~ chicken-core (chicken-5) 364023e4eee865875983224234bc6315cb3bfd3a
commit 364023e4eee865875983224234bc6315cb3bfd3a
Author: Felix <bunny351@gmail.com>
AuthorDate: Sat Oct 10 13:03:48 2009 +0200
Commit: Felix <bunny351@gmail.com>
CommitDate: Sat Oct 10 13:03:48 2009 +0200
imported svn rev. 16155
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 00000000..77661160
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,3 @@
+.svn
+*.o
+*.so
diff --git a/ANNOUNCE b/ANNOUNCE
new file mode 100644
index 00000000..37e2fe23
--- /dev/null
+++ b/ANNOUNCE
@@ -0,0 +1,42 @@
+ANN.: CHICKEN 4.0.0
+
+Version 4.0.0 of CHICKEN, the portable and practical Scheme system has
+been released. In addition to many bugfixes and cleaning up, it provides
+the following significant changes:
+
+- The macro system has been completely rewritten and is now fully
+ hygienic with highlevel R5RS "syntax-rules" macros and low level
+ "explicit renaming" macros that allow full control over hygienie;
+ "define-macro" is not available anymore
+
+- A module system has been implemented that fully supports hygienic
+ macros and still integrates with separate and cross compilation
+
+- The PCRE-based regular regex code has been replaced by Alex Shinn's
+ excellent "IrRegex" regular expression package (while still being
+ API compatible to the old regular expression subsystem)
+
+- New implementations of the tools for download, build and install
+ extension libraries, which are easier to use and provide more
+ flexibility than the old `chicken-setup'
+
+- A new optimization mode "local" enables inlining of definitions
+ that are still visible from other compilation units
+
+- Better support for build and use on Windows (mingw and msys)
+
+- Experimental support for cross-module inlining
+
+CHICKEN 4.0.0 can be downloaded from:
+
+ http://www.call-with-current-continuation.org/chicken-4.0.0.tar.gz
+
+CHICKEN-related mailing lists can be found here:
+
+ http://mail.nongnu.org/mailman/listinfo/chicken-users
+ http://mail.nongnu.org/mailman/listinfo/chicken-hackers
+
+Send bug reports to to <chicken-janitors@nongnu.org> or use the
+`chicken-bug' program.
+
+Many thanks to all who helped improve and extend the system.
diff --git a/ChangeLog.20040412 b/ChangeLog.20040412
new file mode 100644
index 00000000..1d96591e
--- /dev/null
+++ b/ChangeLog.20040412
@@ -0,0 +1,2331 @@
+2004-11-29 flw <flw@gurke>
+
+ * README, build.scm, chicken-setup.1, chicken-setup.scm, chicken.texi, configure.in, eval.scm, parameters.scm, wwchicken:
+ some bugfixes
+
+ - eval: ##sys#do-the-right-thing tested feature at compile time, which didn"t of course apply to the run-time
+ of compiled programs
+ - chicken-setup: added `-no-install" option
+
+2004-11-29 iamphet <iamphet@gurke>
+
+ * csc.scm.in: mingw32: output .dll rather than .so
+
+2004-11-24 flw <flw@gurke>
+
+ * README: *** empty log message ***
+
+2004-11-24 iamphet <iamphet@gurke>
+
+ * eval.scm, parameters.scm: - mingw32: fixed dll names to search
+
+2004-11-22 flw <flw@gurke>
+
+ * csc.scm.in, eval.scm, hen.el, library.scm, makefile.vc, posixwin.scm, runtime.c, TODO, chicken.h, chicken.texi:
+ Bugfixes, Sergey"s dlll-runtime changes
+
+ - eval: warning for declarations in interpreted code passed wrong argument to `error"
+ - hen.el: added changes contributed by Micky Latowicki
+ - library: `c-runtime" returns information about linked C runtime library; MSVC build supports linking with
+ dynamic runtime libs [Thanks to Sergey Khorev]
+ ***DARCS***
+
+ Write the long patch description into this file.
+ The first line of this file will be the patch name.
+ Everything in this file from the above ***DARCS*** line on will be ignored.
+
+ This patch contains the following changes:
+
+ M ./chicken.h +1
+ M ./chicken.texi -2 +12
+ M ./csc.scm.in -1 +1
+ M ./eval.scm -1 +1
+ M ./hen.el -551 +410
+ M ./library.scm +4
+ M ./makefile.vc +3
+ M ./posixwin.scm -2
+ M ./runtime.c -2 +60
+
+2004-11-17 flw <flw@gurke>
+
+ * TODO, build.scm, chicken.texi, configure.in, srfi-13.scm, wwchicken, Makefile.am, README:
+ - Fixed bug in handling of `pretty-print-width" [Thanks to Lars Rustemeier]
+ - Makefile.am: added `csc.scm" to CLEAN_FILES [Thanks to Sven Hartrumpf]
+ - srfi-13: fixed handling of string-parse-start+end return values [Thanks to Alex Shinn]
+
+2004-11-12 flw <flw@gurke>
+
+ * HACKING, README, build.scm, chicken.texi, compiler.scm, configure.in, csi.scm, easyffi.scm, eval.scm, examples/eval-client.c, examples/eval-server.scm, examples/makefile.vc, extras.scm, library.scm, parameters.scm, srfi-18.scm, syntax-case.scm, vcbuild.bat, wwchicken:
+ - srfi-18: added Chris Double"s repl-hack to allow running threads while waiting for user input
+ - fixed several bugs in examples/makefile.vc [Thanks to Psy-Kosh]
+ - easyffi: handles typedef"s for function types
+ - fixed bug in `set-extension-specifier!"
+ - SRFI-55 support
+ - `declare" in interpreted code generates a warning
+ - `use"/`require-extension" also checks `##sys#features" when resolving requirements
+
+2004-11-03 flw <flw@gurke>
+
+ * chicken-setup.scm, chicken.h, chicken.texi, configure.in, runtime.c, wwchicken:
+ - Added externally visible procedures `C_do_[un]register_finalizer()" [as suggested by John Lenz]
+ - fixed typo in chicken-setup [Thanks to Brian Mastenbrook]
+
+ * README, build.scm:
+ - Added externally visible procedure `C_do_register_finalizer()" [as suggested by John Lenz]
+
+2004-11-01 flw <flw@gurke>
+
+ * HACKING, README, build.scm, chicken-setup.scm, chicken.texi, configure.in, csc.1, easyffi.scm, makefile.vc, wwchicken:
+ - easyffi: structure-maker accepts init-arguments
+ - `chicken-setup" is now built on Windows systems with the MSVC compiler (preliminary)
+
+2004-10-18 flw <flw@gurke>
+
+ * benchmarks/shootout/bench, chicken.texi, csc.scm.in, easyffi.l, easyffi.scm, extras.scm, support.scm, wwchicken, HACKING, README, batch-driver.scm, c-platform.scm, chicken-setup.1, chicken-setup.scm, chicken.1, chicken.css, chicken.h:
+ - recovered some lost changes in csc.scm.in
+ - compiler: `-raw" option
+ - utils: `shift!" and `unshift!"
+ - fixed unneeded entries in chicken.css [Thanks to Johannes Groedem]
+ - easyffi: added support for C structures and unions
+ - compiler: if the last top-level form of a file compiled into a shared object returned #f, dynamic loading
+ would fail.
+ - extras: the second argument to `string-intersperse" defaults to " ".
+
+2004-10-11 flw <flw@gurke>
+
+ * Makefile.am, README, TODO, banner.scm, build.scm, chicken.h, chicken.texi, configure.in, csc.scm.in, csi.scm, easyffi.l, easyffi.scm, library.scm, tinyclos.scm:
+ - tinyclos: there was no default initialize method for subclasses of <primitive> [Thanks to Johannes Groedem]
+ - csc: ".h" and ".hpp" files are processed as Scheme compiled with -ffi; Lars Nilsson pointed out a bug in the
+ handling of "-l..." on Windows
+ - easyffi: ___in/___out/___inout qualifiers
+ - library: `#\xXX" and `#\uXXXX" syntax
+ - Makefile.am: README.CVS and chicken.pdf are not installed
+
+2004-09-29 flw <flw@gurke>
+
+ * Makefile.am, README, TODO, build.scm, chicken-setup.1, chicken-setup.scm, chicken.h, chicken.texi, compiler.scm, configure.in, easyffi.scm, eval.scm, match-support.scm, runtime.c, tweaks.scm:
+ - added `C_post_gc_hook"
+ - manual: clarified blocking behaviour of I/O from ports returned by `process" [Thanks to Tim Reid]
+ - extended range of character codes from 16 to 21 bit
+ - declarations are also registered in files loaded at compile-time
+ - chicken-setup: added `-dont-ask" option
+
+2004-09-23 flw <flw@gurke>
+
+ * Makefile.am, README, TODO, chicken-setup.scm, chicken.h, chicken.texi, configure.in, extras.scm, psyntax.scm, syntax-case.scm, tinyclos.scm, wwchicken:
+ - configure.in: -DHAVE_ALLOCA_H will be added to CFLAGS on non-gcc platforms, if needed [Thanks to Mark Baily]
+ - chicken-setup: simple installs (with only a .scm file and no .setup file) keep the .so in the current directory
+ - added internal support for annotations in psyntax
+ - added some examples for `string-split-fields" [Thanks to Christian Pohlmann]
+ - The Makefile handles now the situation when the system is build in a different directory than the current one
+ [Thanks to Daniel Goertzen]
+ - tinyclos: added default initializer for <c++-object> [Thanks to Sergey Khorev]
+ - extras: `pretty-print" handles pointer objects
+
+2004-09-20 flw <flw@gurke>
+
+ * README, TODO, batch-driver.scm, benchmarks/shootout/bench, benchmarks/shootout/heapsort.chicken, benchmarks/shootout/matrix.chicken, benchmarks/shootout/meroon.scm, benchmarks/shootout/meroon/Basics.scm, benchmarks/shootout/meroon/Coercers.scm, benchmarks/shootout/meroon/access.scm, benchmarks/shootout/meroon/alloc.scm, benchmarks/shootout/meroon/anomaly.scm, benchmarks/shootout/meroon/careless.scm, benchmarks/shootout/meroon/clone.scm, benchmarks/shootout/meroon/clostest.scm, benchmarks/shootout/meroon/coinst.scm, benchmarks/shootout/meroon/definers.scm, benchmarks/shootout/meroon/dispatch.scm, benchmarks/shootout/meroon/egal.scm, benchmarks/shootout/meroon/fill.scm, benchmarks/shootout/meroon/genes1.scm, benchmarks/shootout/meroon/genes2.scm, benchmarks/shootout/meroon/handy.scm, benchmarks/shootout/meroon/instance.chicken, benchmarks/shootout/meroon/libgen.scm, benchmarks/shootout/meroon/macinst.chicken, benchmarks/shootout/meroon/macros.scm, benchmarks/shootout/meroon/makefile, benchmarks/shootout/meroon/maker.scm, benchmarks/shootout/meroon/meroon-syntax.scm, benchmarks/shootout/meroon/meroon.chicken, benchmarks/shootout/meroon/modify.scm, benchmarks/shootout/meroon/multi.scm, benchmarks/shootout/meroon/option.scm, benchmarks/shootout/meroon/revision.scm, benchmarks/shootout/meroon/runtime.scm, benchmarks/shootout/meroon/show.scm, benchmarks/shootout/meroon/size.scm, benchmarks/shootout/meroon/trace.scm, benchmarks/shootout/meroon/unveil.scm, benchmarks/shootout/meroon/utils.scm, benchmarks/shootout/meroon/walker.scm, benchmarks/shootout/methcall.chicken, benchmarks/shootout/nestedloop.chicken, benchmarks/shootout/objinst.chicken, benchmarks/shootout/prodcons.chicken, benchmarks/shootout/ringmsg.chicken, benchmarks/shootout/sumcol.chicken, build.scm, chicken.h, chicken.texi, configure.in, posix.scm, posixwin.scm, wwchicken:
+ - dynamic-and-unsafe marker was incorrectly generated for non-dynamic files
+ - added Sergey Khorev"s additions to posixwin.scm (system-information, get-host-name, sleep, process, process-wait)
+ - posix: added `set-root-directory!"
+ - shootout: fixed heapsort, objinst and methcall use meroon, now
+
+2004-09-15 flw <flw@gurke>
+
+ * benchmarks/shootout/bench, benchmarks/shootout/hash.chicken, benchmarks/shootout/wordfreq.chicken, mingw/INSTALL, mingw/Makefile.in, mingw/autogen.sh, mingw/configure.sh, mingw/installdllv.sh, mingw/mingw-cc.sh, mingw/mingw-cxx.sh, wwchicken:
+ removed ming directory and posixstub.scm
+
+2004-09-13 flw <flw@gurke>
+
+ * benchmarks/shootout/README, benchmarks/shootout/ackermann.chicken, benchmarks/shootout/ary.chicken, benchmarks/shootout/bench, benchmarks/shootout/echo.chicken, benchmarks/shootout/except.chicken, benchmarks/shootout/fibo.chicken, benchmarks/shootout/hash.chicken, benchmarks/shootout/hash2.chicken, benchmarks/shootout/heapsort.chicken, benchmarks/shootout/hello.chicken, benchmarks/shootout/lists.chicken, benchmarks/shootout/lists1.chicken, benchmarks/shootout/matrix.chicken, benchmarks/shootout/methcall.chicken, benchmarks/shootout/moments.chicken, benchmarks/shootout/nestedloop.chicken, benchmarks/shootout/objinst.chicken, benchmarks/shootout/prodcons.chicken, benchmarks/shootout/random.chicken, benchmarks/shootout/regexmatch.chicken, benchmarks/shootout/reversefile.chicken, benchmarks/shootout/sieve.chicken, benchmarks/shootout/spellcheck.chicken, benchmarks/shootout/strcat.chicken, benchmarks/shootout/sumcol.chicken, benchmarks/shootout/wc.chicken, benchmarks/shootout/wordfreq.chicken, compiler.scm, configure.in, csi.scm, eval.scm, makefile.vc, posix.scm, posixwin.scm, runtime.c, srfi-18.scm, syntax-case.scm, wwchicken, Makefile.am, README, TODO, banner.scm, build.scm, c-backend.scm, chicken-config.in, chicken-setup.scm, chicken.h, chicken.texi:
+ - eval.scm: `load" sets `##sys#current-load-file" to loaded filename for duration of load (needed for line-info in debug egg)
+ - chicken.h, runtime.c: Eric Raible did some much needed cleaning up [Thanks!]
+ - chicken-setup: added `-csc-option"; errors in scripts were not reported
+ - chicken-config: resurrected `-extra-libs", because the current version of SWIG needs it
+ - wwchicken: removed coloring of egg-entries (didn"t work properly anyway)
+ - runtime.c: FAKE_APPLY (inline-asm hack to simulate `apply") has been disabled - apparently gcc 3.3.3 generates funnny code
+ with -Os
+ - compiler, csc: added `post-process" declaration
+ - posix: added `memory-mapped-file?"
+ - added posixwin.scm [Thanks to Sergey Khorev!]
+ - csi: ,ln pprints currently evaluated expression
+ - eval.scm: `load-noisily" takes couple of keyword arguments
+ - chicken-setup: allows aborting a sequence of installs
+ - srfi-18: `thread-start!" accepts a thunk as argument
+ - syntax-case: `debug-expand" accepts "p" which means: pprint and expand continuously
+
+2004-09-10 njbeckford <njbeckford@gurke>
+
+ * README, configure.in:
+ Support shared libraries on MinGW by dropping -lm linker flag.
+ Got rid of creation of mingw/Makefile from mingw/Makefile.in
+
+2004-09-09 njbeckford <njbeckford@gurke>
+
+ * Makefile.am, configure.in:
+ Use posixstub.scm instead of posix.scm for Mingw
+ Got rid of support for mingw/ directory
+ Do nothing in posixstub.scm
+
+2004-08-30 flw <flw@gurke>
+
+ * FAQ.html, README, TODO, batch-driver.scm, build.scm, c-platform.scm, chicken-match-macros.scm, chicken.h, chicken.spec.in, chicken.texi, compiler.scm, configure.in, csi.scm, easyffi.scm, extras.scm, hen.el, library.scm, lolevel.scm, match-support.scm, psyntax-bootstrap.scm, psyntax.scm, runtime.c, scheduler.scm, support.scm, syntax-case.scm, wwchicken:
+ - configure checks for `-export-dynamic" (that was added in the previous CVS release, actually).
+ - syntax-case.scm: added `debug-expand".
+ - csi: prints newline on eof.
+ - easyffi: the prefix pseudo-declaration does not apply to class names; switching the prefix off didn"t work;
+ brackets following an identifier are allowed when types are parsed.
+ - library/optimizer/c-platform: `fp+", and further flonum operations.
+ - c-platform: `eqv?" should work with flonums in fixnum mode.
+ - this is release version 1.66 -------------------------------------------------------------------
+ - runtime.c: flonum-specific numops (`fp+", ...) check their argument type in safe mode.
+ - Default compiler options for icc and gcc use -Os instead of -O3.
+ - syntax-case.scm: uses internal syntax-error procedure.
+ - library.scm: got internal versions of `block-(ref|set!)"
+ - match: handles native and SRFI-9 records, `define-structure" and friends are gone.
+ - csi/match-support: "match-support" feature is properly registered and will not be loaded twice when `match"
+ is required in hygienic mode.
+ - New declaration-specifiers `c-options" and `link-options".
+ - `atom?" is now an optimized extended binding.
+ - batch-driver.scm: fixed bug in invocation of `user-pass-2".
+ - rewriting rule for `##sys#setslot" didn"t check argument count.
+ - runtime.c: `string->number" and `number->string" reported wrong required number of arguments [Thanks to
+ Alejandro Forero Cuervo]
+ - weak symbol hash-table should be slightly better distributed
+ - csc: accepts `-L<dir>" and handles invalid options more gracefully
+ - Runtime-option `-:x" signals uncaught thread-exceptions in primordial thread (is this the right way to
+ handle it?)
+
+2004-08-18 flw <flw@gurke>
+
+ * syntax-case.scm, wwchicken, README, TODO, batch-driver.scm, build.scm, c-platform.scm, chicken-ffi-macros.scm, chicken.1, chicken.texi, compiler.scm, configure.in, easyffi.l, easyffi.scm, hen.el, posix.scm, psyntax.scm, support.scm:
+ - Added new macros `foreign-parse[/spec]" and read syntaxes `#>$ ... <#" and `#>% ... <#" which allow
+ access to the FFI parser [Suggested by Daniel B. Faken]
+ - The tinyclos unit is not anymore used automatically in parsed C++ code
+ - added `-ffi-custom" option.
+ - easyffi: handles prerprocessor macros nort starting at the first position of a line.
+ - posix.scm: added `file-[access|change]-time" and `file-stat" [Suggested by Peter Bex].
+ - utils.scm: `make-pathname" didn"t remove the leading "/" from the file component, if not needed.
+ - Fixed bug in the generation of an error-messages if non-matching argument-lists of inlined/customized calls
+ had a rest parameter.
+
+2004-08-12 flw <flw@gurke>
+
+ * README, TODO, batch-driver.scm, build.scm, c-backend.scm, c-platform.scm, chicken-entry-points.scm, chicken-highlevel-macros.scm, chicken-more-macros.scm, chicken-setup.scm, chicken.h, chicken.texi, configure.in, csi.scm, easyffi.l, easyffi.scm, eval.scm, extras.scm, library.scm, lolevel.scm, makefile.dj, makefile.vc, pcre.scm, posix.scm, pregexp.scm, psyntax.scm, regex.scm, runtime.c, support.scm, tcp.scm, wwchicken:
+ - tcp.scm: added missing #define EINPROGRESS for Windows
+ - makefile.vc: still had some occurrences of "graph", where "partition" was needed
+ - csc.scm: fixed bug in handling of "-l..." on Windows
+ - wwchicken: `stream-cgi" is now in web category, `rgraph" needs `srfi-40"
+ - extras.scm: `noop", `atom?"
+ - eval.scm: error messages with a single void argument in addition to the message where
+ printed without the argument; `repl-prompt" holds now a procedure instead of a string
+ - chicken-setup.scm: errors during loading of a setup-script did not output anything
+ - library.scm: added `test-feature?"
+ - easyffi: parser accepts `#" everywhere now; illegal characters are shown in error message;
+ user-defined types are heeded when computing classes with full specialization
+ - "curried" `define" syntax ("(define ((foo x) y) ...)") is supported
+ - `include" preserves line-number counter of reader
+ - regex: `grep" uses `string-search" instead of `string-match" [Thanks to Alejandro Cuervo]
+ - posix: `set-group-id!", `create-session", `process-group-id" and `set-process-group-id!" [suggested by Peter Bex]
+ - lolevel: `pointer=?"
+ - new foreign types `symbol" and `number" [The latter was inspired by Daniel B. Faken]
+ - csi: changed prompt and added `#INDEX"/`#" read syntax for easier handling of the REPL history
+ - eval.scm: reading in a repl swallows any #\newline directly following the input [suggested by Taylor Campbell]
+ - chicken-more-macros.scm: `case-lambda" depends on srfi-1 at expansion time (so it"s loaded)
+ [thanks to Michele Simionato]
+ - changed the prefix for certain "easy" FFI macros from "__" to "___" to avoid collisions with identifiers
+ in C standard headers
+
+2004-08-05 njbeckford <njbeckford@gurke>
+
+ * chicken-setup.scm:
+ Fixed bug for "chicken-setup xxx.egg". Previously it would unpack the
+ egg and then go into a recursive loop. Now it unpacks the egg and
+ runs the embedded setup script.
+
+2004-08-02 flw <flw@gurke>
+
+ * TODO, c-backend.scm, chicken-entry-points.scm, chicken.texi, compiler.scm, easyffi.scm, eval.scm, extras.scm, support.scm, wwchicken:
+ - fixed instance-ref"s in FFI [Thanks to Petter Egesund]
+ - extras: `rassoc"; fixed buf in `alist-ref"
+ - wwchicken: added some links; categorized eggs
+ - eval: `set-extension-specifier!"
+
+2004-08-01 sven1999 <sven1999@gurke>
+
+ * chicken-setup.scm: fixed typo: cmod should be chmod
+
+2004-07-29 sven1999 <sven1999@gurke>
+
+ * library.scm: added unsafe variants for list->string and list->vector
+
+2004-07-28 flw <flw@gurke>
+
+ * compiler.scm, configure.in, csi.1, extras.scm, hen.el, lolevel.scm, optimizer.scm, parameters.scm, posix.scm, support.scm, wwchicken, README, TODO, batch-driver.scm, build.scm, c-platform.scm, chicken-highlevel-macros.scm, chicken-more-macros.scm, chicken-setup.scm, chicken.texi:
+ - extras: `alist-ref"
+ - compiler: `define-optimizer" (but keep it undocumented)
+ - batch-driver.scm: fixed a bug related to using `user-pass-2"
+ - lolevel: added `record->vector"
+ - posix.scm: added `get-groups", `set-groups!" and `initialize-groups" [Suggested by Peter Bex]
+
+2004-07-20 sven1999 <sven1999@gurke>
+
+ * chicken.texi:
+ removed @code from 1 @node line (causes crash on second run of tex), increased build number from 43 to 62
+
+2004-07-19 flw <flw@gurke>
+
+ * examples/makefile, srfi-4.scm, support.scm, syntax-case.scm, tcp.scm, tweaks.scm, wwchicken, format.scm, library.scm, lolevel.scm, optimizer.scm, parameters.scm, partition.scm, pcre.scm, posix.scm, profiler.scm, psyntax-bootstrap.scm, regex.scm, runtime.c, scheduler.scm, srfi-13.scm, srfi-18.scm, srfi-25.scm, compiler.scm, configure.in, csi.scm, easyffi.l, easyffi.scm, eval.scm, extras.scm, README, TODO, banner.scm, batch-driver.scm, build.scm, c-backend.scm, c-platform.scm, chicken-default-entry-points.scm, chicken-entry-points.scm, chicken-ffi-macros.scm, chicken-highlevel-macros.scm, chicken-more-macros.scm, chicken-profile.scm, chicken-setup.1, chicken-setup.scm, chicken.h, chicken.scm, chicken.texi:
+ - easyffi: fixed error in parse-error message for unbalanced parens
+ - eval: `set-read-syntax!"
+ - extras: `read-token"
+ - some output routines use faster version of `write-char"
+ - compiler: `export" declaration is able to export toplevel variables from psyntax modules
+ - chicken-setup: some diagnostic output is suppressed in non-verbose mode
+ - wwchicken: fixed a bug related to creating proper timestamps for eggs
+ - c-backend.scm: unsafe marker wasn"t generated when no partitioning was selected
+ - eval.scm: `load" and include-path resolving ignores directory names
+ - visiting files (either explicitly or via `import") does load syntax-extensions, if needed
+ - when special core include files (like `chicken-more-macros.scm") are accessed via `use" or
+ `require-extension", then care is taken to load them only once
+ - easyffi.l: end of input resets pp-mode
+ - `print-error-message" didn"t show location (if provided)
+ - Chicken should now work on amd64 platforms [Thanks to Thomas Weidner and Tollef Fog Heen]
+ - `machine-type": returns "x86-64 on amd64 platforms
+ - chicken-setup: unpacks eggs into a temporary directory; host without port didn"t work; addded
+ `-keep" option
+ - changed snail-mail address in source file headers
+ - easyffi.l: uses `reverse-list->string"
+ - srfi-13: `string-contains-ci" wasn"t implemented; `string-contains[-ci]" had off-by-one error
+ [Thanks to Peter Wang]
+ - tcp.scm: error messages give location (mostly)
+ - tcp.scm: `tcp-connect" doesn"t block other threads [Thanks to Peter Wang]
+
+2004-07-15 njbeckford <njbeckford@gurke>
+
+ * partition.scm: Changed copyright over to Felix.
+
+2004-07-07 flw <flw@gurke>
+
+ * csi.scm, partition.scm, posix.scm, support.scm, wwchicken, build.scm, c-platform.scm, chicken.1, chicken.h, chicken.scm, chicken.texi, compiler.scm, configure.in, csc.scm.in, README, TODO, batch-driver.scm:
+ - chicken.h: added missing macro definition for `__discard"
+ - posix: stat routines did not expand tilde
+ - wwchicken: updates egg dates and colors table entries
+ - csi.scm: report was wrong [Thanks to Benedikt Rosenau]
+ - added `-split-level" compiler option [As suggested by Jonah Beckford]
+ - slightly better error checking for compiler options
+ - when processing foreign-declarations in SWIG mode, C syntax checks are disabled
+
+2004-07-06 njbeckford <njbeckford@gurke>
+
+ * partition.scm: Imported some lambdas to make work in compiled mode.
+
+ * partition.scm: Got rid of most unused methods.
+
+ * partition.scm: Changed unit name to 'partition instead of 'graph.
+
+ * partition.scm, compiler.scm, chicken.texi, chicken.scm, Makefile.am:
+ Changed graph.scm to partition.scm.
+ Fixed bug in partition.scm related to not recalculating all relevant
+ neighbours.
+ Added -debug P, -debug Q and -debug R for the partitioning stuff.
+
+2004-07-06 flw <flw@gurke>
+
+ * examples/makefile, testsuites/makefile.in, benchmarks/cscbench, optimizer.scm, parameters.scm, posix.scm, runtime.c, support.scm, wwchicken, hen.el, library.scm, makefile.dj, makefile.vc, compiler.scm, configure.in, csc.scm.in, csi.scm, easyffi.l, easyffi.scm, eval.scm, extras.scm, README, TODO, batch-driver.scm, build.scm, c-backend.scm, c-platform.scm, chicken-ffi-macros.scm, chicken-highlevel-macros.scm, chicken-more-macros.scm, chicken-setup.1, chicken-setup.scm, chicken.1, chicken.scm, chicken.texi, FAQ.html, Makefile.am:
+ - `define-record-type" expanded into code that didn"t allow subsequent exported definitions
+ in psyntax module forms [Thanks to Grzegorz Chrupala]
+ - removed some leftover occurrences of `-extra-libs" [Thanks to Sven Hartrumpf]
+ - `define-method" expands into a non-definition, which works better with the psyntax module system
+ [Thanks to Grzegorz Chrupala again]
+ - ",r" command in csi was broken
+ - library: added `memory-statistics"
+ - call/cc called with a known lambda is optimized away in case the continuation-variable is never used
+ - csi: uses `memory-statistics"
+ - fixed some errors in the manual [Thanks to Peter Barabas and Benedikt Rosenau]
+ - Jonah Beckford contributed a partitioning algorithm to the compiler that allows splitting a Scheme
+ file into multiple C files - very cool but still experimental
+ - extras: `conc"
+ - renamed unit `script-utils" to `utils"
+ - csc: handles `-split" properly
+ - compiler prefixes identifiers when generating split files
+ - easyffi: Added `__discard" marker
+
+2004-06-19 flw <flw@gurke>
+
+ * examples/README, examples/makefile, optimizer.scm, psyntax.scm, wwchicken, eval.scm, library.scm, batch-driver.scm, c-platform.scm, chicken-ffi-macros.scm, chicken-highlevel-macros.scm, chicken-more-macros.scm, chicken-setup.1, chicken-setup.scm, chicken.css, chicken.h, chicken.texi, FAQ.html, Makefile.am, README, TODO:
+ - some library files were still not up-to-date with respect to the changed declaration syntax for internal
+ procedures (like FFI stubs or trampolines). This caused gcc 3.4 to choke on tcp (and possibly other files
+ that hadn"t been re-translated for longer) [Thanks to Pierre]
+ - eval.scm: `syntax-error"
+ - the SRFI-22 driver programs (trampolines) have been removed
+ - Makefile.am: added dependency for library.c (build.scm)
+ - chicken-setup: options `-fetch" and `-install-as-root"
+ - `open-output-file": append-mode was completely broken
+ - added css stylesheet for HTML version of manual [Thanks to Johannes Groedem]
+ - added case for amd64 to chicken.h (doesn"t yet run, though) [Thanks to thomas001]
+ - `define-foreign-[type|variable]" didn"t check first argument for being a symbol [thanks to Eric Meritt]
+ - added `use" as an alias for `require-extension"
+ - `command-line-arguments" filters out runtime options (anything starting with "-:")
+ - added another optimizer rule; `thread-specific[-set!]" is inlined in unsafe mode
+ - `print[*]" returns 1st argument
+
+2004-06-13 njbeckford <njbeckford@gurke>
+
+ * hen.el:
+ Fixed: char table range must be t, charset, char or vector ... using solution at http://list-archive.xemacs.org/xemacs-beta/200310/msg00407.html
+
+2004-06-09 flw <flw@gurke>
+
+ * wwchicken, support.scm, srfi-13.scm, parameters.scm, library.scm, hen.el, eval.scm, csi.scm, chicken.texi, chicken-more-macros.scm, chicken-config.in, chicken-highlevel-macros.scm, c-platform.scm, batch-driver.scm, README, Makefile.am:
+ - removed all support for SRFI-7
+ - the implementation of SRFI-9 is now much faster (equivalent to `define-record")
+ - fixed srfi-13"s `string-contains[-ci]"
+ - wwchicken generates egg-list and index-page automatically
+
+2004-06-07 flw <flw@gurke>
+
+ * examples/mmcp.scm, examples/makefile, benchmarks/cscbench, wwchicken, syntax-case.scm, posix.scm, makefile.vc, makefile.dj, hen.el, csi.scm, csc.scm.in, compiler.scm, configure.in, chicken.texi, chicken-setup.scm, chicken-profile.scm, chicken-config.in, c-platform.scm, build.scm, batch-driver.scm, README, TODO, Makefile.am, FAQ.html:
+ - posix.scm: patched `file-mkstemp" [Thanks to Johannes Groedem]
+ - rcsi has been dumped
+ - csi now only uses the library, eval and extras units
+ - `extras" has been added to the list of units used by default in compiled code (this means csi
+ and compiled code have basically access to the same set of definitions)
+ - csc always links safe libs, providing `-unsafe-libraries" always links with unsafe ones (independent
+ of any other setting) [Thanks to Sven Hartrumpf]
+ - chicken-config: removed `-extra-libs" option (`-libs" adds all libraries now)
+ - chicken-setup: attempts to handle the "dll" extension transparently in `make" forms [Thanks to T. Kurt Bond]
+ - `undefine-macro!" and `macro?" work now with highlevel macros
+
+2004-05-30 flw <flw@gurke>
+
+ * srfi-13.scm, support.scm, runtime.c, posix.scm, library.scm, format.scm, extras.scm, csc.scm.in, chicken.1, chicken.texi, compiler.scm, c-backend.scm, c-platform.scm, chicken-highlevel-macros.scm, chicken-more-macros.scm, TODO, batch-driver.scm:
+ - The emitting of the symbol for detecting safe/unsafe library mismatches didn"t work properly [Thanks to Peter Barabas]
+ - posix.scm: `user-information" returns now either a list or #f
+ - `include" accepts any number of arguments [Suggested by Taylor Campbell]
+ - library: added `reverse-list->string" (and removed it from srfi-13) and added some minor optimizations
+ to `[##sys#]substring" [Thanks to Sven Hartrumpf]
+ - posix: added `file-mkstemp" [Contributed by Johannes Groedem]
+ - format, library: uses `reverse-list->string"
+ - library: `read" is now faster [Thanks to Alain Mellon and Clifford Stein]
+ - chicken.texi: fixed some problems with "<" / ">" in HTML output [Thanks to Peter Barabas]
+
+2004-05-27 catfive <catfive@gurke>
+
+ * wwchicken:
+ - fixed wwchicken manual links for compiler and interpreter command-line format
+
+2004-05-26 flw <flw@gurke>
+
+ * support.scm, wwchicken, runtime.c, posix.scm, lolevel.scm, makefile.vc, optimizer.scm, hen.el, library.scm, easyffi.scm, eval.scm, csc.scm.in, configure.in, c-platform.scm, chicken-setup.scm, chicken.h, chicken.texi, compiler.scm, README, TODO, build.scm:
+ - makefile.vc: csc.scm.in is copied into csc.scm (or csc.scm wouldn"t be found)
+ - eval.scm: `set!" allows assignments to keywords [Thanks to Mikael]
+ - support.scm, optimizer.scm: inlined lambdas with empty rest list generated invalid code [Thanks Daniel B. Faken]
+ - chicken-setup: doesn"t assume ".so" anymore for compiled extensions, `install-extension" silently
+ handles ".so" extension on Windows [Thanks to T. Kurt Bond]
+ - library.scm: the third argument to `substring" is now optional
+ - csc.scm.in: `-l..." is passed to linker
+ - csc: .i files are passed to swig and passed on to chicken or the C compiler; -swig passes options to SWIG directly
+ - hen.el: added a few kewords for highlighting
+ - runtime.c: removed C_alloc_in_heap, since the continuation can not be saved and will be invalid if GC should occur
+ - compiler: rewriting rules for `string-append" and `substring" in unsafe mode; removed some unneeded variable
+ initialisations from compiler.scm
+ - added `custom-declare" declaration and processing of `.csc" files to compiler/csc for doing weird post-compilation
+ stuff...
+ - easyffi: `typedef ... *ID" is allowed
+ - posix: `user-information" returns 7 * #f, if the user can"t be found [Thanks to Peter Wang]
+
+2004-05-20 flw <flw@gurke>
+
+ * eval.scm, configure.in, build.scm, chicken-config.in, chicken.texi, README, TODO, Makefile.am:
+ - eval.scm: usage of the CHICKEN_REPOSITORY variable for setting the repository-directory was broken
+ [Thanks to Peter Wang]
+ - removed csc.scm from distro-tarball [Thanks to Daniel B. Faken]
+ - chicken-config used `-Wl,-R" on Mac OS X, which is wrong [Thanks to Houman Zolfaghari]
+ - eval.scm: `require" didn"t check current directory [Thanks to Alain Mellan]
+
+2004-05-19 flw <flw@gurke>
+
+ * wwchicken, README, chicken-default-entry-points.scm, chicken-setup.scm, chicken.h, chicken.texi, compiler.scm, csi.scm, extras.scm, hen.el, runtime.c:
+ - chicken-setup: `-program-path" does not influence path to chicken tools
+ - runtime.c: added `CHICKEN_is_running()"
+ - extras.scm: fixed bug in `write-string" [Thanks to Alejandro Forero Cuervo]
+ - csi.scm: fixed wrong implementation of `##csi#symbols-matching" [Thanks to Linh Dang]
+ - chicken-default-entry-points.scm: entry-point counter was not adjusted [Thanks to Daniel B. Faken]
+
+2004-05-15 flw <flw@gurke>
+
+ * tinyclos.scm, wwchicken, pregexp.scm, runtime.c, makefile.vc, parameters.scm, extras.scm, hen.el, library.scm, csc.scm.in, easyffi.scm, eval.scm, compiler.scm, configure.in, chicken.h, chicken.texi, Makefile.am, README, build.scm, chicken-setup.scm:
+ - removed `extension-path", exposed `extension-info"
+ - chicken-setup stores full pathname in info file
+ - renamed `chicken-format-profile" to `chicken-profile"
+ - `import" also searches repository-path
+ - chicken-setup: file-extraction from downloaded files was broken (and several other things)
+ - warnings flush output
+ - added CHICKEN_global_... API
+ - compiler: `require-extension" warns if extension is not currently installed
+ - chicken-setup: automatically adds full path when `run"ning installed chicken programs;
+ verbose mode adds `-v" to csc invocations
+ - fixed two bugs in pregexp.scm [Thanks to Shmul]
+ - easyffi.scm: added `destructor_name" and `exception_handler" pseudo declarations
+ - tinyclos.scm: result-handling of type `(instance ...)" was broken for returned NULL pointers
+ - fixed a few bugs in the Windows build
+
+2004-05-10 flw <flw@gurke>
+
+ * wwchicken, syntax-case.scm, makefile.vc, eval.scm, configure.in, chicken-setup.1, chicken-setup.scm, chicken.texi, chicken-profile.scm, chicken-profile.1, batch-driver.scm, build.scm, README, Makefile.am, FAQ.html:
+ - removed `extension-path`, exposed `extension-info
+
+2004-05-09 flw <flw@gurke>
+
+ * parameters.scm, wwchicken, lolevel.scm, makefile.vc, hen.el, eval.scm, csc.scm.in, configure.in, csc.1, chicken.texi, chicken-setup.scm, chicken-setup.1, build.scm, README, Makefile.am:
+ - csc and chicken-format-profile are now executables
+ - added manpage for chicken-format-profile
+ - completely overhauled extension loading mechanism
+ - chicken-setup has been completely rewritten
+ - lolevel.scm: fixed bug in `pointer-f32/64-set!` [Thanks to jemhoff at student dot umass dot edu]
+
+2004-05-05 flw <flw@gurke>
+
+ * configure.in, csi.scm, eval.scm, extras.scm, hen.el, parameters.scm, support.scm, build.scm, c-backend.scm, chicken-highlevel-macros.scm, chicken-more-macros.scm, chicken.texi, compiler.scm, Makefile.am, README, TODO, banner.scm, batch-driver.scm:
+ - #!eof is handled properly by the evaluator and compiler as a literal
+ - `read-line' optimization is disabled on Windows [Thanks to lars Rustemeier]
+ - added `require-extension'
+ - info files are not split, which seems to work better [Thanks to Linh Dang]
+
+2004-05-03 flw <flw@gurke>
+
+ * FAQ.html, LICENSE, README, README.CVS, chicken.texi, format.txt, tinyclos-examples.scm:
+ moved files from doc directory into base dir
+
+ * library.scm, psyntax.scm, runtime.c, scheduler.scm, wwchicken, Makefile.am, TODO, c-backend.scm, compiler.scm, eval.scm, extras.scm:
+ - `#!eof' reads as end-of-file object, `#!eof' is also the printed reprsentation
+ - removed `package'
+ - scheduler.scm: uses usleep() on Cygwin [Thanks to Feanor]
+ - now uses texinfo format for documentation [Many thanks to Linh Dang for translating the manual]
+ - moved documentation files into base directory
+ - extras.scm: fixed bug in `disjoin' [Thanks to Peter Wang]
+ - library.scm: reader doesn't read `:' as a keyword
+
+2004-04-30 flw <flw@gurke>
+
+ * wwchicken, syntax-case.scm, runtime.c, library.scm, makefile.vc, match-support.scm, psyntax.scm, eval.scm, extras.scm, TODO, compiler.scm, csi.scm:
+ - match-errors raise (exn match)
+ - syntax errors raise (mostly) (exn syntax)
+ - csi: added hooks for emacs interface [as suggested by Linh Dang]
+ - library: hid namespace/import stuff again
+ - fixed a bug in the manual (foreign-value example was wrong) [Thanks to Taylor Campbell]
+
+2004-04-29 flw <flw@gurke>
+
+ * parameters.scm, pcre.scm, psyntax-bootstrap.scm, psyntax.scm, runtime.c, srfi-18.scm, syntax-case.scm, build.scm, c-backend.scm, compiler.scm, configure.in, csc.bat, easyffi.l, eval.scm, extras.scm, format.scm, library.scm:
+ - (declare (foreign-parse ...)) didn't properly macroexpand parsed code [Thanks to Matthias Heiler]
+ - fixed another bug in the C syntax checker, related to handling `#include <...>'
+ - runtime.c: added missing C_regparm declarations to please gcc 3.4 [Thanks to Sven Hartrumpf]
+ - library.scm: added a low-level 2-argument string-append (`##sys#string-append') for internal use
+ - eval.scm: added `##sys#do-the-right-thing' in preparation for a generic extension requirement form
+ - bumped version to 1.46
+ - syntax-case: changed generation of unique (module) identifiers slightly
+ - script-utils: added `read-all'
+ - extras: `read-file' accepts a filename, now
+
+2004-04-21 flw <flw@gurke>
+
+ * support.scm, configure.in, csi.1, csi.scm, easyffi.l, easyffi.scm, eval.scm, format.scm, library.scm, batch-driver.scm, build.scm, c-backend.scm, chicken.1, compiler.scm:
+ - added missing documentation for `export' declaration [Thanks to Terence Brannon]
+ - fixed easyffi parser bug that caused preprocessor-state not to be cleared [Thanks to Feanor]
+ - removed line-number output in ffi-parser errors (which was incorrect anyway)
+ - keyword processing uses internal version of `get-keyword', and keyword-lookup is a bit faster
+ - changed default keyword-style to suffix
+ - chicken-format-profile.bat was built incorrectly
+ - rcsi still has access to all non-standard syntax
+ - C syntax checker didn't handle preprocessor commands properly in certain situations
+ - csc: only links with unsafe libs in benchmark-mode or with `-unsafe-libraries'
+ - Fixed some typos in the documentation [Thanks to z0d and Kim Liu]
+ - C syntax-checks for `foreign-declare' declarations checked each string separatly (which was wrong)
+ - csc: -shared + -embedded doesn't pass `-dynamic' to chicken (otherwise implicit exit handler isn't called)
+ - `format' prints keywords more consistently [Thanks to Alain Mellan]
+
+2004-04-15 flw <flw@gurke>
+
+ * examples/calendar.scm, c-backend.scm, chicken-setup.1, chicken.h, configure.in, csc.bat, csi.scm, easyffi.l, extras.scm, library.scm, lolevel.scm, makefile.vc, psyntax.scm, runtime.c, scheduler.scm, srfi-18.scm, wwchicken, Makefile.am, TODO, batch-driver.scm, build.scm:
+ - scheduler: added `##sys#thread-unblock!' (and renamed old version to `##sys#thread-basic-unblock!')
+ - extras.scm: added fast path to `read-line' that uses fgets() for FILE* ports
+ - configure.in: -fno-strict-aliasing is now the default for gcc
+ - chicken.h: added missing prototype for C_i_foreign_tagged_pointer_argumentp
+ - Makefile.am: added target for chicken-format-profile
+ - c-backend.scm, runtime.c: loading code dynamically checks now whether the executing runtime and the one linked to the
+ loaded shared object are identical (i.e. have the same safety settings) [Thanks to Category 5 for suggesting a clever solution]
+ - Windows batch files are properly generated (without "#!..." line)
+ - chicken-setup: added `-registry' option
+ - `(define (...) ...)' didn't handle DSSSL keywords correctly with the syntax-case macro system
+ - updated makefile.vc
+ - fixed handling of she-bang line in srfi-7 scripts
+ - fixed bug in FFI C parser [Thanks to Daniel B. Faken]
+
+2004-04-11 flw <flw@gurke>
+
+ * csi.scm, easyffi.scm, eval.scm, library.scm, lolevel.scm, psyntax.scm, runtime.c, support.scm, wwchicken, TODO, batch-driver.scm, build.scm, c-platform.scm, chicken-ffi-macros.scm, chicken.1, chicken.h, compiler.scm, configure.in, csc.1, csc.bat:
+ - easyffi: checks C syntax of foreign-declare, foreign-[callback-]lambda* and foreign-value/foreign-code
+ - option `-disable-c-syntax-checks'
+ - load-verbose is set to #t when `-:d' is given
+ - csi: features #:csi, #:rcsi
+ - some minor internal helper stuff for tagged pointers
+ - chicken-setup: `+[...]options' didn't work correctly
+ - lolevel: `tag-pointer', `tagged-pointer?' and `pointer-tag'
+ - the reader accepts symbols starting with `#%' and `#!', `#! ...' is only treated as commment
+ when used in the interpreter and it appears on the first line
+ - batch-driver: erroneously added `use' declaration for lolevel unit, when compiling she-bang scripts
+ - syntax `(define VAR)' is allowed now
+ - extended lambda lists (DSSSL style)
+ - `get-keyword' is slightly more relaxed
+
+2004-03-31 flw <flw@gurke>
+
+ * wwchicken, chicken-match-macros.scm, syntax-case.scm, chicken-ffi-macros.scm, batch-driver.scm, TODO:
+ - syntax-case macro system loads ffi-macros before compilation
+ - fixed bug in expansion of `define-foreign-type'
+ - removed some dependencies of `match' from chicken-ffi-macro.scm
+ - added missing chicken-match-macros.scm and chicken-ffi-macros.scm to CVS [Thanks to Sven Hartrumpf]
+
+2004-03-29 flw <flw@gurke>
+
+ * TODO, build.scm, chicken-default-entry-points.scm, chicken-entry-points.scm, chicken-highlevel-macros.scm, chicken-more-macros.scm, chicken.scm, configure.in, csc.bat, csi.scm, easyffi.scm, examples/calendar.scm, examples/ctclsh.scm, extras.scm, lolevel.scm, syntax-case.scm, tinyclos.scm, wwchicken, Makefile.am:
+ - easyffi: `const' variables are now always accessed by name and are always exported as a normal variable
+ - csc: didn't pass `-static' to the linker, when compiling a static executable
+ - tinyclos.scm: ##tinyclos#compute-std-cpl is now exported to allow fiddling with the MRO
+ - removed URL stuff again
+ - moved FFI macros into separate include file (`chicken-ffi-macros.scm')
+ - renamed all macro definition files by adding `chicken-' prefix (match.scm, entry-points.scm, default-entry-points.scm,
+ highlevel-macros.scm and moremacros.scm)
+ - added `define-foreign-record'
+ - bumped version to 1.42
+ - extras: string-chop
+ - renamed formatprofile to chicken-format-profile
+
+2004-03-26 catfive <catfive@gurke>
+
+ * wwchicken:
+ small changes to feature list order and manual unit display
+
+2004-03-22 flw <flw@gurke>
+
+ * configure.in, csc.bat, csi.scm, easyffi.l, easyffi.scm, eval.scm, formatprofile.bat, library.scm, lolevel.scm, makefile.vc, posix.scm, psyntax.scm, runtime.c, support.scm, tcp.scm, wwchicken, Makefile.am, TODO, batch-driver.scm, build.scm, c-backend.scm, chicken-config.in, chicken.h:
+ - csc: added `-W' as an alias for `-windows'
+ - added foreign type specifiers `byte' and `unsigned-byte'
+ - fixed bug in `string>=?' and `string<=?' [Thanks to Sven Hartrumpf]
+ - `require' of a used library unit printed load message even when already loaded
+ - formatprofile.bat will be properly built now
+ - argument-count error-messages print somewhat nicer (slightly)
+ - `tcp-listen' accepts optional argument to restrict receiving IP address
+ - added "tag" specifications to `#> ... <#' syntax
+ - added `#>: ... <#'
+ - script-utils: added URL parsing
+ - the additional paths given via `-ffi-include-path' replaced the default ("."), but should have been be added
+ - rcsi has to use syntax-case unit for SRFI-22 scripts
+ - fixed a few bugs in makefile.vc
+ - added `(exn runtime limit)' and `(exn arity)' conditions
+ - listed some exceptions in the manual (not complete, yet)
+ - added internal hack to allow self-evaluating symbols
+ - bumped version to 1.41
+ - `-Wl,-R...' isn't added to csc anymore and is not used on OS X [Thanks to Category 5]
+
+2004-03-13 flw <flw@gurke>
+
+ * mingw/Makefile.in, Makefile.am, batch-driver.scm, build.scm, c-backend.scm, chicken.1, chicken.h, compiler.scm, configure.in, csc.1, csi.scm, easyffi.scm, eval.scm, library.scm, makefile.dj, makefile.vc, rcsibatch.bat, runtime.c:
+ - added `rcsi' (a restricted, paired down version of csi), this is also the interpreter invoked by the SRFI-22 trampolines)
+ [suggested by Michele Simionato]
+ - `(define-macro SYMBOL1 SYMBOL2)' is now allowed
+ - added several missing exports to easyffi.scm
+ - added `require-imports', the `-require-imports' option and the `CHICKEN_require_imports()' API
+ - `condition-property-accessor' accepts optional third argument; `print-error-message' handles incomplete comndition
+ objects better
+
+2004-03-08 flw <flw@gurke>
+
+ * batch-driver.scm, build.scm, c-backend.scm, c-platform.scm, chicken-setup.1, chicken.1, chicken.h, compiler.scm, configure.in, csc.bat, csi.scm, easyffi.l, easyffi.scm, eval.scm, library.scm, lolevel.scm, runtime.c, support.scm, test-infrastructure-hygienic.scm, TODO:
+ - lolevel: added `global-make-unbound!' [suggested by Michele Simionato]
+ - runtime-option `-:o' and compiler-option '-disable-stack-overflow-checks'
+ - names of external definitions are checked for being valid C identifiers
+ - `abort' signals condition with 'arguments and 'location properties
+ - support for multiple symbol tables
+ - fixed bug in compiler-handling of `location'
+ - removed all stuff related to `visit'
+ - library: `import'
+ - lolevel: `locative-ref' didn't check argument count
+ - csc: `-cxx' selects alternative C++ compiler; arguments containing "%" are unquoted [suggested by Todd Kueny]
+ - chicken-setup: added a bunch of options to change/add options to the compiler stages; fixed several bugs related to
+ downloading eggs
+ - test-infrastructure: some aliases for output-generation APIs were missing [Thanks to Michele Simionato]
+ - bumped version to 1.38
+
+2004-03-01 flw <flw@gurke>
+
+ * eval.scm, extras.scm, posix.scm, Makefile.am, TODO, batch-driver.scm, build.scm, c-platform.scm, configure.in, csc.bat, csi.1, csi.scm:
+ - extras: `shuffle' uses `sort!' instead of `sort' [thanks to Sven Hartrumpf]
+ - csc: added `-unsafe-libraries', compiling dynamically loadable file in unsafe mode links now by default with safe libraries
+ - csc, chicken-config: automatically adds `-Wl,R%libdir%' to linker invocation, if using gcc
+ - require accepts lists as pathnames for loading unregistered extensions, so "(require '(a b c))" will be equivalent
+ to `(load "a/b/c")', if no extension is registered under this name
+ - chicken, csc, csi: added `-syntax[-at-run-time]' as alias for `-hygienic[-at-run-time]' [Suggested by Category 5]
+ - chicken-setup: fixed bug in downloading routine
+ - posix: `process' forked one process too many
+ - extras: added `alist-update!'
+ - fixed several LaTeX bugs in the manual
+
+2004-02-24 flw <flw@gurke>
+
+ * build.scm, chicken-setup.1, chicken.h, compiler.scm, configure.in, extras.scm, library.scm, lolevel.scm, runtime.c, srfi-25.scm:
+ - chicken-setup.in: allowed additional property-list in repository entries, added `-host' option
+ - added `make-weak-locative', `make-locative' returns now a non-weak one
+ - `location' always returns locatives for movable data
+ - added `#$' as an abbreviation for `location'
+ - chicken-setup: `-host' option accepts optional port specification
+ - print-error-message didn't handle condition objects without any message or arguments
+ - added `CHICKEN_[new|delete]_gc_root' and `CHICKEN_gc_root_[ref|set]' for more conveniently handling
+ GC-roots from C code
+ - extras.scm: added `shuffle' [suggested on c.l.s by Michele Simionato]
+ - csc.in: `-c++' implies `-ffi-define __cplusplus'
+
+2004-02-19 flw <flw@gurke>
+
+ * benchmarks/cscbench, benchmarks/plists, library.scm, runtime.c, support.scm, TODO, batch-driver.scm, chicken.h, easyffi.l, easyffi.scm:
+ - easyffi.scm: `protected' member functions are ignored
+ - added missing `plists' file to benchmarks [Thanks to Sven Hartrumpf]
+ - fixed some references to the old `>>>' prompt in the manual [Thanks to Benedikt Rosenau]
+ - cscbench: added `-I..' to C compiler options [Thanks to Sven Hartrumpf]
+ - chicken-setup.in: supports downloading of eggs
+ - support.scm, batch-driver.scm: `-debug e' lists exported globals
+ - easyffi: added `__specialize' and `__abstract' keywords
+ - chicken.h, runtime.c: added new pointer type for exclusive use by SWIG
+
+2004-02-09 flw <flw@gurke>
+
+ * benchmarks/boyer.scm, benchmarks/browse.scm, benchmarks/conform.scm, benchmarks/cpstak.scm, benchmarks/cscbench, benchmarks/ctak.scm, benchmarks/dderiv.scm, benchmarks/deriv.scm, benchmarks/destructive.scm, benchmarks/div-iter.scm, benchmarks/div-rec.scm, benchmarks/dynamic.scm, benchmarks/earley.scm, benchmarks/fft.scm, benchmarks/fib.scm, benchmarks/fibc.scm, benchmarks/fprint.scm, benchmarks/fread.scm, benchmarks/hanoi.scm, benchmarks/lattice.scm, benchmarks/maze.scm, benchmarks/nqueens.scm, benchmarks/puzzle.scm, benchmarks/scheme.scm, benchmarks/tak.scm, benchmarks/takl.scm, benchmarks/takr.scm, benchmarks/traverse.scm, benchmarks/travinit.scm, benchmarks/triangl.scm, configure.in, csc.bat, csi.scm, eval.scm, makefile.vc, runtime.c, scheduler.scm, support.scm, syntax-case.scm, Makefile.am, TODO, batch-driver.scm, build.scm, c-platform.scm, chicken.1, chicken.h, chicken.scm, compiler.scm:
+ - removed compiler option `-compile-time-macros-only' and declaration `compile-time-macros-only'
+ - added compiler option '-run-time-macros' and declaration 'run-time-macros'
+ - makefile.vc: removed targets for DLL-libraries (these are not needed)
+ - added benchmarks
+ - `define-embedded' handles string results in a more convenient manner
+ - `define-entry-point' generates more efficient code for single result values
+ - chicken-setup.in: doesn't depend on gnutar anymore [Thanks to TiM]
+ - csc.in: added `-dll' option for generating Windows DLLs
+
+2004-02-05 flw <flw@gurke>
+
+ * examples/eval-server.scm, Makefile.am, TODO, banner.scm, build.scm, compiler.scm, configure.in, eval.scm, examples/ctclsh.scm, library.scm, syntax-case.scm, tinyclos.scm:
+ - syntax-case.scm: fixed circularity issue in the definition of `quasiquote' [Thanks to Clifford Stein]
+ - eval.scm: local definitions where in certain situations not processed [Thanks to Michele Simionato]
+ - library.scm: `list->vector' didn't handle dotted lists
+ - configure.in: uses -fno-strict-aliasing with gcc 3.3
+ - compiler.scm: detection of argument-count mismatch for customizable procedures didn't check for dotted lambda-lists
+ - tinyclos.scm: calls to methods with a wrong number of arguments crashed
+ - the definition of `define-entry-point' has now been moved to the include file `entry-points.scm'
+ - entry-points.scm: added a new macro for defining named entry-points (`define-embedded')
+ - changed version to 1.34
+
+2004-02-02 flw <flw@gurke>
+
+ * csi.1, csi.scm, optimizer.scm, runtime.c, compiler.scm, csc.bat:
+ - removed `-slib' option
+ - calls to known procedures generate better error messages if the length of the argument lists don't match
+
+2004-01-29 flw <flw@gurke>
+
+ * build.scm, configure.in, csi.scm, easyffi.scm, eval.scm, runtime.c, TODO:
+ - runtime.c: printf format strings should generate any warnings [Thanks to Sven Hartrumpf]
+ - easyffi.scm: added `transform' pseudo declaration [Suggested by Daniel Faken]
+ - eval.scm, csi.scm: renamed `read-eval-print-loop' to `repl'
+ - eval.scm: added parameter `repl-prompt' (defaults now to "#;> ", unless it turns out to be a bad idea)
+ - bumped version to 1.33
+
+2004-01-28 flw <flw@gurke>
+
+ * TODO, build.scm, chicken-setup.1, chicken-setup.scm, chicken.h, configure.in, csi.scm, easyffi.scm, eval.scm, parameters.scm, runtime.c, Makefile.am:
+ - configure.in: checks for stdint.h, if not available: uses sys/types.h [Thanks to Category 5]
+ - easyffi.scm: in fixnum mode, the `int' type is treated as `__fixnum'
+ - runtime.c: dload tries to resolve toplevel function with and without prefix [Thanks to Oskar Schirmer for suggesting this]
+ - runtime.c: `software-type' returns 'unix on Mac OS X
+ - parameters.scm, eval.scm, chicken-setup.scm: different library and shared object extensions to facilitate Mac OS X quirks
+ - easyffi.scm: enum-names are recognized as types and passed as objects of type `(enum NAME)'
+ - csc.in: fixed discrepancy in -help output [Thanks to Sven Hartrumpf]
+ - moved all setup stuff into separate script (`chicken-setup')
+ - easyffi.scm: member definitions outside of class-declarations are ignored
+
+2004-01-19 flw <flw@gurke>
+
+ * Makefile.am, build.scm, c-platform.scm, chicken.1, chicken.h, chicken.scm, compiler.scm, configure.in, easyffi.scm, eval.scm, library.scm, makefile.vc, runtime.c:
+ - chicken.h: added include for time.h
+ - makefile.vc: upregexp.c wasn't built from pregexp.scm
+ - chicken.scm: lambda-lifting doesn't always work completely reliable, and is now disabled by default
+ (only enabled in benchmark-mode)
+ - runtime.c: GC forwarding-pointers did not work with very large heaps [Thanks to Sven Hartrumpf]
+ - eval.scm, compiler.scm: low-level macros that expand into defining forms in non-toplevel contexts are
+ handled
+ correctly [Thanks to Michele Simionato for pointing out this problem]
+ - easyffi.scm: abstract classes don't get a destructor defined; if in case-insensitive mode, names are
+ downcased
+ - chicken.h: __mips64 compiles in 64-bit mode [Thanks to TiM]
+ - library.scm, c-platform.scm: added `##sys#poke-double' [Thanks to Todd R. Kueny, Sr]
+
+2004-01-14 flw <flw@gurke>
+
+ * TODO, configure.in, runtime.c, srfi-18.scm:
+ - configure.in: changed test for darwin* to *darwin*
+ - runtime.c: `machine-type' returns 'ia64 on IA64
+ - runtime.c: alignment-hole marking in the garbage collector could run over end of heap-space
+
+2004-01-12 flw <flw@gurke>
+
+ * srfi-18.scm, TODO, build.scm, chicken.h, configure.in, library.scm, posix.scm, runtime.c:
+ - configure.in: renamed `--enable-mutation-hook' to `--enable-gc-hooks'
+ - runtime.c, chicken.h: added C_gc_trace_hook
+ - library.scm: `current-seconds' returns a flonum, now [Thanks to Alejandro Forero Cuervo]
+ - posix.scm: `file-modification-time' returns a float, other time routines accept floats as seconds
+ - runtime.c, chicken.h, srfi-18.scm: uses floating-point values for time_t seconds
+
+2004-01-07 flw <flw@gurke>
+
+ * Makefile.am, chicken.h, configure.in, runtime.c:
+ - added C_mutation_hook to runtime.c and `--enable-mutation-hook' configuration option
+
+ * TODO, batch-driver.scm, build.scm, c-backend.scm, c-platform.scm, chicken-setup.scm, chicken.h, chicken.scm, compiler.scm, configure.in, csi.scm, easyffi.scm, eval.scm, extras.scm, library.scm, lolevel.scm, optimizer.scm, parameters.scm, pcre.scm, posix.scm, profiler.scm, regex.scm, runtime.c, scheduler.scm, srfi-18.scm, srfi-25.scm, srfi-4.scm, support.scm, tcp.scm, tinyclos.scm, tweaks.scm:
+ - extras.scm: `pretty-print' respects record-printers defined with `define-record-printer'
+ - easyffi.scm: regexp-substitution declarations are done in the proper order, and apply to all occurrences
+ - easyffi.scm: method-names were not fixed (name-substituted, etc.)
+ - bumped version to 1.29
+ - updated copyrights to 2004
+ - runtime.c: changed some size-argument related to heap-resizing to unsigned [Thanks to Sven Hartrumpf]
+ - tinyclos.scm: added `<integer>' class
+ - easyffi.scm: added `full_specialization' pseudo declaration
+ - manual.tex: fixed bug in description of `require-at-runtime' [Thanks to Category 5]
+
+2003-12-27 uid67214 <uid67214@gurke>
+
+ * Makefile.am, TODO, batch-driver.scm, build.scm, c-backend.scm, c-platform.scm, chicken-setup.scm, chicken.h, compiler.scm, configure.in, csc.bat, csi.scm, easyffi.scm, eval.scm, extras.scm, library.scm, lolevel.scm, makefile.dj, makefile.vc, pcre.scm, posix.scm, pregexp.scm, runtime.c, scheduler.scm, srfi-25.scm, srfi-4.scm, support.scm, tinyclos.scm:
+ - Makefile.am: runs `csi -setup' at installation time
+ - added new foreign type specifier `(instance CNAME SCHEMENAME)'
+ - easyffi.scm: C++ object pointers can now be passed/returned transparently as TinyCLOS instances
+ - csc, chicken, csi: accept `--help'
+ - easyffi.scm: `abstract' pseudo declaration; support for function-pointer types
+ - runtime.c: fixed buffer-overflow in low-level file-opening routine [Thanks to Michele Simionato]
+ - srfi-4.scm: #F wasn't properly read in case-sensitive mode
+ - eval.scm: `(begin)' is allowed in bodies
+ - scheduler.scm: uncaught exceptions in child threads trigger warning (if enabled)
+ - library.scm: `(enable-warnings [BOOL])'
+ - srfi-25.scm: some primitives didn't check argument types
+ - library.scm: `print-error-message' accepts optional third argument
+ - library.scm, runtime.c: added `print-backtrace'
+ - chicken-setup.scm: `csi -setup' lists extensions alphabetically
+ - bumped version to 1.28
+ - renamed regex2.scm to pregexp.scm
+ - added pcre.scm, PCRE is used now be default, when available
+ - pregexp.scm, pcre.scm: register extra feature identifiers
+ - configure.in: on Mac OS X, `-L/sw/include' is added to LIBS
+ - runtime.c: "_" prefix is added for OpenBSD + a.out [Thanks to "Category 5"]
+ - compiler: `-explicit-use' prevents tinyclos unit from being used automatically (in easyffi.scm)
+ - csi.scm: report displays regex flavor
+ - extras.scm: added `hash-table-size'
+ - easyffi.scm: `__scheme_value' was converted into wrong type specifier
+ - posix.scm: should now compile under IRIX [Thanks to "Fizzie"]
+ - easyffi.scm: function prototypes with const return types were not correctly parsed
+ - pcre.scm: non-matched capturing subpatterns were not included in the final match-list (as #f)
+ - lolevel.scm: added `object-' prefix to some procedure names
+
+2003-11-26 flw <flw@gurke>
+
+ * Makefile.am, TODO, build.scm, c-backend.scm, chicken-setup.scm, compiler.scm, configure.in, psyntax.scm, support.scm:
+ - chicken-setup.scm: added `do-chicken-setup'
+ - documented `test-compile'
+ - Makefile.am: removed last remnants of "CPUCONFIGFLAGS" [Thanks to Joerg Wittenberger]
+ - manual.tex: split up all those "Miscellaneous" sections a little
+ - configure.in: added `--with-pregexp' option
+ - highlevel-macros.scm: `foreign-value' wasn't defined properly
+ - support.scm: size-estimation for flonums was wrong
+ - chicken-setup.scm: `csi -setup' lists extension version (if defined); fixed another bug in `chicken-setup' macro
+ - c-backend.scm: fixnum-conversion of FFI calls used hardcoded, 32-bit assuming bitmask [Thanks to "Category 5"]
+
+2003-11-22 flw <flw@gurke>
+
+ * Makefile.am, TODO, banner.scm, batch-driver.scm, build.scm, chicken-config.in, chicken-setup.scm, compiler.scm, configure.in, csc.bat, easyffi.l, eval.scm, library.scm, optimizer.scm, srfi-4.scm, support.scm:
+ - changed silly banner to something slightly less silly
+ - removed obsolete `##core#qualified'
+ - easyffi.l: didn't parse `!=' and `!`
+ - configure.in: removed -mflat for Sparc options
+ - chicken-setup.scm: improved `test-compile'
+ - optimizer.scm: lambda-lifting was broken for indirectly recursive calls of liftable procedures sometimes
+ - compiler.scm: fixed very very strange error in canonicalization of `##core#foreign-callback-wrapper'
+ - batch-driver.scm: #\# is allowed at file start in non-scripts
+ - chicken-config.in: removed -cppflags
+ - configure.in: add "-no-cpp-precomp -I/sw/include" to CFLAGS on Mac OS X [Thanks to Taylor Campbell]
+ - moremacros.scm/highlevel-macros.scm: added `foreign-value'
+ - eval.scm: error in REPL resets ports to the state before the previous read
+ - srfi-4: added `subXXXvector'
+ - support.scm: `##core#primitive' generated invalid C code with syntax-case macros [Thanks to Joerg Wittenberger]
+
+2003-11-15 flw <flw@gurke>
+
+ * chicken.scm, compiler.scm, csi.scm, easyffi.scm, eval.scm, extras.scm, optimizer.scm, support.scm, TODO, batch-driver.scm, c-backend.scm, c-platform.scm, chicken-setup.scm:
+ - support.scm: chicken -help doesn't print silly banner
+ - chicken-setup.scm: `test-compile' has been improved
+ - moremacros.scm, highlevel-macros.scm: added `foreign-code' macro
+ - extras.scm: added `pp' as an alias for `pretty-print'
+ - easyffi.scm: `##compiler#foreign-declarations' wasn't exported
+ - csi.scm, support.scm: changed version/silly banner display slightly
+ - added doc/tinyclos-examples.scm
+ - eval.scm: `##core#global-ref' wasn't implemented in the interpreter [Thanks to Michele Simionato]
+
+2003-11-14 flw <flw@gurke>
+
+ * banner.scm: *** empty log message ***
+
+ * Makefile.am, TODO, chicken.h, compiler.scm, csi.scm, easyffi.l, easyffi.scm, eval.scm, support.scm:
+ - Makefile.am: default-entry-points.scm wasn't put into the list of installed files
+ - chicken.h: all uses of C_toplevel are casted to void *
+ - easyffi.scm: creating TinyCLOS instances from `this' pointers should be a little bit more efficient now
+ - easyffi.scm: added pseudo type `__scheme_value'
+ - eval.scm: added `##sys#void' to scheme-report-environment
+ - compiler.scm: renamed generated C functions from `fNNN' to `f_NNN'
+ - easyffi.scm: parsing class-defs automatically adds `(uses tinyclos)' declaration
+ - added silly banner
+
+2003-11-05 flw <flw@gurke>
+
+ * easyffi.scm, library.scm, runtime.c, syntax-case.scm, Makefile.am, build.scm, c-backend.scm, chicken-config.in, chicken.h, configure.in:
+ - runtime.c: `parse_argv' is not included, unless really needed [Thanks to Sven Hartrumpf]
+ - csc.in, chicken-config.in, Makefile.am, configure.in: On OS X, '-c++' adds `-no-cpp-precomp'
+ to the g++ compiler flags [Thanks to Taylor Campbell]
+ - chicken.h: includes <alloca.h> on SunOS (always) [Thanks to Sven Hartrumpf]
+ - c-backend.scm: moved generation of callback-prototypes at start of output file
+ - easyffi.scm: fixed unbound variable error in `parse-declaration'
+ - syntax-case.scm: `install-highlevel-macro-system'
+ - chicken.h, runtime.c, default-entry-points.scm: added support for simplified embedding of code
+ - library.scm: fixed off-by-one error in `##sys#register-entry-point'
+ - easyffi.scm: wrapped C++ classes accept optional 'this initializer keyword [Thanks to "Dave"]
+ - script-utils.scm: added `for-each-argv-line' [Thanks to William Annis]
+ - bumped version to 1.23
+
+2003-10-30 sven1999 <sven1999@gurke>
+
+ * testsuites/test-example.scm: removed some typos
+
+2003-10-29 flw <flw@gurke>
+
+ * makefile.vc, psyntax.scm, runtime.c, support.scm, tinyclos.scm, eval.scm, library.scm, compiler.scm, configure.in, easyffi.scm, c-backend.scm, chicken.h, build.scm:
+ - psyntax.scm, eval.scm: allow `set!' forms with the first arg being an expression
+ - manual.tex: fixed some typos [Thanks to Sven Hartrumpf]
+ - psyntax.scm, eval.scm: added internal support for SRFI-17
+ - easyffi.scm: declaration values are separated via semicolons, added "type" pseudo declaration
+ - makefile.vc: rule for easyffi.l.silex was wrong
+ - runtime.c, chicken.h: added runtime option for heap-size maximum [Thanks to Sven Hartrumpf]
+ - compiler.scm, support.scm: added compiler special form `##core#global-ref'
+ - tinyclos.scm, highlevel-macros.scm, moremacros.scm: TinyCLOS method definitions now are properly handled with hidden/block globals
+ - c-backend.scm: assignment to foreign variables is properly casted to please C++ compilers
+ - easyffi.scm: fixed two bugs related to using __callback in member defs
+ - library.scm: `argc+argv'
+
+2003-10-21 sven1999 <sven1999@gurke>
+
+ * examples/makefile:
+ new example cube needs more C flags to find chicken.h
+
+2003-10-20 flw <flw@gurke>
+
+ * chicken.h, easyffi.l, easyffi.scm:
+ - easyffi.scm: added pseudo declarations and `struct ID' definition, negative numbers were not recognized
+ - easyffi.scm: bugfix in call to `process-macro-def', pure virtual methods will generate in class without constructor method
+ - easyffi.l: character constants
+
+2003-10-15 flw <flw@gurke>
+
+ * examples/README, examples/cube.scm, examples/makefile, examples/mandelbrot.scm, examples/schelog-support.scm, csi.1, csi.scm, easyffi.l, easyffi.scm, eval.scm, library.scm, optimizer.scm, runtime.c, support.scm, c-platform.scm, chicken.1, chicken.h, chicken.scm, compiler.scm, configure.in, csc.bat, batch-driver.scm, build.scm, c-backend.scm:
+ - removed `no-winding-callcc' declaration specifier and option
+ - added cube.scm to examples
+ - library.scm: `call/cc', `print-error-message'
+ - eval.scm: `require' didn't handle circular requirements
+ - batch-driver.scm: bails out if input- and output-filename are identical
+ - easyffi.scm: handling of if/else outside of preprocessor contexts, inline, explicit, using, const and pure virtual methods
+ - csc.in, c-platform.scm, batch-driver.scm: -ffi option allows compiling C/C++ for extraction of foreign bindings
+ - c-backend.scm, support.scm: reference, const, enum and template type specifiers
+ - easyffi.scm: template types, better support for fixnum and bool, __callback qualifier, struct/union/enum/reference
+ - csc.in: accepts files with ".h" extension
+ - The reader is now by default case sensitive
+ - `-case-sensitive' -> '-case-insensitive'
+ - bumped version to 1.21
+ - local definitions inside bodies always expand into `letrec' forms, enclosing all subsequent forms
+ - `-strict' didn't always imply `-strict-letrec' (now it does)
+ - added compiler/interpreter option `-r5rs' (is `-hygienic -strict')
+ - regex2.scm: `*pregexp-space-sensitive?*' should have been a variable, not a constant
+ - strict letrec mode was erroneously enabled in non-hygienic mode by the compiler
+ - runtime.c: changed FLONUM_PRINT_PRECISION to 15 [Thanks to "Category 5"]
+ - csc.in: accepts .C, .cc, .cxx and .c++ as C++ source extensions
+
+2003-10-03 flw <flw@gurke>
+
+ * easyffi.scm, makefile.vc: - easyffi.scm: removed a diagnostic message
+ - makefile.vc: builds extra libraries in gui mode (so that they don't refer to chicken.dll)
+ - csc.in: `-windows' option is back (and works properly)
+
+2003-10-01 flw <flw@gurke>
+
+ * chicken.h, easyffi.scm:
+ - chicken.h: when compiled with g++, chicken-generated code doesn't use statement expressions [Thanks to Bruce Hoult]
+ - easyffi.scm: added support for static member functions and C++ constants
+
+2003-09-30 flw <flw@gurke>
+
+ * build.scm, chicken.h, configure.in, easyffi.l, easyffi.scm:
+ - easyffi.scm: prototype bodies may contain code, now
+ - easyffi.scm: `#if' fails always
+ - chicken.h: includes `alloca.h', when compiled as C++, under Solaris, with GCC [Thanks to Bruce Hoult]
+ - changed version to 1.20
+ - easyffi.scm: `volatile', `virtual' and destructor parsing
+ - easyffi.scm: enums and numeric `#define's are converted to constant-definitions
+
+2003-09-29 flw <flw@gurke>
+
+ * c-platform.scm, chicken-config.in, compiler.scm, configure.in, easyffi.l, easyffi.scm, tinyclos.scm, Makefile.am, batch-driver.scm, c-backend.scm:
+ - csc.in, chicken-config.in, configure.in, Makefile.am: automatically use proper compiler and linker in C++ mode
+ - easyffi.scm: `#include' is now handled
+ - `export' and `hide' declarations are more robust
+ - c-backend.scm: assignments to foreign procedure argument temporaries are casted to please C++ compiler
+ - easyffi.scm: (very) basic C++ support
+ - tinyclos.scm: added builtin class `<c++-object>'
+
+2003-09-27 flw <flw@gurke>
+
+ * batch-driver.scm, c-backend.scm, c-platform.scm, chicken.1, chicken.h, compiler.scm, easyffi.scm, lolevel.scm, makefile.vc, support.scm:
+ - easyffi.scm: fixed numerous bugs
+ - makefile.vc: can build easyffi.l.silex from source
+ - easyffi.scm: `static' is allowed for prototypes and variables
+ - lolevel.scm: MOVE-MEMORY! handles locatives, now
+ - csc.in: added `-c++' option
+ - c-backend.scm, chicken.h: fixes to allow compiling generated C code in C++ mode
+
+2003-09-22 flw <flw@gurke>
+
+ * examples/makefile, Makefile.am, build.scm, chicken.scm, compiler.scm, configure.in, easyffi.l, easyffi.scm, library.scm, makefile.dj, makefile.vc, silex.scm, support.scm:
+ - library.scm: LIST->STRING could overflow the stack (on Windows) and was rather inefficient in general
+ - added easyffi
+ - bumped version to 1.19
+
+2003-09-10 flw <flw@gurke>
+
+ * configure.in:
+ - csc.in: removed `-windows' option (didn't really work), added `-D SYMBOL' as synonym for `-feature'
+ and added special linker option for NetBSD [Thanks to Jun-iochiro itojun Hagino]
+ - configure.in: gcc-check accepts optional suffix [Thanks to Sven Hartrumpf]
+ - moremacros.scm, highlevel-macros.scm: `define-generic' accepts optional class
+
+2003-09-08 flw <flw@gurke>
+
+ * configure.in, eval.scm, posix.scm, support.scm, build.scm:
+ - csc.in: `-dynamic' is equivalent to `-shared'
+ - support.scm: `-dynamic' wasn't mentioned in `-help' output
+ - when using gcc 3.3, add `-Wno-strict-aliasing' option to CFLAGS [Thanks to Johannes Groedem]
+ - bumped version to 1.18
+ - posix.scm: `file-lock' mixed up input- and output-ports [Thanks to Johannes Groedem]
+ - posix.scm: error-handling for file-locking was wrong
+ - eval.scm: `load' didn't always return void
+
+2003-09-05 flw <flw@gurke>
+
+ * c-platform.scm, chicken.1, configure.in, extras.scm, library.scm, runtime.c, batch-driver.scm:
+ - configure.in: fixed version-number
+ - library.scm: `.' in vector literals caused crash
+ - manual.tex: fixed a few typos
+ - library.scm: `(error SYMBOL)' resulted in crash (oh my!)
+ - csc.in: typo in library-file selection
+ - csc.in, c-platform.scm, batch-driver.scm: added `-dynamic' option
+ - runtime.c: there was no check for the heap-size maximum [Thanks to Sven Hartrumpf]
+ - extras.scm: Sven Hartrumpf suggested a more efficient version of `string-compare3[-ci]'
+
+2003-08-30 flw <flw@gurke>
+
+ * batch-driver.scm, build.scm, chicken-setup.scm, csc.bat, support.scm:
+ - added `-quiet' option to chicken-setup
+ - added `-no-init' option to tex2page invocation line
+ - `#> ... <#' is now an abbreviation for `(declare (foreign-declare " .,, "))'
+ - version is now 1.17
+
+2003-08-25 flw <flw@gurke>
+
+ * library.scm, runtime.c: - csc.in: `-embedded' wasn't recognized
+ - library.scm: `get-keyword' accepts any object as keys
+ - runtime.c: `C_callback' doesn't do a minor GC at entry [Thanks to Bruce Hoult]
+ - `(. ...)' segfaulted instead of giving an error message [Thanks to Category 5]
+ - `(receive X)' is allowed and returns the list of the result-values
+
+2003-08-17 flw <flw@gurke>
+
+ * eval.scm, runtime.c:
+ - fixed big performance leak in minor GC handling: GC-timing stuff for `time'
+ macro caused way too many kernel calls [Thanks to Bruce Hoult]
+ - `dump_trace()' didn't initialize output buffer properly
+
+2003-08-07 flw <flw@gurke>
+
+ * chicken.h, compiler.scm, csc.bat, csi.scm, eval.scm, lolevel.scm, posix.scm, runtime.c, build.scm, chicken-setup.scm:
+ - eval.scm: `extension-path'
+ - lolevel.scm: `global-ref', `global-set!' and `global-bound?'
+ - csc: static libs are reordered to link libchicken last [thanks to Sven Hartrumpf]
+ - posix.scm: `group-information'
+ - added index to the manual [thanks to Peter Wang]
+ - 'loevel was declared as provided by csi (which was wrong)
+ - removed `define-id-macro' and `let-id-macro'
+ - setup-specification attributes `test', `test-command' and `test-chicken-version'
+ - `C_alloc_in_heap()' is called with number of words (not bytes)
+
+2003-07-30 flw <flw@gurke>
+
+ * extras.scm, optimizer.scm, posix.scm, runtime.c, c-backend.scm, chicken.h, configure.in:
+ - `csc' added `-s' option to linker, when linking with optimization (won't
+ work when building shared object)
+ - fixed countless typos in manual.tex [Thanks to Bruce Mitchener]
+ - `csc' uses `-bundle' instead of `-shared' under Mac OS X
+ - runtime.c: dload_2 prefixes dlsym'd name with "_"
+ - posix.scm: under Mac OS X, `environ' is not used (and `current-environment'
+ always returns '())
+ - removed `C_collectibles' and added `C_gc_protect()' and `C_gc_unprotect()'
+ - fixed compiler bug that caused repeated explicit rest-argument list consing
+ [Thanks to Sven Hartrumpf]
+ - added `string-compare3[-ci]'
+ - reduced C_STACK_RESERVE to 4096; the previous setting could overflow the
+ stack-check on machines with a stack in very high memory
+
+2003-07-25 flw <flw@gurke>
+
+ * build.scm, chicken-setup.scm, chicken.h, compiler.scm, csc.bat, csi.scm, eval.scm, posix.scm, runtime.c:
+ - added `C_end_of_main' macro to chicken.h
+ - `location' now accepts callback-names
+ - bumped version to 1.15
+ - `csc' accepts '-windows' under Cygwin
+ - chicken-setup.scm/eval.scm: ##sys#load-library-extension is exported (and used)
+ - the STACKTRACE is printed directly (and not saved in a file)
+ - `,d' in csi stops after 40 elements when printing sequences
+ - chicken-setup.scm: fixed hardcoded ".so"
+ - posix.scm: fixed some routines that weren't updated to the new I/O system
+
+2003-07-17 flw <flw@gurke>
+
+ * scheduler.scm: - scheduler.scm: fixed bug in `##sys#all-threads'
+ - scheduler.scm: fixed invalid timeout computation in `##sys#fdset-select-timeout'
+ [thanks to Peter Wang]
+
+2003-07-15 flw <flw@gurke>
+
+ * csc.bat, csi.1, eval.scm, library.scm, posix.scm:
+ - library.scm: vector-resize
+ - script-utils: for-each-line
+ - uses newest autotools (libtool 1.5, autoconf 2.57, automake 1.7.6)
+ - posix.scm: fixed bug in `process-execute' [Thanks to Peter Wang]
+
+2003-07-07 flw <flw@gurke>
+
+ * chicken.1, csi.scm, support.scm, batch-driver.scm, build.scm, c-platform.scm:
+ - support.scm: generation of C literals from strings escapes '?' to avoid trigraphs
+ - added `-slib' option to csc.in and csi.scm
+ - cleaned up the manual a little
+ - added `-require-for-syntax' option to `csc'/`chicken'
+ - added `-windows' option to `csc'
+ - bumped version to 1.14
+
+2003-07-03 flw <flw@gurke>
+
+ * Makefile.am, chicken.h, configure.in, runtime.c:
+ - removed chicken.init from Makefile.am (thanks to Sven Hartrumpf)
+ - (build-platform) returns 'sun when compiled with the Sun compiler under Solaris
+ - added Matthias Koeppe's fixes for proper handling of HAVE_CONFIG_H
+
+2003-07-01 flw <flw@gurke>
+
+ * batch-driver.scm, build.scm, c-platform.scm, chicken.scm, compiler.scm, csi.scm, eval.scm, extras.scm, library.scm, optimizer.scm, regex.scm, runtime.c, srfi-18.scm:
+ - runtime-system uses internal versions of `require', `provide' and `provided?'
+ - extras.scm: substring=?, subtring-ci=?, string-translate*
+ - regex.scm/regex2.scm: string-substitute*
+ - c-platform.scm: added optimization-rule for `identity'
+ - during exection of compiler-extensions, the feature-identifier #:compiler-extension is registered
+ - Chicken now officially supports SRFI-39
+ - '\xXX' character constants in strings
+ - srfi-18.scm: `thread-deliver-signal!' [On special request by Joerg Wittenberger]
+ - `(##sys#fudge 3)' returns #t if running on a 64-bit platform
+ - removed chicken.init - we will handle this better...
+
+2003-06-25 flw <flw@gurke>
+
+ * Makefile.am, batch-driver.scm, c-backend.scm, c-platform.scm, chicken-setup.scm, configure.in, extras.scm, optimizer.scm:
+ - `csi -setup' with an invalid name gives an error [Thanks to Peter Keller]
+ - `-extend' option was broken [Thanks to Joerg Wittenberger]
+ - csc.in: on Windows, filenames with drive-designators where interpreted as runtime-options
+ - csc.in: pathnames passed to cl and link are transformed (#\/ -> #\\)
+ - on windows, #\\ in pathnames could generate invalid C output in `C_trace()'
+ - extras.scm: identity, project, conjoin, disjoin
+ - configure.in: applied patch to link `nanosleep()' under Solaris 7/8 [Thanks to Matthias Koeppe]
+ - c-platform.scm: added peek-char and char-ready? to side-effecting-standard-bindings
+ - optimizer.scm: fixed bug in rewriting of certain builtin procedures
+ - configure.in: check for ldl had a type [Thanks to Matthias Koeppe]
+ - regex2.scm: wrong feature name for shared compile was used
+ - removed doc/README.txt and added doc/manual.hdir
+
+2003-06-19 flw <flw@gurke>
+
+ * build.scm: - Bumped version number to 1.12
+
+2003-06-14 flw <flw@gurke>
+
+ * Makefile.am, batch-driver.scm, build.scm, c-platform.scm, chicken.h, csi.scm, extras.scm, library.scm, lolevel.scm, posix.scm, runtime.c:
+ - extras.scm: the first argument to `read-string' is now optional
+ - runtime.c: interning of empty string referenced uninitialized memory
+ - posix.scm: I/O on ports returned by `process' is now fully nonblocking
+ - posix.scm: `errno/wouldblock'
+ - files loaded via the `-extend' compiler option are also searched in the
+ current include-path
+ - `##sys#call-with-direct-continuation' and `##sys#direct-return' (they
+ might turn out useful)
+ - lolevel.scm: `unbound-variable-value'
+ - posix.scm: `file-read' didn't check the buffer argument early enough
+ - extras.scm: `write-string'
+ - csi doesn't use the lolevel unit anymore
+ - `chicken-setup.c' was not up to date
+ - added BOOTSTRAP_PATH to Makefile.am, this simplifies the invocation
+ of make when bootstrapping the system from CVS sources
+ [Thanks to Peter Keller]
+
+2003-06-06 flw <flw@gurke>
+
+ * library.scm, posix.scm, runtime.c, tcp.scm:
+ - tcp.scm: tcp-listener-port
+ - fixed bug in runtime.c that resulted in fopen() being called with invalid file-mode
+ - tcp.scm: EWOULDBLOCK wasn't defined under Win32 with MSVC
+ - the printer mixed up "input" and "output" when printing port objects
+ - fixed bug in read-char handler of pipe-ports
+ - fixed two unbound variable bugs in library.scm and posix.scm
+ - commit updates ChangeLog at website and send message to mailing list.
+ In other words: SMTP and FTP extensions are imminent ;-)
+
+2003-06-02 flw <flw@gurke>
+
+ * compiler.scm, csi.scm, eval.scm, extras.scm, format.scm, library.scm, lolevel.scm, posix.scm, runtime.c, scheduler.scm, support.scm, tcp.scm, batch-driver.scm, build.scm, chicken.h:
+ - fixed problem with scheduler.scm (C_msleep) under Windows
+ - overhauled I/O subsystem
+ - lolevel.scm: invalid-procedure-call-handler
+ - declaration `safe-globals'
+ - internal compiler for `##core#app'
+ - eval/visit uses `##core#app'
+ - debug-option `D'
+ - (hopefully) settled all thread-safety issues in `format.scm'
+ - nonblocking I/O for tcp-ports
+ - made `##sys#errno' an int, instead of an integer (library.scm)
+ - fixed bug in tcp.scm: partial writes to tcp-port didn't remove sent part
+ - `##sys#thread-block-for-i/o!' for output (or mixed?) mode doesn't work properly (deactived,
+ does simple polling)
+
+2003-05-21 flw <flw@gurke>
+
+ * chicken-setup.scm, library.scm, scheduler.scm:
+ - scheduler.scm: timeout-values in nanoseconds where calculated incorrectly
+ - chicken-setup.scm: -wrap doesn't create registry, if not existing
+ - ##sys#special-read-syntax-table
+ - updated FAQ a little
+
+2003-05-19 flw <flw@gurke>
+
+ * chicken.h, compiler.scm, eval.scm, posix.scm, runtime.c, scheduler.scm:
+ - `define-foreign-variable' isn't seen by `visit' anymore
+ - `C_flonum()' advanced allocation pointer wrongly on 64-bit platforms
+ - `parameterize' accepts arbitrary expressions in the parameter position of the binding-list
+ - applied patches by Sven Hartrumpf that remove unneeded special casing for ICC
+ - constants defined via `define-constant' are visible inside constant-expressions for
+ that form
+ - the scheduler doesn't waste CPU cycles when waiting for thread- or I/O-timeout, unless
+ other threads are ready [Thanks to Chris Double]
+
+2003-05-08 flw <flw@gurke>
+
+ * support.scm, build.scm, chicken.h, compiler.scm, eval.scm, parameters.scm, posix.scm, runtime.c:
+ - fixed bug in `process-execute', pointers to potentially gc-moved strings where retained
+ [thanks to Joerg Wittenberger]
+ - `define-constant' evaluates 2nd argument at compile time
+ - fixed bug with mutable constants in `define-constant' forms
+ - visiting handles `define-foreign-type' and `define-foreign-variable'
+ - fixed compiler bug in support.scm: `estimate-foreign-result-size' allocated one word too little if flonum result
+ has to be aligned
+ - `##core#inline[_allocate]' expanded incorrectly with the hygienic macro system
+ [Thanks to Panagiotis Vossos]
+ - fixed 32-bit dependencies: C_FLONUM_TAG was wrong on 64-bit platforms; C_equalp() used `int' where a `C_word'
+ was needed
+ - 8-byte alignment was incorrectly handled for 64-bit platforms
+
+2003-05-04 flw <flw@gurke>
+
+ * library.scm:
+ - `output-port?' returned 0 on closed port [Thanks to Burton Samograd]
+
+ * chicken-setup.scm, chicken.h, compiler.scm, csi.scm, eval.scm, extras.scm, format.scm, library.scm, parameters.scm, posix.scm, runtime.c, srfi-13.scm, support.scm, batch-driver.scm, build.scm:
+ - `substring' signals (exn bounds)
+ - replaced several occurences of `substring' with `##sys#substring'
+ - moved the description of `process' into the proper manual section
+ - `process' should read non-blocking, now
+ - buffer grows by doubling it's size in `read-line'
+ - chicken-setup: defaults options are "-O2 -d0"
+ - format is thread-safe
+ - the transcript port wasn't properly recognized as a tty-port
+ - vector-copy! signals (exn bounds)
+ - several small optimizations in library.scm
+ - non-exported globals where still exported, if ref'd before definition
+ - non-blocking `process' seems to work
+ - `csi -setup-help' and -uninstall
+ - `string-null?' is expanded inline
+ - visit handling constant- and inline-definitions
+ - `define-constant' wasn't consistently handled in hygienic and non-hygienic mode
+ - removed procedure-definition syntax for `define-constant'
+
+2003-04-23 flw <flw@gurke>
+
+ * build.scm, c-backend.scm, chicken-setup.scm, chicken.h, compiler.scm, configure.in, eval.scm, extras.scm, library.scm, lolevel.scm, posix.scm, regex.scm, runtime.c, support.scm:
+ - hidden globals where not properly checked for boundedness
+ - the foreign return types `c-pointer' and `pointer' did not return `#f' on NULL results
+ [thanks to Peter Wang]
+ - `##sys#void' is handled better by `canonicalize-begin-body' (support.scm)
+ - fixed space leaks in `regex.scm'
+ - `read-line' accepts optional limit
+ - `-setup' gives useful error-message on non-UNIX platforms
+ - there where two conflicting versions of `provided?'
+ - chicken-setup handles single-file case
+ - some warning-options are passed to CFLAGS
+ - fixed typo in posix.scm [Thanks to Joerg Wittenberger]
+
+2003-04-19 flw <flw@gurke>
+
+ * runtime.c:
+ - fixed a couple of 32-bit dependencies [Thanks to Panagiotis Vossos]
+ - fixed bug in syntax-case version of condition-case
+
+ * examples/ctclsh.scm, support.scm, tcp.scm, runtime.c, srfi-25.scm, csi.scm, library.scm, optimizer.scm, psyntax.scm, Makefile.am, batch-driver.scm, build.scm, c-backend.scm, c-platform.scm, chicken.1, chicken.scm, compiler.scm:
+ - fixed bug in c-backend.scm: heap-limit settings [Thanks to Sven Hartrumpf]
+ - fixed bug in runtime.c: handling of -:t... was bogus [Thanks to Sven]
+ - the default output-file for `chicken' is now the original-filename (+ ".c") [Thanks to Panagiotis Vossos]
+ - syntax-case uses `##sys#void' in expansions
+ - removed `error-handler'
+ - diversified exceptions a little
+ - srfi-25: signals more sensible exn types
+ - added `condition-case'
+
+2003-04-08 flw <flw@gurke>
+
+ * compiler.scm, eval.scm, examples/prolog.scm, examples/schelog-support.scm, library.scm, match-support.scm, posix.scm, regex.scm, runtime.c, scheduler.scm, srfi-1.scm, srfi-13.scm, srfi-14.scm, srfi-18.scm, srfi-37.scm, srfi-4.scm, syntax-case.scm, tcp.scm:
+ - eval.scm: `##sys#environment-is-mutable' isn't hidden anymore.
+ - scheduler.scm: ##sys#fetch-and-clear.
+ - simplified some code in tcp.scm.
+ - `(build-platform)' returns 'intel for ICC.
+ - removed `interrupts-disabled' declaration.
+
+2003-04-03 flw <flw@gurke>
+
+ * configure.in, runtime.c:
+ - Changed calls to AC_INIT and AM_INIT_AUTOMAKE in configure.in to new syntax.
+ - Recreated autotool files using newest versions.
+
+2003-03-31 flw <flw@gurke>
+
+ * batch-driver.scm, build.scm, c-platform.scm, chicken-setup.scm, chicken.1, compiler.scm, csc.bat, csi.scm, eval.scm, library.scm, posix.scm, support.scm:
+ - Removed syntax checks from internal `##core#...' forms.
+ - `require-at-runtime' setup-specification.
+ - `csi -setup -init' did not install core extensions.
+ - `seconds->string' (posix.scm) couldn't handle large (but valid) non-fixnum integers
+ [Thanks to Anthony Carrico]
+ - `visit' and `-visit' options to csi and chicken.
+ - `(gc #t)' didn't return number of free bytes.
+ - `pathname-directory-separator' was #\\ under Cygwin (is now #\/).
+ - Removed fixnum->flonum coercion warning in reader.
+
+2003-03-23 njbeckford <njbeckford@gurke>
+
+ * runtime.c: Got rid of buffer overflow in C_get_environment_variable.
+
+2003-03-22 njbeckford <njbeckford@gurke>
+
+ * Makefile.am:
+ Undid change that made both MORE_LIBS and MORE_STATIC_LIBS be the same thing.
+
+ * Makefile.am:
+ Made both MORE_LIBS and MORE_STATIC_LIBS be the same thing.
+
+ * Makefile.am:
+ -all-static replaced by -static. On Solaris, need libdl.so and
+ libnsl.so since no libdl.a nor libnsl.a.
+
+ * Makefile.am:
+ "make doc" and "make testsuites" now use CHICKEN=../chicken
+
+ * Makefile.am: Uses MORE_STATIC_LIBS instead of MORE_LIBS for
+ lib[xxx_]chicken_la_LDFLAGS so that libtool does not add "-ldl"
+ whenever something links with lib[xxx-]chicken.la.
+
+ * Makefile.am, chicken-config.in, configure.in, runtime.c:
+ configure.in: Made new variable SHLIBS which has -ldl or -ldld, which will only be used in non -all-static code.
+ Makefile.am: Use SHLIBS to differentiate MORE_LIBS from MORE_STATIC_LIBS.
+ runtime.c: Do not even try to use dl.h/dlfcn.h/dlopen/shlopen when in all-static mode.
+ chicken-config.in, csc.in: Use MORE_STATIC_LIBS (%morestaticlibs%) in static mode.
+
+2003-03-20 flw <flw@gurke>
+
+ * build.scm, csc.bat:
+ - `csc' deletes .lib and .exp files if compiling non-shared, non-static on MSVC.
+ - bumped version number to 1.0.
+
+2003-03-16 flw <flw@gurke>
+
+ * build.scm, configure.in, csc.bat, eval.scm, parameters.scm:
+ - "so" was assumed as dynamically loadable file extension (should be "dll" under windows).
+ - csc passed "/DPIC" to msvc, if compiling without `-static'.
+
+2003-03-14 flw <flw@gurke>
+
+ * chicken-config.in, csc.bat, library.scm:
+ - Added `-static' option to csc and chicken-config. Both scripts misused `-shared'
+ as an indicator for linking with shared libs, but this option should be used
+ to generate dynamically loadable modules. Default is now to generate dynamically
+ linked executables. Use `-static' for generating statically linked binaries.
+ - `[...]' is now allowed in strict-reader mode.
+
+2003-03-12 flw <flw@gurke>
+
+ * testsuites/test-lolevel.scm, testsuites/makefile.in, Makefile.am, batch-driver.scm, build.scm, chicken-config.in, configure.in, csc.bat, eval.scm, makefile.vc, parameters.scm, runtime.c:
+ - scheme-chicken-hygienic script interpreter.
+ - Fixed two bugs in csc.in.
+ - removed testsuites/test-lolevel.scm.
+
+2003-03-12 njbeckford <njbeckford@gurke>
+
+ * Makefile.am: Changed "-static" libtool link option to "-all-static".
+
+ -all-static: Always choose static libraries where possible, and try to
+ create a completely statically linked executable.
+
+ -static: This switch is similar to `-all-static', except that it
+ applies to only the uninstalled Libtool libraries in the build
+ tree. Where possible the static archive from these libraries is used,
+ but the default linking mode is used for libraries which are already
+ installed.
+
+ -static was causing problems on some people's systems (well, Felix's)
+ because the default linking mode is shared libraries.
+
+2003-03-11 njbeckford <njbeckford@gurke>
+
+ * Makefile.am, chicken-config.in, csc.bat, testsuites/makefile.in:
+ For static linking, always use an absolute form like
+ /usr/local/lib/libchicken.a instead of -lchicken.
+
+ * chicken-config.in:
+ Condensed multiple lines of output into one. Was screwing up
+ SWIG configure script.
+
+2003-03-10 njbeckford <njbeckford@gurke>
+
+ * compiler.scm: Fixed typo error (fix was by Felix).
+
+ * Makefile.am, mingw/Makefile.in, testsuites/makefile.in:
+ Some fixes to allow MinGW to work as intended.
+ Especially, changing testsuites to rely on chicken-config for the
+ compiling and linking options.
+
+ * mingw/Makefile.in: Just install csc.bat, not csc
+
+ * mingw/configure.sh:
+ Needed to shift the installation location of the list of command line
+ arguments to ../configure.
+
+ * testsuites/makefile: Deprecated; use makefile.in
+
+ * runtime.c:
+ Changed the order of dload_2 functions so that dlopen/dlsym comes
+ before LoadLibrary/GetProcAddress. This means that for Cygwin,
+ dlopen/dlsym will be used, and Cygwin's checking of LD_LIBRARY_PATH in
+ addition to PATH will be used.
+
+ * chicken-config.in:
+ The -shared option needs to add -DPIC to compiler flags.
+
+2003-03-09 njbeckford <njbeckford@gurke>
+
+ * c-backend.scm, chicken.h, csc.bat, makefile.vc, runtime.c:
+ Changes to allow Microsoft Visual C++ to compile. All functions in
+ chicken.h had to have a dllimport/dllexport. Got rid of C_dllexport
+ as it was messing up the MSVC compile, but needs to be looked at
+ further. Makefile.vc updated to build both static and shared
+ libraries. The c-backend was updated so that C_xxx_toplevel was
+ imported and exported properly on a MSVC build.
+
+2003-03-08 flw <flw@gurke>
+
+ * Makefile.am, csc.bat, tcp.scm:
+ - `-strict-reader' doesn't disable `[...]' list syntax.
+ - Added `tcp-abandon-port' to tcp.scm.
+ - Makefile.am: the effect USE_POSIX was sometimes reversed.
+ - csc handles different shared-library file extensions.
+
+2003-03-04 njbeckford <njbeckford@gurke>
+
+ * Makefile.am, configure.in:
+ Fixed configure.in and Makefile.am to work with minimum autoconf 2.50, automake 1.4-p3 and libtool 1.3
+
+ * runtime.c:
+ Bug fix for handling of .dll or .so extension for cygwin/mingw.
+
+ * Makefile.am: Bug fix for multiple compilation of chicken-setup.
+
+ * Makefile.am, chicken-config.in, chicken.h, configure.in, mingw/INSTALL, mingw/Makefile.in, mingw/autogen.sh, mingw/configure.sh, mingw/installdllv.sh, mingw/mingw-cc.sh, mingw/mingw-cxx.sh, runtime.c, testsuites/makefile.in:
+ Support for MinGW/Cygwin dynamic loading. MinGW now uses the GNU
+ autoconf et al. tools.
+
+2003-03-03 flw <flw@gurke>
+
+ * batch-driver.scm, build.scm, c-platform.scm, chicken.1, configure.in, csc.bat, csi.scm, eval.scm, scheduler.scm, support.scm, syntax-case.scm:
+ 1099:
+ - Added `-strict-letrec' option to chicken and csi.
+ - Added `##sys#all-threads' to scheduler.scm [Suggested by Joerg Wittenberger].
+
+2003-03-02 flw <flw@gurke>
+
+ * csi.scm, examples/README, examples/makefile, examples/tcp-client.scm, examples/tcp-server.scm, extras.scm, library.scm, makefile.vc, scheduler.scm, tcp.scm, testsuites/test-example.scm, tinyclos.scm, Makefile.am, batch-driver.scm, build.scm, chicken-setup.scm, compiler.scm, configure.in, csc.bat:
+ - The scheduler does a `select()' with infinite timeout, when no other threads are ready or waiting for timeout.
+ - The predicate returned by `condition-predicate' always returns #t or #f.
+ - Added tcp to base system.
+ - Windows batch files were not compiled with uses-declarations for all csi units.
+ - Removed toplevel command `,x1' in csi.
+ - Updated FAQ.html.
+ - Added `-e[mbedded]' to chicken-config and csc.
+ - `with-(input-from|output-to)-(port|string)' are continuation-safe [Thanks to Joerg Wittenberger and Tony Garnock-Jones].
+ - Removed `-no-warnings' option from Makefile.am.
+ - The compiler could not be loaded into csi (missing variable `posix-is-available') [Thanks to Jonah Beckford].
+ - Fixed some problems in the scheduler [Thanks to Joerg Wittenberger].
+ - Fixed a bug in examples/makefile which made linking ctclsh fail [Thanks to Sven Hartrumpf].
+ - Added a fast path in the `dynamic-wind' enabled version of `call-with-current-continuation' that
+ makes it a little bit faster in case no winding thunks are used [Thanks to Joerg Wittenberger].
+
+2003-02-25 flw <flw@gurke>
+
+ * chicken.h, configure.in, csc.bat, csi.scm, eval.scm, examples/makefile, examples/tclAppInit.c, library.scm, makefile.dj, makefile.guilibs, makefile.vc, parameters.scm, runtime.c, scheduler.scm, Makefile.am, batch-driver.scm, build.scm, c-backend.scm, c-platform.scm, chicken-config.in, chicken-setup.scm:
+ - libchicken is now linked to csi as the last library.
+ - Fixed problem(s) in makefile.vc.
+ - Updated manual.
+ - Compiler emits `main()' entry-point as needed.
+ - libembedded-chicken isn't needed anymore.
+ - Renamed `WINDOWS_GUI/_DLL' to `C_WINDOWS_...'.
+ - `CHICKEN_...' procedures have an additional argument: the toplevel entry point procedure pointer.
+ - `tex2page' is now distributed with all the other stuff.
+ - Added `-setup -init' option to csi.
+ - Alternative registry locations.
+ - `##sys#thread-block-for-i/o!' doesn't block if other threads are ready or blocked.
+
+2003-02-18 flw <flw@gurke>
+
+ * parameters.scm, runtime.c, scheduler.scm, srfi-37.scm, support.scm, tinyclos.scm, makefile.dj, makefile.guilibs, makefile.vc, Makefile.am, batch-driver.scm, chicken-setup.scm, configure.in, csc.bat, csi.scm, eval.scm, lolevel.scm:
+ - Moved scheduler into libchicken (instead of libsrfi-chicken)
+ - Scheduler fix that is needed for Winsock
+ - Compiling csi doesn't need ##csi#run prelude anymore
+ - Added TinyCLOS support for tagged pointers [Thanks to Jonah Beckford]
+ - runtime.c: fixed bug in values_continuation() (stack-shift shifted one
+ too many); fixed uninit'd variable bug in C_gc().
+ Valgrind is incredible!
+ - File-extension of dynamically loadable files is system dependent.
+ - Removed serialization stuff. Has to be done better.
+ - The srfi-37 unit doesn't need regex anymore.
+ - Renamed Win32 libraries to match UNIX names.
+ - chicken-setup stuff doesn't print system commands.
+
+2003-02-11 flw <flw@gurke>
+
+ * examples/prolog.scm, Makefile.am, batch-driver.scm, build.scm, c-platform.scm, chicken-setup.scm, chicken.h, chicken.scm, compiler.scm, configure.in, csi.scm, eval.scm, makefile.dj, makefile.guilibs, makefile.vc, match-support.scm, runtime.c, srfi-37.scm, support.scm:
+ - removed old module system
+ - type-checks for fixed-size objects are more efficient
+ - moved srfi-37 into it's own file
+ - separated macro-definitions from support code in match.scm
+ - pattern matcher is now available with highlevel macros
+ - #!-scripts (csi -script or scheme-chicken) use all units available to the interpreter by default
+ - type-error message in `locative->object' reported wrong location
+ - tex2page is now interpreted (simplifies installation)
+ - manual points now to match.ps at call/cc.org (the old site doesn't seem to be available)
+
+2003-02-06 flw <flw@gurke>
+
+ * Makefile.am, build.scm, chicken.h, configure.in, library.scm, runtime.c:
+ - HTML manual wasn't properly generated from CVS version.
+ - added tagged pointer type.
+
+2003-01-31 flw <flw@gurke>
+
+ * Makefile.am, compiler.scm, csc.bat, support.scm:
+ - compressed literals were not written readably into string constant [Thanks to Sven Hartrumpf]
+
+2003-01-29 flw <flw@gurke>
+
+ * library.scm, scheduler.scm, srfi-18.scm, testsuites/test-example.scm, Makefile.am, build.scm, chicken-config.in, configure.in, csc.bat, csi.scm, extras.scm:
+ - chicken-config and csc don't mention -I/usr/local/include anymore
+ - added basic `select()' based scheduling to the threading stuff
+ - moved port-handler cases for #:write-XXX at start of case [Suggested by Joerg Wittenberger]
+ - removed call to ##sys#all-threads from csi.scm
+ - make install generates HTML docs
+ - csc.1 wasn't installed
+ - bumped version to 1090
+
+2003-01-20 flw <flw@gurke>
+
+ * scheduler.scm: - forgot some files (again)
+
+ * Makefile.am, batch-driver.scm, csi.scm, library.scm, makefile.dj, makefile.vc, posix.scm, runtime.c, srfi-18.scm, testsuites/makefile, testsuites/test-example.scm, testsuites/test-lolevel.scm, testsuites/test-r5rs.scm, testsuites/test-test-infrastructure.scm:
+ - definitions in highlevel-macros.scm used `implicit-identifier'
+ (but it's called now `datum->syntax-object')
+ - added `scheme-chicken' scriopt interpreter
+ - compiler knows how to compile scheme-chicken scripts
+ - put scheduler into own library unit
+ - removed optional argument from `set-signal-handler!'
+ - heavily overhauled scheduler
+ - posix: Ctrl-C now only resets primordial thread
+ - applied fix to `system' which could cause a buffer overflow [Thanks to Joerg Wittenberger]
+
+2003-01-15 flw <flw@gurke>
+
+ * Makefile.am, extras.scm, formatprofile.bat, library.scm:
+ - fixed a bug that caused non-ASCII latin-1 characters to be treated as signed, when retrieved
+ from a string [Thanks to Sven Hartrumpf]
+ - `csi -setup' lists installed extensions
+ - removed the `(number-type flonum)' declaration
+ - ##sys#pathname-resolution
+ - added `scheme-chicken' script interpreter
+ - formatprofile uses `scheme-chicken'; added fix by Joerg
+ - `make-output-port' accepts optional flush parameter [thanks to Joerg Wittenberger]
+
+2003-01-11 flw <flw@gurke>
+
+ * testsuites/makefile, testsuites/test-example.scm, build.scm, chicken-setup.scm, chicken.h, compiler.scm, configure.in:
+ - fixed a bug that caused non-ASCII latin-1 characters to be treated as signed, when retrieved
+ from a string [Thanks to Sven Hartrumpf]
+ - `csi -setup' lists installed extensions
+ - removed the `(number-type flonum)' declaration. It's stupid.
+
+2003-01-07 flw <flw@gurke>
+
+ * examples/makefile, psyntax.scm, regex.scm, runtime.c, srfi-18.scm, srfi-25.scm, srfi-4.scm, support.scm, syntax-case.scm, tweaks.scm, Makefile.am, batch-driver.scm, build.scm, c-backend.scm, c-platform.scm, chicken-config.in, chicken-setup.scm, chicken.h, chicken.scm, compiler.scm, configure.in, csc.bat, csi.scm, eval.scm, extras.scm, formatprofile.bat, library.scm, lolevel.scm, optimizer.scm, parameters.scm, posix.scm, profiler.scm:
+ - chicken-config: `--cc' option [suggested by Sven Hartrumpf]
+ - some minor changes to `chicken.h' and `runtime.c' related to the
+ Intel C compiler
+ - fixed some things in examples/makefile
+ - added nursery-size check at toplevel entry
+ - added optional second argument to `compress-literals' declaration
+ (this is used to move the startup-delay for `syntax-case.scm'
+ to macro-system installation time)
+ - `define-inline' and `define-constant' were not correctly handled
+ under the syntax-case macro system, when interpreted
+ - fixed bugs in read-line and read-string [Thanks to Joerg Wittenberger]
+ - changed copyright to 2003
+ - added pathname-resolution hook
+ - removed call to string-copy in `make-output-port' [Joerg, again]
+ - `formatprofile' shows average time per procedure [Joerg, who else]
+
+2002-12-19 psilord <psilord@gurke>
+
+ * test-infrastructure-hygienic.scm: + Whoo boy. I added lots o' stuff!
+ + Changed all of the test macros to insert a unique serial number into
+ each result that can be made. There is a problem with this though,
+ I need a top level define so this means you can only include this
+ file ONCE in any given project. This means that you have to end up
+ compiling your test program with a single compile. No separate
+ compilation for each file. :( I'm thinking on how to solve this.
+ + Added the function output-html-simple. It outputs an evaluated result
+ tree into html. This isn't done quite yet, but it is a large amount of
+ work and I want it to be safe in the repository. It generates pretty
+ decent looking html for the output, but I still have stuff to add.
+ + There is now a statistics function which you can call on a result tree
+ to calculate all sorts of things about the evluated results, like
+ how many things passed/failed, and damn near anything else you'd care to
+ wonder about. This added around 70 calls to the API, but they are simple.
+ Hmm... I might need to add "how many expectations are in this test case"
+ kind of information though.... We'll see. Right now, there is plenty
+ of computed statistics in there that are useful.
+
+2002-12-17 flw <flw@gurke>
+
+ * Makefile.am, batch-driver.scm, compiler.scm, extras.scm:
+ - `read-line' should now handle CRLF transparently [Thanks to Joerg Wittenberger]
+ - removed `extend-csi' and `extend-chicken' scripts
+ - `let-optionals' and `define-entry-point' are now available under the hygienic macro system
+ - removed `define-integrable', `define-datatype', `record-case' and `cases'
+ - `user-post-analyis-pass'
+
+2002-12-15 psilord <psilord@gurke>
+
+ * test-infrastructure-hygienic.scm:
+ + Changed the undocumented name of the statistics creator function.
+ + Added a global unique identifier creation function and subsequent
+ invocation of it so I can have unique serial numbers for all results.
+ + I have not yet modified the result object construction code to use the
+ serial numbers yet, since I need some questions resolved about how
+ chicken interacts with seperate compilation and (include ...) with
+ toplevel definitions.
+
+ * testsuites/test-lolevel.scm, testsuites/test-r5rs.scm, testsuites/test-test-infrastructure.scm, testsuites/test-example.scm:
+ + Changed the use of output-style-human to output-style-human-simple.
+
+ * test-infrastructure-hygienic.scm:
+ + Changed the name of the output-style-human API call to
+ output-style-human-simple.
+ + Added *-warning? Which checks to see if a warning is active on any kind of
+ a valid result object.
+ + Added a statistics system(and subsequent API to be detailed in the manual)
+ which counts up all sorts of relavant information in a result tree and
+ plances it into a statistics object which a large API has been built
+ to manipulate. I'm not fully done with this yet, but it is such a large
+ amount of detailed work, that I want to check it in to keep it safe. :)
+
+2002-12-14 flw <flw@gurke>
+
+ * psyntax-bootstrap.scm, psyntax.pp, psyntax.scm:
+ forgot some files, naturally
+
+2002-12-13 flw <flw@gurke>
+
+ * Makefile.am, batch-driver.scm, build.scm, c-platform.scm, chicken.1, compiler.scm, configure.in, csc.bat, eval.scm, library.scm, makefile.dj, makefile.guilibs, makefile.vc, parameters.scm, support.scm, syntax-case.scm:
+ - we now use a more up-to-date version of Chez' portable
+ syntax-case implementation.
+ - special compile-handling of `error' accepts now an optional
+ location as first argument.
+ - Steve Elkins confirmed successfull build on OpenBSD.
+ - library units syntax-case and modules are not compiled unsafe
+ (for libuchicken.*).
+ - Compiler-option `-compress-literals' and equivalent declaration.
+ - `(chicken-version)'.
+
+2002-12-11 psilord <psilord@gurke>
+
+ * test-infrastructure-hygienic.scm:
+ + Added the macro (side-effect ...) which evaluates a set of arguments in
+ a (begin ...) form and then returns the ignore-result result. This
+ allows you to set up complicated situations for expectations where
+ you might just want to secretly do a lot of work and then perform several
+ expectations.
+
+2002-12-09 psilord <psilord@gurke>
+
+ * test-infrastructure-hygienic.scm:
+ + Changed the name of a few functions that were undocumented, but I wanted to
+ document them. The names they originally had were not really meaningful.
+
+2002-12-08 flw <flw@gurke>
+
+ * build.scm, c-backend.scm, c-platform.scm, chicken-setup.scm, chicken.h, configure.in, csi.scm, eval.scm, examples/mandelbrot.scm, lolevel.scm, posix.scm, runtime.c, srfi-1.scm:
+ - fixed bug in `chicken-setup.scm': the access-check for the
+ REGISTRY file is now done on the directory.
+ - srfi-1.scm: `proper-list?' is now an alias for `list?'
+ - fixed mean bug in a literal-frame allocation handling: pointer
+ to nursery-allocated symbols, when re-interned and written into
+ a literal-frame circumvented the write-barrier.
+ [Thanks to Joerg Wittenberger for providing sample code]
+ - all places where BSD-specific stuff were used, now check
+ for Open BSD, too. Additionally, RTLD_GLOBAL is defined as 0.
+ [Thanks to Steve Elkins]
+ - removed unused definitions from `examples/mandelbrot.scm'.
+ [Thanks to Sven Hartrumpf]
+ - the way `let' was handled in the evaluator limited the number
+ of bindings to 128 on non-x86 hardware.
+ [Thanks to Dorai Sitaram]
+
+2002-12-08 psilord <psilord@gurke>
+
+ * test-infrastructure-hygienic.scm:
+ + Hid all of the functions I don't want people to use with the prefix
+ 'test:'.
+ + Need to document some API functions I left for people to use.
+
+2002-12-07 psilord <psilord@gurke>
+
+ * Makefile.am:
+ + Added the new test-infrastructure*.scm files to be installed with the
+ loader file in the place where they get installed. :)
+
+ * test-infrastructure-hygienic-local.scm: + Initial revision
+ + This file will contain any implementation specific testing infrastructure
+ code you'd like (for example signal handling expectations) written in the
+ hygienic R5RS macro style. Since it is local to the implementation,
+ you may use implementation specific code in here.
+
+ * test-infrastructure-hygienic.scm:
+ + The code in this file used to be in test-infrastructure.scm. Please
+ look there from 1.16 to 1.1 to see the previous history. That file
+ is now a simple implementation specific loader of the testing
+ infrastructure code.
+ + The code was moved into this file to be as portable as possible and it
+ shall stay as close to R5RS as possible. Any implementation specific
+ mumbo jumbo you'd like to add to the testing infrastructure (example,
+ signal handling expectations), you should add into the corresponding
+ *-local.scm files. Also, the common/base R5RS hygienic macro definition
+ in this file is considered cannon, and the lowlevel macro implementation
+ should always follow what is in this file.
+ + Fixed a bug where printnl was using a non-R5RS function causing a
+ non-portability problem.
+ + Fixed a bug where I typoed a function reference for
+ (terminate-result-result-ref ...)
+
+ * test-infrastructure-lowlevel-local.scm: + Initial revision
+ + This file contains implementation specific test infrastructure code
+ written using low level macros.
+
+ * test-infrastructure.scm:
+ + moved all code in here into test-infrastructure-hygienic.scm
+ + this file is now a simple implementation specific loader that loads either
+ the hygienic or the low level macro version of the test common/base
+ test-infrastructure code plus the test infrastructure code specific
+ to this implementation.
+
+ * test-infrastructure-lowlevel.scm: + Initial revision
+ + This file will contain the low level translation of the common/base
+ hygienic test infrastructure macros.
+
+2002-12-04 psilord <psilord@gurke>
+
+ * test-infrastructure.scm:
+ + Updated my copyright to be a bit more clear on something.
+
+2002-12-02 flw <flw@gurke>
+
+ * Makefile.am, build.scm, chicken-setup.scm, configure.in, csc.bat, csi.scm, extras.scm, formatprofile.bat, lolevel.scm, posix.scm, test-infrastructure.scm:
+ - `flatten' didn't handle empty lists properly
+ - location-stuff has own subsection in manual
+ - Arguments to csc's -C and -L options are split at whitespace
+ - more pointer operations
+ - the index argument to `make-locative' is optional
+ - formatprofile defaults to PROFILE, if no filename is given
+ - `csi -setup' without further arguments initializes the registry
+ - chicken-setup: build didn't restore state on failure
+ - removed non-R5RS stuff from test-infrastructure.scm
+ - posix.scm: `file-XXXX-access?' was broken
+ - `csi -setup' tests write-permission for registry directory
+
+2002-11-25 flw <flw@gurke>
+
+ * chicken-setup.scm, csc.bat, csi.scm, eval.scm, examples/ctclsh.scm, extras.scm, format.scm, library.scm, regex.scm, srfi-18.scm, srfi-25.scm, c-backend.scm:
+ - removed most of the string-utilities from `extras.scm'
+ - fixed bug in `make-mutex'
+ - removed `mutex-owner'
+ - fixed some unbound-variable errors in several library files
+ - precompiled regexp's
+
+2002-11-25 psilord <psilord@gurke>
+
+ * test-infrastructure.scm:
+ + Wrote a destructor object API to wrap the message passing interface to the
+ destructor object. I did this to keep it more consistant with the
+ rest of the test-infrastructure APIs, and also, it now allow sme more
+ freedom is manipulating the destructor object API and keeping it backwards
+ compatible. Eventually, I was to be able to specify nicely the
+ queued function calls so debugging information is much cleaner, and maybe
+ I want to play with the result type of the destructor object instead
+ if having it be the ignore type all of the time.
+ + Recasted the activation of the destructor object to use the new interface.
+
+2002-11-12 flw <flw@gurke>
+
+ * library.scm, lolevel.scm: - `copy' maintains uniqueness of symbols
+ - `define-record-printer' works with SRFI-9 records
+ - fixed bug in `define-record-printer' macro
+
+ * batch-driver.scm, build.scm, c-platform.scm, configure.in, csc.bat, csi.scm, library.scm, runtime.c, srfi-18.scm, support.scm:
+ - fixed bug in `seconds->time' [Thanks to Joerg Wittenberger]
+ - Added alternative keyword styles
+
+2002-11-11 psilord <psilord@gurke>
+
+ * Makefile.am:
+ + c_defaults.h wasn't being generated correctly. It didn't have newlines
+ where newlines were expected. I fixed it.
+
+2002-11-09 flw <flw@gurke>
+
+ * Makefile.am, chicken-setup.scm, configure.in, csi.scm, extras.scm, runtime.c, srfi-18.scm, test-infrastructure.scm, testsuites/makefile, testsuites/test-example.scm, testsuites/test-r5rs.scm, testsuites/test-test-infrastructure.scm:
+ - chicken-setup.scm: `uninstall-extension!' accepts single symbol as argument
+ - Fixed arity-bug in `string-map' (extras.scm)
+ - `hash-table->list'
+ - `make-mutex' wasn't adapted to final SRFI spec [Thanks to Joerg Wittenberger]
+ - Adapted uses of AC_DEFINE in `configure.in' to new autoconf version
+
+2002-11-06 psilord <psilord@gurke>
+
+ * test-infrastructure.scm:
+ + Changed the warning API to reference warnings in the result objects
+ as it is presented to the user cause the old way was stupid. Now
+ it is much more consistant.
+ + Fixed up some comments to be more correct.
+ + Once I changed the warning API, I had to fix output-style-human to reflect
+ the new API design. Much better in my opinion....
+
+2002-10-31 psilord <psilord@gurke>
+
+ * test-infrastructure.scm:
+ + Added the (skip ...) macro which allows you to skip an expectation, test
+ package or test case at your leisure.
+ + fixed up some comments.
+
+2002-10-30 psilord <psilord@gurke>
+
+ * testsuites/test-r5rs.scm:
+ + Added the beginnings of chapter 6 from the R5RS handbook. Eventually,
+ I'll add everything out of it. Mu goal is to implement as much of the
+ R5RS spec as possible using my test infrastructure.
+
+ * test-infrastructure.scm: + Added todo-result and gloss-result.
+ + todo-result is a message that says something needs to be done.
+ + gloss-result is strictly information to be processed by the user in
+ any way desired. Usually it is a string that is printed out explaining
+ some comments about something that is different than a warning.
+ + Changed the output-style-human function to output things in a better fashion.
+ + TODO Need to add the skip macro to be able to skip tests.
+
+2002-10-29 psilord <psilord@gurke>
+
+ * test-infrastructure.scm: + Added some stuff to my copyright.
+ + Fixed the debugging output of the output-style-human function so when it
+ encounters something it doesn't know how to parse, it emits the object
+ itself in the debug message.
+
+ * testsuites/test-r5rs.scm, testsuites/test-test-infrastructure.scm, testsuites/makefile, testsuites/test-example.scm, testsuites/test-lolevel.scm:
+ + fixed the test suite to use the new world order.
+
+ * test-infrastructure.scm:
+ + Fixed the comments about test-cases and test-packages.
+ + Removed some defunct code.
+ + Moved some code around for better organization.
+
+2002-10-28 flw <flw@gurke>
+
+ * Makefile.am, batch-driver.scm, build.scm, chicken-setup.scm, chicken.h, compiler.scm, configure.in, csc.bat, csi.scm, lolevel.scm, makefile.dj, makefile.vc, runtime.c, srfi-18.scm:
+ - `current-time' (srfi-18.scm) returns something more useful
+ - fixed bug in `make-executable-byte-vector' and `make-static-byte-vector':
+ the allocated block was of insufficient size [Thanks to Peter Keller]
+ - simplified the use of preprocessor-symbols with respect to `c_defaults.h'
+ - `-strict[-srfi-0]' didn't work correctly
+ - `csc.bat' is generated from `csc.in'
+
+2002-10-28 psilord <psilord@gurke>
+
+ * testsuites/test-example.scm: + Added some comments.
+
+ * testsuites/makefile: + Added test-example.scm
+ + Commented out all tests except for the example test. I need to convert the
+ other tests into the new world order of the testing infrastructure.
+
+ * testsuites/test-example.scm: + initial revision
+ + A small example of the test-infrastructure code so people can have a
+ starting point with which to write their own test using the system.
+
+ * test-infrastructure.scm:
+ + Added a simple output-style for human readable output of the result tree.
+ The modus opreandi for handling a result tree is to write a recursive
+ analysis procedure to manipulate it in any way you desire. It can
+ print out output, or calculate percentage failure, or do any other
+ computation you desire.
+ + Some Experimetnal API calls exist for the output-style-human function.
+ I don't know what I'm going to do with those quite yet.
+ + Added the warning syntax to all of the expectations(except the exception
+ handling test-cases, I haven't even touched those yet).
+ XXX I think you need another type to specially handle the exception
+ results.
+ + Renamed the escape-result and associated APIs to a terminate result since
+ that is closer to what it actually means.
+ + Fixed a lot of busted API calls to deal with the various result types.
+ + Added a user invoked terminate function which you pass a continuation
+ escpe fucntion and a message that all gets transformed into a terminate
+ result type in the test package or test case you are in. You may pass
+ _any_ escape function in your lexical scope.
+ + Added an "ignore-result" type which is extremely transient, and not
+ creatable by a user directly. It is meant to capture the return values
+ of the destructor object during its use. These are stripped out of the
+ result trees and are unobservable by the user. Some of the internal
+ evaluation functions for the cases/packages and expectations
+ silently process the ignored values and well, ignore them. :)
+ + Added the warning syntax to the test case and test package macros.
+ + Fixed it test case/package macros to always activate the destructor object,
+ strip ignored results, and build termination events when they happen
+ automatically.
+ + Got rid of the true/false macros. I didn't like them.
+ + Whenever you use the destructor, it creates a temporary ignore-result
+ type which immediatly gets eaten when it comes time to process that
+ particular result tree. I decided it wasn't in my best interest to
+ use the #<unspecifed> system here.
+ + Added my copyright for this code, and a small paragraph explaining that
+ you can use it for whatever you desire, but my name stays attached to
+ it.
+
+2002-10-26 psilord <psilord@gurke>
+
+ * test-infrastructure.scm:
+ + Totally revamped the escape procedure handling. Now, when an escape
+ procedure is called, you get an "escape-result" in the
+ returned tree. I'm toying with being able to specify
+ a format you return so that you can give back diagnostic
+ messages. Already it automatically remembers the context you were
+ in package/test-case wise, but not expectation-wise(it can't,
+ in fact--well, it could... and maybe it will some day). I removed
+ the destructor-result object I had before cause it was dumb and
+ didn't model the real concept I wanted.
+ + Added a warning syntax so when you make a test case or a test package
+ you can(optionally) have it embed a warning object into the
+ returned result list to be parsed later by the tree analysis
+ code the user writes. I need to add this functionality to the
+ test-package macro(though the underlying support code for that
+ macro understands it already) and for all of the expectations. The
+ use of this is to mention things like chicken expects this answer
+ when the r5rs handbook says to give that answer. Stuff like that.
+ + Cleaned up some code I fat fingered because I usually write this stuff
+ at 2am.
+ + This is still not ready for prime time, but it is comming very close.
+
+2002-10-25 psilord <psilord@gurke>
+
+ * test-infrastructure.scm:
+ + fixed a bug in evaled-package-results-true where if it was passed the empty
+ list it would return true.
+
+ * test-infrastructure.scm:
+ + I've made serious changes to the internals of this code and until I update
+ the test suites that use this code, they will all break. What I have
+ currently appears to work and so I'm checking it in so I don't lose it
+ through mistake or anything like that. The lowlevel macros definitely
+ need to be redone, and I haven't attempted that yet. To felix, who
+ is prolly reading this, don't do the conversion yet until I say cause
+ a few things still need fixing.
+ + I've made it so that a test package can have multiple test cases or
+ test-packages inside it ad infinitum.
+ + Now all tests return a huge tree that represents all of the results
+ of the tests(along with the unevaluated expectations) and user
+ supplied information for the tests. This causes a separation of
+ output generation/analysis with the evaluation of the expectations.
+ Now you can retarget output generation to be human readable or html
+ or whatever you want.
+ + TODO: add new macro definitions for the "warning" style expectations,
+ packages, and test cases.
+ + I added a ton of API calls to deal with the generated result tree and the
+ various result types encapsulated in the tree. All of this, plus how
+ to use everything needs documentation.
+
+2002-10-21 flw <flw@gurke>
+
+ * testsuites/test-lolevel.scm, testsuites/test-test-infrastructure.scm:
+ - added some testing code
+
+ * test-infrastructure.scm, testsuites/makefile, Makefile.am, csc.bat, csi.scm, extras.scm, lolevel.scm, runtime.c:
+ - fixed some escaped characters in verbatim sections of the manual
+ - ",d <locative>" didn't show anything useful in csi
+ - `make-locative' didn't accept byte-vectors
+ - `pretty-print' didn't handle eof-object (and crashed!)
+ - `(##sys#fudge 16)' returned heavily overflowed values
+ [Thanks to Joerg Wittenberger]
+ - made some minor modifications to `test-infrastructure.scm'
+ - cleaned up the manual
+ - removed #include of `varargs.h' (pseudo-Solaris fix)
+
+2002-10-12 flw <flw@gurke>
+
+ * Makefile.am, autocvs, chicken-setup.scm, chicken.spec.in, test-infrastructure.scm, testsuites/makefile, testsuites/test-r5rs.scm:
+ - added example for `define-external' to manual
+ - added `-build' stage to chicken-setup
+ - updated version of autoconf/automake/libtool-generated files
+ - added test-infrastructure.scm to distribution tarball
+ - removed acinclude.m4 and stamp.h-in from distribution
+ - makefile in testsuites compiles and runs all tests
+
+2002-10-09 flw <flw@gurke>
+
+ * Makefile.am, build.scm, c-backend.scm, c-platform.scm, chicken-setup.1, chicken-setup.scm, chicken.h, compiler.scm, configure.in, eval.scm, library.scm, lolevel.scm, optimizer.scm, posix.scm, runtime.c, support.scm, tinyclos.scm:
+ - Invocation of `csc' in `chicken-setup' uses full path.
+ - Foreign procedure accept pointer-like objects were pointers
+ were previously required (allows locatives as pointer arguments).
+ - Type-check routines for foreign arguments generate better code.
+ - Some locative-related routines are inlined.
+ - An invalid foreign type could crash the compiler.
+ - Result-size compuation for access to foreign data had some 32-bit
+ dependencies.
+ - `define-location' and `let-location', renamed `external-pointer' to `location'.
+ - Allocation for foreign-results is done in-line.
+ - Renamed module `ffi' to `chicken-ffi'.
+
+2002-10-06 psilord <psilord@gurke>
+
+ * testsuites/test-r5rs.scm:
+ + the test package macros return a vector of results, so I fixed up
+ the use of the test package that had been implemented.
+ + Changed the include of the infrastructure to a require of it since it is now
+ in the distribution proper.
+
+2002-10-05 psilord <psilord@gurke>
+
+ * Makefile.am:
+ + Added test-infrastructure.scm into the install procedure so this file
+ is placed into the correct install place like moremacros.scm is.
+ + You may now (require 'test-infrastructure) to gain the ability to use this
+ feature, but you MUST be using hygienic macros.
+ + As soon as I figure out where to document it, I'll do it.
+ + I still need to have a lowlevel macro translation of this file so people
+ can use it without r5rs macros. However, I've barely used lowlevel
+ macros, so it is going to take a while to perform the port while I
+ figure everything out.
+
+2002-10-02 flw <flw@gurke>
+
+ * LICENSE: moved LICENSE into doc directory
+
+ * Makefile.am, README, README.CVS, autocvs, runtime.c:
+ - Fixed bug in heap-resizing routine [Thanks to Benedikt Rosenau]
+ - Fixed several bugs in the manual [Thanks to Sven Hartrumpf and Benedikt Rosenau]
+ - Moved some documentation files into doc directory
+
+2002-09-29 flw <flw@gurke>
+
+ * Makefile.am, README, batch-driver.scm, c-platform.scm, chicken-setup.scm, chicken.h, compiler.scm, configure.in, csc.bat, csi.scm, extras.scm, library.scm, lolevel.scm, runtime.c, srfi-25.scm:
+ - fixed bug in `csc.bat' (wrong spelling of `library-extension')
+ - fixed bug in `compiler.scm': `compile-time-macros-only' declaration set
+ wrong variable
+ - `chicken-setup --wrap <file>.scm' works without .setup file
+ - `arithmetic-shift' generates better code with a known second argument
+ - locatives
+ - `->string'
+ - SRFI-26
+ - `chicken-setup' macro and `-setup' option for csi
+ - the extension-registry is created automatically
+
+2002-09-19 surazal <surazal@gurke>
+
+ * chicken-setup.scm:
+ Ensure that .setup files are canonicalized before output, even where
+ there was no existing file.
+
+2002-09-17 flw <flw@gurke>
+
+ * Makefile.am, README, c-platform.scm, chicken-setup.scm, chicken.h, csi.scm, posix.scm, runtime.c, tinyclos.scm:
+ - `-:r' runtime option
+ - `##sys#immediate?' and `arithmetic-shift' are rewritten to non-CPS calls
+ - did some minor tweaks in `tinyclos.scm'
+ - `C_fix()' used cast to unsigned word
+ - fixed bug in `quit' procedure in `chicken-setup'
+ - `posix' wasn't provided by csi
+ - added `sleep' to `posix.scm'
+ - added Debian-specific `Makefile.am' [Thanks to Joerg Wittenberger]
+ - `manual.tex' has updated build-number [Thanks to Sven Hartrumpf]
+ - fixed bug in `script-utils.scm': a local version of `regex-case' was required
+ [Thanks to Tony Garnock-Jones]
+
+2002-09-17 psilord <psilord@gurke>
+
+ * testsuites/test-r5rs.scm:
+ + Changed include to get infrastructure from toplevel directory
+
+ * testsuites/test-r5rs.scm:
+ initial revision of an R5RS test suite tailored to Chicken
+
+ * test-infrastructure.scm:
+ Initial Revision of part of the test suite code for chicken.
+
+2002-09-13 flw <flw@gurke>
+
+ * Makefile.am, README, build.scm, c-backend.scm, chicken.h, configure.in, csc.bat, csi.scm, library.scm, makefile.vc, srfi-1.scm, srfi-25.scm, support.scm:
+ - fixed bug in `srfi-1.scm' [Thanks to Vladimir Tsichevski]
+ - fixed bug in `support.scm': "nonnull-..." byte-vector types weren't properly handled
+ - code generated for foreign-callback lambdas uses prefixed names for some
+ arguments to avoid collisions with user variables
+ - `csc.bat' treats .lib files like .obj files
+ - `makefile.vc' is able to bootstrap the system from sources
+ - fixed minor bug in `Makefile.am': some docs had wrong paths
+ - fixed bug in `gc': no-argument case invoked wrong GC method
+ - fixed bug in `csi.scm': `,du' interpreter command crashed on immediate objects [Thanks to Benedikt Rosenau]
+ - error-location printed wasn't properly qualified
+
+2002-09-09 flw <flw@gurke>
+
+ * chicken-setup.scm, chicken.1, extras.scm:
+ - chicken-setup: minor fixes, removed `test-run', added some properties
+ - added chicken-setup example to manual
+ - `constantly' accepts multiple arguments
+ - removed manual.html
+
+2002-09-05 flw <flw@gurke>
+
+ * chicken-setup.scm, eval.scm: - `require' handles 'file property, now
+
+2002-09-04 surazal <surazal@gurke>
+
+ * chicken-setup.scm:
+ Base the .so name in chicken-setup on the (file) attribute, rather than
+ the name of the package
+
+2002-09-04 flw <flw@gurke>
+
+ * chicken-setup.scm, tinyclos.scm: - more chicken-setup fixes
+
+2002-09-04 surazal <surazal@gurke>
+
+ * chicken-setup.scm: Change test-compile:
+ - support #:cflags <list> (default ())
+ - support #:ldflags <list> (default ())
+ - support #:compile-only <boolean> (default #f)
+
+ * chicken-setup.scm: Remove offending tilde.
+
+2002-09-03 flw <flw@gurke>
+
+ * Makefile.am, README, chicken-setup.scm, csc.bat, csi.scm, library.scm:
+ - #:srfi-30 wasn't properly registered
+ - several fixes in `chicken-setup.in'
+ - added setup-property `when'; `make' now allows an arbitrary expression
+ - `chicken-setup' is now compiled to a binary
+
+2002-09-02 flw <flw@gurke>
+
+ * Makefile.am, eval.scm, library.scm, support.scm:
+ - stacktrace/runtime error message shows offending source file
+ - removed `regex-case' (will be put into extension library)
+ - fixed problem in `Makefile.am': manual pages weren't found (moved them back into toplevel dir)
+ - added feature-id for SRFI-30
+ - fixed bug in handling of `--define' option in `chicken-setup.in'
+ - fixed another problem in `chicken-setup.in' related to core-extensions
+ - 'open-[input|output]-file' didn't show location in error-message
+
+2002-08-31 flw <flw@gurke>
+
+ * compiler.scm, eval.scm, extras.scm, optimizer.scm, runtime.c:
+ - fixed bug in runtime.c (`C_set_host_data')
+ - unexported, unused globals in files with an `export' declaration weren't removed
+ - `csc' passed `-feature chicken-compile-shared' instead of `-feature csc-compile-shared'
+ - `(random 0)' resulted in div-by-zero
+ - added `compile-time-macros-only' declaration
+ - error in macro-expansion shows macro
+ - chicken-setup: several changes - should now work better with macros at extension build-time
+
+2002-08-30 surazal <surazal@gurke>
+
+ * Makefile.am: Unstomp quoting fixes :-)
+
+2002-08-27 flw <flw@gurke>
+
+ * README, build.scm, c-platform.scm, chicken.h, configure.in, csi.scm, eval.scm, extras.scm, library.scm, lolevel.scm, posix.scm, regex.scm, runtime.c, srfi-1.scm, srfi-13.scm, srfi-14.scm, srfi-18.scm, srfi-4.scm, support.scm, syntax-case.scm:
+ - fixed bug in statistics-code (`-debug s') [Thanks to Benedikt Rosenau]
+ - improved error-messages (location is shown more often)
+ - fixed bug in `define-entry-point'
+ - chicken-setup: repeated compile checks file-modification time
+
+2002-08-25 flw <flw@gurke>
+
+ * FAQ.html, Makefile.am, chicken-config.in, format.txt:
+ - added separate `doc' directory
+
+2002-08-24 flw <flw@gurke>
+
+ * Makefile.am, chicken.h, compiler.scm, csi.scm, eval.scm, examples/mandelbrot.scm, extras.scm, library.scm, lolevel.scm, posix.scm, regex.scm, runtime.c, srfi-1.scm, srfi-13.scm, srfi-14.scm, srfi-18.scm, srfi-25.scm, srfi-4.scm, tinyclos.scm:
+ - fixes some errors in `moremacros.scm' and `chicken-setup.in'.
+ - removed `define-foreign-parameter'
+ - added `manual.tex'
+ - better error-messages
+
+2002-08-24 surazal <surazal@gurke>
+
+ * Makefile.am, chicken-config.in:
+ Add an extra layer of quoting so that our CFLAGS get passed through
+ the various programs properly.
+
+2002-08-17 flw <flw@gurke>
+
+ * csc.bat: - fixed minor bug in `csc.in'/`csc.bat'
+
+2002-08-16 flw <flw@gurke>
+
+ * Makefile.am, autocvs, chicken.scm, csc.bat, eval.scm:
+ - csc: options `-X' and `-H2'
+ - autocvs: no generation of README.txt and ChangeLog
+ - fixed some REGISTRY-related bugs
+
+2002-08-16 surazal <surazal@gurke>
+
+ * autocvs:
+ Copy, rather than symlink, mkinstalldirs/install-sh/missing etc
+
+2002-08-15 surazal <surazal@gurke>
+
+ * configure.in: Added check for -ldld for HPUX shl_load.
+
+ * autocvs: Autogenerate README.txt from README when you run autocvs.
+ It's either that, or have an empty README.txt (touch README.txt) or remove
+ README.txt from DOCFILES in Makefile.am. Or something else :-)
+
+2002-08-14 flw <flw@gurke>
+
+ * Makefile.am, README, build.scm, configure.in, csi.scm, eval.scm, lolevel.scm:
+ - Makefile.am should be pmake-ready, now
+ - Added `--init' to `chicken-setup'
+ - `require' should now worl properly
+
+2002-08-14 surazal <surazal@gurke>
+
+ * configure.in, runtime.c:
+ Use shl_load/shl_findsym on HP-UX instead of dlopen/dlsym.
+
+2002-08-13 flw <flw@gurke>
+
+ * chicken-setup.1: - added `REGISTRY' and `chicken-setup.1'
+
+ * FAQ.html, Makefile.am, README, c-platform.scm, chicken-config.in, csi.scm, eval.scm, library.scm, makefile.dj, makefile.vc, parameters.scm:
+ - `require' and friends have been revamped
+ - Fixed bug in `csi.scm': `untrace' referenced hidden variable `##sys#delq'
+ [Thanks to Panagiotis Vossos]
+ - Fixed bug in `c-platforms.scm': rewriting rule for `gc' has been removed
+
+2002-08-12 surazal <surazal@gurke>
+
+ * Makefile.am, autocvs:
+ Remove README.txt from DOCFILES in Makefile.am; touch ChangeLog in autocvs
+
+2002-08-09 flw <flw@gurke>
+
+ * csi.scm, library.scm, srfi-18.scm: - `(gc #t) forces finalizers.
+ - Documented `hash-table-remove!'
+ - Time-related stuff in `srfi-18.scm' uses wall-clock time instead of
+ CPU time
+
+2002-08-09 surazal <surazal@gurke>
+
+ * extras.scm: Added hash-table-remove!.
+
+2002-08-06 surazal <surazal@gurke>
+
+ * README.CVS: Restore README.CVS from v1.2
+
+2002-08-05 flw <flw@gurke>
+
+ * README, README.CVS, batch-driver.scm, build.scm, chicken-config.in, compiler.scm, configure.in, csc.bat, csi.scm, extras.scm, optimizer.scm, posix.scm, srfi-1.scm, support.scm:
+ some bugfixes, some enhancments, `export' declaration
+
+2002-08-04 surazal <surazal@gurke>
+
+ * autocvs:
+ Mention libtoolize explicitly when running autoconf/automake/etc to
+ avoid warnings. (Panagiotis Vossos)
+
+ * Makefile.am, chicken-config.in:
+ chicken-config now supports "-prefix" argument.
+
+2002-08-01 surazal <surazal@gurke>
+
+ * README.CVS: Spell out multi-stage bootstrap procedure.
+
+ * README.CVS: Initial commit of CVS Chicken bootstrapping instructions.
+
+ * batch-driver.scm, c-platform.scm, chicken.1, compiler.scm, support.scm:
+ (felix) Real-name-table and Line-number-database added
+
+ * README, build.scm, configure.in:
+ (felix) Version number bumped to 1072.
+
+ * examples/tclAppInit.c: RCS Id keyword removed.
+
+ * FAQ.html, INSTALL, LICENSE, Makefile.am, README, autocvs, batch-driver.scm, build.scm, c-backend.scm, c-platform.scm, chicken-config.1, chicken-config.in, chicken.1, chicken.h, chicken.ico, chicken.rc, chicken.scm, chicken.spec.in, compiler.scm, configure.in, csc.1, csc.bat, csi.1, csi.scm, csibatch.bat, eval.scm, examples/README, examples/calendar.scm, examples/ctclsh.scm, examples/eval-client.c, examples/eval-server.scm, examples/hellowin.scm, examples/makefile, examples/makefile.vc, examples/mandelbrot.scm, examples/mmcp.scm, examples/nqueens.prolog, examples/prolog.scm, examples/schelog-macros.scm, examples/schelog-support.scm, examples/tclAppInit.c, examples/x11cplot.c, examples/x11cplot.h, extras.scm, format.scm, format.txt, formatprofile.bat, library.scm, lolevel.scm, makefile.dj, makefile.guilibs, makefile.vc, nsample.scm, optimizer.scm, parameters.scm, posix.scm, profiler.scm, regex.scm, runtime.c, srfi-1.scm, srfi-13-syntax.scm, srfi-13.scm, srfi-14.scm, srfi-18.scm, srfi-25.scm, srfi-4.scm, support.scm, syntax-case.scm, tinyclos.scm, tweaks.scm:
+ Initial commit: 1071 + partway toward 1072 + cleanup + removed .c files
+
diff --git a/ChangeLog.20070807 b/ChangeLog.20070807
new file mode 100644
index 00000000..b74f38b2
--- /dev/null
+++ b/ChangeLog.20070807
@@ -0,0 +1,5272 @@
+Tue Aug 7 09:39:40 CEST 2007 fw@emlix.com
+ * some attempts at cmake support for apply-hack. Naturally, it doesn't work.
+
+Tue Aug 7 08:05:36 CEST 2007 fw@emlix.com
+ * fixed bug in x86 check in configure.in
+
+Tue Aug 7 07:46:57 CEST 2007 fw@emlix.com
+ * apply-hack.s symlink used in autotools build
+
+Mon Aug 6 13:20:05 CEST 2007 felix@call-with-current-continuation.org
+ * added maketexi.scm (from stream-wiki branch, written by Ivan Raikov)
+
+Mon Aug 6 08:56:46 CEST 2007 felix@call-with-current-continuation.org
+ * - removed mingw stuff from autotools build
+ - "unix" is software-type for *BSD
+ - chicken-build fixes for *BSD
+
+Thu Aug 2 15:31:55 CEST 2007 felix@call-with-current-continuation.org
+ * - changed snapshot link in index.html
+
+
+Tue Aug 7 07:38:22 CEST 2007 fw@emlix.com
+ * improved feature list output, in csi ",r" command; more apply-hack support in build files, removed remnants of libffi
+
+Mon Aug 6 01:28:25 CEST 2007 felix@call-with-current-continuation.org
+ * autotools apply hack, still not quite right, as automake is too thick to allow computed _SOURCES
+
+Mon Aug 6 01:19:01 CEST 2007 felix@call-with-current-continuation.orgh
+ * fixed bug in CMakeLists.txt
+
+Mon Aug 6 01:15:21 CEST 2007 felix@call-with-current-continuation.org
+ * removed .spec file stuff, CMake apply hack support started
+
+Mon Aug 6 00:59:13 CEST 2007 felix@call-with-current-continuation.org
+ * - apply-hack for ppc works
+ - first attemt at autotool build support for apply-hack
+ - improved feature list display in csi's ",r" command
+
+Sun Aug 5 01:05:29 CEST 2007 felix@call-with-current-continuation.org
+ * - reorganized apply-hack macros
+ - ppc apply hack is nearly running, but not quite...
+
+Fri Aug 3 14:09:09 CEST 2007 fw@emlix.com
+ * x86-64 apply hack still won't work
+
+Fri Aug 3 13:27:50 CEST 2007 fw@emlix.com
+ * working on x86-64 apply hack
+
+Fri Aug 3 10:32:02 CEST 2007 fw@emlix.com
+ * first try at x86-64 apply hack
+
+Fri Aug 3 07:41:29 CEST 2007 fw@emlix.com
+ * fixed handling of apply-hack in chicken-build, manyargs feature id, apply-hack works for x86
+
+Thu Aug 2 22:09:05 CEST 2007 felix@call-with-current-continuation.org
+ * tiny chicken-build change
+
+Thu Aug 2 22:04:08 CEST 2007 felix@call-with-current-continuation.org
+ * C_do_apply_hack was not exported
+
+Thu Aug 2 21:56:00 CEST 2007 felix@call-with-current-continuation.org
+ * more eyecandy in build.scm, removed libffi support, cleaned up handling of apply-hack in chicken-build.scm
+
+Thu Aug 2 15:30:04 CEST 2007 fw@emlix.com
+ * added initial version of assembler apply hack, some basic untested chicken-build support
+
+Wed Aug 1 13:41:40 CEST 2007 fw@emlix.com
+ * fixed dependencies in dist target for chicken-build
+
+Wed Aug 1 13:30:21 CEST 2007 felix@call-with-current-continuation.org
+ * - chicken-build: dist target only depends on C sources
+
+
+Wed Aug 1 08:40:40 CEST 2007 felix@call-with-current-continuation.org
+ * - tcp: added connect/accept timeouts
+
+Tue Jul 31 16:49:53 CEST 2007 felix@call-with-current-continuation.org
+ * - chicken-build.scm: added "release" target, simplified "dist"
+
+Tue Jul 31 16:40:52 CEST 2007 felix@call-with-current-continuation.org
+ * - tcp: fixed bug in ##sys#check-exact macro
+
+Tue Jul 31 13:23:08 CEST 2007 felix@call-with-current-continuation.org
+ * - version is 2.634
+
+Sun Jul 29 22:43:41 CEST 2007 felix@call-with-current-continuation.org
+ * - "file-select": didn't unfix timeout val in fixnum case
+ - reduced trace buffer default size to 8
+
+Sun Jul 29 22:13:48 CEST 2007 felix@call-with-current-continuation.org
+ * - "file-select" handles subsecond timeouts now
+ - version is 2.633
+
+Sun Jul 29 19:48:36 CEST 2007 felix@call-with-current-continuation.org
+ * - timeout for select call in scheduler used wrong number of microseconds
+
+Sat Jul 28 23:44:51 CEST 2007 felix@call-with-current-continuation.org
+ * - added "select", deprecated "switch"
+ - added slot in thread structure for detecting timeout unblock
+ - chicken-build: flags for configuration options
+ - C_post_gc_hook got additional argument (gc time) - this is backwards incompatible!
+
+Fri Jul 27 08:34:30 CEST 2007 felix@call-with-current-continuation.org
+ * - fixed missing safety checks in srfi-13 [reported by Peter Bex]
+
+
+Tue Jul 24 07:19:18 CEST 2007 felix@call-with-current-continuation.org
+ * - benchmarks/fprint.scm: increased runtime for sensible timing result
+ - csc takes first scheme file as default output file
+
+Mon Jul 23 08:32:59 CEST 2007 felix@call-with-current-continuation.org
+ * fixed bug in rewrite rule for write-char
+
+Mon Jul 23 07:29:29 CEST 2007 fw@emlix.com
+ * fixed in chicken-build.scm and makedoc
+
+Mon Jul 23 07:28:53 CEST 2007 felix@call-with-current-continuation.org
+ * - chicken-build: "dist" depends on "all"
+ - optimization classes 23 and 24 accept both variable- and literal defaultargs [suggested by Kon Lovett]
+
+Sun Jul 22 13:06:25 CEST 2007 felix@call-with-current-continuation.org
+ * fixed conflict in chicken-build.scm
+
+Sun Jul 22 12:56:31 CEST 2007 felix@call-with-current-continuation.org
+ * - missing space in chicken-build.scm
+ - profile generates message in debug mode
+
+Sat Jul 21 21:02:59 CEST 2007 felix@call-with-current-continuation.org
+ * - makedoc doesn't need tool anymore (untested)
+ - chicken-build supports building profiling compiler
+
+
+Sat Jul 21 00:47:35 CEST 2007 felix@call-with-current-continuation.org
+ * - version is 2.632
+
+Wed Jul 18 09:43:26 CEST 2007 felix@call-with-current-continuation.org
+ * removed html directory and html-related targets
+
+Fri Jul 20 08:54:45 CEST 2007 felix@call-with-current-continuation.org
+ * - fixed bug in lambda-list of port-position
+ - argument to port-name is optional
+
+Thu Jul 19 09:21:11 CEST 2007 felix@call-with-current-continuation.org
+ tagged 2.631-snapshot
+
+Thu Jul 19 09:21:03 CEST 2007 felix@call-with-current-continuation.org
+ * - version is 2.631
+
+Thu Jul 19 06:37:48 CEST 2007 felix@call-with-current-continuation.org
+ * - fixed misc/makedoc, with support from Mario
+
+Wed Jul 18 09:34:06 CEST 2007 felix@call-with-current-continuation.org
+ * removed wiki-extensions, makedoc does not work anyway
+
+Wed Jul 18 08:06:23 CEST 2007 felix@call-with-current-continuation.org
+ * - version is 2.630
+ - added compiler hook for special import file entries
+ - sync'd wiki manual once more
+
+Tue Jul 17 23:15:33 CEST 2007 felix@call-with-current-continuation.org
+ * - syncd wiki pages
+
+Tue Jul 17 21:49:58 CEST 2007 felix@call-with-current-continuation.org
+ * - eval: added "##sys#repl-print-hook"
+ - support: added hook for writing to export file
+
+Tue Jul 17 09:11:15 CEST 2007 felix@call-with-current-continuation.org
+ * - applied bugfixes by Sven Hartrumpf to cscbench
+
+
+Tue Jul 17 07:26:07 CEST 2007 felix@call-with-current-continuation.org
+ * - benchmarks/nqueens: increased number to obtain longer runtime [suggested by Sven Hartrumpf]
+ - c-platform: invalid argc for read-string and write-char [Thanks to Kon Lovett]
+
+Mon Jul 16 08:43:23 CEST 2007 felix@call-with-current-continuation.org
+ * - added inline-aliases for several string procedures
+
+
+Fri Jul 13 15:18:14 CEST 2007 felix@call-with-current-continuation.org
+ * - cleaned up port argument handling in some I/O procedures
+ - compiler-rewriting for `read-char' and `write-char'
+
+Fri Jul 6 23:22:09 CEST 2007 bvanevery@gmail.com
+ * include tar and gzip in tarball distribution. Only adds 200k.
+
+Fri Jul 6 22:46:14 CEST 2007 bvanevery@gmail.com
+ * vs8 gives terminal error without C_fcall
+
+Thu Jul 12 13:44:24 CEST 2007 felix@call-with-current-continuation.org
+ * - optimizer: added new substitution class for I/O primitives
+
+Wed Jul 11 22:59:36 CEST 2007 felix@call-with-current-continuation.org
+ * - cscbench: wrongly formatted timing values sometimes [Thanks to Sven Hartrumpf]
+
+Wed Jul 11 14:39:45 CEST 2007 felix@call-with-current-continuation.org
+ * - order of object files in csc should now be correct.
+ - chicken-build: some untested support for PROGRAM_PREFIX/PROGRAM_SUFFIX
+
+Wed Jul 11 13:01:23 CEST 2007 felix@call-with-current-continuation.org
+ * - csc: tried to bring some order into order of object files generated and
+ passed on command line
+ - profile generation: fixnum overflow should be caught now
+
+
+Tue Jul 10 07:56:01 CEST 2007 felix@call-with-current-continuation.org
+ * - chicken-setup: removed automatic file-extension translation for windows
+
+Mon Jul 9 22:23:22 CEST 2007 bunny351@gmail.com
+ * removed TARGET_DLL_EXTENSION
+
+Mon Jul 9 22:21:55 CEST 2007 bunny351@gmail.com
+ * - build-platform wasn't registered as predefined feature
+ - default extension for dynamically loadable files is now ".so" on Windows (experimental)
+
+Mon Jul 9 12:42:03 CEST 2007 felix@call-with-current-continuation.org
+ * - fixed bug in buildfiles (PCRE_STATIC should not have been put into
+ pcre/config.h)
+ - version is 2.629
+
+Fri Jul 6 16:01:42 CEST 2007 felix@call-with-current-continuation.org
+ * - implemented read-byte and write-byte (extras)
+ - version is 2.628
+
+Thu Jul 5 19:59:15 CEST 2007 zb@3e8.org
+ * support #d syntax for numbers
+
+Wed Jul 4 20:53:40 CEST 2007 Shawn W. <shawnw@speakeasy.org>
+ * chicken-setup -keep and -fetch fixes
+
+Thu Jul 5 09:47:06 CEST 2007 felix@call-with-current-continuation.org
+ * - bootstrap.sh: didn't have to pass PCRE defs which are now in config.h
+ - added win32 tar and gzip binaries
+ - chicken-setup: quotewrap and prefix win32 tar/gzip invocations
+
+Thu Jul 5 09:04:05 CEST 2007 Shawn W. <shawnw@speakeasy.org>
+ * unterminated here-doc warning fix: Actually display the name of the tag.
+
+Thu Jul 5 08:34:53 CEST 2007 Shawn W. <shawnw@speakeasy.org>
+ * here-doc whitespace warnings
+
+Thu Jul 5 07:19:35 CEST 2007 Shawn W. <shawnw@speakeasy.org>
+ * unterminated here-doc warning
+
+Tue Jul 3 22:35:51 CEST 2007 bunny351@gmail.com
+ * - hen.el: starts csi subprocess with "-R regex -R srfi-1"
+
+Mon Jul 2 21:11:37 CEST 2007 bunny351@gmail.com
+ * - CMakeLists.txt: installation of win32 gzip/tar binaries
+
+Mon Jul 2 21:08:17 CEST 2007 bunny351@gmail.com
+ * - removed old predist stuff
+ - added tar and gzip programs to distribution manifest
+ - srfi-13: string-map[!] starts from low indices and proceeds to high
+ - chicken-setup: removes *.egg files after successful installation
+
+Mon Jul 2 12:03:10 CEST 2007 felix@call-with-current-continuation.org
+ * - added `program-name'
+
+Mon Jul 2 08:06:43 CEST 2007 felix@call-with-current-continuation.org
+ * - version is 2.627
+ - more `read-u8vector' fixes
+
+Mon Jul 2 07:21:57 CEST 2007 felix@call-with-current-continuation.org
+ * - foreign type `enum' did not generate proper type-check [thanks to Ivan Raikov]
+ - `read-u8vector' was completely borked [Thanks to Alaric]
+ - `string-[ci-]hash' didn't check argument type [Thanks top Arto Bendiken]
+
+Tue Jun 26 09:25:36 CEST 2007 felix@call-with-current-continuation.org
+ * - version is 2.626
+ - nextbuild and chicken-build fixes
+
+
+Mon Jun 25 20:51:40 CEST 2007 bunny351@gmail.com
+ * removed Buildfile
+
+Mon Jun 25 20:50:57 CEST 2007 bunny351@gmail.com
+ * install_name_tool was not applied on installed binary
+
+Mon Jun 25 20:26:01 CEST 2007 felix@call-with-current-continuation.org
+ * - made misc/nextbuild csi script (and added patch code from chicken-setup)
+
+Mon Jun 25 20:16:04 CEST 2007 felix@call-with-current-continuation.org
+ * install_name_tool support in chicken-build, some half-hearted attempts at mingw support
+
+Fri Jun 22 19:28:06 CEST 2007 felix@call-with-current-continuation.org
+ * - bugfix in build.scm, testdist target improvements in chicken-build.scm
+
+Thu Jun 21 12:18:38 CEST 2007 fw@emlix.com
+ * build fixes
+
+Mon Jun 18 08:04:02 CEST 2007 fw@emlix.com
+ * - version is 2.622
+
+Sun Jun 17 00:10:08 CEST 2007 felix@call-with-current-continuation.org
+ * - bug in chicken-version (build-style use)
+
+
+Sat Jun 16 14:20:46 CEST 2007 felix@call-with-current-continuation.org
+ * - added "build-style"
+ - renamed CMAKE_BUILD to C_CMAKE_BUILD
+
+Thu Jun 14 21:39:16 CEST 2007 felix@call-with-current-continuation.org
+ * cleaning up in chicken-build
+
+Thu Jun 14 15:04:51 CEST 2007 fw@emlix.com
+ * sharedir was wrong
+
+Thu Jun 14 11:37:49 CEST 2007 fw@emlix.com
+ * more selfbuild stuff
+
+Thu Jun 14 10:56:18 CEST 2007 fw@emlix.com
+ * bootstrap.sh allows overriding CSI
+
+Sat Jun 9 22:59:19 CEST 2007 felix@call-with-current-continuation.org
+ * removed ref to build.scm
+
+Fri Jun 8 14:14:55 CEST 2007 fw@emlix.com
+ * slight fixes in chicken-build
+
+Thu Jun 7 23:01:58 CEST 2007 felix@call-with-current-continuation.org
+ * - csc: chicken-defaults.h is included via chicken.h, no explicit #include needed
+ - renamed "build.scm" to "version.scm"
+ - all pcre options are now passed pcre/config.h
+
+Wed Jun 6 00:50:18 CEST 2007 felix@call-with-current-continuation.org
+ * csi-static runs ok with chicken-build.scm
+
+Wed Jun 6 00:12:07 CEST 2007 felix@call-with-current-continuation.org
+ * more chicken-build fixes
+
+Tue Jun 5 23:23:00 CEST 2007 felix@call-with-current-continuation.org
+ * chicken-build builds through
+
+Sat Jun 2 20:34:43 CEST 2007 felix@call-with-current-continuation.org
+ * added cleaner Scheme-driven build
+
+Fri Jun 22 22:53:37 CEST 2007 zb@3e8.org
+ * csi: add ,uba (unbreak all) command
+
+Mon Jun 18 08:06:45 CEST 2007 felix@call-with-current-continuation.org
+ * - fixed bug in csc ("-strip" option)
+
+Sat Jun 16 23:10:07 CEST 2007 bunny351@gmail.com
+ * - chicken, csc: added "-disable-compiler-macros" option.
+
+Mon Jun 11 11:21:24 CEST 2007 felix@call-with-current-continuation.org
+ * - moved compiler macro registration into support.scm, moved "define-compiler-macros.scm"
+ into chicken-ffi-macros.scm
+
+Fri Jun 8 14:40:02 CEST 2007 felix@call-with-current-continuation.org
+ * - runtime: overflow-detecting fixnum ops check arguments
+
+Thu Jun 7 08:08:56 CEST 2007 felix@call-with-current-continuation.org
+ * - renamed ":optional" to "optional" (":optional" is deprecated)
+
+Wed Jun 6 17:03:55 CEST 2007 felix@call-with-current-continuation.org
+ * - fixed bug in "apropos" that occurred when procedure-information was not a list
+
+Tue Jun 5 15:24:51 CEST 2007 Will M. Farr <farr@mit.edu>
+ * CMakeLists.txt fix for no libffi error
+
+Tue Jun 5 14:58:13 CEST 2007 felix@call-with-current-continuation.org
+ * - chicken-setup gives message if "-test" is given and egg has no test suite
+
+Tue Jun 5 08:46:10 CEST 2007 felix@call-with-current-continuation.org
+ * - posixunix: "_exit" doesn't run cleanup hooks
+ - tcp: added argument check to tcp-abandon-port [suggested by Peter Bex]
+ - tcp: port-data handling was borked
+ - "-feature" accepts comma-sep'd ids
+
+Mon Jun 4 08:10:07 CEST 2007 felix@call-with-current-continuation.org
+ * - "-uses" and "-require-extension" accept comma-separated arguments
+ - "user-post-analysis-pass" is invoked after every analysis pass
+ - version is 2.621
+
+Sun Jun 3 08:57:18 CEST 2007 bunny351@gmail.com
+ * - version is 2.620
+
+Sat Jun 2 09:33:27 CEST 2007 bunny351@gmail.com
+ * changed arguments to user-post-analysis-hook to include node graph
+
+Fri Jun 1 18:27:42 CEST 2007 felix@call-with-current-continuation.org
+ * Fri Jun 1 18:27:42 CEST 2007
+
+Thu May 31 11:54:05 CEST 2007 bunny351@gmail.com
+ * - "user-post-analysis-pass" was called with wrong accessor procedures
+
+Thu May 31 08:06:11 CEST 2007 klovett@pacbell.net
+ * unit extras format signature CL-like, defaults to old behavior
+
+Fri Jun 1 10:33:45 CEST 2007 felix@call-with-current-continuation.org
+ * - "%hash" uses "fxshl" to avoid overflowing into flonum [Thanks to Alex Shinn]
+ - analysis db listings omit internal and standard bindings
+ - added libffi-test in CMakeLists.txt [test provided by Kon Lovett]
+
+Wed May 30 11:52:40 CEST 2007 felix@call-with-current-continuation.org
+ * - fixed bug in c-backend.scm (invalid level variable)
+ - version is 2.62
+
+Mon May 28 22:16:57 CEST 2007 klovett@pacbell.net
+ *
+
+Mon May 28 16:17:08 CEST 2007 bunny351@gmail.com
+ * - manpage fix for chicken by Ivan Shmakov
+
+Mon May 28 12:38:13 CEST 2007 bunny351@gmail.com
+ * - added two sanity checks in callback invocation mechanism to catch callbacks that do not originate in safe foreign lambdas
+ - hen.al: applied patches by Adhi Hargo
+ - version is 2.619
+
+Fri May 25 10:19:13 CEST 2007 felix@call-with-current-continuation.org
+ * - chicken-setup: "-h" showed incorrect text for "-t"
+ - renamed compiler rewrite for blob-length with blob-size
+
+Thu May 24 08:33:37 CEST 2007 felix@call-with-current-continuation.org
+ * resolved conflict
+
+Thu May 24 08:33:15 CEST 2007 klovett@pacbell.net
+ * Changed blob-length => blob-size since has not structure.
+
+Thu May 24 01:19:38 CEST 2007 klovett@pacbell.net
+ * Added nonblocking param to ##sys#custom-input/output-port. Made noinherit default for Windows create-pipe.
+
+Wed May 23 20:52:19 CEST 2007 klovett@pacbell.net
+ * Added read-string & read-line to ##sys#custom-input/output-port. Fixed loc sym in extras unit.
+
+Thu May 24 08:25:51 CEST 2007 felix@call-with-current-continuation.org
+ * renamed blob-length to blob-size [suggested by Kon Lovett]
+
+Wed May 23 16:03:56 CEST 2007 felix@call-with-current-continuation.org
+ * - chicken-setup "-test" option
+
+Wed May 23 12:48:44 CEST 2007 felix@call-with-current-continuation.org
+ * ,d shows blob instead of byte-vector
+
+Wed May 23 11:21:11 CEST 2007 felix@call-with-current-continuation.org
+ * - renamed byte-vector procedures to "blob..." and deprecated old names
+ - deprecated various byte-vector procedures
+ - added blob <-> numvector converters
+ - version is 2.618
+
+Wed May 23 08:14:50 CEST 2007 felix@call-with-current-continuation.org
+ * - chicken-setup uses "gzip -d" instead of "gunzip" [as suggested by Brandon Van Every]
+ - added internal overflow-detecting fixnum +/- (to be used later)
+ - some silly cleaning up in lolevel
+ - scheduler: "##sys#thread-block-for-i/o!" supports input and output blocking
+ - version is 2.617
+
+Tue May 22 14:16:55 CEST 2007 felix@call-with-current-continuation.org
+ * - "object-release" detects shared data
+
+Tue May 22 10:08:00 CEST 2007 felix@call-with-current-continuation.org
+ * - experimentally enabled blocking call in "tcp-connect"
+ - version is 2.616
+
+Tue May 22 06:53:49 CEST 2007 klovett@pacbell.net
+ * Bug fix for ##sys#platform-fixup-pathname
+
+Tue May 22 05:57:48 CEST 2007 klovett@pacbell.net
+ * Bug fix for open/noinherit variable
+
+Tue May 22 05:29:59 CEST 2007 klovett@pacbell.net
+ * Added trailing dirsep rmv for Windows directory?
+
+Sun May 20 19:33:50 CEST 2007 klovett@pacbell.net
+ * file-exists? trim hack fixup
+
+Sat May 19 23:09:47 CEST 2007 bunny351@gmail.com
+ * file-exists? should work properly with trailing separator on windows (MSVC/mingw) now
+
+Sat May 12 00:30:32 CEST 2007 felix@call-with-current-continuation.org
+ * - compiler-macro-table is only generated when needed
+
+Fri May 18 08:19:00 CEST 2007 klovett@pacbell.net
+ *
+
+Tue May 15 23:04:23 CEST 2007 Brandon J. Van Every <bvanevery@gmail.com>
+ * removed static linking support on Mac OS X
+
+Tue May 15 07:21:26 CEST 2007 Brandon J. Van Every <bvanevery@gmail.com>
+ * build chicken-boot dynamically
+
+Tue May 15 03:18:42 CEST 2007 Brandon J. Van Every <bvanevery@gmail.com>
+ * prefer dynamic chicken for bootstrapping
+
+Mon May 14 06:08:03 CEST 2007 felix@call-with-current-continuation.org
+ * - lolevel: proc.check omitted in unsafe code
+
+Fri May 11 13:37:03 CEST 2007 felix@call-with-current-continuation.org
+ * - version is 2.615
+ - "mutate-procedure" changed slightly
+
+Fri May 11 12:20:17 CEST 2007 felix@call-with-current-continuation.org
+ * - lolevel: added mutate-procedure (not documented yet)
+
+Fri May 11 11:34:15 CEST 2007 felix@call-with-current-continuation.org
+ * - chicken-setup: *repository-tree-downloaded* isn't used anymore
+ - support for internal compiler macros
+
+Wed May 9 09:38:09 CEST 2007 bvanevery@gmail.com
+ * MACOSX should not be unconditionally true for static builds
+
+Thu May 10 02:06:45 CEST 2007 klovett@pacbell.net
+ * Windows exec & spawn need quote-wrapped argument strings
+
+Wed May 9 23:58:57 CEST 2007 klovett@pacbell.net
+ * Free memory & proper return value for spawn
+
+Wed May 9 23:25:41 CEST 2007 klovett@pacbell.net
+ * MinGW cannot quote wrap
+
+Wed May 9 09:19:13 CEST 2007 klovett@pacbell.net
+ * Fix for Windows process-execute/spawn
+
+Wed May 9 09:00:50 CEST 2007 klovett@pacbell.net
+ * Fix for Windows process-execute/spawn
+
+Wed May 9 08:56:03 CEST 2007 felix@call-with-current-continuation.org
+ * - posixwin.scm: fixed incorrect argument handling in "process-execute" and "process-spawn" [reported by Kon]
+
+Wed May 9 03:44:34 CEST 2007 klovett@pacbell.net
+ * MacOS X is a GNU ENV, added common free for arg & env lst
+
+Wed May 9 12:14:23 CEST 2007 felix@call-with-current-continuation.org
+ * - removed evaluatable requirements-tests from chicken-setup
+
+Tue May 8 08:43:46 CEST 2007 felix@call-with-current-continuation.org
+ * - version is 2.614
+ - removed ".o" -> ".obj" renaming in chicken-setup
+
+
+Tue May 8 06:42:03 CEST 2007 klovett@pacbell.net
+ * Windows process param quoting, ren of csc local procs that had names of defnd procs, quoting of csc filenames for unix
+
+Sat May 5 07:06:41 CEST 2007 klovett@pacbell.net
+ * Minor code formatting fix
+
+Sat May 5 05:25:37 CEST 2007 klovett@pacbell.net
+ * chicken-setup create-directory for windows didn't create parent directories
+
+Sat May 5 03:53:11 CEST 2007 klovett@pacbell.net
+ * Cygwin defeat of libffi use in autotools caused ALL use to be defeated
+
+Thu Apr 26 07:53:15 CEST 2007 felix@call-with-current-continuation.org
+ * - Several chicken-profile enhancements by Andre Kuehne
+
+
+Wed Apr 25 15:21:42 CEST 2007 felix@call-with-current-continuation.org
+ * - version is 2.613
+
+Tue Apr 24 13:58:56 CEST 2007 felix@call-with-current-continuation.org
+ * - added csc option "-cxx-name"
+
+Tue Apr 24 09:07:51 CEST 2007 felix@call-with-current-continuation.org
+ * - enabled libffi for cygwin/Cmake again, disabled it for cygwin/autotools
+
+Tue Apr 24 06:22:07 CEST 2007 felix@call-with-current-continuation.org
+ * - fixed mingw bug in configure.in
+
+
+Tue Apr 24 05:21:32 CEST 2007 felix@call-with-current-continuation.org
+ * - disabled libffi on cygwin
+
+Tue Apr 24 05:21:18 CEST 2007 felix@call-with-current-continuation.org
+ * omits libws2_32 check for mingw when cross-compiling
+
+Fri Apr 20 14:18:46 CEST 2007 felix@call-with-current-continuation.org
+ * - chicken-setup: -destdir wasn't used in "install-script"
+ - version is 2.612
+
+Fri Apr 20 13:11:16 CEST 2007 felix@call-with-current-continuation.org
+ * - chicken-setup: removed "-check" option (this will move into a separate tool)
+ - printer: escapes backslash in "|...|" printing
+
+Thu Apr 19 08:25:12 CEST 2007 felix@call-with-current-continuation.org
+ * - fix in "read-string" [Thanks to Andre Kuehne]
+
+Sat Apr 14 22:09:35 CEST 2007 bunny351@gmail.com
+ * - version is 2.611
+ - "pathname-directory" always strips trailing separator [suggested by Andre Kuehne]
+
+Sat Apr 14 21:13:13 CEST 2007 bunny351@gmail.com
+ * readme fix
+
+Mon Apr 16 15:57:53 CEST 2007 felix@call-with-current-continuation.org
+ * - csc.scm: bug fix that applied on Windows/CMake with /I option [Thanks to Esteban U. Caamano Castro]
+ - printer: "`" wasn't recognized as special char (and thus was unescaped)
+
+Tue Apr 24 16:41:14 CEST 2007 felix@call-with-current-continuation.org
+ * - some cleanup in hen.el
+ - "move-memory!" acceps optional 3rd and 4th offset argument
+
+Thu Apr 12 15:08:55 CEST 2007 felix@call-with-current-continuation.org
+ * - print-error-message omitted a ": " when the exception was not a string or condition object.
+
+Tue Apr 10 13:57:10 CEST 2007 felix@call-with-current-continuation.org
+ * - removed -track-scheme since it's quite unusable
+
+Tue Apr 10 12:51:38 CEST 2007 felix@call-with-current-continuation.org
+ * some trivial cleanups in the compiler
+
+Tue Apr 10 09:45:16 CEST 2007 felix@call-with-current-continuation.org
+ * - added setters for "current-effective-(user/group)-id" [thanks to shawnw@speakeasy.org]
+
+Thu Apr 5 23:51:32 CEST 2007 bunny351@gmail.com
+ * - csc returns 1 if subcommand triggers error (required since last change of "system" result handling - at least on OS X)
+
+Sun Apr 8 15:45:57 CEST 2007 felix@call-with-current-continuation.org
+ * installation in Buildfile was rather borked
+
+Thu Apr 5 15:27:46 CEST 2007 felix@call-with-current-continuation.org
+ * - "string->number" would not catch "1.0.0" (double occurrence of ".0", which is special-cased) [Reported by marc Feeley]
+ - string to number conversion catches trailing chars in radix!=10 case
+
+Thu Apr 5 10:23:14 CEST 2007 felix@call-with-current-continuation.org
+ * - added foreign type "c-string-list*"
+
+Thu Apr 5 00:49:59 CEST 2007 klovett@pacbell.net
+ * Removed _mkgmtime since not part of MinGW time.h (altough it is part of the Win SDK)
+
+Wed Apr 4 22:38:46 CEST 2007 klovett@pacbell.net
+ * Version is 2.610 due to incompatible changes to MacOS X build
+
+Wed Apr 4 21:19:52 CEST 2007 klovett@pacbell.net
+ * Bug fix (?) for Cygwin timezone offset & added utc-time->seconds & local-timezone-abbreviation
+
+Wed Apr 4 18:24:50 CEST 2007 klovett@pacbell.net
+ * Ticket #162 fix
+
+Wed Apr 4 13:54:06 CEST 2007 felix@call-with-current-continuation.org
+ * - version is 2.609
+
+Wed Apr 4 13:53:54 CEST 2007 felix@call-with-current-continuation.org
+ * - fixed bug in chicken-setup: ranlib on OS X should only be run for .a files
+ [reported by Arto]
+ - number->string in binary radix with large fixnums fix [also reported by Arto]
+
+
+Wed Apr 4 08:10:32 CEST 2007 felix@call-with-current-continuation.org
+ * - version is 2.608
+ - added "byte-vector-move!" and "byte-vector-append" [contributed by Arto Bendiken]
+
+Tue Apr 3 15:50:12 CEST 2007 felix@call-with-current-continuation.org
+ * - added "c-string-list" result type specifier
+
+Fri Mar 30 21:37:29 CEST 2007 Brandon J. Van Every <bvanevery@gmail.com>
+ * require CMake 2.4.6 on suspicion of Linux bugs
+
+Thu Mar 29 20:08:27 CEST 2007 klovett@pacbell.net
+ * Added port-fold to utils
+
+Sun Apr 8 14:56:37 CEST 2007 felix@call-with-current-continuation.org
+ * - some cleanup in hen.el
+
+Thu Mar 29 09:42:08 CEST 2007 felix@call-with-current-continuation.org
+ * - removed obsolete entry for stack-size.cmake in distribution/manifest
+ - configure.in: sets default for TARGET_DLL_EXTENSION, if not given
+
+Thu Mar 29 08:28:00 CEST 2007 felix@call-with-current-continuation.org
+ * - csc: accepts "-" as input file
+ - Makefile.am: missing replacement of C_TARGET_DLL_EXTENSION in chicken-defaults.h [reported by Mario]
+
+Wed Mar 28 09:12:31 CEST 2007 felix@call-with-current-continuation.org
+ * - utils: added "make-broadcast-port" and "make-concatenated-port"
+ - version is 2.607
+ - fixed bug in chicken-setup (unexported reference to ##sys#current-source-filename) [Reported by Kon Lovett]
+
+Thu Apr 5 13:15:11 CEST 2007 felix@call-with-current-continuation.org
+ * minor housekeeping
+
+Thu Apr 5 09:43:36 CEST 2007 felix@call-with-current-continuation.org
+ * - chicken-setup: accepts when docs or examples are missing
+
+Tue Mar 13 21:02:00 CET 2007 bunny351@gmail.com
+ * csc-trans changes
+
+Fri Mar 9 23:14:12 CET 2007 felix@call-with-current-continuation.org
+ * - apropos[-list]: only lists globally bound symbols
+
+Tue Mar 27 14:31:49 CEST 2007 felix@call-with-current-continuation.org
+ * - version is 2.606
+
+Tue Mar 27 14:30:35 CEST 2007 felix@call-with-current-continuation.org
+ * - runtime.c: added "C_panic_hook" [Suggested by Maria Rekouts]
+
+Tue Mar 27 13:06:27 CEST 2007 felix@call-with-current-continuation.org
+ * - chicken-setup: broken installation of doc-files
+
+Mon Mar 26 06:56:09 CEST 2007 felix@call-with-current-continuation.org
+ * - version is 2.605
+ - applied Mario's help option patch for makedoc
+
+Mon Mar 26 06:39:42 CEST 2007 felix@call-with-current-continuation.org
+ tagged 2.604-snapshot
+
+Mon Mar 26 06:39:07 CEST 2007 felix@call-with-current-continuation.org
+ * - updated site index (2.604 snapshot)
+ - csc.scm: Mac OS X dylib extensions should be so [Thanks to Kon Lovett]
+
+Fri Mar 23 09:51:30 CET 2007 foof@synthcode.com
+ * regex fix
+
+Fri Mar 23 08:45:54 CET 2007 felix@call-with-current-continuation.org
+ * - version is 2.604
+ - added "hash-table-remove!" [suggested by Kon Lovett]
+
+Wed Mar 21 12:48:43 CET 2007 felix@call-with-current-continuation.org
+ * - compiler.scm: fix was broken
+
+
+Wed Mar 21 08:50:03 CET 2007 felix@call-with-current-continuation.org
+ * - csc.scm and configuration: TARGET_DLL_EXTENSION
+ - compiler.scm: fix in canonicalization of symbols [Reported by Marc Feeley]
+
+Mon Mar 19 14:10:58 CET 2007 felix@call-with-current-continuation.org
+ * - version is 2.603
+
+Fri Mar 9 04:58:50 CET 2007 klovett@pacbell.net
+ * Added glob? to regex, directory-null? to utils, fixed bug in srfi-13 %string-map! where updated string was not returned so (void) was result.
+
+Wed Mar 7 02:53:09 CET 2007 klovett@pacbell.net
+ * copy-read-table wasn't copying the 3rd slot
+
+Mon Mar 19 08:29:56 CET 2007 felix@call-with-current-continuation.org
+ * - fixed buggy implementation of ##sys#alias-global-hook [Thanks to marc Feeley]
+ - added support for ##sys#alias-global-hook to compiler
+
+Thu Mar 15 15:48:35 CET 2007 felix@call-with-current-continuation.org
+ * - implemented fix for #\... handling in the reader to handle UTF-8 characters [contributed by Alex Shinn]
+
+Thu Mar 15 08:51:43 CET 2007 felix@call-with-current-continuation.org
+ * - csc accepts -track-scheme (but still not documented)
+ - `system' returns exit status unaltered [Thanks to Mario, Kon and Zbigniew]
+ - version is 2.602
+ - `char-name' doesn't accept character names with less than 2 chars [suggested by Alex Shinn]
+
+Mon Mar 12 08:32:08 CET 2007 felix@call-with-current-continuation.org
+ * added alias-global-hook [suggested by Marc Feeley for snow]
+
+Fri Mar 2 12:17:37 CET 2007 felix@call-with-current-continuation.org
+ * small fixes in ANNOUNCE
+
+Wed Mar 7 11:32:35 CET 2007 felix@call-with-current-continuation.org
+ * - added "unused" declaration [suggested by Kon Lovett]
+
+Mon Feb 26 23:47:53 CET 2007 bunny351@gmail.com
+ * - new banner
+
+Mon Feb 26 23:15:18 CET 2007 bunny351@gmail.com
+ * - Buildfile didn't add OPTIM to TARGET_CFLAGS
+
+Wed Feb 28 16:51:53 CET 2007 klovett@pacbell.net
+ * Replaced loop w/ string-intersperse in ##sys#process for posixwin
+
+Mon Mar 5 10:10:36 CET 2007 felix@call-with-current-continuation.org
+ * proper handling of TARGET_RUN_PATH
+
+Mon Mar 5 09:20:02 CET 2007 felix@call-with-current-continuation.org
+ * - removed C_NO_PIC_NO_DLL
+ - added TARGET_RUN_PATH (and C_TARGET_RUN_LIB_HOME)
+
+
+Fri Mar 2 13:39:36 CET 2007 felix@call-with-current-continuation.org
+ * forgot to save, silly.
+
+Fri Mar 2 12:18:52 CET 2007 felix@call-with-current-continuation.org
+ * - applied Peter Bex' patch to chicken-setup (nicer CSS for docindex)
+ - added support for `[nonnull-]unsigned-c-string[*]' foreign type
+ - version is 2.601
+
+Thu Mar 1 12:15:18 CET 2007 felix@call-with-current-continuation.org
+ tagged 2.6-release
+
+Thu Mar 1 12:15:09 CET 2007 felix@call-with-current-continuation.org
+ * - version is 2.6
+ - Buildfile: fixed bug in testdist target
+ - Final updates to ANNOUNCE
+
+Mon Feb 26 22:04:17 CET 2007 felix@call-with-current-continuation.org
+ tagged 2.6rc1-snapshot
+
+Mon Feb 26 22:03:13 CET 2007 felix@call-with-current-continuation.org
+ * updated NEWS and ANNOUNCE
+
+Tue Mar 6 21:50:37 CET 2007 felix@call-with-current-continuation.org
+ * hen.el: highlight defstruct
+
+Wed Feb 21 21:01:44 CET 2007 bunny351@gmail.com
+ * - updated NEWS
+
+Mon Feb 26 08:54:44 CET 2007 felix@call-with-current-continuation.org
+ * site index update
+
+Thu Mar 1 13:04:58 CET 2007 felix@call-with-current-continuation.org
+ * buildfile test fix
+
+Mon Feb 26 08:05:44 CET 2007 felix@call-with-current-continuation.org
+ * - version is 2.6rc1
+
+Fri Feb 23 22:37:45 CET 2007 Brandon J. Van Every <bvanevery@gmail.com>
+ * must use CMAKE_CFG_INTDIR, not CMAKE_BUILD_TYPE
+
+Sat Feb 24 23:40:43 CET 2007 klovett@pacbell.net
+ * CYGWIN & MINGW have same behavior for +/-inf.0 & nan.0
+
+Fri Feb 23 11:56:46 CET 2007 felix@call-with-current-continuation.org
+ * missed adding C_NO_PIC_NO_DLL - all my fault, Brandon was right. I bow my head in shame
+
+Fri Feb 23 10:32:51 CET 2007 felix@call-with-current-continuation.org
+ * - on OSX, static chicken + csi are not built [suggested by Thomas Chust]
+
+
+Fri Feb 23 08:12:47 CET 2007 felix@call-with-current-continuation.org
+ * - version is 2.524
+
+Fri Feb 23 08:12:36 CET 2007 felix@call-with-current-continuation.org
+ * - eval: CHICKEN_apply_to_string wasn't hidden.
+ - removed C_128_PARAMETERS.
+ - added option to CMakeLists.txt for disabling use of libffi
+
+
+Mon Feb 26 17:10:08 CET 2007 felix@call-with-current-continuation.org
+ * - hid global used in limited length printing
+ - '##sys#cons' wasn't in internal bindings and thus not re-written
+
+Wed Feb 21 10:28:46 CET 2007 felix@call-with-current-continuation.org
+ * - version is 2.523
+ - CMake build adds C_NO_PIC_NO_DLL to cflags
+
+Wed Feb 21 07:51:46 CET 2007 tonysidaway@gmail.com
+ * chicken-setup non-windows file permissions
+ chicken-setup on non-windows systems must ensure that files and
+ directories it copies are usable by all. If chicken-setup is run in
+ a process that has a restrictive umask setting, normal file operations
+ apply that restrictive mask. I have added code to apply appropriate
+ permissions explicitly after a file copy or a directory creation.
+
+Wed Feb 21 07:55:35 CET 2007 felix@call-with-current-continuation.org
+ * - posixunix: tm_zone is not available on HP/UX
+ - CMakeLists.txt: adds -DC_NO_PIC_NO_DLL to RAW_CFLAGS
+
+Mon Feb 19 21:26:30 CET 2007 tonysidaway@gmail.com
+ * chicken-setup: fix required-extension-version
+
+ chicken-setup has a built-in command, required-chicken-extension, which takes a
+ symbol and a string. The symbol is the name of an extension, and the string is
+ the minimum version number. The command is supposed to terminate chicken-setup
+ with an appropriate error message if the required extension is not already
+ installed.
+
+ This was broken so I fixed it.
+
+Tue Feb 20 08:33:16 CET 2007 felix@call-with-current-continuation.org
+ * - `define-record-type' doesn't set record-identifier anymore
+ - CMakeLists.txt: uses INSTALL_RPATH now
+ - chicken-setup: added `cross-chicken'
+
+Mon Feb 19 15:33:10 CET 2007 felix@call-with-current-continuation.org
+ * - version is 2.522
+ - added dist-test in Buildfile
+ - chicken.h: reverted x86/64-specific change that might break on non-UNIX systems
+
+Fri Feb 16 15:41:37 CET 2007 felix@call-with-current-continuation.org
+ * - added missing definitions to chicken-defaults.h.in
+
+
+Fri Feb 16 13:42:43 CET 2007 felix@call-with-current-continuation.org
+ * - version string indicates cross mode
+
+Fri Feb 16 12:11:13 CET 2007 felix@call-with-current-continuation.org
+ * - version is 2.521
+
+Thu Feb 15 13:30:23 CET 2007 bunny351@gmail.com
+ * - eval: resolved conflict
+
+Mon Feb 12 20:52:44 CET 2007 bunny351@gmail.com
+ * - added compiler-option `-keep-shadowed-macros'
+
+Fri Feb 9 19:11:15 CET 2007 bunny351@gmail.com
+ * - eval emitted syntax trace twice for lists with symbol head
+
+Wed Feb 14 13:46:57 CET 2007 felix@call-with-current-continuation.org
+ * always include stdint.h on amd64 [thanks to Alex Shinn], simplifcation of eval-trace-info emission
+
+
+Wed Feb 14 08:00:36 CET 2007 felix@call-with-current-continuation.org
+ * - eval: added interpreter debug level
+ - library: handling of unicode surrogates by Alex Shinn
+ - csi: fixed a few bugs in "describe"
+
+Tue Feb 13 12:10:36 CET 2007 felix@call-with-current-continuation.org
+ * - csi: removed `array' specific code from `describe'
+
+Mon Feb 12 18:36:41 CET 2007 Brandon J. Van Every <bvanevery@gmail.com>
+ * objects grabbed across subdirectories have to be declared as GENERATED
+
+Mon Feb 12 08:32:03 CET 2007 Brandon J. Van Every <bvanevery@gmail.com>
+ * reuse pcre objects to avoid multiple source compilation
+
+Mon Feb 12 08:34:58 CET 2007 felix@call-with-current-continuation.org
+ * - "load-verbose" is always enabled in the repl
+ - first form wasn't passed to "user-preprocessor-pass" [reported by minh thu]
+ - fixed typo in CMakeLists.txt [thanks to Brandon]
+
+Fri Feb 16 22:57:28 CET 2007 felix@call-with-current-continuation.org
+ * - compiler raises proper syntax errors
+ - removed binary incompatibility over "C_emit_trace_info"
+ - syntax-error in compiler shows backtrace
+
+Sun Feb 11 20:34:22 CET 2007 felix@call-with-current-continuation.org
+ * - eval: experimental insertion of processed forms into trace-buffer, marked as "<syntax>"
+ (this is incomplete, since it doesn't show up in compiled code)
+
+Fri Feb 9 11:34:01 CET 2007 felix@call-with-current-continuation.org
+ * buildfile fix
+
+Fri Feb 9 11:16:40 CET 2007 felix@call-with-current-continuation.org
+ * - removed sizeof(double) tests in configure.in
+
+Fri Feb 9 11:12:00 CET 2007 felix@call-with-current-continuation.org
+ * cross-building fixes
+
+Thu Feb 8 10:03:04 CET 2007 felix@call-with-current-continuation.org
+ * more fixes for cross-compilation
+
+Thu Feb 8 08:23:30 CET 2007 felix@call-with-current-continuation.org
+ * - csc.scm: fixed bug in building of link options
+
+Thu Feb 8 07:41:53 CET 2007 felix@call-with-current-continuation.org
+ * fixing conflicts once more in csc.scm
+
+Wed Feb 7 23:29:04 CET 2007 felix@call-with-current-continuation.org
+ * cross-building improvements
+
+Wed Feb 7 23:28:57 CET 2007 bunny351@gmail.com
+ * fixed conflicts in csc.scm
+
+Wed Feb 7 19:30:57 CET 2007 bunny351@gmail.com
+ * - csc: proper separation of target and install variables ("-host" option)
+ - change of TARGET_... variables in various buildfiles
+ - configure.in: if cross-compiling, omit sizeof(double) check***END OF DESCRIPTION***
+
+ Place the long patch description above the ***END OF DESCRIPTION*** marker.
+ The first line of this file will be the patch name.
+
+
+ This patch contains the following changes:
+
+ M ./Buildfile -2 +6
+ M ./CMakeLists.txt -10 +14
+ M ./Makefile.am +16
+ M ./configure.in -7 +21
+ M ./csc.scm -35 +98
+
+Thu Feb 1 20:30:03 CET 2007 bunny351@gmail.com
+ * - string->number: long string would overflow intermediate buffer [Thanks to Robin Lee Powell]
+
+Thu Feb 1 18:58:35 CET 2007 bunny351@gmail.com
+ * - csi: fixed "-s -<opt>" problem
+ - library: "##sys#make-string" is unsafe, "make-string" does checking [suggested by Kon Lovett]
+
+Thu Feb 8 07:35:22 CET 2007 felix@call-with-current-continuation.org
+ * - inlined some uses of "fxmod" and "fx/"
+ - "vector-resize!" uses "##sys#grow-vector"
+
+Wed Feb 7 14:45:51 CET 2007 felix@call-with-current-continuation.org
+ * - README fixed by Mario Domenech Goulart
+ - csc: added "-host" options and some support for cross-compiling
+ - version is 2.52
+
+Mon Feb 5 09:02:17 CET 2007 felix@call-with-current-continuation.org
+ * - removed unnecessary diagnostic output in "object-release" [Thanks to Tony Sidaway]
+
+Fri Feb 2 08:47:43 CET 2007 felix@call-with-current-continuation.org
+ * - csc.scm: "-strip" only when not MSVC
+ - internal buffer could overflow in "string->number" [Thanks to Robin Lee Powell]
+
+Thu Feb 1 06:20:34 CET 2007 felix@call-with-current-continuation.org
+ * - chicken-setup: simplified "run:execute" a little
+ - csc: add "-strip" option
+
+Wed Jan 31 07:46:37 CET 2007 felix@call-with-current-continuation.org
+ * - extras: "read-lines" swallowed line if given limit argument [Thanks to Tony Sidaway]
+
+Wed Jan 31 07:32:22 CET 2007 felix@call-with-current-continuation.org
+ * - chicken-setup: "make" and "make/proc" accept list as argv argument
+ - version is 2.519
+ - "glob->regexp" handles "[...]" now
+
+Tue Jan 30 11:20:29 CET 2007 felix@call-with-current-continuation.org
+ tagged 2.518-snapshot
+
+Tue Jan 30 11:20:21 CET 2007 felix@call-with-current-continuation.org
+ * - updated tarball generation hack
+
+
+Tue Jan 30 09:15:45 CET 2007 felix@call-with-current-continuation.org
+ * updated snapshot link in site index
+
+Tue Jan 30 08:35:11 CET 2007 felix@call-with-current-continuation.org
+ * - version is 2.518
+
+Sat Jan 27 23:21:15 CET 2007 bunny351@gmail.com
+ * - Buildfile: supports DESTDIR
+
+Fri Jan 26 15:02:07 CET 2007 bunny351@gmail.com
+ * - csi: describe omits "s" in one place if unneccessary***END OF DESCRIPTION***
+
+ Place the long patch description above the ***END OF DESCRIPTION*** marker.
+ The first line of this file will be the patch name.
+
+
+ This patch contains the following changes:
+
+ M ./csi.scm -2 +4
+ M ./lolevel.scm +1
+
+Sat Jan 27 04:24:28 CET 2007 klovett@pacbell.net
+ * Bug fix for translate-extension; improper call to pathname-replace-extension
+
+Fri Jan 26 05:13:34 CET 2007 klovett@pacbell.net
+ * Use of ANSI strerror for posixwin
+
+Fri Jan 26 04:53:15 CET 2007 klovett@pacbell.net
+ * Added process*
+
+Thu Jan 25 11:53:02 CET 2007 felix@call-with-current-continuation.org
+ * - Buildfile: -I options did show up in CFLAGS passed by csc
+ - csc: didn't perform special handling of "-require-extension"
+ - "require-extension" does "require-for-syntax" if needed for statically linked extensions
+
+Thu Jan 25 11:32:25 CET 2007 felix@call-with-current-continuation.org
+ * fixed bug introduced in pcre/CMakeLists.txt by last patch
+
+Thu Jan 25 11:31:33 CET 2007 felix@call-with-current-continuation.org
+ * -fPIC was missing in libpcre-for-shared
+
+Wed Jan 24 14:14:48 CET 2007 Brandon J. Van Every <bvanevery@gmail.com>
+ * build pcre once for shared libs
+
+Wed Jan 24 15:56:09 CET 2007 felix@call-with-current-continuation.org
+ * - site/index.html: added links to trac and callcc.org
+ - misc/makehtmldoc: renamed to makedoc, only converts pagers that are out of date
+ - library: added "on-exit" and "bit-set?"
+
+Wed Jan 24 01:36:10 CET 2007 Brandon J. Van Every <bvanevery@gmail.com>
+ * pass correct definitioins for PCRE
+
+Wed Jan 24 01:32:57 CET 2007 Brandon J. Van Every <bvanevery@gmail.com>
+ * update copyright to 2006..2007
+
+Mon Jan 22 20:42:54 CET 2007 klovett@pacbell.net
+ * posixwin process-wait signals error, made yield common, added file-control, bugfix for process, added ##sys#thread-yield!, ##sys#file-nonblocking!, ##sys#file-select-one
+
+Tue Jan 23 15:02:24 CET 2007 felix@call-with-current-continuation.org
+ * - reader warns on unrecognized escape sequences in string literals
+ - version is 2.517
+
+Mon Jan 22 13:38:40 CET 2007 felix@call-with-current-continuation.org
+ * include paths in buildfile
+
+Fri Jan 19 20:11:11 CET 2007 Brandon J. Van Every <bvanevery@gmail.com>
+ * compile straight PCRE sources
+
+Fri Jan 19 11:36:13 CET 2007 felix@call-with-current-continuation.org
+ * fixed bug in static/CMakelists.txt (wrong libname)
+
+Fri Jan 19 11:29:07 CET 2007 felix@call-with-current-continuation.org
+ * builds two pcre intermediate libraries (PIC and non-PIC)
+
+Fri Jan 12 11:03:50 CET 2007 Brandon J. Van Every <bvanevery@gmail.com>
+ * forgot pcre/CMakeLists.txt
+
+Fri Jan 12 10:46:28 CET 2007 Brandon J. Van Every <bvanevery@gmail.com>
+ * build static libpcre
+
+Thu Jan 11 14:39:40 CET 2007 felix@call-with-current-continuation.org
+ * resolved conflicts
+
+Thu Jan 11 08:57:53 CET 2007 Brandon J. Van Every <bvanevery@gmail.com>
+ * resolve chicken-pcre conflicts and a few stray errors
+
+Thu Jan 11 14:32:07 CET 2007 felix@call-with-current-continuation.org
+ * re-added pcre/NON-UNIX-USE
+
+Thu Jan 11 14:27:22 CET 2007 felix@call-with-current-continuation.org
+ * cmake build with pcre working somewhat
+
+Thu Jan 11 13:32:23 CET 2007 felix@call-with-current-continuation.org
+ * first try at cmake/pcre integration
+
+Wed Jan 10 09:51:42 CET 2007 felix@call-with-current-continuation.org
+ * CMake-detection of memmove and strerror
+
+Wed Jan 10 09:28:26 CET 2007 felix@call-with-current-continuation.org
+ * first steps towards pcre integration via cmake
+
+Wed Jan 10 09:17:42 CET 2007 felix@call-with-current-continuation.org
+ * buildfile adapation to pcre integration
+
+Wed Jan 10 07:57:47 CET 2007 felix@call-with-current-continuation.org
+ * - added pcre files, removed all traces of regexunix and pregexp, renamed pcre sorces to regex
+
+Tue Jan 9 17:05:55 CET 2007 felix@call-with-current-continuation.org
+ * - configure.in: fixed bug in check for small doubles (missing closing paren)
+ - added pcre 6.3 sources and adapted configure.in and Makefile.am
+
+Mon Jan 22 13:39:09 CET 2007 felix@call-with-current-continuation.org
+ * - chicken-setup: tries to translate "o"/"a" extension for installed files in windows (msvc + mingw32)
+ - version is 2.516
+
+Mon Jan 22 06:21:29 CET 2007 felix@call-with-current-continuation.org
+ * - csi: "--" wasn't properly handled [Thanks to Marc Feeley]
+ - extras: added "o"
+
+Tue Jan 16 20:36:02 CET 2007 klovett@pacbell.net
+ * Stopped spawnvp/execvp warning message, added signal-handler, set-signal-handler!
+
+Fri Jan 19 10:44:52 CET 2007 felix@call-with-current-continuation.org
+ * - chicken-setup: asks user when executing needs tests
+
+Wed Jan 17 11:36:40 CET 2007 felix@call-with-current-continuation.org
+ * - added `C_mwemcpy_slots' internal wrapper macro
+ - removed `thread-sleep!/ms', added `time->milliseconds', `milliseconds->time' [suggested by Daishi Kato]
+
+Mon Jan 15 21:21:47 CET 2007 bunny351@gmail.com
+ * forgot to save file with posixunix patch... Hm.
+
+Mon Jan 15 20:09:20 CET 2007 bunny351@gmail.com
+ * - added `thread-sleep!/ms' [suggested by Daishi Kato]
+ - `file-stat' returns 13-element vector, including device info [thanks to John Cowan]
+
+Wed Jan 10 18:32:26 CET 2007 bunny351@gmail.com
+ * fixed bug in printer when record-name was "record" [thanks to Daniel Sadilek]
+
+Fri Jan 12 10:38:12 CET 2007 felix@call-with-current-continuation.org
+ * - `-emit-exports' sorts output [Suggested by Brandon van Every]
+ - version is 2.515
+
+Thu Jan 11 02:41:16 CET 2007 Brandon J. Van Every <bvanevery@gmail.com>
+ * make posixwin.scm responsible for posix.exports to avoid file collision with posixunix.scm export of the same
+
+Fri Jan 12 09:39:23 CET 2007 felix@call-with-current-continuation.org
+ * - csc: added support for "CSC_OPTIONS" [Suggested by Stephen Gilardi]
+
+Thu Jan 11 14:35:54 CET 2007 felix@call-with-current-continuation.org
+ * removed win-install.bat
+
+Thu Jan 11 13:22:12 CET 2007 felix@call-with-current-continuation.org
+ tagged 2.514-snapshot
+
+Thu Jan 11 13:22:02 CET 2007 felix@call-with-current-continuation.org
+ * new development snapshot link in homepage
+
+Thu Jan 11 12:02:52 CET 2007 felix@call-with-current-continuation.org
+ * fixed yet another bug in ##sys#do-the-right-thing
+
+Thu Jan 11 11:51:51 CET 2007 felix@call-with-current-continuation.org
+ * - implementation of require-for-syntax and require-extension was not correct with extensions that have both syntax and runtime parts
+ - `include' shows message (in load-verbose mode)
+ - version is 2.514
+
+Thu Jan 11 10:44:44 CET 2007 felix@call-with-current-continuation.org
+ * posix.exports wasn\'t mentioned in configure.in as boot file
+
+Thu Jan 11 09:12:50 CET 2007 felix@call-with-current-continuation.org
+ * - utils.scm used eval (which it doesn't have to)
+ - `require-for-syntax' did expand into pointless runtime-requirements [Thanks to Joshua Griffith]
+
+Thu Jan 11 07:45:43 CET 2007 felix@call-with-current-continuation.org
+ * command-line or first use of (declare (emit-exports ...)) overrides all subsequent declarations
+
+Wed Jan 10 13:24:56 CET 2007 felix@call-with-current-continuation.org
+ * - added stubs for unimplemented things to posixwin.scm
+
+Wed Jan 10 09:15:32 CET 2007 felix@call-with-current-continuation.org
+ * - csc.scm: didn't pass extra libraries to linker
+ - chicken-setup: basic support for complex egg requirements
+
+Mon Jan 8 17:46:00 CET 2007 klovett@pacbell.net
+ * MinGW support for +nan.0, etc.
+
+Mon Jan 8 17:17:31 CET 2007 Brandon J. Van Every <bvanevery@gmail.com>
+ * use #cmakedefine, patch courtesy of Ingo Bungener
+
+Sat Jan 6 20:48:39 CET 2007 bunny351@gmail.com
+ * - chicken-setup: does ranlib automatically for installed files given in "static" option on macosx
+ - posixunix.scm: replaced "intptr_t" with "long" [suggested by Kon]
+
+Sat Jan 6 00:14:32 CET 2007 bunny351@gmail.com
+ * - resolved some conflicts
+ - version is 2.513
+
+Fri Jan 5 23:25:27 CET 2007 bunny351@gmail.com
+ * - added "set-parameterized-read-syntax!" [suggested by John Cowan]
+ - version is 2.512
+
+Thu Jan 4 07:30:06 CET 2007 klovett@pacbell.net
+ * put back (intptr_t)
+
+Thu Jan 4 06:25:55 CET 2007 klovett@pacbell.net
+ * Added ##sys#shell-command
+
+Thu Jan 4 01:51:36 CET 2007 klovett@pacbell.net
+ * Added ##sys#shell-command
+
+Mon Jan 8 15:55:24 CET 2007 felix@call-with-current-continuation.org
+ * - removed def of C_valloc in lowlevel.scm***END OF DESCRIPTION***
+
+ Place the long patch description above the ***END OF DESCRIPTION*** marker.
+ The first line of this file will be the patch name.
+
+
+ This patch contains the following changes:
+
+ M ./lolevel.scm -8 +1
+ M ./runtime.c -2 +2
+ M ./site/tarballs/index.html +1
+
+Wed Jan 3 07:49:48 CET 2007 felix@call-with-current-continuation.org
+ * - initial PTE table wasn't enlarged for previous additions
+ - version is 2.512
+
+Wed Jan 3 03:33:34 CET 2007 klovett@pacbell.net
+ * Split process-wait into public & ##sys# versions
+
+Mon Jan 1 22:09:32 CET 2007 bunny351@gmail.com
+ * - resolved conflicts
+
+Mon Jan 1 21:29:50 CET 2007 bunny351@gmail.com
+ * - added initial PTE entries for some procedures
+
+Mon Jan 1 16:42:03 CET 2007 bunny351@gmail.com
+ * - slight simplification of rewrite-rule for "any?"
+ - updated copyright comments to 2007
+
+Sun Dec 31 01:58:36 CET 2006 felix@call-with-current-continuation.org
+ * fixed highly likely GC bug
+
+Sun Dec 31 01:58:55 CET 2006 bunny351@gmail.com
+ * - inline version of "any?" (C_anyp).
+ - version is 2.511
+
+Fri Dec 29 23:16:37 CET 2006 felix@call-with-current-continuation.org
+ * fixed ref to intptr_t
+
+Fri Dec 29 23:17:09 CET 2006 bunny351@gmail.com
+ * - removed tinyclos page from wiki directory
+
+Mon Jan 1 17:46:56 CET 2007 klovett@pacbell.net
+ * Fix for undefined variable
+
+Mon Jan 1 03:09:43 CET 2007 klovett@pacbell.net
+ * Added ##sys#process
+
+Fri Dec 22 09:26:18 CET 2006 felix@call-with-current-continuation.org
+ * - version is 2.511
+
+Thu Dec 21 19:50:02 CET 2006 bunny351@gmail.com
+ * - added "any?" and compiler rewrite-rule
+
+Tue Dec 19 19:07:48 CET 2006 Brandon J. Van Every <bvanevery@gmail.com>
+ * moved Automake to dist.cmake so that cmake -E copy won't change timestamps and cause it to run twice
+
+Tue Dec 19 16:33:09 CET 2006 klovett@pacbell.net
+ * Chgd use of stdin|out|err as param syms; actually system globals. Added more cpu archs to sysinfo.
+
+Thu Dec 14 00:57:55 CET 2006 bunny351@gmail.com
+ * - cscbench: more regex tweaking [thanks to Deanna Phillips]
+ - batch-driver: added important diagnostic output
+ - dist.cmake: removed obsolete benchmarks
+ - compiler: added documentation-extraction hook
+ - csc: does not assume /usr/local/include is a standard include path [suggested by Deanna Phillips]
+
+Wed Dec 13 20:15:30 CET 2006 bunny351@gmail.com
+ * updated ANNOUNCE
+
+Mon Dec 18 17:13:56 CET 2006 klovett@pacbell.net
+ * Removed srfi-4 dependency
+
+Mon Dec 18 08:52:20 CET 2006 felix@call-with-current-continuation.org
+ * - added srfi-4 requirement in posixwin.scm
+
+Mon Dec 18 08:50:57 CET 2006 felix@call-with-current-continuation.org
+ * - added "read-line" input method and implementation for string- and tcp-ports
+ - simplified special-casing in "read-line" for stream-ports
+ - replaced "process" in posixwin.scm with better version [contributed by mejedi]
+
+Wed Dec 13 12:00:36 CET 2006 felix@call-with-current-continuation.org
+ * - fixed bug in single-variable "let-values" expansion
+ - "print-error-message": missing colon in output if exn is a string
+
+Tue Dec 12 15:47:17 CET 2006 felix@call-with-current-continuation.org
+ * - version is 2.510
+ - added "read-u8vector!"
+
+Tue Dec 12 09:51:27 CET 2006 felix@call-with-current-continuation.org
+ * - added "read-string!"
+ - string-ports support "read-string" method
+
+Mon Dec 11 17:10:54 CET 2006 felix@call-with-current-continuation.org
+ * - added basic support for "read-string" method in port class (but unused in the moment)
+
+Mon Dec 11 15:11:04 CET 2006 felix@call-with-current-continuation.org
+ * - chicken-setup: added "required-extension-version"
+
+Mon Dec 11 00:13:13 CET 2006 bunny351@gmail.com
+ * added debian directory (provided by Ivan Raikov)
+
+Sun Dec 10 21:11:21 CET 2006 bunny351@gmail.com
+ * - eval: ##sys#canonicalize-body accepts optional container argument (ignored, but useful for hooking)
+
+Sun Dec 10 20:03:59 CET 2006 klovett@pacbell.net
+ * added signal-handler, signal-mask, signal-masked?, signal-mask!, signal-unmask!
+
+Mon Dec 11 08:46:00 CET 2006 felix@call-with-current-continuation.org
+ * - chicken-setup: "-V" output showed "Version" twice
+
+Fri Dec 8 15:43:59 CET 2006 felix@call-with-current-continuation.org
+ * - chicken-setup: added "required-chicken-version"
+
+Fri Dec 8 14:37:54 CET 2006 felix@call-with-current-continuation.org
+ * - chicken-setup: added "-revision" option
+
+Thu Dec 7 22:58:59 CET 2006 klovett@pacbell.net
+ * Move of all non-apropos releated environment code to environment egg
+
+Thu Dec 7 18:07:00 CET 2006 klovett@pacbell.net
+ * Environment extn; v2
+
+Fri Dec 8 08:59:12 CET 2006 felix@call-with-current-continuation.org
+ * - calling "error" with first and second arg being symbols resulted in a failing string-append
+
+Thu Dec 7 15:18:58 CET 2006 felix@call-with-current-continuation.org
+ * updated ANNOUNCE
+
+Thu Dec 7 09:23:26 CET 2006 felix@call-with-current-continuation.org
+ * removed a check (should have been in last patch)
+
+Thu Dec 7 09:09:57 CET 2006 felix@call-with-current-continuation.org
+ * - removed some safety checks from ##sys#walk-namespace and other namespace routines
+ - added a few helper scripts
+
+
+Thu Dec 7 02:27:35 CET 2006 klovett@pacbell.net
+ * Chez Scheme-ish environment utilities; v1
+
+Tue Dec 5 09:16:47 CET 2006 Brandon Van Every <bvanevery@gmail.com>
+ * remove CMake version number from INSTALL-CMake.txt so we don't have to keep chasing it around
+
+Tue Dec 5 09:12:02 CET 2006 Brandon Van Every <bvanevery@gmail.com>
+ * require CMake 2.4.5
+
+Mon Dec 4 21:37:32 CET 2006 bunny351@gmail.com
+ * - resolved conflict in README
+ - version is 2.508
+
+Mon Dec 4 21:06:20 CET 2006 bunny351@gmail.com
+ * - updated link to libffi-3 in README, modified layout
+ - hash-table-update![/default] returns update value
+
+Thu Nov 30 22:55:29 CET 2006 bunny351@gmail.com
+ * - calling "(error #f)" doesn't crash anymore, zero arguments are allowed.
+ - slight modifications of the way errors are displayed.
+
+Thu Nov 30 21:51:47 CET 2006 bunny351@gmail.com
+ * - "define-values" and "set!-values" handle single-value case better
+
+Mon Nov 27 23:59:04 CET 2006 bunny351@gmail.com
+ * - added Mario's wiki2pdf script
+
+
+Mon Dec 4 16:37:53 CET 2006 felix@call-with-current-continuation.org
+ * - compiler doesn't "provide" srfi-1, extras and srfi-4 anymore at compile-time [reported by Marc Feeley]
+
+Fri Dec 1 16:40:25 CET 2006 felix@call-with-current-continuation.org
+ * - "let-values" optimizes the single-value case.
+
+Wed Nov 29 15:51:14 CET 2006 felix@call-with-current-continuation.org
+ * tiny things
+
+Wed Nov 29 14:47:41 CET 2006 felix@call-with-current-continuation.org
+ * - added Mario's patch for makehtmldoc
+ - added html for tarball archive
+ - srfi-4: added "read-u8vector" and "write-u8vector"
+ - "receive" handles single-value case better
+ - version is 2.507
+
+Mon Nov 27 16:52:35 CET 2006 felix@call-with-current-continuation.org
+ * - csi: ",d" item coalescing counted one too many
+ - cscbench: didn't match timing-output in scientific notation [Reported by Deanna Phillips]
+
+Sun Nov 26 12:48:29 CET 2006 bunny351@gmail.com
+ * - error-message shown on breakpoint did split application form
+ - csi: ",d" folds runs of eq? elements in sequences
+ - version is 2.506
+
+Sat Nov 25 10:11:55 CET 2006 bunny351@gmail.com
+ * fixed bug in "load" (loading from port crashed, thanks to "$)")
+
+Thu Nov 23 07:57:08 CET 2006 Brandon Van Every <bvanevery@gmail.com>
+ * use WORKING_DIRECTORY to work around Darcs limitations on Cygwin
+
+Thu Nov 23 07:08:16 CET 2006 Brandon Van Every <bvanevery@gmail.com>
+ * use VERSION for Cygwin dll
+
+Thu Nov 23 07:07:02 CET 2006 Brandon Van Every <bvanevery@gmail.com>
+ * added marginally useful WINDOWS_PATH macro
+
+Wed Nov 22 21:04:36 CET 2006 Brandon Van Every <bvanevery@gmail.com>
+ * correction to tutorial. Couldn't unrecord / rerecord for some reason.
+
+Wed Nov 22 19:43:36 CET 2006 Brandon Van Every <bvanevery@gmail.com>
+ * tutorialized STACK_GROWS_DOWNWARD
+
+Wed Nov 22 11:20:25 CET 2006 Brandon Van Every <bvanevery@gmail.com>
+ * updated most comments about CMake 2.4.3 to CMake 2.4.4.
+
+Wed Nov 22 10:31:11 CET 2006 Brandon Van Every <bvanevery@gmail.com>
+ * use --repodir and native paths for Darcs command
+
+Wed Nov 22 10:19:57 CET 2006 Brandon Van Every <bvanevery@gmail.com>
+ * ESCAPE_BACKSLASHES and ESCAPE_QUOTES macros
+
+Wed Nov 22 01:33:06 CET 2006 Brandon Van Every <bvanevery@gmail.com>
+ * update to CMake 2.4.4 in docs
+
+Wed Nov 22 00:52:47 CET 2006 Brandon Van Every <bvanevery@gmail.com>
+ * CMake 2.4.4 now handles apostrophes in -E echo
+
+Wed Nov 22 00:40:13 CET 2006 Brandon Van Every <bvanevery@gmail.com>
+ * removed NATIVE_COMMAND_EXE_PATH as it's dead code and refers to a bug that's been fixed in CMake 2.4.4.
+
+Tue Nov 21 23:39:25 CET 2006 Brandon Van Every <bvanevery@gmail.com>
+ * require CMake 2.4.4
+
+Sat Nov 18 22:03:59 CET 2006 bunny351@gmail.com
+ * - chicken-setup: removed single-file installation, fetch-only with existing egg[-dir] should work
+ - csi.1/chicken-setup.1: updated
+
+Sat Nov 18 00:22:21 CET 2006 bunny351@gmail.com
+ * - chicken-setup: didn't install documentation files (!)
+ - chicken-setup: added "-destdir" option [originally suggested by Peter Busser]
+ - csi: added "-ss" option
+
+Wed Nov 15 22:56:35 CET 2006 bunny351@gmail.com
+ * - chicken-setup: -svn, -tree and -local options, sorted manual page
+ - version is 2.505
+
+Wed Nov 15 20:30:59 CET 2006 bunny351@gmail.com
+ * - chicken-setup: added "-tree FILENAME" option
+
+Fri Nov 17 14:47:47 CET 2006 felix@call-with-current-continuation.org
+ * - library: added call to ##sys#gc in ##sys#dunload
+
+Fri Nov 17 12:44:52 CET 2006 felix@call-with-current-continuation.org
+ * - runtime.c, library.scm, chicken.h: first attempt at implementing ##sys#dunload
+
+Wed Nov 15 15:19:57 CET 2006 felix@call-with-current-continuation.org
+ * - slight modification to repl/unbound warning output
+ - eval: fixed unbound variable bug in ##sys#load
+ - chicken-more-macros: expansion of ":optional" is more efficient in unsafe code***END OF DESCRIPTION***
+
+ Place the long patch description above the ***END OF DESCRIPTION*** marker.
+ The first line of this file will be the patch name.
+
+
+ This patch contains the following changes:
+
+ M ./Buildfile -5 +8
+ M ./chicken-more-macros.scm -3 +5
+ M ./eval.scm -5 +6
+
+Tue Nov 14 10:10:24 CET 2006 felix@call-with-current-continuation.org
+ * - eval/repl: the repl warns about references to unbound toplevel vars
+
+Thu Nov 9 23:46:05 CET 2006 bunny351@gmail.com
+ * - compiler rewrites `void' and `##sys#void' to a reference to ##sys#undefined-value (can't be ##core#undefined directly since the compiler makes some assumptions about this)
+ - version is 2.504
+
+Thu Nov 9 19:03:18 CET 2006 bunny351@gmail.com
+ * - csi: ",breakall" was inverted
+ - added rewrite rules for [su]32vector-ref (unsafe mode)
+
+Mon Nov 6 22:53:56 CET 2006 bunny351@gmail.com
+ * - posixunix.scm: marked some old-style setters as deprecated
+
+Tue Nov 7 07:59:26 CET 2006 felix@call-with-current-continuation.org
+ * - slight rearrangement of notes add by Brandon to README/README.darcs
+
+Tue Nov 7 05:23:39 CET 2006 Brandon Van Every <bvanevery@gmail.com>
+ * added mailing list pointers in README files
+
+Sat Nov 4 09:04:31 CET 2006 bunny351@gmail.com
+ * - chicken-setup: uses of `(string=? ... (pathname-extension ...))' use `equal?' now [thanks to Dan Muresan]
+
+Fri Nov 3 11:40:27 CET 2006 felix@call-with-current-continuation.org
+ * - fixed silly bug in `define-deprecated-macro' (used format string without formatting it)
+ - updated new wiki links
+
+Thu Nov 2 22:52:49 CET 2006 bunny351@gmail.com
+ * - posixwin.scm: fixed some problems in "process" and hacked around Win32 limitation (or my lack of knowledge about it)
+
+Mon Oct 30 23:36:02 CET 2006 bunny351@gmail.com
+ * - fixed some comments in compiler.scm, experiments with inline-export
+ - lolevel: "move-memory!" didn't handle string -> locative movement
+ - version is 2.503
+
+Tue Oct 31 08:49:40 CET 2006 felix@call-with-current-continuation.org
+ * - configure.in: better optimization options for Sun compiler [Thanks to Sven Hartrumpf]
+
+Thu Oct 26 12:19:08 CEST 2006 felix@call-with-current-continuation.org
+ * - cscbench: silly bug in call to "suncc -V"
+ - CMakeLists.txt: added option USE_DYNAMIC_C_RUNTIME (passed /MD)
+
+Thu Oct 26 11:28:57 CEST 2006 felix@call-with-current-continuation.org
+ * - posixunix.scm: added setters for file-position, current-user-id, current-group-id, process-group-id
+ - version is 2.502
+
+Thu Oct 26 10:33:00 CEST 2006 felix@call-with-current-continuation.org
+ * suncc check in configure.in was the wrong way around
+
+Thu Oct 26 10:04:33 CEST 2006 felix@call-with-current-continuation.org
+ * - added support for Sun's compiler in cscbench and configure.in
+
+Mon Oct 23 22:51:34 CEST 2006 bunny351@gmail.com
+ * - undid broken flonum-change that resulted in insufficient storage allocation for flonums
+ - chicken-setup: does not include undoc'd extensions in doc-index [thanks to Kon Lovett]
+
+Mon Oct 23 21:57:00 CEST 2006 bunny351@gmail.com
+ * configure.in fixes for double-size detection
+
+Mon Oct 23 21:32:18 CEST 2006 bunny351@gmail.com
+ * - applied Zbigniew's "sizeof(double) == 2" patches
+
+Sat Oct 21 20:58:44 CEST 2006 bunny351@gmail.com
+ * - slight changes to README.darcs
+
+Wed Oct 18 18:21:44 CEST 2006 bunny351@gmail.com
+ * updated README
+
+Fri Oct 20 14:37:26 CEST 2006 felix@call-with-current-continuation.org
+ * - added CHICKEN_SETUP_OPTIONS
+
+Thu Oct 19 14:46:11 CEST 2006 felix@call-with-current-continuation.org
+ * - version is 2.501
+
+Tue Oct 17 10:14:28 CEST 2006 felix@call-with-current-continuation.org
+ * doc update, distribution files update
+
+Mon Oct 16 22:03:48 CEST 2006 bunny351@gmail.com
+ tagged 2.5-release
+
+Mon Oct 16 21:48:05 CEST 2006 bunny351@gmail.com
+ * - version is 2.5
+
+Fri Oct 13 16:31:31 CEST 2006 felix@call-with-current-continuation.org
+ * - chicken-setup: when installing directly from URL, don't ask for download
+
+Thu Oct 12 20:41:23 CEST 2006 bunny351@gmail.com
+ * - removed shootout benchmarks
+ - cscbench: passed -DC_NO_PIC_NO_DLL to cc [Thanks to John Cowan]
+
+Mon Oct 9 21:57:11 CEST 2006 bunny351@gmail.com
+ * - runtime.c: comment typo fix and added cast to remove warning on suncc [Thanks to Sven Hartrumpf]
+
+Thu Oct 12 08:28:35 CEST 2006 felix@call-with-current-continuation.org
+ * - posixunix.scm: WIF_... hack must be enabled for suncc [Thanks to Sven Hartrumpf]
+
+Mon Oct 9 15:37:29 CEST 2006 felix@call-with-current-continuation.org
+ * - small addition to hen.el
+ - runtime.c: invalid string constructor for suncc build-platform id [Thanks to Sven Hartrumpf]
+
+Wed Oct 4 10:20:00 CEST 2006 felix@call-with-current-continuation.org
+ tagged 2.5rc1-snapshot
+
+Wed Oct 4 10:19:36 CEST 2006 felix@call-with-current-continuation.org
+ * - CMakeLists.txt: fetching installed release handles "rc..." suffix
+
+Wed Oct 4 09:21:01 CEST 2006 felix@call-with-current-continuation.org
+ * - version is 2.5rc1
+ - dist wrapping fixes
+
+
+Sun Oct 1 18:33:39 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * capitalized my last name and fixed 2 typos
+
+Sun Oct 1 10:04:50 CEST 2006 bunny351@gmail.com
+ * buildfile doc generation
+
+Sat Sep 30 16:27:14 CEST 2006 bunny351@gmail.com
+ * more packaging fun
+
+Sat Sep 30 15:31:13 CEST 2006 bunny351@gmail.com
+ * - fixed various files - this whole build shit sucks
+
+Sat Sep 30 13:25:44 CEST 2006 bunny351@gmail.com
+ * - more documentation changes
+ - configure.in: put -DC_NO_PIC_NO_DLL here
+
+Sat Sep 30 10:05:55 CEST 2006 bunny351@gmail.com
+ * - chicken-setup: "-test" lists missing extensions
+ - updated NEWS and various documentation files
+
+Sat Sep 30 00:35:47 CEST 2006 bunny351@gmail.com
+ * removed unneeded file from dist.cmake
+
+Fri Sep 29 22:20:47 CEST 2006 bunny351@gmail.com
+ * - autoconf build: -DC_NO_PIC_NO_DLL always defined
+
+Thu Sep 28 13:42:52 CEST 2006 felix@call-with-current-continuation.org
+ * ##sys#peek-c-string-list and makehtmldoc fix
+
+Thu Sep 28 11:02:32 CEST 2006 felix@call-with-current-continuation.org
+ * makehtmldoc fixes
+
+Thu Sep 28 09:00:55 CEST 2006 felix@call-with-current-continuation.org
+ * - dist.cmake: hyphenated html filenames
+ - makehtmldocs improved, added necessary stream-wiki extensions
+
+Wed Sep 27 13:17:53 CEST 2006 felix@call-with-current-continuation.org
+ * html generation fix
+
+Wed Sep 27 12:36:03 CEST 2006 felix@call-with-current-continuation.org
+ * - removed unneeded option passed to CFLAGS in csc
+
+Wed Sep 27 11:10:27 CEST 2006 felix@call-with-current-continuation.org
+ * - makehtmldoc works now [Thanks to Alejandro]
+ - version is 2.434
+
+Mon Sep 25 23:29:34 CEST 2006 bunny351@gmail.com
+ * - csi: narrower feature list in report (",r")
+
+Sat Sep 23 00:07:10 CEST 2006 bunny351@gmail.com
+ * - added "CHICKEN_interrupt()"
+
+Sun Sep 17 14:27:28 CEST 2006 bunny351@gmail.com
+ * - ##sys#macroexpand-0 is externally visible
+ - csi: features are separated by tab in report (,r)
+ - version is 2.433
+
+Sat Sep 23 09:39:24 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * always build Darcs ChangeLog unconditionally so it stays up to date
+
+Mon Sep 25 16:24:19 CEST 2006 felix@call-with-current-continuation.org
+ * htmldocscript fiddling
+
+Mon Sep 25 15:40:03 CEST 2006 felix@call-with-current-continuation.org
+ * - added machine-type, machine-byte-order, software-version and software-type as features [suggested by Kon Lovett]
+
+Mon Sep 25 11:10:08 CEST 2006 felix@call-with-current-continuation.org
+ * - "exn" conditions with no-string "location" property segfaulted error-message priner [Thanks to Peter Bex]
+
+Fri Sep 22 10:16:11 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * define IS_CMAKE_243 to bracket bugs specific to CMake 2.4.3. Not actually used yet.
+
+Thu Sep 21 23:27:42 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * added check for HAVE_ALLOCA
+
+Thu Sep 21 23:26:41 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * MinGW needs malloc.h for alloca
+
+Thu Sep 21 22:56:48 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * proper indentation level for _AIX pragma alloca
+
+Thu Sep 21 19:54:27 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * find darcs, let user specify darcs
+
+Thu Sep 21 11:47:36 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * robust handling of Darcs ChangeLog. Tested on MSYS and MSVC.
+
+Fri Sep 22 12:22:46 CEST 2006 felix@call-with-current-continuation.org
+ * - fixed bug in "foreign-code"
+
+Fri Sep 22 09:58:06 CEST 2006 fw[_\c3_]@emlix.com
+ * posixunix compiles with uCLinux
+
+Fri Sep 22 09:49:19 CEST 2006 felix@call-with-current-continuation.org
+ * - chicken-setup: untarring egg lists contents only in verbose mode
+ - chicken-setup: "-test" option
+ - "foreign-code" accepts multiple strings
+ - sed script for CFLAGS in Makefile.am should handle commas
+
+Tue Sep 19 01:07:09 CEST 2006 klovett@pacbell.net
+ * Fix for (decompose-pathname "/foo") -> ("" "foo") but -> ("/" "foo") correct.
+
+Mon Sep 18 08:01:15 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * attempted to bulletproof install-opengl-egg success / failure report, but found a CMake bug
+
+Mon Sep 18 07:12:18 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * status messages for mkdir, rmdir
+
+Mon Sep 18 05:59:53 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * don't ask whether to download opengl egg
+
+Mon Sep 18 05:31:26 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * added install-opengl-egg target
+
+Sun Sep 17 23:44:22 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * added tutorial comments to CMakeLists.txt
+
+Sat Sep 16 14:10:20 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * build all static libs and exes in /static directory to work around CMake bug
+
+Sat Sep 16 10:34:07 CEST 2006 bunny351@gmail.com
+ * - added html dir to OS X distro build script
+ - chicken-setup: removal of temporary directory may fail now (issues a warning) [Thanks to John Cowan]
+
+Sat Sep 16 09:22:11 CEST 2006 bunny351@gmail.com
+ * - version is 2.432
+
+Sat Sep 16 09:02:48 CEST 2006 bunny351@gmail.com
+ * - help for chicken-setup didn't mention argument to -R option [Thannks to Mario Goulart]
+
+Mon Sep 18 08:17:49 CEST 2006 felix@call-with-current-continuation.org
+ * - chicken.h: uses "..." instead of <...> when including config headers
+
+Fri Sep 15 14:26:53 CEST 2006 felix@call-with-current-continuation.org
+ * - commented out bench target in CMakeLists.txt. Will need modifications to cscbench.scm to handle out of
+ directory builds
+
+Thu Sep 14 19:31:02 CEST 2006 bunny351@gmail.com
+ * cmake bench target (doesn't work yet)
+
+Thu Sep 14 19:09:04 CEST 2006 bunny351@gmail.com
+ * - dist.cmake: refers to new location of cscbench.scm
+
+Thu Sep 14 18:10:37 CEST 2006 bunny351@gmail.com
+ * - cscbench is built in toplevel dir
+ - updated README
+
+Thu Sep 14 17:40:32 CEST 2006 bunny351@gmail.com
+ * - CMakeLists.txt: removed build-type library suffixes
+ - makefile.vc is gone
+
+Thu Sep 14 14:48:33 CEST 2006 felix@call-with-current-continuation.org
+ * - fluid-let with empty binding-list resulted in invalid syntax
+
+Tue Sep 12 18:41:51 CEST 2006 bunny351@gmail.com
+ * - Makefile.am: copying rule for html file ignores status (ugly, but I'm tired)
+
+Tue Sep 12 17:55:04 CEST 2006 bunny351@gmail.com
+ * fixed another misspelling bug in csc.scm
+
+Tue Sep 12 17:53:26 CEST 2006 bunny351@gmail.com
+ * fixed bug in csc.scm regarding cmake-build
+
+Tue Sep 12 13:41:18 CEST 2006 felix@call-with-current-continuation.org
+ * - version-string extraction in CMakeLists.txt handles non-numeric subversion
+ - version is 2.431
+ - chicken-setup: dependency-tree build should now really work [Thanks to Peter Bex]
+
+Tue Sep 12 10:56:27 CEST 2006 bunny351@gmail.com
+ * htmldoc handling in CMakeLists.txt and dist.cmake
+
+Tue Sep 12 10:40:29 CEST 2006 felix@call-with-current-continuation.org
+ * - Makefile.am: installs HTML docs, if available
+ - first attempt at htmldoc handling in CMakeLists.txt
+
+Mon Sep 11 09:48:46 CEST 2006 felix@call-with-current-continuation.org
+ * - fixed bug in CMakeLists.txt
+
+Mon Sep 11 08:39:14 CEST 2006 felix@call-with-current-continuation.org
+ * - added ENABLE_DEBUG_BUILD option to CMakeLists.txt
+
+Mon Sep 11 03:54:41 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * bulletproofing of INCLUDE_DIRECTORIES
+
+Mon Sep 11 03:10:15 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * William Hoffman suggests that putting all INCLUDE directives after the PROJECT directive may be safer
+
+Mon Sep 11 02:43:38 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * make ChangeLog an ALL target so it is available for installation (thanks to Thomas Chust)
+
+Sun Sep 10 14:36:32 CEST 2006 bunny351@gmail.com
+ * - some enhancements to makehtmldoc
+
+Sun Sep 10 13:57:53 CEST 2006 bunny351@gmail.com
+ * - added "cmake" build feature to "chicken-version"
+ - unrecorded obsolete CMakeLists.txt patch for buildversion extraction
+
+
+Sun Sep 10 22:19:13 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * activated rudimentary Dart Dashboard support
+
+Sun Sep 10 08:36:44 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * bulletproof dependencies for parallel builds (suggested by William Hoffman of Kitware)
+
+Sat Sep 9 23:42:01 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * no more BINARY_DIR_FILES
+
+Sat Sep 9 23:27:45 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * make dist needs to be an ADD_CUSTOM_COMMAND with outputs so that if something fails, it is not reported as success
+
+Sat Sep 9 23:21:40 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * simplify error handling of ChangeLog and Darcs
+
+Sat Sep 9 23:15:16 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * remove buildnumber from distribution
+
+Sat Sep 9 22:20:30 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * noted the availabiliby of -release in all tools as of Chicken 2.430 (thanks Felix!)
+
+Fri Sep 8 14:39:13 CEST 2006 felix@call-with-current-continuation.org
+ * - Fixed bug in CMakeLists.txt (missing substitutions for chicken-defaults.h.in) caused by ME, AND ME ALONE, YES!!!
+ - Added `-release' option to all tools (as suggested by Brandon in CMakeLists.txt)
+
+Fri Sep 8 10:53:15 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * use -release to obtain buildversion
+
+Fri Sep 8 09:12:16 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * use the new buildversion file
+
+Fri Sep 8 03:11:26 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * build static libs in /static directory to avoid bug in CMake 2.4.3
+
+Fri Sep 8 02:34:51 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * documented tarball build procedure
+
+Thu Sep 7 08:48:15 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * move Chicken detection to beginning of CMake script, so that we don't waste time doing tedious tests if we can't actually build
+
+Thu Sep 7 16:02:32 CEST 2006 felix@call-with-current-continuation.org
+ * - version-identifer handling simplified
+ - version is 2.430
+
+Thu Sep 7 14:58:07 CEST 2006 felix@call-with-current-continuation.org
+ * - configure.in: kludge BOOT_CFILES for cross-compile from tarball
+ - --without-pcre option
+
+Thu Sep 7 10:47:01 CEST 2006 felix@call-with-current-continuation.org
+ * - slight change in configure.in for omitting boot-file test when cross-compiling
+
+Thu Sep 7 09:28:55 CEST 2006 felix@call-with-current-continuation.org
+ * - some changes related to target-specific CC/CXX and flags
+
+Thu Sep 7 06:52:44 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * add GCC optimization flags
+
+Thu Sep 7 03:34:32 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * include autogen.sh in distro, so that a distro can create a distro
+
+Tue Sep 5 14:12:32 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * don't scold user if they don't have CHICKEN_HOME set. Only legacy MSVC builds should have it set.
+
+Tue Sep 5 01:22:44 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * ship all .c files and use all of them when building a distribution tarball. Autoconf support complete. CMake needs more work to use all .c files.
+
+Mon Sep 4 23:27:22 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * more credit for my extensive Makefile.am hacking
+
+Mon Sep 4 21:57:29 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * require Automake 1.8.3
+
+Mon Sep 4 09:56:13 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * simplify dist dependencies
+
+Mon Sep 4 09:55:59 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * create .zip archive
+
+Mon Sep 4 11:16:32 CEST 2006 felix@call-with-current-continuation.org
+ * misinterpreted BOOT_CFILES
+
+Mon Sep 4 09:27:45 CEST 2006 felix@call-with-current-continuation.org
+ * - CMake-generated distribution didn't include unsafely compiled C files
+
+Mon Sep 4 09:07:44 CEST 2006 felix@call-with-current-continuation.org
+ * - fixed conflict in support.scm
+ - added csi.c to BOOT_CFILES***END OF DESCRIPTION***
+
+ Place the long patch description above the ***END OF DESCRIPTION*** marker.
+ The first line of this file will be the patch name.
+
+
+ This patch contains the following changes:
+
+ M ./CMakeLists.txt +1
+ M ./Makefile.am -1 +1
+ M ./configure.in -1 +1
+ M ./support.scm -2
+
+Mon Sep 4 08:40:15 CEST 2006 felix@call-with-current-continuation.org
+ * fixed conflicts in compiler, commented dependency on automake 1.9.6
+
+Mon Sep 4 05:28:33 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * activate unified bootstrap!
+
+Mon Sep 4 02:27:35 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * consolidate dependencies and use _SOURCES to specify .c files
+
+Sun Sep 3 19:13:17 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * resolve merge conflict and comment about EXECUTE_PROCESS being wrong
+
+Sun Sep 3 10:33:50 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * CMake 'make dist' now runs Autotools and produces a complete distro
+
+Sun Sep 3 00:17:07 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * determine if boot *.c files are available and set conditionals. No actions taken, still just a stub.
+
+Sat Sep 2 19:54:16 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * use += to make bin_PROGRAMS less verbose
+
+Sat Sep 2 19:47:00 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * AM_CONFIG_HEADER is obsolete, use AC_CONFIG_HEADERS
+
+Sat Sep 2 12:21:55 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * EXTRA_LINK_FLAGS not consumed and not a documented part of Autotools, so removed.
+
+Sat Sep 2 12:14:19 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * LINKFLAGS not consumed and not a documented part of Autotools, so removed.
+
+Sat Sep 2 12:13:24 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * USE_BOOT_CFILES conditional stub, doesn't do anything yet
+
+Sat Sep 2 11:50:39 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * refactord posix and regex conditionals to be less verbose
+
+Sat Sep 2 11:49:16 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * no makeinfo, so don't need AM_MAKEINFOFLAGS
+
+Sat Sep 2 16:04:03 CEST 2006 bunny351@gmail.com
+ * - removed compiler-version of "flonum?"
+ - added "finite?"
+ - "define-record[-type]" uses slightly more efficient expansion"
+
+Sat Sep 2 00:09:32 CEST 2006 farr@mit.edu
+ * Updated unsafe-structures.
+
+Fri Sep 1 22:30:00 CEST 2006 farr@mit.edu
+ * Unsafe structures.
+
+Sat Sep 2 09:32:36 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * INCLUDES is depreciated, use AM_CPPFLAGS instead.
+
+Fri Sep 1 22:52:10 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * distribute .exports because ./configure is a one-stage bootstrap and won't generate them itself, unlike CMake
+
+Fri Sep 1 14:58:54 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * distribute 'ltmain.sh' and 'compile' (latter is needed by Autotools 1.9.6)
+
+Fri Sep 1 09:49:04 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * require Automake 1.9.6, which is available in current Cygwin distributions.
+
+Fri Sep 1 08:49:46 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * delete distribution archive before creating it
+
+Fri Sep 1 08:41:31 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * CMake shall be the canonical method for building a distro, so no special designator for tarball name.
+
+Fri Sep 1 11:13:59 CEST 2006 felix@call-with-current-continuation.org
+ * - removed compiler-internal version of "flonum?"
+
+Fri Sep 1 09:26:47 CEST 2006 felix@call-with-current-continuation.org
+ * - incorporated Will Farr's patches for floating-point operations with sane semantics.
+ - added compiler-rewrite rule for "flonum?"
+
+Thu Aug 31 10:00:00 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * distribute configure.in and Makefile.am just in case user wants to dink with something
+
+Thu Aug 31 09:11:26 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * no more *.c.in files. Put files in /boot/cfiles/*.c
+
+Thu Aug 31 09:01:24 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * do not distribute README.darcs
+
+Thu Aug 31 09:00:11 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * remove mkinstalldirs from README
+
+Thu Aug 31 08:59:34 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * clarify INSTALL vs. INSTALL-CMake.txt in README
+
+Thu Aug 31 08:43:20 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * TASKS no longer in Darcs, so removed it from distro and from README
+
+Thu Aug 31 08:37:01 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * mkinstalldirs not needed in distro, install-sh is used
+
+Thu Aug 31 13:05:23 CEST 2006 felix@call-with-current-continuation.org
+ * - CMakeLists.txt: darcs probe should now generate no output (and clobber ccmake output)
+
+Thu Aug 31 00:12:14 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * added Autoconf files to CMake distribution script
+
+Wed Aug 30 22:26:31 CEST 2006 bunny351@gmail.com
+ * - extras.scm: removed 32-bit dependency in "hash" [Thanks to Kon Lovett]
+ - chicken-setup: another missing quotewrap [Reported by Brandon]
+
+
+Wed Aug 30 21:19:25 CEST 2006 bunny351@gmail.com
+ * - csc/chicken-setup: replaced HOST vars with TARGET ones
+
+Tue Aug 29 06:36:55 CEST 2006 bunny351@gmail.com
+ * - chicken-setup: "test-compile" knows a bit about C++, uses different host compiler (defaults to build compiler)
+ - csc: uses different host compiler
+ - chicken-setup: also build from egg-directory (without egg)
+
+Tue Aug 29 05:20:22 CEST 2006 bunny351@gmail.com
+ * - predist: removes unecessary files
+ - reader gives warning on unterminated "here" string literals
+
+Wed Aug 30 22:21:18 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * simplified csi build rule and updated .scm dependencies
+
+Wed Aug 30 15:31:37 CEST 2006 felix@call-with-current-continuation.org
+ * - Makefile.am: program sources (.c) shouldn't depend on chicken executable
+
+Wed Aug 30 10:06:38 CEST 2006 felix@call-with-current-continuation.org
+ * - CMakeLists.txt: csi didn't use build.scm prologue anymore
+
+Wed Aug 30 09:31:35 CEST 2006 felix@call-with-current-continuation.org
+ * - string hashing functions (internal, in runtime.c and external in extras.scm) do not limit number of characters hashed or
+ number of bits returned [suggested by Kon Lovett]
+
+Mon Aug 28 08:47:22 CEST 2006 felix@call-with-current-continuation.org
+ * - chicken-setup: reverses order of egg requirements [Thanks to John Cowan]
+ - extras.scm: "string[-ci]-hash" were broken [Thanks to Kon Lovett]
+
+Sat Aug 26 09:22:33 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * CMake simple names for CC and CXX
+
+Fri Aug 25 23:06:54 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * MSVC legacy compilers cannot be used to bootstrap Cygwin compilers
+
+Fri Aug 25 21:33:36 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * CMake L_MORE_LIBS needs to be converted to a string
+
+Fri Aug 25 10:17:43 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * CMake update dist.cmake
+
+Fri Aug 25 10:06:06 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * CMake merged with Felix's extensive changes
+
+Fri Aug 25 00:23:00 CEST 2006 Brandon Van Every <bvanevery@gmail.com>
+ * use sed to create chicken-defaults.h from chicken-defaults.h.in
+
+Thu Aug 24 01:15:17 CEST 2006 bunny351@gmail.com
+ * - merged with Brandon's stuff:
+ * uses chicken-defaults.h instead of chicken-paths.h
+ * stack-size.h isn't needed anymore
+ * removed nsample
+ - configure.in: didn't AC_SUBST STACK_GROWS_DOWNWARD
+
+Wed Aug 23 23:45:20 CEST 2006 bunny351@gmail.com
+ * merged with head
+
+Wed Aug 23 22:54:30 CEST 2006 bunny351@gmail.com
+ * - small bugfix in Makefile.am
+ - another bugfix in "make-pathname"
+ - bitwise-ops on 64-bit platforms use full 62-bit fixnum range [Thanks to Zbigniew]
+
+Tue Aug 22 00:25:12 CEST 2006 bunny351@gmail.com
+ * - "darcs dist -d chicken-XXX" should generate a proper tarball, now
+
+Mon Aug 21 23:53:59 CEST 2006 bunny351@gmail.com
+ * added predist script
+
+Mon Aug 21 23:36:44 CEST 2006 bunny351@gmail.com
+ * - removed herald stuff again
+ - make-pathname: accepts additional optional separator string
+ - chicken-setup: uses above mentioned feature for constructing download URL [problem reported by Brandon van Every]
+ - simplified build system by removing necessity to run generated executables during build:
+ a) nsample isn't run anymore
+ b) source distribution tarball should contain all files in precompiled (.c) form
+ c) csc uses chicken-defaults.h for build settings
+
+Sun Aug 20 00:32:35 CEST 2006 bunny351@gmail.com
+ * - version is 2.246
+ - added internal support for file heralds (T-ish)
+ - csc: when only given .c files, compile them as C code
+
+Thu Aug 17 23:34:24 CEST 2006 felix@call-with-current-continuation.org
+ * - removed parameters.scm from misc/release.setup, some small modifications
+ - posixunix.scm: added fake "groups" struct def to handle case when grp.h isn't available
+
+Wed Aug 16 21:14:59 CEST 2006 felix@call-with-current-continuation.org
+ tagged 2.425-experimental
+
+Wed Aug 16 21:14:15 CEST 2006 felix@call-with-current-continuation.org
+ * - removed minimake stuff
+
+
+Fri Aug 11 21:22:43 CEST 2006 bunny351@gmail.com
+ * - moved "chicken-home" into eval.scm
+
+Wed Aug 23 14:28:37 CEST 2006 bvanevery@gmail.com
+ * Automake remove extraneous dependencies
+
+Wed Aug 23 13:04:48 CEST 2006 bvanevery@gmail.com
+ * Automake chicken-paths.h should be a BUILT_SOURCES
+
+Wed Aug 23 12:12:55 CEST 2006 bvanevery@gmail.com
+ * comment about inadequacy of nsample benchmarking
+
+Wed Aug 23 10:30:01 CEST 2006 bvanevery@gmail.com
+ * $(DESTDIR) should never be hardwired into application files. See GNU Coding Standards.
+
+Wed Aug 23 10:19:50 CEST 2006 bvanevery@gmail.com
+ * in sed, \@foo\@ is not posix compliant, but @foo[@] is.
+
+Wed Aug 23 10:03:48 CEST 2006 bvanevery@gmail.com
+ * quote the messages
+
+Wed Aug 23 09:51:47 CEST 2006 bvanevery@gmail.com
+ * chicken.h includes chicken-paths.h
+
+Wed Aug 23 00:47:02 CEST 2006 bvanevery@gmail.com
+ * move C_USE_C_DEFAULTS and C_STACK_GROWS_DOWNWARD to chicken-config.h
+
+Wed Aug 23 00:44:38 CEST 2006 bvanevery@gmail.com
+ * credit for Brandon Van Every
+
+Mon Aug 21 19:58:55 CEST 2006 bvanevery@gmail.com
+ * update make clean
+
+Mon Aug 21 19:15:34 CEST 2006 bvanevery@gmail.com
+ * update the uninstall
+
+Mon Aug 21 11:56:32 CEST 2006 bvanevery@gmail.com
+ * remove redundant -DC_STACK_GROWS_DOWNWARD
+
+Mon Aug 21 11:26:25 CEST 2006 bvanevery@gmail.com
+ * comment about stack-size.h
+
+Mon Aug 21 11:22:34 CEST 2006 bvanevery@gmail.com
+ * remove redundant C_USE_C_DEFAULTS conditionals
+
+Mon Aug 21 11:04:43 CEST 2006 bvanevery@gmail.com
+ * pass chicken-paths.h through chicken.h
+
+Mon Aug 21 10:42:47 CEST 2006 bvanevery@gmail.com
+ * guard against multiple inclusions
+
+Mon Aug 21 10:41:16 CEST 2006 bvanevery@gmail.com
+ * comment correction
+
+Sun Aug 20 23:31:52 CEST 2006 bvanevery@gmail.com
+ * forgot to save changes in my editor
+
+Sun Aug 20 22:07:13 CEST 2006 bvanevery@gmail.com
+ * expunge chicken.html, chicken.texi, chicken.info, parameters.scm
+
+Sun Aug 20 15:20:25 CEST 2006 bvanevery@gmail.com
+ * Always bury the dead bodies.
+
+Sun Aug 20 15:05:22 CEST 2006 bvanevery@gmail.com
+ * -DC_STACK_GROWS_DOWNWARD is redundant to -DC_USE_C_DEFAULTS. chicken-paths.h defines it.
+
+Sun Aug 20 15:00:09 CEST 2006 bvanevery@gmail.com
+ * -DC_INSTALL_* paths are redundant to -DC_USE_C_DEFAULTS. chicken-paths.h holds all paths.
+
+Sun Aug 20 14:52:34 CEST 2006 bvanevery@gmail.com
+ * CMake move CMAKE_BUILD to chicken-config.h
+
+Sun Aug 20 14:38:39 CEST 2006 bvanevery@gmail.com
+ * CMake pass -DC_USE_C_DEFAULTS
+
+Sun Aug 20 14:36:52 CEST 2006 bvanevery@gmail.com
+ * -DHAVE_ALLOCA_H does not need to be passed, as it is defined in chicken-config.h
+
+Sun Aug 20 12:36:02 CEST 2006 bvanevery@gmail.com
+ * CMake generate a chicken-config.h
+
+Sat Aug 19 13:16:56 CEST 2006 bvanevery@gmail.com
+ * ./configure changed chicken-defaults.h to chicken-paths.h and stack-size.h. Needed to merge with CMake build.
+
+Sat Aug 19 12:47:44 CEST 2006 bvanevery@gmail.com
+ * CMake configure chicken.spec.in
+
+Fri Aug 11 10:55:31 CEST 2006 bvanevery@gmail.com
+ * CMake removed stray parameters.scm dependency
+
+Fri Aug 11 09:08:50 CEST 2006 felix@call-with-current-continuation.org
+ * - removed "$" and "modify-location" (put into eggs)
+ - fix for "read-line" on PPC by Mari Domenech Goulart
+
+Thu Aug 10 13:47:28 CEST 2006 bvanevery@gmail.com
+ * CMake doesn't require Windows Platform SDK
+
+Thu Aug 10 13:53:26 CEST 2006 felix@call-with-current-continuation.org
+ * - bitwise-operations limit result to 32-bit on 64-bit platforms [problem with overflow reported by Zbigniew Szadkowski]
+
+Thu Aug 10 13:02:18 CEST 2006 felix@call-with-current-continuation.org
+ * - removed chicken.texi and makefile rules
+ - fixed missing constant in optimizer.scm [Thanks to Kon Lovett]
+ - removed "cmake-build" (done directly in csc, now)
+
+Wed Aug 9 15:46:07 CEST 2006 felix@call-with-current-continuation.org
+ * - removed parameters.scm, some simplifications
+
+Tue Aug 8 21:15:23 CEST 2006 bvanevery@gmail.com
+ * removed flat-directory-install, replaced with cmake-build
+
+Tue Aug 8 15:34:15 CEST 2006 felix@call-with-current-continuation.org
+ * - chicken-setup: bugfix for script-installation by Mario
+ - valgrind detected invalid memory access in fprintf implementation
+ - tried to fix massive breakage caused by variable renaming
+
+
+Tue Aug 8 11:34:24 CEST 2006 bvanevery@gmail.com
+ * path rationalization. INSTALL_SHARE_HOME, INSTALL_LIB_HOME, INSTALL_EGG_HOME
+
+Tue Aug 8 09:38:35 CEST 2006 bvanevery@gmail.com
+ * CMake MSVC build uses -s for static lib postfix
+
+Tue Aug 8 07:12:26 CEST 2006 bvanevery@gmail.com
+ * CMake removed 2 leftover easyffi dependencies
+
+Tue Aug 8 00:37:59 CEST 2006 bunny351@gmail.com
+ * - removed easyffi and tinyclos, fixed various bugs in the process
+ - version is 2.424
+
+Mon Aug 7 16:40:04 CEST 2006 felix@call-with-current-continuation.org
+ * - srfi-18: fixed a serious bug in "thread-join!" [Thanks to dgym]
+
+Mon Aug 7 11:27:50 CEST 2006 felix@call-with-current-continuation.org
+ * - chicken-setup: most pathnames used in subshell invocations should be quoted, if containing whitespace
+
+Sat Aug 5 11:14:43 CEST 2006 bvanevery@gmail.com
+ * CMake check for ws2tcpip.h also needs winsock2.h to work
+
+Sat Aug 5 09:12:46 CEST 2006 bvanevery@gmail.com
+ * CMake warn if winsock2.h or ws2tcpip.h is missing.
+
+Sat Aug 5 04:00:59 CEST 2006 bvanevery@gmail.com
+ * CMake Cygwin was symlinking static rather than dynamic libraries
+
+Fri Aug 4 22:28:32 CEST 2006 bvanevery@gmail.com
+ * CMake implemented uninstall
+
+Fri Aug 4 12:15:19 CEST 2006 bvanevery@gmail.com
+ * CMake Cygwin symlink to libchicken-0.a
+
+Fri Aug 4 00:11:30 CEST 2006 bvanevery@gmail.com
+ * CMake use libchicken-s.a to work around CMake 2.4.3 bug in static vs. dynamic library generation
+
+Thu Aug 3 18:21:59 CEST 2006 bvanevery@gmail.com
+ * CMake 2.4.3 clobbers static and dynamic libs with same rootname. Symlinks as workaround, but aren't available on MSYS.
+
+Thu Aug 3 03:26:46 CEST 2006 bvanevery@gmail.com
+ * CMake hyphenated postfix conventions for MSVC
+
+Thu Aug 3 03:24:57 CEST 2006 bvanevery@gmail.com
+ * CMake symlink to cygchicken.dll
+
+Wed Aug 2 00:20:37 CEST 2006 bvanevery@gmail.com
+ * CMake cleanup nomenclature for Cygwin, postfixes for MSVC
+
+Tue Aug 1 08:19:47 CEST 2006 felix@call-with-current-continuation.org
+ * - posixunix.scm: replaced timegm() hack for cygwin/svr4 [Thanks to John Cowan for testing this]
+ - fixed bug in optimization-rule for "call-with-values" [Thanks to Azul for reporting this]
+ - version is 2.423
+
+Mon Jul 31 20:45:37 CEST 2006 bunny351@gmail.com
+ * - removed deprecated "set-dispatch-read-syntax!"
+ - `#!' allows read-marks (used via "sed-read-syntax!") and skips line if followed by whitespace or slash
+
+Mon Jul 31 15:31:32 CEST 2006 felix@call-with-current-continuation.org
+ * - version is 2.422
+ - cscbench: doesn't pass -ldl anymore
+
+Mon Jul 31 12:28:10 CEST 2006 bvanevery@gmail.com
+ * Solaris needs -lrt
+
+Mon Jul 31 07:01:34 CEST 2006 bvanevery@gmail.com
+ * Solaris needs -lsocket
+
+Sun Jul 30 23:28:46 CEST 2006 bvanevery@gmail.com
+ * quotewrapping for non-win because it could be MinGW
+
+Sun Jul 30 22:48:06 CEST 2006 bvanevery@gmail.com
+ * CMake add -c- to tarball name to distinguish CMake build.
+
+Mon Jul 24 21:32:46 CEST 2006 bvanevery@gmail.com
+ * more quotewraps in csc.scm.in
+
+Fri Jul 28 14:43:05 CEST 2006 felix@call-with-current-continuation.org
+ * - posixunix.scm: "local-timezone-abbreviation" doesn't use ->tm_zone on SVR4 [Thanks to John Cowan]
+ - minimal simplification to Makefile.am
+ - added "modify-location"
+
+Mon Jul 24 23:29:50 CEST 2006 bunny351@gmail.com
+ * - csc.scm.in: gets -DHAVE_CHICKEN_CONFIG passed via Makefile.am
+
+Mon Jul 24 19:17:09 CEST 2006 bunny351@gmail.com
+ * fixed comment in csc.scm.in
+
+Mon Jul 24 18:23:31 CEST 2006 bvanevery@gmail.com
+ * CMake INSTALL_LIB_HOME is not the egg directory
+
+Mon Jul 24 17:14:32 CEST 2006 bvanevery@gmail.com
+ * removed hardwired -DHAVE_CHICKEN_CONFIG_H from csc.scm.in. Flags must be passed by the build system through @INSTALL_CFLAGS@
+
+Mon Jul 24 16:39:20 CEST 2006 bvanevery@gmail.com
+ * remove HIERARCHICAL_INSTALL. use CMAKE_BUILD instead.
+
+Mon Jul 24 09:16:32 CEST 2006 bvanevery@gmail.com
+ * CMake handle Cygwin naming conventions
+
+Sun Jul 23 18:26:36 CEST 2006 bvanevery@gmail.com
+ * CMake isolate library naming code
+
+Mon Jul 24 09:15:36 CEST 2006 felix@call-with-current-continuation.org
+ * - csc.scm.in: fixed use of backslash in non-windows path
+
+Sun Jul 23 17:15:45 CEST 2006 bvanevery@gmail.com
+ * CMake makeinfo and darcs need to be ALL targets, thanks to John Cowan
+
+Sat Jul 22 04:52:55 CEST 2006 bvanevery@gmail.com
+ * if win paths should be backslashed
+
+Sat Jul 22 04:42:16 CEST 2006 bvanevery@gmail.com
+ * CMake don't quote the INSTALL_* paths. Let the source files handle that.
+
+Fri Jul 21 11:37:17 CEST 2006 bvanevery@gmail.com
+ * CMake remove stack-size determination from standard build. Too error prone for a multitasking user.
+
+Fri Jul 21 10:19:57 CEST 2006 bvanevery@gmail.com
+ * CMake bumped stack-size samples to 100 and added low-high variance reporting
+
+Fri Jul 21 09:23:07 CEST 2006 bvanevery@gmail.com
+ * CMake ECHO_TARGET to try to prevent tedium and errors with stubbed targets
+
+Fri Jul 21 03:52:06 CEST 2006 bvanevery@gmail.com
+ * CMake test if makeinfo actually works. Discovered EXECUTE_PROCESS is bugged in CMake 2.4.2 for MSYS VC++ corner case.
+
+Thu Jul 20 21:13:35 CEST 2006 bvanevery@gmail.com
+ * CMake test if Darcs works. Remove ' apostrophes from -E echo comments. It can't handle it!
+
+Thu Jul 20 19:27:27 CEST 2006 bvanevery@gmail.com
+ * CMake handle MAKE_NATIVE_C_PATH for all platforms
+
+Fri Jul 21 08:43:01 CEST 2006 felix@call-with-current-continuation.org
+ * - version is 2.421
+
+Thu Jul 20 10:28:15 CEST 2006 felix@call-with-current-continuation.org
+ * - version is 2.42
+ - read-line patch by Zbigniew Szadkowski
+
+Thu Jul 20 06:11:40 CEST 2006 bvanevery@gmail.com
+ * CMake and ./configure use @ for csc.scm.in
+
+Wed Jul 19 21:33:27 CEST 2006 bvanevery@gmail.com
+ * CMake additional empty directory installation paranoia courtesy of Brad King
+
+Wed Jul 19 18:50:03 CEST 2006 bvanevery@gmail.com
+ * CMake fix for eggs directory installation
+
+Wed Jul 19 12:33:10 CEST 2006 felix@call-with-current-continuation.org
+ * csc.scm.in minifix
+
+Wed Jul 19 10:11:37 CEST 2006 bvanevery@gmail.com
+ * CMake MAKE_WINDOWS_PATH should not escape the quotes
+
+Wed Jul 19 07:23:38 CEST 2006 bvanevery@gmail.com
+ * CMake comments about compiler paths and optimizations
+
+Wed Jul 19 10:51:00 CEST 2006 felix@call-with-current-continuation.org
+ * - fixed links in site/index.html [Thanks to Alex Drummond and Toby Butzon]
+ - extra symbol slot was handled incorrectly in ##sys#make-symbol [Thanks to Benedikt Rosenau]
+
+Wed Jul 19 07:05:42 CEST 2006 bvanevery@gmail.com
+ * CMake mirror the INSTALL_* pathnames as generated by ./configure
+
+Wed Jul 19 06:22:39 CEST 2006 bvanevery@gmail.com
+ * CMake if MAKE_WINDOWS_PATH is passed an already escaped or backslashed pathname, fail the build.
+
+Tue Jul 18 19:30:54 CEST 2006 bvanevery@gmail.com
+ * CMake MAKE_WINDOWS_PATH escape quotes and backslashes but not whitespace
+
+Mon Jul 17 12:18:01 CEST 2006 bvanevery@gmail.com
+ * CMake don't need quotes on STACK_GROWS_DOWNWARD
+
+Mon Jul 17 21:45:49 CEST 2006 bunny351@gmail.com
+ tagged 2.41-release
+
+Mon Jul 17 17:36:28 CEST 2006 bunny351@gmail.com
+ * - version is 2.41
+
+Mon Jul 17 15:59:53 CEST 2006 felix@call-with-current-continuation.org
+ * - version is 2.402
+ - fixed bug in library.scm (token after #endif)
+ - on cygwin, cygchicken-0 is used until we figure out more details
+
+
+Mon Jul 17 11:20:05 CEST 2006 bvanevery@gmail.com
+ * CMake removed chicken-defaults.h, replaced with chicken-paths.h and stack-size.h
+
+Mon Jul 17 07:35:39 CEST 2006 felix@call-with-current-continuation.org
+ * - dynamic-load-libraries is now always '("libchicken")
+
+Sun Jul 16 09:59:04 CEST 2006 bunny351@gmail.com
+ * - version is 2.401
+
+Sun Jul 16 09:58:29 CEST 2006 bunny351@gmail.com
+ * - chicken-setup: patch by Zbigniew Szadkowski fixed several problems; requirements where not correctly processed
+
+Sat Jul 15 16:06:22 CEST 2006 bunny351@gmail.com
+ tagged 2.4-release
+
+Sat Jul 15 16:05:59 CEST 2006 bunny351@gmail.com
+ * VC++ makefile didn't compile llibs with lambda info
+
+Sat Jul 15 16:07:54 CEST 2006 felix@call-with-current-continuation.org
+ * removed refs to partition.* in release script
+
+Sat Jul 15 14:12:23 CEST 2006 bunny351@gmail.com
+ * - makefile.vc: removed unneded -DC_APPLY_HOOK
+
+Sat Jul 15 13:56:24 CEST 2006 bunny351@gmail.com
+ * - small fixes in release script
+
+Sat Jul 15 12:43:40 CEST 2006 bunny351@gmail.com
+ * added file to file-list in README
+
+Sat Jul 15 12:36:06 CEST 2006 bunny351@gmail.com
+ * - added site dir and chicken image
+ - chicken-setup: "-no-install" implied "-keep" (but doesn't pass -k to csc)
+ - fprintf: didn't check type of port argument
+ - version is 2.326
+ - version is 2.4
+
+Sun Jul 16 08:00:24 CEST 2006 bvanevery@gmail.com
+ * CMake nursery support
+
+Sat Jul 15 09:04:38 CEST 2006 bvanevery@gmail.com
+ * CMake removed errant reference to vars.cmake.in
+
+Fri Jul 14 15:39:14 CEST 2006 felix@call-with-current-continuation.org
+ * - pathname-directory-separator on mingw32 should be #\\, or not?
+
+Fri Jul 14 08:50:55 CEST 2006 bvanevery@gmail.com
+ * CMake forgot to actually kill, flog, harass, maim, and utterly destroy vars.cmake.in
+
+Fri Jul 14 08:36:46 CEST 2006 bvanevery@gmail.com
+ * CMake remove vars.cmake.in hack. Use -D argument passing method.
+
+Fri Jul 14 07:17:34 CEST 2006 bvanevery@gmail.com
+ * CMake more licenses
+
+Fri Jul 14 14:24:40 CEST 2006 felix@call-with-current-continuation.org
+ * - marked "critical-section" and "(enable|disable)-interrupts" as deprecated (and removed
+ them from texi)
+ - csc: wraps translator name in double-quotes, if containing whitespace
+ - parameters.scm: still had traces of "libchicken-0" for dynamic loading, which is obsolete [Thanks to Ian Oversby]
+
+Fri Jul 14 04:28:16 CEST 2006 bvanevery@gmail.com
+ * CMake correct error messages for .c.in generation
+
+Fri Jul 14 04:27:21 CEST 2006 bvanevery@gmail.com
+ * CMake distribute all benchmarks and tests
+
+Fri Jul 14 03:33:30 CEST 2006 bvanevery@gmail.com
+ * CMake tarball distribution capability fully implemented
+
+Fri Jul 14 07:34:31 CEST 2006 felix@call-with-current-continuation.org
+ * - used better test-case for srfi-18/mutex bug [Thanks to G[_\c3_][_\b6_]ran Weinholt]
+ - eval.scm: repl flushes stderr on error [Thanks to Ian Oversby]
+
+
+Thu Jul 13 11:05:35 CEST 2006 felix@call-with-current-continuation.org
+ * - renamed "benchmark/plists" to "plists.scm"
+
+Thu Jul 13 00:39:31 CEST 2006 bunny351@gmail.com
+ * - csi: added "set-describer!"
+ - version is 2.325
+
+Mon Jul 10 22:16:39 CEST 2006 bunny351@gmail.com
+ * - added new web-page in misc/index.html
+
+Sun Jul 9 00:54:06 CEST 2006 bunny351@gmail.com
+ * - removed cmake-related files from tarball (temporarily)
+ - slight changes in README and manual
+ - eval: ##sys#load uses normal eval procedure
+
+Wed Jul 12 02:13:01 CEST 2006 bvanevery@gmail.com
+ * CMake move FIND_CHICKEN to /boot
+
+Tue Jul 11 22:08:31 CEST 2006 bvanevery@gmail.com
+ * CMake move .c.in handling to /boot
+
+Tue Jul 11 17:32:31 CEST 2006 bvanevery@gmail.com
+ * CMake boot/CMakeLists.txt license
+
+Thu Jul 13 08:34:21 CEST 2006 felix@call-with-current-continuation.org
+ * - removed "##sys#error-at"
+
+Tue Jul 11 04:04:44 CEST 2006 bvanevery@gmail.com
+ * CMake commented the license
+
+Tue Jul 11 03:54:01 CEST 2006 bvanevery@gmail.com
+ * CMake added Copyright 2006 by Brandon J. Van Every under MIT-style license
+
+Tue Jul 11 07:36:00 CEST 2006 felix@call-with-current-continuation.org
+ * - added srfi-18/mutex buf by G[_\c3_][_\b6_]ran Weinholt to test-suite
+
+Mon Jul 10 09:38:39 CEST 2006 bvanevery@gmail.com
+ * CMake tarball capability, i.e. Chickenless bootstrap
+
+Mon Jul 10 14:15:12 CEST 2006 felix@call-with-current-continuation.org
+ * - csc: added "-library", which is equivalent to "-dll" to link dynamic libs
+
+Sat Jul 8 09:43:21 CEST 2006 bvanevery@gmail.com
+ * CMake [_^V_]ChangeLog.0-20040412 isn't the ChangeLog we actually want to install.
+
+Thu Jul 6 23:01:37 CEST 2006 bvanevery@gmail.com
+ * CMake typo causing liblibuchicken.dll.a problem
+
+Thu Jul 6 21:41:14 CEST 2006 bvanevery@gmail.com
+ * CMake create and install chicken.info
+
+Thu Jul 6 21:30:11 CEST 2006 bvanevery@gmail.com
+ * CMake install .exports to share/chicken, docs to share/chicken/docs
+
+Wed Jul 5 16:52:09 CEST 2006 klovett@pacbell.net
+ * Added match-error-procedure - sets/gets proc called upon a match error
+
+Wed Jul 5 10:42:08 CEST 2006 bvanevery@gmail.com
+ * CMake posixunix and regexunix rename
+
+Tue Jul 4 23:51:58 CEST 2006 bunny351@gmail.com
+ * - renamed posix.scm and regex.scm to posixunix.scm and regexunix.scm, respectively [suggested by Brandon van Every]
+
+Tue Jul 4 22:01:03 CEST 2006 bunny351@gmail.com
+ * - version is 2.324
+
+Mon Jul 3 23:53:56 CEST 2006 bvanevery@gmail.com
+ * distinguish CMake builds with -DCMAKE_BUILD
+
+Mon Jul 3 23:16:40 CEST 2006 bvanevery@gmail.com
+ * CMake handle makeinfo only at configuration time
+
+Sun Jul 2 23:05:35 CEST 2006 bunny351@gmail.com
+ * - removed invalid use of `->string' in eval unit (`set-extension-specifier!')
+ - removed procedure-checks from many internal calls
+
+Thu Jun 29 00:41:34 CEST 2006 bunny351@gmail.com
+ * - pathname-expansion handles "~<user>/...", albeit hackishly (just prefixes with hardcoded "/home/")
+ - printing unreadable symbols in readable mode only escapes vertical bar [suggested by John Cowan]
+ - changed readable-symbol check in printer to be more exact [also suggested by John]
+
+Wed Jun 28 22:16:08 CEST 2006 bunny351@gmail.com
+ * - added `-import' option and `import' declaration
+
+Wed Jun 28 10:17:07 CEST 2006 felix@call-with-current-continuation.org
+ * - optimizer addition that removes calls to functions declared 'constant and whose results is not used
+ - version is 2.323
+
+Tue Jun 27 18:40:53 CEST 2006 bunny351@gmail.com
+ * - removed partition.scm from boot/CMakeLists.txt
+
+Tue Jun 27 18:25:32 CEST 2006 bunny351@gmail.com
+ * - added 'easyffi c/t feature id
+ - added `constant' declaration specifier
+
+Fri Jun 23 20:35:59 CEST 2006 bunny351@gmail.com
+ * - added missing declaration to regex.scm
+ - removed output-file partitioning and "-split..." options
+
+Wed Jun 21 22:18:42 CEST 2006 bunny351@gmail.com
+ * - "keep-shadowed-macros" declaration specifier
+
+
+Wed Jun 28 07:12:19 CEST 2006 felix@call-with-current-continuation.org
+ * - removed unused format.txt
+
+Tue Jun 27 14:07:15 CEST 2006 felix@call-with-current-continuation.org
+ * - posix: "glob" didn't include dotfiles
+
+Tue Jun 27 08:27:14 CEST 2006 felix@call-with-current-continuation.org
+ * - chicken-setup: "examples" setup property
+ - reader is a bit more sane when printing symbols with non-standard chars [thanks to John Cowan]
+
+Mon Jun 26 07:56:49 CEST 2006 felix@call-with-current-continuation.org
+ * - added cygwin-specific handling of string<->number conversion for +nan and +/-inf
+
+Fri Jun 23 09:44:31 CEST 2006 felix@call-with-current-continuation.org
+ * - Makefile.am: uninstall still forgot some files [Thanks to Sven Hartrumpf]
+
+Fri Jun 23 07:51:40 CEST 2006 felix@call-with-current-continuation.org
+ * - csc.scm.in: fixed call to "flat-directory-install"
+
+Fri Jun 23 07:45:50 CEST 2006 felix@call-with-current-continuation.org
+ * - removed thread-interrupt stuff, there needs to be a better way...
+
+Thu Jun 22 11:30:22 CEST 2006 felix@call-with-current-continuation.org
+ * - README: updated link to libffi library on call/cc.org
+ - chicken-setup: lists installed documentation [suggested by Matthew Welland]
+ - runtime: minimal support for triggering interrupts from other native threads [suggested by Joerg Wittenberger]
+ - version is 2.322
+
+Wed Jun 21 14:35:12 CEST 2006 felix@call-with-current-continuation.org
+ * - chicken-setup: removed spurious unquote from "simple-install"
+
+Wed Jun 21 11:24:31 CEST 2006 felix@call-with-current-continuation.org
+ * - +inf/-inf/+nan weren't recognized with trailing ".0"
+ - chicken-setup: added "find-header"
+
+Mon Jun 19 13:35:17 CEST 2006 felix@call-with-current-continuation.org
+ * - Makefile.am: `uninstall' didn't remove all files [Thanks to Sven Hartrumpf]
+
+Mon Jun 19 09:17:09 CEST 2006 felix@call-with-current-continuation.org
+ * - runtime.c: assertion in locative-update procedure was wrong
+
+Sat Jun 17 23:25:17 CEST 2006 bunny351@gmail.com
+ * - chicken-setup: added "installation-prefix" and "find-library", documented "test-compile"
+ - chicken-setup: added progress indication for download
+ - chicken-setup: absolute pathnames in list file-specs where not handled properly
+ - version is 2.321
+
+Fri Jun 16 13:27:07 CEST 2006 bunny351@gmail.com
+ * - compiler: when a toplevel variable is defined with the same name ass a macro, then the
+ macro is undefined (in addition to showing a warning)
+ - version is 2.320
+
+Fri Jun 16 18:22:23 CEST 2006 bvanevery@gmail.com
+ * CMake "\"FILEPATH\"" in defines. Not sure if it's correct, but the build swallows it. csc -version still broken.
+
+Thu Jun 15 20:33:29 CEST 2006 bunny351@gmail.com
+ * - extras: added `string-chomp'
+ - csi: renamed `,what' to `,info'
+ - version is 2.319
+ - slightly better syntax check for `$'
+
+Thu Jun 15 04:58:39 CEST 2006 bvanevery@gmail.com
+ * CMake more aggressive dependency system for silex
+
+Wed Jun 14 15:15:42 CEST 2006 bvanevery@gmail.com
+ * CMake need to promote single digit build numbers to the 100's when canonizing.
+
+Wed Jun 14 08:05:24 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * CMake remove csi detection as it's no longer needed.
+
+Wed Jun 14 07:56:28 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * CMake reinstate silex.exe method of generating easyffi.l.silex
+
+Wed Jun 14 04:39:25 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * CMake remove stray strange comment
+
+Tue Jun 13 18:41:30 CEST 2006 bunny351@gmail.com
+ * - chicken-setup.1: added section for environment variables
+ - chicken.texi: added acknowledgments
+
+Tue Jun 13 16:37:24 CEST 2006 bunny351@gmail.com
+ * - runtime: added C_dbg_hook() as a debugging aid
+ - runtests.sh: compiles and runs benchmarks just once
+ - unsafe runtime is compiled with -DNDEBUG
+ - Locative stress-test turned up bug in update_locative_table(): pointed-at object of locative had to be
+ checked for forwarding twice [Thanks to XXX for reporting this and Kon Lovett for providing a stress test]
+ - added support for CHICKEN_PREFIX [Thanks to XXX]
+ - csc: added `-dry-run' option
+
+Mon Jun 12 15:23:08 CEST 2006 bunny351@gmail.com
+ * - unpulled QUOTED_C_INSTALL_HOME, since it breaks on UNIX
+ - fix in chicken.texi
+
+Mon Jun 12 14:41:53 CEST 2006 bunny351@gmail.com
+ * - chicken-setup fix, added svn repo addr to homepage
+ - added cmake scripts to README and distribution/release.scm
+ - version is 2.318
+
+Sun Jun 11 22:34:05 CEST 2006 bunny351@gmail.com
+ * - chicken-setup: added `setup-verbose-flag' and `setup-install-flag' parameters
+ - version is 2.317
+
+Sat Jun 10 00:53:23 CEST 2006 bunny351@gmail.com
+ * - selected another banner
+
+Tue Jun 13 13:31:40 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * CMake escape the double quotes when obtaining DEFINITIONS flags. This fixes csc -cflags problem.
+
+Mon Jun 12 14:32:17 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * CMake LIST2STRING function
+
+Mon Jun 12 12:05:10 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * quotes are needed around inputs to vars.cmake.in
+
+Mon Jun 12 07:16:44 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * CMake won't replace @VARIABLES@. Switching to %VARIABLES%
+
+Mon Jun 12 04:04:01 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * comments to stdout when generating csc.scm and chicken-defaults.h
+
+Sat Jun 10 05:20:48 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * CMake hierarchical install. Broken due to Windows drive letter problem. Should not change behavior of other builds, knock on wood.
+
+Fri Jun 9 07:15:48 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * libchickengui is the expected naming convention. Also missing some static libs for it.
+
+Fri Jun 9 23:39:03 CEST 2006 bunny351@gmail.com
+ * - csc: passes "-Wl,..." to compiler/linker [suggested by Peter Bex]
+ - chicken-setup: delete's old .so's before installing a replacement [thanks to Peter Bex and Thomas Chust]
+
+Fri Jun 9 22:34:18 CEST 2006 bunny351@gmail.com
+ * - fixed broken link to debian package [thanks to Brandon van Every]
+ - removed vcbuild.bat
+
+Thu Jun 8 19:16:31 CEST 2006 bunny351@gmail.com
+ * - added "uninstall" target to Makefile.am
+ - tcp: added "tcp-buffer-size" and optional output-buffering [suggested by Graham Fawcett]
+
+Thu Jun 8 14:16:03 CEST 2006 bunny351@gmail.com
+ * - chicken-setup: ignores egg-requirements for core library units, several small fixes
+
+Wed Jun 7 12:19:30 CEST 2006 bunny351@gmail.com
+ * tiny fix in NEWS
+
+Fri Jun 9 06:09:00 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * added flat-directory-install to runtime to distinguish msvc built with vcbuild.bat or CMake. No behavioral changes yet.
+
+Thu Jun 8 11:41:50 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * CMake bletcherous hack to allow regex of csc.scm.in. Currently only copies, no regex.
+
+Thu Jun 8 04:54:40 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * updated CMake documentation and moved it to INSTALL-CMake.txt
+
+Wed Jun 7 10:24:32 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * CMake UNSAFE units were missing .c suffix.
+
+Wed Jun 7 09:57:34 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * CMake detect direct.h. This solves the easyffi.l.silex generation problem.
+
+Wed Jun 7 03:51:26 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * CMake detect alloca.h crt_externs.h gcvt stdint.h sysexits.h
+
+Wed Jun 7 01:54:45 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * MinGW should get winsock2.h in posixwin.scm
+
+Wed Jun 7 00:40:36 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * detect LoadLibrary and GetProcAddress
+
+Tue Jun 6 16:32:59 CEST 2006 bunny351@gmail.com
+ * - version is 2.316
+
+Fri Jun 2 14:18:25 CEST 2006 Burton Samograd <kruhft@gmail.com>
+ * update sed_quote_subst to handle commas (,) in CFLAGS
+ A build error occured when the CFLAGS variable contained a comma, such
+ as with the -mfpmath=sse,387 option. This fixes that by adding a
+ comma to the list of characters that are quoted.
+
+Mon Jun 5 00:31:35 CEST 2006 bunny351@gmail.com
+ * - fixed bug in configure.in that would erase CFLAGS
+
+Tue Jun 6 13:25:37 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * make html generation part of ALL target
+
+Tue Jun 6 11:15:16 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * .exports installation wasn't grabbing from correct directory
+
+Tue Jun 6 10:06:50 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * VC++ does not handle split line COMMENT
+
+Tue Jun 6 09:17:21 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * don't generate .exports dependencies for boot compiler
+
+Tue Jun 6 08:28:17 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * informative build comments
+
+Tue Jun 6 07:37:32 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * UNSAFE libraries no longer emit .exports
+
+Tue Jun 6 05:30:45 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * more explicit dependencies to prevent duplicate .c generation
+
+Mon Jun 5 07:09:41 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * use extant csi to build chicken-boot
+
+Mon Jun 5 00:05:08 CEST 2006 bunny351@gmail.com
+ * - typo in csi.scm [Thanks to Kon Lovett]
+
+Sun Jun 4 23:43:13 CEST 2006 felix@call-with-current-continuation.org
+ tagged 2.315-snapshot
+
+Sun Jun 4 23:42:41 CEST 2006 felix@call-with-current-continuation.org
+ * release script fixes, moved wwchicken into misc and cleanup
+
+Sun Jun 4 23:14:30 CEST 2006 felix@call-with-current-continuation.org
+ * release script, doc fixes
+
+Sun Jun 4 22:41:26 CEST 2006 felix@call-with-current-continuation.org
+ * distribution script and release preparations
+
+Sun Jun 4 21:52:27 CEST 2006 bunny351@gmail.com
+ * - added acknowledgments to NEWS
+
+Sat Jun 3 01:13:03 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * 1st stage bootstrapping support
+
+Fri Jun 2 21:32:00 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * macrotize chicken C source list for subdirectories
+
+Fri Jun 2 09:44:44 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * macrotize C source lists for subdirectories
+
+Fri Jun 2 08:14:00 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * generalized build rules for use by subdirectories
+
+Fri Jun 2 06:23:03 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * separate library flags from library generation in prep for subdirectories
+
+Fri Jun 2 11:30:39 CEST 2006 felix@call-with-current-continuation.org
+ * - define-foreign-enum exposes transformer procedures [suggested by Kon Lovett]
+
+
+Fri Jun 2 02:34:15 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * don't need an INCLUDE file to pass variables to subdirectories
+
+Thu Jun 1 22:41:22 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * dialog box warning when .exports not generated
+
+Thu Jun 1 22:36:23 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * dlfcn.h does not imply -ldl
+
+Thu Jun 1 21:06:45 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * failed stack growth tests should be set -1 for no result
+
+Thu Jun 1 19:53:36 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * shared flags needs -DC_NO_PIC_NO_DLL
+
+Thu Jun 1 19:50:32 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * regex-common typo
+
+Thu Jun 1 11:22:40 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * add global.cmake in preparation for staged build subdirectory refactoring
+
+Thu Jun 1 08:49:29 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * allow build with Chicken 2.3 but warn about lack of .exports
+
+Thu Jun 1 07:56:57 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * send more errors when FIND_CHICKEN fails
+
+Thu Jun 1 07:17:56 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * no longer need silex.c
+
+Thu Jun 1 07:15:30 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * SAFE and UNSAFE libraries emit same .exports
+
+Thu Jun 1 06:13:07 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * generate easyffi.l.silex using generated csi-static
+
+Thu Jun 1 05:22:52 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * .exports installation
+
+Wed May 31 11:37:52 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * MINGW needs __int64
+
+Tue May 30 06:13:13 CEST 2006 felix@call-with-current-continuation.org
+ * - extras: Graham Fawcett contributed "queue-push-back[-list]!"
+
+Tue May 30 01:47:56 CEST 2006 felix@call-with-current-continuation.org
+ * - unsafe core libraries don't emit export files [reported by Brandon van Every]
+ - fixed bug in stack-direction-tester for CMake build
+
+Mon May 29 09:13:21 CEST 2006 felix@call-with-current-continuation.org
+ * - srfi-1: bugfix in `list=' [reported by John Cowan, characterized by saccade and found by
+ Taylor Campbell]
+ - library: I/O on closed ports triggers an error [suggested by Azul]
+
+Fri Jun 2 07:32:20 CEST 2006 felix@call-with-current-continuation.org
+ * - __int64 type name for easyffi
+
+Tue May 30 12:12:56 CEST 2006 felix@call-with-current-continuation.org
+ * - trivial changes in NEWS
+ - version is 2.315
+ - integer64 fix
+
+Mon May 29 14:23:28 CEST 2006 felix@call-with-current-continuation.org
+ * - README: note about OS X DYLD_LIBRARY_PATH [Thanks to Arto Bendiken]
+ - support for `integer64' foreign type specifier [suggested by Alejandro Forero Cuervo]
+
+Thu May 25 00:04:03 CEST 2006 bunny351@gmail.com
+ * - singlestep didn't swallow newline
+
+Wed May 24 22:52:38 CEST 2006 bunny351@gmail.com
+ * - added distribution directory and OS X build script
+ - added `--without-libffi' configuration option
+
+Sun May 21 00:20:18 CEST 2006 bunny351@gmail.com
+ * - csi: nicer feature list on ",r"
+ - version is 2.314
+
+Wed May 24 14:37:27 CEST 2006 felix@call-with-current-continuation.org
+ * - CMakeLists.txt: ...-macros.scm files go into share
+
+Wed May 24 10:47:51 CEST 2006 felix@call-with-current-continuation.org
+ * - CMakeLists.txt: all libraries should be installed in lib (not share)
+
+Wed May 24 08:20:29 CEST 2006 felix@call-with-current-continuation.org
+ * - posixwin.scm: removed inclusion of windows.h [suggested by Brandon van Every]
+
+Tue May 23 08:41:09 CEST 2006 felix@call-with-current-continuation.org
+ * - DragonFly-specific patches [Thanks to Peter Bex]
+ - removed windows.h from chicken.h
+
+Mon May 22 10:28:33 CEST 2006 felix@call-with-current-continuation.org
+ * - resolved conflict in CMakeLists.txt
+
+Mon May 22 09:58:18 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * test if stack grows downward at configuration time
+
+Mon May 22 09:56:06 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * support for C_STACK_GROWS_DOWNWARD
+
+Mon May 22 10:11:23 CEST 2006 felix@call-with-current-continuation.org
+ * - fixed typo in CMakeLists.txt
+
+Mon May 22 09:33:42 CEST 2006 felix@call-with-current-continuation.org
+ * - singlestepping: "skip" command
+ - runtime: unsafe resolve_procedure is macro
+ - simplified configure/Makefile (got rid of EXTRA_RUNTIME_FLAGS)
+ - apply-hooks and ptables are enabled by default
+ - CMakeLists.txt: modified user-options to be consistent with configure.in
+
+Mon May 22 03:00:42 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * build nsample
+
+Mon May 22 02:41:16 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * put shared libraries in /share
+
+Mon May 22 01:17:55 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * build chicken.html
+
+Mon May 22 00:30:40 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * better error message when Chicken not found
+
+Sun May 21 23:41:50 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * remove unnecessary .exe suffixes from FIND_CHICKEN
+
+Sun May 21 22:04:02 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * comments about order of <winsock2.h> and <windows.h>
+
+Sun May 21 22:01:17 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * move <windows.h> after <winsock2.h>
+
+Sun May 21 21:57:59 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * change "windows.h" to <windows.h>
+
+Sun May 21 21:22:53 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * include <io.h> to define _isatty
+
+Sun May 21 20:48:29 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * correct generator path for silex.exe
+
+Sun May 21 10:35:43 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * removed commands that don't appear to be needed
+
+Sun May 21 00:01:00 CEST 2006 bunny351@gmail.com
+ * - invalid-procedure-handler wasn't called for `apply'-triggered calls
+
+Wed May 17 17:24:18 CEST 2006 felix@call-with-current-continuation.org
+ * - CMakeLists.txt: option for apply hook
+
+Wed May 17 16:34:29 CEST 2006 felix@call-with-current-continuation.org
+ * - manual fixes by John Cowan
+
+Wed May 17 06:34:48 CEST 2006 felix@call-with-current-continuation.org
+ * - makefile.vc fixes
+
+Tue May 16 20:27:17 CEST 2006 felix@call-with-current-continuation.org
+ * - moved "breakpoint" into library
+ - basic single-stepping (",step", "singlestep")
+
+Tue May 16 09:29:19 CEST 2006 felix@call-with-current-continuation.org
+ * - renamed "thread-deliver-signal!" to "thread-signal!" (old is deprecated)
+ - ",utr" didn't remove item from traced proc list
+ - multithreaded breakpoints
+ - version is 2.313
+
+Tue May 16 07:15:42 CEST 2006 felix@call-with-current-continuation.org
+ * - csi:
+ * ",utr" without args isn't supported anymore
+ * breakpoints (",br", ",ubr", ",c", and "breakpoint")
+
+Sat May 20 06:43:20 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * csi.c generation bug
+
+Fri May 19 22:59:08 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * resolve INSTALL conflict
+
+Fri May 19 22:28:31 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * eliminated ADD_FILE_DEPENDENCIES
+
+Tue May 16 09:37:09 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * install to subdirectories
+
+Tue May 16 07:49:48 CEST 2006 felix@call-with-current-continuation.org
+ * my fault
+
+Mon May 15 09:08:30 CEST 2006 felix@call-with-current-continuation.org
+ * fix conflicts in CMakeLists.txt
+
+Mon May 15 23:09:00 CEST 2006 bunny351@gmail.com
+ * - removed distro stuff
+ - removed last traces of chicken-match-macros from CMakeLists.txt and win-install.bat
+ - Argh! chicken.scm still referenced chicken-match-macros.scm
+ k***END OF DESCRIPTION***
+
+ Place the long patch description above the ***END OF DESCRIPTION*** marker.
+ The first line of this file will be the patch name.
+
+
+ This patch contains the following changes:
+
+ M ./CMakeLists.txt -1 +1
+ M ./chicken.scm -2 +1
+ R ./distribution/
+ R ./distribution/chicken-osx.pmproj
+ M ./win-install.bat -1
+
+Mon May 15 22:19:47 CEST 2006 bunny351@gmail.com
+ * - basic support for apply-hooks
+ - added `C_return'
+ - lolevel: renamed `invalid-procedure-call-handler' to `set-invalid-procedure-call-handler!' (old name is deprecated)
+
+Mon May 15 23:46:45 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * .scm to .c compilation
+
+Mon May 15 13:27:14 CEST 2006 felix@call-with-current-continuation.org
+ * - csi: toplevel-command `,exn'
+ - chicken-ffi-macros.scm: bugfix in `define-foreign-record' [by Kon Lovett]
+ - library: `machine-byte-order'
+
+Sat May 13 23:13:47 CEST 2006 bunny351@gmail.com
+ * - changed silex.scm to accept an output-file name [suggested by Brandon van Every]
+
+Sat May 13 21:57:56 CEST 2006 bunny351@gmail.com
+ * - version is 2.312
+ - "$": added support for SRFI-4 literals
+ - modified test driver for being more convenient (and put bootstrapping test into separate file)
+
+Fri May 12 21:30:36 CEST 2006 bunny351@gmail.com
+ * - removed transcript-on/off from r4rs-enironment
+ - ffi: added "$" macro
+
+Fri May 12 09:36:40 CEST 2006 bunny351@gmail.com
+ * - `foreign-...' macros do slightly better syntax syntax checks
+ - removed `allow-null:' foreign-record spec again
+ - csc: doesn't escape backtick in sub-pass options
+
+
+Thu May 11 23:31:07 CEST 2006 bunny351@gmail.com
+ * - eval.scm: macroexpansion error-handling wrapper wasn't updated to new condition layout
+ - `define-foreign-record': `allow-null:' modifier
+ - added `srfi-31' to builtin srfi list [thanks to Dan Muresan]
+
+Wed May 10 20:26:18 CEST 2006 bunny351@gmail.com
+ * - removed unused procedure from eval (`##sys#undefine-non-standard-macros')
+
+Thu May 11 08:24:06 CEST 2006 felix@call-with-current-continuation.org
+ * - runtime option `-:D' (shows currently when apply-limit is exceeded with libffi)
+
+Wed May 10 13:45:39 CEST 2006 felix@call-with-current-continuation.org
+ * - version is 2.311
+
+Wed May 10 11:18:25 CEST 2006 bunny351@gmail.com
+ * - pointer printing prefixes address with "0x"
+
+Wed May 10 13:43:28 CEST 2006 felix@call-with-current-continuation.org
+ * - chicken-setup: didn't remove old export-entries from setup info
+
+Mon May 8 11:35:03 CEST 2006 felix@call-with-current-continuation.org
+ * - yet another fix to the handling of SRFI-12 signals [by Reed Sheridan, modified by felix]
+
+Mon May 8 10:30:57 CEST 2006 felix@call-with-current-continuation.org
+ * - removed some unused local shadowing bindings for "string"
+
+Mon May 8 09:35:57 CEST 2006 felix@call-with-current-continuation.org
+ * - Added optimization inline rule for "string"
+
+Sat May 6 00:39:02 CEST 2006 Thomas Chust <chust@web.de>
+ * Ignore complex extension specifiers when loading export declarations
+
+Sat May 6 00:20:28 CEST 2006 Thomas Chust <chust@web.de>
+ * Ignore keywords when scanning for read access to undefined symbols
+
+Mon May 8 07:34:16 CEST 2006 felix@call-with-current-continuation.org
+ * - bugfix in "condition-property-accessor" [By Kon Lovett]
+ - undocumented "foreign-safe-wrapper"
+ - fixed bug in handling of `c-string' result type [Thanks to Heath Johns]
+ - added export-file generation for scheduler [reported by Thomas Chust]
+
+Mon May 8 05:44:33 CEST 2006 felix@call-with-current-continuation.org
+ * - csc: added "-G" alias for "-check-imports"***END OF DESCRIPTION***
+
+ Place the long patch description above the ***END OF DESCRIPTION*** marker.
+ The first line of this file will be the patch name.
+
+
+ This patch contains the following changes:
+
+ M ./csc.scm.in -1 +2
+
+Fri May 5 08:15:32 CEST 2006 felix@call-with-current-continuation.org
+ * - added some declarations to srfi-18.scm, partition.scm and easyffi.scm
+
+Fri May 5 04:24:16 CEST 2006 felix@call-with-current-continuation.org
+ * little fix in match
+
+Fri May 5 04:11:23 CEST 2006 felix@call-with-current-continuation.org
+ * - `define-foreign-enum' macro
+ - `enum', `struct' and `union' type-specifiers accept symbols
+
+Fri May 5 02:10:18 CEST 2006 felix@call-with-current-continuation.org
+ * - added mini-runtime example in misc
+ - tinyclos macros moved into tinyclos unit (which is also used by the compiler now)
+ - match macros moved into match (which used to be match-support)
+
+Thu May 4 23:06:42 CEST 2006 felix@call-with-current-continuation.org
+ * - condition-properties are now specific to a condition-kind (so equal property names do not collide
+ in composite conditions) [problem reported by Reed Sheridan, principle of solution by Kon Lovett]
+ - print-error-message: when condition has no messsage property, the kinds are printed instead
+ of a message
+
+
+Thu May 4 21:24:15 CEST 2006 felix@call-with-current-continuation.org
+ * - extensions may also have .exports file
+ - chicken-setup: `exports' property
+
+Sun Apr 30 02:26:27 CEST 2006 felix@call-with-current-continuation.org
+ * - utils.scm: `absolute-pathname?' windows-specific fix by Kon Lovett
+ - compiler: `-emit-exports' and `-check-imports' options
+ - .export-file generation for all library units
+ - version is 2.310
+
+Mon May 1 14:59:15 CEST 2006 bunny351@gmail.com
+ * - added `disable-warning' declaration specifier, added to a few units, removed options from Makefile.am
+ - added `srfi-2' feature-id to builtin features [reported by Dan Muresan]
+
+Thu Apr 27 10:28:35 CEST 2006 bunny351@gmail.com
+ * - srfii-13: added missing check in `substring/shared' [reported by Kon Lovett]
+
+Thu Apr 27 10:08:58 CEST 2006 bunny351@gmail.com
+ * - renamed `test-feature?' to `feature?' (old name still available but deprecated)
+
+Tue May 2 07:42:22 CEST 2006 bunny351@gmail.com
+ * - chicken-setup: `-v' isn't really necessary for simple installs
+ - slight changes in manual (bugs + limitations)
+
+Mon Apr 24 14:42:25 CEST 2006 bunny351@gmail.com
+ * - thread-join!: thread-result generalized to multiple values
+
+Sun Apr 23 19:07:59 CEST 2006 Thomas Chust <chust@web.de>
+ * Fixed a spelling mistake that broke tracing in csi
+
+Tue Apr 18 18:35:15 CEST 2006 rsheridan6@gmail.com
+ * Fix another bug in #<# and give it more readable macroexpansion
+
+Tue Apr 18 09:31:44 CEST 2006 rsheridan6@gmail.com
+ * Fix #<# read syntax (for real this time)
+
+Tue May 2 08:37:22 CEST 2006 felix@call-with-current-continuation.org
+ * fix in runtests.sh
+
+Wed Apr 19 14:12:54 CEST 2006 felix@call-with-current-continuation.org
+ * - fix in cscbench.scm [by Kon Lovett]
+ - added `##sys#apply-argument-limit' [Suggested by Reed Sheridan]
+ - regex-common.scm: replace `string-substitute*' with a simpler and faster version [by Daishi Kato]
+ - runtime.c: more preprocessor magic by Jean-Francois Bignolles
+ - Makefile.am: lowest nursery-size settings in nursery-sampling were simply too small (and could result in endless loops
+ on 64-bit machines)
+
+Wed Apr 19 08:40:03 CEST 2006 felix@call-with-current-continuation.org
+ * - fix in cscbench.scm [by Kon Lovett]
+ - added `##sys#apply-argument-limit' [Suggested by Reed Sheridan]
+ - regex-common.scm: replace `string-substitute*' with a simpler and faster version [by Daishi Kato]
+
+Sun Apr 16 00:31:39 CEST 2006 bunny351@gmail.com
+ * - configure.in: --enable-extra-symbol-slot changes BINARY_VERSION
+ - Manual fix [by Jarod Eells]
+ - regex-common.scm: string-substitute now also uses ##sys#fragements->string
+
+Wed Apr 12 17:58:41 CEST 2006 bunny351@gmail.com
+ * - nothing, really
+
+Wed Apr 12 17:35:42 CEST 2006 bunny351@gmail.com
+ * - cscbench is now compiled to allow self-contained run
+
+Thu Apr 13 15:25:29 CEST 2006 felix@call-with-current-continuation.org
+ * - csi: trace/untrace macroexpand names to work with psyntax modules
+
+Thu Apr 13 10:24:22 CEST 2006 felix@call-with-current-continuation.org
+ * - apply-limit overflow check only in safe runtime
+ - c-w-v optimization enabled by default
+ - version is 2.309
+ - disabled certain warnings for bootstrap (this will result in warnings when bootstraping from older compilers)
+
+Wed Apr 12 11:58:45 CEST 2006 felix@call-with-current-continuation.org
+ * - removed `try-harder' variable from compiler sources
+ - experimental `call-with-values' optimization for known single-valued result procedures
+
+Wed Apr 12 08:12:02 CEST 2006 felix@call-with-current-continuation.org
+ * - `#:extraslot' feature
+ - C_EXTRA_SYMBOL_SLOT moved to chicken-config.h
+
+Tue Apr 11 19:58:42 CEST 2006 rsheridan6@gmail.com
+ * #<# read syntax no longer dies on large input
+
+Tue Apr 11 16:36:34 CEST 2006 Thomas Chust <chust@web.de>
+ * Spelling mistake of variable *remove-command* in chicken-setup.scm corrected
+
+Tue Apr 11 14:44:32 CEST 2006 felix@call-with-current-continuation.org
+ * - testsuite stuff
+ - manual: `make-locative' still documented symbol [reported by John Cowan]
+
+Tue Apr 11 12:22:02 CEST 2006 felix@call-with-current-continuation.org
+ * - CMakeLists.txt: option for extraslot
+
+Tue Apr 11 12:18:15 CEST 2006 felix@call-with-current-continuation.org
+ * - test fixes
+
+
+Tue Apr 11 09:50:51 CEST 2006 felix@call-with-current-continuation.org
+ * - wwchicken typo fix by Mario Goulart
+ - apply overflow check [reported by Reed Sheridan]
+
+Tue Apr 11 08:58:19 CEST 2006 felix@call-with-current-continuation.org
+ * - `--enable-extra-symbol-slot' configure option
+ - version is 2.308
+
+Mon Apr 10 21:42:44 CEST 2006 bunny351@gmail.com
+ * - added config option for symbol-gc to CMakeLists.txt
+ - `chicken-version' also shows gchook feature
+ - removed build-features configure option
+
+Mon Apr 10 20:43:17 CEST 2006 bunny351@gmail.com
+ * - adjusted copyright dates in a few more files
+ - added `-enable-symbol-gc' configuration option
+
+Thu Apr 6 12:35:08 CEST 2006 felix@call-with-current-continuation.org
+ * - read-line: didn't bump port-line-number for stream-ports
+
+Thu Apr 6 11:41:08 CEST 2006 felix@call-with-current-continuation.org
+ * - updated copyright date
+ - csi.scm: includes "parameters.scm"
+
+Wed Apr 5 16:15:13 CEST 2006 felix@call-with-current-continuation.org
+ * - "unused variable" warning in block mode is not shown for variables generated by complex
+ define-constant's
+ - added `-disable-warning' option and differentiated compiler warnings
+ - version is 2.307
+
+Tue Apr 4 16:39:54 CEST 2006 felix@call-with-current-continuation.org
+ * - changed test-driver slightly
+ - moved tinyclos-examples into tests directory
+ - `regexp-escape' didn't escape the dot
+
+Sun Apr 2 22:09:09 CEST 2006 felix@call-with-current-continuation.org
+ * - added `-release' option [suggested by Peter Busser]
+
+Thu Mar 30 22:37:34 CEST 2006 bunny351@gmail.com
+ * - fixed brokenness in `nextbuild' script
+ - version is 2.307
+
+Fri Mar 31 07:23:55 CEST 2006 felix@call-with-current-continuation.org
+ * removed index.html again
+
+Thu Mar 30 21:11:01 CEST 2006 bunny351@gmail.com
+ * - still problems with test-runner
+
+Thu Mar 30 21:00:30 CEST 2006 bunny351@gmail.com
+ * - infix handling of `string-split-fields' improved [Reported by Sunnan]
+ - cleanup up chicken-setup, fixed bug in one call to `make:line-error'
+ - better output for "known proc call with wrong args" compiler warning
+ - generated identifier for `define-constant' has other gensym-prefix for easier distinction in compiler warnings
+ - chicken-setup: allows multiple `-e' options***DARCS***
+
+ Write the long patch description into this file.
+ The first line of this file will be the patch name.
+ Everything in this file from the above ***DARCS*** line on will be ignored.
+
+ This patch contains the following changes:
+
+ M ./chicken-setup.scm -145 +143
+ M ./compiler.scm -3 +4
+ R ./format.scm
+ M ./regex-common.scm -3 +3
+ M ./runtime.c -3 +46
+ A ./tests/
+ A ./tests/r4rstest.scm
+ A ./tests/runtests.scm
+
+Mon Apr 10 14:09:11 CEST 2006 felix@call-with-current-continuation.org
+ * - added some interesting files in "misc/"
+
+
+Mon Apr 10 09:04:34 CEST 2006 felix@call-with-current-continuation.org
+ * - `equal?' didn't return #t for 0.0/-0.0
+
+Fri Mar 31 20:29:44 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * more precise Version Build regex
+
+Fri Mar 31 10:18:53 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * find chicken simplified regex
+
+Fri Mar 31 07:49:31 CEST 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * find extant Chicken installation
+
+Fri Mar 31 08:28:29 CEST 2006 felix@call-with-current-continuation.org
+ * - Makefile.am: added missing dependencies [Thanks to Kon Lovett]
+
+Tue Mar 28 18:39:10 CEST 2006 rsheridan6@gmail.com
+ * Update README.darcs to reflect new repo url
+
+Sat Mar 25 12:29:45 CET 2006 'Brandon Van Every <bvanevery@gmail.com>'
+ * CMake MinGW update
+
+Thu Mar 30 09:31:27 CEST 2006 felix@call-with-current-continuation.org
+ * - ##sys#file-info holds flonums for timestamps
+ - version is 2.306
+ - versioned $(prefix)/share/chicken and $(prefix)/lib/chicken
+
+Mon Mar 27 15:15:45 CEST 2006 felix@call-with-current-continuation.org
+ * - runtime: fixed broken single-value test in `C_apply_values'
+ - version is 2.305
+
+Fri Mar 24 12:07:28 CET 2006 bunny351@gmail.com
+ * - fixed broken merge of read-line patch (it wasn't my fault!)
+
+Thu Mar 23 11:57:42 CET 2006 bunny351@gmail.com
+ * - manual/chicken.1: added note about `-extension'
+
+Wed Mar 22 18:26:20 CET 2006 rsheridan6@gmail.com
+ * read-line fix
+
+ read-line now correctly handles all line terminators and limits.
+
+Wed Mar 22 19:38:53 CET 2006 bunny351@gmail.com
+ * - csc: removed last trace of `-srfi-7' option
+
+Tue Mar 21 19:10:26 CET 2006 bunny351@gmail.com
+ * - darcs goes on my nerves sometimes
+ - read-line: handles "...\r" with string-input
+
+Tue Mar 21 18:52:36 CET 2006 bunny351@gmail.com
+ * - chicken-setup: -f wasn't recognized, -h for -host was of course wrong
+ - extras.scm: unrecorded read-line patch as it broke chicken-setup
+ - chicken-setup: probably fixed cygwin bug (called msvc create_directory) [reported by John Cowan]
+ - version is 2.304
+
+Mon Mar 20 08:43:35 CET 2006 felix@call-with-current-continuation.org
+ * - documented SRFI-61 support, added feature identifier
+
+Mon Mar 20 05:27:43 CET 2006 rsheridan6@gmail.com
+ * read-line fix, remove redundant code
+
+ read-line optional limit argument now works on all platforms
+
+ read-line no longer discards last character in stream unless it's a newline
+
+ removed duplicated definition of #\return
+
+
+Fri Mar 17 15:19:19 CET 2006 felix@call-with-current-continuation.org
+ * - wwchicken: galinha link (coop)
+ - srfi-61 support
+
+Fri Mar 17 10:47:40 CET 2006 felix@call-with-current-continuation.org
+ * - library: added `real-part', `angle', 'imag-part' and `magnitude' [as suggested by Alex Shinn]
+ - tinyclos: added safety check in `initialize' to catch when a generic is not an entity
+ - version is 2.303
+
+Tue Mar 14 07:38:36 CET 2006 felix@call-with-current-continuation.org
+ * - ##sys#read-prompt-hook: uses ##sys#print
+ - csi: always record expr in history to make readline egg work [problem reported by Peter Wright]
+
+Sat Mar 11 22:41:42 CET 2006 bunny351@gmail.com
+ * - repl: error output goes to stderr
+ - wwchicken: link to coop
+
+Wed Mar 8 20:18:43 CET 2006 bunny351@gmail.com
+ * - default error handler didn't write call-chain to stderr
+ - chicken-setup: removed "$VARIABLE" sillyness
+
+Sun Mar 5 06:45:12 CET 2006 felix@call-with-current-continuation.org
+ * - print-call-chain: writes to stdout
+
+Fri Mar 3 23:47:01 CET 2006 felix@call-with-current-continuation.org
+ * - chicken-setup: $VAR syntax
+ - eval: if path is absolute, load-relative doesn't prepend current load path
+
+Fri Mar 3 21:41:45 CET 2006 bunny351@gmail.com
+ * - port-map didn't invoke function (argh)
+ - read-file didn't invoke custom reader for first item (more argh)
+ - chicken-setup: docindex shows release (if defined)
+
+Tue Mar 7 09:48:32 CET 2006 felix@call-with-current-continuation.org
+ * - hen.el fixes by Reed Sheridan
+ - chicken-setup: `-check' option for checking repository for upgrades
+
+Fri Mar 3 09:12:06 CET 2006 felix@call-with-current-continuation.org
+ * - chicken-setup: on download add release-number of setup-info
+
+Tue Feb 28 14:47:04 CET 2006 felix@call-with-current-continuation.org
+ * - library.scm: `chicken-version' used wrong call to fudge for `ptables' [Thanks to Sven Hartrumpf]
+ - version is 2.302
+
+Mon Feb 27 15:14:30 CET 2006 felix@call-with-current-continuation.org
+ * - make-pathname: a little refactoring and handling of empty directory parts in directory lists
+
+Mon Feb 27 10:00:37 CET 2006 felix@call-with-current-continuation.org
+ * - chicken-setup: got `-eval' option
+
+
+Mon Feb 27 08:29:31 CET 2006 felix@call-with-current-continuation.org
+ * nothing important
+
+Sun Feb 26 23:55:55 CET 2006 rsheridan6@gmail.com
+ * hash-table-update! now takes 4th arg optionally, in compliance with SRFI-69
+
+Fri Feb 24 11:46:04 CET 2006 felix@call-with-current-continuation.org
+ * - chicken.h: CHICKEN_default_toplevel casted to void *
+ - manual: removed traces of `error-handler' [Thanks to Reed Sheridan]
+ - eval: added `load-relative'
+
+Wed Feb 22 08:07:45 CET 2006 felix@call-with-current-continuation.org
+ * - hash-table-update fix by Thomas Chust
+ - wwchicken: new win32 binaries version
+
+Tue Feb 21 21:33:03 CET 2006 Thomas Chust <chust@web.de>
+ * hashtable-update! fixed to conform to SRFI-69 [Thomas Chust]
+
+Sat Feb 18 22:26:59 CET 2006 bunny351@gmail.com
+ * - yet another whacky banner
+ - version is 2.301
+ - delete-file and rename-file didn't expand tilde [Patch by Zbigniew Szadkowsi]
+
+Fri Feb 17 20:33:36 CET 2006 bunny351@gmail.com
+ * - updated CMake readme and buildfile [thanks to Brandon van Every]
+
+Fri Feb 17 20:33:26 CET 2006 bunny351@gmail.com
+ tagged 2.3-release
+
+Fri Feb 17 19:04:53 CET 2006 bunny351@gmail.com
+ * - raised version to 2.3
+
+Fri Feb 17 18:16:21 CET 2006 bunny351@gmail.com
+ * - removed cmake references from README (this needs to be better prepared and will hopefully be functional
+ in the next release)
+ - csc: parens are not backslashed when passed as arguments to compiler options
+
+Mon Feb 20 08:42:37 CET 2006 felix@call-with-current-continuation.org
+ * - srfi-4.scm: subXXvector range check was wrong [Thanks to Alex Shinn]
+
+Fri Feb 17 13:03:33 CET 2006 felix@call-with-current-continuation.org
+ * - runtime.c/chicken.h: removed last traces of C_WINDOWS_DLL [Thanks to Brandon van Every]
+ - chicken-setup: only shows deletion of files in verbose mode
+
+Wed Feb 15 21:02:20 CET 2006 bunny351@gmail.com
+ * - version is 2.228
+
+Mon Feb 13 21:09:05 CET 2006 bunny351@gmail.com
+ * - runtime.c: init of trace-buffer-size happened after command-lline-parsing
+
+Wed Feb 15 14:18:14 CET 2006 felix@call-with-current-continuation.org
+ * - user-defined toplevel commands
+
+Wed Feb 15 07:45:28 CET 2006 felix@call-with-current-continuation.org
+ * - print-error-message prints to stdout, by default
+ - csc.scm.in: adapted to new library names for windows
+
+Mon Feb 13 09:28:44 CET 2006 felix@call-with-current-continuation.org
+ * - added foreign types for 32-bit integers
+
+Sat Feb 11 15:42:17 CET 2006 bunny351@gmail.com
+ * - changed darcs repo url again
+
+Sat Feb 11 15:40:05 CET 2006 bunny351@gmail.com
+ * - wwchicken: changed darcs repo url
+
+Mon Feb 6 22:56:31 CET 2006 bunny351@gmail.com
+ * - c_defaults.h -> chicken-defaults.h
+ - DLLs on Windows are now also named "lib..."
+ - version is 2.227
+ - csc does better handling of whitespace in option-arguments passed to chicken
+ - tcp: removed output-string form error-message on write failure
+
+Wed Feb 1 23:31:14 CET 2006 bunny351@gmail.com
+ * - added `C_copy_closure' primitive
+ - csi: `,s', `,l', ',ln' commands accept multiple inputs, added `,tr' and `,utr', removed trace/untrace macros
+
+Thu Feb 9 11:17:49 CET 2006 felix@call-with-current-continuation.org
+ * - utils: added check in shift! [suggested by Kon Lovett]
+ - csc: handles only object-files on the cmd-line
+
+Wed Feb 8 11:26:35 CET 2006 felix@call-with-current-continuation.org
+ * - reverted invalid change of match-error-control in easyffi
+
+Tue Feb 7 13:18:34 CET 2006 felix@call-with-current-continuation.org
+ * - added note about README.cmake-and-mingw32 in README
+ - chicken.h: unref'd locals warning is disabled via pragma [information about this provided by Brandon van Every]
+ - in unsafe mode, use #:fail match-error-control
+
+Mon Feb 6 08:33:13 CET 2006 felix@call-with-current-continuation.org
+ * - removed a slight bit of sillyness
+ - added README for cmake+mingw32 [Thanks to Brandon van Every]
+
+Fri Feb 3 08:43:17 CET 2006 felix@call-with-current-continuation.org
+ * - tcp: port returned by ##net#getservbyname wasn't ntohs'd [Thanks to Mark Wutka]
+ - runtime/lolevel: added the immensely useful `call-with-cthulhu'
+
+Mon Jan 30 06:23:58 CET 2006 felix@call-with-current-continuation.org
+ * - added `C_get_unbound_variable_value_hook' [suggested by Arto Bendiken]
+
+Sat Jan 28 22:37:32 CET 2006 bunny351@gmail.com
+ * - easyffi supports some escape sequences in char literals
+ - fixed bug in srfi-17 setter stuff for define-record
+ - condition-property-accessor enhancement by Kon Lovett***DARCS***
+
+ Write the long patch description into this file.
+ The first line of this file will be the patch name.
+ Everything in this file from the above ***DARCS*** line on will be ignored.
+
+ This patch contains the following changes:
+
+ M ./chicken-more-macros.scm -5 +5
+ M ./chicken.texi -2 +8
+ M ./easyffi.l +5
+ M ./library.scm -3 +3
+
+Sat Jan 28 02:52:23 CET 2006 bunny351@gmail.com
+ * - easyffi: handles macros that expand to char character constants [Suggested by Reed Sheridan]
+ - dynamically loaded compiled code (via `load') can now be reloaded (currently only tested in OS X - leaks space)
+ - version is 2.226
+
+Fri Jan 27 13:00:44 CET 2006 bunny351@gmail.com
+ * - c-string return-type special-casing for define-external's also applies to nonnull-c-string
+ - csi: `,d' omits trailing "s" when element-count is 1
+ - added `define-for-syntax'
+ - version is 2.225
+ - csc: -keep passes `-k' to csc [Thanks to Reed Sheridan]
+
+Tue Jan 24 18:06:23 CET 2006 bunny351@gmail.com
+ * - external callbacks with `c-string' return-type make it zero-terminated [suggested by Levi Pearson]
+
+Tue Jan 24 13:28:44 CET 2006 bunny351@gmail.com
+ * - added resizable finalizer-table by Zbigniew
+
+Tue Jan 24 12:28:06 CET 2006 bunny351@gmail.com
+ * - updated NEWS
+
+Mon Jan 23 22:44:00 CET 2006 bunny351@gmail.com
+ * - Mentioned Sergey Khorev and Brandon van Every more prominently in the acknowledgements section of the manual
+ - `group-information' and `system-information' return lists now instead of multiple values
+
+Wed Jan 25 13:49:58 CET 2006 felix@call-with-current-continuation.org
+ * - posix: timezone stuff was broken for Cygwin [Thanks to Sergey Khorev]
+
+
+Wed Jan 25 09:43:03 CET 2006 felix@call-with-current-continuation.org
+ * - more ccall stuff
+
+Wed Jan 25 09:14:56 CET 2006 felix@call-with-current-continuation.org
+ * - changed `nextbuild' script to be path-independent
+ - added `C_cdecl' declarations at various places to please Watcom C [suggested by Sergey Khorev]
+
+Mon Jan 23 09:38:35 CET 2006 felix@call-with-current-continuation.org
+ * - watcom-specific additions by Sergey Khorev
+ - `hash-table-ref' throws '(exn access) [suggested by Reed Sheridan]
+ - version is 2.224
+
+Sat Jan 21 00:14:43 CET 2006 felix@call-with-current-continuation.org
+ * - added `watcom' to `build-platform'
+
+Sat Jan 21 00:08:51 CET 2006 felix@call-with-current-continuation.org
+ * - `number->string' with radix 8 or 16 and an inexact number that can be represented as
+ an unsigned int returns a proper octal or hex conversion (without decimal point)
+
+Fri Jan 20 15:02:59 CET 2006 felix@call-with-current-continuation.org
+ * - manual: addition to `C_c_string()' doc [Thanks to Zbigniew Szadkowski]
+
+Tue Jan 17 11:21:34 CET 2006 felix@call-with-current-continuation.org
+ * - tcp: sending a chunk used wrong count [thanks to Hans Bulfone]
+ - manual typo fix [by Mario Domenech Goulart]
+ - csc: added `-home'
+ - `define-foreign-record'-accessors: assume nonnull pointers (would crash anyway on #f)
+ - version is 2.223
+
+Sun Jan 15 19:15:29 CET 2006 bunny351@gmail.com
+ * - added BvE's new CMakeLists.txt version
+ - added some interesting benchmarks
+
+Sun Jan 15 16:53:01 CET 2006 bunny351@gmail.com
+ * - utils: `decompose-pathname' and `pathname-directory' omit the trailing slash/separator [suggested by Kon Lovett]
+
+Sat Jan 14 23:16:05 CET 2006 bunny351@gmail.com
+ * - removed chicken-config.1 from the repo
+ - small fix in README
+ - csc: added `-cc-name' and `-ld-name' options
+
+Sat Jan 14 20:46:29 CET 2006 bunny351@gmail.com
+ * - manual: slight fix regarding nno-Windows posix time routines
+
+Fri Jan 13 14:21:26 CET 2006 felix@call-with-current-continuation.org
+ * - posix: fixed invalid fix of Reed Sheridan's fix for `directory'
+
+Thu Jan 12 18:54:41 CET 2006 bunny351@gmail.com
+ * - tcp: increased output-buffer size
+
+Thu Jan 12 17:43:40 CET 2006 bunny351@gmail.com
+ * - resurrected makefile.vc
+ - posix.scm: `map/anonymous' used incorrect C macro
+ - csc: -cflags doesn't include -c; output is less aggressively quoted
+
+Thu Jan 12 08:52:43 CET 2006 felix@call-with-current-continuation.org
+ * - removed `chicken-config' from the manual and the makefile
+ - tcp-output that would block causes thread-switch [suggested by Hans Bulfone]
+ - version is 2.222
+
+Wed Jan 11 11:28:37 CET 2006 felix@call-with-current-continuation.org
+ * - csc: `-libs' includes chicken runtime libs, now
+ - compiler: (require-extension) resolution of non-available extensions during compilation specified in list-syntax
+ could give an error message
+
+Tue Jan 10 13:20:25 CET 2006 felix@call-with-current-continuation.org
+ * - posixwin: `utc-time->seconds' is not available
+ - posix: addeed `local-timezone-abbreviation' [Contributed by Kon Lovett]
+ - chicken-setup: repo-path is created if not existing [Thanks to Adam Buchbinder]
+ - version is 2.221
+
+Mon Jan 9 11:38:55 CET 2006 felix@call-with-current-continuation.org
+ * - posix/posixwin: added enhancements to `directory' [contributed by Reed Sherdidan]
+
+Mon Jan 9 09:04:58 CET 2006 felix@call-with-current-continuation.org
+ * - chicken-setup: added `copy-file', `move-file', `remove-file*' and `create-directory' [Suggested by Kon Lovett]
+ - fixed bug in implementation of `require-extension' in the compiler
+ - added `srfi-69' and `srfi-28' feature-id's to list of builtin features [Shanks to Dan]
+ - chicken-setup: fixed bug with pathnames containing `~' [Thanks to Dan]
+ - version is 2.220
+
+Sat Jan 7 19:35:53 CET 2006 bunny351@gmail.com
+ * - Manual fixes
+ - Removed `transcript-on' and `transcript-off'
+
+Thu Jan 5 22:20:12 CET 2006 bunny351@gmail.com
+ * - `let*-values' is now SRFI-11 compliant
+ - version is 2.219
+
+Wed Jan 4 12:50:50 CET 2006 bunny351@gmail.com
+ * - lolevel: `object-evict-to-location' throws 'evict exn if limit is exceeded
+ - some additions and fixes in the "acknowledgements" section of the manual [thanks to Benedikt Rosenau]
+ - the feature-identifiers #:srfi-12 and #:srfi-15 are registered by default [as suggested by John Cowan]
+ - posix.scm: added `local-time->seconds' and `utc-time->seconds'
+
+ - version is 2.218
+
+Sun Jan 1 21:13:27 CET 2006 bunny351@gmail.com
+ * - replaced tons of proc-typedefs with nifty/weird macro magic [contributed by Jean-Francois Bignolles]
+ - `(define-macro SYM1 SYM2)' should work again [suggested by Zbigniew]
+
+Tue Dec 27 18:50:25 CET 2005 bunny351@gmail.com
+ * - version is 2.217
+ - added 'current-gc-milliseconds' [suggested by Kon Lovett]
+ - `chicken-setup -l NAME ...' lists ext.-info. of named extensions
+
+
+Tue Dec 27 08:48:22 CET 2005 bunny351@gmail.com
+ * - `chicken-home' wasn't added to default include-path
+
+Wed Dec 21 18:28:30 CET 2005 bunny351@gmail.com
+ * - some changes in README and wwchicken
+ - `require'/`require-for-syntax' accept a string as argument
+
+Wed Dec 14 19:07:32 CET 2005 bunny351@gmail.com
+ tagged 2.216-snapshot
+
+Wed Dec 14 17:16:59 CET 2005 bunny351@gmail.com
+ * - CMakeLists.txt: hyphens in targets are *not* OK...; csc.scm is generated in bindir
+
+Fri Dec 23 11:42:59 CET 2005 felix@call-with-current-continuation.org
+ * - fixed off-by-one error in runtime.c:create_initial_ptable
+
+Tue Dec 20 07:33:19 CET 2005 felix@call-with-current-continuation.org
+ * - mingw makefile fixes by Sergey Khorev
+
+Mon Dec 19 09:00:47 CET 2005 felix@call-with-current-continuation.org
+ * - more mingw fixes by Sergey Khorev
+
+
+Fri Dec 16 15:02:14 CET 2005 felix@call-with-current-continuation.org
+ * - added mingw specific fixes by Sergey Khorev
+
+Fri Dec 16 11:59:27 CET 2005 felix@call-with-current-continuation.org
+ * - removed test for HAVE__NSGETENVIRON in posix.scm
+
+
+Fri Dec 16 11:17:22 CET 2005 felix@call-with-current-continuation.org
+ * - `current-environment' should work now on OS X [Thanks to Kon Lovett]
+ - added correct timezone access [By Kon Lovett]
+ - Fixed bug in printer that caused trashing with length-limited output
+
+Thu Dec 15 15:11:19 CET 2005 felix@call-with-current-continuation.org
+ * - BvE's CMakeLists.txt fixes...
+
+Wed Dec 14 14:51:13 CET 2005 bunny351@gmail.com
+ * - readme fix
+
+Tue Dec 13 10:11:01 CET 2005 felix@call-with-current-continuation.org
+ * - version is 2.216
+
+Tue Dec 13 09:29:50 CET 2005 felix@call-with-current-continuation.org
+ * - manual fix by Reed Sheridan
+ - several CMakeLists.txt fixes by Brandon van Every
+
+Fri Dec 9 08:17:27 CET 2005 felix@call-with-current-continuation.org
+ * - added `-profile-name' option
+
+Wed Dec 7 16:09:59 CET 2005 felix@call-with-current-continuation.org
+ * - Small fixes (chicken.h, Makefile.am)***END OF DESCRIPTION***
+
+ Place the long patch description above the ***END OF DESCRIPTION*** marker.
+ The first line of this file will be the patch name.
+
+
+ This patch contains the following changes:
+
+ M ./Makefile.am -1 +1
+ M ./chicken.h -3
+
+Wed Dec 7 11:05:13 CET 2005 felix@call-with-current-continuation.org
+ * - configure.in: better checking for gcvt on MacOS [Thanks to Kon Lovett]
+ - Makefile.am typo and uposix-generation fixes by Kon
+ - version is 2.215
+
+Thu Dec 8 18:23:18 CET 2005 felix@call-with-current-continuation.org
+ * - extras: added `each'
+
+Fri Dec 2 04:51:17 CET 2005 felix@call-with-current-continuation.org
+ * - removed makefile.vc and updated README
+ - csi: describe hash-table shows hash-function
+
+Thu Dec 1 21:53:49 CET 2005 felix@call-with-current-continuation.org
+ * - runtime.c: ##sys#fudge(30) (_MSC_VER)
+ - fixed win-install.bat
+ - fixed CMakeLists.txt problems
+ - fixed conflicts and missing def for SD_RECEIVE/SD_SEND on win32
+
+Mon Nov 28 08:22:11 CET 2005 felix@call-with-current-continuation.org
+ * - csi: ",d" of hash-table prints procedure normally
+ - removed `pathname-extension-separator' and `pathname-directory-separator'
+ - utils: `make-pathname' with a dir part of #f chopped the slash, if the file part was starting with one
+
+Sun Nov 27 09:49:45 CET 2005 bunny351@gmail.com
+ * - `print-call-chain' didn't work with non-stream ports
+ - setup-information files have now ".setup-info" extension, or alternatively ".setup" [suggested by Pupeno]
+ - added `##sys#clear-trace-buffer' (eval)
+ - version is 2.214
+
+Sat Nov 26 14:37:16 CET 2005 bunny351@gmail.com
+ * tiny manual fix
+
+Fri Nov 25 14:58:51 CET 2005 felix@call-with-current-continuation.org
+ * - chicken.h: C_TLS is defined, if chicken-config.h is not included
+ - library: `file-exists?' returns it's argument, if succeeding (quite handy)
+ - chicken-setup: added link to egg-page in local doc-index
+
+Thu Nov 24 12:44:09 CET 2005 felix@call-with-current-continuation.org
+ * - `-:x' should actually work now
+ - Thread-exceptions display call-chain
+ - `print-call-chain' and `get-call-chain' accept optional thread argument
+
+Wed Nov 23 15:02:37 CET 2005 felix@call-with-current-continuation.org
+ * - compiler: added `-track-scheme', but somehow doesn't work yet and doesn't produce overly much output
+
+Wed Nov 23 12:41:22 CET 2005 felix@call-with-current-continuation.org
+ * - chicken-setup: errors in .setup scripts were printed twice
+ - `set-dispatch-read-syntax!' renamed to `set-sharp-read-syntax!' (old name still available, but deprecated)
+ - csc: added `-rpath PATHNAME'
+ - version is 2.213
+
+Tue Nov 22 23:07:17 CET 2005 bunny351@gmail.com
+ * - tcp: added `tcp-port-numbers` [Contributed by Daishi Kato]
+ - eval: removed dependency on extras (with-output-to-string)
+ - Makefile.am: posixwin should now be used instead of posix when building from tarball
+ - csc: added `-Fdir'
+ - fixed bug in `C_make_tagged_pointer' [Thanks to Zbigniew Szadkoswski, Pupeno and Tony Garnock-Jones]
+ - runtime.c: resurrected MSVC/x86 apply hack
+
+Tue Nov 22 07:40:41 CET 2005 felix@call-with-current-continuation.org
+ * - ws2tcpip.h include check for win32
+
+
+Tue Nov 15 17:16:48 CET 2005 bunny351@gmail.com
+ * - more CMakeLists.txt tweaks, still incomplete
+ - `let-values' is SRFI-11 compliant [Thanks to Reed Sheridan]
+ - added record-declarations to `define-foreign-record'
+ - version is 2.212
+
+Sat Nov 12 16:54:05 CET 2005 bunny351@gmail.com
+ * - libffi is used by default, when available
+ - added runtime-option `-:aXXX' to set trace-buffer/call-chain length
+ - more CMakeLists.txt tweaks (libffi, enable ptables)***DARCS***
+
+ Write the long patch description into this file.
+ The first line of this file will be the patch name.
+ Everything in this file from the above ***DARCS*** line on will be ignored.
+
+ This patch contains the following changes:
+
+ M ./CMakeLists.txt -57 +109
+ M ./README -4 +1
+ M ./TODO -1 +3
+ M ./chicken.h +1
+ M ./chicken.texi -2 +7
+ M ./configure.in -10 +2
+ M ./library.scm -2 +3
+ M ./parameters.scm -1
+ M ./runtime.c -10 +26
+
+Sat Nov 12 05:18:03 CET 2005 felix@call-with-current-continuation.org
+ * - version is 2.210
+ - Fixed typo in chicken.h [Thanks to Jarod Eells]
+ - added length-limit in call-chain output for source
+ - added additional info slot in trace-buffer for evaluation-context/container
+
+Tue Nov 8 20:49:42 CET 2005 bunny351@gmail.com
+ * - fxed warning in tcp.scm (getpeername)
+ - removed #include for ws2tcpip.h again (must be Windows-version specific)
+
+Thu Nov 3 21:03:30 CET 2005 bunny351@gmail.com
+ * - added -DC_ENABLE_PTABLES to Windows build-files
+ - Incorporated Wright's documentation for `match' into manual
+ - reduced trace-buffer size to 20
+ - c-backend: generates better code for ptables
+ - eval: added `##sys#eval-decorator' hook
+
+Fri Nov 11 15:52:24 CET 2005 felix@call-with-current-continuation.org
+ * - Some more CMakeLists.txt tweaking
+ - Fixed bug in `hash-table-fold' [Thanks to David Janssens]
+
+Fri Nov 11 14:50:06 CET 2005 bunny351@gmail.com
+ * - CMakeLists.txt fix for UNIX
+
+Fri Nov 11 10:16:46 CET 2005 felix@call-with-current-continuation.org
+ * - csc.scm.in: `-static' was passed to gcc without leading whitespace [Thanks to Sven Hartrumpf]
+
+Tue Nov 8 11:27:09 CET 2005 felix@call-with-current-continuation.org
+ * - undid optimization (problems found by Sven Hartrumpf)
+ - added Win32-specific create-dir function in chicken-setup
+
+Mon Nov 7 13:59:27 CET 2005 felix@call-with-current-continuation.org
+ * - Makefile.am fixes by Svben Hartrumpf
+
+Mon Nov 7 09:08:17 CET 2005 felix@call-with-current-continuation.org
+ * - compiler: removed unused warning procedure
+ - easyffi: unknown type-names will be treated as opaque pointers
+
+
+Mon Nov 7 07:21:10 CET 2005 felix@call-with-current-continuation.org
+ * - easyffi: removed `idtype' token
+ - macros: srfi-17 setters are not enabled for records by default
+
+Fri Nov 4 13:30:28 CET 2005 felix@call-with-current-continuation.org
+ * - scheduler: missed wincock2 include
+
+Fri Nov 4 13:29:01 CET 2005 felix@call-with-current-continuation.org
+ * - fixed silly bug in `hash-table-fold'
+ - Removed non-existant targets in Makefile.am (extra-dist rule) [thanks to Sven Hartrumpf]
+
+Fri Nov 4 08:19:56 CET 2005 felix@call-with-current-continuation.org
+ * - regex: fixed bug in `string-substitute' [Thanks to Daishi Kato]
+ - factored out common code in pregex.scm, regex.scm and pcre.scm into regex-common.scm
+
+Fri Nov 4 07:38:32 CET 2005 felix@call-with-current-continuation.org
+ * - fixed wrong doc links in README
+ - library: registers #:ptables feature, if available
+ - tcp.scm: added #include for winsock2.h
+
+Wed Nov 2 22:54:02 CET 2005 bunny351@gmail.com
+ * - version is 2.209
+
+Wed Nov 2 21:19:00 CET 2005 bunny351@gmail.com
+ tagged 2.207-snapshot
+
+Wed Nov 2 21:18:16 CET 2005 bunny351@gmail.com
+ * - Updated README.darcs (required CHICKEN version for bootstrapping is 2.2) [Thanks to Brandon van Every]
+ - scheduler: `thread-sleep!' didn't unfix sleep time value [Thanks to "datrus" and Guillaume Germaine]
+
+Mon Oct 31 19:14:48 CET 2005 bunny351@gmail.com
+ * - runtime: initial ptable didn't hold entries for procedures supplied by runtime.c
+
+Sun Oct 30 00:46:18 CEST 2005 bunny351@gmail.com
+ * - added `-cflags', `-ldflags' and `-libs' to csc
+ - improved procedure-table handling
+
+Mon Oct 31 07:23:33 CET 2005 felix@call-with-current-continuation.org
+ * ...
+
+Sat Oct 29 04:00:40 CEST 2005 felix@call-with-current-continuation.org
+ * - fixed bug in definition of `define-record-type' [thanks to Sven Hartrumpf]
+ - version is 2.207
+
+Thu Oct 27 18:39:51 CEST 2005 felix@call-with-current-continuation.org
+ * - added compiler support for serializating procedures (very experimental)
+ - library: added `##sys#interned-symbol?'
+
+Mon Oct 24 17:39:06 CEST 2005 bunny351@gmail.com
+ * fixed some conflicts
+
+Mon Oct 24 17:05:51 CEST 2005 bunny351@gmail.com
+ * - version is 2.206
+ - tinyclos: added builtin class `<regexp>'
+
+Mon Oct 31 09:03:41 CET 2005 felix@call-with-current-continuation.org
+ * - manual: added FAQ entry about non-existant native thread support
+ - csc, chicken-profile: block mode
+
+Tue Oct 25 14:34:54 CEST 2005 felix@call-with-current-continuation.org
+ * - added internal alias for `force'
+ - chicken-setup: added missing newline after error message
+ - added srfi-17 to the list of builtin features in compiled code
+
+Mon Oct 24 12:32:43 CEST 2005 felix@call-with-current-continuation.org
+ * - some notes in the documentation.
+
+Mon Oct 24 07:44:53 CEST 2005 felix@call-with-current-continuation.org
+ * - added primitive classes for all structures to TinyCLOS
+ - added setter for `global-ref'
+
+Thu Oct 20 22:21:01 CEST 2005 bunny351@gmail.com
+ * - manual: added various helpful people in the "Acknowledgemments" section
+
+Wed Oct 19 19:57:30 CEST 2005 bunny351@gmail.com
+ * - Nicer output of ##core#call simplifications
+
+Wed Oct 19 18:42:26 CEST 2005 bunny351@gmail.com
+ * - moved read-syntax definition procedures into library.scm
+ - added thread-specific read-table parameter `current-read-table' and `copy-read-table'
+ - added `##sys#infix-list-hook'
+ - added optimization for trivial constant-propagation in operator position
+
+Thu Oct 20 11:31:27 CEST 2005 felix@call-with-current-continuation.org
+ * - slight cleanup in output of print-call-chain
+
+Wed Oct 19 12:50:34 CEST 2005 bunny351@gmail.com
+ * setters for pointer/srfi-4 vectors weren't commited
+
+Wed Oct 19 12:49:43 CEST 2005 bunny351@gmail.com
+ * - setters for SRFI-4 vectors and lolevel pointer objects accesors added
+ - setters for records defined with `define-record' and `define-record-type'
+
+Wed Oct 19 11:19:58 CEST 2005 bunny351@gmail.com
+ * - added rewrites and setters for block-ref, hash-table-ref, locative-ref, byte-vector-ref
+
+
+Fri Oct 14 13:38:17 CEST 2005 bunny351@gmail.com
+ * - srfi-17 setter for `slot-ref'
+ - Some optimization for known setters - still not perfect (variable propagation not complete)
+
+Wed Oct 19 13:18:43 CEST 2005 felix@call-with-current-continuation.org
+ * - reader: #e/#i syntax uses internal hooked versions of `inexact->exact' and `exact->inexact' [Thanks to John Cowan]
+
+Tue Oct 18 21:41:26 CEST 2005 bunny351@gmail.com
+ * - renamed `extension-info' to `extension-information' (the old name is still available but deprecated)
+ - Evaluator (`##sys#compile-to-closure') keeps track of tail-position
+ - chicken-setup: added `setup-root-directory' and `setup-build-directory' parameters
+ - renamed `print-backtrace' to `print-call-chain' (the old name is still available but deprecated)
+ - Evaluator emits trace-info, too (into the same buffer as compiled code)
+ - added `get-call-chain'
+
+Mon Oct 17 20:23:15 CEST 2005 bunny351@gmail.com
+ * - version is 2.205
+
+Mon Oct 17 19:51:23 CEST 2005 bunny351@gmail.com
+ * - wwchicken: removed egg-specifics
+
+Sat Oct 15 12:49:44 CEST 2005 bunny351@gmail.com
+ * - tcp: added define for `socklen_' on Windows [Thanks to Andrey Fomichev]
+
+Fri Oct 14 08:57:47 CEST 2005 felix@call-with-current-continuation.org
+ * - runtime.c: uses C_alloca instead of alloca
+ - added ##compiler#postponed-initforms
+
+Thu Oct 13 08:11:46 CEST 2005 felix@call-with-current-continuation.org
+ * testing test
+
+Wed Oct 12 23:07:49 CEST 2005 bunny351@gmail.com
+ * - version is 2.204
+
+Wed Oct 12 22:56:44 CEST 2005 bunny351@gmail.com
+ * - version is 2.203
+ - Fixed bug in `hash-table-exists?' [Thanks to Daniel B. Faken]
+ - Fixed documentation bug(s) for `set-[dispatch-]read-syntax!'
+
+Sat Oct 8 06:00:58 CEST 2005 felix@call-with-current-continuation.org
+ * new eggs in wwchicken
+
+Fri Oct 7 06:57:19 CEST 2005 felix@call-with-current-continuation.org
+ * - chicken-setup: non-argument case didn't work correctly
+ - Added CMakeLists.txt (Windows-specific) [Contributed by Patrick Brannan]
+
+Thu Oct 6 18:43:01 CEST 2005 felix@call-with-current-continuation.org
+ * - chicken-setup: if no arguments are given, the .setup files in the current directory
+ are processed (if any)
+ - `string->number' returns #f for "."
+
+Mon Oct 3 23:51:33 CEST 2005 bunny351@gmail.com
+ * - csc: broken compile-flags when `-framework' was used
+ - tcp: small fix for MSVC [Thanks to Eric Raible]
+ - version is 2.202
+ - reader: `\xXX' encodes directly (not as UTF8)
+ - chicken-setup: checks .egg files for gzip header
+
+Tue Oct 11 07:36:18 CEST 2005 felix@call-with-current-continuation.org
+ * - runtime.c: RTLD_NOW wasn't defined on OpenBSD [Thanks to Category5]
+ - csc: .csc file is deleted even with -keep option
+
+Tue Oct 4 07:48:30 CEST 2005 felix@call-with-current-continuation.org
+ * - fixed obsolete header-file name in scheduler.scm [Thanks to Patrick Brannan]
+
+Wed Sep 28 20:05:19 CEST 2005 bunny351@gmail.com
+ * changed banner
+
+Wed Sep 28 08:55:37 CEST 2005 felix@call-with-current-continuation.org
+ * - vcbuild.bat wasn't listed in the README [Thanks to Brandon van Every]
+ - easyffi handles `#import'
+ - csc: added `-objc' and handling of .m files
+ - tcp.scm: changed header name for Windows sockets [Thanks to Patrick Brannan]
+ - eval: removed unused parameter from internal routines in closure-compiler
+
+Tue Sep 27 13:39:41 CEST 2005 felix@call-with-current-continuation.org
+ * - thread-deliver-signal!: properly unblocks target thread
+ - compiler: require-extension checks registered features as well before issuing warning
+ - argc-error doesn't print offending proc if no available
+ - eval: lambda/value-naming handles `let' forms, now
+
+Mon Sep 26 09:33:24 CEST 2005 felix@call-with-current-continuation.org
+ * - csc: undocumented misdocumented `-g' option [Thanks to Mario Goulart]
+ - Fixed obsolete doc-links in wwchicken
+ - extras: hash-function doesn't handle permanent literal strings specially [Thanks to Mario Goulart]
+ - version is 2.3
+ - version is 2.201
+
+Sat Sep 24 23:36:44 CEST 2005 bunny351@gmail.com
+ tagged 2.2-release
+
+Sat Sep 24 23:36:24 CEST 2005 bunny351@gmail.com
+ * - cleanups in wwchicken + manual
+
+
+Sat Sep 24 00:35:05 CEST 2005 bunny351@gmail.com
+ * - On Mac OS X, snprintf is used instead of gcvt to format flonums [Thanks to Kon Lovett]
+ - version is 2.2
+
+Fri Sep 23 17:43:28 CEST 2005 bunny351@gmail.com
+ * - added documentation for `C_callback_adjust_stack_limits'
+
+Fri Sep 23 14:21:24 CEST 2005 bunny351@gmail.com
+ * - small cleanups in nextbuild and wwchicken
+
+Thu Sep 22 04:26:19 CEST 2005 felix@call-with-current-continuation.org
+ * - chicken-setup now handles the case when a broken repository directory doesn't contain
+ an entry for a required extension [Thanks to Reed Sheridan]
+ - implemented sanity check for callbacks when invoked out of a non-Scheme context (i.e.
+ when embedding) [Possible problems with the old behaviour where suggested by Daniel
+ Faken]
+
+Tue Sep 20 17:30:57 CEST 2005 felix@call-with-current-continuation.org
+ * - version is 2.114
+ - argument-count checks show offending proceedure (if available)
+
+Sun Sep 18 13:30:23 CEST 2005 bunny351@gmail.com
+ * - csc: -framework is also passed to cc
+ - chicken-setup: silly bug in option handling
+ - C_hash_string_ci: uses `C_tolower'
+
+Sun Sep 18 05:16:13 CEST 2005 felix@call-with-current-continuation.org
+ * - `process' doesn't finalize ports at all, buster.
+ - extras: removed `clear-hash-table!', `get' and `put!'
+ - version is 2.113
+
+Sat Sep 17 07:39:46 CEST 2005 felix@call-with-current-continuation.org
+ * - `process' finalizes ports
+ - chicken-setup: slight enhancement of the appearance of the doc-index page
+ - SRFi-69 support
+
+Wed Sep 14 06:34:38 CEST 2005 felix@call-with-current-continuation.org
+ * - cscbench: handles scientific notation in `time' output
+ - compiler.scm: add linfo to closure only when llist is a pair
+ - `pp' handles linfo
+ - csi: `,d' of lambda required tinyclos
+ - chicken-setup: several bugfixes
+ - eval: decorated lambdas
+ - configure/Makefile: `...-static' executables are not generated, if shared or static
+ build is deactivated [suggested by Sergey Khorev]
+ - `print-backtrace' accepts optional start parameter
+
+Sat Sep 10 23:34:39 CEST 2005 bunny351@gmail.com
+ * - added TODO
+
+Sat Sep 10 22:48:12 CEST 2005 bunny351@gmail.com
+ * - cosmetic backend fix
+
+Sat Sep 10 22:56:56 CEST 2005 felix@call-with-current-continuation.org
+ * - added `version' extension specifier
+
+Sat Sep 3 11:40:29 CEST 2005 felix@call-with-current-continuation.org
+ * - SRFI-28 `format' is now in the base system (alias for `sprintf')
+ - chicken-setup: `-uninstall' removes all given extension
+
+Sat Sep 3 09:44:37 CEST 2005 felix@call-with-current-continuation.org
+ * - removed needless macroexpansion-hook and added another for local expansions
+ - version is 2.111
+ - chicken-setup, chicken-profile: removed `format' dependency
+ - removed `format' unit from base system
+
+Sat Sep 10 22:25:57 CEST 2005 bunny351@gmail.com
+ * - c-backend: comment wasn't quite right
+
+Fri Sep 9 14:23:26 CEST 2005 felix@call-with-current-continuation.org
+ * - srfi-13: fixed bug in `string-concatenate-reverse/shared' [Thanks to Ashley Bone]
+ - utils: `for-each-argv-line' binds current input-port
+
+Thu Sep 8 08:52:31 CEST 2005 felix@call-with-current-continuation.org
+ * - fixed overflow/negative handling in `arithmetic-shift'
+
+Wed Sep 7 23:19:21 CEST 2005 bunny351@gmail.com
+ * - with -no-trace, trace-call is inserted as comment
+ - library: addded `promise?'
+ - csc: added `-framework' option
+ - version is 2.112
+
+Tue Sep 6 08:09:12 CEST 2005 felix@call-with-current-continuation.org
+ * - compiler: fixed invalid invocation of `default-user-pass-2'
+ - renamed `pattern->regexp' to `glob->regexp' [Suggested by Kon Lovett]
+ - removed user-level optimizers
+ - chicken-setup: handles missing option arguments better
+
+Fri Sep 2 15:06:34 CEST 2005 felix@call-with-current-continuation.org
+ * - csc: accepts `-D...'
+
+Fri Sep 2 08:55:08 CEST 2005 felix@call-with-current-continuation.org
+ * - Fixed bug in `procedure-information' (call to `##sys#read' had wrong arity)
+ - interned toplevel symbols were not properly allocated in static memory
+
+Wed Aug 31 21:37:52 CEST 2005 felix@call-with-current-continuation.org
+ * small changes in wwchicken
+
+Wed Aug 31 03:02:27 CEST 2005 felix@call-with-current-continuation.org
+ * - fixed silly bug in `foreign-...' macros
+ - SRFI-17 is now built-in
+ - version is 2.110
+
+Wed Aug 31 01:31:39 CEST 2005 felix@call-with-current-continuation.org
+ * - moved lambda-decorators into library
+ - lolevel: extended-procedures use lambda-decorators
+ - added `foreign-declare', `foreign-parse' and `foreign-parse/declare' macros
+ - length-limited printing omitted the complete object if the limit was exceeded, now everything up to the limit
+ is shown [Thanks to Gene Pavlovsky]
+
+Tue Aug 30 00:28:51 CEST 2005 felix@call-with-current-continuation.org
+ * - `require-extension' is available by default and `(require-extension chicken-more-macros)' should actually work now
+ [Thanks to Daniel Faken]
+
+ - version is 2.109
+
+Mon Aug 29 23:28:04 CEST 2005 felix@call-with-current-continuation.org
+ * removed unused entries in hen.el
+
+Mon Aug 29 18:06:51 CEST 2005 felix@call-with-current-continuation.org
+ * - added `stub' unit for simpler embedding, if only basic Scheme interpreter is needed
+ - Checking for installed extension when compiling `require-extension' is a bit more intelligent now
+ - csc: single quote is not escaped in option strings (to handle quoted args in code fragments)
+
+Sun Aug 28 16:08:17 CEST 2005 felix@call-with-current-continuation.org
+ * - chicken-ffi-macros: some more fiddling with `define-foreign-record', still not perfect, but hopefully better
+
+Sat Aug 27 14:54:09 CEST 2005 felix@call-with-current-continuation.org
+ * - chicken-ffi-macros: slots of `const' type in `define-foreign-record' used invalid result conversion [Thanks to Reed Sheridan]
+ - `-debug-level 1' is equivalent to `-no-trace', -d2 is now the default
+ - version is 2.108
+
+Sat Aug 27 14:13:47 CEST 2005 felix@call-with-current-continuation.org
+ * - chicken: handles missing option arguments a bit more graceful
+ - Fixed silly bug in `atom?' [Thanks to Reed Sheridan]
+
+Thu Aug 25 14:07:13 CEST 2005 felix@call-with-current-continuation.org
+ * - replaced uses of `(##sys#fudge 1)' with `#!eof'
+ - version is 2.107
+ - `(current-directory DIR)' is the same as `(change-directory DIR)' [Suggested by Ed Watkeys]
+ - chicken-setup accepts short options names, now
+
+Wed Aug 24 22:51:31 CEST 2005 felix@call-with-current-continuation.org
+ tagged 2.106-snapshot
+
+Wed Aug 24 22:46:37 CEST 2005 felix@call-with-current-continuation.org
+ * tagged snapshot
+
+Wed Aug 24 22:46:34 CEST 2005 felix@call-with-current-continuation.org
+ tagged 2.1106-snapshot
+
+Wed Aug 24 22:36:50 CEST 2005 felix@call-with-current-continuation.org
+ * - fixed silly bug in `##sys#lambda-info'
+
+Wed Aug 24 19:06:12 CEST 2005 felix@call-with-current-continuation.org
+ * - unsafe libs are compiled with `-no-lambda-info'
+
+Wed Aug 24 14:05:29 CEST 2005 felix@call-with-current-continuation.org
+ * - doc fix, cscbench links directly with static runtime
+
+
+Tue Aug 23 15:06:16 CEST 2005 felix@call-with-current-continuation.org
+ * - some more comments
+ - Makefile: unsafe libs are built with '-no-lambda-info'
+
+Mon Aug 22 23:05:52 CEST 2005 felix@call-with-current-continuation.org
+ * - library: added `warning'
+ - removed uses of `##sys#read-line-number' with port-positions
+ - Makefile.am: Scheme sources are compiled with '-no-trace' instead of `-debug-level 0'
+ - all files should be compiled with lambda-info now
+
+Tue Aug 16 14:17:27 CEST 2005 felix@call-with-current-continuation.org
+ * - wwchicken: removed srfi-37 dependency from spiffy; split web and xml sections
+
+Mon Aug 22 14:53:42 CEST 2005 felix@call-with-current-continuation.org
+ * - fixed bug in definition of `##sys#block-address'
+
+Mon Aug 22 14:09:41 CEST 2005 felix@call-with-current-continuation.org
+ * - `signum' is exactness preserving [Suggested by John Cowan]
+ - wwchicken: added note about SWIG [Suggested by John as well]
+ - Resurrected `-emit-debug-info', added LAMBDA_INFO type
+ - `##sys#block-address' was unreliable
+ - removed `##sys#error-at' stuff from compiler
+ - library: `procedure-information'
+ - c-backend/runtime: string literals (and print-names for symbol literals) are allocated in static memory
+
+Wed Aug 17 14:56:39 CEST 2005 felix@call-with-current-continuation.org
+ * - `read-lines' also accepts a filename instead of a port.
+
+Mon Aug 15 07:48:24 CEST 2005 felix@call-with-current-continuation.org
+ * - extras: `read-file' accepts optional maxcount argument [Suggested by Ed Watkeys]
+
+Fri Aug 12 22:02:47 CEST 2005 felix@call-with-current-continuation.org
+ * - chicken-setup: fixed invalid handling of -host argument***DARCS***
+
+ Write the long patch description into this file.
+ The first line of this file will be the patch name.
+ Everything in this file from the above ***DARCS*** line on will be ignored.
+
+ This patch contains the following changes:
+
+ M ./TASKS -2
+ M ./chicken-setup.scm -3 +5
+ M ./wwchicken +7
+
+Fri Aug 12 08:46:23 CEST 2005 felix@call-with-current-continuation.org
+ * - extras: `read-file' accepts optional reader procedure [Suggested by Ed Watkeys]
+
+Wed Aug 10 09:22:14 CEST 2005 felix@call-with-current-continuation.org
+ * - tcp.scm: `tcp-connect' gives proper error message if connecting to a non-existant port [Thanks to Reed Sheridan]
+
+Tue Aug 9 19:03:01 CEST 2005 felix@call-with-current-continuation.org
+ * - removed `hash-table-size', renamed `hash-table-count' to `hash-table-size'
+
+Mon Aug 8 06:21:03 CEST 2005 felix@call-with-current-continuation.org
+ * - csc: added missing entry for `-ffi-no-include' in -h text
+ - easyffi: handles enum-values that are itself enums; -ffi-no-include wasn't properly handled
+
+Mon Aug 8 05:41:01 CEST 2005 felix@call-with-current-continuation.org
+ * - csc: removed `-export-dynamic' again
+ - library: string literals printed in readable mode escape special characters [Thanks to Thomas Chust]
+ - posixwin: `process-spawn' returns pid [Thanks to Ashley Bone]
+ - tcp: some cosmetic fixes [Thanks to Daishi Kato]
+
+Sat Aug 6 01:23:04 CEST 2005 felix@call-with-current-continuation.org
+ * - chicken-setup: -docindex ads a newline; docindex includes other eggs
+ - canonicalization of bodies didn't check lexical environments for shadowing of macros
+
+Fri Aug 5 22:37:48 CEST 2005 felix@call-with-current-continuation.org
+ * - open-input-file crashed on empty filename [Thanks to Reed Sheridan]
+
+Thu Aug 4 08:55:52 CEST 2005 felix@call-with-current-continuation.org
+ * - format: increased maximal number of iterations [Thanks to Alejandro Forero Cuervo]
+ - chicken-setup: handles full URL paths
+
+Fri Aug 5 05:41:00 CEST 2005 felix@call-with-current-continuation.org
+ * - chicken-setup: `test-compile' didn't remove tmp-file properly
+ - c-backend.scm: external prototypes are declared as `C_externexport', not `C_extern'
+ [Thanks to Ashley Bone]
+ - SRFI-31 support
+ - csc: added `-export-dynamic'
+ - chicken-setup: direct downloads; documentation index
+
+Sun Jul 31 18:16:12 CEST 2005 felix@call-with-current-continuation.org
+ * - `require-extension' shows a warning when compiling and the extension is not currently installed [suggested
+ by Alejandro Cuervo]
+ - `define-foreign-record' handles recursive structs [Thanks to Daniel Faken]
+ - `CHICKEN_run' returns the continuation, `CHICKEN_continue' allows re-entry
+
+Wed Jul 27 22:30:07 CEST 2005 felix@call-with-current-continuation.org
+ * - bumped version to 2.102
+
+Sun Jul 31 06:18:48 CEST 2005 felix@call-with-current-continuation.org
+ * - extras.scm: much better hash-table resizing [Thanks to Alejandro Cuervo]
+ - increased C_SIZEOF_FLONUM by 1 [Thanks to Daniel Faken]
+ - csc: -P/-check-syntax didn't omit compiler invocation
+
+Sat Jul 30 08:39:38 CEST 2005 felix@call-with-current-continuation.org
+ * removed obsolete files from README
+
+Sat Jul 30 08:38:06 CEST 2005 felix@call-with-current-continuation.org
+ * - removed all entry-point stuff (as suggested by Daniel Faken), `define-embedded'
+ and integrated boiler-plate API into eval.scm
+
+Sat Jul 30 07:50:15 CEST 2005 felix@call-with-current-continuation.org
+ tagged 2.101-with-old-entry-points
+
+Sat Jul 30 07:44:16 CEST 2005 felix@call-with-current-continuation.org
+ * - chicken-setup doesn't pass -E anymore
+ - csc: -I<DIR> is passed directly to C compiler
+ - `-extension' takes basename of output file (or source, if no output-file is specified)
+
+Fri Jul 29 17:04:21 CEST 2005 felix@call-with-current-continuation.org
+ * - csc: changed `-E' to `-P'
+ - compiler: `-extension' option
+ - chicken-setup passes `-E' on simple install
+
+Wed Jul 27 22:15:27 CEST 2005 felix@call-with-current-continuation.org
+ * - removed `foreign-parse' and `foreign-parse/spec'
+ - lolevel: removed executable bytevector stuff
+ - official support for SRFI-62
+
+Thu Aug 4 07:19:14 CEST 2005 felix@call-with-current-continuation.org
+ * removed some unused files
+
+Wed Jul 27 11:26:58 CEST 2005 felix@call-with-current-continuation.org
+ * - added documentation for new filelist format in chicken-setup
+
+Tue Jul 26 08:06:31 CEST 2005 felix@call-with-current-continuation.org
+ * - slightly better error message when `library' unit hasn't been linked
+ - chicken-setup: more fiddling to handle subdirectories
+
+Tue Jul 26 00:59:55 CEST 2005 felix@call-with-current-continuation.org
+ * - fiddled a bit with chicken-setup (ensures that target directory of copying operation exists), but still not
+ complete (we need support for subdirectories)
+
+Mon Jul 25 23:40:41 CEST 2005 felix@call-with-current-continuation.org
+ * - cscbench: prints times with 3 digits after the point [Thanks to Sven Hartrumpf]
+ - fixed example in the manual [Thanks to John Cowan]
+
+Mon Jul 25 15:09:51 CEST 2005 felix@call-with-current-continuation.org
+ * - chicken-ffi-macros: `define-foreign-record' stringifies second item in head, if given (or the compiler loops)
+ [Thanks to Daniel Faken]
+ - manual: added note about `C_alloc' being equivalent to declaring stack data [Thanks to Danel Faken, again]
+
+Mon Jul 18 09:54:52 CEST 2005 felix@call-with-current-continuation.org
+ * - added `#+...' read-syntax
+ - fixed bug in `seconds->time' (expected flonum) [Thanks to Kon Lovett and Reed Sheridan]
+
+Sun Jul 17 10:33:19 CEST 2005 felix@call-with-current-continuation.org
+ * fixed conflict in wwchicken
+
+Sun Jul 17 10:16:16 CEST 2005 felix@call-with-current-continuation.org
+ * - makefile.vc and vcbuild.bat still refered to syntax-case unit
+ - win-install-bat: removed copy-command for nonexistent chicken-highlevel-macros.scm
+
+Sat Jul 16 16:55:40 CEST 2005 felix@call-with-current-continuation.org
+ * - csi: fixed silly bug in option-processing while in `-script' mode
+
+Sat Jul 16 16:29:06 CEST 2005 felix@call-with-current-continuation.org
+ tagged 2.0-release
+
+Sat Jul 16 16:25:36 CEST 2005 felix@call-with-current-continuation.org
+ * - changed version to 2.0
+
+Wed Jul 13 19:58:04 CEST 2005 felix@call-with-current-continuation.org
+ * - `#<<...' accepts EOF
+ - cscbench: applied OS X specific fix [Thanks to Kon Lovett]
+ - Sven Hartrumpf contributed some improvements for `chicken-setup'
+ - manual: removed references to `chicken-format-profile' [found by Sven Hartrumpf]
+ - compiler: renamed `-require-for-syntax' to `require-extension'; it also behaves accordingly, now
+ - removed `-no-feature' options from compiler and csi
+ - csi: supports short options and `-require-extension'
+ - escapes in string literals: \f, \a and #\v; named char literals #\alarm, #\vtab and #\nul***DARCS***
+
+ Write the long patch description into this file.
+ The first line of this file will be the patch name.
+ Everything in this file from the above ***DARCS*** line on will be ignored.
+
+ This patch contains the following changes:
+
+ M ./Makefile.am -8
+ M ./NEWS +4
+ M ./README -1 +1
+ M ./batch-driver.scm -12 +4
+ M ./benchmarks/cscbench -1 +2
+ M ./build.scm -1 +1
+ M ./c-platform.scm -2 +2
+ M ./chicken-profile.scm -28 +38
+ M ./chicken.1 -7 +5
+ M ./chicken.texi -31 +31
+ M ./configure.in -1 +1
+ M ./csc.scm.in -5 +4
+ M ./csi.1 -17 +15
+ M ./csi.scm -30 +72
+ M ./library.scm -2 +8
+ M ./support.scm -2 +1
+ M ./wwchicken -10 +11
+
+Tue Jul 12 15:42:03 CEST 2005 felix@call-with-current-continuation.org
+ * - chicken-setup: doesn't list entries without extension-info
+ - removed examples from distribution
+
+Wed Jul 13 21:28:43 CEST 2005 felix@call-with-current-continuation.org
+ * - set-finalizer! forced finalizers on overflow only in debug mode
+ - removed `end-of-file'
+ - utils: added `port-for-each' and `port-map'
+
+Tue Jul 5 08:00:35 CEST 2005 felix@call-with-current-continuation.org
+ * - eval: `(define-macro SYMBOL X)' accepts any expression at second position
+
+Mon Jun 6 01:09:54 CEST 2005 felix@call-with-current-continuation.org
+ * - library/extras: procedure printing goees through `##sys#procedure->string'
+
+Thu Jun 30 22:38:56 CEST 2005 felix@call-with-current-continuation.org
+ * - updated manual pages
+ - csc: -static-libs option links with static libchicken (but dynamic libc)
+
+Thu Jun 30 00:21:34 CEST 2005 felix@call-with-current-continuation.org
+ * - removed strictness stuff
+ - removed -script-meta
+ - removed psyntax completely
+
+Thu Jun 30 08:41:23 CEST 2005 felix@call-with-current-continuation.org
+ * - some manual fixes
+
+Tue Jun 28 00:04:54 CEST 2005 felix@call-with-current-continuation.org
+ * conflicts again
+
+Tue Jun 28 00:00:53 CEST 2005 felix@call-with-current-continuation.org
+ * - small cleanups
+
+Mon Jun 27 23:05:18 CEST 2005 felix@call-with-current-continuation.org
+ * - `chicken-version' returns full version info, if optional parameter is given and true
+
+
+Mon Jun 27 08:20:04 CEST 2005 felix@call-with-current-continuation.org
+ * - configure.in/README: removed testsuites makefile
+
+Sun Jun 26 01:05:21 CEST 2005 felix@call-with-current-continuation.org
+ * resolved conflicts
+
+Sun Jun 26 00:15:25 CEST 2005 felix@call-with-current-continuation.org
+ * - removed srfi-25 and test-infrastructure from core system (are now available as eggs)
+
+
+Mon Jun 20 22:40:46 CEST 2005 felix@call-with-current-continuation.org
+ * - posix: `close-input-pipe' and `close-output-pipe' return the result-code from the invoked process [Suggested
+ by Zbigniew Szadkowski]
+ - posix: applied eCos patches [Contributed by Hans H[_\fc_]bner]
+
+Fri Jun 24 09:01:35 CEST 2005 felix@call-with-current-continuation.org
+ * - removed traces of `compute-module-exports'
+
+Fri Jun 24 08:42:24 CEST 2005 felix@call-with-current-continuation.org
+ * - compiler: removed special casing of `export' declaration for psyntax
+
+Thu Jun 23 13:40:24 CEST 2005 felix@call-with-current-continuation.org
+ * - reader escapes symbols starting with "#!", unless #!rest, #!optional or #!key
+
+Tue Jun 21 13:02:51 CEST 2005 bunny351@gmail.com
+ * - Makefile.am/configure.in: --enable-build-feature
+
+Tue Jun 21 08:59:44 CEST 2005 felix@call-with-current-continuation.org
+ * - srfi-14: some helper functions where not hidden
+ - same for srfi-25.scm
+
+Mon Jun 20 08:52:14 CEST 2005 felix@call-with-current-continuation.org
+ * - `-debug e' doesn't print header
+
+Sun Jun 19 15:44:01 CEST 2005 felix@call-with-current-continuation.org
+ * - bumped version to 1.942
+
+Sat Jun 18 09:15:22 CEST 2005 felix@call-with-current-continuation.org
+ * - csc: csc bombs when CHICKEN_HOME is not set on Windows [Thanks to Krysztof Kowalczyk]
+ - vcbuild.bat: added changes suggested by Andre van Tonder
+
+Fri Jun 17 14:04:50 CEST 2005 felix@call-with-current-continuation.org
+ * - fixed bug in vc-install.bat and renamed it to win-install.bat [Thanks to Krysztof Kowalczyk]
+ - chicken-setup: fixed bug in `test-compile'
+
+Thu Jun 16 09:20:04 CEST 2005 felix@call-with-current-continuation.org
+ * - added instructions for using the free microsoft development tools [Many thanks to Andre van Tonder]
+ - added vc-install.bat [Thanks to Krysztof Kowalczyk]
+
+Thu Jun 16 07:55:59 CEST 2005 felix@call-with-current-continuation.org
+ * - added kernel32 and gdi32 libs to linked libraries for VC runtime [Thanks to Krysztof Kowalczyk]
+
+Mon Jun 13 22:56:07 CEST 2005 felix@call-with-current-continuation.org
+ * small changes to TASKS and NEWS
+
+Mon Jun 13 21:58:05 CEST 2005 felix@call-with-current-continuation.org
+ * added TASKS
+
+Mon Jun 13 09:38:17 CEST 2005 felix@call-with-current-continuation.org
+ * - pathnames may be prefixed with "$VARIABLE"
+
+Mon Jun 13 09:17:50 CEST 2005 felix@call-with-current-continuation.org
+ * - eval.scm: extension-specifier handling was broken with source files [Thanks to Michele Simionato]
+ - extras.scm: added `hash-table-keys' and `hash-table-values'
+ - tcp.scm: uses strerror() for better error messages on failure [Thanks to Peter Bex]
+
+Fri Jun 10 14:51:21 CEST 2005 felix@call-with-current-continuation.org
+ * removed README.CVS
+
+Fri Jun 10 14:50:06 CEST 2005 felix@call-with-current-continuation.org
+ * - moved `##sys#check-special' into library.scm
+
+Thu Jun 9 17:58:15 CEST 2005 felix@call-with-current-continuation.org
+ * - csc.scm.in: doesn't remove /usr/local/include from include-path
+
+Mon Jun 6 19:43:13 CEST 2005 felix@call-with-current-continuation.org
+ * - ##sys#user-read-hook invokes ##sys#read-error, not ##sys#error
+ - `##sys#procedure->string'
+
+Thu Jun 9 09:18:50 CEST 2005 felix@call-with-current-continuation.org
+ * - srfi-14: added patch by Reed Sheridan
+ - Fixed build-problems for HP/UX [Contributed by Zbigniew Szadkoswki]
+
+Wed Jun 8 14:39:08 CEST 2005 felix@call-with-current-continuation.org
+ * - bugfix in srfi-14.scm (missing typecheck, overeager declarations) [Thanks to Reed Sheridan]
+ - documented `hash'
+ - `make-hash-table' allows custom hash-function
+
+Wed Jun 8 08:07:59 CEST 2005 felix@call-with-current-continuation.org
+ * - extras.scm: more error checking in extras.scm [Thanks to Peter Bex]
+ - srfi-14.scm: more error checking as well [Thanks to Reed Sheridan]
+
+Tue Jun 7 09:10:05 CEST 2005 felix@call-with-current-continuation.org
+ * - tcp.scm: fixed bug in select implementation [Thanks to hans Huebner]
+ - runtime.c: return value of C_a_i_arithmetic_shift did check for uint, not int [Thanks to Dale Jordan]
+
+Mon Jun 6 08:24:54 CEST 2005 felix@call-with-current-continuation.org
+ * - tinyclos: added type-check in `initialize-slots' [Thanks to Reed Sheridan]
+ - eval: `define' checks for too many arguments [Thanks to Michele Simionato]
+
+Thu Jun 2 07:48:38 CEST 2005 felix@call-with-current-continuation.org
+ * - srfi-25: `share-array' didn't check first argument [Thanks to Matthias Heiler]
+
+Tue May 31 07:18:41 CEST 2005 felix@call-with-current-continuation.org
+ * - regex.scm: flags wheren't properly passed to regcomp [Thanks to Zbigniew]
+
+Tue May 31 07:08:23 CEST 2005 felix@call-with-current-continuation.org
+ * - posix: `process' didn't check string argument type (check in `process-execute' was too late)
+
+Mon May 30 22:26:49 CEST 2005 felix@call-with-current-continuation.org
+ * - psyntax.scm: removed some unused code left over from earlier debugging times
+ - library.scm: #` reads as quasisyntax (not used yet, but might be useful later...)
+ - eval: added internal toplevel-expansion hook
+ - wwchicken: new eggs
+ - chicken-setup: registers 'chicken-setup feature
+
+Fri May 27 23:37:02 CEST 2005 felix@call-with-current-continuation.org
+ * - Non-blocking repl-hack enabled for Cygwin [Thanks to Dominique Boucher]
+
+Wed May 25 23:05:56 CEST 2005 felix@call-with-current-continuation.org
+ * - manual: some tweaking on the modules section
+ - wwchicken: protobj
+
+Thu May 26 04:01:56 CEST 2005 felix@call-with-current-continuation.org
+ * - csc: -W does nothing on non-Windows platform
+ - chicken-setup: `install-program' automatically adds ".exe" extension on windows
+ - manual: added module introduction
+
+Sun May 22 21:02:48 CEST 2005 felix@call-with-current-continuation.org
+ * - wwchicken: updated
+
+Fri May 20 18:17:53 CEST 2005 felix@call-with-current-continuation.org
+ * imlib2 ref in wwchicken
+
+Fri May 20 11:50:15 CEST 2005 felix@call-with-current-continuation.org
+ * - `process' passes environment arg to `process-execute'
+
+Fri May 20 10:28:10 CEST 2005 felix@call-with-current-continuation.org
+ * - `define-foreign-record' always expanded into a struct named `foo' [Thanks Carlos Pita]
+ - extras.scm: added `hash-table-exists?' [Suggested by Michele Simionato and Alex Shinn]
+ - `foreign-primitive': return-type is optional
+ - `process-execute' accepts optional environment list
+
+Wed May 18 22:46:02 CEST 2005 felix@call-with-current-continuation.org
+ * small manual fix
+
+Wed May 18 22:07:38 CEST 2005 felix@call-with-current-continuation.org
+ * - psyntax.scm: uses inernally hookable `number?' predicate
+ - compiler: `M' debug option
+ - pcre.scm: anchor is omitted in `string-match[-positions]' when start is > 0 [Thanks to Christian Jaeger]
+
+Wed May 18 08:44:16 CEST 2005 felix@call-with-current-continuation.org
+ * manual additions [Thanks to Christian Jaeger]
+
+Tue May 17 09:02:52 CEST 2005 felix@call-with-current-continuation.org
+ * small manual fix
+
+Mon May 16 21:12:09 CEST 2005 felix@call-with-current-continuation.org
+ * - csi: `-eval' implies `-batch' and `-quiet' [Suggested by Reed Sheridan]
+ - easyffi: `___inout' and `___out' works now with C++ reference types; better error message for invalid characters
+ - compiler: small fix to handle `#>(swig ...) ...<#' with newest SWIG version
+ - `[not] check-c-syntax' declaration
+ - wwchicken: support for "hidden" eggs
+
+Wed May 11 22:46:00 CEST 2005 felix@call-with-current-continuation.org
+ * - chicken-profile and csi accept `-h' option
+
+Mon May 9 22:28:16 CEST 2005 felix@call-with-current-continuation.org
+ * - added NEWS to repo
+
+Mon May 9 21:19:55 CEST 2005 felix@call-with-current-continuation.org
+ * - csc doesn't pass `-static' to gcc on OS X [Thanks Henrik Tramberend]
+
+Wed May 11 07:42:39 CEST 2005 felix@call-with-current-continuation.org
+ * - wwchicken: newsitems in web-page are not wrapped in <a> tag
+
+Wed May 11 00:50:43 CEST 2005 rsheridan6@gmail.com
+ * Minor UI fixes for chicken
+
+Mon May 9 13:32:07 CEST 2005 felix@call-with-current-continuation.org
+ * - extras: Added `alist->hash-table' [Contributed by Alehandro Forero Cuervo]
+
+Mon May 9 08:18:24 CEST 2005 felix@call-with-current-continuation.org
+ * - refactored pointer->string conversion
+ - enabled relaxed multival-return rules
+
+Thu May 5 23:12:02 CEST 2005 felix@call-with-current-continuation.org
+ * - spurious "." is detected (but escaped syntax is still allowed)
+ - csi: `advise' has been removed
+ - some small fixes in number-to-string conversion
+
+Fri May 6 03:20:37 CEST 2005 felix@call-with-current-continuation.org
+ * - library/runtime: reader supports "+/-inf" and "+nan"; the compiler uses
+ string-representation of literals if needed [Thanks to Kon Lovett]
+
+Thu May 5 05:58:30 CEST 2005 felix@call-with-current-continuation.org
+ * - posix.scm: errno/exist was missing [Thanks to Reed Sheridan]
+ - added `-:fXXX' runtime option
+ - added `-ffi-no-include' option
+ - `define-inline' (lolevel) detects non-lambda value
+
+Wed May 4 08:10:26 CEST 2005 felix@call-with-current-continuation.org
+ * - chicken-setup: .so is removed on simple install; d/l query only once
+ - posix: open/read is an alias for open/rdonly [Thanks to Reed Sheridan]
+ - raised pending finalizers max
+
+Thu May 5 21:20:42 CEST 2005 felix@call-with-current-continuation.org
+ * - posixwin.scm: `C_fileno' -> `C_C_fileno'
+ - makefile.vc: added a few missing line-continuation characters
+ - chicken-config/csc: adds `-DHAVE_CHICKEN_CONFIG_H'
+ - added NEWS file
+
+Sun May 1 10:08:12 CEST 2005 felix@call-with-current-continuation.org
+ * - config-script checks for GNU make
+
+Sat Apr 30 09:17:21 CEST 2005 felix@call-with-current-continuation.org
+ * documented new search order for require
+
+Sat Apr 30 08:51:25 CEST 2005 felix@call-with-current-continuation.org
+ * - hen.el: `include' is highlighted
+ - chicken-entry-points.scm: `scheme-pointer' return type wasn't supported
+
+Wed Apr 27 22:26:36 CEST 2005 felix@call-with-current-continuation.org
+ * - bumped version to 1.936
+
+Mon Apr 25 23:02:16 CEST 2005 felix@call-with-current-continuation.org
+ tagged 1.935 snapshot
+
+Fri Apr 29 13:46:11 CEST 2005 felix@call-with-current-continuation.org
+ * - documented '-:B'
+ - extensions are now only searched in "." if not found in the repository path
+
+Thu Apr 28 13:16:26 CEST 2005 felix@call-with-current-continuation.org
+ * - added `-:B' runtime option
+
+Wed Apr 27 11:48:00 CEST 2005 felix@call-with-current-continuation.org
+ * c-pointer alias for define-entry-point was not recognized
+
+Wed Apr 27 10:17:13 CEST 2005 felix@call-with-current-continuation.org
+ * - chicken-entry-points.scm: compile-time eval thingy was completely broken with `-syntax' [Thanks to Daishi Kato]
+
+Tue Apr 26 13:49:27 CEST 2005 felix@call-with-current-continuation.org
+ * - the reader can read now |.| [Thanks to Nicolas Pelletier]
+
+Mon Apr 25 22:31:10 CEST 2005 felix@call-with-current-continuation.org
+ * - removed last traced of libstuffed-chicken/libsrfi-chicken
+
+Sun Apr 24 00:38:26 CEST 2005 felix@call-with-current-continuation.org
+ * - `define-extension' allows optional `export' clause
+ - fixed a stupid bug in `string->number' (caused by previous "fix")
+ - `set-finalizer!' was broken
+
+Thu Apr 21 23:52:02 CEST 2005 felix@call-with-current-continuation.org
+ * - several patches and hooks for numbers
+
+Thu Apr 21 00:31:04 CEST 2005 felix@call-with-current-continuation.org
+ * - `string->number' didn't handle inexact numbers starting with #\#
+ - `set-finalizer!' forces finaloizers if live count exceed max
+
+Mon Apr 25 10:08:15 CEST 2005 felix@call-with-current-continuation.org
+ * - Removed DJGPP support
+ - libstuffed-chicken and libsrfi-chicken have been folded into libchicken
+
+Fri Apr 22 09:33:17 CEST 2005 felix@call-with-current-continuation.org
+ * pp handles other pointer types
+
+Mon Apr 18 09:39:49 CEST 2005 felix@call-with-current-continuation.org
+ * - SWIG-pointers are accepted by `##sys#foreign-pointer-argument'
+
+Mon Apr 18 08:22:22 CEST 2005 felix@call-with-current-continuation.org
+ * - `CHICKEN_delete_gc_root()' didn't free memory of root object
+ - chicken-entry-points.scm: added void-ptr cast
+ - removed wrong entry in help text given by `,?' in csi [Thanks to Dale Jordan]
+ - library: added `##sys#' aliases to `string->number' and `number->string' (and some other primitives)
+ for later hooking
+ - added `define-extension'
+
+Fri Apr 15 09:04:51 CEST 2005 felix@call-with-current-continuation.org
+ * - deletion of GC roots is O(1)
+
+Thu Apr 14 14:53:36 CEST 2005 felix@call-with-current-continuation.org
+ * - internal char-type predicates didn't use libc alias macros
+
+Wed Apr 13 22:57:34 CEST 2005 felix@call-with-current-continuation.org
+ * resolved stupid conflict
+
+Wed Apr 13 22:53:22 CEST 2005 felix@call-with-current-continuation.org
+ * - fixed `define-method' to specialize all arguments
+
+Tue Apr 12 00:21:39 CEST 2005 felix@call-with-current-continuation.org
+ * - John Lenz fixed a few problems with handling methods with argument lists of unequal length
+
+Mon Apr 11 23:55:36 CEST 2005 felix@call-with-current-continuation.org
+ * - backtrace indicates current frame
+ - `printf' accepts `~n' as an alias for `~%'
+ - wwchicken: fixed broken links to SRFI47/57 docs [Thanks to Reed Sheridan]
+
+Thu Apr 7 10:43:26 CEST 2005 felix@call-with-current-continuation.org
+ * - Makefile.am: banner.scm was installed for unknown reasons
+ - #\U... char syntax and \U... escape sequence
+ - pretty-print didn't handle extended character syntax
+ - changed macro-definition of `define-method' to handle non-specialized args correctly [Thanks to John Lenz]
+ - utils: `decompose-pathname' should return #f, #f, #f for the empty string [Thanks to Peter Bex]
+
+Wed Apr 6 07:20:09 CEST 2005 felix@call-with-current-continuation.org
+ * - csc.scm and chicken-config pass -DHAVE_CHICKEN_CONFIG_H to C compiler [Thanks to Alex Shinn]
+
+Mon Apr 4 23:29:54 CEST 2005 felix@call-with-current-continuation.org
+ * - manual: added documentation for `\uXXXX'
+
+Mon Apr 4 23:16:03 CEST 2005 felix@call-with-current-continuation.org
+ * - utils: `make-pathname' didn't check type of filename-argument [Thanks to Peter Bex]
+ - wwchicken: added new eggs
+ - syntax-case: `declare' is now always available, even with `-r5rs'
+
+Thu Mar 24 22:03:02 CET 2005 felix@call-with-current-continuation.org
+ * - changed version-numbering to use 3-digit release number
+ - manual: moved `___pointer' description
+
+Mon Apr 4 09:47:38 CEST 2005 felix@call-with-current-continuation.org
+ * - Arithmetic comparison operators didn't work properly on 64-bit machines [Thanks to Alex Shinn]
+
+Mon Apr 4 09:18:33 CEST 2005 felix@call-with-current-continuation.org
+ * - Makefile.in: uses different escapes to allow commas [Thanks to G[_\c3_][_\b6_]ran Krampe]
+ - compiler: keywords are not optimized to literal accesses in strict mode; assignment to keyword triggers warning
+ [Thanks to Damian Gryski]
+ - '\uXXXX' escape sequence in strings
+
+Thu Mar 24 08:07:03 CET 2005 felix@call-with-current-continuation.org
+ * - library.scm: file-open functions and deletion/renaming use strerror(3) for better error messages [suggested by
+ Alejandro Forero Cuervo]
+
+Fri Mar 25 05:45:59 CET 2005 felix@call-with-current-continuation.org
+ * - chicken.h: added macro for `___pointer'
+ - easyffi: added `opaque' pseudo-declaration; `___byte_vector' pseudo type
+
+Mon Mar 21 11:38:35 CET 2005 felix@call-with-current-continuation.org
+ * - easyffi: added `___pointer' marker
+
+Mon Mar 21 08:28:52 CET 2005 felix@call-with-current-continuation.org
+ * - easyffi: default-renaming is now triggered on any uppercase or underscore character
+
+Wed Mar 16 10:26:55 CET 2005 felix@call-with-current-continuation.org
+ * - easyffi: default-renaming is also triggered on underscores
+ - library: ##sys#find-symbol-table is exported
+
+Wed Mar 16 08:34:25 CET 2005 felix@call-with-current-continuation.org
+ * - runtime.c: the removal of finalizer-list entries was broken [Thanks to John Lenz]
+
+Tue Mar 15 14:03:22 CET 2005 felix@call-with-current-continuation.org
+ * - wwchicken: added requirements for stream-ldif
+ - srfi-4: fixed problem for `u32vector-ref' on 64-bit machines [Thanks to Alex Shinn]
+ - extras: fixed stupid buf in rassoc
+ - easyffi: `___length()' argument marker
+
+Mon Mar 14 23:31:59 CET 2005 felix@call-with-current-continuation.org
+ * ...
+
+Mon Mar 14 23:22:24 CET 2005 felix@call-with-current-continuation.org
+ * huh?
+
+Mon Mar 14 23:18:26 CET 2005 felix@call-with-current-continuation.org
+ * resolved RCS conflicts; new eggs in wwchicken
+
+Mon Mar 14 21:31:54 CET 2005 felix@call-with-current-continuation.org
+ * - added internal error class #:process-error
+ - posix: uses strerror(3)
+ - lolevel: `object-unevict' optionally copies byteblock objects
+ - compiler: gives warnings for undefined exported globals
+ - `define-inline' and `define-constant' are now usable with psyntax' module system (but expand to simple defines)
+ - added inlining, no noticable performance improvements, though (customizable procedures and gcc inlining may probably
+ do the job here...)
+
+Mon Mar 14 08:42:52 CET 2005 felix@call-with-current-continuation.org
+ * - added `u' debugging mode
+
+Wed Mar 9 14:56:34 CET 2005 felix@call-with-current-continuation.org
+ * - csi: ,ln prints an arrow before the result
+
+
+Mon Mar 7 23:27:20 CET 2005 felix@call-with-current-continuation.org
+ * - added continuation API
+
+Thu Mar 3 23:09:47 CET 2005 felix@call-with-current-continuation.org
+ * - easyffi: accepts `size_t' type (treated as unsigned int)
+ - manual: missing backslash in example for `string-substitute'
+ - easyffi: added pseudo declaration for default name substitution (`default_renaming')
+
+Mon Mar 7 13:04:35 CET 2005 felix@call-with-current-continuation.org
+ * - manual: fixed example for `join' [Thanks to William Annis]
+ - new primitive `##sys#apply-values' and compiler rewritings
+
+Thu Mar 3 21:23:36 CET 2005 felix@call-with-current-continuation.org
+ * - Fixed stupid bug in new handling of `-:r''s output; some macros in chicken.h didn't use libc aliases
+
+Thu Mar 3 08:30:35 CET 2005 felix@call-with-current-continuation.org
+ * - `-:r' sends output to stderr [Suggested by Alejandro]
+ - added `lambda-lift' declaration
+
+Wed Mar 2 23:31:28 CET 2005 felix@call-with-current-continuation.org
+ * spiffy link
+
+Wed Mar 2 20:52:02 CET 2005 felix@call-with-current-continuation.org
+ * - tcp/posix: port-name and type for tcp-ports is set properly; `port->fileno' handles tcp ports
+
+Wed Mar 2 18:00:36 CET 2005 felix@call-with-current-continuation.org
+ * added new shootout benchmarks
+
+Wed Mar 2 17:58:22 CET 2005 felix@call-with-current-continuation.org
+ * - the dot in `(X . Y)' was only recognized when followed by whitespace (now it accepts any delimiter) [Thanks to Christian Jaeger]
+ - hen: `set!' is highlighted
+
+Tue Mar 1 08:41:40 CET 2005 felix@call-with-current-continuation.org
+ * - Alejandro Forero Cuervo contributed support for accumulated profile data; felix added
+ `-accumulate-profile' option
+
+Sat Feb 26 16:32:35 CET 2005 felix@call-with-current-continuation.org
+ * wwchicken: broken link
+
+Sat Feb 26 12:40:11 CET 2005 felix@call-with-current-continuation.org
+ * - chicken-setup: added `compile'; `(run (csc ...))' passes `-feature compiling extension' to csc
+
+Sat Feb 26 10:46:51 CET 2005 felix@call-with-current-continuation.org
+ * - tcp: `tcp-accept' could block indefinitely if the syscall was interrupted
+ - scheduler: slightly better interrupt handling
+
+Sun Feb 27 06:18:37 CET 2005 felix@call-with-current-continuation.org
+ * scheduler: unimportant stuff
+
+Sun Feb 27 04:14:56 CET 2005 felix@call-with-current-continuation.org
+ * - batch-driver: unit-specification and -dynamic triggers warning [thanks to Julian Morrison]
+ - tcp: added `tcp-listener-fileno'
+ - scheduler.scm: fixed bug in `##sys#thread-unblock!'
+
+Wed Feb 23 06:48:28 CET 2005 felix@call-with-current-continuation.org
+ * - minor fixes
+
+Mon Feb 21 21:05:31 CET 2005 felix@call-with-current-continuation.org
+ * - changed version to 1.93
+ - The README says to use GNU make in a more verbose manner [suggested by Volker Stolz]
+ - configure.in: changed configure `--enable-libffi' to `--with-libffi'
+ - the scheduler unblocks the primordial thread when select-based waiting is interrupted [Thanks to mark Wutka]
+
+Wed Feb 16 19:42:58 CET 2005 felix@call-with-current-continuation.org
+ * - wwchicken: lalr.egg link was broken
+
+Wed Feb 16 19:04:41 CET 2005 felix@call-with-current-continuation.org
+ * - wwchicken: added rfc3339
+
+Wed Feb 16 15:03:18 CET 2005 felix@call-with-current-continuation.org
+ * - posix: fixed bug in `process-execute' [wrong foreign type spec]
+
+Wed Feb 16 09:43:12 CET 2005 felix@call-with-current-continuation.org
+ * - wwchicken: lalr link in egg-index was wrong
+ - changed copyrights to 2005
+
+Tue Feb 15 14:39:30 CET 2005 felix@call-with-current-continuation.org
+ * - changed copyright notice to 2005 [Thanks to Benedikt Rosenau]
+
+Tue Feb 15 08:57:26 CET 2005 felix@call-with-current-continuation.org
+ * - easyffi: added `___scheme_pointer' pseudo type
+
+Tue Feb 15 06:03:38 CET 2005 felix@call-with-current-continuation.org
+ * - fixed nasty optimizer bug related to hidden procedures with explicitly consed rest argument [Thanks to
+ Julian Morrison] (this was actually fixed in the 1.92 snapshot)
+ - library: in debug mode, prints number of processed finalizers
+ - srfi-4: finalization handling was wrong
+
+Mon Feb 14 23:31:10 CET 2005 felix@call-with-current-continuation.org
+ tagged 1.92 snapshot
+
+Mon Feb 14 22:48:17 CET 2005 felix@call-with-current-continuation.org
+ * - chicken-setup: better handling when no remote repository file exists
+
+Mon Feb 14 21:26:08 CET 2005 felix@call-with-current-continuation.org
+ * - chicken.h: no compiler warning when C_STACK_GROWS_DOWNWARD isn't defined in chicken-config.h
+ - csi: loads "./.csirc" if it exists
+
+Mon Feb 14 14:43:07 CET 2005 felix@call-with-current-continuation.org
+ * minor doc fix
+
+Fri Feb 11 11:58:46 CET 2005 felix@call-with-current-continuation.org
+ * - fixed bug in chicken-setup
+
+Fri Feb 11 11:23:38 CET 2005 felix@call-with-current-continuation.org
+ * - chicken-setup supports connection via proxy [Contributed by Mark Wutka]
+
+Fri Feb 11 08:23:28 CET 2005 felix@call-with-current-continuation.org
+ * - reverted to old psyntax code - the changes broke when compiling the dissector
+ [Thanks to Thomas Chust]
+
+Tue Feb 8 12:28:24 CET 2005 felix@call-with-current-continuation.org
+ * conflict in cscbench
+
+Mon Feb 7 23:19:18 CET 2005 felix@call-with-current-continuation.org
+ * - added some internal support for syntax-case annotations
+ - extended lambda-lists weren't properly handled with syntax-case in some cases
+ - optional argument processing generates better code in unsafe mode
+ - reader: added support for `#cs/#ci ...'
+ - added foreign type-specifier `scheme-pointer' (old unqualified `pointer' is deprecated)
+ - tagged pointer checks use `equal?' now
+
+Mon Feb 7 14:40:24 CET 2005 felix@call-with-current-continuation.org
+ * - extras: removed `collect' again (`filter-map' is fine)
+
+Sat Feb 5 16:08:36 CET 2005 felix@call-with-current-continuation.org
+ * (- broken darcs link was reported by Andrey Sidorenko)
+ - added `set-dynamic-load-mode!' [Thanks to Mark Baily for pointing out this shortcoming]
+ - added `regexp-escape' [Suggested by Peter Bex]
+
+Sat Feb 5 12:12:03 CET 2005 felix@call-with-current-continuation.org
+ * - wwchicken: fixed broken darcs link [Thanks to Andrej ...]
+ - chicken.h: check of _MIPS_SZPTR is only done for gcc
+ - trigonometric functions can be inlined (partially) resulting in slightly better performance
+
+Sat Feb 5 04:00:12 CET 2005 felix@call-with-current-continuation.org
+ * - hen.el: added `foreign-code' to highlighted keywords
+ - easyffi: didn't handle #\page in embedded C fragments [Thanks to Nicolas Pelletier]
+ - extras: collect accepts more than one list
+ - `read-string' didn't check port argument properly
+ - `process' accepts optional argument list
+ - wwchicken: RSS-generator adds guids and unique links [Thanks to Sergey Khorev]
+
+Sat Jan 29 21:36:54 CET 2005 felix@call-with-current-continuation.org
+ * - csi: `,d <fixnum>' only shows character representation if code is less than #x10000
+ - posixwin: added `symbolic-link?' (always returns #f)
+
+Thu Jan 27 23:54:36 CET 2005 felix@call-with-current-continuation.org
+ * - chicken.h: on MIPS, C_SIXTYFOUR is only selected if _MIPS_SZPTR == 64 [Thanks to Mark Baily]
+
+Thu Jan 27 22:59:40 CET 2005 felix@call-with-current-continuation.org
+ * - definition of C_fixnum_abs() in chicken.h was wrong [Thanks to Alex Shinn]
+ - `hash-table-for-each' has it's argument order swapped (the old order is still supported);
+ renamed `hash-table->list' to `hash-table->alist'; added `hash-table-update!' [Thanks to Sven Hartrumpf]
+
+Tue Jan 25 10:56:40 CET 2005 felix@call-with-current-continuation.org
+ * - added `regular-file?' to posixwin
+
+Tue Jan 25 09:06:02 CET 2005 felix@call-with-current-continuation.org
+ * - expansion of #!optional with a single argument is more efficient
+ - posix: added `symbolic-link?' and `regular-file?' [as suggested by William Annis]
+
+Mon Jan 24 21:54:30 CET 2005 felix@call-with-current-continuation.org
+ * - `machine-type' returns 'arm on ARM
+
+Mon Jan 24 20:55:07 CET 2005 felix@call-with-current-continuation.org
+ * - `define-method' handles #!optional/#!key/#!rest (but doesn't specialize them)
+ - chicken.h: some cleaning up
+ - easyffi: allows `C_word' as type; `___callback' is now called `___safe' (`___callback' is still allowed, though)
+ - `foreign-callback-lambda[*]' and `foreign-callback-wrapper' have been renamed to `foreign-safe-lambda[*]' and
+ `foreign-safe-wrapper', respectively. The old names are deprecated
+ - chicken-setup: file-lists in `install-...' procedures can specify absolute path to control destination directory
+ - renamed `autosetup' to `autogen.sh' and made it more verbose
+ - tinyclos: `port' argument to `print-object' and `describe-object' is now optional
+ - fixed bug in optimizer that caused unsed unused arguments to callbacks defined with `define-external' to
+ be removed
+
+Fri Jan 21 21:13:17 CET 2005 felix@call-with-current-continuation.org
+ * more preprocessor aliases, updated wwchicken a little
+
+Fri Jan 21 18:46:14 CET 2005 felix@call-with-current-continuation.org
+ * - added some preprocessor stuff for redefining libc accesses
+
+Thu Jan 20 05:22:27 CET 2005 brannanster@gmail.com[_^M_]
+ * A compact test output function
+
+Thu Jan 20 04:37:17 CET 2005 "Patrick Brannan <brannanster@gmail.com>"[_^M_]
+ * Windows mkdir fix
+
+Wed Jan 19 14:08:36 CET 2005 felix@call-with-current-continuation.org
+ * - some more aliases for libc routines
+ - documented `C_u_i_c[ad]r'
+
+Wed Jan 19 11:58:27 CET 2005 felix@call-with-current-continuation.org
+ * - added `(emit-external-prototypes-first)' declaration
+ - chicken.h/runtime.c: added some `C_...' aliases for stdlib
+
+Tue Jan 18 14:59:48 CET 2005 felix@call-with-current-continuation.org
+ * - `number->string' adds a trailing zero for inexact numbers with zero fractional part [Thanks to Sven Hartrumpf]
+
+Tue Jan 18 12:12:38 CET 2005 felix@call-with-current-continuation.org
+ * - chicken.h: __LP64__ selects 64-bit mode
+ - posix: added `file-link' [Suggested by Sunnan]
+
+Mon Jan 17 21:52:59 CET 2005 felix@call-with-current-continuation.org
+ * added testeez
+
+Mon Jan 17 19:56:55 CET 2005 felix@call-with-current-continuation.org
+ * - extras: `collect'
+
+Mon Jan 17 14:12:14 CET 2005 felix@call-with-current-continuation.org
+ * - tinyclos: added instance-of?
+
+Mon Jan 17 13:51:02 CET 2005 felix@call-with-current-continuation.org
+ * - chicken-setup: `-no-install' wasn't recognized; error message was broken
+
+
+Mon Jan 17 07:34:45 CET 2005 felix@call-with-current-continuation.org
+ * posix: fixed bug in absolute-pathname? [Thanks to Peter Bex]
+
+Mon Jan 17 05:49:42 CET 2005 felix@call-with-current-continuation.org
+ * - added `-emit-external-prototypes-first'
+
+Fri Jan 14 08:39:17 CET 2005 felix@call-with-current-continuation.org
+ * - tinyclos.scm: took bugfix for missing `(reverse field-initializers) in `(initialize <class>)' from Andreas
+ Rottmann's tinyclos port
+ - added `-:b' runtime option
+
+Wed Jan 12 20:51:24 CET 2005 felix@call-with-current-continuation.org
+ * - dload2 and libffi features
+ - libffi hack is only used when argc >= 120
+
+Wed Jan 12 09:03:14 CET 2005 felix@call-with-current-continuation.org
+ * support for libffi to handle large argument lists
+
+Wed Jan 12 08:18:26 CET 2005 felix@call-with-current-continuation.org
+ * documented foreign-primitive
+
+Tue Jan 11 11:08:18 CET 2005 felix@call-with-current-continuation.org
+ * foreign-primitive
+
+Mon Jan 10 22:15:07 CET 2005 felix@call-with-current-continuation.org
+ tagged 1.89 release
+
+Mon Jan 10 22:14:55 CET 2005 felix@call-with-current-continuation.org
+ * final touch on homepage
+
+Sat Jan 8 13:34:53 CET 2005 felix@call-with-current-continuation.org
+ * added FAQ entry to explain the macro systems
+
+Sat Jan 8 12:29:50 CET 2005 felix@call-with-current-continuation.org
+ * some manual cleanups, new version
+
+Wed Jan 5 14:30:52 CET 2005 felix@call-with-current-continuation.org
+ * Added missing copyright statement in LICENSE [Thanks to Toby Butzon]
+ argument type-check didn't handle `(const c-string)' properly [Thanks to Peter Bex]
+
+Tue Jan 4 18:43:44 CET 2005 felix@call-with-current-continuation.org
+ * fixed bug in easyffi.l that caused wrong parsing of C comments [Thanks to Nicholas Pelletier]
+
+Mon Jan 3 20:43:22 CET 2005 felix@call-with-current-continuation.org
+ * chicken-setup: `test-compile' was broken [thanks to Peter Bex]
+
+Fri Dec 31 01:44:14 CET 2004 felix@call-with-current-continuation.org
+ * bitwise ops accept full integer range
+
+ - `bitwise-and', `bitwise-ior', `bitwise-xor', `bitwise-not' and `arithmetic-shift' also accept non-exact
+ integers, provided they are in machine word range
+ - library: added `fxand', `fxior', `fxxor', `fxnot', `fxshl' and `fxshr'
+ - ",d" invokes `unveil' for meroon instances
+ - removed TODO
+
+
+Wed Dec 29 00:34:00 CET 2004 felix@call-with-current-continuation.org
+ * csc.scm.in: handles damaged .csc files
+
+Fri Dec 24 03:35:48 CET 2004 felix@call-with-current-continuation.org
+ * `-:d' shows message before finalizers are forced on exit
+
+Thu Dec 23 05:49:18 CET 2004 felix@call-with-current-continuation.org
+ * more finalizer tests, documentation
+
+ - minor documentation fix
+
+Wed Dec 22 17:07:41 CET 2004 felix@call-with-current-continuation.org
+ * finalizer tuning
+
+ - `set-finalizer!' returns the finalized object
+ - finalizers are vastly more efficient now [Thanks to Ed Watkeys for pointing out this problem]
+
+Wed Dec 22 15:58:43 CET 2004 felix@call-with-current-continuation.org
+ tagged 1.85-work
+
+Wed Dec 22 15:57:47 CET 2004 felix@call-with-current-continuation.org
+ * removed meroon (?)
+
+Thu Dec 23 10:28:06 CET 2004 felix@call-with-current-continuation.org
+ * bumped version number
+
+Wed Dec 15 23:04:13 CET 2004 felix@call-with-current-continuation.org
+ tagged 1.85 (development)
+
+Mon Dec 20 12:11:13 CET 2004 felix@call-with-current-continuation.org
+ * more bugfixes, doc changes
+
+ - csi crashed on Windows when CHICKEN_HOME wasn't defined [Thanks to Shmulik Regev]
+ - documented `<swig-pointer>' in manual
+ - easy ffi: handles "long/short int" types [Thanks to Nicolas Pelletier]
+
+Sun Dec 19 12:07:20 CET 2004 felix@call-with-current-continuation.org
+ * some bugfixes
+
+ - tinyclos: new primitive class <swig-pointer> [Thanks to Joel Reymont]
+ - csi: script-file loading in csi didn't work on Cygwin [Thanks to Dale Jordan]
+ - added inlining rules for several SRFI-4 accessors
+
+Thu Dec 16 11:08:11 CET 2004 felix@call-with-current-continuation.org
+ * minor stuff
+
+ - hen.el: marks define-foreign-record
+ - fixed bug in manual (#xe0 is 224, not 240 :-) [Thanks to Michele Simionato]
+ - Circular dependency (library.c -> c_defaults.h, nsample -> library.c) in Makefile.am fixed [Thanks to Fabian B[_\c3_][_\b6_]hlke]
+
+Wed Dec 15 22:38:30 CET 2004 felix@call-with-current-continuation.org
+ * doc improvements, define-macro at run-time
+
+ - `define-macro' is now available in compiled files at run-time [shown to be useful by Michele Simionato]
+ - eval-when: alternative specifiers `compile-time' and `run-time'
+ - pcre, regex, pregexp: `regexp' handles optional caseless/igorespace/utf8 arguments [Contributed by Alex Shinn]
+ - easyffi.scm: fixed a stupid bug in the type-simplifier [Thanks to Thomas Chust]
+
+Wed Dec 15 07:16:52 CET 2004 felix@call-with-current-continuation.org
+ * chicken-home checks CHICKEN:HOME
+
+Tue Dec 14 10:25:45 CET 2004 felix@call-with-current-continuation.org
+ * minor optiomization in srfi-13
+
+Tue Dec 14 08:08:36 CET 2004 felix@call-with-current-continuation.org
+ * `chicken-compile-static' feature
+
+ - csc: passes `-feature chicken-compile-static' in static mode [Suggested by Thomas Chust]
+
+Mon Dec 13 09:12:47 CET 2004 felix@call-with-current-continuation.org
+ * minor bugfixes
+
+ - `define-method' allows mixed qualified and unqualified arguments [Thanks to Joel Reymont]
+ - lolevel: `##sys#check-pointer' also allows SWIG-pointers [Thanks to Joel Reymont]
+ - added `chicken-home' [Thanks to Michele Simionato]
+ - `##sys#resolve-include-filename' is a bit cleverer now
+
+Tue Dec 7 00:18:00 CET 2004 felix@call-with-current-continuation.org
+ * chicken-setup stuff
+
+ - chicken-setup: `install-sources' (preliminary); portable (?) "mkdir -p" command
+ - wwchicken: RSS feed wasn't de-htmlized
+
+Tue Dec 7 08:09:36 CET 2004 felix@call-with-current-continuation.org
+ * define-values works now in all definition context [solution by Abdulaziz Ghuloum]
+
+Mon Dec 6 09:11:33 CET 2004 felix@call-with-current-continuation.org
+ * removed FAQ.html from makefile
+
+Sat Dec 4 18:06:39 CET 2004 felix@call-with-current-continuation.org
+ * Bugfix for `provide', slight source-file cleanups
+
+ - eval: `##sys#do-the-right-thing' didn't check whether an extension is explicitly provided
+ - removed HACKING from repository
+ - removed some old files from repository
+ - chicken-entry-points: didn't work properly with psyntax
+ - hen.el: added some keywords
+ - added FAQ to manual
+
+Sat Dec 4 05:29:03 CET 2004 felix@call-with-current-continuation.org
+ * cleanups of docs
+
+Thu Dec 2 18:16:28 CET 2004 felix@call-with-current-continuation.org
+ * redefintion of records is safer
+
+ - since `define-record[-type]' is not generative, redefinition with subsequent access of slots
+ via the previous accessors was unsafe
+
+Thu Dec 2 18:03:40 CET 2004 felix@call-with-current-continuation.org
+ * -r5rs option is stricter
+
+ - `-r5rs' implies `-no-usual-integrations'
+ - fixed docs regarding `-r5rs' option
+
+Thu Dec 2 17:02:37 CET 2004 felix@call-with-current-continuation.org
+ * cleaning up
+
+ - compiler: removed `-usual-integrations' and added `-no-usual-integrations'
+ (this is now the default behaviour!)
+ - the unbound value is printed differently now
+ - removed last remnants of SRFI-22
+
+Tue Nov 30 21:57:26 CET 2004 felix@call-with-current-continuation.org
+ tagged 1.81-work
+
+Tue Nov 30 21:15:04 CET 2004 felix@call-with-current-continuation.org
+ * simplifications of macro stuff
+
+ - removed srfi-13-syntax.scm (moved into chicken-more-macros/chicken-highlevel-macros)
+
+Tue Nov 30 16:45:47 CET 2004 felix@call-with-current-continuation.org
+ * added make-expansions.scm
+
+Tue Nov 30 16:35:57 CET 2004 felix@call-with-current-continuation.org
+ * removed refs to srfi-13-syntax.scm in Makefile.am
+
+Tue Nov 30 16:34:31 CET 2004 felix@call-with-current-continuation.org
+ * simplifications of macro stuff
+
+ - removed srfi-13-syntax.scm (moved into chicken-more-macros/chicken-highlevel-macros)
+
+Tue Nov 30 00:34:30 CET 2004 felix@call-with-current-continuation.org
+ * small cleanups, psyntax work
+
+ - wwchicken: fixed bug introduced with previous change (htmlfile)
+ - chicken-highlevel-macros: slightly cleaned up to allow bootstrapping of macro-definers
+ - non-standard psyntax macro-definitions are now generated via script and compiled to native code
+ (which gives better startup times)
+ - removed `-strict-...' and `-r5rs' options from compiler and interpreter
+ - README: filenames were wrong again
+
+Mon Nov 29 19:56:52 CET 2004 felix@call-with-current-continuation.org
+ * removed csc.scm (finally)
+
+Mon Nov 29 19:56:22 CET 2004 felix@call-with-current-continuation.org
+ * xx
+
+Mon Nov 29 19:56:10 CET 2004 felix@call-with-current-continuation.org
+ * christ...
+
+Mon Nov 29 19:35:02 CET 2004 felix@call-with-current-continuation.org
+ * bugfixes and chicken-setup option
+
+Mon Nov 29 08:44:12 CET 2004 felix@call-with-current-continuation.org
+ * better feature-check in ##sys#do-the-right-thing
+
+Thu Nov 25 07:33:42 CET 2004 felix@call-with-current-continuation.org
+ * removed csc.scm
+
+Wed Nov 24 22:42:09 CET 2004 felix@call-with-current-continuation.org
+ * Sergey's fixes
+
+Mon Nov 22 23:37:29 CET 2004 felix@call-with-current-continuation.org
+ * Bugfixes, Sergey's dlll-runtime changes
+
+ - eval: warning for declarations in interpreted code passed wrong argument to `error'
+ - hen.el: added changes contributed by Micky Latowicki
+ - library: `c-runtime' returns information about linked C runtime library; MSVC build supports linking with
+ dynamic runtime libs [Thanks to Sergey Khorev]
+
+Wed Nov 17 23:49:34 CET 2004 felix@call-with-current-continuation.org
+ * ...
+
+Wed Nov 17 23:45:00 CET 2004 felix@call-with-current-continuation.org
+ * Initial revision
diff --git a/ChangeLog.20091010 b/ChangeLog.20091010
new file mode 100644
index 00000000..febf8164
--- /dev/null
+++ b/ChangeLog.20091010
@@ -0,0 +1,5327 @@
+------------------------------------------------------------------------
+r16155 | felix | 2009-10-08 09:07:24 +0200 (Thu, 08 Oct 2009) | 1 line
+
+reverted backwards-incompatible changes to [set-]file-position[!]
+------------------------------------------------------------------------
+r16154 | felix | 2009-10-08 09:06:54 +0200 (Thu, 08 Oct 2009) | 1 line
+
+fixed incorrect constant-folding of format
+------------------------------------------------------------------------
+r16132 | felix | 2009-10-05 04:20:05 +0200 (Mon, 05 Oct 2009) | 1 line
+
+reverted commits 16083, 16091 and 16115
+------------------------------------------------------------------------
+r16126 | felix | 2009-10-03 20:22:10 +0200 (Sat, 03 Oct 2009) | 1 line
+
+removed svn2git script
+------------------------------------------------------------------------
+r16120 | kon | 2009-10-03 03:37:33 +0200 (Sat, 03 Oct 2009) | 2 lines
+
+Rmv use of _ftelli64/_fseeki64 since cannot link.
+
+------------------------------------------------------------------------
+r16118 | kon | 2009-10-02 03:39:59 +0200 (Fri, 02 Oct 2009) | 2 lines
+
+Renamed posix-test to plural. Added to test suite.
+
+------------------------------------------------------------------------
+r16117 | kon | 2009-10-02 03:23:39 +0200 (Fri, 02 Oct 2009) | 2 lines
+
+Fix for file position wider than a fixnum.
+
+------------------------------------------------------------------------
+r16115 | felix | 2009-10-01 11:59:26 +0200 (Thu, 01 Oct 2009) | 1 line
+
+tweaks in chicken-scheme script
+------------------------------------------------------------------------
+r16109 | kon | 2009-09-29 16:50:38 +0200 (Tue, 29 Sep 2009) | 2 lines
+
+Updated with new unit lolevel routines.
+
+------------------------------------------------------------------------
+r16108 | felix | 2009-09-29 09:22:34 +0200 (Tue, 29 Sep 2009) | 1 line
+
+removed pointless internal library function; removed commented out bug in optimizer; line-break in scrutinizer error message
+------------------------------------------------------------------------
+r16102 | kon | 2009-09-27 05:24:32 +0200 (Sun, 27 Sep 2009) | 2 lines
+
+Added current value api for invalid procedure call hook & unbound variable hook.
+
+------------------------------------------------------------------------
+r16091 | felix | 2009-09-26 13:42:37 +0200 (Sat, 26 Sep 2009) | 1 line
+
+added sv2git script; improvements in chicken-scheme script, fixed rename in manifest
+------------------------------------------------------------------------
+r16090 | iraikov | 2009-09-26 02:28:23 +0200 (Sat, 26 Sep 2009) | 2 lines
+
+since dev snapshot 4.2.2 has already been released, we need to start a NEWS section for 4.2.3
+
+------------------------------------------------------------------------
+r16086 | kon | 2009-09-25 17:23:30 +0200 (Fri, 25 Sep 2009) | 2 lines
+
+reverse-string-append added
+
+------------------------------------------------------------------------
+r16085 | kon | 2009-09-25 16:58:44 +0200 (Fri, 25 Sep 2009) | 2 lines
+
+Exported 'reverse-string-append'. Ports does not use 'reverse-string-append'. Rmvd 'reverse-string-append' from extras since it uses"data-structures".
+
+------------------------------------------------------------------------
+r16083 | felix | 2009-09-25 11:58:03 +0200 (Fri, 25 Sep 2009) | 1 line
+
+renamed autocompile script
+------------------------------------------------------------------------
+r16055 | kon | 2009-09-23 18:34:56 +0200 (Wed, 23 Sep 2009) | 2 lines
+
+'##sys#check-syntax' for 'lambda-list allowed keywords as variables.
+
+------------------------------------------------------------------------
+r16033 | kon | 2009-09-22 21:50:04 +0200 (Tue, 22 Sep 2009) | 2 lines
+
+Applied Jim Usetto's patch for the (ref TYPE) foreign-argumentApplied Jim Usetto's patch for the (ref TYPE) foreign-argument..
+
+------------------------------------------------------------------------
+r16016 | kon | 2009-09-21 17:43:58 +0200 (Mon, 21 Sep 2009) | 2 lines
+
+Better '%list-every/1'
+
+------------------------------------------------------------------------
+r16014 | kon | 2009-09-21 15:23:55 +0200 (Mon, 21 Sep 2009) | 2 lines
+
+Start of 4.2.2 News section
+
+------------------------------------------------------------------------
+r16013 | iraikov | 2009-09-21 11:24:36 +0200 (Mon, 21 Sep 2009) | 2 lines
+
+trunk version set to 4.2.2
+
+------------------------------------------------------------------------
+r15999 | kon | 2009-09-20 22:53:43 +0200 (Sun, 20 Sep 2009) | 2 lines
+
+'cd' cmd arg needed to quoted also
+
+------------------------------------------------------------------------
+r15992 | kon | 2009-09-20 20:08:03 +0200 (Sun, 20 Sep 2009) | 2 lines
+
+Quoted 'chicken-install' for directories with whitespace
+
+------------------------------------------------------------------------
+r15972 | kon | 2009-09-20 03:53:52 +0200 (Sun, 20 Sep 2009) | 2 lines
+
+Added predicate for lambda-info. moved make-lambda-info into library since used by compiler & eval.
+
+------------------------------------------------------------------------
+r15951 | kon | 2009-09-19 00:30:07 +0200 (Sat, 19 Sep 2009) | 3 lines
+
+Unit srfi-69 is-a core-library-module but not a builtin-feature, and Unit regex-extras doesn't exist.
+Added %list-fold, alist routines, renamed any/1. (chicken-primitive-object-inlines.scm).
+
+------------------------------------------------------------------------
+r15946 | felix | 2009-09-18 15:45:18 +0200 (Fri, 18 Sep 2009) | 1 line
+
+possible bugfix for optimization problem reported by Thomas Chust
+------------------------------------------------------------------------
+r15937 | felix | 2009-09-17 12:39:48 +0200 (Thu, 17 Sep 2009) | 1 line
+
+another path-test fix
+------------------------------------------------------------------------
+r15936 | felix | 2009-09-17 12:10:06 +0200 (Thu, 17 Sep 2009) | 1 line
+
+path-tests must be platform specific
+------------------------------------------------------------------------
+r15935 | felix | 2009-09-17 11:01:00 +0200 (Thu, 17 Sep 2009) | 1 line
+
+updated path tests
+------------------------------------------------------------------------
+r15932 | kon | 2009-09-17 01:51:44 +0200 (Thu, 17 Sep 2009) | 2 lines
+
+Fix for binary image pathname extension check on Windows. Was comparing too many chars. Added errmsg for wrong extn.
+
+------------------------------------------------------------------------
+r15918 | kon | 2009-09-16 10:21:12 +0200 (Wed, 16 Sep 2009) | 2 lines
+
+'dynamic-load-mode' didn't handle case of no dload-flags. 'C_dynamic_library_open' didn't test for .dll & .so
+
+------------------------------------------------------------------------
+r15913 | kon | 2009-09-16 07:03:22 +0200 (Wed, 16 Sep 2009) | 2 lines
+
+'local-timezone-abbreviation' wasn't using the current time so tz-name constant.
+
+------------------------------------------------------------------------
+r15908 | kon | 2009-09-15 21:24:07 +0200 (Tue, 15 Sep 2009) | 2 lines
+
+Made raising an error optional for dynamic load routines. Updated manual for new routines.
+
+------------------------------------------------------------------------
+r15907 | kon | 2009-09-15 20:17:43 +0200 (Tue, 15 Sep 2009) | 2 lines
+
+Made dynld routines handle string allocation. Use of common code for dynamic-library-procedure/variable. Made dynld sym routine a noret.
+
+------------------------------------------------------------------------
+r15902 | kon | 2009-09-15 11:16:25 +0200 (Tue, 15 Sep 2009) | 2 lines
+
+Rmvd 'C_dynamic_library_symbol' from initial ptable - not a scheme routine.
+
+------------------------------------------------------------------------
+r15901 | kon | 2009-09-15 11:04:50 +0200 (Tue, 15 Sep 2009) | 2 lines
+
+Rmvd non-scheme procs from initial ptable.
+
+------------------------------------------------------------------------
+r15900 | kon | 2009-09-15 10:59:43 +0200 (Tue, 15 Sep 2009) | 2 lines
+
+Extended len of initial ptable.
+
+------------------------------------------------------------------------
+r15899 | kon | 2009-09-15 10:47:15 +0200 (Tue, 15 Sep 2009) | 2 lines
+
+Added check for unsuccessful alloc of lf_list node. Rmvd attempt at free of NULL ptr..
+
+------------------------------------------------------------------------
+r15897 | iraikov | 2009-09-15 08:42:13 +0200 (Tue, 15 Sep 2009) | 2 lines
+
+added Getting started back
+
+------------------------------------------------------------------------
+r15896 | iraikov | 2009-09-15 08:40:50 +0200 (Tue, 15 Sep 2009) | 2 lines
+
+merged manual from wiki
+
+------------------------------------------------------------------------
+r15869 | kon | 2009-09-15 01:07:21 +0200 (Tue, 15 Sep 2009) | 5 lines
+
+library Added new dynamic library sys namespace procedures
+runtime Added support for non-chicken dynload, "folded" 'C_dload2' into platform indep routine
+chicken Added new dynload procs
+eval Made dynload flags a parameter, added new dynload routines (only a subset is "public", i.e. non-sys namespace)
+
+------------------------------------------------------------------------
+r15845 | iraikov | 2009-09-13 03:22:23 +0200 (Sun, 13 Sep 2009) | 2 lines
+
+trunk version set to 4.2.1
+
+------------------------------------------------------------------------
+r15830 | felix | 2009-09-12 14:10:59 +0200 (Sat, 12 Sep 2009) | 1 line
+
+strip module names
+------------------------------------------------------------------------
+r15828 | felix | 2009-09-11 16:13:46 +0200 (Fri, 11 Sep 2009) | 1 line
+
+handle case where proc in for-each/map is macro name
+------------------------------------------------------------------------
+r15823 | kon | 2009-09-11 05:10:24 +0200 (Fri, 11 Sep 2009) | 2 lines
+
+More work on loaded library introspection
+
+------------------------------------------------------------------------
+r15819 | kon | 2009-09-10 19:40:43 +0200 (Thu, 10 Sep 2009) | 4 lines
+
+files, path-tests Fix for "empty" but absolute pathnames
+library, runtime, chicken Better names for experimental "module" introspection
+files Deprecated 'make-pathname' separator argument
+
+------------------------------------------------------------------------
+r15817 | felix | 2009-09-10 15:11:08 +0200 (Thu, 10 Sep 2009) | 1 line
+
+avoid inlining map/for-each for possibly side-effecting operator
+------------------------------------------------------------------------
+r15816 | kon | 2009-09-09 10:09:01 +0200 (Wed, 09 Sep 2009) | 2 lines
+
+Begin of "module" (actually loaded .so) introspection. Reminder about 'normalize-pathname' problem with absolute pathnames.
+
+------------------------------------------------------------------------
+r15815 | felix | 2009-09-09 10:08:28 +0200 (Wed, 09 Sep 2009) | 1 line
+
+inlining of multi-arg for-each/map
+------------------------------------------------------------------------
+r15813 | kon | 2009-09-09 07:04:31 +0200 (Wed, 09 Sep 2009) | 6 lines
+
+posixwin use of 'fx= 0' instead of 'zero?'
+posixunix use of 'fx= 0' instead of 'zero?', fix for 'create-directory' when absolute pathname & easier to read
+files common code for "is this a pds char?", added 'decompose-directory', rmvd redundent compile-time proc cache
+files added 'decompose-directory'
+data-structures 'random-seed' not here
+
+------------------------------------------------------------------------
+r15799 | felix | 2009-09-08 21:40:12 +0200 (Tue, 08 Sep 2009) | 1 line
+
+enabled compiler-syntax for map, better rewrites for add1/sub1; WARNING: not tested, yet
+------------------------------------------------------------------------
+r15795 | felix | 2009-09-08 14:26:40 +0200 (Tue, 08 Sep 2009) | 1 line
+
+added compiler-syntax for map (not enabled yet)
+------------------------------------------------------------------------
+r15794 | felix | 2009-09-08 13:19:42 +0200 (Tue, 08 Sep 2009) | 1 line
+
+documented reexport; added test
+------------------------------------------------------------------------
+r15773 | felix | 2009-09-07 15:16:08 +0200 (Mon, 07 Sep 2009) | 1 line
+
+units used by default have been reduced to library and eval (expand); added -setup-mode option to compiler and interpreter
+------------------------------------------------------------------------
+r15772 | felix | 2009-09-07 12:26:11 +0200 (Mon, 07 Sep 2009) | 1 line
+
+module-names in import forms and imports generated for import-libs are stripped; fix for -emit-all-import-libraries in csc; first go at reexport (not fully tested or documented, yet)
+------------------------------------------------------------------------
+r15770 | felix | 2009-09-07 10:38:36 +0200 (Mon, 07 Sep 2009) | 1 line
+
+added -emit-all-import-libraries
+------------------------------------------------------------------------
+r15761 | kon | 2009-09-06 20:54:23 +0200 (Sun, 06 Sep 2009) | 2 lines
+
+Want to see mkdir cmd.
+
+------------------------------------------------------------------------
+r15758 | kon | 2009-09-06 20:40:11 +0200 (Sun, 06 Sep 2009) | 2 lines
+
+Forgot about "sudo" mode with 'create-directory/parents'. 'string-null?' is srfi-13 routine - rplcd w/ '(string=? "" ...)'.
+
+------------------------------------------------------------------------
+r15742 | kon | 2009-09-05 20:25:51 +0200 (Sat, 05 Sep 2009) | 2 lines
+
+Applied Dave N Murray's OpenBSD patch for 'convert_string_to_number'.
+
+------------------------------------------------------------------------
+r15734 | iraikov | 2009-09-04 09:40:33 +0200 (Fri, 04 Sep 2009) | 2 lines
+
+trunk version set to 4.1.9
+
+------------------------------------------------------------------------
+r15733 | iraikov | 2009-09-04 09:37:38 +0200 (Fri, 04 Sep 2009) | 2 lines
+
+rewrite of create-directory
+
+------------------------------------------------------------------------
+r15728 | kon | 2009-09-03 17:53:40 +0200 (Thu, 03 Sep 2009) | 2 lines
+
+Use of '##sys#expand-home-path' in unix & win posix 'create-directory'. Use of posix 'create-directory' in setup-api for 'create-directory/parents'.
+
+------------------------------------------------------------------------
+r15720 | iraikov | 2009-09-03 03:06:38 +0200 (Thu, 03 Sep 2009) | 2 lines
+
+trunk version set to 4.1.8
+
+------------------------------------------------------------------------
+r15719 | kon | 2009-09-03 02:25:29 +0200 (Thu, 03 Sep 2009) | 2 lines
+
+Fix for 'create-directory' when parents wanted; was always trying an absolute-pathname!
+
+------------------------------------------------------------------------
+r15708 | felix | 2009-09-01 20:55:26 +0200 (Tue, 01 Sep 2009) | 1 line
+
+deprecated for-each[-argv]-line; bumped version to 4.1.7
+------------------------------------------------------------------------
+r15703 | felix | 2009-09-01 14:42:40 +0200 (Tue, 01 Sep 2009) | 1 line
+
+print note in test-script
+------------------------------------------------------------------------
+r15700 | felix | 2009-09-01 13:20:26 +0200 (Tue, 01 Sep 2009) | 1 line
+
+fixed load bug #72, reported by Mario
+------------------------------------------------------------------------
+r15669 | felix | 2009-08-31 15:41:27 +0200 (Mon, 31 Aug 2009) | 1 line
+
+added possible patch for combination unit
+------------------------------------------------------------------------
+r15668 | felix | 2009-08-31 15:20:40 +0200 (Mon, 31 Aug 2009) | 1 line
+
+added TODO item
+------------------------------------------------------------------------
+r15660 | felix | 2009-08-30 16:15:25 +0200 (Sun, 30 Aug 2009) | 1 line
+
+chicken-install tries alternative servers if server responds with error
+------------------------------------------------------------------------
+r15659 | felix | 2009-08-30 15:58:29 +0200 (Sun, 30 Aug 2009) | 1 line
+
+sparc wordsize detection by Thomas Chust
+------------------------------------------------------------------------
+r15657 | felix | 2009-08-30 15:26:15 +0200 (Sun, 30 Aug 2009) | 1 line
+
+ptables were not enabled for compiled files compiled with csc
+------------------------------------------------------------------------
+r15647 | felix | 2009-08-30 11:57:47 +0200 (Sun, 30 Aug 2009) | 1 line
+
+fixed version in NEWS
+------------------------------------------------------------------------
+r15646 | felix | 2009-08-30 11:57:06 +0200 (Sun, 30 Aug 2009) | 1 line
+
+bumped version to 4.1.6; deprecated cross-chicken procedure
+------------------------------------------------------------------------
+r15637 | felix | 2009-08-29 15:47:26 +0200 (Sat, 29 Aug 2009) | 1 line
+
+updated bootstrap tarball
+------------------------------------------------------------------------
+r15614 | felix | 2009-08-29 01:12:51 +0200 (Sat, 29 Aug 2009) | 1 line
+
+cross-chicken fixes
+------------------------------------------------------------------------
+r15613 | felix | 2009-08-28 23:30:17 +0200 (Fri, 28 Aug 2009) | 1 line
+
+no install-libs toplevel target
+------------------------------------------------------------------------
+r15612 | felix | 2009-08-28 22:47:42 +0200 (Fri, 28 Aug 2009) | 1 line
+
+added regex benchmarks to manifest and test-script
+------------------------------------------------------------------------
+r15603 | felix | 2009-08-28 17:10:14 +0200 (Fri, 28 Aug 2009) | 1 line
+
+soname-related fix (when will it finally work?)
+------------------------------------------------------------------------
+r15601 | felix | 2009-08-28 14:18:16 +0200 (Fri, 28 Aug 2009) | 1 line
+
+types.db fixes
+------------------------------------------------------------------------
+r15600 | felix | 2009-08-28 09:42:29 +0200 (Fri, 28 Aug 2009) | 1 line
+
+added get-condition-property
+------------------------------------------------------------------------
+r15583 | felix | 2009-08-27 15:47:45 +0200 (Thu, 27 Aug 2009) | 1 line
+
+tcp ports allow accessing buffer and buffer size; wrapper for setting port data
+------------------------------------------------------------------------
+r15580 | felix | 2009-08-27 13:27:14 +0200 (Thu, 27 Aug 2009) | 1 line
+
+moved internally used compiler syntax into separate unit
+------------------------------------------------------------------------
+r15579 | felix | 2009-08-27 09:13:23 +0200 (Thu, 27 Aug 2009) | 1 line
+
+rartional? still not right; more mingw build fixes by Fadi
+------------------------------------------------------------------------
+r15578 | felix | 2009-08-26 16:34:54 +0200 (Wed, 26 Aug 2009) | 1 line
+
+only list globals that are not keywords
+------------------------------------------------------------------------
+r15576 | felix | 2009-08-26 13:31:13 +0200 (Wed, 26 Aug 2009) | 1 line
+
+slight changes
+------------------------------------------------------------------------
+r15575 | felix | 2009-08-26 13:24:59 +0200 (Wed, 26 Aug 2009) | 1 line
+
+added shinns regex benchmarks
+------------------------------------------------------------------------
+r15574 | felix | 2009-08-26 09:06:06 +0200 (Wed, 26 Aug 2009) | 1 line
+
+mingw-specific build fixes (thanks to Fadi Moukayed)
+------------------------------------------------------------------------
+r15573 | felix | 2009-08-26 08:50:26 +0200 (Wed, 26 Aug 2009) | 1 line
+
+removed redundant use of -inline
+------------------------------------------------------------------------
+r15564 | kon | 2009-08-25 17:34:42 +0200 (Tue, 25 Aug 2009) | 2 lines
+
+Use of 'C_randomize' only in init..
+
+------------------------------------------------------------------------
+r15563 | felix | 2009-08-25 14:34:43 +0200 (Tue, 25 Aug 2009) | 1 line
+
+updated bootstrap tarball; bumped version to 4.1.5
+------------------------------------------------------------------------
+r15562 | felix | 2009-08-25 10:21:22 +0200 (Tue, 25 Aug 2009) | 1 line
+
+ackd Fadi Moukayed
+------------------------------------------------------------------------
+r15561 | felix | 2009-08-25 10:19:04 +0200 (Tue, 25 Aug 2009) | 1 line
+
+replaced static platform test with dynamic one
+------------------------------------------------------------------------
+r15559 | felix | 2009-08-24 16:43:08 +0200 (Mon, 24 Aug 2009) | 1 line
+
+test for srandom availability in extras was insufficient - removed srandom support
+------------------------------------------------------------------------
+r15555 | felix | 2009-08-24 09:05:59 +0200 (Mon, 24 Aug 2009) | 1 line
+
+-O2 enables inlining by default; fixed bug in rational? reported by Zbigniew
+------------------------------------------------------------------------
+r15545 | iraikov | 2009-08-23 02:59:07 +0200 (Sun, 23 Aug 2009) | 2 lines
+
+updated NEWS file
+
+------------------------------------------------------------------------
+r15543 | felix | 2009-08-23 00:02:41 +0200 (Sun, 23 Aug 2009) | 1 line
+
+merged inlining branch (r15318:15542) into trunk; updated bootstrap tarball; bumped version to 4.1.4
+------------------------------------------------------------------------
+r15540 | felix | 2009-08-22 22:20:52 +0200 (Sat, 22 Aug 2009) | 1 line
+
+added OPTIMIZE_FOR_SPEED build option
+------------------------------------------------------------------------
+r15531 | kon | 2009-08-22 06:17:12 +0200 (Sat, 22 Aug 2009) | 2 lines
+
+Chgd to more inclusive msg.
+
+------------------------------------------------------------------------
+r15530 | kon | 2009-08-22 05:37:12 +0200 (Sat, 22 Aug 2009) | 2 lines
+
+The create dir is now "sudo" sensitive.
+
+------------------------------------------------------------------------
+r15528 | iraikov | 2009-08-21 14:24:56 +0200 (Fri, 21 Aug 2009) | 2 lines
+
+Chicken version set to 4.1.3
+
+------------------------------------------------------------------------
+r15527 | felix | 2009-08-21 12:08:40 +0200 (Fri, 21 Aug 2009) | 1 line
+
+added topological-sort to data-structures unit; chicken-install sorts dependencies before installing them
+------------------------------------------------------------------------
+r15506 | felix | 2009-08-17 13:46:19 +0200 (Mon, 17 Aug 2009) | 1 line
+
+assembler files weren't preprocessed at all
+------------------------------------------------------------------------
+r15501 | felix | 2009-08-16 11:29:09 +0200 (Sun, 16 Aug 2009) | 1 line
+
+remove symlink in make clean if soname is used
+------------------------------------------------------------------------
+r15485 | felix | 2009-08-14 19:20:38 +0200 (Fri, 14 Aug 2009) | 1 line
+
+enabled soname for bsd builds
+------------------------------------------------------------------------
+r15484 | felix | 2009-08-14 19:00:15 +0200 (Fri, 14 Aug 2009) | 1 line
+
+apply patch by Zbigniew to disable executable stack in assembly code modules (reported by Marihn Schouten)
+------------------------------------------------------------------------
+r15483 | felix | 2009-08-14 18:42:29 +0200 (Fri, 14 Aug 2009) | 1 line
+
+applied patch to csc by Zbigniew to always exit with a status code of 1 on errors (as somehow the error status got lost previously)
+------------------------------------------------------------------------
+r15482 | felix | 2009-08-14 18:19:18 +0200 (Fri, 14 Aug 2009) | 1 line
+
+uninstall only removes libraries installed for this version
+------------------------------------------------------------------------
+r15445 | felix | 2009-08-13 20:15:14 +0200 (Thu, 13 Aug 2009) | 1 line
+
+various fixes related to soname; bnumped version to 4.1.2
+------------------------------------------------------------------------
+r15438 | felix | 2009-08-13 18:36:10 +0200 (Thu, 13 Aug 2009) | 1 line
+
+reactivated SONAME, possibly messed everything up
+------------------------------------------------------------------------
+r15430 | felix | 2009-08-13 16:50:39 +0200 (Thu, 13 Aug 2009) | 1 line
+
+setup-api.c and setup-download.c are not removed in make clean (reported by Davide Puricelli)
+------------------------------------------------------------------------
+r15414 | felix | 2009-08-11 15:14:39 +0200 (Tue, 11 Aug 2009) | 1 line
+
+added support for VARDIR
+------------------------------------------------------------------------
+r15413 | felix | 2009-08-11 13:49:09 +0200 (Tue, 11 Aug 2009) | 1 line
+
+decoding of encoded large integers could overflow on 64-bit platforms (#64)
+------------------------------------------------------------------------
+r15346 | kon | 2009-08-07 05:54:45 +0200 (Fri, 07 Aug 2009) | 2 lines
+
+Rmvd unnecessary '-C' from benchmarks compile ('-I' is a C compiler option). Made compiler format strings glovars w/ "ld" '-s' option rmvd for MacOS X.
+
+------------------------------------------------------------------------
+r15331 | felix | 2009-08-06 12:59:30 +0200 (Thu, 06 Aug 2009) | 1 line
+
+fixed missing relinking for chicken-setup (reported by sjamaan)
+------------------------------------------------------------------------
+r15321 | felix | 2009-08-05 08:21:08 +0200 (Wed, 05 Aug 2009) | 1 line
+
+documentation fixes, read-symbolic-link enhancement by mario; rational? fixed (thanks to John Cowan)
+------------------------------------------------------------------------
+r15313 | sjamaan | 2009-08-03 20:42:23 +0200 (Mon, 03 Aug 2009) | 1 line
+
+Change all occurrences of '==' used in test(1) comparisons to read '=', instead. == is a bash-ism which doesn't work in most other shells
+------------------------------------------------------------------------
+r15310 | felix | 2009-08-03 12:15:15 +0200 (Mon, 03 Aug 2009) | 1 line
+
+ack update
+------------------------------------------------------------------------
+r15304 | felix | 2009-08-03 01:30:21 +0200 (Mon, 03 Aug 2009) | 1 line
+
+merged last changes from release branch
+------------------------------------------------------------------------
+r15294 | felix | 2009-08-01 00:41:44 +0200 (Sat, 01 Aug 2009) | 1 line
+
+merged some changes from the wiki into manual
+------------------------------------------------------------------------
+r15292 | felix | 2009-07-31 21:50:25 +0200 (Fri, 31 Jul 2009) | 1 line
+
+applied patch by zbigniew for fixing various buffer overflows (#61)
+------------------------------------------------------------------------
+r15291 | felix | 2009-07-31 21:45:17 +0200 (Fri, 31 Jul 2009) | 1 line
+
+fixed abs(3) overflow by applying patch from zbigniew
+------------------------------------------------------------------------
+r15276 | felix | 2009-07-30 10:51:41 +0200 (Thu, 30 Jul 2009) | 1 line
+
+strip unit names (if unit-name equals symbol in se); include windows.h and define WINAPI, when needed
+------------------------------------------------------------------------
+r15275 | felix | 2009-07-29 11:10:09 +0200 (Wed, 29 Jul 2009) | 1 line
+
+handle errors when deleting files and optional loading for compile-file
+------------------------------------------------------------------------
+r15274 | felix | 2009-07-29 10:22:55 +0200 (Wed, 29 Jul 2009) | 1 line
+
+handle crappy shells when using compile-file
+------------------------------------------------------------------------
+r15272 | felix | 2009-07-28 15:47:18 +0200 (Tue, 28 Jul 2009) | 1 line
+
+compile-file was missing from import lib
+------------------------------------------------------------------------
+r15270 | felix | 2009-07-28 14:53:18 +0200 (Tue, 28 Jul 2009) | 1 line
+
+enabled gc-report shows reclaimed locative-table entries
+------------------------------------------------------------------------
+r15262 | felix | 2009-07-26 01:49:53 +0200 (Sun, 26 Jul 2009) | 1 line
+
+bumped version to 4.1.1; improvements and corrections for compile-file
+------------------------------------------------------------------------
+r15259 | felix | 2009-07-25 23:00:16 +0200 (Sat, 25 Jul 2009) | 1 line
+
+renamed cachedir for `scheme' script
+------------------------------------------------------------------------
+r15246 | felix | 2009-07-22 12:54:00 +0200 (Wed, 22 Jul 2009) | 1 line
+
+-debug v; compile-file; all namespace decls in one file
+------------------------------------------------------------------------
+r15243 | felix | 2009-07-19 16:38:29 +0200 (Sun, 19 Jul 2009) | 1 line
+
+marked printf non-foldable; o is only inlined, if extended-binding
+------------------------------------------------------------------------
+r15234 | felix | 2009-07-17 20:59:08 +0200 (Fri, 17 Jul 2009) | 1 line
+
+compiler-syntax based optimization of "o"; extended bindings weren't properly handled with regard to constant-folding; lambdas in operator position are now correctly handled and optimized (after expansion of procedure-call form)
+------------------------------------------------------------------------
+r15207 | felix | 2009-07-12 21:44:51 +0200 (Sun, 12 Jul 2009) | 1 line
+
+create-temporary-file uses /tmp, if no suitable env. var is found
+------------------------------------------------------------------------
+r15203 | felix | 2009-07-09 16:35:02 +0200 (Thu, 09 Jul 2009) | 1 line
+
+flush output after load message
+------------------------------------------------------------------------
+r15194 | felix | 2009-07-08 09:20:34 +0200 (Wed, 08 Jul 2009) | 1 line
+
+create test-repo manually
+------------------------------------------------------------------------
+r15193 | felix | 2009-07-08 08:03:55 +0200 (Wed, 08 Jul 2009) | 1 line
+
+flush stderr on load-warning
+------------------------------------------------------------------------
+r15173 | felix | 2009-07-06 13:45:28 +0200 (Mon, 06 Jul 2009) | 1 line
+
+merged item in NEWS from prerelease branch (r15167)
+------------------------------------------------------------------------
+r15171 | felix | 2009-07-06 11:23:55 +0200 (Mon, 06 Jul 2009) | 1 line
+
+fix in foreign-value; tests use own repo; other fixes (thanks to sjaaman)
+------------------------------------------------------------------------
+r15170 | felix | 2009-07-06 10:53:52 +0200 (Mon, 06 Jul 2009) | 1 line
+
+spotless cleans more files, as suggested by sjaaman in #56
+------------------------------------------------------------------------
+r15169 | felix | 2009-07-06 10:40:57 +0200 (Mon, 06 Jul 2009) | 1 line
+
+applied fix by sjaaman for #54
+------------------------------------------------------------------------
+r15168 | felix | 2009-07-06 10:40:34 +0200 (Mon, 06 Jul 2009) | 1 line
+
+disabled debugging operations, this makes map-se hidable again
+------------------------------------------------------------------------
+r15164 | kon | 2009-07-05 23:25:01 +0200 (Sun, 05 Jul 2009) | 2 lines
+
+chicken-ffi-syntax : foreign-value macro used C-code as return type. expand - temp fix for call of undefined proc.
+
+------------------------------------------------------------------------
+r15149 | felix | 2009-07-03 13:43:28 +0200 (Fri, 03 Jul 2009) | 1 line
+
+trivial fixes
+------------------------------------------------------------------------
+r15143 | felix | 2009-07-03 10:46:56 +0200 (Fri, 03 Jul 2009) | 1 line
+
+foreign-code accepts symbol argument
+------------------------------------------------------------------------
+r15134 | felix | 2009-07-02 07:51:39 +0200 (Thu, 02 Jul 2009) | 1 line
+
+fix in henrietta list command
+------------------------------------------------------------------------
+r15123 | felix | 2009-06-30 16:48:34 +0200 (Tue, 30 Jun 2009) | 1 line
+
+typo fix
+------------------------------------------------------------------------
+r15119 | felix | 2009-06-30 13:55:24 +0200 (Tue, 30 Jun 2009) | 1 line
+
+deprecated getenv and canonical-path; normalize-pathname does most of canonicalizations
+------------------------------------------------------------------------
+r15118 | felix | 2009-06-30 10:26:47 +0200 (Tue, 30 Jun 2009) | 1 line
+
+fixed tilde-expansion (reported by Zbigniew), ~user isn't supported anymore (and never was officially)
+------------------------------------------------------------------------
+r15117 | felix | 2009-06-30 10:18:43 +0200 (Tue, 30 Jun 2009) | 1 line
+
+added -no-compiler-syntax; compiler syntax used by optimizer respects standard-/extended-bindings decl
+------------------------------------------------------------------------
+r15116 | iraikov | 2009-06-30 04:00:09 +0200 (Tue, 30 Jun 2009) | 2 lines
+
+added extra space between svn arguments in make-svn-ls-cmd
+
+------------------------------------------------------------------------
+r15104 | felix | 2009-06-29 15:04:56 +0200 (Mon, 29 Jun 2009) | 1 line
+
+typo
+------------------------------------------------------------------------
+r15102 | felix | 2009-06-29 14:50:11 +0200 (Mon, 29 Jun 2009) | 1 line
+
+updated NEWS file
+------------------------------------------------------------------------
+r15100 | felix | 2009-06-29 10:56:12 +0200 (Mon, 29 Jun 2009) | 1 line
+
+define-compiler-syntax respects run-time-macros decl; wiki2html improvements
+------------------------------------------------------------------------
+r15085 | felix | 2009-06-27 15:45:11 +0200 (Sat, 27 Jun 2009) | 1 line
+
+fixed bug in format-string compilation
+------------------------------------------------------------------------
+r15084 | felix | 2009-06-27 15:42:54 +0200 (Sat, 27 Jun 2009) | 1 line
+
+tiny test-dist.sh changer
+------------------------------------------------------------------------
+r15082 | felix | 2009-06-27 15:24:09 +0200 (Sat, 27 Jun 2009) | 1 line
+
+removed mentioning of obsolete man extension
+------------------------------------------------------------------------
+r15078 | felix | 2009-06-27 15:09:45 +0200 (Sat, 27 Jun 2009) | 1 line
+
+forgot file
+------------------------------------------------------------------------
+r15077 | felix | 2009-06-27 15:07:40 +0200 (Sat, 27 Jun 2009) | 1 line
+
+minor doc and compiler fixes; tested compiler-syntax
+------------------------------------------------------------------------
+r15076 | felix | 2009-06-26 12:22:50 +0200 (Fri, 26 Jun 2009) | 1 line
+
+makedist.scm fixes
+------------------------------------------------------------------------
+r15075 | felix | 2009-06-26 10:29:10 +0200 (Fri, 26 Jun 2009) | 1 line
+
+csi: -sx didn't ignore extra options and arguments; makedist.scm generates html
+------------------------------------------------------------------------
+r15074 | felix | 2009-06-26 10:03:12 +0200 (Fri, 26 Jun 2009) | 1 line
+
+local compiler macros; compiler macro synrules fallthrough handling; refactored define-syntax and define-compiler-syntax; bumped version to 4.0.9
+------------------------------------------------------------------------
+r15061 | felix | 2009-06-25 15:26:41 +0200 (Thu, 25 Jun 2009) | 1 line
+
+slight change in semantics for define-compiler-syntax, some testing
+------------------------------------------------------------------------
+r15060 | felix | 2009-06-25 13:13:33 +0200 (Thu, 25 Jun 2009) | 1 line
+
+uses core syntax forms more often to avoid capture of non-macro special forms; added define-compiler-syntax (untested)
+------------------------------------------------------------------------
+r15059 | felix | 2009-06-25 12:57:09 +0200 (Thu, 25 Jun 2009) | 1 line
+
+synced changes from wiki into manual
+------------------------------------------------------------------------
+r15057 | felix | 2009-06-25 09:39:06 +0200 (Thu, 25 Jun 2009) | 1 line
+
+fix for begin-capturing bug (#47), removed uses of define-macro
+------------------------------------------------------------------------
+r15053 | felix | 2009-06-24 12:07:52 +0200 (Wed, 24 Jun 2009) | 1 line
+
+format-string compiler macros cleanup and tests
+------------------------------------------------------------------------
+r15050 | felix | 2009-06-23 15:20:38 +0200 (Tue, 23 Jun 2009) | 1 line
+
+bumped version to 4.0.8
+------------------------------------------------------------------------
+r15049 | felix | 2009-06-23 14:53:54 +0200 (Tue, 23 Jun 2009) | 1 line
+
+types.db fixes; optimizer defines compiler syntax for for-each and [sf]printf/format; scrutiny done on debugbuild, not via explicit make target
+------------------------------------------------------------------------
+r15047 | felix | 2009-06-22 13:19:06 +0200 (Mon, 22 Jun 2009) | 1 line
+
+possibly really fixed prefix/import problem
+------------------------------------------------------------------------
+r15038 | felix | 2009-06-20 16:07:53 +0200 (Sat, 20 Jun 2009) | 4 lines
+
+- `er-macro-transformer' is not officially required anymore and moved from the scheme module into the chicken module
+- internal support or compiler macros
+- locating import-library does start in repo, as it used to be (otherwise you'll get runtime linker errors during build)
+
+------------------------------------------------------------------------
+r15037 | felix | 2009-06-19 09:18:41 +0200 (Fri, 19 Jun 2009) | 5 lines
+
+- warn if transformer returns original form
+- new bootstrap tarball
+- removed pre-cps pass
+- exceptions in module-finalization in compiler doesn't show backtrace
+
+------------------------------------------------------------------------
+r15021 | felix | 2009-06-18 16:11:02 +0200 (Thu, 18 Jun 2009) | 1 line
+
+do not check for re-def of type for deprecated ids
+------------------------------------------------------------------------
+r15020 | felix | 2009-06-18 16:08:09 +0200 (Thu, 18 Jun 2009) | 1 line
+
+added missing files to distribution/manifest; possibly fixed prefix bug
+------------------------------------------------------------------------
+r15017 | felix | 2009-06-18 13:51:14 +0200 (Thu, 18 Jun 2009) | 1 line
+
+install_name_tool patch by Zbigniew (#43)
+------------------------------------------------------------------------
+r15016 | felix | 2009-06-18 13:50:48 +0200 (Thu, 18 Jun 2009) | 1 line
+
+added T debugging option
+------------------------------------------------------------------------
+r15001 | felix | 2009-06-17 15:07:03 +0200 (Wed, 17 Jun 2009) | 9 lines
+
+- deprecated "stat-..." functions from posix unit
+- added to posix unit:
+ character-device?
+ block-device?
+ socket?
+- library: added "directory-exists?"
+- error during compilation doesn't show backtrace
+- import-libraries are first looked for in current directory
+
+------------------------------------------------------------------------
+r15000 | felix | 2009-06-16 13:39:52 +0200 (Tue, 16 Jun 2009) | 1 line
+
+renamed setup-{install,verbose}-flag to ...-mode; old names are still available, but deprecated
+------------------------------------------------------------------------
+r14999 | felix | 2009-06-16 13:31:46 +0200 (Tue, 16 Jun 2009) | 1 line
+
+prefer pwd when locating import libraries
+------------------------------------------------------------------------
+r14995 | felix | 2009-06-14 21:57:18 +0200 (Sun, 14 Jun 2009) | 1 line
+
+trivial changes
+------------------------------------------------------------------------
+r14994 | felix | 2009-06-14 21:56:51 +0200 (Sun, 14 Jun 2009) | 1 line
+
+fixed broken -R option
+------------------------------------------------------------------------
+r14993 | felix | 2009-06-14 21:56:10 +0200 (Sun, 14 Jun 2009) | 1 line
+
+scrutinizer: types.db fixes; noreturn propagates so value-count check in conditional doesn't fail
+------------------------------------------------------------------------
+r14988 | felix | 2009-06-14 01:09:20 +0200 (Sun, 14 Jun 2009) | 1 line
+
+applied string-substitute patch by zb
+------------------------------------------------------------------------
+r14987 | felix | 2009-06-14 00:13:06 +0200 (Sun, 14 Jun 2009) | 1 line
+
+fix in types.db
+------------------------------------------------------------------------
+r14940 | felix | 2009-06-08 13:21:56 +0200 (Mon, 08 Jun 2009) | 1 line
+
+added stub application for chicken-setup
+------------------------------------------------------------------------
+r14898 | felix | 2009-06-06 01:20:24 +0200 (Sat, 06 Jun 2009) | 1 line
+
+user-interrupt condition object had missing slot for kinds
+------------------------------------------------------------------------
+r14897 | felix | 2009-06-06 00:47:49 +0200 (Sat, 06 Jun 2009) | 1 line
+
+another types.db fix
+------------------------------------------------------------------------
+r14896 | felix | 2009-06-06 00:35:18 +0200 (Sat, 06 Jun 2009) | 1 line
+
+types.db fix for assoc
+------------------------------------------------------------------------
+r14895 | felix | 2009-06-06 00:12:07 +0200 (Sat, 06 Jun 2009) | 1 line
+
+compiler import library reference removed
+------------------------------------------------------------------------
+r14893 | felix | 2009-06-05 11:41:45 +0200 (Fri, 05 Jun 2009) | 1 line
+
+trivial help text change
+------------------------------------------------------------------------
+r14883 | felix | 2009-06-04 08:48:42 +0200 (Thu, 04 Jun 2009) | 1 line
+
+updated version to 4.0.7
+------------------------------------------------------------------------
+r14882 | felix | 2009-06-04 08:47:54 +0200 (Thu, 04 Jun 2009) | 1 line
+
+disabled pre-cps rewrite (until we actually do something); removed MSVC build support
+------------------------------------------------------------------------
+r14875 | felix | 2009-06-03 13:28:58 +0200 (Wed, 03 Jun 2009) | 1 line
+
+types.db fixes
+------------------------------------------------------------------------
+r14874 | felix | 2009-06-03 13:25:11 +0200 (Wed, 03 Jun 2009) | 1 line
+
+global inlining fixes; other small things
+------------------------------------------------------------------------
+r14870 | felix | 2009-06-03 08:53:07 +0200 (Wed, 03 Jun 2009) | 6 lines
+
+- added new options to option table in c-platform.scm
+- started with rewrite pass (not implemented yet)
+- removed "compiler" import library
+- added `-consult-inline-file FILENAME'
+- slight scrutiny improvement (real-name for let bindings)
+
+------------------------------------------------------------------------
+r14864 | kon | 2009-06-03 04:52:14 +0200 (Wed, 03 Jun 2009) | 2 lines
+
+Added -no-argc/bound/procedure-checks & -no-procedure-checks-for-usual-bindings options.
+
+------------------------------------------------------------------------
+r14861 | felix | 2009-06-02 13:31:07 +0200 (Tue, 02 Jun 2009) | 1 line
+
+forgot to enable loading inline files in batch-driver
+------------------------------------------------------------------------
+r14860 | felix | 2009-06-02 12:42:09 +0200 (Tue, 02 Jun 2009) | 1 line
+
+disable debugging output
+------------------------------------------------------------------------
+r14859 | felix | 2009-06-02 12:41:45 +0200 (Tue, 02 Jun 2009) | 1 line
+
+fixes in types.db (thanks to Peter Bex); more portable removal of scrutiny files
+------------------------------------------------------------------------
+r14858 | kon | 2009-06-02 04:30:34 +0200 (Tue, 02 Jun 2009) | 2 lines
+
+scrutiny files may not exist.
+
+------------------------------------------------------------------------
+r14829 | felix | 2009-05-29 15:52:46 +0200 (Fri, 29 May 2009) | 1 line
+
+scrutiny-related fixes
+------------------------------------------------------------------------
+r14828 | felix | 2009-05-29 14:44:07 +0200 (Fri, 29 May 2009) | 1 line
+
+merged scrutiny branch
+------------------------------------------------------------------------
+r14806 | kon | 2009-05-27 19:28:18 +0200 (Wed, 27 May 2009) | 2 lines
+
+Missing ')'.
+
+------------------------------------------------------------------------
+r14801 | felix | 2009-05-27 00:42:54 +0200 (Wed, 27 May 2009) | 1 line
+
+string-hash[-ci] redundancy slightly improved
+------------------------------------------------------------------------
+r14799 | felix | 2009-05-26 23:33:44 +0200 (Tue, 26 May 2009) | 1 line
+
+hopefully better unsigned-c-string support
+------------------------------------------------------------------------
+r14782 | felix | 2009-05-25 17:19:16 +0200 (Mon, 25 May 2009) | 1 line
+
+msvc build attempt
+------------------------------------------------------------------------
+r14781 | felix | 2009-05-25 13:04:41 +0200 (Mon, 25 May 2009) | 1 line
+
+hidden expansions into er-macro-transformer are needless and problematic when emitting import libraries
+------------------------------------------------------------------------
+r14779 | felix | 2009-05-25 10:16:55 +0200 (Mon, 25 May 2009) | 1 line
+
+-debug e; added set-file-position! again
+------------------------------------------------------------------------
+r14720 | iraikov | 2009-05-21 04:27:15 +0200 (Thu, 21 May 2009) | 2 lines
+
+typo fix
+
+------------------------------------------------------------------------
+r14710 | ashinn | 2009-05-19 17:12:34 +0200 (Tue, 19 May 2009) | 2 lines
+
+exporting irregex-apply-match
+
+------------------------------------------------------------------------
+r14709 | ashinn | 2009-05-19 15:45:19 +0200 (Tue, 19 May 2009) | 2 lines
+
+adding irregex-apply-match
+
+------------------------------------------------------------------------
+r14706 | felix | 2009-05-19 14:44:32 +0200 (Tue, 19 May 2009) | 1 line
+
+bumped version to 4.0.5
+------------------------------------------------------------------------
+r14705 | felix | 2009-05-19 14:22:59 +0200 (Tue, 19 May 2009) | 1 line
+
+chicken-install needs chicken-syntax; bug in case-lambda; tidying up
+------------------------------------------------------------------------
+r14656 | felix | 2009-05-15 23:02:26 +0200 (Fri, 15 May 2009) | 1 line
+
+bumped version to 4.0.4; fixed various bugs in chicken-install; fixed name-resolution bug in compiler handling of assignment
+------------------------------------------------------------------------
+r14653 | felix | 2009-05-15 14:48:26 +0200 (Fri, 15 May 2009) | 1 line
+
+case-lambda uses eq? instead of =; started convenience module chicken-base
+------------------------------------------------------------------------
+r14630 | ashinn | 2009-05-14 16:46:53 +0200 (Thu, 14 May 2009) | 2 lines
+
+fixing \xNN escapes in char-set ranges
+
+------------------------------------------------------------------------
+r14613 | iraikov | 2009-05-13 03:07:26 +0200 (Wed, 13 May 2009) | 3 lines
+
+added the make-eggdoc script, a tool to create HTML files from eggdoc
+documentation
+
+------------------------------------------------------------------------
+r14607 | felix | 2009-05-12 11:27:35 +0200 (Tue, 12 May 2009) | 1 line
+
+bumped version to 4.0.3
+------------------------------------------------------------------------
+r14599 | iraikov | 2009-05-12 06:07:55 +0200 (Tue, 12 May 2009) | 3 lines
+
+Fix to require-extension version to handle the case when required
+version and present version are equal.
+
+------------------------------------------------------------------------
+r14590 | felix | 2009-05-11 13:49:45 +0200 (Mon, 11 May 2009) | 1 line
+
+applied patch by sjaaman for stripping FFI form variables
+------------------------------------------------------------------------
+r14587 | iraikov | 2009-05-11 03:42:30 +0200 (Mon, 11 May 2009) | 2 lines
+
+Fixes in egg version comparison.
+
+------------------------------------------------------------------------
+r14565 | felix | 2009-05-08 11:48:02 +0200 (Fri, 08 May 2009) | 1 line
+
+multiple uses of -v replace -v2/-v3
+------------------------------------------------------------------------
+r14556 | felix | 2009-05-07 12:09:35 +0200 (Thu, 07 May 2009) | 1 line
+
+added note about redefinition of imported syntax
+------------------------------------------------------------------------
+r14555 | felix | 2009-05-07 12:03:39 +0200 (Thu, 07 May 2009) | 1 line
+
+added missing imports (#10, reported by presto)
+------------------------------------------------------------------------
+r14554 | felix | 2009-05-07 11:59:34 +0200 (Thu, 07 May 2009) | 1 line
+
+fixed bug #16 (setter for file-position accepts list, now)
+------------------------------------------------------------------------
+r14540 | ashinn | 2009-05-07 03:22:58 +0200 (Thu, 07 May 2009) | 2 lines
+
+Matching `*' as the module exports list unhygienically.
+
+------------------------------------------------------------------------
+r14533 | felix | 2009-05-06 00:57:45 +0200 (Wed, 06 May 2009) | 1 line
+
+typos
+------------------------------------------------------------------------
+r14531 | felix | 2009-05-06 00:04:55 +0200 (Wed, 06 May 2009) | 1 line
+
+added new logo by Joshua Griffith
+------------------------------------------------------------------------
+r14527 | zbigniew | 2009-05-04 22:29:49 +0200 (Mon, 04 May 2009) | 3 lines
+
+Fix silly number-hash bug which hashed all fixnums to 23 --
+any self-respecting nerd would know they should hash to 42
+
+------------------------------------------------------------------------
+r14521 | ashinn | 2009-05-04 05:00:46 +0200 (Mon, 04 May 2009) | 2 lines
+
+updating to 0.8.6
+
+------------------------------------------------------------------------
+r14511 | felix | 2009-04-30 12:15:46 +0200 (Thu, 30 Apr 2009) | 1 line
+
+global-inlining fixes (for problems reported by Jim Ursetto)
+------------------------------------------------------------------------
+r14507 | felix | 2009-04-29 16:10:26 +0200 (Wed, 29 Apr 2009) | 1 line
+
+applied read-string patch by zb
+------------------------------------------------------------------------
+r14496 | felix | 2009-04-28 11:34:38 +0200 (Tue, 28 Apr 2009) | 1 line
+
+created new bootstrapping tarball
+------------------------------------------------------------------------
+r14474 | felix | 2009-04-27 10:20:23 +0200 (Mon, 27 Apr 2009) | 1 line
+
+strip-syntax foreign types at a few more locations
+------------------------------------------------------------------------
+r14447 | felix | 2009-04-26 00:01:54 +0200 (Sun, 26 Apr 2009) | 1 line
+
+foreign types are strip-syntax'ed (should fix #17), reported by Shawn Rutledge
+------------------------------------------------------------------------
+r14400 | iraikov | 2009-04-24 01:37:36 +0200 (Fri, 24 Apr 2009) | 2 lines
+
+Set the actual timeout value to 20 seconds.
+
+------------------------------------------------------------------------
+r14398 | felix | 2009-04-23 10:22:41 +0200 (Thu, 23 Apr 2009) | 1 line
+
+strip-syntax handles circular structures (contributed by Alex Shinn)
+------------------------------------------------------------------------
+r14397 | felix | 2009-04-23 09:41:31 +0200 (Thu, 23 Apr 2009) | 1 line
+
+setup-download closes in and out ports together; increased read/write timeout to 20 secs (#13)
+------------------------------------------------------------------------
+r14377 | ashinn | 2009-04-23 02:51:38 +0200 (Thu, 23 Apr 2009) | 2 lines
+
+Adding bugfix from upstream to irregex-match-data?.
+
+------------------------------------------------------------------------
+r14341 | felix | 2009-04-22 13:06:13 +0200 (Wed, 22 Apr 2009) | 1 line
+
+added test for #15 by Alex Shinn
+------------------------------------------------------------------------
+r14340 | felix | 2009-04-22 11:09:11 +0200 (Wed, 22 Apr 2009) | 1 line
+
+possible fix for let-syntax/local var (#15) bug reported by Alex Shinn
+------------------------------------------------------------------------
+r14327 | felix | 2009-04-21 11:43:55 +0200 (Tue, 21 Apr 2009) | 1 line
+
+bumped version to 4.0.2
+------------------------------------------------------------------------
+r14326 | felix | 2009-04-21 11:43:17 +0200 (Tue, 21 Apr 2009) | 1 line
+
+missing exports from chicken module
+------------------------------------------------------------------------
+r14297 | zbigniew | 2009-04-18 20:31:10 +0200 (Sat, 18 Apr 2009) | 1 line
+
+make-egg-index: fix words that are runtogether
+------------------------------------------------------------------------
+r14292 | felix | 2009-04-18 13:18:36 +0200 (Sat, 18 Apr 2009) | 1 line
+
+minor changes
+------------------------------------------------------------------------
+r14291 | felix | 2009-04-18 13:17:47 +0200 (Sat, 18 Apr 2009) | 1 line
+
+applied version-comparison fix by Jim Ursetto
+------------------------------------------------------------------------
+r14287 | zbigniew | 2009-04-18 02:55:44 +0200 (Sat, 18 Apr 2009) | 1 line
+
+make-egg-index: HTML and CSS updates
+------------------------------------------------------------------------
+r14283 | zbigniew | 2009-04-17 22:51:29 +0200 (Fri, 17 Apr 2009) | 1 line
+
+exported irregex-fold
+------------------------------------------------------------------------
+r14279 | felix | 2009-04-17 11:17:15 +0200 (Fri, 17 Apr 2009) | 1 line
+
+Note aboud /usr/pkg and NetBSD; -nursery compiler option should work now (reported by Jim Ursetto)
+------------------------------------------------------------------------
+r14273 | ashinn | 2009-04-17 05:50:52 +0200 (Fri, 17 Apr 2009) | 3 lines
+
+bugfix for [ inside character classes when not used as a POSIX
+named character class
+
+------------------------------------------------------------------------
+r14268 | felix | 2009-04-16 11:34:25 +0200 (Thu, 16 Apr 2009) | 1 line
+
+fixed keyword var resolve bug reported by Alonso Andres (#7)
+------------------------------------------------------------------------
+r14258 | felix | 2009-04-15 10:14:12 +0200 (Wed, 15 Apr 2009) | 1 line
+
+permalink is false for egg rss feed items
+------------------------------------------------------------------------
+r14257 | felix | 2009-04-15 09:48:15 +0200 (Wed, 15 Apr 2009) | 1 line
+
+make-egg-rss-feed uses sxml-transforms, now
+------------------------------------------------------------------------
+r14256 | felix | 2009-04-15 09:27:08 +0200 (Wed, 15 Apr 2009) | 1 line
+
+note about parallel builds; egg index/feed script stuff
+------------------------------------------------------------------------
+r14237 | felix | 2009-04-13 12:38:22 +0200 (Mon, 13 Apr 2009) | 1 line
+
+applied readline-speedup patch by Jim Ursetto; chicken-install -prefix should work better
+------------------------------------------------------------------------
+r14236 | felix | 2009-04-13 11:32:45 +0200 (Mon, 13 Apr 2009) | 1 line
+
+added er-macro-transformer
+------------------------------------------------------------------------
+r14235 | sjamaan | 2009-04-11 15:21:55 +0200 (Sat, 11 Apr 2009) | 1 line
+
+Fix make-egg-index script so it links to user profile pages under /wiki/users
+------------------------------------------------------------------------
+r14224 | felix | 2009-04-10 00:23:23 +0200 (Fri, 10 Apr 2009) | 1 line
+
+added egg image to index page
+------------------------------------------------------------------------
+r14200 | felix | 2009-04-09 00:06:16 +0200 (Thu, 09 Apr 2009) | 1 line
+
+set version to 4.0.1; pulled last prerelease changes
+------------------------------------------------------------------------
+r14188 | kon | 2009-04-08 18:55:13 +0200 (Wed, 08 Apr 2009) | 2 lines
+
+Bug fix for use of %port -> %port?, %wordblock-ref? -> %wordblock-ref. Added %list/1, %list, %any/1.
+
+------------------------------------------------------------------------
+r14143 | kon | 2009-04-07 04:44:57 +0200 (Tue, 07 Apr 2009) | 2 lines
+
+Dup ##sys#signal-hook in forward refs.
+
+------------------------------------------------------------------------
+r14133 | felix | 2009-04-06 23:02:11 +0200 (Mon, 06 Apr 2009) | 1 line
+
+fix for case-lambda (thanks to Peter Bex); some manual fixes
+------------------------------------------------------------------------
+r14105 | kon | 2009-04-06 18:01:53 +0200 (Mon, 06 Apr 2009) | 2 lines
+
+Updated xref.
+
+------------------------------------------------------------------------
+r14101 | kon | 2009-04-06 17:30:35 +0200 (Mon, 06 Apr 2009) | 2 lines
+
+Applied the fix for dangling open ports suggested by Matt Jones.
+
+------------------------------------------------------------------------
+r14095 | felix | 2009-04-06 00:28:12 +0200 (Mon, 06 Apr 2009) | 1 line
+
+merged changes from prerelease revs 13879-14094
+------------------------------------------------------------------------
+r14076 | kon | 2009-04-04 18:54:06 +0200 (Sat, 04 Apr 2009) | 2 lines
+
+Added i/o-port?, proc?
+
+------------------------------------------------------------------------
+r14074 | kon | 2009-04-04 17:09:27 +0200 (Sat, 04 Apr 2009) | 2 lines
+
+Installation of examples didn't observe the 'sudo' mode.
+
+------------------------------------------------------------------------
+r14061 | kon | 2009-04-03 17:29:23 +0200 (Fri, 03 Apr 2009) | 2 lines
+
+Spelling.
+
+------------------------------------------------------------------------
+r14026 | kon | 2009-04-01 05:41:39 +0200 (Wed, 01 Apr 2009) | 2 lines
+
+Added make-list, take & drop. Renamed -1 to /1.
+
+------------------------------------------------------------------------
+r14011 | kon | 2009-03-31 19:46:27 +0200 (Tue, 31 Mar 2009) | 2 lines
+
+Fixed %=/%</etc.
+
+------------------------------------------------------------------------
+r13985 | felix | 2009-03-28 21:56:09 +0100 (Sat, 28 Mar 2009) | 1 line
+
+disabled hacked-apply for mingw with ARCH = x86-64 (thanks to Leonardo Manera)
+------------------------------------------------------------------------
+r13984 | felix | 2009-03-28 21:53:05 +0100 (Sat, 28 Mar 2009) | 1 line
+
+resolved conflicts in ANNOUNCE
+------------------------------------------------------------------------
+r13962 | felix | 2009-03-27 08:51:34 +0100 (Fri, 27 Mar 2009) | 1 line
+
+moved scripts; added scripts/README
+------------------------------------------------------------------------
+r13953 | kon | 2009-03-27 02:20:55 +0100 (Fri, 27 Mar 2009) | 2 lines
+
+Extra define ##sys#vector-length.
+
+------------------------------------------------------------------------
+r13952 | kon | 2009-03-27 02:14:41 +0100 (Fri, 27 Mar 2009) | 2 lines
+
+##sys#vector-ref was vector-length!
+
+------------------------------------------------------------------------
+r13948 | kon | 2009-03-26 17:42:05 +0100 (Thu, 26 Mar 2009) | 2 lines
+
+No srandomev for any Linux. Added LINKER_OPTIMIZATION_OPTIONS to TARGET_LINKER_OPTIMIZATION_OPTIONS.
+
+------------------------------------------------------------------------
+r13944 | felix | 2009-03-26 15:58:39 +0100 (Thu, 26 Mar 2009) | 1 line
+
+moved henrietta script
+------------------------------------------------------------------------
+r13943 | felix | 2009-03-26 13:32:59 +0100 (Thu, 26 Mar 2009) | 1 line
+
+updated acknowledgments
+------------------------------------------------------------------------
+r13942 | felix | 2009-03-26 11:51:56 +0100 (Thu, 26 Mar 2009) | 1 line
+
+fixed incorrect path handling in gather-egg-information (setup-download.scm)
+------------------------------------------------------------------------
+r13941 | felix | 2009-03-26 10:55:59 +0100 (Thu, 26 Mar 2009) | 1 line
+
+added tools.scm to dist
+------------------------------------------------------------------------
+r13940 | felix | 2009-03-26 10:54:38 +0100 (Thu, 26 Mar 2009) | 1 line
+
+added some scripts to the dist tarball
+------------------------------------------------------------------------
+r13921 | felix | 2009-03-25 11:16:09 +0100 (Wed, 25 Mar 2009) | 1 line
+
+chicken-bug attempts several tries to connect; reordered compiler switch settings in Makefile.macosx
+------------------------------------------------------------------------
+r13910 | kon | 2009-03-24 23:58:57 +0100 (Tue, 24 Mar 2009) | 2 lines
+
+NetBSD doesn't have srandomdev, in any version it seems..
+
+------------------------------------------------------------------------
+r13906 | felix | 2009-03-24 22:44:44 +0100 (Tue, 24 Mar 2009) | 1 line
+
+lolevel test assumes 4-byte wordsize
+------------------------------------------------------------------------
+r13888 | felix | 2009-03-24 13:57:12 +0100 (Tue, 24 Mar 2009) | 1 line
+
+fixed bug in compiler-specific syntax-error reporting
+------------------------------------------------------------------------
+r13875 | felix | 2009-03-23 12:07:43 +0100 (Mon, 23 Mar 2009) | 1 line
+
+ack, announce
+------------------------------------------------------------------------
+r13874 | felix | 2009-03-23 11:50:54 +0100 (Mon, 23 Mar 2009) | 1 line
+
+windows-related fix in chicken-bug
+------------------------------------------------------------------------
+r13873 | felix | 2009-03-23 11:23:08 +0100 (Mon, 23 Mar 2009) | 1 line
+
+updated ANNOUNCE
+------------------------------------------------------------------------
+r13872 | felix | 2009-03-23 11:13:17 +0100 (Mon, 23 Mar 2009) | 1 line
+
+set version to 4.0.1x1; some trivial other fixes
+------------------------------------------------------------------------
+r13871 | felix | 2009-03-23 11:12:46 +0100 (Mon, 23 Mar 2009) | 1 line
+
+added faq entry for block vs. local
+------------------------------------------------------------------------
+r13870 | felix | 2009-03-23 11:12:20 +0100 (Mon, 23 Mar 2009) | 1 line
+
+added nursery stress test to test-suite
+------------------------------------------------------------------------
+r13858 | felix | 2009-03-22 01:00:31 +0100 (Sun, 22 Mar 2009) | 1 line
+
+paren-synonyms should always be terminating
+------------------------------------------------------------------------
+r13857 | felix | 2009-03-22 00:51:49 +0100 (Sun, 22 Mar 2009) | 1 line
+
+minor fixes
+------------------------------------------------------------------------
+r13856 | felix | 2009-03-22 00:51:14 +0100 (Sun, 22 Mar 2009) | 1 line
+
+fixed incomplete handling of lambda expressions in operator position (reported by Jim Ursetto)
+------------------------------------------------------------------------
+r13854 | kon | 2009-03-21 04:25:28 +0100 (Sat, 21 Mar 2009) | 2 lines
+
+srfi-18 prev is srfi-14
+
+------------------------------------------------------------------------
+r13851 | felix | 2009-03-20 21:47:37 +0100 (Fri, 20 Mar 2009) | 1 line
+
+documented SREs, some script and manaul fixes
+------------------------------------------------------------------------
+r13847 | felix | 2009-03-20 12:06:49 +0100 (Fri, 20 Mar 2009) | 1 line
+
+delay is a macro
+------------------------------------------------------------------------
+r13836 | kon | 2009-03-19 04:37:04 +0100 (Thu, 19 Mar 2009) | 2 lines
+
+Added delay.
+
+------------------------------------------------------------------------
+r13831 | kon | 2009-03-18 18:47:28 +0100 (Wed, 18 Mar 2009) | 2 lines
+
+Use of random for *nix systems, use of srandomev for gnu systems. Rmvd data-structures stuff from Unit extras manual, modified `random' description to indicate integer values & not exact integer.
+
+------------------------------------------------------------------------
+r13820 | felix | 2009-03-18 16:13:13 +0100 (Wed, 18 Mar 2009) | 1 line
+
+removed use of soname as it breaks explicit dynamic loading of core libraries; test-dist fixes
+------------------------------------------------------------------------
+r13819 | kon | 2009-03-18 15:13:35 +0100 (Wed, 18 Mar 2009) | 2 lines
+
+Applied Will Farr's rand patch.
+
+------------------------------------------------------------------------
+r13818 | felix | 2009-03-18 14:51:44 +0100 (Wed, 18 Mar 2009) | 1 line
+
+use right chicken when building test dist
+------------------------------------------------------------------------
+r13817 | felix | 2009-03-18 14:38:44 +0100 (Wed, 18 Mar 2009) | 1 line
+
+unix lineendings
+------------------------------------------------------------------------
+r13816 | felix | 2009-03-18 14:37:24 +0100 (Wed, 18 Mar 2009) | 1 line
+
+script fixes
+------------------------------------------------------------------------
+r13815 | felix | 2009-03-18 14:31:49 +0100 (Wed, 18 Mar 2009) | 1 line
+
+converted scripts to unix format
+------------------------------------------------------------------------
+r13814 | felix | 2009-03-18 14:26:13 +0100 (Wed, 18 Mar 2009) | 1 line
+
+optional bootstrapping for test-dist
+------------------------------------------------------------------------
+r13813 | felix | 2009-03-18 14:21:52 +0100 (Wed, 18 Mar 2009) | 1 line
+
+added test scripts
+------------------------------------------------------------------------
+r13810 | felix | 2009-03-18 10:21:57 +0100 (Wed, 18 Mar 2009) | 1 line
+
+make-egg-index usable now
+------------------------------------------------------------------------
+r13806 | kon | 2009-03-18 04:28:20 +0100 (Wed, 18 Mar 2009) | 2 lines
+
+Fix for mismatched arg ids.
+
+------------------------------------------------------------------------
+r13800 | felix | 2009-03-17 17:26:52 +0100 (Tue, 17 Mar 2009) | 1 line
+
+small cleanups; tested make-egg-index script
+------------------------------------------------------------------------
+r13783 | felix | 2009-03-16 20:52:28 +0100 (Mon, 16 Mar 2009) | 1 line
+
+added initial attempt at script to generate egg-index page
+------------------------------------------------------------------------
+r13780 | kon | 2009-03-16 03:32:12 +0100 (Mon, 16 Mar 2009) | 2 lines
+
+Fix for intemperate use of ##sys#hash-table. Reported by Jim Ursetto.
+
+------------------------------------------------------------------------
+r13768 | kon | 2009-03-15 20:09:27 +0100 (Sun, 15 Mar 2009) | 2 lines
+
+Update of rtd prop. Added %add1 & %sub1.
+
+------------------------------------------------------------------------
+r13756 | kon | 2009-03-14 18:31:20 +0100 (Sat, 14 Mar 2009) | 2 lines
+
+Better impl of BITWISE_UINT_ONLY. Undefined BITWISE_UINT_ONLY since the manual says integers are accepted.
+
+------------------------------------------------------------------------
+r13743 | kon | 2009-03-14 04:49:03 +0100 (Sat, 14 Mar 2009) | 2 lines
+
+Fixed use of non-% routines. Made proc arg names > 1 char.
+
+------------------------------------------------------------------------
+r13742 | kon | 2009-03-14 03:49:13 +0100 (Sat, 14 Mar 2009) | 2 lines
+
+Rmvd apropos stuff.
+
+------------------------------------------------------------------------
+r13741 | kon | 2009-03-14 03:29:48 +0100 (Sat, 14 Mar 2009) | 2 lines
+
+Fixed port-fold proc name
+
+------------------------------------------------------------------------
+r13740 | kon | 2009-03-14 03:17:07 +0100 (Sat, 14 Mar 2009) | 2 lines
+
+Ordered by srfi #. Added srfi-69.
+
+------------------------------------------------------------------------
+r13737 | kon | 2009-03-13 17:47:14 +0100 (Fri, 13 Mar 2009) | 2 lines
+
+Rmvd noin-existent ident. Updated for `apropos` status.
+
+------------------------------------------------------------------------
+r13736 | felix | 2009-03-13 14:37:50 +0100 (Fri, 13 Mar 2009) | 1 line
+
+no info, texi or pdf
+------------------------------------------------------------------------
+r13735 | felix | 2009-03-13 14:34:36 +0100 (Fri, 13 Mar 2009) | 1 line
+
+makedist.scm fixes; removed texinfo for the time being
+------------------------------------------------------------------------
+r13727 | kon | 2009-03-13 05:31:10 +0100 (Fri, 13 Mar 2009) | 2 lines
+
+Added strcmp.
+
+------------------------------------------------------------------------
+r13723 | kon | 2009-03-12 23:02:19 +0100 (Thu, 12 Mar 2009) | 2 lines
+
+Fixes for ##sys#syntactic-environment routines.
+
+------------------------------------------------------------------------
+r13714 | kon | 2009-03-12 19:09:18 +0100 (Thu, 12 Mar 2009) | 2 lines
+
+Rmvd dup. Added opers.
+
+------------------------------------------------------------------------
+r13713 | kon | 2009-03-12 15:20:51 +0100 (Thu, 12 Mar 2009) | 2 lines
+
+Removed my stupid -chicken-syntax option.
+
+------------------------------------------------------------------------
+r13712 | felix | 2009-03-12 13:57:34 +0100 (Thu, 12 Mar 2009) | 1 line
+
+I said: gone
+------------------------------------------------------------------------
+r13711 | felix | 2009-03-12 13:57:02 +0100 (Thu, 12 Mar 2009) | 1 line
+
+macro? and undefine-macro! are gone
+------------------------------------------------------------------------
+r13710 | felix | 2009-03-12 13:11:25 +0100 (Thu, 12 Mar 2009) | 1 line
+
+more cleaning up in manual
+------------------------------------------------------------------------
+r13709 | felix | 2009-03-12 12:54:05 +0100 (Thu, 12 Mar 2009) | 1 line
+
+manual cleanups; added record proposal by Kon; wiki2html ugly but working
+------------------------------------------------------------------------
+r13705 | kon | 2009-03-12 11:19:05 +0100 (Thu, 12 Mar 2009) | 2 lines
+
+Fixed wrong # of args.
+
+------------------------------------------------------------------------
+r13704 | kon | 2009-03-12 10:46:26 +0100 (Thu, 12 Mar 2009) | 2 lines
+
+Fix for mismatched arg ids.
+
+------------------------------------------------------------------------
+r13702 | kon | 2009-03-12 10:39:14 +0100 (Thu, 12 Mar 2009) | 2 lines
+
+Added 'macro?' from expand.scm & 'define-reader-ctor' from eval.scm
+
+------------------------------------------------------------------------
+r13695 | kon | 2009-03-12 10:03:24 +0100 (Thu, 12 Mar 2009) | 2 lines
+
+Rmvd dups. Fixed '%bytevector=?' parens.
+
+------------------------------------------------------------------------
+r13694 | kon | 2009-03-12 07:46:49 +0100 (Thu, 12 Mar 2009) | 2 lines
+
+Added 'symbol-escape' support. Renamed 'parenthesis-synonyms' -> 'parentheses-synonyms'. Changed command-line option for 'parentheses-synonyms' to 'no-parentheses-synonyms' since binary only. Added minor comments to 'regex', used common identifier name for regular-expression argument. Re-flowed command usage so under 80 columns. Updated manual with new features.
+
+------------------------------------------------------------------------
+r13686 | felix | 2009-03-11 17:21:38 +0100 (Wed, 11 Mar 2009) | 1 line
+
+manual cleanups
+------------------------------------------------------------------------
+r13685 | kon | 2009-03-11 16:09:38 +0100 (Wed, 11 Mar 2009) | 2 lines
+
+Removed identifier wrongly added - 'environment?' is in the sys namespace.
+
+------------------------------------------------------------------------
+r13683 | felix | 2009-03-11 15:15:21 +0100 (Wed, 11 Mar 2009) | 1 line
+
+slight manual fixes; wiki2html improvements
+------------------------------------------------------------------------
+r13677 | kon | 2009-03-11 03:23:24 +0100 (Wed, 11 Mar 2009) | 2 lines
+
+Moved 'apropos' out. Added routines to encapsulate information the new apropos extension needs
+
+------------------------------------------------------------------------
+r13672 | kon | 2009-03-10 20:13:50 +0100 (Tue, 10 Mar 2009) | 2 lines
+
+Added 'parenthesis-synonyms' concept. Updated the unsafe inlines w/ more routines & better names.
+
+------------------------------------------------------------------------
+r13670 | felix | 2009-03-10 16:18:42 +0100 (Tue, 10 Mar 2009) | 1 line
+
+not a fix at all
+------------------------------------------------------------------------
+r13669 | felix | 2009-03-10 16:16:35 +0100 (Tue, 10 Mar 2009) | 1 line
+
+manual fixes
+------------------------------------------------------------------------
+r13661 | felix | 2009-03-10 10:46:34 +0100 (Tue, 10 Mar 2009) | 1 line
+
+wiki2html work; fixed table in manual
+------------------------------------------------------------------------
+r13659 | felix | 2009-03-10 10:11:14 +0100 (Tue, 10 Mar 2009) | 1 line
+
+small manual fixes; merged wiki changes (rev. 13647) into manual
+------------------------------------------------------------------------
+r13632 | kon | 2009-03-10 00:03:52 +0100 (Tue, 10 Mar 2009) | 2 lines
+
+Renamed 'dir' -> 'nam' in 'extension-name-and-version'.
+
+------------------------------------------------------------------------
+r13620 | kon | 2009-03-09 19:48:44 +0100 (Mon, 09 Mar 2009) | 2 lines
+
+Fixed up some code formatting.
+
+------------------------------------------------------------------------
+r13612 | felix | 2009-03-09 08:22:32 +0100 (Mon, 09 Mar 2009) | 1 line
+
+include files are not installed anymore
+------------------------------------------------------------------------
+r13611 | zbigniew | 2009-03-09 07:30:57 +0100 (Mon, 09 Mar 2009) | 1 line
+
+move-memory! broken in r13148, fixed
+------------------------------------------------------------------------
+r13583 | felix | 2009-03-08 02:13:04 +0100 (Sun, 08 Mar 2009) | 1 line
+
+two more newlines
+------------------------------------------------------------------------
+r13582 | felix | 2009-03-08 02:07:09 +0100 (Sun, 08 Mar 2009) | 1 line
+
+fix for syntax-rules bug reported by Jim Ursetto
+------------------------------------------------------------------------
+r13581 | felix | 2009-03-08 02:06:02 +0100 (Sun, 08 Mar 2009) | 1 line
+
+miscellaneous trivialities
+------------------------------------------------------------------------
+r13580 | felix | 2009-03-08 02:04:40 +0100 (Sun, 08 Mar 2009) | 1 line
+
+updated manual with some changes from the wiki
+------------------------------------------------------------------------
+r13577 | kon | 2009-03-07 23:28:47 +0100 (Sat, 07 Mar 2009) | 2 lines
+
+Added new number limits.
+
+------------------------------------------------------------------------
+r13562 | kon | 2009-03-07 17:08:16 +0100 (Sat, 07 Mar 2009) | 2 lines
+
+Added fixnum & flonum limit constants.
+
+------------------------------------------------------------------------
+r13550 | kon | 2009-03-07 06:39:03 +0100 (Sat, 07 Mar 2009) | 2 lines
+
+'extension-name-and-version' has validation. 'extension-version' ensures default version result is a string.
+
+------------------------------------------------------------------------
+r13548 | kon | 2009-03-07 02:25:03 +0100 (Sat, 07 Mar 2009) | 2 lines
+
+Added version capture & export. Since the http server doesn't report the actual version for no-specific-version this feature is currently broken for 'chicken-install ... foo'. However 'chicken-install ... foo:#.#' will report version "#.#".
+
+------------------------------------------------------------------------
+r13544 | kon | 2009-03-07 01:10:57 +0100 (Sat, 07 Mar 2009) | 2 lines
+
+Rmvd unused 'C_hashptr' & 'C_mem_compare'. Rmvd hash related 'hides'.
+
+------------------------------------------------------------------------
+r13543 | kon | 2009-03-07 01:10:01 +0100 (Sat, 07 Mar 2009) | 2 lines
+
+Rmvd unused 'C_mem_compare' def. Use of '(eof-object? x)' instead of '(eq? x #!eof)'.
+
+------------------------------------------------------------------------
+r13542 | kon | 2009-03-07 01:08:55 +0100 (Sat, 07 Mar 2009) | 2 lines
+
+Folded hanging right paran.
+
+------------------------------------------------------------------------
+r13538 | felix | 2009-03-06 16:03:05 +0100 (Fri, 06 Mar 2009) | 1 line
+
+minor fixes
+------------------------------------------------------------------------
+r13534 | kon | 2009-03-06 07:49:18 +0100 (Fri, 06 Mar 2009) | 2 lines
+
+Wrong arg order for map/etc.
+
+------------------------------------------------------------------------
+r13532 | kon | 2009-03-06 07:16:55 +0100 (Fri, 06 Mar 2009) | 2 lines
+
+Chgd block-word to wordblock & block-byte to byteblock. Fix for set-cdr names.
+
+------------------------------------------------------------------------
+r13525 | kon | 2009-03-06 06:23:51 +0100 (Fri, 06 Mar 2009) | 2 lines
+
+Addded maybe-immediate set! routines. Added better assert comments.
+
+------------------------------------------------------------------------
+r13504 | kon | 2009-03-05 08:23:17 +0100 (Thu, 05 Mar 2009) | 2 lines
+
+Renaming to new canonical style.
+
+------------------------------------------------------------------------
+r13488 | kon | 2009-03-04 06:09:45 +0100 (Wed, 04 Mar 2009) | 2 lines
+
+Added '%append!' & thread state test procs.
+
+------------------------------------------------------------------------
+r13466 | kon | 2009-03-03 18:57:13 +0100 (Tue, 03 Mar 2009) | 2 lines
+
+Fix for core prim calls.
+
+------------------------------------------------------------------------
+r13452 | felix | 2009-03-02 12:40:15 +0100 (Mon, 02 Mar 2009) | 1 line
+
+some cleanup, manual fixes, NEWS and README update
+------------------------------------------------------------------------
+r13451 | felix | 2009-03-02 12:39:29 +0100 (Mon, 02 Mar 2009) | 1 line
+
+srfi-69 error check added (thanks to Drew Hess)
+------------------------------------------------------------------------
+r13389 | felix | 2009-02-23 00:23:48 +0100 (Mon, 23 Feb 2009) | 1 line
+
+added testcase
+------------------------------------------------------------------------
+r13368 | zbigniew | 2009-02-20 03:12:21 +0100 (Fri, 20 Feb 2009) | 1 line
+
+posixunix: unsetenv didn't work on OS X
+------------------------------------------------------------------------
+r13351 | felix | 2009-02-19 09:12:27 +0100 (Thu, 19 Feb 2009) | 1 line
+
+aliases remembers original name (otherwise stripping will not recover orig. name)
+------------------------------------------------------------------------
+r13339 | felix | 2009-02-18 19:03:51 +0100 (Wed, 18 Feb 2009) | 1 line
+
+reverted fix for separately marked finalizer procedures reported by Alejandro to re-enable finalization in the interpreter
+------------------------------------------------------------------------
+r13337 | felix | 2009-02-18 13:15:54 +0100 (Wed, 18 Feb 2009) | 1 line
+
+mingw/msys fix for test suite
+------------------------------------------------------------------------
+r13328 | felix | 2009-02-17 14:16:13 +0100 (Tue, 17 Feb 2009) | 1 line
+
+fixed broken fix for non-ascii character case conversion
+------------------------------------------------------------------------
+r13304 | felix | 2009-02-14 17:06:49 +0100 (Sat, 14 Feb 2009) | 1 line
+
+patch by Jim Ursetto for faster read-string from string-port
+------------------------------------------------------------------------
+r13300 | felix | 2009-02-14 15:58:47 +0100 (Sat, 14 Feb 2009) | 1 line
+
+applied read-lime-limit patch by Jim Ursetto
+------------------------------------------------------------------------
+r13250 | felix | 2009-02-11 18:14:08 +0100 (Wed, 11 Feb 2009) | 1 line
+
+scripts/setversion works in binary mode (for windoof)
+------------------------------------------------------------------------
+r13246 | felix | 2009-02-11 09:40:27 +0100 (Wed, 11 Feb 2009) | 1 line
+
+use --enable-auto-import on mingw
+------------------------------------------------------------------------
+r13239 | felix | 2009-02-10 16:39:48 +0100 (Tue, 10 Feb 2009) | 1 line
+
+mingw/msys build fix
+------------------------------------------------------------------------
+r13191 | felix | 2009-02-06 15:31:29 +0100 (Fri, 06 Feb 2009) | 1 line
+
+mingw/msys build fixes
+------------------------------------------------------------------------
+r13188 | kon | 2009-02-06 00:42:05 +0100 (Fri, 06 Feb 2009) | 2 lines
+
+Hope this works for everyone.
+
+------------------------------------------------------------------------
+r13179 | kon | 2009-02-04 20:31:13 +0100 (Wed, 04 Feb 2009) | 2 lines
+
+Reverted defaults & had wrong svnrevision
+
+------------------------------------------------------------------------
+r13177 | kon | 2009-02-04 01:35:11 +0100 (Wed, 04 Feb 2009) | 3 lines
+
+runtime.c : use of C defines for platform info, reflowed some comments & code since > 100 chars long.
+chicken.h : use of C defines for platform info
+
+------------------------------------------------------------------------
+r13175 | kon | 2009-02-03 22:50:30 +0100 (Tue, 03 Feb 2009) | 2 lines
+
+Separation of testing for new svnrev & testing for new buildsvnrev
+
+------------------------------------------------------------------------
+r13174 | kon | 2009-02-03 19:17:24 +0100 (Tue, 03 Feb 2009) | 2 lines
+
+Ok, buildsvnrevision is .PHONY too.
+
+------------------------------------------------------------------------
+r13173 | kon | 2009-02-03 18:57:17 +0100 (Tue, 03 Feb 2009) | 2 lines
+
+Rplcd buildsvnrevision as dep of target all.
+
+------------------------------------------------------------------------
+r13169 | zbigniew | 2009-02-03 06:44:33 +0100 (Tue, 03 Feb 2009) | 1 line
+
+Expose string->sre in Chicken 4 irregex
+------------------------------------------------------------------------
+r13168 | kon | 2009-02-03 05:32:38 +0100 (Tue, 03 Feb 2009) | 2 lines
+
+Forgot to svn add this one.
+
+------------------------------------------------------------------------
+r13167 | kon | 2009-02-03 05:28:28 +0100 (Tue, 03 Feb 2009) | 5 lines
+
+posixunix.scm, osixwin.scm : added Unit ports use
+lolevel.scm : comment fix
+runtime.c : cl -> closure (like other procs), use of macros rather than open-coded block access
+chicken-thread-object-inlines.scm : minor fix
+
+------------------------------------------------------------------------
+r13152 | kon | 2009-02-02 18:37:33 +0100 (Mon, 02 Feb 2009) | 2 lines
+
+Supposed to be 'primitive-object', not just 'primitive', since mostly access operations, few computations.
+
+------------------------------------------------------------------------
+r13151 | ashinn | 2009-02-02 10:08:25 +0100 (Mon, 02 Feb 2009) | 4 lines
+
+Adding posix-string to sre-length-ranges. Still need to add checks
+for this in more places to support compiling embedded posix-strings to
+DFAs.
+
+------------------------------------------------------------------------
+r13150 | kon | 2009-02-02 09:27:26 +0100 (Mon, 02 Feb 2009) | 5 lines
+
+library.scm, c-platform.scm : C_pointerp -> C_anypointerp
+lolevel.import.scm : added new procs
+hash-table-tests.scm : added use of srfi-69 (worked because csi uses srfi-69)
+runtests.sh : add lolevel test, no reading of .csirc
+
+------------------------------------------------------------------------
+r13148 | kon | 2009-02-02 08:17:31 +0100 (Mon, 02 Feb 2009) | 8 lines
+
+distribution/manifest : added lolevel test
+tests/lolevel-tests.scm : new lolevel test (incomplete)
+runtime.c : MacOS X is-a BSD
+lolevel.scm : better arg checks, grouping, added record-instance procs.
+chicken.h : grouped like, comments, swig-pointer is now special
+manual/Unit lolevel : discussion of pointer-like & vector-like
+chicken-primitive-inlines.scm : wrond identifier for unbound value predicate
+
+------------------------------------------------------------------------
+r13146 | kon | 2009-02-02 05:36:56 +0100 (Mon, 02 Feb 2009) | 3 lines
+
+Added core inlines include files.
+Stopped 'buildsvnrevision' target from always forcing a build. Hope I didn't introduce a different bug.
+
+------------------------------------------------------------------------
+r13141 | felix | 2009-02-01 00:02:07 +0100 (Sun, 01 Feb 2009) | 1 line
+
+attempt to fix msvc build (incomplete)§
+------------------------------------------------------------------------
+r13140 | kon | 2009-01-31 23:53:34 +0100 (Sat, 31 Jan 2009) | 2 lines
+
+Renamed not proper list error per ##sys#error- for all error type procs, deprecated '##sys#not-a-proper-list-error'.
+
+------------------------------------------------------------------------
+r13138 | kon | 2009-01-31 10:19:20 +0100 (Sat, 31 Jan 2009) | 2 lines
+
+Chgd "can not" to "cannot" - saves bytes you know ;-)
+
+------------------------------------------------------------------------
+r13137 | ashinn | 2009-01-31 03:32:35 +0100 (Sat, 31 Jan 2009) | 3 lines
+
+Fixing silly bug that didn't allow mixing the : abbreviation for seq
+with submatches in DFA regular expressions.
+
+------------------------------------------------------------------------
+r13135 | kon | 2009-01-30 13:21:18 +0100 (Fri, 30 Jan 2009) | 10 lines
+
+trunk/posixwin.scm : unimplimented is syntax
+trunk/runtime.c : nl btwn computation & return is distracting
+lolevel.scm : added type check helpers
+library.scm : moved '##sys#abandon-mutexes' to schedular
+posixunix.scm : rmvd some unused decls
+schedular.scm : added '##sys#abandon-mutexes' since only used here
+tests/runtests.sh : added no init
+runtime.c : added "true unix" fudge, rmvd host PCRE fudge
+srfi-18 : added OO-procedures - the algorithms read much easier now
+
+------------------------------------------------------------------------
+r13131 | felix | 2009-01-28 15:17:08 +0100 (Wed, 28 Jan 2009) | 1 line
+
+applied regex fix by Ivan; mingw build fixes
+------------------------------------------------------------------------
+r13127 | kon | 2009-01-27 22:40:54 +0100 (Tue, 27 Jan 2009) | 2 lines
+
+Chgd runtime::barf msgs to match library::##sys#error-hook msgs. Chgd proc define '(define x (lambda ...' style to '(define (x ...' style. Chgd err msgs to common style. Added 'exn subtyp ('arity, etc.) for untyped error-hooks. Chgd '##sys#check-' to common style.
+
+------------------------------------------------------------------------
+r13125 | kon | 2009-01-27 20:30:54 +0100 (Tue, 27 Jan 2009) | 2 lines
+
+Chgd to use existing errmsg (##sys#error-hook). Use of define-inline for common fx & fp code. Common cond-expand style for fx & fp.
+
+------------------------------------------------------------------------
+r13124 | kon | 2009-01-27 19:21:08 +0100 (Tue, 27 Jan 2009) | 2 lines
+
+Make proper-list arg err same form as other bad arg typ. Chgd bytevector to blob in errmsg.
+
+------------------------------------------------------------------------
+r13093 | kon | 2009-01-26 00:54:39 +0100 (Mon, 26 Jan 2009) | 2 lines
+
+Alignment.
+
+------------------------------------------------------------------------
+r13081 | felix | 2009-01-25 14:56:47 +0100 (Sun, 25 Jan 2009) | 1 line
+
+fixed silly bug in char-downcase; disabled meta-syntax-test (needs to be compiled properly)
+------------------------------------------------------------------------
+r13074 | felix | 2009-01-24 16:11:27 +0100 (Sat, 24 Jan 2009) | 1 line
+
+applied regex patches fixing indices from chicken-3 branch by Ivan to trunk (not tested yet)
+------------------------------------------------------------------------
+r13062 | felix | 2009-01-22 09:06:19 +0100 (Thu, 22 Jan 2009) | 1 line
+
+more char-code safety measures
+------------------------------------------------------------------------
+r13041 | felix | 2009-01-20 22:44:55 +0100 (Tue, 20 Jan 2009) | 1 line
+
+default inlined character-cae operations use lowest 8 bit only (caused bug reported by Peter Bex)
+------------------------------------------------------------------------
+r13023 | kon | 2009-01-17 02:56:16 +0100 (Sat, 17 Jan 2009) | 2 lines
+
+Rmvd dup 'ports' ref.
+
+------------------------------------------------------------------------
+r13018 | kon | 2009-01-16 04:47:04 +0100 (Fri, 16 Jan 2009) | 2 lines
+
+Added return value testing for FreeLibrary & shl_unlaod.
+
+------------------------------------------------------------------------
+r13017 | kon | 2009-01-16 00:46:30 +0100 (Fri, 16 Jan 2009) | 2 lines
+
+Added warning classes.
+
+------------------------------------------------------------------------
+r13015 | kon | 2009-01-16 00:25:08 +0100 (Fri, 16 Jan 2009) | 2 lines
+
+Added runtime commandline options. Minor fixes to options w/ arguments.
+
+------------------------------------------------------------------------
+r13008 | felix | 2009-01-14 19:48:11 +0100 (Wed, 14 Jan 2009) | 1 line
+
+import-libs where installed with wrong permissions
+------------------------------------------------------------------------
+r13007 | felix | 2009-01-14 12:48:23 +0100 (Wed, 14 Jan 2009) | 1 line
+
+trivial fix in defaults.make
+------------------------------------------------------------------------
+r13006 | felix | 2009-01-13 16:42:31 +0100 (Tue, 13 Jan 2009) | 1 line
+
+cygwin build fixes
+------------------------------------------------------------------------
+r12964 | felix | 2009-01-08 14:36:54 +0100 (Thu, 08 Jan 2009) | 1 line
+
+updated TODO list
+------------------------------------------------------------------------
+r12963 | felix | 2009-01-08 14:35:04 +0100 (Thu, 08 Jan 2009) | 1 line
+
+alternative definition for define-for-syntax (untested)
+------------------------------------------------------------------------
+r12961 | felix | 2009-01-08 12:17:36 +0100 (Thu, 08 Jan 2009) | 1 line
+
+build fixes, meta-syntax testing
+------------------------------------------------------------------------
+r12957 | felix | 2009-01-07 23:54:59 +0100 (Wed, 07 Jan 2009) | 1 line
+
+added note to README
+------------------------------------------------------------------------
+r12956 | felix | 2009-01-07 23:51:40 +0100 (Wed, 07 Jan 2009) | 1 line
+
+possibly fixed mingw quoting hell - a bow before Matthew Flatt, who is a master hacker
+------------------------------------------------------------------------
+r12952 | felix | 2009-01-07 15:44:49 +0100 (Wed, 07 Jan 2009) | 1 line
+
+removed redundant module check
+------------------------------------------------------------------------
+r12950 | felix | 2009-01-07 15:06:14 +0100 (Wed, 07 Jan 2009) | 1 line
+
+yes, it should
+------------------------------------------------------------------------
+r12949 | felix | 2009-01-07 14:48:20 +0100 (Wed, 07 Jan 2009) | 1 line
+
+number->string fix for bug reported by Kevin Beranek
+------------------------------------------------------------------------
+r12948 | felix | 2009-01-07 10:59:13 +0100 (Wed, 07 Jan 2009) | 1 line
+
+special length procedure in compiler to compute llist lengths (reported by Peter Bex); updated bootstrap tarball
+------------------------------------------------------------------------
+r12940 | felix | 2009-01-06 11:39:46 +0100 (Tue, 06 Jan 2009) | 1 line
+
+length checks argument for being cyclic (suggested by Taylor Campbell)
+------------------------------------------------------------------------
+r12939 | felix | 2009-01-06 09:47:34 +0100 (Tue, 06 Jan 2009) | 1 line
+
+added finalizable GC roots, as suggested by Alejandro
+------------------------------------------------------------------------
+r12938 | felix | 2009-01-05 13:50:06 +0100 (Mon, 05 Jan 2009) | 1 line
+
+added egg-list operation to henrietta
+------------------------------------------------------------------------
+r12937 | felix | 2009-01-05 10:15:21 +0100 (Mon, 05 Jan 2009) | 1 line
+
+updateed copyright
+------------------------------------------------------------------------
+r12936 | felix | 2009-01-04 16:52:56 +0100 (Sun, 04 Jan 2009) | 1 line
+
+updated copyright
+------------------------------------------------------------------------
+r12935 | felix | 2009-01-04 16:52:30 +0100 (Sun, 04 Jan 2009) | 1 line
+
+why did this work before?
+------------------------------------------------------------------------
+r12934 | felix | 2009-01-04 16:10:44 +0100 (Sun, 04 Jan 2009) | 1 line
+
+can not stand it any longer
+------------------------------------------------------------------------
+r12933 | felix | 2009-01-03 02:59:36 +0100 (Sat, 03 Jan 2009) | 1 line
+
+forgot to save; mingw chicken-install fails mysteriously
+------------------------------------------------------------------------
+r12932 | felix | 2009-01-03 02:53:14 +0100 (Sat, 03 Jan 2009) | 1 line
+
+attempts at fixing mingw build; probably everything broken now
+------------------------------------------------------------------------
+r12929 | felix | 2008-12-31 13:19:46 +0100 (Wed, 31 Dec 2008) | 1 line
+
+removed some obsolete exports from regex import lib and manual
+------------------------------------------------------------------------
+r12922 | felix | 2008-12-30 15:08:31 +0100 (Tue, 30 Dec 2008) | 1 line
+
+added irregex import lib to those installed by chicken-install -init
+------------------------------------------------------------------------
+r12920 | felix | 2008-12-30 14:53:41 +0100 (Tue, 30 Dec 2008) | 1 line
+
+irregex merge; -ignore-repository disables dloading; extension-version fix for chicken-install (reported by Peter Bex); compiler export/blockmode fix; updated bootstrapping tarball
+------------------------------------------------------------------------
+r12896 | felix | 2008-12-28 01:30:31 +0100 (Sun, 28 Dec 2008) | 1 line
+
+changed semantics of -static-extension option; added it to core compiler
+------------------------------------------------------------------------
+r12869 | felix | 2008-12-22 10:02:39 +0100 (Mon, 22 Dec 2008) | 1 line
+
+finalizer bug not fixed, perhaps now
+------------------------------------------------------------------------
+r12867 | felix | 2008-12-22 09:20:34 +0100 (Mon, 22 Dec 2008) | 1 line
+
+csi toplevel commands resolve identifier names
+------------------------------------------------------------------------
+r12852 | felix | 2008-12-19 12:30:06 +0100 (Fri, 19 Dec 2008) | 1 line
+
+applied patch by Peter Bex: relinking applies to import-libs, too
+------------------------------------------------------------------------
+r12848 | kon | 2008-12-18 19:18:00 +0100 (Thu, 18 Dec 2008) | 2 lines
+
+Error during update of the module db is not fatal.
+
+------------------------------------------------------------------------
+r12844 | felix | 2008-12-18 08:42:00 +0100 (Thu, 18 Dec 2008) | 1 line
+
+actually removed the options
+------------------------------------------------------------------------
+r12840 | felix | 2008-12-17 13:13:02 +0100 (Wed, 17 Dec 2008) | 1 line
+
+removed nonsensical option
+------------------------------------------------------------------------
+r12838 | felix | 2008-12-17 09:43:11 +0100 (Wed, 17 Dec 2008) | 1 line
+
+removed bogus compiler-check from foreign and compiler import libs; possible fix for finalizer bug; documented -repository option for setup tools in manual
+------------------------------------------------------------------------
+r12830 | felix | 2008-12-16 10:33:34 +0100 (Tue, 16 Dec 2008) | 1 line
+
+added test for finalization demonstrating finalizer bug reported by Alejo
+------------------------------------------------------------------------
+r12825 | felix | 2008-12-15 15:27:27 +0100 (Mon, 15 Dec 2008) | 1 line
+
+hopefully fixed special dependency status of setup import libs (untested)
+------------------------------------------------------------------------
+r12819 | felix | 2008-12-15 08:53:06 +0100 (Mon, 15 Dec 2008) | 1 line
+
+build bugfixes (thanks to Wietse Jacobs); added -repository option to setup tools
+------------------------------------------------------------------------
+r12813 | felix | 2008-12-12 14:14:35 +0100 (Fri, 12 Dec 2008) | 1 line
+
+removed if-test-with-non-false-result optimization; added user-level rewrite rules; some compiler cleanup
+------------------------------------------------------------------------
+r12803 | felix | 2008-12-09 11:10:36 +0100 (Tue, 09 Dec 2008) | 1 line
+
+slightly more useful warning on missing import
+------------------------------------------------------------------------
+r12798 | felix | 2008-12-08 10:18:06 +0100 (Mon, 08 Dec 2008) | 1 line
+
+updated bootstrapping tarball
+------------------------------------------------------------------------
+r12797 | felix | 2008-12-08 10:16:34 +0100 (Mon, 08 Dec 2008) | 1 line
+
+bumped version to 4.0.0x4; doc
+------------------------------------------------------------------------
+r12790 | kon | 2008-12-07 17:42:54 +0100 (Sun, 07 Dec 2008) | 2 lines
+
+Time/string procs documented.
+
+------------------------------------------------------------------------
+r12789 | felix | 2008-12-07 16:29:38 +0100 (Sun, 07 Dec 2008) | 1 line
+
+setup-utils removal was quite incomplete; added -ignore-repository; msvc Makefile fix (thanks to Ivan Shcheklein); lots of mindless hacking
+------------------------------------------------------------------------
+r12788 | kon | 2008-12-07 02:37:26 +0100 (Sun, 07 Dec 2008) | 2 lines
+
+Rmvd setup-utils refs.
+
+------------------------------------------------------------------------
+r12786 | felix | 2008-12-05 15:08:07 +0100 (Fri, 05 Dec 2008) | 1 line
+
+removed setup-utils (merged into setup-api)
+------------------------------------------------------------------------
+r12703 | felix | 2008-12-01 14:29:53 +0100 (Mon, 01 Dec 2008) | 1 line
+
+removed junk files
+------------------------------------------------------------------------
+r12700 | felix | 2008-12-01 11:22:37 +0100 (Mon, 01 Dec 2008) | 1 line
+
+removed remaining support for DJGPP, Metrowerks and Watcom
+------------------------------------------------------------------------
+r12644 | kon | 2008-11-29 04:41:31 +0100 (Sat, 29 Nov 2008) | 2 lines
+
+Make sure tzname, etc. variables are set before use. Doubtful if tzname will be used before a time.h proc is used but to be safe.
+
+------------------------------------------------------------------------
+r12642 | felix | 2008-11-28 23:44:08 +0100 (Fri, 28 Nov 2008) | 1 line
+
+added missing test file
+------------------------------------------------------------------------
+r12637 | felix | 2008-11-28 13:50:59 +0100 (Fri, 28 Nov 2008) | 1 line
+
+forgot to mark internal bindings as intrinsic
+------------------------------------------------------------------------
+r12632 | felix | 2008-11-28 13:08:29 +0100 (Fri, 28 Nov 2008) | 1 line
+
+disabled checks for chicken-syntax.scm
+------------------------------------------------------------------------
+r12631 | felix | 2008-11-28 10:57:21 +0100 (Fri, 28 Nov 2008) | 1 line
+
+disabled checks in expand; fix in build-rules for setup-*.import.scm; folded procedure resolution and global var retrieval runtime functions
+------------------------------------------------------------------------
+r12630 | felix | 2008-11-28 09:29:34 +0100 (Fri, 28 Nov 2008) | 1 line
+
+various trivial fixes
+------------------------------------------------------------------------
+r12625 | ashinn | 2008-11-28 06:53:23 +0100 (Fri, 28 Nov 2008) | 3 lines
+
+Fixing bug in ##sys#custom-input-port which caused char-ready? to
+always return true for any process ports.
+
+------------------------------------------------------------------------
+r12610 | felix | 2008-11-27 10:30:59 +0100 (Thu, 27 Nov 2008) | 1 line
+
+profiling not that right (yet)
+------------------------------------------------------------------------
+r12609 | felix | 2008-11-27 09:23:01 +0100 (Thu, 27 Nov 2008) | 5 lines
+
+- updated NEWS and chicken-install.1
+- added import suggestion to compiler using modules.db
+- renamed db file to "modules.db"
+
+
+------------------------------------------------------------------------
+r12608 | kon | 2008-11-27 03:23:32 +0100 (Thu, 27 Nov 2008) | 2 lines
+
+Bug fix for sudo install mode - inconsitent signature for 'sudo-install' & didn't set the *sudo* flag.
+
+------------------------------------------------------------------------
+r12596 | felix | 2008-11-26 16:31:11 +0100 (Wed, 26 Nov 2008) | 1 line
+
+fixed import form check (handles aliasing); bumped version to 4.0.0x3
+------------------------------------------------------------------------
+r12595 | felix | 2008-11-26 16:05:25 +0100 (Wed, 26 Nov 2008) | 7 lines
+
+- removed custom declarations
+- added "-update-db" option to chicken-install
+- chicken: "-quiet" is useless and DEPRECATED
+- added support for db file in repository (not used yet)
+- compiler warns if first form in module body is not an `import' form
+
+
+------------------------------------------------------------------------
+r12588 | felix | 2008-11-25 13:39:26 +0100 (Tue, 25 Nov 2008) | 1 line
+
+do'h
+------------------------------------------------------------------------
+r12585 | felix | 2008-11-24 13:18:36 +0100 (Mon, 24 Nov 2008) | 1 line
+
+variable holding linker options was named incorrectly (problem reported by Peter Bex)
+------------------------------------------------------------------------
+r12584 | felix | 2008-11-24 12:55:54 +0100 (Mon, 24 Nov 2008) | 1 line
+
+binaries are set to 644 instead of a+rw after relinking (thanks to Drake Wilson)
+------------------------------------------------------------------------
+r12562 | felix | 2008-11-20 09:52:33 +0100 (Thu, 20 Nov 2008) | 1 line
+
+macro defs in import libs are syntax-stripped
+------------------------------------------------------------------------
+r12560 | felix | 2008-11-19 11:20:04 +0100 (Wed, 19 Nov 2008) | 1 line
+
+another file in dist missing
+------------------------------------------------------------------------
+r12559 | felix | 2008-11-19 11:17:36 +0100 (Wed, 19 Nov 2008) | 9 lines
+
+- put non-std macros into own unit (chicken-syntax) which makes
+ chicken-more-macros.scm obsolete;
+- renamed chicken-ffi-macros.scm to chicken-ffi-syntax.scm
+- added missing entries to distribution/manifest
+- ec tests use only required exports now (and work)
+- bumped version to 4.0.0x2
+- various fixes in the manual
+
+
+------------------------------------------------------------------------
+r12546 | felix | 2008-11-17 10:49:22 +0100 (Mon, 17 Nov 2008) | 1 line
+
+import libs only contain syntax, if syntax is exported; fixed bug in ptable-entry string reported by Brown Dragon
+------------------------------------------------------------------------
+r12498 | felix | 2008-11-14 21:34:15 +0100 (Fri, 14 Nov 2008) | 1 line
+
+updated bootstrap tarball
+------------------------------------------------------------------------
+r12495 | felix | 2008-11-14 10:28:38 +0100 (Fri, 14 Nov 2008) | 1 line
+
+reexport of syntax seems to work now
+------------------------------------------------------------------------
+r12481 | felix | 2008-11-12 10:37:52 +0100 (Wed, 12 Nov 2008) | 1 line
+
+some port checks for tcp operations [reported by Peter Bex]
+------------------------------------------------------------------------
+r12476 | felix | 2008-11-11 15:39:03 +0100 (Tue, 11 Nov 2008) | 1 line
+
+handling uninitialized panic_hook while parsing command line
+------------------------------------------------------------------------
+r12436 | felix | 2008-11-10 09:17:27 +0100 (Mon, 10 Nov 2008) | 1 line
+
+non-exported syntax is added to import libs to allow references from exported syntax
+------------------------------------------------------------------------
+r12398 | felix | 2008-11-07 15:11:26 +0100 (Fri, 07 Nov 2008) | 1 line
+
+allocation estimation in preparation phase of the compiler takes maximum allocation for each conditional branch, not sum
+------------------------------------------------------------------------
+r12359 | felix | 2008-11-05 11:28:42 +0100 (Wed, 05 Nov 2008) | 1 line
+
+fixed ellipsis check (srfi-46 extension); chicken-install removes failed http locations from defaults list
+------------------------------------------------------------------------
+r12342 | felix | 2008-11-03 03:56:09 +0100 (Mon, 03 Nov 2008) | 2 lines
+
+removed some dead code
+
+------------------------------------------------------------------------
+r12341 | felix | 2008-11-03 03:43:42 +0100 (Mon, 03 Nov 2008) | 1 line
+
+updated bootstrapping tarball (this one should avoid loading compiled import libs, also should not contain IDIOTIC bug introduced by felix, the silly ass)
+------------------------------------------------------------------------
+r12340 | felix | 2008-11-03 03:36:25 +0100 (Mon, 03 Nov 2008) | 1 line
+
+added docindex-generation script; removed totally idiotic fix from rev 12227 related to alias-global-hook (IDIOT, felix, IDIOT\!)
+------------------------------------------------------------------------
+r12331 | felix | 2008-11-02 00:56:38 +0100 (Sun, 02 Nov 2008) | 1 line
+
+slightly reorganized version info in banner
+------------------------------------------------------------------------
+r12320 | felix | 2008-10-31 08:39:00 +0100 (Fri, 31 Oct 2008) | 1 line
+
+removed reference to array egg [suggested by Kon]; set version to 4.0.0x1
+------------------------------------------------------------------------
+r12318 | kon | 2008-10-31 02:25:48 +0100 (Fri, 31 Oct 2008) | 2 lines
+
+Spelling.
+
+------------------------------------------------------------------------
+r12316 | felix | 2008-10-30 15:43:49 +0100 (Thu, 30 Oct 2008) | 1 line
+
+updated bootstrapping tarball
+------------------------------------------------------------------------
+r12314 | felix | 2008-10-30 12:23:22 +0100 (Thu, 30 Oct 2008) | 1 line
+
+updated TODO
+------------------------------------------------------------------------
+r12308 | felix | 2008-10-29 16:34:08 +0100 (Wed, 29 Oct 2008) | 1 line
+
+-inline-global implies -inline; -inline-global is not required for -emit-inline-file to work
+------------------------------------------------------------------------
+r12306 | felix | 2008-10-29 14:41:03 +0100 (Wed, 29 Oct 2008) | 1 line
+
+updated NEWS
+------------------------------------------------------------------------
+r12305 | felix | 2008-10-29 14:36:32 +0100 (Wed, 29 Oct 2008) | 1 line
+
+chicken-install: 404 starts retry; tested retries; enabled kitten-technologies mirror as download location; chicken-uninstall gives indication if no egg matches
+------------------------------------------------------------------------
+r12301 | felix | 2008-10-29 12:08:07 +0100 (Wed, 29 Oct 2008) | 1 line
+
+merged changes from cmi branch
+------------------------------------------------------------------------
+r12300 | felix | 2008-10-29 10:50:54 +0100 (Wed, 29 Oct 2008) | 1 line
+
+put installation-directory creation into own subrule [due to problem reported by Alaric]
+------------------------------------------------------------------------
+r12262 | kon | 2008-10-25 06:49:10 +0200 (Sat, 25 Oct 2008) | 2 lines
+
+Rmvd lolevel make-hash-table from imports (no existing refs that I found). Internal renames for canonical-ish style (sorry Felix). Rmvd dup unused code.
+
+------------------------------------------------------------------------
+r12247 | felix | 2008-10-22 10:49:53 +0200 (Wed, 22 Oct 2008) | 1 line
+
+added missing documentation; -init option for chicken-install; added missing chicken-home to chicken.import.scm
+------------------------------------------------------------------------
+r12227 | felix | 2008-10-21 20:42:22 +0200 (Tue, 21 Oct 2008) | 6 lines
+
+- added helpful script for testing in build dir
+- chicken-install checks for TCP timeouts and handles multiple default sources
+ to download from
+- alias-global-hook is saved and restored when loading compiler extensions
+- making bootstrap automaticaly makes confclean
+
+------------------------------------------------------------------------
+r12217 | felix | 2008-10-21 00:37:40 +0200 (Tue, 21 Oct 2008) | 1 line
+
+todos update
+------------------------------------------------------------------------
+r12215 | felix | 2008-10-20 23:28:01 +0200 (Mon, 20 Oct 2008) | 1 line
+
+only tries to find/load .so's, when dloading is available
+------------------------------------------------------------------------
+r12201 | felix | 2008-10-19 22:43:58 +0200 (Sun, 19 Oct 2008) | 1 line
+
+fixed another let-location bug detected by Joerg Wittenberger
+------------------------------------------------------------------------
+r12195 | felix | 2008-10-18 18:31:31 +0200 (Sat, 18 Oct 2008) | 1 line
+
+updated TODOs
+------------------------------------------------------------------------
+r12130 | felix | 2008-10-09 09:48:55 +0200 (Thu, 09 Oct 2008) | 1 line
+
+added missing entry in chicken.import.scm for load-verbose; require-extension didn't generate import code for registered feature id [both reported by Peter Bex]
+------------------------------------------------------------------------
+r12122 | felix | 2008-10-08 12:38:00 +0200 (Wed, 08 Oct 2008) | 1 line
+
+silly
+------------------------------------------------------------------------
+r12117 | kon | 2008-10-07 05:04:46 +0200 (Tue, 07 Oct 2008) | 2 lines
+
+PCRE 7.8, use of "full" flonum-hash, new scheme-complete by Alex Shinn.
+
+------------------------------------------------------------------------
+r12115 | felix | 2008-10-07 00:21:45 +0200 (Tue, 07 Oct 2008) | 1 line
+
+removed obsolete files
+------------------------------------------------------------------------
+r12114 | felix | 2008-10-06 22:53:40 +0200 (Mon, 06 Oct 2008) | 1 line
+
+fixed lambda-lifting (actually analyzer) bug reported by Joerg Wittenberger
+------------------------------------------------------------------------
+r12112 | iraikov | 2008-10-06 03:48:51 +0200 (Mon, 06 Oct 2008) | 2 lines
+
+Consolidated news items for 3.4.0 in trunk.
+
+------------------------------------------------------------------------
+r12109 | felix | 2008-10-03 12:32:38 +0200 (Fri, 03 Oct 2008) | 1 line
+
+lambda nodes in inlined procedures get new f-id
+------------------------------------------------------------------------
+r12105 | felix | 2008-10-02 20:23:37 +0200 (Thu, 02 Oct 2008) | 1 line
+
+timeout-list removal fixes (thanks to Joerg Wittenberger)
+------------------------------------------------------------------------
+r12104 | felix | 2008-10-02 20:08:20 +0200 (Thu, 02 Oct 2008) | 1 line
+
+fixed let-location expansion bug reported by Joerg Wittenberger
+------------------------------------------------------------------------
+r12102 | felix | 2008-10-02 16:25:31 +0200 (Thu, 02 Oct 2008) | 1 line
+
+added test-case for declarations in modules
+------------------------------------------------------------------------
+r12101 | felix | 2008-10-02 13:22:49 +0200 (Thu, 02 Oct 2008) | 1 line
+
+declaration processing did not handle expanded names
+------------------------------------------------------------------------
+r12088 | felix | 2008-10-01 16:24:10 +0200 (Wed, 01 Oct 2008) | 1 line
+
+fixes in inl.scm
+------------------------------------------------------------------------
+r12087 | felix | 2008-10-01 13:54:32 +0200 (Wed, 01 Oct 2008) | 1 line
+
+updated bootstrapping tarball
+------------------------------------------------------------------------
+r12086 | felix | 2008-10-01 13:49:25 +0200 (Wed, 01 Oct 2008) | 1 line
+
+removed some deprecated compiler options; removed compiler-macros
+------------------------------------------------------------------------
+r12085 | felix | 2008-10-01 11:59:57 +0200 (Wed, 01 Oct 2008) | 1 line
+
+moved user passes into batch-driver; added post-opt. user pass
+------------------------------------------------------------------------
+r12083 | felix | 2008-10-01 10:37:34 +0200 (Wed, 01 Oct 2008) | 1 line
+
+made hygienic branch new trunk
+------------------------------------------------------------------------
+r12030 | felix | 2008-09-29 08:36:00 +0200 (Mon, 29 Sep 2008) | 1 line
+
+added missing bindings to scheme.import.scm
+------------------------------------------------------------------------
+r12021 | felix | 2008-09-28 15:02:47 +0200 (Sun, 28 Sep 2008) | 1 line
+
+merged trunk rev. 11636-12020. This should be the last merge before hygienic becomes the new trunk
+------------------------------------------------------------------------
+r11989 | felix | 2008-09-24 09:33:35 +0200 (Wed, 24 Sep 2008) | 1 line
+
+added srfi-98 support, chicken-install should handle core library units as dependencies (untested)
+------------------------------------------------------------------------
+r11978 | felix | 2008-09-22 11:44:02 +0200 (Mon, 22 Sep 2008) | 1 line
+
+henrietta fixes
+------------------------------------------------------------------------
+r11974 | felix | 2008-09-20 00:20:50 +0200 (Sat, 20 Sep 2008) | 1 line
+
+removed last use of quotewrap
+------------------------------------------------------------------------
+r11973 | felix | 2008-09-20 00:20:16 +0200 (Sat, 20 Sep 2008) | 1 line
+
+there must be SOME fun in this
+------------------------------------------------------------------------
+r11967 | felix | 2008-09-19 16:43:48 +0200 (Fri, 19 Sep 2008) | 1 line
+
+updated TODO list
+------------------------------------------------------------------------
+r11966 | felix | 2008-09-19 14:26:16 +0200 (Fri, 19 Sep 2008) | 1 line
+
+bugfix in setup-download module
+------------------------------------------------------------------------
+r11961 | felix | 2008-09-18 13:01:47 +0200 (Thu, 18 Sep 2008) | 1 line
+
+henrietta test-case handling stuff - untested
+------------------------------------------------------------------------
+r11948 | felix | 2008-09-15 08:46:03 +0200 (Mon, 15 Sep 2008) | 1 line
+
+eqv?-optimization also for ##sys#eqv?
+------------------------------------------------------------------------
+r11941 | felix | 2008-09-10 08:45:08 +0200 (Wed, 10 Sep 2008) | 1 line
+
+improved installation order for repeated occurrences in dependency chains
+------------------------------------------------------------------------
+r11919 | felix | 2008-09-07 22:41:59 +0200 (Sun, 07 Sep 2008) | 1 line
+
+case macro uses qualified version if eqv?
+------------------------------------------------------------------------
+r11905 | felix | 2008-09-05 16:49:38 +0200 (Fri, 05 Sep 2008) | 1 line
+
+comment fix and TODO update
+------------------------------------------------------------------------
+r11903 | felix | 2008-09-05 10:05:55 +0200 (Fri, 05 Sep 2008) | 1 line
+
+replaced primitives used by synrules to avoid primitive-renaming problem
+------------------------------------------------------------------------
+r11892 | felix | 2008-09-04 10:25:51 +0200 (Thu, 04 Sep 2008) | 1 line
+
+resurrected local documentation and examples handling in setup api; removed chicken-setup
+------------------------------------------------------------------------
+r11864 | felix | 2008-09-02 11:31:58 +0200 (Tue, 02 Sep 2008) | 1 line
+
+added manual text for alternative transports
+------------------------------------------------------------------------
+r11842 | felix | 2008-09-01 09:11:02 +0200 (Mon, 01 Sep 2008) | 1 line
+
+letrec is a core form now [to fix problem reported by Jim]
+------------------------------------------------------------------------
+r11792 | felix | 2008-08-28 12:12:01 +0200 (Thu, 28 Aug 2008) | 1 line
+
+process options from CHICKEN_OPTIONS before command-line-options
+------------------------------------------------------------------------
+r11776 | felix | 2008-08-27 09:05:10 +0200 (Wed, 27 Aug 2008) | 1 line
+
+-version option for new setup tools; options for credentials
+------------------------------------------------------------------------
+r11771 | felix | 2008-08-26 11:01:54 +0200 (Tue, 26 Aug 2008) | 1 line
+
+added default options back again
+------------------------------------------------------------------------
+r11769 | elf | 2008-08-26 09:24:23 +0200 (Tue, 26 Aug 2008) | 3 lines
+
+null deref check, thanks raikov
+
+
+------------------------------------------------------------------------
+r11767 | elf | 2008-08-26 08:28:02 +0200 (Tue, 26 Aug 2008) | 8 lines
+
+make clean gets rid of import libs now. defaults handles some import shtuff
+properly and it removes the -quiet and -no-trace flags from the default,
+nonoverridable compilation options, cause its a royal pain anyway especially
+when bugfixing. bootstrap.tar.gz is now up to date with something that
+actually works with chicken4 and no longer references libraries that dont
+exist.
+
+
+------------------------------------------------------------------------
+r11766 | elf | 2008-08-26 07:17:11 +0200 (Tue, 26 Aug 2008) | 8 lines
+
+LOTS of fixes.
+compiler fixes: nested statements like
+(print (((if #t (lambda () add1))) 0))
+now work. imitation compiler hash tables are used properly. bootstrap target
+works now, although the bootstrap is WAY out of date. all of the -debug flags
+now work and dont make the compilation crash. :)
+
+
+------------------------------------------------------------------------
+r11765 | felix | 2008-08-26 05:35:53 +0200 (Tue, 26 Aug 2008) | 1 line
+
+henrietta + setup-download fix for tagged repo dirs
+------------------------------------------------------------------------
+r11750 | felix | 2008-08-25 08:44:45 +0200 (Mon, 25 Aug 2008) | 1 line
+
+added -n to chicken-install
+------------------------------------------------------------------------
+r11741 | felix | 2008-08-24 21:41:12 +0200 (Sun, 24 Aug 2008) | 1 line
+
+hygiene issues with several ffi forms; debugging code in expand only when DEBUGBUILD
+------------------------------------------------------------------------
+r11717 | felix | 2008-08-23 14:26:09 +0200 (Sat, 23 Aug 2008) | 1 line
+
+henrietta writes REMOTE_ADDR to log
+------------------------------------------------------------------------
+r11714 | felix | 2008-08-23 14:14:54 +0200 (Sat, 23 Aug 2008) | 1 line
+
+setup-download fixes; updated manifest
+------------------------------------------------------------------------
+r11707 | felix | 2008-08-22 11:00:59 +0200 (Fri, 22 Aug 2008) | 1 line
+
+fix in debug output
+------------------------------------------------------------------------
+r11705 | felix | 2008-08-22 10:45:50 +0200 (Fri, 22 Aug 2008) | 1 line
+
+error checking in setup tools
+------------------------------------------------------------------------
+r11703 | felix | 2008-08-22 10:29:37 +0200 (Fri, 22 Aug 2008) | 1 line
+
+setup fixes
+------------------------------------------------------------------------
+r11680 | felix | 2008-08-19 11:24:22 +0200 (Tue, 19 Aug 2008) | 1 line
+
+fixes and usage of file module
+------------------------------------------------------------------------
+r11647 | felix | 2008-08-15 09:27:05 +0200 (Fri, 15 Aug 2008) | 1 line
+
+added test parameter
+------------------------------------------------------------------------
+r11646 | felix | 2008-08-14 11:50:52 +0200 (Thu, 14 Aug 2008) | 1 line
+
+merged with trunk rev. 11635; compiler bugfix; added files import lib
+------------------------------------------------------------------------
+r11644 | felix | 2008-08-14 11:01:22 +0200 (Thu, 14 Aug 2008) | 1 line
+
+added files manual page
+------------------------------------------------------------------------
+r11643 | felix | 2008-08-14 10:48:28 +0200 (Thu, 14 Aug 2008) | 1 line
+
+added files.scm
+------------------------------------------------------------------------
+r11642 | felix | 2008-08-14 10:45:16 +0200 (Thu, 14 Aug 2008) | 1 line
+
+terminate response with eof object
+------------------------------------------------------------------------
+r11640 | felix | 2008-08-14 08:53:12 +0200 (Thu, 14 Aug 2008) | 1 line
+
+note about compiler bug
+------------------------------------------------------------------------
+r11628 | felix | 2008-08-13 08:10:18 +0200 (Wed, 13 Aug 2008) | 1 line
+
+more manpages
+------------------------------------------------------------------------
+r11627 | felix | 2008-08-13 07:56:34 +0200 (Wed, 13 Aug 2008) | 1 line
+
+added manpage for chicken-install
+------------------------------------------------------------------------
+r11607 | felix | 2008-08-12 13:08:58 +0200 (Tue, 12 Aug 2008) | 1 line
+
+setup bugfixes
+------------------------------------------------------------------------
+r11597 | felix | 2008-08-11 15:09:02 +0200 (Mon, 11 Aug 2008) | 1 line
+
+started with henrietta
+------------------------------------------------------------------------
+r11577 | felix | 2008-08-09 15:30:25 +0200 (Sat, 09 Aug 2008) | 1 line
+
+added support for alternative define-syntax syntax
+------------------------------------------------------------------------
+r11573 | felix | 2008-08-09 00:11:04 +0200 (Sat, 09 Aug 2008) | 1 line
+
+integrated setup tools into build (optional); some enhancements, mostly untested
+------------------------------------------------------------------------
+r11572 | felix | 2008-08-08 23:07:37 +0200 (Fri, 08 Aug 2008) | 1 line
+
+gnah
+------------------------------------------------------------------------
+r11558 | felix | 2008-08-07 14:47:38 +0200 (Thu, 07 Aug 2008) | 1 line
+
+minor setup tweaks
+------------------------------------------------------------------------
+r11547 | felix | 2008-08-05 23:59:39 +0200 (Tue, 05 Aug 2008) | 1 line
+
+small fixes
+------------------------------------------------------------------------
+r11542 | felix | 2008-08-05 01:49:41 +0200 (Tue, 05 Aug 2008) | 3 lines
+
+- documented `terminal-size'
+- first skeletons of setup tools
+
+------------------------------------------------------------------------
+r11536 | felix | 2008-08-02 13:13:44 +0200 (Sat, 02 Aug 2008) | 1 line
+
+implemented chicken-status
+------------------------------------------------------------------------
+r11528 | felix | 2008-08-01 11:15:20 +0200 (Fri, 01 Aug 2008) | 1 line
+
+fixes and improvements to setup modules
+------------------------------------------------------------------------
+r11524 | felix | 2008-08-01 01:17:42 +0200 (Fri, 01 Aug 2008) | 1 line
+
+re-loading imported module into interpreter incorrectly renamed export list (export-lists are now sytax-stripped); started with guerilla setup
+------------------------------------------------------------------------
+r11496 | felix | 2008-07-31 00:33:49 +0200 (Thu, 31 Jul 2008) | 1 line
+
+moved some files
+------------------------------------------------------------------------
+r11493 | felix | 2008-07-30 23:05:07 +0200 (Wed, 30 Jul 2008) | 1 line
+
+added export macro (as requested by Hans Bulfone)
+------------------------------------------------------------------------
+r11455 | felix | 2008-07-28 12:03:54 +0200 (Mon, 28 Jul 2008) | 1 line
+
+updated NEWS, mini-setup (version file support)
+------------------------------------------------------------------------
+r11420 | felix | 2008-07-25 01:13:40 +0200 (Fri, 25 Jul 2008) | 1 line
+
+added char-ready? to scheme.import.scm (thanks to Hans Bulfone)
+------------------------------------------------------------------------
+r11418 | felix | 2008-07-24 18:35:33 +0200 (Thu, 24 Jul 2008) | 1 line
+
+added syntax->datum; added some notes to module/macro chapter
+------------------------------------------------------------------------
+r11401 | felix | 2008-07-22 21:54:32 +0200 (Tue, 22 Jul 2008) | 1 line
+
+working mini-setup; csi describe and report tweaks; wrong handling of require-extension with core libs (import case)
+------------------------------------------------------------------------
+r11395 | felix | 2008-07-22 15:14:45 +0200 (Tue, 22 Jul 2008) | 1 line
+
+indirect reexports not even strictly necessary; started mini-setup
+------------------------------------------------------------------------
+r11391 | felix | 2008-07-22 01:04:46 +0200 (Tue, 22 Jul 2008) | 1 line
+
+overhauled handling of primitives to fix indirect reexport problem reported by Jim; primitive modules now map to #%... symbols, which have a property pointing back to the original name
+------------------------------------------------------------------------
+r11390 | felix | 2008-07-21 22:19:50 +0200 (Mon, 21 Jul 2008) | 1 line
+
+indirect exports respect identifiers that were imported; checks now for indirect syntax exports (which are pointless)
+------------------------------------------------------------------------
+r11343 | felix | 2008-07-18 10:38:05 +0200 (Fri, 18 Jul 2008) | 1 line
+
+cleanup
+------------------------------------------------------------------------
+r11324 | felix | 2008-07-17 11:44:42 +0200 (Thu, 17 Jul 2008) | 1 line
+
+optional SONAMEing; module bugfix attempt
+------------------------------------------------------------------------
+r11278 | felix | 2008-07-14 18:36:50 +0200 (Mon, 14 Jul 2008) | 1 line
+
+eval id lookup didn't check for SE membership before doing global aliasing (sounds very intelligent, doesn't it?)
+------------------------------------------------------------------------
+r11264 | sjamaan | 2008-07-12 20:26:45 +0200 (Sat, 12 Jul 2008) | 1 line
+
+Add load-relative to chicken.import.scm
+------------------------------------------------------------------------
+r11258 | kon | 2008-07-11 04:40:23 +0200 (Fri, 11 Jul 2008) | 2 lines
+
+'regexp*' 'options' param is a list.
+
+------------------------------------------------------------------------
+r11219 | felix | 2008-07-08 18:55:28 +0200 (Tue, 08 Jul 2008) | 1 line
+
+bsd makefile fixes (does relinking); de-deprecated 'use'; reexports (only value bindings, yet)
+------------------------------------------------------------------------
+r11179 | sjamaan | 2008-07-06 22:37:18 +0200 (Sun, 06 Jul 2008) | 1 line
+
+Add arithmetic-shift to chicken.import.scm
+------------------------------------------------------------------------
+r11164 | sjamaan | 2008-07-05 12:14:50 +0200 (Sat, 05 Jul 2008) | 2 lines
+
+Fix BSD makefiles (linking of import-*.so files required -R switch)
+
+------------------------------------------------------------------------
+r11160 | felix | 2008-07-04 23:41:22 +0200 (Fri, 04 Jul 2008) | 1 line
+
+removed chicken-update attempt; module-registration only happens for compiled units or shared code
+------------------------------------------------------------------------
+r11159 | felix | 2008-07-04 14:15:32 +0200 (Fri, 04 Jul 2008) | 1 line
+
+started with chicken-update.scm - egg setup is a mess. can't this be simplified?
+------------------------------------------------------------------------
+r11158 | ashinn | 2008-07-04 11:36:17 +0200 (Fri, 04 Jul 2008) | 2 lines
+
+0.8.2 release
+
+------------------------------------------------------------------------
+r11154 | felix | 2008-07-04 10:23:29 +0200 (Fri, 04 Jul 2008) | 1 line
+
+define-constant expands into define for complex literals, small fixes
+------------------------------------------------------------------------
+r11151 | felix | 2008-07-03 14:57:51 +0200 (Thu, 03 Jul 2008) | 1 line
+
+added missing test file
+------------------------------------------------------------------------
+r11150 | felix | 2008-07-03 14:56:53 +0200 (Thu, 03 Jul 2008) | 1 line
+
+carried over changes (and renames) of debian files
+------------------------------------------------------------------------
+r11149 | felix | 2008-07-03 14:54:02 +0200 (Thu, 03 Jul 2008) | 1 line
+
+merged trunk rev. 11148; started with split up setup api modules
+------------------------------------------------------------------------
+r11133 | felix | 2008-07-01 14:46:58 +0200 (Tue, 01 Jul 2008) | 1 line
+
+removed expand*, added missing entries to chicken import lib
+------------------------------------------------------------------------
+r11126 | felix | 2008-06-30 09:23:52 +0200 (Mon, 30 Jun 2008) | 1 line
+
+more tests; primitive exports are not marked on import
+------------------------------------------------------------------------
+r11118 | felix | 2008-06-30 06:54:24 +0200 (Mon, 30 Jun 2008) | 1 line
+
+added begin-for-syntax, elab-time execution happens in meta-env
+------------------------------------------------------------------------
+r11109 | felix | 2008-06-29 23:03:53 +0200 (Sun, 29 Jun 2008) | 1 line
+
+added lowlevel macros in chicken-setup to allow build with r3 chicken
+------------------------------------------------------------------------
+r11107 | felix | 2008-06-29 12:28:55 +0200 (Sun, 29 Jun 2008) | 1 line
+
+define-for-syntax defs added to import lib
+------------------------------------------------------------------------
+r11096 | felix | 2008-06-28 09:28:54 +0200 (Sat, 28 Jun 2008) | 1 line
+
+inline-defs do not extract mutable constants anymore as this would require walking twice
+------------------------------------------------------------------------
+r11092 | felix | 2008-06-27 12:30:24 +0200 (Fri, 27 Jun 2008) | 1 line
+
+removed srfi-13 macro from chicken-more-macros
+------------------------------------------------------------------------
+r11091 | felix | 2008-06-27 09:51:22 +0200 (Fri, 27 Jun 2008) | 1 line
+
+inline-function problems
+------------------------------------------------------------------------
+r11087 | felix | 2008-06-26 16:16:58 +0200 (Thu, 26 Jun 2008) | 1 line
+
+added test
+------------------------------------------------------------------------
+r11086 | felix | 2008-06-26 16:12:12 +0200 (Thu, 26 Jun 2008) | 1 line
+
+mark as aliased only when _really_ aliased
+------------------------------------------------------------------------
+r11085 | felix | 2008-06-26 09:03:17 +0200 (Thu, 26 Jun 2008) | 1 line
+
+module debugging
+------------------------------------------------------------------------
+r11075 | felix | 2008-06-24 08:43:32 +0200 (Tue, 24 Jun 2008) | 1 line
+
+handle import-for-syntax differently
+------------------------------------------------------------------------
+r11070 | felix | 2008-06-23 13:25:44 +0200 (Mon, 23 Jun 2008) | 1 line
+
+slightly mindless tweaking
+------------------------------------------------------------------------
+r11066 | felix | 2008-06-23 09:56:01 +0200 (Mon, 23 Jun 2008) | 1 line
+
+imp.libs must be compiled for host
+------------------------------------------------------------------------
+r11056 | felix | 2008-06-20 16:16:43 +0200 (Fri, 20 Jun 2008) | 1 line
+
+various fixes
+------------------------------------------------------------------------
+r11053 | felix | 2008-06-20 12:33:51 +0200 (Fri, 20 Jun 2008) | 1 line
+
+expand fixes, re-added 'use' (but deprecated)
+------------------------------------------------------------------------
+r11038 | kon | 2008-06-18 17:13:45 +0200 (Wed, 18 Jun 2008) | 2 lines
+
+Rplcd 'use' w/ 'require-extension'.
+
+------------------------------------------------------------------------
+r11037 | kon | 2008-06-18 17:00:45 +0200 (Wed, 18 Jun 2008) | 2 lines
+
+Added missing close paren.
+
+------------------------------------------------------------------------
+r11035 | felix | 2008-06-18 09:21:16 +0200 (Wed, 18 Jun 2008) | 1 line
+
+deprecated define-extension, documented require-library
+------------------------------------------------------------------------
+r11034 | felix | 2008-06-18 09:18:17 +0200 (Wed, 18 Jun 2008) | 1 line
+
+re-added define-record, added require-library (and changed require-extension, still untested)
+------------------------------------------------------------------------
+r11033 | felix | 2008-06-18 00:16:58 +0200 (Wed, 18 Jun 2008) | 1 line
+
+updated TODO
+------------------------------------------------------------------------
+r11031 | zbigniew | 2008-06-17 06:59:36 +0200 (Tue, 17 Jun 2008) | 1 line
+
+add -L. to LINKER_LINK_DLOADABLE_OPTIONS on macosx
+------------------------------------------------------------------------
+r11026 | felix | 2008-06-16 23:22:57 +0200 (Mon, 16 Jun 2008) | 1 line
+
+modules can export all defs now
+------------------------------------------------------------------------
+r11015 | felix | 2008-06-13 11:43:43 +0200 (Fri, 13 Jun 2008) | 1 line
+
+arg.
+------------------------------------------------------------------------
+r11013 | felix | 2008-06-13 08:24:07 +0200 (Fri, 13 Jun 2008) | 1 line
+
+removed require-for-syntax; fix in data-structures import lib
+------------------------------------------------------------------------
+r11011 | felix | 2008-06-13 08:00:32 +0200 (Fri, 13 Jun 2008) | 1 line
+
+fixed bug in chicken-setup [thanks to John Cowan]
+------------------------------------------------------------------------
+r11008 | felix | 2008-06-11 09:28:14 +0200 (Wed, 11 Jun 2008) | 1 line
+
+added missing test and activated r5rs_pitfalls
+------------------------------------------------------------------------
+r11007 | felix | 2008-06-11 08:50:00 +0200 (Wed, 11 Jun 2008) | 1 line
+
+it might even work now
+------------------------------------------------------------------------
+r11005 | kon | 2008-06-11 04:32:37 +0200 (Wed, 11 Jun 2008) | 2 lines
+
+Added include-path to compile & interpret so import modules found in build dir. (Note that "test-chained-modules.scm" is not currently in the repo.)
+
+------------------------------------------------------------------------
+r10996 | felix | 2008-06-10 13:23:05 +0200 (Tue, 10 Jun 2008) | 1 line
+
+one step forward, half a step back
+------------------------------------------------------------------------
+r10995 | felix | 2008-06-10 00:05:46 +0200 (Tue, 10 Jun 2008) | 1 line
+
+localized problem
+------------------------------------------------------------------------
+r10990 | felix | 2008-06-09 11:03:59 +0200 (Mon, 09 Jun 2008) | 1 line
+
+toplevel import issue - now ec module test fails
+------------------------------------------------------------------------
+r10986 | felix | 2008-06-07 15:26:29 +0200 (Sat, 07 Jun 2008) | 1 line
+
+indirect exports for compiled modules and import libs incomplete
+------------------------------------------------------------------------
+r10984 | felix | 2008-06-07 01:40:11 +0200 (Sat, 07 Jun 2008) | 1 line
+
+chained imports: exported macros don't close over imported macros
+------------------------------------------------------------------------
+r10983 | felix | 2008-06-05 20:40:44 +0200 (Thu, 05 Jun 2008) | 1 line
+
+one day this will work.
+------------------------------------------------------------------------
+r10982 | felix | 2008-06-05 14:15:41 +0200 (Thu, 05 Jun 2008) | 1 line
+
+hackhackhack
+------------------------------------------------------------------------
+r10981 | felix | 2008-06-05 13:42:08 +0200 (Thu, 05 Jun 2008) | 1 line
+
+...clicka...clicka...
+------------------------------------------------------------------------
+r10980 | felix | 2008-06-05 10:21:41 +0200 (Thu, 05 Jun 2008) | 1 line
+
+getting better
+------------------------------------------------------------------------
+r10979 | felix | 2008-06-04 23:28:31 +0200 (Wed, 04 Jun 2008) | 1 line
+
+it's life, Jim - but not as we know it.
+------------------------------------------------------------------------
+r10975 | felix | 2008-06-04 13:37:35 +0200 (Wed, 04 Jun 2008) | 1 line
+
+more dabbling, no solution
+------------------------------------------------------------------------
+r10974 | felix | 2008-06-04 12:19:40 +0200 (Wed, 04 Jun 2008) | 1 line
+
+needs to be reworked, alas
+------------------------------------------------------------------------
+r10973 | felix | 2008-06-04 10:20:50 +0200 (Wed, 04 Jun 2008) | 1 line
+
+module fix attempts
+------------------------------------------------------------------------
+r10954 | felix | 2008-05-30 09:48:27 +0200 (Fri, 30 May 2008) | 1 line
+
+completed merge
+------------------------------------------------------------------------
+r10953 | felix | 2008-05-29 14:32:21 +0200 (Thu, 29 May 2008) | 1 line
+
+fixes, tests
+------------------------------------------------------------------------
+r10952 | felix | 2008-05-29 13:19:44 +0200 (Thu, 29 May 2008) | 1 line
+
+merged changed from trunk rev. 10622:10950 (untested)
+------------------------------------------------------------------------
+r10951 | felix | 2008-05-29 09:55:11 +0200 (Thu, 29 May 2008) | 1 line
+
+checking of refs to undefd identifiers in modules
+------------------------------------------------------------------------
+r10943 | felix | 2008-05-28 09:15:57 +0200 (Wed, 28 May 2008) | 1 line
+
+fixed body-expansion problem partially
+------------------------------------------------------------------------
+r10939 | felix | 2008-05-27 09:15:03 +0200 (Tue, 27 May 2008) | 1 line
+
+various attempts at fixing body-expansion-related bugs
+------------------------------------------------------------------------
+r10938 | zbigniew | 2008-05-27 00:07:19 +0200 (Tue, 27 May 2008) | 1 line
+
+hygienic branch: define-record-printer fix (hope you don't mind, felix :)
+------------------------------------------------------------------------
+r10935 | felix | 2008-05-23 16:28:36 +0200 (Fri, 23 May 2008) | 2 lines
+
+manual fixes
+
+------------------------------------------------------------------------
+r10934 | felix | 2008-05-23 15:53:43 +0200 (Fri, 23 May 2008) | 5 lines
+
+- add modules and macro examples and documentation
+- acknowledgements in manual
+- exposed "syntax"
+- added tests from exrename paper
+
+------------------------------------------------------------------------
+r10933 | felix | 2008-05-23 15:53:37 +0200 (Fri, 23 May 2008) | 5 lines
+
+- add modules and macro examples and documentation
+- acknowledgements in manual
+- exposed "syntax"
+- added tests from exrename paper
+
+------------------------------------------------------------------------
+r10932 | felix | 2008-05-23 15:53:29 +0200 (Fri, 23 May 2008) | 5 lines
+
+- add modules and macro examples and documentation
+- acknowledgements in manual
+- exposed "syntax"
+- added tests from exrename paper
+
+------------------------------------------------------------------------
+r10931 | felix | 2008-05-23 15:53:23 +0200 (Fri, 23 May 2008) | 5 lines
+
+- add modules and macro examples and documentation
+- acknowledgements in manual
+- exposed "syntax"
+- added tests from exrename paper
+
+------------------------------------------------------------------------
+r10930 | felix | 2008-05-23 15:53:17 +0200 (Fri, 23 May 2008) | 5 lines
+
+- add modules and macro examples and documentation
+- acknowledgements in manual
+- exposed "syntax"
+- added tests from exrename paper
+
+------------------------------------------------------------------------
+r10929 | felix | 2008-05-23 15:53:08 +0200 (Fri, 23 May 2008) | 5 lines
+
+- add modules and macro examples and documentation
+- acknowledgements in manual
+- exposed "syntax"
+- added tests from exrename paper
+
+------------------------------------------------------------------------
+r10928 | felix | 2008-05-23 15:53:01 +0200 (Fri, 23 May 2008) | 5 lines
+
+- add modules and macro examples and documentation
+- acknowledgements in manual
+- exposed "syntax"
+- added tests from exrename paper
+
+------------------------------------------------------------------------
+r10927 | felix | 2008-05-23 15:52:55 +0200 (Fri, 23 May 2008) | 5 lines
+
+- add modules and macro examples and documentation
+- acknowledgements in manual
+- exposed "syntax"
+- added tests from exrename paper
+
+------------------------------------------------------------------------
+r10922 | felix | 2008-05-22 16:06:53 +0200 (Thu, 22 May 2008) | 1 line
+
+added import-for-syntax; fix for -sx; -j as abbrev. for -emit-import-library; meta-macro-env. use when loading import lib
+------------------------------------------------------------------------
+r10910 | felix | 2008-05-21 12:35:03 +0200 (Wed, 21 May 2008) | 1 line
+
+default macro env also contains syntax-rules; integrated ec tests
+------------------------------------------------------------------------
+r10909 | felix | 2008-05-21 08:56:56 +0200 (Wed, 21 May 2008) | 1 line
+
+testing modules, fix in fprintf0
+------------------------------------------------------------------------
+r10872 | felix | 2008-05-19 07:15:29 +0200 (Mon, 19 May 2008) | 1 line
+
+started module documentation, changed linker options for dloadable files
+------------------------------------------------------------------------
+r10829 | felix | 2008-05-15 10:50:52 +0200 (Thu, 15 May 2008) | 1 line
+
+applied build fix by Peter Bex
+------------------------------------------------------------------------
+r10804 | felix | 2008-05-13 08:26:28 +0200 (Tue, 13 May 2008) | 1 line
+
+added csi module, some doc fixes
+------------------------------------------------------------------------
+r10788 | felix | 2008-05-12 23:20:53 +0200 (Mon, 12 May 2008) | 8 lines
+
+- added remaining import libraries
+- csi uses srfi-69 now to avoid bootstrapping problem
+- csi: renamed "-se" to "-sx"
+- global assigns get variable name in comment in generated C code
+- import libs are compiled to .so's (likely to be not complete for windoze builds - that would be too easy)
+- removed a lot of deprecated stuff
+- it really seems to work...
+
+------------------------------------------------------------------------
+r10754 | felix | 2008-05-10 23:40:57 +0200 (Sat, 10 May 2008) | 1 line
+
+added notes, forgot import lib
+------------------------------------------------------------------------
+r10753 | felix | 2008-05-10 23:36:55 +0200 (Sat, 10 May 2008) | 1 line
+
+chicken import lib, trivial fixes, foreign import lib (untested)
+------------------------------------------------------------------------
+r10745 | felix | 2008-05-10 00:01:23 +0200 (Sat, 10 May 2008) | 1 line
+
+module fixes, reexports, -se option for csi, some cleanups, I'm the greatest Scheme hacker on earth
+------------------------------------------------------------------------
+r10722 | felix | 2008-05-07 21:10:10 +0200 (Wed, 07 May 2008) | 1 line
+
+fix in runtests
+------------------------------------------------------------------------
+r10721 | felix | 2008-05-07 13:32:32 +0200 (Wed, 07 May 2008) | 1 line
+
+added loopy-loop test
+------------------------------------------------------------------------
+r10720 | felix | 2008-05-07 12:54:46 +0200 (Wed, 07 May 2008) | 1 line
+
+added meta macro-environment
+------------------------------------------------------------------------
+r10716 | felix | 2008-05-06 23:30:32 +0200 (Tue, 06 May 2008) | 1 line
+
+import specs
+------------------------------------------------------------------------
+r10715 | felix | 2008-05-06 08:49:56 +0200 (Tue, 06 May 2008) | 1 line
+
+fixes, importlibs (untested)
+------------------------------------------------------------------------
+r10713 | felix | 2008-05-05 21:57:59 +0200 (Mon, 05 May 2008) | 1 line
+
+makefile fix
+------------------------------------------------------------------------
+r10712 | felix | 2008-05-05 20:20:23 +0200 (Mon, 05 May 2008) | 1 line
+
+various tests and improvements
+------------------------------------------------------------------------
+r10658 | felix | 2008-04-30 13:44:34 +0200 (Wed, 30 Apr 2008) | 1 line
+
+module fixes
+------------------------------------------------------------------------
+r10657 | felix | 2008-04-30 10:35:39 +0200 (Wed, 30 Apr 2008) | 1 line
+
+dist target fixes
+------------------------------------------------------------------------
+r10656 | felix | 2008-04-30 09:45:43 +0200 (Wed, 30 Apr 2008) | 1 line
+
+simpler module approach
+------------------------------------------------------------------------
+r10629 | felix | 2008-04-24 13:40:51 +0200 (Thu, 24 Apr 2008) | 1 line
+
+merged changes from trunk rev. 10622
+------------------------------------------------------------------------
+r10624 | felix | 2008-04-24 09:26:19 +0200 (Thu, 24 Apr 2008) | 1 line
+
+added some files from trunk
+------------------------------------------------------------------------
+r10623 | felix | 2008-04-24 09:15:24 +0200 (Thu, 24 Apr 2008) | 1 line
+
+added files new in trunk
+------------------------------------------------------------------------
+r10572 | felix | 2008-04-20 13:04:58 +0200 (Sun, 20 Apr 2008) | 1 line
+
+renamed merge-branch script, fixed bug in tools.scm
+------------------------------------------------------------------------
+r10557 | felix | 2008-04-19 23:30:37 +0200 (Sat, 19 Apr 2008) | 1 line
+
+let-optionals* macro fix
+------------------------------------------------------------------------
+r10532 | felix | 2008-04-19 13:22:40 +0200 (Sat, 19 Apr 2008) | 1 line
+
+ffi fixes; change in variable resolution in compiler
+------------------------------------------------------------------------
+r10531 | felix | 2008-04-19 12:23:44 +0200 (Sat, 19 Apr 2008) | 1 line
+
+updated version to 4.0.0x
+------------------------------------------------------------------------
+r10530 | felix | 2008-04-19 11:24:17 +0200 (Sat, 19 Apr 2008) | 1 line
+
+renamed branch
+------------------------------------------------------------------------
+r10522 | felix | 2008-04-18 12:57:46 +0200 (Fri, 18 Apr 2008) | 1 line
+
+various macro and compiler fixes
+------------------------------------------------------------------------
+r10478 | felix | 2008-04-16 00:03:48 +0200 (Wed, 16 Apr 2008) | 1 line
+
+some macro fixes, bugfixes in expand, trying csi -s makedist, but and-let* not yet working
+------------------------------------------------------------------------
+r10439 | felix | 2008-04-14 06:38:02 +0200 (Mon, 14 Apr 2008) | 1 line
+
+painfully slowly debugging compiler
+------------------------------------------------------------------------
+r10427 | felix | 2008-04-12 01:05:06 +0200 (Sat, 12 Apr 2008) | 1 line
+
+llist keywords and qualified syms are not macro-aliased
+------------------------------------------------------------------------
+r10426 | felix | 2008-04-12 00:30:34 +0200 (Sat, 12 Apr 2008) | 1 line
+
+removed current module crap and made compiler run again; fixed several bugs introduced by decruftification; I'm still the boss here.
+------------------------------------------------------------------------
+r10424 | felix | 2008-04-11 16:29:39 +0200 (Fri, 11 Apr 2008) | 1 line
+
+compiler broken. I'm tired.
+------------------------------------------------------------------------
+r10423 | felix | 2008-04-11 15:51:45 +0200 (Fri, 11 Apr 2008) | 1 line
+
+this is hard
+------------------------------------------------------------------------
+r10422 | felix | 2008-04-11 15:46:03 +0200 (Fri, 11 Apr 2008) | 1 line
+
+more module tests, imported syntax refers to wrong imported globals
+------------------------------------------------------------------------
+r10420 | felix | 2008-04-11 10:17:33 +0200 (Fri, 11 Apr 2008) | 1 line
+
+simple module test
+------------------------------------------------------------------------
+r10414 | felix | 2008-04-10 20:21:28 +0200 (Thu, 10 Apr 2008) | 1 line
+
+compile-syntax option and decl; env experiments (not working)
+------------------------------------------------------------------------
+r10398 | felix | 2008-04-09 11:26:53 +0200 (Wed, 09 Apr 2008) | 1 line
+
+removed some ffi cruft (including silly quoting for psyntax), converted all macros, removed old hooks
+------------------------------------------------------------------------
+r10381 | felix | 2008-04-07 21:02:20 +0200 (Mon, 07 Apr 2008) | 1 line
+
+doc updates
+------------------------------------------------------------------------
+r10380 | felix | 2008-04-07 20:58:15 +0200 (Mon, 07 Apr 2008) | 1 line
+
+converted all non-std macros; various fixes; removed defined-foreign-record
+------------------------------------------------------------------------
+r10378 | felix | 2008-04-07 16:28:01 +0200 (Mon, 07 Apr 2008) | 1 line
+
+forgot to update manifest
+------------------------------------------------------------------------
+r10377 | felix | 2008-04-07 16:23:12 +0200 (Mon, 07 Apr 2008) | 1 line
+
+removed old pattern matcher completely
+------------------------------------------------------------------------
+r10375 | felix | 2008-04-07 14:00:59 +0200 (Mon, 07 Apr 2008) | 1 line
+
+removed uses of match
+------------------------------------------------------------------------
+r10374 | felix | 2008-04-07 11:49:28 +0200 (Mon, 07 Apr 2008) | 1 line
+
+removed uses of match in c-backend
+------------------------------------------------------------------------
+r10371 | felix | 2008-04-07 09:24:01 +0200 (Mon, 07 Apr 2008) | 1 line
+
+forgot test code
+------------------------------------------------------------------------
+r10370 | felix | 2008-04-07 09:23:33 +0200 (Mon, 07 Apr 2008) | 1 line
+
+updated synrules from upstream (riaxpander egg); some conversions; some fixes; added tests
+------------------------------------------------------------------------
+r10359 | felix | 2008-04-06 01:34:34 +0200 (Sun, 06 Apr 2008) | 1 line
+
+low-level module attempt; converted some more macros
+------------------------------------------------------------------------
+r10358 | felix | 2008-04-05 23:05:10 +0200 (Sat, 05 Apr 2008) | 1 line
+
+macro conversion
+------------------------------------------------------------------------
+r10353 | felix | 2008-04-04 15:06:11 +0200 (Fri, 04 Apr 2008) | 1 line
+
+converted some macros
+------------------------------------------------------------------------
+r10352 | felix | 2008-04-04 14:46:07 +0200 (Fri, 04 Apr 2008) | 1 line
+
+some bugfixes; r4rstest runs (yay)
+------------------------------------------------------------------------
+r10351 | felix | 2008-04-04 13:55:21 +0200 (Fri, 04 Apr 2008) | 1 line
+
+some macros converted, fix in body-canonicalization
+------------------------------------------------------------------------
+r10345 | felix | 2008-04-04 09:12:19 +0200 (Fri, 04 Apr 2008) | 1 line
+
+quasiquote fixes; uses srfi-9 for all records; disabled define-record; some more hygienic macros
+------------------------------------------------------------------------
+r10334 | felix | 2008-04-03 11:43:19 +0200 (Thu, 03 Apr 2008) | 1 line
+
+all default macros are hygienic, now
+------------------------------------------------------------------------
+r10290 | felix | 2008-04-02 21:14:15 +0200 (Wed, 02 Apr 2008) | 1 line
+
+some default macros are hygienic, more tests
+------------------------------------------------------------------------
+r10261 | felix | 2008-04-02 08:38:51 +0200 (Wed, 02 Apr 2008) | 1 line
+
+added test; updated manifest
+------------------------------------------------------------------------
+r10216 | felix | 2008-03-31 11:48:11 +0200 (Mon, 31 Mar 2008) | 1 line
+
+fixed compare function for er macros (needs passing dynamic se to transformers)
+------------------------------------------------------------------------
+r10212 | felix | 2008-03-30 13:30:41 +0200 (Sun, 30 Mar 2008) | 1 line
+
+er-compare handles non-symbols; added keyword-rebinding test (fails)
+------------------------------------------------------------------------
+r10211 | felix | 2008-03-30 12:54:10 +0200 (Sun, 30 Mar 2008) | 1 line
+
+added feature-ids for highlevel macros; fixes; more tests, all is well
+------------------------------------------------------------------------
+r10210 | felix | 2008-03-30 08:54:53 +0200 (Sun, 30 Mar 2008) | 1 line
+
+lots of fixes; ##core#syntax; refactored debug output; synrules integration; explicitly nonhygienic lisp-transformer macros
+------------------------------------------------------------------------
+r10209 | felix | 2008-03-29 14:28:03 +0100 (Sat, 29 Mar 2008) | 1 line
+
+a few makefile fixes (allow disabling HACKED_APPLY); internal versions of get/put!; compiler expands fac.scm, now; added synrules from riaxpander/R&K, but not integrated, yet
+------------------------------------------------------------------------
+r10194 | felix | 2008-03-28 16:58:56 +0100 (Fri, 28 Mar 2008) | 1 line
+
+first real testing
+------------------------------------------------------------------------
+r10193 | felix | 2008-03-28 15:56:34 +0100 (Fri, 28 Mar 2008) | 1 line
+
+##sys#lisp-expander and new registration functions; proper a-conversion in eval; fixes
+------------------------------------------------------------------------
+r10176 | felix | 2008-03-27 07:13:32 +0100 (Thu, 27 Mar 2008) | 1 line
+
+first define-syntax tests, various fixes
+------------------------------------------------------------------------
+r10166 | felix | 2008-03-26 17:32:11 +0100 (Wed, 26 Mar 2008) | 1 line
+
+a few fixes, some more expansions work in csi
+------------------------------------------------------------------------
+r10164 | felix | 2008-03-26 15:55:30 +0100 (Wed, 26 Mar 2008) | 1 line
+
+mindless hacking and testing
+------------------------------------------------------------------------
+r10163 | felix | 2008-03-26 13:34:37 +0100 (Wed, 26 Mar 2008) | 1 line
+
+forgot
+------------------------------------------------------------------------
+r10162 | felix | 2008-03-26 13:33:57 +0100 (Wed, 26 Mar 2008) | 1 line
+
+first tests
+------------------------------------------------------------------------
+r10161 | felix | 2008-03-26 12:17:11 +0100 (Wed, 26 Mar 2008) | 1 line
+
+builds, still untested
+------------------------------------------------------------------------
+r10160 | felix | 2008-03-26 11:28:18 +0100 (Wed, 26 Mar 2008) | 1 line
+
+hack, hack, hack
+------------------------------------------------------------------------
+r10159 | felix | 2008-03-26 09:27:23 +0100 (Wed, 26 Mar 2008) | 1 line
+
+proper passing of se's
+------------------------------------------------------------------------
+r10121 | felix | 2008-03-24 01:33:30 +0100 (Mon, 24 Mar 2008) | 1 line
+
+macro-environment is alist, uses lookup-identifier for environment lookup (will need unified se for compiler/eval)
+------------------------------------------------------------------------
+r10119 | felix | 2008-03-24 00:12:21 +0100 (Mon, 24 Mar 2008) | 1 line
+
+factored all macro stuff into expand.scm; added local define-syntax expansion
+------------------------------------------------------------------------
+r9905 | felix | 2008-03-20 15:59:03 +0100 (Thu, 20 Mar 2008) | 1 line
+
+added identifier type, strips identifiers for quote; no identifier handling in eval or compile, yet
+------------------------------------------------------------------------
+r9894 | felix | 2008-03-19 08:48:21 +0100 (Wed, 19 Mar 2008) | 1 line
+
+branched from trunk
+------------------------------------------------------------------------
+r9587 | kon | 2008-03-14 02:15:54 +0100 (Fri, 14 Mar 2008) | 2 lines
+
+Docu for new combinators (where did the originals go?) & minor optimization to right-section.
+
+------------------------------------------------------------------------
+r9586 | kon | 2008-03-14 01:58:32 +0100 (Fri, 14 Mar 2008) | 2 lines
+
+Hacked fix for 'unbound variable: every' in csi.
+
+------------------------------------------------------------------------
+r9535 | iraikov | 2008-03-13 12:40:33 +0100 (Thu, 13 Mar 2008) | 2 lines
+
+Updated to 3.0.8
+
+------------------------------------------------------------------------
+r9534 | iraikov | 2008-03-13 12:40:11 +0100 (Thu, 13 Mar 2008) | 2 lines
+
+Increased version number to 3.0.8.
+
+------------------------------------------------------------------------
+r9533 | iraikov | 2008-03-13 12:30:49 +0100 (Thu, 13 Mar 2008) | 3 lines
+
+A fix for to setup-build-prefix when neither HOME nor USER are
+defined.
+
+------------------------------------------------------------------------
+r9524 | felix | 2008-03-12 23:07:57 +0100 (Wed, 12 Mar 2008) | 5 lines
+
+- extras: moved local defmacros out, as it suggested local macros were supported
+- manual: srfi-7 was implicitly listed as supported
+- removed runtime.c from bootstrapping tarball, added both posix files
+
+
+------------------------------------------------------------------------
+r9507 | iraikov | 2008-03-12 01:15:10 +0100 (Wed, 12 Mar 2008) | 2 lines
+
+Version increased to 3.0.7
+
+------------------------------------------------------------------------
+r9506 | iraikov | 2008-03-12 01:09:11 +0100 (Wed, 12 Mar 2008) | 2 lines
+
+Put new changes in NEWS under 3.0.7.
+
+------------------------------------------------------------------------
+r9498 | elf | 2008-03-12 00:51:02 +0100 (Wed, 12 Mar 2008) | 3 lines
+
+annoying error message gone
+
+
+------------------------------------------------------------------------
+r9497 | elf | 2008-03-12 00:40:12 +0100 (Wed, 12 Mar 2008) | 4 lines
+
+
+fixed bug preventing static linking of executables with csc -static
+
+
+------------------------------------------------------------------------
+r9432 | zbigniew | 2008-03-11 08:04:08 +0100 (Tue, 11 Mar 2008) | 1 line
+
+readme: regex patch
+------------------------------------------------------------------------
+r9431 | zbigniew | 2008-03-11 08:00:35 +0100 (Tue, 11 Mar 2008) | 1 line
+
+regex: scheme-pointer should have been nonnull-scheme-pointer
+------------------------------------------------------------------------
+r9428 | elf | 2008-03-11 07:28:45 +0100 (Tue, 11 Mar 2008) | 4 lines
+
+
+applied zbigniews patch
+
+
+------------------------------------------------------------------------
+r9422 | iraikov | 2008-03-11 07:00:20 +0100 (Tue, 11 Mar 2008) | 2 lines
+
+Version number updated in the documentation.
+
+------------------------------------------------------------------------
+r9419 | iraikov | 2008-03-11 06:55:15 +0100 (Tue, 11 Mar 2008) | 2 lines
+
+Small fix to allow maketexi script to work.
+
+------------------------------------------------------------------------
+r9418 | iraikov | 2008-03-11 06:51:11 +0100 (Tue, 11 Mar 2008) | 2 lines
+
+Manual updated from the wiki.
+
+------------------------------------------------------------------------
+r9409 | iraikov | 2008-03-11 05:27:38 +0100 (Tue, 11 Mar 2008) | 2 lines
+
+Increased version number to 3.0.6
+
+------------------------------------------------------------------------
+r9395 | iraikov | 2008-03-10 05:52:03 +0100 (Mon, 10 Mar 2008) | 2 lines
+
+Version number increased to 3.0.6.
+
+------------------------------------------------------------------------
+r9394 | iraikov | 2008-03-10 05:50:25 +0100 (Mon, 10 Mar 2008) | 2 lines
+
+Version number increased to 3.0.6.
+
+------------------------------------------------------------------------
+r9393 | iraikov | 2008-03-10 05:49:30 +0100 (Mon, 10 Mar 2008) | 2 lines
+
+Bug fix in constructing the pathname for examples.
+
+------------------------------------------------------------------------
+r9382 | kon | 2008-03-09 18:19:43 +0100 (Sun, 09 Mar 2008) | 2 lines
+
+Rmvd dup expr from fix for chmod of example file.
+
+------------------------------------------------------------------------
+r9380 | kon | 2008-03-09 17:53:18 +0100 (Sun, 09 Mar 2008) | 2 lines
+
+Fix for chmod of examples.
+
+------------------------------------------------------------------------
+r9356 | iraikov | 2008-03-09 15:32:36 +0100 (Sun, 09 Mar 2008) | 2 lines
+
+Updated Texinfo documentation.
+
+------------------------------------------------------------------------
+r9354 | iraikov | 2008-03-09 15:21:47 +0100 (Sun, 09 Mar 2008) | 2 lines
+
+Updated Locations page.
+
+------------------------------------------------------------------------
+r9352 | iraikov | 2008-03-09 15:18:08 +0100 (Sun, 09 Mar 2008) | 2 lines
+
+Fixed link to location-and-c-string-star.
+
+------------------------------------------------------------------------
+r9351 | iraikov | 2008-03-09 15:16:17 +0100 (Sun, 09 Mar 2008) | 2 lines
+
+Updated version in the manual.
+
+------------------------------------------------------------------------
+r9350 | iraikov | 2008-03-09 15:12:51 +0100 (Sun, 09 Mar 2008) | 2 lines
+
+Added scripts subdir to manifest.
+
+------------------------------------------------------------------------
+r9342 | iraikov | 2008-03-09 11:17:14 +0100 (Sun, 09 Mar 2008) | 2 lines
+
+Updated buildversion to 3.0.5.
+
+------------------------------------------------------------------------
+r9341 | iraikov | 2008-03-09 10:56:36 +0100 (Sun, 09 Mar 2008) | 2 lines
+
+Added quotes around parens in conditional expression.
+
+------------------------------------------------------------------------
+r9340 | iraikov | 2008-03-09 10:52:05 +0100 (Sun, 09 Mar 2008) | 2 lines
+
+Added a check for buildsvnrevision file.
+
+------------------------------------------------------------------------
+r9339 | iraikov | 2008-03-09 10:45:37 +0100 (Sun, 09 Mar 2008) | 2 lines
+
+Added Overview chapter.
+
+------------------------------------------------------------------------
+r9331 | elf | 2008-03-08 18:04:00 +0100 (Sat, 08 Mar 2008) | 3 lines
+
+corrected stat values
+
+
+------------------------------------------------------------------------
+r9327 | iraikov | 2008-03-08 15:51:18 +0100 (Sat, 08 Mar 2008) | 2 lines
+
+Increased version no to 3.0.5.
+
+------------------------------------------------------------------------
+r9326 | iraikov | 2008-03-08 15:50:39 +0100 (Sat, 08 Mar 2008) | 2 lines
+
+Added information about stat predicates.
+
+------------------------------------------------------------------------
+r9325 | elf | 2008-03-08 15:42:19 +0100 (Sat, 08 Mar 2008) | 3 lines
+
+fixed error
+
+
+------------------------------------------------------------------------
+r9323 | elf | 2008-03-08 15:30:46 +0100 (Sat, 08 Mar 2008) | 3 lines
+
+updated stattypes for windows
+
+
+------------------------------------------------------------------------
+r9322 | elf | 2008-03-08 15:28:33 +0100 (Sat, 08 Mar 2008) | 4 lines
+
+
+stat predicates for file types
+
+
+------------------------------------------------------------------------
+r9321 | elf | 2008-03-08 15:10:42 +0100 (Sat, 08 Mar 2008) | 3 lines
+
+minor fix
+
+
+------------------------------------------------------------------------
+r9317 | elf | 2008-03-08 15:01:12 +0100 (Sat, 08 Mar 2008) | 3 lines
+
+remove buildsvnrevision during confclean
+
+
+------------------------------------------------------------------------
+r9316 | elf | 2008-03-08 14:57:01 +0100 (Sat, 08 Mar 2008) | 3 lines
+
+fixes
+
+
+------------------------------------------------------------------------
+r9314 | elf | 2008-03-08 14:32:47 +0100 (Sat, 08 Mar 2008) | 3 lines
+
+canonical-path update, random-seed add
+
+
+------------------------------------------------------------------------
+r9258 | iraikov | 2008-03-07 07:35:10 +0100 (Fri, 07 Mar 2008) | 2 lines
+
+A fix to handle the case when installing from a .egg file.
+
+------------------------------------------------------------------------
+r9257 | iraikov | 2008-03-07 06:18:25 +0100 (Fri, 07 Mar 2008) | 2 lines
+
+Committed fixes to installing from local repository.
+
+------------------------------------------------------------------------
+r9254 | kon | 2008-03-07 00:42:13 +0100 (Fri, 07 Mar 2008) | 2 lines
+
+Applied Jim Ursetto's string-copy patch.
+
+------------------------------------------------------------------------
+r9204 | felix | 2008-03-06 11:28:45 +0100 (Thu, 06 Mar 2008) | 1 line
+
+banner cosmetics; svnrev makefile fix [by Andrei Ivushkin, but also partially already repaired by elf]
+------------------------------------------------------------------------
+r9182 | elf | 2008-03-06 02:34:40 +0100 (Thu, 06 Mar 2008) | 4 lines
+
+
+fixed incorrect build rule - get-svn-revision should have been buildsvnrevision
+
+
+------------------------------------------------------------------------
+r9181 | iraikov | 2008-03-06 02:28:04 +0100 (Thu, 06 Mar 2008) | 2 lines
+
+Updated Texinfo manual with latest files from the wiki.
+
+------------------------------------------------------------------------
+r9174 | iraikov | 2008-03-06 01:42:42 +0100 (Thu, 06 Mar 2008) | 2 lines
+
+Bug fixes for the case when installing from local repository.
+
+------------------------------------------------------------------------
+r9169 | elf | 2008-03-05 14:18:25 +0100 (Wed, 05 Mar 2008) | 4 lines
+
+
+updated bootstrap .c files, added posixwin.c (was missing)
+
+
+------------------------------------------------------------------------
+r9168 | iraikov | 2008-03-05 05:18:55 +0100 (Wed, 05 Mar 2008) | 2 lines
+
+Updated information about chicken-setup.
+
+------------------------------------------------------------------------
+r9167 | iraikov | 2008-03-05 05:13:03 +0100 (Wed, 05 Mar 2008) | 2 lines
+
+Added Overview page to list of pages.
+
+------------------------------------------------------------------------
+r9160 | mario | 2008-03-04 16:00:11 +0100 (Tue, 04 Mar 2008) | 2 lines
+
+Added `Overview' chapter.
+
+------------------------------------------------------------------------
+r9159 | iraikov | 2008-03-04 11:37:58 +0100 (Tue, 04 Mar 2008) | 2 lines
+
+Put back the -d (dont-ask) option.
+
+------------------------------------------------------------------------
+r9155 | felix | 2008-03-04 10:06:55 +0100 (Tue, 04 Mar 2008) | 1 line
+
+fixed bug in fprintf0; removed buildsvnrevision from repo to avoid conflicts; fixed bug in svnrevision.sh
+------------------------------------------------------------------------
+r9154 | iraikov | 2008-03-04 09:49:53 +0100 (Tue, 04 Mar 2008) | 2 lines
+
+Checking for the presence of svn in a sane way.
+
+------------------------------------------------------------------------
+r9149 | felix | 2008-03-03 13:03:29 +0100 (Mon, 03 Mar 2008) | 1 line
+
+bootstrap fix on mingw [by Andrei Ivushkin]
+------------------------------------------------------------------------
+r9133 | kon | 2008-02-29 18:18:10 +0100 (Fri, 29 Feb 2008) | 2 lines
+
+PCRE 7.6
+
+------------------------------------------------------------------------
+r9122 | iraikov | 2008-02-29 08:11:54 +0100 (Fri, 29 Feb 2008) | 2 lines
+
+Introduced option -install-prefix; supersedes -destdir.
+
+------------------------------------------------------------------------
+r9102 | ashley | 2008-02-28 17:08:05 +0100 (Thu, 28 Feb 2008) | 2 lines
+
+Modified README to note support (and issues with) for MSVC.
+
+------------------------------------------------------------------------
+r9099 | iraikov | 2008-02-28 14:37:27 +0100 (Thu, 28 Feb 2008) | 2 lines
+
+Removed use url declaration.
+
+------------------------------------------------------------------------
+r9098 | iraikov | 2008-02-28 14:27:35 +0100 (Thu, 28 Feb 2008) | 2 lines
+
+Go back to the start directory after a package is built.
+
+------------------------------------------------------------------------
+r9095 | iraikov | 2008-02-28 14:07:16 +0100 (Thu, 28 Feb 2008) | 2 lines
+
+Added a check for non-html, non-wiki documentation (e.g. eggdoc).
+
+------------------------------------------------------------------------
+r9092 | iraikov | 2008-02-28 13:59:55 +0100 (Thu, 28 Feb 2008) | 2 lines
+
+Small bugfix in dpkg-eggs
+
+------------------------------------------------------------------------
+r9091 | iraikov | 2008-02-28 13:54:25 +0100 (Thu, 28 Feb 2008) | 2 lines
+
+Copyright notice update.
+
+------------------------------------------------------------------------
+r9090 | iraikov | 2008-02-28 13:42:00 +0100 (Thu, 28 Feb 2008) | 3 lines
+
+Some updates to the Debian egg building stuff,
+so that documentation is automatically generated from the wiki.
+
+------------------------------------------------------------------------
+r9088 | iraikov | 2008-02-28 12:31:42 +0100 (Thu, 28 Feb 2008) | 2 lines
+
+Renamed enscript.scm to enscript-texinfo.
+
+------------------------------------------------------------------------
+r9087 | felix | 2008-02-28 11:50:58 +0100 (Thu, 28 Feb 2008) | 1 line
+
+bugfix in csc [thanks to Andrei Ivushkin]
+------------------------------------------------------------------------
+r9083 | iraikov | 2008-02-28 08:07:38 +0100 (Thu, 28 Feb 2008) | 2 lines
+
+Online help updates.
+
+------------------------------------------------------------------------
+r9082 | iraikov | 2008-02-28 07:44:36 +0100 (Thu, 28 Feb 2008) | 2 lines
+
+chicken-setup documentation updates.
+
+------------------------------------------------------------------------
+r9080 | iraikov | 2008-02-28 05:33:37 +0100 (Thu, 28 Feb 2008) | 2 lines
+
+Clarifications added in the documentation for options -R and -P.
+
+------------------------------------------------------------------------
+r9078 | iraikov | 2008-02-28 03:24:59 +0100 (Thu, 28 Feb 2008) | 2 lines
+
+Included Ashley Bone's patch to the MSVC build system.
+
+------------------------------------------------------------------------
+r9040 | kon | 2008-02-26 20:11:26 +0100 (Tue, 26 Feb 2008) | 2 lines
+
+Applied Jim Ursetto's tcp socket port write patch.
+
+------------------------------------------------------------------------
+r9022 | iraikov | 2008-02-26 11:20:40 +0100 (Tue, 26 Feb 2008) | 2 lines
+
+Egg build dir should be /tmp/..., not $HOME/...
+
+------------------------------------------------------------------------
+r9021 | iraikov | 2008-02-26 11:04:26 +0100 (Tue, 26 Feb 2008) | 2 lines
+
+Further tweaks to the selection of default build dir in chicken-setup
+
+------------------------------------------------------------------------
+r9017 | iraikov | 2008-02-26 08:25:18 +0100 (Tue, 26 Feb 2008) | 2 lines
+
+Added information about the updates to chicken-setup.
+
+------------------------------------------------------------------------
+r8901 | iraikov | 2008-02-25 14:26:42 +0100 (Mon, 25 Feb 2008) | 2 lines
+
+Removed unnecessary debug statements.
+
+------------------------------------------------------------------------
+r8898 | iraikov | 2008-02-25 13:50:59 +0100 (Mon, 25 Feb 2008) | 2 lines
+
+Added support for user-specified build directories.
+
+------------------------------------------------------------------------
+r8649 | felix | 2008-02-23 09:40:49 +0100 (Sat, 23 Feb 2008) | 1 line
+
+bumped version to 3.0.3, added entry in NEWS
+------------------------------------------------------------------------
+r8648 | felix | 2008-02-23 09:38:59 +0100 (Sat, 23 Feb 2008) | 1 line
+
+applied Jim's print-width patch with fix for proper parameter use
+------------------------------------------------------------------------
+r8647 | felix | 2008-02-23 09:22:28 +0100 (Sat, 23 Feb 2008) | 1 line
+
+added Ashley's msvc patch
+------------------------------------------------------------------------
+r8641 | kon | 2008-02-23 00:10:16 +0100 (Sat, 23 Feb 2008) | 2 lines
+
+Added flonum-print-precision.
+
+------------------------------------------------------------------------
+r8640 | felix | 2008-02-22 23:33:01 +0100 (Fri, 22 Feb 2008) | 1 line
+
+use MAP_ANON (MAP_ANONYMOUS not available on Darwin); use C_check_uintX and BITWISE_UINT_ONLY
+------------------------------------------------------------------------
+r8588 | felix | 2008-02-20 11:44:52 +0100 (Wed, 20 Feb 2008) | 5 lines
+
+- added overflow-detecting bitwise fixnum operations
+- fixed bug in c-backend that resulted in unaligned lambda-infos
+- bumped version to 3.0.2
+
+
+------------------------------------------------------------------------
+r8506 | kon | 2008-02-17 01:17:18 +0100 (Sun, 17 Feb 2008) | 2 lines
+
+Bug fix for "hash-table-set!" - wasn't, setting that is.
+
+------------------------------------------------------------------------
+r8505 | kon | 2008-02-17 00:41:48 +0100 (Sun, 17 Feb 2008) | 2 lines
+
+C_check_uintX used instead of C_check_uint for bitwise.
+
+------------------------------------------------------------------------
+r8504 | kon | 2008-02-17 00:11:29 +0100 (Sun, 17 Feb 2008) | 2 lines
+
+BITWISE_UINT_ONLY - not.
+
+------------------------------------------------------------------------
+r8468 | kon | 2008-02-14 17:10:04 +0100 (Thu, 14 Feb 2008) | 2 lines
+
+Removed MacOS 9 references - unsupported.
+
+------------------------------------------------------------------------
+r8457 | kon | 2008-02-13 19:24:49 +0100 (Wed, 13 Feb 2008) | 2 lines
+
+Cygwin has 'localtime' but no tm_zone member.
+
+------------------------------------------------------------------------
+r8456 | kon | 2008-02-13 18:43:59 +0100 (Wed, 13 Feb 2008) | 2 lines
+
+Cygwin has endian.h, timegm, localtime.
+
+------------------------------------------------------------------------
+r8430 | iraikov | 2008-02-13 05:23:51 +0100 (Wed, 13 Feb 2008) | 2 lines
+
+Now using the trunk/debian directory instead of latest/debian.
+
+------------------------------------------------------------------------
+r8410 | kon | 2008-02-12 11:01:50 +0100 (Tue, 12 Feb 2008) | 2 lines
+
+Moved wiki files to chicken trunk manual since using wrong files to document.
+
+------------------------------------------------------------------------
+r8408 | kon | 2008-02-12 09:44:01 +0100 (Tue, 12 Feb 2008) | 2 lines
+
+Removed macro versions of tm struct set/get.
+
+------------------------------------------------------------------------
+r8397 | kon | 2008-02-12 04:12:52 +0100 (Tue, 12 Feb 2008) | 2 lines
+
+Added chardefs make procedure.
+
+------------------------------------------------------------------------
+r8390 | kon | 2008-02-12 00:51:24 +0100 (Tue, 12 Feb 2008) | 2 lines
+
+Removed regex-extras. More ugliness for using the platfrom PCRE header files in regex.
+
+------------------------------------------------------------------------
+r8380 | kon | 2008-02-11 18:00:53 +0100 (Mon, 11 Feb 2008) | 2 lines
+
+Updated NEWS for new hash-table, hash, combinators, and time/string. Removed unused "false-thunk". Updated hashing comments. Added "none?", "always?", and "never?" to combinators. Fixed "hash-table-set!" so it returns "unspecified". Renamed "##sys#make-hash-table" to remove any indication of relation to the "##sys#hash-table-*" routines. Renamed "$other-number-hash" to "$non-fixnum-number-hash" to be specific.
+
+------------------------------------------------------------------------
+r8372 | iraikov | 2008-02-11 12:24:32 +0100 (Mon, 11 Feb 2008) | 2 lines
+
+Added option --exclude.
+
+------------------------------------------------------------------------
+r8368 | iraikov | 2008-02-11 11:21:23 +0100 (Mon, 11 Feb 2008) | 2 lines
+
+Fixed a bug in the ordering of release versions.
+
+------------------------------------------------------------------------
+r8366 | iraikov | 2008-02-11 10:45:45 +0100 (Mon, 11 Feb 2008) | 2 lines
+
+Added dpkg-eggs script.
+
+------------------------------------------------------------------------
+r8364 | iraikov | 2008-02-11 10:32:54 +0100 (Mon, 11 Feb 2008) | 2 lines
+
+Added back README.Debian in the main chicken source tree.
+
+------------------------------------------------------------------------
+r8363 | iraikov | 2008-02-11 10:29:22 +0100 (Mon, 11 Feb 2008) | 2 lines
+
+Removed unnecessary README.Debian files.
+
+------------------------------------------------------------------------
+r8361 | felix | 2008-02-11 10:13:54 +0100 (Mon, 11 Feb 2008) | 1 line
+
+probably fixed 64-bit literal bug and changed copyrights
+------------------------------------------------------------------------
+r8341 | iraikov | 2008-02-11 06:59:10 +0100 (Mon, 11 Feb 2008) | 2 lines
+
+A small fix to include ChangeLog.* in the Debian package.
+
+------------------------------------------------------------------------
+r8340 | iraikov | 2008-02-11 06:51:55 +0100 (Mon, 11 Feb 2008) | 2 lines
+
+Update of the Texinfo manual to 3.0.0
+
+------------------------------------------------------------------------
+r8339 | iraikov | 2008-02-11 06:51:14 +0100 (Mon, 11 Feb 2008) | 2 lines
+
+Added Texinfo variant of the enscript extension to maketexi.
+
+------------------------------------------------------------------------
+r8330 | kon | 2008-02-10 16:52:44 +0100 (Sun, 10 Feb 2008) | 2 lines
+
+Fix for non-0 term'd str use in 'string->time' & 'time->string'. [Thanks to Hans Bulfone for pointing it out]
+
+------------------------------------------------------------------------
+r8311 | kon | 2008-02-09 22:47:59 +0100 (Sat, 09 Feb 2008) | 2 lines
+
+Added left & right section to Combinators. Simple but useful.
+
+------------------------------------------------------------------------
+r8302 | iraikov | 2008-02-09 04:29:58 +0100 (Sat, 09 Feb 2008) | 2 lines
+
+Tested and comitted Frederick Akalin's patch.
+
+------------------------------------------------------------------------
+r8290 | ashinn | 2008-02-08 11:42:29 +0100 (Fri, 08 Feb 2008) | 2 lines
+
+releasing 0.8
+
+------------------------------------------------------------------------
+r8281 | kon | 2008-02-08 04:36:02 +0100 (Fri, 08 Feb 2008) | 2 lines
+
+8 space string in generic-write was collapsed with tab - me & my stupid editor.
+
+------------------------------------------------------------------------
+r8278 | kon | 2008-02-08 01:10:19 +0100 (Fri, 08 Feb 2008) | 2 lines
+
+Bug fixes for hash-table & hash. Added hash-table test to runtests.
+
+------------------------------------------------------------------------
+r8276 | zbigniew | 2008-02-07 20:12:17 +0100 (Thu, 07 Feb 2008) | 1 line
+
+Add MACOSX_DEPLOYMENT_TARGET to README for universal build
+------------------------------------------------------------------------
+r8275 | kon | 2008-02-07 17:17:55 +0100 (Thu, 07 Feb 2008) | 2 lines
+
+Use of tabs+spaces.
+
+------------------------------------------------------------------------
+r8235 | kon | 2008-02-07 02:10:10 +0100 (Thu, 07 Feb 2008) | 2 lines
+
+Bug fix for 'Error: (apply) bad argument type: #<procedure (f_10741)>' in hash-table-ref.
+
+------------------------------------------------------------------------
+r8205 | felix | 2008-02-06 15:02:21 +0100 (Wed, 06 Feb 2008) | 1 line
+
+merged bootstrapping tarball update
+------------------------------------------------------------------------
+r8198 | kon | 2008-02-06 09:42:20 +0100 (Wed, 06 Feb 2008) | 2 lines
+
+Merge of branches/felix
+
+------------------------------------------------------------------------
+r8197 | kon | 2008-02-06 09:15:52 +0100 (Wed, 06 Feb 2008) | 2 lines
+
+Added kon branch
+
+------------------------------------------------------------------------
+r8182 | kon | 2008-02-06 04:29:01 +0100 (Wed, 06 Feb 2008) | 2 lines
+
+Rplcd 'fprintf w/ loc in fprintf0.
+
+------------------------------------------------------------------------
+r8158 | zbigniew | 2008-02-05 22:38:16 +0100 (Tue, 05 Feb 2008) | 1 line
+
+fix minor readme typo (thx Andre Kuehne)
+------------------------------------------------------------------------
+r8157 | kon | 2008-02-05 18:57:36 +0100 (Tue, 05 Feb 2008) | 2 lines
+
+Rmvd ##sys#hash prefix.
+
+------------------------------------------------------------------------
+r8156 | felix | 2008-02-05 10:34:31 +0100 (Tue, 05 Feb 2008) | 1 line
+
+removed warning about unsupported literals (is caught later and certain literals are allowed anyway)
+------------------------------------------------------------------------
+r8155 | felix | 2008-02-05 09:01:47 +0100 (Tue, 05 Feb 2008) | 1 line
+
+refactored [sf]printf, non-tty port is buffered first (ticket #418)
+------------------------------------------------------------------------
+r8153 | kon | 2008-02-05 05:50:20 +0100 (Tue, 05 Feb 2008) | 2 lines
+
+SRFI-90-ish hash-tables.
+
+------------------------------------------------------------------------
+r8136 | felix | 2008-02-04 08:53:34 +0100 (Mon, 04 Feb 2008) | 1 line
+
+added missing revision file
+------------------------------------------------------------------------
+r8135 | zbigniew | 2008-02-04 08:16:45 +0100 (Mon, 04 Feb 2008) | 1 line
+
+buildsvnrevision fix
+------------------------------------------------------------------------
+r8134 | felix | 2008-02-04 07:24:04 +0100 (Mon, 04 Feb 2008) | 1 line
+
+set ddefault nursery size to 256k on x86-64 (suggested by Shawn W.); added missing svnrevision script
+------------------------------------------------------------------------
+r8133 | felix | 2008-02-04 07:16:37 +0100 (Mon, 04 Feb 2008) | 1 line
+
+svn revision is compiled into runtime
+------------------------------------------------------------------------
+r8078 | kon | 2008-02-02 22:37:24 +0100 (Sat, 02 Feb 2008) | 2 lines
+
+Added '(define ...)' for '(set! ...)' introduced identifiers.
+
+------------------------------------------------------------------------
+r8062 | felix | 2008-02-02 16:21:37 +0100 (Sat, 02 Feb 2008) | 1 line
+
+process-lambda-doc. is only called for global vars; removed nl after printing chicken banner
+------------------------------------------------------------------------
+r8030 | kon | 2008-02-01 18:57:37 +0100 (Fri, 01 Feb 2008) | 2 lines
+
+Fix for wrong errcod; should be C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR.
+
+------------------------------------------------------------------------
+r8029 | kon | 2008-02-01 18:02:09 +0100 (Fri, 01 Feb 2008) | 2 lines
+
+Added check inexact.
+
+------------------------------------------------------------------------
+r8027 | felix | 2008-02-01 10:27:44 +0100 (Fri, 01 Feb 2008) | 4 lines
+
+- bootstrapping chicken from svn defaults to "chicken" (not prefixed one)
+- better ##sys#process-lambda-documentation hook
+- "repository-path" uses "CHICKEN_PREFIX"
+
+------------------------------------------------------------------------
+r8024 | iraikov | 2008-02-01 06:20:26 +0100 (Fri, 01 Feb 2008) | 2 lines
+
+Added an entry for 3.0.0.
+
+------------------------------------------------------------------------
+r8004 | zbigniew | 2008-01-31 06:13:40 +0100 (Thu, 31 Jan 2008) | 1 line
+
+fix README typo (thx mbishop)
+------------------------------------------------------------------------
+r7985 | kon | 2008-01-29 21:05:40 +0100 (Tue, 29 Jan 2008) | 2 lines
+
+Made custom input port read-line not call out from ##sys#scan-buffer-line. Made C_ tm get/set since used many times.
+
+------------------------------------------------------------------------
+r7984 | kon | 2008-01-29 01:04:28 +0100 (Tue, 29 Jan 2008) | 2 lines
+
+Added optional format (strftime) to time->string. Added string->time (strptime); no Windows though.
+
+------------------------------------------------------------------------
+r7983 | kon | 2008-01-28 22:55:56 +0100 (Mon, 28 Jan 2008) | 2 lines
+
+Re-formatted C_ time macros so easier to read.
+
+------------------------------------------------------------------------
+r7972 | felix | 2008-01-28 14:34:27 +0100 (Mon, 28 Jan 2008) | 1 line
+
+replaced fix-gensyms script with simpler solution
+------------------------------------------------------------------------
+r7970 | felix | 2008-01-28 07:29:44 +0100 (Mon, 28 Jan 2008) | 1 line
+
+renamed misc directory and support file
+------------------------------------------------------------------------
+r7945 | kon | 2008-01-26 22:29:42 +0100 (Sat, 26 Jan 2008) | 2 lines
+
+Added flonum-print-precision procedure.
+
+------------------------------------------------------------------------
+r7938 | kon | 2008-01-26 00:56:02 +0100 (Sat, 26 Jan 2008) | 2 lines
+
+Fixed bug in absolute-pathname?, was not properly an anchored pattern when a drive is possible (Windows).
+
+------------------------------------------------------------------------
+r7936 | felix | 2008-01-26 00:38:42 +0100 (Sat, 26 Jan 2008) | 1 line
+
+renamed script again
+------------------------------------------------------------------------
+r7935 | felix | 2008-01-26 00:37:25 +0100 (Sat, 26 Jan 2008) | 1 line
+
+renamed merge script
+------------------------------------------------------------------------
+r7934 | felix | 2008-01-26 00:25:56 +0100 (Sat, 26 Jan 2008) | 1 line
+
+added missing files to distribution/manifest
+------------------------------------------------------------------------
+r7933 | felix | 2008-01-25 23:54:28 +0100 (Fri, 25 Jan 2008) | 1 line
+
+bootstrap change (no automatic rebuild after building chicken-boot)
+------------------------------------------------------------------------
+r7929 | kon | 2008-01-25 18:21:01 +0100 (Fri, 25 Jan 2008) | 2 lines
+
+Added closure bad argument checking support. Added proc test to 'make-hash-table'.
+
+------------------------------------------------------------------------
+r7921 | elf | 2008-01-24 11:23:49 +0100 (Thu, 24 Jan 2008) | 4 lines
+
+
+reverted to 7870, ie just before i started mucking with it.
+
+
+------------------------------------------------------------------------
+r7917 | felix | 2008-01-24 08:51:00 +0100 (Thu, 24 Jan 2008) | 1 line
+
+added stub for get_tty_size for platforms where it is not available
+------------------------------------------------------------------------
+r7916 | felix | 2008-01-24 08:50:04 +0100 (Thu, 24 Jan 2008) | 1 line
+
+bumped version to 3.0.1
+------------------------------------------------------------------------
+r7915 | elf | 2008-01-24 07:27:34 +0100 (Thu, 24 Jan 2008) | 5 lines
+
+
+a fix for the srfi-1 requirement in case-lambda, as well as removing the
+dependency on the eval unit, i believe.
+
+
+------------------------------------------------------------------------
+r7901 | kon | 2008-01-23 23:50:46 +0100 (Wed, 23 Jan 2008) | 2 lines
+
+In '_make-pathname' the 'dir' variable is always a string so the truth test is not rqrd.
+
+------------------------------------------------------------------------
+r7900 | kon | 2008-01-23 23:43:43 +0100 (Wed, 23 Jan 2008) | 2 lines
+
+Fixed use of boolean valued 'pds' in 'make-absolute-pathname' - '##sys#string-append' wants only strings.
+
+------------------------------------------------------------------------
+r7899 | elf | 2008-01-23 23:36:40 +0100 (Wed, 23 Jan 2008) | 5 lines
+
+
+##current-line -> #!current-line
+##current-file -> #!current-file
+
+
+------------------------------------------------------------------------
+r7898 | elf | 2008-01-23 23:20:34 +0100 (Wed, 23 Jan 2008) | 7 lines
+
+
+a fix so the r4rs tester wont fail on differing gensyms. fix-gensyms.scm is
+a script with no dependencies that finds all gensyms and renumbers them in
+order. runtests.sh now calls fix-gensyms.scm on r4rstest.out and r4rstest.log
+before doing the diff. (the diff caused massive test failure.)
+
+
+------------------------------------------------------------------------
+r7879 | elf | 2008-01-23 16:59:04 +0100 (Wed, 23 Jan 2008) | 4 lines
+
+
+let->let*
+
+
+------------------------------------------------------------------------
+r7878 | elf | 2008-01-23 15:18:16 +0100 (Wed, 23 Jan 2008) | 4 lines
+
+
+forgot to add this. if-condition for simple condition catching.
+
+
+------------------------------------------------------------------------
+r7877 | elf | 2008-01-23 14:44:26 +0100 (Wed, 23 Jan 2008) | 5 lines
+
+
+made the optimisation i suggested in the previous diff for the new reader
+syntax.
+
+
+------------------------------------------------------------------------
+r7876 | elf | 2008-01-23 14:27:06 +0100 (Wed, 23 Jan 2008) | 6 lines
+
+
+added special reader tokens: ##current-line and ##current-file
+i make no claims as to the efficiency. they should probably be moved into
+the following clause to avoid penalising most lookups.
+
+
+------------------------------------------------------------------------
+r7871 | elf | 2008-01-23 08:48:49 +0100 (Wed, 23 Jan 2008) | 10 lines
+
+
+added else clause to condition-case with the following format:
+(else <lambda-list> <body> ...)
+where lambda-list is a lambda list (or var) bound to the value(s) of the
+test case, and <body> ... is the code to be executed in that context.
+
+this allows cleaner handling of exceptions, removing the need for special
+values as caught error outputs.
+
+
+------------------------------------------------------------------------
+r7864 | felix | 2008-01-22 23:52:14 +0100 (Tue, 22 Jan 2008) | 1 line
+
+fixed uses of time->string and seconds->string (no trailing newline)
+------------------------------------------------------------------------
+r7844 | felix | 2008-01-22 13:33:34 +0100 (Tue, 22 Jan 2008) | 1 line
+
+applied Ivan Shmakov's mmap() patch
+------------------------------------------------------------------------
+r7839 | felix | 2008-01-22 09:36:51 +0100 (Tue, 22 Jan 2008) | 1 line
+
+updated bootstrap tarball, cond-expand is available to base expander
+------------------------------------------------------------------------
+r7835 | kon | 2008-01-22 02:29:41 +0100 (Tue, 22 Jan 2008) | 2 lines
+
+Added numerator & denominator for fix & flo.
+
+------------------------------------------------------------------------
+r7829 | sjamaan | 2008-01-21 23:06:24 +0100 (Mon, 21 Jan 2008) | 2 lines
+
+Add apply-hack for SPARC64 (SYSV)
+
+------------------------------------------------------------------------
+r7809 | felix | 2008-01-21 03:54:07 +0100 (Mon, 21 Jan 2008) | 1 line
+
+updated to refer to rrb3
+------------------------------------------------------------------------
+r7801 | felix | 2008-01-20 19:44:56 +0100 (Sun, 20 Jan 2008) | 1 line
+
+fixed bug in read-line special casing (again. again thanks to Mario)
+------------------------------------------------------------------------
+r7794 | felix | 2008-01-19 20:49:05 +0100 (Sat, 19 Jan 2008) | 1 line
+
+fixed bug in read-line support code in library [Thanks to Mario]
+------------------------------------------------------------------------
+r7784 | felix | 2008-01-19 16:09:32 +0100 (Sat, 19 Jan 2008) | 5 lines
+
+- possibly fixed li-alignment problem for non-gcc compilers
+- updated acknowledgements
+- posixunix includes <sys/tty.h> on Solaris [Thanks to Brad Watson]
+
+
+------------------------------------------------------------------------
+r7778 | felix | 2008-01-18 12:43:49 +0100 (Fri, 18 Jan 2008) | 1 line
+
+updated bootstrapping tarball
+------------------------------------------------------------------------
+r7777 | felix | 2008-01-18 12:23:34 +0100 (Fri, 18 Jan 2008) | 1 line
+
+fixed tests, alignment problem with lambdainfo solved (gcc only)
+------------------------------------------------------------------------
+r7776 | felix | 2008-01-18 11:21:10 +0100 (Fri, 18 Jan 2008) | 1 line
+
+more read-line bugfixes; updated copyright date; added port test
+------------------------------------------------------------------------
+r7775 | felix | 2008-01-18 09:51:15 +0100 (Fri, 18 Jan 2008) | 1 line
+
+fixed bug in special-casing of read-line for string ports [Thanks to Alex Shinn]
+------------------------------------------------------------------------
+r7774 | ashinn | 2008-01-18 05:40:37 +0100 (Fri, 18 Jan 2008) | 2 lines
+
+version 0.7, higher-order types and smart strings
+
+------------------------------------------------------------------------
+r7773 | zbigniew | 2008-01-18 05:14:17 +0100 (Fri, 18 Jan 2008) | 1 line
+
+Enable universal binary support on OS X
+------------------------------------------------------------------------
+r7772 | felix | 2008-01-17 18:25:24 +0100 (Thu, 17 Jan 2008) | 1 line
+
+documented -p and -P csi options in manual
+------------------------------------------------------------------------
+r7770 | felix | 2008-01-17 12:45:15 +0100 (Thu, 17 Jan 2008) | 1 line
+
+added -p and -P options to csi
+------------------------------------------------------------------------
+r7765 | felix | 2008-01-16 20:45:21 +0100 (Wed, 16 Jan 2008) | 1 line
+
+updated NEWS
+------------------------------------------------------------------------
+r7764 | felix | 2008-01-16 20:32:57 +0100 (Wed, 16 Jan 2008) | 1 line
+
+applied 3.0.0rc1/repobranches patch; fixed small bug in defaults.make
+------------------------------------------------------------------------
+r7364 | felix | 2008-01-16 10:44:09 +0100 (Wed, 16 Jan 2008) | 1 line
+
+accepts unspecified value as valid literal [thanks to Alex Shinn]
+------------------------------------------------------------------------
+r7360 | felix | 2008-01-16 04:13:38 +0100 (Wed, 16 Jan 2008) | 1 line
+
+libchickengui wasn't installed in bin directory
+------------------------------------------------------------------------
+r7350 | iraikov | 2008-01-15 02:00:17 +0100 (Tue, 15 Jan 2008) | 2 lines
+
+Committed Ivan Shmakov's cosmetic improvements.
+
+------------------------------------------------------------------------
+r7339 | felix | 2008-01-12 17:12:03 +0100 (Sat, 12 Jan 2008) | 1 line
+
+initing gc_root_list in declaration
+------------------------------------------------------------------------
+r7338 | felix | 2008-01-11 22:00:19 +0100 (Fri, 11 Jan 2008) | 1 line
+
+error-handler expected stream port for ##sys#standard-error
+------------------------------------------------------------------------
+r7334 | felix | 2008-01-10 15:49:06 +0100 (Thu, 10 Jan 2008) | 1 line
+
+removed -check from chicken-setup manpage [Thanks to Jürgen Lorentz]
+------------------------------------------------------------------------
+r7333 | felix | 2008-01-10 10:43:42 +0100 (Thu, 10 Jan 2008) | 1 line
+
+bumped version to 2.741
+------------------------------------------------------------------------
+r7331 | felix | 2008-01-10 10:23:10 +0100 (Thu, 10 Jan 2008) | 1 line
+
+fixed bug in cross-linux-mingw makefile [Thanks to Mario]
+------------------------------------------------------------------------
+r7325 | felix | 2008-01-09 08:48:52 +0100 (Wed, 09 Jan 2008) | 1 line
+
+moved PCRE check into defaults.make
+------------------------------------------------------------------------
+r7309 | felix | 2008-01-08 13:41:49 +0100 (Tue, 08 Jan 2008) | 1 line
+
+use USE_HOST_PCRE to use host pcre (grumble)
+------------------------------------------------------------------------
+r7307 | felix | 2008-01-08 09:04:25 +0100 (Tue, 08 Jan 2008) | 1 line
+
+fixed bug in blob=?
+------------------------------------------------------------------------
+r7306 | felix | 2008-01-08 08:55:43 +0100 (Tue, 08 Jan 2008) | 1 line
+
+added blob=?
+------------------------------------------------------------------------
+r7298 | felix | 2008-01-07 08:36:43 +0100 (Mon, 07 Jan 2008) | 1 line
+
+csi uses command-line-arguments instead of argv when constructing the final command line arguments passed to a script
+------------------------------------------------------------------------
+r7295 | felix | 2008-01-07 07:18:58 +0100 (Mon, 07 Jan 2008) | 1 line
+
+csi removes runtime-options from command-line-arguments, even if following -- or -script options
+------------------------------------------------------------------------
+r7293 | felix | 2008-01-07 05:27:44 +0100 (Mon, 07 Jan 2008) | 1 line
+
+added Alex' patch
+------------------------------------------------------------------------
+r7282 | ashinn | 2008-01-06 05:43:42 +0100 (Sun, 06 Jan 2008) | 2 lines
+
+Checking in version 0.6.
+
+------------------------------------------------------------------------
+r7278 | felix | 2008-01-05 20:23:14 +0100 (Sat, 05 Jan 2008) | 1 line
+
+set version to 2.740
+------------------------------------------------------------------------
+r7277 | felix | 2008-01-05 20:19:11 +0100 (Sat, 05 Jan 2008) | 1 line
+
+updated NEWS once again
+------------------------------------------------------------------------
+r7275 | felix | 2008-01-05 20:16:54 +0100 (Sat, 05 Jan 2008) | 1 line
+
+updated NEWS
+------------------------------------------------------------------------
+r7274 | felix | 2008-01-05 19:52:52 +0100 (Sat, 05 Jan 2008) | 1 line
+
+trivial changes
+------------------------------------------------------------------------
+r7233 | felix | 2008-01-02 00:55:38 +0100 (Wed, 02 Jan 2008) | 1 line
+
+install_name_tool fix (cross build)
+------------------------------------------------------------------------
+r7229 | felix | 2007-12-30 23:25:25 +0100 (Sun, 30 Dec 2007) | 1 line
+
+converted repobranches-3.0.0 branch into patch
+------------------------------------------------------------------------
+r7228 | felix | 2007-12-30 22:45:39 +0100 (Sun, 30 Dec 2007) | 1 line
+
+csc invokes install_name_tool on OS X; installation of import lib for libchickengui was missing
+------------------------------------------------------------------------
+r7217 | felix | 2007-12-28 12:37:04 +0100 (Fri, 28 Dec 2007) | 1 line
+
+added note about bootstrapping tarball to README
+------------------------------------------------------------------------
+r7216 | felix | 2007-12-28 00:09:38 +0100 (Fri, 28 Dec 2007) | 1 line
+
+resolved conflict
+------------------------------------------------------------------------
+r7215 | felix | 2007-12-27 23:31:44 +0100 (Thu, 27 Dec 2007) | 1 line
+
+fixed bootstrapping make rules
+------------------------------------------------------------------------
+r7213 | felix | 2007-12-27 22:39:56 +0100 (Thu, 27 Dec 2007) | 1 line
+
+added bootstrapping tarball and make targets
+------------------------------------------------------------------------
+r7189 | felix | 2007-12-23 01:05:41 +0100 (Sun, 23 Dec 2007) | 1 line
+
+terminal-size procedure and chicken-setup egg list improvements by Shawn Wagner
+------------------------------------------------------------------------
+r7188 | felix | 2007-12-23 00:40:21 +0100 (Sun, 23 Dec 2007) | 1 line
+
+re-added bugfix that got nuked by merge. Damn.
+------------------------------------------------------------------------
+r7187 | felix | 2007-12-23 00:22:11 +0100 (Sun, 23 Dec 2007) | 1 line
+
+mingw makefile fix; other mingw-makefile fixes by Mario; added thread-wait-for-i/o<bang>
+------------------------------------------------------------------------
+r7182 | felix | 2007-12-21 11:06:46 +0100 (Fri, 21 Dec 2007) | 1 line
+
+removed use obsolete C-level qualifier
+------------------------------------------------------------------------
+r7181 | felix | 2007-12-21 08:45:32 +0100 (Fri, 21 Dec 2007) | 1 line
+
+fixed make-pathname
+------------------------------------------------------------------------
+r7180 | felix | 2007-12-21 07:50:11 +0100 (Fri, 21 Dec 2007) | 8 lines
+
+- removed CHICKEN_HOME
+- ##sys#pathname-directory-separator isn't used anymore, the slash is now used
+ everywhere
+- fixed some minor mingw issues
+- bumped version
+- dlls are installed in BINDIR on mingw32
+
+
+------------------------------------------------------------------------
+r7177 | felix | 2007-12-20 15:08:44 +0100 (Thu, 20 Dec 2007) | 1 line
+
+C string literals encode characters 126 and 127 in octal
+------------------------------------------------------------------------
+r7172 | felix | 2007-12-19 13:37:07 +0100 (Wed, 19 Dec 2007) | 1 line
+
+minor corrections [suggested by Sven Hartrumpf]
+------------------------------------------------------------------------
+r7169 | zbigniew | 2007-12-19 09:23:10 +0100 (Wed, 19 Dec 2007) | 1 line
+
+fix tab issues in chicken README
+------------------------------------------------------------------------
+r7168 | zbigniew | 2007-12-19 09:18:03 +0100 (Wed, 19 Dec 2007) | 1 line
+
+Add Mac OS X 64-bit make instructions to Chicken README
+------------------------------------------------------------------------
+r7167 | felix | 2007-12-19 08:21:07 +0100 (Wed, 19 Dec 2007) | 1 line
+
+merged encoded literals branch
+------------------------------------------------------------------------
+r7145 | felix | 2007-12-17 09:26:09 +0100 (Mon, 17 Dec 2007) | 1 line
+
+fixed bug in expansion of make macro [reported by Rick Taube]
+------------------------------------------------------------------------
+r7129 | felix | 2007-12-14 14:23:46 +0100 (Fri, 14 Dec 2007) | 1 line
+
+-q in csi disables call-trace info
+------------------------------------------------------------------------
+r7084 | felix | 2007-12-11 15:10:44 +0100 (Tue, 11 Dec 2007) | 1 line
+
+fixed bug in chicken-setup (make argv format) [Thanks to Mario]
+------------------------------------------------------------------------
+r7081 | felix | 2007-12-11 09:41:05 +0100 (Tue, 11 Dec 2007) | 1 line
+
+manual version is updated automatically, too
+------------------------------------------------------------------------
+r7080 | felix | 2007-12-11 09:35:15 +0100 (Tue, 11 Dec 2007) | 1 line
+
+bumped version to 2.737
+------------------------------------------------------------------------
+r7078 | felix | 2007-12-11 08:10:10 +0100 (Tue, 11 Dec 2007) | 1 line
+
+C_callback_adjust_stack_limits didnt take object size into account [Thanks to Todd Ingalls and Rick Taube]
+------------------------------------------------------------------------
+r7077 | zbigniew | 2007-12-11 04:23:44 +0100 (Tue, 11 Dec 2007) | 1 line
+
+Add C_{INSTALL,TARGET}_LDFLAGS to cygwin and mingw Makefiles
+------------------------------------------------------------------------
+r7076 | felix | 2007-12-10 12:11:06 +0100 (Mon, 10 Dec 2007) | 1 line
+
+ws2_32 lib was not linked in cross Makefile
+------------------------------------------------------------------------
+r7074 | felix | 2007-12-10 08:44:37 +0100 (Mon, 10 Dec 2007) | 1 line
+
+DESTDIR is used in addition to PREFIX, not as an alternative
+------------------------------------------------------------------------
+r7053 | felix | 2007-12-08 09:53:33 +0100 (Sat, 08 Dec 2007) | 1 line
+
+invalid expansion of make macro with missing argv
+------------------------------------------------------------------------
+r7044 | zbigniew | 2007-12-07 00:11:42 +0100 (Fri, 07 Dec 2007) | 1 line
+
+Add x86-64 support for OS X.
+------------------------------------------------------------------------
+r7036 | felix | 2007-12-06 08:48:16 +0100 (Thu, 06 Dec 2007) | 1 line
+
+merged wiki into manual; added pre-gc hook and gc-hook test
+------------------------------------------------------------------------
+r7031 | iraikov | 2007-12-05 14:29:01 +0100 (Wed, 05 Dec 2007) | 3 lines
+
+Added some explanations about the makefile variable settings used to
+build the Debian package.
+
+------------------------------------------------------------------------
+r7018 | felix | 2007-12-03 13:45:07 +0100 (Mon, 03 Dec 2007) | 1 line
+
+elf suggested putting quotes around the port name, when printing it
+------------------------------------------------------------------------
+r7017 | felix | 2007-12-03 12:15:53 +0100 (Mon, 03 Dec 2007) | 1 line
+
+some feedback after Ctrl-D in chicken-bug
+------------------------------------------------------------------------
+r6999 | iraikov | 2007-12-02 09:57:35 +0100 (Sun, 02 Dec 2007) | 2 lines
+
+Added an entry for 2.732
+
+------------------------------------------------------------------------
+r6991 | elf | 2007-12-01 12:56:44 +0100 (Sat, 01 Dec 2007) | 6 lines
+
+
+working mailer. tested from linux. uses no platform dependent libraries,
+period. straight tcp. mails to the chicken-janitors list automatically now,
+with fallback to previous behaviour.
+
+
+------------------------------------------------------------------------
+r6990 | elf | 2007-12-01 12:39:28 +0100 (Sat, 01 Dec 2007) | 1 line
+
+port25 is blocked locally so i cant test this outside of mail failure behaviour, which works fine. need to commit it in order to test from another machine.
+------------------------------------------------------------------------
+r6980 | iraikov | 2007-12-01 07:42:33 +0100 (Sat, 01 Dec 2007) | 2 lines
+
+Added options for Debian makeinfo.
+
+------------------------------------------------------------------------
+r6978 | iraikov | 2007-12-01 06:43:36 +0100 (Sat, 01 Dec 2007) | 2 lines
+
+Changed sharedir to be $(PREFIX)/share.
+
+------------------------------------------------------------------------
+r6967 | elf | 2007-11-30 21:44:45 +0100 (Fri, 30 Nov 2007) | 1 line
+
+updated the readme with current data. updated rules.make so that mingw can install. verified to build and run correctly for the following targets: linux, mingw, cygwin.
+------------------------------------------------------------------------
+r6966 | elf | 2007-11-30 21:33:57 +0100 (Fri, 30 Nov 2007) | 1 line
+
+added README data about cygwin. fixed a premature endif that broke mingw installation.
+------------------------------------------------------------------------
+r6965 | elf | 2007-11-30 20:49:19 +0100 (Fri, 30 Nov 2007) | 1 line
+
+minor update to reflect cygwin presence and requirements.
+------------------------------------------------------------------------
+r6964 | elf | 2007-11-30 20:34:32 +0100 (Fri, 30 Nov 2007) | 1 line
+
+minor errors: typo (no space after ifdef) and felix left an endif in the cygwin makefile with no if :)
+------------------------------------------------------------------------
+r6963 | elf | 2007-11-30 20:19:59 +0100 (Fri, 30 Nov 2007) | 1 line
+
+changes: cygwin dynamic library compilation is not compatible with any other system. handled the cygwin case specially in rules.make. separated each non-wildcard multi-file install into separate lines as windows copy command is incapable of handling multiple files correctly (which means mingw make install fails). fixed and ifdefed LIBCHICKEN_SO_FILE and PRIMARY_LIBCHICKEN (had ?= where there should be = and didnt handle the case properly regardless). i will test this on mingw, cygwin, and linux - the changes are not yet tested.
+------------------------------------------------------------------------
+r6911 | felix | 2007-11-26 09:06:34 +0100 (Mon, 26 Nov 2007) | 1 line
+
+more cygwin fixed by elf
+------------------------------------------------------------------------
+r6910 | felix | 2007-11-26 07:18:52 +0100 (Mon, 26 Nov 2007) | 1 line
+
+removed srfi-1 dependency from match unit; compiler-generated files should be wordsize independent, now
+------------------------------------------------------------------------
+r6892 | felix | 2007-11-23 11:53:30 +0100 (Fri, 23 Nov 2007) | 1 line
+
+some currently unused files
+------------------------------------------------------------------------
+r6891 | felix | 2007-11-23 11:47:04 +0100 (Fri, 23 Nov 2007) | 1 line
+
+various fixes in the cygwin makefile [thanks to elf]
+------------------------------------------------------------------------
+r6889 | iraikov | 2007-11-22 05:04:27 +0100 (Thu, 22 Nov 2007) | 2 lines
+
+Updated binary compatibility version to 3.
+
+------------------------------------------------------------------------
+r6885 | felix | 2007-11-20 13:01:46 +0100 (Tue, 20 Nov 2007) | 1 line
+
+removal of deprecated features
+------------------------------------------------------------------------
+r6877 | felix | 2007-11-19 07:18:54 +0100 (Mon, 19 Nov 2007) | 1 line
+
+fullcheck does normal check first
+------------------------------------------------------------------------
+r6876 | felix | 2007-11-19 07:16:19 +0100 (Mon, 19 Nov 2007) | 1 line
+
+fullcheck target performs 3-stage bootstrap
+------------------------------------------------------------------------
+r6874 | felix | 2007-11-19 05:44:50 +0100 (Mon, 19 Nov 2007) | 1 line
+
+added static linking option
+------------------------------------------------------------------------
+r6869 | felix | 2007-11-16 15:07:15 +0100 (Fri, 16 Nov 2007) | 1 line
+
+separate chicken-rebuild on check
+------------------------------------------------------------------------
+r6864 | felix | 2007-11-16 13:27:20 +0100 (Fri, 16 Nov 2007) | 1 line
+
+check runs chicken-bootstrap; wrong name of private-namespace.scm in distmanifest; fixed makefile bug
+------------------------------------------------------------------------
+r6862 | felix | 2007-11-16 09:35:08 +0100 (Fri, 16 Nov 2007) | 1 line
+
+fixed broken error check for inline funcs
+------------------------------------------------------------------------
+r6839 | felix | 2007-11-15 11:09:16 +0100 (Thu, 15 Nov 2007) | 1 line
+
+inline-recursions is handled [reported by elf]; removed some deprecated features (see NEWS)
+------------------------------------------------------------------------
+r6829 | felix | 2007-11-14 13:34:32 +0100 (Wed, 14 Nov 2007) | 1 line
+
+added relinking-on-installation support - not tested whether this breaks anything in other builds
+------------------------------------------------------------------------
+r6828 | felix | 2007-11-14 11:01:11 +0100 (Wed, 14 Nov 2007) | 1 line
+
+updated scheme-complete; removed uses of andmap and ormap (both are deprecated, now)
+------------------------------------------------------------------------
+r6827 | felix | 2007-11-14 09:26:13 +0100 (Wed, 14 Nov 2007) | 4 lines
+
+- defaults.make: fixed broken occurrence of HOST_C_COMPILER
+- added private-namespace.scm, removed unspeakable namespace hack (and supporting code)
+
+
+------------------------------------------------------------------------
+r6811 | felix | 2007-11-12 16:19:59 +0100 (Mon, 12 Nov 2007) | 1 line
+
+fixed silly bug in C_double_to_number [thanks to Peter Bex]
+------------------------------------------------------------------------
+r6780 | kon | 2007-11-09 23:34:58 +0100 (Fri, 09 Nov 2007) | 2 lines
+
+Update rules.make uninstall target for correct CHICKEN_BUG_PROGRAM variable, added infodir for uninstall info, added windows rmv csibatch.bat.
+
+------------------------------------------------------------------------
+r6753 | felix | 2007-11-08 09:16:25 +0100 (Thu, 08 Nov 2007) | 1 line
+
+renamed TARGET/HOST to TARGETSYSTEM/HOSTSYSTEM to avoid clashes with predefined env vars [Thanks to Benedikt Rosenau]
+------------------------------------------------------------------------
+r6709 | felix | 2007-11-07 15:27:39 +0100 (Wed, 07 Nov 2007) | 1 line
+
+cleanups in the makefiles; dist and libs targets in toplevel makefile
+------------------------------------------------------------------------
+r6707 | felix | 2007-11-07 08:33:05 +0100 (Wed, 07 Nov 2007) | 1 line
+
+removed ecos stuff from posixunix.scm; dist target for toplevel Makefile; locked tospace fudge flag and feature in version string
+------------------------------------------------------------------------
+r6694 | felix | 2007-11-06 13:49:59 +0100 (Tue, 06 Nov 2007) | 1 line
+
+fixed buggy frees of aligned heapspace pointers
+------------------------------------------------------------------------
+r6693 | felix | 2007-11-06 13:17:07 +0100 (Tue, 06 Nov 2007) | 1 line
+
+updated NEWS
+------------------------------------------------------------------------
+r6692 | felix | 2007-11-06 11:31:20 +0100 (Tue, 06 Nov 2007) | 1 line
+
+bumped version
+------------------------------------------------------------------------
+r6691 | felix | 2007-11-06 11:30:02 +0100 (Tue, 06 Nov 2007) | 1 line
+
+syncd manual (with better sync-from-wiki); added experimental support for tospace locking
+------------------------------------------------------------------------
+r6688 | felix | 2007-11-06 08:12:53 +0100 (Tue, 06 Nov 2007) | 4 lines
+
+- file-size result for "file-size" and "file-stat" should handle 64-bit off_t, now
+ [Thanks to Sjaaman, Zbigniew and certainty]
+- added more clever result conversion for "integer64" type
+
+------------------------------------------------------------------------
+r6669 | felix | 2007-11-05 07:23:47 +0100 (Mon, 05 Nov 2007) | 5 lines
+
+- chicken-setup: -create-tree option
+- incorporated Ivan Shmakovs simplifications for rules.make
+- small fixes, cross-compilation improvements
+
+
+------------------------------------------------------------------------
+r6638 | felix | 2007-11-01 13:12:08 +0100 (Thu, 01 Nov 2007) | 1 line
+
+no -p for mkdir on mingw w/o msys
+------------------------------------------------------------------------
+r6578 | felix | 2007-10-30 12:26:48 +0100 (Tue, 30 Oct 2007) | 1 line
+
+cygwin makefile was missing from distro [thanks, elf]
+------------------------------------------------------------------------
+r6576 | felix | 2007-10-30 10:52:55 +0100 (Tue, 30 Oct 2007) | 1 line
+
+fixed some buildsystem bugs reported by Markus Huelsmann; documented PROGRAM_PREFIX and _SUFFIX
+------------------------------------------------------------------------
+r6575 | felix | 2007-10-29 15:20:35 +0100 (Mon, 29 Oct 2007) | 1 line
+
+program map was incorrect
+------------------------------------------------------------------------
+r6569 | felix | 2007-10-29 11:17:21 +0100 (Mon, 29 Oct 2007) | 1 line
+
+variable executable names; some makefile cleanup
+------------------------------------------------------------------------
+r6526 | felix | 2007-10-25 13:57:53 +0200 (Thu, 25 Oct 2007) | 1 line
+
+makefile fix and added missing tests to tarball [thanks to elf]
+------------------------------------------------------------------------
+r6522 | felix | 2007-10-25 07:46:05 +0200 (Thu, 25 Oct 2007) | 1 line
+
+replaced use of cat with type in mingw makefile [Thanks to Don]
+------------------------------------------------------------------------
+r6520 | felix | 2007-10-24 11:23:00 +0200 (Wed, 24 Oct 2007) | 1 line
+
+fixed various makefile bugs; install-libs target; version is 2.728
+------------------------------------------------------------------------
+r6496 | mario | 2007-10-22 19:05:17 +0200 (Mon, 22 Oct 2007) | 2 lines
+
+"install on" instead of "install in".
+
+------------------------------------------------------------------------
+r6495 | mario | 2007-10-22 18:41:43 +0200 (Mon, 22 Oct 2007) | 2 lines
+
+Small typo fix.
+
+------------------------------------------------------------------------
+r6492 | sven | 2007-10-22 14:51:48 +0200 (Mon, 22 Oct 2007) | 2 lines
+
+removed 1 occurrence of plists.scm
+
+------------------------------------------------------------------------
+r6489 | felix | 2007-10-22 09:37:40 +0200 (Mon, 22 Oct 2007) | 1 line
+
+removed plists.scm from distro manifest
+------------------------------------------------------------------------
+r6488 | felix | 2007-10-22 07:49:19 +0200 (Mon, 22 Oct 2007) | 4 lines
+
+- fixed bug in C_apply (uninit'd variable in unsafe runtime lib)
+- benchmarks use built-in plists, now
+
+
+------------------------------------------------------------------------
+r6479 | felix | 2007-10-21 19:55:42 +0200 (Sun, 21 Oct 2007) | 1 line
+
+added note in README about passing CHICKEN setting to make when bootstrapping [thanks to Rick Taube]
+------------------------------------------------------------------------
+r6439 | felix | 2007-10-18 13:12:35 +0200 (Thu, 18 Oct 2007) | 1 line
+
+chicken-profile selects newest PROFILE.<pid>
+------------------------------------------------------------------------
+r6428 | kon | 2007-10-17 19:59:37 +0200 (Wed, 17 Oct 2007) | 2 lines
+
+srfi-12 is ok.
+
+------------------------------------------------------------------------
+r6424 | felix | 2007-10-17 14:20:40 +0200 (Wed, 17 Oct 2007) | 1 line
+
+another makefile fix by Alex Q.
+------------------------------------------------------------------------
+r6423 | felix | 2007-10-17 08:14:08 +0200 (Wed, 17 Oct 2007) | 1 line
+
+info installation fix by Eugene Ossintsev; PROFILE file has PID as extension (suggested by Robin Lee Powell)
+------------------------------------------------------------------------
+r6422 | felix | 2007-10-17 07:56:34 +0200 (Wed, 17 Oct 2007) | 1 line
+
+fix for mingw makefile (location of def. of CUSTOM_CHICKEN_DEFAULTS)
+------------------------------------------------------------------------
+r6421 | felix | 2007-10-17 07:52:46 +0200 (Wed, 17 Oct 2007) | 1 line
+
+incorporated Alex Queiroz' patch for mingw without msys
+------------------------------------------------------------------------
+r6385 | kon | 2007-10-13 03:01:16 +0200 (Sat, 13 Oct 2007) | 2 lines
+
+Opps, 8 space tabs.
+
+------------------------------------------------------------------------
+r6382 | kon | 2007-10-12 17:37:45 +0200 (Fri, 12 Oct 2007) | 2 lines
+
+sys immediate is macro. canon form for C in posixwin. began user info.
+
+------------------------------------------------------------------------
+r6381 | felix | 2007-10-12 08:09:30 +0200 (Fri, 12 Oct 2007) | 1 line
+
+fixed bug in program-name, when running in an embedded app [Thanks to Todd Ingalls]
+------------------------------------------------------------------------
+r6376 | kon | 2007-10-11 20:47:10 +0200 (Thu, 11 Oct 2007) | 2 lines
+
+Forgot new files must be in manifest. Added 'current-user-name' function to windows & unix posix.
+
+------------------------------------------------------------------------
+r6363 | kon | 2007-10-10 20:28:12 +0200 (Wed, 10 Oct 2007) | 2 lines
+
+Added sys macros. Made %hash an exported sys namespace identifier.
+
+------------------------------------------------------------------------
+r6325 | felix | 2007-10-09 07:17:40 +0200 (Tue, 09 Oct 2007) | 1 line
+
+initial ptable was one too short; found thanks to valgrind
+------------------------------------------------------------------------
+r6297 | sjamaan | 2007-10-05 18:11:34 +0200 (Fri, 05 Oct 2007) | 4 lines
+
+__powerpc__ is defined on NetBSD, not __ppc__, resulting in a
+"netbsd-unix-gnu-unknown" arch. Add __powerpc__ to the list in
+C_machine_type.
+
+------------------------------------------------------------------------
+r6292 | felix | 2007-10-05 10:44:28 +0200 (Fri, 05 Oct 2007) | 1 line
+
+chicken-setup: try-compile did not pass linker path and libraries to compiler
+------------------------------------------------------------------------
+r6291 | felix | 2007-10-05 09:29:03 +0200 (Fri, 05 Oct 2007) | 1 line
+
+thread timed out while waiting for I/O could leave scheduler fd set in inconsistent state
+------------------------------------------------------------------------
+r6278 | felix | 2007-10-04 13:33:07 +0200 (Thu, 04 Oct 2007) | 1 line
+
+added libs to link of chicken-bug
+------------------------------------------------------------------------
+r6265 | kon | 2007-10-02 18:58:40 +0200 (Tue, 02 Oct 2007) | 2 lines
+
+Moved regex-chardef-table? into regex-extras
+
+------------------------------------------------------------------------
+r6257 | kon | 2007-10-02 17:25:53 +0200 (Tue, 02 Oct 2007) | 2 lines
+
+Wrong proc name for pointer-tag. Bug fix for regex-extras.
+
+------------------------------------------------------------------------
+r6256 | kon | 2007-10-02 15:44:10 +0200 (Tue, 02 Oct 2007) | 2 lines
+
+Added regex-extras to core lib list. Bug fix for regexp-options - bad arg nam.
+
+------------------------------------------------------------------------
+r6254 | kon | 2007-10-02 14:55:05 +0200 (Tue, 02 Oct 2007) | 2 lines
+
+Moved structure stuff out of regex into regex-extras, renamed pcre- -> regex-, added regex-extras to rules.make, bumped verno to 2.718.
+
+------------------------------------------------------------------------
+r6252 | felix | 2007-10-02 07:48:14 +0200 (Tue, 02 Oct 2007) | 1 line
+
+chicken-bug fixes
+------------------------------------------------------------------------
+r6251 | felix | 2007-10-02 07:38:06 +0200 (Tue, 02 Oct 2007) | 5 lines
+
+- disabled regex warnings for unused temporaries
+- added more options to chicken-bug, improved manpage a little; added to manifest
+- version is 2.717
+
+
+------------------------------------------------------------------------
+r6236 | kon | 2007-10-01 17:32:22 +0200 (Mon, 01 Oct 2007) | 2 lines
+
+Missing chicken-bug targets & deps.
+
+------------------------------------------------------------------------
+r6229 | kon | 2007-10-01 16:04:23 +0200 (Mon, 01 Oct 2007) | 2 lines
+
+Deprecated shisft! & unshift!. Bumped version since core chg.
+
+------------------------------------------------------------------------
+r6228 | kon | 2007-10-01 15:48:57 +0200 (Mon, 01 Oct 2007) | 2 lines
+
+Updated manifest for pcre 7.4
+
+------------------------------------------------------------------------
+r6226 | felix | 2007-10-01 12:18:51 +0200 (Mon, 01 Oct 2007) | 1 line
+
+added chicken-bug(1) tool (incomplete, yet); install-info with --info-file=... does not seem to work?
+------------------------------------------------------------------------
+r6219 | felix | 2007-10-01 08:03:53 +0200 (Mon, 01 Oct 2007) | 1 line
+
+added setter for symbol-plist
+------------------------------------------------------------------------
+r6216 | kon | 2007-09-30 23:55:14 +0200 (Sun, 30 Sep 2007) | 2 lines
+
+Missing line continuation in uninstall.
+
+------------------------------------------------------------------------
+r6215 | kon | 2007-09-30 15:58:28 +0200 (Sun, 30 Sep 2007) | 2 lines
+
+Docu update for Windoze
+
+------------------------------------------------------------------------
+r6214 | kon | 2007-09-30 15:52:07 +0200 (Sun, 30 Sep 2007) | 2 lines
+
+Per Jerry Van Dijk: added '--info-file=chicken.info' to install.
+
+------------------------------------------------------------------------
+r6208 | kon | 2007-09-30 07:02:38 +0200 (Sun, 30 Sep 2007) | 2 lines
+
+Rmvd HAVE_DLFCN_H
+
+------------------------------------------------------------------------
+r6197 | kon | 2007-09-29 16:12:25 +0200 (Sat, 29 Sep 2007) | 2 lines
+
+Rpld blob w/ byte-vector for old chicken, made regexp-options polymorphic.
+
+------------------------------------------------------------------------
+r6186 | kon | 2007-09-28 22:23:18 +0200 (Fri, 28 Sep 2007) | 2 lines
+
+Added 3 CL like property list procs, use of nonnull-c-string in regex.
+
+------------------------------------------------------------------------
+r6180 | felix | 2007-09-28 08:11:45 +0200 (Fri, 28 Sep 2007) | 6 lines
+
+- first attempt at cygwin Makefile (Thanks to Shawn Rutledge)
+- added property lists, removed extraslot feature
+- bumped version to 2.713
+- small regex bugfix ("unit8_t" -> "uint8_t")
+
+
+------------------------------------------------------------------------
+r6177 | kon | 2007-09-27 20:59:53 +0200 (Thu, 27 Sep 2007) | 2 lines
+
+Fixed pcre directory ref.
+
+------------------------------------------------------------------------
+r6176 | kon | 2007-09-27 20:34:32 +0200 (Thu, 27 Sep 2007) | 2 lines
+
+Rmvd pcre 6 stuff.
+
+------------------------------------------------------------------------
+r6175 | kon | 2007-09-27 20:12:03 +0200 (Thu, 27 Sep 2007) | 2 lines
+
+Changes for PCRE 7.4, use of compiled regexp in posix & utils units.
+
+------------------------------------------------------------------------
+r6123 | zbigniew | 2007-09-22 22:24:23 +0200 (Sat, 22 Sep 2007) | 1 line
+
+Fix unterminated ifdef
+------------------------------------------------------------------------
+r6122 | kon | 2007-09-22 21:13:07 +0200 (Sat, 22 Sep 2007) | 2 lines
+
+linux uses endian.h
+
+------------------------------------------------------------------------
+r6117 | kon | 2007-09-22 03:14:45 +0200 (Sat, 22 Sep 2007) | 2 lines
+
+Accept -nan.0 on Windows.
+
+------------------------------------------------------------------------
+r6112 | kon | 2007-09-21 23:40:24 +0200 (Fri, 21 Sep 2007) | 2 lines
+
+Added windows gui libs to install, since they are built..
+
+------------------------------------------------------------------------
+r6108 | kon | 2007-09-21 17:28:05 +0200 (Fri, 21 Sep 2007) | 2 lines
+
+Made byte-order call runtime proc, made [nonnull-]pointer deprecation easier, added inttypes.h & byte order.
+
+------------------------------------------------------------------------
+r6105 | felix | 2007-09-21 14:46:02 +0200 (Fri, 21 Sep 2007) | 1 line
+
+2.711: removed old oblist access (intended for hen), removed completion from hen.el
+------------------------------------------------------------------------
+r6083 | kon | 2007-09-19 20:35:51 +0200 (Wed, 19 Sep 2007) | 2 lines
+
+Combined platform defines into same "section" in chicken.h, Made compiler optimization options user settable.
+
+------------------------------------------------------------------------
+r6080 | felix | 2007-09-19 19:01:26 +0200 (Wed, 19 Sep 2007) | 1 line
+
+version is 2.710, raised binaryversion to 2, some makefile fixes
+------------------------------------------------------------------------
+r6068 | felix | 2007-09-18 14:41:45 +0200 (Tue, 18 Sep 2007) | 1 line
+
+makefile.linux bugfix by Alex Q.
+------------------------------------------------------------------------
+r6062 | zbigniew | 2007-09-17 23:44:26 +0200 (Mon, 17 Sep 2007) | 1 line
+
+Fix dylib crashes on OS X
+------------------------------------------------------------------------
+r6061 | zbigniew | 2007-09-17 21:36:17 +0200 (Mon, 17 Sep 2007) | 1 line
+
+Re-enabled ptables (typo)
+------------------------------------------------------------------------
+r6058 | felix | 2007-09-17 14:55:40 +0200 (Mon, 17 Sep 2007) | 1 line
+
+stdint.h is included by default on Linux/x86-64 and Linux/alpha
+------------------------------------------------------------------------
+r6057 | felix | 2007-09-17 14:53:23 +0200 (Mon, 17 Sep 2007) | 1 line
+
+makefile cleanups; version is 2.709
+------------------------------------------------------------------------
+r6037 | felix | 2007-09-15 11:53:48 +0200 (Sat, 15 Sep 2007) | 1 line
+
+chicken-setup quotewrapping fix on windows [Thanks to Eric Rochester]; bumped version to 2.709
+------------------------------------------------------------------------
+r6005 | felix | 2007-09-13 13:55:43 +0200 (Thu, 13 Sep 2007) | 1 line
+
+minor things
+------------------------------------------------------------------------
+r5989 | felix | 2007-09-12 08:00:03 +0200 (Wed, 12 Sep 2007) | 4 lines
+
+- version is 2.708
+- added Alex Shinn's scheme-complete.el
+- README additions
+
+------------------------------------------------------------------------
+r5982 | felix | 2007-09-11 13:04:48 +0200 (Tue, 11 Sep 2007) | 1 line
+
+calls to known procedures with mismatching arglists trigger error instead of warning
+------------------------------------------------------------------------
+r5979 | felix | 2007-09-11 11:18:29 +0200 (Tue, 11 Sep 2007) | 1 line
+
+tiny bugfix with extraslot
+------------------------------------------------------------------------
+r5974 | felix | 2007-09-10 22:35:31 +0200 (Mon, 10 Sep 2007) | 1 line
+
+tcp-listen port check only done in safe mode
+------------------------------------------------------------------------
+r5971 | felix | 2007-09-10 20:55:32 +0200 (Mon, 10 Sep 2007) | 1 line
+
+distribution manifest did not include all makefiles
+------------------------------------------------------------------------
+r5970 | felix | 2007-09-10 13:10:30 +0200 (Mon, 10 Sep 2007) | 1 line
+
+x86-64 apply hack should now really, really work
+------------------------------------------------------------------------
+r5968 | felix | 2007-09-10 09:21:22 +0200 (Mon, 10 Sep 2007) | 4 lines
+
+- version is 2.707
+- added tcp-listen range check [Thanks to Jon Strait]
+- argument buffer in C_apply aligned to 16 bytes to avoid segfault on amd64 systems
+
+------------------------------------------------------------------------
+r5947 | felix | 2007-09-08 14:58:30 +0200 (Sat, 08 Sep 2007) | 1 line
+
+fixed serious bug in uninstall target
+------------------------------------------------------------------------
+r5946 | felix | 2007-09-07 12:12:21 +0200 (Fri, 07 Sep 2007) | 1 line
+
+pdf install
+------------------------------------------------------------------------
+r5945 | felix | 2007-09-07 11:29:51 +0200 (Fri, 07 Sep 2007) | 1 line
+
+renamed some tools in misc/; apply hack fix on x86-64 (again); re-added manual
+------------------------------------------------------------------------
+r5932 | felix | 2007-09-06 09:59:09 +0200 (Thu, 06 Sep 2007) | 1 line
+
+x86-64 apply hack should work now
+------------------------------------------------------------------------
+r5931 | felix | 2007-09-06 08:07:43 +0200 (Thu, 06 Sep 2007) | 1 line
+
+removed manual (will be generated); another go at x86-64 apply hack
+------------------------------------------------------------------------
+r5923 | iraikov | 2007-09-05 14:03:09 +0200 (Wed, 05 Sep 2007) | 2 lines
+
+Created branch debian-chicken-2.7.
+
+------------------------------------------------------------------------
+r5922 | felix | 2007-09-05 13:17:30 +0200 (Wed, 05 Sep 2007) | 1 line
+
+removed html dir, installation failure is ignored
+------------------------------------------------------------------------
+r5920 | felix | 2007-09-05 10:53:09 +0200 (Wed, 05 Sep 2007) | 1 line
+
+fix in runtests.sh by Sven Hartrumpf
+------------------------------------------------------------------------
+r5919 | felix | 2007-09-05 10:35:12 +0200 (Wed, 05 Sep 2007) | 4 lines
+
+- disabled x86-643 hack (currently imcomplete)
+- STATICBUILD make option and associated changes
+
+
+------------------------------------------------------------------------
+r5918 | felix | 2007-09-05 08:41:04 +0200 (Wed, 05 Sep 2007) | 1 line
+
+cygwin fix in runtime.c (reported by John Cowan)
+------------------------------------------------------------------------
+r5917 | felix | 2007-09-05 08:32:18 +0200 (Wed, 05 Sep 2007) | 4 lines
+
+- x86-64 fixes (for problems reported by Alex Shinn)
+- slight change in makefiles for TARGETS variable
+
+
+------------------------------------------------------------------------
+r5897 | iraikov | 2007-09-04 14:18:51 +0200 (Tue, 04 Sep 2007) | 2 lines
+
+Updated Debian version number to 2.703-0.1.
+
+------------------------------------------------------------------------
+r5893 | felix | 2007-09-03 21:59:13 +0200 (Mon, 03 Sep 2007) | 3 lines
+
+- version is 2.703
+- makefiles fix by Peter Bex (ARCH check)
+
+------------------------------------------------------------------------
+r5891 | felix | 2007-09-03 20:30:46 +0200 (Mon, 03 Sep 2007) | 3 lines
+
+- tcp: default read/write timeouts are 1 minute
+- applied several fixes (Makefile.bsd and runtests.sh) by Peter Bex
+
+------------------------------------------------------------------------
+r5884 | iraikov | 2007-09-03 08:56:49 +0200 (Mon, 03 Sep 2007) | 2 lines
+
+Created chicken-2.7 branch.
+
+------------------------------------------------------------------------
+r5883 | iraikov | 2007-09-03 06:34:51 +0200 (Mon, 03 Sep 2007) | 2 lines
+
+Added SHAREDIR to the list of variables passed to the makefile.
+
+------------------------------------------------------------------------
+r5882 | iraikov | 2007-09-03 05:58:08 +0200 (Mon, 03 Sep 2007) | 2 lines
+
+Made some fixes so that the Debian package builds with the new build system.
+
+------------------------------------------------------------------------
+r5878 | kon | 2007-09-03 02:29:48 +0200 (Mon, 03 Sep 2007) | 2 lines
+
+Use of static library w/ non-static binary on MacOS X was causing illegal instruction trap w/ conform in "unsafe" mode.
+
+------------------------------------------------------------------------
+r5876 | sjamaan | 2007-09-02 20:58:37 +0200 (Sun, 02 Sep 2007) | 2 lines
+
+Implement #312
+
+------------------------------------------------------------------------
+r5861 | felix | 2007-09-02 09:46:54 +0200 (Sun, 02 Sep 2007) | 4 lines
+
+- added SYSV-specific ppc apply-hack [Thanks to Peter Bex]
+- added bsd makefile (untested!)
+- version is 2.702
+
+------------------------------------------------------------------------
+r5853 | felix | 2007-09-01 18:29:16 +0200 (Sat, 01 Sep 2007) | 5 lines
+
+Massive reorganization of the build process.
+
+Oh, this is going to be fun...
+
+
+------------------------------------------------------------------------
+r5794 | kon | 2007-08-28 23:33:33 +0200 (Tue, 28 Aug 2007) | 2 lines
+
+Bumped the version, to reflect version.scm (2 places is too many for me tiny brain).
+
+------------------------------------------------------------------------
+r5752 | zbigniew | 2007-08-27 08:32:32 +0200 (Mon, 27 Aug 2007) | 1 line
+
+library.scm: optional -> #!optional; allows bootstrap with < 2.622
+------------------------------------------------------------------------
+r5746 | kon | 2007-08-26 06:17:57 +0200 (Sun, 26 Aug 2007) | 2 lines
+
+unsafe units, chicken, didn't work when srcdir != builddir. apply-hack link forced in srcdir.
+
+------------------------------------------------------------------------
+r5741 | kon | 2007-08-26 00:39:19 +0200 (Sun, 26 Aug 2007) | 2 lines
+
+Nice to know.
+
+------------------------------------------------------------------------
+r5658 | kon | 2007-08-23 18:55:35 +0200 (Thu, 23 Aug 2007) | 2 lines
+
+print & print* accept 0 arguments, returning (void), & use common inline proc.
+
+------------------------------------------------------------------------
+r5639 | kon | 2007-08-23 09:37:43 +0200 (Thu, 23 Aug 2007) | 2 lines
+
+Added numeric -> scheme value overrides to define-foreign-enum. Bumped version number to 2.637
+
+------------------------------------------------------------------------
+r5616 | felix | 2007-08-23 01:02:55 +0200 (Thu, 23 Aug 2007) | 1 line
+
+added warning when extension is compiled in unsafe mode
+------------------------------------------------------------------------
+r5607 | kon | 2007-08-22 17:27:30 +0200 (Wed, 22 Aug 2007) | 2 lines
+
+Added "safe" reverse-list->string, :optional chg.
+
+------------------------------------------------------------------------
+r5529 | kon | 2007-08-20 05:35:22 +0200 (Mon, 20 Aug 2007) | 2 lines
+
+Moved blob to library. Use ##sys#make-blob in srfi-4 unit.
+
+------------------------------------------------------------------------
+r5526 | felix | 2007-08-20 01:28:24 +0200 (Mon, 20 Aug 2007) | 1 line
+
+version 2.636; ugly naming hack in runtime.c and apply-hack files
+------------------------------------------------------------------------
+r5501 | kon | 2007-08-18 04:25:18 +0200 (Sat, 18 Aug 2007) | 2 lines
+
+'foreign-type-declaration' didn't recognize 'unsigned-c-string*'.
+
+------------------------------------------------------------------------
+r5432 | felix | 2007-08-15 08:30:40 +0200 (Wed, 15 Aug 2007) | 1 line
+
+fixed bug in 'chicken-version' [reported by Mario]
+------------------------------------------------------------------------
+r5430 | felix | 2007-08-14 16:18:28 +0200 (Tue, 14 Aug 2007) | 1 line
+
+makefile.am fix
+------------------------------------------------------------------------
+r5429 | felix | 2007-08-14 15:45:13 +0200 (Tue, 14 Aug 2007) | 1 line
+
+chicken-build fixes, added texi to manifest [Thanks to mario]
+------------------------------------------------------------------------
+r5424 | felix | 2007-08-14 08:12:00 +0200 (Tue, 14 Aug 2007) | 1 line
+
+more attempts at info file generation and installation
+------------------------------------------------------------------------
+r5401 | kon | 2007-08-13 18:14:47 +0200 (Mon, 13 Aug 2007) | 2 lines
+
+Added unsigned-c-string*
+
+------------------------------------------------------------------------
+r5399 | felix | 2007-08-13 15:31:15 +0200 (Mon, 13 Aug 2007) | 1 line
+
+cmake woes; texinfo handling for autotools
+------------------------------------------------------------------------
+r5397 | felix | 2007-08-13 10:27:23 +0200 (Mon, 13 Aug 2007) | 1 line
+
+manual page renaming
+------------------------------------------------------------------------
+r5393 | felix | 2007-08-13 08:19:13 +0200 (Mon, 13 Aug 2007) | 1 line
+
+manual sync, site index points to current snapshort link
+------------------------------------------------------------------------
+r5375 | felix | 2007-08-10 13:53:29 +0200 (Fri, 10 Aug 2007) | 1 line
+
+added site/eggs index and fixed a problem reported by elf
+------------------------------------------------------------------------
+r5374 | felix | 2007-08-10 07:25:26 +0200 (Fri, 10 Aug 2007) | 1 line
+
+Changelog generation in dist script refer'd to hg instead of svn [reported by Mario]
+------------------------------------------------------------------------
+r5373 | kon | 2007-08-10 01:35:04 +0200 (Fri, 10 Aug 2007) | 2 lines
+
+Extd sig of user-post-analysis-pass & rename of print proc.
+
+------------------------------------------------------------------------
+r5364 | felix | 2007-08-09 10:08:13 +0200 (Thu, 09 Aug 2007) | 1 line
+
+added error checking to print-call-chain [reported by Peter Bex]
+------------------------------------------------------------------------
+r5362 | felix | 2007-08-09 08:33:12 +0200 (Thu, 09 Aug 2007) | 6 lines
+
+- regex: string-substitute signals an error on an empty match (reported by mario/zb)
+- another attempt at apply-hack support for cmake; failed, naturally
+- C_NO_APPLY_HACK disables apply hack
+- version is 2.635
+
+
+------------------------------------------------------------------------
+r5361 | felix | 2007-08-09 07:11:22 +0200 (Thu, 09 Aug 2007) | 1 line
+
+reorganizing chicken dir (part 2)
+------------------------------------------------------------------------
+r5360 | felix | 2007-08-09 07:08:36 +0200 (Thu, 09 Aug 2007) | 1 line
+
+reorganizing chicken dir (part 1)
+------------------------------------------------------------------------
+r5358 | felix | 2007-08-08 22:40:50 +0200 (Wed, 08 Aug 2007) | 8 lines
+
+- renamed manual dir
+- can't get cmake to handle assembler file. I give up.
+- removed darcs link from site index
+- trivial build output changes
+- some more cleanup, trivialities
+- I'm out of ASCII banners
+
+
+------------------------------------------------------------------------
+r5357 | felix | 2007-08-08 22:18:42 +0200 (Wed, 08 Aug 2007) | 1 line
+
+renamed wiki backup dir to manual
+------------------------------------------------------------------------
+r5220 | felix | 2007-07-26 17:03:23 +0200 (Thu, 26 Jul 2007) | 1 line
+
+doc updates, small fixes
+------------------------------------------------------------------------
+r4918 | felix | 2007-07-06 08:07:10 +0200 (Fri, 06 Jul 2007) | 1 line
+
+added missing version.scm
+------------------------------------------------------------------------
+r4845 | felix | 2007-07-03 22:56:36 +0200 (Tue, 03 Jul 2007) | 1 line
+
+reverted unneeded format-modular change, chicken update, minor fixes
+------------------------------------------------------------------------
+r4520 | felix | 2007-06-12 23:31:32 +0200 (Tue, 12 Jun 2007) | 1 line
+
+fspath metafile fix
+------------------------------------------------------------------------
+r4413 | felix | 2007-06-05 09:38:05 +0200 (Tue, 05 Jun 2007) | 1 line
+
+tcp unit update
+------------------------------------------------------------------------
+r4392 | felix | 2007-06-02 10:04:57 +0200 (Sat, 02 Jun 2007) | 1 line
+
+added internal docs, json merge, peep
+------------------------------------------------------------------------
+r4340 | felix | 2007-05-28 16:01:34 +0200 (Mon, 28 May 2007) | 1 line
+
+fp updates
+------------------------------------------------------------------------
+r4232 | felix | 2007-05-20 00:32:05 +0200 (Sun, 20 May 2007) | 1 line
+
+various fixes, alexpander update
+------------------------------------------------------------------------
+r3839 | felix | 2007-04-14 21:12:47 +0200 (Sat, 14 Apr 2007) | 1 line
+
+chicken update
+------------------------------------------------------------------------
+r3241 | felix | 2007-03-03 13:22:58 +0100 (Sat, 03 Mar 2007) | 1 line
+
+chicken update, added directories for thu's eggs
+------------------------------------------------------------------------
+r3156 | felix | 2007-02-26 22:11:10 +0100 (Mon, 26 Feb 2007) | 1 line
+
+chicken update
+------------------------------------------------------------------------
+r3046 | ashinn | 2007-02-13 10:51:49 +0100 (Tue, 13 Feb 2007) | 5 lines
+
+Adding support for surrogate pair escapes in string literals
+of the form "\uDNNN\uDMMM" for compatibility with some other
+languages, as per bug #79.
+Also replacing #sys#char->utf8-string with a much faster version.
+
+------------------------------------------------------------------------
+r3033 | felix | 2007-02-12 19:22:59 +0100 (Mon, 12 Feb 2007) | 1 line
+
+added tool, softscheme fix, other small fixes, unfroze wiki/index
+------------------------------------------------------------------------
+r2970 | felix | 2007-02-01 17:20:10 +0100 (Thu, 01 Feb 2007) | 1 line
+
+wiki/doc update, chicken updates
+------------------------------------------------------------------------
+r2926 | felix | 2007-01-26 13:49:03 +0100 (Fri, 26 Jan 2007) | 1 line
+
+new chicken version (pcre merged), aalib
+------------------------------------------------------------------------
+r2869 | felix | 2007-01-15 19:47:49 +0100 (Mon, 15 Jan 2007) | 1 line
+
+grmph
+------------------------------------------------------------------------
+r2868 | felix | 2007-01-15 19:12:06 +0100 (Mon, 15 Jan 2007) | 1 line
+
+doc updates, chicken update
+------------------------------------------------------------------------
+r2798 | felix | 2007-01-06 19:26:09 +0100 (Sat, 06 Jan 2007) | 1 line
+
+wiki updates, rss fix
+------------------------------------------------------------------------
+r2794 | felix | 2007-01-05 22:25:39 +0100 (Fri, 05 Jan 2007) | 1 line
+
+chicken update, codewalk fix, bb experiment
+------------------------------------------------------------------------
+r2777 | felix | 2007-01-01 20:32:31 +0100 (Mon, 01 Jan 2007) | 1 line
+
+chicken update, bb fix
+------------------------------------------------------------------------
+r2776 | felix | 2007-01-01 19:30:30 +0100 (Mon, 01 Jan 2007) | 1 line
+
+spiffy update, added contracts
+------------------------------------------------------------------------
+r2769 | felix | 2006-12-28 22:30:52 +0100 (Thu, 28 Dec 2006) | 1 line
+
+z3 update
+------------------------------------------------------------------------
+r2710 | felix | 2006-12-18 21:51:15 +0100 (Mon, 18 Dec 2006) | 1 line
+
+added fps
+------------------------------------------------------------------------
+r2634 | iraikov | 2006-12-11 19:22:48 +0100 (Mon, 11 Dec 2006) | 2 lines
+
+Added the Debian-related files to the dist target.
+
+------------------------------------------------------------------------
+r2628 | iraikov | 2006-12-11 16:01:31 +0100 (Mon, 11 Dec 2006) | 2 lines
+
+Updated the package description and maintainer information.
+
+------------------------------------------------------------------------
+r2616 | felix | 2006-12-10 22:44:37 +0100 (Sun, 10 Dec 2006) | 1 line
+
+added Ivan's debian dir
+------------------------------------------------------------------------
+r2615 | felix | 2006-12-10 22:31:55 +0100 (Sun, 10 Dec 2006) | 1 line
+
+various updates, added records
+------------------------------------------------------------------------
+r2536 | felix | 2006-11-27 21:03:16 +0100 (Mon, 27 Nov 2006) | 1 line
+
+added loopy-loop, scgi fix by pbusser
+------------------------------------------------------------------------
+r2488 | felix | 2006-11-20 19:41:58 +0100 (Mon, 20 Nov 2006) | 1 line
+
+various updates, documentation update for chicken-setup
+------------------------------------------------------------------------
+r2443 | felix | 2006-11-15 16:44:26 +0100 (Wed, 15 Nov 2006) | 1 line
+
+chicken update, codewalk fixes, qt/mac
+------------------------------------------------------------------------
+r2430 | felix | 2006-11-15 06:13:49 +0100 (Wed, 15 Nov 2006) | 1 line
+
+added scsh-regexp
+------------------------------------------------------------------------
+r2248 | felix | 2006-11-02 21:51:13 +0100 (Thu, 02 Nov 2006) | 1 line
+
+qt updates, removed roadmap
+------------------------------------------------------------------------
+r2197 | felix | 2006-10-27 22:00:46 +0200 (Fri, 27 Oct 2006) | 1 line
+
+mucked around with qt on mac
+------------------------------------------------------------------------
+r2192 | felix | 2006-10-26 10:50:03 +0200 (Thu, 26 Oct 2006) | 1 line
+
+version update, qt additions
+------------------------------------------------------------------------
+r2181 | felix | 2006-10-23 20:15:46 +0200 (Mon, 23 Oct 2006) | 1 line
+
+sqlite3 meta/setup fixes (by pbusser)
+------------------------------------------------------------------------
+r2119 | felix | 2006-10-21 19:49:40 +0200 (Sat, 21 Oct 2006) | 1 line
+
+various fixes, removed roadmap
+------------------------------------------------------------------------
+r2047 | felix | 2006-10-14 19:40:32 +0200 (Sat, 14 Oct 2006) | 1 line
+
+antispam and macosx update
+------------------------------------------------------------------------
+r1984 | felix | 2006-10-05 19:45:59 +0200 (Thu, 05 Oct 2006) | 1 line
+
+antispam, bumped manual version
+------------------------------------------------------------------------
+r1958 | felix | 2006-09-29 21:41:32 +0200 (Fri, 29 Sep 2006) | 1 line
+
+added q-lang, modules stuff
+------------------------------------------------------------------------
+r1928 | felix | 2006-09-25 21:18:34 +0200 (Mon, 25 Sep 2006) | 1 line
+
+several updates
+------------------------------------------------------------------------
+r1869 | felix | 2006-09-17 07:45:52 +0200 (Sun, 17 Sep 2006) | 1 line
+
+codewalk, readline updates
+------------------------------------------------------------------------
+r1748 | felix | 2006-09-12 17:11:36 +0200 (Tue, 12 Sep 2006) | 1 line
+
+cleanup of files
+------------------------------------------------------------------------
+r1713 | felix | 2006-09-10 19:07:58 +0200 (Sun, 10 Sep 2006) | 1 line
+
+wiki updates, added missing chicken files
+------------------------------------------------------------------------
+r1613 | felix | 2006-08-30 21:00:49 +0200 (Wed, 30 Aug 2006) | 1 line
+
+added codewalk
+------------------------------------------------------------------------
+r1612 | felix | 2006-08-30 20:23:51 +0200 (Wed, 30 Aug 2006) | 1 line
+
+added pty, small fix to ncurses
+------------------------------------------------------------------------
+r1404 | felix | 2006-08-24 00:11:34 +0200 (Thu, 24 Aug 2006) | 1 line
+
+pty and fastcgi updates
+------------------------------------------------------------------------
+r1403 | felix | 2006-08-23 21:12:13 +0200 (Wed, 23 Aug 2006) | 1 line
+
+various updates and easyffi-related fixes
+------------------------------------------------------------------------
+r1373 | felix | 2006-08-07 23:09:46 +0200 (Mon, 07 Aug 2006) | 1 line
+
+easyffi and tinyclos, s11n fix
+------------------------------------------------------------------------
+r1349 | felix | 2006-07-31 19:17:57 +0200 (Mon, 31 Jul 2006) | 1 line
+
+manual updates
+------------------------------------------------------------------------
+r1277 | felix | 2006-07-25 17:57:00 +0200 (Tue, 25 Jul 2006) | 1 line
+
+chicken-dump used obsolete file
+------------------------------------------------------------------------
+r1269 | felix | 2006-07-22 23:12:35 +0200 (Sat, 22 Jul 2006) | 1 line
+
+removed sxpath
+------------------------------------------------------------------------
+r1267 | felix | 2006-07-21 10:50:18 +0200 (Fri, 21 Jul 2006) | 1 line
+
+s11n fallback; converted some eggs to real ones
+------------------------------------------------------------------------
+r1258 | felix | 2006-07-17 19:28:22 +0200 (Mon, 17 Jul 2006) | 1 line
+
+updated to version 2.41
+------------------------------------------------------------------------
+r1254 | felix | 2006-07-16 08:18:23 +0200 (Sun, 16 Jul 2006) | 1 line
+
+added fastcgi
+------------------------------------------------------------------------
+r1253 | felix | 2006-07-16 07:19:53 +0200 (Sun, 16 Jul 2006) | 1 line
+
+2.4 release
+------------------------------------------------------------------------
+r1216 | felix | 2006-07-12 23:29:34 +0200 (Wed, 12 Jul 2006) | 1 line
+
+forgot to remove some files from chicken.meta
+------------------------------------------------------------------------
+r1213 | felix | 2006-07-12 23:08:34 +0200 (Wed, 12 Jul 2006) | 1 line
+
+removed old mailbox egg
+------------------------------------------------------------------------
+r1186 | felix | 2006-07-04 21:13:29 +0200 (Tue, 04 Jul 2006) | 1 line
+
+mailbox got own queue implementation
+------------------------------------------------------------------------
+r1063 | felix | 2006-06-21 20:50:56 +0200 (Wed, 21 Jun 2006) | 1 line
+
+wiki pages for manual, chicken update
+------------------------------------------------------------------------
+r1016 | felix | 2006-06-15 20:52:15 +0200 (Thu, 15 Jun 2006) | 1 line
+
+removed tagged chicken versions - too much copying
+------------------------------------------------------------------------
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 00000000..327fc9d0
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,22 @@
+Copyright (c) 2000-2006, Felix L. Winkelmann
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+conditions are met:
+
+ Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+ disclaimer.
+ 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.
+ Neither the name of the author nor the names of its contributors may be used to endorse or promote
+ products derived from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGE.
diff --git a/Makefile b/Makefile
new file mode 100644
index 00000000..f1aaa31a
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,80 @@
+# Makefile - toplevel makefile
+#
+# Copyright (c) 2007, Felix L. Winkelmann
+# Copyright (c) 2008-2009, The Chicken Team
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+# conditions are met:
+#
+# Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+# disclaimer.
+# 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.
+# Neither the name of the author nor the names of its contributors may be used to endorse or promote
+# products derived from this software without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+# OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+# AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+
+STANDARD_TARGETS \
+ = all clean distclean spotless install uninstall confclean check \
+ fullcheck dist libs bootstrap
+
+SRCDIR = .
+
+.PHONY: $(STANDARD_TARGETS)
+
+ifndef PLATFORM
+$(STANDARD_TARGETS):
+ @echo "no PLATFORM given."
+ @echo ""
+ @echo "Please select your target platform by running one of the following commands:"
+ @echo ""
+ @echo " $(MAKE) PLATFORM=linux"
+ @echo " $(MAKE) PLATFORM=bsd"
+ @echo " $(MAKE) PLATFORM=macosx"
+ @echo " $(MAKE) PLATFORM=mingw-msys"
+ @echo " $(MAKE) PLATFORM=mingw"
+ @echo " $(MAKE) PLATFORM=cygwin"
+ @echo " $(MAKE) PLATFORM=solaris"
+ @echo " $(MAKE) PLATFORM=cross-linux-mingw"
+ @echo ""
+ @echo "For more information, consult the README file."
+ @exit 1
+else
+all:
+ $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) all
+clean:
+ $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) clean
+distclean:
+ $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) distclean
+spotless:
+ $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) spotless
+install:
+ $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) install
+uninstall:
+ $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) uninstall
+confclean:
+ $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) confclean
+check:
+ $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) check
+fullcheck:
+ $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) fullcheck
+dist:
+ $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) distfiles
+ csi -s scripts/makedist.scm
+libs:
+ $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) libs
+bootstrap:
+ $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) bootstrap
+bench:
+ $(MAKE) -f $(SRCDIR)/Makefile.$(PLATFORM) bench
+endif
diff --git a/Makefile.bsd b/Makefile.bsd
new file mode 100644
index 00000000..57ee1b1e
--- /dev/null
+++ b/Makefile.bsd
@@ -0,0 +1,108 @@
+# Makefile.bsd - configuration for BSD UNIX -*- Makefile -*-
+#
+# Copyright (c) 2007, Felix L. Winkelmann
+# Copyright (c) 2008-2009, The Chicken Team
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+# conditions are met:
+#
+# Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+# disclaimer.
+# 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.
+# Neither the name of the author nor the names of its contributors may be used to endorse or promote
+# products derived from this software without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+# OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+# AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+
+
+SRCDIR = ./
+
+# platform configuration
+
+ARCH = $(shell sh $(SRCDIR)/config-arch.sh)
+
+# options
+
+C_COMPILER_OPTIONS = -fno-strict-aliasing -DHAVE_CHICKEN_CONFIG_H
+ifdef DEBUGBUILD
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -g -Wall -Wno-unused
+else
+ifdef OPTIMIZE_FOR_SPEED
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -O3 -fomit-frame-pointer
+else
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -Os -fomit-frame-pointer
+endif
+endif
+LINKER_LINK_SHARED_LIBRARY_OPTIONS = -shared
+LINKER_LINK_SHARED_DLOADABLE_OPTIONS = -shared -Wl,-R$(RUNTIME_LINKER_PATH) -Wl,-L.
+LINKER_LINK_SHARED_PROGRAM_OPTIONS = -Wl,-R$(RUNTIME_LINKER_PATH)
+LIBCHICKEN_SO_LINKER_OPTIONS = -Wl,-soname,libchicken.so$(SONAME_VERSION)
+LIBUCHICKEN_SO_LINKER_OPTIONS = -Wl,-soname,libuchicken.so$(SONAME_VERSION)
+LIBRARIES = -lm
+NEEDS_RELINKING = yes
+USES_SONAME = yes
+
+# special files
+
+CHICKEN_CONFIG_H = chicken-config.h
+
+# select default and internal settings
+
+include $(SRCDIR)/defaults.make
+
+# These may be useful for NetBSD:
+#
+#C_COMPILER_OPTIONS += -I/usr/pkg/lib
+#LINKER_OPTIONS += -L/usr/pkg/lib -Wl,-R/usr/pkg/lib
+
+chicken-config.h: chicken-defaults.h
+ echo "#define HAVE_DIRENT_H 1" >$@
+ echo "#define HAVE_DLFCN_H 1" >>$@
+ echo "#define HAVE_INTTYPES_H 1" >>$@
+ echo "#define HAVE_LIMITS_H 1" >>$@
+ echo "#define HAVE_LONG_LONG 1" >>$@
+ echo "#define HAVE_MEMMOVE 1" >>$@
+ echo "#define HAVE_MEMORY_H 1" >>$@
+ echo "#define HAVE_STDINT_H 1" >>$@
+ echo "#define HAVE_STDLIB_H 1" >>$@
+ echo "#define HAVE_STRERROR 1" >>$@
+ echo "#define HAVE_STRINGS_H 1" >>$@
+ echo "#define HAVE_STRING_H 1" >>$@
+ echo "#define HAVE_STRTOLL 1" >>$@
+ echo "#define HAVE_STRTOQ 1" >>$@
+ echo "#define HAVE_SYS_STAT_H 1" >>$@
+ echo "#define HAVE_SYS_TYPES_H 1" >>$@
+ echo "#define HAVE_UNISTD_H 1" >>$@
+ echo "#define HAVE_UNSIGNED_LONG_LONG 1" >>$@
+ echo "#define STDC_HEADERS 1" >>$@
+ echo "#define HAVE_ALLOCA 1" >>$@
+ echo "#define HAVE_ALLOCA_H 1" >>$@
+ echo "#define HAVE_GRP_H 1" >>$@
+ echo "#define HAVE_ERRNO_H 1" >>$@
+ echo "#define HAVE_SYSEXITS_H 1" >>$@
+ echo "#define C_STACK_GROWS_DOWNWARD 1" >>$@
+ifdef GCHOOKS
+ echo "#define C_GC_HOOKS" >>$@
+endif
+ifdef SYMBOLGC
+ echo "#define C_COLLECT_ALL_SYMBOLS" >>$@
+endif
+ifdef NOAPPLYHOOK
+ echo "#define C_NO_APPLY_HOOK" >>$@
+endif
+ifneq ($(HACKED_APPLY),)
+ echo "#define C_HACKED_APPLY" >>$@
+endif
+ cat chicken-defaults.h >>$@
+
+include $(SRCDIR)/rules.make
diff --git a/Makefile.cross-linux-mingw b/Makefile.cross-linux-mingw
new file mode 100644
index 00000000..5bcb014a
--- /dev/null
+++ b/Makefile.cross-linux-mingw
@@ -0,0 +1,139 @@
+# Makefile.cross-linux-mingw - configuration for MinGW (crosscompiled from Linux) -*- Makefile -*-
+#
+# Copyright (c) 2007, Felix L. Winkelmann
+# Copyright (c) 2008-2009, The Chicken Team
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+# conditions are met:
+#
+# Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+# disclaimer.
+# 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.
+# Neither the name of the author nor the names of its contributors may be used to endorse or promote
+# products derived from this software without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+# OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+# AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+
+
+SRCDIR = ./
+
+# platform configuration
+
+DLLSINPATH = 1
+ARCH = x86
+HACKED_APPLY = 1
+WINDOWS = 1
+
+# file extensions
+
+SO = .dll
+EXE = .exe
+
+# commands
+
+HOSTSYSTEM=mingw32
+
+# options
+
+C_COMPILER_OPTIONS = -fno-strict-aliasing -DHAVE_CHICKEN_CONFIG_H
+ifdef DEBUGBUILD
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -g -Wall -Wno-unused
+else
+ifdef OPTIMIZE_FOR_SPEED
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -O3 -fomit-frame-pointer
+else
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -Os -fomit-frame-pointer
+endif
+endif
+C_COMPILER_SHARED_OPTIONS = -DPIC
+C_COMPILER_GUI_RUNTIME_OPTIONS = -DC_WINDOWS_GUI
+LINKER_LINK_SHARED_LIBRARY_OPTIONS = -shared
+LIBRARIES = -lm -lws2_32
+LIBCHICKEN_SO_LINKER_OPTIONS = -Wl,--out-implib,libchicken.dll.a
+LIBUCHICKEN_SO_LINKER_OPTIONS = -Wl,--out-implib,libuchicken.dll.a
+LIBCHICKENGUI_SO_LINKER_OPTIONS = -Wl,--out-implib,libchickengui.dll.a
+LIBCHICKEN_SO_LIBRARIES = -lws2_32
+LIBUCHICKEN_SO_LIBRARIES = -lws2_32
+LIBCHICKENGUI_SO_LIBRARIES = -lkernel32 -luser32 -lgdi32 -lws2_32
+LIBCHICKEN_IMPORT_LIBRARY = libchicken.dll.a
+LIBUCHICKEN_IMPORT_LIBRARY = libuchicken.dll.a
+LIBCHICKENGUI_IMPORT_LIBRARY = libchickengui.dll.a
+TARGET_C_COMPILER = gcc
+TARGET_CXX_COMPILER = g++
+
+# special files
+
+APPLY_HACK_OBJECT = apply-hack.$(ARCH)$(O)
+POSIXFILE = posixwin
+
+# select default and internal settings
+
+include $(SRCDIR)/defaults.make
+
+# main target
+
+ifndef BUILD_SETUP_TOOLS
+TARGETS = libchicken$(A) libuchicken$(A) chicken$(EXE) csi$(EXE) \
+ chicken-profile$(EXE) csc$(EXE) libchicken$(SO) \
+ libuchicken$(SO) chicken-setup$(EXE) \
+ libchickengui$(SO) chicken-bug$(EXE)
+else
+TARGETS = libchicken$(A) libuchicken$(A) chicken$(EXE) csi$(EXE) \
+ chicken-profile$(EXE) csc$(EXE) libchicken$(SO) \
+ libuchicken$(SO) chicken-install$(EXE) chicken-uninstall$(EXE) \
+ chicken-status$(EXE) \
+ libchickengui$(SO) chicken-bug$(EXE)
+endif
+
+chicken-config.h: chicken-defaults.h
+ echo "#define HAVE_DIRENT_H 1" >$@
+ echo "#define HAVE_INTTYPES_H 1" >>$@
+ echo "#define HAVE_LIMITS_H 1" >>$@
+ echo "#define HAVE_LONG_LONG 1" >>$@
+ echo "#define HAVE_MEMMOVE 1" >>$@
+ echo "#define HAVE_MEMORY_H 1" >>$@
+ echo "#define HAVE_STDINT_H 1" >>$@
+ echo "#define HAVE_STDLIB_H 1" >>$@
+ echo "#define HAVE_STRERROR 1" >>$@
+ echo "#define HAVE_STRINGS_H 1" >>$@
+ echo "#define HAVE_STRING_H 1" >>$@
+ echo "#define HAVE_STRTOLL 1" >>$@
+ echo "#define HAVE_SYS_STAT_H 1" >>$@
+ echo "#define HAVE_SYS_TYPES_H 1" >>$@
+ echo "#define HAVE_UNISTD_H 1" >>$@
+ echo "#define HAVE_UNSIGNED_LONG_LONG 1" >>$@
+ echo "#define HAVE_WINDOWS_H 1" >>$@
+ echo "#define HAVE__STRTOI64 1" >>$@
+ echo "#define STDC_HEADERS 1" >>$@
+ echo "#define HAVE_ALLOCA_H 1" >>$@
+ echo "#define HAVE_DIRECT_H 1" >>$@
+ echo "#define HAVE_ERRNO_H 1" >>$@
+ echo "#define HAVE_GCVT 1" >>$@
+ echo "#define HAVE_LOADLIBRARY 1" >>$@
+ echo "#define HAVE_GETPROCADDRESS 1" >>$@
+ echo "#define HAVE_WINSOCK2_H 1" >>$@
+ echo "#define HAVE_WS2TCPIP_H 1" >>$@
+ echo "#define C_STACK_GROWS_DOWNWARD 1" >>$@
+ifdef GCHOOKS
+ echo "#define C_GC_HOOKS" >>$@
+endif
+ifdef SYMBOLGC
+ echo "#define C_COLLECT_ALL_SYMBOLS" >>$@
+endif
+ifdef NOAPPLYHOOK
+ echo "#define C_NO_APPLY_HOOK" >>$@
+endif
+ echo "#define C_HACKED_APPLY" >>$@
+ cat chicken-defaults.h >>$@
+
+include $(SRCDIR)rules.make
diff --git a/Makefile.cygwin b/Makefile.cygwin
new file mode 100644
index 00000000..9ec8c867
--- /dev/null
+++ b/Makefile.cygwin
@@ -0,0 +1,242 @@
+# Makefile.cygwin - configuration for Linux -*- Makefile -*-
+#
+# Copyright (c) 2007, Felix L. Winkelmann
+# Copyright (c) 2008-2009, The Chicken Team
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+# conditions are met:
+#
+# Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+# disclaimer.
+# 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.
+# Neither the name of the author nor the names of its contributors may be used to endorse or promote
+# products derived from this software without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+# OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+# AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+
+
+SRCDIR = ./
+
+# platform configuration
+
+ARCH = x86
+HACKED_APPLY=1
+DLLSINPATH = 1
+
+# options
+
+SO = .dll
+EXE = .exe
+
+C_COMPILER = gcc
+CXX_COMPILER = g++
+LINKER = gcc
+
+
+C_COMPILER_OPTIONS = -fno-strict-aliasing -DHAVE_CHICKEN_CONFIG_H
+ifdef DEBUGBUILD
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -g -Wall -Wno-unused
+else
+ifdef OPTIMIZE_FOR_SPEED
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -O3 -fomit-frame-pointer
+else
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -Os -fomit-frame-pointer
+endif
+endif
+C_COMPILER_SHARED_OPTIONS = -DPIC
+LINKER_LINK_SHARED_LIBRARY_OPTIONS = -shared
+LINKER_LINK_SHARED_PROGRAM_OPTIONS = -Wl,--dll-search-prefix=cyg -Wl,--export-dynamic
+LIBCHICKEN_SO_LINKER_OPTIONS = -Wl,--out-implib,libchicken.dll.a \
+ -Wl,--export-all-symbols \
+ -Wl,--enable-auto-import \
+ -Wl,--image-base=0x10000000 \
+ -Wl,--dll \
+ -Wl,--add-stdcall-alias \
+ -Wl,--no-whole-archive
+LIBUCHICKEN_SO_LINKER_OPTIONS = -Wl,--out-implib,libuchicken.dll.a \
+ -Wl,--export-all-symbols \
+ -Wl,--enable-auto-import \
+ -Wl,--image-base=0x10000000 \
+ -Wl,--dll \
+ -Wl,--add-stdcall-alias \
+ -Wl,--no-whole-archive
+
+LIBRARIES = -lm
+LIBCHICKEN_IMPORT_LIBRARY = libchicken.dll.a
+LIBUCHICKEN_IMPORT_LIBRARY = libuchicken.dll.a
+
+
+# special files
+
+CHICKEN_CONFIG_H = chicken-config.h
+APPLY_HACK_OBJECT = apply-hack.$(ARCH)$(O)
+
+# select default and internal settings
+
+CUSTOM_CHICKEN_DEFAULTS=1
+include $(SRCDIR)/defaults.make
+
+LIBCHICKEN_SO_LIBRARIES = $(LIBRARIES)
+LIBUCHICKEN_SO_LIBRARIES = $(LIBRARIES)
+
+chicken-config.h: chicken-defaults.h buildsvnrevision
+ echo "#define C_SVN_REVISION $(shell cat buildsvnrevision)" >$@
+ echo "#define HAVE_DIRENT_H 1" >>$@
+ echo "#define HAVE_INTTYPES_H 1" >>$@
+ echo "#define HAVE_LIMITS_H 1" >>$@
+ echo "#define HAVE_LONG_LONG 1" >>$@
+ echo "#define HAVE_MEMMOVE 1" >>$@
+ echo "#define HAVE_MEMORY_H 1" >>$@
+ echo "#define HAVE_STDINT_H 1" >>$@
+ echo "#define HAVE_STDLIB_H 1" >>$@
+ echo "#define HAVE_STRERROR 1" >>$@
+ echo "#define HAVE_STRINGS_H 1" >>$@
+ echo "#define HAVE_STRING_H 1" >>$@
+ echo "#define HAVE_STRTOLL 1" >>$@
+ echo "#define HAVE_STRTOQ 1" >>$@
+ echo "#define HAVE_SYS_STAT_H 1" >>$@
+ echo "#define HAVE_SYS_TYPES_H 1" >>$@
+ echo "#define HAVE_UNISTD_H 1" >>$@
+ echo "#define HAVE_UNSIGNED_LONG_LONG 1" >>$@
+ echo "#define STDC_HEADERS 1" >>$@
+ echo "#define HAVE_ALLOCA 1" >>$@
+ echo "#define HAVE_ALLOCA_H 1" >>$@
+ echo "#define HAVE_GRP_H 1" >>$@
+ echo "#define HAVE_ERRNO_H 1" >>$@
+ echo "#define HAVE_GCVT 1" >>$@
+ echo "#define HAVE_SYSEXITS_H 1" >>$@
+ echo "#define HAVE_DLFCN_H 1" >>$@
+ echo "#define C_STACK_GROWS_DOWNWARD 1" >>$@
+ifdef GCHOOKS
+ echo "#define C_GC_HOOKS" >>$@
+endif
+ifdef SYMBOLGC
+ echo "#define C_COLLECT_ALL_SYMBOLS" >>$@
+endif
+ifdef NOAPPLYHOOK
+ echo "#define C_NO_APPLY_HOOK" >>$@
+endif
+ifdef HACKED_APPLY
+ echo "#define C_HACKED_APPLY" >>$@
+endif
+ cat chicken-defaults.h >>$@
+
+chicken-defaults.h:
+ echo "/* generated */" >$@
+ echo "#define C_BUILD_TAG \"$(BUILD_TAG)\"" >>$@
+ echo "#define C_CHICKEN_PROGRAM \"$(CHICKEN_PROGRAM)$(EXE)\"" >>$@
+ echo "#define C_SVN_REVISION $(shell cat buildsvnrevision)" >>$@
+ echo "#ifndef C_INSTALL_CC" >>$@
+ echo "# define C_INSTALL_CC \"$(C_COMPILER)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_CXX" >>$@
+ echo "# define C_INSTALL_CXX \"$(CXX_COMPILER)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_CFLAGS" >>$@
+ echo "# define C_INSTALL_CFLAGS \"$(C_COMPILER_OPTIONS) $(C_COMPILER_OPTIMIZATION_OPTIONS)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_LDFLAGS" >>$@
+ echo "# define C_INSTALL_LDFLAGS \"$(LINKER_OPTIONS) $(LINKER_OPTIMIZATION_OPTIONS)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_SHARE_HOME" >>$@
+ echo "# define C_INSTALL_SHARE_HOME \"$(DATADIR)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_BIN_HOME" >>$@
+ echo "# define C_INSTALL_BIN_HOME \"$(BINDIR)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_EGG_HOME" >>$@
+ echo "# define C_INSTALL_EGG_HOME \"$(EGGDIR)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_LIB_HOME" >>$@
+ echo "# define C_INSTALL_LIB_HOME \"$(BINDIR)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_STATIC_LIB_HOME" >>$@
+ echo "# define C_INSTALL_STATIC_LIB_HOME \"$(LIBDIR)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_INCLUDE_HOME" >>$@
+ echo "# define C_INSTALL_INCLUDE_HOME \"$(INCDIR)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_MORE_LIBS" >>$@
+ echo "# define C_INSTALL_MORE_LIBS \"$(LIBRARIES)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_MORE_STATIC_LIBS" >>$@
+ echo "# define C_INSTALL_MORE_STATIC_LIBS \"$(LIBRARIES)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_DEFAULT_TARGET_STACK_SIZE" >>$@
+ echo "# define C_DEFAULT_TARGET_STACK_SIZE $(NURSERY)" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_DEFAULT_TARGET_HEAP_SIZE" >>$@
+ echo "# define C_DEFAULT_TARGET_HEAP_SIZE 0" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_STACK_GROWS_DOWNWARD" >>$@
+ echo "# define C_STACK_GROWS_DOWNWARD $(STACKDIRECTION)" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_MORE_LIBS" >>$@
+ echo "# define C_TARGET_MORE_LIBS \"$(TARGET_LIBRARIES)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_MORE_STATIC_LIBS" >>$@
+ echo "# define C_TARGET_MORE_STATIC_LIBS \"$(TARGET_LIBRARIES)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_CC" >>$@
+ echo "# define C_TARGET_CC \"$(TARGET_C_COMPILER)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_CXX" >>$@
+ echo "# define C_TARGET_CXX \"$(TARGET_CXX_COMPILER)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_CFLAGS" >>$@
+ echo "# define C_TARGET_CFLAGS \"$(TARGET_C_COMPILER_OPTIONS) $(TARGET_C_COMPILER_OPTIMIZATION_OPTIONS)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_LDFLAGS" >>$@
+ echo "# define C_TARGET_LDFLAGS \"$(TARGET_LINKER_OPTIONS) $(TARGET_LINKER_OPTIMIZATION_OPTIONS)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_CROSS_CHICKEN" >>$@
+ echo "# define C_CROSS_CHICKEN $(CROSS_CHICKEN)" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_BIN_HOME" >>$@
+ echo "# define C_TARGET_BIN_HOME \"$(TARGET_PREFIX)/bin\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_LIB_HOME" >>$@
+ echo "# define C_TARGET_LIB_HOME \"$(TARGET_PREFIX)/bin\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_RUN_LIB_HOME" >>$@
+ echo "# define C_TARGET_RUN_LIB_HOME \"$(TARGET_RUN_PREFIX)/bin\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_SHARE_HOME" >>$@
+ echo "# define C_TARGET_SHARE_HOME \"$(TARGET_PREFIX)/share\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_INCLUDE_HOME" >>$@
+ echo "# define C_TARGET_INCLUDE_HOME \"$(TARGET_PREFIX)/include\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_STATIC_LIB_HOME" >>$@
+ echo "# define C_TARGET_STATIC_LIB_HOME \"$(TARGET_PREFIX)/lib\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_CHICKEN_PROGRAM" >>$@
+ echo "# define C_CHICKEN_PROGRAM \"$(CHICKEN_PROGRAM)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_CSC_PROGRAM" >>$@
+ echo "# define C_CSC_PROGRAM \"$(CSC_PROGRAM)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_CSI_PROGRAM" >>$@
+ echo "# define C_CSI_PROGRAM \"$(CSI_PROGRAM)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_CHICKEN_BUG_PROGRAM" >>$@
+ echo "# define C_CHICKEN_BUG_PROGRAM \"$(CHICKEN_BUG_PROGRAM)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_WINDOWS_SHELL" >>$@
+ echo "# define C_WINDOWS_SHELL 0" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_BINARY_VERSION" >>$@
+ echo "# define C_BINARY_VERSION $(BINARYVERSION)" >>$@
+ echo "#endif" >>$@
+
+include $(SRCDIR)/rules.make
diff --git a/Makefile.linux b/Makefile.linux
new file mode 100644
index 00000000..bc3b9e35
--- /dev/null
+++ b/Makefile.linux
@@ -0,0 +1,105 @@
+# Makefile.linux - configuration for Linux -*- Makefile -*-
+#
+# Copyright (c) 2007, Felix L. Winkelmann
+# Copyright (c) 2008-2009, The Chicken Team
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+# conditions are met:
+#
+# Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+# disclaimer.
+# 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.
+# Neither the name of the author nor the names of its contributors may be used to endorse or promote
+# products derived from this software without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+# OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+# AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+
+
+SRCDIR ?= ./
+
+# platform configuration
+
+ARCH = $(shell sh $(SRCDIR)/config-arch.sh)
+
+# options
+
+C_COMPILER_OPTIONS = -fno-strict-aliasing -DHAVE_CHICKEN_CONFIG_H
+ifdef DEBUGBUILD
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -g -Wall -Wno-unused
+else
+ifdef OPTIMIZE_FOR_SPEED
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -O3 -fomit-frame-pointer
+else
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -Os -fomit-frame-pointer
+endif
+endif
+LINKER_LINK_SHARED_LIBRARY_OPTIONS = -shared
+LINKER_LINK_SHARED_DLOADABLE_OPTIONS = -L. -shared -Wl,-R$(RUNTIME_LINKER_PATH)
+LINKER_LINK_SHARED_PROGRAM_OPTIONS = -Wl,-R$(RUNTIME_LINKER_PATH)
+LIBCHICKEN_SO_LINKER_OPTIONS = -Wl,-soname,libchicken.so$(SONAME_VERSION)
+LIBUCHICKEN_SO_LINKER_OPTIONS = -Wl,-soname,libuchicken.so$(SONAME_VERSION)
+LIBRARIES = -lm -ldl
+NEEDS_RELINKING = yes
+USES_SONAME = yes
+
+# special files
+
+CHICKEN_CONFIG_H = chicken-config.h
+
+# select default and internal settings
+
+include $(SRCDIR)/defaults.make
+
+chicken-config.h: chicken-defaults.h
+ echo "#define HAVE_DIRENT_H 1" >$@
+ echo "#define HAVE_DLFCN_H 1" >>$@
+ echo "#define HAVE_INTTYPES_H 1" >>$@
+ echo "#define HAVE_LIMITS_H 1" >>$@
+ echo "#define HAVE_LONG_LONG 1" >>$@
+ echo "#define HAVE_MEMMOVE 1" >>$@
+ echo "#define HAVE_MEMORY_H 1" >>$@
+ echo "#define HAVE_STDINT_H 1" >>$@
+ echo "#define HAVE_STDLIB_H 1" >>$@
+ echo "#define HAVE_STRERROR 1" >>$@
+ echo "#define HAVE_STRINGS_H 1" >>$@
+ echo "#define HAVE_STRING_H 1" >>$@
+ echo "#define HAVE_STRTOLL 1" >>$@
+ echo "#define HAVE_STRTOQ 1" >>$@
+ echo "#define HAVE_SYS_STAT_H 1" >>$@
+ echo "#define HAVE_SYS_TYPES_H 1" >>$@
+ echo "#define HAVE_UNISTD_H 1" >>$@
+ echo "#define HAVE_UNSIGNED_LONG_LONG 1" >>$@
+ echo "#define STDC_HEADERS 1" >>$@
+ echo "#define HAVE_ALLOCA 1" >>$@
+ echo "#define HAVE_ALLOCA_H 1" >>$@
+ echo "#define HAVE_GRP_H 1" >>$@
+ echo "#define HAVE_ERRNO_H 1" >>$@
+ echo "#define HAVE_GCVT 1" >>$@
+ echo "#define HAVE_SYSEXITS_H 1" >>$@
+ echo "#define HAVE_MEMMOVE 1" >>$@
+ echo "#define C_STACK_GROWS_DOWNWARD 1" >>$@
+ifdef GCHOOKS
+ echo "#define C_GC_HOOKS" >>$@
+endif
+ifdef SYMBOLGC
+ echo "#define C_COLLECT_ALL_SYMBOLS" >>$@
+endif
+ifdef NOAPPLYHOOK
+ echo "#define C_NO_APPLY_HOOK" >>$@
+endif
+ifneq ($(HACKED_APPLY),)
+ echo "#define C_HACKED_APPLY" >>$@
+endif
+ cat chicken-defaults.h >>$@
+
+include $(SRCDIR)/rules.make
diff --git a/Makefile.macosx b/Makefile.macosx
new file mode 100644
index 00000000..581b8d08
--- /dev/null
+++ b/Makefile.macosx
@@ -0,0 +1,135 @@
+# Makefile.macosx - configuration for Apple Macintosh OS X -*- Makefile -*-
+#
+# Copyright (c) 2007, Felix L. Winkelmann
+# Copyright (c) 2008-2009, The Chicken Team
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+# conditions are met:
+#
+# Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+# disclaimer.
+# 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.
+# Neither the name of the author nor the names of its contributors may be used to endorse or promote
+# products derived from this software without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+# OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+# AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+
+
+SRCDIR = ./
+
+# platform configuration
+
+ARCH = $(shell sh $(SRCDIR)/config-arch.sh)
+
+# commands
+
+POSTINSTALL_PROGRAM = install_name_tool
+
+# options
+
+C_COMPILER_OPTIONS = -no-cpp-precomp -fno-strict-aliasing -fno-common -DHAVE_CHICKEN_CONFIG_H
+ifdef DEBUGBUILD
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -g -Wall -Wno-unused
+else
+ifdef OPTIMIZE_FOR_SPEED
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -O3 -fomit-frame-pointer
+else
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -Os -fomit-frame-pointer
+endif
+endif
+LINKER_LINK_SHARED_LIBRARY_OPTIONS = -dynamiclib -compatibility_version 1 -current_version 1.0 -install_name $@
+POSTINSTALL_PROGRAM_FLAGS = -change libchicken$(SO) $(LIBDIR)/libchicken$(SO)
+LIBRARIAN_OPTIONS = scru
+LINKER_LINK_SHARED_DLOADABLE_OPTIONS = -bundle -L.
+
+# file extensions
+
+SO = .dylib
+
+# special files
+
+CHICKEN_CONFIG_H = chicken-config.h
+APPLY_HACK_OBJECT = apply-hack.$(ARCH)$(O)
+
+# architectures
+
+ifeq ($(ARCH),x86-64)
+C_COMPILER_OPTIONS += -m64
+LINKER_OPTIONS += -m64
+# Avoid bus error in install_name_tool
+LINKER_LINK_SHARED_DLOADABLE_OPTIONS += -Wl,-headerpad -Wl,128
+else
+
+ifeq ($(ARCH),universal)
+C_COMPILER_OPTIONS += -arch ppc -arch i386 -isysroot /Developer/SDKs/MacOSX10.4u.sdk
+LINKER_OPTIONS += -arch ppc -arch i386 -isysroot /Developer/SDKs/MacOSX10.4u.sdk
+
+ifneq ($(HACKED_APPLY),)
+# We undefine HACKED_APPLY in order to override rules.make.
+HACKED_APPLY=
+apply-hack.ppc.darwin$(O): apply-hack.ppc.darwin.S
+ as -arch ppc -o $@ $<
+apply-hack.x86$(O): apply-hack.x86.S
+ as -arch i386 -o $@ $<
+$(APPLY_HACK_OBJECT): apply-hack.x86$(O) apply-hack.ppc.darwin$(O)
+ lipo -create -output $(APPLY_HACK_OBJECT) $^
+endif
+endif
+endif
+
+# select default and internal settings
+
+include $(SRCDIR)/defaults.make
+
+chicken-config.h: chicken-defaults.h
+ echo "#define HAVE_DIRENT_H 1" >$@
+ echo "#define HAVE_DLFCN_H 1" >>$@
+ echo "#define HAVE_INTTYPES_H 1" >>$@
+ echo "#define HAVE_LIMITS_H 1" >>$@
+ echo "#define HAVE_LONG_LONG 1" >>$@
+ echo "#define HAVE_MEMMOVE 1" >>$@
+ echo "#define HAVE_MEMORY_H 1" >>$@
+ echo "#define HAVE_STDINT_H 1" >>$@
+ echo "#define HAVE_STDLIB_H 1" >>$@
+ echo "#define HAVE_STRERROR 1" >>$@
+ echo "#define HAVE_STRINGS_H 1" >>$@
+ echo "#define HAVE_STRING_H 1" >>$@
+ echo "#define HAVE_STRTOLL 1" >>$@
+ echo "#define HAVE_STRTOQ 1" >>$@
+ echo "#define HAVE_SYS_STAT_H 1" >>$@
+ echo "#define HAVE_SYS_TYPES_H 1" >>$@
+ echo "#define HAVE_UNISTD_H 1" >>$@
+ echo "#define HAVE_UNSIGNED_LONG_LONG 1" >>$@
+ echo "#define STDC_HEADERS 1" >>$@
+ echo "#define HAVE_ALLOCA 1" >>$@
+ echo "#define HAVE_ALLOCA_H 1" >>$@
+ echo "#define HAVE_GRP_H 1" >>$@
+ echo "#define HAVE_CRT_EXTERNS_H 1" >>$@
+ echo "#define HAVE_ERRNO_H 1" >>$@
+ echo "#define HAVE_SYSEXITS_H 1" >>$@
+ echo "#define C_STACK_GROWS_DOWNWARD 1" >>$@
+ifdef GCHOOKS
+ echo "#define C_GC_HOOKS" >>$@
+endif
+ifdef SYMBOLGC
+ echo "#define C_COLLECT_ALL_SYMBOLS" >>$@
+endif
+ifdef NOAPPLYHOOK
+ echo "#define C_NO_APPLY_HOOK" >>$@
+endif
+ifneq ($(HACKED_APPLY),)
+ echo "#define C_HACKED_APPLY" >>$@
+endif
+ cat chicken-defaults.h >>$@
+
+include $(SRCDIR)/rules.make
diff --git a/Makefile.mingw b/Makefile.mingw
new file mode 100644
index 00000000..b7a75e05
--- /dev/null
+++ b/Makefile.mingw
@@ -0,0 +1,241 @@
+# Makefile.mingw - configuration for MinGW (no MSYS) -*- Makefile -*-
+#
+# Copyright (c) 2007, Felix L. Winkelmann
+# Copyright (c) 2008-2009, The Chicken Team
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+# conditions are met:
+#
+# Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+# disclaimer.
+# 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.
+# Neither the name of the author nor the names of its contributors may be used to endorse or promote
+# products derived from this software without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+# OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+# AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+
+
+SEP = $(strip \)
+SRCDIR =.$(SEP)
+
+# platform configuration
+
+DLLSINPATH = 1
+ARCH = x86
+WINDOWS = 1
+WINDOWS_SHELL = 1
+UNAME_SYS = MinGW
+
+ifeq ($(ARCH),x86)
+HACKED_APPLY = 1
+else
+HACKED_APPLY =
+endif
+
+# file extensions
+
+SO = .dll
+EXE = .exe
+
+# options
+
+C_COMPILER ?= gcc
+C_COMPILER_OPTIONS = -fno-strict-aliasing -DHAVE_CHICKEN_CONFIG_H
+ifdef DEBUGBUILD
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -g -Wall -Wno-unused
+else
+ifdef OPTIMIZE_FOR_SPEED
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -O3
+else
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -Os
+endif
+endif
+C_COMPILER_SHARED_OPTIONS = -DPIC
+C_COMPILER_GUI_RUNTIME_OPTIONS = -DC_WINDOWS_GUI
+LINKER_LINK_SHARED_LIBRARY_OPTIONS = -shared
+LIBRARIES = -lm -lws2_32
+LINKER_OPTIONS = -Wl,--enable-auto-import
+LIBCHICKEN_SO_LINKER_OPTIONS = -Wl,--out-implib,libchicken.dll.a
+LIBUCHICKEN_SO_LINKER_OPTIONS = -Wl,--out-implib,libuchicken.dll.a
+LIBCHICKENGUI_SO_LINKER_OPTIONS = -Wl,--out-implib,libchickengui.dll.a
+LIBCHICKEN_SO_LIBRARIES = -lm -lws2_32
+LIBUCHICKEN_SO_LIBRARIES = -lm -lws2_32
+LIBCHICKENGUI_SO_LIBRARIES = -lm -lkernel32 -luser32 -lgdi32 -lws2_32
+LIBCHICKENGUI_IMPORT_LIBRARY = libchickengui.dll.a
+LIBCHICKEN_IMPORT_LIBRARY = libchicken.dll.a
+LIBUCHICKEN_IMPORT_LIBRARY = libuchicken.dll.a
+MAKEDIR_COMMAND_OPTIONS =
+
+# special files
+
+CHICKEN_CONFIG_H = chicken-config.h
+APPLY_HACK_OBJECT = apply-hack.$(ARCH)$(O)
+POSIXFILE = posixwin
+
+# select default and internal settings
+
+CUSTOM_CHICKEN_DEFAULTS=1
+
+include $(SRCDIR)defaults.make
+
+# main target
+
+all: libchicken$(A) libuchicken$(A) chicken$(EXE) csi$(EXE) chicken-profile$(EXE) \
+ csc$(EXE) libchicken$(SO) \
+ libuchicken$(SO) libchickengui$(SO) libchickengui$(A) chicken-install$(EXE) \
+ chicken-status$(EXE) chicken-uninstall$(EXE)
+
+chicken-config.h: chicken-defaults.h
+ echo #define HAVE_DIRENT_H 1 >$@
+ echo #define HAVE_INTTYPES_H 1 >>$@
+ echo #define HAVE_LIMITS_H 1 >>$@
+ echo #define HAVE_LONG_LONG 1 >>$@
+ echo #define HAVE_MEMMOVE 1 >>$@
+ echo #define HAVE_MEMORY_H 1 >>$@
+ echo #define HAVE_STDINT_H 1 >>$@
+ echo #define HAVE_STDLIB_H 1 >>$@
+ echo #define HAVE_STRERROR 1 >>$@
+ echo #define HAVE_STRINGS_H 1 >>$@
+ echo #define HAVE_STRING_H 1 >>$@
+ echo #define HAVE_STRTOLL 1 >>$@
+ echo #define HAVE_SYS_STAT_H 1 >>$@
+ echo #define HAVE_SYS_TYPES_H 1 >>$@
+ echo #define HAVE_UNISTD_H 1 >>$@
+ echo #define HAVE_UNSIGNED_LONG_LONG 1 >>$@
+ echo #define HAVE_WINDOWS_H 1 >>$@
+ echo #define HAVE__STRTOI64 1 >>$@
+ echo #define STDC_HEADERS 1 >>$@
+ echo #define HAVE_ALLOCA_H 1 >>$@
+ echo #define HAVE_DIRECT_H 1 >>$@
+ echo #define HAVE_ERRNO_H 1 >>$@
+ echo #define HAVE_GCVT 1 >>$@
+ echo #define HAVE_LOADLIBRARY 1 >>$@
+ echo #define HAVE_GETPROCADDRESS 1 >>$@
+ echo #define HAVE_WINSOCK2_H 1 >>$@
+ echo #define HAVE_WS2TCPIP_H 1 >>$@
+ echo #define C_STACK_GROWS_DOWNWARD 1 >>$@
+ifdef GCHOOKS
+ echo #define C_GC_HOOKS >>$@
+endif
+ifdef SYMBOLGC
+ echo #define C_COLLECT_ALL_SYMBOLS >>$@
+endif
+ifdef NOAPPLYHOOK
+ echo #define C_NO_APPLY_HOOK >>$@
+endif
+ echo #define C_HACKED_APPLY >>$@
+ type chicken-defaults.h >>$@
+
+chicken-defaults.h:
+ echo /* generated */ >$@
+ echo #define C_BUILD_TAG "$(BUILD_TAG)" >>$@
+ echo #define C_CHICKEN_PROGRAM "$(CHICKEN_PROGRAM)$(EXE)" >>$@
+ echo #define C_WINDOWS_SHELL 1 >>$@
+ echo #ifndef C_INSTALL_CC >>$@
+ echo # define C_INSTALL_CC "$(C_COMPILER)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_INSTALL_CXX >>$@
+ echo # define C_INSTALL_CXX "$(CXX_COMPILER)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_INSTALL_CFLAGS >>$@
+ echo # define C_INSTALL_CFLAGS "$(C_COMPILER_OPTIONS) $(C_COMPILER_OPTIMIZATION_OPTIONS)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_INSTALL_LDFLAGS >>$@
+ echo # define C_INSTALL_LDFLAGS "$(LINKER_OPTIONS) $(LINKER_OPTIMIZATION_OPTIONS)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_INSTALL_SHARE_HOME >>$@
+ echo # define C_INSTALL_SHARE_HOME "$(DATADIR)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_INSTALL_BIN_HOME >>$@
+ echo # define C_INSTALL_BIN_HOME "$(BINDIR)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_INSTALL_EGG_HOME >>$@
+ echo # define C_INSTALL_EGG_HOME "$(EGGDIR)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_INSTALL_LIB_HOME >>$@
+ echo # define C_INSTALL_LIB_HOME "$(LIBDIR)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_INSTALL_STATIC_LIB_HOME >>$@
+ echo # define C_INSTALL_STATIC_LIB_HOME "$(LIBDIR)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_INSTALL_INCLUDE_HOME >>$@
+ echo # define C_INSTALL_INCLUDE_HOME "$(INCDIR)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_INSTALL_MORE_LIBS >>$@
+ echo # define C_INSTALL_MORE_LIBS "$(LIBRARIES)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_INSTALL_MORE_STATIC_LIBS >>$@
+ echo # define C_INSTALL_MORE_STATIC_LIBS "$(LIBRARIES)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_DEFAULT_TARGET_STACK_SIZE >>$@
+ echo # define C_DEFAULT_TARGET_STACK_SIZE $(NURSERY) >>$@
+ echo #endif >>$@
+ echo #ifndef C_DEFAULT_TARGET_HEAP_SIZE >>$@
+ echo # define C_DEFAULT_TARGET_HEAP_SIZE 0 >>$@
+ echo #endif >>$@
+ echo #ifndef C_STACK_GROWS_DOWNWARD >>$@
+ echo # define C_STACK_GROWS_DOWNWARD $(STACKDIRECTION) >>$@
+ echo #endif >>$@
+ echo #ifndef C_TARGET_MORE_LIBS >>$@
+ echo # define C_TARGET_MORE_LIBS "$(TARGET_LIBRARIES)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_TARGET_MORE_STATIC_LIBS >>$@
+ echo # define C_TARGET_MORE_STATIC_LIBS "$(TARGET_LIBRARIES)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_TARGET_CC >>$@
+ echo # define C_TARGET_CC "$(TARGET_C_COMPILER)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_TARGET_CXX >>$@
+ echo # define C_TARGET_CXX "$(TARGET_CXX_COMPILER)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_TARGET_CFLAGS >>$@
+ echo # define C_TARGET_CFLAGS "$(TARGET_C_COMPILER_OPTIONS) $(TARGET_C_COMPILER_OPTIMIZATION_OPTIONS)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_TARGET_LDFLAGS >>$@
+ echo # define C_TARGET_LDFLAGS "$(TARGET_LINKER_OPTIONS) $(TARGET_LINKER_OPTIMIZATION_OPTIONS)" >>$@
+ echo #endif >>$@
+ echo #ifndef C_CROSS_CHICKEN >>$@
+ echo # define C_CROSS_CHICKEN $(CROSS_CHICKEN) >>$@
+ echo #endif >>$@
+ echo #ifndef C_TARGET_BIN_HOME >>$@
+ echo # define C_TARGET_BIN_HOME "$(TARGET_PREFIX)/bin" >>$@
+ echo #endif >>$@
+ echo #ifndef C_TARGET_LIB_HOME >>$@
+ echo # define C_TARGET_LIB_HOME "$(TARGET_PREFIX)/lib" >>$@
+ echo #endif >>$@
+ echo #ifndef C_TARGET_RUN_LIB_HOME >>$@
+ echo # define C_TARGET_RUN_LIB_HOME "$(TARGET_PREFIX)/lib" >>$@
+ echo #endif >>$@
+ echo #ifndef C_TARGET_SHARE_HOME >>$@
+ echo # define C_TARGET_SHARE_HOME "$(TARGET_PREFIX)/share" >>$@
+ echo #endif >>$@
+ echo #ifndef C_TARGET_INCLUDE_HOME >>$@
+ echo # define C_TARGET_INCLUDE_HOME "$(TARGET_PREFIX)/include" >>$@
+ echo #endif >>$@
+ echo #ifndef C_TARGET_STATIC_LIB_HOME >>$@
+ echo # define C_TARGET_STATIC_LIB_HOME "$(TARGET_PREFIX)/lib" >>$@
+ echo #endif >>$@
+ echo #ifndef C_CSC_PROGRAM" >>$@
+ echo # define C_CSC_PROGRAM "$(CSC_PROGRAM)" >>$@
+ echo #endif" >>$@
+ echo #ifndef C_CSI_PROGRAM" >>$@
+ echo # define C_CSI_PROGRAM "$(CSI_PROGRAM)" >>$@
+ echo #endif" >>$@
+ echo #ifndef C_CHICKEN_BUG_PROGRAM" >>$@
+ echo # define C_CHICKEN_BUG_PROGRAM "$(CHICKEN_BUG_PROGRAM)" >>$@
+ echo #endif" >>$@
+ echo #ifndef C_BINARY_VERSION >>$@
+ echo # define C_BINARY_VERSION $(BINARYVERSION) >>$@
+ echo #endif >>$@
+
+include $(SRCDIR)rules.make
diff --git a/Makefile.mingw-msys b/Makefile.mingw-msys
new file mode 100644
index 00000000..7572c197
--- /dev/null
+++ b/Makefile.mingw-msys
@@ -0,0 +1,128 @@
+# Makefile.mingw - configuration for MinGW (MSYS) -*- Makefile -*-
+#
+# Copyright (c) 2007, Felix L. Winkelmann
+# Copyright (c) 2008-2009, The Chicken Team
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+# conditions are met:
+#
+# Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+# disclaimer.
+# 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.
+# Neither the name of the author nor the names of its contributors may be used to endorse or promote
+# products derived from this software without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+# OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+# AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+
+
+SRCDIR = ./
+
+# platform configuration
+
+DLLSINPATH = 1
+ARCH = x86
+HACKED_APPLY = 1
+WINDOWS = 1
+
+# file extensions
+
+SO = .dll
+EXE = .exe
+
+# options
+
+C_COMPILER_OPTIONS = -fno-strict-aliasing -DHAVE_CHICKEN_CONFIG_H
+ifdef DEBUGBUILD
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -g -Wall -Wno-unused
+else
+ifdef OPTIMIZE_FOR_SPEED
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -O3
+else
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -Os
+endif
+endif
+C_COMPILER_SHARED_OPTIONS = -DPIC
+C_COMPILER_GUI_RUNTIME_OPTIONS = -DC_WINDOWS_GUI
+LINKER_OPTIONS = -Wl,--enable-auto-import
+LINKER_LINK_SHARED_LIBRARY_OPTIONS = -shared
+LIBRARIES = -lm -lws2_32
+LIBCHICKEN_SO_LINKER_OPTIONS = -Wl,--out-implib,libchicken.dll.a
+LIBUCHICKEN_SO_LINKER_OPTIONS = -Wl,--out-implib,libuchicken.dll.a
+LIBCHICKENGUI_SO_LINKER_OPTIONS = -Wl,--out-implib,libchickengui.dll.a
+LIBCHICKEN_SO_LIBRARIES = -lm -lws2_32
+LIBUCHICKEN_SO_LIBRARIES = -lm -lws2_32
+LIBCHICKENGUI_SO_LIBRARIES = -lm -lkernel32 -luser32 -lgdi32 -lws2_32
+LIBCHICKENGUI_IMPORT_LIBRARY = libchickengui.dll.a
+LIBCHICKEN_IMPORT_LIBRARY = libchicken.dll.a
+LIBUCHICKEN_IMPORT_LIBRARY = libuchicken.dll.a
+
+# special files
+
+CHICKEN_CONFIG_H = chicken-config.h
+APPLY_HACK_OBJECT = apply-hack.$(ARCH)$(O)
+POSIXFILE = posixwin
+
+# select default and internal settings
+
+include $(SRCDIR)/defaults.make
+
+# main target
+
+all: libchicken$(A) libuchicken$(A) chicken$(EXE) csi$(EXE) chicken-profile$(EXE) \
+ csc$(EXE) libchicken$(SO) \
+ libuchicken$(SO) libchickengui$(SO) libchickengui$(A) chicken-install$(EXE) \
+ chicken-uninstall$(EXE) chicken-status$(EXE)
+
+chicken-config.h: chicken-defaults.h
+ echo "#define HAVE_DIRENT_H 1" >$@
+ echo "#define HAVE_INTTYPES_H 1" >>$@
+ echo "#define HAVE_LIMITS_H 1" >>$@
+ echo "#define HAVE_LONG_LONG 1" >>$@
+ echo "#define HAVE_MEMMOVE 1" >>$@
+ echo "#define HAVE_MEMORY_H 1" >>$@
+ echo "#define HAVE_STDINT_H 1" >>$@
+ echo "#define HAVE_STDLIB_H 1" >>$@
+ echo "#define HAVE_STRERROR 1" >>$@
+ echo "#define HAVE_STRINGS_H 1" >>$@
+ echo "#define HAVE_STRING_H 1" >>$@
+ echo "#define HAVE_STRTOLL 1" >>$@
+ echo "#define HAVE_SYS_STAT_H 1" >>$@
+ echo "#define HAVE_SYS_TYPES_H 1" >>$@
+ echo "#define HAVE_UNISTD_H 1" >>$@
+ echo "#define HAVE_UNSIGNED_LONG_LONG 1" >>$@
+ echo "#define HAVE_WINDOWS_H 1" >>$@
+ echo "#define HAVE__STRTOI64 1" >>$@
+ echo "#define STDC_HEADERS 1" >>$@
+ echo "#define HAVE_ALLOCA_H 1" >>$@
+ echo "#define HAVE_DIRECT_H 1" >>$@
+ echo "#define HAVE_ERRNO_H 1" >>$@
+ echo "#define HAVE_GCVT 1" >>$@
+ echo "#define HAVE_LOADLIBRARY 1" >>$@
+ echo "#define HAVE_GETPROCADDRESS 1" >>$@
+ echo "#define HAVE_WINSOCK2_H 1" >>$@
+ echo "#define HAVE_WS2TCPIP_H 1" >>$@
+ echo "#define C_WINDOWS_SHELL 1" >>$@
+ echo "#define C_STACK_GROWS_DOWNWARD 1" >>$@
+ifdef GCHOOKS
+ echo "#define C_GC_HOOKS" >>$@
+endif
+ifdef SYMBOLGC
+ echo "#define C_COLLECT_ALL_SYMBOLS" >>$@
+endif
+ifdef NOAPPLYHOOK
+ echo "#define C_NO_APPLY_HOOK" >>$@
+endif
+ echo "#define C_HACKED_APPLY" >>$@
+ cat chicken-defaults.h >>$@
+
+include $(SRCDIR)/rules.make
diff --git a/Makefile.solaris b/Makefile.solaris
new file mode 100644
index 00000000..9dbb4d50
--- /dev/null
+++ b/Makefile.solaris
@@ -0,0 +1,100 @@
+# Makefile.solaris - configuration for Solaris -*- Makefile -*-
+#
+# Copyright (c) 2007, Felix L. Winkelmann
+# Copyright (c) 2008-2009, The Chicken Team
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+# conditions are met:
+#
+# Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+# disclaimer.
+# 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.
+# Neither the name of the author nor the names of its contributors may be used to endorse or promote
+# products derived from this software without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+# OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+# AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+
+
+SRCDIR = ./
+
+# platform configuration
+
+ARCH = $(shell sh $(SRCDIR)/config-arch.sh)
+
+# options
+
+C_COMPILER_OPTIONS = -fno-strict-aliasing -DHAVE_CHICKEN_CONFIG_H
+ifdef DEBUGBUILD
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -g -Wall -Wno-unused
+else
+ifdef OPTIMIZE_FOR_SPEED
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -O3 -fomit-frame-pointer
+else
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -Os -fomit-frame-pointer
+endif
+endif
+LINKER_LINK_SHARED_LIBRARY_OPTIONS = -shared
+LINKER_LINK_SHARED_DLOADABLE_OPTIONS = -shared -Wl,-R$(RUNTIME_LINKER_PATH) -Wl,-L.
+LINKER_LINK_SHARED_PROGRAM_OPTIONS = -Wl,-R$(RUNTIME_LINKER_PATH)
+LIBRARIES = -lrt -lsocket -lnsl -lm -ldl
+NEEDS_RELINKING = yes
+
+# special files
+
+CHICKEN_CONFIG_H = chicken-config.h
+
+# select default and internal settings
+
+include $(SRCDIR)/defaults.make
+
+chicken-config.h: chicken-defaults.h
+ echo "#define HAVE_DIRENT_H 1" >$@
+ echo "#define HAVE_DLFCN_H 1" >>$@
+ echo "#define HAVE_INTTYPES_H 1" >>$@
+ echo "#define HAVE_LIMITS_H 1" >>$@
+ echo "#define HAVE_LONG_LONG 1" >>$@
+ echo "#define HAVE_MEMMOVE 1" >>$@
+ echo "#define HAVE_MEMORY_H 1" >>$@
+ echo "#define HAVE_STDINT_H 1" >>$@
+ echo "#define HAVE_STDLIB_H 1" >>$@
+ echo "#define HAVE_STRERROR 1" >>$@
+ echo "#define HAVE_STRINGS_H 1" >>$@
+ echo "#define HAVE_STRING_H 1" >>$@
+ echo "#define HAVE_STRTOLL 1" >>$@
+ echo "#define HAVE_SYS_STAT_H 1" >>$@
+ echo "#define HAVE_SYS_TYPES_H 1" >>$@
+ echo "#define HAVE_UNISTD_H 1" >>$@
+ echo "#define HAVE_UNSIGNED_LONG_LONG 1" >>$@
+ echo "#define STDC_HEADERS 1" >>$@
+ echo "#define HAVE_ALLOCA_H 1" >>$@
+ echo "#define HAVE_ALLOCA 1" >>$@
+ echo "#define HAVE_GRP_H 1" >>$@
+ echo "#define HAVE_ERRNO_H 1" >>$@
+ echo "#define HAVE_GCVT 1" >>$@
+ echo "#define HAVE_SYSEXITS_H 1" >>$@
+ echo "#define C_STACK_GROWS_DOWNWARD 1" >>$@
+ifdef GCHOOKS
+ echo "#define C_GC_HOOKS" >>$@
+endif
+ifdef SYMBOLGC
+ echo "#define C_COLLECT_ALL_SYMBOLS" >>$@
+endif
+ifdef NOAPPLYHOOK
+ echo "#define C_NO_APPLY_HOOK" >>$@
+endif
+ifneq ($(HACKED_APPLY),)
+ echo "#define C_HACKED_APPLY" >>$@
+endif
+ cat chicken-defaults.h >>$@
+
+include $(SRCDIR)/rules.make
diff --git a/NEWS b/NEWS
new file mode 100644
index 00000000..0dc0cc3e
--- /dev/null
+++ b/NEWS
@@ -0,0 +1,742 @@
+4.2.3
+
+- exported Unit data-structures 'reverse-string-append'
+
+4.2.2
+
+- added 'loaded-libraries', 'dynamic-library-load',
+ 'dynamic-library-procedure' and 'dynamic-library-variable' to eval unit;
+ basic support for shared binary load
+- fix for core library modules - regex-extras isn't but srfi-69 is
+- fix for builtin features - srfi-69 isn't
+- fix for pathnames with whitespace in 'runtests.sh' on Windows
+- fix for 'normalize-pathname' with absolute pathname argument
+- added 'decompose-directory' to unit files
+- fix for 'local-timezone-abbreviation' - wasn't using the current time
+ so tz-name constant
+- deprecated 'make-pathname' separator argument
+
+4.2.0
+
+- added compiler option `-emit-all-import-libraries'
+- added `reexport'
+- added compiler and interpreter option `-setup-mode'
+- various minor performance improvements
+- fix for 'create-directory' when parents wanted
+- `for-each-line' and `for-each-argv-line' have been deprecated
+- chicken-install tries alternative servers if server responds with error
+- fixed load bug (ticket #72)
+- new library procedure `get-condition-property'
+- many mingw build fixes (thanks tp Fadi Moukayed)
+- setup-api: deprecated `cross-chicken' (use `cond-expand' or
+ `feature?' instead)
+- added topological-sort to data-structures unit; chicken-install
+ sorts dependencies before installing them
+- "-optimize-level 2" enables inlining by default
+- disable executable stack in assembly code modules (patch by
+ Zbigniew, reported by Marijn Schouten)
+- csc now always exits with a status code of 1 on errors (patch by Zbigniew)
+
+
+4.1.0
+
+- The new parameter "parantheses-synonyms" and the command-line
+ option "-no-parantheses-synonyms" allow disabling list-like behaviour
+ of "{ ... }" and "[ ... ]" tokens
+- The new parameter "symbol-escape" and the command-line
+ option "-no-symbol-escape" allows disabling "| ... |" symbol escape
+ syntax
+- Added command-line option "-r5rs-syntax" to disable CHICKEN-specific
+ read-syntax
+- Removed "macro?" and "undefine-macro!"
+- Support for Microsoft Visual Studio / MSVC has been dropped
+- The compiler provides now a simple flow-analysis pass that does
+ basic checking of argument-counts and -types for core library procedure
+ calls (new option "-scrutinize")
+- New compiler-options "-no-argc-checks", "-no-bound-checks",
+ "-no-procedure checks", "-no-procedure-checks-for-usual-bindings",
+ "-types TYPEFILE" and "-consult-inline-file FILENAME"
+- Added a "chicken-setup" stub-application to catch incorrect use of
+ this tool (which has been replaced in 4.0.0 with "chicken-install")
+- Changed "setup-install-flag" and "setup-verbose-flag" to
+ "setup-install-mode" and "setup-verbose-mode" in "setup-api" module,
+ the old names are still available but deprecated
+- Posix unit:
+ added "socket?", "block-device?" and "character-device?", deprecated
+ redundant "stat-..." procedures
+- Added "directory-exists?"
+- "(for-each (lambda ...) X)" is compiled as a loop
+- The argument-count check for format-strings for "[sf]printf" with a constant
+ string argument is done at compile-time
+
+4.0.0
+
+- removed `apropos' and `apropos-list' from the "utils" library unit;
+ available as an extension
+- removed texinfo and PDF documentation - this will possible be added back
+ later
+- replaced PCRE regex engine with Alex Shinn's "irregex" regular expression
+ package
+- removed `-extension' option
+- removed `-static-extensions' csc option and added `-static-extension NAME'
+- `regex' unit: removed `regexp*' and `regex-optimize'
+- added `CHICKEN_new_finalizable_gc_root()'
+- `length' checks its argument for being cyclic
+- removed custom declarations and "link-options" and "c-options" declarations
+- deprecated "-quiet" option to "chicken" program
+- added "-update-db" option to chicken-install
+- the compiler now suggests possibly required module-imports
+- moved non-standard syntax-definitions into "chicken-syntax" library unit
+- the pretty-printer prints the end-of-file object readably now
+- alternative conditional execution paths have separate allocation computation
+ (previously the allocation of all alternatives was coalesced)
+- removed unused "%kmp-search" from "srfi-13" library unit
+- expander handles syntax-reexports and makes unexported syntax available
+ for exported expanders in import libraries
+- added checks in some procedures in the "tcp" library unit
+- the macro system has been completely overhauled and converted
+ to hygienic macros
+- a macro-aware module system has been added
+- added "-sx" option to csi
+- removed the following deprecated functions:
+ [un]shift!
+ andmap ormap
+ byte-vector? byte-vector-fill!
+ make-byte-vector byte-vector
+ byte-vector-set! byte-vector-ref
+ byte-vector->list list->byte-vector
+ string->byte-vector byte-vector->string
+ byte-vector-length
+ make-static-byte-vector static-byte-vector->pointer
+ byte-vector-move! byte-vector-append!
+ set-file-position! set-user-id! set-group-id!
+ set-process-group-id!
+ macro? undefine-macro!
+- the situation-identifiers "run-time" and "compile-time" have
+ been removed
+- the compiler options "-check-imports", "-import" and "-emit-exports"
+ have been removed
+- new procedures:
+ strip-syntax
+ expand
+- new macros
+ define-syntax
+ module
+ export
+- the following macros have been removed:
+ define-foreign-record
+ define-foreign-enum
+ define-macro
+ define-extension
+- "local" mode, in which locally defined exported toplevel variables can
+ be inlined
+- new options and declarations "[-]local", "[-]inline-global" and "-emit-inline-file"
+- optimization levels changed to use inlining:
+ -optimize-level 3: enables -inline -local (but *not* -unsafe)
+ -optimize-level 4: enables -inline -local -unsafe
+- increased default inlining-limit to 20
+- support for cross-module inlining
+- "make <VARIABLES> bench" runs the benchmark suite
+- "chicken-setup" has been replaced by new command line tools
+ "chicken-install", "chicken-uninstall" and "chicken-status", which are
+ more flexible and allow greater freedom when creating local or application-
+ specific repositories
+- extension-installation can be done directly from SVN repositories or a local
+ file tree
+- enabled chicken mirror site as alternative download location
+
+3.4.0
+
+- Fixes to the MinGW build.
+- PCRE 7.7
+- Bug fix for bitwise-or use [Joerg Wittenberger]
+- Bug fix in thread-terminate! [thanks to Joerg Wittenberger]
+- Cygwin build patched to put the runtime libraries in the right place.
+ [thanks to Nathan Thern]
+- added support for out-of-tree compilation (via the SRCDIR variable)
+ [thanks to Ivan Shmakov]
+- bug fix for (string->number "/")
+- support for selective procedure profiling in the compiler
+- unit utils: moved file- and pathname-related procedures to unit files
+- new unit files
+
+3.3.0
+
+- bug fix for bitwise-or use [Joerg Wittenberger]
+- bug fixes for tickets 393, 430, 436
+- bug fix pointer->address
+- the build system now sets the SONAME field of libchicken.so under Linux
+- fixed an allocation bug in decode_literal
+- some fixes to the build system when USE_HOST_PCRE is set
+- added use of unit ports to unit extras and chicken-setup
+- unit utils and extras: moved port extensions to unit ports
+- new unit ports
+
+3.2.0
+
+- unit extras: moved lists, queues, strings to data-structures
+- new unit data-structures
+- unit library: symbol->string now copies its argument
+- chicken-setup: added option -svn-trunk
+- unit utils: added file-copy and file-move (request by the einit team)
+- unit srfi-69: added hash-table-clear!
+- unit srfi-69: new
+- unit extras: moved SRFI 69 to unit srfi-69
+
+3.1.0
+
+- svnrevision.sh - cleaned logic to prevent invalid error message
+- csc - fixed bug preventing static linking of executables (build order issues)
+- unit regex: PCRE 7.6
+- unit regex: avoid string copy in regex matching [Jim Ursetto]
+- chicken-setup: eggs are downloaded to and compiled in a temporary
+ directory determined by CHICKEN_TMPDIR or TMPDIR environment
+ variables, or by -build-prefix and -download-dir options,
+ respectively; -destdir option is replaced with -install-prefix.
+- unit regex: PCRE 7.6
+- unit tcp: use of offset into string rather than substring for faster
+ socket write [Jim Ursetto]
+- MSVC can now be used to build the system, when standard UNIX tools (like
+ MSYS) are available [Many thanks to Ashley]
+- unit library: added "flonum-print-precision" for changing the default of
+ 16
+- unit posix: create-directory can now handle DOS drive letters
+ in the given path
+- unit posix: added stat- predicates for file types
+- unit posix: added strftime format string support to "time->string"
+- unit posix: added "string->time", which takes a strptime format string
+ (Unix only)
+- unit extras: added "left-section", "right-section", "none?", "always?",
+ and "never?"
+- unit extras: added "hash-table-merge", "hash-table-map",
+ "hash-table-for-each", and extended "make-hash-table" with minimum/maximum
+ load & initial value
+- unit extras: added "eq?-hash", "eqv?-hash", "equal?-hash", "number-hash",
+ "symbol-hash", "keyword-hash", "##sys#number-hash-hook", and
+ "hash-by-identity" as a synonym for "eq?-hash"
+
+3.0.0
+
+- upgraded scheme-complete.el to version 0.6 [Thanks to Alex Shinn]
+- unit library: added "blob=?"
+- the library can optionally be built with an already installed libpcre
+- chicken-setup accesses a separate set of eggs, specific on the major CHICKEN
+ version (3)
+- added csi options "-p" ("-print") and "-P" ("-pretty-print")
+- support for Mac OS X universal binaries hase been added [Thanks to Zbigniew]
+- `cond-expand' is available in the set of core macros [Thanks to Alex Shinn]
+- On sparc64 architectures more than 126 procedure arguments are allowed
+ [Thanks to Peter Bex]
+- posix unit: "seconds->string" and "time->string" have now their trailing
+ #\newline character removed. THIS IS A BACKWARD-INCOMPATIBLE CHANGE.
+
+2.739
+
+- the SVN checkout can now be built from a bootstrapping tarball without
+ the need for a pre-installed "chicken" executable
+- literals are compiled in a platform-independent binary encoding into
+ the executable which results in faster C compile times and moe compact
+ binaries. This also makes the "compress-literals" option and declaration
+ unnecessary
+- the "-compress-literals" compiler option and the "compress-literals"
+ declaration have been removed
+- the CHICKEN_HOME environment variable is now obsolete, use CHICKEN_PREFIX
+ and possibly CHICKEN_REPOSITORY_PATH
+- added pre GC hook C-level variable
+- Cygwin is now fully supported
+- removed deprecated functions:
+ extension-info
+ print-backtrace
+ test-feature?
+ ___callback (chicken.h)
+ foreign-callback-lambda[*]
+ thread-deliver-signal!
+ critical-section
+ enable-interrupts
+ disable-interrupts
+ invalid-procedure-call-handler
+- There is no platform-dependent pathname directory separator
+ anymore, the slash ("/") and backslash ("\") characters can be
+ used interchangably
+- New procedures "regexp*", "regex-optimize" and "make-anchored-pattern"
+ (regex library unit)
+- New procedures "terminall-size", "terminal-name" and "get-host-name"
+ (posix library unit)
+- chicken-setup: can create repository catalog file from local
+ SVN checkout of egg repository
+- chicken-setup has the new option "-host-extension" to force
+ compiling extensions in "host" mode when using a cross-compiling
+ chicken
+- Better cross-development support for the build system (the
+ Makefile accepts various variables for customizing the build)
+- "file-size" and "file-stat" handle file-sizes of >4GB now
+- "find-files" collects directories as well, now [Thanks to Ivan Raikov]
+- added "dist" target to toplevel makefile
+- "andmap" and "ormap" have been deprecated
+- makefiles support relinking now
+- added "thread-wait-for-i/o!" (srfi-18 library unit)
+- the "chicken-bug" program can now be used to create bug reports
+ and send them to the CHICKEN maintainers
+
+2.717
+
+- New binary compatibility version (3) - installed eggs mst be recompiled!
+- deprecated "shift!" and "unshift!"
+- regex unit:
+ Uses PCRE 7.4
+- utils unit:
+ Uses compiled regular expressions
+- unit posix:
+ Uses compiled regular expressions
+- removed build option for extra symbol slot
+- added Lisp-style symbol property lists
+
+2.701
+
+- countless bugfixes and minor improvements
+- new foreign types:
+ [nonnull-]unsigned-c-string[*]
+ c-string-list[*]
+- added "unused" declaration specifier
+- new GNU Make based build process
+- libffi is not used anymore, handcoded assembler is used for x86, x86-64
+ and powerpc platforms
+- library unit:
+ blob?
+ make-blob
+ blob-size
+ string->blob
+ blob->string
+- regex unit:
+ glob?
+- utils unit:
+ directory-null?
+ port-fold
+- extras unit:
+ hash-table-remove!
+- lolevel unit:
+ mutate-procedure
+- srfi-4 unit:
+ XXXvector->blob[/shared]
+ blob->XXXvector[/shared]
+- csc options:
+ -cxx-name
+ -disable-compiler-macros
+- byte-vectors have been removed and replaced by new "blob" type,
+ added various blob<->SRFI-4 vector conversion procedures in srfi-4 unit
+- ":optional" has been renamed to "optional" (the old name is still
+ available but deprecated)
+- "switch" has been replaced by "select" ("switch" is still available but
+ deprecated)
+- "tcp-connect" and "tcp-accept" handle time-outs via parameters
+ "tcp-connect-timeout" and "tcp-accept-timeout"
+- tcp unit: support for read/write timeouts
+
+
+2.6
+
+- Many bugfixes
+- Better support for Sun's C compiler
+- Input-performance has been improved
+- PCRE (Perl compatible regular expressions) by Philip Hazel is now
+ bundled with CHICKEN
+- Static linking of extensions is now possible (when supported by
+ the egg)
+- The interpreter warns about references to potentially unbound variables
+ in loaded code and expressions entered on the REPL
+- The expansion process is traced during compilation and interpretation
+ to give (slightly) more usable syntactic context in error messages
+- library:
+ * added `any?`, `bit-set?' and `on-exit'
+- eval:
+ * new procedure `set-parameterized-read-syntax!'
+- posix:
+ * SRFI-17 setters for `file-position`, `current-user-id',
+ `current-group-id', `process-group-id'; the respective setter-procedures
+ are still available but have been deprecated
+ * `file-stat' returns more information (including device info)
+ * added `process*'
+- extras:
+ * added `read-string!'
+- utils:
+ * `apropos' and `apropos-list' procedures
+- srfi-4:
+ * added `read-u8vector', `read-u8vector!' and `write-u8vector'
+- srfi-18:
+ * added `time->milliseconds' and `milliseconds->time'
+- csi:
+ * `-ss SCRIPTNAME' option
+- csc:
+ * accepts options given in the environment variable `CSC_OPTIONS'
+ * new options `-static-extensions' and `-host'
+- chicken/csc:
+ * new option `-keep-shadowed-macros'
+- chicken-setup:
+ * accepts options given in the environment variable `CHICKEN_SETUP_OPTIONS'
+ * allows retrieval and installation of eggs from subversion repository
+ and the local filesystem
+ * new options `-tree FILENAME', `-svn', `-local', `-revsion' and
+ `-destdir PATHNAME'
+ * added helper procedures `required-chicken-version' and
+ `required-extension-version'
+- Lots of improvements in the CMake build
+
+Many thanks to Ingo Bungener, Peter Busser, John Cowan, Marc Feeley,
+Stephen Gilardi, Mario Domenech Goulart, Joshua Griffith, Sven
+Hartrumpf, Daishi Kato, mejedi, Dan Muresan, Deanna
+Phillips, Robin Lee Powell, Ivan Raikov, Danial Sadilek, Alex Shinn,
+Tony Sideaway, Minh Thu for reporting bugs, suggesting improvements
+and contributing fixes.
+
+Thanks again to Brandon Van Every for his extensive work on the CMake
+build process.
+
+Special thanks to Kon Lovett for many improvements made in the posix
+library.
+
+
+2.5
+
+- Bugfixes
+- CHICKEN can now be built using CMake <http://www.cmake.org>, in fact CMake
+ is required to built CHICKEN from sources on Windows with the Microsoft
+ tools
+- the whole build process has been cleaned up and simplified
+- the "easyffi" and "tinyclos" library units have been removed from the base
+ system and are now available as separate extensions
+- the deprecated "set-dispatch-read-syntax!" has been removed
+- Will Farr cleaned up the behaviour of number-type specific numeric operations
+ ("fx..."/"fp...") with respect to safe/unsafe mode
+- added "(finite? NUMBER)"
+- the "$" macro moved into its own separate extension
+- the values of "software-type", "software-version", "machine-type" and "machine-byte-order"
+ are now registered as features and can be tested using "cond-expand" or "#+"
+- all tools now support the "-release" option
+- chicken-setup: added "-test" option
+
+Special thanks to Brandon Van Every, who put considerable effort into the
+CHICKEN build system and who ported it to CMake completely from scratch.
+The installation instructions and build file are extensively documented and may
+serve as a tutorial for creating non-trivial software projects with CMake.
+Thanks, Brandon! Also thanks to Bill Hoffmann and Brad King from Kitware
+for their support.
+
+Many thanks to Peter Bex, Toby Butzon, Thomans Chust, John Cowan, Alejandro Forero Cuervo,
+dgym, Alex Drummond, Mario Domenech Goulart, Kon Lovett, Benedikt Rosenau and Zbigniew
+Szadkowski for reporting bugs, suggesting improvements and contributing fixes.
+
+
+2.41
+
+- Bugfixes galore
+- compiler:
+ * added support for the generation of "export" files through the "-emit-exports" option
+ * new option `-check-imports' (csc: `-G') checks for unimported symbols and can be quite
+ helpful in finding unbound variable errors (this requires all extensions ("eggs") to be
+ adapted to this new feature, a process which isn't complete yet)
+ * new declarations `emit-exports', `constant' and `import'
+ * new option `-disable-warning' and declaration `disable-warning'
+ * new options `-release' and `-import'
+- chicken-setup:
+ * new `exports' extension property
+ * option `-check' checks for extension upgrades
+ * added `-eval' option
+ * added parameters `setup-install-flag' and `setup-verbose-flag'
+- FFI:
+ * added the handy `$' macro, which lets you do foreign calls directly without declaring
+ a placeholder procedure
+ * `define-foreign-enum' for treating C enums as symbol-sets
+ * `foreign-safe-wrapper' has been deprecated
+- Slight reorganization of TinyCLOS and match macros and support code
+- `thread-join!' has been generalized to allow a thread to have multiple results
+- Renamed `thread-deliver-signal!' to `thread-signal!' and `invalid-procedure-call-handler'
+ to `set-procedure-call-handler!'
+- The system can be configured to add an extra slot to symbol objects
+- Another configuration option enables GC of unused symbols by default
+- The extension repository is now versioned to catch binary incompatible
+ installations, this requires to either move all installed extensions to the
+ new location ("$prefix/lib/chicken/1") or reinstall them
+- Now supports SRFI-61 (extended `cond')
+- Added procedures `load-relative', `tcp-buffer-size`, `string-chomp'
+- trivial implementations of `real-part', `imag-part', `angle' and `magnitude' have
+ been added to the library to allow more portable code
+- Breakpoints and single-stepping of compiled code on the function-level, new
+ procedures `breakpoint' and `singlestep'
+- csi: new toplevel commands `,info', `,step', `,br', `,ubr', `,breakall', `,breakonly',
+ `,exn' and `,c'
+- csi: `set-describer!' allows definition of custom output for the `,d' command
+- Added `integer64' foreign type specifier
+- The environment variable "CHICKEN_PREFIX" allows (together with "CHICKEN_REPOSITORY") overriding
+ the installation path prefix in case you want to install and run multiple instances/versions
+ of CHICKEN or install on a shared network
+- csc: added `-dry-run' option
+- removed `-split...' options (and the ability to generate multiple C files from a single
+ Scheme file)
+- `crictical-section', `disable-interrupts' and `enable-interrupts' shouldn't be used from
+ now on (deprecated), use SRFI-18 mutexes instead
+
+Many thanks to Nico Amtsberg, Arto Bendiken, Jean-Francois Bignolles, Peter Busser, Thomas Chust,
+John Cowan, Alejandro Forero Cuervo, Jaarod Eells, Brandon van Every, Graham Fawcett, Mario Domenech
+Goulart, Sven Hartrumpf, Markus Hülsmann, Goetz Isenmann, Heath Johns, Daishi Kato, Kon Lovett, Dan
+Muresan, Ian Oversby, Göran Weinholt, Burton Samograd, Reed Sheridan, Alex Shinn, Sunnan, Zbigniew
+Szadkowski and Peter Wright for their helpful contributions, suggestions and bug reports!
+
+
+2.3
+
+- Many many bugfixes
+- compiler:
+ * new option `-profile-name FILENAME'
+- the `chicken-config' script has been removed, identical functionality can be provided
+ by `csc'
+- csc:
+ * new option `-objc' compiles generated C files in Objective-C mode
+ * accepts .m files and handles the case when only object files are given
+ * new options `-framework', `-F<dir>' and `-rpath'
+ * options `-home', `-cflags', `-ldflags', `-libs', `-cc-name' and `-ld-name'
+- chicken-setup:
+ * detects whether eggs are gzipped or not and accepts ungzipped eggs
+ * if no other actions are specified and no eggs are given on the command line, then
+ all .setup scripts in the current directory are executed
+ * added `setup-build-directory' and `setup-root-directory' parameters
+ * helper procedures `copy-file', `move-file', `remove-file' and `create-directory'
+- csi commands `,s', `,l' and `,ln' accept multiple inputs, the `trace'/`untrace'
+ macros have been replaced byy the toplevel commands `,tr' and `,utr'
+- new toplevel commands in csi can be defined with the `toplevel-command' procedure
+- `extension-info' has been renamed to `extension-information'. The old name is
+ still available, but deprecated
+- `print-backtrace' has been renamed to `print-call-chain'. The old name is still
+ available (and deprecated)
+- `transcript-on' and `transcript-off' are no longer supported
+- New macro `define-for-syntax'
+- library:
+ (get-call-chain [DEPTH])
+ (current-read-table)
+ (copy-read-table READ-TABLE)
+ (current-gc-milliseconds)
+ `print-error-message' writes now to the current output-port, not the error port
+ `number-string' does now a slightly better job converting large exact integers
+ with non-decimal base
+- extras:
+ (each PROC ...)
+ `hash-table-ref' throws (exn access) on error
+- posix:
+ (local-time->seconds TIME)
+ (utc-time->seconds TIME)
+ (local-timezone-abbreviation)
+ `directory' takes optional path and dotfiles arguments
+ `[group|system]-information' return lists instead of multiple values
+- tcp:
+ (tcp-port-numbers PORT)
+- `set-dispatch-read-syntax!' has been renamed to `set-sharp-read-syntax!' (the old
+ name is still available but deprecated)
+- evaluated code generates call-trace information (as compiled code does), which
+ results in much better back-traces.
+- new foreign types `[unsigned-]int32' and `[unsigned-]integer32'
+- added SRFI-17 setters for many accessors of the core libraries
+- tinyclos: added a couple of missing classes for core library structures
+- `let[*]-values' is now SRFI-11 compliant
+- the finalizer-table is now resized dynamically, which speeds up code that uses
+ very many finalizers [Thanks to Zbigniew Szadkowski]
+- reloading compiled code dynamically does basically work (but still leaks memory)
+- the manual contains a section on pattern matching
+- libffi is used by default, when available
+- CHICKEN has now experimental support for the "CMake" build system <http://www.cmake.org>
+ Many thanks to Bill Hoffmann from Kitware and Brandon van Every for helping with this
+- added compiler/runtime support for object serialization via the `s11n' extension
+ (see <http://www.call-with-current-continuation.org/eggs/s11n.html>)
+
+Sergey Khorev has offered to help with maintaining the Windows port of CHICKEN.
+Thanks, Sergey!
+
+Many thanks Jean-Francois Bignolles, Patrick Brannan, Adam Buchbinder, Hans Bulfone, Category 5,
+John Cowan, datrus, Guillaume Germaine, Mario Domenech Goulart, Daniel B. Faken, Andrey Fomichev,
+Jarod Eells, Sven Hartrumpf, David Janssens, Daishi Kato, Levi Pearson, Pupeno, Eric Raible, Benedikt
+Rosenau, Reed Sheridan, Zbigniew Szadkowski and Mark Wutka for their helpful contributions,
+suggestions and bug reports!
+
+Special thanks to Kon Lovett for fixing countless open issues and many useful sugestions.
+
+
+2.2
+
+- Many bugfixes
+- The read-syntax `#+X Y' is provided as a shorthand for `(cond-expand (X Y) (else))'
+- `foreign-parse' and `foreign-parse/spec' have been removed
+- lolevel: Executable byte-vector stuff has been removed
+- SRFIs 28, 31, 62 and 69 are now officially supported
+- New compiler option `-extension' simplifies static compilation of eggs
+- csc: changed `-E' to `-P', `-E' is now an alias for `-extension'
+- Embedding:
+ * All the `entry-point' related things have been removed, as has been `define-embedded',
+ calling Scheme from C is now exclusively done with callbacks
+ * Integrated boilerplate embedding API into the `eval' unit
+ * Added `CHICKEN_continue' API function
+ * Default "stub" toplevel (`CHICKEN_default_toplevel') allows embedding without a
+ separate Scheme file
+ * Different stack-levels during invocation of CHICKEN_run or callbacks could result
+ in crashes - this is now detected (or can be checked manually)
+- Added extension-specifier `(version ...)'
+- New FFI macros `foreign-declare', `foreign-parse' and `foreign-parse/declare' replace
+ the declaration-specifiers of the same name
+- Hash-table resizing was ridiculously slow, and should now be much faster
+- `define-foreign-record' handles recursive structures
+- `require-extension' is now available by default, and so can be used with the
+ plain Scheme evaluator
+- Procedures now contain some basic debug information, unless a file was compiled
+ with `-no-lambda-info'
+- compiler: `-debug-level 2' is now the default (enables trace- and lambda-info)
+- chicken-setup:
+ * handles direct downloads from arbitrary URLs
+ * HTML documentation for eggs can now be included into the egg and will be installed
+ in the repository (using the `documentation' info-property)
+ * `chicken-setup -docindex' shows path of generated documentation index for all
+ installed eggs
+- extras:
+ * SRFI-69 is now fully supported, note that THIS WILL BREAK EXISTING CODE, since
+ the API is not compatible to the previous one
+ * `clear-hash-table!', `get' and `put!' are gone
+ * `read-file' accepts optional reader procedure and max count
+ * `read-lines' accepts filename instead of port
+- library:
+ * `signum' is now exactness-preserving
+ * `procedure-information' returns some basic debug info for a given procedure
+ * Added `(warning MESSAGE ARGUMENTS ...)'
+ * `(promise? X)'
+- posix:
+ * `(current-directory DIR)' is equivalent to `(change-directory DIR)'
+- regex:
+ * `pattern->regexp' has been renamed to `glob->regexp'
+- The `format' library unit has been removed from the base system and is noww available
+ separately
+- SRFI-17, on the other hand has been moved into the base system
+- String literals and the print-names of symbol literals are now allocated in static
+ (non-GC'd) memory
+- If static or shared build is disabled, no `...-static' executables will be generated
+
+
+Many thanks to Ashley Bone, Thomas Chust, John Cowan, Alejandro Forero Cuervo, Daniel Faken, Sven
+Hartrumpf, Daishi Kato, Sergey Khorev, Kon Lovett, Gene Pavlovsky, Reed Sheridan and Ed Watkeys for
+their helpful contributions, suggestions and bug reports!
+
+
+2.0
+
+- Many bugfixes
+- Loads of minor improvements (better error messages, more warnings, more error
+ checks, etc.)
+- On systems supported by the "libffi" library, the 128-argument limit can
+ be exceeded (currently to an arbitrary maximum of 1000). To take advantage
+ of this, add `--with-libffi' to the configuration options when building
+ chicken
+- The `libsrfi-chicken' and `libstuffed-chicken' libraries have been folded
+ into `libchicken', so only a single library is linked with generated
+ executables, which greatly simplifies and speeds up the build process.
+ It is recommended to remove any traced of `libstuffed-chicken.*' and
+ `libsrfi-chicken.*' before installing a new release. This requires also
+ to reinstall all eggs (extension libraries).
+- The compiler is able to inline more procedure calls
+- Implicit non-multival continuations (like in `begin' or 'let') accept multiple
+ values and discard all but the first value
+- finalization should actually work now and is much more efficient (unless
+ used excessively)
+- csi:
+ `advise' has been removed
+ `-eval' implies `-batch' and `-quiet'
+ added `-require-extension'
+ short option names are now supported and may be collapsed, if unambigous
+- New runtime options:
+ -:b (enter REPL on error)
+ -:B (ring bell on every major GC)
+ -:fNNN (set pending finalizer maximum limit)
+- New compiler options:
+ -accumulate-profile
+ -inline
+ -inline-limit
+ -emit-external-prototypes-first
+- The compiler-option `-require-for-syntax' has been renamed to `-require-extension'
+ and is the same as putting a `(require-extension ...)' form directly into the code
+- Removed compiler- and interpreter option `-no-feature'
+- New declarations:
+ (lambda-lift)
+ ([not] inline)
+ (inline-limit LIMIT)
+ (emit-external-prototypes-first)
+ ([not] check-c-syntax)
+- `foreign-callback-lambda[*]' has been renamed to `foreign-safe-lambda[*]' - the
+ old names are still valid but deprecated
+- New foreign type specifier `scheme-pointer' (the same as `pointer', which is
+ deprecated now)
+- Easy FFI:
+ `___scheme_pointer' and `___byte_vector' pseudo types
+ `___pointer' and `___length' markers
+ `default_renaming' and `opaque' pseudo declarations
+ `___inout' and `___out' argument markers work also for C++ reference types
+ Recognizes `C_word' and `size_t'
+- The reader supports selective case sensitive/insensitive reading using the
+ `#cs...' and `#ci...' syntax (as supported in PLT Scheme)
+- `\uXXXX' and `\UXXXXXXXX' escape-sequences for string literals
+- `#\UXXXXXXXX' character literal syntax
+- `\v', `\a' and `\f' escape sequences and `#\delete', `#\esc', `#\alarm', `#\vtab'
+ and `#\nul' character literals
+- `chicken-setup' supports proxy connections via the `-proxy' option
+- library:
+ (set-dynamic-load-mode! MODE)
+ `(end-of-file)' has been removed (use `#!eof' instead)
+- The alternative continuation API described in Marc Feeley's paper
+ "A better API for first class continuations" is supported natively:
+ (continuation-capture PROC)
+ (continuation-graft K THUNK)
+ (continuation-return K VALUE ...)
+ (continuation? X)
+- `foreign-primitive' and `define-extension' macros
+- tinyclos:
+ (instance-of? X)
+ `define-method' specializes on all arguments and allows DSSSL keyword argument lists
+- eval:
+ (set-dispatch-read-syntax! CHAR PROC)
+- extras:
+ (hash-table-update! HT KEY PROC INIT)
+ (hash-table-exists? HT KEY)
+ (hash-table-values HT)
+ (hash-table-keys HT)
+ (alist->hash-table ALIST [TEST SIZE])
+ `hash-table->list' has been renamed to `hash-table->alist
+ `hash-table-for-each' takes the arguments in reversed order (the old order is still
+ valid but deprecated)
+ Hash-tables support now user-defined hash functions
+- posix:
+ (file-link OLD NEW)
+ (symbolic-link? FILENAME)
+ (regular-file? FILENAME)
+ errno/exist
+ `process' and `process-execute' allow passing an environment
+- regex:
+ (regexp-escape STR)
+- tcp:
+ (tcp-listener-fileno LISTENER)
+- utils:
+ (port-for-each FN THUNK)
+ (port-map FN THUNK)
+- On Windows, the batch file `win-install.bat' can be used to install the system
+ into the desired location
+- Building Chicken on Windows with the free development tools from Microsoft (VCToolkit,
+ Platform Core SDK) has been tested and is documented in the file `vctk-install.txt'
+- The `-script-meta' option has been removed
+- The srfi-25 and srfi-37 library units and the test-infrastructure facility have been
+ removed from the core system and is now separately available as an extensions (eggs)
+- The syntax-case macro and module system has been removed and also available as an
+ extension. This implies that all compiler- and interpreter options related to hygienic
+ macros and syntax-case are gone as well.
+- All strictness compiler- and interpreter options (and the `strict-reader' parameter)
+ have been removed
+- the `examples' directory and its contents have been removed from the distribution
+
+
+Many thanks to William Annis, Mark Baily, Peter Bex, Dominique Boucher, Patrick Brannan,
+Thomas Chust, Alejandro Forero Cuervo, Graham Fawcett, Damian Gryski, Sven Hartrumpf,
+Hans Huebner, Christian Jaeger, Dale Jordan, Daishi Kato, Sergey Khorev, Krysztof Kowalczyk,
+Goran Krampe, John Lenz, Kon Lovett, Scott G. Miller, Julian Morrison, Nicolas Pelletier,
+Carlos Pita, Benedikt Rosenau, Andreas Rottmann, Reed Sheridan, Alex Shinn, Andrey Sidorenko,
+Michele Simionato, Volker Stolz, Sunnan, Zbigniew Szadkowski, Andre van Tonder, Henrik
+Tramberend and Mark Wutka for their helpful contributions, suggestions and bug reports!
diff --git a/README b/README
new file mode 100644
index 00000000..370677fe
--- /dev/null
+++ b/README
@@ -0,0 +1,381 @@
+
+ README file for the CHICKEN Scheme system
+ (c) 2000-2007, Felix L. Winkelmann
+ (c) 2008-2009, The Chicken Team
+
+ version 4.2.2
+
+
+ 1. Introduction:
+
+ CHICKEN is a Scheme-to-C compiler supporting the language
+ features as defined in the 'Revised^5 Report on
+ Scheme'. Separate compilation is supported and full
+ tail-recursion and efficient first-class continuations are
+ available.
+
+ Some things that CHICKEN has to offer:
+
+ 1. CHICKEN generates quite portable C code and compiled files
+ generated by it (including itself) should work without any
+ changes on DOS, Windows, most UNIX-like platforms, and with
+ minor changes on other systems.
+
+ 2. The whole package is distributed under a BSD style license
+ and as such is free to use and modify as long as you agree
+ to its terms.
+
+ 3. Linkage to C modules and C library functions is
+ straightforward. Compiled programs can easily be embedded
+ into existing C code.
+
+ 4. Loads of extra libraries.
+
+ Note: Should you have any trouble in setting up and using
+ CHICKEN, please ask questions on the Chicken mailing list. You
+ can subscribe to the list from the Chicken homepage,
+ http://www.call-with-current-continuation.org)
+
+
+ 2. Installation:
+
+ First unzip the package ("unzip chicken-<version>.zip" or "tar
+ xzf chicken-<version>.tar.gz" on UNIX or use your favorite
+ extraction program on Windows).
+
+ Building CHICKEN requires GNU Make. Other "make" derivates are
+ not supported. If you are using a Windows system and do not
+ have GNU Make, see below for a link to a precompiled set of
+ UNIX utilities, which among other useful tools contains "make".
+
+ Configuration and customization of the build process is done by
+ either setting makefile variables on the "make" command line or
+ by editing the platform-specific makefile.
+
+ Invoke "make" like this:
+
+ make PLATFORM=<platform> PREFIX=<destination>
+
+ where "PLATFORM" specifies on what kind of system CHICKEN
+ shall be built and "PREFIX" specifies where the executables
+ and libraries shall be installed. Out-of-directory builds are
+ currently not supported, so you must be in the toplevel source
+ directory to invoke "make".
+
+ Enter "make" without any options to see a list of supported
+ platforms.
+
+ Note that parallel builds (using the "-j" make(1) option) is
+ *not* supported.
+
+ If you build CHICKEN directly from the development sources out
+ of the subversion repository, you will need a "chicken"
+ executable to generate the compiled C files from the Scheme
+ library sources. If you have a recent version of CHICKEN
+ installed, then pass "CHICKEN=<chicken-executable>" to the
+ "make" invocation to override this setting. "CHICKEN" defaults
+ to "$PREFIX/bin/chicken".
+
+ If you do not have a "chicken" binary installed, enter
+
+ make PLATFORM=<platform> PREFIX=<destination> bootstrap
+
+ which will unpack a tarball containing precompiled C sources
+ that are recent enough to generate the current version. After
+ building a statically linked compiler executable (named
+ "chicken-boot") all *.scm files are marked for rebuilt. By
+ passing "CHICKEN=./chicken-boot" to "make", you can force
+ using this bootstrapped compiler to build the system.
+
+ If CHICKEN is build successfully, you can install it on your
+ system by entering
+
+ make PLATFORM=<platform> PREFIX=<destination> install
+
+ "PREFIX" defaults to "/usr/local". Note that the PREFIX is
+ compiled into several CHICKEN tools and must be the same
+ while building the system and during installation.
+
+ To install CHICKEN for a particular PREFIX on a different
+ location, set the "DESTDIR" variable in addition to "PREFIX":
+ It designates the directory where the files are installed
+ into.
+
+ You can further enable various optional features by adding
+ one or more of the following variables to the "make"
+ invocation:
+
+ DEBUGBUILD=1
+ Disable optimizations in compiled C code and enable
+ debug information.
+
+ STATICBUILD=1
+ Build only static versions of the runtime library, compiler
+ and interpreter. `chicken-install', `chicken-uninstall' and
+ `chicken-status' will not be generated, as it is mostly
+ useless unless compiled code can be loaded.
+
+ SYMBOLGC=1
+ Always enable garbage collection for unused symbols in the
+ symbol table by default. This will result in slightly slower
+ garbage collection, but minimizes the amount of garbage
+ retained at runtime (which might be important for long
+ running server applications). If you don't specify this
+ option you can still enable symbol GC at runtime by passing
+ the `-:w' runtime option when running the program.
+
+ NOAPPLYHOOK=1
+ For maximum performance this will disable support for
+ breakpoints, but speed up procedure invocation in safe
+ code. Smaller binaries can be obtained by also giving
+ "NOPTABLES=1", but that means serialization (available
+ as a separate package) of procedures will not be available.
+
+ OPTIMIZE_FOR_SPEED=1
+ Use C optimization options that prefer speed over size. For
+ the GNU C compiler this will currently select "-O3" (the
+ default is "-Os"). You can also se
+ C_COMPILER_OPTIMIZATION_OPTIONS (see below) to have more
+ control over the options given to the C compiler.
+
+ C_COMPILER_OPTIMIZATION_OPTIONS=...
+ Override built-in C compiler optimization options. Available
+ for debug or release build.
+
+ PROGRAM_PREFIX=
+ A prefix to prepend to the names of all generated executables.
+ This allows having multiple CHICKEN versions in your PATH
+ (but note that they have to be installed at different locations).
+
+ PROGRAM_SUFFIX=
+ A suffix to be appended to the names of all generated executables.
+
+ HOSTSYSTEM=
+ A "<machine>-<platform>" name prefix to use for the C compiler to to
+ use to compile the runtime system and executables. Set this variable
+ if you want to compile CHICKEN for a different architecture than
+ the one on which you are building it.
+
+ TARGETSYSTEM=
+ Similar to "HOSTSYSTEM", but specifies the name
+ prefix to use for compiling code with the "csc" compiler
+ driver. This is required for creating a "cross chicken", a
+ specially built CHICKEN that invokes a cross C compiler to
+ build the final binaries. You will need a cross compiled
+ runtime system by building a version of CHICKEN with the
+ "HOST" option mentioned above. More information about this
+ process and the variables that you should set are provided
+ in the CHICKEN wiki at
+ <http://chicken.wiki.br/cross-compilation>.
+
+ SRCDIR=
+ Specifies that CHICKEN should be built outside of its source
+ tree. The SRCDIR variable indicates the location of the
+ CHICKEN source tree. The executables and object files will
+ be generated in the current directory.
+
+ VARDIR=
+ If set, this directory overrides the location where
+ extensions along with their metadata are stored. Normally
+ this will be equivalent to "<PREFIX>/lib/chicken/<BINARYVERSION>".
+ When VARDIR is specified, extensions will be stored in
+ "<VARDIR>/chicken/<BINARYVERSION>", conforming to the FHS.
+
+
+ To remove CHICKEN from your file-system, enter (probably as
+ root):
+
+ make PLATFORM=<platform> PREFIX=<destination> uninstall
+
+ (If you gave DESTDIR during installation, you have to pass
+ the same setting to "make" when uninstalling)
+
+ In case you invoke "make" with different configuration parameters,
+ it is advisable to run
+
+ make PLATFORM=<platform> confclean
+
+ to remove old configuration files.
+
+
+ 3. Usage:
+
+ Documentation can be found in the directory
+ PREFIX/share/chicken/doc. The HTML documentation (in
+ "PREFIX/share/chicken/doc/html") is automatically generated
+ from the Wiki pages at <http://chicken.wiki.br/>. Go there to
+ read the most up to date documentation.
+
+
+ 4. Extensions:
+
+ A large number of extension libraries for CHICKEN are
+ available at
+ <http://www.call-with-current-continuation.org/eggs/>. You can
+ automatically download, compile and install extensions with
+ the "chicken-install" program. See the CHICKEN User's Manual for
+ more information.
+
+ A selection of 3rd party libraries, together with source and
+ binary packages for tools helpful for development with CHICKEN
+ are also available at:
+ <http://www.call-with-current-continuation.org/tarballs/>.
+
+
+ 5. Platform issues:
+
+ - *BSD system users *must* use GNU make ("gmake") - the makefiles
+ can not be processed by BSD make.
+
+ - Some old Linux distributions ship with a buggy version of
+ the GNU C compiler (2.96). If the system is configured for
+ kernel recompilation, then an alternative GCC version is
+ available under the name `kgcc' (GCC 2.96 can not recompile
+ the kernel). CHICKEN's configuration script should normally
+ be able to handle this problem, but you have to remember to
+ compile your translated Scheme files with `kgcc' instead of
+ `gcc'.
+
+ - Older versions of Solaris have a bug in ld.so that causes
+ trouble with dynamic loading. Patching Solaris fixes the
+ problem. Solaris 7 needs patch 106950-18. Solaris 8 has an
+ equivalent patch, 109147-16.
+
+ You can find out if you have these patches installed by
+ running:
+
+ % showrev -p | grep 106950 # solaris 7
+ % showrev -p | grep 109147 # solaris 8
+
+ - On NetBSD it might be possible that compilation fails with a
+ "virtual memory exhausted error". Try the following:
+
+ % unlimit datasize
+
+ - Using external libraries on NetBSD may also be easier, if
+ you add the following definitions to `Makefile.bsd':
+
+ C_COMPILER_OPTIONS += -I/usr/pkg/lib
+ LINKER_OPTIONS += -L/usr/pkg/lib -Wl,-R/usr/pkg/lib
+
+ Note that this may cause build-problems, if you already have
+ an existing CHICKEN installation in the /usr/pkg prefix.
+
+ - For Mac OS X, Chicken requires libdl, for loading compiled
+ code dynamically. This library is available on Mac OS X 10.4
+ (Tiger) by default. For older versions you can find it here:
+
+ http://www.opendarwin.org/projects/dlcompat
+
+ - On Mac OS X, Chicken and its eggs can be built as universal
+ binaries which will work on either Intel or PowerPC.
+ To build on Tiger (10.4):
+
+ make PLATFORM=macosx ARCH=universal
+
+ On Leopard (10.5), an extra step is required before `make':
+
+ export MACOSX_DEPLOYMENT_TARGET=10.4
+ make PLATFORM=macosx ARCH=universal
+
+ - On Mac OS X, Chicken can be built in 64-bit mode on Intel
+ Core 2 Duo systems--basically, most recent machines. The default
+ is 32-bit mode. To enable 64-bit mode, invoke `make' thusly:
+
+ make PLATFORM=macosx ARCH=x86-64
+
+ - On Windows, mingw32, <http://mingw.sourceforge.net/> and
+ Cygwin are supported (Microsoft Visual Studio is *NOT*).
+ Makefiles for mingw under MSYS and Windows shell are provided
+ (`Makefile.mingw-msys' and `Makefile.mingw'). Please also
+ read the notes below.
+
+ - When installing under the mingw-msys platform, PREFIX must be an
+ absolute path name (i.e. it must include the drive letter) and
+ must use forward slashes (no backward slashes).
+
+ - When installing under mingw, with a windows shell ("cmd.exe"),
+ pass an absolute pathname as PREFIX and use forward slashes.
+
+ - When installing under mingw without MSYS, make sure that the
+ MSYS tools (in case you have some of them, in particular the
+ sh.exe UNIX shell) are *NOT* visible in your PATH.
+
+ - Cygwin will not be able to find the chicken shared libraries
+ until Windows is rebooted.
+
+ - gcc 3.4 shows sometimes warnings of the form
+
+ easyffi.c: In function `f_11735':
+ easyffi.c:18697: warning: `noreturn' function does return
+
+ when compiling the system or compiled Scheme files. These
+ warnings are bogus and can be ignored.
+
+ 6. Emacs support:
+
+ An emacs mode is provided in the file `hen.el'. To use it,
+ copy it somewhere into a location you normally use for emacs
+ extensions. If you want to add a specific location permanently
+ to the list of paths emacs should search for extensions, add
+ the following line to your `.emacs' file:
+
+ (setq load-path
+ (cons
+ "<directory-where-your-emacs-lisp-files-live>"
+ load-path))
+
+ Add
+
+ (require 'hen)
+
+ To make "hen-mode" available, and enter it by issuing the
+ command M-x hen-mode.
+
+ A copy of Alex Shinn's highly useful tab-completion code is
+ also included in `scheme-complete.el'. Install it like `hen.el'
+ and add this code to your `.emacs':
+
+ (autoload 'scheme-smart-complete "scheme-complete" nil t)
+ (eval-after-load 'scheme
+ '(progn (define-key scheme-mode-map "\e\t" 'scheme-smart-complete)))
+
+ Or:
+
+ (eval-after-load 'scheme
+ '(progn (define-key scheme-mode-map "\t" 'scheme-complete-or-indent)))
+
+ If you use eldoc-mode (included in Emacs), you can also get live
+ scheme documentation with:
+
+ (add-hook 'scheme-mode-hook
+ (lambda ()
+ (setq eldoc-info-function 'scheme-get-current-symbol-info)
+ (eldoc-mode)))
+
+ Replace "'scheme" in the elisp expressions above with "'hen", if
+ you want to add tab-completion to CHICKEN's own emacs mode.
+
+
+ 7. Compatibility notes
+
+ CHICKEN 4 uses a completely reimplemented hygienic macro and
+ module system, which has considerably more felixbility and power,
+ but will require rewriting macros in code that previously was
+ used with CHICKEN 3. Notably, `define-macro' is not available
+ anymore. See the manual on how to translate such macros to
+ low-level hygienic macros or ask on the CHICKEN mailing list.
+
+
+ 8. What's next?
+
+ If you find any bugs, or want to report a problem, please consider
+ using the "chicken-bug" tool to create a detailed bug report.
+
+ If you have any more questions or problems (even the slightest
+ problems, or the most stupid questions), then please subscribe
+ to the "chicken-users" mailing list and ask for help. It will
+ be answered.
+
+
+ Have fun!
diff --git a/TODO b/TODO
new file mode 100644
index 00000000..71d04352
--- /dev/null
+++ b/TODO
@@ -0,0 +1,140 @@
+TODO for chicken -*- Outline -*-
+================
+
+
+* bugs
+
+** compiler
+*** pre-optimization
+**** changes call-sites and makes them invalid for later pre-optimization
+*** check profiling (-profile vs. profile-declaration)
+**** this doesn't always seem to work, in particular with library units
+**** ##sys#finish-profile should always be invoked
+ is it in `exit'?
+*** when re-defining intrinsics, the compiler should warn and disable re-writes
+ add declaration to keep re-writes enabled for core library files
+*** -prologue, -epilogue, -prelude, -postlude should check for argument being directory
+ (reported by Eduardo Cavazos)
+
+** expander
+*** expansion of r5rs_pitfall 4.2 incorrect
+ possibly due to a non-aliased implicit "begin" somewhere
+*** dirty-macros.scm loops when using `defile'
+ possibly due to unrenamed special forms
+*** extended lambda-lists refer to `optional' and `let-optionals[*]'
+ this will break, when these macros are renamed on import or not imported
+ at all
+**** a possible solution is to use internal forms, provided by the "scheme" module.
+*** need way to force generating module-registration code for standalone executables.
+
+** modules
+*** mark import-source (module) on plist of imported symbols and use in re-import warning
+ doesn't work that easily, try to find another solution
+*** DSSSL lambda-lists need imports of `chicken' module ("optional", "let-optionals", ...)
+**** should probably use internal aliases
+
+** libraries
+*** library/runtime: cyclic list checks for assq/assv/assoc/memq/memv/member
+ and C_i_list_tail
+*** finalizers on lexically ref'd data not working in interpreter
+ reported by Jim Ursetto
+ reverted original patch, see patches/finalizer-closures.diff
+
+** tools
+*** chicken-bug: SMTP servers not accessible (greylisting)
+
+
+* tasks
+
+** branches
+*** try to improve performance in lazy-gensyms
+ this *should* give better performance, but the extra handling of symbols
+ without name seems to be to expensive
+
+** module issues
+*** need a way to omit generating module registration without generating import lib
+ for example when compiling static version, where implib already exists
+*** code-duplication in compiler and evaluator for ##core#module
+*** "scheme" module does not include some special forms ("define-syntax", etc.)
+*** import-for-syntax imports value bindings into import-env
+ should actually be a distinct meta-import-env.
+ example: we need `(import-for-syntax chicken)' to have access to
+ `receive' in a procedural syntax definition.
+*** curried define performs expansion in empty se - problem?
+ (as comment in expand.scm indicated (##sys#register-export))
+*** check phase separation and module access
+**** see "expander" above
+*** consider adding support for unnamed modules
+
+** compiler
+*** (csc) generate object-files in /tmp (or TMPDIR)?
+
+** setup/install
+*** setup-download
+**** use "HTTP_PROXY"/"http_proxy" env. var
+**** handle redirects in http-fetch
+
+** library units
+*** read-mark list should be stored in read-table
+*** normalize-pathname: return short name on windows? (mingw/msvc)
+*** Use record-descriptors instead of symbols as 1st slot in structure objects?
+**** see Kon's proposal for new record-descriptors in "misc/Chicken Runtime Data Type Proposal"
+*** Weak locatives can probably be used to implement weak hash-tables (at least for some data)
+
+** syntax-error
+*** if ##sys#current-module is set, add name to error message?
+*** fluidly keep track of expanded forms (extend meaning of culprit) to pprint pruned expr on error
+
+** build
+*** need script to process import libraries for generating indices for doc.callcc.org
+ then tell Toby Butzon about it
+*** using "touch" with WINDOWS_SHELL won't work (need alternative) (mingw/non-msys build)
+*** extend scripts/guess-platforms.sh for more platforms
+
+** scrutiny
+*** add support for keyword arguments and check even length and available keywords
+
+
+* tests
+
+** optional longer run (env. var)
+*** syntax-rules-stress-test
+*** fully compiled ec-tests
+** 3-stage bootstrap with compiler-output comparison
+
+
+* optimizations
+
+** local mode could be enabled for all core libs
+ also could reduce performance, as it does for regex
+
+** global inline files for core units
+*** This would remove necessity for many simple re-write rules in c-platform.scm
+
+** self-recursion optimization
+ what MacScheme called "benchmark-mode" (assume self-calls are recursion)
+*** needs declaration or option, >= -O2
+
+** when inlining, consing arg-list with "list" may make get-keyword possibly foldable
+
+** compiler-support for get-keyword ?
+
+** lambda-fusion / "fuse-and-dispatch" (suggested by Alex Shinn)
+ convert groups of local lambdas referenced to only in operator-position into
+ looping lambda + dispatch (static variable can be used), otherwise similar to
+ a conditional
+
+** lazy gensyms (see "lazy-gensyms" branch)
+
+** handle optional args primitively
+ for example, set to distinguished val (checking argc) on C level, core
+ primitive for checking this - should be quite simple, but llist processing
+ (decompose-lambda-list) will be more expensive and cumbersome.
+
+** pre-hashed symbols (extra symbol slot)
+ The memory usage should be acceptable, performance gain is hard to guess.
+ Some experiments indicate that hashing the string is cheaper than it appears,
+ but low-level hashtables should get the most of this (and thus speed up
+ the compiler)
+
+** The benchmarks are meaningless - find real ones.
diff --git a/apply-hack.ppc.darwin.S b/apply-hack.ppc.darwin.S
new file mode 100644
index 00000000..88d7b246
--- /dev/null
+++ b/apply-hack.ppc.darwin.S
@@ -0,0 +1,70 @@
+/* apply-hack.ppc.s
+;
+; Copyright (c) 2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009 The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+*/
+
+ .text
+
+ .globl _C_do_apply_hack
+ .align 2
+
+_C_do_apply_hack:
+ mr r13, r3 /* r13=proc */
+ mr r14, r4 /* r14=buf */
+ mr r15, r5 /* r15=count */
+ cmpwi r15, 8
+ bge l1
+ li r3, 8 /* offset is (8 - count) * 4 */
+ sub r15, r3, r15
+ slwi r15, r15, 2
+ bl l2 /* compute branch address */
+l2: mflr r4
+ add r15, r4, r15
+ addi r15, r15, lo16(l1 - l2)
+ mtctr r15
+ bctr
+l1: lwz r10, 28(r14) /* load register arguments */
+ lwz r9, 24(r14)
+ lwz r8, 20(r14)
+ lwz r7, 16(r14)
+ lwz r6, 12(r14)
+ lwz r5, 8(r14)
+ lwz r4, 4(r14)
+ lwz r3, 0(r14)
+ lwz r15, 20(r1) /* save link area above faked argument area */
+ stw r15, -4(r14) /* (start from end if destination overlaps) */
+ lwz r15, 16(r1) /* is this needed at all? at least for proper gdb backtraces? */
+ stw r15, -8(r14)
+ lwz r15, 12(r1)
+ stw r15, -12(r14)
+ lwz r15, 8(r1)
+ stw r15, -16(r14)
+ lwz r15, 4(r1)
+ stw r15, -20(r14)
+ lwz r15, 0(r1)
+ stw r15, -24(r14)
+ addi r1, r14, -24 /* set frame-pointer to faked frame */
+ mtctr r13 /* jump to proc, lr is invalid, but we won't return anyway */
+ bctr
diff --git a/apply-hack.ppc.sysv.S b/apply-hack.ppc.sysv.S
new file mode 100644
index 00000000..f0a17a8d
--- /dev/null
+++ b/apply-hack.ppc.sysv.S
@@ -0,0 +1,66 @@
+/* apply-hack.ppc.s
+;
+; Copyright (c) 2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+*/
+
+ .text
+
+ .globl _C_do_apply_hack
+ .align 2
+
+_C_do_apply_hack:
+ mr %r13, %r3 /* r13=proc */
+ mr %r14, %r4 /* r14=buf */
+ mr %r15, %r5 /* r15=count */
+ li %r16, 8 /* Assume count >= 8 */
+ cmpwi %r15, 8
+ bge l1
+ li %r3, 8 /* offset is (8 - count) * 4 */
+ mr %r16, %r15 /* Remember count */
+ sub %r15, %r3, %r15
+ slwi %r15, %r15, 2
+ bl l2 /* compute branch address */
+l2: mflr %r4
+ add %r15, %r4, %r15
+ addi %r15, %r15, (l1 - l2)@l
+ mtctr %r15
+ bctr
+l1: lwz %r10, 28(%r14) /* load register arguments */
+ lwz %r9, 24(%r14)
+ lwz %r8, 20(%r14)
+ lwz %r7, 16(%r14)
+ lwz %r6, 12(%r14)
+ lwz %r5, 8(%r14)
+ lwz %r4, 4(%r14)
+ lwz %r3, 0(%r14)
+ lwz %r15, 4(%r1) /* LR (needed?) */
+ stw %r15, -4(%r14)
+ lwz %r15, 0(%r1) /* Back chain (needed?) */
+ stw %r15, -8(%r14)
+ slwi %r16, %r16, 2 /* (Count * 4, but never > 8) can be shifted from params list */
+ add %r1, %r14, %r16 /* set frame-pointer to faked frame */
+ subi %r1, %r1, 8 /* Add LR and back chain save word */
+ mtctr %r13 /* jump to proc */
+ bctr
diff --git a/apply-hack.sparc64.S b/apply-hack.sparc64.S
new file mode 100644
index 00000000..fe4e3f35
--- /dev/null
+++ b/apply-hack.sparc64.S
@@ -0,0 +1,62 @@
+/* apply-hack.ppc.s
+;
+; Copyright (c) 2008-2009, Peter Bex
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+*/
+
+ .text
+
+ .globl _C_do_apply_hack
+ .align 8
+ .equ BIAS, 2047
+
+_C_do_apply_hack:
+ mov %o1, %g4 /* buf */
+ sllx %o2, 3, %o2 /* o2 <- count, in bytes */
+ subcc %o2, 6*8, %o2 /* 6 params are in registers */
+ bg l0
+ mov %o0, %g1 /* proc (delay slot) */
+ udivx %o2, -2, %o2 /* Offset in quads -> offset in words from l2 */
+ setx l2, %o3, %o1
+ jmp %o1+%o2
+ nop
+ /* Rest args on stack if > 6 args */
+l0: sub %sp, %o2, %sp /* Alloc space for additional args */
+ clr %o1
+ add %sp, BIAS+176, %o5
+ add %g4, 6*8, %o3 /* 7th arg and up */
+l1: ldx [%o3], %o4
+ stx %o4, [%o5+%o1]
+ add %o1, 8, %o1
+ cmp %o1, %o2
+ bl l1
+ add %o3, 8, %o3 /* (delay slot) */
+l2: ldx [%g4+40], %o5
+ ldx [%g4+32], %o4
+ ldx [%g4+24], %o3
+ ldx [%g4+16], %o2
+ ldx [%g4+8], %o1
+ ldx [%g4+0], %o0
+
+ jmp %g1
+ nop
diff --git a/apply-hack.x86-64.S b/apply-hack.x86-64.S
new file mode 100644
index 00000000..861481f3
--- /dev/null
+++ b/apply-hack.x86-64.S
@@ -0,0 +1,61 @@
+/* Apply-hack.x86-64.s
+;
+; Copyright (c) 2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+*/
+
+ .text
+
+ .globl _C_do_apply_hack
+#ifndef __APPLE__
+ .type _C_do_apply_hack, @function
+#endif
+
+_C_do_apply_hack:
+ subq $8, %rsp /* force non-16 byte alignment */
+ movq %rdi, %r11 /* get proc */
+ movq %rsi, %r10 /* save buffer address, before we clobber %rsi */
+ cmpl $6, %edx /* clamp at 6 */
+ ja l2
+ je l3
+ movq $6, %rbx /* (6 - count) * 4 gives instruction address */
+ subq %rdx, %rbx
+ shlq $2, %rbx
+ lea l3(%rip), %rdx
+ addq %rdx, %rbx
+ jmp *%rbx
+l2: lea 48(%r10), %rsp /* %r10 must be 16-byte aligned at this point */
+l3: movq 40(%r10), %r9 /* fill registers... */
+ movq 32(%r10), %r8
+ movq 24(%r10), %rcx
+ movq 16(%r10), %rdx
+ movq 8(%r10), %rsi
+ movq (%r10), %rdi
+ xorq %rax, %rax
+ call *%r11
+
+/* Set non-executable stack for Linux ELF target */
+#if defined(__ELF__)
+ .section .note.GNU-stack,"",%progbits
+#endif
diff --git a/apply-hack.x86.S b/apply-hack.x86.S
new file mode 100644
index 00000000..239cfbe4
--- /dev/null
+++ b/apply-hack.x86.S
@@ -0,0 +1,41 @@
+/* apply-hack.x86.s
+;
+; Copyright (c) 2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+*/
+
+ .text
+
+ .globl _C_do_apply_hack
+
+_C_do_apply_hack:
+ movl 4(%esp), %eax
+ movl 8(%esp), %esp
+ call *%eax
+
+/* Set non-executable stack for Linux ELF target */
+#if defined(__ELF__)
+ .section .note.GNU-stack,"",%progbits
+#endif
+
diff --git a/banner.scm b/banner.scm
new file mode 100644
index 00000000..49f9cd32
--- /dev/null
+++ b/banner.scm
@@ -0,0 +1,11 @@
+;;;; banner.scm
+
+
+(define-constant +product+ "CHICKEN")
+
+(define-constant +banner+ #<<EOF
+(c)2008-2009 The Chicken Team
+(c)2000-2007 Felix L. Winkelmann
+
+EOF
+)
diff --git a/batch-driver.scm b/batch-driver.scm
new file mode 100644
index 00000000..8dbe388c
--- /dev/null
+++ b/batch-driver.scm
@@ -0,0 +1,628 @@
+;;;; batch-driver.scm - Driver procedure for the compiler
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit driver)
+ (disable-warning var))
+
+(include "compiler-namespace")
+(include "tweaks")
+
+(define-constant default-profile-name "PROFILE")
+(define-constant funny-message-timeout 60000)
+
+(define user-options-pass (make-parameter #f))
+(define user-read-pass (make-parameter #f))
+(define user-preprocessor-pass (make-parameter #f))
+(define user-pass (make-parameter #f))
+(define user-post-analysis-pass (make-parameter #f))
+
+
+;;; Compile a complete source file:
+
+(define (compile-source-file filename . options)
+ (define (option-arg p)
+ (if (null? (cdr p))
+ (quit "missing argument to `-~A' option" (car p))
+ (let ([arg (cadr p)])
+ (if (symbol? arg)
+ (quit "invalid argument to `~A' option" arg)
+ arg) ) ) )
+ (initialize-compiler)
+ (set! explicit-use-flag (memq 'explicit-use options))
+ (let ([initforms `((##core#declare
+ ,@(append
+ default-declarations
+ (if explicit-use-flag
+ '()
+ `((uses ,@units-used-by-default)) ) ) ) ) ]
+ [verbose (memq 'verbose options)]
+ [outfile (cond [(memq 'output-file options)
+ => (lambda (node)
+ (let ([oname (option-arg node)])
+ (if (symbol? oname)
+ (symbol->string oname)
+ oname) ) ) ]
+ [(memq 'to-stdout options) #f]
+ [else (make-pathname #f (if filename (pathname-file filename) "out") "c")] ) ]
+ [ipath (map chop-separator (string-split (or (get-environment-variable "CHICKEN_INCLUDE_PATH") "") ";"))]
+ [opasses default-optimization-passes]
+ [time0 #f]
+ [time-breakdown #f]
+ [forms '()]
+ [cleanup-forms '(((##sys#implicit-exit-handler)))]
+ [profile (or (memq 'profile options) (memq 'accumulate-profile options) (memq 'profile-name options))]
+ [profile-name (or (and-let* ((pn (memq 'profile-name options))) (cadr pn)) default-profile-name)]
+ [hsize (memq 'heap-size options)]
+ [hisize (memq 'heap-initial-size options)]
+ [hgrowth (memq 'heap-growth options)]
+ [hshrink (memq 'heap-shrinkage options)]
+ [kwstyle (memq 'keyword-style options)]
+ [uses-units '()]
+ [uunit (memq 'unit options)]
+ [a-only (memq 'analyze-only options)]
+ [dynamic (memq 'dynamic options)]
+ [dumpnodes #f]
+ [start-time #f]
+ (upap #f)
+ [ssize (or (memq 'nursery options) (memq 'stack-size options))] )
+
+ (define (cputime) (##sys#fudge 6))
+
+ (define (dribble fstr . args)
+ (when verbose (printf "~?~%~!" fstr args)))
+
+ (define (print-header mode dbgmode)
+ (dribble "pass: ~a" mode)
+ (and (memq dbgmode debugging-chicken)
+ (begin
+ (printf "[~a]~%" mode)
+ #t) ) )
+
+ (define (print-node mode dbgmode n)
+ (when (print-header mode dbgmode)
+ (if dumpnodes
+ (dump-nodes n)
+ (pretty-print (build-expression-tree n)) ) ) )
+
+ (define (print-db mode dbgmode db pass)
+ (when (print-header mode dbgmode)
+ (printf "(iteration ~s)~%" pass)
+ (display-analysis-database db) ) )
+
+ (define (print-expr mode dbgmode xs)
+ (when (print-header mode dbgmode)
+ (for-each pretty-print xs) ) )
+
+ (define (infohook class data val)
+ (let ([data2 ((or ##sys#default-read-info-hook (lambda (a b c) b)) class data val)])
+ (when (and (eq? 'list-info class) (symbol? (car data2)))
+ (##sys#hash-table-set!
+ ##sys#line-number-database
+ (car data2)
+ (alist-cons data2 val
+ (or (##sys#hash-table-ref ##sys#line-number-database (car data2))
+ '() ) ) ) )
+ data2) )
+
+ (define (arg-val str)
+ (let* ((len (string-length str))
+ (len1 (- len 1)) )
+ (or (if (< len 2)
+ (string->number str)
+ (case (string-ref str len1)
+ ((#\m #\M) (* (string->number (substring str 0 len1)) (* 1024 1024)))
+ ((#\k #\K) (* (string->number (substring str 0 len1)) 1024))
+ (else (string->number str)) ) )
+ (quit "invalid numeric argument ~S" str) ) ) )
+
+ (define (collect-options opt)
+ (let loop ([opts options])
+ (cond [(memq opt opts) => (lambda (p) (cons (option-arg p) (loop (cddr p))))]
+ [else '()] ) ) )
+
+ (define (begin-time)
+ (when time-breakdown (set! time0 (cputime))) )
+
+ (define (end-time pass)
+ (when time-breakdown
+ (printf "milliseconds needed for ~a: \t~s~%" pass (- (cputime) time0)) ) )
+
+ (define (read-form in)
+ (##sys#read in infohook) )
+
+ (define (analyze pass node . args)
+ (let-optionals args ((no 0) (contf #t))
+ (let ((db (analyze-expression node)))
+ (when upap
+ (upap pass db node
+ (cut get db <> <>)
+ (cut put! db <> <> <>)
+ no contf) )
+ db) ) )
+
+ (when uunit
+ (set! unit-name (string->c-identifier (stringify (option-arg uunit)))) )
+ (when (or unit-name dynamic)
+ (set! standalone-executable #f))
+ (when (memq 'ignore-repository options)
+ (set! ##sys#dload-disabled #t)
+ (repository-path #f))
+ (set! debugging-chicken
+ (append-map
+ (lambda (do)
+ (map (lambda (c) (string->symbol (string c)))
+ (string->list do) ) )
+ (collect-options 'debug) ) )
+ (set! dumpnodes (memq '|D| debugging-chicken))
+ (set! import-libraries
+ (map (lambda (il)
+ (cons (string->symbol il)
+ (string-append il ".import.scm")))
+ (collect-options 'emit-import-library)))
+ (when (and (memq 'emit-all-import-libraries options)
+ (not a-only))
+ (set! all-import-libraries #t))
+ (when (memq 'lambda-lift options) (set! do-lambda-lifting #t))
+ (when (memq 'scrutinize options) (set! do-scrutinize #t))
+ (when (memq 't debugging-chicken) (##sys#start-timer))
+ (when (memq 'b debugging-chicken) (set! time-breakdown #t))
+ (when (memq 'emit-exports options)
+ (warning "deprecated compiler option: emit-exports") )
+ (when (memq 'raw options)
+ (set! explicit-use-flag #t)
+ (set! cleanup-forms '())
+ (set! initforms '()) )
+ (when (memq 'no-lambda-info options)
+ (set! emit-closure-info #f) )
+ (when (memq 'no-compiler-syntax options)
+ (set! compiler-syntax-enabled #f))
+ (when (memq 'local options)
+ (set! local-definitions #t))
+ (when (memq 'inline-global options)
+ (set! enable-inline-files #t)
+ (set! inline-locally #t)
+ (set! inline-globally #t))
+ (set! disabled-warnings (map string->symbol (collect-options 'disable-warning)))
+ (when (memq 'no-warnings options)
+ (dribble "Warnings are disabled")
+ (set! ##sys#warnings-enabled #f) )
+ (when (memq 'optimize-leaf-routines options) (set! optimize-leaf-routines #t))
+ (when (memq 'unsafe options)
+ (set! unsafe #t) )
+ (when (and dynamic (memq 'unsafe-libraries options))
+ (set! emit-unsafe-marker #t) )
+ (when (memq 'setup-mode options)
+ (set! ##sys#setup-mode #t))
+ (when (memq 'disable-interrupts options) (set! insert-timer-checks #f))
+ (when (memq 'fixnum-arithmetic options) (set! number-type 'fixnum))
+ (when (memq 'block options) (set! block-compilation #t))
+ (when (memq 'emit-external-prototypes-first options)
+ (set! external-protos-first #t))
+ (when (memq 'inline options) (set! inline-locally #t))
+ (and-let* ((ifile (memq 'emit-inline-file options)))
+ (set! inline-locally #t) ; otherwise this option makes no sense
+ (set! local-definitions #t)
+ (set! inline-output-file (option-arg ifile)))
+ (and-let* ([inlimit (memq 'inline-limit options)])
+ (set! inline-max-size
+ (let ([arg (option-arg inlimit)])
+ (or (string->number arg)
+ (quit "invalid argument to `-inline-limit' option: `~A'" arg) ) ) ) )
+ (when (memq 'case-insensitive options)
+ (dribble "Identifiers and symbols are case insensitive")
+ (register-feature! 'case-insensitive)
+ (case-sensitive #f) )
+ (when (memq 'compress-literals options)
+ (compiler-warning 'usage "`the -compress-literals' option is obsolete") )
+ (when kwstyle
+ (let ([val (option-arg kwstyle)])
+ (cond [(string=? "prefix" val) (keyword-style #:prefix)]
+ [(string=? "none" val) (keyword-style #:none)]
+ [(string=? "suffix" val) (keyword-style #:suffix)]
+ [else (quit "invalid argument to `-keyword-style' option")] ) ) )
+ (when (memq 'no-parenthesis-synonyms options)
+ (dribble "Disabled support for parenthesis synonyms")
+ (parenthesis-synonyms #f) )
+ (when (memq 'no-symbol-escape options)
+ (dribble "Disabled support for escaped symbols")
+ (symbol-escape #f) )
+ (when (memq '("-r5rs-syntax") options)
+ (dribble "Disabled the Chicken extensions to R5RS syntax")
+ (case-sensitive #f)
+ (keyword-style #:none)
+ (parentheses-synonyms #f)
+ (symbol-escape #f) )
+ (set! verbose-mode verbose)
+ (set! ##sys#read-error-with-line-number #t)
+ (set! ##sys#include-pathnames
+ (append (map chop-separator (collect-options 'include-path))
+ ##sys#include-pathnames
+ ipath) )
+ (when (and outfile filename (string=? outfile filename))
+ (quit "source- and output-filename are the same") )
+ (set! uses-units (map string->symbol (collect-options 'uses)))
+ (when (memq 'keep-shadowed-macros options)
+ (set! undefine-shadowed-macros #f) )
+ (when (memq 'no-argc-checks options)
+ (set! no-argc-checks #t) )
+ (when (memq 'no-bound-checks options)
+ (set! no-bound-checks #t) )
+ (when (memq 'no-procedure-checks options)
+ (set! no-procedure-checks #t) )
+ (when (memq 'no-procedure-checks-for-usual-bindings options)
+ (for-each
+ (lambda (v)
+ (mark-variable v '##compiler#always-bound-to-procedure)
+ (mark-variable v '##compiler#always-bound) )
+ default-standard-bindings)
+ (for-each
+ (lambda (v)
+ (mark-variable v '##compiler#always-bound-to-procedure)
+ (mark-variable v '##compiler#always-bound) )
+ default-extended-bindings) )
+
+ ;; Handle feature options:
+ (for-each
+ register-feature!
+ (append-map (cut string-split <> ",") (collect-options 'feature)))
+
+ ;; Load extensions:
+ (set! ##sys#features (cons #:compiler-extension ##sys#features))
+ (let ([extends (collect-options 'extend)])
+ (dribble "Loading compiler extensions...")
+ (when verbose (load-verbose #t))
+ (for-each
+ (lambda (f) (load (##sys#resolve-include-filename f #f #t)))
+ extends) )
+ (set! ##sys#features (delete #:compiler-extension ##sys#features eq?))
+
+ (set! ##sys#features (cons '#:compiling ##sys#features))
+ (set! upap (user-post-analysis-pass))
+
+ ;; Insert postponed initforms:
+ (set! initforms (append initforms postponed-initforms))
+
+ (let ((se (map string->symbol (collect-options 'static-extension))))
+ ;; Append required extensions to initforms:
+ (set! initforms
+ (append
+ initforms
+ (map (lambda (r) `(##core#require-extension (,r) #t))
+ (append se (map string->symbol (collect-options 'require-extension))))))
+
+ ;; add static-extensions as used units:
+ (set! ##sys#explicit-library-modules
+ (append ##sys#explicit-library-modules se)))
+
+ (when (memq 'compile-syntax options)
+ (set! ##sys#enable-runtime-macros #t) )
+ (set! target-heap-size
+ (if hsize
+ (arg-val (option-arg hsize))
+ (and-let* ([hsize default-default-target-heap-size]
+ [(not (zero? hsize))] )
+ hsize) ) )
+ (set! target-initial-heap-size (and hisize (arg-val (option-arg hisize))))
+ (set! target-heap-growth (and hgrowth (arg-val (option-arg hgrowth))))
+ (set! target-heap-shrinkage (and hshrink (arg-val (option-arg hshrink))))
+ (set! target-stack-size
+ (if ssize
+ (arg-val (option-arg ssize))
+ (and-let* ([ssize default-default-target-stack-size]
+ [(not (zero? ssize))] )
+ ssize) ) )
+ (set! emit-trace-info (not (memq 'no-trace options)))
+ (set! disable-stack-overflow-checking (memq 'disable-stack-overflow-checks options))
+ (when (memq 'm debugging-chicken) (set-gc-report! #t))
+ (unless (memq 'no-usual-integrations options)
+ (set! standard-bindings default-standard-bindings)
+ (set! extended-bindings default-extended-bindings) )
+ (dribble "debugging info: ~A"
+ (if emit-trace-info
+ "calltrace"
+ "none") )
+ (when profile
+ (let ([acc (eq? 'accumulate-profile (car profile))])
+ (set! emit-profile #t)
+ (set! profiled-procedures 'all)
+ (set! initforms
+ (append
+ initforms
+ default-profiling-declarations
+ (if acc
+ '((set! ##sys#profile-append-mode #t))
+ '() ) ) )
+ (dribble "Generating ~aprofile" (if acc "accumulated " "")) ) )
+
+ ;;*** hardcoded "modules.db" is bad (also used in chicken-install.scm)
+ (load-identifier-database "modules.db")
+
+ (cond ((memq 'version options)
+ (print-version #t)
+ (newline) )
+ ((or (memq 'help options) (memq '-help options) (memq 'h options) (memq '-h options))
+ (print-usage))
+ ((memq 'release options)
+ (display (chicken-version))
+ (newline) )
+ ((not filename)
+ (print-version #t)
+ (display "\nEnter \"chicken -help\" for information on how to use it.\n") )
+ (else
+
+ ;; Display header:
+ (dribble "compiling `~a' ..." filename)
+ (set! source-filename filename)
+ (debugging 'r "options" options)
+ (debugging 'r "debugging options" debugging-chicken)
+ (debugging 'r "target heap size" target-heap-size)
+ (debugging 'r "target stack size" target-stack-size)
+ (set! start-time (cputime))
+
+ ;; Read toplevel expressions:
+ (set! ##sys#line-number-database (make-vector line-number-database-size '()))
+ (let ([prelude (collect-options 'prelude)]
+ [postlude (collect-options 'postlude)]
+ [files (append
+ (collect-options 'prologue)
+ (list filename)
+ (collect-options 'epilogue) ) ] )
+
+ (let ([proc (user-read-pass)])
+ (cond [proc
+ (dribble "User read pass...")
+ (set! forms (proc prelude files postlude)) ]
+ [else
+ (do ([files files (cdr files)])
+ ((null? files)
+ (set! forms
+ (append (map string->expr prelude)
+ (reverse forms)
+ (map string->expr postlude) ) ) )
+ (let* ((f (car files))
+ (in (check-and-open-input-file f)) )
+ (fluid-let ((##sys#current-source-filename f))
+ (let ((x1 (read-form in)) )
+ (do ((x x1 (read-form in)))
+ ((eof-object? x)
+ (close-checked-input-file in f) )
+ (set! forms (cons x forms)) ) ) ) ) ) ] ) ) )
+
+ ;; Start compilation passes:
+ (let ([proc (user-preprocessor-pass)])
+ (when proc
+ (dribble "User preprocessing pass...")
+ (set! forms (map proc forms))))
+
+ (print-expr "source" '|1| forms)
+ (begin-time)
+ (unless (null? uses-units)
+ (set! ##sys#explicit-library-modules (append ##sys#explicit-library-modules uses-units))
+ (set! forms (cons `(declare (uses ,@uses-units)) forms)) )
+ (let* ([exps0 (map canonicalize-expression (append initforms forms))]
+ [pvec (gensym)]
+ [plen (length profile-lambda-list)]
+ [exps (append
+ (map (lambda (ic) `(set! ,(cdr ic) ',(car ic))) immutable-constants)
+ (map (lambda (n) `(##core#callunit ,n)) used-units)
+ (if emit-profile
+ `((set! ,profile-info-vector-name
+ (##sys#register-profile-info
+ ',plen
+ ',(if unit-name #f profile-name))))
+ '() )
+ (map (lambda (pl)
+ `(##sys#set-profile-info-vector!
+ ,profile-info-vector-name
+ ',(car pl)
+ ',(cdr pl) ) )
+ profile-lambda-list)
+ exps0
+ (if (and (not unit-name) (not dynamic))
+ cleanup-forms
+ '() )
+ '((##core#undefined))) ] )
+
+ (when (and (pair? compiler-syntax-statistics)
+ (debugging 'o "applied compiler syntax:"))
+ (for-each
+ (lambda (cs) (printf " ~a\t\t~a~%" (car cs) (cdr cs)))
+ compiler-syntax-statistics))
+ (when (debugging '|N| "real name table:")
+ (display-real-name-table) )
+ (when (debugging 'n "line number database:")
+ (display-line-number-database) )
+
+ (when (and unit-name dynamic)
+ (compiler-warning 'usage "library unit `~a' compiled in dynamic mode" unit-name) )
+
+ (when (and unsafe (feature? 'compiling-extension))
+ (compiler-warning
+ 'style
+ "compiling extensions in unsafe mode is bad practice and should be avoided") )
+
+ (set! ##sys#line-number-database line-number-database-2)
+ (set! line-number-database-2 #f)
+
+ (end-time "canonicalization")
+ (print-expr "canonicalized" '|2| exps)
+
+ (when (memq 'check-syntax options) (exit))
+
+ (let ([proc (user-pass)])
+ (when proc
+ (dribble "User pass...")
+ (begin-time)
+ (set! exps (map proc exps))
+ (end-time "user pass") ) )
+
+ (let ((node0 (make-node
+ 'lambda '(())
+ (list (build-node-graph
+ (canonicalize-begin-body exps) ) ) ) )
+ (db #f))
+
+ (print-node "initial node tree" '|T| node0)
+ (initialize-analysis-database)
+
+ (when do-scrutinize
+ ;;;*** hardcoded database file name
+ (unless (memq 'ignore-repository options)
+ (load-type-database "types.db"))
+ (for-each (cut load-type-database <> #f) (collect-options 'types))
+ (begin-time)
+ (set! first-analysis #f)
+ (set! db (analyze 'scrutiny node0))
+ (print-db "analysis" '|0| db 0)
+ (end-time "pre-analysis")
+ (begin-time)
+ (debugging 'p "performing scrutiny")
+ (scrutinize node0 db)
+ (end-time "scrutiny")
+ (set! first-analysis #t) )
+
+ (when do-lambda-lifting
+ (begin-time)
+ (unless do-scrutinize ; no need to do analysis if already done above
+ (set! first-analysis #f)
+ (set! db (analyze 'lift node0))
+ (print-db "analysis" '|0| db 0)
+ (end-time "pre-analysis (lambda-lift)"))
+ (begin-time)
+ (perform-lambda-lifting! node0 db)
+ (end-time "lambda lifting")
+ (print-node "lambda lifted" '|L| node0)
+ (set! first-analysis #t) )
+
+ (let ((req (concatenate (vector->list file-requirements))))
+ (when (debugging 'M "; requirements:")
+ (pp req))
+ (when enable-inline-files
+ (for-each
+ (lambda (id)
+ (and-let* ((ifile (##sys#resolve-include-filename
+ (make-pathname #f (symbol->string id) "inline")
+ #f #t))
+ ((file-exists? ifile)))
+ (dribble "Loading inline file ~a ..." ifile)
+ (load-inline-file ifile)))
+ (concatenate (map cdr req))) )
+ (let ((ifs (collect-options 'consult-inline-file)))
+ (unless (null? ifs)
+ (set! inline-globally #t)
+ (set! inline-locally #t)
+ (for-each
+ (lambda (ilf)
+ (dribble "Loading inline file ~a ..." ilf)
+ (load-inline-file ilf) )
+ ifs))))
+
+ (set! ##sys#line-number-database #f)
+ (set! constant-table #f)
+ (set! inline-table #f)
+ (unless unsafe
+ (scan-toplevel-assignments (first (node-subexpressions node0))) )
+
+ (begin-time)
+ (let ([node1 (perform-cps-conversion node0)])
+ (end-time "cps conversion")
+ (print-node "cps" '|3| node1)
+
+ ;; Optimization loop:
+ (let loop ([i 1] [node2 node1] [progress #t])
+
+ (begin-time)
+ (let ([db (analyze 'opt node2 i progress)])
+ (when first-analysis
+ (when (memq 'u debugging-chicken)
+ (dump-undefined-globals db))
+ (when (memq 'd debugging-chicken)
+ (dump-defined-globals db))
+ (when (memq 'v debugging-chicken)
+ (dump-global-refs db)) )
+ (set! first-analysis #f)
+ (end-time "analysis")
+ (print-db "analysis" '|4| db i)
+
+ (when (memq 's debugging-chicken) (print-program-statistics db))
+
+ (cond [progress
+ (debugging 'p "optimization pass" i)
+
+ (begin-time)
+ (receive (node2 progress-flag)
+ (perform-high-level-optimizations node2 db)
+ (end-time "optimization")
+ (print-node "optimized-iteration" '|5| node2)
+
+ (cond [progress-flag (loop (add1 i) node2 #t)]
+ [(not inline-substitutions-enabled)
+ (debugging 'p "rewritings enabled...")
+ (set! inline-substitutions-enabled #t)
+ (loop (add1 i) node2 #t) ]
+ [optimize-leaf-routines
+ (begin-time)
+ (let ([db (analyze 'leaf node2)])
+ (end-time "analysis")
+ (begin-time)
+ (let ([progress (transform-direct-lambdas! node2 db)])
+ (end-time "leaf routine optimization")
+ (loop (add1 i) node2 progress) ) ) ]
+ [else (loop (add1 i) node2 #f)] ) ) ]
+
+ [else
+ (print-node "optimized" '|7| node2)
+
+ (when inline-output-file
+ (let ((f inline-output-file))
+ (dribble "Generating global inline file `~a' ..." f)
+ (emit-global-inline-file f db) ) )
+
+ (begin-time)
+ (let ([node3 (perform-closure-conversion node2 db)])
+ (end-time "closure conversion")
+ (print-db "final-analysis" '|8| db i)
+ (when (and ##sys#warnings-enabled (> (- (cputime) start-time) funny-message-timeout))
+ (display "(don't worry - still compiling...)\n") )
+ (when a-only (exit 0))
+ (print-node "closure-converted" '|9| node3)
+
+ (begin-time)
+ (receive (node literals lliterals lambdas)
+ (prepare-for-code-generation node3 db)
+ (end-time "preparation")
+
+ (begin-time)
+ (let ((out (if outfile (open-output-file outfile) (current-output-port))) )
+ (dribble "generating `~A' ..." outfile)
+ (generate-code literals lliterals lambdas out filename dynamic db)
+ (when outfile (close-output-port out)))
+ (end-time "code generation")
+ (when (memq 't debugging-chicken) (##sys#display-times (##sys#stop-timer)))
+ (compiler-cleanup-hook)
+ (dribble "compilation finished.") ) ) ] ) ) ) ) ) ) ) ) ) )
diff --git a/benchmarks/0.scm b/benchmarks/0.scm
new file mode 100644
index 00000000..81a44219
--- /dev/null
+++ b/benchmarks/0.scm
@@ -0,0 +1,3 @@
+;;;; 0.scm - does nothing
+
+(time #f)
diff --git a/benchmarks/binarytrees.scm b/benchmarks/binarytrees.scm
new file mode 100644
index 00000000..8ed7ce9c
--- /dev/null
+++ b/benchmarks/binarytrees.scm
@@ -0,0 +1,33 @@
+;;; The Computer Language Benchmarks Game
+;;; http://shootout.alioth.debian.org/
+;;; contributed by Sven Hartrumpf
+
+(define make (lambda (item d)
+ (if (= d 0)
+ (list 'empty item)
+ (let ((item2 (* item 2))
+ (d2 (- d 1)))
+ (list 'node (make (- item2 1) d2) item (make item2 d2))))))
+
+(define check (lambda (t)
+ (if (eq? (car t) 'empty)
+ (cadr t)
+ (+ (caddr t) (- (check (cadr t)) (check (cadddr t)))))))
+
+(define main (lambda (n)
+ (let* ((min-depth 4)
+ (max-depth (max (+ min-depth 2) n)))
+ (let ((stretch-depth (+ max-depth 1)))
+ (display "stretch tree of depth ") (display stretch-depth) (write-char #\tab) (display " check: ") (display (check (make 0 stretch-depth))) (newline))
+ (let ((long-lived-tree (make 0 max-depth)))
+ (do ((d 4 (+ d 2))
+ (c 0 0))
+ ((> d max-depth))
+ (let ((iterations (arithmetic-shift 1 (+ (- max-depth d) min-depth)))) ; chicken-specific: arithmetic-shift
+ (do ((i 0 (+ i 1)))
+ ((>= i iterations))
+ (set! c (+ c (check (make i d)) (check (make (- i) d)))))
+ (display (* 2 iterations)) (write-char #\tab) (display " trees of depth ") (display d) (write-char #\tab) (display " check: ") (display c) (newline)))
+ (display "long lived tree of depth ") (display max-depth) (write-char #\tab) (display " check: ") (display (check long-lived-tree)) (newline)))))
+
+(time (main 10))
diff --git a/benchmarks/boyer.scm b/benchmarks/boyer.scm
new file mode 100644
index 00000000..d6118372
--- /dev/null
+++ b/benchmarks/boyer.scm
@@ -0,0 +1,284 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; File: boyer.sc
+;;; 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)
+;;; 23-May-94 (Qobi)
+;;; 31-Mar-98 (Qobi)
+;;; 26-Mar-00 (flw)
+;;; Language: Scheme (but see note)
+;;; 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).
+;;; Note: The Common Lisp version of this benchmark returns the wrong
+;;; answer because it uses the Common Lisp equivalent of memv instead of
+;;; member in the falsep and truep procedures. (The error arose because
+;;; memv is called member in Common Lisp. Don't ask what member is called,
+;;; unless you want to learn about keyword arguments.) This Scheme version
+;;; may run a few percent slower than it would if it were equivalent to
+;;; the Common Lisp version, but it works.
+
+;;; BOYER -- Logic programming benchmark, originally written by Bob Boyer.
+;;; Fairly CONS intensive.
+
+
+(define unify-subst '()) ;Qobi
+
+(define temp-temp #f) ;Qobi
+
+(define (add-lemma term)
+ (cond ((and (pair? term) (eq? (car term) 'equal) (pair? (cadr term)))
+ (put! (car (cadr term))
+ 'lemmas
+ (cons term (or (get (car (cadr term)) 'lemmas) '()))))
+ (else (display "ADD-LEMMA did not like term: ") ;Qobi
+ (display term) ;Qobi
+ (newline)))) ;Qobi
+
+(define (add-lemma-lst lst)
+ (cond ((null? lst) #t)
+ (else (add-lemma (car lst)) (add-lemma-lst (cdr lst)))))
+
+(define (apply-subst alist term)
+ (cond ((not (pair? term))
+ (cond ((begin (set! temp-temp (assq term alist)) temp-temp)
+ (cdr temp-temp))
+ (else term)))
+ (else (cons (car term) (apply-subst-lst alist (cdr term))))))
+
+(define (apply-subst-lst alist lst)
+ (cond ((null? lst) '()) ;Qobi
+ (else (cons (apply-subst alist (car lst))
+ (apply-subst-lst alist (cdr lst))))))
+
+(define (falsep x lst) (or (equal? x '(f)) (member x lst)))
+
+(define (one-way-unify term1 term2)
+ (set! unify-subst '()) ;Qobi
+ (one-way-unify1 term1 term2))
+
+(define (one-way-unify1 term1 term2)
+ (cond ((not (pair? term2))
+ (cond ((begin (set! temp-temp (assq term2 unify-subst)) temp-temp)
+ (equal? term1 (cdr temp-temp)))
+ (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) #t)
+ ((one-way-unify1 (car lst1) (car lst2))
+ (one-way-unify1-lst (cdr lst1) (cdr lst2)))
+ (else #f)))
+
+(define (rewrite term)
+ (cond ((not (pair? term)) term)
+ (else (rewrite-with-lemmas
+ (cons (car term) (rewrite-args (cdr term)))
+ (or (get (car term) 'lemmas) '())))))
+
+(define (rewrite-args lst)
+ (cond ((null? lst) '()) ;Qobi
+ (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 (setup)
+ (add-lemma-lst
+ '((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)))) ;Qobi
+ (equal (countps- l pred) (countps-loop l pred (zero)))
+ (equal (fact- i) (fact-loop i (one)))
+ (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)))) ;Qobi
+ (equal (and p q) (if p (if q (t) (f)) (f)))
+ (equal (or p q) (if p (t) (if q (t) (f)) (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 (one)) (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 (one))))))
+ (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 (one))) (equal x (zero))))
+ (equal (equal (greatest-factor x y) (one)) (equal x (one)))
+ (equal (numberp (greatest-factor x y))
+ (not (and (or (zerop y) (equal y (one))) (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 (one)))))
+ (equal (greatereqpr x y) (not (lessp x y)))
+ (equal (equal x (times x y))
+ (or (equal x (zero)) (and (numberp x) (equal y (one)))))
+ (equal (remainder (times y x) y) (zero))
+ (equal (equal (times a b) (one))
+ (and (not (equal a (zero)))
+ (not (equal b (zero)))
+ (numberp a)
+ (numberp b)
+ (equal (sub1 a) (zero)) ;Qobi
+ (equal (sub1 b) (zero)))) ;Qobi
+ (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 (six) (length x7)))
+ (equal (difference (add1 (add1 x)) (two)) (fix x))
+ (equal (quotient (plus x (plus x y)) (two)) (plus x (quotient y (two))))
+ (equal (sigma (zero) i) (quotient (times i (add1 i)) (two)))
+ (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 (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)
+ (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 (tautp x) (tautologyp (rewrite x) '() '())) ;Qobi
+
+(define (test)
+ (define ans #f)
+ (define term #f)
+ (set! term
+ (apply-subst
+ '((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))))
+ '(implies (and (implies x y)
+ (and (implies y z) (and (implies z u) (implies u w))))
+ (implies x w))))
+ (set! ans (tautp term))
+ ans)
+
+(define (truep x lst) (or (equal? x '(t)) (member x lst)))
+
+(setup)
+
+(if (not (eq? #t (time (test))))
+ (error "wrong result") )
diff --git a/benchmarks/browse.scm b/benchmarks/browse.scm
new file mode 100644
index 00000000..bb433899
--- /dev/null
+++ b/benchmarks/browse.scm
@@ -0,0 +1,151 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; File: browse.sc
+;;; Description: The BROWSE benchmark from the Gabriel tests
+;;; Author: Richard Gabriel
+;;; Created: 8-Apr-85
+;;; Modified: 14-Jun-85 18:44:49 (Bob Shaw)
+;;; 16-Aug-87 (Will Clinger)
+;;; 22-Jan-88 (Will Clinger)
+;;; 24-Mar-96 (Qobi)
+;;; 31-Mar-98 (Qobi)
+;;; 26-Mar-00 (flw)
+;;; Language: Scheme (but see notes below)
+;;; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; Note: This benchmark has been run only in implementations in which
+;;; the empty list is the same as #f, and may not work if that is not true.
+;;; 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).
+;;; Note: The Common Lisp version assumes that eq works on characters,
+;;; which is not a portable assumption but is true in most implementations.
+;;; This translation makes the same assumption about eq?.
+;;; Note: The gensym procedure was left as in Common Lisp. Most Scheme
+;;; implementations have something similar internally.
+;;; Note: The original benchmark took the car or cdr of the empty list
+;;; 14,600 times. Before explicit tests were added to protect the offending
+;;; calls to car and cdr, MacScheme was spending a quarter of its run time
+;;; in the exception handler recovering from those errors.
+
+; 11/07/00 - felix:
+;
+; - Renamed 'match' to 'bmatch', because there exists a macro-definition of
+; 'match' already.
+
+;;; The next few definitions should be omitted if the Scheme implementation
+;;; already provides them.
+
+(define (append! x y)
+ (if (null? x)
+ y
+ (do ((a x b) (b (cdr x) (cdr b))) ((null? b) (set-cdr! a y) x))))
+
+(define (copy-tree x)
+ (if (not (pair? x)) x (cons (copy-tree (car x)) (copy-tree (cdr x)))))
+
+
+;;; BROWSE -- Benchmark to create and browse through
+;;; an AI-like data base of units.
+
+;;; n is # of symbols
+;;; m is maximum amount of stuff on the plist
+;;; npats is the number of basic patterns on the unit
+;;; ipats is the instantiated copies of the patterns
+
+(define *rand* 21)
+
+(define (init n m npats ipats)
+ (let ((ipats (copy-tree ipats)))
+ (do ((p ipats (cdr p))) ((null? (cdr p)) (set-cdr! p ipats)))
+ (do ((n n (- n 1))
+ (i m (cond ((zero? i) m) (else (- i 1))))
+ (name (gensym) (gensym))
+ (a '()))
+ ((= n 0) a)
+ (set! a (cons name a))
+ (do ((i i (- i 1))) ((zero? i)) (put! name (gensym) #f))
+ (put! name
+ 'pattern
+ (do ((i npats (- i 1)) (ipats ipats (cdr ipats)) (a '()))
+ ((zero? i) a)
+ (set! a (cons (car ipats) a))))
+ (do ((j (- m i) (- j 1))) ((zero? j)) (put! name (gensym) #f)))))
+
+(define (browse-random)
+ (set! *rand* (remainder (* *rand* 17) 251))
+ *rand*)
+
+(define (randomize l)
+ (do ((a '())) ((null? l) a)
+ (let ((n (remainder (browse-random) (length l))))
+ (cond ((zero? n)
+ (set! a (cons (car l) a))
+ (set! l (cdr l))
+ l)
+ (else (do ((n n (- n 1)) (x l (cdr x)))
+ ((= n 1)
+ (set! a (cons (cadr x) a))
+ (set-cdr! x (cddr x))
+ x)))))))
+
+(define (bmatch pat dat alist)
+ (cond ((null? pat) (null? dat))
+ ((null? dat) #f) ;Qobi: used to depend on () being false
+ ((or (eq? (car pat) '?) (eq? (car pat) (car dat)))
+ (bmatch (cdr pat) (cdr dat) alist))
+ ((eq? (car pat) '*)
+ (or (bmatch (cdr pat) dat alist)
+ (bmatch (cdr pat) (cdr dat) alist)
+ (bmatch pat (cdr dat) alist)))
+ (else (cond ((not (pair? (car pat)))
+ (cond ((eq? (string-ref (symbol->string (car pat)) 0) #\?)
+ (let ((val (assv (car pat) alist)))
+ (cond (val (bmatch (cons (cdr val) (cdr pat))
+ dat alist))
+ (else (bmatch (cdr pat)
+ (cdr dat)
+ (cons (cons (car pat)
+ (car dat))
+ alist))))))
+ ((eq? (string-ref (symbol->string (car pat)) 0) #\*)
+ (let ((val (assv (car pat) alist)))
+ (cond (val (bmatch (append (cdr val) (cdr pat))
+ dat alist))
+ (else
+ (do ((l '()
+ (append! l
+ (cons (if (null? d)
+ '()
+ (car d))
+ '())))
+ (e (cons '() dat) (cdr e))
+ (d dat (if (null? d) '() (cdr d))))
+ ((or (null? e)
+ (bmatch (cdr pat)
+ d
+ (cons (cons (car pat) l)
+ alist)))
+ (if (null? e) #f #t)))))))
+ ;; Qobi: used to depend of missing ELSE returning #F
+ (else #f)))
+ (else (and (pair? (car dat))
+ (bmatch (car pat) (car dat) alist)
+ (bmatch (cdr pat) (cdr dat) alist)))))))
+
+(define (browse)
+ (investigate (randomize (init 100 10 4 '((a a a b b b b a a a a a b b a a a)
+ (a a b b b b a a (a a) (b b))
+ (a a a b (b a) b a b a))))
+ '((*a ?b *b ?b a *a a *b *a)
+ (*a *b *b *a (*a) (*b))
+ (? ? * (b a) * ? ?))))
+
+(define (investigate units pats)
+ (do ((units units (cdr units))) ((null? units))
+ (do ((pats pats (cdr pats))) ((null? pats))
+ (do ((p (get (car units) 'pattern) (cdr p))) ((null? p))
+ (bmatch (car pats) (car p) '())))))
+
+
+(time (browse))
diff --git a/benchmarks/conform.scm b/benchmarks/conform.scm
new file mode 100644
index 00000000..be2013d5
--- /dev/null
+++ b/benchmarks/conform.scm
@@ -0,0 +1,453 @@
+;;; CONFORM -- Type checker, written by Jim Miller.
+
+;;; Functional and unstable
+
+(define (sort-list obj pred)
+
+ (define (loop l)
+ (if (and (pair? l) (pair? (cdr l)))
+ (split-list l '() '())
+ l))
+
+ (define (split-list l one two)
+ (if (pair? l)
+ (split-list (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))
+
+;; 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 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))
+
+(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))
+ (fatal-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) (fatal-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 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))
+
+; 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))))
+
+;; GRAPHS
+
+(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))
+
+; 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. <arg, res>) 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-list 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) (fatal-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 (setup)
+ (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)
+ (setup)
+ (map name
+ (graph-nodes (make-lattice (make-graph a b c d any-node none-node) #f))))
+
+(time (test))
diff --git a/benchmarks/cpstak.scm b/benchmarks/cpstak.scm
new file mode 100644
index 00000000..0c6ea7b7
--- /dev/null
+++ b/benchmarks/cpstak.scm
@@ -0,0 +1,24 @@
+;;; cpstak.scm
+
+
+(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)))
+
+(time (do ((i 100 (- i 1))) ((zero? i)) (cpstak 18 12 6)))
+
diff --git a/benchmarks/cscbench.scm b/benchmarks/cscbench.scm
new file mode 100644
index 00000000..cf194c12
--- /dev/null
+++ b/benchmarks/cscbench.scm
@@ -0,0 +1,189 @@
+;;;; cscbench - Compile and run benchmarks - felix -*- Scheme -*-
+;
+; - Usage: cscbench [-debug] [-cc=<path>] [-csc=<path>] [-chicken=<path>] OPTION ...
+
+(require-extension srfi-1 utils posix regex)
+
+(define ignored-files '("cscbench.scm" "cscbench.scm~"))
+(define flonum-files '("fft" "maze" "nbody"))
+(define cc "gcc")
+(define chicken "chicken")
+(define csc "csc")
+
+(define +chicken-format+
+ "~A ~A -quiet -no-warnings -heap-size 16m -output-file tmpfile.c ~A ~A -debug xopi 2>&1 >>bench.log")
+
+(define +cc-format+
+ (cond-expand
+ (macos "~a ~a -s -I.. tmpfile.c -o tmpfile ../lib~achicken.a -lm")
+ (else "~a ~a -I.. tmpfile.c -o tmpfile ../lib~achicken.a -lm") ) )
+
+(define (abort-run) #f)
+
+(define run
+ (let ([secrx (regexp "^ *([-.+e0-9]*(\\.[0-9]*)?) seconds elapsed$")])
+ (lambda ()
+ (system* "./tmpfile >tmpfile.out")
+ (with-input-from-file "tmpfile.out"
+ (lambda ()
+ (let loop ([line (read-line)])
+ (if (eof-object? line)
+ (abort-run)
+ (let ([m (string-match secrx line)])
+ (if m
+ (string->number (second m))
+ (loop (read-line)) ) ) ) ) ) ) ) ) )
+
+(define (display-l str len pad)
+ (let ([slen (string-length str)])
+ (display (substring str 0 (min slen len)))
+ (display (make-string (max 0 (- len slen)) pad)) ) )
+
+(define (display-r str len pad)
+ (let ([slen (string-length str)])
+ (display (make-string (max 0 (- len slen)) pad))
+ (display (substring str 0 (min slen len))) ) )
+
+(define display-f-4.3
+ (let ([florx (regexp "^([-+e0-9]*)(\\.([0-9]*))?$")])
+ (lambda (n)
+ (let* ([m (string-match florx (number->string n))]
+ [is (second m)]
+ [fs (fourth m)] )
+ (display-r is 4 #\space)
+ (display #\.)
+ (display-r (or fs "0") 3 #\0) ) ) ) )
+
+(define (display-size n)
+ (display-r
+ (string-append (number->string (quotient n 1024)) "k")
+ 10 #\space))
+
+(define (compile-and-run file decls options coptions unsafe)
+ (system* +chicken-format+ chicken file decls options)
+ (system* +cc-format+ cc coptions (if unsafe "u" ""))
+ (let ((time (call-with-current-continuation
+ (lambda (abort)
+ (set! abort-run (cut abort #f))
+ (let ((runs
+ (butlast
+ (cdr
+ (sort
+ (map (lambda _ (run)) (iota 5))
+ <)))))
+ (/ (apply + runs) 3)))))
+ (size (file-size "tmpfile")))
+ (display #\space)
+ (cond (time
+ (display-f-4.3 time)
+ (values time size))
+ (else
+ (display "FAILED")
+ (values 9999.9 size)))))
+
+(define (dflush x)
+ (display x)
+ (flush-output) )
+
+(define (main options)
+ (call/cc
+ (lambda (return)
+ (let loop ((opts options))
+ (cond ((null? opts) (return #f))
+ ((string=? "-debug" (car opts))
+ (set! system*
+ (let ([system* system*])
+ (lambda args
+ (let ([s (apply sprintf args)])
+ (printf "system: ~A~%" s)
+ (system* s) ) ) ) ) )
+ ((string-match "-cc=(.*)" (car opts)) =>
+ (lambda (m) (set! cc (second m))))
+ ((string-match "-csc=(.*)" (car opts)) =>
+ (lambda (m) (set! csc (second m))))
+ ((string-match "-chicken=(.*)" (car opts)) =>
+ (lambda (m) (set! chicken (second m))))
+ (else
+ (set! options opts)
+ (return #f)))
+ (loop (cdr opts)))))
+ (set! cc (string-trim-both (with-input-from-pipe "csc -cc-name" read-line)))
+ (delete-file* "tmpfile.scm")
+ (delete-file* "bench.log")
+ (system* "~A -version" chicken)
+ (dflush "\nCC:\n")
+ (if (eq? (build-platform) 'sun)
+ (system (conc cc " -V"))
+ (system* "~A -v" cc) )
+ (dflush "\nCFLAGS:\n")
+ (system* "echo `~a -cflags`" csc)
+ (display "\nRunning benchmarks ...\n\n (averaging over 5 runs, dropping highest and lowest, binaries are statically linked and stripped,\n")
+ (display " compiler log will be written to \"bench.log\")\n")
+ (display "\n (runtime) (code size)\n")
+ (display "\n base fast unsafe max base fast unsafe max")
+ (display "\n ----------------------------------------------------------------------------------\n")
+ (let ((sum-base 0.0)
+ (sum-fast 0.0)
+ (sum-unsafe 0.0)
+ (sum-max 0.0)
+ (size-base 0)
+ (size-fast 0)
+ (size-unsafe 0)
+ (size-max 0))
+ (for-each
+ (lambda (file)
+ (let* ([name (pathname-file file)]
+ [options (string-intersperse options " ")]
+ (t 0))
+ (display-l name 16 #\space)
+ (flush-output)
+ (set!-values
+ (t size-base)
+ (compile-and-run ; base
+ file
+ "-debug-level 0 -optimize-level 1"
+ options "" #f))
+ (set! sum-base (+ sum-base t))
+ (dflush " ")
+ (set!-values
+ (t size-fast)
+ (compile-and-run ; fast but safe
+ file
+ "-debug-level 0 -optimize-level 3 -lambda-lift"
+ options "" #f))
+ (set! sum-fast (+ sum-fast t))
+ (dflush " ")
+ (set!-values
+ (t size-unsafe)
+ (compile-and-run ; fast and unsafe
+ file
+ "-debug-level 0 -optimize-level 4 -block -disable-interrupts -lambda-lift"
+ options "" #t))
+ (set! sum-unsafe (+ sum-unsafe t))
+ (dflush " ")
+ (cond ((member name flonum-files)
+ (display " "))
+ (else
+ (set!-values
+ (t size-max)
+ (compile-and-run file "-benchmark-mode" options "" #t) ) ; maximal speed
+ (set! sum-max (+ sum-max t))))
+ (display-size size-base)
+ (display-size size-fast)
+ (display-size size-unsafe)
+ (display-size size-max)
+ (newline)
+ (flush-output)))
+ (lset-difference string=? (sort (glob "*.scm") string<?) ignored-files))
+ (display "\nTOTAL ")
+ (display-f-4.3 sum-base)
+ (display " ")
+ (display-f-4.3 sum-fast)
+ (display " ")
+ (display-f-4.3 sum-unsafe)
+ (display " ")
+ (display-f-4.3 sum-max)
+ (newline)
+ 0))
+
+(main (command-line-arguments))
diff --git a/benchmarks/ctak.scm b/benchmarks/ctak.scm
new file mode 100644
index 00000000..c2fc46b0
--- /dev/null
+++ b/benchmarks/ctak.scm
@@ -0,0 +1,35 @@
+;;; ctak.scm
+
+(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
+ (lambda (k) ; (was missing)
+ (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)))))))) )
+
+
+(time (do ((i 10 (- i 1))) ((zero? i)) (ctak 18 12 6)))
diff --git a/benchmarks/dderiv.scm b/benchmarks/dderiv.scm
new file mode 100644
index 00000000..911082bc
--- /dev/null
+++ b/benchmarks/dderiv.scm
@@ -0,0 +1,76 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; File: dderiv.sc
+;;; 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)
+;;; 21-Mar-94 (Qobi)
+;;; 31-Mar-98 (Qobi)
+;;; 26-Mar-00 (flw)
+;;; 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 Vaughan 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 (+ . <rest>), the code
+;;; stored under the atom '+ with indicator DERIV will take <rest> 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.
+
+
+(define (dderiv-aux a) (list '/ (dderiv a) a))
+
+(define (+dderiv a) (cons '+ (map dderiv a)))
+
+(put! '+ 'dderiv +dderiv) ; install procedure on the property list
+
+(define (-dderiv a) (cons '- (map dderiv a)))
+
+(put! '- 'dderiv -dderiv) ; install procedure on the property list
+
+(define (*dderiv a) (list '* (cons '* a) (cons '+ (map dderiv-aux a))))
+
+(put! '* 'dderiv *dderiv) ; install procedure on the property list
+
+(define (/dderiv a)
+ (list '-
+ (list '/ (dderiv (car a)) (cadr a))
+ (list '/
+ (car a)
+ (list '* (cadr a) (cadr a) (dderiv (cadr a))))))
+
+(put! '/ 'dderiv /dderiv) ; install procedure on the property list
+
+(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 1000))
+ (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))))
+
+
+(time (do ((i 10 (- i 1))) ((zero? i)) (run)))
diff --git a/benchmarks/deriv.scm b/benchmarks/deriv.scm
new file mode 100644
index 00000000..10f848cc
--- /dev/null
+++ b/benchmarks/deriv.scm
@@ -0,0 +1,42 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; File: deriv.sc
+;;; 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)
+;;; 21-Mar-94 (Qobi)
+;;; 31-Mar-98 (Qobi)
+;;; 26-Mar-00 (felix)
+;;; Language: Scheme
+;;; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; DERIV -- Symbolic derivative benchmark written by Vaughan Pratt.
+;;; It uses a simple subset of Lisp and does a lot of CONSing.
+
+(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 1000))
+ (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))))
+
+(time (do ((i 10 (- i 1))) ((zero? i)) (run)))
diff --git a/benchmarks/destructive.scm b/benchmarks/destructive.scm
new file mode 100644
index 00000000..4b54e62a
--- /dev/null
+++ b/benchmarks/destructive.scm
@@ -0,0 +1,47 @@
+;;; destructive.scm
+
+
+(define (append! lst1 lst2)
+ (let loop ((lst1 lst1))
+ (cond ((null? lst1) lst2)
+ ((null? (cdr lst1)) (set-cdr! lst1 lst2))
+ (else (loop (cdr lst1))) ) )
+ lst1)
+
+(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 '() '())))
+ (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))))))))))))
+
+(time (destructive 6000 50))
diff --git a/benchmarks/div-iter.scm b/benchmarks/div-iter.scm
new file mode 100644
index 00000000..1639344b
--- /dev/null
+++ b/benchmarks/div-iter.scm
@@ -0,0 +1,24 @@
+;;; div-iter.scm
+
+
+(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 (test l)
+ (do ((i 3000 (- i 1)))
+ ((= i 0))
+ (iterative-div2 l)
+ (iterative-div2 l)
+ (iterative-div2 l)
+ (iterative-div2 l)))
+
+(time (test *ll*))
diff --git a/benchmarks/div-rec.scm b/benchmarks/div-rec.scm
new file mode 100644
index 00000000..d100f405
--- /dev/null
+++ b/benchmarks/div-rec.scm
@@ -0,0 +1,23 @@
+;;; div-rec.scm
+
+
+(define (create-n n)
+ (do ((n n (- n 1))
+ (a '() (cons '() a)))
+ ((= n 0) a)))
+
+(define *ll* (create-n 200))
+
+(define (recursive-div2 l)
+ (cond ((null? l) '())
+ (else (cons (car l) (recursive-div2 (cddr l))))))
+
+(define (test l)
+ (do ((i 3000 (- i 1)))
+ ((= i 0))
+ (recursive-div2 l)
+ (recursive-div2 l)
+ (recursive-div2 l)
+ (recursive-div2 l)))
+
+(time (test *ll*))
diff --git a/benchmarks/dynamic.scm b/benchmarks/dynamic.scm
new file mode 100644
index 00000000..bfe1d140
--- /dev/null
+++ b/benchmarks/dynamic.scm
@@ -0,0 +1,2320 @@
+;;; DYNAMIC -- Obtained from Andrew Wright.
+;
+; 08/06/01 (felix): renamed "null" to "null2" because stupid MZC can't
+; handle redefinitions of primitives.
+;
+;
+;; Fritz's dynamic type inferencer, set up to run on itself
+;; (see the end of this file).
+
+;----------------------------------------------------------------------------
+; Environment management
+;----------------------------------------------------------------------------
+
+;; environments are lists of pairs, the first component being the key
+
+;; general environment operations
+;;
+;; empty-env: Env
+;; gen-binding: Key x Value -> Binding
+;; binding-key: Binding -> Key
+;; binding-value: Binding -> Value
+;; binding-show: Binding -> Symbol*
+;; extend-env-with-binding: Env x Binding -> Env
+;; extend-env-with-env: Env x Env -> Env
+;; lookup: Key x Env -> (Binding + False)
+;; env->list: Env -> Binding*
+;; env-show: Env -> Symbol*
+
+
+; bindings
+
+(define gen-binding cons)
+; generates a type binding, binding a symbol to a type variable
+
+(define binding-key car)
+; returns the key of a type binding
+
+(define binding-value cdr)
+; returns the tvariable of a type binding
+
+(define (key-show key)
+ ; default show procedure for keys
+ key)
+
+(define (value-show value)
+ ; default show procedure for values
+ value)
+
+(define (binding-show binding)
+ ; returns a printable representation of a type binding
+ (cons (key-show (binding-key binding))
+ (cons ': (value-show (binding-value binding)))))
+
+
+; environments
+
+(define dynamic-empty-env '())
+; returns the empty environment
+
+(define (extend-env-with-binding env binding)
+ ; extends env with a binding, which hides any other binding in env
+ ; for the same key (see dynamic-lookup)
+ ; returns the extended environment
+ (cons binding env))
+
+(define (extend-env-with-env env ext-env)
+ ; extends environment env with environment ext-env
+ ; a binding for a key in ext-env hides any binding in env for
+ ; the same key (see dynamic-lookup)
+ ; returns the extended environment
+ (append ext-env env))
+
+(define dynamic-lookup (lambda (x l) (assv x l)))
+; returns the first pair in env that matches the key; returns #f
+; if no such pair exists
+
+(define (env->list e)
+ ; converts an environment to a list of bindings
+ e)
+
+(define (env-show env)
+ ; returns a printable list representation of a type environment
+ (map binding-show env))
+;----------------------------------------------------------------------------
+; Parsing for Scheme
+;----------------------------------------------------------------------------
+
+
+;; Needed packages: environment management
+
+;(load "env-mgmt.ss")
+;(load "pars-act.ss")
+
+;; Lexical notions
+
+(define syntactic-keywords
+ ;; source: IEEE Scheme, 7.1, <expression keyword>, <syntactic keyword>
+ '(lambda if set! begin cond and or case let let* letrec do
+ quasiquote else => define unquote unquote-splicing))
+
+
+;; Parse routines
+
+; Datum
+
+; dynamic-parse-datum: parses nonterminal <datum>
+
+(define (dynamic-parse-datum e)
+ ;; Source: IEEE Scheme, sect. 7.2, <datum>
+ ;; Note: "'" is parsed as 'quote, "`" as 'quasiquote, "," as
+ ;; 'unquote, ",@" as 'unquote-splicing (see sect. 4.2.5, p. 18)
+ ;; ***Note***: quasi-quotations are not permitted! (It would be
+ ;; necessary to pass the environment to dynamic-parse-datum.)
+ (cond
+ ((null? e)
+ (dynamic-parse-action-null-const))
+ ((boolean? e)
+ (dynamic-parse-action-boolean-const e))
+ ((char? e)
+ (dynamic-parse-action-char-const e))
+ ((number? e)
+ (dynamic-parse-action-number-const e))
+ ((string? e)
+ (dynamic-parse-action-string-const e))
+ ((symbol? e)
+ (dynamic-parse-action-symbol-const e))
+ ((vector? e)
+ (dynamic-parse-action-vector-const (map dynamic-parse-datum (vector->list e))))
+ ((pair? e)
+ (dynamic-parse-action-pair-const (dynamic-parse-datum (car e))
+ (dynamic-parse-datum (cdr e))))
+ (else (error 'dynamic-parse-datum "Unknown datum: ~s" e))))
+
+
+; VarDef
+
+; dynamic-parse-formal: parses nonterminal <variable> in defining occurrence position
+
+(define (dynamic-parse-formal f-env e)
+ ; e is an arbitrary object, f-env is a forbidden environment;
+ ; returns: a variable definition (a binding for the symbol), plus
+ ; the value of the binding as a result
+ (if (symbol? e)
+ (cond
+ ((memq e syntactic-keywords)
+ (error 'dynamic-parse-formal "Illegal identifier (keyword): ~s" e))
+ ((dynamic-lookup e f-env)
+ (error 'dynamic-parse-formal "Duplicate variable definition: ~s" e))
+ (else (let ((dynamic-parse-action-result (dynamic-parse-action-var-def e)))
+ (cons (gen-binding e dynamic-parse-action-result)
+ dynamic-parse-action-result))))
+ (error 'dynamic-parse-formal "Not an identifier: ~s" e)))
+
+; dynamic-parse-formal*
+
+(define (dynamic-parse-formal* formals)
+ ;; parses a list of formals and returns a pair consisting of generated
+ ;; environment and list of parsing action results
+ (letrec
+ ((pf*
+ (lambda (f-env results formals)
+ ;; f-env: "forbidden" environment (to avoid duplicate defs)
+ ;; results: the results of the parsing actions
+ ;; formals: the unprocessed formals
+ ;; Note: generates the results of formals in reverse order!
+ (cond
+ ((null? formals)
+ (cons f-env results))
+ ((pair? formals)
+ (let* ((fst-formal (car formals))
+ (binding-result (dynamic-parse-formal f-env fst-formal))
+ (binding (car binding-result))
+ (var-result (cdr binding-result)))
+ (pf*
+ (extend-env-with-binding f-env binding)
+ (cons var-result results)
+ (cdr formals))))
+ (else (error 'dynamic-parse-formal* "Illegal formals: ~s" formals))))))
+ (let ((renv-rres (pf* dynamic-empty-env '() formals)))
+ (cons (car renv-rres) (reverse (cdr renv-rres))))))
+
+
+; dynamic-parse-formals: parses <formals>
+
+(define (dynamic-parse-formals formals)
+ ;; parses <formals>; see IEEE Scheme, sect. 7.3
+ ;; returns a pair: env and result
+ (letrec ((pfs (lambda (f-env formals)
+ (cond
+ ((null? formals)
+ (cons dynamic-empty-env (dynamic-parse-action-null-formal)))
+ ((pair? formals)
+ (let* ((fst-formal (car formals))
+ (rem-formals (cdr formals))
+ (bind-res (dynamic-parse-formal f-env fst-formal))
+ (bind (car bind-res))
+ (res (cdr bind-res))
+ (nf-env (extend-env-with-binding f-env bind))
+ (renv-res* (pfs nf-env rem-formals))
+ (renv (car renv-res*))
+ (res* (cdr renv-res*)))
+ (cons
+ (extend-env-with-binding renv bind)
+ (dynamic-parse-action-pair-formal res res*))))
+ (else
+ (let* ((bind-res (dynamic-parse-formal f-env formals))
+ (bind (car bind-res))
+ (res (cdr bind-res)))
+ (cons
+ (extend-env-with-binding dynamic-empty-env bind)
+ res)))))))
+ (pfs dynamic-empty-env formals)))
+
+
+; Expr
+
+; dynamic-parse-expression: parses nonterminal <expression>
+
+(define (dynamic-parse-expression env e)
+ (cond
+ ((symbol? e)
+ (dynamic-parse-variable env e))
+ ((pair? e)
+ (let ((op (car e)) (args (cdr e)))
+ (case op
+ ((quote) (dynamic-parse-quote env args))
+ ((lambda) (dynamic-parse-lambda env args))
+ ((if) (dynamic-parse-if env args))
+ ((set!) (dynamic-parse-set env args))
+ ((begin) (dynamic-parse-begin env args))
+ ((cond) (dynamic-parse-cond env args))
+ ((case) (dynamic-parse-case env args))
+ ((and) (dynamic-parse-and env args))
+ ((or) (dynamic-parse-or env args))
+ ((let) (dynamic-parse-let env args))
+ ((let*) (dynamic-parse-let* env args))
+ ((letrec) (dynamic-parse-letrec env args))
+ ((do) (dynamic-parse-do env args))
+ ((quasiquote) (dynamic-parse-quasiquote env args))
+ (else (dynamic-parse-procedure-call env op args)))))
+ (else (dynamic-parse-datum e))))
+
+; dynamic-parse-expression*
+
+(define (dynamic-parse-expression* env exprs)
+ ;; Parses lists of expressions (returns them in the right order!)
+ (letrec ((pe*
+ (lambda (results es)
+ (cond
+ ((null? es) results)
+ ((pair? es) (pe* (cons (dynamic-parse-expression env (car es)) results) (cdr es)))
+ (else (error 'dynamic-parse-expression* "Not a list of expressions: ~s" es))))))
+ (reverse (pe* '() exprs))))
+
+
+; dynamic-parse-expressions
+
+(define (dynamic-parse-expressions env exprs)
+ ;; parses lists of arguments of a procedure call
+ (cond
+ ((null? exprs) (dynamic-parse-action-null-arg))
+ ((pair? exprs) (let* ((fst-expr (car exprs))
+ (rem-exprs (cdr exprs))
+ (fst-res (dynamic-parse-expression env fst-expr))
+ (rem-res (dynamic-parse-expressions env rem-exprs)))
+ (dynamic-parse-action-pair-arg fst-res rem-res)))
+ (else (error 'dynamic-parse-expressions "Illegal expression list: ~s"
+ exprs))))
+
+
+; dynamic-parse-variable: parses variables (applied occurrences)
+
+(define (dynamic-parse-variable env e)
+ (if (symbol? e)
+ (if (memq e syntactic-keywords)
+ (error 'dynamic-parse-variable "Illegal identifier (keyword): ~s" e)
+ (let ((assoc-var-def (dynamic-lookup e env)))
+ (if assoc-var-def
+ (dynamic-parse-action-variable (binding-value assoc-var-def))
+ (dynamic-parse-action-identifier e))))
+ (error 'dynamic-parse-variable "Not an identifier: ~s" e)))
+
+
+; dynamic-parse-procedure-call
+
+(define (dynamic-parse-procedure-call env op args)
+ (dynamic-parse-action-procedure-call
+ (dynamic-parse-expression env op)
+ (dynamic-parse-expressions env args)))
+
+
+; dynamic-parse-quote
+
+(define (dynamic-parse-quote env args)
+ (if (list-of-1? args)
+ (dynamic-parse-datum (car args))
+ (error 'dynamic-parse-quote "Not a datum (multiple arguments): ~s" args)))
+
+
+; dynamic-parse-lambda
+
+(define (dynamic-parse-lambda env args)
+ (if (pair? args)
+ (let* ((formals (car args))
+ (body (cdr args))
+ (nenv-fresults (dynamic-parse-formals formals))
+ (nenv (car nenv-fresults))
+ (fresults (cdr nenv-fresults)))
+ (dynamic-parse-action-lambda-expression
+ fresults
+ (dynamic-parse-body (extend-env-with-env env nenv) body)))
+ (error 'dynamic-parse-lambda "Illegal formals/body: ~s" args)))
+
+
+; dynamic-parse-body
+
+(define (dynamic-parse-body env body)
+ ; <body> = <definition>* <expression>+
+ (define (def-var* f-env body)
+ ; finds the defined variables in a body and returns an
+ ; environment containing them
+ (if (pair? body)
+ (let ((n-env (def-var f-env (car body))))
+ (if n-env
+ (def-var* n-env (cdr body))
+ f-env))
+ f-env))
+ (define (def-var f-env clause)
+ ; finds the defined variables in a single clause and extends
+ ; f-env accordingly; returns false if it's not a definition
+ (if (pair? clause)
+ (case (car clause)
+ ((define) (if (pair? (cdr clause))
+ (let ((pattern (cadr clause)))
+ (cond
+ ((symbol? pattern)
+ (extend-env-with-binding
+ f-env
+ (gen-binding pattern
+ (dynamic-parse-action-var-def pattern))))
+ ((and (pair? pattern) (symbol? (car pattern)))
+ (extend-env-with-binding
+ f-env
+ (gen-binding (car pattern)
+ (dynamic-parse-action-var-def
+ (car pattern)))))
+ (else f-env)))
+ f-env))
+ ((begin) (def-var* f-env (cdr clause)))
+ (else #f))
+ #f))
+ (if (pair? body)
+ (dynamic-parse-command* (def-var* env body) body)
+ (error 'dynamic-parse-body "Illegal body: ~s" body)))
+
+; dynamic-parse-if
+
+(define (dynamic-parse-if env args)
+ (cond
+ ((list-of-3? args)
+ (dynamic-parse-action-conditional
+ (dynamic-parse-expression env (car args))
+ (dynamic-parse-expression env (cadr args))
+ (dynamic-parse-expression env (caddr args))))
+ ((list-of-2? args)
+ (dynamic-parse-action-conditional
+ (dynamic-parse-expression env (car args))
+ (dynamic-parse-expression env (cadr args))
+ (dynamic-parse-action-empty)))
+ (else (error 'dynamic-parse-if "Not an if-expression: ~s" args))))
+
+
+; dynamic-parse-set
+
+(define (dynamic-parse-set env args)
+ (if (list-of-2? args)
+ (dynamic-parse-action-assignment
+ (dynamic-parse-variable env (car args))
+ (dynamic-parse-expression env (cadr args)))
+ (error 'dynamic-parse-set "Not a variable/expression pair: ~s" args)))
+
+
+; dynamic-parse-begin
+
+(define (dynamic-parse-begin env args)
+ (dynamic-parse-action-begin-expression
+ (dynamic-parse-body env args)))
+
+
+; dynamic-parse-cond
+
+(define (dynamic-parse-cond env args)
+ (if (and (pair? args) (list? args))
+ (dynamic-parse-action-cond-expression
+ (map (lambda (e)
+ (dynamic-parse-cond-clause env e))
+ args))
+ (error 'dynamic-parse-cond "Not a list of cond-clauses: ~s" args)))
+
+; dynamic-parse-cond-clause
+
+(define (dynamic-parse-cond-clause env e)
+ ;; ***Note***: Only (<test> <sequence>) is permitted!
+ (if (pair? e)
+ (cons
+ (if (eqv? (car e) 'else)
+ (dynamic-parse-action-empty)
+ (dynamic-parse-expression env (car e)))
+ (dynamic-parse-body env (cdr e)))
+ (error 'dynamic-parse-cond-clause "Not a cond-clause: ~s" e)))
+
+
+; dynamic-parse-and
+
+(define (dynamic-parse-and env args)
+ (if (list? args)
+ (dynamic-parse-action-and-expression
+ (dynamic-parse-expression* env args))
+ (error 'dynamic-parse-and "Not a list of arguments: ~s" args)))
+
+
+; dynamic-parse-or
+
+(define (dynamic-parse-or env args)
+ (if (list? args)
+ (dynamic-parse-action-or-expression
+ (dynamic-parse-expression* env args))
+ (error 'dynamic-parse-or "Not a list of arguments: ~s" args)))
+
+
+; dynamic-parse-case
+
+(define (dynamic-parse-case env args)
+ (if (and (list? args) (> (length args) 1))
+ (dynamic-parse-action-case-expression
+ (dynamic-parse-expression env (car args))
+ (map (lambda (e)
+ (dynamic-parse-case-clause env e))
+ (cdr args)))
+ (error 'dynamic-parse-case "Not a list of clauses: ~s" args)))
+
+; dynamic-parse-case-clause
+
+(define (dynamic-parse-case-clause env e)
+ (if (pair? e)
+ (cons
+ (cond
+ ((eqv? (car e) 'else)
+ (list (dynamic-parse-action-empty)))
+ ((list? (car e))
+ (map dynamic-parse-datum (car e)))
+ (else (error 'dynamic-parse-case-clause "Not a datum list: ~s" (car e))))
+ (dynamic-parse-body env (cdr e)))
+ (error 'dynamic-parse-case-clause "Not case clause: ~s" e)))
+
+
+; dynamic-parse-let
+
+(define (dynamic-parse-let env args)
+ (if (pair? args)
+ (if (symbol? (car args))
+ (dynamic-parse-named-let env args)
+ (dynamic-parse-normal-let env args))
+ (error 'dynamic-parse-let "Illegal bindings/body: ~s" args)))
+
+
+; dynamic-parse-normal-let
+
+(define (dynamic-parse-normal-let env args)
+ ;; parses "normal" let-expressions
+ (let* ((bindings (car args))
+ (body (cdr args))
+ (env-ast (dynamic-parse-parallel-bindings env bindings))
+ (nenv (car env-ast))
+ (bresults (cdr env-ast)))
+ (dynamic-parse-action-let-expression
+ bresults
+ (dynamic-parse-body (extend-env-with-env env nenv) body))))
+
+; dynamic-parse-named-let
+
+(define (dynamic-parse-named-let env args)
+ ;; parses a named let-expression
+ (if (pair? (cdr args))
+ (let* ((variable (car args))
+ (bindings (cadr args))
+ (body (cddr args))
+ (vbind-vres (dynamic-parse-formal dynamic-empty-env variable))
+ (vbind (car vbind-vres))
+ (vres (cdr vbind-vres))
+ (env-ast (dynamic-parse-parallel-bindings env bindings))
+ (nenv (car env-ast))
+ (bresults (cdr env-ast)))
+ (dynamic-parse-action-named-let-expression
+ vres bresults
+ (dynamic-parse-body (extend-env-with-env
+ (extend-env-with-binding env vbind)
+ nenv) body)))
+ (error 'dynamic-parse-named-let "Illegal named let-expression: ~s" args)))
+
+
+; dynamic-parse-parallel-bindings
+
+(define (dynamic-parse-parallel-bindings env bindings)
+ ; returns a pair consisting of an environment
+ ; and a list of pairs (variable . asg)
+ ; ***Note***: the list of pairs is returned in reverse unzipped form!
+ (if (list-of-list-of-2s? bindings)
+ (let* ((env-formals-asg
+ (dynamic-parse-formal* (map car bindings)))
+ (nenv (car env-formals-asg))
+ (bresults (cdr env-formals-asg))
+ (exprs-asg
+ (dynamic-parse-expression* env (map cadr bindings))))
+ (cons nenv (cons bresults exprs-asg)))
+ (error 'dynamic-parse-parallel-bindings
+ "Not a list of bindings: ~s" bindings)))
+
+
+; dynamic-parse-let*
+
+(define (dynamic-parse-let* env args)
+ (if (pair? args)
+ (let* ((bindings (car args))
+ (body (cdr args))
+ (env-ast (dynamic-parse-sequential-bindings env bindings))
+ (nenv (car env-ast))
+ (bresults (cdr env-ast)))
+ (dynamic-parse-action-let*-expression
+ bresults
+ (dynamic-parse-body (extend-env-with-env env nenv) body)))
+ (error 'dynamic-parse-let* "Illegal bindings/body: ~s" args)))
+
+; dynamic-parse-sequential-bindings
+
+(define (dynamic-parse-sequential-bindings env bindings)
+ ; returns a pair consisting of an environment
+ ; and a list of pairs (variable . asg)
+ ;; ***Note***: the list of pairs is returned in reverse unzipped form!
+ (letrec
+ ((psb
+ (lambda (f-env c-env var-defs expr-asgs binds)
+ ;; f-env: forbidden environment
+ ;; c-env: constructed environment
+ ;; var-defs: results of formals
+ ;; expr-asgs: results of corresponding expressions
+ ;; binds: reminding bindings to process
+ (cond
+ ((null? binds)
+ (cons f-env (cons var-defs expr-asgs)))
+ ((pair? binds)
+ (let ((fst-bind (car binds)))
+ (if (list-of-2? fst-bind)
+ (let* ((fbinding-bres
+ (dynamic-parse-formal f-env (car fst-bind)))
+ (fbind (car fbinding-bres))
+ (bres (cdr fbinding-bres))
+ (new-expr-asg
+ (dynamic-parse-expression c-env (cadr fst-bind))))
+ (psb
+ (extend-env-with-binding f-env fbind)
+ (extend-env-with-binding c-env fbind)
+ (cons bres var-defs)
+ (cons new-expr-asg expr-asgs)
+ (cdr binds)))
+ (error 'dynamic-parse-sequential-bindings
+ "Illegal binding: ~s" fst-bind))))
+ (else (error 'dynamic-parse-sequential-bindings
+ "Illegal bindings: ~s" binds))))))
+ (let ((env-vdefs-easgs (psb dynamic-empty-env env '() '() bindings)))
+ (cons (car env-vdefs-easgs)
+ (cons (reverse (cadr env-vdefs-easgs))
+ (reverse (cddr env-vdefs-easgs)))))))
+
+
+; dynamic-parse-letrec
+
+(define (dynamic-parse-letrec env args)
+ (if (pair? args)
+ (let* ((bindings (car args))
+ (body (cdr args))
+ (env-ast (dynamic-parse-recursive-bindings env bindings))
+ (nenv (car env-ast))
+ (bresults (cdr env-ast)))
+ (dynamic-parse-action-letrec-expression
+ bresults
+ (dynamic-parse-body (extend-env-with-env env nenv) body)))
+ (error 'dynamic-parse-letrec "Illegal bindings/body: ~s" args)))
+
+; dynamic-parse-recursive-bindings
+
+(define (dynamic-parse-recursive-bindings env bindings)
+ ;; ***Note***: the list of pairs is returned in reverse unzipped form!
+ (if (list-of-list-of-2s? bindings)
+ (let* ((env-formals-asg
+ (dynamic-parse-formal* (map car bindings)))
+ (formals-env
+ (car env-formals-asg))
+ (formals-res
+ (cdr env-formals-asg))
+ (exprs-asg
+ (dynamic-parse-expression*
+ (extend-env-with-env env formals-env)
+ (map cadr bindings))))
+ (cons
+ formals-env
+ (cons formals-res exprs-asg)))
+ (error 'dynamic-parse-recursive-bindings "Illegal bindings: ~s" bindings)))
+
+
+; dynamic-parse-do
+
+(define (dynamic-parse-do env args)
+ ;; parses do-expressions
+ ;; ***Note***: Not implemented!
+ (error 'dynamic-parse-do "Nothing yet..."))
+
+; dynamic-parse-quasiquote
+
+(define (dynamic-parse-quasiquote env args)
+ ;; ***Note***: Not implemented!
+ (error 'dynamic-parse-quasiquote "Nothing yet..."))
+
+
+;; Command
+
+; dynamic-parse-command
+
+(define (dynamic-parse-command env c)
+ (if (pair? c)
+ (let ((op (car c))
+ (args (cdr c)))
+ (case op
+ ((define) (dynamic-parse-define env args))
+; ((begin) (dynamic-parse-command* env args)) ;; AKW
+ ((begin) (dynamic-parse-action-begin-expression (dynamic-parse-command* env args)))
+ (else (dynamic-parse-expression env c))))
+ (dynamic-parse-expression env c)))
+
+
+; dynamic-parse-command*
+
+(define (dynamic-parse-command* env commands)
+ ;; parses a sequence of commands
+ (if (list? commands)
+ (map (lambda (command) (dynamic-parse-command env command)) commands)
+ (error 'dynamic-parse-command* "Invalid sequence of commands: ~s" commands)))
+
+
+; dynamic-parse-define
+
+(define (dynamic-parse-define env args)
+ ;; three cases -- see IEEE Scheme, sect. 5.2
+ ;; ***Note***: the parser admits forms (define (x . y) ...)
+ ;; ***Note***: Variables are treated as applied occurrences!
+ (if (pair? args)
+ (let ((pattern (car args))
+ (exp-or-body (cdr args)))
+ (cond
+ ((symbol? pattern)
+ (if (list-of-1? exp-or-body)
+ (dynamic-parse-action-definition
+ (dynamic-parse-variable env pattern)
+ (dynamic-parse-expression env (car exp-or-body)))
+ (error 'dynamic-parse-define "Not a single expression: ~s" exp-or-body)))
+ ((pair? pattern)
+ (let* ((function-name (car pattern))
+ (function-arg-names (cdr pattern))
+ (env-ast (dynamic-parse-formals function-arg-names))
+ (formals-env (car env-ast))
+ (formals-ast (cdr env-ast)))
+ (dynamic-parse-action-function-definition
+ (dynamic-parse-variable env function-name)
+ formals-ast
+ (dynamic-parse-body (extend-env-with-env env formals-env) exp-or-body))))
+ (else (error 'dynamic-parse-define "Not a valid pattern: ~s" pattern))))
+ (error 'dynamic-parse-define "Not a valid definition: ~s" args)))
+
+;; Auxiliary routines
+
+; forall?
+
+(define (forall? pred list)
+ (if (null? list)
+ #t
+ (and (pred (car list)) (forall? pred (cdr list)))))
+
+; list-of-1?
+
+(define (list-of-1? l)
+ (and (pair? l) (null? (cdr l))))
+
+; list-of-2?
+
+(define (list-of-2? l)
+ (and (pair? l) (pair? (cdr l)) (null? (cddr l))))
+
+; list-of-3?
+
+(define (list-of-3? l)
+ (and (pair? l) (pair? (cdr l)) (pair? (cddr l)) (null? (cdddr l))))
+
+; list-of-list-of-2s?
+
+(define (list-of-list-of-2s? e)
+ (cond
+ ((null? e)
+ #t)
+ ((pair? e)
+ (and (list-of-2? (car e)) (list-of-list-of-2s? (cdr e))))
+ (else #f)))
+
+
+;; File processing
+
+; dynamic-parse-from-port
+
+(define (dynamic-parse-from-port port)
+ (let ((next-input (read port)))
+ (if (eof-object? next-input)
+ '()
+ (dynamic-parse-action-commands
+ (dynamic-parse-command dynamic-empty-env next-input)
+ (dynamic-parse-from-port port)))))
+
+; dynamic-parse-file
+
+(define (dynamic-parse-file file-name)
+ (let ((input-port (open-input-file file-name)))
+ (dynamic-parse-from-port input-port)))
+;----------------------------------------------------------------------------
+; Implementation of Union/find data structure in Scheme
+;----------------------------------------------------------------------------
+
+;; for union/find the following attributes are necessary: rank, parent
+;; (see Tarjan, "Data structures and network algorithms", 1983)
+;; In the Scheme realization an element is represented as a single
+;; cons cell; its address is the element itself; the car field contains
+;; the parent, the cdr field is an address for a cons
+;; cell containing the rank (car field) and the information (cdr field)
+
+
+;; general union/find data structure
+;;
+;; gen-element: Info -> Elem
+;; find: Elem -> Elem
+;; link: Elem! x Elem! -> Elem
+;; asymm-link: Elem! x Elem! -> Elem
+;; info: Elem -> Info
+;; set-info!: Elem! x Info -> Void
+
+
+(define (gen-element info)
+ ; generates a new element: the parent field is initialized to '(),
+ ; the rank field to 0
+ (cons '() (cons 0 info)))
+
+(define info (lambda (l) (cddr l)))
+ ; returns the information stored in an element
+
+(define (set-info! elem info)
+ ; sets the info-field of elem to info
+ (set-cdr! (cdr elem) info))
+
+; (define (find! x)
+; ; finds the class representative of x and sets the parent field
+; ; directly to the class representative (a class representative has
+; ; '() as its parent) (uses path halving)
+; ;(display "Find!: ")
+; ;(display (pretty-print (info x)))
+; ;(newline)
+; (let ((px (car x)))
+; (if (null? px)
+; x
+; (let ((ppx (car px)))
+; (if (null? ppx)
+; px
+; (begin
+; (set-car! x ppx)
+; (find! ppx)))))))
+
+(define (find! elem)
+ ; finds the class representative of elem and sets the parent field
+ ; directly to the class representative (a class representative has
+ ; '() as its parent)
+ ;(display "Find!: ")
+ ;(display (pretty-print (info elem)))
+ ;(newline)
+ (let ((p-elem (car elem)))
+ (if (null? p-elem)
+ elem
+ (let ((rep-elem (find! p-elem)))
+ (set-car! elem rep-elem)
+ rep-elem))))
+
+(define (link! elem-1 elem-2)
+ ; links class elements by rank
+ ; they must be distinct class representatives
+ ; returns the class representative of the merged equivalence classes
+ ;(display "Link!: ")
+ ;(display (pretty-print (list (info elem-1) (info elem-2))))
+ ;(newline)
+ (let ((rank-1 (cadr elem-1))
+ (rank-2 (cadr elem-2)))
+ (cond
+ ((= rank-1 rank-2)
+ (set-car! (cdr elem-2) (+ rank-2 1))
+ (set-car! elem-1 elem-2)
+ elem-2)
+ ((> rank-1 rank-2)
+ (set-car! elem-2 elem-1)
+ elem-1)
+ (else
+ (set-car! elem-1 elem-2)
+ elem-2))))
+
+(define asymm-link! (lambda (l x) (set-car! l x)))
+
+;(define (asymm-link! elem-1 elem-2)
+ ; links elem-1 onto elem-2 no matter what rank;
+ ; does not update the rank of elem-2 and does not return a value
+ ; the two arguments must be distinct
+ ;(display "AsymmLink: ")
+ ;(display (pretty-print (list (info elem-1) (info elem-2))))
+ ;(newline)
+ ;(set-car! elem-1 elem-2))
+
+;----------------------------------------------------------------------------
+; Type management
+;----------------------------------------------------------------------------
+
+; introduces type variables and types for Scheme,
+
+
+;; type TVar (type variables)
+;;
+;; gen-tvar: () -> TVar
+;; gen-type: TCon x TVar* -> TVar
+;; dynamic: TVar
+;; tvar-id: TVar -> Symbol
+;; tvar-def: TVar -> Type + Null
+;; tvar-show: TVar -> Symbol*
+;;
+;; set-def!: !TVar x TCon x TVar* -> Null
+;; equiv!: !TVar x !TVar -> Null
+;;
+;;
+;; type TCon (type constructors)
+;;
+;; ...
+;;
+;; type Type (types)
+;;
+;; gen-type: TCon x TVar* -> Type
+;; type-con: Type -> TCon
+;; type-args: Type -> TVar*
+;;
+;; boolean: TVar
+;; character: TVar
+;; null: TVar
+;; pair: TVar x TVar -> TVar
+;; procedure: TVar x TVar* -> TVar
+;; charseq: TVar
+;; symbol: TVar
+;; array: TVar -> TVar
+
+
+; Needed packages: union/find
+
+;(load "union-fi.so")
+
+; TVar
+
+(define counter 0)
+; counter for generating tvar id's
+
+(define (gen-id)
+ ; generates a new id (for printing purposes)
+ (set! counter (+ counter 1))
+ counter)
+
+(define (gen-tvar)
+ ; generates a new type variable from a new symbol
+ ; uses union/find elements with two info fields
+ ; a type variable has exactly four fields:
+ ; car: TVar (the parent field; initially null)
+ ; cadr: Number (the rank field; is always nonnegative)
+ ; caddr: Symbol (the type variable identifier; used only for printing)
+ ; cdddr: Type (the leq field; initially null)
+ (gen-element (cons (gen-id) '())))
+
+(define (gen-type tcon targs)
+ ; generates a new type variable with an associated type definition
+ (gen-element (cons (gen-id) (cons tcon targs))))
+
+(define dynamic (gen-element (cons 0 '())))
+; the special type variable dynamic
+; Generic operations
+
+(define (tvar-id tvar)
+ ; returns the (printable) symbol representing the type variable
+ (car (info tvar)))
+
+(define (tvar-def tvar)
+ ; returns the type definition (if any) of the type variable
+ (cdr (info tvar)))
+
+(define (set-def! tvar tcon targs)
+ ; sets the type definition part of tvar to type
+ (set-cdr! (info tvar) (cons tcon targs))
+ '())
+
+(define (reset-def! tvar)
+ ; resets the type definition part of tvar to nil
+ (set-cdr! (info tvar) '()))
+
+(define type-con (lambda (l) (car l)))
+; returns the type constructor of a type definition
+
+(define type-args (lambda (l) (cdr l)))
+; returns the type variables of a type definition
+
+(define (tvar->string tvar)
+ ; converts a tvar's id to a string
+ (if (eqv? (tvar-id tvar) 0)
+ "Dynamic"
+ (string-append "t#" (number->string (tvar-id tvar) 10))))
+
+(define (tvar-show tv)
+ ; returns a printable list representation of type variable tv
+ (let* ((tv-rep (find! tv))
+ (tv-def (tvar-def tv-rep)))
+ (cons (tvar->string tv-rep)
+ (if (null? tv-def)
+ '()
+ (cons 'is (type-show tv-def))))))
+
+(define (type-show type)
+ ; returns a printable list representation of type definition type
+ (cond
+ ((eqv? (type-con type) ptype-con)
+ (let ((new-tvar (gen-tvar)))
+ (cons ptype-con
+ (cons (tvar-show new-tvar)
+ (tvar-show ((type-args type) new-tvar))))))
+ (else
+ (cons (type-con type)
+ (map (lambda (tv)
+ (tvar->string (find! tv)))
+ (type-args type))))))
+
+
+
+; Special type operations
+
+; type constructor literals
+
+(define boolean-con 'boolean)
+(define char-con 'char)
+(define null-con 'null)
+(define number-con 'number)
+(define pair-con 'pair)
+(define procedure-con 'procedure)
+(define string-con 'string)
+(define symbol-con 'symbol)
+(define vector-con 'vector)
+
+; type constants and type constructors
+
+(define (null2)
+ ; ***Note***: Temporarily changed to be a pair!
+ ; (gen-type null-con '())
+ (pair (gen-tvar) (gen-tvar)))
+(define (boolean)
+ (gen-type boolean-con '()))
+(define (character)
+ (gen-type char-con '()))
+(define (number)
+ (gen-type number-con '()))
+(define (charseq)
+ (gen-type string-con '()))
+(define (symbol)
+ (gen-type symbol-con '()))
+(define (pair tvar-1 tvar-2)
+ (gen-type pair-con (list tvar-1 tvar-2)))
+(define (array tvar)
+ (gen-type vector-con (list tvar)))
+(define (procedure arg-tvar res-tvar)
+ (gen-type procedure-con (list arg-tvar res-tvar)))
+
+
+; equivalencing of type variables
+
+(define (equiv! tv1 tv2)
+ (let* ((tv1-rep (find! tv1))
+ (tv2-rep (find! tv2))
+ (tv1-def (tvar-def tv1-rep))
+ (tv2-def (tvar-def tv2-rep)))
+ (cond
+ ((eqv? tv1-rep tv2-rep)
+ '())
+ ((eqv? tv2-rep dynamic)
+ (equiv-with-dynamic! tv1-rep))
+ ((eqv? tv1-rep dynamic)
+ (equiv-with-dynamic! tv2-rep))
+ ((null? tv1-def)
+ (if (null? tv2-def)
+ ; both tv1 and tv2 are distinct type variables
+ (link! tv1-rep tv2-rep)
+ ; tv1 is a type variable, tv2 is a (nondynamic) type
+ (asymm-link! tv1-rep tv2-rep)))
+ ((null? tv2-def)
+ ; tv1 is a (nondynamic) type, tv2 is a type variable
+ (asymm-link! tv2-rep tv1-rep))
+ ((eqv? (type-con tv1-def) (type-con tv2-def))
+ ; both tv1 and tv2 are (nondynamic) types with equal numbers of
+ ; arguments
+ (link! tv1-rep tv2-rep)
+ (map equiv! (type-args tv1-def) (type-args tv2-def)))
+ (else
+ ; tv1 and tv2 are types with distinct type constructors or different
+ ; numbers of arguments
+ (equiv-with-dynamic! tv1-rep)
+ (equiv-with-dynamic! tv2-rep))))
+ '())
+
+(define (equiv-with-dynamic! tv)
+ (let ((tv-rep (find! tv)))
+ (if (not (eqv? tv-rep dynamic))
+ (let ((tv-def (tvar-def tv-rep)))
+ (asymm-link! tv-rep dynamic)
+ (if (not (null? tv-def))
+ (map equiv-with-dynamic! (type-args tv-def))))))
+ '())
+;----------------------------------------------------------------------------
+; Polymorphic type management
+;----------------------------------------------------------------------------
+
+; introduces parametric polymorphic types
+
+
+;; forall: (Tvar -> Tvar) -> TVar
+;; fix: (Tvar -> Tvar) -> Tvar
+;;
+;; instantiate-type: TVar -> TVar
+
+; type constructor literal for polymorphic types
+
+(define ptype-con 'forall)
+
+(define (forall tv-func)
+ (gen-type ptype-con tv-func))
+
+(define (forall2 tv-func2)
+ (forall (lambda (tv1)
+ (forall (lambda (tv2)
+ (tv-func2 tv1 tv2))))))
+
+(define (forall3 tv-func3)
+ (forall (lambda (tv1)
+ (forall2 (lambda (tv2 tv3)
+ (tv-func3 tv1 tv2 tv3))))))
+
+(define (forall4 tv-func4)
+ (forall (lambda (tv1)
+ (forall3 (lambda (tv2 tv3 tv4)
+ (tv-func4 tv1 tv2 tv3 tv4))))))
+
+(define (forall5 tv-func5)
+ (forall (lambda (tv1)
+ (forall4 (lambda (tv2 tv3 tv4 tv5)
+ (tv-func5 tv1 tv2 tv3 tv4 tv5))))))
+
+
+; (polymorphic) instantiation
+
+(define (instantiate-type tv)
+ ; instantiates type tv and returns a generic instance
+ (let* ((tv-rep (find! tv))
+ (tv-def (tvar-def tv-rep)))
+ (cond
+ ((null? tv-def)
+ tv-rep)
+ ((eqv? (type-con tv-def) ptype-con)
+ (instantiate-type ((type-args tv-def) (gen-tvar))))
+ (else
+ tv-rep))))
+
+(define (fix tv-func)
+ ; forms a recursive type: the fixed point of type mapping tv-func
+ (let* ((new-tvar (gen-tvar))
+ (inst-tvar (tv-func new-tvar))
+ (inst-def (tvar-def inst-tvar)))
+ (if (null? inst-def)
+ (error 'fix "Illegal recursive type: ~s"
+ (list (tvar-show new-tvar) '= (tvar-show inst-tvar)))
+ (begin
+ (set-def! new-tvar
+ (type-con inst-def)
+ (type-args inst-def))
+ new-tvar))))
+
+
+;----------------------------------------------------------------------------
+; Constraint management
+;----------------------------------------------------------------------------
+
+
+; constraints
+
+(define gen-constr (lambda (a b) (cons a b)))
+; generates an equality between tvar1 and tvar2
+
+(define constr-lhs (lambda (c) (car c)))
+; returns the left-hand side of a constraint
+
+(define constr-rhs (lambda (c) (cdr c)))
+; returns the right-hand side of a constraint
+
+(define (constr-show c)
+ (cons (tvar-show (car c))
+ (cons '=
+ (cons (tvar-show (cdr c)) '()))))
+
+
+; constraint set management
+
+(define global-constraints '())
+
+(define (init-global-constraints!)
+ (set! global-constraints '()))
+
+(define (add-constr! lhs rhs)
+ (set! global-constraints
+ (cons (gen-constr lhs rhs) global-constraints))
+ '())
+
+(define (glob-constr-show)
+ ; returns printable version of global constraints
+ (map constr-show global-constraints))
+
+
+; constraint normalization
+
+; Needed packages: type management
+
+;(load "typ-mgmt.so")
+
+(define (normalize-global-constraints!)
+ (normalize! global-constraints)
+ (init-global-constraints!))
+
+(define (normalize! constraints)
+ (map (lambda (c)
+ (equiv! (constr-lhs c) (constr-rhs c))) constraints))
+; ----------------------------------------------------------------------------
+; Abstract syntax definition and parse actions
+; ----------------------------------------------------------------------------
+
+; Needed packages: ast-gen.ss
+;(load "ast-gen.ss")
+
+;; Abstract syntax
+;;
+;; VarDef
+;;
+;; Identifier = Symbol - SyntacticKeywords
+;; SyntacticKeywords = { ... } (see Section 7.1, IEEE Scheme Standard)
+;;
+;; Datum
+;;
+;; null-const: Null -> Datum
+;; boolean-const: Bool -> Datum
+;; char-const: Char -> Datum
+;; number-const: Number -> Datum
+;; string-const: String -> Datum
+;; vector-const: Datum* -> Datum
+;; pair-const: Datum x Datum -> Datum
+;;
+;; Expr
+;;
+;; Datum < Expr
+;;
+;; var-def: Identifier -> VarDef
+;; variable: VarDef -> Expr
+;; identifier: Identifier -> Expr
+;; procedure-call: Expr x Expr* -> Expr
+;; lambda-expression: Formals x Body -> Expr
+;; conditional: Expr x Expr x Expr -> Expr
+;; assignment: Variable x Expr -> Expr
+;; cond-expression: CondClause+ -> Expr
+;; case-expression: Expr x CaseClause* -> Expr
+;; and-expression: Expr* -> Expr
+;; or-expression: Expr* -> Expr
+;; let-expression: (VarDef* x Expr*) x Body -> Expr
+;; named-let-expression: VarDef x (VarDef* x Expr*) x Body -> Expr
+;; let*-expression: (VarDef* x Expr*) x Body -> Expr
+;; letrec-expression: (VarDef* x Expr*) x Body -> Expr
+;; begin-expression: Expr+ -> Expr
+;; do-expression: IterDef* x CondClause x Expr* -> Expr
+;; empty: -> Expr
+;;
+;; VarDef* < Formals
+;;
+;; simple-formal: VarDef -> Formals
+;; dotted-formals: VarDef* x VarDef -> Formals
+;;
+;; Body = Definition* x Expr+ (reversed)
+;; CondClause = Expr x Expr+
+;; CaseClause = Datum* x Expr+
+;; IterDef = VarDef x Expr x Expr
+;;
+;; Definition
+;;
+;; definition: Identifier x Expr -> Definition
+;; function-definition: Identifier x Formals x Body -> Definition
+;; begin-command: Definition* -> Definition
+;;
+;; Expr < Command
+;; Definition < Command
+;;
+;; Program = Command*
+
+
+;; Abstract syntax operators
+
+; Datum
+
+(define null-const 0)
+(define boolean-const 1)
+(define char-const 2)
+(define number-const 3)
+(define string-const 4)
+(define symbol-const 5)
+(define vector-const 6)
+(define pair-const 7)
+
+; Bindings
+
+(define var-def 8)
+(define null-def 29)
+(define pair-def 30)
+
+; Expr
+
+(define variable 9)
+(define identifier 10)
+(define procedure-call 11)
+(define lambda-expression 12)
+(define conditional 13)
+(define assignment 14)
+(define cond-expression 15)
+(define case-expression 16)
+(define and-expression 17)
+(define or-expression 18)
+(define let-expression 19)
+(define named-let-expression 20)
+(define let*-expression 21)
+(define letrec-expression 22)
+(define begin-expression 23)
+(define do-expression 24)
+(define empty 25)
+(define null-arg 31)
+(define pair-arg 32)
+
+; Command
+
+(define definition 26)
+(define function-definition 27)
+(define begin-command 28)
+
+
+;; Parse actions for abstract syntax construction
+
+(define (dynamic-parse-action-null-const)
+ ;; dynamic-parse-action for '()
+ (ast-gen null-const '()))
+
+(define (dynamic-parse-action-boolean-const e)
+ ;; dynamic-parse-action for #f and #t
+ (ast-gen boolean-const e))
+
+(define (dynamic-parse-action-char-const e)
+ ;; dynamic-parse-action for character constants
+ (ast-gen char-const e))
+
+(define (dynamic-parse-action-number-const e)
+ ;; dynamic-parse-action for number constants
+ (ast-gen number-const e))
+
+(define (dynamic-parse-action-string-const e)
+ ;; dynamic-parse-action for string literals
+ (ast-gen string-const e))
+
+(define (dynamic-parse-action-symbol-const e)
+ ;; dynamic-parse-action for symbol constants
+ (ast-gen symbol-const e))
+
+(define (dynamic-parse-action-vector-const e)
+ ;; dynamic-parse-action for vector literals
+ (ast-gen vector-const e))
+
+(define (dynamic-parse-action-pair-const e1 e2)
+ ;; dynamic-parse-action for pairs
+ (ast-gen pair-const (cons e1 e2)))
+
+(define (dynamic-parse-action-var-def e)
+ ;; dynamic-parse-action for defining occurrences of variables;
+ ;; e is a symbol
+ (ast-gen var-def e))
+
+(define (dynamic-parse-action-null-formal)
+ ;; dynamic-parse-action for null-list of formals
+ (ast-gen null-def '()))
+
+(define (dynamic-parse-action-pair-formal d1 d2)
+ ;; dynamic-parse-action for non-null list of formals;
+ ;; d1 is the result of parsing the first formal,
+ ;; d2 the result of parsing the remaining formals
+ (ast-gen pair-def (cons d1 d2)))
+
+(define (dynamic-parse-action-variable e)
+ ;; dynamic-parse-action for applied occurrences of variables
+ ;; ***Note***: e is the result of a dynamic-parse-action on the
+ ;; corresponding variable definition!
+ (ast-gen variable e))
+
+(define (dynamic-parse-action-identifier e)
+ ;; dynamic-parse-action for undeclared identifiers (free variable
+ ;; occurrences)
+ ;; ***Note***: e is a symbol (legal identifier)
+ (ast-gen identifier e))
+
+(define (dynamic-parse-action-null-arg)
+ ;; dynamic-parse-action for a null list of arguments in a procedure call
+ (ast-gen null-arg '()))
+
+(define (dynamic-parse-action-pair-arg a1 a2)
+ ;; dynamic-parse-action for a non-null list of arguments in a procedure call
+ ;; a1 is the result of parsing the first argument,
+ ;; a2 the result of parsing the remaining arguments
+ (ast-gen pair-arg (cons a1 a2)))
+
+(define (dynamic-parse-action-procedure-call op args)
+ ;; dynamic-parse-action for procedure calls: op function, args list of arguments
+ (ast-gen procedure-call (cons op args)))
+
+(define (dynamic-parse-action-lambda-expression formals body)
+ ;; dynamic-parse-action for lambda-abstractions
+ (ast-gen lambda-expression (cons formals body)))
+
+(define (dynamic-parse-action-conditional test then-branch else-branch)
+ ;; dynamic-parse-action for conditionals (if-then-else expressions)
+ (ast-gen conditional (cons test (cons then-branch else-branch))))
+
+(define (dynamic-parse-action-empty)
+ ;; dynamic-parse-action for missing or empty field
+ (ast-gen empty '()))
+
+(define (dynamic-parse-action-assignment lhs rhs)
+ ;; dynamic-parse-action for assignment
+ (ast-gen assignment (cons lhs rhs)))
+
+(define (dynamic-parse-action-begin-expression body)
+ ;; dynamic-parse-action for begin-expression
+ (ast-gen begin-expression body))
+
+(define (dynamic-parse-action-cond-expression clauses)
+ ;; dynamic-parse-action for cond-expressions
+ (ast-gen cond-expression clauses))
+
+(define (dynamic-parse-action-and-expression args)
+ ;; dynamic-parse-action for and-expressions
+ (ast-gen and-expression args))
+
+(define (dynamic-parse-action-or-expression args)
+ ;; dynamic-parse-action for or-expressions
+ (ast-gen or-expression args))
+
+(define (dynamic-parse-action-case-expression key clauses)
+ ;; dynamic-parse-action for case-expressions
+ (ast-gen case-expression (cons key clauses)))
+
+(define (dynamic-parse-action-let-expression bindings body)
+ ;; dynamic-parse-action for let-expressions
+ (ast-gen let-expression (cons bindings body)))
+
+(define (dynamic-parse-action-named-let-expression variable bindings body)
+ ;; dynamic-parse-action for named-let expressions
+ (ast-gen named-let-expression (cons variable (cons bindings body))))
+
+(define (dynamic-parse-action-let*-expression bindings body)
+ ;; dynamic-parse-action for let-expressions
+ (ast-gen let*-expression (cons bindings body)))
+
+(define (dynamic-parse-action-letrec-expression bindings body)
+ ;; dynamic-parse-action for let-expressions
+ (ast-gen letrec-expression (cons bindings body)))
+
+(define (dynamic-parse-action-definition variable expr)
+ ;; dynamic-parse-action for simple definitions
+ (ast-gen definition (cons variable expr)))
+
+(define (dynamic-parse-action-function-definition variable formals body)
+ ;; dynamic-parse-action for function definitions
+ (ast-gen function-definition (cons variable (cons formals body))))
+
+
+(define dynamic-parse-action-commands (lambda (a b) (cons a b)))
+;; dynamic-parse-action for processing a command result followed by a the
+;; result of processing the remaining commands
+
+
+;; Pretty-printing abstract syntax trees
+
+(define (ast-show ast)
+ ;; converts abstract syntax tree to list representation (Scheme program)
+ ;; ***Note***: check translation of constructors to numbers at the top of the file
+ (let ((syntax-op (ast-con ast))
+ (syntax-arg (ast-arg ast)))
+ (case syntax-op
+ ((0 1 2 3 4 8 10) syntax-arg)
+ ((29 31) '())
+ ((30 32) (cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
+ ((5) (list 'quote syntax-arg))
+ ((6) (list->vector (map ast-show syntax-arg)))
+ ((7) (list 'cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
+ ((9) (ast-arg syntax-arg))
+ ((11) (cons (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
+ ((12) (cons 'lambda (cons (ast-show (car syntax-arg))
+ (map ast-show (cdr syntax-arg)))))
+ ((13) (cons 'if (cons (ast-show (car syntax-arg))
+ (cons (ast-show (cadr syntax-arg))
+ (let ((alt (cddr syntax-arg)))
+ (if (eqv? (ast-con alt) empty)
+ '()
+ (list (ast-show alt))))))))
+ ((14) (list 'set! (ast-show (car syntax-arg)) (ast-show (cdr syntax-arg))))
+ ((15) (cons 'cond
+ (map (lambda (cc)
+ (let ((guard (car cc))
+ (body (cdr cc)))
+ (cons
+ (if (eqv? (ast-con guard) empty)
+ 'else
+ (ast-show guard))
+ (map ast-show body))))
+ syntax-arg)))
+ ((16) (cons 'case
+ (cons (ast-show (car syntax-arg))
+ (map (lambda (cc)
+ (let ((data (car cc)))
+ (if (and (pair? data)
+ (eqv? (ast-con (car data)) empty))
+ (cons 'else
+ (map ast-show (cdr cc)))
+ (cons (map datum-show data)
+ (map ast-show (cdr cc))))))
+ (cdr syntax-arg)))))
+ ((17) (cons 'and (map ast-show syntax-arg)))
+ ((18) (cons 'or (map ast-show syntax-arg)))
+ ((19) (cons 'let
+ (cons (map
+ (lambda (vd e)
+ (list (ast-show vd) (ast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map ast-show (cdr syntax-arg)))))
+ ((20) (cons 'let
+ (cons (ast-show (car syntax-arg))
+ (cons (map
+ (lambda (vd e)
+ (list (ast-show vd) (ast-show e)))
+ (caadr syntax-arg)
+ (cdadr syntax-arg))
+ (map ast-show (cddr syntax-arg))))))
+ ((21) (cons 'let*
+ (cons (map
+ (lambda (vd e)
+ (list (ast-show vd) (ast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map ast-show (cdr syntax-arg)))))
+ ((22) (cons 'letrec
+ (cons (map
+ (lambda (vd e)
+ (list (ast-show vd) (ast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map ast-show (cdr syntax-arg)))))
+ ((23) (cons 'begin
+ (map ast-show syntax-arg)))
+ ((24) (error 'ast-show "Do expressions not handled! (~s)" syntax-arg))
+ ((25) (error 'ast-show "This can't happen: empty encountered!"))
+ ((26) (list 'define
+ (ast-show (car syntax-arg))
+ (ast-show (cdr syntax-arg))))
+ ((27) (cons 'define
+ (cons
+ (cons (ast-show (car syntax-arg))
+ (ast-show (cadr syntax-arg)))
+ (map ast-show (cddr syntax-arg)))))
+ ((28) (cons 'begin
+ (map ast-show syntax-arg)))
+ (else (error 'ast-show "Unknown abstract syntax operator: ~s"
+ syntax-op)))))
+
+
+;; ast*-show
+
+(define (ast*-show p)
+ ;; shows a list of abstract syntax trees
+ (map ast-show p))
+
+
+;; datum-show
+
+(define (datum-show ast)
+ ;; prints an abstract syntax tree as a datum
+ (case (ast-con ast)
+ ((0 1 2 3 4 5) (ast-arg ast))
+ ((6) (list->vector (map datum-show (ast-arg ast))))
+ ((7) (cons (datum-show (car (ast-arg ast))) (datum-show (cdr (ast-arg ast)))))
+ (else (error 'datum-show "This should not happen!"))))
+
+; write-to-port
+
+(define (write-to-port prog port)
+ ; writes a program to a port
+ (for-each
+ (lambda (command)
+ (pretty-print command port)
+ (newline port))
+ prog)
+ '())
+
+; write-file
+
+(define (write-to-file prog filename)
+ ; write a program to a file
+ (let ((port (open-output-file filename)))
+ (write-to-port prog port)
+ (close-output-port port)
+ '()))
+
+; ----------------------------------------------------------------------------
+; Typed abstract syntax tree management: constraint generation, display, etc.
+; ----------------------------------------------------------------------------
+
+
+;; Abstract syntax operations, incl. constraint generation
+
+(define (ast-gen syntax-op arg)
+ ; generates all attributes and performs semantic side effects
+ (let ((ntvar
+ (case syntax-op
+ ((0 29 31) (null2))
+ ((1) (boolean))
+ ((2) (character))
+ ((3) (number))
+ ((4) (charseq))
+ ((5) (symbol))
+ ((6) (let ((aux-tvar (gen-tvar)))
+ (for-each (lambda (t)
+ (add-constr! t aux-tvar))
+ (map ast-tvar arg))
+ (array aux-tvar)))
+ ((7 30 32) (let ((t1 (ast-tvar (car arg)))
+ (t2 (ast-tvar (cdr arg))))
+ (pair t1 t2)))
+ ((8) (gen-tvar))
+ ((9) (ast-tvar arg))
+ ((10) (let ((in-env (dynamic-lookup arg dynamic-top-level-env)))
+ (if in-env
+ (instantiate-type (binding-value in-env))
+ (let ((new-tvar (gen-tvar)))
+ (set! dynamic-top-level-env (extend-env-with-binding
+ dynamic-top-level-env
+ (gen-binding arg new-tvar)))
+ new-tvar))))
+ ((11) (let ((new-tvar (gen-tvar)))
+ (add-constr! (procedure (ast-tvar (cdr arg)) new-tvar)
+ (ast-tvar (car arg)))
+ new-tvar))
+ ((12) (procedure (ast-tvar (car arg))
+ (ast-tvar (tail (cdr arg)))))
+ ((13) (let ((t-test (ast-tvar (car arg)))
+ (t-consequent (ast-tvar (cadr arg)))
+ (t-alternate (ast-tvar (cddr arg))))
+ (add-constr! (boolean) t-test)
+ (add-constr! t-consequent t-alternate)
+ t-consequent))
+ ((14) (let ((var-tvar (ast-tvar (car arg)))
+ (exp-tvar (ast-tvar (cdr arg))))
+ (add-constr! var-tvar exp-tvar)
+ var-tvar))
+ ((15) (let ((new-tvar (gen-tvar)))
+ (for-each (lambda (body)
+ (add-constr! (ast-tvar (tail body)) new-tvar))
+ (map cdr arg))
+ (for-each (lambda (e)
+ (add-constr! (boolean) (ast-tvar e)))
+ (map car arg))
+ new-tvar))
+ ((16) (let* ((new-tvar (gen-tvar))
+ (t-key (ast-tvar (car arg)))
+ (case-clauses (cdr arg)))
+ (for-each (lambda (exprs)
+ (for-each (lambda (e)
+ (add-constr! (ast-tvar e) t-key))
+ exprs))
+ (map car case-clauses))
+ (for-each (lambda (body)
+ (add-constr! (ast-tvar (tail body)) new-tvar))
+ (map cdr case-clauses))
+ new-tvar))
+ ((17 18) (for-each (lambda (e)
+ (add-constr! (boolean) (ast-tvar e)))
+ arg)
+ (boolean))
+ ((19 21 22) (let ((var-def-tvars (map ast-tvar (caar arg)))
+ (def-expr-types (map ast-tvar (cdar arg)))
+ (body-type (ast-tvar (tail (cdr arg)))))
+ (for-each add-constr! var-def-tvars def-expr-types)
+ body-type))
+ ((20) (let ((var-def-tvars (map ast-tvar (caadr arg)))
+ (def-expr-types (map ast-tvar (cdadr arg)))
+ (body-type (ast-tvar (tail (cddr arg))))
+ (named-var-type (ast-tvar (car arg))))
+ (for-each add-constr! var-def-tvars def-expr-types)
+ (add-constr! (procedure (convert-tvars var-def-tvars) body-type)
+ named-var-type)
+ body-type))
+ ((23) (ast-tvar (tail arg)))
+ ((24) (error 'ast-gen
+ "Do-expressions not handled! (Argument: ~s) arg"))
+ ((25) (gen-tvar))
+ ((26) (let ((t-var (ast-tvar (car arg)))
+ (t-exp (ast-tvar (cdr arg))))
+ (add-constr! t-var t-exp)
+ t-var))
+ ((27) (let ((t-var (ast-tvar (car arg)))
+ (t-formals (ast-tvar (cadr arg)))
+ (t-body (ast-tvar (tail (cddr arg)))))
+ (add-constr! (procedure t-formals t-body) t-var)
+ t-var))
+ ((28) (gen-tvar))
+ (else (error 'ast-gen "Can't handle syntax operator: ~s" syntax-op)))))
+ (cons syntax-op (cons ntvar arg))))
+
+(define ast-con car)
+;; extracts the ast-constructor from an abstract syntax tree
+
+(define ast-arg cddr)
+;; extracts the ast-argument from an abstract syntax tree
+
+(define ast-tvar cadr)
+;; extracts the tvar from an abstract syntax tree
+
+
+;; tail
+
+(define (tail l)
+ ;; returns the tail of a nonempty list
+ (if (null? (cdr l))
+ (car l)
+ (tail (cdr l))))
+
+; convert-tvars
+
+(define (convert-tvars tvar-list)
+ ;; converts a list of tvars to a single tvar
+ (cond
+ ((null? tvar-list) (null2))
+ ((pair? tvar-list) (pair (car tvar-list)
+ (convert-tvars (cdr tvar-list))))
+ (else (error 'convert-tvars "Not a list of tvars: ~s" tvar-list))))
+
+
+;; Pretty-printing abstract syntax trees
+
+(define (tast-show ast)
+ ;; converts abstract syntax tree to list representation (Scheme program)
+ (let ((syntax-op (ast-con ast))
+ (syntax-tvar (tvar-show (ast-tvar ast)))
+ (syntax-arg (ast-arg ast)))
+ (cons
+ (case syntax-op
+ ((0 1 2 3 4 8 10) syntax-arg)
+ ((29 31) '())
+ ((30 32) (cons (tast-show (car syntax-arg))
+ (tast-show (cdr syntax-arg))))
+ ((5) (list 'quote syntax-arg))
+ ((6) (list->vector (map tast-show syntax-arg)))
+ ((7) (list 'cons (tast-show (car syntax-arg))
+ (tast-show (cdr syntax-arg))))
+ ((9) (ast-arg syntax-arg))
+ ((11) (cons (tast-show (car syntax-arg)) (tast-show (cdr syntax-arg))))
+ ((12) (cons 'lambda (cons (tast-show (car syntax-arg))
+ (map tast-show (cdr syntax-arg)))))
+ ((13) (cons 'if (cons (tast-show (car syntax-arg))
+ (cons (tast-show (cadr syntax-arg))
+ (let ((alt (cddr syntax-arg)))
+ (if (eqv? (ast-con alt) empty)
+ '()
+ (list (tast-show alt))))))))
+ ((14) (list 'set! (tast-show (car syntax-arg))
+ (tast-show (cdr syntax-arg))))
+ ((15) (cons 'cond
+ (map (lambda (cc)
+ (let ((guard (car cc))
+ (body (cdr cc)))
+ (cons
+ (if (eqv? (ast-con guard) empty)
+ 'else
+ (tast-show guard))
+ (map tast-show body))))
+ syntax-arg)))
+ ((16) (cons 'case
+ (cons (tast-show (car syntax-arg))
+ (map (lambda (cc)
+ (let ((data (car cc)))
+ (if (and (pair? data)
+ (eqv? (ast-con (car data)) empty))
+ (cons 'else
+ (map tast-show (cdr cc)))
+ (cons (map datum-show data)
+ (map tast-show (cdr cc))))))
+ (cdr syntax-arg)))))
+ ((17) (cons 'and (map tast-show syntax-arg)))
+ ((18) (cons 'or (map tast-show syntax-arg)))
+ ((19) (cons 'let
+ (cons (map
+ (lambda (vd e)
+ (list (tast-show vd) (tast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map tast-show (cdr syntax-arg)))))
+ ((20) (cons 'let
+ (cons (tast-show (car syntax-arg))
+ (cons (map
+ (lambda (vd e)
+ (list (tast-show vd) (tast-show e)))
+ (caadr syntax-arg)
+ (cdadr syntax-arg))
+ (map tast-show (cddr syntax-arg))))))
+ ((21) (cons 'let*
+ (cons (map
+ (lambda (vd e)
+ (list (tast-show vd) (tast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map tast-show (cdr syntax-arg)))))
+ ((22) (cons 'letrec
+ (cons (map
+ (lambda (vd e)
+ (list (tast-show vd) (tast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map tast-show (cdr syntax-arg)))))
+ ((23) (cons 'begin
+ (map tast-show syntax-arg)))
+ ((24) (error 'tast-show "Do expressions not handled! (~s)" syntax-arg))
+ ((25) (error 'tast-show "This can't happen: empty encountered!"))
+ ((26) (list 'define
+ (tast-show (car syntax-arg))
+ (tast-show (cdr syntax-arg))))
+ ((27) (cons 'define
+ (cons
+ (cons (tast-show (car syntax-arg))
+ (tast-show (cadr syntax-arg)))
+ (map tast-show (cddr syntax-arg)))))
+ ((28) (cons 'begin
+ (map tast-show syntax-arg)))
+ (else (error 'tast-show "Unknown abstract syntax operator: ~s"
+ syntax-op)))
+ syntax-tvar)))
+
+;; tast*-show
+
+(define (tast*-show p)
+ ;; shows a list of abstract syntax trees
+ (map tast-show p))
+
+
+;; counters for tagging/untagging
+
+(define untag-counter 0)
+(define no-untag-counter 0)
+(define tag-counter 0)
+(define no-tag-counter 0)
+(define may-untag-counter 0)
+(define no-may-untag-counter 0)
+
+(define (reset-counters!)
+ (set! untag-counter 0)
+ (set! no-untag-counter 0)
+ (set! tag-counter 0)
+ (set! no-tag-counter 0)
+ (set! may-untag-counter 0)
+ (set! no-may-untag-counter 0))
+
+(define (counters-show)
+ (list
+ (cons tag-counter no-tag-counter)
+ (cons untag-counter no-untag-counter)
+ (cons may-untag-counter no-may-untag-counter)))
+
+
+;; tag-show
+
+(define (tag-show tvar-rep prog)
+ ; display prog with tagging operation
+ (if (eqv? tvar-rep dynamic)
+ (begin
+ (set! tag-counter (+ tag-counter 1))
+ (list 'tag prog))
+ (begin
+ (set! no-tag-counter (+ no-tag-counter 1))
+ (list 'no-tag prog))))
+
+
+;; untag-show
+
+(define (untag-show tvar-rep prog)
+ ; display prog with untagging operation
+ (if (eqv? tvar-rep dynamic)
+ (begin
+ (set! untag-counter (+ untag-counter 1))
+ (list 'untag prog))
+ (begin
+ (set! no-untag-counter (+ no-untag-counter 1))
+ (list 'no-untag prog))))
+
+(define (may-untag-show tvar-rep prog)
+ ; display possible untagging in actual arguments
+ (if (eqv? tvar-rep dynamic)
+ (begin
+ (set! may-untag-counter (+ may-untag-counter 1))
+ (list 'may-untag prog))
+ (begin
+ (set! no-may-untag-counter (+ no-may-untag-counter 1))
+ (list 'no-may-untag prog))))
+
+
+;; tag-ast-show
+
+(define (tag-ast-show ast)
+ ;; converts typed and normalized abstract syntax tree to
+ ;; a Scheme program with explicit tagging and untagging operations
+ (let ((syntax-op (ast-con ast))
+ (syntax-tvar (find! (ast-tvar ast)))
+ (syntax-arg (ast-arg ast)))
+ (case syntax-op
+ ((0 1 2 3 4)
+ (tag-show syntax-tvar syntax-arg))
+ ((8 10) syntax-arg)
+ ((29 31) '())
+ ((30) (cons (tag-ast-show (car syntax-arg))
+ (tag-ast-show (cdr syntax-arg))))
+ ((32) (cons (may-untag-show (find! (ast-tvar (car syntax-arg)))
+ (tag-ast-show (car syntax-arg)))
+ (tag-ast-show (cdr syntax-arg))))
+ ((5) (tag-show syntax-tvar (list 'quote syntax-arg)))
+ ((6) (tag-show syntax-tvar (list->vector (map tag-ast-show syntax-arg))))
+ ((7) (tag-show syntax-tvar (list 'cons (tag-ast-show (car syntax-arg))
+ (tag-ast-show (cdr syntax-arg)))))
+ ((9) (ast-arg syntax-arg))
+ ((11) (let ((proc-tvar (find! (ast-tvar (car syntax-arg)))))
+ (cons (untag-show proc-tvar
+ (tag-ast-show (car syntax-arg)))
+ (tag-ast-show (cdr syntax-arg)))))
+ ((12) (tag-show syntax-tvar
+ (cons 'lambda (cons (tag-ast-show (car syntax-arg))
+ (map tag-ast-show (cdr syntax-arg))))))
+ ((13) (let ((test-tvar (find! (ast-tvar (car syntax-arg)))))
+ (cons 'if (cons (untag-show test-tvar
+ (tag-ast-show (car syntax-arg)))
+ (cons (tag-ast-show (cadr syntax-arg))
+ (let ((alt (cddr syntax-arg)))
+ (if (eqv? (ast-con alt) empty)
+ '()
+ (list (tag-ast-show alt)))))))))
+ ((14) (list 'set! (tag-ast-show (car syntax-arg))
+ (tag-ast-show (cdr syntax-arg))))
+ ((15) (cons 'cond
+ (map (lambda (cc)
+ (let ((guard (car cc))
+ (body (cdr cc)))
+ (cons
+ (if (eqv? (ast-con guard) empty)
+ 'else
+ (untag-show (find! (ast-tvar guard))
+ (tag-ast-show guard)))
+ (map tag-ast-show body))))
+ syntax-arg)))
+ ((16) (cons 'case
+ (cons (tag-ast-show (car syntax-arg))
+ (map (lambda (cc)
+ (let ((data (car cc)))
+ (if (and (pair? data)
+ (eqv? (ast-con (car data)) empty))
+ (cons 'else
+ (map tag-ast-show (cdr cc)))
+ (cons (map datum-show data)
+ (map tag-ast-show (cdr cc))))))
+ (cdr syntax-arg)))))
+ ((17) (cons 'and (map
+ (lambda (ast)
+ (let ((bool-tvar (find! (ast-tvar ast))))
+ (untag-show bool-tvar (tag-ast-show ast))))
+ syntax-arg)))
+ ((18) (cons 'or (map
+ (lambda (ast)
+ (let ((bool-tvar (find! (ast-tvar ast))))
+ (untag-show bool-tvar (tag-ast-show ast))))
+ syntax-arg)))
+ ((19) (cons 'let
+ (cons (map
+ (lambda (vd e)
+ (list (tag-ast-show vd) (tag-ast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map tag-ast-show (cdr syntax-arg)))))
+ ((20) (cons 'let
+ (cons (tag-ast-show (car syntax-arg))
+ (cons (map
+ (lambda (vd e)
+ (list (tag-ast-show vd) (tag-ast-show e)))
+ (caadr syntax-arg)
+ (cdadr syntax-arg))
+ (map tag-ast-show (cddr syntax-arg))))))
+ ((21) (cons 'let*
+ (cons (map
+ (lambda (vd e)
+ (list (tag-ast-show vd) (tag-ast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map tag-ast-show (cdr syntax-arg)))))
+ ((22) (cons 'letrec
+ (cons (map
+ (lambda (vd e)
+ (list (tag-ast-show vd) (tag-ast-show e)))
+ (caar syntax-arg)
+ (cdar syntax-arg))
+ (map tag-ast-show (cdr syntax-arg)))))
+ ((23) (cons 'begin
+ (map tag-ast-show syntax-arg)))
+ ((24) (error 'tag-ast-show "Do expressions not handled! (~s)" syntax-arg))
+ ((25) (error 'tag-ast-show "This can't happen: empty encountered!"))
+ ((26) (list 'define
+ (tag-ast-show (car syntax-arg))
+ (tag-ast-show (cdr syntax-arg))))
+ ((27) (let ((func-tvar (find! (ast-tvar (car syntax-arg)))))
+ (list 'define
+ (tag-ast-show (car syntax-arg))
+ (tag-show func-tvar
+ (cons 'lambda
+ (cons (tag-ast-show (cadr syntax-arg))
+ (map tag-ast-show (cddr syntax-arg))))))))
+ ((28) (cons 'begin
+ (map tag-ast-show syntax-arg)))
+ (else (error 'tag-ast-show "Unknown abstract syntax operator: ~s"
+ syntax-op)))))
+
+
+; tag-ast*-show
+
+(define (tag-ast*-show p)
+ ; display list of commands/expressions with tagging/untagging
+ ; operations
+ (map tag-ast-show p))
+; ----------------------------------------------------------------------------
+; Top level type environment
+; ----------------------------------------------------------------------------
+
+
+; Needed packages: type management (monomorphic and polymorphic)
+
+;(load "typ-mgmt.ss")
+;(load "ptyp-mgm.ss")
+
+
+; type environment for miscellaneous
+
+(define misc-env
+ (list
+ (cons 'quote (forall (lambda (tv) tv)))
+ (cons 'eqv? (forall (lambda (tv) (procedure (convert-tvars (list tv tv))
+ (boolean)))))
+ (cons 'eq? (forall (lambda (tv) (procedure (convert-tvars (list tv tv))
+ (boolean)))))
+ (cons 'equal? (forall (lambda (tv) (procedure (convert-tvars (list tv tv))
+ (boolean)))))
+ ))
+
+; type environment for input/output
+
+(define io-env
+ (list
+ (cons 'open-input-file (procedure (convert-tvars (list (charseq))) dynamic))
+ (cons 'eof-object? (procedure (convert-tvars (list dynamic)) (boolean)))
+ (cons 'read (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) dynamic))))
+ (cons 'write (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) dynamic))))
+ (cons 'display (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) dynamic))))
+ (cons 'newline (procedure (null2) dynamic))
+ (cons 'pretty-print (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) dynamic))))))
+
+
+; type environment for Booleans
+
+(define boolean-env
+ (list
+ (cons 'boolean? (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) (boolean)))))
+ ;(cons #f (boolean))
+ ; #f doesn't exist in Chez Scheme, but gets mapped to null!
+ (cons #t (boolean))
+ (cons 'not (procedure (convert-tvars (list (boolean))) (boolean)))
+ ))
+
+
+; type environment for pairs and lists
+
+(define (list-type tv)
+ (fix (lambda (tv2) (pair tv tv2))))
+
+(define list-env
+ (list
+ (cons 'pair? (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars (list (pair tv1 tv2)))
+ (boolean)))))
+ (cons 'null? (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars (list (pair tv1 tv2)))
+ (boolean)))))
+ (cons 'list? (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars (list (pair tv1 tv2)))
+ (boolean)))))
+ (cons 'cons (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars (list tv1 tv2))
+ (pair tv1 tv2)))))
+ (cons 'car (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars (list (pair tv1 tv2)))
+ tv1))))
+ (cons 'cdr (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars (list (pair tv1 tv2)))
+ tv2))))
+ (cons 'set-car! (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars (list (pair tv1 tv2)
+ tv1))
+ dynamic))))
+ (cons 'set-cdr! (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars (list (pair tv1 tv2)
+ tv2))
+ dynamic))))
+ (cons 'caar (forall3 (lambda (tv1 tv2 tv3)
+ (procedure (convert-tvars
+ (list (pair (pair tv1 tv2) tv3)))
+ tv1))))
+ (cons 'cdar (forall3 (lambda (tv1 tv2 tv3)
+ (procedure (convert-tvars
+ (list (pair (pair tv1 tv2) tv3)))
+ tv2))))
+
+ (cons 'cadr (forall3 (lambda (tv1 tv2 tv3)
+ (procedure (convert-tvars
+ (list (pair tv1 (pair tv2 tv3))))
+ tv2))))
+ (cons 'cddr (forall3 (lambda (tv1 tv2 tv3)
+ (procedure (convert-tvars
+ (list (pair tv1 (pair tv2 tv3))))
+ tv3))))
+ (cons 'caaar (forall4
+ (lambda (tv1 tv2 tv3 tv4)
+ (procedure (convert-tvars
+ (list (pair (pair (pair tv1 tv2) tv3) tv4)))
+ tv1))))
+ (cons 'cdaar (forall4
+ (lambda (tv1 tv2 tv3 tv4)
+ (procedure (convert-tvars
+ (list (pair (pair (pair tv1 tv2) tv3) tv4)))
+ tv2))))
+ (cons 'cadar (forall4
+ (lambda (tv1 tv2 tv3 tv4)
+ (procedure (convert-tvars
+ (list (pair (pair tv1 (pair tv2 tv3)) tv4)))
+ tv2))))
+ (cons 'cddar (forall4
+ (lambda (tv1 tv2 tv3 tv4)
+ (procedure (convert-tvars
+ (list (pair (pair tv1 (pair tv2 tv3)) tv4)))
+ tv3))))
+ (cons 'caadr (forall4
+ (lambda (tv1 tv2 tv3 tv4)
+ (procedure (convert-tvars
+ (list (pair tv1 (pair (pair tv2 tv3) tv4))))
+ tv2))))
+ (cons 'cdadr (forall4
+ (lambda (tv1 tv2 tv3 tv4)
+ (procedure (convert-tvars
+ (list (pair tv1 (pair (pair tv2 tv3) tv4))))
+ tv3))))
+ (cons 'caddr (forall4
+ (lambda (tv1 tv2 tv3 tv4)
+ (procedure (convert-tvars
+ (list (pair tv1 (pair tv2 (pair tv3 tv4)))))
+ tv3))))
+ (cons 'cdddr (forall4
+ (lambda (tv1 tv2 tv3 tv4)
+ (procedure (convert-tvars
+ (list (pair tv1 (pair tv2 (pair tv3 tv4)))))
+ tv4))))
+ (cons 'cadddr
+ (forall5 (lambda (tv1 tv2 tv3 tv4 tv5)
+ (procedure (convert-tvars
+ (list (pair tv1
+ (pair tv2
+ (pair tv3
+ (pair tv4 tv5))))))
+ tv4))))
+ (cons 'cddddr
+ (forall5 (lambda (tv1 tv2 tv3 tv4 tv5)
+ (procedure (convert-tvars
+ (list (pair tv1
+ (pair tv2
+ (pair tv3
+ (pair tv4 tv5))))))
+ tv5))))
+ (cons 'list (forall (lambda (tv)
+ (procedure tv tv))))
+ (cons 'length (forall (lambda (tv)
+ (procedure (convert-tvars (list (list-type tv)))
+ (number)))))
+ (cons 'append (forall (lambda (tv)
+ (procedure (convert-tvars (list (list-type tv)
+ (list-type tv)))
+ (list-type tv)))))
+ (cons 'reverse (forall (lambda (tv)
+ (procedure (convert-tvars (list (list-type tv)))
+ (list-type tv)))))
+ (cons 'list-ref (forall (lambda (tv)
+ (procedure (convert-tvars (list (list-type tv)
+ (number)))
+ tv))))
+ (cons 'memq (forall (lambda (tv)
+ (procedure (convert-tvars (list tv
+ (list-type tv)))
+ (boolean)))))
+ (cons 'memv (forall (lambda (tv)
+ (procedure (convert-tvars (list tv
+ (list-type tv)))
+ (boolean)))))
+ (cons 'member (forall (lambda (tv)
+ (procedure (convert-tvars (list tv
+ (list-type tv)))
+ (boolean)))))
+ (cons 'assq (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars
+ (list tv1
+ (list-type (pair tv1 tv2))))
+ (pair tv1 tv2)))))
+ (cons 'assv (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars
+ (list tv1
+ (list-type (pair tv1 tv2))))
+ (pair tv1 tv2)))))
+ (cons 'assoc (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars
+ (list tv1
+ (list-type (pair tv1 tv2))))
+ (pair tv1 tv2)))))
+ ))
+
+
+(define symbol-env
+ (list
+ (cons 'symbol? (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) (boolean)))))
+ (cons 'symbol->string (procedure (convert-tvars (list (symbol))) (charseq)))
+ (cons 'string->symbol (procedure (convert-tvars (list (charseq))) (symbol)))
+ ))
+
+(define number-env
+ (list
+ (cons 'number? (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) (boolean)))))
+ (cons '+ (procedure (convert-tvars (list (number) (number))) (number)))
+ (cons '- (procedure (convert-tvars (list (number) (number))) (number)))
+ (cons '* (procedure (convert-tvars (list (number) (number))) (number)))
+ (cons '/ (procedure (convert-tvars (list (number) (number))) (number)))
+ (cons 'number->string (procedure (convert-tvars (list (number))) (charseq)))
+ (cons 'string->number (procedure (convert-tvars (list (charseq))) (number)))
+ ))
+
+(define char-env
+ (list
+ (cons 'char? (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) (boolean)))))
+ (cons 'char->integer (procedure (convert-tvars (list (character)))
+ (number)))
+ (cons 'integer->char (procedure (convert-tvars (list (number)))
+ (character)))
+ ))
+
+(define string-env
+ (list
+ (cons 'string? (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) (boolean)))))
+ ))
+
+(define vector-env
+ (list
+ (cons 'vector? (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) (boolean)))))
+ (cons 'make-vector (forall (lambda (tv)
+ (procedure (convert-tvars (list (number)))
+ (array tv)))))
+ (cons 'vector-length (forall (lambda (tv)
+ (procedure (convert-tvars (list (array tv)))
+ (number)))))
+ (cons 'vector-ref (forall (lambda (tv)
+ (procedure (convert-tvars (list (array tv)
+ (number)))
+ tv))))
+ (cons 'vector-set! (forall (lambda (tv)
+ (procedure (convert-tvars (list (array tv)
+ (number)
+ tv))
+ dynamic))))
+ ))
+
+(define procedure-env
+ (list
+ (cons 'procedure? (forall (lambda (tv)
+ (procedure (convert-tvars (list tv)) (boolean)))))
+ (cons 'map (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars
+ (list (procedure (convert-tvars
+ (list tv1)) tv2)
+ (list-type tv1)))
+ (list-type tv2)))))
+ (cons 'foreach (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars
+ (list (procedure (convert-tvars
+ (list tv1)) tv2)
+ (list-type tv1)))
+ (list-type tv2)))))
+ (cons 'call-with-current-continuation
+ (forall2 (lambda (tv1 tv2)
+ (procedure (convert-tvars
+ (list (procedure
+ (convert-tvars
+ (list (procedure (convert-tvars
+ (list tv1)) tv2)))
+ tv2)))
+ tv2))))
+ ))
+
+
+; global top level environment
+
+(define (global-env)
+ (append misc-env
+ io-env
+ boolean-env
+ symbol-env
+ number-env
+ char-env
+ string-env
+ vector-env
+ procedure-env
+ list-env))
+
+(define dynamic-top-level-env (global-env))
+
+(define (init-dynamic-top-level-env!)
+ (set! dynamic-top-level-env (global-env))
+ '())
+
+(define (dynamic-top-level-env-show)
+ ; displays the top level environment
+ (map (lambda (binding)
+ (cons (key-show (binding-key binding))
+ (cons ': (tvar-show (binding-value binding)))))
+ (env->list dynamic-top-level-env)))
+; ----------------------------------------------------------------------------
+; Dynamic type inference for Scheme
+; ----------------------------------------------------------------------------
+
+; Needed packages:
+
+(define (ic!) (init-global-constraints!))
+(define (pc) (glob-constr-show))
+(define (lc) (length global-constraints))
+(define (n!) (normalize-global-constraints!))
+(define (pt) (dynamic-top-level-env-show))
+(define (it!) (init-dynamic-top-level-env!))
+(define (io!) (set! tag-ops 0) (set! no-ops 0))
+(define (i!) (ic!) (it!) (io!) '())
+
+(define tag-ops 0)
+(define no-ops 0)
+
+
+(define doit
+ (lambda ()
+ (i!)
+ (let ((foo (dynamic-parse-file "dynamic.scm")))
+ (normalize-global-constraints!)
+ (reset-counters!)
+ (tag-ast*-show foo)
+ (counters-show))))
+
+(let ((result (time (doit))))
+ (if (not (equal? result '((330 . 339) (6 . 1895) (2306 . 344))))
+ (error "wrong result" result) ) )
diff --git a/benchmarks/earley.scm b/benchmarks/earley.scm
new file mode 100644
index 00000000..163e57c5
--- /dev/null
+++ b/benchmarks/earley.scm
@@ -0,0 +1,646 @@
+;;; EARLEY -- Earley's parser, written by Marc Feeley.
+
+; (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)
+ (let ((p (make-parser '( (s (a) (s s)) )
+ (lambda (l) (map (lambda (x) (list x x)) l)))))
+ (let ((x (p '(a a a a a a a a a))))
+ (length (parse->trees x 's 0 9)))))
+
+(time (test))
diff --git a/benchmarks/fft.scm b/benchmarks/fft.scm
new file mode 100644
index 00000000..53e02c07
--- /dev/null
+++ b/benchmarks/fft.scm
@@ -0,0 +1,114 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; File: fft.sc
+;;; 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)
+;;; 16-Nov-94 (Qobi)
+;;; 31-Mar-98 (Qobi)
+;;; 26-Mar-00 (flw)
+;;; 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 areal) ;Qobi
+ (ai aimag) ;Qobi
+ (i 0)
+ (j 0)
+ (k 0)
+ (m 0)
+ (n 0)
+ (le 0)
+ (le1 0)
+ (ip 0)
+ (nv2 0)
+ (nm1 0)
+ (ur 0.0) ;Qobi
+ (ui 0.0) ;Qobi
+ (wr 0.0) ;Qobi
+ (wi 0.0) ;Qobi
+ (tr 0.0) ;Qobi
+ (ti 0.0)) ;Qobi
+ ;; 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 (let loop ((i m) (p 1)) ;Qobi
+ (if (zero? i) p (loop (- i 1) (* 2 p))))))
+ (display "array size not a power of two.")
+ (newline)))
+ ;; 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 (quotient k 2)) ;Qobi: was / but this violates R4RS
+ (l6))))
+ (set! j (+ j k))
+ (set! i (+ i 1))
+ (cond ((< i n) (l3))))
+ ;; loop thru stages (syntax converted from old MACLISP style \bs)
+ (do ((l 1 (+ l 1))) ((> l m))
+ (set! le (let loop ((i l) (p 1)) ;Qobi
+ (if (zero? i) p (loop (- i 1) (* 2 p)))))
+ (set! le1 (quotient le 2))
+ (set! ur 1.0)
+ (set! ui 0.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 10))
+ (fft *re* *im*)))
+
+(time (fft-bench))
diff --git a/benchmarks/fib.scm b/benchmarks/fib.scm
new file mode 100644
index 00000000..22b4918d
--- /dev/null
+++ b/benchmarks/fib.scm
@@ -0,0 +1,8 @@
+;;; fib.scm
+
+(define (fib n)
+ (if (< n 2)
+ n
+ (+ (fib (- n 1)) (fib (- n 2))) ) )
+
+(time (print (fib 30)))
diff --git a/benchmarks/fibc.scm b/benchmarks/fibc.scm
new file mode 100644
index 00000000..017a2113
--- /dev/null
+++ b/benchmarks/fibc.scm
@@ -0,0 +1,24 @@
+;;; FIBC -- FIB using first-class continuations, written by Kent Dybvig
+
+;;; fib with peano arithmetic (using numbers) with call/cc
+
+(define (add1 x) (+ x 1))
+(define (sub1 x) (- x 1))
+
+(define (addc x y k)
+ (if (zero? y)
+ (k x)
+ (addc (add1 x) (sub1 y) k)))
+
+(define (fibc x c)
+ (if (zero? x)
+ (c 0)
+ (if (zero? (sub1 x))
+ (c 1)
+ (addc (call-with-current-continuation (lambda (c) (fibc (sub1 x) c)))
+ (call-with-current-continuation (lambda (c) (fibc (sub1 (sub1 x)) c)))
+ c))))
+
+(let ((x (time (fibc 30 (lambda (n) n)))))
+ (if (not (equal? x 832040))
+ (error "wrong result" x) ) )
diff --git a/benchmarks/fprint.scm b/benchmarks/fprint.scm
new file mode 100644
index 00000000..4346edd3
--- /dev/null
+++ b/benchmarks/fprint.scm
@@ -0,0 +1,47 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; File: fprint.sc
+;;; Description: FPRINT benchmark
+;;; Author: Richard Gabriel
+;;; Created: 11-Apr-85
+;;; Modified: 9-Jul-85 21:11:33 (Bob Shaw)
+;;; 24-Jul-87 (Will Clinger)
+;;; 16-Nov-94 (Qobi)
+;;; 31-Mar-98 (Qobi)
+;;; 26-Mar-00 (flw)
+;;; Language: Scheme
+;;; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; FPRINT -- Benchmark to print to a file.
+
+(define test-atoms '(abcdef12 cdefgh23 efghij34 ghijkl45 ijklmn56 klmnop67
+ mnopqr78 opqrst89 qrstuv90 stuvwx01 uvwxyz12
+ ;; Qobi: changed 123456AB to AB123456 etc. since
+ ;; Scheme->C can't READ original symbols
+ wxyzab23 xyzabc34 ab123456 bc234567 cd345678
+ de456789 ef567890 fg678901 gh789012 hi890123))
+
+(define (init-aux m n atoms)
+ (cond ((= m 0) (car atoms))
+ (else (do ((i n (- i 2)) (a '())) ((< i 1) a)
+ (set! a (cons (car atoms) a))
+ (set! atoms (cdr atoms))
+ (set! a (cons (init-aux (- m 1) n atoms) a))))))
+
+(define (init m n atoms)
+ (define (copy x) (if (pair? x) (cons (copy (car x)) (copy (cdr x))) x))
+ (let ((atoms (copy atoms)))
+ (do ((a atoms (cdr a))) ((null? (cdr a)) (set-cdr! a atoms)))
+ (init-aux m n atoms)))
+
+(define test-pattern (init 8 8 test-atoms))
+
+(define (fprint)
+ (call-with-output-file "fprint.tst"
+ (lambda (stream)
+ (newline stream)
+ (write test-pattern stream)) ))
+
+;;; note: The INIT is not done multiple times.
+
+(time (fprint))
diff --git a/benchmarks/fread.scm b/benchmarks/fread.scm
new file mode 100644
index 00000000..d326c4b6
--- /dev/null
+++ b/benchmarks/fread.scm
@@ -0,0 +1,22 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; File: fread.sc
+;;; Description: FREAD benchmark
+;;; Author: Richard Gabriel
+;;; Created: 11-Apr-85
+;;; Modified: 11-Apr-85 20:39:09 (Bob Shaw)
+;;; 24-Jul-87 (Will Clinger)
+;;; 14-Jun-95 (Qobi)
+;;; 31-Mar-98 (Qobi)
+;;; 26-Mar-00 (flw)
+;;; Language: Scheme
+;;; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; FREAD -- Benchmark to read from a file.
+;;; Requires the existence of FPRINT.TST which is created by FPRINT.
+
+(define (fread)
+ (call-with-input-file "fprint.tst" (lambda (stream) (read stream))))
+
+(time (fread)
+)
diff --git a/benchmarks/hanoi.scm b/benchmarks/hanoi.scm
new file mode 100644
index 00000000..41dc0a0d
--- /dev/null
+++ b/benchmarks/hanoi.scm
@@ -0,0 +1,13 @@
+;;;; hanoi.scm
+
+(define hanoi
+ (lambda (n)
+ (letrec ((move-them
+ (lambda (n from to helper)
+ (if (> n 1)
+ (begin
+ (move-them (- n 1) from helper to)
+ (move-them (- n 1) helper to from))))))
+ (move-them n 0 1 2))))
+
+(time (do ((i 10 (- i 1))) ((zero? i)) (hanoi 20)))
diff --git a/benchmarks/lattice.scm b/benchmarks/lattice.scm
new file mode 100644
index 00000000..6bcb938c
--- /dev/null
+++ b/benchmarks/lattice.scm
@@ -0,0 +1,217 @@
+;;; LATTICE -- Obtained from Andrew Wright.
+;
+; 08/06/01 (felix): renamed "reverse!" to "reverse!2" because MZC doesn't like redefinitions.
+;
+; 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!2 ac)
+ (select-a
+ (let ((head (car lst)))
+ (if (test head)
+ (cons head ac)
+ ac))
+ (cdr lst)))))
+ (select-a '() lst)))
+
+(define reverse!2
+ (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!2 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/maze.scm b/benchmarks/maze.scm
new file mode 100644
index 00000000..3c5e1bf2
--- /dev/null
+++ b/benchmarks/maze.scm
@@ -0,0 +1,726 @@
+;;; MAZE -- Constructs a maze on a hexagonal grid, written by Olin Shivers.
+
+; 18/07/01 (felix): 100 iterations
+
+;------------------------------------------------------------------------------
+; 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 (vector-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)
+ (vector-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)
+ (vector-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)))
+
+;;; _ _
+;;; _/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \_/
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \
+;;; / \_/ \_/
+;;; \_/ \_/ \_/
+
+;------------------------------------------------------------------------------
+
+(define (run)
+ (do ((i 100 (- i 1)))
+ ((zero? i) (reverse output))
+ (set! output '())
+ (pmaze 20 7) ) )
+
+(let ((x (time (run))))
+; (for-each display x)
+ (if (not (equal? x '
+(#\ #\ #\ #\_ #\ #\ #\ #\_ #\ #\ #\ #\_ #\newline
+ #\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\ #\newline
+ #\/ #\ #\\ #\ #\ #\ #\\ #\_ #\ #\. #\ #\ #\/ #\. #\\ #\newline
+ #\\ #\ #\ #\ #\\ #\ #\/ #\. #\ #\_ #\/ #\. #\\ #\ #\/ #\newline
+ #\/ #\ #\\ #\_ #\/ #\. #\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
+ #\\ #\ #\/ #\ #\\ #\ #\/ #\ #\ #\_ #\/ #\ #\\ #\_ #\/ #\newline
+ #\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\ #\\ #\ #\/ #\ #\\ #\newline
+ #\\ #\ #\/ #\ #\\ #\ #\/ #\ #\ #\_ #\/ #\ #\ #\ #\/ #\newline
+ #\/ #\ #\\ #\ #\/ #\. #\\ #\ #\/ #\. #\\ #\_ #\/ #\ #\\ #\newline
+ #\\ #\_ #\/ #\ #\\ #\ #\/ #\. #\ #\_ #\ #\. #\\ #\ #\/ #\newline
+ #\/ #\ #\\ #\_ #\ #\. #\ #\_ #\/ #\ #\\ #\ #\ #\ #\\ #\newline
+ #\\ #\_ #\ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\newline
+ #\/ #\ #\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\ #\/ #\ #\\ #\newline
+ #\\ #\_ #\ #\ #\\ #\ #\/ #\ #\\ #\_ #\ #\. #\\ #\_ #\/ #\newline
+ #\/ #\ #\\ #\_ #\ #\ #\\ #\_ #\ #\ #\\ #\_ #\ #\. #\\ #\newline
+ #\\ #\_ #\ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\ #\/ #\newline
+ #\/ #\ #\\ #\_ #\ #\ #\\ #\ #\/ #\. #\\ #\ #\ #\. #\\ #\newline
+ #\\ #\ #\/ #\. #\\ #\_ #\ #\. #\ #\ #\/ #\. #\\ #\ #\/ #\newline
+ #\/ #\ #\ #\ #\ #\. #\ #\_ #\/ #\. #\\ #\ #\/ #\ #\\ #\newline
+ #\\ #\ #\/ #\. #\\ #\_ #\/ #\. #\\ #\_ #\ #\. #\\ #\ #\/ #\newline
+ #\/ #\ #\\ #\_ #\ #\. #\ #\ #\/ #\ #\ #\_ #\/ #\ #\\ #\newline
+ #\\ #\_ #\ #\ #\\ #\_ #\/ #\. #\\ #\_ #\ #\ #\\ #\_ #\/ #\newline
+ #\/ #\ #\ #\_ #\/ #\ #\\ #\ #\/ #\ #\\ #\_ #\ #\ #\\ #\newline
+ #\\ #\_ #\/ #\ #\ #\_ #\/ #\. #\\ #\_ #\ #\ #\\ #\_ #\/ #\newline
+ #\/ #\ #\\ #\ #\/ #\ #\ #\_ #\ #\. #\ #\_ #\ #\ #\\ #\newline
+ #\\ #\ #\/ #\ #\\ #\_ #\/ #\. #\ #\_ #\ #\ #\\ #\_ #\/ #\newline
+ #\/ #\ #\ #\_ #\ #\ #\\ #\ #\ #\ #\\ #\_ #\/ #\ #\\ #\newline
+ #\\ #\_ #\/ #\. #\\ #\_ #\ #\. #\\ #\_ #\/ #\ #\ #\_ #\/ #\newline
+ #\/ #\ #\\ #\ #\ #\. #\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\newline
+ #\\ #\ #\/ #\. #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\ #\/ #\newline
+ #\/ #\ #\\ #\_ #\ #\. #\ #\_ #\/ #\. #\ #\ #\ #\ #\\ #\newline
+ #\\ #\ #\ #\ #\ #\ #\ #\. #\ #\ #\/ #\. #\\ #\_ #\/ #\newline
+ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
+ #\\ #\_ #\/ #\ #\ #\ #\/ #\ #\\ #\_ #\/ #\. #\ #\ #\/ #\newline
+ #\/ #\ #\ #\ #\/ #\ #\ #\_ #\ #\ #\\ #\ #\/ #\ #\\ #\newline
+ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\. #\\ #\_ #\/ #\newline
+ #\/ #\ #\\ #\_ #\/ #\ #\ #\_ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
+ #\\ #\ #\ #\ #\ #\_ #\/ #\. #\ #\ #\/ #\. #\ #\_ #\/ #\newline
+ #\/ #\ #\\ #\ #\/ #\. #\ #\ #\/ #\ #\\ #\_ #\ #\. #\\ #\newline
+ #\\ #\_ #\/ #\. #\ #\_ #\/ #\. #\\ #\_ #\/ #\. #\\ #\ #\/ #\newline
+ #\/ #\ #\ #\_ #\ #\. #\\ #\_ #\ #\. #\ #\_ #\ #\. #\\ #\newline
+ #\\ #\_ #\/ #\ #\\ #\ #\/ #\ #\\ #\_ #\/ #\ #\\ #\_ #\/ #\newline)))
+(error "wrong result") ) )
diff --git a/benchmarks/nbody.scm b/benchmarks/nbody.scm
new file mode 100644
index 00000000..78210f07
--- /dev/null
+++ b/benchmarks/nbody.scm
@@ -0,0 +1,138 @@
+;;; The Computer Language Benchmarks Game
+;;; http://shootout.alioth.debian.org/
+;;;
+;;; contributed by Anthony Borla
+;;; modified by Graham Fawcett
+
+;; define planetary masses, initial positions & velocity
+
+(define +pi+ 3.141592653589793)
+(define +days-per-year+ 365.24)
+
+(define +solar-mass+ (* 4 +pi+ +pi+))
+
+(define-record body x y z vx vy vz mass)
+
+(define *sun*
+ (make-body 0.0 0.0 0.0 0.0 0.0 0.0 +solar-mass+))
+
+(define *jupiter*
+ (make-body 4.84143144246472090
+ -1.16032004402742839
+ -1.03622044471123109e-1
+ (* 1.66007664274403694e-3 +days-per-year+)
+ (* 7.69901118419740425e-3 +days-per-year+)
+ (* -6.90460016972063023e-5 +days-per-year+)
+ (* 9.54791938424326609e-4 +solar-mass+)))
+
+(define *saturn*
+ (make-body 8.34336671824457987
+ 4.12479856412430479
+ -4.03523417114321381e-1
+ (* -2.76742510726862411e-3 +days-per-year+)
+ (* 4.99852801234917238e-3 +days-per-year+)
+ (* 2.30417297573763929e-5 +days-per-year+)
+ (* 2.85885980666130812e-4 +solar-mass+)))
+
+(define *uranus*
+ (make-body 1.28943695621391310e1
+ -1.51111514016986312e1
+ -2.23307578892655734e-1
+ (* 2.96460137564761618e-03 +days-per-year+)
+ (* 2.37847173959480950e-03 +days-per-year+)
+ (* -2.96589568540237556e-05 +days-per-year+)
+ (* 4.36624404335156298e-05 +solar-mass+)))
+
+(define *neptune*
+ (make-body 1.53796971148509165e+01
+ -2.59193146099879641e+01
+ 1.79258772950371181e-01
+ (* 2.68067772490389322e-03 +days-per-year+)
+ (* 1.62824170038242295e-03 +days-per-year+)
+ (* -9.51592254519715870e-05 +days-per-year+)
+ (* 5.15138902046611451e-05 +solar-mass+)))
+
+;; -------------------------------
+(define (offset-momentum system)
+ (let loop-i ((i system) (px 0.0) (py 0.0) (pz 0.0))
+ (if (null? i)
+ (begin
+ (body-vx-set! (car system) (/ (- px) +solar-mass+))
+ (body-vy-set! (car system) (/ (- py) +solar-mass+))
+ (body-vz-set! (car system) (/ (- pz) +solar-mass+)))
+ (loop-i (cdr i)
+ (+ px (* (body-vx (car i)) (body-mass (car i))))
+ (+ py (* (body-vy (car i)) (body-mass (car i))))
+ (+ pz (* (body-vz (car i)) (body-mass (car i))))))))
+
+;; -------------------------------
+(define (energy system)
+ (let loop-o ((o system) (e 0.0))
+ (if (null? o)
+ e
+ (let ([e (+ e (* 0.5 (body-mass (car o))
+ (+ (* (body-vx (car o)) (body-vx (car o)))
+ (* (body-vy (car o)) (body-vy (car o)))
+ (* (body-vz (car o)) (body-vz (car o))))))])
+
+ (let loop-i ((i (cdr o)) (e e))
+ (if (null? i)
+ (loop-o (cdr o) e)
+ (let* ((dx (- (body-x (car o)) (body-x (car i))))
+ (dy (- (body-y (car o)) (body-y (car i))))
+ (dz (- (body-z (car o)) (body-z (car i))))
+ (distance (sqrt (+ (* dx dx) (* dy dy) (* dz dz)))))
+ (let ([e (- e (/ (* (body-mass (car o)) (body-mass (car i))) distance))])
+ (loop-i (cdr i) e)))))))))
+
+;; -------------------------------
+(define (advance system dt)
+ (let loop-o ((o system))
+ (unless (null? o)
+ (let loop-i ((i (cdr o)))
+ (unless (null? i)
+ (let* ((o1 (car o))
+ (i1 (car i))
+ (dx (- (body-x o1) (body-x i1)))
+ (dy (- (body-y o1) (body-y i1)))
+ (dz (- (body-z o1) (body-z i1)))
+ (distance (sqrt (+ (* dx dx) (* dy dy) (* dz dz))))
+ (mag (/ dt (* distance distance distance)))
+ (dxmag (* dx mag))
+ (dymag (* dy mag))
+ (dzmag (* dz mag))
+ (om (body-mass o1))
+ (im (body-mass i1)))
+ (body-vx-set! o1 (- (body-vx o1) (* dxmag im)))
+ (body-vy-set! o1 (- (body-vy o1) (* dymag im)))
+ (body-vz-set! o1 (- (body-vz o1) (* dzmag im)))
+ (body-vx-set! i1 (+ (body-vx i1) (* dxmag om)))
+ (body-vy-set! i1 (+ (body-vy i1) (* dymag om)))
+ (body-vz-set! i1 (+ (body-vz i1) (* dzmag om)))
+ (loop-i (cdr i)))))
+ (loop-o (cdr o))))
+
+ (let loop-o ((o system))
+ (unless (null? o)
+ (let ([o1 (car o)])
+ (body-x-set! o1 (+ (body-x o1) (* dt (body-vx o1))))
+ (body-y-set! o1 (+ (body-y o1) (* dt (body-vy o1))))
+ (body-z-set! o1 (+ (body-z o1) (* dt (body-vz o1))))
+ (loop-o (cdr o))))))
+
+;; -------------------------------
+(define (main n)
+ (let ((system (list *sun* *jupiter* *saturn* *uranus* *neptune*)))
+
+ (offset-momentum system)
+ (print-float (energy system))
+
+ (do ((i 1 (+ i 1)))
+ ((< n i))
+ (advance system 0.01))
+ (print-float (energy system))))
+
+(define print-float
+ (foreign-lambda* void ((double f)) "printf(\"%2.9f\\n\", f);"))
+
+(time (main 100000))
diff --git a/benchmarks/nqueens.scm b/benchmarks/nqueens.scm
new file mode 100644
index 00000000..75df9ce2
--- /dev/null
+++ b/benchmarks/nqueens.scm
@@ -0,0 +1,30 @@
+;;; NQUEENS -- Compute number of solutions to 8-queens problem.
+
+(define trace? #f)
+
+(define (nqueens n)
+
+ (define (dec-to n)
+ (let loop ((i n) (l '()))
+ (if (= i 0) l (loop (- i 1) (cons i l)))))
+
+ (define (try 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 (append (cdr x) y) '() (cons (car x) z))
+ 0)
+ (try (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 (dec-to n) '() '()))
+
+(time (do ((i 1000 (- 1 1))) ((zero? i)) (nqueens 10)))
diff --git a/benchmarks/others/Makefile b/benchmarks/others/Makefile
new file mode 100644
index 00000000..a231e053
--- /dev/null
+++ b/benchmarks/others/Makefile
@@ -0,0 +1,21 @@
+.PHONY: all clean
+
+all: exception except setlongjmp except-fast except2
+
+clean:
+ rm -f *.o except exception except-fast except2 setlongjmp
+
+exception: exception.cpp
+ g++ $< -o $@ -O2
+
+except: except.scm
+ csc $< -o $@ -O2 -d0
+
+except-fast: except.scm
+ csc $< -o $@ -Ob
+
+except2: except2.scm
+ csc $< -o $@ -Ob
+
+setlongjmp: setlongjmp.c
+ gcc $< -o $@ -O2
diff --git a/benchmarks/others/except.scm b/benchmarks/others/except.scm
new file mode 100644
index 00000000..56c387d7
--- /dev/null
+++ b/benchmarks/others/except.scm
@@ -0,0 +1,10 @@
+(define n 0)
+
+(define (foo k)
+ (set! n (+ n 1))
+ (k 123))
+
+(let ((count (string->number (:optional (command-line-arguments) "10000"))))
+ (do ((i count (- i 1)))
+ ((zero? i) (print n))
+ (call/cc (lambda (k) (foo k))) ) )
diff --git a/benchmarks/others/except2.scm b/benchmarks/others/except2.scm
new file mode 100644
index 00000000..a83e0c2c
--- /dev/null
+++ b/benchmarks/others/except2.scm
@@ -0,0 +1,10 @@
+(define n 0)
+
+(define (foo k)
+ (set! n (+ n 1))
+ (##sys#direct-return k 123))
+
+(let ((count (string->number (:optional (command-line-arguments) "10000"))))
+ (do ((i count (- i 1)))
+ ((zero? i) (print n))
+ (##sys#call-with-direct-continuation (lambda (k) (foo k))) ) )
diff --git a/benchmarks/others/exception.cpp b/benchmarks/others/exception.cpp
new file mode 100644
index 00000000..a49f4ae5
--- /dev/null
+++ b/benchmarks/others/exception.cpp
@@ -0,0 +1,25 @@
+#include <stdio.h>
+#include <stdlib.h>
+
+static void foo()
+{
+ throw 123;
+}
+
+int main(int argc, char *argv[])
+{
+ int count = argc == 1 ? 10000 : atoi(argv[ 1 ]);
+ int n = 0;
+
+ for(int i = 0; i < count; ++i) {
+ try {
+ foo();
+ }
+ catch(...) {
+ ++n;
+ }
+ }
+
+ printf("%d\n", n);
+ return 0;
+}
diff --git a/benchmarks/others/results.txt b/benchmarks/others/results.txt
new file mode 100644
index 00000000..8bd50f02
--- /dev/null
+++ b/benchmarks/others/results.txt
@@ -0,0 +1,63 @@
+Darwin o3215.o.pppool.de 8.0.0 Darwin Kernel Version 8.0.0: Sat Mar 26 14:15:22 PST 2005; root:xnu-792.obj~1/RELEASE_PPC Power Macintosh powerpc:
+%
+% time exception 1000000
+1000000
+
+real 0m32.497s
+user 0m22.000s
+sys 0m0.119s
+% time exception 1000000
+1000000
+
+real 0m28.155s
+user 0m21.985s
+sys 0m0.090s
+% time setlongjmp 1000000
+1000000
+
+real 0m5.516s
+user 0m1.269s
+sys 0m2.680s
+% time setlongjmp 1000000
+1000000
+
+real 0m4.993s
+user 0m1.239s
+sys 0m2.636s
+% time except 1000000
+1000000
+
+real 0m2.392s
+user 0m1.646s
+sys 0m0.078s
+% time except 1000000
+1000000
+
+real 0m2.208s
+user 0m1.652s
+sys 0m0.076s
+% time except-fast 1000000
+1000000
+
+real 0m1.374s
+user 0m1.034s
+sys 0m0.063s
+% time except-fast 1000000
+1000000
+
+real 0m1.364s
+user 0m1.033s
+sys 0m0.061s
+% time except2 1000000
+1000000
+
+real 0m0.419s
+user 0m0.283s
+sys 0m0.026s
+% time except2 1000000
+1000000
+
+real 0m0.404s
+user 0m0.285s
+sys 0m0.024s
+%
diff --git a/benchmarks/others/setlongjmp.c b/benchmarks/others/setlongjmp.c
new file mode 100644
index 00000000..355de55b
--- /dev/null
+++ b/benchmarks/others/setlongjmp.c
@@ -0,0 +1,26 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <setjmp.h>
+
+static int n = 0;
+static jmp_buf jb;
+
+static void foo()
+{
+ ++n;
+ longjmp(jb, 123);
+}
+
+int main(int argc, char *argv[])
+{
+ int count = argc == 1 ? 10000 : atoi(argv[ 1 ]);
+ int i;
+
+ for(i = 0; i < count; ++i) {
+ if(!setjmp(jb))
+ foo();
+ }
+
+ printf("%d\n", n);
+ return 0;
+}
diff --git a/benchmarks/puzzle.scm b/benchmarks/puzzle.scm
new file mode 100644
index 00000000..19bb73b8
--- /dev/null
+++ b/benchmarks/puzzle.scm
@@ -0,0 +1,151 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; File: puzzle.sc
+;;; 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)
+;;; 8-Oct-95 (Qobi)
+;;; 31-Mar-98 (Qobi)
+;;; 26-Mar-00 (flw)
+;;; 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 511)
+ (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 (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))))) ;Qobi: resist temptation to optimize
+
+ (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)
+ ;; Qobi: changed () to #F in the following
+ (do ((i 0 (+ i 1))) ((> i typemax) (set! *kount* (+ *kount* 1)) #f)
+ (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) ;Qobi: removed R3RS NUMBER->STRING
+ (newline)
+ (display "Piece ")
+ (display x)
+ (display " at ")
+ (display y)
+ (display "."))
+
+ (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 (newline) (display "Error."))) ;Qobi: removed BEGIN
+ (cond ((trial n) ;Qobi: removed BEGIN
+ (newline)
+ (display "Success in ")
+ (write *kount*)
+ (display " trials."))
+ (else (newline) (display "Failure."))))) ;Qobi: removed BEGIN
+
+ ;; Qobi: moved
+ (for-each (lambda (i) (vector-set! *p* i (make-vector (+ size 1))))
+ (iota (+ typemax 1)))
+
+(time
+ (begin
+ (start)
+ (newline) ) ) ;Qobi: added
diff --git a/benchmarks/regex/benchmark.pl b/benchmarks/regex/benchmark.pl
new file mode 100644
index 00000000..261e0354
--- /dev/null
+++ b/benchmarks/regex/benchmark.pl
@@ -0,0 +1,28 @@
+#! /usr/bin/env perl
+
+use strict;
+
+sub bench ($$$) {
+ my ($name, $sub, $n) = @_;
+ my $start = times;
+ for (my $i=0; $i<$n; $i++) { $sub->(); }
+ print "$name: ".((times-$start)*1000)."\n";
+}
+
+open(IN, "< re-benchmarks.txt");
+while (<IN>) {
+ next if /^\s*#/;
+ my ($name, $pat, $str, $prefix, $compn, $execn) = split(/\t/);
+ bench("$name: compile-time", sub {eval "/$pat/"}, $compn);
+ my ($rx, $rxm, $str2);
+ eval "\$rx = qr/$pat/";
+ eval "\$rxm = qr/^$pat\$/";
+ bench("$name: match-time", sub {$str =~ $rxm}, $execn);
+ for (my $mult=1; $execn>=10; $mult*=10, $execn/=10) {
+ $str2 = (($prefix x $mult).$str);
+ bench("$name: search prefix x $mult", sub {$str2 =~ $rx}, $execn);
+ }
+}
+close(IN);
+
+
diff --git a/benchmarks/regex/benchmark.scm b/benchmarks/regex/benchmark.scm
new file mode 100644
index 00000000..3d2106dc
--- /dev/null
+++ b/benchmarks/regex/benchmark.scm
@@ -0,0 +1,58 @@
+
+(use chicken extras regex data-structures srfi-13)
+(import irregex)
+
+(define-syntax time-expr
+ (syntax-rules ()
+ ((time-expr expr)
+ (let ((start (nth-value 0 (cpu-time))))
+ expr
+ (- (nth-value 0 (cpu-time)) start)))))
+
+(define (string-replicate str reps)
+ (let lp ((ls '()) (reps reps))
+ (if (<= reps 0)
+ (string-concatenate-reverse ls)
+ (lp (cons str ls) (- reps 1)))))
+
+(define (run-bench name pat str prefix comp-count exec-count)
+ (let-syntax
+ ((bench (syntax-rules ()
+ ((bench variation expr count)
+ (let ((time-taken
+ (time-expr (do ((i count (- i 1)))
+ ((< i 0))
+ expr))))
+ (display name) (display ": ")
+ (display variation) (display ": ")
+ (write time-taken) (newline))))))
+ (let ((comp-count (string->number comp-count))
+ (exec-count (string->number exec-count)))
+ ;; compile time
+ (bench "compile-time" (string->irregex pat) comp-count)
+ (let ((irx (string->irregex pat)))
+ ;; match time
+ (bench "match-time" (irregex-match irx str) exec-count)
+ ;; search times
+ (let lp ((mult 1) (reps exec-count))
+ (cond
+ ((>= reps 10)
+ (let ((str (string-append (string-replicate prefix mult) str)))
+ (bench (string-append "search prefix x " (number->string mult))
+ (irregex-search irx str)
+ reps)
+ (lp (* mult 10) (quotient reps 10))))))))))
+
+(call-with-input-file "re-benchmarks.txt"
+ (lambda (in)
+ (let lp ()
+ (let ((line (read-line in)))
+ (cond
+ ((eof-object? line))
+ ((string-match "^\\s*#.*" line)
+ (lp))
+ (else
+ (let ((ls (string-split line "\t")))
+ (apply run-bench ls)
+ (lp))))))))
+
diff --git a/benchmarks/regex/re-benchmarks.txt b/benchmarks/regex/re-benchmarks.txt
new file mode 100644
index 00000000..b8f2acdb
--- /dev/null
+++ b/benchmarks/regex/re-benchmarks.txt
@@ -0,0 +1,9 @@
+char literal a a xxxxxxxxxx 1000 10000
+string literal abccb abccb xxxxxxxxxx 1000 10000
+ci string literal (?i:abccb) aBCcB xxxxxxxxxx 1000 10000
+best-case boyer-moore abcdefghijklmnopq abcdefghijklmnopq xxxxxxxxxx 1000 10000
+worst-case boyer-moore abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb bbbbbbbbbb 1000 10000
+alternation (?:asm|break|case|catch|const_cast|continue|default|delete|do|dynamic_cast|else|explicit|export|false|for|friend|goto|if|mutable|namespace|new|operator|private|protected|public|register|reinterpret_cast|return|sizeof|static_cast|switch|template|this|throw|true|try|typedef|typeid|typename|using|virtual|while) virtual aeiouaeiou 1 10000
+backtracker a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa x 100 100
+exponential dfa a[ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab] abbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb b 1 100
+# backtracker + exponential dfa a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?a?aaaaaaaaaaaaaaaaaaaaaaaaaaaaaa[ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab][ab] aaaaaaaaaaaaaaaaaaaaaaaaaaaaaabbbbbbbbbb b 1 100
diff --git a/benchmarks/scheme.scm b/benchmarks/scheme.scm
new file mode 100644
index 00000000..8b28b3f9
--- /dev/null
+++ b/benchmarks/scheme.scm
@@ -0,0 +1,1082 @@
+;;; SCHEME -- A Scheme interpreter evaluating a sorting routine, written by Marc Feeley.
+;
+; 08/06/01 (felix): renamed "macro?" to "macro?2" because MZC can't
+; handle redefinitions of primitives.
+; 18/07/01 (felix): 100 iterations
+;
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(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)
+ (fatal-error msg args))
+
+; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
+
+(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?2 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 cannot 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?2 (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?2 (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))
+
+(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? pair?)
+(def-proc 'cons cons)
+(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>=? 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-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>=? 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 '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 (run)
+ (let ((result #f))
+ (do ((i 100 (- i 1)))
+ ((zero? i) result)
+ (set! result
+ (scheme-eval
+ '(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<?)))))))
+
+(let ((r (time (run))))
+ (if (not (equal? r '("eight" "eleven" "five" "four" "nine" "one" "seven" "six" "ten" "three" "twelve" "two")))
+ (error "wrong result" r) ) )
+
diff --git a/benchmarks/tak.scm b/benchmarks/tak.scm
new file mode 100644
index 00000000..48d2e40d
--- /dev/null
+++ b/benchmarks/tak.scm
@@ -0,0 +1,11 @@
+;;;; tak.scm
+
+
+(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) ) ) )
+
+(time (do ((i 100 (- i 1))) ((zero? i)) (tak 18 12 6)))
diff --git a/benchmarks/takl.scm b/benchmarks/takl.scm
new file mode 100644
index 00000000..e467756a
--- /dev/null
+++ b/benchmarks/takl.scm
@@ -0,0 +1,30 @@
+;;;; takl.scm
+
+
+(define (listn n)
+ (if (= 0 n)
+ '()
+ (cons n (listn (- n 1)))) )
+
+(define 18l (listn 18))
+(define 12l (listn 12))
+(define 6l (listn 6))
+
+(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 (pair? y)
+ (or (null? x)
+ (shorterp (cdr x)
+ (cdr y)))) )
+
+(time (do ((i 10 (- i 1))) ((zero? i)) (mas 18l 12l 6l)))
+
diff --git a/benchmarks/takr.scm b/benchmarks/takr.scm
new file mode 100644
index 00000000..7f378f82
--- /dev/null
+++ b/benchmarks/takr.scm
@@ -0,0 +1,507 @@
+;;; takr.scm
+
+
+(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)))))
+
+(time (do ((i 100 (- i 1))) ((zero? i)) (tak0 18 12 6)))
+
diff --git a/benchmarks/traverse.scm b/benchmarks/traverse.scm
new file mode 100644
index 00000000..fe9d5099
--- /dev/null
+++ b/benchmarks/traverse.scm
@@ -0,0 +1,145 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; File: traverse.sc
+;;; Description: TRAVERSE benchmark
+;;; Author: Richard Gabriel
+;;; Created: 12-Apr-85
+;;; Modified: 12-Apr-85 10:24:04 (Bob Shaw)
+;;; 9-Aug-87 (Will Clinger)
+;;; 20-Nov-94 (Qobi)
+;;; 31-Mar-98 (Qobi)
+;;; 26-Mar-00 (flw)
+;;; Language: Scheme
+;;; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; TRAVERSE -- Benchmark which creates and traverses a tree structure.
+
+(define (make-node)
+ (let ((node (make-vector 11 '())))
+ (vector-set! node 0 'node)
+ (vector-set! node 3 (snb))
+ (vector-set! node 4 #f) ;Qobi
+ (vector-set! node 5 #f) ;Qobi
+ (vector-set! node 6 #f) ;Qobi
+ (vector-set! node 7 #f) ;Qobi
+ (vector-set! node 8 #f) ;Qobi
+ (vector-set! node 9 #f) ;Qobi
+ (vector-set! node 10 #f) ;Qobi
+ node))
+
+ (define (node-parents node) (vector-ref node 1))
+ (define (node-sons node) (vector-ref node 2))
+ (define (node-sn node) (vector-ref node 3))
+ (define (node-entry1 node) (vector-ref node 4))
+ (define (node-entry2 node) (vector-ref node 5))
+ (define (node-entry3 node) (vector-ref node 6))
+ (define (node-entry4 node) (vector-ref node 7))
+ (define (node-entry5 node) (vector-ref node 8))
+ (define (node-entry6 node) (vector-ref node 9))
+ (define (node-mark node) (vector-ref node 10))
+
+ (define (node-parents-set! node v) (vector-set! node 1 v))
+ (define (node-sons-set! node v) (vector-set! node 2 v))
+ (define (node-sn-set! node v) (vector-set! node 3 v))
+ (define (node-entry1-set! node v) (vector-set! node 4 v))
+ (define (node-entry2-set! node v) (vector-set! node 5 v))
+ (define (node-entry3-set! node v) (vector-set! node 6 v))
+ (define (node-entry4-set! node v) (vector-set! node 7 v))
+ (define (node-entry5-set! node v) (vector-set! node 8 v))
+ (define (node-entry6-set! node v) (vector-set! node 9 v))
+ (define (node-mark-set! node v) (vector-set! node 10 v))
+
+ (define *sn* 0)
+ (define *rand* 21)
+ (define *count* 0)
+ (define *marker* #f)
+ (define *root* '())
+
+ (define (snb)
+ (set! *sn* (+ 1 *sn*))
+ *sn*)
+
+ (define (seed)
+ (set! *rand* 21)
+ *rand*)
+
+ (define (traverse-random)
+ (set! *rand* (remainder (* *rand* 17) 251))
+ *rand*)
+
+ (define (traverse-remove n q)
+ (cond ((eq? (cdr (car q)) (car q)) (let ((x (caar q))) (set-car! q '()) x))
+ ((zero? n)
+ (let ((x (caar q)))
+ (do ((p (car q) (cdr p)))
+ ((eq? (cdr p) (car q))
+ (set-cdr! p (cdr (car q)))
+ (set-car! q p)))
+ x))
+ (else (do ((n n (- n 1)) (q (car q) (cdr q)) (p (cdr (car q)) (cdr p)))
+ ((zero? n) (let ((x (car q))) (set-cdr! q p) x))))))
+
+ (define (traverse-select n q)
+ (do ((n n (- n 1)) (q (car q) (cdr q))) ((zero? n) (car q))))
+
+ (define (add a q)
+ (cond ((null? q) `(,(let ((x `(,a))) (set-cdr! x x) x)))
+ ((null? (car q))
+ (let ((x `(,a)))
+ (set-cdr! x x)
+ (set-car! q x)
+ q))
+ ;; the CL version had a useless set-car! in the next line (wc)
+ (else (set-cdr! (car q) `(,a . ,(cdr (car q)))) q)))
+
+ (define (create-structure n)
+ (let ((a `(,(make-node))))
+ (do ((m (- n 1) (- m 1)) (p a))
+ ((zero? m)
+ (set! a `(,(begin (set-cdr! p a) p)))
+ (do ((unused a) (used (add (traverse-remove 0 a) '())) (x 0) (y 0))
+ ((null? (car unused)) (find-root (traverse-select 0 used) n))
+ (set! x (traverse-remove (remainder (traverse-random) n) unused))
+ (set! y (traverse-select (remainder (traverse-random) n) used))
+ (add x used)
+ (node-sons-set! y `(,x . ,(node-sons y)))
+ (node-parents-set! x `(,y . ,(node-parents x))) ))
+ (set! a (cons (make-node) a)))))
+
+ (define (find-root node n)
+ (do ((n n (- n 1))) ((or (zero? n) (null? (node-parents node))) node)
+ (set! node (car (node-parents node)))))
+
+ (define (travers node mark)
+ (cond ((eq? (node-mark node) mark) #f)
+ (else (node-mark-set! node mark)
+ (set! *count* (+ 1 *count*))
+ (node-entry1-set! node (not (node-entry1 node)))
+ (node-entry2-set! node (not (node-entry2 node)))
+ (node-entry3-set! node (not (node-entry3 node)))
+ (node-entry4-set! node (not (node-entry4 node)))
+ (node-entry5-set! node (not (node-entry5 node)))
+ (node-entry6-set! node (not (node-entry6 node)))
+ (do ((sons (node-sons node) (cdr sons))) ((null? sons) #f)
+ (travers (car sons) mark)))))
+
+ (define (traverse root)
+ (let ((*count* 0))
+ (travers root (begin (set! *marker* (not *marker*)) *marker*))
+ *count*))
+
+ (define (init-traverse) ; Changed from defmacro to defun \bs
+ (set! *root* (create-structure 100))
+ #f)
+
+ (define (run-traverse) ; Changed from defmacro to defun \bs
+ (do ((i 50 (- i 1))) ((zero? i))
+ (traverse *root*)
+ (traverse *root*)
+ (traverse *root*)
+ (traverse *root*)
+ (traverse *root*)))
+
+(init-traverse)
+
+(time (run-traverse))
diff --git a/benchmarks/travinit.scm b/benchmarks/travinit.scm
new file mode 100644
index 00000000..7a853bf1
--- /dev/null
+++ b/benchmarks/travinit.scm
@@ -0,0 +1,143 @@
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; File: traverse-init.sc
+;;; Description: TRAVERSE benchmark
+;;; Author: Richard Gabriel
+;;; Created: 12-Apr-85
+;;; Modified: 12-Apr-85 10:24:04 (Bob Shaw)
+;;; 9-Aug-87 (Will Clinger)
+;;; 20-Nov-94 (Qobi)
+;;; 31-Mar-98 (Qobi)
+;;; 26-Mar-00 (flw)
+;;; Language: Scheme
+;;; Status: Public Domain
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; TRAVERSE -- Benchmark which creates and traverses a tree structure.
+
+(define (make-node)
+ (let ((node (make-vector 11 '())))
+ (vector-set! node 0 'node)
+ (vector-set! node 3 (snb))
+ (vector-set! node 4 #f) ;Qobi
+ (vector-set! node 5 #f) ;Qobi
+ (vector-set! node 6 #f) ;Qobi
+ (vector-set! node 7 #f) ;Qobi
+ (vector-set! node 8 #f) ;Qobi
+ (vector-set! node 9 #f) ;Qobi
+ (vector-set! node 10 #f) ;Qobi
+ node))
+
+ (define (node-parents node) (vector-ref node 1))
+ (define (node-sons node) (vector-ref node 2))
+ (define (node-sn node) (vector-ref node 3))
+ (define (node-entry1 node) (vector-ref node 4))
+ (define (node-entry2 node) (vector-ref node 5))
+ (define (node-entry3 node) (vector-ref node 6))
+ (define (node-entry4 node) (vector-ref node 7))
+ (define (node-entry5 node) (vector-ref node 8))
+ (define (node-entry6 node) (vector-ref node 9))
+ (define (node-mark node) (vector-ref node 10))
+
+ (define (node-parents-set! node v) (vector-set! node 1 v))
+ (define (node-sons-set! node v) (vector-set! node 2 v))
+ (define (node-sn-set! node v) (vector-set! node 3 v))
+ (define (node-entry1-set! node v) (vector-set! node 4 v))
+ (define (node-entry2-set! node v) (vector-set! node 5 v))
+ (define (node-entry3-set! node v) (vector-set! node 6 v))
+ (define (node-entry4-set! node v) (vector-set! node 7 v))
+ (define (node-entry5-set! node v) (vector-set! node 8 v))
+ (define (node-entry6-set! node v) (vector-set! node 9 v))
+ (define (node-mark-set! node v) (vector-set! node 10 v))
+
+ (define *sn* 0)
+ (define *rand* 21)
+ (define *count* 0)
+ (define *marker* #f)
+ (define *root* '())
+
+ (define (snb)
+ (set! *sn* (+ 1 *sn*))
+ *sn*)
+
+ (define (seed)
+ (set! *rand* 21)
+ *rand*)
+
+ (define (traverse-random)
+ (set! *rand* (remainder (* *rand* 17) 251))
+ *rand*)
+
+ (define (traverse-remove n q)
+ (cond ((eq? (cdr (car q)) (car q)) (let ((x (caar q))) (set-car! q '()) x))
+ ((zero? n)
+ (let ((x (caar q)))
+ (do ((p (car q) (cdr p)))
+ ((eq? (cdr p) (car q))
+ (set-cdr! p (cdr (car q)))
+ (set-car! q p)))
+ x))
+ (else (do ((n n (- n 1)) (q (car q) (cdr q)) (p (cdr (car q)) (cdr p)))
+ ((zero? n) (let ((x (car q))) (set-cdr! q p) x))))))
+
+ (define (traverse-select n q)
+ (do ((n n (- n 1)) (q (car q) (cdr q))) ((zero? n) (car q))))
+
+ (define (add a q)
+ (cond ((null? q) `(,(let ((x `(,a))) (set-cdr! x x) x)))
+ ((null? (car q))
+ (let ((x `(,a)))
+ (set-cdr! x x)
+ (set-car! q x)
+ q))
+ ;; the CL version had a useless set-car! in the next line (wc)
+ (else (set-cdr! (car q) `(,a . ,(cdr (car q)))) q)))
+
+ (define (create-structure n)
+ (let ((a `(,(make-node))))
+ (do ((m (- n 1) (- m 1)) (p a))
+ ((zero? m)
+ (set! a `(,(begin (set-cdr! p a) p)))
+ (do ((unused a) (used (add (traverse-remove 0 a) '())) (x 0) (y 0))
+ ((null? (car unused)) (find-root (traverse-select 0 used) n))
+ (set! x (traverse-remove (remainder (traverse-random) n) unused))
+ (set! y (traverse-select (remainder (traverse-random) n) used))
+ (add x used)
+ (node-sons-set! y `(,x . ,(node-sons y)))
+ (node-parents-set! x `(,y . ,(node-parents x))) ))
+ (set! a (cons (make-node) a)))))
+
+ (define (find-root node n)
+ (do ((n n (- n 1))) ((or (zero? n) (null? (node-parents node))) node)
+ (set! node (car (node-parents node)))))
+
+ (define (travers node mark)
+ (cond ((eq? (node-mark node) mark) #f)
+ (else (node-mark-set! node mark)
+ (set! *count* (+ 1 *count*))
+ (node-entry1-set! node (not (node-entry1 node)))
+ (node-entry2-set! node (not (node-entry2 node)))
+ (node-entry3-set! node (not (node-entry3 node)))
+ (node-entry4-set! node (not (node-entry4 node)))
+ (node-entry5-set! node (not (node-entry5 node)))
+ (node-entry6-set! node (not (node-entry6 node)))
+ (do ((sons (node-sons node) (cdr sons))) ((null? sons) #f)
+ (travers (car sons) mark)))))
+
+ (define (traverse root)
+ (let ((*count* 0))
+ (travers root (begin (set! *marker* (not *marker*)) *marker*))
+ *count*))
+
+ (define (init-traverse) ; Changed from defmacro to defun \bs
+ (set! *root* (create-structure 100))
+ #f)
+
+ (define (run-traverse) ; Changed from defmacro to defun \bs
+ (do ((i 50 (- i 1))) ((zero? i))
+ (traverse *root*)
+ (traverse *root*)
+ (traverse *root*)
+ (traverse *root*)
+ (traverse *root*)))
+
+(time (init-traverse))
diff --git a/benchmarks/triangl.scm b/benchmarks/triangl.scm
new file mode 100644
index 00000000..7935c2d3
--- /dev/null
+++ b/benchmarks/triangl.scm
@@ -0,0 +1,57 @@
+;;; TRIANGL -- Board game benchmark.
+
+(define *board*
+ (list->vector '(1 1 1 1 1 0 1 1 1 1 1 1 1 1 1 1)))
+
+(define *sequence*
+ (list->vector '(0 0 0 0 0 0 0 0 0 0 0 0 0 0)))
+
+(define *a*
+ (list->vector '(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)))
+
+(define *b*
+ (list->vector '(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)))
+
+(define *c*
+ (list->vector '(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)))
+
+(define *answer* '())
+
+(define (attempt i depth)
+ (cond ((= depth 14)
+ (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) (attempt 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) #f)
+ (else #f)))
+
+(define (test)
+ (set! *answer* '())
+ (attempt 22 1)
+ (car *answer*))
+
+(let ((result (time (test))))
+ (if (not (equal? result
+ '(22 34 31 15 7 1 20 17 25 6 5 13 32)))
+ (error "wrong result" result) ) )
+
diff --git a/bootstrap.tar.gz b/bootstrap.tar.gz
new file mode 100644
index 00000000..128bacbb
Binary files /dev/null and b/bootstrap.tar.gz differ
diff --git a/buildbinaryversion b/buildbinaryversion
new file mode 100644
index 00000000..56a6051c
--- /dev/null
+++ b/buildbinaryversion
@@ -0,0 +1 @@
+1
\ No newline at end of file
diff --git a/buildversion b/buildversion
new file mode 100644
index 00000000..078bf8b7
--- /dev/null
+++ b/buildversion
@@ -0,0 +1 @@
+4.2.2
\ No newline at end of file
diff --git a/c-backend.scm b/c-backend.scm
new file mode 100644
index 00000000..d8f3bd0e
--- /dev/null
+++ b/c-backend.scm
@@ -0,0 +1,1402 @@
+;;; c-backend.scm - C-generating backend for the CHICKEN compiler
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare (unit backend))
+
+
+(include "compiler-namespace")
+(include "tweaks")
+
+
+;;; Write atoms to output-port:
+
+(define output #f)
+
+(define (gen . data)
+ (for-each
+ (lambda (x)
+ (if (eq? #t x)
+ (newline output)
+ (display x output) ) )
+ data) )
+
+(define (gen-list lst)
+ (for-each
+ (lambda (x) (display x output))
+ (intersperse lst #\space) ) )
+
+
+;;; Unique id/prefix:
+
+(define unique-id
+ (string->c-identifier
+ (sprintf "C_~X_~A_" (random #x1000000) (current-seconds)) ) )
+
+
+;;; Generate target code:
+
+(define (generate-code literals lliterals lambdas out source-file dynamic db)
+ (let ()
+
+ ;; Some helper procedures
+
+ (define (find-lambda id)
+ (or (find (lambda (ll) (eq? id (lambda-literal-id ll))) lambdas)
+ (bomb "can't find lambda" id) ) )
+
+ (define (slashify s) (string-translate (->string s) "\\" "/"))
+ (define (uncommentify s) (string-translate* (->string s) '(("*/" . "* /"))))
+
+ ;; Compile a single expression
+ (define (expression node temps ll)
+
+ (define (expr n i)
+ (let ((subs (node-subexpressions n))
+ (params (node-parameters n)) )
+ (case (node-class n)
+
+ ((##core#immediate)
+ (case (first params)
+ ((bool) (gen (if (second params) "C_SCHEME_TRUE" "C_SCHEME_FALSE")))
+ ((char) (gen "C_make_character(" (char->integer (second params)) #\)))
+ ((nil) (gen "C_SCHEME_END_OF_LIST"))
+ ((fix) (gen "C_fix(" (second params) #\)))
+ ((eof) (gen "C_SCHEME_END_OF_FILE"))
+ (else (bomb "bad immediate")) ) )
+
+ ((##core#literal)
+ (let ((lit (first params)))
+ (if (vector? lit)
+ (gen "((C_word)li" (vector-ref lit 0) ")")
+ (gen "lf[" (first params) #\])) ) )
+
+ ((if)
+ (gen #t "if(C_truep(")
+ (expr (car subs) i)
+ (gen ")){")
+ (expr (cadr subs) i)
+ (gen #\} #t "else{")
+ (expr (caddr subs) i)
+ (gen #\}) )
+
+ ((##core#proc)
+ (gen "(C_word)" (first params)) )
+
+ ((##core#bind)
+ (let loop ((bs subs) (i i) (count (first params)))
+ (cond [(> count 0)
+ (gen #t #\t i #\=)
+ (expr (car bs) i)
+ (gen #\;)
+ (loop (cdr bs) (add1 i) (sub1 count)) ]
+ [else (expr (car bs) i)] ) ) )
+
+ ((##core#ref)
+ (gen "((C_word*)")
+ (expr (car subs) i)
+ (gen ")[" (+ (first params) 1) #\]) )
+
+ ((##core#unbox)
+ (gen "((C_word*)")
+ (expr (car subs) i)
+ (gen ")[1]") )
+
+ ((##core#update_i)
+ (gen "C_set_block_item(")
+ (expr (car subs) i)
+ (gen #\, (first params) #\,)
+ (expr (cadr subs) i)
+ (gen #\)) )
+
+ ((##core#update)
+ (gen "C_mutate(((C_word *)")
+ (expr (car subs) i)
+ (gen ")+" (+ (first params) 1) ",")
+ (expr (cadr subs) i)
+ (gen #\)) )
+
+ ((##core#updatebox_i)
+ (gen "C_set_block_item(")
+ (expr (car subs) i)
+ (gen ",0,")
+ (expr (cadr subs) i)
+ (gen #\)) )
+
+ ((##core#updatebox)
+ (gen "C_mutate(((C_word *)")
+ (expr (car subs) i)
+ (gen ")+1,")
+ (expr (cadr subs) i)
+ (gen #\)) )
+
+ ((##core#closure)
+ (let ((n (first params)))
+ (gen "(*a=C_CLOSURE_TYPE|" n #\,)
+ (for-each
+ (lambda (x j)
+ (gen "a[" j "]=")
+ (expr x i)
+ (gen #\,) )
+ subs (iota n 1 1) )
+ (gen "tmp=(C_word)a,a+=" (add1 n) ",tmp)") ) )
+
+ ((##core#box)
+ (gen "(*a=C_VECTOR_TYPE|1,a[1]=")
+ (expr (car subs) i)
+ (gen ",tmp=(C_word)a,a+=2,tmp)") )
+
+ ((##core#local) (gen #\t (first params)))
+
+ ((##core#setlocal)
+ (gen #\t (first params) #\=)
+ (expr (car subs) i) )
+
+ ((##core#global)
+ (let ((index (first params))
+ (safe (second params))
+ (block (third params)) )
+ (cond [block
+ (if safe
+ (gen "lf[" index "]")
+ (gen "C_retrieve2(lf[" index "]," (c-ify-string (symbol->string (fourth params))) #\)) ) ]
+ [safe (gen "*((C_word*)lf[" index "]+1)")]
+ [else (gen "C_retrieve(lf[" index "])")] ) ) )
+
+ ((##core#setglobal)
+ (let ((index (first params))
+ (block (second params))
+ (var (third params)))
+ (if block
+ (gen "C_mutate(&lf[" index "]")
+ (gen "C_mutate((C_word*)lf[" index "]+1") )
+ (gen " /* (set! " (uncommentify (symbol->string var)) " ...) */,")
+ (expr (car subs) i)
+ (gen #\)) ) )
+
+ ((##core#setglobal_i)
+ (let ((index (first params))
+ (block (second params))
+ (var (third params)) )
+ (cond [block
+ (gen "lf[" index "] /* "
+ (uncommentify (symbol->string var)) " */ =")
+ (expr (car subs) i)
+ (gen #\;) ]
+ [else
+ (gen "C_set_block_item(lf[" index "] /* "
+ (uncommentify (symbol->string var)) " */,0,")
+ (expr (car subs) i)
+ (gen #\)) ] ) ) )
+
+ ((##core#undefined) (gen "C_SCHEME_UNDEFINED"))
+
+ ((##core#call)
+ (let* ((args (cdr subs))
+ (n (length args))
+ (nc i)
+ (nf (add1 n))
+ (p2 (pair? (cdr params)))
+ (name (and p2 (second params)))
+ (name-str (source-info->string name))
+ (call-id (and p2 (pair? (cddr params)) (third params)))
+ (customizable (and call-id (fourth params)))
+ (empty-closure (and customizable (zero? (lambda-literal-closure-size (find-lambda call-id)))))
+ (fn (car subs)) )
+ (when name
+ (if emit-trace-info
+ (gen #t "C_trace(\"" (slashify name-str) "\");")
+ (gen #t "/* " (uncommentify name-str) " */") ) )
+ (cond ((eq? '##core#proc (node-class fn))
+ (let ([fpars (node-parameters fn)])
+ (gen #t (first fpars) #\( nf ",0,") )
+ (expr-args args i)
+ (gen ");") )
+ (call-id
+ (cond ((and (eq? call-id (lambda-literal-id ll))
+ (lambda-literal-looping ll) )
+ (let* ([temps (lambda-literal-temporaries ll)]
+ [ts (iota n (+ temps nf) 1)] )
+ (for-each
+ (lambda (arg tr)
+ (gen #t #\t tr #\=)
+ (expr arg i)
+ (gen #\;) )
+ args ts)
+ (for-each
+ (lambda (from to) (gen #t #\t to "=t" from #\;))
+ ts (iota n 1 1) )
+ (unless customizable (gen #t "c=" nf #\;))
+ (gen #t "goto loop;") ) )
+ (else
+ (unless empty-closure
+ (gen #t #\t nc #\=)
+ (expr fn i)
+ (gen #\;) )
+ (gen #t call-id #\()
+ (unless customizable (gen nf #\,))
+ (unless empty-closure (gen #\t nc #\,))
+ (expr-args args i)
+ (gen ");") ) ) )
+ ((and (eq? '##core#global (node-class fn))
+ (not unsafe)
+ (not no-procedure-checks)
+ (not (first params)))
+ (let* ((gparams (node-parameters fn))
+ (index (first gparams))
+ (safe (second gparams))
+ (block (third gparams))
+ (carg #f))
+ (gen #t "((C_proc" nf ")")
+ (cond (block
+ (set! carg (string-append "lf[" (number->string index) "]"))
+ (if safe
+ (gen "C_retrieve_proc(" carg ")")
+ (gen "C_retrieve2_symbol_proc(" carg ","
+ (c-ify-string (symbol->string (fourth gparams))) #\)) ) )
+ (safe
+ (set! carg
+ (string-append "*((C_word*)lf[" (number->string index) "]+1)"))
+ (gen "C_retrieve_proc(" carg ")"))
+ (else
+ (set! carg
+ (string-append "*((C_word*)lf[" (number->string index) "]+1)"))
+ (gen "C_retrieve_symbol_proc(lf[" index "])") ))
+ (gen ")(" nf #\, carg #\,)
+ (expr-args args i)
+ (gen ");") ) )
+ (else
+ (gen #t #\t nc #\=)
+ (expr fn i)
+ (gen #\; #t
+ "((C_proc" nf ")")
+ (if (or unsafe no-procedure-checks (first params))
+ (gen "(void*)(*((C_word*)t" nc "+1))")
+ (gen "C_retrieve_proc(t" nc ")") )
+ (gen ")(" nf ",t" nc #\,)
+ (expr-args args i)
+ (gen ");") ) ) ) )
+
+ ((##core#recurse)
+ (let* ([n (length subs)]
+ [nf (add1 n)]
+ [tailcall (first params)]
+ [call-id (second params)]
+ [empty-closure (zero? (lambda-literal-closure-size ll))] )
+ (cond (tailcall
+ (let* ([temps (lambda-literal-temporaries ll)]
+ [ts (iota n (+ temps nf) 1)] )
+ (for-each
+ (lambda (arg tr)
+ (gen #t #\t tr #\=)
+ (expr arg i)
+ (gen #\;) )
+ subs ts)
+ (for-each
+ (lambda (from to) (gen #t #\t to "=t" from #\;))
+ ts (iota n 1 1) )
+ (gen #t "goto loop;") ) )
+ (else
+ (gen call-id #\()
+ (unless empty-closure (gen "t0,"))
+ (expr-args subs i)
+ (gen #\)) ) ) ) )
+
+ ((##core#direct_call)
+ (let* ((args (cdr subs))
+ (n (length args))
+ (nf (add1 n))
+ ;;(name (second params))
+ (call-id (third params))
+ (demand (fourth params))
+ (allocating (not (zero? demand)))
+ (empty-closure (zero? (lambda-literal-closure-size (find-lambda call-id))))
+ (fn (car subs)) )
+ (gen call-id #\()
+ (when allocating
+ (gen "C_a_i(&a," demand #\))
+ (when (or (not empty-closure) (pair? args)) (gen #\,)) )
+ (unless empty-closure
+ (expr fn i)
+ (when (pair? args) (gen #\,)) )
+ (when (pair? args) (expr-args args i))
+ (gen #\)) ) )
+
+ ((##core#callunit)
+ ;; The code generated here does not use the extra temporary needed for standard calls, so we have
+ ;; one unused varable:
+ (let* ((n (length subs))
+ (nf (+ n 1)) )
+ (gen #t "C_" (first params) "_toplevel(" nf ",C_SCHEME_UNDEFINED,")
+ (expr-args subs i)
+ (gen ");") ) )
+
+ ((##core#return)
+ (gen #t "return(")
+ (expr (first subs) i)
+ (gen ");") )
+
+ ((##core#inline)
+ (gen "(C_word)" (first params) #\()
+ (expr-args subs i)
+ (gen #\)) )
+
+ ((##core#inline_allocate)
+ (gen "(C_word)" (first params) "(&a," (length subs))
+ (if (pair? subs)
+ (begin
+ (gen #\,)
+ (expr-args subs i) ) )
+ (gen #\)) )
+
+ ((##core#inline_ref)
+ (gen (foreign-result-conversion (second params) "a") (first params) #\)) )
+
+ ((##core#inline_update)
+ (let ([t (second params)])
+ (gen #\( (first params) "=(" (foreign-type-declaration t "") #\) (foreign-argument-conversion t))
+ (expr (first subs) i)
+ (gen "),C_SCHEME_UNDEFINED)") ) )
+
+ ((##core#inline_loc_ref)
+ (let ([t (first params)])
+ (gen (foreign-result-conversion t "a") "*((" (foreign-type-declaration t "") "*)C_data_pointer(")
+ (expr (first subs) i)
+ (gen ")))") ) )
+
+ ((##core#inline_loc_update)
+ (let ([t (first params)])
+ (gen "((*(" (foreign-type-declaration t "") "*)C_data_pointer(")
+ (expr (first subs) i)
+ (gen "))=" (foreign-argument-conversion t))
+ (expr (second subs) i)
+ (gen "),C_SCHEME_UNDEFINED)") ) )
+
+ ((##core#switch)
+ (gen #t "switch(")
+ (expr (first subs) i)
+ (gen "){")
+ (do ([j (first params) (sub1 j)]
+ [ps (cdr subs) (cddr ps)] )
+ ((zero? j)
+ (gen #t "default:")
+ (expr (car ps) i)
+ (gen #\}) )
+ (gen #t "case ")
+ (expr (car ps) i)
+ (gen #\:)
+ (expr (cadr ps) i) ) )
+
+ ((##core#cond)
+ (gen "(C_truep(")
+ (expr (first subs) i)
+ (gen ")?")
+ (expr (second subs) i)
+ (gen #\:)
+ (expr (third subs) i)
+ (gen #\)) )
+
+ (else (bomb "bad form")) ) ) )
+
+ (define (expr-args args i)
+ (pair-for-each
+ (lambda (xs)
+ (if (not (eq? xs args)) (gen #\,))
+ (expr (car xs) i) )
+ args) )
+
+ (expr node temps) )
+
+ (define (header)
+ (define (pad0 n)
+ (if (< n 10)
+ (string-append "0" (number->string n))
+ n) )
+ (let* ((tm (##sys#decode-seconds (current-seconds) #f))
+ (min (vector-ref tm 1))
+ (hour (vector-ref tm 2))
+ (mday (vector-ref tm 3))
+ (mon (vector-ref tm 4))
+ (year (vector-ref tm 5)) )
+ (gen "/* Generated from " source-file " by the CHICKEN compiler" #t
+ " http://www.call-with-current-continuation.org" #t
+ " " (+ 1900 year) #\- (pad0 (add1 mon)) #\- (pad0 mday) #\space (pad0 hour) #\: (pad0 min) #t
+ (string-intersperse
+ (map (cut string-append " " <> "\n")
+ (string-split (chicken-version #t) "\n") )
+ "")
+ " command line: ")
+ (gen-list compiler-arguments)
+ (gen #t)
+ (cond [unit-name (gen " unit: " unit-name)]
+ [else
+ (gen " used units: ")
+ (gen-list used-units) ] )
+ (gen #t "*/" #t #t "#include \"" target-include-file "\"")
+ (when external-protos-first
+ (generate-foreign-callback-stub-prototypes foreign-callback-stubs) )
+ (when (pair? foreign-declarations)
+ (gen #t)
+ (for-each (lambda (decl) (gen #t decl)) foreign-declarations) )
+ (unless external-protos-first
+ (generate-foreign-callback-stub-prototypes foreign-callback-stubs) ) ) )
+
+ (define (trailer)
+ (gen #t "/* end of file */" #t) )
+
+ (define (declarations)
+ (let ((n (length literals)))
+ (gen #t #t "static C_PTABLE_ENTRY *create_ptable(void);")
+ (for-each
+ (lambda (uu)
+ (gen #t "C_noret_decl(C_" uu "_toplevel)"
+ #t "C_externimport void C_ccall C_" uu "_toplevel(C_word c,C_word d,C_word k) C_noret;"))
+ used-units)
+ (unless (zero? n)
+ (gen #t #t "static C_TLS C_word lf[" n "];") )
+ (gen #t "static double C_possibly_force_alignment;")
+ (do ((i 0 (add1 i))
+ (llits lliterals (cdr llits)))
+ ((null? llits))
+ (let* ((ll (##sys#lambda-info->string (car llits)))
+ (llen (string-length ll)))
+ (gen #t "static C_char C_TLS li" i "[] C_aligned={C_lihdr("
+ (arithmetic-shift llen -16) #\,
+ (bitwise-and #xff (arithmetic-shift llen -8)) #\,
+ (bitwise-and #xff llen)
+ #\))
+ (do ((n 0 (add1 n)))
+ ((>= n llen))
+ (gen #\, (char->integer (string-ref ll n))) )
+ (do ((n (- (bitwise-and #xfffff8 (+ llen 7)) llen) (sub1 n))) ; fill up with zeros to align following entry
+ ((zero? n))
+ (gen ",0") )
+ (gen "};")))))
+
+ (define (prototypes)
+ (let ([large-signatures '()])
+ (gen #t)
+ (for-each
+ (lambda (ll)
+ (let* ([n (lambda-literal-argument-count ll)]
+ [customizable (lambda-literal-customizable ll)]
+ [empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))]
+ [varlist (intersperse (make-variable-list (if empty-closure (sub1 n) n) "t") #\,)]
+ [id (lambda-literal-id ll)]
+ [rest (lambda-literal-rest-argument ll)]
+ [rest-mode (lambda-literal-rest-argument-mode ll)]
+ [direct (lambda-literal-direct ll)]
+ [allocated (lambda-literal-allocated ll)] )
+ (when (>= n small-parameter-limit)
+ (set! large-signatures (lset-adjoin = large-signatures (add1 n))) )
+ (gen #t)
+ (for-each
+ (lambda (s)
+ (when (>= s small-parameter-limit)
+ (set! large-signatures (lset-adjoin = large-signatures (add1 s))) ) )
+ (lambda-literal-callee-signatures ll) )
+ (cond [(not (eq? 'toplevel id))
+ (gen "C_noret_decl(" id ")" #t)
+ (gen "static ")
+ (gen (if direct "C_word " "void "))
+ (if customizable
+ (gen "C_fcall ")
+ (gen "C_ccall ") )
+ (gen id) ]
+ [else
+ (let ((uname (if unit-name (string-append unit-name "_toplevel") "toplevel")))
+ (gen "C_noret_decl(C_" uname ")" #t)
+ (when emit-unsafe-marker
+ (gen "C_externexport void C_dynamic_and_unsafe(void) {}" #t) )
+ (gen "C_externexport void C_ccall ")
+ (gen "C_" uname) ) ] )
+ (gen #\()
+ (unless customizable (gen "C_word c,"))
+ (when (and direct (not (zero? allocated)))
+ (gen "C_word *a")
+ (when (pair? varlist) (gen #\,)) )
+ (apply gen varlist)
+ (cond [rest
+ (gen ",...) C_noret;")
+ (if (not (eq? rest-mode 'none))
+ (begin
+ (gen #t "C_noret_decl(" id ")"
+ #t "static void C_ccall " id "r(")
+ (apply gen varlist)
+ (gen ",C_word t" (+ n 1) ") C_noret;") ) ) ]
+ [else
+ (gen #\))
+ ;;(when customizable (gen " C_c_regparm"))
+ (unless direct (gen " C_noret"))
+ (gen #\;) ] ) ) )
+ lambdas)
+ (for-each
+ (lambda (s)
+ (gen #t "typedef void (*C_proc" s ")(C_word")
+ (for-each gen (make-list s ",C_word"))
+ (gen ") C_noret;") )
+ large-signatures) ) )
+
+ (define (trampolines)
+ (let ([ns '()]
+ [nsr '()]
+ [nsrv '()] )
+
+ (define (restore n)
+ (do ((i (- n 1) (- i 1))
+ (j 0 (+ j 1)) )
+ ((negative? i))
+ (gen #t "C_word t" i "=C_pick(" j ");") )
+ (gen #t "C_adjust_stack(-" n ");") )
+
+ (define (emitter vflag)
+ (lambda (n)
+ (gen #t #t "C_noret_decl(tr" n #\r (if vflag #\v "") ")"
+ #t "static void C_fcall tr" n #\r (if vflag #\v ""))
+ (gen "(C_proc" n " k) C_regparm C_noret;")
+ (gen #t "C_regparm static void C_fcall tr" n #\r)
+ (when vflag (gen #\v))
+ (gen "(C_proc" n " k){"
+ #t "int n;"
+ #t "C_word *a,t" n #\;)
+ (restore n)
+ (gen #t "n=C_rest_count(0);")
+ (if vflag
+ (gen #t "a=C_alloc(n+1);")
+ (gen #t "a=C_alloc(n*3);") )
+ (gen #t #\t n "=C_restore_rest")
+ (when vflag (gen "_vector"))
+ (gen "(a,n);")
+ (gen #t "(k)(")
+ (apply gen (intersperse (make-argument-list (+ n 1) "t") #\,))
+ (gen ");}") ) )
+
+ (for-each
+ (lambda (ll)
+ (let* ([argc (lambda-literal-argument-count ll)]
+ [rest (lambda-literal-rest-argument ll)]
+ [rest-mode (lambda-literal-rest-argument-mode ll)]
+ [id (lambda-literal-id ll)]
+ [customizable (lambda-literal-customizable ll)]
+ [empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))] )
+ (when empty-closure (set! argc (sub1 argc)))
+ (unless (lambda-literal-direct ll)
+ (cond [customizable
+ (gen #t #t "C_noret_decl(tr" id ")"
+ #t "static void C_fcall tr" id "(void *dummy) C_regparm C_noret;")
+ (gen #t "C_regparm static void C_fcall tr" id "(void *dummy){")
+ (restore argc)
+ (gen #t id #\()
+ (let ([al (make-argument-list argc "t")])
+ (apply gen (intersperse al #\,)) )
+ (gen ");}") ]
+ [(or rest (> (lambda-literal-allocated ll) 0) (lambda-literal-external ll))
+ (if (and rest (not (eq? rest-mode 'none)))
+ (if (eq? rest-mode 'vector)
+ (set! nsrv (lset-adjoin = nsrv argc))
+ (set! nsr (lset-adjoin = nsr argc)) )
+ (set! ns (lset-adjoin = ns argc)) ) ] ) ) ) )
+ lambdas)
+ (for-each
+ (lambda (n)
+ (gen #t #t "C_noret_decl(tr" n ")"
+ #t "static void C_fcall tr" n "(C_proc" n " k) C_regparm C_noret;")
+ (gen #t "C_regparm static void C_fcall tr" n "(C_proc" n " k){")
+ (restore n)
+ (gen #t "(k)(" n #\,)
+ (apply gen (intersperse (make-argument-list n "t") #\,))
+ (gen ");}") )
+ ns)
+ (for-each (emitter #f) nsr)
+ (for-each (emitter #t) nsrv) ) )
+
+ (define (literal-frame)
+ (do ([i 0 (add1 i)]
+ [lits literals (cdr lits)] )
+ ((null? lits))
+ (gen-lit (car lits) (sprintf "lf[~s]" i)) ) )
+
+ (define (bad-literal lit)
+ (bomb "type of literal not supported" lit) )
+
+ (define (literal-size lit)
+ (cond [(immediate? lit) 0]
+ [(string? lit) 0]
+ [(number? lit) words-per-flonum]
+ [(symbol? lit) 10] ; size of symbol, and possibly a bucket
+ [(pair? lit) (+ 3 (literal-size (car lit)) (literal-size (cdr lit)))]
+ [(vector? lit) (+ 1 (vector-length lit) (reduce + 0 (map literal-size (vector->list lit))))]
+ [(block-variable-literal? lit) 0]
+ [(##sys#immediate? lit) (bad-literal lit)]
+ [(##core#inline "C_lambdainfop" lit) 0]
+ [(##sys#bytevector? lit) (+ 2 (words (##sys#size lit))) ] ; drops "permanent" property!
+ [(##sys#generic-structure? lit)
+ (let ([n (##sys#size lit)])
+ (let loop ([i 0] [s (+ 2 n)])
+ (if (>= i n)
+ s
+ (loop (add1 i) (+ s (literal-size (##sys#slot lit i)))) ) ) ) ]
+ [else (bad-literal lit)] ) )
+
+ (define (gen-lit lit to)
+ ;; we do simple immediate literals directly to avoid a function call:
+ (cond ((and (fixnum? lit) (not (big-fixnum? lit)))
+ (gen #t to "=C_fix(" lit ");") )
+ ((block-variable-literal? lit))
+ ((eq? lit (void))
+ (gen #t to "=C_SCHEME_UNDEFINED;") )
+ ((boolean? lit)
+ (gen #t to #\= (if lit "C_SCHEME_TRUE" "C_SCHEME_FALSE") #\;) )
+ ((char? lit)
+ (gen #t to "=C_make_character(" (char->integer lit) ");") )
+ ((symbol? lit) ; handled slightly specially (see C_h_intern_in)
+ (let* ([str (##sys#slot lit 1)]
+ [cstr (c-ify-string str)]
+ [len (##sys#size str)] )
+ (gen #t to "=")
+ (gen "C_h_intern(&" to #\, len #\, cstr ");") ) )
+ ((null? lit)
+ (gen #t to "=C_SCHEME_END_OF_LIST;") )
+ ((and (not (##sys#immediate? lit))
+ (##core#inline "C_lambdainfop" lit)))
+ ((or (fixnum? lit) (not (##sys#immediate? lit)))
+ (gen #t to "=C_decode_literal(C_heaptop,")
+ (gen-string-constant (encode-literal lit))
+ (gen ");") )
+ (else (bad-literal lit))))
+
+ (define (gen-string-constant str)
+ (let* ([len (##sys#size str)]
+ [ns (fx/ len 80)]
+ [srest (modulo len 80)] )
+ (do ([i ns (sub1 i)]
+ [offset 0 (+ offset 80)] )
+ ((zero? i)
+ (when (or (zero? len) (not (zero? srest)))
+ (gen (c-ify-string (string-like-substring str offset len))) ) )
+ (gen (c-ify-string (string-like-substring str offset (+ offset 80))) #t) ) ) )
+
+ (define (string-like-substring s start end)
+ (let* ([len (- end start)]
+ [s2 (make-string len)] )
+ (##sys#copy-bytes s s2 start 0 len)
+ s2) )
+
+ (define (procedures)
+ (for-each
+ (lambda (ll)
+ (let* ([n (lambda-literal-argument-count ll)]
+ [id (lambda-literal-id ll)]
+ [rname (real-name id db)]
+ [demand (lambda-literal-allocated ll)]
+ [rest (lambda-literal-rest-argument ll)]
+ [customizable (lambda-literal-customizable ll)]
+ [empty-closure (and customizable (zero? (lambda-literal-closure-size ll)))]
+ [nec (- n (if empty-closure 1 0))]
+ [vlist0 (make-variable-list n "t")]
+ [alist0 (make-argument-list n "t")]
+ [varlist (intersperse (if empty-closure (cdr vlist0) vlist0) #\,)]
+ [arglist (intersperse (if empty-closure (cdr alist0) alist0) #\,)]
+ [external (lambda-literal-external ll)]
+ [looping (lambda-literal-looping ll)]
+ [direct (lambda-literal-direct ll)]
+ [rest-mode (lambda-literal-rest-argument-mode ll)]
+ [temps (lambda-literal-temporaries ll)]
+ [topname (if unit-name
+ (string-append unit-name "_toplevel")
+ "toplevel") ] )
+ (when empty-closure (debugging 'o "dropping unused closure argument" id))
+ (gen #t #t)
+ (gen "/* " (cleanup rname) " */" #t)
+ (cond [(not (eq? 'toplevel id))
+ (gen "static ")
+ (gen (if direct "C_word " "void "))
+ (if customizable
+ (gen "C_fcall ")
+ (gen "C_ccall ") )
+ (gen id) ]
+ [else
+ (gen "static C_TLS int toplevel_initialized=0;")
+ (unless unit-name
+ (gen #t "C_main_entry_point") )
+ (gen #t "C_noret_decl(toplevel_trampoline)"
+ #t "static void C_fcall toplevel_trampoline(void *dummy) C_regparm C_noret;"
+ #t "C_regparm static void C_fcall toplevel_trampoline(void *dummy){"
+ #t "C_" topname "(2,C_SCHEME_UNDEFINED,C_restore);}"
+ #t #t "void C_ccall C_" topname) ] )
+ (gen #\()
+ (unless customizable (gen "C_word c,"))
+ (when (and direct (not (zero? demand)))
+ (gen "C_word *a")
+ (when (pair? varlist) (gen #\,)) )
+ (apply gen varlist)
+ (when rest (gen ",..."))
+ (gen "){")
+ (when (eq? rest-mode 'none) (set! rest #f))
+ (gen #t "C_word tmp;")
+ (if rest
+ (gen #t "C_word t" n #\;) ; To hold rest-list if demand is met
+ (do ([i n (add1 i)]
+ [j (+ temps (if looping (sub1 n) 0)) (sub1 j)] )
+ ((zero? j))
+ (gen #t "C_word t" i #\;) ) )
+ (cond [(eq? 'toplevel id)
+ (let ([ldemand (fold (lambda (lit n) (+ n (literal-size lit))) 0 literals)]
+ [llen (length literals)] )
+ (gen #t "C_word *a;"
+ #t "if(toplevel_initialized) C_kontinue(t1,C_SCHEME_UNDEFINED);"
+ #t "else C_toplevel_entry(C_text(\"" topname "\"));")
+ (when disable-stack-overflow-checking
+ (gen #t "C_disable_overflow_check=1;") )
+ (unless unit-name
+ (cond [target-initial-heap-size
+ (gen #t "C_set_or_change_heap_size(" target-initial-heap-size ",1);") ]
+ [target-heap-size
+ (gen #t "C_set_or_change_heap_size(" target-heap-size ",1);"
+ #t "C_heap_size_is_fixed=1;") ] )
+ (when target-heap-growth
+ (gen #t "C_heap_growth=" target-heap-growth #\;) )
+ (when target-heap-shrinkage
+ (gen #t "C_heap_shrinkage=" target-heap-shrinkage #\;) )
+ (when target-stack-size
+ (gen #t "C_resize_stack(" target-stack-size ");") ) )
+ (gen #t "C_check_nursery_minimum(" demand ");"
+ #t "if(!C_demand(" demand ")){"
+ #t "C_save(t1);"
+ #t "C_reclaim((void*)toplevel_trampoline,NULL);}"
+ #t "toplevel_initialized=1;")
+ (gen #t "if(!C_demand_2(" ldemand ")){"
+ #t "C_save(t1);"
+ #t "C_rereclaim2(" ldemand "*sizeof(C_word), 1);"
+ #t "t1=C_restore;}")
+ (gen #t "a=C_alloc(" demand ");")
+ (when (not (zero? llen))
+ (gen #t "C_initialize_lf(lf," llen ");")
+ (literal-frame)
+ (gen #t "C_register_lf2(lf," llen ",create_ptable());") ) ) ]
+ [rest
+ (gen #t "va_list v;")
+ (gen #t "C_word *a,c2=c;")
+ (gen #t "C_save_rest(")
+ (if (> n 0)
+ (gen #\t (- n 1))
+ (gen "c") )
+ (gen ",c2," n ");")
+ (when (and (not unsafe) (not no-argc-checks) (> n 2) (not empty-closure))
+ (gen #t "if(c<" n ") C_bad_min_argc_2(c," n ",t0);") )
+ (when insert-timer-checks (gen #t "C_check_for_interrupt;"))
+ (gen #t "if(!C_demand(c*C_SIZEOF_PAIR+" demand ")){") ]
+ [else
+ (cond [(and (not direct) (> demand 0))
+ (if looping
+ (gen #t "C_word *a;"
+ #t "loop:"
+ #t "a=C_alloc(" demand ");")
+ (gen #t "C_word ab[" demand "],*a=ab;") ) ]
+ [else
+ (unless direct (gen #t "C_word *a;"))
+ (when looping (gen #t "loop:"))
+ (when (and direct (not unsafe) (not disable-stack-overflow-checking))
+ (gen #t "C_stack_check;") ) ] )
+ (when (and external (not unsafe) (not no-argc-checks) (not customizable))
+ ;; (not customizable) implies empty-closure
+ (if (eq? rest-mode 'none)
+ (when (> n 2) (gen #t "if(c<" n ") C_bad_min_argc_2(c," n ",t0);"))
+ (gen #t "if(c!=" n ") C_bad_argc_2(c," n ",t0);") ) )
+ (when (and (not direct) (or external (> demand 0)))
+ (when insert-timer-checks (gen #t "C_check_for_interrupt;"))
+ (if (and looping (> demand 0))
+ (gen #t "if(!C_stack_probe(a)){")
+ (gen #t "if(!C_stack_probe(&a)){") ) ) ] )
+ (when (and (not (eq? 'toplevel id))
+ (not direct)
+ (or rest external (> demand 0)) )
+;; (cond [(> nec 1)
+;; (gen #t "C_adjust_stack(" nec ");")
+;; (do ([i (if empty-closure 1 0) (+ i 1)])
+;; ((>= i n))
+;; (gen #t "C_rescue(t" i #\, (- n i 1) ");") ) ]
+;; [(= nec 1) (gen #t "C_save(" (if empty-closure "t1" "t0") ");")] )
+ (cond [rest
+ (gen #t (if (> nec 0) "C_save_and_reclaim" "C_reclaim") "((void*)tr" n #\r)
+ (when (eq? rest-mode 'vector) (gen #\v))
+ (gen ",(void*)" id "r")
+ (when (> nec 0)
+ (gen #\, nec #\,)
+ (apply gen arglist) )
+ (gen ");}"
+ #t "else{"
+ #t "a=C_alloc((c-" n ")*3);")
+ (case rest-mode
+ [(list #f) (gen #t "t" n "=C_restore_rest(a,C_rest_count(0));")]
+ [(vector) (gen #t "t" n "=C_restore_rest_vector(a,C_rest_count(0));")] )
+ (gen #t id "r(")
+ (apply gen (intersperse (make-argument-list n "t") #\,))
+ (gen ",t" n ");}}")
+ ;; Create secondary routine (no demand-check or argument-count-parameter):
+ (gen #t #t "static void C_ccall " id "r(")
+ (apply gen varlist)
+ (gen ",C_word t" n "){")
+ (gen #t "C_word tmp;")
+ (do ([i (+ n 1) (+ i 1)]
+ [j temps (- j 1)] )
+ ((zero? j))
+ (gen #t "C_word t" i #\;) )
+ (when (> demand 0) (gen #t "C_word *a=C_alloc(" demand ");")) ]
+ [else
+ (gen #t (if (> nec 0) "C_save_and_reclaim" "C_reclaim") "((void*)tr")
+ (if customizable
+ (gen id ",NULL")
+ (gen n ",(void*)" id) )
+ (when (> nec 0)
+ (gen #\, nec #\,)
+ (apply gen arglist) )
+ (gen ");}") ] ) )
+ (expression
+ (lambda-literal-body ll)
+ (if rest
+ (add1 n) ; One temporary is needed to hold the rest-list
+ n)
+ ll)
+ (gen #\}) ) )
+ lambdas) )
+
+ (debugging 'p "code generation phase...")
+ (set! output out)
+ (header)
+ (declarations)
+ (generate-external-variables external-variables)
+ (generate-foreign-stubs foreign-lambda-stubs db)
+ (prototypes)
+ (generate-foreign-callback-stubs foreign-callback-stubs db)
+ (trampolines)
+ (procedures)
+ (emit-procedure-table-info lambdas source-file)
+ (trailer) ) )
+
+
+;;; Emit procedure table:
+
+(define (emit-procedure-table-info lambdas sf)
+ (gen #t #t "#ifdef C_ENABLE_PTABLES"
+ #t "static C_PTABLE_ENTRY ptable[" (add1 (length lambdas)) "] = {")
+ (do ((ll lambdas (cdr ll)))
+ ((null? ll)
+ (gen #t "{NULL,NULL}};") )
+ (let ((id (lambda-literal-id (car ll))))
+ (gen #t "{\"" id #\: (string->c-identifier sf) "\",(void*)")
+ (if (eq? 'toplevel id)
+ (if unit-name
+ (gen "C_" unit-name "_toplevel},")
+ (gen "C_toplevel},") )
+ (gen id "},") ) ) )
+ (gen #t "#endif")
+ (gen #t #t "static C_PTABLE_ENTRY *create_ptable(void)")
+ (gen "{" #t "#ifdef C_ENABLE_PTABLES"
+ #t "return ptable;"
+ #t "#else"
+ #t "return NULL;"
+ #t "#endif"
+ #t "}") )
+
+
+;;; Create name that is safe for C comments:
+
+(define (cleanup s)
+ (let ([s2 #f]
+ [len (string-length s)] )
+ (let loop ([i 0])
+ (if (>= i len)
+ (or s2 s)
+ (let ([c (string-ref s i)])
+ (if (or (char<? c #\space)
+ (char>? c #\~)
+ (and (char=? c #\*) (< i (sub1 len)) (char=? #\/ (string-ref s (add1 i)))) )
+ (begin
+ (unless s2 (set! s2 (string-copy s)))
+ (string-set! s2 i #\~) )
+ (when s2 (string-set! s2 i c)) )
+ (loop (add1 i)) ) ) ) ) )
+
+
+;;; Create list of variables/parameters, interspersed with a special token:
+
+(define (make-variable-list n prefix)
+ (list-tabulate
+ n
+ (lambda (i) (string-append "C_word " prefix (number->string i))) ) )
+
+(define (make-argument-list n prefix)
+ (list-tabulate
+ n
+ (lambda (i) (string-append prefix (number->string i))) ) )
+
+
+;;; Generate external variable declarations:
+
+(define (generate-external-variables vars)
+ (gen #t)
+ (for-each
+ (lambda (v)
+ (let ((name (vector-ref v 0))
+ (type (vector-ref v 1))
+ (exported (vector-ref v 2)) )
+ (gen #t (if exported "" "static ") (foreign-type-declaration type name) #\;) ) )
+ vars) )
+
+
+;;; Generate foreign stubs:
+
+(define (generate-foreign-callback-stub-prototypes stubs)
+ (for-each
+ (lambda (stub)
+ (gen #t)
+ (generate-foreign-callback-header "C_externexport " stub)
+ (gen #\;) )
+ stubs) )
+
+(define (generate-foreign-stubs stubs db)
+ (for-each
+ (lambda (stub)
+ (let* ([id (foreign-stub-id stub)]
+ [rname (real-name2 id db)]
+ [types (foreign-stub-argument-types stub)]
+ [n (length types)]
+ [varlist (intersperse (cons "C_word C_buf" (make-variable-list n "C_a")) #\,)]
+ [rtype (foreign-stub-return-type stub)]
+ [sname (foreign-stub-name stub)]
+ [body (foreign-stub-body stub)]
+ [names (or (foreign-stub-argument-names stub) (make-list n #f))]
+ [rconv (foreign-result-conversion rtype "C_a")]
+ [cps (foreign-stub-cps stub)]
+ [callback (foreign-stub-callback stub)] )
+ (gen #t)
+ (when rname
+ (gen #t "/* from " (cleanup rname) " */") )
+ (when body
+ (gen #t "#define return(x) C_cblock C_r = (" rconv
+ "(x))); goto C_ret; C_cblockend"))
+ (if cps
+ (gen #t "C_noret_decl(" id ")"
+ #t "static void C_ccall " id "(C_word C_c,C_word C_self,C_word C_k,")
+ (gen #t "static C_word C_fcall " id #\() )
+ (apply gen varlist)
+ (if cps
+ (gen ") C_noret;" #t "static void C_ccall " id "(C_word C_c,C_word C_self,C_word C_k,")
+ (gen ") C_regparm;" #t "C_regparm static C_word C_fcall " id #\() )
+ (apply gen varlist)
+ (gen "){")
+ (gen #t "C_word C_r=C_SCHEME_UNDEFINED,*C_a=(C_word*)C_buf;")
+ (for-each
+ (lambda (type index name)
+ (gen #t
+ (foreign-type-declaration
+ type
+ (if name (symbol->string name) (sprintf "t~a" index)) )
+ "=(" (foreign-type-declaration type "") #\)
+ (foreign-argument-conversion type) "C_a" index ");") )
+ types (iota n) names)
+ (when callback (gen #t "int C_level=C_save_callback_continuation(&C_a,C_k);"))
+ (cond [body
+ (gen #t body
+ #t "C_ret:")
+ (gen #t "#undef return" #t)
+ (cond [callback
+ (gen #t "C_k=C_restore_callback_continuation2(C_level);"
+ #t "C_kontinue(C_k,C_r);") ]
+ [cps (gen #t "C_kontinue(C_k,C_r);")]
+ [else (gen #t "return C_r;")] ) ]
+ [else
+ (if (not (eq? rtype 'void))
+ (gen #t "C_r=" rconv)
+ (gen #t) )
+ (gen sname #\()
+ (apply gen (intersperse (make-argument-list n "t") #\,))
+ (unless (eq? rtype 'void) (gen #\)))
+ (gen ");")
+ (cond [callback
+ (gen #t "C_k=C_restore_callback_continuation2(C_level);"
+ #t "C_kontinue(C_k,C_r);") ]
+ [cps (gen "C_kontinue(C_k,C_r);")]
+ [else (gen #t "return C_r;")] ) ] )
+ (gen #\}) ) )
+ stubs) )
+
+(define (generate-foreign-callback-stubs stubs db)
+ (for-each
+ (lambda (stub)
+ (let* ([id (foreign-callback-stub-id stub)]
+ [rname (real-name2 id db)]
+ [rtype (foreign-callback-stub-return-type stub)]
+ [argtypes (foreign-callback-stub-argument-types stub)]
+ [n (length argtypes)]
+ [vlist (make-argument-list n "t")] )
+
+ (define (compute-size type var ns)
+ (case type
+ [(char int int32 short bool void unsigned-short scheme-object unsigned-char unsigned-int unsigned-int32
+ byte unsigned-byte)
+ ns]
+ [(float double c-pointer unsigned-integer unsigned-integer32 long integer integer32 unsigned-long
+ nonnull-c-pointer number integer64 c-string-list c-string-list*)
+ (string-append ns "+3") ]
+ [(c-string c-string* unsigned-c-string unsigned-c-string unsigned-c-string*)
+ (string-append ns "+2+(" var "==NULL?1:C_bytestowords(C_strlen(" var ")))") ]
+ [(nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string nonnull-unsigned-c-string* symbol)
+ (string-append ns "+2+C_bytestowords(C_strlen(" var "))") ]
+ [else
+ (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type))
+ => (lambda (t)
+ (compute-size (if (vector? t) (vector-ref t 0) t) var ns) ) ]
+ [(pair? type)
+ (case (car type)
+ [(ref pointer c-pointer nonnull-pointer nonnull-c-pointer function instance
+ nonnull-instance instance-ref)
+ (string-append ns "+3") ]
+ [(const) (compute-size (cadr type) var ns)]
+ [else ns] ) ]
+ [else ns] ) ] ) )
+
+ (let ([sizestr (fold compute-size "0" argtypes vlist)])
+ (gen #t)
+ (when rname
+ (gen #t "/* from " (cleanup rname) " */") )
+ (generate-foreign-callback-header "" stub)
+ (gen #\{ #t "C_word x,s=" sizestr ",*a=C_alloc(s);")
+ (gen #t "C_callback_adjust_stack(a,s);") ; make sure content is below stack_bottom as well
+ (for-each
+ (lambda (v t)
+ (gen #t "x=" (foreign-result-conversion t "a") v ");"
+ #t "C_save(x);") )
+ vlist
+ argtypes)
+ (unless (eq? 'void rtype)
+ (gen #t "return " (foreign-argument-conversion rtype)) )
+ (gen "C_callback_wrapper((void *)" id #\, n #\))
+ (unless (eq? 'void rtype) (gen #\)))
+ (gen ";}") ) ) )
+ stubs) )
+
+(define (generate-foreign-callback-header cls stub)
+ (let* ([name (foreign-callback-stub-name stub)]
+ [quals (foreign-callback-stub-qualifiers stub)]
+ [rtype (foreign-callback-stub-return-type stub)]
+ [argtypes (foreign-callback-stub-argument-types stub)]
+ [n (length argtypes)]
+ [vlist (make-argument-list n "t")] )
+ (gen #t cls #\space (foreign-type-declaration rtype "") quals #\space name #\()
+ (pair-for-each
+ (lambda (vs ts)
+ (gen (foreign-type-declaration (car ts) (car vs)))
+ (when (pair? (cdr vs)) (gen #\,)) )
+ vlist argtypes)
+ (gen #\)) ) )
+
+
+;; Create type declarations
+
+(define (foreign-type-declaration type target)
+ (let ([err (lambda () (quit "illegal foreign type `~A'" type))]
+ [str (lambda (ts) (string-append ts " " target))] )
+ (case type
+ [(scheme-object) (str "C_word")]
+ [(char byte) (str "C_char")]
+ [(unsigned-char unsigned-byte) (str "unsigned C_char")]
+ [(unsigned-int unsigned-integer) (str "unsigned int")]
+ [(unsigned-int32 unsigned-integer32) (str "C_u32")]
+ [(int integer bool) (str "int")]
+ [(int32 integer32) (str "C_s32")]
+ [(integer64) (str "C_s64")]
+ [(short) (str "short")]
+ [(long) (str "long")]
+ [(unsigned-short) (str "unsigned short")]
+ [(unsigned-long) (str "unsigned long")]
+ [(float) (str "float")]
+ [(double number) (str "double")]
+ ;; pointer and nonnull-pointer are DEPRECATED
+ [(pointer nonnull-pointer) (str "void *")]
+ [(c-pointer nonnull-c-pointer scheme-pointer nonnull-scheme-pointer) (str "void *")]
+ [(c-string-list c-string-list*) "C_char **"]
+ ;; byte-vector and nonnull-byte-vector are DEPRECATED
+ [(byte-vector nonnull-byte-vector) (str "unsigned char *")]
+ [(blob nonnull-blob u8vector nonnull-u8vector) (str "unsigned char *")]
+ [(u16vector nonnull-u16vector) (str "unsigned short *")]
+ [(s8vector nonnull-s8vector) (str "char *")]
+ [(u32vector nonnull-u32vector) (str "unsigned int *")]
+ [(s16vector nonnull-s16vector) (str "short *")]
+ [(s32vector nonnull-s32vector) (str "int *")]
+ [(f32vector nonnull-f32vector) (str "float *")]
+ [(f64vector nonnull-f64vector) (str "double *")]
+ [(nonnull-c-string c-string nonnull-c-string* c-string* symbol)
+ (str "char *")]
+ [(nonnull-unsigned-c-string nonnull-unsigned-c-string* unsigned-c-string unsigned-c-string*)
+ (str "unsigned char *")]
+ [(void) (str "void")]
+ [else
+ (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type))
+ => (lambda (t)
+ (foreign-type-declaration (if (vector? t) (vector-ref t 0) t) target)) ]
+ [(string? type) (str type)]
+ [(list? type)
+ (let ((len (length type)))
+ (cond
+ ((and (= 2 len)
+ (memq (car type) '(pointer nonnull-pointer c-pointer
+ nonnull-c-pointer) ) )
+ (foreign-type-declaration (cadr type) (string-append "*" target)) )
+ ((and (= 2 len)
+ (eq? 'ref (car type)))
+ (foreign-type-declaration (cadr type) (string-append "&" target)) )
+ ((and (> len 2)
+ (eq? 'template (car type)))
+ (str
+ (string-append
+ (foreign-type-declaration (cadr type) "")
+ "<"
+ (string-intersperse
+ (map (cut foreign-type-declaration <> "") (cddr type))
+ ",")
+ "> ") ) )
+ ((and (= len 2) (eq? 'const (car type)))
+ (string-append "const " (foreign-type-declaration (cadr type) target)))
+ ((and (= len 2) (eq? 'struct (car type)))
+ (string-append "struct " (->string (cadr type)) " " target))
+ ((and (= len 2) (eq? 'union (car type)))
+ (string-append "union " (->string (cadr type)) " " target))
+ ((and (= len 2) (eq? 'enum (car type)))
+ (string-append "enum " (->string (cadr type)) " " target))
+ ((and (= len 3) (memq (car type) '(instance nonnull-instance)))
+ (string-append (->string (cadr type)) "*" target))
+ ((and (= len 3) (eq? 'instance-ref (car type)))
+ (string-append (->string (cadr type)) "&" target))
+ ((and (>= len 3) (eq? 'function (car type)))
+ (let ((rtype (cadr type))
+ (argtypes (caddr type))
+ (callconv (optional (cdddr type) "")))
+ (string-append
+ (foreign-type-declaration rtype "")
+ callconv
+ " (*" target ")("
+ (string-intersperse
+ (map (lambda (at)
+ (if (eq? '... at)
+ "..."
+ (foreign-type-declaration at "") ) )
+ argtypes)
+ ",")
+ ")" ) ) )
+ (else (err)) ) ) ]
+ [else (err)] ) ] ) ) )
+
+
+;; Generate expression to convert argument from Scheme data
+
+(define (foreign-argument-conversion type)
+ (let ([err (lambda () (quit "illegal foreign argument type `~A'" type))])
+ (case type
+ ((scheme-object) "(")
+ ((char unsigned-char) "C_character_code((C_word)")
+ ((byte int unsigned-int unsigned-int32 unsigned-byte) "C_unfix(")
+ ((short) "C_unfix(")
+ ((unsigned-short) "(unsigned short)C_unfix(")
+ ((unsigned-long) "C_num_to_unsigned_long(")
+ ((double number float) "C_c_double(")
+ ((integer integer32) "C_num_to_int(")
+ ((integer64) "C_num_to_int64(")
+ ((long) "C_num_to_long(")
+ ((unsigned-integer unsigned-integer32) "C_num_to_unsigned_int(")
+ ;; pointer and nonnull-pointer are DEPRECATED
+ ((pointer) "C_data_pointer_or_null(")
+ ((nonnull-pointer) "C_data_pointer(")
+ ((scheme-pointer) "C_data_pointer_or_null(")
+ ((nonnull-scheme-pointer) "C_data_pointer(")
+ ((c-pointer) "C_c_pointer_or_null(")
+ ((nonnull-c-pointer) "C_c_pointer_nn(")
+ ((blob) "C_c_bytevector_or_null(")
+ ((nonnull-blob) "C_c_bytevector(")
+ ;; byte-vector and nonnull-byte-vector are DEPRECATED
+ ((byte-vector) "C_c_bytevector_or_null(")
+ ((nonnull-byte-vector) "C_c_bytevector(")
+ ((u8vector) "C_c_u8vector_or_null(")
+ ((nonnull-u8vector) "C_c_u8vector(")
+ ((u16vector) "C_c_u16vector_or_null(")
+ ((nonnull-u16vector) "C_c_u16vector(")
+ ((u32vector) "C_c_u32vector_or_null(")
+ ((nonnull-u32vector) "C_c_u32vector(")
+ ((s8vector) "C_c_s8vector_or_null(")
+ ((nonnull-s8vector) "C_c_s8vector(")
+ ((s16vector) "C_c_s16vector_or_null(")
+ ((nonnull-s16vector) "C_c_s16vector(")
+ ((s32vector) "C_c_s32vector_or_null(")
+ ((nonnull-s32vector) "C_c_s32vector(")
+ ((f32vector) "C_c_f32vector_or_null(")
+ ((nonnull-f32vector) "C_c_f32vector(")
+ ((f64vector) "C_c_f64vector_or_null(")
+ ((nonnull-f64vector) "C_c_f64vector(")
+ ((c-string c-string* unsigned-c-string unsigned-c-string*) "C_string_or_null(")
+ ((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string
+ nonnull-unsigned-c-string* symbol) "C_c_string(")
+ ((bool) "C_truep(")
+ (else
+ (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type))
+ => (lambda (t)
+ (foreign-argument-conversion (if (vector? t) (vector-ref t 0) t)) ) ]
+ [(and (list? type) (>= (length type) 2))
+ (case (car type)
+ ;; pointer and nonnull-pointer are DEPRECATED
+ ((pointer) "C_c_pointer_or_null(")
+ ((nonnull-pointer) "C_c_pointer_nn(")
+ ((c-pointer) "C_c_pointer_or_null(")
+ ((nonnull-c-pointer) "C_c_pointer_nn(")
+ ((instance) "C_c_pointer_or_null(")
+ ((nonnull-instance) "C_c_pointer_nn(")
+ ((function) "C_c_pointer_or_null(")
+ ((const) (foreign-argument-conversion (cadr type)))
+ ((enum) "C_num_to_int(")
+ ((ref)
+ (string-append "*(" (foreign-type-declaration (cadr type) "*")
+ ")C_c_pointer_nn("))
+ ((instance-ref)
+ (string-append "*(" (cadr type) "*)C_c_pointer_nn("))
+ (else (err)) ) ]
+ [else (err)] ) ) ) ) )
+
+
+;; Generate suitable conversion of a result value into Scheme data
+
+(define (foreign-result-conversion type dest)
+ (let ([err (lambda () (quit "illegal foreign return type `~A'" type))])
+ (case type
+ ((char unsigned-char) "C_make_character((C_word)")
+ ((int int32) "C_fix((C_word)")
+ ((unsigned-int unsigned-int32) "C_fix(C_MOST_POSITIVE_FIXNUM&(C_word)")
+ ((short) "C_fix((short)")
+ ((unsigned-short) "C_fix(0xffff&(C_word)")
+ ((byte) "C_fix((char)")
+ ((unsigned-byte) "C_fix(0xff&(C_word)")
+ ((float double) (sprintf "C_flonum(&~a," dest)) ;*** suboptimal for int64
+ ((number) (sprintf "C_number(&~a," dest))
+ ((nonnull-c-string c-string nonnull-c-pointer c-string* nonnull-c-string*
+ unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string
+ nonnull-unsigned-c-string* symbol c-string-list c-string-list*)
+ (sprintf "C_mpointer(&~a,(void*)" dest) )
+ ((c-pointer) (sprintf "C_mpointer_or_false(&~a,(void*)" dest))
+ ((integer integer32) (sprintf "C_int_to_num(&~a," dest))
+ ((integer64) (sprintf "C_a_double_to_num(&~a," dest))
+ ((unsigned-integer unsigned-integer32) (sprintf "C_unsigned_int_to_num(&~a," dest))
+ ((long) (sprintf "C_long_to_num(&~a," dest))
+ ((unsigned-long) (sprintf "C_unsigned_long_to_num(&~a," dest))
+ ((bool) "C_mk_bool(")
+ ((void scheme-object) "((C_word)")
+ (else
+ (cond [(and (symbol? type) (##sys#hash-table-ref foreign-type-table type))
+ => (lambda (x)
+ (foreign-result-conversion (if (vector? x) (vector-ref x 0) x) dest)) ]
+ [(and (list? type) (>= (length type) 2))
+ (case (car type)
+ ((nonnull-pointer nonnull-c-pointer)
+ (sprintf "C_mpointer(&~A,(void*)" dest) )
+ ((ref)
+ (sprintf "C_mpointer(&~A,(void*)&" dest) )
+ ((instance)
+ (sprintf "C_mpointer_or_false(&~A,(void*)" dest) )
+ ((nonnull-instance)
+ (sprintf "C_mpointer(&~A,(void*)" dest) )
+ ((instance-ref)
+ (sprintf "C_mpointer(&~A,(void*)&" dest) )
+ ((const) (foreign-result-conversion (cadr type) dest))
+ ((pointer c-pointer)
+ (sprintf "C_mpointer_or_false(&~a,(void*)" dest) )
+ ((function) (sprintf "C_mpointer(&~a,(void*)" dest))
+ ((enum) (sprintf "C_int_to_num(&~a," dest))
+ (else (err)) ) ]
+ [else (err)] ) ) ) ) )
+
+
+;;; Encoded literals as strings, to be decoded by "C_decode_literal()"
+;;
+;; - everything hardcoded, using the FFI would be the ugly, but safer method.
+
+(define (encode-literal lit)
+ (define getbits
+ (foreign-lambda* int ((scheme-object lit))
+ "
+#ifdef C_SIXTY_FOUR
+return((C_header_bits(lit) >> (24 + 32)) & 0xff);
+#else
+return((C_header_bits(lit) >> 24) & 0xff);
+#endif
+") )
+ (define getsize
+ (foreign-lambda* int ((scheme-object lit))
+ "return(C_header_size(lit));"))
+ (define (encode-size n)
+ ;; only handles sizes in the 24-bit range!
+ (string (integer->char (bitwise-and #xff (arithmetic-shift n -16)))
+ (integer->char (bitwise-and #xff (arithmetic-shift n -8)))
+ (integer->char (bitwise-and #xff n))))
+ (define (finish str) ; can be taken out at a later stage
+ (string-append (string #\xfe) str))
+ (finish
+ (cond ((eq? #t lit) "\xff\x06\x01")
+ ((eq? #f lit) "\xff\x06\x00")
+ ((char? lit) (string-append "\xff\x0a" (encode-size (char->integer lit))))
+ ((null? lit) "\xff\x0e")
+ ((eof-object? lit) "\xff\x3e")
+ ((eq? (void) lit) "\xff\x1e")
+ ((fixnum? lit)
+ (if (not (big-fixnum? lit))
+ (string-append
+ "\xff\x01"
+ (string (integer->char (bitwise-and #xff (arithmetic-shift lit -24)))
+ (integer->char (bitwise-and #xff (arithmetic-shift lit -16)))
+ (integer->char (bitwise-and #xff (arithmetic-shift lit -8)))
+ (integer->char (bitwise-and #xff lit)) ) )
+ (string-append "\xff\x55" (number->string lit) "\x00") ) )
+ ((number? lit)
+ (string-append "\x55" (number->string lit) "\x00") )
+ ((symbol? lit)
+ (let ((str (##sys#slot lit 1)))
+ (string-append
+ "\x01"
+ (encode-size (string-length str))
+ str) ) )
+ ((##sys#immediate? lit)
+ (bomb "invalid literal - cannot encode" lit))
+ ((##core#inline "C_byteblockp" lit)
+ (##sys#string-append ; relies on the fact that ##sys#string-append doesn't check
+ (string-append
+ (string (integer->char (getbits lit)))
+ (encode-size (getsize lit)) )
+ lit) )
+ (else
+ (let ((len (getsize lit)))
+ (string-intersperse
+ (cons*
+ (string (integer->char (getbits lit)))
+ (encode-size len)
+ (list-tabulate len (lambda (i) (encode-literal (##sys#slot lit i)))))
+ ""))))) )
diff --git a/c-platform.scm b/c-platform.scm
new file mode 100644
index 00000000..2ba21720
--- /dev/null
+++ b/c-platform.scm
@@ -0,0 +1,1062 @@
+;;;; c-platform.scm - Platform specific parameters and definitions
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare (unit platform))
+
+
+(include "compiler-namespace")
+(include "tweaks")
+
+
+;;; Parameters:
+
+(define default-optimization-passes 3)
+
+(define default-declarations
+ '((always-bound
+ ##sys#standard-input ##sys#standard-output ##sys#standard-error)
+ (bound-to-procedure
+ ##sys#for-each ##sys#map ##sys#print ##sys#setter
+ ##sys#setslot ##sys#dynamic-wind ##sys#call-with-values
+ ##sys#start-timer ##sys#stop-timer ##sys#gcd ##sys#lcm ##sys#make-promise ##sys#structure? ##sys#slot
+ ##sys#allocate-vector ##sys#list->vector ##sys#block-ref ##sys#block-set!
+ ##sys#list ##sys#cons ##sys#append ##sys#vector ##sys#foreign-char-argument ##sys#foreign-fixnum-argument
+ ##sys#foreign-flonum-argument ##sys#error ##sys#peek-c-string ##sys#peek-nonnull-c-string
+ ##sys#peek-and-free-c-string ##sys#peek-and-free-nonnull-c-string
+ ##sys#foreign-block-argument ##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#foreign-integer-argument
+ ##sys#call-with-current-continuation) ) )
+
+(define default-debugging-declarations
+ '((##core#declare
+ '(uses debugger)
+ '(bound-to-procedure
+ ##sys#push-debug-frame ##sys#pop-debug-frame ##sys#check-debug-entry ##sys#check-debug-assignment
+ ##sys#register-debug-lambdas ##sys#register-debug-variables ##sys#debug-call) ) ) )
+
+(define default-profiling-declarations
+ '((##core#declare
+ (uses profiler)
+ (bound-to-procedure
+ ##sys#profile-entry ##sys#profile-exit) ) ) )
+
+(define units-used-by-default '(library eval))
+(define words-per-flonum 4)
+(define parameter-limit 1024)
+(define small-parameter-limit 128)
+(define unlikely-variables '(unquote unquote-splicing))
+
+(define eq-inline-operator "C_eqp")
+(define optimizable-rest-argument-operators
+ '(car cadr caddr cadddr length pair? null? list-ref))
+(define membership-test-operators
+ '(("C_i_memq" . "C_eqp") ("C_u_i_memq" . "C_eqp") ("C_i_member" . "C_i_equalp")
+ ("C_i_memv" . "C_i_eqvp") ) )
+(define membership-unfold-limit 20)
+(define target-include-file "chicken.h")
+
+(define valid-compiler-options
+ '(-help
+ h help version verbose explicit-use
+ quiet ; DEPRECATED
+ no-trace no-warnings unsafe block
+ check-syntax to-stdout no-usual-integrations case-insensitive no-lambda-info
+ profile inline keep-shadowed-macros ignore-repository
+ fixnum-arithmetic disable-interrupts optimize-leaf-routines
+ lambda-lift compile-syntax tag-pointers accumulate-profile
+ disable-stack-overflow-checks disable-c-syntax-checks unsafe-libraries raw
+ emit-external-prototypes-first release local inline-global
+ analyze-only dynamic scrutinize no-argc-checks no-procedure-checks
+ no-bound-checks no-procedure-checks-for-usual-bindings no-compiler-syntax
+ no-parentheses-synonyms no-symbol-escape r5rs-syntax emit-all-import-libraries
+ setup-mode) )
+
+(define valid-compiler-options-with-argument
+ '(debug
+ output-file include-path heap-size stack-size unit uses keyword-style require-extension
+ inline-limit profile-name disable-warning parenthesis-synonyms
+ prelude postlude prologue epilogue nursery extend feature types
+ emit-import-library emit-inline-file static-extension consult-inline-file
+ heap-growth heap-shrinkage heap-initial-size ffi-define ffi-include-path) )
+
+
+;;; Standard and extended bindings:
+
+(define default-standard-bindings
+ '(not boolean? apply call-with-current-continuation eq? eqv? equal? pair? cons car cdr caar cadr
+ cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar
+ cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr!
+ null? list list? length zero? * - + / - > < >= <= = current-output-port current-input-port
+ write-char newline write display append symbol->string for-each map char? char->integer
+ integer->char eof-object? vector-length string-length string-ref string-set! vector-ref
+ vector-set! char=? char<? char>? char>=? char<=? gcd lcm reverse symbol? string->symbol
+ number? complex? real? integer? rational? odd? even? positive? negative? exact? inexact?
+ max min quotient remainder modulo floor ceiling truncate round exact->inexact inexact->exact
+ exp log sin expt sqrt cos tan asin acos atan number->string string->number char-ci=?
+ char-ci<? char-ci>? char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric?
+ char-lower-case? char-upper-case? char-upcase char-downcase string? string=? string>? string<?
+ string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=?
+ string-append string->list list->string vector? vector->list list->vector string read
+ read-char substring string-fill! vector-fill! make-string make-vector open-input-file
+ open-output-file call-with-input-file call-with-output-file close-input-port close-output-port
+ values call-with-values vector procedure? memq memv member assq assv assoc list-tail
+ list-ref abs char-ready? peek-char list->string string->list) )
+
+(define default-extended-bindings
+ '(bitwise-and bitwise-ior bitwise-xor bitwise-not add1 sub1 fx+ fx- fx* fx/ fxmod o
+ fx= fx> fx< fx>= fx<= fixnum? fxneg fxmax fxmin identity fp+ fp- fp* fp/ fpmin fpmax fpneg
+ fp> fp< fp= fp>= fp<= fxand fxnot fxior fxxor fxshr fxshl bit-set?
+ arithmetic-shift void flush-output thread-specific thread-specific-set!
+ not-pair? atom? null-list? print print* error cpu-time proper-list? call/cc
+ blob-size u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared
+ s16vector->blob/shared u32vector->blob/shared s32vector->blob/shared
+ f32vector->blob/shared f64vector->blob/shared
+ blob->u8vector/shared blob->s8vector/shared blob->u16vector/shared
+ blob->s16vector/shared blob->u32vector/shared blob->s32vector/shared
+ blob->f32vector/shared blob->f64vector/shared
+ block-ref block-set! number-of-slots substring-index substring-index-ci
+ hash-table-ref any? read-string substring=? substring-ci=?
+ first second third fourth make-record-instance
+ u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length s32vector-length
+ f32vector-length f64vector-length setter
+ u8vector-ref s8vector-ref u16vector-ref s16vector-ref u32vector-ref s32vector-ref
+ f32vector-ref f64vector-ref
+ u8vector-set! s8vector-set! u16vector-set! s16vector-set! u32vector-set! s32vector-set!
+ locative-ref locative-set! locative->object locative? global-ref
+ null-pointer? pointer->object flonum? finite?
+ printf sprintf format) )
+
+(define internal-bindings
+ '(##sys#slot ##sys#setslot ##sys#block-ref ##sys#block-set!
+ ##sys#call-with-current-continuation ##sys#size ##sys#byte ##sys#setbyte
+ ##sys#pointer? ##sys#generic-structure? ##sys#structure? ##sys#check-structure
+ ##sys#check-exact ##sys#check-number ##sys#check-list ##sys#check-pair ##sys#check-string ##sys#check-symbol
+ ##sys#check-char ##sys#check-vector ##sys#check-byte-vector ##sys#list ##sys#cons
+ ##sys#call-with-values ##sys#fits-in-int? ##sys#fits-in-unsigned-int? ##sys#flonum-in-fixnum-range?
+ ##sys#fudge ##sys#immediate? ##sys#direct-return ##sys#context-switch
+ ##sys#make-structure ##sys#apply ##sys#apply-values ##sys#continuation-graft
+ ##sys#bytevector? ##sys#make-vector ##sys#setter ##sys#car ##sys#cdr ##sys#pair?
+ ##sys#eq? ##sys#list? ##sys#vector? ##sys#eqv?
+ ##sys#foreign-char-argument ##sys#foreign-fixnum-argument ##sys#foreign-flonum-argument
+ ##sys#foreign-block-argument ##sys#foreign-number-vector-argument
+ ##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#void
+ ##sys#foreign-integer-argument ##sys#foreign-unsigned-integer-argument ##sys#double->number
+ ##sys#peek-fixnum ##sys#setislot ##sys#poke-integer ##sys#permanent? ##sys#values ##sys#poke-double
+ ##sys#intern-symbol ##sys#make-symbol ##sys#null-pointer? ##sys#peek-byte) )
+
+(define non-foldable-bindings
+ '(vector
+ cons list string make-vector make-string string->symbol values current-input-port current-output-port
+ read-char write-char printf fprintf format
+ apply call-with-current-continuation set-car! set-cdr! write-char newline write display
+ peek-char char-ready?
+ read read-char for-each map string-set! vector-set! string-fill! vector-fill! open-input-file
+ open-output-file close-input-port close-output-port call-with-input-port call-with-output-port
+ call-with-values eval
+ ##sys#slot ##sys#setslot ##sys#call-with-current-continuation ##sys#fudge flush-output print void
+ u8vector->blob/shared s8vector->blob/shared u16vector->blob/shared s16vector->blob/shared u32vector->blob/shared
+ f32vector->blob/shared f64vector->blob/shared
+ s32vector->blob/shared read-string read-string! o
+ ##sys#make-structure print* ##sys#make-vector ##sys#apply ##sys#setislot ##sys#block-ref
+ ##sys#byte ##sys#setbyte
+ u8vector-length s8vector-length u16vector-length s16vector-length u32vector-length s32vector-length
+ f32vector-length f64vector-length ##sys#apply-values ##sys#setter setter
+ u8vector-ref s8vector-ref u16vector-ref s16vector-ref u32vector-ref s32vector-ref
+ u8vector-set! s8vector-set! u16vector-set! s16vector-set! u32vector-set! s32vector-set!
+ ##sys#intern-symbol ##sys#make-symbol make-record-instance error cpu-time ##sys#block-set!) )
+
+(define foldable-bindings
+ (lset-difference
+ eq?
+ (lset-union eq? default-standard-bindings default-extended-bindings)
+ non-foldable-bindings) )
+
+
+;;; Rewriting-definitions for this platform:
+
+(rewrite '+ 19 0 "C_fixnum_plus" "C_u_fixnum_plus" #f)
+
+(rewrite
+ '* 8
+ (lambda (db classargs cont callargs)
+ ;; (*) -> 1
+ ;; (* <x>) -> <x>
+ ;; (* <x1> ...) -> (##core#inline "C_fixnum_times" <x1> (##core#inline "C_fixnum_times" ...)) [fixnum-mode]
+ ;; - Remove "1" from arguments.
+ ;; - Replace multiplications with 2 by shift left. [fixnum-mode]
+ (let ([callargs
+ (remove
+ (lambda (x)
+ (and (eq? 'quote (node-class x))
+ (= 1 (first (node-parameters x))) ) )
+ callargs) ] )
+ (cond [(null? callargs) (make-node '##core#call '(#t) (list cont (qnode 0)))]
+ [(null? (cdr callargs))
+ (make-node '##core#call '(#t) (list cont (first callargs))) ]
+ [(eq? number-type 'fixnum)
+ (make-node
+ '##core#call '(#t)
+ (list
+ cont
+ (fold-inner
+ (lambda (x y)
+ (if (and (eq? 'quote (node-class y)) (= 2 (first (node-parameters y))))
+ (make-node '##core#inline '("C_fixnum_shift_left") (list x (qnode 1)))
+ (make-node '##core#inline '("C_fixnum_times") (list x y)) ) )
+ callargs) ) ) ]
+ [else #f] ) ) ) )
+
+(rewrite
+ '- 8
+ (lambda (db classargs cont callargs)
+ ;; (- <x>) -> (##core#inline "C_fixnum_negate" <x>) [fixnum-mode]
+ ;; (- <x>) -> (##core#inline "C_u_fixnum_negate" <x>) [fixnum-mode + unsafe]
+ ;; (- <x1> ...) -> (##core#inline "C_fixnum_difference" <x1> (##core#inline "C_fixnum_difference" ...)) [fixnum-mode]
+ ;; (- <x1> ...) -> (##core#inline "C_u_fixnum_difference" <x1> (##core#inline "C_u_fixnum_difference" ...))
+ ;; [fixnum-mode + unsafe]
+ ;; - Remove "0" from arguments, if more than 1.
+ (cond [(null? callargs) #f]
+ [(and (null? (cdr callargs)) (eq? number-type 'fixnum))
+ (make-node
+ '##core#call '(#t)
+ (list cont
+ (make-node '##core#inline
+ (if unsafe '("C_u_fixnum_negate") '("C_fixnum_negate"))
+ callargs)) ) ]
+ [else
+ (let ([callargs
+ (cons (car callargs)
+ (remove
+ (lambda (x)
+ (and (eq? 'quote (node-class x))
+ (zero? (first (node-parameters x))) ) )
+ (cdr callargs) ) ) ] )
+ (and (eq? number-type 'fixnum)
+ (>= (length callargs) 2)
+ (make-node
+ '##core#call '(#t)
+ (list
+ cont
+ (fold-inner
+ (lambda (x y)
+ (make-node '##core#inline
+ (if unsafe '("C_u_fixnum_difference") '("C_fixnum_difference"))
+ (list x y) ) )
+ callargs) ) ) ) ) ] ) ) )
+
+(rewrite
+ '/ 8
+ (lambda (db classargs cont callargs)
+ ;; (/ <x1> ...) -> (##core#inline "C_fixnum_divide" <x1> (##core#inline "C_fixnum_divide" ...)) [fixnum-mode]
+ ;; - Remove "1" from arguments, if more than 1.
+ ;; - Replace divisions by 2 with shift right. [fixnum-mode]
+ (and (>= (length callargs) 2)
+ (let ([callargs
+ (cons (car callargs)
+ (remove
+ (lambda (x)
+ (and (eq? 'quote (node-class x))
+ (= 1 (first (node-parameters x))) ) )
+ (cdr callargs) ) ) ] )
+ (and (eq? number-type 'fixnum)
+ (>= (length callargs) 2)
+ (make-node
+ '##core#call '(#t)
+ (list
+ cont
+ (fold-inner
+ (lambda (x y)
+ (if (and (eq? 'quote (node-class y)) (= 2 (first (node-parameters y))))
+ (make-node '##core#inline '("C_fixnum_shift_right") (list x (qnode 1)))
+ (make-node '##core#inline '("C_fixnum_divide") (list x y)) ) )
+ callargs) ) ) ) ) ) ) )
+
+(rewrite
+ 'quotient 8
+ (lambda (db classargs cont callargs)
+ ;; (quotient <x> 2) -> (##core#inline "C_fixnum_shift_right" <x> 1) [fixnum-mode]
+ ;; (quotient <x> <y>) -> (##core#inline "C_fixnum_divide" <x> <y>) [fixnum-mode]
+ ;; (quotient <x> <y>) -> ((##core#proc "C_quotient") <x> <y>)
+ (and (= (length callargs) 2)
+ (if (eq? 'fixnum number-type)
+ (make-node
+ '##core#call '(#t)
+ (let ([arg2 (second callargs)])
+ (list cont
+ (if (and (eq? 'quote (node-class arg2))
+ (= 2 (first (node-parameters arg2))) )
+ (make-node
+ '##core#inline '("C_fixnum_shift_right")
+ (list (first callargs) (qnode 1)) )
+ (make-node '##core#inline '("C_fixnum_divide") callargs) ) ) ) )
+ (make-node
+ '##core#call '(#t)
+ (cons* (make-node '##core#proc '("C_quotient" #t) '()) cont callargs) ) ) ) ) )
+
+(let ()
+ ;; (add1 <x>) -> (##core#inline "C_fixnum_increase" <x>) [fixnum-mode]
+ ;; (add1 <x>) -> (##core#inline "C_u_fixnum_increase" <x>) [fixnum-mode + unsafe]
+ ;; (add1 <x>) -> (##core#inline_allocate ("C_a_i_plus" 4) <x> 1)
+ ;; (sub1 <x>) -> (##core#inline "C_fixnum_decrease" <x>) [fixnum-mode]
+ ;; (sub1 <x>) -> (##core#inline "C_u_fixnum_decrease" <x>) [fixnum-mode + unsafe]
+ ;; (sub1 <x>) -> (##core#inline_allocate ("C_a_i_minus" 4) <x> 1)
+ (define ((op1 fiop ufiop aiop) db classargs cont callargs)
+ (and (= (length callargs) 1)
+ (make-node
+ '##core#call '(#t)
+ (list
+ cont
+ (if (eq? 'fixnum number-type)
+ (make-node '##core#inline (list (if unsafe ufiop fiop)) callargs)
+ (make-node
+ '##core#inline_allocate (list aiop 4)
+ (list (car callargs) (qnode 1))))))))
+ (rewrite 'add1 8 (op1 "C_fixnum_increase" "C_u_fixnum_increase" "C_a_i_plus"))
+ (rewrite 'sub1 8 (op1 "C_fixnum_decrease" "C_u_fixnum_decrease" "C_a_i_minus")))
+
+(let ()
+ (define (eqv?-id db classargs cont callargs)
+ ;; (eqv? <var> <var>) -> (quote #t)
+ ;; (eqv? ...) -> (##core#inline "C_eqp" ...) [one argument is a constant and not a flonum]
+ (and (= (length callargs) 2)
+ (let ([arg1 (first callargs)]
+ [arg2 (second callargs)] )
+ (or (and (eq? '##core#variable (node-class arg1))
+ (eq? '##core#variable (node-class arg2))
+ (equal? (node-parameters arg1) (node-parameters arg2))
+ (make-node '##core#call '(#t) (list cont (qnode #t))) )
+ (and (or (and (eq? 'quote (node-class arg1))
+ (not (flonum? (first (node-parameters arg1)))) )
+ (and (eq? 'quote (node-class arg2))
+ (not (flonum? (first (node-parameters arg2)))) ) )
+ (make-node
+ '##core#call '(#t)
+ (list cont (make-node '##core#inline '("C_eqp") callargs)) ) ) ) ) ) )
+ (rewrite 'eqv? 8 eqv?-id)
+ (rewrite '##sys#eqv? 8 eqv?-id))
+
+(rewrite
+ 'equal? 8
+ (lambda (db classargs cont callargs)
+ ;; (equal? <var> <var>) -> (quote #t)
+ ;; (equal? ...) -> (##core#inline "C_eqp" ...) [one argument is a constant and immediate or a symbol]
+ ;; (equal? ...) -> (##core#inline "C_i_equalp" ...)
+ (and (= (length callargs) 2)
+ (let ([arg1 (first callargs)]
+ [arg2 (second callargs)] )
+ (or (and (eq? '##core#variable (node-class arg1))
+ (eq? '##core#variable (node-class arg2))
+ (equal? (node-parameters arg1) (node-parameters arg2))
+ (make-node '##core#call '(#t) (list cont (qnode #t))) )
+ (and (or (and (eq? 'quote (node-class arg1))
+ (let ([f (first (node-parameters arg1))])
+ (or (immediate? f) (symbol? f)) ) )
+ (and (eq? 'quote (node-class arg2))
+ (let ([f (first (node-parameters arg2))])
+ (or (immediate? f) (symbol? f)) ) ) )
+ (make-node
+ '##core#call '(#t)
+ (list cont (make-node '##core#inline '("C_eqp") callargs)) ) )
+ (make-node
+ '##core#call '(#t)
+ (list cont (make-node '##core#inline '("C_i_equalp") callargs)) ) ) ) ) ) )
+
+(let ()
+ (define (rewrite-apply db classargs cont callargs)
+ ;; (apply <fn> <x1> ... '(<y1> ...)) -> (<fn> <x1> ... '<y1> ...)
+ ;; (apply ...) -> ((##core#proc "C_apply") ...)
+ ;; (apply values <lst>) -> ((##core#proc "C_apply_values") lst)
+ ;; (apply ##sys#values <lst>) -> ((##core#proc "C_apply_values") lst)
+ (and (pair? callargs)
+ (let ([lastarg (last callargs)]
+ [proc (car callargs)] )
+ (if (eq? 'quote (node-class lastarg))
+ (make-node
+ '##core#call '(#f)
+ (cons* (first callargs)
+ cont
+ (append (cdr (butlast callargs)) (map qnode (first (node-parameters lastarg)))) ) )
+ (or (and (eq? '##core#variable (node-class proc))
+ (= 2 (length callargs))
+ (let ([name (car (node-parameters proc))])
+ (and (memq name '(values ##sys#values))
+ (intrinsic? name)
+ (make-node
+ '##core#call '(#t)
+ (list (make-node '##core#proc '("C_apply_values" #t) '())
+ cont
+ (cadr callargs) ) ) ) ) )
+ (make-node
+ '##core#call '(#t)
+ (cons* (make-node '##core#proc '("C_apply" #t) '())
+ cont callargs) ) ) ) ) ) )
+ (rewrite 'apply 8 rewrite-apply)
+ (rewrite '##sys#apply 8 rewrite-apply) )
+
+(let ()
+ (define (rewrite-c..r op iop1 iop2 index)
+ (rewrite
+ op 8
+ (lambda (db classargs cont callargs)
+ ;; (<op> <rest-vector>) -> (##core#inline "C_i_vector_ref"/"C_slot" <rest-vector> (quote <index>))
+ ;; (<op> <x>) -> (##core#inline <iop1> <x>) [safe]
+ ;; (<op> <x>) -> (##core#inline <iop2> <x>) [unsafe]
+ (and (= (length callargs) 1)
+ (call-with-current-continuation
+ (lambda (return)
+ (let ([arg (first callargs)])
+ (make-node
+ '##core#call '(#t)
+ (list
+ cont
+ (cond [(and (eq? '##core#variable (node-class arg))
+ (eq? 'vector (get db (first (node-parameters arg)) 'rest-parameter)) )
+ (make-node
+ '##core#inline
+ (if unsafe
+ '("C_slot")
+ '("C_i_vector_ref") )
+ (list arg (qnode index)) ) ]
+ [(and unsafe iop2) (make-node '##core#inline (list iop2) callargs)]
+ [iop1 (make-node '##core#inline (list iop1) callargs)]
+ [else (return #f)] ) ) ) ) ) ) ) ) ) )
+
+ (rewrite-c..r 'car "C_i_car" "C_u_i_car" 0)
+ (rewrite-c..r '##sys#car "C_i_car" "C_u_i_car" 0)
+ (rewrite-c..r '##sys#cdr "C_i_cdr" "C_u_i_cdr" 0)
+ (rewrite-c..r 'cadr "C_i_cadr" "C_u_i_cadr" 1)
+ (rewrite-c..r 'caddr "C_i_caddr" "C_u_i_caddr" 2)
+ (rewrite-c..r 'cadddr "C_i_cadddr" "C_u_i_cadddr" 3)
+ (rewrite-c..r 'first "C_i_car" "C_u_i_car" 0)
+ (rewrite-c..r 'second "C_i_cadr" "C_u_i_cadr" 1)
+ (rewrite-c..r 'third "C_i_caddr" "C_u_i_caddr" 2)
+ (rewrite-c..r 'fourth "C_i_cadddr" "C_u_i_cadddr" 3) )
+
+(let ([rvalues
+ (lambda (db classargs cont callargs)
+ ;; (values <x>) -> <x>
+ (and (= (length callargs) 1)
+ (make-node '##core#call '(#t) (cons cont callargs) ) ) ) ] )
+ (rewrite 'values 8 rvalues)
+ (rewrite '##sys#values 8 rvalues) )
+
+(let ()
+ (define (rewrite-c-w-v db classargs cont callargs)
+ ;; (call-with-values <var1> <var2>) -> (let ((k (lambda (r) (<var2> <k0> r)))) (<var1> k))
+ ;; - if <var2> is a known lambda of a single argument
+ (and (= 2 (length callargs))
+ (let ((arg1 (car callargs))
+ (arg2 (cadr callargs)) )
+ (and (eq? '##core#variable (node-class arg1)) ; probably not needed
+ (eq? '##core#variable (node-class arg2))
+ (and-let* ((sym (car (node-parameters arg2)))
+ (val (get db sym 'value)) )
+ (and (eq? '##core#lambda (node-class val))
+ (let ((llist (third (node-parameters val))))
+ (and (proper-list? llist)
+ (= 2 (length (third (node-parameters val))))
+ (let ((tmp (gensym))
+ (tmpk (gensym 'r)) )
+ (debugging 'o "removing single-valued `call-with-values'" (node-parameters val))
+ (make-node
+ 'let (list tmp)
+ (list (make-node
+ '##core#lambda
+ (list (gensym 'f_) #f (list tmpk) 0)
+ (list (make-node
+ '##core#call '(#t)
+ (list arg2 cont (varnode tmpk)) ) ) )
+ (make-node
+ '##core#call '(#t)
+ (list arg1 (varnode tmp)) ) ) ) ) ) ) ) ) ) ) ) )
+ (rewrite 'call-with-values 8 rewrite-c-w-v)
+ (rewrite '##sys#call-with-values 8 rewrite-c-w-v) )
+
+(rewrite 'values 13 "C_values" #t)
+(rewrite '##sys#values 13 "C_values" #t)
+(rewrite 'call-with-values 13 "C_u_call_with_values" #f)
+(rewrite 'call-with-values 13 "C_call_with_values" #t)
+(rewrite '##sys#call-with-values 13 "C_u_call_with_values" #f)
+(rewrite '##sys#call-with-values 13 "C_call_with_values" #t)
+(rewrite 'cpu-time 13 "C_cpu_time" #t)
+(rewrite 'locative-ref 13 "C_locative_ref" #t)
+(rewrite '##sys#continuation-graft 13 "C_continuation_graft" #t)
+
+(rewrite 'caar 2 1 "C_u_i_caar" #f #f)
+(rewrite 'cdar 2 1 "C_u_i_cdar" #f #f)
+(rewrite 'cddr 2 1 "C_u_i_cddr" #f #f)
+(rewrite 'caaar 2 1 "C_u_i_caaar" #f #f)
+(rewrite 'cadar 2 1 "C_u_i_cadar" #f #f)
+(rewrite 'caddr 2 1 "C_u_i_caddr" #f #f)
+(rewrite 'cdaar 2 1 "C_u_i_cdaar" #f #f)
+(rewrite 'cdadr 2 1 "C_u_i_cdadr" #f #f)
+(rewrite 'cddar 2 1 "C_u_i_cddar" #f #f)
+(rewrite 'cdddr 2 1 "C_u_i_cdddr" #f #f)
+(rewrite 'caaaar 2 1 "C_u_i_caaaar" #f #f)
+(rewrite 'caadar 2 1 "C_u_i_caadar" #f #f)
+(rewrite 'caaddr 2 1 "C_u_i_caaddr" #f #f)
+(rewrite 'cadaar 2 1 "C_u_i_cadaar" #f #f)
+(rewrite 'cadadr 2 1 "C_u_i_cadadr" #f #f)
+(rewrite 'caddar 2 1 "C_u_i_caddar" #f #f)
+(rewrite 'cadddr 2 1 "C_u_i_cadddr" #f #f)
+(rewrite 'cdaaar 2 1 "C_u_i_cdaaar" #f #f)
+(rewrite 'cdaadr 2 1 "C_u_i_cdaadr" #f #f)
+(rewrite 'cdadar 2 1 "C_u_i_cdadar" #f #f)
+(rewrite 'cdaddr 2 1 "C_u_i_cdaddr" #f #f)
+(rewrite 'cddaar 2 1 "C_u_i_cddaar" #f #f)
+(rewrite 'cddadr 2 1 "C_u_i_cddadr" #f #f)
+(rewrite 'cdddar 2 1 "C_u_i_cdddar" #f #f)
+(rewrite 'cddddr 2 1 "C_u_i_cddddr" #f #f)
+
+(rewrite 'cddr 2 1 "C_i_cddr" #t #f)
+(rewrite 'cdddr 2 1 "C_i_cdddr" #t #f)
+(rewrite 'cddddr 2 1 "C_i_cddddr" #t #f)
+
+(rewrite 'cdr 7 1 "C_slot" 1 #f)
+(rewrite 'cdr 2 1 "C_i_cdr" #t #f)
+
+(rewrite 'eq? 1 2 "C_eqp")
+(rewrite '##sys#eq? 1 2 "C_eqp")
+(rewrite 'eqv? 1 2 "C_i_eqvp")
+(rewrite '##sys#eqv? 1 2 "C_i_eqvp")
+
+(rewrite 'list-ref 2 2 "C_u_i_list_ref" #f "C_slot")
+(rewrite 'list-ref 2 2 "C_i_list_ref" #t "C_i_vector_ref")
+(rewrite 'null? 2 1 "C_i_nullp" #t "C_vemptyp")
+(rewrite '##sys#null? 2 1 "C_i_nullp" #t "C_vemptyp")
+(rewrite 'length 2 1 "C_i_length" #t "C_block_size")
+(rewrite 'not 2 1 "C_i_not" #t #f)
+(rewrite 'char? 2 1 "C_charp" #t #f)
+(rewrite 'string? 2 1 "C_i_stringp" #t #f)
+(rewrite 'locative? 2 1 "C_i_locativep" #t #f)
+(rewrite 'symbol? 2 1 "C_i_symbolp" #t #f)
+(rewrite 'vector? 2 1 "C_i_vectorp" #t #f)
+(rewrite '##sys#vector? 2 1 "C_i_vectorp" #t #f)
+(rewrite 'pair? 2 1 "C_i_pairp" #t "C_notvemptyp")
+(rewrite '##sys#pair? 2 1 "C_i_pairp" #t "C_notvemptyp")
+(rewrite 'procedure? 2 1 "C_i_closurep" #t #f)
+(rewrite 'port? 2 1 "C_i_portp" #t #f)
+(rewrite 'boolean? 2 1 "C_booleanp" #t #f)
+(rewrite 'number? 2 1 "C_i_numberp" #t #f)
+(rewrite 'complex? 2 1 "C_i_numberp" #t #f)
+(rewrite 'rational? 2 1 "C_i_rationalp" #t #f)
+(rewrite 'real? 2 1 "C_i_numberp" #t #f)
+(rewrite 'integer? 2 1 "C_i_integerp" #t #f)
+(rewrite 'flonum? 2 1 "C_i_flonump" #t #f)
+(rewrite 'fixnum? 2 1 "C_fixnump" #t #f)
+(rewrite 'finite? 2 1 "C_i_finitep" #f #f)
+(rewrite '##sys#pointer? 2 1 "C_anypointerp" #t #f)
+(rewrite '##sys#generic-structure? 2 1 "C_structurep" #t #f)
+(rewrite 'exact? 2 1 "C_fixnump" #f #f)
+(rewrite 'exact? 2 1 "C_i_exactp" #t #f)
+(rewrite 'exact? 2 1 "C_u_i_exactp" #f #f)
+(rewrite 'inexact? 2 1 "C_nfixnump" #f #f)
+(rewrite 'inexact? 2 1 "C_i_inexactp" #t #f)
+(rewrite 'inexact? 2 1 "C_u_i_inexactp" #f #f)
+(rewrite 'list? 2 1 "C_i_listp" #t #f)
+(rewrite 'proper-list? 2 1 "C_i_listp" #t #f)
+(rewrite 'eof-object? 2 1 "C_eofp" #t #f)
+(rewrite 'string-ref 2 2 "C_subchar" #f #f)
+(rewrite 'string-ref 2 2 "C_i_string_ref" #t #f)
+(rewrite 'string-set! 2 3 "C_setsubchar" #f #f)
+(rewrite 'string-set! 2 3 "C_i_string_set" #t #f)
+(rewrite 'vector-ref 2 2 "C_slot" #f #f)
+(rewrite 'vector-ref 2 2 "C_i_vector_ref" #t #f)
+(rewrite 'char=? 2 2 "C_eqp" #t #f)
+(rewrite 'char>? 2 2 "C_fixnum_greaterp" #t #f)
+(rewrite 'char<? 2 2 "C_fixnum_lessp" #t #f)
+(rewrite 'char>=? 2 2 "C_fixnum_greater_or_equal_p" #t #f)
+(rewrite 'char<=? 2 2 "C_fixnum_less_or_equal_p" #t #f)
+(rewrite '##sys#slot 2 2 "C_slot" #t #f) ; consider as safe, the primitive is unsafe anyway.
+(rewrite '##sys#block-ref 2 2 "C_i_block_ref" #t #f) ;*** must be safe for pattern matcher (anymore?)
+(rewrite '##sys#size 2 1 "C_block_size" #t #f)
+(rewrite 'fxnot 2 1 "C_fixnum_not" #t #f)
+(rewrite 'fx* 2 2 "C_fixnum_times" #t #f)
+(rewrite 'fx/ 2 2 "C_fixnum_divide" #f #f)
+(rewrite 'fxmod 2 2 "C_fixnum_modulo" #f #f)
+(rewrite 'fx= 2 2 "C_eqp" #t #f)
+(rewrite 'fx> 2 2 "C_fixnum_greaterp" #t #f)
+(rewrite 'fx< 2 2 "C_fixnum_lessp" #t #f)
+(rewrite 'fx>= 2 2 "C_fixnum_greater_or_equal_p" #t #f)
+(rewrite 'fx<= 2 2 "C_fixnum_less_or_equal_p" #t #f)
+(rewrite 'fp= 2 2 "C_flonum_equalp" #t #f)
+(rewrite 'fp> 2 2 "C_flonum_greaterp" #t #f)
+(rewrite 'fp< 2 2 "C_flonum_lessp" #t #f)
+(rewrite 'fp>= 2 2 "C_flonum_greater_or_equal_p" #t #f)
+(rewrite 'fp<= 2 2 "C_flonum_less_or_equal_p" #t #f)
+(rewrite 'fxmax 2 2 "C_i_fixnum_max" #t #f)
+(rewrite 'fxmin 2 2 "C_i_fixnum_min" #t #f)
+(rewrite 'fpmax 2 2 "C_i_flonum_max" #t #f)
+(rewrite 'fpmin 2 2 "C_i_flonum_min" #t #f)
+(rewrite 'char-numeric? 2 1 "C_u_i_char_numericp" #t #f)
+(rewrite 'char-alphabetic? 2 1 "C_u_i_char_alphabeticp" #t #f)
+(rewrite 'char-whitespace? 2 1 "C_u_i_char_whitespacep" #t #f)
+(rewrite 'char-upper-case? 2 1 "C_u_i_char_upper_casep" #t #f)
+(rewrite 'char-lower-case? 2 1 "C_u_i_char_lower_casep" #t #f)
+(rewrite 'char-upcase 2 1 "C_u_i_char_upcase" #t #f)
+(rewrite 'char-downcase 2 1 "C_u_i_char_downcase" #t #f)
+(rewrite 'list-tail 2 2 "C_i_list_tail" #t #f)
+(rewrite '##sys#structure? 2 2 "C_i_structurep" #t #f)
+(rewrite '##sys#bytevector? 2 2 "C_bytevectorp" #t #f)
+(rewrite 'block-ref 2 2 "C_slot" #f #f) ; ok to be unsafe, lolevel is anyway
+(rewrite 'number-of-slots 2 1 "C_block_size" #f #f)
+
+(rewrite 'assv 14 'fixnum 2 "C_i_assq" "C_u_i_assq")
+(rewrite 'assv 2 2 "C_i_assv" #t #f)
+(rewrite 'memv 14 'fixnum 2 "C_i_memq" "C_u_i_memq")
+(rewrite 'memv 2 2 "C_i_memv" #t #f)
+(rewrite 'assq 17 2 "C_i_assq" "C_u_i_assq")
+(rewrite 'memq 17 2 "C_i_memq" "C_u_i_memq")
+(rewrite 'assoc 2 2 "C_i_assoc" #t #f)
+(rewrite 'member 2 2 "C_i_member" #t #f)
+
+(rewrite 'set-car! 4 '##sys#setslot 0)
+(rewrite 'set-cdr! 4 '##sys#setslot 1)
+(rewrite 'set-car! 17 2 "C_i_set_car" "C_u_i_set_car")
+(rewrite 'set-cdr! 17 2 "C_i_set_cdr" "C_u_i_set_cdr")
+
+(rewrite 'abs 14 'fixnum 1 "C_fixnum_abs" "C_fixnum_abs")
+(rewrite 'abs 16 1 "C_a_i_abs" #t words-per-flonum)
+
+(rewrite 'bitwise-xor 21 0 "C_fixnum_xor" "C_fixnum_xor" "C_a_i_bitwise_xor" words-per-flonum)
+(rewrite 'bitwise-and 21 -1 "C_fixnum_and" "C_u_fixnum_and" "C_a_i_bitwise_and" words-per-flonum)
+(rewrite 'bitwise-ior 21 0 "C_fixnum_or" "C_u_fixnum_or" "C_a_i_bitwise_ior" words-per-flonum)
+
+(rewrite 'bitwise-not 22 1 "C_a_i_bitwise_not" #t words-per-flonum "C_fixnum_not")
+
+(rewrite 'fp+ 16 2 "C_a_i_flonum_plus" #t words-per-flonum)
+(rewrite 'fp- 16 2 "C_a_i_flonum_difference" #t words-per-flonum)
+(rewrite 'fp* 16 2 "C_a_i_flonum_times" #t words-per-flonum)
+(rewrite 'fp/ 16 2 "C_a_i_flonum_quotient" #t words-per-flonum)
+(rewrite 'fpneg 16 1 "C_a_i_flonum_negate" #t words-per-flonum)
+
+(rewrite 'exp 16 1 "C_a_i_exp" #t words-per-flonum)
+(rewrite 'sin 16 1 "C_a_i_sin" #t words-per-flonum)
+(rewrite 'cos 16 1 "C_a_i_cos" #t words-per-flonum)
+(rewrite 'tan 16 1 "C_a_i_tan" #t words-per-flonum)
+(rewrite 'log 16 1 "C_a_i_log" #t words-per-flonum)
+(rewrite 'asin 16 1 "C_a_i_asin" #t words-per-flonum)
+(rewrite 'acos 16 1 "C_a_i_acos" #t words-per-flonum)
+(rewrite 'atan 16 1 "C_a_i_atan" #t words-per-flonum)
+(rewrite 'sqrt 16 1 "C_a_i_sqrt" #t words-per-flonum)
+(rewrite 'atan 16 2 "C_a_i_atan2" #t words-per-flonum)
+
+(rewrite 'zero? 5 "C_eqp" 0 'fixnum)
+(rewrite 'zero? 2 1 "C_i_zerop" #t #f)
+(rewrite 'zero? 2 1 "C_u_i_zerop" #f #f)
+(rewrite 'positive? 5 "C_fixnum_greaterp" 0 'fixnum)
+(rewrite 'positive? 5 "C_flonum_greaterp" 0 'flonum)
+(rewrite 'positive? 2 1 "C_i_positivep" #t #f)
+(rewrite 'positive? 2 1 "C_u_i_positivep" #f #f)
+(rewrite 'negative? 5 "C_fixnum_lessp" 0 'fixnum)
+(rewrite 'negative? 5 "C_flonum_lessp" 0 'flonum)
+(rewrite 'negative? 2 1 "C_i_negativep" #t #f)
+(rewrite 'negative? 2 1 "C_u_i_negativep" #f #f)
+
+(rewrite 'vector-length 6 "C_fix" "C_header_size" #f)
+(rewrite 'string-length 6 "C_fix" "C_header_size" #f)
+(rewrite 'char->integer 6 "C_fix" "C_character_code" #t)
+(rewrite 'integer->char 6 "C_make_character" "C_unfix" #t)
+
+(rewrite 'vector-length 2 1 "C_i_vector_length" #t #f)
+(rewrite '##sys#vector-length 2 1 "C_i_vector_length" #t #f)
+(rewrite 'string-length 2 1 "C_i_string_length" #t #f)
+(rewrite 'inexact->exact 2 1 "C_i_inexact_to_exact" #t #f)
+
+(rewrite '##sys#check-exact 2 1 "C_i_check_exact" #t #f)
+(rewrite '##sys#check-number 2 1 "C_i_check_number" #t #f)
+(rewrite '##sys#check-list 2 1 "C_i_check_list" #t #f)
+(rewrite '##sys#check-pair 2 1 "C_i_check_pair" #t #f)
+(rewrite '##sys#check-symbol 2 1 "C_i_check_symbol" #t #f)
+(rewrite '##sys#check-string 2 1 "C_i_check_string" #t #f)
+(rewrite '##sys#check-byte-vector 2 1 "C_i_check_bytevector" #t #f)
+(rewrite '##sys#check-vector 2 1 "C_i_check_vector" #t #f)
+(rewrite '##sys#check-structure 2 2 "C_i_check_structure" #t #f)
+(rewrite '##sys#check-char 2 1 "C_i_check_char" #t #f)
+(rewrite '##sys#check-exact 2 2 "C_i_check_exact_2" #t #f)
+(rewrite '##sys#check-number 2 2 "C_i_check_number_2" #t #f)
+(rewrite '##sys#check-list 2 2 "C_i_check_list_2" #t #f)
+(rewrite '##sys#check-pair 2 2 "C_i_check_pair_2" #t #f)
+(rewrite '##sys#check-symbol 2 2 "C_i_check_symbol_2" #t #f)
+(rewrite '##sys#check-string 2 2 "C_i_check_string_2" #t #f)
+(rewrite '##sys#check-byte-vector 2 2 "C_i_check_bytevector_2" #t #f)
+(rewrite '##sys#check-vector 2 2 "C_i_check_vector_2" #t #f)
+(rewrite '##sys#check-structure 2 3 "C_i_check_structure_2" #t #f)
+(rewrite '##sys#check-char 2 2 "C_i_check_char_2" #t #f)
+
+(rewrite '= 9 "C_eqp" "C_i_equalp" #t #t)
+(rewrite '> 9 "C_fixnum_greaterp" "C_flonum_greaterp" #t #f)
+(rewrite '< 9 "C_fixnum_lessp" "C_flonum_lessp" #t #f)
+(rewrite '>= 9 "C_fixnum_greater_or_equal_p" "C_flonum_greater_or_equal_p" #t #f)
+(rewrite '<= 9 "C_fixnum_less_or_equal_p" "C_flonum_less_or_equal_p" #t #f)
+
+(rewrite 'setter 11 1 '##sys#setter #t)
+(rewrite 'for-each 11 2 '##sys#for-each #t)
+(rewrite 'map 11 2 '##sys#map #t)
+(rewrite 'block-set! 11 3 '##sys#setslot #t)
+(rewrite '##sys#block-set! 11 3 '##sys#setslot #f)
+(rewrite 'make-record-instance 11 #f '##sys#make-structure #f)
+(rewrite 'substring 11 3 '##sys#substring #f)
+(rewrite 'string-append 11 2 '##sys#string-append #f)
+(rewrite 'string->list 11 1 '##sys#string->list #t)
+(rewrite 'list->string 11 1 '##sys#list->string #t)
+
+(rewrite 'vector-set! 11 3 '##sys#setslot #f)
+(rewrite 'vector-set! 2 3 "C_i_vector_set" #t #f)
+
+(rewrite '##sys#vector->list 11 1 'vector->list #t)
+(rewrite '##sys#list->vector 11 1 'list->vector #t)
+(rewrite '##sys#>= 11 2 '>= #t)
+(rewrite '##sys#= 11 2 '= #t)
+
+(rewrite 'gcd 12 '##sys#gcd #t 2)
+(rewrite 'lcm 12 '##sys#lcm #t 2)
+(rewrite 'identity 12 #f #t 1)
+
+(rewrite 'gcd 18 0)
+(rewrite 'lcm 18 1)
+(rewrite 'list 18 '())
+
+(rewrite 'argv 13 "C_get_argv" #t)
+
+(rewrite '* 16 2 "C_a_i_times" #t 4) ; words-per-flonum
+(rewrite '+ 16 2 "C_a_i_plus" #t 4) ; words-per-flonum
+(rewrite '- 16 2 "C_a_i_minus" #t 4) ; words-per-flonum
+(rewrite '/ 16 2 "C_a_i_divide" #t 4) ; words-per-flonum
+(rewrite '= 17 2 "C_i_nequalp")
+(rewrite '> 17 2 "C_i_greaterp")
+(rewrite '< 17 2 "C_i_lessp")
+(rewrite '>= 17 2 "C_i_greater_or_equalp")
+(rewrite '<= 17 2 "C_i_less_or_equalp")
+
+(rewrite '* 13 "C_times" #t)
+(rewrite '- 13 "C_minus" #t)
+(rewrite '+ 13 "C_plus" #t)
+(rewrite '/ 13 "C_divide" #t)
+(rewrite '= 13 "C_nequalp" #t)
+(rewrite '> 13 "C_greaterp" #t)
+(rewrite '< 13 "C_lessp" #t)
+(rewrite '>= 13 "C_greater_or_equal_p" #t)
+(rewrite '<= 13 "C_less_or_equal_p" #t)
+
+(rewrite 'exact->inexact 13 "C_exact_to_inexact" #t)
+(rewrite 'string->number 13 "C_string_to_number" #t)
+(rewrite 'number->string 13 "C_number_to_string" #t)
+(rewrite '##sys#call-with-current-continuation 13 "C_call_cc" #t)
+(rewrite '##sys#floor 13 "C_flonum_floor" #t)
+(rewrite '##sys#ceiling 13 "C_flonum_ceiling" #t)
+(rewrite '##sys#truncate 13 "C_flonum_truncate" #t)
+(rewrite '##sys#round 13 "C_flonum_round" #t)
+(rewrite '##sys#allocate-vector 13 "C_allocate_vector" #t)
+(rewrite '##sys#ensure-heap-reserve 13 "C_ensure_heap_reserve" #t)
+(rewrite 'return-to-host 13 "C_return_to_host" #t)
+(rewrite '##sys#context-switch 13 "C_context_switch" #t)
+(rewrite '##sys#intern-symbol 13 "C_string_to_symbol" #t)
+(rewrite '##sys#make-symbol 13 "C_make_symbol" #t)
+
+(rewrite 'even? 14 'fixnum 1 "C_i_fixnumevenp" "C_i_fixnumevenp")
+(rewrite 'odd? 14 'fixnum 1 "C_i_fixnumoddp" "C_i_fixnumoddp")
+(rewrite 'remainder 14 'fixnum 2 "C_fixnum_modulo" "C_fixnum_modulo")
+
+(rewrite 'even? 2 1 "C_i_evenp" #t #f)
+(rewrite 'even? 2 1 "C_u_i_evenp" #f #f)
+(rewrite 'odd? 2 1 "C_i_oddp" #t #f)
+(rewrite 'odd? 2 1 "C_u_i_oddp" #f #f)
+
+(rewrite 'floor 15 'flonum 'fixnum '##sys#floor #f)
+(rewrite 'ceiling 15 'flonum 'fixnum '##sys#ceiling #f)
+(rewrite 'truncate 15 'flonum 'fixnum '##sys#truncate #f)
+(rewrite 'round 15 'flonum 'fixnum '##sys#round #f)
+
+(rewrite 'cons 16 2 "C_a_i_cons" #t 3)
+(rewrite '##sys#cons 16 2 "C_a_i_cons" #t 3)
+(rewrite 'list 16 #f "C_a_i_list" #t '(3))
+(rewrite '##sys#list 16 #f "C_a_i_list" #t '(3))
+(rewrite 'vector 16 #f "C_a_i_vector" #t #t)
+(rewrite '##sys#vector 16 #f "C_a_i_vector" #t #t)
+(rewrite '##sys#make-structure 16 #f "C_a_i_record" #t #t)
+(rewrite 'string 16 #f "C_a_i_string" #t #t) ; the last #t is actually too much, but we don't care
+
+(rewrite
+ '##sys#setslot 8
+ (lambda (db classargs cont callargs)
+ ;; (##sys#setslot <x> <y> <immediate>) -> (##core#inline "C_i_set_i_slot" <x> <y> <i>)
+ ;; (##sys#setslot <x> <y> <z>) -> (##core#inline "C_i_setslot" <x> <y> <z>)
+ (and (= (length callargs) 3)
+ (make-node
+ '##core#call '(#t)
+ (list cont
+ (make-node
+ '##core#inline
+ (let ([val (third callargs)])
+ (if (and (eq? 'quote (node-class val))
+ (immediate? (first (node-parameters val))) )
+ '("C_i_set_i_slot")
+ '("C_i_setslot") ) )
+ callargs) ) ) ) ) )
+
+(rewrite 'fx+ 17 2 "C_fixnum_plus" "C_u_fixnum_plus")
+(rewrite 'fx- 17 2 "C_fixnum_difference" "C_u_fixnum_difference")
+(rewrite 'fxshl 17 2 "C_fixnum_shift_left")
+(rewrite 'fxshr 17 2 "C_fixnum_shift_right")
+(rewrite 'fxneg 17 1 "C_fixnum_negate" "C_u_fixnum_negate")
+(rewrite 'fxxor 17 2 "C_fixnum_xor" "C_fixnum_xor")
+(rewrite 'fxand 17 2 "C_fixnum_and" "C_u_fixnum_and")
+(rewrite 'fxior 17 2 "C_fixnum_or" "C_u_fixnum_or")
+
+(rewrite
+ 'arithmetic-shift 8
+ (lambda (db classargs cont callargs)
+ ;; (arithmetic-shift <x> <-int>) -> (##core#inline "C_fixnum_shift_right" <x> -<int>)
+ ;; (arithmetic-shift <x> <+int>) -> (##core#inline "C_fixnum_shift_left" <x> <int>)
+ ;; _ -> (##core#inline "C_a_i_arithmetic_shift" <x> <y>)
+ ;; not in fixnum-mode: _ -> (##core#inline_allocate ("C_a_i_arithmetic_shift" words-per-flonum) <x> <y>)
+ (and (= 2 (length callargs))
+ (let ([val (second callargs)])
+ (make-node
+ '##core#call '(#t)
+ (list cont
+ (or (and-let* ([(eq? 'quote (node-class val))]
+ [(eq? number-type 'fixnum)]
+ [n (first (node-parameters val))]
+ [(and (fixnum? n) (not (big-fixnum? n)))] )
+ (if (negative? n)
+ (make-node
+ '##core#inline '("C_fixnum_shift_right")
+ (list (first callargs) (qnode (- n))) )
+ (make-node
+ '##core#inline '("C_fixnum_shift_left")
+ (list (first callargs) val) ) ) )
+ (if (eq? number-type 'fixnum)
+ (make-node '##core#inline '("C_i_fixnum_arithmetic_shift") callargs)
+ (make-node '##core#inline_allocate (list "C_a_i_arithmetic_shift" words-per-flonum)
+ callargs) ) ) ) ) ) ) ) )
+
+(rewrite '##sys#byte 17 2 "C_subbyte")
+(rewrite '##sys#setbyte 17 3 "C_setbyte")
+(rewrite '##sys#peek-fixnum 17 2 "C_peek_fixnum")
+(rewrite '##sys#peek-byte 17 2 "C_peek_byte")
+(rewrite 'pointer->object 17 2 "C_pointer_to_object")
+(rewrite '##sys#setislot 17 3 "C_i_set_i_slot")
+(rewrite '##sys#poke-integer 17 3 "C_poke_integer")
+(rewrite '##sys#poke-double 17 3 "C_poke_double")
+(rewrite '##sys#double->number 17 1 "C_double_to_number")
+(rewrite 'string=? 17 2 "C_i_string_equal_p" "C_u_i_string_equal_p")
+(rewrite 'string-ci=? 17 2 "C_i_string_ci_equal_p")
+(rewrite '##sys#fudge 17 1 "C_fudge")
+(rewrite '##sys#fits-in-int? 17 1 "C_fits_in_int_p")
+(rewrite '##sys#fits-in-unsigned-int? 17 1 "C_fits_in_unsigned_int_p")
+(rewrite '##sys#flonum-in-fixnum-range? 17 1 "C_flonum_in_fixnum_range_p")
+(rewrite '##sys#permanent? 17 1 "C_permanentp")
+(rewrite '##sys#null-pointer? 17 1 "C_null_pointerp" "C_null_pointerp")
+(rewrite 'null-pointer? 17 1 "C_i_null_pointerp" "C_null_pointerp")
+(rewrite '##sys#immediate? 17 1 "C_immp")
+(rewrite 'locative->object 17 1 "C_i_locative_to_object")
+(rewrite 'locative-set! 17 2 "C_i_locative_set")
+(rewrite '##sys#foreign-fixnum-argument 17 1 "C_i_foreign_fixnum_argumentp")
+(rewrite '##sys#foreign-char-argument 17 1 "C_i_foreign_char_argumentp")
+(rewrite '##sys#foreign-flonum-argument 17 1 "C_i_foreign_flonum_argumentp")
+(rewrite '##sys#foreign-block-argument 17 1 "C_i_foreign_block_argumentp")
+(rewrite '##sys#foreign-number-vector-argument 17 2 "C_i_foreign_number_vector_argumentp")
+(rewrite '##sys#foreign-string-argument 17 1 "C_i_foreign_string_argumentp")
+(rewrite '##sys#foreign-pointer-argument 17 1 "C_i_foreign_pointer_argumentp")
+(rewrite '##sys#foreign-integer-argument 17 1 "C_i_foreign_integer_argumentp")
+(rewrite '##sys#foreign-unsigned-integer-argument 17 1 "C_i_foreign_unsigned_integer_argumentp")
+(rewrite '##sys#direct-return 17 2 "C_direct_return")
+
+(rewrite 'blob-size 2 1 "C_block_size" #f #f)
+
+(rewrite 'u8vector-ref 2 2 "C_u_i_u8vector_ref" #f #f)
+(rewrite 's8vector-ref 2 2 "C_u_i_s8vector_ref" #f #f)
+(rewrite 'u16vector-ref 2 2 "C_u_i_u16vector_ref" #f #f)
+(rewrite 's16vector-ref 2 2 "C_u_i_s16vector_ref" #f #f)
+
+(rewrite 'u32vector-ref 22 2 "C_a_i_u32vector_ref" #f words-per-flonum "C_u_i_u32vector_ref")
+(rewrite 's32vector-ref 22 2 "C_a_i_s32vector_ref" #f words-per-flonum "C_u_i_s32vector_ref")
+
+(rewrite 'u8vector-set! 2 3 "C_u_i_u8vector_set" #f #f)
+(rewrite 's8vector-set! 2 3 "C_u_i_s8vector_set" #f #f)
+(rewrite 'u16vector-set! 2 3 "C_u_i_u16vector_set" #f #f)
+(rewrite 's16vector-set! 2 3 "C_u_i_s16vector_set" #f #f)
+(rewrite 'u32vector-set! 2 3 "C_u_i_u32vector_set" #f #f)
+(rewrite 's32vector-set! 2 3 "C_u_i_s32vector_set" #f #f)
+
+(rewrite 'u8vector-length 2 1 "C_u_i_8vector_length" #f #f)
+(rewrite 's8vector-length 2 1 "C_u_i_8vector_length" #f #f)
+(rewrite 'u16vector-length 2 1 "C_u_i_16vector_length" #f #f)
+(rewrite 's16vector-length 2 1 "C_u_i_16vector_length" #f #f)
+(rewrite 'u32vector-length 2 1 "C_u_i_32vector_length" #f #f)
+(rewrite 's32vector-length 2 1 "C_u_i_32vector_length" #f #f)
+(rewrite 'f32vector-length 2 1 "C_u_i_32vector_length" #f #f)
+(rewrite 'f64vector-length 2 1 "C_u_i_64vector_length" #f #f)
+
+(rewrite 'not-pair? 17 1 "C_i_not_pair_p")
+(rewrite 'atom? 17 1 "C_i_not_pair_p")
+(rewrite 'null-list? 17 1 "C_i_null_list_p" "C_i_nullp")
+
+(rewrite 'u8vector->blob/shared 7 1 "C_slot" 1 #f)
+(rewrite 's8vector->blob/shared 7 1 "C_slot" 1 #f)
+(rewrite 'u16vector->blob/shared 7 1 "C_slot" 1 #f)
+(rewrite 's16vector->blob/shared 7 1 "C_slot" 1 #f)
+(rewrite 'u32vector->blob/shared 7 1 "C_slot" 1 #f)
+(rewrite 's32vector->blob/shared 7 1 "C_slot" 1 #f)
+(rewrite 'f32vector->blob/shared 7 1 "C_slot" 1 #f)
+(rewrite 'f64vector->blob/shared 7 1 "C_slot" 1 #f)
+
+(let ()
+ (define (rewrite-make-vector db classargs cont callargs)
+ ;; (make-vector '<n> [<x>]) -> (let ((<tmp> <x>)) (##core#inline_allocate ("C_a_i_vector" <n>+1) '<n> <tmp>))
+ ;; - <n> should be less or equal to 32.
+ (let ([argc (length callargs)])
+ (and (pair? callargs)
+ (let ([n (first callargs)])
+ (and (eq? 'quote (node-class n))
+ (let ([tmp (gensym)]
+ [c (first (node-parameters n))] )
+ (and (fixnum? c)
+ (<= c 32)
+ (let ([val (if (pair? (cdr callargs))
+ (second callargs)
+ (make-node '##core#undefined '() '()) ) ] )
+ (make-node
+ 'let
+ (list tmp)
+ (list val
+ (make-node
+ '##core#call '(#t)
+ (list cont
+ (make-node
+ '##core#inline_allocate
+ (list "C_a_i_vector" (add1 c))
+ (list-tabulate c (lambda (i) (varnode tmp)) ) ) ) ) ) ) ) ) ) ) ) ) ) )
+ (rewrite 'make-vector 8 rewrite-make-vector)
+ (rewrite '##sys#make-vector 8 rewrite-make-vector) )
+
+(rewrite 'thread-specific 7 1 "C_slot" 10 #f)
+(rewrite 'thread-specific-set! 20 2 "C_i_setslot" 10 #f)
+
+(let ()
+ (define (rewrite-call/cc db classargs cont callargs)
+ ;; (call/cc <var>), <var> = (lambda (kont k) ... k is never used ...) -> (<var> #f)
+ (and (= 1 (length callargs))
+ (let ([val (first callargs)])
+ (and (eq? '##core#variable (node-class val))
+ (and-let* ([proc (get db (first (node-parameters val)) 'value)]
+ [(eq? '##core#lambda (node-class proc))] )
+ (let ([llist (third (node-parameters proc))])
+ (decompose-lambda-list
+ llist
+ (lambda (vars argc rest)
+ (and (= argc 2)
+ (let ([var (or rest (second llist))])
+ (and (not (get db var 'references))
+ (not (get db var 'assigned))
+ (not (get db var 'inline-transient))
+ (make-node
+ '##core#call '(#t)
+ (list val cont (qnode #f)) ) ) ) ) ) ) ) ) ) ) ) )
+ (rewrite 'call-with-current-continuation 8 rewrite-call/cc)
+ (rewrite 'call/cc 8 rewrite-call/cc) )
+
+(declare (hide setter-map))
+
+(define setter-map
+ '((car . set-car!)
+ (cdr . set-cdr!)
+ (hash-table-ref . hash-table-set!)
+ (block-ref . block-set!)
+ (locative-ref . locative-set!)
+ (u8vector-ref . u8vector-set!)
+ (s8vector-ref . s8vector-set!)
+ (u16vector-ref . u16vector-set!)
+ (s16vector-ref . s16vector-set!)
+ (u32vector-ref . u32vector-set!)
+ (s32vector-ref . s32vector-set!)
+ (f32vector-ref . f32vector-set!)
+ (f64vector-ref . f64vector-set!)
+ (pointer-u8-ref . pointer-u8-set!)
+ (pointer-s8-ref . pointer-s8-set!)
+ (pointer-u16-ref . pointer-u16-set!)
+ (pointer-s16-ref . pointer-s16-set!)
+ (pointer-u32-ref . pointer-u32-set!)
+ (pointer-s32-ref . pointer-s32-set!)
+ (pointer-f32-ref . pointer-f32-set!)
+ (pointer-f64-ref . pointer-f64-set!)
+ (string-ref . string-set!)
+ (global-ref . global-set!)
+ (vector-ref . vector-set!) ) )
+
+(rewrite
+ '##sys#setter 8
+ (lambda (db classargs cont callargs)
+ ;; (setter <known-getter>) -> <known-setter>
+ (and (= 1 (length callargs))
+ (let ((arg (car callargs)))
+ (and (eq? '##core#variable (node-class arg))
+ (let ((sym (car (node-parameters arg))))
+ (and (intrinsic? sym)
+ (and-let* ((a (assq sym setter-map)))
+ (make-node
+ '##core#call '(#t)
+ (list cont (varnode (cdr a))) ) ) ) ) ) ) ) ) )
+
+(rewrite 'void 3 '##sys#undefined-value)
+(rewrite '##sys#void 3 '##sys#undefined-value)
+
+(rewrite
+ 'any? 8
+ (lambda (db classargs cont callargs)
+ (and (= 1 (length callargs))
+ (let ((arg (car callargs)))
+ (make-node
+ '##core#call '(#t)
+ (list cont
+ (if (and (eq? '##core#variable (node-class arg))
+ (not (get db (car (node-parameters arg)) 'global)) )
+ (qnode #t)
+ (make-node
+ '##core#inline '("C_anyp")
+ (list arg)) ) ) ) ) ) ) )
+
+(rewrite
+ 'bit-set? 8
+ (lambda (db classargs cont callargs)
+ (and (= 2 (length callargs))
+ (make-node
+ '##core#call '(#t)
+ (list cont
+ (make-node
+ '##core#inline
+ (list (if (eq? number-type 'fixnum) "C_u_i_bit_setp" "C_i_bit_setp"))
+ callargs) ) ) ) ) )
+
+(rewrite 'read-char 23 0 '##sys#read-char/port '##sys#standard-input)
+(rewrite 'write-char 23 1 '##sys#write-char/port '##sys#standard-output)
+(rewrite 'read-string 23 1 '##sys#read-string/port '##sys#standard-input)
+(rewrite 'substring=? 23 2 '##sys#substring=? 0 0 #f)
+(rewrite 'substring-ci=? 23 2 '##sys#substring-ci=? 0 0 #f)
+(rewrite 'substring-index 23 2 '##sys#substring-index 0)
+(rewrite 'substring-index-ci 23 2 '##sys#substring-index-ci 0)
diff --git a/cconv-sample.c b/cconv-sample.c
new file mode 100644
index 00000000..56325686
--- /dev/null
+++ b/cconv-sample.c
@@ -0,0 +1,23 @@
+/* cconv-sample.c */
+
+
+#include "chicken.h"
+
+
+void foo(C_word x1, C_word x2, C_word x3, C_word x4, C_word x5,
+ C_word x6, C_word x7, C_word x8, C_word x9, C_word x10) C_noret;
+
+void
+foo(C_word x1, C_word x2, C_word x3, C_word x4, C_word x5,
+ C_word x6, C_word x7, C_word x8, C_word x9, C_word x10)
+{
+ exit(0);
+}
+
+
+void
+callfoo()
+{
+ foo(C_fix(1), C_fix(2), C_fix(3), C_fix(4), C_fix(5),
+ C_fix(6), C_fix(7), C_fix(8), C_fix(9), C_fix(10) );
+}
diff --git a/chicken-bug.1 b/chicken-bug.1
new file mode 100644
index 00000000..1e38b1a1
--- /dev/null
+++ b/chicken-bug.1
@@ -0,0 +1,63 @@
+.\" dummy line
+.TH CHICKEN-BUG 1 "19 Sep 2001"
+
+.SH NAME
+
+chicken-bug \- generates a Chicken Scheme bug report from user input
+
+.SH SYNOPSIS
+
+.B chicken-bug
+[
+.I filename
+|
+.I OPTION ...
+]
+
+.SH OPTIONS
+
+.TP
+.B \-help
+Show usage information.
+
+.TP
+.B \-to-stdout
+Write bug report to standard output instead of writing it to a file.
+
+.TP
+.B \-
+Read user input from standard input, even if files are given on the command line.
+
+.SH DESCRIPTION
+
+.I chicken-bug
+generates a bug report file that collects user-input, optional
+files and system information obtained from the installed CHICKEN
+executables and libraries. Non-option arguments given on the command line
+are inserted into the bug report. If no option is given, or if
+.B \-
+has been passed on the command line, then a description of the problem
+is read from standard input, until EOF (CTRL-D) is read.
+
+The report will be automatically e-mailed to the CHICKEN maintainers,
+if an SMTP connection can be established. If no connection can be
+made, the bug report will be written to a file in the current directory,
+which should be sent to CHICKEN maintainers as it contains various
+useful bits of information that make it easier to classify the
+problem described.
+
+Bug reports should be as detailed as possible. It is also very helpful
+to include code that reproduces the problem. The more detailed the input
+and the more thorough the description is, the easier you make it for
+the CHICKEN developers to help you.
+
+.SH BUGS
+Submit bug reports by e-mail to
+.I chicken-janitors@nongnu.org
+
+.SH AUTHOR
+Felix L. Winkelmann (felix@call-with-current-continuation.org)
+and The Chicken Team.
+
+.SH SEE ALSO
+.BR chicken(1)
diff --git a/chicken-bug.scm b/chicken-bug.scm
new file mode 100644
index 00000000..3980ece1
--- /dev/null
+++ b/chicken-bug.scm
@@ -0,0 +1,264 @@
+;;;; chicken-bug.scm - Bug report-generator
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(require-extension srfi-13 posix tcp data-structures utils extras)
+
+
+(define-constant +bug-report-file+ "chicken-bug-report.~a-~a-~a")
+
+(define-constant +fallbackdestinations+
+ "chicken-janitors@nongnu.org\nchicken-hackers@nongnu.org\nchicken-users@nongnu.org")
+
+(define-constant +destination+ "chicken-janitors@nongnu.org")
+(define-constant +mxservers+ (list "mx10.gnu.org" "mx20.gnu.org"))
+(define-constant +send-tries+ 3)
+
+(define-foreign-variable +cc+ c-string "C_TARGET_CC")
+(define-foreign-variable +cxx+ c-string "C_TARGET_CXX")
+(define-foreign-variable +c-include-path+ c-string "C_INSTALL_INCLUDE_HOME")
+
+(define (user-id)
+ (cond-expand
+ ((or mingw32 msvc) "<not available>")
+ (else (user-information (current-user-id)))))
+
+(define (collect-info)
+ (print "\n--------------------------------------------------\n")
+ (print "This is a bug report generated by chicken-bug(1).\n")
+ (print "Date:\t" (seconds->string (current-seconds)) "\n\n")
+ (printf "User information:\t~s~%~%" (user-id))
+ (print "Host information:\n")
+ (print "\tmachine type:\t" (machine-type))
+ (print "\tsoftware type:\t" (software-type))
+ (print "\tsoftware version:\t" (software-version))
+ (print "\tbuild platform:\t" (build-platform) "\n")
+ (print "CHICKEN version is:\n" (chicken-version #t) "\n")
+ (print "Home directory:\t" (chicken-home) "\n")
+ (printf "Include path:\t~s~%~%" ##sys#include-pathnames)
+ (print "Features:")
+ (for-each
+ (lambda (lst)
+ (display "\n ")
+ (for-each
+ (lambda (f)
+ (printf "~a~a" f (make-string (fxmax 1 (fx- 16 (string-length f))) #\space)) )
+ lst) )
+ (chop (sort (map keyword->string ##sys#features) string<?) 5))
+ (print "\n\nchicken-config.h:\n")
+ (with-input-from-file (make-pathname +c-include-path+ "chicken-config.h")
+ (lambda ()
+ (display (read-all)) ) )
+ (newline)
+ (when (and (string=? +cc+ "gcc") (feature? 'unix))
+ (print "CC seems to be gcc, trying to obtain version...\n")
+ (with-input-from-pipe "gcc -v 2>&1"
+ (lambda ()
+ (display (read-all)))))
+ (newline) )
+
+(define (usage code)
+ (print #<<EOF
+usage: chicken-bug [FILENAME ...]
+
+ -help -h show this message
+ -to-stdout write bug report to standard output
+ - read description from standard input
+
+Generates a bug report file from user input or alternatively
+from the contents of files given on the command line.
+
+EOF
+)
+ (exit code) )
+
+(define (user-input)
+ (when (##sys#tty-port? (current-input-port))
+ (print #<<EOF
+This is the CHICKEN bug report generator. Please enter a detailed
+description of the problem you have encountered and enter CTRL-D (EOF)
+once you have finished. Press CTRL-C to abort the program. You can
+also pass the description from a file (just abort now and re-invoke
+"chicken-bug" with one or more input files given on the command-line)
+
+EOF
+) )
+ (read-all) )
+
+(define (justify n)
+ (let ((s (number->string n)))
+ (if (> (string-length s) 1)
+ s
+ (string-append "0" s))))
+
+(define (main args)
+ (let ((msg "")
+ (files #f)
+ (stdout #f))
+ (for-each
+ (lambda (arg)
+ (cond ((string=? "-" arg)
+ (set! files #t)
+ (set! msg (string-append msg "\n\nUser input:\n\n" (user-input))) )
+ ((member arg '("--help" "-h" "-help"))
+ (usage 0) )
+ ((string=? "-to-stdout" arg)
+ (set! stdout #t) )
+ (else
+ (set! files #t)
+ (set! msg
+ (string-append
+ msg
+ "\n\nFile added: " arg "\n\n"
+ (read-all arg) ) ) ) ) )
+ args)
+ (unless files
+ (set! msg (string-append msg "\n\n" (user-input))))
+ (newline)
+ (let* ((lt (seconds->local-time (current-seconds)))
+ (day (vector-ref lt 3))
+ (mon (vector-ref lt 4))
+ (yr (vector-ref lt 5)) )
+ (if stdout
+ (begin
+ (print msg)
+ (collect-info))
+ (try-mail
+ +mxservers+
+ (sprintf +bug-report-file+ (+ 1900 yr) (justify mon) (justify day))
+ (mail-headers)
+ (with-output-to-string
+ (lambda ()
+ (print msg)
+ (collect-info))))))))
+ ;(let* ((file (sprintf +bug-report-file+ (+ 1900 yr) (justify mon) (justify day)))
+ ; (port (if stdout (current-output-port) (open-output-file file))))
+ ;(with-output-to-port port
+ ; (lambda ()
+ ; (print msg)
+ ; (collect-info) ) )
+ ;(unless stdout
+ ; (close-output-port port)
+ ; (print "\nA bug report has been written to `" file "'. Please send it to")
+ ; (print "one of the following addresses:\n\n" +destinations+) ) ) ) ) )
+
+(define (try-mail servs fname hdrs msg)
+ (if (null? servs)
+ (begin
+ (with-output-to-file fname
+ (lambda () (print msg)))
+ (print "\nCould not send mail automatically!\n\nA bug report has been written to `" fname "'. Please send it to")
+ (print "one of the following addresses:\n\n" +fallbackdestinations+))
+ (or (send-mail (car servs) msg hdrs fname)
+ (try-mail (cdr servs) fname hdrs msg))))
+
+(define (mail-date-str tm)
+ (string-append
+ (case (vector-ref tm 6)
+ ((0) "Sun, ")
+ ((1) "Mon, ")
+ ((2) "Tue, ")
+ ((3) "Wed, ")
+ ((4) "Thu, ")
+ ((5) "Fri, ")
+ ((6) "Sat, "))
+ (string-pad (number->string (vector-ref tm 3)) 2 #\0)
+ (case (vector-ref tm 4)
+ ((0) " Jan ")
+ ((1) " Feb ")
+ ((2) " Mar ")
+ ((3) " Apr ")
+ ((4) " May ")
+ ((5) " Jun ")
+ ((6) " Jul ")
+ ((7) " Aug ")
+ ((8) " Sep ")
+ ((9) " Oct ")
+ ((10) " Nov ")
+ ((11) " Dec "))
+ (number->string (+ 1900 (vector-ref tm 5)))
+ " "
+ (string-pad (number->string (vector-ref tm 2)) 2 #\0)
+ ":"
+ (string-pad (number->string (vector-ref tm 1)) 2 #\0)
+ ":"
+ (string-pad (number->string (vector-ref tm 0)) 2 #\0)
+ " +0000"))
+
+(define (mail-headers)
+ (string-append
+ "Date: " (mail-date-str (seconds->utc-time (current-seconds))) "\r\n"
+ "From: \"chicken-bug user\" <chicken-bug-command@callcc.org>\r\n"
+ "To: \"Chicken Janitors\" <chicken-janitors@nongnu.org>\r\n"
+ "Subject: Automated chicken-bug output -- "))
+
+(define (mail-read i o)
+ (let ((v (condition-case (read-line i)
+ (var () (close-input-port i) (close-output-port o) #f))))
+ (if v
+ (if (char-numeric? (string-ref v 0))
+ (string->number (substring v 0 3))
+ (mail-read i o))
+ #f)))
+
+(define (mail-write i o m)
+ (let ((v (condition-case (display m o)
+ (var () (close-input-port i) (close-output-port o) #f))))
+ (if v
+ (mail-read i o)
+ #f)))
+
+(define (mail-check i o v e k)
+ (if (and v (= v e))
+ #t
+ (begin
+ (close-input-port i)
+ (close-output-port o)
+ (k #f))))
+
+(define (send-mail serv msg hdrs fname)
+ (call/cc
+ (lambda (return)
+ (do ((try 1 (add1 try)))
+ ((> try +send-tries+))
+ (print* "connecting to " serv ", try #" try " ...")
+ (receive (i o)
+ (tcp-connect serv 25)
+ (call-with-current-continuation
+ (lambda (k)
+ (mail-check i o (mail-read i o) 220 k)
+ (mail-check i o (mail-write i o "HELO callcc.org\r\n") 250 k)
+ (mail-check i o (mail-write i o "MAIL FROM:<chicken-bug-command@callcc.org>\r\n") 250 k)
+ (mail-check i o (mail-write i o "RCPT TO:<chicken-janitors@nongnu.org>\r\n") 250 k)
+ (mail-check i o (mail-write i o "DATA\r\n") 354 k)
+ (mail-check i o (mail-write i o (string-append hdrs fname "\r\n\r\n" msg "\r\n.\r\n")) 250 k)
+ (display "QUIT" o)
+ (close-input-port i)
+ (close-output-port o)
+ (print "ok.\n\nBug report successfully mailed to the Chicken maintainers.\nThank you very much!\n\n")
+ (return #t))))
+ (print " failed.")))))
+
+(main (command-line-arguments))
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
new file mode 100644
index 00000000..a4650a72
--- /dev/null
+++ b/chicken-ffi-syntax.scm
@@ -0,0 +1,163 @@
+;;;; chicken-ffi-syntax.scm
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(define ##sys#chicken-ffi-macro-environment
+ (let ((me0 (##sys#macro-environment)))
+
+(##sys#extend-macro-environment
+ 'define-external
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (let* ((form (cdr form))
+ (%quote (r 'quote))
+ (quals (and (pair? form) (string? (car form))))
+ (var (and (not quals) (pair? form) (symbol? (car form)))) )
+ (cond [var
+ (##sys#check-syntax 'define-external form '(symbol _ . #(_ 0 1)))
+ (let ([var (car form)])
+ `(,(r 'begin)
+ (,(r 'define-foreign-variable) ,var ,(cadr form))
+ (,(r 'define-external-variable) ,var ,(cadr form) #t)
+ ,@(if (pair? (cddr form))
+ `((##core#set! ,var ,(caddr form)))
+ '() ) ) ) ]
+ [else
+ (if quals
+ (##sys#check-syntax 'define-external form '(string (symbol . #((_ symbol) 0)) _ . #(_ 1)))
+ (##sys#check-syntax 'define-external form '((symbol . #((_ symbol) 0)) _ . #(_ 1))) )
+ (let* ([head (if quals (cadr form) (car form))]
+ [args (cdr head)] )
+ `(,(r 'define) ,(car head)
+ (##core#foreign-callback-wrapper
+ ',(car head)
+ ,(if quals (car form) "")
+ ',(if quals (caddr form) (cadr form))
+ ',(map (lambda (a) (car a)) args)
+ (,(r 'lambda)
+ ,(map (lambda (a) (cadr a)) args)
+ ,@(if quals (cdddr form) (cddr form)) ) ) ) ) ] ) ) ) ) )
+
+
+
+;;; External locations:
+
+(##sys#extend-macro-environment
+ 'define-location
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'define-location form '(_ variable _ . #(_ 0 1)))
+ (let ((var (cadr form))
+ (type (caddr form))
+ (init (optional (cdddr form) #f))
+ (name (r (gensym))))
+ `(,(r 'begin)
+ (,(r 'define-foreign-variable) ,var ,type ,(symbol->string name))
+ (,(r 'define-external-variable) ,var ,type #f ,name)
+ ,@(if (pair? init)
+ `((##core#set! ,var ,(car init)))
+ '() ) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'let-location
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'let-location form '(_ #((variable _ . #(_ 0 1)) 0) . _))
+ (let* ((bindings (cadr form))
+ (body (cddr form))
+ (%let (r 'let))
+ [aliases (map (lambda (_) (r (gensym))) bindings)])
+ `(,%let ,(append-map
+ (lambda (b a)
+ (if (pair? (cddr b))
+ (list (cons a (cddr b)))
+ '() ) )
+ bindings aliases)
+ ,(fold-right
+ (lambda (b a rest)
+ (if (= 3 (length b))
+ `(##core#let-location
+ ,(car b)
+ ,(cadr b)
+ ,a
+ ,rest)
+ `(##core#let-location
+ ,(car b)
+ ,(cadr b)
+ ,rest) ) )
+ `(,%let () ,@body)
+ bindings aliases) ) ) ) ) )
+
+
+;;; Embedding code directly:
+
+(##sys#extend-macro-environment
+ 'foreign-code
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'foreign-code form '(_ . #(string 0)))
+ (let ([tmp (gensym 'code_)])
+ `(,(r 'begin)
+ (,(r 'declare)
+ (foreign-declare
+ ,(sprintf "static C_word ~A() { ~A\n; return C_SCHEME_UNDEFINED; }\n"
+ tmp
+ (string-intersperse (cdr form) "\n")) ) )
+ (##core#inline ,tmp) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'foreign-value
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'foreign-value form '(_ _ _))
+ (let ((tmp (gensym 'code_))
+ (code (cadr form)))
+ `(,(r 'begin)
+ (,(r 'define-foreign-variable) ,tmp
+ ,(caddr form)
+ ,(cond ((string? code) code)
+ ((symbol? code) (symbol->string code))
+ (else (syntax-error 'foreign-value "bad argument type - not a string or symbol" code))))
+ ,tmp) ) ) ) )
+
+
+;;; Include/parse foreign code fragments
+
+(##sys#extend-macro-environment
+ 'foreign-declare
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'foreign-declare form '(_ . #(string 0)))
+ `(##core#declare (foreign-declare ,@(cdr form))))))
+
+
+(##sys#macro-subset me0)))
diff --git a/chicken-install.1 b/chicken-install.1
new file mode 100644
index 00000000..e1454e27
--- /dev/null
+++ b/chicken-install.1
@@ -0,0 +1,155 @@
+.\" dummy line
+.TH CHICKEN-INSTALL 1 "13 Aug 2008"
+
+.SH NAME
+
+chicken-install \- download and install extension libraries for Chicken Scheme
+
+.SH SYNOPSIS
+
+chicken-install [OPTION | EXTENSION[:VERSION]] ...
+
+.SH DESCRIPTION
+
+.I chicken\-install
+is a program that downloads, compiles and installs a prepackaged
+extension library from sources. If no extension name is given on the
+command-line, then any existing
+.B setup
+scripts in the current
+directory will be executed in some unspecified order.
+See the
+.B Chicken
+manual for more information.
+
+.SH OPTIONS
+
+.TP
+.B \-h,\ \-help
+Shows a summary of options and exits.
+
+.TP
+.B \-v,\ \-version
+Shows tool version and exits.
+
+.TP
+.B \-force
+Do not ask when versions don't match, continue with the installation instead.
+
+.TP
+.BI \-i,\ \-init\ DIRECTORY
+Initialize empty alternative repository.
+
+.TP
+.B \-k,\ \-keep
+Keep temporary directories after an installation process finished
+(whether successfull or not).
+
+.TP
+.N \-n\-install
+Do not install the extension, just build it. Implies
+.B \-keep
+
+.TP
+.BI \-l,\ \-location \ LOCATION
+Specifies the location from where to retrieve the extension sources.
+Defaults to the current official egg-repository suitable for this
+version of
+.B CHICKEN
+Depending on the transport used (see below), the
+.B LOCATION
+may be an svn(1) repository URL, a http URL or a location in the local
+file-system.
+
+.TP
+.BI \-t,\ \-transport \ TRANSPORT
+Selects the mechanism to use to download any extensions that are directly
+or indirectly to be installed. Currently the transports
+.B http
+(the default, retrieve files via the HTTP protocol),
+.B svn
+(retrieve by performing a checkout - requires the svn(1) client to be
+installed) and
+.B local
+(install directly from the local file-system).
+
+.TP
+.B \-s,\ \-sudo
+Perform any installation steps the install files by commands invoked
+with the sudo(1) tool.
+
+.TP
+.B \-u,\ \-update
+Scan all installed import libraries and generate module database file.
+
+.TP
+.B \-r,\ \-retrieve
+Only fetch the extensions, do not install them.
+
+.TP
+.BI \-p,\ \-prefix \ PREFIX
+Select an alternative installation prefix.
+
+.TP
+.B \-host\-extension
+Mark this extension as a "host" extension. This is mainly intended
+for cross-compilation.
+
+.TP
+.B \-test
+After successfull installation, invoke any accompanying test-suite,
+if found in the extension sources. When this option is given, additional
+dependencies configured in the
+.B test\-depends
+meta property may be downloaded and installed, if necessary.
+
+.TP
+.BI \-username USERNAME
+Set username for transports that require authentification.
+
+.TP
+.BI \-password PASSWORD
+Set password for transports that require authentification.
+
+.SH ENVIRONMENT\ VARIABLES
+
+.TP
+.B CHICKEN_PREFIX
+The installation prefix where CHICKEN Scheme and its support files and
+libraries are located. Defaults to the installation time prefix given
+when configuring the system.
+
+.TP
+.B CHICKEN_INSTALL_PREFIX
+An alternative installation prefix that will be prepended to extension
+installation paths if specified.
+
+.TP
+.B CHICKEN_REPOSITORY
+The path where extension libraries are installed. Defaults to the package-library
+path selected during configuration (usually
+.B $prefix/lib/chicken/<binary\-version>
+)
+
+
+.SH DOCUMENTATION
+
+More information can be found in the
+.I Chicken\ User's\ Manual
+
+.SH BUGS
+Submit bug reports by e-mail to
+.I chicken-janitors@nongnu.org
+, preferrably using the
+.B chicken\-bug
+tool.
+
+.SH AUTHORS
+The Chicken Team
+
+.SH SEE ALSO
+.BR chicken-uninstall(1)
+.BR chicken-status(1)
+.BR chicken(1)
+.BR csc(1)
+.BR chicken-bug(1)
diff --git a/chicken-install.scm b/chicken-install.scm
new file mode 100644
index 00000000..08faf100
--- /dev/null
+++ b/chicken-install.scm
@@ -0,0 +1,523 @@
+;;;; chicken-install.scm
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(require-library setup-download setup-api)
+(require-library srfi-1 posix data-structures utils regex ports extras
+ srfi-13 files)
+(require-library chicken-syntax) ; in case an import library reexports chicken syntax
+
+
+(module main ()
+
+ (import scheme chicken srfi-1 posix data-structures utils regex ports extras
+ srfi-13 files)
+ (import setup-download setup-api)
+
+ (import foreign)
+
+ (define +default-repository-files+
+ '("setup-api.so" "setup-api.import.so"
+ "setup-download.so" "setup-download.import.so"
+ "chicken.import.so"
+ "lolevel.import.so"
+ "srfi-1.import.so"
+ "srfi-4.import.so"
+ "data-structures.import.so"
+ "ports.import.so"
+ "files.import.so"
+ "posix.import.so"
+ "srfi-13.import.so"
+ "srfi-69.import.so"
+ "extras.import.so"
+ "regex.import.so"
+ "srfi-14.import.so"
+ "tcp.import.so"
+ "foreign.import.so"
+ "scheme.import.so"
+ "srfi-18.import.so"
+ "utils.import.so"
+ "csi.import.so"
+ "irregex.import.so"
+ "types.db"))
+
+ (define *program-path*
+ (or (and-let* ((p (get-environment-variable "CHICKEN_PREFIX")))
+ (make-pathname p "bin") )
+ (foreign-value "C_INSTALL_BIN_HOME" c-string) ) )
+
+ (define *keep* #f)
+ (define *force* #f)
+ (define *prefix* #f)
+ (define *host-extension* #f)
+ (define *run-tests* #f)
+ (define *retrieve-only* #f)
+ (define *no-install* #f)
+ (define *username* #f)
+ (define *password* #f)
+ (define *default-sources* '())
+ (define *default-location* #f)
+ (define *default-transport* 'http)
+ (define *windows-shell* (foreign-value "C_WINDOWS_SHELL" bool))
+
+ (define-constant +module-db+ "modules.db")
+ (define-constant +defaults-file+ "setup.defaults")
+
+ (define (load-defaults)
+ (let ([deff (make-pathname (chicken-home) +defaults-file+)])
+ (cond [(not (file-exists? deff))
+ '() ]
+ [else
+ (set! *default-sources* (read-file deff))
+ (pair? *default-sources*) ] ) ) )
+
+ (define (known-default-sources)
+ (if (and *default-location* *default-transport*)
+ `(((location ,*default-location*)
+ (transport ,*default-transport*)))
+ *default-sources* ) )
+
+ (define (invalidate-default-source! def)
+ (set! *default-sources* (delete def *default-sources* eq?)) )
+
+ (define (deps key meta)
+ (or (and-let* ((d (assq key meta)))
+ (cdr d))
+ '()))
+
+ (define (init-repository dir)
+ (let ((src (repository-path))
+ (copy (if *windows-shell*
+ "copy"
+ "cp -r")))
+ (print "copying required files to " dir " ...")
+ (for-each
+ (lambda (f)
+ ($system (sprintf "~a ~a ~a" copy (shellpath (make-pathname src f)) (shellpath dir))))
+ +default-repository-files+)))
+
+ (define (ext-version x)
+ (cond ((or (eq? x 'chicken)
+ (equal? x "chicken")
+ (member (->string x) ##sys#core-library-modules))
+ (chicken-version) )
+ ((extension-information x) =>
+ (lambda (info)
+ (let ((a (assq 'version info)))
+ (if a
+ (->string (cadr a))
+ "0.0.0"))))
+ (else #f)))
+
+ (define (meta-dependencies meta)
+ (append
+ (deps 'depends meta)
+ (deps 'needs meta)
+ (if *run-tests* (deps 'test-depends meta) '())))
+
+ (define (outdated-dependencies meta)
+ (let ((ds (meta-dependencies meta)))
+ (let loop ((deps ds) (missing '()) (upgrade '()))
+ (if (null? deps)
+ (values (reverse missing) (reverse upgrade))
+ (let ((dep (car deps))
+ (rest (cdr deps)))
+ (cond ((or (symbol? dep) (string? dep))
+ (loop rest
+ (if (ext-version dep)
+ missing
+ (cons (->string dep) missing))
+ upgrade))
+ ((and (list? dep) (= 2 (length dep))
+ (or (string? (car dep)) (symbol? (car dep))))
+ (let ((v (ext-version (car dep))))
+ (cond ((not v)
+ (loop rest (cons (->string (car dep)) missing) upgrade))
+ ((not (version>=? v (->string (cadr dep))))
+ (when (string=? "chicken" (->string (car dep)))
+ (error
+ (string-append
+ "Your CHICKEN version is not recent enough to use this extension - version "
+ (cadr dep)
+ " or newer is required")))
+ (loop rest missing
+ (alist-cons
+ (->string (car dep)) (->string (cadr dep))
+ upgrade)))
+ (else (loop rest missing upgrade)))))
+ (else
+ (warning
+ "invalid dependency syntax in extension meta information"
+ dep)
+ (loop rest missing upgrade))))))))
+
+ (define *eggs+dirs+vers* '())
+ (define *dependencies* '())
+ (define *checked* '())
+ (define *csi* (shellpath (make-pathname *program-path* (foreign-value "C_CSI_PROGRAM" c-string))))
+
+ (define (try-extension name version trans locn)
+ (condition-case
+ (retrieve-extension
+ name trans locn
+ version: version
+ destination: (and *retrieve-only* (current-directory))
+ tests: *run-tests*
+ username: *username*
+ password: *password*)
+ [(exn net)
+ (print "TCP connect timeout")
+ (values #f "") ]
+ [(exn http-fetch)
+ (print "HTTP protocol error")
+ (values #f "") ]
+ [e (exn setup-download-error)
+ (print "Server error:")
+ (print-error-message e)
+ (values #f "")]
+ [e ()
+ (abort e) ] ) )
+
+ (define (try-default-sources name version)
+ (let trying-sources ([defs (known-default-sources)])
+ (if (null? defs)
+ (values #f "")
+ (let* ([def (car defs)]
+ [locn (cadr (or (assq 'location def)
+ (error "missing location entry" def)))]
+ [trans (cadr (or (assq 'transport def)
+ (error "missing transport entry" def)))])
+ (let-values ([(dir ver) (try-extension name version trans locn)])
+ (if dir
+ (values dir ver)
+ (begin
+ (invalidate-default-source! def)
+ (trying-sources (cdr defs)) ) ) ) ) ) ) )
+
+ (define (make-replace-extension-question e+d+v upgrade)
+ (string-concatenate
+ (append
+ (list "The following installed extensions are outdated, because `"
+ (car e+d+v)
+ "' requires later versions:\n")
+ (map
+ (lambda (e)
+ (conc
+ " " (car e)
+ " (" (let ([v (assq 'version (extension-information (car e)))]) (if v (cadr v) "???"))
+ " -> " (cdr e) ")"
+ #\newline) )
+ upgrade)
+ '("\nDo you want to replace the existing extensions?"))) )
+
+ (define (retrieve eggs)
+ (print "retrieving ...")
+ (for-each
+ (lambda (egg)
+ (cond [(assoc egg *eggs+dirs+vers*) =>
+ (lambda (a)
+ ;; push to front
+ (set! *eggs+dirs+vers* (cons a (delete a *eggs+dirs+vers* eq?))) ) ]
+ [else
+ (let ([name (if (pair? egg) (car egg) egg)]
+ [version (and (pair? egg) (cdr egg))])
+ (let-values ([(dir ver) (try-default-sources name version)])
+ (unless dir (error "extension or version not found"))
+ (print " " name " located at " dir)
+ (set! *eggs+dirs+vers* (cons (list name dir ver) *eggs+dirs+vers*)) ) ) ] ) )
+ eggs)
+ (unless *retrieve-only*
+ (for-each
+ (lambda (e+d+v)
+ (unless (member (car e+d+v) *checked*)
+ (set! *checked* (cons (car e+d+v) *checked*))
+ (let ([mfile (make-pathname (cadr e+d+v) (car e+d+v) "meta")])
+ (cond [(file-exists? mfile)
+ (let ([meta (with-input-from-file mfile read)])
+ (print "checking dependencies for `" (car e+d+v) "' ...")
+ (let-values ([(missing upgrade) (outdated-dependencies meta)])
+ (set! *dependencies*
+ (cons
+ (cons (car e+d+v) (append missing upgrade))
+ *dependencies*))
+ (when (pair? missing)
+ (print " missing: " (string-intersperse missing ", "))
+ (retrieve missing))
+ (when (and (pair? upgrade)
+ (or *force*
+ (yes-or-no?
+ (make-replace-extension-question e+d+v upgrade)
+ "no") ) )
+ (let ([ueggs (unzip1 upgrade)])
+ (print " upgrade: " (string-intersperse ueggs ", "))
+ (for-each
+ (lambda (e)
+ (print "removing previously installed extension `" e "' ...")
+ (remove-extension e) )
+ ueggs)
+ (retrieve ueggs) ) ) ) ) ]
+ [else
+ (warning
+ (string-append
+ "extension `" (car e+d+v) "' has no .meta file "
+ "- assuming it has no dependencies")) ] ) ) ) )
+ *eggs+dirs+vers*) ) )
+
+ (define (make-install-command e+d+v)
+ (conc
+ *csi*
+ " -bnq -setup-mode -e \"(require-library setup-api)\" -e \"(import setup-api)\""
+ (sprintf " -e \"(extension-name-and-version '(\\\"~a\\\" \\\"~a\\\"))\"" (car e+d+v) (caddr e+d+v))
+ (if (sudo-install) " -e \"(sudo-install #t)\"" "")
+ (if *keep* " -e \"(keep-intermediates #t)\"" "")
+ (if *no-install* " -e \"(setup-install-mode #f)\"" "")
+ (if *host-extension* " -e \"(host-extension #t)\"" "")
+ (if *prefix* (sprintf " -e \"(installation-prefix \\\"~a\\\")\"" *prefix*) "")
+ #\space (shellpath (make-pathname (cadr e+d+v) (car e+d+v) "setup"))) )
+
+ (define (install eggs)
+ (retrieve eggs)
+ (unless *retrieve-only*
+ (let ((dag (reverse (topological-sort *dependencies* string=?))))
+ (print "install order:")
+ (pp dag)
+ (for-each
+ (lambda (e+d+v)
+ (print "installing " (car e+d+v) #\: (caddr e+d+v) " ...")
+ (print "changing current directory to " (cadr e+d+v))
+ (parameterize ((current-directory (cadr e+d+v)))
+ (let ([cmd (make-install-command e+d+v)])
+ (print " " cmd)
+ ($system cmd))
+ (when (and *run-tests*
+ (file-exists? "tests")
+ (directory? "tests")
+ (file-exists? "tests/run.scm") )
+ (current-directory "tests")
+ (let ((cmd (sprintf "~a -s run.scm ~a" *csi* (car e+d+v))))
+ (print " " cmd)
+ ($system cmd)))))
+ (map (cut assoc <> *eggs+dirs+vers*) dag)))))
+
+ (define (cleanup)
+ (unless *keep*
+ (and-let* ((tmpdir (temporary-directory)))
+ (remove-directory tmpdir))))
+
+ (define (update-db)
+ (let* ((files (glob (make-pathname (repository-path) "*.import.*")))
+ (tmpdir (create-temporary-directory))
+ (dbfile (make-pathname tmpdir +module-db+))
+ (rx (regexp ".*/([^/]+)\\.import\\.(scm|so)")))
+ (print "loading import libraries ...")
+ (fluid-let ((##sys#warnings-enabled #f))
+ (for-each
+ (lambda (f)
+ (let ((m (string-match rx f)))
+ (handle-exceptions ex
+ (print-error-message
+ ex (current-error-port)
+ (sprintf "Failed to import from `~a'" f))
+ (eval `(import ,(string->symbol (cadr m)))))))
+ files))
+ (print "generating database")
+ (let ((db
+ (sort
+ (append-map
+ (lambda (m)
+ (let* ((mod (cdr m))
+ (mname (##sys#module-name mod)))
+ (print* " " mname)
+ (let-values (((_ ve se) (##sys#module-exports mod)))
+ (append
+ (map (lambda (se) (list (car se) 'syntax mname)) se)
+ (map (lambda (ve) (list (car ve) 'value mname)) ve)))))
+ ##sys#module-table)
+ (lambda (e1 e2)
+ (string<? (symbol->string (car e1)) (symbol->string (car e2)))))))
+ (newline)
+ (with-output-to-file dbfile
+ (lambda ()
+ (for-each (lambda (x) (write x) (newline)) db)))
+ (copy-file dbfile (make-pathname (repository-path) +module-db+))
+ (remove-directory tmpdir))))
+
+ (define ($system str)
+ (let ((r (system
+ (if *windows-shell*
+ (string-append "\"" str "\"")
+ str))))
+ (unless (zero? r)
+ (error "shell command terminated with nonzero exit code" r str))))
+
+ (define (usage code)
+ (print #<<EOF
+usage: chicken-install [OPTION | EXTENSION[:VERSION]] ...
+
+ -h -help show this message and exit
+ -v -version show version and exit
+ -force don't ask, install even if versions don't match
+ -k -keep keep temporary files
+ -l -location LOCATION install from given location instead of default
+ -t -transport TRANSPORT use given transport instead of default
+ -s -sudo use sudo(1) for filesystem operations
+ -r -retrieve only retrieve egg into current directory, don't install
+ -n -no-install do not install, just build (implies `-keep')
+ -p -prefix PREFIX change installation prefix to PREFIX
+ -host-extension when cross-compiling, compile extension for host
+ -test run included test-cases, if available
+ -username USER set username for transports that require this
+ -password PASS set password for transports that require this
+ -i -init DIRECTORY initialize empty alternative repository
+ -u -update-db update export database
+EOF
+);|
+ (exit code))
+
+ (define *short-options* '(#\h #\k #\l #\t #\s #\p #\r #\n #\v #\i #\u))
+
+ (define (main args)
+ (let ((defaults (load-defaults))
+ (update #f)
+ (rx "([^:]+):(.+)"))
+ (let loop ((args args) (eggs '()))
+ (cond ((null? args)
+ (cond (update (update-db))
+ (else
+ (when (null? eggs)
+ (let ((setups (glob "*.setup")))
+ (cond ((pair? setups)
+ (set! *eggs+dirs+vers*
+ (append
+ (map
+ (lambda (s) (cons (pathname-file s) (list "." "")))
+ setups)
+ *eggs+dirs+vers*)))
+ (else
+ (print "no setup-scripts to process")
+ (exit 1))) ) )
+ (unless defaults
+ (unless *default-transport*
+ (error "no default transport defined - please use `-transport' option"))
+ (unless *default-location*
+ (error "no default location defined - please use `-location' option")))
+ (install (reverse eggs)))))
+ (else
+ (let ((arg (car args)))
+ (cond ((or (string=? arg "-help")
+ (string=? arg "-h")
+ (string=? arg "--help"))
+ (usage 0))
+ ((string=? arg "-force")
+ (set! *force* #t)
+ (loop (cdr args) eggs))
+ ((or (string=? arg "-k") (string=? arg "-keep"))
+ (set! *keep* #t)
+ (loop (cdr args) eggs))
+ ((or (string=? arg "-s") (string=? arg "-sudo"))
+ (sudo-install #t)
+ (loop (cdr args) eggs))
+ ((or (string=? arg "-r") (string=? arg "-retrieve"))
+ (set! *retrieve-only* #t)
+ (loop (cdr args) eggs))
+ ((or (string=? arg "-l") (string=? arg "-location"))
+ (unless (pair? (cdr args)) (usage 1))
+ (set! *default-location* (cadr args))
+ (loop (cddr args) eggs))
+ ((or (string=? arg "-t") (string=? arg "-transport"))
+ (unless (pair? (cdr args)) (usage 1))
+ (set! *default-transport* (string->symbol (cadr args)))
+ (loop (cddr args) eggs))
+ ((or (string=? arg "-p") (string=? arg "-prefix"))
+ (unless (pair? (cdr args)) (usage 1))
+ (set! *prefix* (cadr args))
+ (loop (cddr args) eggs))
+ ((or (string=? arg "-n") (string=? arg "-no-install"))
+ (set! *keep* #t)
+ (set! *no-install* #t)
+ (loop (cdr args) eggs))
+ ((or (string=? arg "-v") (string=? arg "-version"))
+ (print (chicken-version))
+ (exit 0))
+ ((or (string=? arg "-u") (string=? arg "-update-db"))
+ (set! update #t)
+ (loop (cdr args) eggs))
+ ((or (string=? arg "-i") (string=? arg "-init"))
+ (unless (pair? (cdr args)) (usage 1))
+ (init-repository (cadr args))
+ (exit 0))
+ ((string=? "-test" arg)
+ (set! *run-tests* #t)
+ (loop (cdr args) eggs))
+ ((string=? "-host-extension" arg)
+ (set! *host-extension* #t)
+ (loop (cdr args) eggs))
+ ((string=? "-username" arg)
+ (unless (pair? (cdr args)) (usage 1))
+ (set! *username* (cadr args))
+ (loop (cddr args) eggs))
+ ((string=? "-password" arg)
+ (unless (pair? (cdr args)) (usage 1))
+ (set! *password* (cadr args))
+ (loop (cddr args) eggs))
+ ((and (positive? (string-length arg))
+ (char=? #\- (string-ref arg 0)))
+ (if (> (string-length arg) 2)
+ (let ((sos (string->list (substring arg 1))))
+ (if (null? (lset-intersection eq? *short-options* sos))
+ (loop (append (map (cut string #\- <>) sos) (cdr args)) eggs)
+ (usage 1)))
+ (usage 1)))
+ ((equal? "setup" (pathname-extension arg))
+ (let ((egg (pathname-file arg)))
+ (set! *eggs+dirs+vers*
+ (alist-cons
+ egg
+ (list
+ (let ((dir (pathname-directory arg)))
+ (if dir
+ (if (absolute-pathname? dir)
+ dir
+ (make-pathname (current-directory) dir) )
+ (current-directory)))
+ "")
+ *eggs+dirs+vers*))
+ (loop (cdr args) (cons egg eggs))))
+ ((string-match rx arg) =>
+ (lambda (m)
+ (loop (cdr args) (alist-cons (cadr m) (caddr m) eggs))))
+ (else (loop (cdr args) (cons arg eggs))))))))))
+
+ (register-feature! 'chicken-install)
+
+ (handle-exceptions ex
+ (begin
+ (print-error-message ex (current-error-port))
+ (cleanup)
+ (exit 1))
+ (main (command-line-arguments))
+ (cleanup))
+
+) ;module main
diff --git a/chicken-primitive-object-inlines.scm b/chicken-primitive-object-inlines.scm
new file mode 100644
index 00000000..b47e768b
--- /dev/null
+++ b/chicken-primitive-object-inlines.scm
@@ -0,0 +1,1093 @@
+;;;; chicken-primitive-object-nlines.scm
+;;;; Kon Lovett, Jan '09
+;;;; (Was chicken-sys-macros.scm)
+
+; ***** SHOULD RENAME SAFE ROUTINES AS '*foo', KEEPING '%foo' FOR UNSAFE *****
+
+; Usage
+;
+; (include "chicken-primitive-object-inlines")
+
+;; Notes
+;;
+;; Provides inlines for primitive procedures. Use of these procedures
+;; by non-core is highly suspect. Many of these routines are unsafe.
+;;
+;; In fact, any use is suspect ;-)
+;;
+;; A ##core#Inline is just what it says - literal inclusion in the compiled C
+;; code of the C macro/function and the arguments taken literally, i.e. as the
+;; C_word value.
+;;
+;; These are much faster than a lambda, but very dangerous since the arguments and
+;; the return value are not converted. The C code must perform any such conversions.
+;;
+;; ##core#inline cannot be used with a runtime C function which is coded in the
+;; CPS style.
+;;
+;; A ##core#primitive creates a lambda for a C function which is coded in the
+;; CPS style.
+;;
+;; These have a stereotypical argument list which begins the 3 arguments C_word
+;; c, C_word closure, and C_word k. Any actual arguments follow.
+;;
+;; c - number of arguments, not including 'c', but including 'closure' & 'k'
+;; closure - caller
+;; k - continuation
+
+;;; Unsafe Type Predicates
+
+;; Fixnum
+
+(define-inline (%fixnum-type? x) (##core#inline "C_fixnump" x))
+
+;; Character
+
+(define-inline (%char-type? x) (##core#inline "C_charp" x))
+
+;; Boolean
+
+(define-inline (%boolean-type? x) (##core#inline "C_booleanp" x))
+
+;; EOF
+
+(define-inline (%eof-object-type? x) (##core#inline "C_eofp" x))
+
+;; Null (the end-of-list value)
+
+(define-inline (%eol-object-type? x) (##core#inline "C_i_nullp" x))
+
+;; Undefined (void)
+
+(define-inline (%undefined-type? x) (##core#inline "C_undefinedp" x))
+
+;; Unbound (the unbound value, not 'is a symbol unbound')
+
+(define-inline (%unbound-type? x) (##core#inline "C_unboundvaluep" x))
+
+;; Byteblock
+
+(define-inline (%byteblock-type? x) (##core#inline "C_byteblockp" x))
+
+;; Bytevector
+
+(define-inline (%bytevector-type? x) (##core#inline "C_bytevectorp" x))
+
+;; String
+
+(define-inline (%string-type? x) (##core#inline "C_stringp" x))
+
+;; Flonum
+
+(define-inline (%flonum-type? x) (##core#inline "C_flonump" x))
+
+;; Lambda-info
+
+(define-inline (%lambda-info-type? x) (##core#inline "C_lambdainfop" x))
+
+;; Vector
+
+(define-inline (%vector-type? x) (##core#inline "C_vectorp" x))
+
+;; Pair
+
+(define-inline (%pair-type? x) (##core#inline "C_pairp" x))
+
+;; Bucket
+
+; A bucket is used by the runtime for the symbol-table. The bucket type is not
+; "seen" by Scheme code.
+
+;; Structure
+
+(define-inline (%structure-type? x) (##core#inline "C_structurep" x))
+
+;; Symbol
+
+(define-inline (%symbol-type? x) (##core#inline "C_symbolp" x))
+
+;; Closure
+
+(define-inline (%closure-type? x) (##core#inline "C_closurep" x))
+
+;; Port
+
+(define-inline (%port-type? x) (##core#inline "C_portp" x))
+
+;; Any-pointer
+
+(define-inline (%any-pointer-type? x) (##core#inline "C_anypointerp" x))
+
+;; Simple-pointer
+
+(define-inline (%simple-pointer-type? x) (##core#inline "C_pointerp" x))
+
+;; Tagged-Pointer
+
+(define-inline (%tagged-pointer-type? x) (##core#inline "C_taggedpointerp" x))
+
+;; Swig-Pointer
+
+(define-inline (%swig-pointer-type? x) (##core#inline "C_swigpointerp" x))
+
+;; Locative
+
+(define-inline (%locative-type? x) (##core#inline "C_locativep" x))
+
+;;; Safe Type Predicates
+
+;; Immediate
+
+(define-inline (%immediate? x) (##core#inline "C_immp" x))
+
+;; Fixnum
+
+(define-inline (%fixnum? x) (and (%immediate? x) (%fixnum-type? x)))
+
+;; Character
+
+(define-inline (%char? x) (and (%immediate? x) (%char-type? x)))
+
+;; Boolean
+
+(define-inline (%boolean? x) (and (%immediate? x) (%boolean-type? x)))
+
+(define-inline (%true-value? x) (and (%boolean? x) (##core#inline "C_and" x #t)))
+(define-inline (%false-value? x) (not (%true-value? x)))
+
+;; EOF
+
+(define-inline (%eof-object? x) (and (%immediate? x) (%eof-object-type? x)))
+
+;; Null (the end-of-list value)
+
+(define-inline (%eol-object? x) (and (%immediate? x) (%eol-object-type? x)))
+
+;; Undefined (void)
+
+(define-inline (%undefined-value? x) (and (%immediate? x) (%undefined-type? x)))
+
+(define-inline (%undefined-value) (##core#undefined))
+
+;; Unbound (the unbound value, not 'is a symbol unbound')
+
+(define-inline (%unbound-value? x) (and (%immediate? x) (%unbound-type? x)))
+
+;; Block (anything not immediate)
+
+(define-inline (%block? x) (##core#inline "C_blockp" x))
+
+;; Special
+
+(define-inline (%special? x) (##core#inline "C_specialp" x))
+
+;; Byteblock
+
+(define-inline (%byteblock? x) (and (%block? x) (%byteblock-type? x)))
+
+;; Bytevector
+
+(define-inline (%bytevector? x) (and (%block? x) (%bytevector-type? x)))
+
+;; String
+
+(define-inline (%string? x) (and (%block? x) (%string-type? x)))
+
+;; Flonum
+
+(define-inline (%flonum? x) (and (%block? x) (%flonum-type? x)))
+
+;; Lambda-info
+
+(define-inline (%lambda-info? x) (and (%block? x) (%lambda-info-type? x)))
+
+;; Wordblock (special block)
+
+(define-inline (%wordblock? x) (and (%block? x) (%special? x)))
+
+;; Vector
+
+(define-inline (%vector? x) (and (%block? x) (%vector-type? x)))
+
+;; Pair
+
+(define-inline (%pair? x) (and (%block? x) (%pair-type? x)))
+
+;; Bucket
+
+; A bucket is used by the runtime for the symbol-table. The bucket type is not
+; "seen" by Scheme code.
+
+;; Structure
+
+(define-inline (%structure? x) (and (%block? x) (%structure-type? x)))
+
+;; Symbol
+
+(define-inline (%symbol? x) (and (%block? x) (%symbol-type? x)))
+
+;; Closure
+
+(define-inline (%closure? x) (and (%block? x) (%closure-type? x)))
+
+;; Port
+
+(define-inline (%port? x) (and (%block? x) (%port-type? x)))
+
+;; Any-pointer
+
+(define-inline (%pointer? x) (and (%block? x) (%any-pointer-type? x)))
+
+;; Simple-pointer
+
+(define-inline (%simple-pointer? x) (and (%block? x) (%simple-pointer-type? x)))
+
+;; Tagged-Pointer
+
+(define-inline (%tagged-pointer? x) (and (%block? x) (%tagged-pointer-type? x)))
+
+;; Swig-Pointer
+
+(define-inline (%swig-pointer? x) (and (%block? x) (%swig-pointer-type? x)))
+
+;; Locative
+
+(define-inline (%locative? x) (and (%block? x) (%locative-type? x)))
+
+;; Forwarded (block object moved to new address, forwarding pointer)
+
+(define-inline (%forwarded? x) (##core#inline "C_forwardedp" x))
+
+;;; Operations
+
+;Safe
+
+(define-inline (%eq? x y) (##core#inline "C_eqp" x y))
+
+;; Fixnum
+
+;Safe
+
+(define-inline (%fxrandom x) (##core#inline "C_random_fixnum" x))
+
+;Unsafe
+
+(define-inline (%fx= x y) (%eq? x y))
+(define-inline (%fx> x y) (##core#inline "C_fixnum_greaterp" x y))
+(define-inline (%fx< x y) (##core#inline "C_fixnum_lessp" x y))
+(define-inline (%fx>= x y) (##core#inline "C_fixnum_greater_or_equal_p" x y))
+(define-inline (%fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y))
+
+(define-inline (%fxclosed-right? l x h) (and (fx%< l x) (%fx<= x h)))
+(define-inline (%fxclosed? l x h) (and (%fx<= l x) (%fx<= x h)))
+(define-inline (%fxclosed-left? l x h) (and (%fx<= l x) (%fx< x h)))
+
+(define-inline (%fxzero? fx) (%fx= 0 fx))
+(define-inline (%fxpositive? fx) (%fx< 0 fx))
+(define-inline (%fxnegative? fx) (%fx< fx 0))
+(define-inline (%fxcardinal? fx) (%fx<= 0 fx))
+(define-inline (%fxodd? fx) (%fx= 1 (%fxand fx 1)))
+(define-inline (%fxeven? fx) (%fx= 0 (%fxand fx 1)))
+
+(define-inline (%fxmin x y) (if (%fx< x y) x y))
+(define-inline (%fxmax x y) (if (%fx< x y) y x))
+
+(define-inline (%fx+ x y) (##core#inline "C_fixnum_plus" x y))
+(define-inline (%fx- x y) (##core#inline "C_fixnum_difference" x y))
+(define-inline (%fx* x y) (##core#inline "C_fixnum_times" x y))
+(define-inline (%fx/ x y) (##core#inline "C_fixnum_divide" x y))
+(define-inline (%fxmod x y) (##core#inline "C_fixnum_modulo" x y))
+
+(define-inline (%fxadd1 fx) (##core#inline "C_fixnum_increase" fx))
+(define-inline (%fxsub1 fx) (##core#inline "C_fixnum_decrease" fx))
+
+(define-inline (%fxshl x y) (##core#inline "C_fixnum_shift_left" x y))
+(define-inline (%fxshr x y) (##core#inline "C_fixnum_shift_right" x y))
+
+(define-inline (%fxneg x) (##core#inline "C_fixnum_negate" x))
+(define-inline (%fxabs fx) (if (%fxnegative? fx) (%fxneg fx) fx))
+
+(define-inline (%fxand x y) (##core#inline "C_fixnum_and" x y))
+(define-inline (%fxior x y) (##core#inline "C_fixnum_or" x y))
+(define-inline (%fxxor x y) (##core#inline "C_fixnum_xor" x y))
+(define-inline (%fxnot x) (##core#inline "C_fixnum_not" x))
+
+;; Block
+
+(define-inline (%peek-signed-integer b i) ((##core#primitive "C_peek_signed_integer") b i))
+(define-inline (%peek-unsigned-integer b i) ((##core#primitive "C_peek_unsigned_integer") b i))
+(define-inline (%poke-integer b i n) (##core#inline "C_poke_integer" b i n))
+
+;Safe
+
+(define-inline (%block-address b) (##core#inline_allocate ("C_block_address" 4) b))
+
+;; Size of object in units of sub-object.
+
+; (%block-allocate size byteblock? fill aligned-8-byte-boundry?)
+;
+; byteblock? #t - size is # of bytes, fill is-a character -> "string"
+; byteblock? #f - size is # of words, fill is-a any -> "vector"
+
+(define-inline (%block-allocate n bb? f a?) ((##core#primitive "C_allocate_vector") n bb? f a?))
+
+;Unsafe
+
+; Byteblock -> # of bytes
+; Wordblock -> # of words.
+
+(define-inline (%block-size b) (##core#inline "C_block_size" b))
+
+;;
+
+;; Byteblock
+
+;Safe
+
+(define-inline (%make-byteblock n f a?) (%block-allocate n #t f a?))
+
+;Unsafe
+
+(define-inline (%byteblock-length bb) (%block-size bb))
+
+(define-inline (%byteblock-ref bb i) (##core#inline "C_subbyte" bb i))
+
+(define-inline (%byteblock-set! bb i v) (##core#inline "C_setsubbyte" bb i v))
+
+;; Generic-byteblock
+
+;Safe
+
+; generic-byteblock isa bytevector, string, flonum, or lambda-info
+(define-inline (%generic-byteblock? x)
+ (or (%bytevector? x) (%string? x) (%flonum? x) (%lambda-info? x)) )
+
+;; Bytevector (byteblock)
+
+;Safe
+
+(define-inline (%make-bytevector sz)
+ (let ((bv (%make-byteblock sz #f #t)))
+ (##core#inline "C_string_to_bytevector" bv)
+ bv ) )
+
+(define-inline (%string->bytevector s)
+ (let* ((n (%byteblock-length s) #;(%string-size s))
+ (bv (%make-bytevector sz)) )
+ (##core#inline "C_copy_memory" bv s n)
+ bv ) )
+
+;Unsafe
+
+(define-inline (%bytevector-length bv) (%byteblock-length bv))
+
+(define-inline (%bytevector=? bv1 bv2)
+ (let ((n (%bytevector-length bv1)))
+ (and (%fx= n (%bytevector-length bv2))
+ (%fx= 0 (##core#inline "C_string_compare" bv1 bv2 n)) ) ) )
+
+(define-inline (%bytevector-ref bv i) (%byteblock-ref bv i))
+
+(define-inline (%bytevector-set! bv i x) (%byteblock-set! bv i x))
+
+;; Blob (isa bytevector w/o accessors)
+
+(define-inline (%make-blob sz) (%make-bytevector sz))
+
+(define-inline (%string->blob s) (%string->bytevector s))
+
+(define-inline (%blob? x) (%bytevector? x))
+
+(define-inline (%blob-size b) (%bytevector-length b))
+
+(define-inline (%blob=? b1 b2) (%bytevector=? b1 b2))
+
+;; String (byteblock)
+
+;Safe
+
+(define-inline (%make-string size fill) (%make-byteblock size fill #f))
+
+;Unsafe
+
+(define-inline (%bytevector->string bv)
+ (let* ((n (%bytevector-length bv))
+ (s (%make-string n #\space)) )
+ (##core#inline "C_copy_memory" s bv n)
+ s ) )
+
+(define-inline (%blob->string bv) (%bytevector->string bv))
+
+(define-inline (%lambda-info->string li)
+ (let* ((sz (%byteblock-length li) #;(%lambda-info-length li))
+ (s (%make-string sz #\space)) )
+ (##core#inline "C_copy_memory" s li sz)
+ s ) )
+
+(define-inline (%string-size s) (%byteblock-length s))
+(define-inline (%string-length s) (%byteblock-length s))
+
+(define-inline (%string-ref s i) (##core#inline "C_subchar" s i))
+
+(define-inline (%string-set! s i c) (##core#inline "C_setsubchar" s i c))
+
+(define-inline (%string-compare/length s1 s2 l) (##core#inline "C_string_compare" s1 s2 l))
+
+(define-inline (%string-compare s1 s2)
+ (let* ((l1 (%string-length s1))
+ (l2 (%string-length s2))
+ (d (%fx- l1 l2))
+ (r (%string-compare/length s1 s2 (if (%fxpositive? d) l2 l1))) )
+ (if (%fxzero? r) d
+ r ) ) )
+
+(define-inline (%string=? s1 s2) (%fxzero? (%string-compare s1 s2)))
+(define-inline (%string<? s1 s2) (%fxnegative? (%string-compare s1 s2)))
+(define-inline (%string>? s1 s2) (%fxpositive? (%string-compare s1 s2)))
+(define-inline (%string<=? s1 s2) (%fx<= 0 (%string-compare s1 s2)))
+(define-inline (%string>=? s1 s2) (%fx>= 0 (%string-compare s1 s2)))
+
+(define-inline (%string-ci-compare/length s1 s2 l) (##core#inline "C_string_compare_case_insensitive" s1 s2 l))
+
+(define-inline (%string-ci-compare s1 s2)
+ (let* ((l1 (%string-length s1))
+ (l2 (%string-length s2))
+ (d (%fx- l1 l2))
+ (r (%string-ci-compare/length s1 s2 (if (%fxpositive? d) l2 l1))) )
+ (if (%fxzero? r) d
+ r ) ) )
+
+(define-inline (%string-ci=? s1 s2) (%fxzero? (%string-ci-compare s1 s2)))
+(define-inline (%string-ci<? s1 s2) (%fxnegative? (%string-ci-compare s1 s2)))
+(define-inline (%string-ci>? s1 s2) (%fxpositive? (%string-ci-compare s1 s2)))
+(define-inline (%string-ci<=? s1 s2) (%fx<= 0 (%string-ci-compare s1 s2)))
+(define-inline (%string-ci>=? s1 s2) (%fx>= 0 (%string-ci-compare s1 s2)))
+
+;; Flonum (byteblock)
+
+;Unsafe
+
+(define-inline (%fp= x y) (##core#inline "C_flonum_equalp" x y))
+(define-inline (%fp< x y) (##core#inline "C_flonum_lessp" x y))
+(define-inline (%fp<= x y) (##core#inline "C_flonum_less_or_equal_p" x y))
+(define-inline (%fp> x y) (##core#inline "C_flonum_greaterp" x y))
+(define-inline (%fp>= x y) (##core#inline "C_flonum_greater_or_equal_p" x y))
+
+(define-inline (%fpmax x y) (##core#inline "C_i_flonum_max" x y))
+(define-inline (%fpmin x y) (##core#inline "C_i_flonum_min" x y))
+
+(define-inline (%finite? x) (##core#inline "C_i_finitep" x))
+
+(define-inline (%fp- x y) (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y))
+(define-inline (%fp* x y) (##core#inline_allocate ("C_a_i_flonum_times" 4) x y))
+(define-inline (%fp/ x y) (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y))
+(define-inline (%fp+ x y) (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y))
+
+(define-inline (%fpfraction x) ((##core#primitive "C_flonum_fraction") x))
+
+(define-inline (%fpnegate x) (##core#inline_allocate ("C_a_i_flonum_negate" 4) x))
+
+(define-inline (%fpfloor x) ((##core#primitive "C_flonum_floor") x))
+(define-inline (%fpceiling x) ((##core#primitive "C_flonum_ceiling") x))
+(define-inline (%fpround x) ((##core#primitive "C_flonum_round") x))
+(define-inline (%fptruncate x) ((##core#primitive "C_flonum_truncate") x))
+
+;Safe
+
+(define-inline (%exact->inexact x) ((##core#primitive "C_exact_to_inexact") x))
+
+; Actually 'number' operations
+(define-inline (%fpabs x) (##core#inline_allocate ("C_a_i_abs" 4) x))
+(define-inline (%fpacos x) (##core#inline_allocate ("C_a_i_acos" 4) x))
+(define-inline (%fpasin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
+(define-inline (%fpatan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
+(define-inline (%fpatan2 x y) (##core#inline_allocate ("C_a_i_atan2" 4) x y))
+(define-inline (%fpcos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
+(define-inline (%fpexp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
+(define-inline (%fplog x) (##core#inline_allocate ("C_a_i_log" 4) x))
+(define-inline (%fpsin x) (##core#inline_allocate ("C_a_i_sin" 4) x))
+(define-inline (%fpsqrt x) (##core#inline_allocate ("C_a_i_sqrt" 4) x))
+(define-inline (%fptan x) (##core#inline_allocate ("C_a_i_tan" 4) x))
+
+;; Lambda-info (byteblock)
+
+;Unsafe
+
+(define-inline (%string->lambda-info s)
+ (let* ((n (%string-size s))
+ (li (%make-string n)) )
+ (##core#inline "C_copy_memory" li s n)
+ (##core#inline "C_string_to_lambdainfo" li)
+ li ) )
+
+(define-inline (%lambda-info-length li) (%byteblock-length s))
+
+;; Wordblock
+
+;Safe
+
+(define-inline (%make-wordblock n f a?) (%block-allocate n #f f a?))
+
+;Unsafe
+
+(define-inline (%wordblock-length wb) (%block-size wb))
+
+(define-inline (%wordblock-ref wb i) (##core#inline "C_slot" wb i))
+
+(define-inline (%wordblock-set!/mutate wb i v) (##core#inline "C_i_setslot" wb i v))
+(define-inline (%wordblock-set!/immediate wb i v) (##core#inline "C_i_set_i_slot" wb i v))
+(define-inline (%wordblock-set! wb i v)
+ (if (%immediate? v) (%wordblock-set!/immediate wb i v)
+ (%wordblock-set!/mutate wb i v) ) )
+
+;; Generic-vector (wordblock)
+
+; generic-vector isa vector, pair, structure, symbol, or keyword
+(define-inline (%generic-vector? x) (and (%block? x) (not (or (%special? x) (%byteblock? x)))))
+
+;; Vector (wordblock)
+
+;Safe
+
+(define-inline (%make-vector size fill) (%make-wordblock size fill #f))
+
+;Unsafe
+
+(define-inline (%vector-length v) (%wordblock-length v))
+
+(define-inline (%vector-ref v i) (%wordblock-ref v i))
+
+(define-inline (%vector-set!/mutate v i x) (%wordblock-set!/mutate v i x))
+(define-inline (%vector-set!/immediate v i x) (%wordblock-set!/immediate v i x))
+(define-inline (%vector-set! v i x) (%wordblock-set! v i x))
+
+;; Pair (wordblock)
+
+;Safe
+
+(define-inline (%null? x) (%eol-object? x))
+
+(define-inline (%list? x) (or (%null? x) (%pair? x)))
+
+(define-inline (%cons x y) (##core#inline_allocate ("C_a_i_cons" 3) x y) )
+
+(define-inline (%length ls) (##core#inline "C_i_length" ls))
+
+;Unsafe
+
+(define-inline (%car pr) (%wordblock-ref pr 0))
+
+(define-inline (%set-car!/mutate pr x) (%wordblock-set!/mutate pr 0 x))
+(define-inline (%set-car!/immediate pr x) (%wordblock-set!/immediate pr 0 x))
+(define-inline (%set-car! pr x) (%wordblock-set! pr 0 x))
+
+(define-inline (%cdr pr) (%wordblock-ref pr 1))
+
+(define-inline (%set-cdr!/mutate pr x) (%wordblock-set!/mutate pr 1 x))
+(define-inline (%set-cdr!/immediate pr x) (%wordblock-set!/immediate pr 1 x))
+(define-inline (%set-cdr! pr x) (%wordblock-set! pr 1 x))
+
+(define-inline (%caar pr) (%car (%car pr)))
+(define-inline (%cadr pr) (%car (%cdr pr)))
+(define-inline (%cdar pr) (%cdr (%car pr)))
+(define-inline (%cddr pr) (%cdr (%cdr pr)))
+
+(define-inline (%caaar pr) (%car (%caar pr)))
+(define-inline (%caadr pr) (%car (%cadr pr)))
+(define-inline (%cadar pr) (%car (%cdar pr)))
+(define-inline (%caddr pr) (%car (%cddr pr)))
+(define-inline (%cdaar pr) (%cdr (%caar pr)))
+(define-inline (%cdadr pr) (%cdr (%cadr pr)))
+(define-inline (%cddar pr) (%cdr (%cdar pr)))
+(define-inline (%cdddr pr) (%cdr (%cddr pr)))
+
+;Safe
+
+(define-inline (%memq x ls) (##core#inline "C_i_memq" x ls))
+(define-inline (%memv x ls) (##core#inline "C_i_memv" x ls))
+(define-inline (%member x ls) (##core#inline "C_i_member" x ls))
+
+(define-inline (%assq x ls) (##core#inline "C_i_assq" x ls))
+(define-inline (%assv x ls) (##core#inline "C_i_assv" x ls))
+(define-inline (%assoc x ls) (##core#inline "C_i_assoc" x ls))
+
+;Unsafe
+
+(define-inline (%list-ref ls0 i0)
+ ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
+ (let loop ((ls ls0) (i i0))
+ (cond ((%null? ls) '() )
+ ((%fx= 0 i) (%car ls) )
+ (else (loop (%cdr ls) (%fx- i 1)) ) ) ) )
+
+(define-inline (%list-pair-ref ls0 i0)
+ ;(assert (and (proper-list? ls0) (exact? i0) (<= 0 i0 (sub1 (length ls0)))))
+ (let loop ((ls ls0) (i i0))
+ (cond ((%null? ls) '() )
+ ((%fx= 0 i) ls )
+ (else (loop (%cdr ls) (%fx- i 1)) ) ) ) )
+
+(define-inline (%last-pair ls0)
+ ;(assert (and (proper-list? ls0) (pair? ls0)))
+ (do ((ls ls0 (%cdr ls)))
+ ((%null? (%cdr ls)) ls)) )
+
+(define-inline (%list-copy ls0)
+ ;(assert (proper-list? ls0))
+ (let copy-rest ((ls ls0))
+ (if (%null? ls) '()
+ (%cons (%car ls) (copy-rest (%cdr ls))) ) ) )
+
+(define-inline (%append! . lss)
+ ;(assert (and (proper-list? lss) (for-each (cut proper-list? <>) lss)))
+ (let ((lss (let position-at-first-pair ((lss lss))
+ (cond ((%null? lss) '() )
+ ((%null? (%car lss)) (position-at-first-pair (%cdr lss)) )
+ (else lss ) ) ) ) )
+ (if (%null? lss) '()
+ (let ((ls0 (%car lss)))
+ ;(assert (pair? ls0))
+ (let append!-rest ((lss (%cdr lss)) (pls ls0))
+ (if (%null? lss) ls0
+ (let ((ls (%car lss)))
+ (cond ((%null? ls)
+ (append!-rest (%cdr lss) pls) )
+ (else
+ (%set-cdr!/mutate (%last-pair pls) ls)
+ (append!-rest (%cdr lss) ls) ) ) ) ) ) ) ) ) )
+
+(define-inline (%delq! x ls0)
+ ;(assert (proper-list? ls0))
+ (let find-elm ((ls ls0) (ppr #f))
+ (cond ((%null? ls)
+ ls0 )
+ ((%eq? x (%car ls))
+ (cond (ppr
+ (%set-cdr! ppr (%cdr ls))
+ ls0 )
+ (else
+ (%cdr ls) ) ) )
+ (else
+ (find-elm (%cdr ls) ls) ) ) ) )
+
+(define-inline (%list-fold/1 func init ls0)
+ ;(assert (and (proper-list? ls0) (procedure? func)))
+ (let loop ((ls ls0) (acc init))
+ (if (%null? ls) acc
+ (loop (%cdr ls) (func (%car ls) acc)) ) ) )
+
+(define-inline (%list-map/1 func ls0)
+ ;(assert (and (proper-list? ls0) (procedure? func)))
+ (let loop ((ls ls0))
+ (if (%null? ls) '()
+ (%cons (func (%car ls)) (loop (%cdr ls))) ) ) )
+
+(define-inline (%list-for-each/1 proc ls0)
+ ;(assert (and (proper-list? ls0) (procedure? proc)))
+ (let loop ((ls ls0))
+ (unless (%null? ls)
+ (proc (%car ls))
+ (loop (%cdr ls)) ) ) )
+
+(define-inline (%list/1 obj) (%cons obj '()))
+
+(define-inline (%list . objs)
+ (let loop ((objs objs))
+ (if (%null? objs) '()
+ (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
+
+(define-inline (%make-list n e)
+ (let loop ((n n) (ls '()))
+ (if (%fxzero? n) ls
+ (loop (%fxsub1 n) (%cons e ls)) ) ) )
+
+(define-inline (%list-take ls0 n)
+ (let loop ((ls ls0) (n n))
+ (if (%fxzero? n) '()
+ (%cons (%car ls) (loop (%cdr ls) (%fxsub1 n))) ) ) )
+
+(define-inline (%list-drop ls0 n)
+ (let loop ((ls ls0) (n n))
+ (if (%fxzero? n) ls
+ (loop (%cdr ls) (%fxsub1 n)) ) ) )
+
+(define-inline (%list-any/1 pred? ls)
+ (let loop ((ls ls))
+ (and (not (%null? ls))
+ (or (pred? (%car ls))
+ (loop (%cdr ls)) ) ) ) )
+
+(define-inline (%list-every/1 pred? ls)
+ (let loop ((ls ls))
+ (or (%null? ls)
+ (and (pred? (%car ls))
+ (loop (%cdr ls))) ) ) )
+
+(define-inline (%list-length ls0)
+ (let loop ((ls ls0) (n 0))
+ (if (%null? ls) n
+ (loop (%cdr ls) (%fxadd1 n)) ) ) )
+
+(define-inline (%list-find pred? ls)
+ (let loop ((ls ls))
+ (and (not (%null? ls))
+ (or (let ((elm (%car ls))) (and (pred? elm) elm))
+ (loop (%cdr ls)) ) ) ) )
+
+(define-inline (%alist-ref key al #!optional (test eqv?) def)
+ (let loop ((al al))
+ (cond ((%null? al) def )
+ ((test key (%caar al)) (%cdar al) )
+ (else (loop (%cdr al)) ) ) ) )
+
+(define-inline (%alist-update! key val al0 #!optional (test eqv?))
+ (let loop ((al al0))
+ (cond ((%null? al) (%cons (%cons key val) al0) )
+ ((test key (%caar al)) (%set-cdr! (%car al) val) al0 )
+ (else (loop (%cdr al)) ) ) ) )
+
+(define-inline (%alist-delete! key al0 #!optional (test equal?))
+ (let loop ((al al0) (prv #f))
+ (cond ((%null? al) al0)
+ ((test key (%caar al)) (if prv (begin (%set-cdr! prv (%cdr al)) al0) (%cdr al)) )
+ (else (loop (%cdr al) al) ) ) ) )
+
+;; Structure (wordblock)
+
+(define-inline (%make-structure t . s) (apply (##core#primitive "C_make_structure") t s))
+
+(define-inline (%structure-instance? x s) (##core#inline "C_i_structurep" x s))
+
+(define-inline (%structure-length r) (%wordblock-length r))
+
+(define-inline (%structure-tag r) (%wordblock-ref r 0))
+
+(define-inline (%structure-ref r i) (%wordblock-ref r i))
+
+(define-inline (%structure-set!/mutate r i x) (%wordblock-set!/mutate r i x))
+(define-inline (%structure-set!/immediate r i x) (%wordblock-set!/immediate r i x))
+(define-inline (%structure-set! r i x) (%wordblock-set! r i x))
+
+;; Port (wordblock)
+
+; Port layout:
+;
+; 0 FP (special - FILE *)
+; 1 input/output (bool)
+; 2 class (vector, see Port-class)
+; 3 name (string)
+; 4 row (fixnum)
+; 5 col (fixnum)
+; 6 EOF (bool)
+; 7 type (symbol)
+; 8 closed (bool)
+; 9 data
+; 10-15 reserved, port class specific
+
+(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
+(define-inline (%port-input-mode? port) (%wordblock-ref port 1))
+(define-inline (%port-class port) (%wordblock-ref port 2))
+(define-inline (%port-name port) (%wordblock-ref port 3))
+(define-inline (%port-row port) (%wordblock-ref port 4))
+(define-inline (%port-column port) (%wordblock-ref port 5))
+(define-inline (%port-eof? port) (%wordblock-ref port 6))
+(define-inline (%port-type port) (%wordblock-ref port 7))
+(define-inline (%port-closed? port) (%wordblock-ref port 8))
+(define-inline (%port-data port) (%wordblock-ref port 9))
+
+(define-inline (%input-port? x) (and (%port? x) (%port-input-mode? x)))
+(define-inline (%output-port? x) (and (%port? x) (not (%port-input-mode? x))))
+
+(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))
+(define-inline (%port-input-mode-set! port f) (%wordblock-set!/immediate port 1 f))
+(define-inline (%port-class-set! port v) (%wordblock-set!/mutate port 2 v))
+(define-inline (%port-name-set! port s) (%wordblock-set!/mutate port 3 s))
+(define-inline (%port-row-set! port n) (%wordblock-set!/immediate port 4 n))
+(define-inline (%port-column-set! port n) (%wordblock-set!/immediate port 5 n))
+(define-inline (%port-eof-set! port f) (%wordblock-set!/immediate port 6 f))
+(define-inline (%port-type-set! port s) (%wordblock-set!/mutate port 7 s))
+(define-inline (%port-closed-set! port f) (%wordblock-set!/immediate port 8 f))
+(define-inline (%port-data-set! port x) (%wordblock-set!/mutate port 9 x))
+
+(define-inline (%make-port i/o class name type)
+ ; port is 16 slots + a block-header word
+ (let ((port (##core#inline_allocate ("C_a_i_port" 17))))
+ (%port-input-mode-set! port i/o)
+ (%port-class-set! port class)
+ (%port-name-set! port name)
+ (%port-row-set! port 1)
+ (%port-column-set! port 0)
+ (%port-type-set! port type)
+ port ) )
+
+; Port-class layout
+;
+; 0 (read-char PORT) -> CHAR | EOF
+; 1 (peek-char PORT) -> CHAR | EOF
+; 2 (write-char PORT CHAR)
+; 3 (write-string PORT STRING)
+; 4 (close PORT)
+; 5 (flush-output PORT)
+; 6 (char-ready? PORT) -> BOOL
+; 7 (read-string! PORT COUNT STRING START) -> COUNT'
+; 8 (read-line PORT LIMIT) -> STRING | EOF
+
+(define-inline (%make-port-class rc pc wc ws cl fl cr rs rl)
+ (let ((class (%make-vector 9 #f)))
+ (%vector-set! class 0 rc)
+ (%vector-set! class 1 pc)
+ (%vector-set! class 2 wc)
+ (%vector-set! class 3 ws)
+ (%vector-set! class 4 cl)
+ (%vector-set! class 5 fl)
+ (%vector-set! class 6 cr)
+ (%vector-set! class 7 rs)
+ (%vector-set! class 8 rl)
+ class ) )
+
+(define-inline (%port-class-read-char-ref c) (%vector-ref c 0))
+(define-inline (%port-class-peek-char-ref c) (%vector-ref c 1))
+(define-inline (%port-class-write-char-ref c) (%vector-ref c 2))
+(define-inline (%port-class-write-string-ref c) (%vector-ref c 3))
+(define-inline (%port-class-close-ref c) (%vector-ref c 4))
+(define-inline (%port-class-flush-output-ref c) (%vector-ref c 5))
+(define-inline (%port-class-char-ready-ref c) (%vector-ref c 6))
+(define-inline (%port-class-read-string-ref c) (%vector-ref c 7))
+(define-inline (%port-class-read-line-ref c) (%vector-ref c 8))
+
+(define-inline (%port-class-read-char c p) ((%port-class-read-char-ref c) p) )
+(define-inline (%port-class-peek-char c p) ((%port-class-peek-char-ref c) p))
+(define-inline (%port-class-write-char c p c) ((%port-class-write-char-ref c) p c))
+(define-inline (%port-class-write-string c p s) ((%port-class-write-string-ref c) p s))
+(define-inline (%port-class-close c p) ((%port-class-close-ref c) p))
+(define-inline (%port-class-flush-output c p) ((%port-class-flush-output-ref c) p))
+(define-inline (%port-class-char-ready? c p) ((%port-class-char-ready-ref c) p))
+(define-inline (%port-class-read-string! c p n d s) ((%port-class-read-string-ref c) p n d s))
+(define-inline (%port-class-read-line c p l) ((%port-class-read-line-ref c) p l))
+
+(define-inline (%port-read-char p) ((%port-class-read-char-ref (%port-class p)) p) )
+(define-inline (%port-peek-char p) ((%port-class-peek-char-ref (%port-class p)) p))
+(define-inline (%port-write-char p c) ((%port-class-write-char-ref (%port-class p)) p c))
+(define-inline (%port-write-string p s) ((%port-class-write-string-ref (%port-class p)) p s))
+(define-inline (%port-close p) ((%port-class-close-ref (%port-class p)) p))
+(define-inline (%port-flush-output p) ((%port-class-flush-output-ref (%port-class p)) p))
+(define-inline (%port-char-ready? p) ((%port-class-char-ready-ref (%port-class p)) p))
+(define-inline (%port-read-string! p n d s) ((%port-class-read-string-ref (%port-class p)) p n d s))
+(define-inline (%port-read-line p l) ((%port-class-read-line-ref (%port-class p)) p l))
+
+;; Closure (wordblock)
+
+;Unsafe
+
+(define-inline (%make-closure! n)
+ (let ((v (%make-vector n)))
+ (##core#inline "C_vector_to_closure" v)
+ v ) )
+
+(define-inline (%procedure? x) (%closure? x))
+
+(define-inline (%vector->closure! v a)
+ (##core#inline "C_vector_to_closure" v)
+ (##core#inline "C_update_pointer" a v) )
+
+(define-inline (%closure-length c) (%wordblock-length? c))
+
+(define-inline (%closure-ref c i) (%wordblock-ref c i))
+
+(define-inline (%closure-set! c i v) (%wordblock-set! c i v))
+
+(define-inline (%closure-copy tc fc l)
+ (do ((i 1 (%fxadd1 i)))
+ ((%fx>= i l))
+ (%closure-set! tc i (%closure-ref fc i)) ) )
+
+(define-inline (%closure-decoration c test)
+ (let find-decor ((i (%fxsub1 (%closure-length c))))
+ (and (%fxpositive? i)
+ (let ((x (%closure-ref c i)))
+ (if (test x) x
+ (find-decor (%fxsub1 i)) ) ) ) ) )
+
+(define-inline (%closure-decorate! c test dcor)
+ (let ((l (%closure-length c)))
+ (let find-decor ((i (%fxsub l)))
+ (cond ((%fxzero? i)
+ (let ((nc (%make-closure (%fxadd1 l))))
+ (%closure-copy nc c l)
+ (##core#inline "C_copy_pointer" c nc)
+ (dcor nc i) ) )
+ (else
+ (let ((x (%closure-ref c i)))
+ (if (test x) (dcor c i)
+ (find-decor (%fxsub i)) ) ) ) ) ) ) )
+
+(define-inline (%closure-lambda-info c)
+ (%closure-decoration c (lambda (x) (%lambda-info? x))) )
+
+;; Symbol (wordblock)
+
+;Unsafe
+
+(define-inline (%symbol-binding s) (%wordblock-ref s 0))
+(define-inline (%symbol-string s) (%wordblock-ref s 1))
+(define-inline (%symbol-bucket s) (%wordblock-ref s 2))
+
+(define-constant NAMESPACE-MAX-ID-LEN 31)
+
+(define-inline (%qualified-symbol? s)
+ (let ((str (%symbol-string s)))
+ (and (%fxpositive? (%string-size str))
+ (%fx<= (%byteblock-ref str 0) NAMESPACE-MAX-ID-LEN) ) ) )
+
+;Safe
+
+(define-inline (%string->symbol-interned s) ((##core#primitive "C_string_to_symbol") s))
+
+(define-inline (%symbol-interned? x) (##core#inline "C_lookup_symbol" x))
+
+(define-inline (%symbol-bound? s) (##core#inline "C_boundp" s))
+
+;; Keyword (wordblock)
+
+(define-inline (%keyword? x) (and (%symbol? x) (%fxzero? (%byteblock-ref (%symbol-string x) 0))))
+
+;; Pointer (wordblock)
+
+; simple-pointer, tagged-pointer, swig-pointer, locative
+(define-inline (%generic-pointer? x) (or (%pointer? x) (%locative? x)))
+
+; simple-pointer, tagged-pointer, swig-pointer, locative, closure, port, symbol, keyword
+(define-inline (%pointer-like? x) (%wordblock? x))
+
+; These operate on pointer-like objects
+
+(define-inline (%pointer-null? ptr) (##core#inline "C_null_pointerp" ptr))
+
+(define-inline (%pointer-ref ptr) (%wordblock-ref ptr 0))
+(define-inline (%pointer-set! ptr y) (%wordblock-set!/mutate ptr 0 y))
+
+(define-inline (%peek-byte ptr i) (##core#inline "C_peek_byte" ptr i))
+
+(define-inline (%pointer->address ptr)
+ ; Pack pointer address value into Chicken words; '4' is platform dependent!
+ (##core#inline_allocate ("C_block_address" 4) (%generic-pointer-ref ptr)) )
+
+;; Simple-pointer (wordblock)
+
+(define-inline (%make-simple-pointer) ((##core#primitive "C_make_pointer")))
+
+(define-inline (%make-pointer-null)
+ (let ((ptr (%make-simple-pointer)))
+ (##core#inline "C_update_pointer" 0 ptr)
+ ptr ) )
+
+(define-inline (%address->pointer a)
+ (let ((ptr (%make-simple-pointer)))
+ (##core#inline "C_update_pointer" a ptr)
+ ptr ) )
+
+(define-inline (%make-block-pointer b)
+ (let ((ptr (%make-simple-pointer)))
+ (##core#inline "C_pointer_to_block" ptr b)
+ ptr ) )
+
+;; Tagged-pointer (wordblock)
+
+(define-inline (%make-tagged-pointer t) ((##core#primitive "C_make_tagged_pointer") t))
+
+;; Swig-pointer (wordblock)
+
+;; Locative (wordblock)
+
+(define-inline (%make-locative typ obj idx weak?)
+ (##core#inline_allocate ("C_a_i_make_locative" 5) typ obj idx weak?))
+
+; Locative layout:
+;
+; 0 Object-address + byte-offset (address)
+; 1 Byte-offset (fixnum)
+; 2 Type (fixnum)
+; 0 vector or pair (C_SLOT_LOCATIVE)
+; 1 string (C_CHAR_LOCATIVE)
+; 2 u8vector (C_U8_LOCATIVE)
+; 3 s8vector or bytevector (C_U8_LOCATIVE)
+; 4 u16vector (C_U16_LOCATIVE)
+; 5 s16vector (C_S16_LOCATIVE)
+; 6 u32vector (C_U32_LOCATIVE)
+; 7 s32vector (C_S32_LOCATIVE)
+; 8 f32vector (C_F32_LOCATIVE)
+; 9 f64vector (C_F64_LOCATIVE)
+; 3 Object or #f, if weak (C_word)
+
+(define-inline (%locative-address lv) (%pointer->address lv))
+
+(define-inline (%locative-offset lv) (%wordblock-ref lv 1))
+(define-inline (%locative-type lv) (%wordblock-ref lv 2))
+(define-inline (%locative-weak? lv) (not (%wordblock-ref lv 3)))
+(define-inline (%locative-object lv) (%wordblock-ref lv 3))
+
+;; Numbers
+
+;Safe
+
+(define-inline (%number? x) (or (%fixnum? x) (%flonum? x)))
+(define-inline (%integer? x) (##core#inline "C_i_integerp" x))
+(define-inline (%exact? x) (##core#inline "C_i_exactp" x))
+(define-inline (%inexact? x) (##core#inline "C_i_inexactp" x))
+
+(define-inline (%= x y) (##core#inline "C_i_eqvp" x y))
+(define-inline (%< x y) (##core#inline "C_i_lessp" x y))
+(define-inline (%<= x y) (##core#inline "C_i_less_or_equalp" x y))
+(define-inline (%> x y) (##core#inline "C_i_greaterp" x y))
+(define-inline (%>= x y) (##core#inline "C_i_greater_or_equalp" x y))
+
+(define-inline (%zero? n) (##core#inline "C_i_zerop" n))
+(define-inline (%positive? n) (##core#inline "C_i_positivep" n))
+(define-inline (%negative? n) (##core#inline "C_i_negativep" n))
+(define-inline (%cardinal? fx) (%<= 0 fx))
+
+(define-inline (%odd? n) (##core#inline "C_i_oddp" n))
+(define-inline (%even? n) (##core#inline "C_i_evenp" n))
+
+(define-inline (%+ x y) ((##core#primitive "C_plus") x y))
+(define-inline (%- x y) ((##core#primitive "C_minus") x y))
+(define-inline (%* x y) ((##core#primitive "C_times") x y))
+(define-inline (%/ x y) ((##core#primitive "C_divide") x y))
+
+(define-inline (%add1 x) (%+ x 1))
+(define-inline (%sub1 x) (%- x 1))
+
+(define-inline (%quotient x y) ((##core#primitive "C_quotient") x y))
+(define-inline (%remainder x y) (let ((quo (%quotient x y))) (%- x (%* quo y))))
+
+(define-inline (%expt x y) ((##core#primitive "C_expt") x y))
+(define-inline (%abs x) (##core#inline_allocate ("C_a_i_abs" 4) x))
+(define-inline (%acos x) (##core#inline_allocate ("C_a_i_acos" 4) x))
+(define-inline (%asin x) (##core#inline_allocate ("C_a_i_asin" 4) x))
+(define-inline (%atan x) (##core#inline_allocate ("C_a_i_atan" 4) x))
+(define-inline (%atan2 x y) (##core#inline_allocate ("C_a_i_atan2" 4) x y))
+(define-inline (%cos x) (##core#inline_allocate ("C_a_i_cos" 4) x))
+(define-inline (%exp x) (##core#inline_allocate ("C_a_i_exp" 4) x))
+(define-inline (%log x) (##core#inline_allocate ("C_a_i_log" 4) x))
+(define-inline (%sin x) (##core#inline_allocate ("C_a_i_sin" 4) x))
+(define-inline (%sqrt x) (##core#inline_allocate ("C_a_i_sqrt" 4) x))
+(define-inline (%tan x) (##core#inline_allocate ("C_a_i_tan" 4) x))
+
+(define-inline (%bitwise-and x y) (##core#inline_allocate ("C_a_i_bitwise_and" 4) x y))
+(define-inline (%bitwise-xor x y) (##core#inline_allocate ("C_a_i_bitwise_xor" 4) x y))
+(define-inline (%bitwise-ior x y) (##core#inline_allocate ("C_a_i_bitwise_ior" 4) x y))
+(define-inline (%bitwise-not x) (##core#inline_allocate ("C_a_i_bitwise_not" 4) x))
+
+(define-inline (%arithmetic-shift x d) (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x d))
+
+(define-inline (%bit-set? n i) (##core#inline "C_i_bit_setp" n i))
+
+(define-inline (%randomize n) (##core#inline "C_randomize" n))
+
+;;; Operations
+
+;Safe
+
+(define-inline (%->boolean obj) (and obj #t))
+
+(define-inline (%make-unique-object #!optional id) (if id (%make-vector 1 id) '#()))
diff --git a/chicken-profile.1 b/chicken-profile.1
new file mode 100644
index 00000000..0b638065
--- /dev/null
+++ b/chicken-profile.1
@@ -0,0 +1,61 @@
+.\" dummy line
+.TH CHICKEN-PROFILE 1 "19 Sep 2001"
+
+.SH NAME
+
+chicken-profile \- generate a report from Chicken Scheme profiled program output
+
+.SH SYNOPSIS
+
+.B chicken-profile
+[
+.I filename
+|
+.I option ...
+]
+
+.SH OPTIONS
+
+.TP
+.B \-sort\-by\-calls
+Sort output by call frequency.
+
+.TP
+.B \-sort\-by\-time
+Sort output by procedure execution time.
+
+.TP
+.B \-sort\-by\-avg
+Sort output by average procedure execution time.
+
+.TP
+.B \-sort\-by\-name
+Sort output alphabetically by procedure name.
+
+.TP
+.B \-no\-unused
+Remove procedures that are never called.
+
+.TP
+.B \-help
+Show usage information.
+
+
+.SH DESCRIPTION
+
+.I chicken\-profile reads in profiling information generated by Scheme
+programs compiled with the
+.B \-profile
+option, and generates a table listing function names and their execution times.
+
+
+.SH BUGS
+Submit bug reports by e-mail to
+.I chicken-janitors@nongnu.org
+
+.SH AUTHORS
+Felix L. Winkelmann and the Chicken Team
+
+.SH SEE ALSO
+.BR chicken(1)
+.BR csc(1)
diff --git a/chicken-profile.scm b/chicken-profile.scm
new file mode 100644
index 00000000..c2db7883
--- /dev/null
+++ b/chicken-profile.scm
@@ -0,0 +1,234 @@
+;;;; chicken-profile.scm - Formatted display of profile outputs - felix -*- Scheme -*-
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (block)
+ (uses srfi-1
+ srfi-13
+ srfi-69
+ posix
+ utils))
+
+(define sort-by #f)
+(define file #f)
+(define no-unused #f)
+(define seconds-digits 3)
+(define average-digits 3)
+(define percent-digits 3)
+(define top 0)
+
+(define (print-usage)
+ (display #<#EOF
+Usage: chicken-profile [FILENAME | OPTION] ...
+
+ -sort-by-calls sort output by call frequency
+ -sort-by-time sort output by procedure execution time
+ -sort-by-avg sort output by average procedure execution time
+ -sort-by-name sort output alphabetically by procedure name
+ -decimals DDD set number of decimals for seconds, average and
+ percent columns (three digits, default: #{seconds-digits}#{average-digits}#{percent-digits})
+ -no-unused remove procedures that are never called
+ -top N display only the top N entries
+ -help show this text and exit
+ -version show version and exit
+ -release show release number and exit
+
+ FILENAME defaults to the `PROFILE.<number>', selecting the one with
+ the highest modification time, in case multiple profiles exist.
+
+EOF
+)
+ (exit 64) )
+
+(define (run args)
+ (let loop ([args args])
+ (if (null? args)
+ (begin
+ (unless file
+ (set! file
+ (let ((fs (glob "PROFILE.*")))
+ (if (null? fs)
+ (error "no PROFILEs found")
+ (first (sort fs
+ (lambda (f1 f2)
+ (> (file-modification-time f1)
+ (file-modification-time f2))) ) ) ) ) ) )
+ (write-profile) )
+ (let ([arg (car args)]
+ [rest (cdr args)] )
+ (define (next-arg)
+ (if (null? rest)
+ (error "missing argument to option" arg)
+ (let ((narg (car rest)))
+ (set! rest (cdr rest))
+ narg)))
+ (define (next-number)
+ (let ((n (string->number (next-arg))))
+ (if (and n (> n 0)) n (error "invalid argument to option" arg))))
+ (cond
+ [(member arg '("-h" "-help" "--help")) (print-usage)]
+ [(member arg '("-v" "-version"))
+ (print "chicken-profile - Version " (chicken-version))
+ (exit) ]
+ [(string=? arg "-release")
+ (print (chicken-version))
+ (exit) ]
+ [(string=? arg "-no-unused") (set! no-unused #t)]
+ [(string=? arg "-top") (set! top (next-number))]
+ [(string=? arg "-sort-by-calls") (set! sort-by sort-by-calls)]
+ [(string=? arg "-sort-by-time") (set! sort-by sort-by-time)]
+ [(string=? arg "-sort-by-avg") (set! sort-by sort-by-avg)]
+ [(string=? arg "-sort-by-name") (set! sort-by sort-by-name)]
+ [(string=? arg "-decimals") (set-decimals (next-arg))]
+ [(and (> (string-length arg) 1) (char=? #\- (string-ref arg 0)))
+ (error "invalid option" arg) ]
+ [file (print-usage)]
+ [else (set! file arg)] )
+ (loop rest) ) ) ) )
+
+(define (sort-by-calls x y)
+ (let ([c1 (second x)]
+ [c2 (second y)] )
+ (if (eqv? c1 c2)
+ (> (third x) (third y))
+ (if c1 (if c2 (> c1 c2) #t) #t) ) ) )
+
+(define (sort-by-time x y)
+ (let ([c1 (third x)]
+ [c2 (third y)] )
+ (if (= c1 c2)
+ (> (second x) (second y))
+ (> c1 c2) ) ) )
+
+(define (sort-by-avg x y)
+ (let ([c1 (cadddr x)]
+ [c2 (cadddr y)] )
+ (if (eqv? c1 c2)
+ (> (third x) (third y))
+ (> c1 c2) ) ) )
+
+(define (sort-by-name x y)
+ (string<? (symbol->string (first x)) (symbol->string (first y))) )
+
+(set! sort-by sort-by-time)
+
+(define (set-decimals arg)
+ (if (= (string-length arg) 3)
+ (begin
+ (define (arg-digit n)
+ (let ((n (- (char->integer (string-ref arg n))
+ (char->integer #\0))))
+ (if (<= 0 n 9)
+ (if (= n 9) 8 n) ; 9 => overflow in format-real
+ (error "invalid argument to -decimals option" arg))))
+ (set! seconds-digits (arg-digit 0))
+ (set! average-digits (arg-digit 1))
+ (set! percent-digits (arg-digit 2)))
+ (error "invalid argument to -decimals option" arg)))
+
+(define (read-profile)
+ (let ((hash (make-hash-table eq?)))
+ (do ((line (read) (read)))
+ ((eof-object? line))
+ (hash-table-set!
+ hash (first line)
+ (map (lambda (x y) (and x y (+ x y)))
+ (hash-table-ref/default hash (first line) '(0 0))
+ (cdr line))))
+ (hash-table->alist hash)))
+
+(define (format-string str cols #!optional right (padc #\space))
+ (let* ((len (string-length str))
+ (pad (make-string (fxmax 0 (fx- cols len)) padc)) )
+ (if right
+ (string-append pad str)
+ (string-append str pad) ) ) )
+
+(define (format-real n d)
+ (let ((exact-value (inexact->exact (truncate n))))
+ (string-append
+ (number->string exact-value)
+ (if (> d 0) "." "")
+ (substring
+ (number->string
+ (inexact->exact
+ (truncate
+ (* (- n exact-value -1) (expt 10 d)))))
+ 1 (+ d 1)))))
+
+(define (write-profile)
+ (print "reading `" file "' ...\n")
+ (let* ([data0 (with-input-from-file file read-profile)]
+ [max-t (fold (lambda (t result)
+ (max (third t) result))
+ 0
+ data0)]
+ [data (sort (map
+ (lambda (t) (append t (let ((c (second t))
+ (t (third t)))
+ (list (or (and c (> c 0) (/ t c))
+ 0)
+ (or (and (> max-t 0) (* (/ t max-t) 100))
+ 0)
+ ))))
+ data0)
+ sort-by)])
+ (if (< 0 top (length data))
+ (set! data (take data top)))
+ (set! data (map (lambda (entry)
+ (let ([c (second entry)]
+ [t (third entry)]
+ [a (cadddr entry)]
+ [p (list-ref entry 4)] )
+ (list (##sys#symbol->qualified-string (first entry))
+ (if (not c) "overflow" (number->string c))
+ (format-real (/ t 1000) seconds-digits)
+ (format-real (/ a 1000) average-digits)
+ (format-real p percent-digits))))
+ (remove (lambda (entry)
+ (if (second entry)
+ (and (zero? (second entry)) no-unused)
+ #f) )
+ data)))
+ (let* ([headers (list "procedure" "calls" "seconds" "average" "percent")]
+ [alignments (list #f #t #t #t #t)]
+ [spacing 2]
+ [spacer (make-string spacing #\space)]
+ [column-widths (fold
+ (lambda (row max-widths)
+ (map max (map string-length row) max-widths))
+ (list 0 0 0 0 0)
+ (cons headers data))])
+ (define (print-row row)
+ (print (string-join (map format-string row column-widths alignments) spacer)))
+ (print-row headers)
+ (print (make-string (+ (reduce + 0 column-widths)
+ (* spacing (- (length alignments) 1)))
+ #\-))
+ (for-each print-row data))))
+
+(run (command-line-arguments))
diff --git a/chicken-setup.scm b/chicken-setup.scm
new file mode 100644
index 00000000..85087d0b
--- /dev/null
+++ b/chicken-setup.scm
@@ -0,0 +1,28 @@
+;;;; chicken-setup.scm - stub application to overwrite old versions of this program on installation
+;
+; Copyright (c) 2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(print "This program is obsolete. Please use `chicken-install' instead.")
+(exit 1)
diff --git a/chicken-status.1 b/chicken-status.1
new file mode 100644
index 00000000..02c78a28
--- /dev/null
+++ b/chicken-status.1
@@ -0,0 +1,72 @@
+.\" dummy line
+.TH CHICKEN-STATUS 1 "13 Aug 2008"
+
+.SH NAME
+
+chicken-status \- list installed extension libraries
+
+.SH SYNOPSIS
+
+chicken-status [OPTION | PATTERN] ...
+
+.SH DESCRIPTION
+
+.I chicken\-status
+lists installed extensions matching the regular expression(s)
+.B PATTERN
+or all, if no pattern has been given.
+See the
+.B Chicken
+manual for more information.
+
+.SH OPTIONS
+
+.TP
+.B \-h,\ \-help
+Shows a summary of options and exits.
+
+.TP
+.B \-v,\ \-version
+Shows tool version and exits.
+
+.TP
+.B \-f,\ \-files
+Shows files belonging to the matching extension.
+
+
+.SH ENVIRONMENT\ VARIABLES
+
+.TP
+.B CHICKEN_PREFIX
+The installation prefix where CHICKEN Scheme and its support files and
+libraries are located. Defaults to the installation time prefix given
+when configuring the system.
+
+.TP
+.B CHICKEN_REPOSITORY
+The path where extension libraries are installed. Defaults to the package-library
+path selected during configuration (usually
+.B $prefix/lib/chicken/<binary\-version>
+)
+
+
+.SH DOCUMENTATION
+
+More information can be found in the
+.I Chicken\ User's\ Manual
+
+.SH BUGS
+Submit bug reports by e-mail to
+.I chicken-janitors@nongnu.org
+, preferrably using the
+.B chicken\-bug
+tool.
+
+.SH AUTHORS
+The Chicken Team
+
+.SH SEE ALSO
+.BR chicken-install(1)
+.BR chicken-uninstall(1)
+.BR chicken(1)
+.BR chicken-bug(1)
diff --git a/chicken-status.scm b/chicken-status.scm
new file mode 100644
index 00000000..9713988c
--- /dev/null
+++ b/chicken-status.scm
@@ -0,0 +1,131 @@
+;;;; chicken-status.scm
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(require-library setup-api srfi-1 posix data-structures utils ports regex files)
+
+
+(module main ()
+
+ (import scheme chicken)
+ (import srfi-1 posix data-structures utils ports regex
+ files setup-api)
+
+ (define (gather-eggs patterns)
+ (let ((eggs (map pathname-file
+ (glob (make-pathname (repository-path) "*" "setup-info")))))
+ (delete-duplicates
+ (concatenate (map (cut grep <> eggs) patterns))
+ string=?)))
+
+ (define (format-string str cols #!optional right (padc #\space))
+ (let* ((len (string-length str))
+ (pad (make-string (fxmax 0 (fx- cols len)) padc)) )
+ (if right
+ (string-append pad str)
+ (string-append str pad) ) ) )
+
+ (define get-terminal-width
+ (let ((default-width 80)) ; Standard default terminal width
+ (lambda ()
+ (let ((cop (current-output-port)))
+ (if (terminal-port? cop)
+ (let ((w (nth-value 1 (terminal-size cop))))
+ (if (zero? w) default-width w))
+ default-width)))))
+
+ (define (list-installed-eggs eggs)
+ (let ((w (quotient (- (get-terminal-width) 2) 2)))
+ (for-each
+ (lambda (egg)
+ (let ((version (assq 'version (read-info egg))))
+ (if version
+ (print
+ (format-string (string-append egg " ") w #f #\.)
+ (format-string
+ (string-append " version: " (->string (cadr version)))
+ w #t #\.))
+ (print egg))))
+ (sort eggs string<?))))
+
+ (define (list-installed-files eggs)
+ (for-each
+ print
+ (sort
+ (append-map
+ (lambda (egg)
+ (let ((files (assq 'files (read-info egg))))
+ (if files
+ (cdr files)
+ '())))
+ eggs)
+ string<?)))
+
+ (define (usage code)
+ (print #<<EOF
+usage: chicken-status [OPTION | PATTERN] ...
+
+ -h -help show this message
+ -v -version show version and exit
+ -f -files list installed files
+EOF
+);|
+ (exit code))
+
+ (define *short-options* '(#\h #\f))
+
+ (define (main args)
+ (let ((files #f))
+ (let loop ((args args) (pats '()))
+ (if (null? args)
+ (let ((eggs (gather-eggs (if (null? pats) '(".*") pats))))
+ (if (null? eggs)
+ (print "(none)")
+ ((if files list-installed-files list-installed-eggs)
+ eggs)))
+ (let ((arg (car args)))
+ (cond ((or (string=? arg "-help")
+ (string=? arg "-h")
+ (string=? arg "--help"))
+ (usage 0))
+ ((or (string=? arg "-f") (string=? arg "-files"))
+ (set! files #t)
+ (loop (cdr args) pats))
+ ((or (string=? arg "-v") (string=? arg "-version"))
+ (print (chicken-version))
+ (exit 0))
+ ((and (positive? (string-length arg))
+ (char=? #\- (string-ref arg 0)))
+ (if (> (string-length arg) 2)
+ (let ((sos (string->list (substring arg 1))))
+ (if (null? (lset-intersection eq? *short-options* sos))
+ (loop (append (map (cut string #\- <>) sos) (cdr args)) pats)
+ (usage 1)))
+ (usage 1)))
+ (else (loop (cdr args) (cons arg pats)))))))))
+
+ (main (command-line-arguments))
+
+ )
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
new file mode 100644
index 00000000..34fe44b0
--- /dev/null
+++ b/chicken-syntax.scm
@@ -0,0 +1,1112 @@
+;;;; chicken-syntax.scm - non-standard syntax extensions
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit chicken-syntax)
+ (disable-interrupts)
+ (no-bound-checks)
+ (no-procedure-checks)
+ (fixnum) )
+
+(##sys#provide
+ 'chicken-more-macros ; historical, remove later
+ 'chicken-syntax)
+
+
+;;; Non-standard macros:
+
+(define ##sys#chicken-macro-environment
+ (let ((me0 (##sys#macro-environment)))
+
+(##sys#extend-macro-environment
+ 'define-record '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'define-record x '(_ symbol . #(symbol 0)))
+ (let* ((name (cadr x))
+ (slots (cddr x))
+ (prefix (symbol->string name))
+ (%quote (r 'quote))
+ (setters (memq #:record-setters ##sys#features))
+ (%begin (r 'begin))
+ (%define (r 'define))
+ (%getter-with-setter (r 'getter-with-setter))
+ (%lambda (r 'lambda)) )
+ `(,%begin
+ (,%define
+ ,(string->symbol (string-append "make-" prefix))
+ (,%lambda ,slots (##sys#make-structure (,%quote ,name) ,@slots)) )
+ (,%define
+ ,(string->symbol (string-append prefix "?"))
+ (,%lambda (x) (##sys#structure? x ',name)) )
+ ,@(let mapslots ((slots slots) (i 1))
+ (if (eq? slots '())
+ slots
+ (let* ((slotname (symbol->string (##sys#slot slots 0)))
+ (setr (string->symbol (string-append prefix "-" slotname "-set!")))
+ (getr (string->symbol (string-append prefix "-" slotname)) ) )
+ (cons
+ `(,%begin
+ (,%define
+ ,setr
+ (,%lambda (x val)
+ (##core#check (##sys#check-structure x (,%quote ,name)))
+ (##sys#block-set! x ,i val) ) )
+ (,%define
+ ,getr
+ ,(if setters
+ `(,%getter-with-setter
+ (,%lambda (x)
+ (##core#check (##sys#check-structure x (,%quote ,name)))
+ (##sys#block-ref x ,i) )
+ ,setr)
+ `(,%lambda (x)
+ (##core#check (##sys#check-structure x (,%quote ,name)))
+ (##sys#block-ref x ,i) ) ) ) )
+ (mapslots (##sys#slot slots 1) (fx+ i 1)) ) ) ) ) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'receive
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (let ((%lambda (r 'lambda))
+ (%let (r 'let)))
+ (##sys#check-syntax 'receive form '(_ _ . #(_ 0)))
+ (cond ((null? (cddr form))
+ `(##sys#call-with-values (,%lambda () ,@(cdr form)) ##sys#list) )
+ (else
+ (##sys#check-syntax 'receive form '(_ lambda-list _ . #(_ 1)))
+ (let ((vars (cadr form))
+ (exp (caddr form))
+ (rest (cdddr form)))
+ (if (and (pair? vars) (null? (cdr vars)))
+ `(,%let ((,(car vars) ,exp)) ,@rest)
+ `(##sys#call-with-values
+ (,%lambda () ,exp)
+ (,%lambda ,vars ,@rest)) ) ) ) ) ))))
+
+(##sys#extend-macro-environment
+ 'time '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (let ((rvar (r 't))
+ (%begin (r 'begin))
+ (%lambda (r 'lambda)))
+ `(,%begin
+ (##sys#start-timer)
+ (##sys#call-with-values
+ (,%lambda () ,@(cdr form))
+ (,%lambda ,rvar
+ (##sys#display-times (##sys#stop-timer))
+ (##sys#apply ##sys#values ,rvar) ) ) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'declare '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ `(##core#declare ,@(cdr form)))))
+
+(##sys#extend-macro-environment
+ 'include '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'include form '(_ string))
+ (let ((path (##sys#resolve-include-filename (cadr form) #t))
+ (%begin (r 'begin)))
+ (when (load-verbose) (print "; including " path " ..."))
+ `(,%begin
+ ,@(with-input-from-file path
+ (lambda ()
+ (fluid-let ((##sys#current-source-filename path))
+ (do ([x (read) (read)]
+ [xs '() (cons x xs)] )
+ ((eof-object? x)
+ (reverse xs))) ) ) ) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'assert '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'assert form '#(_ 1))
+ (let* ((exp (cadr form))
+ (msg-and-args (cddr form))
+ (%if (r 'if))
+ (%quote (r 'quote))
+ (msg (if (eq? '() msg-and-args)
+ `(##core#immutable '"assertion failed")
+ (car msg-and-args) ) ) )
+ `(,%if (##core#check ,exp)
+ (##core#undefined)
+ (##sys#error
+ ,msg
+ ,@(if (fx> (length msg-and-args) 1)
+ (cdr msg-and-args)
+ '() ) ) ) ) )) )
+
+(##sys#extend-macro-environment
+ 'ensure
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'ensure form '#(_ 3))
+ (let ((pred (cadr form))
+ (exp (caddr form))
+ (args (cdddr form))
+ (tmp (r 'tmp))
+ (%let (r 'let))
+ (%if (r 'if)) )
+ `(,%let ([,tmp ,exp])
+ (,%if (##core#check (,pred ,tmp))
+ ,tmp
+ (##sys#signal-hook
+ #:type-error
+ ,@(if (pair? args)
+ args
+ `((##core#immutable '"argument has incorrect type")
+ ,tmp ',pred) ) ) ) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'fluid-let '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'fluid-let form '(_ #((symbol _) 0) . _))
+ (let* ((clauses (cadr form))
+ (body (cddr form))
+ (ids (##sys#map car clauses))
+ (new-tmps (##sys#map (lambda (x) (r (gensym))) clauses))
+ (old-tmps (##sys#map (lambda (x) (r (gensym))) clauses))
+ (%let (r 'let))
+ (%lambda (r 'lambda)))
+ `(,%let (,@(map ##sys#list new-tmps (##sys#map cadr clauses))
+ ,@(map ##sys#list old-tmps
+ (let loop ((n (length clauses)))
+ (if (eq? n 0)
+ '()
+ (cons #f (loop (fx- n 1))) ) ) ) )
+ (##sys#dynamic-wind
+ (,%lambda ()
+ ,@(map (lambda (ot id) `(##core#set! ,ot ,id))
+ old-tmps ids)
+ ,@(map (lambda (id nt) `(##core#set! ,id ,nt))
+ ids new-tmps)
+ (##core#undefined) )
+ (,%lambda () ,@body)
+ (,%lambda ()
+ ,@(map (lambda (nt id) `(##core#set! ,nt ,id))
+ new-tmps ids)
+ ,@(map (lambda (id ot) `(##core#set! ,id ,ot))
+ ids old-tmps)
+ (##core#undefined) ) ) ) ) )))
+
+(##sys#extend-macro-environment
+ 'eval-when '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'eval-when form '#(_ 2))
+ (let* ((situations (cadr form))
+ (%begin (r 'begin))
+ (body `(,%begin ,@(cddr form)))
+ (%eval (r 'eval))
+ (%compile (r 'compile))
+ (%load (r 'load))
+ (e #f)
+ (co #f)
+ (l #f))
+ (let loop ([ss situations])
+ (if (pair? ss)
+ (let ((s (car ss)))
+ (cond ((c s %eval) (set! e #t))
+ ((c s %load) (set! l #t))
+ ((c s %compile) (set! co #t))
+ (else (##sys#error "invalid situation specifier" (car ss)) ))
+ (loop (##sys#slot ss 1)) ) ) )
+ (if (memq '#:compiling ##sys#features)
+ (cond [(and co l) `(##core#compiletimetoo ,body)]
+ [co `(##core#compiletimeonly ,body)]
+ [l body]
+ [else '(##core#undefined)] )
+ (if e
+ body
+ '(##core#undefined) ) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'parameterize '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'parameterize form '#(_ 2))
+ (let* ((bindings (cadr form))
+ (body (cddr form))
+ (swap (r 'swap))
+ (%let (r 'let))
+ (%lambda (r 'lambda))
+ [params (##sys#map car bindings)]
+ [vals (##sys#map cadr bindings)]
+ [aliases (##sys#map (lambda (z) (r (gensym))) params)]
+ [aliases2 (##sys#map (lambda (z) (r (gensym))) params)] )
+ `(,%let ,(##sys#append (map ##sys#list aliases params) (map ##sys#list aliases2 vals))
+ (,%let ((,swap (,%lambda ()
+ ,@(map (lambda (a a2)
+ `(,%let ((t (,a))) (,a ,a2)
+ (##core#set! ,a2 t)))
+ aliases aliases2) ) ) )
+ (##sys#dynamic-wind
+ ,swap
+ (,%lambda () ,@body)
+ ,swap) ) ) ) )))
+
+(##sys#extend-macro-environment
+ 'when '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'when form '#(_ 2))
+ `(,(r 'if) ,(cadr form)
+ (,(r 'begin) ,@(cddr form))))))
+
+(##sys#extend-macro-environment
+ 'unless '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'unless form '#(_ 2))
+ `(,(r 'if) ,(cadr form)
+ (##core#undefined)
+ (,(r 'begin) ,@(cddr form))))))
+
+(##sys#extend-macro-environment
+ 'set!-values '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'set!-values form '(_ #(variable 0) _))
+ (let ((vars (cadr form))
+ (exp (caddr form))
+ (%lambda (r 'lambda)))
+ (cond ((null? vars)
+ ;; may this be simply "exp"?
+ `(##sys#call-with-values
+ (,%lambda () ,exp)
+ (,%lambda () (##core#undefined))) )
+ ((null? (cdr vars))
+ `(##core#set! ,(car vars) ,exp))
+ (else
+ (let ([aliases (map gensym vars)])
+ `(##sys#call-with-values
+ (,%lambda () ,exp)
+ (,%lambda ,aliases
+ ,@(map (lambda (v a)
+ `(##core#set! ,v ,a))
+ vars aliases) ) ) ) ) ) ))))
+
+(##sys#extend-macro-environment
+ 'define-values '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'define-values form '(_ #(variable 0) _))
+ (for-each (cut ##sys#register-export <> (##sys#current-module)) (cadr form))
+ `(,(r 'set!-values) ,@(cdr form)))))
+
+(##sys#extend-macro-environment
+ 'let-values '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'let-values form '(_ list . _))
+ (let ((vbindings (cadr form))
+ (body (cddr form))
+ (%let (r 'let))
+ (%lambda (r 'lambda)))
+ (letrec ((append* (lambda (il l)
+ (if (not (pair? il))
+ (cons il l)
+ (cons (car il)
+ (append* (cdr il) l)))))
+ (map* (lambda (proc l)
+ (cond ((null? l) '())
+ ((not (pair? l)) (proc l))
+ (else (cons (proc (car l)) (map* proc (cdr l))))))))
+ (let* ([llists (map car vbindings)]
+ [vars (let loop ((llists llists) (acc '()))
+ (if (null? llists)
+ acc
+ (let* ((llist (car llists))
+ (new-acc
+ (cond ((list? llist) (append llist acc))
+ ((pair? llist) (append* llist acc))
+ (else (cons llist acc)))))
+ (loop (cdr llists) new-acc))))]
+ [aliases (map (lambda (v) (cons v (r (gensym v)))) vars)]
+ [lookup (lambda (v) (cdr (assq v aliases)))]
+ [llists2 (let loop ((llists llists) (acc '()))
+ (if (null? llists)
+ (reverse acc)
+ (let* ((llist (car llists))
+ (new-acc
+ (cond ((not (pair? llist)) (cons (lookup llist) acc))
+ (else (cons (map* lookup llist) acc)))))
+ (loop (cdr llists) new-acc))))])
+ (let fold ([llists llists]
+ [exps (map (lambda (x) (cadr x)) vbindings)]
+ [llists2 llists2] )
+ (cond ((null? llists)
+ `(,%let ,(map (lambda (v) (##sys#list v (lookup v))) vars) ,@body) )
+ ((and (pair? (car llists2)) (null? (cdar llists2)))
+ `(,%let ((,(caar llists2) ,(car exps)))
+ ,(fold (cdr llists) (cdr exps) (cdr llists2)) ) )
+ (else
+ `(##sys#call-with-values
+ (,%lambda () ,(car exps))
+ (,%lambda ,(car llists2) ,(fold (cdr llists) (cdr exps) (cdr llists2))) ) ) ) ) ) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'let*-values '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'let*-values form '(_ list . _))
+ (let ((vbindings (cadr form))
+ (body (cddr form))
+ (%let (r 'let))
+ (%let-values (r 'let-values)) )
+ (let fold ([vbindings vbindings])
+ (if (null? vbindings)
+ `(,%let () ,@body)
+ `(,%let-values (,(car vbindings))
+ ,(fold (cdr vbindings))) ) ) ))))
+
+(##sys#extend-macro-environment
+ 'letrec-values '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'letrec-values form '(_ list . _))
+ (let ((vbindings (cadr form))
+ (body (cddr form))
+ (%let (r 'let))
+ (%lambda (r 'lambda)))
+ (let* ([vars (apply ##sys#append (map (lambda (x) (car x)) vbindings))]
+ [aliases (map (lambda (v) (cons v (r (gensym v)))) vars)]
+ [lookup (lambda (v) (cdr (assq v aliases)))] )
+ `(,%let ,(map (lambda (v) (##sys#list v '(##core#undefined))) vars)
+ ,@(map (lambda (vb)
+ `(##sys#call-with-values
+ (,%lambda () ,(cadr vb))
+ (,%lambda ,(map lookup (car vb))
+ ,@(map (lambda (v) `(##core#set! ,v ,(lookup v))) (car vb)) ) ) )
+ vbindings)
+ ,@body) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'nth-value
+ `((list-ref . ,(##sys#primitive-alias 'list-ref)))
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'nth-value form '(_ _ _))
+ (let ((v (r 'tmp))
+ (%lambda (r 'lambda)))
+ `(##sys#call-with-values
+ (,%lambda () ,(caddr form))
+ (,%lambda ,v (,(r 'list-ref) ,v ,(cadr form))))))))
+
+(##sys#extend-macro-environment
+ 'define-inline '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (let ((%lambda (r 'lambda)))
+ (letrec ([quotify-proc
+ (lambda (xs id)
+ (##sys#check-syntax id xs '#(_ 1))
+ (let* ([head (car xs)]
+ [name (if (pair? head) (car head) head)]
+ [val (if (pair? head)
+ `(,%lambda ,(cdr head) ,@(cdr xs))
+ (cadr xs) ) ] )
+ (when (or (not (pair? val)) (not (c %lambda (car val))))
+ (syntax-error
+ 'define-inline "invalid substitution form - must be lambda"
+ name) )
+ (list name val) ) ) ] )
+ `(##core#define-inline ,@(quotify-proc (cdr form) 'define-inline)))) ) ) )
+
+(##sys#extend-macro-environment
+ 'and-let* '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'and-let* form '(_ #(_ 0) . _))
+ (let ((bindings (cadr form))
+ (body (cddr form))
+ (%if (r 'if))
+ (%let (r 'let)))
+ (let fold ([bs bindings])
+ (if (null? bs)
+ `(,(r 'begin) ,@body)
+ (let ([b (car bs)]
+ [bs2 (cdr bs)] )
+ (cond [(not (pair? b)) `(,%if ,b ,(fold bs2) #f)]
+ [(null? (cdr b)) `(,%if ,(car b) ,(fold bs2) #f)]
+ [else
+ (let ((var (car b)))
+ `(,%let ((,var ,(cadr b)))
+ (,%if ,var ,(fold bs2) #f) ) ) ] ) ) ) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'select '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'select form '(_ _ . _))
+ (let ((exp (cadr form))
+ (body (cddr form))
+ (tmp (r 'tmp))
+ (%if (r 'if))
+ (%else (r 'else))
+ (%or (r 'or))
+ (%begin (r 'begin)))
+ `(,(r 'let) ((,tmp ,exp))
+ ,(let expand ((clauses body))
+ (if (not (pair? clauses))
+ '(##core#undefined)
+ (let ((clause (##sys#slot clauses 0))
+ (rclauses (##sys#slot clauses 1)) )
+ (##sys#check-syntax 'select clause '#(_ 1))
+ (if (c %else (car clause))
+ `(,%begin ,@(cdr clause))
+ `(,%if (,%or ,@(map (lambda (x) `(##sys#eqv? ,tmp ,x))
+ (car clause) ) )
+ (,%begin ,@(cdr clause))
+ ,(expand rclauses) ) ) ) ) ) ) ) ) ) )
+
+
+;;; Optional argument handling:
+
+;;; Copyright (C) 1996 by Olin Shivers.
+;;;
+;;; This file defines three macros for parsing optional arguments to procs:
+;;; (LET-OPTIONALS arg-list ((var1 default1) ...) . body)
+;;; (LET-OPTIONALS* arg-list ((var1 default1) ...) . body)
+;;; (:OPTIONAL rest-arg default-exp)
+;;;
+;;; The LET-OPTIONALS macro is defined using the Clinger/Rees
+;;; explicit-renaming low-level macro system. You'll have to do some work to
+;;; port it to another macro system.
+;;;
+;;; The LET-OPTIONALS* and :OPTIONAL macros are defined with simple
+;;; high-level macros, and should be portable to any R4RS system.
+;;;
+;;; These macros are all careful to evaluate their default forms *only* if
+;;; their values are needed.
+;;;
+;;; The only non-R4RS dependencies in the macros are ERROR
+;;; and CALL-WITH-VALUES.
+;;; -Olin
+
+;;; (LET-OPTIONALS arg-list ((var1 default1) ...)
+;;; body
+;;; ...)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This form is for binding a procedure's optional arguments to either
+;;; the passed-in values or a default.
+;;;
+;;; The expression takes a rest list ARG-LIST and binds the VARi to
+;;; the elements of the rest list. When there are no more elements, then
+;;; the remaining VARi are bound to their corresponding DEFAULTi values.
+;;; It is an error if there are more args than variables.
+;;;
+;;; - The default expressions are *not* evaluated unless needed.
+;;;
+;;; - When evaluated, the default expressions are carried out in the *outer*
+;;; environment. That is, the DEFAULTi forms do *not* see any of the VARi
+;;; bindings.
+;;;
+;;; I originally wanted to have the DEFAULTi forms get eval'd in a LET*
+;;; style scope -- DEFAULT3 would see VAR1 and VAR2, etc. But this is
+;;; impossible to implement without side effects or redundant conditional
+;;; tests. If I drop this requirement, I can use the efficient expansion
+;;; shown below. If you need LET* scope, use the less-efficient
+;;; LET-OPTIONALS* form defined below.
+;;;
+;;; Example:
+;;; (define (read-string! str . maybe-args)
+;;; (let-optionals maybe-args ((port (current-input-port))
+;;; (start 0)
+;;; (end (string-length str)))
+;;; ...))
+;;;
+;;; expands to:
+;;;
+;;; (let* ((body (lambda (port start end) ...))
+;;; (end-def (lambda (%port %start) (body %port %start <end-default>)))
+;;; (start-def (lambda (%port) (end-def %port <start-default>)))
+;;; (port-def (lambda () (start-def <port-def>))))
+;;; (if (null? rest) (port-def)
+;;; (let ((%port (car rest))
+;;; (rest (cdr rest)))
+;;; (if (null? rest) (start-def %port)
+;;; (let ((%start (car rest))
+;;; (rest (cdr rest)))
+;;; (if (null? rest) (end-def %port %start)
+;;; (let ((%end (car rest))
+;;; (rest (cdr rest)))
+;;; (if (null? rest) (body %port %start %end)
+;;; (error ...)))))))))
+
+
+;;; (LET-OPTIONALS args ((var1 default1) ...) body1 ...)
+
+(##sys#extend-macro-environment
+ 'let-optionals
+ `((car . ,(##sys#primitive-alias 'car))
+ (cdr . ,(##sys#primitive-alias 'cdr)))
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'let-optionals form '(_ _ . _))
+ (let ((arg-list (cadr form))
+ (var/defs (caddr form))
+ (body (cdddr form))
+ (%if (r 'if))
+ (%let (r 'let))
+ (%lambda (r 'lambda)))
+
+ ;; This guy makes the END-DEF, START-DEF, PORT-DEF definitions above.
+ ;; I wish I had a reasonable loop macro.
+
+ (define (make-default-procs vars body-proc defaulter-names defs rename)
+ (let recur ((vars (reverse vars))
+ (defaulter-names (reverse defaulter-names))
+ (defs (reverse defs))
+ (next-guy body-proc))
+ (if (null? vars) '()
+ (let ((vars (cdr vars)))
+ `((,(car defaulter-names)
+ (,%lambda ,(reverse vars)
+ (,next-guy ,@(reverse vars) ,(car defs))))
+ . ,(recur vars
+ (cdr defaulter-names)
+ (cdr defs)
+ (car defaulter-names)))))))
+
+
+ ;; This guy makes the (IF (NULL? REST) (PORT-DEF) ...) tree above.
+
+ (define (make-if-tree vars defaulters body-proc rest rename)
+ (let recur ((vars vars) (defaulters defaulters) (non-defaults '()))
+ (if (null? vars)
+ `(,%if (##core#check (,(r 'null?) ,rest))
+ (,body-proc . ,(reverse non-defaults))
+ (##sys#error (##core#immutable '"too many optional arguments") ,rest))
+ (let ((v (car vars)))
+ `(,%if (null? ,rest)
+ (,(car defaulters) . ,(reverse non-defaults))
+ (,%let ((,v (,(r 'car) ,rest)) ; we use car/cdr, because of rest-list optimization
+ (,rest (,(r 'cdr) ,rest)))
+ ,(recur (cdr vars)
+ (cdr defaulters)
+ (cons v non-defaults))))))))
+
+ (##sys#check-syntax 'let-optionals var/defs '#((variable _) 0))
+ (##sys#check-syntax 'let-optionals body '#(_ 1))
+ (let* ((vars (map car var/defs))
+ (prefix-sym (lambda (prefix sym)
+ (string->symbol (string-append prefix (symbol->string sym)))))
+
+ ;; Private vars, one for each user var.
+ ;; We prefix the % to help keep macro-expanded code from being
+ ;; too confusing.
+ (vars2 (map (lambda (v) (r (prefix-sym "%" v)))
+ vars))
+
+ (defs (map cadr var/defs))
+ (body-proc (r 'body))
+
+ ;; A private var, bound to the value of the ARG-LIST expression.
+ (rest-var (r '%rest))
+
+ (defaulter-names (map (lambda (var) (r (prefix-sym "def-" var)))
+ vars))
+
+ (defaulters (make-default-procs vars2 body-proc
+ defaulter-names defs gensym))
+ (if-tree (make-if-tree vars2 defaulter-names body-proc
+ rest-var gensym)))
+
+ `(,(r 'let*) ((,rest-var ,arg-list)
+ (,body-proc (,%lambda ,vars . ,body))
+ . ,defaulters)
+ ,if-tree) ) ))))
+
+
+;;; (optional rest-arg default-exp)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This form is for evaluating optional arguments and their defaults
+;;; in simple procedures that take a *single* optional argument. It is
+;;; a macro so that the default will not be computed unless it is needed.
+;;;
+;;; REST-ARG is a rest list from a lambda -- e.g., R in
+;;; (lambda (a b . r) ...)
+;;; - If REST-ARG has 0 elements, evaluate DEFAULT-EXP and return that.
+;;; - If REST-ARG has 1 element, return that element.
+;;; - If REST-ARG has >1 element, error.
+
+(##sys#extend-macro-environment
+ 'optional
+ `((null? . ,(##sys#primitive-alias 'null?))
+ (car . ,(##sys#primitive-alias 'car))
+ (cdr . ,(##sys#primitive-alias 'cdr)) )
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'optional form '(_ _ . #(_ 0 1)))
+ (let ((var (r 'tmp))
+ (%if (r 'if)))
+ `(,(r 'let) ((,var ,(cadr form)))
+ (,%if (,(r 'null?) ,var)
+ ,(optional (cddr form) #f)
+ (,%if (##core#check (,(r 'null?) (,(r 'cdr) ,var)))
+ (,(r 'car) ,var)
+ (##sys#error
+ (##core#immutable '"too many optional arguments")
+ ,var))))))))
+
+
+;;; (LET-OPTIONALS* args ((var1 default1) ... [rest]) body1 ...)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This is just like LET-OPTIONALS, except that the DEFAULTi forms
+;;; are evaluated in a LET*-style environment. That is, DEFAULT3 is evaluated
+;;; within the scope of VAR1 and VAR2, and so forth.
+;;;
+;;; - If the last form in the ((var1 default1) ...) list is not a
+;;; (VARi DEFAULTi) pair, but a simple variable REST, then it is
+;;; bound to any left-over values. For example, if we have VAR1 through
+;;; VAR7, and ARGS has 9 values, then REST will be bound to the list of
+;;; the two values of ARGS. If ARGS is too short, causing defaults to
+;;; be used, then REST is bound to '().
+;;; - If there is no REST variable, then it is an error to have excess
+;;; values in the ARGS list.
+
+(##sys#extend-macro-environment
+ 'let-optionals*
+ `((null? . ,(##sys#primitive-alias 'null?)))
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'let-optionals* form '(_ _ list . _))
+ (let ((args (cadr form))
+ (var/defs (caddr form))
+ (body (cdddr form))
+ (%let (r 'let))
+ (%null? (r 'null?))
+ (%car (r 'car))
+ (%cdr (r 'cdr))
+ (%if (r 'if)))
+ (let ((rvar (r 'tmp)))
+ `(,%let ((,rvar ,args))
+ ,(let loop ([args rvar] [vardefs var/defs])
+ (if (null? vardefs)
+ `(,%if (##core#check (,%null? ,args))
+ (,%let () ,@body)
+ (##sys#error
+ (##core#immutable '"too many optional arguments")
+ ,args) )
+ (let ([head (car vardefs)])
+ (if (pair? head)
+ (let ((rvar2 (r 'tmp2)))
+ `(,%let ((,(car head) (,%if (,%null? ,args)
+ ,(cadr head)
+ (,%car ,args)))
+ (,rvar2 (,%if (,%null? ,args)
+ '()
+ (,%cdr ,args))) )
+ ,(loop rvar2 (cdr vardefs)) ) )
+ `(,%let ((,head ,args)) ,@body) ) ) ) ) ) ) ))))
+
+
+;;; case-lambda (SRFI-16):
+
+(##sys#extend-macro-environment
+ 'case-lambda
+ `((>= . ,(##sys#primitive-alias '>=))
+ (car . ,(##sys#primitive-alias 'car))
+ (cdr . ,(##sys#primitive-alias 'cdr))
+ (eq? . ,(##sys#primitive-alias 'eq?)))
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'case-lambda form '(_ . _))
+ (define (genvars n)
+ (let loop ([i 0])
+ (if (fx>= i n)
+ '()
+ (cons (r (gensym)) (loop (fx+ i 1))) ) ) )
+ (require 'srfi-1) ; ugh...
+ (let* ((mincount (apply min (map (lambda (c)
+ (##sys#decompose-lambda-list
+ (car c)
+ (lambda (vars argc rest) argc) ) )
+ (cdr form))))
+ (minvars (genvars mincount))
+ (rvar (r 'rvar))
+ (lvar (r 'lvar))
+ (%lambda (r 'lambda))
+ (%let (r 'let))
+ (%>= (r '>=))
+ (%eq? (r 'eq?))
+ (%car (r 'car))
+ (%cdr (r 'cdr))
+ (%if (r 'if)))
+ `(,%lambda ,(append minvars rvar)
+ (,%let ((,lvar (length ,rvar)))
+ ,(fold-right
+ (lambda (c body)
+ (##sys#decompose-lambda-list
+ (car c)
+ (lambda (vars argc rest)
+ (##sys#check-syntax 'case-lambda (car c) 'lambda-list)
+ `(,%if ,(let ([a2 (fx- argc mincount)])
+ (if rest
+ (if (zero? a2)
+ #t
+ `(,%>= ,lvar ,a2) )
+ `(,%eq? ,lvar ,a2) ) )
+ ,(receive (vars1 vars2)
+ (split-at! (take vars argc) mincount)
+ (let ((bindings
+ (let build ((vars2 vars2) (vrest rvar))
+ (if (null? vars2)
+ (cond (rest `(,%let ((,rest ,vrest)) ,@(cdr c)))
+ ((null? (cddr c)) (cadr c))
+ (else `(,%let () ,@(cdr c))) )
+ (let ((vrest2 (r (gensym))))
+ `(,%let ((,(car vars2) (,%car ,vrest))
+ (,vrest2 (,%cdr ,vrest)) )
+ ,(if (pair? (cdr vars2))
+ (build (cdr vars2) vrest2)
+ (build '() vrest2) ) ) ) ) ) ) )
+ (if (null? vars1)
+ bindings
+ `(,%let ,(map list vars1 minvars) ,bindings) ) ) )
+ ,body) ) ) )
+ '(##core#check (##sys#error (##core#immutable '"no matching clause in call to 'case-lambda' form")))
+ (cdr form))))))))
+
+
+;;; Record printing:
+
+(##sys#extend-macro-environment
+ 'define-record-printer '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'define-record-printer form '(_ _ . _))
+ (let ([head (cadr form)]
+ [body (cddr form)])
+ (cond [(pair? head)
+ (##sys#check-syntax
+ 'define-record-printer (cons head body)
+ '((symbol symbol symbol) . #(_ 1)))
+ `(##sys#register-record-printer
+ ',(##sys#slot head 0)
+ (,(r 'lambda) ,(##sys#slot head 1) ,@body)) ]
+ [else
+ (##sys#check-syntax 'define-record-printer (cons head body) '(symbol _))
+ `(##sys#register-record-printer ',head ,@body) ] ) ))))
+
+
+;;; Exceptions:
+
+(##sys#extend-macro-environment
+ 'handle-exceptions
+ `((call-with-current-continuation . ,(##sys#primitive-alias 'call-with-current-continuation))
+ (with-exception-handler . ,(##sys#primitive-alias 'with-exception-handler)))
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'handle-exceptions form '(_ variable _ . _))
+ (let ((k (r 'k))
+ (args (r 'args))
+ (%lambda (r 'lambda)))
+ `((,(r 'call-with-current-continuation)
+ (,%lambda (,k)
+ (,(r 'with-exception-handler)
+ (,%lambda (,(cadr form)) (,k (,%lambda () ,(caddr form))))
+ (,%lambda ()
+ (##sys#call-with-values
+ (,%lambda () ,@(cdddr form))
+ (,%lambda
+ ,args
+ (,k (lambda () (##sys#apply ##sys#values ,args)))) ) ) ) ) ) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'condition-case
+ `((else . ,(##sys#primitive-alias 'else))
+ (memv . ,(##sys#primitive-alias 'memv)))
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'condition-case form '(_ _ . _))
+ (let ((exvar (r 'exvar))
+ (kvar (r 'kvar))
+ (%and (r 'and))
+ (%let (r 'let))
+ (%quote (r 'quote))
+ (%memv (r 'memv))
+ (%else (r 'else)))
+ (define (parse-clause c)
+ (let* ([var (and (symbol? (car c)) (car c))]
+ [kinds (if var (cadr c) (car c))]
+ [body (if var (cddr c) (cdr c))] )
+ (if (null? kinds)
+ `(,%else
+ ,(if var
+ `(,%let ([,var ,exvar]) ,@body)
+ `(,%let () ,@body) ) )
+ `((,%and ,kvar ,@(map (lambda (k) `(,%memv (,%quote ,k) ,kvar)) kinds))
+ ,(if var
+ `(,%let ([,var ,exvar]) ,@body)
+ `(,%let () ,@body) ) ) ) ) )
+ `(,(r 'handle-exceptions) ,exvar
+ (,%let ([,kvar (,%and (##sys#structure? ,exvar (,%quote condition) )
+ (##sys#slot ,exvar 1))])
+ (,(r 'cond) ,@(map parse-clause (cddr form))
+ (,%else (##sys#signal ,exvar)) ) )
+ ,(cadr form))))))
+
+
+;;; SRFI-9:
+
+(##sys#extend-macro-environment
+ 'define-record-type
+ `((getter-with-setter . (##sys#primitive-alias 'getter-with-setter)))
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'define-record-type form '(_ variable #(variable 1) variable . _))
+ (let* ((t (cadr form))
+ (conser (caddr form))
+ (pred (cadddr form))
+ (slots (cddddr form))
+ (%begin (r 'begin))
+ (%lambda (r 'lambda))
+ (%define (r 'define))
+ (%quote (r 'quote))
+ (%getter-with-setter (r 'getter-with-setter))
+ (vars (cdr conser))
+ (x (r 'x))
+ (y (r 'y))
+ (slotnames (map car slots)))
+ `(,%begin
+ (,%define ,conser
+ (##sys#make-structure
+ (,%quote ,t)
+ ,@(map (lambda (sname)
+ (if (memq sname vars)
+ sname
+ '(##core#undefined) ) )
+ slotnames) ) )
+ (,%define (,pred ,x) (##sys#structure? ,x (,%quote ,t)))
+ ,@(let loop ([slots slots] [i 1])
+ (if (null? slots)
+ '()
+ (let* ([slot (car slots)]
+ (setters (memq #:record-setters ##sys#features))
+ (setr? (pair? (cddr slot)))
+ (getr `(,%lambda (,x)
+ (##core#check (##sys#check-structure ,x (,%quote ,t)))
+ (##sys#block-ref ,x ,i) ) ) )
+ `(,@(if setr?
+ `((,%define (,(caddr slot) ,x ,y)
+ (##core#check (##sys#check-structure ,x (,%quote ,t)))
+ (##sys#block-set! ,x ,i ,y)) )
+ '() )
+ (,%define ,(cadr slot)
+ ,(if (and setr? setters)
+ `(,%getter-with-setter ,getr ,(caddr slot))
+ getr) )
+ ,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) ) ) )
+
+
+;;; SRFI-26:
+
+(##sys#extend-macro-environment
+ 'cut
+ `((apply . ,(##sys#primitive-alias 'apply)))
+ (##sys#er-transformer
+ (lambda (form r c)
+ (let ((%<> (r '<>))
+ (%<...> (r '<...>))
+ (%apply (r 'apply))
+ (%begin (r 'begin))
+ (%lambda (r 'lambda)))
+ (let loop ([xs (cdr form)] [vars '()] [vals '()] [rest #f])
+ (if (null? xs)
+ (let ([rvars (reverse vars)]
+ [rvals (reverse vals)] )
+ (if rest
+ (let ([rv (r (gensym))])
+ `(,%lambda (,@rvars . ,rv)
+ (,%apply ,(car rvals) ,@(cdr rvals) ,rv) ) )
+ `(,%lambda ,rvars ((,%begin ,(car rvals)) ,@(cdr rvals)) ) ) )
+ (cond ((c %<> (car xs))
+ (let ([v (r (gensym))])
+ (loop (cdr xs) (cons v vars) (cons v vals) #f) ) )
+ ((c %<...> (car xs)) (loop '() vars vals #t))
+ (else (loop (cdr xs) vars (cons (car xs) vals) #f)) ) ) ) ) )))
+
+(##sys#extend-macro-environment
+ 'cute
+ `((apply . ,(##sys#primitive-alias 'apply)))
+ (##sys#er-transformer
+ (lambda (form r c)
+ (let ((%let (r 'let))
+ (%lambda (r 'lambda))
+ (%apply (r 'apply))
+ (%<> (r '<>))
+ (%<...> (r '<...>)))
+ (let loop ([xs (cdr form)] [vars '()] [bs '()] [vals '()] [rest #f])
+ (if (null? xs)
+ (let ([rvars (reverse vars)]
+ [rvals (reverse vals)] )
+ (if rest
+ (let ([rv (r (gensym))])
+ `(,%let
+ ,bs
+ (,%lambda (,@rvars . ,rv)
+ (,%apply ,(car rvals) ,@(cdr rvals) ,rv) ) ) )
+ `(,%let ,bs
+ (,%lambda ,rvars (,(car rvals) ,@(cdr rvals)) ) ) ) )
+ (cond ((c %<> (car xs))
+ (let ([v (r (gensym))])
+ (loop (cdr xs) (cons v vars) bs (cons v vals) #f) ) )
+ ((c %<...> (car xs)) (loop '() vars bs vals #t))
+ (else
+ (let ([v (r (gensym))])
+ (loop (cdr xs)
+ vars
+ (cons (list v (car xs)) bs)
+ (cons v vals) #f) ) ))))))))
+
+
+;;; Extension helper:
+
+(##sys#extend-macro-environment ; DEPRECATED
+ 'define-extension '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'define-extension form '(_ symbol . _))
+ (let ((%declare (r 'declare))
+ (%begin (r 'begin))
+ (%static (r 'static))
+ (%dynamic (r 'dynamic))
+ (%export (r 'export)))
+ (let loop ((s '()) (d '()) (cs (cddr form)) (exports #f))
+ (cond ((null? cs)
+ (let ((exps (if exports
+ `(,%declare (,%export ,@exports))
+ '(,%begin))))
+ `(,(r 'cond-expand)
+ (chicken-compile-shared ,exps ,@d)
+ ((,(r 'not) compiling) ,@d)
+ (,(r 'else)
+ (,%declare (unit ,name))
+ ,exps
+ (,(r 'provide) (,(r 'quote) ,name))
+ ,@s) ) ) )
+ ((and (pair? cs) (pair? (car cs)))
+ (let ((t (caar cs))
+ (next (cdr cs)) )
+ (cond ((c %static t)
+ (loop (cons `(,%begin ,@(cdar cs)) s) d next exports))
+ ((c %dynamic t)
+ (loop s (cons `(,%begin ,@(cdar cs)) d) next exports))
+ ((c %export t)
+ (loop s d next (append (or exports '()) (cdar cs))))
+ (else
+ (syntax-error 'define-extension "invalid clause specifier" (caar cs))) ) ) )
+ (else
+ (syntax-error
+ 'define-extension
+ "invalid clause syntax" cs)) ) ) ))))
+
+
+;;; SRFI-31
+
+(##sys#extend-macro-environment
+ 'rec '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'rec form '(_ _ . _))
+ (let ((head (cadr form))
+ (%letrec (r 'letrec)))
+ (if (pair? head)
+ `(,%letrec ((,(car head)
+ (,(r 'lambda) ,(cdr head)
+ ,@(cddr form))))
+ ,(car head))
+ `(,%letrec ((,head ,@(cddr form))) ,head))))))
+
+
+;;; Definitions available at macroexpansion-time:
+
+(##sys#extend-macro-environment
+ 'define-for-syntax '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'define-for-syntax form '(_ _ . _))
+ `(,(r 'begin-for-syntax)
+ (,(r 'define) ,@(cdr form))))))
+
+
+;;; use
+
+(##sys#extend-macro-environment
+ 'use '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'use x '(_ . #(_ 0)))
+ `(##core#require-extension ,(cdr x) #t))))
+
+
+;;; compiler syntax
+
+(##sys#extend-macro-environment
+ 'define-compiler-syntax '()
+ (##sys#er-transformer
+ (syntax-rules ()
+ ((_ (name . llist) body ...)
+ (define-compiler-syntax name (lambda llist body ...)))
+ ((_ name transformer)
+ (##core#define-compiler-syntax name transformer)))))
+
+(##sys#extend-macro-environment
+ 'let-compiler-syntax '()
+ (##sys#er-transformer
+ (syntax-rules ()
+ ((_ ((name transformer) ...) body ...)
+ (##core#let-compiler-syntax ((name transformer) ...) body ...)))))
+
+
+;;; Just in case someone forgets
+
+(##sys#extend-macro-environment
+ 'define-macro '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (syntax-error 'define-macro "`define-macro' is not supported - please use `define-syntax'"))))
+
+
+(##sys#macro-subset me0 ##sys#default-macro-environment)))
+
+;; register features
+
+(eval-when (compile load eval)
+ (register-feature! 'srfi-8 'srfi-16 'srfi-26 'srfi-31 'srfi-15 'srfi-11) )
diff --git a/chicken-thread-object-inlines.scm b/chicken-thread-object-inlines.scm
new file mode 100644
index 00000000..c4213ac6
--- /dev/null
+++ b/chicken-thread-object-inlines.scm
@@ -0,0 +1,297 @@
+;;;; chicken-thread-object-primitive-inlines.scm
+;;;; Kon Lovett, Jan '09
+
+; Usage
+;
+; (include "chicken-primitive-object-inlines")
+; (include "chicken-thread-object-inlines")
+
+;; Notes
+;
+; Provides inlines & macros for thread objects. Use of these procedures
+; by non-core & non-core-extensions is highly suspect. Many of these routines
+; are unsafe.
+;
+; In fact, any use is suspect ;-)
+
+
+;;; Mutex object helpers:
+
+;; Mutex layout:
+;
+; 0 Tag - 'mutex
+; 1 Name (object)
+; 2 Thread (thread or #f)
+; 3 Waiting threads (FIFO list)
+; 4 Abandoned? (boolean)
+; 5 Locked? (boolean)
+; 6 Specific (object)
+
+(define-inline (%mutex? x)
+ (%structure-instance? x 'mutex) )
+
+(define-inline (%mutex-name mx)
+ (%structure-ref mx 1) )
+
+(define-inline (%mutex-thread mx)
+ (%structure-ref mx 2) )
+
+(define-inline (%mutex-thread-set! mx th)
+ (%structure-set!/mutate mx 2 th) )
+
+(define-inline (%mutex-thread-clear! mx)
+ (%structure-set!/immediate mx 2 #f) )
+
+(define-inline (%mutex-waiters mx)
+ (%structure-ref mx 3) )
+
+(define-inline (%mutex-waiters-set! mx wt)
+ (%structure-set!/mutate mx 3 wt) )
+
+(define-inline (%mutex-waiters-empty? mx)
+ (%null? (%mutex-waiters mx)) )
+
+(define-inline (%mutex-waiters-empty! mx)
+ (%structure-set!/immediate mx 3 '()) )
+
+(define-inline (%mutex-waiters-add! mx th)
+ (%mutex-waiters-set! mx (%append! (%mutex-waiters mx) (%cons th '()))) )
+
+(define-inline (%mutex-waiters-delete! mx th)
+ (%mutex-waiters-set! mx (%delq! th (%mutex-waiters mx))) )
+
+(define-inline (%mutex-waiters-pop! mx)
+ (let* ([wt (%mutex-waiters mx)]
+ [top (%car wt)])
+ (%mutex-waiters-set! mx (%cdr wt))
+ top ) )
+
+(define-inline (%mutex-abandoned? mx)
+ (%structure-ref mx 4) )
+
+(define-inline (%mutex-abandoned-set! mx f)
+ (%structure-set!/immediate mx 4 f) )
+
+(define-inline (%mutex-locked? mx)
+ (%structure-ref mx 5) )
+
+(define-inline (%mutex-locked-set! mx f)
+ (%structure-set!/immediate mx 5 f) )
+
+(define-inline (%mutex-specific mx)
+ (%structure-ref mx 6) )
+
+(define-inline (%mutex-specific-set! mx x)
+ (%structure-set!/mutate mx 6 x) )
+
+
+;;; Thread object helpers:
+
+;; Thread layout:
+;
+; 0 Tag - 'thread
+; 1 Thunk (procedure)
+; 2 Results (list-of object)
+; 3 State (symbol)
+; 4 Block-timeout (fixnum or #f)
+; 5 State buffer (vector)
+; 0 Dynamic winds (list)
+; 1 Standard input (port)
+; 2 Standard output (port)
+; 3 Standard error (port)
+; 4 Exception handler (procedure)
+; 5 Parameters (vector)
+; 6 Name (object)
+; 7 Reason (condition of #f)
+; 8 Mutexes (list-of mutex)
+; 9 Quantum (fixnum)
+; 10 Specific (object)
+; 11 Block object (thread or (pair-of fd io-mode))
+; 12 Recipients (list-of thread)
+; 13 Unblocked by timeout? (boolean)
+
+(define-inline (%thread? x)
+ (%structure-instance? x 'thread) )
+
+(define-inline (%thread-thunk th)
+ (%structure-ref th 1) )
+
+(define-inline (%thread-thunk-set! th tk)
+ (%structure-set!/mutate th 1 tk) )
+
+(define-inline (%thread-results th)
+ (%structure-ref th 2) )
+
+(define-inline (%thread-results-set! th rs)
+ (%structure-set!/mutate th 2 rs) )
+
+(define-inline (%thread-state th)
+ (%structure-ref th 3) )
+
+(define-inline (%thread-state-set! th st)
+ (%structure-set!/mutate th 3 st) )
+
+(define-inline (%thread-block-timeout th)
+ (%structure-ref th 4) )
+
+(define-inline (%thread-block-timeout-set! th to)
+ (%structure-set!/immediate th 4 to) )
+
+(define-inline (%thread-block-timeout-clear! th)
+ (%thread-block-timeout-set! th #f) )
+
+(define-inline (%thread-state-buffer th)
+ (%structure-ref th 5) )
+
+(define-inline (%thread-state-buffer-set! th v)
+ (%structure-set!/mutate th 5 v) )
+
+(define-inline (%thread-name th)
+ (%structure-ref th 6) )
+
+(define-inline (%thread-reason th)
+ (%structure-ref th 7) )
+
+(define-inline (%thread-reason-set! th cd)
+ (%structure-set!/mutate th 7 cd) )
+
+(define-inline (%thread-mutexes th)
+ (%structure-ref th 8) )
+
+(define-inline (%thread-mutexes-set! th wt)
+ (%structure-set!/mutate th 8 wx) )
+
+(define-inline (%thread-mutexes-empty? th)
+ (%null? (%thread-mutexes th)) )
+
+(define-inline (%thread-mutexes-empty! th)
+ (%structure-set!/immediate th 8 '()) )
+
+(define-inline (%thread-mutexes-add! th mx)
+ (%thread-mutexes-set! th (%cons mx (%thread-mutexes th))) )
+
+(define-inline (%thread-mutexes-delete! th mx)
+ (%thread-mutexes-set! th (%delq! mx (%thread-mutexes th))) )
+
+(define-inline (%thread-quantum th)
+ (%structure-ref th 9) )
+
+(define-inline (%thread-quantum-set! th qt)
+ (%structure-set!/immediate th 9 qt) )
+
+(define-inline (%thread-specific th)
+ (%structure-ref th 10) )
+
+(define-inline (%thread-specific-set! th x)
+ (%structure-set!/mutate th 10 x) )
+
+(define-inline (%thread-block-object th)
+ (%structure-ref th 11) )
+
+(define-inline (%thread-block-object-set! th x)
+ (%structure-set!/mutate th 11 x) )
+
+(define-inline (%thread-block-object-clear! th)
+ (%structure-set!/immediate th 11 #f) )
+
+(define-inline (%thread-recipients th)
+ (%structure-ref th 12) )
+
+(define-inline (%thread-recipients-set! th x)
+ (%structure-set!/mutate th 12 x) )
+
+(define-inline (%thread-recipients-empty? th)
+ (%null? (%condition-variable-waiters th)) )
+
+(define-inline (%thread-recipients-empty! th)
+ (%structure-set!/immediate th 12 '()) )
+
+(define-inline (%thread-recipients-add! th rth)
+ (%thread-recipients-set! t (%cons rth (%thread-recipients t))) )
+
+(define-inline (%thread-recipients-process! th tk)
+ (let ([rs (%thread-recipients t)])
+ (unless (%null? rs) (for-each tk rs) ) )
+ (%thread-recipients-empty! t) )
+
+(define-inline (%thread-unblocked-by-timeout? th)
+ (%structure-ref th 13) )
+
+(define-inline (%thread-unblocked-by-timeout-set! th f)
+ (%structure-set!/immediate th 13 f) )
+
+(define-inline (%thread-blocked-for-timeout? th)
+ (and (%thread-block-timeout th)
+ (not (%thread-block-object th))) )
+
+(define-inline (%thread-blocked? th)
+ (%eq? 'blocked (%thread-state th)) )
+
+(define-inline (%thread-created? th)
+ (%eq? 'created (%thread-state th)) )
+
+(define-inline (%thread-ready? th)
+ (%eq? 'ready (%thread-state th)) )
+
+(define-inline (%thread-sleeping? th)
+ (%eq? 'sleeping (%thread-state th)) )
+
+(define-inline (%thread-suspended? th)
+ (%eq? 'suspended (%thread-state th)) )
+
+(define-inline (%thread-terminated? th)
+ (%eq? 'terminated (%thread-state th)) )
+
+(define-inline (%thread-dead? th)
+ (%eq? 'dead (%thread-state th)) )
+
+;; Synonyms
+
+(define-inline (%current-thread)
+ ##sys#current-thread )
+
+
+;;; Condition-variable object:
+
+;; Condition-variable layout:
+;
+; 0 Tag - 'condition-variable
+; 1 Name (object)
+; 2 Waiting threads (FIFO list)
+; 3 Specific (object)
+
+(define-inline (%condition-variable? x)
+ (%structure-instance? x 'condition-variable) )
+
+(define-inline (%condition-variable-name cv)
+ (%structure-ref cv 1) )
+
+(define-inline (%condition-variable-waiters cv)
+ (%structure-ref cv 2) )
+
+(define-inline (%condition-variable-waiters-set! cv x)
+ (%structure-set!/mutate cv 2 x) )
+
+(define-inline (%condition-variable-waiters-empty? cv)
+ (%null? (%condition-variable-waiters cv)) )
+
+(define-inline (%condition-variable-waiters-empty! cv)
+ (%structure-set!/immediate cv 2 '()) )
+
+(define-inline (%condition-variable-waiters-add! cv th)
+ (%condition-variable-waiters-set! cv (%append! (%condition-variable-waiters cv) (%cons th '()))) )
+
+(define-inline (%condition-variable-waiters-delete! cv th)
+ (%condition-variable-waiters-set! cv (%delq! th (%condition-variable-waiters cv))) )
+
+(define-inline (%condition-variable-waiters-pop! mx)
+ (let* ([wt (%condition-variable-waiters mx)]
+ [top (%car wt)])
+ (%condition-variable-waiters-set! mx (%cdr wt))
+ top ) )
+
+(define-inline (%condition-variable-specific cv)
+ (%structure-ref cv 3) )
+
+(define-inline (%condition-variable-specific-set! cv x)
+ (%structure-set!/mutate cv 3 x) )
diff --git a/chicken-uninstall.1 b/chicken-uninstall.1
new file mode 100644
index 00000000..da34bc61
--- /dev/null
+++ b/chicken-uninstall.1
@@ -0,0 +1,84 @@
+.\" dummy line
+.TH CHICKEN-UNINSTALL 1 "13 Aug 2008"
+
+.SH NAME
+
+chicken-uninstall \- uninstall extension library
+
+.SH SYNOPSIS
+
+chicken-uninstall [OPTION | PATTERN] ...
+
+.SH DESCRIPTION
+
+.I chicken\-uninstall
+removes one or more already installed extension libraries.
+.B PATTERN
+may be a regular expression naming multiple extensions or just
+an extension name.
+See the
+.B Chicken
+manual for more information.
+
+.SH OPTIONS
+
+.TP
+.B \-h,\ \-help
+Shows a summary of options and exits.
+
+.TP
+.B \-v,\ \-version
+Shows tool version and exits.
+
+.TP
+.B \-force
+Do not ask when multiple extensions match the given patterns, delete
+whatever matches.
+
+.TP
+.B \-s,\ \-sudo
+Perform any uninstallation steps that remove files by commands invoked
+with the sudo(1) tool.
+
+
+.SH ENVIRONMENT\ VARIABLES
+
+.TP
+.B CHICKEN_PREFIX
+The installation prefix where CHICKEN Scheme and its support files and
+libraries are located. Defaults to the installation time prefix given
+when configuring the system.
+
+.TP
+.B CHICKEN_INSTALL_PREFIX
+An alternative installation prefix that will be prepended to extension
+installation paths if specified.
+
+.TP
+.B CHICKEN_REPOSITORY
+The path where extension libraries are installed. Defaults to the package-library
+path selected during configuration (usually
+.B $prefix/lib/chicken/<binary\-version>
+)
+
+
+.SH DOCUMENTATION
+
+More information can be found in the
+.I Chicken\ User's\ Manual
+
+.SH BUGS
+Submit bug reports by e-mail to
+.I chicken-janitors@nongnu.org
+, preferrably using the
+.B chicken\-bug
+tool.
+
+.SH AUTHORS
+The Chicken Team
+
+.SH SEE ALSO
+.BR chicken-install(1)
+.BR chicken-status(1)
+.BR chicken(1)
+.BR chicken-bug(1)
diff --git a/chicken-uninstall.scm b/chicken-uninstall.scm
new file mode 100644
index 00000000..f56147c3
--- /dev/null
+++ b/chicken-uninstall.scm
@@ -0,0 +1,119 @@
+;;;; chicken-uninstall.scm
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(require-library
+ setup-api
+ srfi-1 posix data-structures utils ports regex srfi-13 files)
+
+
+(module main ()
+
+ (import scheme chicken)
+ (import setup-api)
+ (import srfi-1 posix data-structures utils ports regex srfi-13 files)
+
+ (define *force* #f)
+
+ (define (gather-eggs patterns)
+ (let ((eggs (map pathname-file
+ (glob (make-pathname (repository-path) "*" "setup-info")))))
+ (delete-duplicates
+ (concatenate (map (cut grep <> eggs) patterns))
+ string=?)))
+
+ (define (quit code)
+ (print "aborted.")
+ (exit code))
+
+ (define (ask eggs)
+ (handle-exceptions ex
+ (if (eq? ex 'aborted)
+ (quit 1)
+ (signal ex))
+ (yes-or-no?
+ (string-concatenate
+ (append
+ '("About to delete the following extensions:\n\n")
+ (map (cut string-append " " <> "\n") eggs)
+ '("\nDo you want to proceed?")))
+ default: "no")))
+
+ (define (uninstall pats)
+ (let ((eggs (gather-eggs pats)))
+ (cond ((null? eggs)
+ (print "nothing to remove.") )
+ ((or *force* (equal? eggs pats) (ask eggs))
+ (for-each
+ (lambda (e)
+ (print "removing " e)
+ (remove-extension e) )
+ eggs)))))
+
+ (define (usage code)
+ (print #<<EOF
+usage: chicken-uninstall [OPTION | PATTERN] ...
+
+ -h -help show this message and exit
+ -v -version show version and exit
+ -force don't ask, delete whatever matches
+ -s -sudo use sudo(1) for deleting files
+EOF
+);|
+ (exit code))
+
+ (define *short-options* '(#\h #\s))
+
+ (define (main args)
+ (let loop ((args args) (pats '()))
+ (if (null? args)
+ (uninstall (if (null? pats) (usage 1) (reverse pats)))
+ (let ((arg (car args)))
+ (cond ((or (string=? arg "-help")
+ (string=? arg "-h")
+ (string=? arg "--help"))
+ (usage 0))
+ ((or (string=? arg "-v") (string=? arg "-version"))
+ (print (chicken-version))
+ (exit 0))
+ ((string=? arg "-force")
+ (set! *force* #t)
+ (loop (cdr args) pats))
+ ((or (string=? arg "-s") (string=? arg "-sudo"))
+ (sudo-install #t)
+ (loop (cdr args) pats))
+ ((and (positive? (string-length arg))
+ (char=? #\- (string-ref arg 0)))
+ (if (> (string-length arg) 2)
+ (let ((sos (string->list (substring arg 1))))
+ (if (null? (lset-intersection eq? *short-options* sos))
+ (loop (append (map (cut string #\- <>) sos) (cdr args)) pats)
+ (usage 1)))
+ (usage 1)))
+ (else (loop (cdr args) (cons arg pats))))))))
+
+ (main (command-line-arguments))
+
+ )
diff --git a/chicken.1 b/chicken.1
new file mode 100644
index 00000000..dcaa84c5
--- /dev/null
+++ b/chicken.1
@@ -0,0 +1,613 @@
+.\" dummy line
+.TH CHICKEN 1 "10 Sep 2002"
+
+.SH NAME
+
+chicken \- A Scheme\-to\-C compiler
+
+.SH SYNOPSIS
+
+.B chicken
+.I pathname
+[
+.I option ...
+]
+
+.SH DESCRIPTION
+
+.I Chicken
+is a compiler for the programming language
+.I Scheme
+supporting most of the features as described in the
+.I Revised^5 Report on
+.I the Algorithmic Language Scheme
+\.
+
+.SH OPTIONS
+
+.TP
+.B \-analyze\-only
+Stop compilation after first analysis pass.
+
+.B \-benchmark\-mode
+Equivalent to
+.B \-optimize\-level\ 3\ \-fixnum\-arithmetic\ \-disable\-interrupts\ \-lambda\-lift
+.B \-block\ \-no\-lambda\-info
+
+.TP
+.B \-block
+Enable block-compilation. When this option is specified, the compiler assumes
+that global variables are not modified outside this compilation-unit.
+
+.TP
+.B \-case\-insensitive
+Enables the reader to read symbols case-insensitive. The default is to read
+case-sensitive (in violation of R5RS).
+This option registers the
+.B case\-insensitive
+feature identifier.
+
+.TP
+.B \-check\-imports
+Search for references to undefined global variables.
+
+.TP
+.B \-check\-syntax
+Aborts compilation process after macro-expansion and syntax checks.
+
+.TP
+.BI \-database\-size \ number
+Specifies the initial size of the analysis-database. Should only be used if
+extremely large files are to be compiled.
+
+.TP
+.BI \-debug \ modes
+Enables one or more debugging modes. See the User's Manual for more information.
+
+.TP
+.BI \-debug\-level \ level
+Selects amount of debug-information.
+.I level
+should be an integer.
+.P
+.br
+.B \ \ \ \ 0
+-no-trace -no-lambda-info
+.br
+.B \ \ \ \ 1
+-no-trace
+.br
+.B \ \ \ \ 2
+nothing.
+
+.TP
+.B \-disable\-c\-syntax\-checks
+Disable basic syntax checking of embedded C code fragments.
+
+.TP
+.B \-disable\-compiler\-macros
+Disable expansion of compiler macros.
+
+.TP
+.B \-disable\-interrupts
+Equivalent to
+.B \-prelude\ \'(declare\ (interrupts-disabled))\'
+\.
+
+.TP
+.B \-disable\-stack\-overflow\-checks
+Disables detection of stack-overflows.
+
+.TP
+.BI \-disable\-warning \ class
+Disables specific
+.I class
+of warnings, may be given multiple times.
+.P
+.br
+.B \ \ \ \ ext\ \ \
+Suspect extension use.
+.br
+.B \ \ \ \ type\ \
+Suspect type/literal use.
+.br
+.B \ \ \ \ usage\
+Suspect feature use.
+.br
+.B \ \ \ \ style\
+Suspect feature use.
+.br
+.B \ \ \ \ syntax
+Suspect sytax form.
+.br
+.B \ \ \ \ redef\
+Redefinition of builtin binding.
+.br
+.B \ \ \ \ var\ \ \
+Suspect variable use.
+
+.TP
+.B \-dynamic
+This option should be used when compiling files intended to be loaded dynamically into
+a running Scheme program.
+
+.TP
+.BI \-epilogue \ filename
+Includes the file named
+.I filename
+at the end of the compiled source file.
+The include-path is not searched. This option may be given multiple times.
+
+.TP
+.B \-emit\-debug\-info
+Emit additional information for each
+.B lambda
+expression (currently the argument-list,
+after alpha-conversion/renaming).
+
+.TP
+.BI \-emit\-exports \ filename
+Write exported toplevel variables to file
+.I filename
+\.
+
+.TP
+.B \-emit\-external\-prototypes\-first
+Emit prototypes for callbacks defined with
+.B define\-external
+before any
+other foreign declarations. This is sometimes useful, when C/C++ code embedded into
+the a Scheme program has to access the callbacks. By default the prototypes are emitted
+after foreign declarations.
+
+.TP
+.BI \-emit\-inline\-file \ filename
+Write procedures that can be globally inlined in internal form to
+.I filename
+, if global inlining is enabled. Implies "-inline -local".
+
+.TP
+.B \-explicit\-use
+Disables automatic use of the units
+.I library
+and
+.I eval
+\. Use this option if compiling a library unit
+instead of an application unit.
+
+.TP
+.BI \-extend \ filename
+Loads a Scheme file,
+.I filename
+, before compilation commences. This feature can be used to extend the compiler.
+
+.TP
+.B \-extension
+Mostly equivalent to
+.B \-prelude\ \'(define-extension\ NAME)\'
+where
+.B NAME
+is the basename of the currently compiled file. Note that if you want to compile a file
+as a normal (dynamically loadable) extension library, you should also pass the
+.B \-shared
+option.
+
+.TP
+.BI \-feature \ symbol
+Registers
+.I symbol
+to be a valid feature identifier for
+.B cond\-expand
+
+.TP
+.B \-fixnum\-arithmetic
+Equivalent to
+.B \-prelude\ \'(declare\ (fixnum))\'
+\.
+
+.TP
+.BI \-heap\-size \ number
+Sets the static heap-size of the generated executable to
+.I number
+bytes. The parameter may be
+followed by a
+.B M
+or
+.B K
+suffix which stand for mega- and kilo-bytes, respectively. The default heap-size is 16 megabytes.
+
+.TP
+.BI \-heap\-initial\-size \ number
+Sets the size that the heap of the compiled application should have at startup time.
+
+.TP
+.BI \-heap\-growth \ percentage
+Sets the heap-growth rate for the compiled program at compile time.
+
+.TP
+.BI \-heap\-shrinkage \ percentage
+Sets the heap-shrinkage rate for the compiled program at compile time.
+
+.TP
+.B \-help
+Print a summary of available options and the format of the command-line
+parameters and exit the compiler.
+
+.TP
+.B \-ignore\-repository
+Do not load any extensions from the repository (treat repository as empty). Also
+do not consult compiled (only interpreted) import libraries in
+.I import
+forms.
+
+.TP
+.BI \-import\ pathname
+Read exports from linked or loaded libraries from given file. Implies
+.B \-check\-imports
+
+.TP
+.BI \-include\-path \ pathname
+Specifies an additional search path for files included via the
+.I include
+special form. This option may be given multiple times.
+
+.TP
+.B \-inline
+Enables procedure inlining.
+
+.TP
+.B \-inline\-global
+Enable cross-module inlining.
+
+.TP
+.BI \-inline\-limit \ threshold
+Sets the maximum size of potentially inlinable procedures.
+
+.TP
+.BI \-keep\-shadowed\-macros
+Do not remove macro definitions with the same name as assigned toplevel
+variables (the default is to remove the macro definition).
+
+.TP
+.BI \-keyword\-style \ style
+Enables alternative keyword syntax, where style may be either
+.B prefix
+(as in Common Lisp),
+.B suffix
+(as in DSSSL) or
+.B none
+Any other value is ignored. The default is
+.B suffix
+\.
+
+.TP
+.B \-lambda\-lift
+Enable the optimization known as lambda-lifting.
+
+.TP
+.B \-local
+Assume toplevel variables defined in the current compilation unit are
+not externally modified.
+
+.TP
+.B \-no\-trace
+Disable generation of tracing information. If a compiled executable should halt
+due to a runtime error, then a file containing a stack-trace will be written to
+the current directory under the name
+.I STACKTRACE
+\. Each line in the created file gives the name and the line-number (if
+available) of a procedure call. With this option given, the generated code is
+slightly faster.
+
+.TP
+.B \-no\-warnings
+Disable generation of compiler warnings.
+
+.TP
+.BI \-nursery \ number
+
+.TP
+.BI \-stack\-size \ number
+Sets the size of the first heap-generation of the generated executable to
+.I number
+bytes. The parameter may
+be followed by a
+.B M
+or
+.B K
+suffix. The default stack-size depends on the target platform.
+
+.TP
+.BI \-optimize\-leaf\-routines
+Enable leaf routine optimization.
+
+.TP
+.BI \-optimize\-level \ level
+Enables certain sets of optimization options.
+.I level
+should be an integer. Each optimization level corresponds to a certain set of optimization option
+as shown in the following list:
+.P
+.br
+.B \ \ \ \ 0
+nothing
+.br
+.B \ \ \ \ 1
+-optimize-leaf-routines
+.br
+.B \ \ \ \ 2
+-optimize-leaf-routines -usual-integrations
+.br
+.B \ \ \ \ 3
+-optimize-leaf-routines -usual-integrations -unsafe
+
+.TP
+.BI \-output\-file \ filename
+Specifies the pathname of the generated C file. Default is
+.I FILENAME.c
+\.
+
+.TP
+.BI \-postlude \ expressions
+Add
+.I expressions
+after all other toplevel expressions in the compiled file.
+This option may be given multiple times. Processing of this option takes place
+after processing of
+.BI \-epilogue
+\.
+
+.TP
+.BI \-prelude \ expressions
+Add
+.I expressions
+before all other toplevel expressions in the compiled file.
+This option may be given multiple times. Processing of this option takes place
+before processing of
+.B \-prologue
+\.
+
+.TP
+.B \-profile
+.B \-accumulate\-profile
+Instruments the source code to count procedure calls and execution times. After
+the program terminates (either via an explicit
+.B exit
+or implicitly), profiling statistics are written to a file named
+.B PROFILE.<PID>
+where <PID> is the process ID of the program being profiled.
+Each line of the generated file contains a list with the procedure name,
+the number of calls and the time spent executing it. Use the
+.B chicken\-profile
+program to display the profiling information in a more user-friendly form.
+
+.TP
+.BI \-profile\-name \ filename
+Specifies the name of the generated profile information file. Only useful
+in combination with the
+.B \-profile
+or
+.B \-accumulate-profile
+options.
+
+.TP
+.BI \-prologue \ filename
+Includes the file named
+.I filename
+at the start of the compiled source file.
+The include-path is not searched. This option may be given multiple times.
+
+.TP
+.B \-release
+Print release number and exit.
+
+.TP
+.BI \-require\-extension \ name
+Loads the syntax-extension
+.I name
+before the source program is processed. This is identical to adding
+.B require\-extension\ NAME
+at the start of
+the compiled program.
+
+.TP
+.B \-run\-time\-macros
+Makes low-level macros (defined with
+.B define\-macro
+also available at run-time. By default
+low-level macros are not available at run-time. Note that highlevel-macros ("syntax-case")
+defined in compiled code are never available at run-time.
+
+.TP
+.B \-to\-stdout
+Write compiled code to standard output instead of creating a
+.I .c
+file.
+
+.TP
+.BI \-unit \ name
+Compile this file as a library unit.
+
+.TP
+.B \-unsafe
+Disable runtime safety checks.
+
+.TP
+.B \-unsafe\-libraries
+Marks the generated file for being linked with the unsafe runtime system. This
+should be used when generating shared object files that are to be loaded
+dynamically. If the marker is present, any attempt to load code compiled with
+this option will signal an error.
+
+.TP
+.BI \-uses \ name
+Use definitions in the given library unit.
+
+.TP
+.B \-usual\-integrations
+Specifies that standard procedures and certain internal procedures are never redefined, and can
+be inlined. This is equivalent to declaring
+.I (usual\-integrations)
+\.
+
+.TP
+.B \-verbose
+Prints progress information to standard output during compilation.
+
+.TP
+.B \-version
+Prints the version and some copyright information and exit the compiler.
+
+.SH ENVIRONMENT\ VARIABLES
+
+.TP
+.B CHICKEN_PREFIX
+Is used as a prefix directory for support files, include-files and libraries.
+
+.TP
+.B CHICKEN_INCLUDE_PATH
+Contains one or more pathnames where the compiler should additionally look for
+include-files, separated by
+.B \;
+characters.
+
+.TP
+.B CHICKEN_OPTIONS
+Holds a string of default compiler options that should apply to every invocation of
+.B chicken
+\.
+
+.SH RUNTIME\ OPTIONS
+After successful compilation a C source file is generated and can be compiled
+with a C compiler. Executables generated with
+.B chicken
+(and the
+.B chicken
+program itself) accept a small set of runtime options.
+
+.TP
+.B \-:?
+Shows a list of the available runtime options and exits the program.
+
+.TP
+.B \-:aNUMBER
+Specifies the length of the buffer for recording a trace of the last invoked
+procedures. Defaults to 8.
+
+.TP
+.B \-:b
+Enter a read-eval-print-loop when an error is encountered.
+
+.TP
+.B \-:B
+Sounds a bell (ASCII 7) on every major garbage collection.
+
+.TP
+.B \-:c
+Forces console mode. Currently this is only used in the interpreter (csi) to
+force output of the
+.I #;N>
+prompt even if stdin is not a terminal (for example if running in an emacs buffer under Windows).
+
+.TP
+.B \-:d
+Prints some debug-information at runtime.
+
+.TP
+.B \-:D
+Prints some more debug-information at runtime.
+
+.TP
+.B \-:fNUMBER
+Specifies the maximal number of currently pending finalizers before finalization is forced.
+
+.TP
+.B \-:hNUMBER
+Specifies fixed heap size
+
+.TP
+.B \-:hgPERCENTAGE
+Sets the growth rate of the heap in percent. If the heap is exhausted, then it
+will grow by
+.B PERCENTAGE
+\. The default is 200.
+
+.TP
+.B \-:hiNUMBER
+Specifies the initial heap size
+
+.TP
+.B \-:hmNUMBER
+Specifies a maximal heap size. The default is (2GB - 15).
+
+.TP
+.B \-:hsPERCENTAGE
+Sets the shrink rate of the heap in percent. If no more than a quarter of
+.B PERCENTAGE
+of the heap is used, then it will shrink to
+.B PERCENTAGE
+\. The default
+is 50. Note: If you want to make sure that the heap never shrinks, specify a
+value of 0. (this can be useful in situations where an optimal heap-size is
+known in advance).
+
+.TP
+.B \-:o
+Disables detection of stack overflows at run-time.
+
+.TP
+.B \-:r
+Writes trace output to stderr. This option has no effect with in files compiled with the
+.B -no-trace
+options.
+
+.TP
+.B \-:sNUMBER
+Specifies stack size.
+
+.TP
+.B \-:tNUMBER
+Specifies symbol table size.
+
+.TP
+.B \-:w
+Enables garbage collection of unused symbols. By default unused and unbound
+symbols are not garbage collected.
+
+.TP
+.B \-:x
+Raises uncaught exceptions of separately spawned threads in primordial thread.
+By default uncaught exceptions in separate threads are not handled, unless the
+primordial one explicitly joins them. When warnings are enabled (the default)
+and
+.B \-:x
+is not given, a warning will be shown, though.
+
+.P
+The
+.B NUMBER
+argument values may be given in bytes, in kilobytes (suffixed with K or k),
+in megabytes (suffixed with M or m), or in gigabytes (suffixed with G or g).
+Runtime options may be combined, like
+.B \-:dc
+, but everything following a
+.B NUMBER
+argument is ignored. So
+.B \-:wh64m
+is OK, but
+.B \-:h64mw
+will not enable GC of unused symbols.
+
+.SH DOCUMENTATION
+
+More information can be found in the
+.I Chicken\ User's\ Manual
+
+.SH AUTHORS
+
+Felix L. Winkelmann and The Chicken Team.
+
+.SH SEE ALSO
+
+.BR csc(1)
+.BR chicken-bug(1)
diff --git a/chicken.css b/chicken.css
new file mode 100644
index 00000000..51018c46
--- /dev/null
+++ b/chicken.css
@@ -0,0 +1,57 @@
+h1, h2, h3, h4, h5, h6 { font-family: sans-serif; }
+.node P {
+ background: #2965AB;
+ color: white;
+ margin: 0; padding: 0.5em 0.5em 0.5em;
+ border-bottom: outset 3px #4985CB;
+ border-right: outset 3px #4985CB;
+ font-family: sans-serif;
+ font-weight: bold;
+ font-size: 10pt;
+}
+.node A {
+ font-weight: normal;
+ text-decoration: none;
+ color: white;
+}
+.node A[name] {
+ font-weight: bold;
+ color: black;
+}
+.node A[href] {
+ color: #c0c0c0;
+ border-bottom-style: dotted;
+}
+.node A[href]:hover {
+ border-bottom-color: darkred;
+}
+A[href] {
+ border-bottom: 1px solid black;
+}
+PRE
+{
+ background: #efeee0;
+ color: black;
+ padding: 0.1em;
+ border: 1px solid #bbbaaf;
+ /* border-bottom: outset 3px #bbbaaf; */
+ /* border-right: outset 3px #bbbaaf; */
+}
+PRE.lisp
+{
+ border: none;
+ background: #f5f5f5;
+}
+.node HR, .node BR {
+ display: none;
+}
+A[href]:hover {
+ border-bottom: 1px solid red;
+}
+A {
+ color: #3e42d9;
+ text-decoration: none;
+}
+UL A[href] {
+ border-bottom: none;
+}
diff --git a/chicken.h b/chicken.h
new file mode 100644
index 00000000..11b6a2c3
--- /dev/null
+++ b/chicken.h
@@ -0,0 +1,1710 @@
+/* chicken.h - General headerfile for compiler generated executables
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+*/
+
+/* Configuration: */
+
+/*
+ * The Watcom (__WATCOMC__), Metroworks (__MWERKS__), and Delorie (__DJGPP__)
+ * compilers are not currently supported but existing references remain,
+ * just in case.
+ */
+
+#ifndef ___CHICKEN
+#define ___CHICKEN
+
+#define C_MAJOR_VERSION 4
+
+/*
+ * N.B. This file MUST not rely upon "chicken-config.h"
+ */
+#if defined(HAVE_CONFIG_H) || defined(HAVE_CHICKEN_CONFIG_H)
+# include "chicken-config.h"
+#endif
+
+
+/* Kind of platform */
+
+#ifndef C_SIXTY_FOUR
+# if defined (__alpha__) || defined(__ia64__) || defined(__x86_64__) || defined(__LP64__) || defined(__powerpc64__)
+# define C_SIXTY_FOUR
+# elif (defined(__sparc_v9__) || defined(__sparcv9)) && defined(__arch64__)
+# define C_SIXTY_FOUR
+# elif defined(__mips64) && (!defined(__GNUC__) || _MIPS_SZPTR == 64)
+# define C_SIXTY_FOUR
+# endif
+#endif
+
+#if defined(__APPLE__) && defined(__MACH__)
+# define C_MACOSX
+#endif
+
+#if defined(C_MACOSX) || defined(__FreeBSD__) || defined(__NetBSD__) || defined(__DragonFly__) || defined(__OpenBSD__)
+# define C_XXXBSD
+#endif
+
+#if /*defined(__GNUC__) &&*/ (defined(__linux__) || defined(C_XXXBSD))
+# define C_GNU_ENV
+#endif
+
+#if defined(_MSC_VER) || defined(__MINGW32__) || defined(__WATCOMC__) || defined(__MWERKS__) || defined(__DJGPP__)
+# define C_NONUNIX
+#endif
+
+
+/* Headers */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdarg.h>
+#include <ctype.h>
+#include <string.h>
+#include <setjmp.h>
+#include <limits.h>
+#include <time.h>
+
+#if !defined(C_NONUNIX) || defined(__MINGW32__) || defined(__WATCOMC__)
+# include <unistd.h>
+# include <inttypes.h>
+# include <sys/types.h>
+#endif
+
+/* Byteorder in machine word */
+
+#if defined(__MINGW32__)
+# include <sys/param.h>
+#elif defined(__CYGWIN__)
+# include <endian.h>
+#elif defined(__linux__)
+# include <endian.h>
+#elif defined(C_XXXBSD)
+# include <machine/endian.h>
+#elif defined(__hpux__)
+# include <arpa/nameser.h>
+#elif defined(_AIX)
+# include <sys/machine.h>
+#elif defined(__sun__)
+# include <sys/isa_defs.h>
+#elif defined(__svr4__)
+# include <sys/byteorder.h>
+#endif
+
+#if defined(_MSC_VER) || defined(__MINGW32__) || defined(__WATCOMC__)
+# include <malloc.h>
+#endif
+
+#ifdef _MSC_VER
+# include <io.h>
+#endif
+
+/* Much better with stack allocation API */
+
+#if defined(_MSC_VER)
+# if HAVE_ALLOCA_H
+# define alloca _alloca
+# endif
+#elif !defined(__GNUC__) && !defined(__WATCOMC__)
+# if HAVE_ALLOCA_H
+# include <alloca.h>
+# elif defined(_AIX)
+# pragma alloca
+# elif !defined(alloca) /* predefined by HP cc +Olibcalls */
+ char *alloca ();
+# endif
+#elif (defined(__sun__) && defined(__svr4__)) || defined(__sgi__)
+# if HAVE_ALLOCA_H
+# include <alloca.h>
+# endif
+#endif
+
+
+/* Chicken Core C API */
+
+#if defined(__BYTE_ORDER) && __BYTE_ORDER == __BIG_ENDIAN
+# define C_BIG_ENDIAN
+#elif defined(BYTE_ORDER) && defined(BIG_ENDIAN) && BYTE_ORDER == BIG_ENDIAN
+# define C_BIG_ENDIAN
+#elif defined(__BIG_ENDIAN__)
+# define C_BIG_ENDIAN
+#elif defined(__sparc__) || defined(__POWERPC__) || defined(__MC68K__) || defined(__mips__)
+# define C_BIG_ENDIAN
+#endif
+
+#if defined(__BYTE_ORDER) && defined(__LITTLE_ENDIAN) && __BYTE_ORDER == __LITTLE_ENDIAN
+# define C_LITTLE_ENDIAN
+#elif defined(BYTE_ORDER) && defined(LITTLE_ENDIAN) && BYTE_ORDER == LITTLE_ENDIAN
+# define C_LITTLE_ENDIAN
+#elif defined(__LITTLE_ENDIAN__)
+# define C_LITTLE_ENDIAN
+#elif defined (__alpha__) || defined(_M_IX86) || defined(__i386__) || defined(__x86_64__) || defined(__ia64__)
+# define C_LITTLE_ENDIAN
+#endif
+
+/* Make sure some common C identifiers are availble w/ Windows */
+
+#ifdef _MSC_VER
+# define strncasecmp strnicmp
+# define isatty _isatty
+typedef __int8 int8_t;
+typedef unsigned __int8 uint8_t;
+typedef __int16 int16_t;
+typedef unsigned __int16 uint16_t;
+typedef __int32 int32_t;
+typedef unsigned __int32 uint32_t;
+typedef __int64 int64_t;
+typedef unsigned __int64 uint64_t;
+# pragma warning(disable: 4101)
+#endif
+
+/* Could be used by C++ source */
+
+#ifdef __cplusplus
+# define C_extern extern "C"
+# define C_BEGIN_C_DECLS extern "C" {
+# define C_END_C_DECLS }
+#else
+# define C_extern extern
+# define C_BEGIN_C_DECLS
+# define C_END_C_DECLS
+#endif
+
+
+/* Function declaration modes */
+
+/* Visibility */
+#define C_varextern C_extern
+#define C_fctimport
+#define C_fctexport
+#define C_externimport C_extern
+#define C_externexport C_extern
+#if defined(PIC)
+# if defined(__CYGWIN__) || defined(__MINGW32__)
+# ifndef C_BUILDING_LIBCHICKEN
+# undef C_varextern
+# define C_varextern C_extern __declspec(dllimport)
+# endif
+# elif defined(_MSC_VER)
+# undef C_fctimport
+# define C_fctimport __declspec(dllexport)
+# undef C_externimport
+# undef C_externexport
+# define C_externexport C_extern __declspec(dllexport)
+# undef C_varextern
+# undef C_fctexport
+# ifdef C_BUILDING_LIBCHICKEN
+# define C_varextern C_extern __declspec(dllexport)
+# define C_fctexport __declspec(dllexport)
+# define C_externimport C_extern __declspec(dllexport)
+# else
+# define C_varextern C_extern __declspec(dllimport)
+# define C_fctexport __declspec(dllimport)
+# define C_externimport C_extern __declspec(dllimport)
+# endif
+# elif defined(__WATCOMC__)
+# undef C_fctimport
+# define C_fctimport __declspec(dllexport)
+# undef C_externimport
+# undef C_externexport
+# define C_externexport C_extern __declspec(dllexport)
+# undef C_varextern
+# undef C_fctexport
+# ifdef C_BUILDING_LIBCHICKEN
+# define C_varextern C_extern __declspec(dllexport)
+# define C_fctexport __declspec(dllexport)
+# define C_externimport C_extern __declspec(dllexport)
+# else
+# define C_varextern C_extern __declspec(dllimport)
+# define C_fctexport __declspec(dllimport)
+# define C_externimport C_extern __declspec(dllimport)
+# endif
+# endif
+#endif
+
+/* Language specifics: */
+#if defined(__GNUC__) || defined(__INTEL_COMPILER)
+# ifndef __cplusplus
+# define C_cblock ({
+# define C_cblockend })
+# define C_noret __attribute__ ((noreturn))
+# define C_noret_decl(name)
+# define C_aligned __attribute__ ((aligned))
+# endif
+# ifdef __i386__
+# define C_regparm __attribute__ ((regparm(3)))
+# endif
+#elif defined(_MSC_VER)
+# define C_fcall __fastcall
+#elif defined(__WATCOMC__)
+# define C_ccall __cdecl
+#endif
+
+#ifndef C_cblock
+# define C_cblock do{
+# define C_cblockend }while(0)
+# define C_noret
+# define C_noret_decl(name)
+#endif
+
+#ifndef C_regparm
+# define C_regparm
+#endif
+
+#ifndef C_fcall
+# define C_fcall
+#endif
+
+#ifndef C_ccall
+# define C_ccall
+#endif
+
+#ifndef C_aligned
+# define C_aligned
+#endif
+
+#define C_c_regparm
+
+/* Thread Local Stoarage */
+#ifdef C_ENABLE_TLS
+# if defined(__GNUC__)
+# define C_TLS __thread
+# elif defined(_MSC_VER)
+# define C_TLS __declspec(thread)
+# endif
+#endif
+
+#ifndef C_TLS
+# define C_TLS
+#endif
+
+
+/* Stack growth direction; used to compute stack addresses */
+
+#ifndef C_STACK_GROWS_DOWNWARD
+# define C_STACK_GROWS_DOWNWARD -1
+#endif
+
+#if C_STACK_GROWS_DOWNWARD == -1
+# ifdef __hppa__
+# undef C_STACK_GROWS_DOWNWARD
+# define C_STACK_GROWS_DOWNWARD 0
+# else
+# undef C_STACK_GROWS_DOWNWARD
+# define C_STACK_GROWS_DOWNWARD 1
+# endif
+#endif
+
+/* Have a GUI? */
+
+#if defined(C_WINDOWS_GUI)
+# define C_MICROSOFT_WINDOWS
+# include <windows.h>
+# ifndef WINAPI
+# define WINAPI
+# endif
+#else
+# define C_GENERIC_CONSOLE
+#endif
+
+/* Needed for pre-emptive threading */
+
+#define C_TIMER_INTERRUPTS
+
+/* For the easy FFI: */
+
+#define ___fixnum int
+#define ___number double
+#define ___bool int
+#define ___byte char
+#define ___scheme_value C_word
+#define ___scheme_pointer void *
+#define ___byte_vector unsigned char *
+#define ___symbol char *
+#define ___safe
+#define ___declare(x, y)
+#define ___specialize
+#define ___abstract
+#define ___discard
+#define ___in
+#define ___out
+#define ___inout
+#define ___mutable
+#define ___length(var)
+#define ___pointer
+#define ___u32 C_u32
+#define ___s32 C_s32
+#define ___u64 C_u64
+#define ___s64 C_s64
+
+
+/* Constants: */
+
+#define C_STACK_RESERVE 4096
+#define C_DEFAULT_MAX_PENDING_FINALIZERS 2048
+
+#define C_IMMEDIATE_MARK_BITS 0x00000003
+#define C_IMMEDIATE_TYPE_BITS 0x0000000f
+
+#define C_BOOLEAN_BITS 0x00000006
+#define C_CHARACTER_BITS 0x0000000a
+#define C_SPECIAL_BITS 0x0000000e
+
+#define C_SCHEME_FALSE ((C_word)(C_BOOLEAN_BITS | 0x00000000))
+#define C_SCHEME_TRUE ((C_word)(C_BOOLEAN_BITS | 0x00000010))
+
+#define C_SCHEME_END_OF_LIST ((C_word)(C_SPECIAL_BITS | 0x00000000))
+#define C_SCHEME_UNDEFINED ((C_word)(C_SPECIAL_BITS | 0x00000010))
+#define C_SCHEME_UNBOUND ((C_word)(C_SPECIAL_BITS | 0x00000020))
+#define C_SCHEME_END_OF_FILE ((C_word)(C_SPECIAL_BITS | 0x00000030))
+
+#define C_FIXNUM_BIT 0x00000001
+#define C_FIXNUM_SHIFT 1
+
+/* Character range is that of a UTF-8 codepoint, not representable range */
+#define C_CHAR_BIT_MASK 0x1fffff
+#define C_CHAR_SHIFT 8
+
+#ifdef C_SIXTY_FOUR
+# define C_MOST_POSITIVE_FIXNUM 0x3fffffffffffffffL
+# define C_WORD_SIZE 64
+#else
+# define C_MOST_POSITIVE_FIXNUM 0x3fffffff
+# define C_WORD_SIZE 32
+#endif
+
+#define C_MOST_NEGATIVE_FIXNUM (-C_MOST_POSITIVE_FIXNUM - 1)
+
+#ifdef C_SIXTY_FOUR
+# define C_INT_SIGN_BIT 0x8000000000000000L
+# define C_INT_TOP_BIT 0x4000000000000000L
+# define C_HEADER_BITS_MASK 0xff00000000000000L
+# define C_HEADER_TYPE_BITS 0x0f00000000000000L
+# define C_HEADER_SIZE_MASK 0x00ffffffffffffffL
+# define C_GC_FORWARDING_BIT 0x8000000000000000L /* header contains forwarding pointer */
+# define C_BYTEBLOCK_BIT 0x4000000000000000L /* block contains bytes instead of slots */
+# define C_SPECIALBLOCK_BIT 0x2000000000000000L /* 1st item is a non-value */
+# define C_8ALIGN_BIT 0x1000000000000000L /* data is aligned to 8-byte boundary */
+
+# define C_SYMBOL_TYPE (0x0100000000000000L)
+# define C_STRING_TYPE (0x0200000000000000L | C_BYTEBLOCK_BIT)
+# define C_PAIR_TYPE (0x0300000000000000L)
+# define C_CLOSURE_TYPE (0x0400000000000000L | C_SPECIALBLOCK_BIT)
+# define C_FLONUM_TYPE (0x0500000000000000L | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
+/* unused (0x0600000000000000L ...) */
+# define C_PORT_TYPE (0x0700000000000000L | C_SPECIALBLOCK_BIT)
+# define C_STRUCTURE_TYPE (0x0800000000000000L)
+# define C_POINTER_TYPE (0x0900000000000000L | C_SPECIALBLOCK_BIT)
+# define C_LOCATIVE_TYPE (0x0a00000000000000L | C_SPECIALBLOCK_BIT)
+# define C_TAGGED_POINTER_TYPE (0x0b00000000000000L | C_SPECIALBLOCK_BIT)
+# define C_SWIG_POINTER_TYPE (0x0c00000000000000L | C_SPECIALBLOCK_BIT)
+# define C_LAMBDA_INFO_TYPE (0x0d00000000000000L | C_BYTEBLOCK_BIT)
+/* unused (0x0e00000000000000L ...) */
+# define C_BUCKET_TYPE (0x0f00000000000000L)
+#else
+# define C_INT_SIGN_BIT 0x80000000
+# define C_INT_TOP_BIT 0x40000000
+# define C_HEADER_BITS_MASK 0xff000000
+# define C_HEADER_TYPE_BITS 0x0f000000
+# define C_HEADER_SIZE_MASK 0x00ffffff
+# define C_GC_FORWARDING_BIT 0x80000000
+# define C_BYTEBLOCK_BIT 0x40000000
+# define C_SPECIALBLOCK_BIT 0x20000000
+# define C_8ALIGN_BIT 0x10000000
+
+# define C_SYMBOL_TYPE (0x01000000)
+# define C_STRING_TYPE (0x02000000 | C_BYTEBLOCK_BIT)
+# define C_PAIR_TYPE (0x03000000)
+# define C_CLOSURE_TYPE (0x04000000 | C_SPECIALBLOCK_BIT)
+# ifdef C_DOUBLE_IS_32_BITS
+# define C_FLONUM_TYPE (0x05000000 | C_BYTEBLOCK_BIT)
+# else
+# define C_FLONUM_TYPE (0x05000000 | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
+# endif
+/* unused (0x06000000 ...) */
+# define C_PORT_TYPE (0x07000000 | C_SPECIALBLOCK_BIT)
+# define C_STRUCTURE_TYPE (0x08000000)
+# define C_POINTER_TYPE (0x09000000 | C_SPECIALBLOCK_BIT)
+# define C_LOCATIVE_TYPE (0x0a000000 | C_SPECIALBLOCK_BIT)
+# define C_TAGGED_POINTER_TYPE (0x0b000000 | C_SPECIALBLOCK_BIT)
+# define C_SWIG_POINTER_TYPE (0x0c000000 | C_SPECIALBLOCK_BIT)
+# define C_LAMBDA_INFO_TYPE (0x0d000000 | C_BYTEBLOCK_BIT)
+/* unused (0x0e000000 ...) */
+# define C_BUCKET_TYPE (0x0f000000)
+#endif
+#define C_VECTOR_TYPE 0x00000000
+#define C_BYTEVECTOR_TYPE (C_VECTOR_TYPE | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
+
+#define C_SIZEOF_LIST(n) ((n) * 3 + 1)
+#define C_SIZEOF_PAIR 3
+#define C_SIZEOF_STRING(n) (C_bytestowords(n) + 2)
+#define C_SIZEOF_SYMBOL 4
+#define C_SIZEOF_INTERNED_SYMBOL(n) (C_SIZEOF_SYMBOL + C_SIZEOF_BUCKET + C_SIZEOF_STRING(n))
+#ifdef C_DOUBLE_IS_32_BITS
+# define C_SIZEOF_FLONUM 2
+#else
+# define C_SIZEOF_FLONUM 4
+#endif
+#define C_SIZEOF_POINTER 2
+#define C_SIZEOF_TAGGED_POINTER 3
+#define C_SIZEOF_SWIG_POINTER 3
+#define C_SIZEOF_VECTOR(n) ((n) + 1)
+#define C_SIZEOF_BUCKET 3
+#define C_SIZEOF_LOCATIVE 5
+#define C_SIZEOF_PORT 16
+
+/* Fixed size types have pre-computed header tags */
+#define C_PAIR_TAG (C_PAIR_TYPE | (C_SIZEOF_PAIR - 1))
+#define C_POINTER_TAG (C_POINTER_TYPE | (C_SIZEOF_POINTER - 1))
+#define C_LOCATIVE_TAG (C_LOCATIVE_TYPE | (C_SIZEOF_LOCATIVE - 1))
+#define C_TAGGED_POINTER_TAG (C_TAGGED_POINTER_TYPE | (C_SIZEOF_TAGGED_POINTER - 1))
+#define C_SWIG_POINTER_TAG (C_SWIG_POINTER_TYPE | (C_wordstobytes(C_SIZEOF_SWIG_POINTER - 1)))
+#define C_SYMBOL_TAG (C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1))
+#define C_FLONUM_TAG (C_FLONUM_TYPE | sizeof(double))
+
+/* Locative subtypes */
+#define C_SLOT_LOCATIVE 0
+#define C_CHAR_LOCATIVE 1
+#define C_U8_LOCATIVE 2
+#define C_S8_LOCATIVE 3
+#define C_U16_LOCATIVE 4
+#define C_S16_LOCATIVE 5
+#define C_U32_LOCATIVE 6
+#define C_S32_LOCATIVE 7
+#define C_F32_LOCATIVE 8
+#define C_F64_LOCATIVE 9
+
+#ifdef C_SIXTY_FOUR
+# define C_word long
+# define C_u32 uint32_t
+# define C_s32 int32_t
+#else
+# define C_word int
+# define C_u32 unsigned int
+# define C_s32 int
+#endif
+
+#if defined(_MSC_VER) || defined (__MINGW32__)
+# define C_s64 __int64
+#else
+# define C_s64 int64_t
+#endif
+
+#define C_char char
+#define C_uchar unsigned C_char
+#define C_byte char
+#define C_uword unsigned C_word
+#define C_header C_uword
+#define C_text(x) x
+
+#define C_TIMER_INTERRUPT_NUMBER 255
+
+#define C_BAD_ARGUMENT_COUNT_ERROR 1
+#define C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR 2
+#define C_BAD_ARGUMENT_TYPE_ERROR 3
+#define C_UNBOUND_VARIABLE_ERROR 4
+#define C_TOO_MANY_PARAMETERS_ERROR 5
+#define C_OUT_OF_MEMORY_ERROR 6
+#define C_DIVISION_BY_ZERO_ERROR 7
+#define C_OUT_OF_RANGE_ERROR 8
+#define C_NOT_A_CLOSURE_ERROR 9
+#define C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR 10
+#define C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR 11
+#define C_TOO_DEEP_RECURSION_ERROR 12
+#define C_CANT_REPRESENT_INEXACT_ERROR 13
+#define C_NOT_A_PROPER_LIST_ERROR 14
+#define C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR 15
+#define C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR 16
+#define C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR 17
+#define C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR 18
+#define C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR 19
+#define C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR 20
+#define C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR 21
+#define C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR 22
+#define C_STACK_OVERFLOW_ERROR 23
+#define C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR 24
+#define C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR 25
+#define C_LOST_LOCATIVE_ERROR 26
+#define C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR 27
+#define C_BAD_ARGUMENT_TYPE_NO_NUMBER_VECTOR_ERROR 28
+#define C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR 29
+#define C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR 30
+#define C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR 31
+#define C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR 32
+#define C_RUNTIME_UNSAFE_DLOAD_SAFE_ERROR 33
+#define C_RUNTIME_SAFE_DLOAD_UNSAFE_ERROR 34
+#define C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR 35
+#define C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR 36
+
+
+/* Platform information */
+#if defined(C_BIG_ENDIAN)
+# define C_MACHINE_BYTE_ORDER "big-endian"
+#elif defined(C_LITTLE_ENDIAN)
+# define C_MACHINE_BYTE_ORDER "little-endian"
+#endif
+
+#if defined(__alpha__)
+# define C_MACHINE_TYPE "alpha"
+#elif defined(__mips__)
+# define C_MACHINE_TYPE "mips"
+#elif defined(__hppa__)
+# define C_MACHINE_TYPE "hppa"
+#elif defined(__sparc_v9__) || defined(__sparcv9)
+# define C_MACHINE_TYPE "ultrasparc"
+#elif defined(__sparc__)
+# define C_MACHINE_TYPE "sparc"
+#elif defined(__powerpc64__)
+# define C_MACHINE_TYPE "ppc64"
+#elif defined(__ppc__) || defined(__powerpc__)
+# define C_MACHINE_TYPE "ppc"
+#elif defined(_M_IX86) || defined(__i386__)
+# define C_MACHINE_TYPE "x86"
+#elif defined(__ia64__)
+# define C_MACHINE_TYPE "ia64"
+#elif defined(__x86_64__)
+# define C_MACHINE_TYPE "x86-64"
+#elif defined(__arm__)
+# define C_MACHINE_TYPE "arm"
+#else
+# define C_MACHINE_TYPE "unknown"
+#endif
+
+#if defined(__CYGWIN__) || defined(__MINGW32__) || defined(_WIN32) || defined(__WINNT__)
+# define C_SOFTWARE_TYPE "windows"
+#elif defined(__unix__) || defined(C_XXXBSD)
+# define C_SOFTWARE_TYPE "unix"
+#elif defined(ECOS)
+# define C_SOFTWARE_TYPE "ecos"
+#else
+# define C_SOFTWARE_TYPE "unknown"
+#endif
+
+#if defined(__CYGWIN__)
+# define C_BUILD_PLATFORM "cygwin"
+#elif defined(_MSC_VER)
+# define C_BUILD_PLATFORM "msvc"
+#elif defined(__SUNPRO_C)
+# define C_BUILD_PLATFORM "sun"
+#elif defined(__MINGW32__)
+# define C_BUILD_PLATFORM "mingw32"
+#elif defined(__GNUC__)
+# define C_BUILD_PLATFORM "gnu"
+#elif defined(__MWERKS__)
+# define C_BUILD_PLATFORM "metrowerks"
+#elif defined(__INTEL_COMPILER)
+# define C_BUILD_PLATFORM "intel"
+#elif defined(__WATCOMC__)
+# define C_BUILD_PLATFORM "watcom"
+#else
+# define C_BUILD_PLATFORM "unknown"
+#endif
+
+#if defined(_MSC_VER)
+# if defined(_DLL)
+# define C_RUNTIME_VERSION "dynamic"
+# else
+# define C_RUNTIME_VERSION "static"
+# endif
+#else
+# define C_RUNTIME_VERSION "unknown"
+#endif
+
+#if defined(__linux__)
+# define C_SOFTWARE_VERSION "linux"
+#elif defined(__FreeBSD__)
+# define C_SOFTWARE_VERSION "freebsd"
+#elif defined(__NetBSD__)
+# define C_SOFTWARE_VERSION "netbsd"
+#elif defined(__OpenBSD__)
+# define C_SOFTWARE_VERSION "openbsd"
+#elif defined(C_MACOSX)
+# define C_SOFTWARE_VERSION "macosx"
+#elif defined(__hpux__)
+# define C_SOFTWARE_VERSION "hpux"
+#elif defined(__DragonFly__)
+# define C_SOFTWARE_VERSION "dragonfly"
+#elif defined(__sun__)
+# if defined(__svr4__)
+# define C_SOFTWARE_VERSION "solaris"
+# else
+# define C_SOFTWARE_VERSION "sunos"
+# endif
+#else
+# define C_SOFTWARE_VERSION "unknown"
+#endif
+
+
+/* Types: */
+
+typedef struct C_block_struct
+{
+ C_header header;
+ C_word data[ 1 ];
+} C_SCHEME_BLOCK;
+
+typedef struct C_symbol_table_struct
+{
+ char *name;
+ unsigned int size;
+ C_word *table;
+ struct C_symbol_table_struct *next;
+} C_SYMBOL_TABLE;
+
+typedef struct C_gc_root_struct
+{
+ C_word value;
+ struct C_gc_root_struct *next, *prev;
+ int finalizable;
+} C_GC_ROOT;
+
+typedef struct C_ptable_entry_struct
+{
+ C_char *id;
+ void *ptr;
+} C_PTABLE_ENTRY;
+
+#ifdef __x86_64__
+# define C_AMD64_ABI_WEIRDNESS , ...
+#else
+# define C_AMD64_ABI_WEIRDNESS
+#endif
+
+/* C_WORD_p<P>_<B>: List of ((2 ** P) * B) 'C_word' parameters */
+#define C_WORD_p0_0
+#define C_WORD_p1_0
+#define C_WORD_p2_0
+#define C_WORD_p3_0
+#define C_WORD_p4_0
+#define C_WORD_p5_0
+#define C_WORD_p6_0
+#define C_WORD_p7_0
+#define C_WORD_p0_1 C_word,
+#define C_WORD_p1_1 C_word, C_word,
+#define C_WORD_p2_1 C_WORD_p1_1 C_WORD_p1_1
+#define C_WORD_p3_1 C_WORD_p2_1 C_WORD_p2_1
+#define C_WORD_p4_1 C_WORD_p3_1 C_WORD_p3_1
+#define C_WORD_p5_1 C_WORD_p4_1 C_WORD_p4_1
+#define C_WORD_p6_1 C_WORD_p5_1 C_WORD_p5_1
+#define C_WORD_p7_1 C_WORD_p6_1 C_WORD_p6_1
+
+/* DECL_C_PROC_p0 (n0, p7,p6,p5,p4,p3,p2,p1,p0):
+ * declare function C_proc<n0>, which have <n0> 'C_word' parameters
+ * (not counting last 'C_word C_AMD64_ABI_WEIRDNESS' one).
+ * We must have: n0 = SUM (i = 7 to 0, p<i> * (1 << i)).
+ * DECL_C_PROC_p<N+1> (...):
+ * declare 2 as much functions as DECL_C_PROC_p<N>...
+ */
+#define DECL_C_PROC_p0( n0, p7,p6,p5,p4,p3,p2,p1,p0) \
+ typedef void (C_ccall *C_proc##n0) (C_WORD_p7_##p7 C_WORD_p6_##p6 \
+ C_WORD_p5_##p5 C_WORD_p4_##p4 \
+ C_WORD_p3_##p3 C_WORD_p2_##p2 \
+ C_WORD_p1_##p1 C_WORD_p0_##p0 \
+ C_word C_AMD64_ABI_WEIRDNESS) C_noret;
+#define DECL_C_PROC_p1( n0,n1, p7,p6,p5,p4,p3,p2,p1) \
+ DECL_C_PROC_p0 (n0, p7,p6,p5,p4,p3,p2,p1,0) \
+ DECL_C_PROC_p0 (n1, p7,p6,p5,p4,p3,p2,p1,1)
+#define DECL_C_PROC_p2( n0,n1,n2,n3, p7,p6,p5,p4,p3,p2) \
+ DECL_C_PROC_p1 (n0,n1, p7,p6,p5,p4,p3,p2,0) \
+ DECL_C_PROC_p1 (n2,n3, p7,p6,p5,p4,p3,p2,1)
+#define DECL_C_PROC_p3( n0,n1,n2,n3,n4,n5,n6,n7, p7,p6,p5,p4,p3) \
+ DECL_C_PROC_p2 (n0,n1,n2,n3, p7,p6,p5,p4,p3,0) \
+ DECL_C_PROC_p2 (n4,n5,n6,n7, p7,p6,p5,p4,p3,1)
+
+DECL_C_PROC_p1 (2,3, 0,0,0,0,0,0,1)
+DECL_C_PROC_p2 (4,5,6,7, 0,0,0,0,0,1)
+DECL_C_PROC_p3 (8,9,10,11,12,13,14,15, 0,0,0,0,1)
+DECL_C_PROC_p3 (16,17,18,19,20,21,22,23, 0,0,0,1,0)
+DECL_C_PROC_p3 (24,25,26,27,28,29,30,31, 0,0,0,1,1)
+DECL_C_PROC_p3 (32,33,34,35,36,37,38,39, 0,0,1,0,0)
+DECL_C_PROC_p3 (40,41,42,43,44,45,46,47, 0,0,1,0,1)
+DECL_C_PROC_p3 (48,49,50,51,52,53,54,55, 0,0,1,1,0)
+DECL_C_PROC_p3 (56,57,58,59,60,61,62,63, 0,0,1,1,1)
+DECL_C_PROC_p1 (64,65, 0,1,0,0,0,0,0)
+DECL_C_PROC_p0 (66, 0,1,0,0,0,0,1,0)
+DECL_C_PROC_p0 (67, 0,1,0,0,0,0,1,1)
+DECL_C_PROC_p2 (68,69,70,71, 0,1,0,0,0,1)
+DECL_C_PROC_p3 (72,73,74,75,76,77,78,79, 0,1,0,0,1)
+DECL_C_PROC_p3 (80,81,82,83,84,85,86,87, 0,1,0,1,0)
+DECL_C_PROC_p3 (88,89,90,91,92,93,94,95, 0,1,0,1,1)
+DECL_C_PROC_p3 (96,97,98,99,100,101,102,103, 0,1,1,0,0)
+DECL_C_PROC_p3 (104,105,106,107,108,109,110,111, 0,1,1,0,1)
+DECL_C_PROC_p3 (112,113,114,115,116,117,118,119, 0,1,1,1,0)
+DECL_C_PROC_p3 (120,121,122,123,124,125,126,127, 0,1,1,1,1)
+DECL_C_PROC_p0 (128, 1,0,0,0,0,0,0,0)
+
+
+/* Macros: */
+
+#define CHICKEN_gc_root_ref(root) (((C_GC_ROOT *)(root))->value)
+#define CHICKEN_gc_root_set(root, x) C_mutate(&((C_GC_ROOT *)(root))->value, (x))
+
+#define CHICKEN_global_ref(root) C_u_i_car(((C_GC_ROOT *)(root))->value)
+#define CHICKEN_global_set(root, x) C_mutate(&C_u_i_car(((C_GC_ROOT *)(root))->value), (x))
+
+#define CHICKEN_default_toplevel ((void *)C_default_stub_toplevel)
+
+#define C_align4(n) (((n) + 3) & ~3)
+#define C_align8(n) (((n) + 7) & ~7)
+#define C_align16(n) (((n) + 15) & ~15)
+
+/* This is word-size dependent: */
+#ifdef C_SIXTY_FOUR
+# define C_align(n) C_align8(n)
+# define C_wordstobytes(n) ((n) << 3)
+# define C_bytestowords(n) (((n) + 7) >> 3)
+# define C_wordsperdouble(n) (n)
+# define C_WORD_MIN LONG_MIN
+# define C_WORD_MAX LONG_MAX
+# define C_UWORD_MAX ULONG_MAX
+#else
+# define C_align(n) C_align4(n)
+# define C_wordstobytes(n) ((n) << 2)
+# define C_bytestowords(n) (((n) + 3) >> 2)
+# define C_wordsperdouble(n) ((n) << 1)
+# define C_WORD_MIN INT_MIN
+# define C_WORD_MAX INT_MAX
+# define C_UWORD_MAX UINT_MAX
+#endif
+
+#ifndef C_PROVIDE_LIBC_STUBS
+# define C_FILEPTR FILE *
+
+# define C_stdin stdin
+# define C_stdout stdout
+# define C_stderr stderr
+
+# define C_memcpy memcpy
+# define C_memcmp memcmp
+# define C_strcpy strcpy
+# define C_strncpy strncpy
+# define C_strcmp strcmp
+# define C_strncmp strncmp
+# define C_strlen strlen
+# define C_strcat strcat
+# define C_memset memset
+# define C_memmove memmove
+# define C_strncasecmp strncasecmp
+# define C_malloc malloc
+# define C_calloc calloc
+# define C_free free
+# define C_strchr strchr
+# define C_realloc realloc
+# define C_strdup strdup
+# define C_strtol strtol
+# define C_strtod strtod
+# define C_strtoul strtoul
+# define C_fopen fopen
+# define C_fclose fclose
+# define C_strpbrk strpbrk
+# define C_gcvt gcvt
+# define C_sprintf sprintf
+# define C_snprintf snprintf
+# define C_printf printf
+# define C_fprintf fprintf
+# define C_fflush fflush
+# define C_getchar getchar
+# define C_exit exit
+# define C_dlopen dlopen
+# define C_dlclose dlclose
+# define C_dlsym dlsym
+# define C_fwrite fwrite
+# define C_fread fread
+# define C_fputs fputs
+# define C_fputc fputc
+# define C_putchar putchar
+# if (defined getc_unlocked || _POSIX_C_SOURCE >= 199506L)
+# define C_getc getc_unlocked
+# else
+# define C_getc getc
+# endif
+# define C_fgetc fgetc
+# define C_fgets fgets
+# define C_ungetc ungetc
+# define C_system system
+# define C_isatty isatty
+# define C_fileno fileno
+# define C_select select
+# define C_signal signal
+# define C_getrusage getrusage
+# define C_tolower tolower
+# define C_toupper toupper
+# define C_gettimeofday gettimeofday
+# define C_gmtime gmtime
+# define C_localtime localtime
+# define C_setjmp setjmp
+# define C_longjmp longjmp
+# define C_alloca alloca
+# define C_strerror strerror
+# define C_isalpha isalpha
+# define C_isdigit isdigit
+# define C_isspace isspace
+# define C_islower islower
+# define C_isupper isupper
+#else
+# include "chicken-libc-stubs.h"
+#endif
+
+#define C_return(x) return(x)
+#define C_resize_stack(n) C_do_resize_stack(n)
+#define C_memcpy_slots(t, f, n) C_memcpy((t), (f), (n) * sizeof(C_word))
+#define C_block_header(x) (((C_SCHEME_BLOCK *)(x))->header)
+#define C_header_bits(x) (C_block_header(x) & C_HEADER_BITS_MASK)
+#define C_header_size(x) (C_block_header(x) & C_HEADER_SIZE_MASK)
+#define C_make_header(type, size) ((C_header)(((type) & C_HEADER_BITS_MASK) | ((size) & C_HEADER_SIZE_MASK)))
+#define C_symbol_value(x) (C_block_item(x, 0))
+#define C_block_item(x, i) (((C_SCHEME_BLOCK *)(x))->data[ i ])
+#define C_set_block_item(x, i, y) (C_block_item(x, i) = (y))
+#define C_save(x) (*(--C_temporary_stack) = (C_word)(x))
+#define C_adjust_stack(n) (C_temporary_stack -= (n))
+#define C_rescue(x, i) (C_temporary_stack[ i ] = (x))
+#define C_save_rest(s, c, n) for(va_start(v, s); c-- > (n); C_save(va_arg(v, C_word)))
+#define C_rest_count(c) ((C_temporary_stack_bottom - C_temporary_stack) - (c))
+#define C_restore (*(C_temporary_stack++))
+#define C_heaptop ((C_word **)(&C_fromspace_top))
+#define C_pick(n) (C_temporary_stack[ n ])
+#define C_drop(n) (C_temporary_stack += (n))
+#define C_alloc(n) ((C_word *)C_alloca((n) * sizeof(C_word)))
+#define C_stack_pointer ((C_word *)C_alloca(0))
+#define C_stack_pointer_test ((C_word *)C_alloca(1))
+#define C_demand_2(n) (((C_word *)C_fromspace_top + (n)) < (C_word *)C_fromspace_limit)
+#define C_fix(n) (((C_word)(n) << C_FIXNUM_SHIFT) | C_FIXNUM_BIT)
+#define C_unfix(x) ((x) >> C_FIXNUM_SHIFT)
+#define C_make_character(c) ((((c) & C_CHAR_BIT_MASK) << C_CHAR_SHIFT) | C_CHARACTER_BITS)
+#define C_character_code(x) (((x) >> C_CHAR_SHIFT) & C_CHAR_BIT_MASK)
+#define C_flonum_magnitude(x) (*((double *)(((C_SCHEME_BLOCK *)(x))->data)))
+#define C_c_string(x) ((C_char *)(((C_SCHEME_BLOCK *)(x))->data))
+#define C_c_pointer(x) ((void *)(x))
+#define C_c_pointer_nn(x) ((void *)C_block_item(x, 0))
+#define C_truep(x) ((x) != C_SCHEME_FALSE)
+#define C_immediatep(x) ((x) & C_IMMEDIATE_MARK_BITS)
+#define C_mk_bool(x) ((x) ? C_SCHEME_TRUE : C_SCHEME_FALSE)
+#define C_mk_nbool(x) ((x) ? C_SCHEME_FALSE : C_SCHEME_TRUE)
+#define C_port_file(p) ((C_FILEPTR)C_block_item(p, 0))
+#define C_data_pointer(x) ((void *)((C_SCHEME_BLOCK *)(x))->data)
+#define C_invert_flag(f) (!(f))
+#define C_fitsinfixnump(n) (((n) & C_INT_SIGN_BIT) == (((n) & C_INT_TOP_BIT) << 1))
+#define C_ufitsinfixnump(n) (((n) & (C_INT_SIGN_BIT | (C_INT_SIGN_BIT >> 1))) == 0)
+#define C_quickflonumtruncate(n) (C_fix((C_word)C_flonum_magnitude(n)))
+#define C_and(x, y) (C_truep(x) ? (y) : C_SCHEME_FALSE)
+#define C_c_bytevector(x) ((unsigned char *)C_data_pointer(x))
+#define C_c_bytevector_or_null(x) ((unsigned char *)C_data_pointer_or_null(x))
+#define C_c_u8vector(x) ((unsigned char *)C_data_pointer(C_u_i_cdr(x)))
+#define C_c_u8vector_or_null(x) ((unsigned char *)C_srfi_4_vector_or_null(x))
+#define C_c_s8vector(x) ((char *)C_data_pointer(C_u_i_cdr(x)))
+#define C_c_s8vector_or_null(x) ((char *)C_srfi_4_vector_or_null(x))
+#define C_c_u16vector(x) ((unsigned short *)C_data_pointer(C_u_i_cdr(x)))
+#define C_c_u16vector_or_null(x) ((unsigned short *)C_srfi_4_vector_or_null(x))
+#define C_c_s16vector(x) ((short *)C_data_pointer(C_u_i_cdr(x)))
+#define C_c_s16vector_or_null(x) ((short *)C_srfi_4_vector_or_null(x))
+#define C_c_u32vector(x) ((C_u32 *)C_data_pointer(C_u_i_cdr(x)))
+#define C_c_u32vector_or_null(x) ((C_u32 *)C_srfi_4_vector_or_null(x))
+#define C_c_s32vector(x) ((C_s32 *)C_data_pointer(C_u_i_cdr(x)))
+#define C_c_s32vector_or_null(x) ((C_s32 *)C_srfi_4_vector_or_null(x))
+#define C_c_f32vector(x) ((float *)C_data_pointer(C_u_i_cdr(x)))
+#define C_c_f32vector_or_null(x) ((float *)C_srfi_4_vector_or_null(x))
+#define C_c_f64vector(x) ((double *)C_data_pointer(C_u_i_cdr(x)))
+#define C_c_f64vector_or_null(x) ((double *)C_srfi_4_vector_or_null(x))
+
+#ifdef C_STRESS_TEST
+# define C_STRESS_FAILURE 3
+# define C_stress (rand() % C_STRESS_FAILURE)
+#else
+# define C_stress 1
+#endif
+
+#if C_STACK_GROWS_DOWNWARD
+# define C_demand(n) (C_stress && ((C_word)(C_stack_pointer - C_stack_limit) > (n)))
+# define C_stack_probe(p) (C_stress && ((C_word *)(p) >= C_stack_limit))
+# define C_stack_check if(!C_disable_overflow_check && (C_byte*)(C_stack_pointer) + C_STACK_RESERVE < (C_byte *)C_stack_limit) C_stack_overflow()
+#else
+# define C_demand(n) (C_stress && ((C_word)(C_stack_limit - C_stack_pointer) > (n)))
+# define C_stack_probe(p) (C_stress && ((C_word *)(p) < C_stack_limit))
+# define C_stack_check if(!C_disable_overflow_check && (C_byte*)(C_stack_pointer) - C_STACK_RESERVE > (C_byte *)C_stack_limit) C_stack_overflow()
+#endif
+
+#define C_zero_length_p(x) C_mk_bool(C_header_size(x) == 0)
+#define C_boundp(x) C_mk_bool(((C_SCHEME_BLOCK *)(x))->data[ 0 ] != C_SCHEME_UNBOUND)
+#define C_unboundvaluep(x) C_mk_bool((x) == C_SCHEME_UNBOUND)
+#define C_blockp(x) C_mk_bool(!C_immediatep(x))
+#define C_forwardedp(x) C_mk_bool((C_block_header(x) & C_GC_FORWARDING_BIT) != 0)
+#define C_immp(x) C_mk_bool(C_immediatep(x))
+#define C_flonump(x) C_mk_bool(C_block_header(x) == C_FLONUM_TAG)
+#define C_stringp(x) C_mk_bool(C_header_bits(x) == C_STRING_TYPE)
+#define C_symbolp(x) C_mk_bool(C_block_header(x) == C_SYMBOL_TAG)
+#define C_pairp(x) C_mk_bool(C_block_header(x) == C_PAIR_TAG)
+#define C_closurep(x) C_mk_bool(C_header_bits(x) == C_CLOSURE_TYPE)
+#define C_vectorp(x) C_mk_bool(C_header_bits(x) == C_VECTOR_TYPE)
+#define C_bytevectorp(x) C_mk_bool(C_header_bits(x) == C_BYTEVECTOR_TYPE)
+#define C_portp(x) C_mk_bool(C_header_bits(x) == C_PORT_TYPE)
+#define C_structurep(x) C_mk_bool(C_header_bits(x) == C_STRUCTURE_TYPE)
+#define C_locativep(x) C_mk_bool(C_block_header(x) == C_LOCATIVE_TAG)
+#define C_charp(x) C_mk_bool(((x) & C_IMMEDIATE_TYPE_BITS) == C_CHARACTER_BITS)
+#define C_booleanp(x) C_mk_bool(((x) & C_IMMEDIATE_TYPE_BITS) == C_BOOLEAN_BITS)
+#define C_eofp(x) C_mk_bool((x) == C_SCHEME_END_OF_FILE)
+#define C_undefinedp(x) C_mk_bool((x) == C_SCHEME_UNDEFINED)
+#define C_fixnump(x) C_mk_bool((x) & C_FIXNUM_BIT)
+#define C_nfixnump(x) C_mk_nbool((x) & C_FIXNUM_BIT)
+#define C_pointerp(x) C_mk_bool(C_block_header(x) == C_POINTER_TAG)
+#define C_taggedpointerp(x) C_mk_bool(C_block_header(x) == C_TAGGED_POINTER_TAG)
+#define C_swigpointerp(x) C_mk_bool(C_block_header(x) == C_SWIG_POINTER_TAG)
+#define C_lambdainfop(x) C_mk_bool(C_header_bits(x) == C_LAMBDA_INFO_TYPE)
+#define C_anypointerp(x) C_mk_bool(C_block_header(x) == C_POINTER_TAG || C_block_header(x) == C_TAGGED_POINTER_TAG || C_block_header(x) == C_SWIG_POINTER_TAG)
+#define C_specialp(x) C_mk_bool(C_header_bits(x) & C_SPECIALBLOCK_BIT)
+#define C_byteblockp(x) C_mk_bool(C_header_bits(x) & C_BYTEBLOCK_BIT)
+#define C_anyp(x) C_SCHEME_TRUE
+#define C_eqp(x, y) C_mk_bool((x) == (y))
+#define C_vemptyp(x) C_mk_bool(C_header_size(x) == 0)
+#define C_notvemptyp(x) C_mk_bool(C_header_size(x) > 0)
+#define C_slot(x, i) (((C_SCHEME_BLOCK *)(x))->data[ C_unfix(i) ])
+#define C_slot0(x) (((C_SCHEME_BLOCK *)(x))->data[ 0 ])
+#define C_subbyte(x, i) C_fix(((C_byte *)((C_SCHEME_BLOCK *)(x))->data)[ C_unfix(i) ] & 0xff)
+#define C_subchar(x, i) C_make_character(((C_uchar *)((C_SCHEME_BLOCK *)(x))->data)[ C_unfix(i) ])
+#define C_setbyte(x, i, n) (((C_byte *)((C_SCHEME_BLOCK *)(x))->data)[ C_unfix(i) ] = C_unfix(n), C_SCHEME_UNDEFINED)
+#define C_setsubchar(x, i, n) (((C_char *)((C_SCHEME_BLOCK *)(x))->data)[ C_unfix(i) ] = C_character_code(n), C_SCHEME_UNDEFINED)
+#define C_setsubbyte(x, i, n) (((C_char *)((C_SCHEME_BLOCK *)(x))->data)[ C_unfix(i) ] = C_unfix(n), C_SCHEME_UNDEFINED)
+#define C_fixnum_times(n1, n2) (C_fix(C_unfix(n1) * C_unfix(n2)))
+#define C_u_fixnum_plus(n1, n2) (((n1) - C_FIXNUM_BIT) + (n2))
+#define C_fixnum_plus(n1, n2) (C_u_fixnum_plus(n1, n2) | C_FIXNUM_BIT)
+#define C_u_fixnum_difference(n1, n2) ((n1) - (n2) + C_FIXNUM_BIT)
+#define C_fixnum_difference(n1, n2) (C_u_fixnum_difference(n1, n2) | C_FIXNUM_BIT)
+#define C_fixnum_divide(n1, n2) (C_fix(C_unfix(n1) / C_unfix(n2)))
+#define C_fixnum_modulo(n1, n2) (C_fix(C_unfix(n1) % C_unfix(n2)))
+#define C_u_fixnum_and(n1, n2) ((n1) & (n2))
+#define C_fixnum_and(n1, n2) (C_u_fixnum_and(n1, n2) | C_FIXNUM_BIT)
+#define C_u_fixnum_or(n1, n2) ((n1) | (n2))
+#define C_fixnum_or(n1, n2) (C_u_fixnum_or(n1, n2) | C_FIXNUM_BIT)
+#define C_fixnum_xor(n1, n2) (((n1) ^ (n2)) | C_FIXNUM_BIT)
+#define C_fixnum_not(n) ((~(n)) | C_FIXNUM_BIT)
+#define C_fixnum_shift_left(n1, n2) (C_fix(C_unfix(n1) << C_unfix(n2)))
+#define C_fixnum_shift_right(n1, n2) (((n1) >> C_unfix(n2)) | C_FIXNUM_BIT)
+#define C_u_fixnum_negate(n) (-(n) + 2 * C_FIXNUM_BIT)
+#define C_fixnum_negate(n) (C_u_fixnum_negate(n) | C_FIXNUM_BIT)
+#define C_fixnum_greaterp(n1, n2) (C_mk_bool((C_word)(n1) > (C_word)(n2)))
+#define C_fixnum_lessp(n1, n2) (C_mk_bool((C_word)(n1) < (C_word)(n2)))
+#define C_fixnum_greater_or_equal_p(n1, n2) (C_mk_bool((C_word)(n1) >= (C_word)(n2)))
+#define C_fixnum_less_or_equal_p(n1, n2)(C_mk_bool((C_word)(n1) <= (C_word)(n2)))
+#define C_u_fixnum_increase(n) ((n) + (1 << C_FIXNUM_SHIFT))
+#define C_fixnum_increase(n) (C_u_fixnum_increase(n) | C_FIXNUM_BIT)
+#define C_u_fixnum_decrease(n) ((n) - (1 << C_FIXNUM_SHIFT))
+#define C_fixnum_decrease(n) (C_u_fixnum_decrease(n) | C_FIXNUM_BIT)
+#define C_fixnum_abs(n) C_fix(abs(C_unfix(n)))
+
+#define C_flonum_equalp(n1, n2) C_mk_bool(C_flonum_magnitude(n1) == C_flonum_magnitude(n2))
+#define C_flonum_greaterp(n1, n2) C_mk_bool(C_flonum_magnitude(n1) > C_flonum_magnitude(n2))
+#define C_flonum_lessp(n1, n2) C_mk_bool(C_flonum_magnitude(n1) < C_flonum_magnitude(n2))
+#define C_flonum_greater_or_equal_p(n1, n2) C_mk_bool(C_flonum_magnitude(n1) >= C_flonum_magnitude(n2))
+#define C_flonum_less_or_equal_p(n1, n2) C_mk_bool(C_flonum_magnitude(n1) <= C_flonum_magnitude(n2))
+
+#define C_display_fixnum(p, n) (C_fprintf(C_port_file(p), C_text("%d"), C_unfix(n)), C_SCHEME_UNDEFINED)
+#define C_display_char(p, c) (C_fputc(C_character_code(c), C_port_file(p)), C_SCHEME_UNDEFINED)
+#define C_display_string(p, s) (C_fwrite(((C_SCHEME_BLOCK *)(s))->data, sizeof(C_char), C_header_size(s), \
+ C_port_file(p)), C_SCHEME_UNDEFINED)
+#define C_fix_to_char(x) (C_make_character(C_unfix(x)))
+#define C_char_to_fix(x) (C_fix(C_character_code(x)))
+#define C_math_result(x) (C_temporary_flonum = (x), C_SCHEME_UNDEFINED)
+#define C_substring_copy(s1, s2, start1, end1, start2) \
+ (C_memcpy((C_char *)C_data_pointer(s2) + C_unfix(start2), \
+ (C_char *)C_data_pointer(s1) + C_unfix(start1), \
+ C_unfix(end1) - C_unfix(start1) ), C_SCHEME_UNDEFINED)
+#define C_substring_compare(s1, s2, start1, start2, len) \
+ C_mk_bool(C_memcmp((C_char *)C_data_pointer(s1) + C_unfix(start1), \
+ (C_char *)C_data_pointer(s2) + C_unfix(start2), \
+ C_unfix(len) ) == 0)
+#define C_substring_compare_case_insensitive(s1, s2, start1, start2, len) \
+ C_mk_bool(C_strncasecmp((C_char *)C_data_pointer(s1) + C_unfix(start1), \
+ (C_char *)C_data_pointer(s2) + C_unfix(start2), \
+ C_unfix(len) ) == 0)
+#define C_subvector_copy(v1, v2, start1, end1, start2) \
+ (C_memcpy_slots((C_char *)C_data_pointer(v2) + C_unfix(start2), \
+ (C_char *)C_data_pointer(v1) + C_unfix(start1), \
+ C_unfix(end1) - C_unfix(start1) ), C_SCHEME_UNDEFINED)
+#define C_words(n) C_fix(C_bytestowords(C_unfix(n)))
+#define C_bytes(n) C_fix(C_wordstobytes(C_unfix(n)))
+#define C_random_fixnum(n) C_fix((int)(((double)rand())/(RAND_MAX + 1.0) * C_unfix(n)))
+#define C_randomize(n) (srand(C_unfix(n)), C_SCHEME_UNDEFINED)
+#define C_block_size(x) C_fix(C_header_size(x))
+#define C_pointer_address(x) ((C_byte *)C_u_i_car(x))
+#define C_block_address(ptr, n, x) C_a_unsigned_int_to_num(ptr, n, x)
+#define C_offset_pointer(x, y) (C_pointer_address(x) + (y))
+#define C_kontinue(k, r) ((C_proc2)(void *)C_u_i_car(k))(2, (k), (r))
+#define C_fetch_byte(x, p) (((unsigned C_byte *)((C_SCHEME_BLOCK *)(x))->data)[ p ])
+#define C_poke_integer(x, i, n) (C_set_block_item(x, C_unfix(i), C_num_to_int(n)), C_SCHEME_UNDEFINED)
+#define C_pointer_to_block(p, x) (C_set_block_item(p, 0, (C_word)C_data_pointer(x)), C_SCHEME_UNDEFINED)
+#define C_null_pointerp(x) C_mk_bool((void *)C_u_i_car(x) == NULL)
+#define C_update_pointer(p, ptr) (C_set_block_item(ptr, 0, C_num_to_unsigned_int(p)), C_SCHEME_UNDEFINED)
+#define C_copy_pointer(from, to) (C_set_block_item(to, 0, C_u_i_car(from)), C_SCHEME_UNDEFINED)
+#define C_pointer_to_object(ptr) ((C_word*)C_block_item(ptr, 0))
+
+#define C_direct_return(dk, x) (C_kontinue(dk, x), C_SCHEME_UNDEFINED)
+
+#ifdef C_SIXTY_FOUR
+# define C_poke_integer_32(x, i, n) (((C_s32 *)C_data_pointer(x))[ C_unfix(i) ] = C_unfix(n), C_SCHEME_UNDEFINED)
+#else
+# define C_poke_integer_32 C_poke_integer
+#endif
+
+#define C_copy_memory(to, from, n) (C_memcpy(C_data_pointer(to), C_data_pointer(from), C_unfix(n)), C_SCHEME_UNDEFINED)
+#define C_set_memory(to, c, n) (C_memset(C_data_pointer(to), C_character_code(c), C_unfix(n)), C_SCHEME_UNDEFINED)
+#define C_string_compare(to, from, n) C_fix(C_strncmp(C_c_string(to), C_c_string(from), C_unfix(n)))
+#define C_string_compare_case_insensitive(from, to, n) \
+ C_fix(C_strncasecmp(C_c_string(from), C_c_string(to), C_unfix(n)))
+#define C_rename_file(old, new) C_fix(rename(C_c_string(old), C_c_string(new)))
+#define C_delete_file(fname) C_fix(remove(C_c_string(fname)))
+#define C_poke_double(b, i, n) (((double *)C_data_pointer(b))[ C_unfix(i) ] = C_c_double(n), C_SCHEME_UNDEFINED)
+#define C_poke_c_string(b, i, from) (C_strcpy((char *)C_block_item(b, C_unfix(i)), C_data_pointer(from)), C_SCHEME_UNDEFINED)
+#define C_peek_fixnum(b, i) C_fix(C_block_item(b, C_unfix(i)))
+#define C_peek_byte(ptr, i) C_fix(((unsigned char *)C_u_i_car(ptr))[ C_unfix(i) ])
+#define C_dupstr(s) C_strdup(C_data_pointer(s))
+#define C_poke_pointer(b, i, x) (C_set_block_item(b, C_unfix(i), (C_word)C_data_pointer(x)), C_SCHEME_UNDEFINED)
+#define C_poke_pointer_or_null(b, i, x) (C_set_block_item(b, C_unfix(i), (C_word)C_data_pointer_or_null(x)), C_SCHEME_UNDEFINED)
+#define C_qfree(ptr) (C_free(C_c_pointer_nn(ptr)), C_SCHEME_UNDEFINED)
+
+#define C_tty_portp(p) C_mk_bool(isatty(fileno(C_port_file(p))))
+
+#define C_emit_eval_trace_info(x, y, z) C_emit_trace_info2("<eval>", x, y, z)
+#define C_emit_syntax_trace_info(x, y, z) C_emit_trace_info2("<syntax>", x, y, z)
+
+/* These expect C_VECTOR_TYPE to be 0: */
+#define C_vector_to_structure(v) (((C_SCHEME_BLOCK *)(v))->header |= C_STRUCTURE_TYPE, C_SCHEME_UNDEFINED)
+#define C_vector_to_closure(v) (((C_SCHEME_BLOCK *)(v))->header |= C_CLOSURE_TYPE, C_SCHEME_UNDEFINED)
+#define C_string_to_bytevector(s) (((C_SCHEME_BLOCK *)(s))->header = C_header_size(s) | C_BYTEVECTOR_TYPE, C_SCHEME_UNDEFINED)
+#define C_string_to_lambdainfo(s) (((C_SCHEME_BLOCK *)(s))->header = C_header_size(s) | C_LAMBDA_INFO_TYPE, C_SCHEME_UNDEFINED)
+
+#ifdef C_TIMER_INTERRUPTS
+# ifdef PARANOIA
+# define C_check_for_interrupt C_paranoid_check_for_interrupt()
+# else
+# define C_check_for_interrupt if(--C_timer_interrupt_counter <= 0) C_raise_interrupt(C_TIMER_INTERRUPT_NUMBER)
+# endif
+#else
+# define C_check_for_interrupt
+#endif
+
+#if defined(__GNUC__) || defined(__INTEL_COMPILER)
+# define C_a_i(a, n) ({C_word *tmp = *a; *a += (n); tmp;})
+# define C_a_i_cons(a, n, car, cdr) ({C_word tmp = (C_word)(*a); (*a)[0] = C_PAIR_TYPE | 2; *a += 3; \
+ C_set_block_item(tmp, 0, car); C_set_block_item(tmp, 1, cdr); tmp;})
+#else
+# define C_a_i_cons(a, n, car, cdr) C_pair(a, car, cdr)
+#endif /* __GNUC__ */
+
+#define C_a_i_data_mpointer(ptr, n, x) C_mpointer(ptr, C_data_pointer(x))
+#define C_a_int_to_num(ptr, n, i) C_int_to_num(ptr, i)
+#define C_a_unsigned_int_to_num(ptr, n, i) C_unsigned_int_to_num(ptr, i)
+#define C_a_double_to_num(ptr, n) C_double_to_number(C_flonum(ptr, n))
+#define C_a_i_vector C_vector
+#define C_list C_a_i_list
+#define C_i_setslot(x, i, y) (C_mutate(&C_block_item(x, C_unfix(i)), y), C_SCHEME_UNDEFINED)
+#define C_i_set_i_slot(x, i, y) (C_set_block_item(x, C_unfix(i), y), C_SCHEME_UNDEFINED)
+#define C_u_i_set_car(p, x) (C_mutate(&C_u_i_car(p), x), C_SCHEME_UNDEFINED)
+#define C_u_i_set_cdr(p, x) (C_mutate(&C_u_i_cdr(p), x), C_SCHEME_UNDEFINED)
+
+#define C_i_not(x) (C_truep(x) ? C_SCHEME_FALSE : C_SCHEME_TRUE)
+#define C_i_equalp(x, y) C_mk_bool(C_equalp((x), (y)))
+#define C_i_fixnumevenp(x) C_mk_nbool((x) & 0x00000002)
+#define C_i_fixnumoddp(x) C_mk_bool((x) & 0x00000002)
+#define C_i_nullp(x) C_mk_bool((x) == C_SCHEME_END_OF_LIST)
+#define C_i_structurep(x, s) C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_STRUCTURE_TYPE && C_block_item(x, 0) == (s))
+
+#define C_u_i_char_alphabeticp(x) C_mk_bool(C_character_code(x) < 0x100 && C_isalpha(C_character_code(x)))
+#define C_u_i_char_numericp(x) C_mk_bool(C_character_code(x) < 0x100 && C_isdigit(C_character_code(x)))
+#define C_u_i_char_whitespacep(x) C_mk_bool(C_character_code(x) < 0x100 && C_isspace(C_character_code(x)))
+#define C_u_i_char_upper_casep(x) C_mk_bool(C_character_code(x) < 0x100 && C_isupper(C_character_code(x)))
+#define C_u_i_char_lower_casep(x) C_mk_bool(C_character_code(x) < 0x100 && C_islower(C_character_code(x)))
+
+#define C_u_i_char_upcase(x) (C_character_code(x) < 0x100 ? C_make_character(C_toupper(C_character_code(x))) : (x))
+#define C_u_i_char_downcase(x) (C_character_code(x) < 0x100 ? C_make_character(C_tolower(C_character_code(x))) : (x))
+
+#define C_i_list_ref(lst, i) C_i_car(C_i_list_tail(lst, i))
+#define C_u_i_list_ref(lst, i) C_u_i_car(C_i_list_tail(lst, i))
+
+#define C_u_i_car(x) C_block_item(x, 0)
+#define C_u_i_cdr(x) C_block_item(x, 1)
+#define C_u_i_caar(x) C_u_i_car( C_u_i_car( x ) )
+#define C_u_i_cadr(x) C_u_i_car( C_u_i_cdr( x ) )
+#define C_u_i_cdar(x) C_u_i_cdr( C_u_i_car( x ) )
+#define C_u_i_cddr(x) C_u_i_cdr( C_u_i_cdr( x ) )
+#define C_u_i_caaar(x) C_u_i_car( C_u_i_caar( x ) )
+#define C_u_i_caadr(x) C_u_i_car( C_u_i_cadr( x ) )
+#define C_u_i_cadar(x) C_u_i_car( C_u_i_cdar( x ) )
+#define C_u_i_caddr(x) C_u_i_car( C_u_i_cddr( x ) )
+#define C_u_i_cdaar(x) C_u_i_cdr( C_u_i_caar( x ) )
+#define C_u_i_cdadr(x) C_u_i_cdr( C_u_i_cadr( x ) )
+#define C_u_i_cddar(x) C_u_i_cdr( C_u_i_cdar( x ) )
+#define C_u_i_cdddr(x) C_u_i_cdr( C_u_i_cddr( x ) )
+#define C_u_i_caaaar(x) C_u_i_car( C_u_i_caaar( x ) )
+#define C_u_i_caaadr(x) C_u_i_car( C_u_i_caadr( x ) )
+#define C_u_i_caadar(x) C_u_i_car( C_u_i_cadar( x ) )
+#define C_u_i_caaddr(x) C_u_i_car( C_u_i_caddr( x ) )
+#define C_u_i_cadaar(x) C_u_i_car( C_u_i_cdaar( x ) )
+#define C_u_i_cadadr(x) C_u_i_car( C_u_i_cdadr( x ) )
+#define C_u_i_caddar(x) C_u_i_car( C_u_i_cddar( x ) )
+#define C_u_i_cadddr(x) C_u_i_car( C_u_i_cdddr( x ) )
+#define C_u_i_cdaaar(x) C_u_i_cdr( C_u_i_caaar( x ) )
+#define C_u_i_cdaadr(x) C_u_i_cdr( C_u_i_caadr( x ) )
+#define C_u_i_cdadar(x) C_u_i_cdr( C_u_i_cadar( x ) )
+#define C_u_i_cdaddr(x) C_u_i_cdr( C_u_i_caddr( x ) )
+#define C_u_i_cddaar(x) C_u_i_cdr( C_u_i_cdaar( x ) )
+#define C_u_i_cddadr(x) C_u_i_cdr( C_u_i_cdadr( x ) )
+#define C_u_i_cdddar(x) C_u_i_cdr( C_u_i_cddar( x ) )
+#define C_u_i_cddddr(x) C_u_i_cdr( C_u_i_cdddr( x ) )
+
+#define C_a_i_times( ptr, n, x, y) C_2_times( ptr, x, y)
+#define C_a_i_plus( ptr, n, x, y) C_2_plus( ptr, x, y)
+#define C_a_i_minus( ptr, n, x, y) C_2_minus( ptr, x, y)
+#define C_a_i_divide(ptr, n, x, y) C_2_divide(ptr, x, y)
+
+#if defined(__GNUC__) || defined(__INTEL_COMPILER)
+# define C_i_not_pair_p(x) ({C_word tmp = (x); C_mk_bool(C_immediatep(tmp) || C_block_header(tmp) != C_PAIR_TAG);})
+#else
+# define C_i_not_pair_p C_i_not_pair_p_2
+#endif
+
+#define C_i_check_closure(x) C_i_check_closure_2(x, C_SCHEME_FALSE)
+#define C_i_check_exact(x) C_i_check_exact_2(x, C_SCHEME_FALSE)
+#define C_i_check_inexact(x) C_i_check_inexact_2(x, C_SCHEME_FALSE)
+#define C_i_check_number(x) C_i_check_number_2(x, C_SCHEME_FALSE)
+#define C_i_check_string(x) C_i_check_string_2(x, C_SCHEME_FALSE)
+#define C_i_check_bytevector(x) C_i_check_bytevector_2(x, C_SCHEME_FALSE)
+#define C_i_check_symbol(x) C_i_check_symbol_2(x, C_SCHEME_FALSE)
+#define C_i_check_list(x) C_i_check_list_2(x, C_SCHEME_FALSE)
+#define C_i_check_pair(x) C_i_check_pair_2(x, C_SCHEME_FALSE)
+#define C_i_check_vector(x) C_i_check_vector_2(x, C_SCHEME_FALSE)
+#define C_i_check_structure(x, st) C_i_check_structure_2(x, (st), C_SCHEME_FALSE)
+#define C_i_check_char(x) C_i_check_char_2(x, C_SCHEME_FALSE)
+
+#define C_u_i_8vector_length(x) C_fix(C_header_size(C_block_item(x, 1)))
+#define C_u_i_16vector_length(x) C_fix(C_header_size(C_block_item(x, 1)) >> 1)
+#define C_u_i_32vector_length(x) C_fix(C_header_size(C_block_item(x, 1)) >> 2)
+#define C_u_i_64vector_length(x) C_fix(C_header_size(C_block_item(x, 1)) >> 3)
+
+#define C_u_i_u8vector_ref(x, i) C_fix(((unsigned char *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
+#define C_u_i_s8vector_ref(x, i) C_fix(((char *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
+#define C_u_i_u16vector_ref(x, i) C_fix(((unsigned short *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
+#define C_u_i_s16vector_ref(x, i) C_fix(((short *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
+#define C_u_i_u32vector_ref(x, i) C_fix(((C_u32 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
+#define C_u_i_s32vector_ref(x, i) C_fix(((C_u32 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
+#define C_a_i_u32vector_ref(ptr, c, x, i) C_unsigned_int_to_num(ptr, ((C_u32 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
+#define C_a_i_s32vector_ref(ptr, c, x, i) C_int_to_num(ptr, ((C_s32 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
+
+#define C_u_i_u8vector_set(x, i, v) ((((unsigned char *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ] = C_unfix(v)), C_SCHEME_UNDEFINED)
+#define C_u_i_s8vector_set(x, i, v) ((((char *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ] = C_unfix(v)), C_SCHEME_UNDEFINED)
+#define C_u_i_u16vector_set(x, i, v) ((((unsigned short *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ] = C_unfix(v)), C_SCHEME_UNDEFINED)
+#define C_u_i_s16vector_set(x, i, v) ((((short *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ] = C_unfix(v)), C_SCHEME_UNDEFINED)
+#define C_u_i_u32vector_set(x, i, v) ((((C_u32 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ] = C_num_to_unsigned_int(v)), C_SCHEME_UNDEFINED)
+#define C_u_i_s32vector_set(x, i, v) ((((C_s32 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ] = C_num_to_int(v)), C_SCHEME_UNDEFINED)
+
+#define C_u_i_bit_setp(x, i) C_mk_bool((C_unfix(x) & (1 << C_unfix(i))) != 0)
+
+#ifdef C_BIG_ENDIAN
+# ifdef C_SIXTY_FOUR
+# define C_lihdr(x, y, z) ((C_LAMBDA_INFO_TYPE >> 56) & 0xff), \
+ 0, 0, 0, 0, (x), (y), (z)
+# else
+# define C_lihdr(x, y, z) ((C_LAMBDA_INFO_TYPE >> 24) & 0xff), \
+ (x), (y), (z)
+# endif
+#else
+# ifdef C_SIXTY_FOUR
+# define C_lihdr(x, y, z) (z), (y), (x), 0, 0, 0, 0, \
+ ((C_LAMBDA_INFO_TYPE >> 56) & 0xff)
+# else
+# define C_lihdr(x, y, z) (z), (y), (x), \
+ ((C_LAMBDA_INFO_TYPE >> 24) & 0xff)
+# endif
+#endif
+
+#define C_end_of_main
+
+#if !defined(C_EMBEDDED) && !defined(C_SHARED)
+# ifndef C_WINDOWS_GUI
+# define C_main_entry_point int main(int argc, char *argv[]) { return CHICKEN_main(argc, argv, (void*)C_toplevel); } C_end_of_main
+# else
+# define C_main_entry_point \
+ int WINAPI WinMain(HINSTANCE me, HINSTANCE you, LPSTR cmdline, int show) \
+ { return CHICKEN_main(0, NULL, (void *)C_toplevel); } C_end_of_main
+# endif
+#else
+# define C_main_entry_point
+#endif
+
+
+/* Variables: */
+
+C_varextern C_TLS time_t C_startup_time_seconds;
+C_varextern C_TLS C_word
+ *C_temporary_stack,
+ *C_temporary_stack_bottom,
+ *C_stack_limit;
+C_varextern C_TLS long
+ C_timer_interrupt_counter,
+ C_initial_timer_interrupt_period;
+C_varextern C_TLS C_byte
+ *C_fromspace_top,
+ *C_fromspace_limit;
+C_varextern C_TLS double C_temporary_flonum;
+C_varextern C_TLS jmp_buf C_restart;
+C_varextern C_TLS void *C_restart_address;
+C_varextern C_TLS int C_entry_point_status;
+
+C_varextern C_TLS void (C_fcall *C_restart_trampoline)(void *proc) C_regparm C_noret;
+C_varextern C_TLS void (*C_pre_gc_hook)(int mode);
+C_varextern C_TLS void (*C_post_gc_hook)(int mode, long ms);
+C_varextern C_TLS void (*C_panic_hook)(C_char *msg);
+
+C_varextern C_TLS int
+ C_abort_on_thread_exceptions,
+ C_interrupts_enabled,
+ C_disable_overflow_check,
+ C_enable_gcweak,
+ C_heap_size_is_fixed,
+ C_max_pending_finalizers,
+ C_trace_buffer_size,
+ C_main_argc;
+C_varextern C_TLS C_uword
+ C_heap_growth,
+ C_heap_shrinkage;
+C_varextern C_TLS char
+ **C_main_argv,
+ *C_dlerror;
+C_varextern C_TLS C_uword C_maximal_heap_size;
+C_varextern C_TLS int (*C_gc_mutation_hook)(C_word *slot, C_word val);
+C_varextern C_TLS void (*C_gc_trace_hook)(C_word *var, int mode);
+C_varextern C_TLS C_word (*C_get_unbound_variable_value_hook)(C_word sym);
+
+
+/* Prototypes: */
+
+C_BEGIN_C_DECLS
+
+C_fctexport int CHICKEN_main(int argc, char *argv[], void *toplevel);
+C_fctexport int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel);
+C_fctexport C_word CHICKEN_run(void *toplevel);
+C_fctexport C_word CHICKEN_continue(C_word k);
+C_fctexport void *CHICKEN_new_gc_root();
+C_fctexport void *CHICKEN_new_finalizable_gc_root();
+C_fctexport void *CHICKEN_new_gc_root_2(int finalizable);
+C_fctexport void CHICKEN_delete_gc_root(void *root);
+C_fctexport void *CHICKEN_global_lookup(char *name);
+C_fctexport int CHICKEN_is_running();
+C_fctexport void CHICKEN_interrupt();
+
+C_fctexport void C_check_nursery_minimum(C_word size);
+C_fctexport int C_fcall C_save_callback_continuation(C_word **ptr, C_word k);
+C_fctexport C_word C_fcall C_restore_callback_continuation(void);
+C_fctexport C_word C_fcall C_restore_callback_continuation2(int level);
+C_fctexport C_word C_fcall C_callback(C_word closure, int argc);
+C_fctexport C_word C_fcall C_callback_wrapper(void *proc, int argc);
+C_fctexport void C_fcall C_callback_adjust_stack_limits(C_word *base); /* DEPRECATED */
+C_fctexport void C_fcall C_callback_adjust_stack(C_word *base, int size);
+C_fctexport void CHICKEN_parse_command_line(int argc, char *argv[], C_word *heap, C_word *stack, C_word *symbols);
+C_fctexport void C_fcall C_toplevel_entry(C_char *name) C_regparm;
+C_fctexport C_word C_fcall C_enable_interrupts(void) C_regparm;
+C_fctexport C_word C_fcall C_disable_interrupts(void) C_regparm;
+C_fctexport void C_fcall C_paranoid_check_for_interrupt(void) C_regparm;
+C_fctexport double C_fcall C_c_double(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_num_to_int(C_word x) C_regparm;
+C_fctexport C_s64 C_fcall C_num_to_int64(C_word x) C_regparm;
+C_fctexport C_uword C_fcall C_num_to_unsigned_int(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_int_to_num(C_word **ptr, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_unsigned_int_to_num(C_word **ptr, C_uword n) C_regparm;
+C_fctexport C_word C_fcall C_long_to_num(C_word **ptr, long n) C_regparm;
+C_fctexport C_word C_fcall C_unsigned_long_to_num(C_word **ptr, unsigned long n) C_regparm;
+C_fctexport long C_fcall C_num_to_long(C_word x) C_regparm;
+C_fctexport unsigned long C_fcall C_num_to_unsigned_long(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_flonum_in_int_range_p(C_word n) C_regparm;
+C_fctexport C_word C_fcall C_flonum_in_uint_range_p(C_word n) C_regparm;
+C_fctexport C_word C_fcall C_double_to_number(C_word n) C_regparm;
+C_fctexport char *C_fcall C_string_or_null(C_word x) C_regparm;
+C_fctexport void *C_fcall C_data_pointer_or_null(C_word x) C_regparm;
+C_fctexport void *C_fcall C_srfi_4_vector_or_null(C_word x) C_regparm;
+C_fctexport void *C_fcall C_c_pointer_or_null(C_word x) C_regparm;
+C_fctexport void *C_fcall C_scheme_or_c_pointer(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_flonum_in_fixnum_range_p(C_word n) C_regparm;
+C_fctexport void C_zap_strings(C_word str);
+C_fctexport void C_set_or_change_heap_size(C_word heap, int reintern);
+C_fctexport void C_do_resize_stack(C_word stack);
+C_fctexport C_word C_resize_pending_finalizers(C_word size);
+C_fctexport void C_initialize_lf(C_word *lf, int count);
+C_fctexport void *C_register_lf(C_word *lf, int count);
+C_fctexport void *C_register_lf2(C_word *lf, int count, C_PTABLE_ENTRY *ptable);
+C_fctexport void C_unregister_lf(void *handle);
+C_fctexport C_char *C_dump_trace(int start);
+C_fctexport void C_fcall C_clear_trace_buffer(void) C_regparm;
+C_fctexport C_word C_fetch_trace(C_word start, C_word buffer);
+C_fctexport C_word C_fcall C_string(C_word **ptr, int len, C_char *str) C_regparm;
+C_fctexport C_word C_fcall C_static_string(C_word **ptr, int len, C_char *str) C_regparm;
+C_fctexport C_word C_fcall C_static_lambda_info(C_word **ptr, int len, C_char *str) C_regparm;
+C_fctexport C_word C_fcall C_bytevector(C_word **ptr, int len, C_char *str) C_regparm;
+C_fctexport C_word C_fcall C_pbytevector(int len, C_char *str) C_regparm;
+C_fctexport C_word C_fcall C_string_aligned8(C_word **ptr, int len, C_char *str) C_regparm;
+C_fctexport C_word C_fcall C_string2(C_word **ptr, C_char *str) C_regparm;
+C_fctexport C_word C_fcall C_string2_safe(C_word **ptr, int max, C_char *str) C_regparm;
+C_fctexport C_word C_fcall C_intern(C_word **ptr, int len, C_char *str) C_regparm;
+C_fctexport C_word C_fcall C_intern_in(C_word **ptr, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
+C_fctexport C_word C_fcall C_h_intern(C_word *slot, int len, C_char *str) C_regparm;
+C_fctexport C_word C_fcall C_h_intern_in(C_word *slot, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
+C_fctexport C_word C_fcall C_intern2(C_word **ptr, C_char *str) C_regparm;
+C_fctexport C_word C_fcall C_intern3(C_word **ptr, C_char *str, C_word value) C_regparm;
+C_fctexport C_word C_fcall C_restore_rest(C_word *ptr, int num) C_regparm;
+C_fctexport C_word C_fcall C_restore_rest_vector(C_word *ptr, int num) C_regparm;
+C_fctexport void C_bad_memory(void) C_noret;
+C_fctexport void C_bad_memory_2(void) C_noret;
+C_fctexport void C_bad_argc(int c, int n) C_noret;
+C_fctexport void C_bad_min_argc(int c, int n) C_noret;
+C_fctexport void C_bad_argc_2(int c, int n, C_word closure) C_noret;
+C_fctexport void C_bad_min_argc_2(int c, int n, C_word closure) C_noret;
+C_fctexport void C_stack_overflow(void) C_noret;
+C_fctexport void C_unbound_error(C_word sym) C_noret;
+C_fctexport void C_no_closure_error(C_word x) C_noret;
+C_fctexport C_word C_closure(C_word **ptr, int cells, C_word proc, ...);
+C_fctexport C_word C_fcall C_pair(C_word **ptr, C_word car, C_word cdr) C_regparm;
+C_fctexport C_word C_fcall C_h_pair(C_word car, C_word cdr) C_regparm;
+C_fctexport C_word C_fcall C_flonum(C_word **ptr, double n) C_regparm;
+C_fctexport C_word C_fcall C_number(C_word **ptr, double n) C_regparm;
+C_fctexport C_word C_fcall C_mpointer(C_word **ptr, void *mp) C_regparm;
+C_fctexport C_word C_fcall C_mpointer_or_false(C_word **ptr, void *mp) C_regparm;
+C_fctexport C_word C_fcall C_mpointer(C_word **ptr, void *mp) C_regparm;
+C_fctexport C_word C_fcall C_mpointer_or_false(C_word **ptr, void *mp) C_regparm;
+C_fctexport C_word C_fcall C_taggedmpointer(C_word **ptr, C_word tag, void *mp) C_regparm;
+C_fctexport C_word C_fcall C_taggedmpointer_or_false(C_word **ptr, C_word tag, void *mp) C_regparm;
+C_fctexport C_word C_fcall C_swigmpointer(C_word **ptr, void *mp, void *sdata) C_regparm;
+C_fctexport C_word C_vector(C_word **ptr, int n, ...);
+C_fctexport C_word C_h_vector(int n, ...);
+C_fctexport C_word C_structure(C_word **ptr, int n, ...);
+C_fctexport C_word C_h_structure(int n, ...);
+C_fctexport C_word C_fcall C_mutate(C_word *slot, C_word val) C_regparm;
+C_fctexport void C_fcall C_reclaim(void *trampoline, void *proc) C_regparm C_noret;
+C_fctexport void C_save_and_reclaim(void *trampoline, void *proc, int n, ...) C_noret;
+C_fctexport void C_fcall C_rereclaim(long size) C_regparm; /* deprecated */
+C_fctexport void C_fcall C_rereclaim2(C_uword size, int double_plus) C_regparm;
+C_fctexport C_word C_fcall C_retrieve(C_word sym) C_regparm;
+C_fctexport C_word C_fcall C_retrieve2(C_word val, char *name) C_regparm;
+C_fctexport void *C_fcall C_retrieve_proc(C_word closure) C_regparm;
+C_fctexport void *C_fcall C_retrieve_symbol_proc(C_word sym) C_regparm;
+C_fctexport void *C_fcall C_retrieve2_symbol_proc(C_word val, char *name) C_regparm;
+C_fctexport C_word C_fcall C_permanentp(C_word x) C_regparm;
+C_fctexport int C_in_stackp(C_word x) C_regparm;
+C_fctexport int C_fcall C_in_heapp(C_word x) C_regparm;
+C_fctexport int C_fcall C_in_fromspacep(C_word x) C_regparm;
+C_fctexport void C_fcall C_trace(C_char *name) C_regparm;
+C_fctexport C_word C_fcall C_emit_trace_info(C_word x, C_word y, C_word t) C_regparm;
+C_fctexport C_word C_fcall C_emit_trace_info2(char *raw, C_word x, C_word y, C_word t) C_regparm;
+C_fctexport C_word C_fcall C_hash_string(C_word str) C_regparm;
+C_fctexport C_word C_fcall C_hash_string_ci(C_word str) C_regparm;
+C_fctexport C_word C_halt(C_word msg);
+C_fctexport C_word C_message(C_word msg);
+C_fctexport C_word C_fcall C_equalp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_set_gc_report(C_word flag) C_regparm;
+C_fctexport C_word C_fcall C_start_timer(void) C_regparm;
+C_fctexport C_word C_exit_runtime(C_word code);
+C_fctexport C_word C_fcall C_display_flonum(C_word port, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_set_print_precision(C_word n) C_regparm;
+C_fctexport C_word C_fcall C_get_print_precision(void) C_regparm;
+C_fctexport C_word C_fcall C_read_char(C_word port) C_regparm;
+C_fctexport C_word C_fcall C_peek_char(C_word port) C_regparm;
+C_fctexport C_word C_fcall C_execute_shell_command(C_word string) C_regparm;
+C_fctexport C_word C_fcall C_char_ready_p(C_word port) C_regparm;
+C_fctexport C_word C_fcall C_flush_output(C_word port) C_regparm;
+C_fctexport C_word C_fcall C_fudge(C_word fudge_factor) C_regparm;
+C_fctexport void C_fcall C_raise_interrupt(int reason) C_regparm;
+C_fctexport C_word C_fcall C_set_initial_timer_interrupt_period(C_word n) C_regparm;
+C_fctexport C_word C_fcall C_establish_signal_handler(C_word signum, C_word reason) C_regparm;
+C_fctexport C_word C_fcall C_fits_in_int_p(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_fits_in_unsigned_int_p(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_copy_block(C_word from, C_word to) C_regparm;
+C_fctexport C_word C_fcall C_evict_block(C_word from, C_word ptr) C_regparm;
+C_fctexport void C_fcall C_gc_protect(C_word **addr, int n) C_regparm;
+C_fctexport void C_fcall C_gc_unprotect(int n) C_regparm;
+C_fctexport C_SYMBOL_TABLE *C_new_symbol_table(char *name, unsigned int size) C_regparm;
+C_fctexport void C_delete_symbol_table(C_SYMBOL_TABLE *st) C_regparm;
+C_fctexport void C_set_symbol_table(C_SYMBOL_TABLE *st) C_regparm;
+C_fctexport C_SYMBOL_TABLE *C_find_symbol_table(char *name) C_regparm;
+C_fctexport C_word C_find_symbol(C_word str, C_SYMBOL_TABLE *stable) C_regparm;
+C_fctexport C_word C_fcall C_lookup_symbol(C_word sym) C_regparm;
+C_fctexport C_word C_enumerate_symbols(C_SYMBOL_TABLE *stable, C_word pos) C_regparm;
+C_fctexport void C_do_register_finalizer(C_word x, C_word proc);
+C_fctexport int C_do_unregister_finalizer(C_word x);
+C_fctexport C_word C_dbg_hook(C_word x);
+
+C_fctimport void C_ccall C_toplevel(C_word c, C_word self, C_word k) C_noret;
+C_fctexport void C_ccall C_stop_timer(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_apply(C_word c, C_word closure, C_word k, C_word fn, ...) C_noret;
+C_fctexport void C_ccall C_do_apply(C_word n, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_call_cc(C_word c, C_word closure, C_word k, C_word cont) C_noret;
+C_fctexport void C_ccall C_continuation_graft(C_word c, C_word closure, C_word k, C_word kk, C_word proc) C_noret;
+C_fctexport void C_ccall C_values(C_word c, C_word closure, C_word k, ...) C_noret;
+C_fctexport void C_ccall C_apply_values(C_word c, C_word closure, C_word k, C_word lst) C_noret;
+C_fctexport void C_ccall C_call_with_values(C_word c, C_word closure, C_word k, C_word thunk, C_word kont) C_noret;
+C_fctexport void C_ccall C_u_call_with_values(C_word c, C_word closure, C_word k, C_word thunk, C_word kont) C_noret;
+C_fctexport void C_ccall C_times(C_word c, C_word closure, C_word k, ...) C_noret;
+C_fctexport void C_ccall C_plus(C_word c, C_word closure, C_word k, ...) C_noret;
+C_fctexport void C_ccall C_minus(C_word c, C_word closure, C_word k, C_word n1, ...) C_noret;
+C_fctexport void C_ccall C_divide(C_word c, C_word closure, C_word k, C_word n1, ...) C_noret;
+C_fctexport void C_ccall C_nequalp(C_word c, C_word closure, C_word k, ...) C_noret;
+C_fctexport void C_ccall C_greaterp(C_word c, C_word closure, C_word k, ...) C_noret;
+C_fctexport void C_ccall C_lessp(C_word c, C_word closure, C_word k, ...) C_noret;
+C_fctexport void C_ccall C_greater_or_equal_p(C_word c, C_word closure, C_word k, ...) C_noret;
+C_fctexport void C_ccall C_less_or_equal_p(C_word c, C_word closure, C_word k, ...) C_noret;
+C_fctexport void C_ccall C_expt(C_word c, C_word closure, C_word k, C_word n1, C_word n2) C_noret;
+C_fctexport void C_ccall C_gc(C_word c, C_word closure, C_word k, ...) C_noret;
+C_fctexport void C_ccall C_open_file_port(C_word c, C_word closure, C_word k, C_word port, C_word channel, C_word mode) C_noret;
+C_fctexport void C_ccall C_allocate_vector(C_word c, C_word closure, C_word k, C_word size, C_word type, C_word init, C_word align8) C_noret;
+C_fctexport void C_ccall C_string_to_symbol(C_word c, C_word closure, C_word k, C_word string) C_noret;
+C_fctexport void C_ccall C_build_symbol(C_word c, C_word closure, C_word k, C_word string) C_noret;
+C_fctexport void C_ccall C_cons_flonum(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_flonum_fraction(C_word c, C_word closure, C_word k, C_word n) C_noret;
+C_fctexport void C_ccall C_exact_to_inexact(C_word c, C_word closure, C_word k, C_word n) C_noret;
+C_fctexport void C_ccall C_flonum_floor(C_word c, C_word closure, C_word k, C_word n) C_noret;
+C_fctexport void C_ccall C_flonum_ceiling(C_word c, C_word closure, C_word k, C_word n) C_noret;
+C_fctexport void C_ccall C_flonum_truncate(C_word c, C_word closure, C_word k, C_word n) C_noret;
+C_fctexport void C_ccall C_flonum_round(C_word c, C_word closure, C_word k, C_word n) C_noret;
+C_fctexport void C_ccall C_quotient(C_word c, C_word closure, C_word k, C_word n1, C_word n2) C_noret;
+C_fctexport void C_ccall C_string_to_number(C_word c, C_word closure, C_word k, C_word str, ...) C_noret;
+C_fctexport void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num, ...) C_noret;
+C_fctexport void C_ccall C_get_argv(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_make_structure(C_word c, C_word closure, C_word k, C_word type, ...) C_noret;
+C_fctexport void C_ccall C_make_symbol(C_word c, C_word closure, C_word k, C_word name) C_noret;
+C_fctexport void C_ccall C_make_pointer(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_make_tagged_pointer(C_word c, C_word closure, C_word k, C_word tag) C_noret;
+C_fctexport void C_ccall C_ensure_heap_reserve(C_word c, C_word closure, C_word k, C_word n) C_noret;
+C_fctexport void C_ccall C_return_to_host(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_file_info(C_word c, C_word closure, C_word k, C_word port) C_noret;
+C_fctexport void C_ccall C_get_environment_variable(C_word c, C_word closure, C_word k, C_word name) C_noret;
+C_fctexport void C_ccall C_get_symbol_table_info(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_get_memory_info(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_context_switch(C_word c, C_word closure, C_word k, C_word state) C_noret;
+C_fctexport void C_ccall C_peek_signed_integer(C_word c, C_word closure, C_word k, C_word v, C_word index) C_noret;
+C_fctexport void C_ccall C_peek_unsigned_integer(C_word c, C_word closure, C_word k, C_word v, C_word index) C_noret;
+C_fctexport void C_ccall C_decode_seconds(C_word c, C_word closure, C_word k, C_word secs, C_word mode) C_noret;
+C_fctexport void C_ccall C_software_type(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_machine_type(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_machine_byte_order(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_software_version(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_build_platform(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_c_runtime(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_register_finalizer(C_word c, C_word closure, C_word k, C_word x, C_word proc) C_noret;
+C_fctexport void C_ccall C_dlopen_flags(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_set_dlopen_flags(C_word c, C_word closure, C_word k, C_word now, C_word global) C_noret;
+C_fctexport void C_ccall C_dload(C_word c, C_word closure, C_word k, C_word name, C_word entry, C_word reloadable) C_noret;
+C_fctexport void C_ccall C_become(C_word c, C_word closure, C_word k, C_word table) C_noret;
+C_fctexport void C_ccall C_cpu_time(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_locative_ref(C_word c, C_word closure, C_word k, C_word loc) C_noret;
+C_fctexport void C_ccall C_call_with_cthulhu(C_word c, C_word self, C_word k, C_word proc) C_noret;
+C_fctexport void C_ccall C_copy_closure(C_word c, C_word closure, C_word k, C_word proc) C_noret;
+
+C_fctexport void C_ccall C_dynamic_library_names(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_dynamic_library_data(C_word c, C_word closure, C_word k, C_word libnam) C_noret;
+C_fctexport void C_ccall C_chicken_library_literal_frame(C_word c, C_word closure, C_word k, C_word lfnam, C_word lfhnd, C_word lfcnt) C_noret;
+C_fctexport void C_ccall C_chicken_library_ptable(C_word c, C_word closure, C_word k, C_word lfnam, C_word lfhnd, C_word lfcnt, C_word inclptrs) C_noret;
+
+C_fctexport void C_ccall C_dynamic_library_load(C_word c, C_word closure, C_word k, C_word name) C_noret;
+C_fctexport void C_ccall C_dynamic_library_symbol(C_word c, C_word closure, C_word k, C_word mname, C_word sname, C_word isprcsym) C_noret;
+C_fctexport void C_ccall C_dynamic_library_unload(C_word c, C_word closure, C_word k, C_word name) C_noret;
+
+#if !defined(__GNUC__) && !defined(__INTEL_COMPILER)
+C_fctexport C_word *C_a_i(C_word **a, int n);
+#endif
+
+C_fctexport time_t C_fcall C_seconds(long *ms) C_regparm;
+C_fctexport C_word C_a_i_list(C_word **a, int c, ...);
+C_fctexport C_word C_h_list(int c, ...);
+C_fctexport C_word C_a_i_string(C_word **a, int c, ...);
+C_fctexport C_word C_a_i_record(C_word **a, int c, ...);
+C_fctexport C_word C_a_i_port(C_word **a, int c);
+C_fctexport C_word C_fcall C_a_i_bytevector(C_word **a, int c, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_eqvp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_symbolp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_pairp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_vectorp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_closurep(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_portp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_stringp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_numberp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_rationalp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_integerp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_flonump(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_finitep(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_locativep(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_fixnum_min(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_fixnum_max(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_flonum_min(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_flonum_max(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_a_i_abs(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_i_listp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_string_equal_p(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_string_ci_equal_p(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_u_i_string_equal_p(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_set_car(C_word p, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_set_cdr(C_word p, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_exactp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_u_i_exactp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_inexactp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_u_i_inexactp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_zerop(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_u_i_zerop(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_positivep(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_u_i_positivep(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_negativep(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_u_i_negativep(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_car(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_cdr(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_cadr(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_cddr(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_caddr(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_cdddr(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_cadddr(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_cddddr(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_list_tail(C_word lst, C_word i) C_regparm;
+C_fctexport C_word C_fcall C_i_evenp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_u_i_evenp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_oddp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_u_i_oddp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_vector_ref(C_word v, C_word i) C_regparm;
+C_fctexport C_word C_fcall C_i_block_ref(C_word x, C_word i) C_regparm;
+C_fctexport C_word C_fcall C_i_string_set(C_word s, C_word i, C_word c) C_regparm;
+C_fctexport C_word C_fcall C_i_string_ref(C_word s, C_word i) C_regparm;
+C_fctexport C_word C_fcall C_i_vector_length(C_word v) C_regparm;
+C_fctexport C_word C_fcall C_i_string_length(C_word s) C_regparm;
+C_fctexport C_word C_fcall C_i_assq(C_word x, C_word lst) C_regparm;
+C_fctexport C_word C_fcall C_u_i_assq(C_word x, C_word lst) C_regparm;
+C_fctexport C_word C_fcall C_i_assv(C_word x, C_word lst) C_regparm;
+C_fctexport C_word C_fcall C_i_assoc(C_word x, C_word lst) C_regparm;
+C_fctexport C_word C_fcall C_i_memq(C_word x, C_word lst) C_regparm;
+C_fctexport C_word C_fcall C_u_i_memq(C_word x, C_word lst) C_regparm;
+C_fctexport C_word C_fcall C_i_memv(C_word x, C_word lst) C_regparm;
+C_fctexport C_word C_fcall C_i_member(C_word x, C_word lst) C_regparm;
+C_fctexport C_word C_fcall C_i_length(C_word lst) C_regparm;
+C_fctexport C_word C_fcall C_u_i_length(C_word lst) C_regparm;
+C_fctexport C_word C_fcall C_i_inexact_to_exact(C_word n) C_regparm;
+C_fctexport C_word C_fcall C_i_check_closure_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_fcall C_i_check_exact_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_fcall C_i_check_inexact_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_fcall C_i_check_number_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_fcall C_i_check_string_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_fcall C_i_check_bytevector_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_fcall C_i_check_symbol_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_fcall C_i_check_list_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_fcall C_i_check_pair_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_fcall C_i_check_vector_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_fcall C_i_check_structure_2(C_word x, C_word st, C_word loc) C_regparm;
+C_fctexport C_word C_fcall C_i_check_char_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_fcall C_2_times(C_word **ptr, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_2_plus(C_word **ptr, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_2_minus(C_word **ptr, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_2_divide(C_word **ptr, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_nequalp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_greaterp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_lessp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_greater_or_equalp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_less_or_equalp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_not_pair_p_2(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_null_list_p(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_string_null_p(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_string_to_pbytevector(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_null_pointerp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_fixnum_arithmetic_shift(C_word n, C_word c) C_regparm;
+C_fctexport C_word C_fcall C_i_locative_set(C_word loc, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_locative_to_object(C_word loc) C_regparm;
+C_fctexport C_word C_fcall C_a_i_make_locative(C_word **a, int c, C_word type, C_word object, C_word index, C_word weak) C_regparm;
+C_fctexport C_word C_fcall C_a_i_flonum_plus(C_word **a, int c, C_word n1, C_word n2) C_regparm;
+C_fctexport C_word C_fcall C_a_i_flonum_difference(C_word **a, int c, C_word n1, C_word n2) C_regparm;
+C_fctexport C_word C_fcall C_a_i_flonum_times(C_word **a, int c, C_word n1, C_word n2) C_regparm;
+C_fctexport C_word C_fcall C_a_i_flonum_quotient(C_word **a, int c, C_word n1, C_word n2) C_regparm;
+C_fctexport C_word C_fcall C_a_i_flonum_negate(C_word **a, int c, C_word n1) C_regparm;
+C_fctexport C_word C_fcall C_a_i_bitwise_and(C_word **a, int c, C_word n1, C_word n2) C_regparm;
+C_fctexport C_word C_fcall C_a_i_bitwise_ior(C_word **a, int c, C_word n1, C_word n2) C_regparm;
+C_fctexport C_word C_fcall C_a_i_bitwise_not(C_word **a, int c, C_word n1) C_regparm;
+C_fctexport C_word C_fcall C_i_bit_setp(C_word n, C_word i) C_regparm;
+C_fctexport C_word C_fcall C_a_i_bitwise_xor(C_word **a, int c, C_word n1, C_word n2) C_regparm;
+C_fctexport C_word C_fcall C_a_i_arithmetic_shift(C_word **a, int c, C_word n1, C_word n2) C_regparm;
+C_fctexport C_word C_fcall C_a_i_exp(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_a_i_log(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_a_i_sin(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_a_i_cos(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_a_i_tan(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_a_i_asin(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_a_i_acos(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_a_i_atan(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2) C_regparm;
+C_fctexport C_word C_fcall C_a_i_sqrt(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_fcall C_i_o_fixnum_plus(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_o_fixnum_difference(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_o_fixnum_and(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_o_fixnum_ior(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_fcall C_i_o_fixnum_xor(C_word x, C_word y) C_regparm;
+
+C_fctexport C_word C_fcall C_i_foreign_char_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_foreign_fixnum_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_foreign_flonum_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_foreign_block_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_foreign_number_vector_argumentp(C_word t, C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_foreign_string_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_foreign_symbol_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t) C_regparm;
+C_fctexport C_word C_fcall C_i_foreign_pointer_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_foreign_scheme_or_c_pointer_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_foreign_integer_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x) C_regparm;
+
+C_fctexport void * C_fcall C_dynamic_library_open(C_char *name) C_regparm;
+C_fctexport void * C_fcall C_dynamic_library_procedure(void *handle, C_char *name) C_regparm;
+C_fctexport void * C_fcall C_dynamic_library_procedure_exact(void *handle, C_char *name) C_regparm;
+C_fctexport void * C_fcall C_dynamic_library_variable(void *handle, C_char *name) C_regparm;
+C_fctexport void * C_fcall C_dynamic_library_variable_exact(void *handle, C_char *name) C_regparm;
+C_fctexport int C_fcall C_dynamic_library_close(void *handle) C_regparm;
+
+C_fctexport C_char * C_lookup_procedure_id(void *ptr);
+C_fctexport void * C_lookup_procedure_ptr(C_char *id);
+C_fctexport C_word C_ccall C_dunload(C_word name);
+
+#ifdef C_SIXTY_FOUR
+C_fctexport void C_ccall C_peek_signed_integer_32(C_word c, C_word closure, C_word k, C_word v, C_word index) C_noret;
+C_fctexport void C_ccall C_peek_unsigned_integer_32(C_word c, C_word closure, C_word k, C_word v, C_word index) C_noret;
+#else
+# define C_peek_signed_integer_32 C_peek_signed_integer
+# define C_peek_unsigned_integer_32 C_peek_unsigned_integer
+#endif
+
+C_fctexport C_word C_fcall C_decode_literal(C_word **ptr, C_char *str) C_regparm;
+
+/* defined in eval.scm: */
+C_fctexport void CHICKEN_get_error_message(char *buf,int bufsize);
+C_fctexport int CHICKEN_load(char * filename);
+C_fctexport int CHICKEN_read(char * str,C_word *result);
+C_fctexport int CHICKEN_apply_to_string(C_word func,C_word args,char *buf,int bufsize);
+C_fctexport int CHICKEN_apply(C_word func,C_word args,C_word *result);
+C_fctexport int CHICKEN_eval_string_to_string(char *str,char *buf,int bufsize);
+C_fctexport int CHICKEN_eval_to_string(C_word exp,char *buf,int bufsize);
+C_fctexport int CHICKEN_eval_string(char * str,C_word *result);
+C_fctexport int CHICKEN_eval(C_word exp,C_word *result);
+C_fctexport int CHICKEN_yield();
+
+C_fctexport void C_default_stub_toplevel(C_word c,C_word d,C_word k) C_noret;
+
+C_END_C_DECLS
+
+#endif /* ___CHICKEN */
diff --git a/chicken.ico b/chicken.ico
new file mode 100644
index 00000000..ba5111b6
Binary files /dev/null and b/chicken.ico differ
diff --git a/chicken.import.scm b/chicken.import.scm
new file mode 100644
index 00000000..9db915a9
--- /dev/null
+++ b/chicken.import.scm
@@ -0,0 +1,216 @@
+;;;; chicken.import.scm - import library for "chicken" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'chicken
+ '(abort
+ add1
+ argc+argv
+ argv
+ arithmetic-shift
+ bit-set?
+ bitwise-and
+ bitwise-ior
+ bitwise-not
+ bitwise-xor
+ blob->string
+ blob-size
+ blob?
+ blob=?
+ breakpoint
+ build-platform
+ c-runtime
+ call/cc
+ case-sensitive
+ char-name
+ chicken-home
+ chicken-version
+ command-line-arguments
+ condition-predicate
+ condition-property-accessor
+ condition?
+ continuation-capture
+ continuation-graft
+ continuation-return
+ continuation?
+ copy-read-table
+ cpu-time
+ current-error-port
+ current-exception-handler
+ current-gc-milliseconds
+ current-milliseconds
+ current-read-table
+ current-seconds
+ define-reader-ctor
+ delete-file
+ enable-warnings
+ errno
+ error
+ exit
+ exit-handler
+ expand
+ extension-information
+ feature?
+ features
+ file-exists?
+ directory-exists?
+ fixnum-bits
+ fixnum-precision
+ fixnum?
+ flonum-decimal-precision
+ flonum-epsilon
+ flonum-maximum-decimal-exponent
+ flonum-maximum-exponent
+ flonum-minimum-decimal-exponent
+ flonum-minimum-exponent
+ flonum-precision
+ flonum-print-precision
+ flonum-radix
+ flonum?
+ flush-output
+ force-finalizers
+ fp-
+ fp*
+ fp/
+ fp+
+ fp<
+ fp<=
+ fp=
+ fp>
+ fp>=
+ fpmax
+ fpmin
+ fpneg
+ fx-
+ fx*
+ fx/
+ fx+
+ fx<
+ fx<=
+ fx=
+ fx>
+ fx>=
+ fxand
+ fxior
+ fxmax
+ fxmin
+ fxmod
+ fxneg
+ fxnot
+ fxshl
+ fxshr
+ fxxor
+ gc
+ gensym
+ get
+ get-call-chain
+ get-condition-property
+ get-environment-variable
+ get-keyword
+ get-output-string
+ get-properties
+ getenv ; DEPRECATED
+ getter-with-setter
+ implicit-exit-handler
+ keyword->string
+ keyword-style
+ keyword?
+ load-library
+ load-relative
+ load-verbose
+ machine-byte-order
+ machine-type
+ make-blob
+ make-composite-condition
+ make-parameter
+ make-property-condition
+ maximum-flonum
+ memory-statistics
+ minimum-flonum
+ most-negative-fixnum
+ most-positive-fixnum
+ on-exit
+ open-input-string
+ open-output-string
+ parentheses-synonyms
+ port-name
+ port-position
+ port?
+ print
+ print-call-chain
+ print-error-message
+ print*
+ procedure-information
+ program-name
+ promise?
+ put!
+ register-feature!
+ remprop!
+ rename-file
+ repl
+ repl-prompt
+ repository-path
+ require
+ reset
+ reset-handler
+ return-to-host
+ reverse-list->string
+ set-finalizer!
+ set-gc-report!
+ set-parameterized-read-syntax!
+ set-port-name!
+ set-read-syntax!
+ set-sharp-read-syntax!
+ setter
+ signal
+ signum
+ singlestep
+ software-type
+ software-version
+ string->blob
+ string->keyword
+ string->uninterned-symbol
+ strip-syntax
+ sub1
+ symbol-escape
+ symbol-plist
+ syntax-error
+ system
+ unregister-feature!
+ vector-resize
+ void
+ warning
+ eval-handler
+ er-macro-transformer
+ set-dynamic-load-mode! ;DEPRECATED
+ dynamic-load-mode
+ dynamic-load-libraries
+ loaded-libraries
+ dynamic-library-load
+ dynamic-library-procedure
+ dynamic-library-variable
+ with-exception-handler)
+ ##sys#chicken-macro-environment) ;*** incorrect - won't work in compiled executable that does expansion
diff --git a/chicken.rc b/chicken.rc
new file mode 100644
index 00000000..e0cbdb0e
--- /dev/null
+++ b/chicken.rc
@@ -0,0 +1,3 @@
+/* chicken.rc - Resource script for Windoze - felix */
+
+CHICKEN_ICON ICON "chicken.ico"
diff --git a/chicken.scm b/chicken.scm
new file mode 100644
index 00000000..9b2afd93
--- /dev/null
+++ b/chicken.scm
@@ -0,0 +1,124 @@
+;;;; chicken.scm - The CHICKEN Scheme compiler (loader/main-module)
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (uses chicken-syntax srfi-1 srfi-4 utils files extras data-structures support
+ compiler optimizer compiler-syntax scrutinizer driver platform backend
+ srfi-69)
+ (compile-syntax) )
+
+
+(include "compiler-namespace")
+(include "tweaks")
+
+(eval-when (load)
+ (include "chicken-ffi-syntax") )
+
+
+;;; Prefix argument list with default options:
+
+(define compiler-arguments
+ (append
+ (remove
+ (lambda (x) (string=? x ""))
+ (string-split (or (get-environment-variable "CHICKEN_OPTIONS") "")))
+ (cdr (argv))))
+
+
+;;; Process command-line options:
+;
+; - remove runtime-options ("-:...")
+; - filter out source-filename
+; - convert options into symbols (without the initial hyphens)
+
+(define (process-command-line args)
+ (let loop ([args args] [options '()] [filename #f])
+ (if (null? args)
+ (values filename (reverse options))
+ (let* ([arg (car args)]
+ [len (string-length arg)]
+ [char0 (string-ref arg 0)] )
+ (if (and (char=? #\- char0) (> len 1))
+ (if (and (> len 1) (char=? #\: (string-ref arg 1)))
+ (loop (cdr args) options filename)
+ (loop (cdr args) (cons (string->symbol (substring arg 1 len)) options) filename) )
+ (if filename
+ (loop (cdr args) (cons arg options) filename)
+ (loop (cdr args) options arg) ) ) ) ) ) )
+
+
+;;; Run compiler with command-line options:
+
+(receive (filename options) ((or (user-options-pass) process-command-line) compiler-arguments)
+ (let loop ([os options])
+ (unless (null? os)
+ (let ([o (car os)]
+ [rest (cdr os)] )
+ (cond [(eq? 'optimize-level o)
+ (let ([level (string->number (car rest))])
+ (case level
+ [(0) #f]
+ [(1)
+ (set! options (cons 'optimize-leaf-routines options)) ]
+ [(2)
+ (set! options
+ (cons* 'optimize-leaf-routines 'inline options)) ]
+ [(3)
+ (set! options
+ (cons* 'optimize-leaf-routines 'inline 'local options) ) ]
+ [(4)
+ (set! options
+ (cons* 'optimize-leaf-routines 'inline 'local 'unsafe options) ) ]
+ [else (compiler-warning 'usage "invalid optimization level ~S - ignored" (car rest))] )
+ (loop (cdr rest)) ) ]
+ [(eq? 'debug-level o)
+ (let ([level (string->number (car rest))])
+ (case level
+ [(0) (set! options (cons* 'no-lambda-info 'no-trace options))]
+ [(1) (set! options (cons 'no-trace options))]
+ [(2) #f]
+ [else (compiler-warning 'usage "invalid debug level ~S - ignored" (car rest))] )
+ (loop (cdr rest)) ) ]
+ [(eq? 'benchmark-mode o)
+ (set! options
+ (cons* 'fixnum-arithmetic 'disable-interrupts 'no-trace 'unsafe
+ 'optimize-leaf-routines 'block 'lambda-lift 'no-lambda-info
+ 'inline
+ options) )
+ (loop rest) ]
+ [(memq o valid-compiler-options) (loop rest)]
+ [(memq o valid-compiler-options-with-argument)
+ (if (pair? rest)
+ (loop (cdr rest))
+ (quit "missing argument to `-~s' option" o) ) ]
+ [else
+ (compiler-warning
+ 'usage "invalid compiler option `~a' - ignored"
+ (if (string? o) o (conc "-" o)) )
+ (loop rest) ] ) ) ) )
+ (apply compile-source-file filename options)
+ (exit) )
diff --git a/compiler-namespace.scm b/compiler-namespace.scm
new file mode 100644
index 00000000..5945ea16
--- /dev/null
+++ b/compiler-namespace.scm
@@ -0,0 +1,299 @@
+;;;; compiler-namespace.scm - private namespace declarations for compiler units
+;
+; Copyright (c) 2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(private
+ compiler
+ analyze-expression
+ all-import-libraries
+ banner
+ basic-literal?
+ big-fixnum?
+ block-compilation
+ block-variable-literal-name
+ block-variable-literal?
+ bomb
+ broken-constant-nodes
+ build-expression-tree
+ build-lambda-list
+ build-node-graph
+ c-ify-string
+ callback-names
+ canonicalize-begin-body
+ canonicalize-expression
+ check-and-open-input-file
+ check-signature
+ chop-extension
+ chop-separator
+ cleanup
+ close-checked-input-file
+ collapsable-literal?
+ collect!
+ compile-format-string
+ compiler-arguments
+ compiler-cleanup-hook
+ compiler-source-file
+ compiler-syntax-enabled
+ compiler-syntax-statistics
+ compiler-warning
+ compute-database-statistics
+ constant-declarations
+ constant-table
+ constant?
+ constants-used
+ copy-node!
+ copy-node-tree-and-rename
+ count!
+ create-foreign-stub
+ csc-control-file
+ current-program-size
+ data-declarations
+ debug-info-index
+ debug-info-vector-name
+ debug-lambda-list
+ debug-variable-list
+ debugging
+ debugging-chicken
+ debugging-executable
+ decompose-lambda-list
+ default-debugging-declarations
+ default-declarations
+ default-default-target-heap-size
+ default-default-target-stack-size
+ default-extended-bindings
+ default-optimization-iterations
+ default-optimization-passes
+ default-optimization-passes-when-trying-harder
+ default-output-filename
+ default-profiling-declarations
+ default-standard-bindings
+ defconstant-bindings
+ dependency-list
+ direct-call-ids
+ disable-stack-overflow-checking
+ disabled-warnings
+ display-analysis-database
+ display-line-number-database
+ display-real-name-table
+ do-lambda-lifting
+ do-scrutinize
+ dump-defined-globals
+ dump-global-refs
+ dump-nodes
+ dump-undefined-globals
+ emit-closure-info
+ emit-control-file-item
+ emit-global-inline-file
+ emit-profile
+ emit-syntax-trace-info
+ emit-trace-info
+ emit-unsafe-marker
+ enable-inline-files
+ encode-literal
+ eq-inline-operator
+ error-is-extended-binding
+ estimate-foreign-result-location-size
+ estimate-foreign-result-size
+ expand-debug-assignment
+ expand-debug-call
+ expand-debug-lambda
+ expand-foreign-callback-lambda
+ expand-foreign-callback-lambda*
+ expand-foreign-lambda
+ expand-foreign-lambda*
+ expand-foreign-primitive
+ expand-profile-lambda
+ explicit-use-flag
+ export-dump-hook
+ export-variable
+ expression-has-side-effects?
+ external-protos-first
+ external-to-pointer
+ external-variables
+ extract-mutable-constants
+ file-io-only
+ file-requirements
+ final-foreign-type
+ find-early-refs
+ find-inlining-candidates
+ find-lambda-container
+ finish-foreign-result
+ first-analysis
+ fold-boolean
+ fold-inner
+ foldable-bindings
+ follow-without-loop
+ foreign-argument-conversion
+ foreign-declarations
+ foreign-lambda-stubs
+ foreign-result-conversion
+ foreign-string-result-reserve
+ foreign-type-check
+ foreign-type-convert-argument
+ foreign-type-convert-result
+ foreign-type-declaration
+ foreign-type-table
+ foreign-variables
+ gen
+ gen-list
+ generate-code
+ generate-external-variables
+ generate-foreign-callback-header
+ generate-foreign-callback-stub-prototypes
+ generate-foreign-stubs
+ get
+ get-all
+ get-line
+ get-line-2
+ get-list
+ hide-variable
+ immediate?
+ immutable-constants
+ import-libraries
+ initialize-analysis-database
+ initialize-compiler
+ inline-globally
+ inline-lambda-bindings
+ inline-locally
+ inline-max-size
+ inline-output-file
+ inline-substitutions-enabled
+ inline-table
+ inline-table-used
+ inlining
+ insert-timer-checks
+ installation-home
+ internal-bindings
+ intrinsic?
+ line-number-database-2
+ line-number-database-size
+ llist-length
+ load-identifier-database
+ load-inline-file
+ load-type-database
+ local-definitions
+ location-pointer-map
+ loop-lambda-names
+ make-argument-list
+ make-block-variable-literal
+ make-random-name
+ make-variable-list
+ mark-variable
+ match-node
+ membership-test-operators
+ membership-unfold-limit
+ no-argc-checks
+ no-bound-checks
+ no-procedure-checks
+ node->sexpr
+ non-foldable-bindings
+ nonwinding-call/cc
+ optimizable-rest-argument-operators
+ optimization-iterations
+ original-program-size
+ output
+ parameter-limit
+ pending-canonicalizations
+ perform-closure-conversion
+ perform-cps-conversion
+ perform-high-level-optimizations
+ perform-inlining!
+ perform-lambda-lifting!
+ perform-pre-optimization!
+ posq
+ postponed-initforms
+ pprint-expressions-to-file
+ prepare-for-code-generation
+ print-program-statistics
+ print-usage
+ print-version
+ process-command-line
+ process-declaration
+ process-lambda-documentation
+ profile-info-vector-name
+ profile-lambda-index
+ profile-lambda-list
+ profiled-procedures
+ put!
+ qnode
+ r-c-s
+ real-name
+ real-name-table
+ real-name2
+ reorganize-recursive-bindings
+ require-imports-flag
+ rest-parameters-promoted-to-vector
+ rewrite
+ safe-globals-flag
+ scan-free-variables
+ scan-sharp-greater-string
+ scan-toplevel-assignments
+ scan-used-variables
+ scrutinize
+ set-real-name!
+ sexpr->node
+ simple-lambda-node?
+ simplifications
+ simplified-ops
+ simplify-named-call
+ sort-symbols
+ source-filename
+ source-info->line
+ source-info->string
+ standalone-executable
+ string->c-identifier
+ string->expr
+ stringify
+ substitution-table
+ symbolify
+ target-heap-growth
+ target-heap-shrinkage
+ target-heap-size
+ target-include-file
+ target-initial-heap-size
+ target-stack-size
+ toplevel-lambda-id
+ toplevel-scope
+ transform-direct-lambdas!
+ tree-copy
+ undefine-shadowed-macros
+ unique-id
+ unit-name
+ units-used-by-default
+ unlikely-variables
+ update-line-number-database
+ update-line-number-database!
+ used-units
+ valid-c-identifier?
+ valid-compiler-options
+ valid-compiler-options-with-argument
+ variable-mark
+ variable-visible?
+ varnode
+ verbose-mode
+ words
+ words->bytes
+ words-per-flonum
+ zap-strings-flag)
diff --git a/compiler-syntax.scm b/compiler-syntax.scm
new file mode 100644
index 00000000..9d15d1d5
--- /dev/null
+++ b/compiler-syntax.scm
@@ -0,0 +1,249 @@
+;;;; compiler-syntax.scm - compiler syntax used internally
+;
+; Copyright (c) 2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit compiler-syntax) )
+
+
+(include "compiler-namespace")
+(include "tweaks.scm")
+
+
+;;; Compiler macros (that operate in the expansion phase)
+
+(define compiler-syntax-statistics '())
+
+(set! ##sys#compiler-syntax-hook
+ (lambda (name result)
+ (let ((a (alist-ref name compiler-syntax-statistics eq? 0)))
+ (set! compiler-syntax-statistics
+ (alist-update! name (add1 a) compiler-syntax-statistics)))))
+
+(define (r-c-s names transformer #!optional (se '()))
+ (let ((t (cons (##sys#er-transformer transformer) se)))
+ (for-each
+ (lambda (name)
+ (##sys#put! name '##compiler#compiler-syntax t) )
+ (if (symbol? names) (list names) names) ) ) )
+
+(define-syntax define-internal-compiler-syntax
+ (syntax-rules ()
+ ((_ (names . llist) (se ...) . body)
+ (r-c-s
+ 'names (lambda llist . body)
+ `((se . ,(##sys#primitive-alias 'se)) ...)))))
+
+(define-internal-compiler-syntax ((for-each ##sys#for-each #%for-each) x r c)
+ (pair?)
+ (let ((%let (r 'let))
+ (%if (r 'if))
+ (%loop (r 'loop))
+ (%begin (r 'begin))
+ (%and (r 'and))
+ (%pair? (r 'pair?))
+ (%lambda (r 'lambda))
+ (lsts (cddr x)))
+ (if (and (memq 'for-each standard-bindings) ; we have to check this because the db (and thus
+ (> (length+ x) 2) ; intrinsic marks) isn't set up yet
+ (or (and (pair? (cadr x))
+ (c %lambda (caadr x)))
+ (symbol? (cadr x))))
+ (let ((vars (map (lambda _ (gensym)) lsts)))
+ `(,%let ,%loop ,(map list vars lsts)
+ (,%if (,%and ,@(map (lambda (v) `(,%pair? ,v)) vars))
+ (,%begin
+ ((,%begin ,(cadr x))
+ ,@(map (lambda (v) `(##sys#slot ,v 0)) vars))
+ (##core#app
+ ,%loop
+ ,@(map (lambda (v) `(##sys#slot ,v 1)) vars) ) ))))
+ x)))
+
+(define-internal-compiler-syntax ((map ##sys#map #%map) x r c)
+ (pair?)
+ (let ((%let (r 'let))
+ (%if (r 'if))
+ (%loop (r 'loop))
+ (%res (r 'res))
+ (%cons (r 'cons))
+ (%set! (r 'set!))
+ (%result (r 'result))
+ (%node (r 'node))
+ (%quote (r 'quote))
+ (%begin (r 'begin))
+ (%lambda (r 'lambda))
+ (%and (r 'and))
+ (%pair? (r 'pair?))
+ (lsts (cddr x)))
+ (if (and (memq 'map standard-bindings) ; s.a.
+ (> (length+ x) 2)
+ (or (and (pair? (cadr x))
+ (c %lambda (caadr x)))
+ (symbol? (cadr x))))
+ (let ((vars (map (lambda _ (gensym)) lsts)))
+ `(,%let ((,%result (,%quote ()))
+ (,%node #f))
+ (,%let ,%loop ,(map list vars lsts)
+ (,%if (,%and ,@(map (lambda (v) `(,%pair? ,v)) vars))
+ (,%let ((,%res
+ (,%cons
+ ((,%begin ,(cadr x))
+ ,@(map (lambda (v) `(##sys#slot ,v 0)) vars))
+ (,%quote ()))))
+ (,%if ,%node
+ (##sys#setslot ,%node 1 ,%res)
+ (,%set! ,%result ,%res))
+ (,%set! ,%node ,%res)
+ (,%loop
+ ,@(map (lambda (v) `(##sys#slot ,v 1)) vars)))
+ ,%result))))
+ x)))
+
+(define-internal-compiler-syntax ((o #%o) x r c) ()
+ (if (and (fx> (length x) 1)
+ (memq 'o extended-bindings) ) ; s.a.
+ (let ((%tmp (r 'tmp)))
+ `(,(r 'lambda) (,%tmp) ,(fold-right list %tmp (cdr x))))
+ x))
+
+(define-internal-compiler-syntax ((sprintf #%sprintf format #%format) x r c)
+ (display write fprintf number->string write-char open-output-string get-output-string)
+ (let* ((out (gensym 'out))
+ (code (compile-format-string
+ (if (memq (car x) '(sprintf #%sprintf))
+ 'sprintf
+ 'format)
+ out
+ x
+ (cdr x)
+ r c)))
+ (if code
+ `(,(r 'let) ((,out (,(r 'open-output-string))))
+ ,code
+ (,(r 'get-output-string) ,out))
+ x)))
+
+(define-internal-compiler-syntax ((fprintf #%fprintf) x r c)
+ (display write fprintf number->string write-char open-output-string get-output-string)
+ (if (>= (length x) 3)
+ (let ((code (compile-format-string
+ 'fprintf (cadr x)
+ x (cddr x)
+ r c)))
+ (or code x))
+ x))
+
+(define-internal-compiler-syntax ((printf #%printf) x r c)
+ (display write fprintf number->string write-char open-output-string get-output-string)
+ (let ((code (compile-format-string
+ 'printf '##sys#standard-output
+ x (cdr x)
+ r c)))
+ (or code x)))
+
+(define (compile-format-string func out x args r c)
+ (call/cc
+ (lambda (return)
+ (and (>= (length args) 1)
+ (memq func extended-bindings) ; s.a.
+ (or (string? (car args))
+ (and (list? (car args))
+ (c (r 'quote) (caar args))
+ (string? (cadar args))))
+ (let ((fstr (if (string? (car args)) (car args) (cadar args)))
+ (args (cdr args)))
+ (define (fail ret? msg . args)
+ (let ((ln (get-line x)))
+ (compiler-warning
+ 'syntax
+ "(~a) in format string ~s~a, ~?"
+ func fstr
+ (if ln (sprintf " in line ~a" ln) "")
+ msg args) )
+ (when ret? (return #f)))
+ (let ((code '())
+ (index 0)
+ (len (string-length fstr))
+ (%display (r 'display))
+ (%write (r 'write))
+ (%write-char (r 'write-char))
+ (%out (r 'out))
+ (%fprintf (r 'fprintf))
+ (%let (r 'let))
+ (%number->string (r 'number->string)))
+ (define (fetch)
+ (let ((c (string-ref fstr index)))
+ (set! index (fx+ index 1))
+ c) )
+ (define (next)
+ (if (null? args)
+ (fail #t "too few arguments to formatted output procedure")
+ (let ((x (car args)))
+ (set! args (cdr args))
+ x) ) )
+ (define (endchunk chunk)
+ (when (pair? chunk)
+ (push
+ (if (= 1 (length chunk))
+ `(,%write-char ,(car chunk) ,%out)
+ `(,%display ,(reverse-list->string chunk) ,%out)))))
+ (define (push exp)
+ (set! code (cons exp code)))
+ (let loop ((chunk '()))
+ (cond ((>= index len)
+ (unless (null? args)
+ (fail #f "too many arguments to formatted output procedure"))
+ (endchunk chunk)
+ `(,%let ((,%out ,out))
+ ,@(reverse code)))
+ (else
+ (let ((c (fetch)))
+ (if (eq? c #\~)
+ (let ((dchar (fetch)))
+ (endchunk chunk)
+ (case (char-upcase dchar)
+ ((#\S) (push `(,%write ,(next) ,%out)))
+ ((#\A) (push `(,%display ,(next) ,%out)))
+ ((#\C) (push `(,%write-char ,(next) ,%out)))
+ ((#\B) (push `(,%display (,%number->string ,(next) 2) ,%out)))
+ ((#\O) (push `(,%display (,%number->string ,(next) 8) ,%out)))
+ ((#\X) (push `(,%display (,%number->string ,(next) 16) ,%out)))
+ ((#\!) (push `(##sys#flush-output ,%out)))
+ ((#\?)
+ (let* ([fstr (next)]
+ [lst (next)] )
+ (push `(##sys#apply ,%fprintf ,%out ,fstr ,lst))))
+ ((#\~) (push `(,write-char #\~ ,%out)))
+ ((#\% #\N) (push `(,%write-char #\newline ,%out)))
+ (else
+ (if (char-whitespace? dchar)
+ (let skip ((c (fetch)))
+ (if (char-whitespace? c)
+ (skip (fetch))
+ (set! index (sub1 index))))
+ (fail #t "illegal format-string character `~c'" dchar) ) ) )
+ (loop '()) )
+ (loop (cons c chunk)))))))))))))
diff --git a/compiler.scm b/compiler.scm
new file mode 100644
index 00000000..7680ec99
--- /dev/null
+++ b/compiler.scm
@@ -0,0 +1,2678 @@
+;;;; compiler.scm - The CHICKEN Scheme compiler
+;
+;
+; "This is insane. What we clearly want to do is not exactly clear, and is rooted in NCOMPLR."
+;
+;
+;-----------------------------------------------------------------------------------------------------------
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+;
+;
+; Supported syntax:
+;
+; - Declaration specifiers:
+;
+; ([not] extended-bindings {<name>})
+; ([not] inline {<var>})
+; ([not] interrupts-enabled)
+; ([not] safe)
+; ([not] standard-bindings {<name>})
+; ([not] usual-integrations {<name>})
+; (local {<name> ...})
+; ([not] inline-global {<name>})
+; ([number-type] <type>)
+; (always-bound {<name>})
+; (block)
+; (block-global {<name>})
+; (bound-to-procedure {<var>})
+; (c-options {<opt>})
+; (compile-syntax)
+; (disable-interrupts)
+; (disable-warning <class> ...)
+; (emit-import-library {<module> | (<module> <filename>)})
+; (export {<name>})
+; (fixnum-arithmetic)
+; (foreign-declare {<string>})
+; (hide {<name>})
+; (inline-limit <limit>)
+; (keep-shadowed-macros)
+; (lambda-lift)
+; (link-options {<opt>})
+; (no-argc-checks)
+; (no-bound-checks)
+; (no-procedure-checks)
+; (no-procedure-checks-for-usual-bindings)
+; (post-process <string> ...)
+; (profile <symbol> ...)
+; (safe-globals)
+; (separate)
+; (type (<symbol> <typespec>) ...)
+; (unit <unitname>)
+; (unsafe)
+; (unused <symbol> ...)
+; (uses {<unitname>})
+; (scrutinize)
+;
+; <type> = fixnum | generic
+
+; - Global symbol properties:
+;
+; ##compiler#always-bound -> BOOL
+; ##compiler#always-bound-to-procedure -> BOOL
+; ##compiler#local -> BOOL
+; ##compiler#visibility -> #f | 'hidden | 'exported
+; ##compiler#constant -> BOOL
+; ##compiler#intrinsic -> #f | 'standard | 'extended
+; ##compiler#inline -> 'no | 'yes
+; ##compiler#inline-global -> 'yes | 'no | <node>
+; ##compiler#profile -> BOOL
+; ##compiler#unused -> BOOL
+; ##compiler#foldable -> BOOL
+
+; - Source language:
+;
+; <variable>
+; <constant>
+; (##core#declare {<spec>})
+; (##core#immutable <exp>)
+; (##core#global-ref <variable>)
+; (quote <exp>)
+; (if <exp> <exp> [<exp>])
+; ([##core#]syntax <exp>)
+; ([##core#]let <variable> ({(<variable> <exp>)}) <body>)
+; ([##core#]let ({(<variable> <exp>)}) <body>)
+; ([##core#]letrec ({(<variable> <exp>)}) <body>)
+; (##core#let-location <symbol> <type> [<init>] <exp>)
+; ([##core#]lambda <variable> <body>)
+; ([##core#]lambda ({<variable>}+ [. <variable>]) <body>)
+; ([##core#]set! <variable> <exp>)
+; ([##core#]begin <exp> ...)
+; (##core#named-lambda <name> <llist> <body>)
+; (##core#loop-lambda <llist> <body>)
+; (##core#undefined)
+; (##core#primitive <name>)
+; (##core#inline <op> {<exp>})
+; (##core#inline_allocate (<op> <words>) {<exp>})
+; (##core#inline_ref (<name> <type>))
+; (##core#inline_update (<name> <type>) <exp>)
+; (##core#inline_loc_ref (<type>) <exp>)
+; (##core#inline_loc_update (<type>) <exp> <exp>)
+; (##core#compiletimetoo <exp>)
+; (##core#compiletimeonly <exp>)
+; (##core#elaborationtimetoo <exp>)
+; (##core#elaborationtimeonly <exp>)
+; (define-foreign-variable <symbol> <type> [<string>])
+; (define-foreign-type <symbol> <type> [<proc1> [<proc2>]])
+; (foreign-lambda <type> <string> {<type>})
+; (foreign-lambda* <type> ({(<type> <var>)})) {<string>})
+; (foreign-safe-lambda <type> <string> {<type>})
+; (foreign-safe-lambda* <type> ({(<type> <var>)})) {<string>})
+; (foreign-primitive <type> ({(<type> <var>)}) {<string>})
+; (##core#define-inline <name> <exp>)
+; (define-constant <name> <exp>)
+; (##core#foreign-callback-wrapper '<name> <qualifiers> '<type> '({<type>}) <exp>)
+; (##core#define-external-variable (quote <name>) (quote <type>) (quote <bool>))
+; (##core#check <exp>)
+; (##core#require-for-syntax <exp> ...)
+; (##core#require-extension (<id> ...) <bool>)
+; (##core#app <exp> {<exp>})
+; ([##core#]syntax <exp>)
+; (<exp> {<exp>})
+; (define-syntax <symbol> <expr>)
+; (define-syntax (<symbol> . <llist>) <expr> ...)
+; (define-compiled-syntax <symbol> <expr>)
+; (define-compiled-syntax (<symbol> . <llist>) <expr> ...)
+; (##core#define-compiler-syntax <symbol> <expr>)
+; (##core#let-compiler-syntax ((<symbol> <expr>) ...) <expr> ...)
+; (##core#module <symbol> #t | (<name> | (<name> ...) ...) <body>)
+
+; - Core language:
+;
+; [##core#variable {<variable>}]
+; [if {} <exp> <exp> <exp>)]
+; [quote {<exp>}]
+; [let {<variable>} <exp-v> <exp>]
+; [##core#lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>]
+; [set! {<variable>} <exp>]
+; [##core#undefined {}]
+; [##core#global-ref {<variable>}]
+; [##core#primitive {<name>}]
+; [##core#inline {<op>} <exp>...]
+; [##core#inline_allocate {<op> <words>} <exp>...]
+; [##core#inline_ref {<name> <type>}]
+; [##core#inline_update {<name> <type>} <exp>]
+; [##core#inline_loc_ref {<type>} <exp>]
+; [##core#inline_loc_update {<type>} <exp> <exp>]
+; [##core#call {<safe-flag> [<debug-info>]} <exp-f> <exp>...]
+; [##core#callunit {<unitname>} <exp>...]
+; [##core#switch {<count>} <exp> <const1> <body1> ... <defaultbody>]
+; [##core#cond <exp> <exp> <exp>]
+; [##core#recurse {<tail-flag>} <exp1> ...]
+; [##core#return <exp>]
+; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
+; [##core#direct_lambda {<id> <mode> (<variable>... [. <variable>]) <size>} <exp>]
+
+; - Closure converted/prepared language:
+;
+; [if {} <exp> <exp> <exp>]
+; [quote {<exp>}]
+; [##core#bind {<count>} <exp-v>... <exp>]
+; [##core#undefined {}]
+; [##core#inline {<op>} <exp>...]
+; [##core#inline_allocate {<op <words>} <exp>...]
+; [##core#inline_ref {<name> <type>}]
+; [##core#inline_update {<name> <type>} <exp>]
+; [##core#inline_loc_ref {<type>} <exp>]
+; [##core#inline_loc_update {<type>} <exp> <exp>]
+; [##core#closure {<count>} <exp>...]
+; [##core#box {} <exp>]
+; [##core#unbox {} <exp>]
+; [##core#ref {<index>} <exp>]
+; [##core#update {<index>} <exp> <exp>]
+; [##core#updatebox {} <exp> <exp>]
+; [##core#update_i {<index>} <exp> <exp>]
+; [##core#updatebox_i {} <exp> <exp>]
+; [##core#call {<safe-flag> [<debug-info> [<call-id> <customizable-flag>]]} <exp-f> <exp>...]
+; [##core#callunit {<unitname>} <exp>...]
+; [##core#cond <exp> <exp> <exp>]
+; [##core#local {<index>}]
+; [##core#setlocal {<index>} <exp>]
+; [##core#global {<literal> <safe-flag> <block-mode> [<name>]}]
+; [##core#setglobal {<literal> <block-mode> <name>} <exp>]
+; [##core#setglobal_i {<literal> <block-mode> <name>} <exp>]
+; [##core#literal {<literal>}]
+; [##core#immediate {<type> [<immediate>]}] - type: bool/fix/nil/char
+; [##core#proc {<name> [<non-internal>]}]
+; [##core#recurse {<tail-flag> <call-id>} <exp1> ...]
+; [##core#return <exp>]
+; [##core#direct_call {<safe-flag> <debug-info> <call-id> <words>} <exp-f> <exp>...]
+
+; Analysis database entries:
+;
+; <variable>:
+;
+; captured -> <boolean> If true: variable is used outside it's home-scope
+; global -> <boolean> If true: variable does not occur in any lambda-list
+; call-sites -> ((<lambda-id> <node>) ...) Known call-nodes of a named procedure
+; home -> <lambda-id> Procedure which introduces this variable
+; unknown -> <boolean> If true: variable cannot have a known value
+; assigned -> <boolean> If true: variable is assigned somewhere
+; assigned-locally -> <boolean> If true: variable has been assigned inside user lambda
+; undefined -> <boolean> If true: variable is unknown yet but can be known later
+; value -> <node> Variable has a known value
+; local-value -> <node> Variable is declared local and has value
+; potential-value -> <node> Global variable was assigned this value
+; references -> (<node> ...) Nodes that are accesses of this variable (##core#variable nodes)
+; boxed -> <boolean> If true: variable has to be boxed after closure-conversion
+; contractable -> <boolean> If true: variable names contractable procedure
+; inlinable -> <boolean> If true: variable names potentially inlinable procedure
+; collapsable -> <boolean> If true: variable refers to collapsable constant
+; removable -> <boolean> If true: variable is not used
+; replacable -> <variable> Variable can be replaced by another variable
+; replacing -> <boolean> If true: variable can replace another variable (don't remove)
+; standard-binding -> <boolean> If true: variable names a standard binding
+; extended-binding -> <boolean> If true: variable names an extended binding
+; unused -> <boolean> If true: variable is a formal parameter that is never used
+; rest-parameter -> #f | 'vector | 'list If true: variable holds rest-argument list mode
+; o-r/access-count -> <n> Contains number of references as arguments of optimizable rest operators
+; constant -> <boolean> If true: variable has fixed value
+; hidden-refs -> <boolean> If true: procedure that refers to hidden global variables
+; inline-transient -> <boolean> If true: was introduced during inlining
+;
+; <lambda-id>:
+;
+; contains -> (<lambda-id> ...) Procedures contained in this lambda
+; contained-in -> <lambda-id> Procedure containing this lambda
+; has-unused-parameters -> <boolean> If true: procedure has unused formal parameters
+; use-expr -> (<lambda-id> ...) Marks non-direct use-sites of common subexpression
+; closure-size -> <integer> Number of free variables stored in a closure
+; customizable -> <boolean> If true: all call sites are known, procedure does not escape
+; simple -> <boolean> If true: procedure only calls its continuation
+; explicit-rest -> <boolean> If true: procedure is called with consed rest list
+; captured-variables -> (<var> ...) List of closed over variables
+; inline-target -> <boolean> If true: was target of an inlining operation
+
+
+(declare
+ (unit compiler)
+ (disable-warning var) )
+
+
+(include "compiler-namespace")
+
+(define (d arg1 . more)
+ (if (null? more)
+ (pp arg1)
+ (apply print arg1 more)))
+
+(define-syntax d (syntax-rules () ((_ . _) (void))))
+
+(include "tweaks")
+
+
+(define-inline (gensym-f-id) (gensym 'f_))
+
+(eval-when (eval)
+ (define installation-home #f)
+ (define default-target-heap-size #f)
+ (define default-target-stack-size #f) )
+
+(eval-when (load)
+ (define-foreign-variable installation-home c-string "C_INSTALL_SHARE_HOME")
+ (define-foreign-variable default-target-heap-size int "C_DEFAULT_TARGET_HEAP_SIZE")
+ (define-foreign-variable default-target-stack-size int "C_DEFAULT_TARGET_STACK_SIZE") )
+
+(define-constant foreign-type-table-size 301)
+(define-constant analysis-database-size 3001)
+(define-constant default-line-number-database-size 997)
+(define-constant inline-table-size 301)
+(define-constant constant-table-size 301)
+(define-constant file-requirements-size 301)
+(define-constant real-name-table-size 997)
+(define-constant default-inline-max-size 20)
+
+
+;;; Global variables containing compilation parameters:
+
+(define unit-name #f)
+(define number-type 'generic)
+(define standard-bindings '())
+(define extended-bindings '())
+(define insert-timer-checks #t)
+(define used-units '())
+(define unsafe #f)
+(define foreign-declarations '())
+(define emit-trace-info #f)
+(define block-compilation #f)
+(define line-number-database-size default-line-number-database-size)
+(define target-heap-size #f)
+(define target-initial-heap-size #f)
+(define target-stack-size #f)
+(define optimize-leaf-routines #f)
+(define emit-profile #f)
+(define no-bound-checks #f)
+(define no-argc-checks #f)
+(define no-procedure-checks #f)
+(define source-filename #f)
+(define safe-globals-flag #f)
+(define explicit-use-flag #f)
+(define disable-stack-overflow-checking #f)
+(define require-imports-flag #f)
+(define emit-unsafe-marker #f)
+(define external-protos-first #f)
+(define do-lambda-lifting #f)
+(define inline-max-size default-inline-max-size)
+(define emit-closure-info #t)
+(define undefine-shadowed-macros #t)
+(define constant-declarations '())
+(define profiled-procedures #f)
+(define import-libraries '())
+(define all-import-libraries #f)
+(define standalone-executable #t)
+(define local-definitions #f)
+(define inline-globally #f)
+(define inline-locally #f)
+(define inline-output-file #f)
+(define do-scrutinize #f)
+(define enable-inline-files #f)
+(define compiler-syntax-enabled #t)
+
+
+;;; These are here so that the backend can access them:
+
+(define default-default-target-heap-size default-target-heap-size)
+(define default-default-target-stack-size default-target-stack-size)
+
+
+;;; Other global variables:
+
+(define verbose-mode #f)
+(define original-program-size #f)
+(define current-program-size 0)
+(define line-number-database-2 #f)
+(define immutable-constants '())
+(define rest-parameters-promoted-to-vector '())
+(define inline-table #f)
+(define inline-table-used #f)
+(define constant-table #f)
+(define constants-used #f)
+(define broken-constant-nodes '())
+(define inline-substitutions-enabled #f)
+(define direct-call-ids '())
+(define first-analysis #t)
+(define foreign-type-table #f)
+(define foreign-variables '())
+(define foreign-lambda-stubs '())
+(define foreign-callback-stubs '())
+(define external-variables '())
+(define loop-lambda-names '())
+(define profile-lambda-list '())
+(define profile-lambda-index 0)
+(define profile-info-vector-name #f)
+(define external-to-pointer '())
+(define error-is-extended-binding #f)
+(define real-name-table #f)
+(define location-pointer-map '())
+(define pending-canonicalizations '())
+(define defconstant-bindings '())
+(define callback-names '())
+(define toplevel-scope #t)
+(define toplevel-lambda-id #f)
+(define csc-control-file #f)
+(define data-declarations '())
+(define file-requirements #f)
+(define postponed-initforms '())
+
+
+;;; Initialize globals:
+
+(define (initialize-compiler)
+ (if line-number-database-2
+ (vector-fill! line-number-database-2 '())
+ (set! line-number-database-2 (make-vector line-number-database-size '())) )
+ (if inline-table
+ (vector-fill! inline-table '())
+ (set! inline-table (make-vector inline-table-size '())) )
+ (if constant-table
+ (vector-fill! constant-table '())
+ (set! constant-table (make-vector constant-table-size '())) )
+ (set! profile-info-vector-name (make-random-name 'profile-info))
+ (set! real-name-table (make-vector real-name-table-size '()))
+ (if file-requirements
+ (vector-fill! file-requirements '())
+ (set! file-requirements (make-vector file-requirements-size '())) )
+ (if foreign-type-table
+ (vector-fill! foreign-type-table '())
+ (set! foreign-type-table (make-vector foreign-type-table-size '())) ) )
+
+
+;;; Expand macros and canonicalize expressions:
+
+(define (canonicalize-expression exp)
+
+ (define (find-id id se) ; ignores macro bindings
+ (cond ((null? se) #f)
+ ((and (eq? id (caar se)) (symbol? (cdar se))) (cdar se))
+ (else (find-id id (cdr se)))))
+
+ (define (lookup id se)
+ (cond ((find-id id se))
+ ((##sys#get id '##core#macro-alias))
+ (else id)))
+
+ (define (macro-alias var se)
+ (let ((alias (gensym var)))
+ (##sys#put! alias '##core#macro-alias (lookup var se))
+ alias) )
+
+ (define (set-real-names! as ns)
+ (for-each (lambda (a n) (set-real-name! a n)) as ns) )
+
+ (define (write-to-string x)
+ (let ([out (open-output-string)])
+ (write x out)
+ (get-output-string out) ) )
+
+ (define (unquotify x se)
+ (if (and (list? x)
+ (= 2 (length x))
+ (symbol? (car x))
+ (eq? 'quote (lookup (car x) se)))
+ (cadr x)
+ x) )
+
+ (define (resolve-variable x0 e se dest)
+ (let ((x (lookup x0 se)))
+ (d `(RESOLVE-VARIABLE: ,x0 ,x ,(map car se)))
+ (cond ((not (symbol? x)) x0) ; syntax?
+ [(and constants-used (##sys#hash-table-ref constant-table x))
+ => (lambda (val) (walk (car val) e se dest)) ]
+ [(and inline-table-used (##sys#hash-table-ref inline-table x))
+ => (lambda (val) (walk val e se dest)) ]
+ [(assq x foreign-variables)
+ => (lambda (fv)
+ (let* ([t (second fv)]
+ [ft (final-foreign-type t)]
+ [body `(##core#inline_ref (,(third fv) ,t))] )
+ (walk
+ (foreign-type-convert-result
+ (finish-foreign-result ft body)
+ t)
+ e se dest)))]
+ [(assq x location-pointer-map)
+ => (lambda (a)
+ (let* ([t (third a)]
+ [ft (final-foreign-type t)]
+ [body `(##core#inline_loc_ref (,t) ,(second a))] )
+ (walk
+ (foreign-type-convert-result
+ (finish-foreign-result ft body)
+ t)
+ e se dest))) ]
+ ((##sys#get x '##core#primitive))
+ ((not (memq x e)) (##sys#alias-global-hook x #f)) ; only if global
+ (else x))))
+
+ (define (eval/meta form)
+ (parameterize ((##sys#current-module #f)
+ (##sys#macro-environment (##sys#meta-macro-environment)))
+ ((##sys#compile-to-closure
+ form
+ '()
+ (##sys#current-meta-environment))
+ '() ) ))
+
+ (define (emit-import-lib name il)
+ (let ((fname (if all-import-libraries
+ (string-append (symbol->string name) ".import.scm")
+ (cdr il))))
+ (when verbose-mode
+ (print "generating import library " fname " for module "
+ name " ..."))
+ (with-output-to-file fname
+ (lambda ()
+ (print ";;;; " fname " - GENERATED BY CHICKEN "
+ (chicken-version) " -*- Scheme -*-\n")
+ (for-each
+ pretty-print
+ (##sys#compiled-module-registration
+ (##sys#current-module)))
+ (print "\n;; END OF FILE")))))
+
+ (define (walk x e se dest)
+ (cond ((symbol? x)
+ (cond ((keyword? x) `(quote ,x))
+ ((memq x unlikely-variables)
+ (compiler-warning
+ 'var
+ "reference to variable `~s' possibly unintended" x) ))
+ (resolve-variable x e se dest))
+ ((not-pair? x)
+ (if (constant? x)
+ `(quote ,x)
+ (syntax-error "illegal atomic form" x)))
+ ((symbol? (car x))
+ (let ([ln (get-line x)])
+ (emit-syntax-trace-info x #f)
+ (unless (proper-list? x)
+ (if ln
+ (syntax-error (sprintf "(in line ~s) - malformed expression" ln) x)
+ (syntax-error "malformed expression" x)))
+ (set! ##sys#syntax-error-culprit x)
+ (let* ((name0 (lookup (car x) se))
+ (name (or (and (symbol? name0) (##sys#get name0 '##core#primitive)) name0))
+ (xexpanded (##sys#expand x se compiler-syntax-enabled)))
+ (cond ((not (eq? x xexpanded))
+ (walk xexpanded e se dest))
+
+ [(and inline-table-used (##sys#hash-table-ref inline-table name))
+ => (lambda (val)
+ (walk (cons val (cdr x)) e se dest)) ]
+
+ [else
+ (when ln (update-line-number-database! xexpanded ln))
+ (case name
+
+ ((if)
+ (##sys#check-syntax 'if x '(if _ _ . #(_)) #f se)
+ `(if
+ ,(walk (cadr x) e se #f)
+ ,(walk (caddr x) e se #f)
+ ,(if (null? (cdddr x))
+ '(##core#undefined)
+ (walk (cadddr x) e se #f) ) ) )
+
+ ((quote syntax ##core#syntax)
+ (##sys#check-syntax name x '(_ _) #f se)
+ `(quote ,(##sys#strip-syntax (cadr x))))
+
+ ((##core#check)
+ (if unsafe
+ ''#t
+ (walk (cadr x) e se dest) ) )
+
+ ((##core#immutable)
+ (let ((c (cadadr x)))
+ (cond [(assoc c immutable-constants) => cdr]
+ [else
+ (let ([var (gensym 'c)])
+ (set! immutable-constants (alist-cons c var immutable-constants))
+ (mark-variable var '##compiler#always-bound)
+ (hide-variable var)
+ var) ] ) ) )
+
+ ((##core#undefined ##core#callunit ##core#primitive) x)
+
+ ((##core#inline_ref)
+ `(##core#inline_ref
+ (,(caadr x) ,(##sys#strip-syntax (cadadr x)))))
+
+ ((##core#inline_loc_ref)
+ `(##core#inline_loc_ref
+ ,(##sys#strip-syntax (cadr x))
+ ,(walk (caddr x) e se dest)))
+
+ ((##core#require-for-syntax)
+ (let ([ids (map eval (cdr x))])
+ (apply ##sys#require ids)
+ (##sys#hash-table-update!
+ file-requirements 'dynamic/syntax
+ (cut lset-union eq? <> ids)
+ (lambda () ids) )
+ '(##core#undefined) ) )
+
+ ((##core#require-extension)
+ (let ((imp? (caddr x)))
+ (walk
+ (let loop ([ids (cadr x)])
+ (if (null? ids)
+ '(##core#undefined)
+ (let ([id (car ids)])
+ (let-values ([(exp f) (##sys#do-the-right-thing id #t imp?)])
+ (unless (or f
+ (and (symbol? id)
+ (or (feature? id)
+ (##sys#find-extension
+ (##sys#canonicalize-extension-path
+ id 'require-extension)
+ #f)) ) )
+ (compiler-warning
+ 'ext "extension `~A' is currently not installed" id))
+ `(##core#begin ,exp ,(loop (cdr ids))) ) ) ) )
+ e se dest) ) )
+
+ ((let ##core#let)
+ (##sys#check-syntax 'let x '(_ #((variable _) 0) . #(_ 1)) #f se)
+ (let* ((bindings (cadr x))
+ (vars (unzip1 bindings))
+ (aliases (map gensym vars))
+ (se2 (append (map cons vars aliases) se)) )
+ (set-real-names! aliases vars)
+ `(let
+ ,(map (lambda (alias b)
+ (list alias (walk (cadr b) e se (car b))) )
+ aliases bindings)
+ ,(walk (##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
+ (append aliases e)
+ se2 dest) ) ) )
+
+ ((letrec ##core#letrec)
+ (##sys#check-syntax 'letrec x '(_ #((symbol _) 0) . #(_ 1)))
+ (let ((bindings (cadr x))
+ (body (cddr x)) )
+ (walk
+ `(##core#let
+ ,(map (lambda (b)
+ (list (car b) '(##core#undefined)))
+ bindings)
+ ,@(map (lambda (b)
+ `(##core#set! ,(car b) ,(cadr b)))
+ bindings)
+ (##core#let () ,@body) )
+ e se dest)))
+
+ ((lambda ##core#lambda)
+ (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f se)
+ (let ((llist (cadr x))
+ (obody (cddr x)) )
+ (when (##sys#extended-lambda-list? llist)
+ (set!-values
+ (llist obody)
+ (##sys#expand-extended-lambda-list
+ llist obody ##sys#error se) ) )
+ (decompose-lambda-list
+ llist
+ (lambda (vars argc rest)
+ (let* ((aliases (map gensym vars))
+ (se2 (append (map cons vars aliases) se))
+ (body0 (##sys#canonicalize-body obody se2 compiler-syntax-enabled))
+ (body (walk body0 (append aliases e) se2 #f))
+ (llist2
+ (build-lambda-list
+ aliases argc
+ (and rest (list-ref aliases (posq rest vars))) ) )
+ (l `(lambda ,llist2 ,body)) )
+ (set-real-names! aliases vars)
+ (cond ((or (not dest)
+ (assq dest se)) ; not global?
+ l)
+ ((and (eq? 'lambda (or (lookup name se) name))
+ emit-profile
+ (or (eq? profiled-procedures 'all)
+ (and
+ (eq? profiled-procedures 'some)
+ (variable-mark dest '##compiler#profile))))
+ (expand-profile-lambda dest llist2 body) )
+ (else
+ (if (and (> (length body0) 1)
+ (symbol? (car body0))
+ (eq? 'begin (or (lookup (car body0) se) (car body0)))
+ (let ((x1 (cadr body0)))
+ (or (string? x1)
+ (and (list? x1)
+ (= (length x1) 2)
+ (symbol? (car x1))
+ (eq? 'quote (or (lookup (car x1) se) (car x1)))))))
+ (process-lambda-documentation
+ dest (cadr body) l)
+ l))))))))
+
+ ((let-syntax)
+ (##sys#check-syntax 'let-syntax x '(let-syntax #((variable _) 0) . #(_ 1)) #f se)
+ (let ((se2 (append
+ (map (lambda (b)
+ (list
+ (car b)
+ se
+ (##sys#er-transformer
+ (eval/meta (cadr b)))))
+ (cadr x) )
+ se) ) )
+ (walk
+ (##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
+ e se2
+ dest) ) )
+
+ ((letrec-syntax)
+ (##sys#check-syntax 'letrec-syntax x '(letrec-syntax #((variable _) 0) . #(_ 1)) #f se)
+ (let* ((ms (map (lambda (b)
+ (list
+ (car b)
+ #f
+ (##sys#er-transformer
+ (eval/meta (cadr b)))))
+ (cadr x) ) )
+ (se2 (append ms se)) )
+ (for-each
+ (lambda (sb)
+ (set-car! (cdr sb) se2) )
+ ms)
+ (walk
+ (##sys#canonicalize-body (cddr x) se2 compiler-syntax-enabled)
+ e se2 dest)))
+
+ ((define-syntax define-compiled-syntax)
+ (##sys#check-syntax
+ (car x) x
+ (if (pair? (cadr x))
+ '(_ (variable . lambda-list) . #(_ 1))
+ '(_ variable _) )
+ #f se)
+ (let* ((var (if (pair? (cadr x)) (caadr x) (cadr x)))
+ (body (if (pair? (cadr x))
+ `(##core#lambda ,(cdadr x) ,@(cddr x))
+ (caddr x)))
+ (name (lookup var se)))
+ (##sys#register-syntax-export name (##sys#current-module) body)
+ (##sys#extend-macro-environment
+ name
+ (##sys#current-environment)
+ (##sys#er-transformer (eval/meta body)))
+ (walk
+ (if (or ##sys#enable-runtime-macros
+ (eq? 'define-compiled-syntax (car x)))
+ `(##sys#extend-macro-environment
+ ',var
+ (##sys#current-environment)
+ (##sys#er-transformer ,body)) ;*** possibly wrong se?
+ '(##core#undefined) )
+ e se dest)) )
+
+ ((##core#define-compiler-syntax)
+ (let* ((var (cadr x))
+ (body (caddr x))
+ (name (##sys#strip-syntax var se #t)))
+ (##sys#put!
+ name '##compiler#compiler-syntax
+ (##sys#cons
+ (##sys#er-transformer (eval/meta body))
+ (##sys#current-environment)))
+ (walk
+ (if ##sys#enable-runtime-macros
+ `(##sys#put!
+ (##core#syntax ,name)
+ '##compiler#compiler-syntax
+ (##sys#cons
+ (##sys#er-transformer ,body)
+ (##sys#current-environment)))
+ '(##core#undefined) )
+ e se dest)))
+
+ ((##core#let-compiler-syntax)
+ (let ((bs (map (lambda (b)
+ (##sys#check-syntax 'let-compiler-syntax b '(symbol _))
+ (let ((name (##sys#strip-syntax (car b) se #t)))
+ (list
+ name
+ (cons (##sys#er-transformer (eval/meta (cadr b))) se)
+ (##sys#get name '##compiler#compiler-syntax) ) ) )
+ (cadr x))))
+ (dynamic-wind ; this ain't thread safe
+ (lambda ()
+ (for-each
+ (lambda (b) (##sys#put! (car b) '##compiler#compiler-syntax (cadr b)))
+ bs) )
+ (lambda ()
+ (walk
+ (##sys#canonicalize-body (cddr x) se compiler-syntax-enabled)
+ e se dest) )
+ (lambda ()
+ (for-each
+ (lambda (b) (##sys#put! (car b) '##compiler#compiler-syntax (caddr b)))
+ bs) ) ) ) )
+
+ ((##core#module)
+ (let* ((name (##sys#strip-syntax (cadr x)))
+ (exports
+ (or (eq? #t (caddr x))
+ (map (lambda (exp)
+ (cond ((symbol? exp) exp)
+ ((and (pair? exp)
+ (let loop ((exp exp))
+ (or (null? exp)
+ (and (symbol? (car exp))
+ (loop (cdr exp))))))
+ exp)
+ (else
+ (##sys#syntax-error-hook
+ 'module
+ "invalid export syntax" exp name))))
+ (##sys#strip-syntax (caddr x))))))
+ (when (##sys#current-module)
+ (##sys#syntax-error-hook 'module "modules may not be nested" name))
+ (let-values (((body mreg)
+ (parameterize ((##sys#current-module
+ (##sys#register-module name exports) )
+ (##sys#current-environment '())
+ (##sys#macro-environment ##sys#initial-macro-environment))
+ (let loop ((body (cdddr x)) (xs '()))
+ (cond
+ ((null? body)
+ (handle-exceptions ex
+ (begin
+ ;; avoid backtrace
+ (print-error-message ex (current-error-port))
+ (exit 1))
+ (##sys#finalize-module (##sys#current-module)))
+ (cond ((or all-import-libraries
+ (assq name import-libraries) ) =>
+ (lambda (il)
+ (emit-import-lib name il)
+ (values
+ (reverse xs)
+ '((##core#undefined)))))
+ (else
+ (values
+ (reverse xs)
+ (if standalone-executable
+ '()
+ (##sys#compiled-module-registration (##sys#current-module)))))))
+ (else
+ (when (and (pair? body)
+ (null? xs)
+ (pair? (car body))
+ (symbol? (caar body))
+ (let ((imp (or (lookup (caar body) se) (caar body))))
+ (and (not (memq imp '(import import-for-syntax)))
+ ;; can it get any uglier? yes, it can
+ (not (eq? imp (cdr (assq 'import ##sys#initial-macro-environment))))
+ (not (eq? imp (cdr (assq 'import-for-syntax ##sys#initial-macro-environment)))))))
+ (compiler-warning
+ 'syntax
+ "module body of `~s' does not begin with `import' form - maybe unintended?"
+ name))
+ (loop
+ (cdr body)
+ (cons (walk
+ (car body)
+ e ;?
+ (##sys#current-environment)
+ #f)
+ xs))))))))
+ (canonicalize-begin-body
+ (append
+ (parameterize ((##sys#current-module #f)
+ (##sys#macro-environment (##sys#meta-macro-environment)))
+ (map
+ (lambda (x)
+ (walk
+ x
+ e ;?
+ (##sys#current-meta-environment) #f) )
+ mreg))
+ body)))))
+
+ ((##core#named-lambda)
+ (walk `(##core#lambda ,@(cddr x)) e se (cadr x)) )
+
+ ((##core#loop-lambda)
+ (let* ([vars (cadr x)]
+ [obody (cddr x)]
+ [aliases (map gensym vars)]
+ (se2 (append (map cons vars aliases) se))
+ [body
+ (walk
+ (##sys#canonicalize-body obody se2 compiler-syntax-enabled)
+ (append aliases e)
+ se2 #f) ] )
+ (set-real-names! aliases vars)
+ `(##core#lambda ,aliases ,body) ) )
+
+ ((set! ##core#set!)
+ (##sys#check-syntax 'set! x '(_ variable _) #f se)
+ (let* ([var0 (cadr x)]
+ [var (lookup var0 se)]
+ [ln (get-line x)]
+ [val (caddr x)] )
+ (when (memq var unlikely-variables)
+ (compiler-warning
+ 'var
+ "assignment to variable `~s' possibly unintended"
+ var))
+ (cond ((assq var foreign-variables)
+ => (lambda (fv)
+ (let ([type (second fv)]
+ [tmp (gensym)] )
+ (walk
+ `(let ([,tmp ,(foreign-type-convert-argument val type)])
+ (##core#inline_update
+ (,(third fv) ,type)
+ ,(foreign-type-check tmp type) ) )
+ e se #f))))
+ ((assq var location-pointer-map)
+ => (lambda (a)
+ (let* ([type (third a)]
+ [tmp (gensym)] )
+ (walk
+ `(let ([,tmp ,(foreign-type-convert-argument val type)])
+ (##core#inline_loc_update
+ (,type)
+ ,(second a)
+ ,(foreign-type-check tmp type) ) )
+ e se #f))))
+ (else
+ (unless (memq var e) ; global?
+ (set! var (or (##sys#get var '##core#primitive)
+ (##sys#alias-global-hook var #t)))
+ (when safe-globals-flag
+ (mark-variable var '##compiler#always-bound-to-procedure)
+ (mark-variable var '##compiler#always-bound)))
+ (when (##sys#macro? var)
+ (compiler-warning
+ 'var "assigned global variable `~S' is a macro ~A"
+ var
+ (if ln (sprintf "in line ~S" ln) "") )
+ (when undefine-shadowed-macros (##sys#undefine-macro! var) ) )
+ (when (keyword? var)
+ (compiler-warning 'syntax "assignment to keyword `~S'" var) )
+ (when (pair? var) ; macro
+ (syntax-error
+ 'set! "assignment to syntactic identifier" var))
+ `(set! ,var ,(walk val e se var0))))))
+
+ ((##core#inline)
+ `(##core#inline ,(unquotify (cadr x) se) ,@(mapwalk (cddr x) e se)))
+
+ ((##core#inline_allocate)
+ `(##core#inline_allocate
+ ,(map (cut unquotify <> se) (second x))
+ ,@(mapwalk (cddr x) e se)))
+
+ ((##core#inline_update)
+ `(##core#inline_update ,(cadr x) ,(walk (caddr x) e se #f)) )
+
+ ((##core#inline_loc_update)
+ `(##core#inline_loc_update
+ ,(cadr x)
+ ,(walk (caddr x) e se #f)
+ ,(walk (cadddr x) e se #f)) )
+
+ ((##core#compiletimetoo ##core#elaborationtimetoo)
+ (let ((exp (cadr x)))
+ (eval/meta exp)
+ (walk exp e se dest) ) )
+
+ ((##core#compiletimeonly ##core#elaborationtimeonly)
+ (eval/meta (cadr x))
+ '(##core#undefined) )
+
+ ((begin ##core#begin)
+ (##sys#check-syntax 'begin x '(_ . #(_ 0)) #f se)
+ (if (pair? (cdr x))
+ (canonicalize-begin-body
+ (let fold ([xs (cdr x)])
+ (let ([x (car xs)]
+ [r (cdr xs)] )
+ (if (null? r)
+ (list (walk x e se dest))
+ (cons (walk x e se #f) (fold r)) ) ) ) )
+ '(##core#undefined) ) )
+
+ ((foreign-lambda)
+ (walk (expand-foreign-lambda x #f) e se dest) )
+
+ ((foreign-safe-lambda)
+ (walk (expand-foreign-lambda x #t) e se dest) )
+
+ ((foreign-lambda*)
+ (walk (expand-foreign-lambda* x #f) e se dest) )
+
+ ((foreign-safe-lambda*)
+ (walk (expand-foreign-lambda* x #t) e se dest) )
+
+ ((foreign-primitive)
+ (walk (expand-foreign-primitive x) e se dest) )
+
+ ((define-foreign-variable)
+ (let* ([var (##sys#strip-syntax (second x))]
+ [type (##sys#strip-syntax (third x))]
+ [name (if (pair? (cdddr x))
+ (fourth x)
+ (symbol->string var) ) ] )
+ (set! foreign-variables
+ (cons (list var type
+ (if (string? name)
+ name
+ (symbol->string name)))
+ foreign-variables))
+ '(##core#undefined) ) )
+
+ ((define-foreign-type)
+ (let ([name (second x)]
+ [type (##sys#strip-syntax (third x))]
+ [conv (cdddr x)] )
+ (cond [(pair? conv)
+ (let ([arg (gensym)]
+ [ret (gensym)] )
+ (##sys#hash-table-set! foreign-type-table name (vector type arg ret))
+ (mark-variable arg '##compiler#always-bound)
+ (mark-variable ret '##compiler#always-bound)
+ (hide-variable arg)
+ (hide-variable ret)
+ (walk
+ `(##core#begin
+ (define ,arg ,(first conv))
+ (define
+ ,ret
+ ,(if (pair? (cdr conv)) (second conv) '##sys#values)) )
+ e se dest) ) ]
+ [else
+ (##sys#hash-table-set! foreign-type-table name type)
+ '(##core#undefined) ] ) ) )
+
+ ((define-external-variable)
+ (let* ([sym (second x)]
+ [name (symbol->string sym)]
+ [type (third x)]
+ [exported (fourth x)]
+ [rname (make-random-name)] )
+ (unless exported (set! name (symbol->string (fifth x))))
+ (set! external-variables (cons (vector name type exported) external-variables))
+ (set! foreign-variables
+ (cons (list rname 'c-pointer (string-append "&" name))
+ foreign-variables) )
+ (set! external-to-pointer (alist-cons sym rname external-to-pointer))
+ '(##core#undefined) ) )
+
+ ((##core#let-location)
+ (let* ([var (second x)]
+ [type (##sys#strip-syntax (third x))]
+ [alias (gensym)]
+ [store (gensym)]
+ [init (and (pair? (cddddr x)) (fourth x))] )
+ (set-real-name! alias var)
+ (set! location-pointer-map
+ (cons (list alias store type) location-pointer-map) )
+ (walk
+ `(let (,(let ([size (words (estimate-foreign-result-location-size type))])
+ ;; Add 2 words: 1 for the header, 1 for double-alignment:
+ ;; Note: C_a_i_bytevector takes number of words, not bytes
+ (list
+ store
+ `(##core#inline_allocate
+ ("C_a_i_bytevector" ,(+ 2 size))
+ ',size)) ) )
+ (##core#begin
+ ,@(if init
+ `((##core#set! ,alias ,init))
+ '() )
+ ,(if init (fifth x) (fourth x)) ) )
+ e (alist-cons var alias se)
+ dest) ) )
+
+ ((##core#define-inline)
+ (let* ((name (second x))
+ (val `(##core#lambda ,@(cdaddr x))))
+ (##sys#hash-table-set! inline-table name val)
+ (set! inline-table-used #t)
+ '(##core#undefined)))
+
+ ((define-constant)
+ (let* ([name (second x)]
+ [valexp (third x)]
+ [val (handle-exceptions ex
+ ;; could show line number here
+ (quit "error in constant evaluation of ~S for named constant ~S"
+ valexp name)
+ (if (collapsable-literal? valexp)
+ valexp
+ (eval
+ `(##core#let
+ ,defconstant-bindings ,valexp)) ) ) ] )
+ (set! constants-used #t)
+ (set! defconstant-bindings (cons (list name `',val) defconstant-bindings))
+ (cond [(collapsable-literal? val)
+ (##sys#hash-table-set! constant-table name (list val))
+ '(##core#undefined) ]
+ [else
+ (let ([var (gensym "constant")])
+ (##sys#hash-table-set! constant-table name (list var))
+ (hide-variable var)
+ (mark-variable var '##compiler#constant)
+ (mark-variable var '##compiler#always-bound)
+ (walk `(define ,var ',val) e se #f) ) ] ) ) )
+
+ ((##core#declare)
+ (walk
+ `(##core#begin
+ ,@(map (lambda (d)
+ (process-declaration d se))
+ (cdr x) ) )
+ e '() #f) )
+
+ ((##core#foreign-callback-wrapper)
+ (let-values ([(args lam) (split-at (cdr x) 4)])
+ (let* ([lam (car lam)]
+ [name (cadr (first args))]
+ [rtype (cadr (third args))]
+ [atypes (cadr (fourth args))]
+ [vars (second lam)] )
+ (if (valid-c-identifier? name)
+ (set! callback-names (cons name callback-names))
+ (quit "name `~S' of external definition is not a valid C identifier"
+ name) )
+ (when (or (not (proper-list? vars))
+ (not (proper-list? atypes))
+ (not (= (length vars) (length atypes))) )
+ (syntax-error
+ "non-matching or invalid argument list to foreign callback-wrapper"
+ vars atypes) )
+ `(##core#foreign-callback-wrapper
+ ,@(mapwalk args e se)
+ ,(walk `(##core#lambda
+ ,vars
+ (##core#let
+ ,(let loop ([vars vars] [types atypes])
+ (if (null? vars)
+ '()
+ (let ([var (car vars)]
+ [type (car types)] )
+ (cons
+ (list
+ var
+ (foreign-type-convert-result
+ (finish-foreign-result (final-foreign-type type) var)
+ type) )
+ (loop (cdr vars) (cdr types)) ) ) ) )
+ ,(foreign-type-convert-argument
+ `(##core#let
+ ()
+ ,@(cond
+ ((member
+ rtype
+ '((const nonnull-c-string)
+ (const nonnull-unsigned-c-string)
+ nonnull-unsigned-c-string
+ nonnull-c-string))
+ `((##sys#make-c-string
+ (##core#let
+ () ,@(cddr lam)))))
+ ((member
+ rtype
+ '((const c-string*)
+ (const unsigned-c-string*)
+ unsigned-c-string*
+ c-string*
+ c-string-list
+ c-string-list*))
+ (syntax-error
+ "not a valid result type for callback procedures"
+ rtype
+ name) )
+ ((member
+ rtype
+ '(c-string
+ (const unsigned-c-string)
+ unsigned-c-string
+ (const c-string)) )
+ `((##core#let
+ ((r (##core#let () ,@(cddr lam))))
+ (,(macro-alias 'and se)
+ r
+ (##sys#make-c-string r)) ) ) )
+ (else (cddr lam)) ) )
+ rtype) ) )
+ e se #f) ) ) ) )
+
+ (else
+ (let ([handle-call
+ (lambda ()
+ (let* ([x2 (mapwalk x e se)]
+ [head2 (car x2)]
+ [old (##sys#hash-table-ref line-number-database-2 head2)] )
+ (when ln
+ (##sys#hash-table-set!
+ line-number-database-2
+ head2
+ (cons name (alist-cons x2 ln (if old (cdr old) '()))) ) )
+ x2) ) ] )
+
+ (cond [(eq? 'location name)
+ (##sys#check-syntax 'location x '(location _) #f se)
+ (let ([sym (cadr x)])
+ (if (symbol? sym)
+ (cond [(assq (lookup sym se) location-pointer-map)
+ => (lambda (a)
+ (walk
+ `(##sys#make-locative ,(second a) 0 #f 'location)
+ e se #f) ) ]
+ [(assq sym external-to-pointer)
+ => (lambda (a) (walk (cdr a) e se #f)) ]
+ [(memq sym callback-names)
+ `(##core#inline_ref (,(symbol->string sym) c-pointer)) ]
+ [else
+ (walk `(##sys#make-locative ,sym 0 #f 'location) e se #f) ] )
+ (walk `(##sys#make-locative ,sym 0 #f 'location) e se #f) ) ) ]
+
+ [else (handle-call)] ) ) ) ) ] ) ) ) )
+
+ ((not (proper-list? x))
+ (syntax-error "malformed expression" x) )
+
+ ((constant? (car x))
+ (emit-syntax-trace-info x #f)
+ (compiler-warning 'syntax "literal in operator position: ~S" x)
+ (mapwalk x e se) )
+
+ (else
+ (emit-syntax-trace-info x #f)
+ (let ((x (mapwalk x e se)))
+ (if (and (pair? (car x))
+ (symbol? (caar x))
+ (memq (or (lookup (caar x) se) (caar x)) '(lambda ##core#lambda)))
+ (let ((lexp (car x))
+ (args (cdr x)) )
+ (##sys#check-syntax 'lambda lexp '(_ lambda-list . #(_ 1)) #f se)
+ (let ((llist (cadr lexp)))
+ (if (and (proper-list? llist) (= (llist-length llist) (length args)))
+ `(let ,(map list llist args) ,@(cddr lexp))
+ (let ((var (gensym 't)))
+ `(let ((,var ,(car x)))
+ (,var ,@(cdr x)) ) ) ) ) )
+ x))) ) )
+
+ (define (mapwalk xs e se)
+ (map (lambda (x) (walk x e se #f)) xs) )
+
+ (when (memq 'c debugging-chicken) (newline) (pretty-print exp))
+ (##sys#clear-trace-buffer)
+ ;; Process visited definitions and main expression:
+ (walk
+ `(##core#begin
+ ,@(let ([p (reverse pending-canonicalizations)])
+ (set! pending-canonicalizations '())
+ p)
+ ,(begin
+ (set! extended-bindings (append internal-bindings extended-bindings))
+ exp) )
+ '() (##sys#current-environment)
+ #f) )
+
+
+(define (process-declaration spec se) ; se unused in the moment
+ (define (check-decl spec minlen . maxlen)
+ (let ([n (length (cdr spec))])
+ (if (or (< n minlen) (> n (optional maxlen 99999)))
+ (syntax-error "invalid declaration" spec) ) ) )
+ (define (stripa x) ; global aliasing
+ (##sys#strip-syntax x se #t))
+ (define (strip x) ; raw symbol
+ (##sys#strip-syntax x se))
+ (define stripu ##sys#strip-syntax)
+ (call-with-current-continuation
+ (lambda (return)
+ (unless (pair? spec)
+ (syntax-error "invalid declaration specification" spec) )
+ ;(pp `(DECLARE: ,(strip spec)))
+ (case (##sys#strip-syntax (car spec)) ; no global aliasing
+ ((uses)
+ (let ((us (stripu (cdr spec))))
+ (apply register-feature! us)
+ (when (pair? us)
+ (##sys#hash-table-update!
+ file-requirements 'static
+ (cut lset-union eq? us <>)
+ (lambda () us))
+ (let ((units (map (lambda (u) (string->c-identifier (stringify u))) us)))
+ (set! used-units (append used-units units)) ) ) ) )
+ ((unit)
+ (check-decl spec 1 1)
+ (let* ([u (stripu (cadr spec))]
+ [un (string->c-identifier (stringify u))] )
+ (when (and unit-name (not (string=? unit-name un)))
+ (compiler-warning 'usage "unit was already given a name (new name is ignored)") )
+ (set! unit-name un) ) )
+ ((standard-bindings)
+ (if (null? (cdr spec))
+ (set! standard-bindings default-standard-bindings)
+ (set! standard-bindings (append (stripa (cdr spec)) standard-bindings)) ) )
+ ((extended-bindings)
+ (if (null? (cdr spec))
+ (set! extended-bindings default-extended-bindings)
+ (set! extended-bindings (append (stripa (cdr spec)) extended-bindings)) ) )
+ ((usual-integrations)
+ (cond [(null? (cdr spec))
+ (set! standard-bindings default-standard-bindings)
+ (set! extended-bindings default-extended-bindings) ]
+ [else
+ (let ([syms (stripa (cdr spec))])
+ (set! standard-bindings (lset-intersection eq? syms default-standard-bindings))
+ (set! extended-bindings (lset-intersection eq? syms default-extended-bindings)) ) ] ) )
+ ((number-type)
+ (check-decl spec 1 1)
+ (set! number-type (strip (cadr spec))))
+ ((fixnum fixnum-arithmetic) (set! number-type 'fixnum))
+ ((generic) (set! number-type 'generic))
+ ((unsafe) (set! unsafe #t))
+ ((safe) (set! unsafe #f))
+ ((no-bound-checks) (set! no-bound-checks #t))
+ ((no-argc-checks) (set! no-argc-checks #t))
+ ((no-procedure-checks) (set! no-procedure-checks #t))
+ ((interrupts-enabled) (set! insert-timer-checks #t))
+ ((disable-interrupts) (set! insert-timer-checks #f))
+ ((disable-warning)
+ (set! disabled-warnings
+ (append (strip (cdr spec)) disabled-warnings)))
+ ((always-bound)
+ (for-each (cut mark-variable <> '##compiler#always-bound) (stripa (cdr spec))))
+ ((safe-globals) (set! safe-globals-flag #t))
+ ((no-procedure-checks-for-usual-bindings)
+ (for-each
+ (cut mark-variable <> '##compiler#always-bound-to-procedure)
+ (append default-standard-bindings default-extended-bindings))
+ (for-each
+ (cut mark-variable <> '##compiler#always-bound)
+ (append default-standard-bindings default-extended-bindings)))
+ ((bound-to-procedure)
+ (let ((vars (stripa (cdr spec))))
+ (for-each (cut mark-variable <> '##compiler#always-bound-to-procedure) vars)
+ (for-each (cut mark-variable <> '##compiler#always-bound) vars)))
+ ((foreign-declare)
+ (let ([fds (cdr spec)])
+ (if (every string? fds)
+ (set! foreign-declarations (append foreign-declarations fds))
+ (syntax-error "invalid declaration" spec) ) ) )
+ ((c-options)
+ (emit-control-file-item `(c-options ,@(strip (cdr spec)))) )
+ ((link-options)
+ (emit-control-file-item `(link-options ,@(strip (cdr spec))) ) )
+ ((post-process)
+ (emit-control-file-item
+ (let ([file (pathname-strip-extension source-filename)])
+ `(post-process ,@(map (cut string-substitute "\\$@" file <>) (cdr spec))) ) ) )
+ ((block) (set! block-compilation #t))
+ ((separate) (set! block-compilation #f))
+ ((keep-shadowed-macros) (set! undefine-shadowed-macros #f))
+ ((unused)
+ (for-each (cut mark-variable <> '##compiler#unused) (stripa (cdr spec))))
+ ((not)
+ (check-decl spec 1)
+ (case (##sys#strip-syntax (second spec)) ; strip all
+ [(standard-bindings)
+ (if (null? (cddr spec))
+ (set! standard-bindings '())
+ (set! standard-bindings
+ (lset-difference eq? default-standard-bindings
+ (stripa (cddr spec))))) ]
+ [(extended-bindings)
+ (if (null? (cddr spec))
+ (set! extended-bindings '())
+ (set! extended-bindings
+ (lset-difference eq? default-extended-bindings
+ (stripa (cddr spec))) )) ]
+ [(inline)
+ (if (null? (cddr spec))
+ (set! inline-locally #f)
+ (for-each
+ (cut mark-variable <> '##compiler#inline 'no)
+ (stripa (cddr spec)))) ]
+ [(usual-integrations)
+ (cond [(null? (cddr spec))
+ (set! standard-bindings '())
+ (set! extended-bindings '()) ]
+ [else
+ (let ([syms (stripa (cddr spec))])
+ (set! standard-bindings (lset-difference eq? default-standard-bindings syms))
+ (set! extended-bindings (lset-difference eq? default-extended-bindings syms)) ) ] ) ]
+ ((inline-global)
+ (set! enable-inline-files #t)
+ (if (null? (cddr spec))
+ (set! inline-globally #f)
+ (for-each
+ (cut mark-variable <> '##compiler#inline-global 'no)
+ (stripa (cddr spec)))))
+ [else
+ (check-decl spec 1 1)
+ (let ((id (strip (cadr spec))))
+ (case id
+ [(interrupts-enabled) (set! insert-timer-checks #f)]
+ [(safe) (set! unsafe #t)]
+ [else (compiler-warning 'syntax "illegal declaration specifier `~s'" id)]))]))
+ ((compile-syntax
+ run-time-macros) ; DEPRECATED
+ (set! ##sys#enable-runtime-macros #t))
+ ((block-global hide)
+ (let ([syms (stripa (cdr spec))])
+ (if (null? syms)
+ (set! block-compilation #t)
+ (for-each hide-variable syms))))
+ ((export)
+ (set! block-compilation #t)
+ (let ((syms (stripa (cdr spec))))
+ (for-each export-variable syms)))
+ ((emit-external-prototypes-first)
+ (set! external-protos-first #t) )
+ ((lambda-lift) (set! do-lambda-lifting #t))
+ ((inline)
+ (if (null? (cdr spec))
+ (set! inline-locally #t)
+ (for-each
+ (cut mark-variable <> '##compiler#inline 'yes)
+ (stripa (cdr spec)))))
+ ((inline-limit)
+ (check-decl spec 1 1)
+ (let ([n (cadr spec)])
+ (if (number? n)
+ (set! inline-max-size n)
+ (compiler-warning
+ 'syntax
+ "invalid argument to `inline-limit' declaration: ~s" spec) ) ) )
+ ((constant)
+ (let ((syms (cdr spec)))
+ (if (every symbol? syms)
+ (set! constant-declarations (append syms constant-declarations))
+ (quit "invalid arguments to `constant' declaration: ~S" spec)) ) )
+ ((emit-import-library)
+ (set! import-libraries
+ (append
+ import-libraries
+ (map (lambda (il)
+ (cond ((symbol? il)
+ (cons il (string-append (symbol->string il) ".import.scm")) )
+ ((and (list? il) (= 2 (length il))
+ (symbol? (car il)) (string (cadr il)))
+ (cons (car il) (cadr il)))
+ (else
+ (compiler-warning
+ 'syntax
+ "invalid import-library specification: ~s" il))))
+ (strip (cdr spec))))))
+ ((profile)
+ (set! emit-profile #t)
+ (cond ((null? (cdr spec))
+ (set! profiled-procedures 'all) )
+ (else
+ (set! profiled-propcedures 'some)
+ (for-each
+ (cut mark-variable <> '##compiler#profile)
+ (stripa (cdr spec))))))
+ ((local)
+ (cond ((null? (cdr spec))
+ (set! local-definitions #t) )
+ (else
+ (for-each
+ (cut mark-variable <> '##compiler#local)
+ (stripa (cdr spec))))))
+ ((inline-global)
+ (set! enable-inline-files #t)
+ (set! inline-locally #t)
+ (if (null? (cdr spec))
+ (set! inline-globally #t)
+ (for-each
+ (cut mark-variable <> '##compiler#inline-global 'yes)
+ (stripa (cdr spec)))))
+ ((type)
+ (for-each
+ (lambda (spec)
+ (cond ((and (list? spec) (symbol? (car spec)) (= 2 (length spec)))
+ (##sys#put! (car spec) '##core#type (cadr spec))
+ (##sys#put! (car spec) '##core#declared-type #t))
+ (else
+ (compiler-warning 'syntax "illegal `type' declaration item `~s'" spec))))
+ (cdr spec)))
+ ((scrutinize)
+ (set! do-scrutinize #t))
+ (else (compiler-warning 'syntax "illegal declaration specifier `~s'" spec)) )
+ '(##core#undefined) ) ) )
+
+
+;;; Expand "foreign-lambda"/"foreign-callback-lambda" forms and add item to stub-list:
+
+(define-record-type foreign-stub
+ (make-foreign-stub id return-type name argument-types argument-names body cps callback)
+ foreign-stub?
+ (id foreign-stub-id) ; symbol
+ (return-type foreign-stub-return-type) ; type-specifier
+ (name foreign-stub-name) ; string or #f
+ (argument-types foreign-stub-argument-types) ; (type-specifier...)
+ (argument-names foreign-stub-argument-names) ; #f or (symbol ...)
+ (body foreign-stub-body) ; #f or string
+ (cps foreign-stub-cps) ; boolean
+ (callback foreign-stub-callback)) ; boolean
+
+(define (create-foreign-stub rtype sname argtypes argnames body callback cps)
+ (let* ((rtype (##sys#strip-syntax rtype))
+ (argtypes (##sys#strip-syntax argtypes))
+ [params (list-tabulate (length argtypes) (lambda (x) (gensym 'a)))]
+ [f-id (gensym 'stub)]
+ [bufvar (gensym)]
+ [rsize (estimate-foreign-result-size rtype)] )
+ (set-real-name! f-id #t)
+ (set! foreign-lambda-stubs
+ (cons (make-foreign-stub f-id rtype sname argtypes argnames body cps callback)
+ foreign-lambda-stubs) )
+ (let ([rsize (if callback (+ rsize 24) rsize)] ; 24 -> has to hold cons on 64-bit platforms!
+ [head (if cps
+ `((##core#primitive ,f-id))
+ `(##core#inline ,f-id) ) ]
+ [rest (map (lambda (p t) (foreign-type-check (foreign-type-convert-argument p t) t)) params argtypes)] )
+ `(lambda ,params
+ ;; Do minor GC (if callback) to make room on stack:
+ ,@(if callback '((##sys#gc #f)) '())
+ ,(if (zero? rsize)
+ (foreign-type-convert-result (append head (cons '(##core#undefined) rest)) rtype)
+ (let ([ft (final-foreign-type rtype)]
+ [ws (words rsize)] )
+ `(let ([,bufvar (##core#inline_allocate ("C_a_i_bytevector" ,(+ 2 ws)) ',ws)])
+ ,(foreign-type-convert-result
+ (finish-foreign-result ft (append head (cons bufvar rest)))
+ rtype) ) ) ) ) ) ) )
+
+(define (expand-foreign-lambda exp callback?)
+ (let* ([name (third exp)]
+ [sname (cond ((symbol? name) (symbol->string (##sys#strip-syntax name)))
+ ((string? name) name)
+ (else (quit "name `~s' of foreign procedure has wrong type" name)) ) ]
+ [rtype (second exp)]
+ [argtypes (cdddr exp)] )
+ (create-foreign-stub rtype sname argtypes #f #f callback? callback?) ) )
+
+(define (expand-foreign-lambda* exp callback?)
+ (let* ([rtype (second exp)]
+ [args (third exp)]
+ [body (apply string-append (cdddr exp))]
+ [argtypes (map car args)]
+ ;; C identifiers aren't hygienically renamed inside body strings
+ [argnames (map cadr (##sys#strip-syntax args))] )
+ (create-foreign-stub rtype #f argtypes argnames body callback? callback?) ) )
+
+;; TODO: Try to fold this procedure into expand-foreign-lambda*
+(define (expand-foreign-primitive exp)
+ (let* ([hasrtype (and (pair? (cddr exp)) (not (string? (caddr exp))))]
+ [rtype (if hasrtype (second exp) 'void)]
+ [args (##sys#strip-syntax (if hasrtype (third exp) (second exp)))]
+ [body (apply string-append (if hasrtype (cdddr exp) (cddr exp)))]
+ [argtypes (map car args)]
+ ;; C identifiers aren't hygienically renamed inside body strings
+ [argnames (map cadr (##sys#strip-syntax args))] )
+ (create-foreign-stub rtype #f argtypes argnames body #f #t) ) )
+
+
+;;; Traverse expression and update line-number db with all contained calls:
+
+(define (update-line-number-database! exp ln)
+ (define (mapupdate xs)
+ (let loop ((xs xs))
+ (if (pair? xs)
+ (begin
+ (walk (car xs))
+ (loop (cdr xs)) ) ) ) )
+ (define (walk x)
+ (cond ((not-pair? x))
+ ((symbol? (car x))
+ (let* ((name (car x))
+ (old (or (##sys#hash-table-ref ##sys#line-number-database name) '())) )
+ (if (not (assq x old))
+ (##sys#hash-table-set! ##sys#line-number-database name (alist-cons x ln old)) )
+ (mapupdate (cdr x)) ) )
+ (else (mapupdate x)) ) )
+ (walk exp) )
+
+
+;;; Convert canonicalized node-graph into continuation-passing-style:
+
+(define (perform-cps-conversion node)
+
+ (define (cps-lambda id llist subs k)
+ (let ([t1 (gensym 'k)])
+ (k (make-node
+ '##core#lambda (list id #t (cons t1 llist) 0)
+ (list (walk (car subs)
+ (lambda (r)
+ (make-node '##core#call '(#t) (list (varnode t1) r)) ) ) ) ) ) ) )
+
+ (define (walk n k)
+ (let ((subs (node-subexpressions n))
+ (params (node-parameters n))
+ (class (node-class n)) )
+ (case (node-class n)
+ ((##core#variable quote ##core#undefined ##core#primitive ##core#global-ref) (k n))
+ ((if) (let* ((t1 (gensym 'k))
+ (t2 (gensym 'r))
+ (k1 (lambda (r) (make-node '##core#call '(#t) (list (varnode t1) r)))) )
+ (make-node 'let
+ (list t1)
+ (list (make-node '##core#lambda (list (gensym-f-id) #f (list t2) 0)
+ (list (k (varnode t2))) )
+ (walk (car subs)
+ (lambda (v)
+ (make-node 'if '()
+ (list v
+ (walk (cadr subs) k1)
+ (walk (caddr subs) k1) ) ) ) ) ) ) ) )
+ ((let)
+ (let loop ((vars params) (vals subs))
+ (if (null? vars)
+ (walk (car vals) k)
+ (walk (car vals)
+ (lambda (r)
+ (make-node 'let
+ (list (car vars))
+ (list r (loop (cdr vars) (cdr vals))) ) ) ) ) ) )
+ ((lambda ##core#lambda) (cps-lambda (gensym-f-id) (first params) subs k))
+ ((set!) (let ((t1 (gensym 't)))
+ (walk (car subs)
+ (lambda (r)
+ (make-node 'let (list t1)
+ (list (make-node 'set! (list (first params)) (list r))
+ (k (varnode t1)) ) ) ) ) ) )
+ ((##core#foreign-callback-wrapper)
+ (let ([id (gensym-f-id)]
+ [lam (first subs)] )
+ (set! foreign-callback-stubs
+ (cons (apply make-foreign-callback-stub id params) foreign-callback-stubs) )
+ (cps-lambda id (first (node-parameters lam)) (node-subexpressions lam) k) ) )
+ ((##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update ##core#inline_loc_ref
+ ##core#inline_loc_update)
+ (walk-inline-call class params subs k) )
+ ((##core#call) (walk-call (car subs) (cdr subs) params k))
+ ((##core#callunit) (walk-call-unit (first params) k))
+ (else (bomb "bad node (cps)")) ) ) )
+
+ (define (walk-call fn args params k)
+ (let ((t0 (gensym 'k))
+ (t3 (gensym 'r)) )
+ (make-node
+ 'let (list t0)
+ (list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0)
+ (list (k (varnode t3))) )
+ (walk-arguments
+ args
+ (lambda (vars)
+ (walk fn
+ (lambda (r)
+ (make-node '##core#call params (cons* r (varnode t0) vars) ) ) ) ) ) ) ) ) )
+
+ (define (walk-call-unit unitname k)
+ (let ((t0 (gensym 'k))
+ (t3 (gensym 'r)) )
+ (make-node
+ 'let (list t0)
+ (list (make-node '##core#lambda (list (gensym-f-id) #f (list t3) 0)
+ (list (k (varnode t3))) )
+ (make-node '##core#callunit (list unitname)
+ (list (varnode t0)) ) ) ) ) )
+
+ (define (walk-inline-call class op args k)
+ (walk-arguments
+ args
+ (lambda (vars)
+ (k (make-node class op vars)) ) ) )
+
+ (define (walk-arguments args wk)
+ (let loop ((args args) (vars '()))
+ (cond ((null? args) (wk (reverse vars)))
+ ((atomic? (car args))
+ (loop (cdr args) (cons (car args) vars)) )
+ (else
+ (let ((t1 (gensym 'a)))
+ (walk (car args)
+ (lambda (r)
+ (make-node 'let (list t1)
+ (list r
+ (loop (cdr args)
+ (cons (varnode t1) vars) ) ) ) ) ) ) ) ) ) )
+
+ (define (atomic? n)
+ (let ((class (node-class n)))
+ (or (memq class '(quote ##core#variable ##core#undefined ##core#global-ref))
+ (and (memq class '(##core#inline ##core#inline_allocate ##core#inline_ref ##core#inline_update
+ ##core#inline_loc_ref ##core#inline_loc_update))
+ (every atomic? (node-subexpressions n)) ) ) ) )
+
+ (walk node values) )
+
+
+;;; Foreign callback stub type:
+
+(define-record-type foreign-callback-stub
+ (make-foreign-callback-stub id name qualifiers return-type argument-types)
+ foreign-callback-stub?
+ (id foreign-callback-stub-id) ; symbol
+ (name foreign-callback-stub-name) ; string
+ (qualifiers foreign-callback-stub-qualifiers) ; string
+ (return-type foreign-callback-stub-return-type) ; type-specifier
+ (argument-types foreign-callback-stub-argument-types)) ; (type-specifier ...)
+
+
+;;; Perform source-code analysis:
+
+(define (analyze-expression node)
+ (let ([db (make-vector analysis-database-size '())]
+ [explicitly-consed '()] )
+
+ (define (grow n)
+ (set! current-program-size (+ current-program-size n)) )
+
+ (define (walk n env localenv here call)
+ (let ((subs (node-subexpressions n))
+ (params (node-parameters n))
+ (class (node-class n)) )
+ (grow 1)
+ (case class
+ ((quote ##core#undefined ##core#proc) #f)
+
+ ((##core#variable)
+ (let ((var (first params)))
+ (ref var n)
+ (unless (memq var localenv)
+ (grow 1)
+ (cond ((memq var env)
+ (put! db var 'captured #t))
+ ((not (get db var 'global))
+ (put! db var 'global #t) ) ) ) ) )
+
+ ((##core#global-ref)
+ (let ((var (first params)))
+ (ref var n)
+ (grow 1)
+ (put! db var 'global #t) ) )
+
+ ((##core#callunit ##core#recurse)
+ (grow 1)
+ (walkeach subs env localenv here #f) )
+
+ ((##core#call)
+ (grow 1)
+ (let ([fun (car subs)])
+ (if (eq? '##core#variable (node-class fun))
+ (let ([name (first (node-parameters fun))])
+ (collect! db name 'call-sites (cons here n))
+ ;; If call to standard-binding & optimizable rest-arg operator: decrease access count:
+ (if (and (intrinsic? name)
+ (memq name optimizable-rest-argument-operators) )
+ (for-each
+ (lambda (arg)
+ (and-let* ([(eq? '##core#variable (node-class arg))]
+ [var (first (node-parameters arg))] )
+ (when (get db var 'rest-parameter) (count! db var 'o-r/access-count)) ) )
+ (cdr subs) ) ) ) )
+ (walk (first subs) env localenv here #t)
+ (walkeach (cdr subs) env localenv here #f) ) )
+
+ ((let ##core#let)
+ (let ([env2 (append params localenv env)])
+ (let loop ([vars params] [vals subs])
+ (if (null? vars)
+ (walk (car vals) env (append params localenv) here #f)
+ (let ([var (car vars)]
+ [val (car vals)] )
+ (put! db var 'home here)
+ (assign var val env2 here)
+ (walk val env localenv here #f)
+ (loop (cdr vars) (cdr vals)) ) ) ) ) )
+
+ ((lambda)
+ (grow 1)
+ (decompose-lambda-list
+ (first params)
+ (lambda (vars argc rest)
+ (for-each
+ (lambda (var) (put! db var 'unknown #t))
+ vars)
+ (let ([tl toplevel-scope])
+ (set! toplevel-scope #f)
+ (walk (car subs) (append localenv env) vars #f #f)
+ (set! toplevel-scope tl) ) ) ) )
+
+ ((##core#lambda ##core#direct_lambda)
+ (grow 1)
+ (decompose-lambda-list
+ (third params)
+ (lambda (vars argc rest)
+ (let ([id (first params)]
+ [size0 current-program-size] )
+ (when here
+ (collect! db here 'contains id)
+ (put! db id 'contained-in here) )
+ (for-each
+ (lambda (var)
+ (put! db var 'home here)
+ (put! db var 'unknown #t) )
+ vars)
+ (when rest
+ (put! db rest 'rest-parameter
+ (if (memq rest rest-parameters-promoted-to-vector)
+ 'vector
+ 'list) ) )
+ (when (simple-lambda-node? n) (put! db id 'simple #t))
+ (let ([tl toplevel-scope])
+ (unless toplevel-lambda-id (set! toplevel-lambda-id id))
+ (when (and (second params) (not (eq? toplevel-lambda-id id)))
+ (set! toplevel-scope #f)) ; only if non-CPS lambda
+ (walk (car subs) (append localenv env) vars id #f)
+ (set! toplevel-scope tl)
+ ;; decorate ##core#call node with size
+ (set-car! (cdddr (node-parameters n)) (- current-program-size size0)) ) ) ) ) )
+
+ ((set! ##core#set!)
+ (let* ([var (first params)]
+ [val (car subs)] )
+ (when first-analysis
+ (case (variable-mark var '##compiler#intrinsic)
+ ((standard)
+ (compiler-warning 'redef "redefinition of standard binding `~S'" var) )
+ ((extended)
+ (compiler-warning 'redef "redefinition of extended binding `~S'" var) ) )
+ (put! db var 'potential-value val) )
+ (unless (memq var localenv)
+ (grow 1)
+ (cond ((memq var env)
+ (put! db var 'captured #t))
+ ((not (get db var 'global))
+ (put! db var 'global #t) ) ) )
+ (assign var val (append localenv env) here)
+ (unless toplevel-scope (put! db var 'assigned-locally #t))
+ (put! db var 'assigned #t)
+ (walk (car subs) env localenv here #f) ) )
+
+ ((##core#primitive ##core#inline)
+ (let ([id (first params)])
+ (when (and first-analysis here (symbol? id) (##sys#hash-table-ref real-name-table id))
+ (set-real-name! id here) )
+ (walkeach subs env localenv here #f) ) )
+
+ (else (walkeach subs env localenv here #f)) ) ) )
+
+ (define (walkeach xs env lenv here call)
+ (for-each (lambda (x) (walk x env lenv here call)) xs) )
+
+ (define (assign var val env here)
+ (cond ((eq? '##core#undefined (node-class val))
+ (put! db var 'undefined #t) )
+ ((and (eq? '##core#variable (node-class val)) ; assignment to itself
+ (eq? var (first (node-parameters val))) ) )
+ ((or (memq var env)
+ (variable-mark var '##compiler#constant)
+ (not (variable-visible? var)))
+ (let ((props (get-all db var 'unknown 'value))
+ (home (get db var 'home)) )
+ (unless (assq 'unknown props)
+ (if (assq 'value props)
+ (put! db var 'unknown #t)
+ (if (or (not home) (eq? here home))
+ (put! db var 'value val)
+ (put! db var 'unknown #t) ) ) ) ) )
+ ((and (or local-definitions
+ (variable-mark var '##compiler#local))
+ (not (get db var 'unknown)))
+ (let ((home (get db var 'home)))
+ (cond ((get db var 'local-value)
+ (put! db var 'unknown #t))
+ ((or (not home) (eq? here home))
+ (put! db var 'local-value val) )
+ (else (put! db var 'unknown #t)))))
+ (else (put! db var 'unknown #t)) ) )
+
+ (define (ref var node)
+ (collect! db var 'references node) )
+
+ (define (quick-put! plist prop val)
+ (set-cdr! plist (alist-cons prop val (cdr plist))) )
+
+ ;; Return true if <id> directly or indirectly contains any of <other-ids>:
+ (define (contains? id other-ids)
+ (or (memq id other-ids)
+ (let ((clist (get db id 'contains)))
+ (and clist
+ (any (lambda (id2) (contains? id2 other-ids)) clist) ) ) ) )
+
+ ;; Walk toplevel expression-node:
+ (debugging 'p "analysis traversal phase...")
+ (set! current-program-size 0)
+ (walk node '() '() #f #f)
+
+ ;; Complete gathered database information:
+ (debugging 'p "analysis gathering phase...")
+ (##sys#hash-table-for-each
+ (lambda (sym plist)
+ (let ([unknown #f]
+ [value #f]
+ [local-value #f]
+ [pvalue #f]
+ [references '()]
+ [captured #f]
+ [call-sites '()]
+ [assigned #f]
+ [assigned-locally #f]
+ [undefined #f]
+ [global #f]
+ [o-r/access-count 0]
+ [rest-parameter #f]
+ [nreferences 0]
+ [ncall-sites 0] )
+
+ (for-each
+ (lambda (prop)
+ (case (car prop)
+ [(unknown) (set! unknown #t)]
+ [(references)
+ (set! references (cdr prop))
+ (set! nreferences (length references)) ]
+ [(captured) (set! captured #t)]
+ [(potential-value) (set! pvalue (cdr prop))]
+ [(call-sites)
+ (set! call-sites (cdr prop))
+ (set! ncall-sites (length call-sites)) ]
+ [(assigned) (set! assigned #t)]
+ [(assigned-locally) (set! assigned-locally #t)]
+ [(undefined) (set! undefined #t)]
+ [(global) (set! global #t)]
+ [(value) (set! value (cdr prop))]
+ [(local-value) (set! local-value (cdr prop))]
+ [(o-r/access-count) (set! o-r/access-count (cdr prop))]
+ [(rest-parameter) (set! rest-parameter #t)] ) )
+ plist)
+
+ (set! value (and (not unknown) value))
+ (set! local-value (and (not unknown) local-value))
+
+ ;; If this is the first analysis, register known local or potentially known global lambda-value id's
+ ;; along with their names:
+ (when (and first-analysis
+ (eq? '##core#lambda
+ (and-let* ([val (or value (and global pvalue))])
+ (node-class val) ) ) )
+ (set-real-name! (first (node-parameters (or value pvalue))) sym) )
+
+ ;; If this is the first analysis and the variable is global and has no references and we are
+ ;; in block mode, then issue warning:
+ (when (and first-analysis
+ global
+ (null? references)
+ (not (variable-mark sym '##compiler#unused)))
+ (when assigned-locally
+ (compiler-warning 'var "local assignment to unused variable `~S' may be unintended" sym) )
+ (when (and (not (variable-visible? sym))
+ (not (variable-mark sym '##compiler#constant)) )
+ (compiler-warning 'var "global variable `~S' is never used" sym) ) )
+
+ ;; Make 'boxed, if 'assigned & 'captured:
+ (when (and assigned captured)
+ (quick-put! plist 'boxed #t) )
+
+ ;; Make 'contractable, if it has a procedure as known value, has only one use and one call-site and
+ ;; if the lambda has no free non-global variables or is an internal lambda. Make 'inlinable if
+ ;; use/call count is not 1:
+ (cond (value
+ (let ((valparams (node-parameters value)))
+ (when (and (eq? '##core#lambda (node-class value))
+ (or (not (second valparams))
+ (every
+ (lambda (v) (get db v 'global))
+ (nth-value 0 (scan-free-variables value)) ) ) )
+ (if (and (= 1 nreferences) (= 1 ncall-sites))
+ (quick-put! plist 'contractable #t)
+ (quick-put! plist 'inlinable #t) ) ) ) )
+ (local-value
+ ;; Make 'inlinable, if it is declared local and has a value
+ (let ((valparams (node-parameters local-value)))
+ (when (eq? '##core#lambda (node-class local-value))
+ (let-values (((vars hvars) (scan-free-variables local-value)))
+ (when (and (get db sym 'global)
+ (pair? hvars))
+ (quick-put! plist 'hidden-refs #t))
+ (when (or (not (second valparams))
+ (every
+ (lambda (v) (get db v 'global))
+ vars))
+ (quick-put! plist 'inlinable #t) ) ) ) ) )
+ ((variable-mark sym '##compiler#inline-global) =>
+ (lambda (n)
+ (when (node? n)
+ (cond (assigned
+ (debugging
+ 'i "global inlining candidate was assigned and will not be inlined"
+ sym)
+ (mark-variable sym '##compiler#inline-global 'no))
+ (else
+ (let ((lparams (node-parameters n)))
+ (quick-put! plist 'inlinable #t)
+ (quick-put! plist 'local-value n))))))))
+
+ ;; Make 'collapsable, if it has a known constant value which is either collapsable or is only
+ ;; referenced once and if no assignments are made:
+ (when (and value
+ ;; (not (assq 'assigned plist)) - If it has a known value, it's assigned just once!
+ (eq? 'quote (node-class value)) )
+ (let ((val (first (node-parameters value))))
+ (when (or (collapsable-literal? val)
+ (= 1 nreferences) )
+ (quick-put! plist 'collapsable #t) ) ) )
+
+ ;; If it has a known value that is a procedure, and if the number of call-sites is equal to the
+ ;; number of references (does not escape), then make all formal parameters 'unused which are
+ ;; never referenced or assigned (if no rest parameter exist):
+ ;; - also marks the procedure as 'has-unused-parameters (if not in `callback-names')
+ ;; - if the procedure is internal (a continuation) do NOT mark unused parameters.
+ ;; - also: if procedure has rest-parameter and no unused params, mark f-id as 'explicit-rest.
+ (when value
+ (let ([has #f])
+ (when (and (eq? '##core#lambda (node-class value))
+ (= nreferences ncall-sites) )
+ (let ([lparams (node-parameters value)])
+ (when (second lparams)
+ (decompose-lambda-list
+ (third lparams)
+ (lambda (vars argc rest)
+ (unless rest
+ (for-each
+ (lambda (var)
+ (cond [(and (not (get db var 'references))
+ (not (get db var 'assigned)) )
+ (put! db var 'unused #t)
+ (set! has #t)
+ #t]
+ [else #f] ) )
+ vars) )
+ (cond [(and has (not (memq sym callback-names)))
+ (put! db (first lparams) 'has-unused-parameters #t) ]
+ [rest
+ (set! explicitly-consed (cons rest explicitly-consed))
+ (put! db (first lparams) 'explicit-rest #t) ] ) ) ) ) ) ) ) )
+
+ ;; Make 'removable, if it has no references and is not assigned to, and if it has either a value that
+ ;; does not cause any side-effects or if it is 'undefined:
+ (when (and (not assigned)
+ (null? references)
+ (or (and value
+ (or (not (eq? '##core#variable (node-class value)))
+ (not (get db (first (node-parameters value)) 'global)) )
+ (not (expression-has-side-effects? value db)) )
+ undefined) )
+ (quick-put! plist 'removable #t) )
+
+ ;; Make 'replacable, if it has a variable as known value and if either that variable has
+ ;; a known value itself, or if it is not captured and referenced only once, the target and
+ ;; the source are never assigned and the source is non-global or we are in block-mode:
+ ;; - The target-variable is not allowed to be global.
+ ;; - The variable that can be substituted for the current one is marked as 'replacing.
+ ;; This is done to prohibit beta-contraction of the replacing variable (It wouldn't be there, if
+ ;; it was contracted).
+ (when (and value (not global))
+ (when (eq? '##core#variable (node-class value))
+ (let* ([name (first (node-parameters value))]
+ [nrefs (get db name 'references)] )
+ (when (or (and (not (get db name 'unknown)) (get db name 'value))
+ (and (not (get db name 'captured))
+ nrefs
+ (= 1 (length nrefs))
+ (not assigned)
+ (not (get db name 'assigned))
+ (or (not (variable-visible? name))
+ (not (get db name 'global))) ) )
+ (quick-put! plist 'replacable name)
+ (put! db name 'replacing #t) ) ) ) )
+
+ ;; Make 'replacable, if it has a known value of the form: '(lambda (<xvar>) (<kvar> <xvar>))' and
+ ;; is an internally created procedure: (See above for 'replacing)
+ (when (and value (eq? '##core#lambda (node-class value)))
+ (let ([params (node-parameters value)])
+ (when (not (second params))
+ (let ([llist (third params)]
+ [body (first (node-subexpressions value))] )
+ (when (and (pair? llist)
+ (null? (cdr llist))
+ (eq? '##core#call (node-class body)) )
+ (let ([subs (node-subexpressions body)])
+ (when (= 2 (length subs))
+ (let ([v1 (first subs)]
+ [v2 (second subs)] )
+ (when (and (eq? '##core#variable (node-class v1))
+ (eq? '##core#variable (node-class v2))
+ (eq? (first llist) (first (node-parameters v2))) )
+ (let ([kvar (first (node-parameters v1))])
+ (quick-put! plist 'replacable kvar)
+ (put! db kvar 'replacing #t) ) ) ) ) ) ) ) ) ) )
+
+ ;; If a rest-argument, convert 'rest-parameter property to 'vector, if the variable is never
+ ;; assigned, and the number of references is identical to the number of accesses in optimizable
+ ;; rest-argument operators:
+ ;; - Add variable to "rest-parameters-promoted-to-vector", because subsequent optimization will
+ ;; change variables context (operators applied to it).
+ (when (and rest-parameter
+ (not assigned)
+ (= nreferences o-r/access-count) )
+ (set! rest-parameters-promoted-to-vector (lset-adjoin eq? rest-parameters-promoted-to-vector sym))
+ (put! db sym 'rest-parameter 'vector) ) ) )
+
+ db)
+
+ ;; Remove explicitly consed rest parameters from promoted ones:
+ (set! rest-parameters-promoted-to-vector
+ (lset-difference eq? rest-parameters-promoted-to-vector explicitly-consed) )
+
+ ;; Set original program-size, if this is the first analysis-pass:
+ (unless original-program-size
+ (set! original-program-size current-program-size) )
+ db) )
+
+
+;;; Convert closures to explicit data structures (effectively flattens function-binding structure):
+
+(define (perform-closure-conversion node db)
+ (let ([direct-calls 0]
+ [customizable '()] )
+
+ (define (test sym item) (get db sym item))
+
+ (define (register-customizable! var id)
+ (set! customizable (lset-adjoin eq? customizable var))
+ (put! db id 'customizable #t) )
+
+ (define (register-direct-call! id)
+ (set! direct-calls (add1 direct-calls))
+ (set! direct-call-ids (lset-adjoin eq? direct-call-ids id)) )
+
+ ;; Gather free-variable information:
+ ;; (and: - register direct calls
+ ;; - update (by mutation) call information in "##core#call" nodes)
+ (define (gather n here env)
+ (let ((subs (node-subexpressions n))
+ (params (node-parameters n)) )
+ (case (node-class n)
+
+ ((quote ##core#variable ##core#undefined ##core#proc ##core#primitive ##core#global-ref) #f)
+
+ ((let)
+ (receive (vals body) (split-at subs (length params))
+ (for-each (lambda (n) (gather n here env)) vals)
+ (gather (first body) here (append params env)) ) )
+
+ ((##core#call)
+ (let* ([fn (first subs)]
+ [mode (first params)]
+ [name (and (pair? (cdr params)) (second params))]
+ [varfn (eq? '##core#variable (node-class fn))] )
+ (node-parameters-set!
+ n
+ (cons mode
+ (if (or name varfn)
+ (cons name
+ (if varfn
+ (let* ([varname (first (node-parameters fn))]
+ [val (and (not (test varname 'unknown)) (test varname 'value))] )
+ (if (and val (eq? '##core#lambda (node-class val)))
+ (let* ([params (node-parameters val)]
+ [llist (third params)]
+ [id (first params)]
+ [refs (test varname 'references)]
+ [sites (test varname 'call-sites)]
+ [custom
+ (and refs sites
+ (= (length refs) (length sites))
+ (proper-list? llist) ) ] )
+ (when (and name
+ custom
+ (not (= (llist-length llist) (length (cdr subs)))))
+ (quit
+ "known procedure called with wrong number of arguments: ~A"
+ (source-info->string name) ) )
+ (register-direct-call! id)
+ (when custom (register-customizable! varname id))
+ (list id custom) )
+ '() ) )
+ '() ) )
+ '() ) ) )
+ (for-each (lambda (n) (gather n here env)) subs) ) )
+
+ ((##core#lambda ##core#direct_lambda)
+ (decompose-lambda-list
+ (third params)
+ (lambda (vars argc rest)
+ (let* ([id (if here (first params) 'toplevel)]
+ [capturedvars (captured-variables (car subs) env)]
+ [csize (length capturedvars)] )
+ (put! db id 'closure-size csize)
+ (put! db id 'captured-variables capturedvars)
+ (gather (car subs) id (append vars env)) ) ) ) )
+
+ (else (for-each (lambda (n) (gather n here env)) subs)) ) ) )
+
+ ;; Create explicit closures:
+ (define (transform n here closure)
+ (let ((subs (node-subexpressions n))
+ (params (node-parameters n))
+ (class (node-class n)) )
+ (case class
+
+ ((quote ##core#undefined ##core#proc ##core#global-ref) n)
+
+ ((##core#variable)
+ (let* ((var (first params))
+ (val (ref-var n here closure)) )
+ (if (test var 'boxed)
+ (make-node '##core#unbox '() (list val))
+ val) ) )
+
+ ((if ##core#call ##core#inline ##core#inline_allocate ##core#callunit ##core#inline_ref ##core#inline_update
+ ##core#switch ##core#cond ##core#direct_call ##core#recurse ##core#return ##core#inline_loc_ref
+ ##core#inline_loc_update)
+ (make-node (node-class n) params (maptransform subs here closure)) )
+
+ ((let)
+ (let* ([var (first params)]
+ [boxedvar (test var 'boxed)]
+ [boxedalias (gensym var)] )
+ (if boxedvar
+ (make-node
+ 'let (list boxedalias)
+ (list (transform (first subs) here closure)
+ (make-node
+ 'let (list var)
+ (list (make-node '##core#box '() (list (varnode boxedalias)))
+ (transform (second subs) here closure) ) ) ) )
+ (make-node
+ 'let params
+ (maptransform subs here closure) ) ) ) )
+
+ ((##core#lambda ##core#direct_lambda)
+ (let ([llist (third params)])
+ (decompose-lambda-list
+ llist
+ (lambda (vars argc rest)
+ (let* ([boxedvars (filter (lambda (v) (test v 'boxed)) vars)]
+ [boxedaliases (map cons boxedvars (map gensym boxedvars))]
+ [cvar (gensym 'c)]
+ [id (if here (first params) 'toplevel)]
+ [capturedvars (or (test id 'captured-variables) '())]
+ [csize (or (test id 'closure-size) 0)]
+ [info (and emit-closure-info (second params) (pair? llist))] )
+ ;; If rest-parameter is boxed: mark it as 'boxed-rest
+ ;; (if we don't do this than preparation will think the (boxed) alias
+ ;; of the rest-parameter is never used)
+ (and-let* ([rest]
+ [(test rest 'boxed)]
+ [rp (test rest 'rest-parameter)] )
+ (put! db (cdr (assq rest boxedaliases)) 'boxed-rest #t) )
+ (make-node
+ '##core#closure (list (+ csize (if info 2 1)))
+ (cons
+ (make-node
+ class
+ (list id
+ (second params)
+ (cons
+ cvar
+ (build-lambda-list
+ (map (lambda (v)
+ (cond ((assq v boxedaliases) => cdr)
+ (else v) ) )
+ vars)
+ argc
+ (cond ((and rest (assq rest boxedaliases)) => cdr)
+ (else rest) ) ) )
+ (fourth params) )
+ (list (let ((body (transform (car subs) cvar capturedvars)))
+ (if (pair? boxedvars)
+ (fold-right
+ (lambda (alias val body) (make-node 'let (list alias) (list val body)))
+ body
+ (unzip1 boxedaliases)
+ (map (lambda (a) (make-node '##core#box '() (list (varnode (cdr a)))))
+ boxedaliases) )
+ body) ) ) )
+ (let ((cvars (map (lambda (v) (ref-var (varnode v) here closure))
+ capturedvars) ) )
+ (if info
+ (append
+ cvars
+ (list
+ (qnode
+ (##sys#make-lambda-info
+ (->string (cons (or (real-name id) '?)
+ (cdr llist) )))))) ; this is not always correct, due to optimizations
+ cvars) ) ) ) ) ) ) ) )
+
+ ((set!)
+ (let* ([var (first params)]
+ [val (first subs)]
+ [cval (node-class val)]
+ [immf (or (and (eq? 'quote cval) (immediate? (first (node-parameters val))))
+ (eq? '##core#undefined cval) ) ] )
+ (cond ((posq var closure)
+ => (lambda (i)
+ (if (test var 'boxed)
+ (make-node
+ (if immf '##core#updatebox_i '##core#updatebox)
+ '()
+ (list (make-node '##core#ref (list (add1 i)) (list (varnode here)))
+ (transform val here closure) ) )
+ ;; Is the following actually used???
+ (make-node
+ (if immf '##core#update_i '##core#update)
+ (list (add1 i))
+ (list (varnode here)
+ (transform val here closure) ) ) ) ) )
+ ((test var 'boxed)
+ (make-node
+ (if immf '##core#updatebox_i '##core#updatebox)
+ '()
+ (list (varnode var)
+ (transform val here closure) ) ) )
+ (else (make-node
+ 'set! (list var)
+ (list (transform val here closure) ) ) ) ) ) )
+
+ ((##core#primitive)
+ (make-node
+ '##core#closure (list (if emit-closure-info 2 1))
+ (cons (make-node '##core#proc (list (car params) #t) '())
+ (if emit-closure-info
+ (list (qnode (##sys#make-lambda-info (car params))))
+ '() ) ) ) )
+
+ (else (bomb "bad node (closure2)")) ) ) )
+
+ (define (maptransform xs here closure)
+ (map (lambda (x) (transform x here closure)) xs) )
+
+ (define (ref-var n here closure)
+ (let ((var (first (node-parameters n))))
+ (cond ((posq var closure)
+ => (lambda (i)
+ (make-node '##core#ref (list (+ i 1))
+ (list (varnode here)) ) ) )
+ (else n) ) ) )
+
+ (define (captured-variables node env)
+ (let ([vars '()])
+ (let walk ([n node])
+ (let ((subs (node-subexpressions n))
+ (params (node-parameters n)) )
+ (case (node-class n)
+ ((##core#variable)
+ (let ([var (first params)])
+ (when (memq var env)
+ (set! vars (lset-adjoin eq? vars var)) ) ) )
+ ((quote ##core#undefined ##core#primitive ##core#proc ##core#inline_ref ##core#global-ref) #f)
+ ((set!)
+ (let ([var (first params)])
+ (when (memq var env) (set! vars (lset-adjoin eq? vars var)))
+ (walk (car subs)) ) )
+ (else (for-each walk subs)) ) ) )
+ vars) )
+
+ (debugging 'p "closure conversion gathering phase...")
+ (gather node #f '())
+ (debugging 'o "customizable procedures" customizable)
+ (debugging 'p "closure conversion transformation phase...")
+ (let ((node2 (transform node #f #f)))
+ (unless (zero? direct-calls)
+ (debugging 'o "calls to known targets" direct-calls (delay (length direct-call-ids))) )
+ node2) ) )
+
+
+;;; Do some preparations before code-generation can commence:
+
+(define-record-type lambda-literal
+ (make-lambda-literal id external arguments argument-count rest-argument temporaries
+ callee-signatures allocated directly-called closure-size
+ looping customizable rest-argument-mode body direct)
+ lambda-literal?
+ (id lambda-literal-id) ; symbol
+ (external lambda-literal-external) ; boolean
+ (arguments lambda-literal-arguments) ; (symbol...)
+ (argument-count lambda-literal-argument-count) ; integer
+ (rest-argument lambda-literal-rest-argument) ; symbol | #f
+ (temporaries lambda-literal-temporaries) ; integer
+ (callee-signatures lambda-literal-callee-signatures) ; (integer...)
+ (allocated lambda-literal-allocated) ; integer
+ (directly-called lambda-literal-directly-called) ; boolean
+ (closure-size lambda-literal-closure-size) ; integer
+ (looping lambda-literal-looping) ; boolean
+ (customizable lambda-literal-customizable) ; boolean
+ (rest-argument-mode lambda-literal-rest-argument-mode) ; #f | LIST | VECTOR | UNUSED
+ (body lambda-literal-body) ; expression
+ (direct lambda-literal-direct)) ; boolean
+
+(define (prepare-for-code-generation node db)
+ (let ([literals '()]
+ [lambda-info-literals '()]
+ [lambdas '()]
+ [temporaries 0]
+ [allocated 0]
+ [looping 0]
+ [signatures '()]
+ [fastinits 0]
+ [fastrefs 0]
+ [fastsets 0] )
+
+ (define (walk-var var e sf)
+ (cond [(posq var e) => (lambda (i) (make-node '##core#local (list i) '()))]
+ [(keyword? var) (make-node '##core#literal (list (literal var)) '())]
+ [else (walk-global var sf)] ) )
+
+ (define (walk-global var sf)
+ (let* ([safe (or sf
+ no-bound-checks
+ unsafe
+ (variable-mark var '##compiler#always-bound)
+ (intrinsic? var))]
+ [blockvar (and (get db var 'assigned)
+ (not (variable-visible? var)))])
+ (when blockvar (set! fastrefs (add1 fastrefs)))
+ (make-node
+ '##core#global
+ (list (if blockvar
+ (blockvar-literal var)
+ (literal var) )
+ safe
+ blockvar
+ var)
+ '() ) ) )
+
+ (define (walk n e here boxes)
+ (let ((subs (node-subexpressions n))
+ (params (node-parameters n))
+ (class (node-class n)) )
+ (case class
+
+ ((##core#undefined ##core#proc) n)
+
+ ((##core#variable)
+ (walk-var (first params) e #f) )
+
+ ((##core#global-ref)
+ (walk-global (first params) #t) )
+
+ ((##core#direct_call)
+ (set! allocated (+ allocated (fourth params)))
+ (make-node class params (mapwalk subs e here boxes)) )
+
+ ((##core#inline_allocate)
+ (set! allocated (+ allocated (second params)))
+ (make-node class params (mapwalk subs e here boxes)) )
+
+ ((##core#inline_ref)
+ (set! allocated (+ allocated (words (estimate-foreign-result-size (second params)))))
+ (make-node class params '()) )
+
+ ((##core#inline_loc_ref)
+ (set! allocated (+ allocated (words (estimate-foreign-result-size (first params)))))
+ (make-node class params (mapwalk subs e here boxes)) )
+
+ ((##core#closure)
+ (set! allocated (+ allocated (first params) 1))
+ (make-node '##core#closure params (mapwalk subs e here boxes)) )
+
+ ((##core#box)
+ (set! allocated (+ allocated 2))
+ (make-node '##core#box params (list (walk (first subs) e here boxes))) )
+
+ ((##core#updatebox)
+ (let* ([b (first subs)]
+ [subs (mapwalk subs e here boxes)] )
+ (make-node
+ (cond [(and (eq? '##core#variable (node-class b))
+ (memq (first (node-parameters b)) boxes) )
+ (set! fastinits (add1 fastinits))
+ '##core#updatebox_i]
+ [else class] )
+ '()
+ subs) ) )
+
+ ((##core#lambda ##core#direct_lambda)
+ (let ([temps temporaries]
+ [sigs signatures]
+ [lping looping]
+ [alc allocated]
+ [direct (eq? class '##core#direct_lambda)] )
+ (set! temporaries 0)
+ (set! allocated 0)
+ (set! signatures '())
+ (set! looping 0)
+ (decompose-lambda-list
+ (third params)
+ (lambda (vars argc rest)
+ (let* ([id (first params)]
+ [rest-mode
+ (and rest
+ (let ([rrefs (get db rest 'references)])
+ (cond [(get db rest 'assigned) 'list]
+ [(and (not (get db rest 'boxed-rest)) (or (not rrefs) (null? rrefs))) 'none]
+ [else (get db rest 'rest-parameter)] ) ) ) ]
+ [body (walk
+ (car subs)
+ (if (eq? 'none rest-mode)
+ (butlast vars)
+ vars)
+ id
+ '()) ] )
+ (case rest-mode
+ [(none) (debugging 'o "unused rest argument" rest id)]
+ [(vector) (debugging 'o "rest argument accessed as vector" rest id)] )
+ (when (and direct rest)
+ (bomb "bad direct lambda" id allocated rest) )
+ (set! lambdas
+ (cons (make-lambda-literal
+ id
+ (second params)
+ vars
+ argc
+ rest
+ (add1 temporaries)
+ signatures
+ allocated
+ (or direct (memq id direct-call-ids))
+ (or (get db id 'closure-size) 0)
+ (and (not rest)
+ (> looping 0)
+ (begin
+ (debugging 'o "identified direct recursive calls" id looping)
+ #t) )
+ (or direct (get db id 'customizable))
+ rest-mode
+ body
+ direct)
+ lambdas) )
+ (set! looping lping)
+ (set! temporaries temps)
+ (set! allocated alc)
+ (set! signatures sigs)
+ (make-node '##core#proc (list (first params)) '()) ) ) ) ) )
+
+ ((let)
+ (let* ([var (first params)]
+ [val (first subs)]
+ [boxvars (if (eq? '##core#box (node-class val)) (list var) '())] )
+ (set! temporaries (add1 temporaries))
+ (make-node
+ '##core#bind (list 1)
+ (list (walk val e here boxes)
+ (walk (second subs) (append e params) here (append boxvars boxes)) ) ) ) )
+
+ ((set!)
+ (let ([var (first params)]
+ [val (first subs)] )
+ (cond ((posq var e)
+ => (lambda (i)
+ (make-node '##core#setlocal (list i) (list (walk val e here boxes)) ) ) )
+ (else
+ (let* ([cval (node-class val)]
+ [safe (not (or no-bound-checks
+ unsafe
+ (variable-mark var '##compiler#always-bound)
+ (intrinsic? var)))]
+ [blockvar (not (variable-visible? var))]
+ [immf (or (and (eq? cval 'quote) (immediate? (first (node-parameters val))))
+ (eq? '##core#undefined cval) ) ] )
+ (when blockvar (set! fastsets (add1 fastsets)))
+ (make-node
+ (if immf '##core#setglobal_i '##core#setglobal)
+ (list (if blockvar
+ (blockvar-literal var)
+ (literal var) )
+ blockvar
+ var)
+ (list (walk (car subs) e here boxes)) ) ) ) ) ) )
+
+ ((##core#call)
+ (let ([len (length (cdr subs))])
+ (set! signatures (lset-adjoin = signatures len))
+ (when (and (>= (length params) 3) (eq? here (third params)))
+ (set! looping (add1 looping)) )
+ (make-node class params (mapwalk subs e here boxes)) ) )
+
+ ((##core#recurse)
+ (when (first params) (set! looping (add1 looping)))
+ (make-node class params (mapwalk subs e here boxes)) )
+
+ ((quote)
+ (let ((c (first params)))
+ (cond ((and (fixnum? c) (not (big-fixnum? c)))
+ (immediate-literal c) )
+ ((number? c)
+ (cond ((eq? 'fixnum number-type)
+ (cond ((and (integer? c) (not (big-fixnum? c)))
+ (compiler-warning
+ 'type
+ "coerced inexact literal number `~S' to fixnum ~S" c (inexact->exact c))
+ (immediate-literal (inexact->exact c)) )
+ (else (quit "cannot coerce inexact literal `~S' to fixnum" c)) ) )
+ (else (make-node '##core#literal (list (literal c)) '())) ) )
+ ((immediate? c) (immediate-literal c))
+ (else (make-node '##core#literal (list (literal c)) '())) ) ) )
+
+ ((if ##core#cond)
+ (let* ((test (walk (first subs) e here boxes))
+ (a0 allocated)
+ (x1 (walk (second subs) e here boxes))
+ (a1 allocated)
+ (x2 (walk (third subs) e here boxes)))
+ (set! allocated (+ a0 (max (- allocated a1) (- a1 a0))))
+ (make-node class params (list test x1 x2))))
+
+ ((##core#switch)
+ (let* ((exp (walk (first subs) e here boxes))
+ (a0 allocated))
+ (make-node
+ class
+ params
+ (cons
+ exp
+ (let loop ((j (first params)) (subs (cdr subs)) (ma 0))
+ (set! allocated a0)
+ (if (zero? j)
+ (let ((def (walk (car subs) e here boxes)))
+ (set! allocated (+ a0 (max ma (- allocated a0))))
+ (list def))
+ (let* ((const (walk (car subs) e here boxes))
+ (body (walk (cadr subs) e here boxes)))
+ (cons*
+ const body
+ (loop (sub1 j) (cddr subs) (max (- allocated a0) ma))))))))))
+
+ (else (make-node class params (mapwalk subs e here boxes)) ) ) ) )
+
+ (define (mapwalk xs e here boxes)
+ (map (lambda (x) (walk x e here boxes)) xs) )
+
+ (define (literal x)
+ (cond [(immediate? x) (immediate-literal x)]
+ [(number? x)
+ (or (and (inexact? x)
+ (list-index (lambda (y) (and (number? y) (inexact? y) (= x y)))
+ literals) )
+ (new-literal x)) ]
+ ((##core#inline "C_lambdainfop" x)
+ (let ((i (length lambda-info-literals)))
+ (set! lambda-info-literals
+ (append lambda-info-literals (list x))) ;*** see below
+ (vector i) ) )
+ [(posq x literals) => identity]
+ [else (new-literal x)] ) )
+
+ (define (new-literal x)
+ (let ([i (length literals)])
+ (set! literals (append literals (list x))) ;*** could (should) be optimized
+ i) )
+
+ (define (blockvar-literal var)
+ (or (list-index
+ (lambda (lit)
+ (and (block-variable-literal? lit)
+ (eq? var (block-variable-literal-name lit)) ) )
+ literals)
+ (new-literal (make-block-variable-literal var)) ) )
+
+ (define (immediate-literal x)
+ (if (eq? (void) x)
+ (make-node '##core#undefined '() '())
+ (make-node '##core#immediate
+ (cond ((fixnum? x) `(fix ,x))
+ ((boolean? x) `(bool ,x))
+ ((char? x) `(char ,x))
+ ((null? x) '(nil))
+ ((eof-object? x) '(eof))
+ (else (bomb "bad immediate (prepare)")) )
+ '() ) ) )
+
+ (debugging 'p "preparation phase...")
+ (let ((node2 (walk node '() #f '())))
+ (debugging 'o "fast box initializations" fastinits)
+ (debugging 'o "fast global references" fastrefs)
+ (debugging 'o "fast global assignments" fastsets)
+ (values node2 literals lambda-info-literals lambdas) ) ) )
diff --git a/config-arch.sh b/config-arch.sh
new file mode 100644
index 00000000..4a87a300
--- /dev/null
+++ b/config-arch.sh
@@ -0,0 +1,39 @@
+#!/bin/sh
+# config-arch.sh - return host architecture id, if supported by apply-hack
+#
+# Copyright (c) 2000-2007, Felix L. Winkelmann
+# Copyright (c) 2008-2009, The Chicken Team
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+# conditions are met:
+#
+# Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+# disclaimer.
+# 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.
+# Neither the name of the author nor the names of its contributors may be used to endorse or promote
+# products derived from this software without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+# OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+# AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+
+
+case "`uname -m`" in
+ i*86) echo "x86";;
+ "Power Macintosh"|ppc|powerpc|macppc)
+ case "`uname -s`" in
+ Darwin) echo "ppc.darwin";;
+ *) echo "ppc.sysv";;
+ esac;;
+ sparc64) echo "sparc64";;
+ amd64|x86_64) echo "x86-64";;
+ *) ;;
+esac
diff --git a/csc-trans b/csc-trans
new file mode 100644
index 00000000..77ef4f28
--- /dev/null
+++ b/csc-trans
@@ -0,0 +1,64 @@
+#!/bin/sh
+
+INDENT=indent
+INDENT_OPTS="-st"
+ENSCRIPT=enscript
+ENSCRIPT_OPTS="-q -Ec"
+CSC_OPTS="-to-stdout"
+CSC=csc
+
+# check for options
+COLOR="--color"
+MODE=""
+OUTPUT=-
+ALL=0
+while getopts ":a23ufbihprcotlI:" opt; do
+ case $opt in
+ a ) ALL="1";;
+ h ) MODE="--language=html";;
+ p ) MODE="--language=PostScript";;
+ r ) MODE="--language=rtf";;
+ t ) NOENSCRIPT="1";;
+ c ) COLOR="";; # disable color (on by default)
+ o ) OUTPUT=$OPTARG;;
+ u ) CSC_OPTS="$CSC_OPTS -unsafe";;
+ b ) CSC_OPTS="$CSC_OPTS -block";;
+ f ) CSC_OPTS="$CSC_OPTS -fixnum-arithmetic";;
+ i ) CSC_OPTS="$CSC_OPTS -inline";;
+ I ) CSC_OPTS="$CSC_OPTS -disable-interrupts";;
+ 2 ) CSC_OPTS="$CSC_OPTS -O2";;
+ 3 ) CSC_OPTS="$CSC_OPTS -O3";;
+ l ) CSC="./csc -compiler ./chicken-static";;
+ esac
+done
+shift $(($OPTIND - 1))
+
+# First argument after options is the file
+FILE=$1
+if [ "x$FILE" == "x" ]; then
+ FILE="/dev/stdin"
+fi
+
+# Only prettify output if the appropriate programs are installed
+if type $INDENT >/dev/null 2>&1; then
+ PASS2="$INDENT $INDENT_OPTS"
+else
+ PASS2=cat
+fi
+if type $ENSCRIPT >/dev/null 2>&1; then
+ PASS3="$ENSCRIPT $ENSCRIPT_OPTS $MODE $COLOR -o $OUTPUT"
+else
+ PASS3=cat
+fi
+if [ -n "$NOENSCRIPT" ]; then
+ PASS3=cat
+fi
+
+# Are we filtering out just the user code?
+if [ "x$ALL" == "x1" ]; then
+ $CSC $CSC_OPTS $FILE | $PASS2 2>/dev/null | $PASS3 2>/dev/null
+else
+ $CSC $CSC_OPTS $FILE |\
+ perl -an000e 'print if /C_trace/&&!/##sys#implicit/ || (/\/\* [-!%\w]+ in k\d+ / && ! /\/\* k\d+ /)' |\
+ $PASS2 | $PASS3
+fi
diff --git a/csc.1 b/csc.1
new file mode 100644
index 00000000..4faa7654
--- /dev/null
+++ b/csc.1
@@ -0,0 +1,58 @@
+.\" dummy line
+.TH CSC 1 "19 Sep 2001"
+
+.SH NAME
+
+csc \- driver program for the Chicken Scheme compiler
+
+.SH SYNOPSIS
+
+.B csc
+[
+.I filename
+|
+.I option ...
+]
+
+.SH DESCRIPTION
+
+.I csc
+is a program that invokes the
+.I CHICKEN
+compiler and the host systems C compiler to generate
+an executable from a Scheme source file or C files generated by
+.I CHICKEN
+For a list of options enter
+.B csc \ \-help
+
+.SH ENVIRONMENT\ VARIABLES
+
+.TP
+.B CSC_OPTIONS
+Can hold default options that should be passed to every invocation of
+.B csc
+
+.TP
+.B CHICKEN_PREFIX
+An alternative installation prefix, where the Scheme-to-C translator
+and any support files and libraries are located. Defaults to the installation
+time prefix given when configuring the system.
+
+.SH DOCUMENTATION
+
+More information can be found in the
+.I Chicken\ User's\ Manual
+
+.SH BUGS
+Submit bug reports by e-mail to
+.I chicken-janitors@nongnu.org
+, preferrably using the
+.B chicken\-bug
+tool.
+
+.SH AUTHOR
+Felix L. Winkelmann and the Chicken Team
+
+.SH SEE ALSO
+.BR chicken(1)
+.BR chicken-bug(1)
diff --git a/csc.scm b/csc.scm
new file mode 100644
index 00000000..472002b0
--- /dev/null
+++ b/csc.scm
@@ -0,0 +1,940 @@
++;;;; csc.scm - Driver program for the CHICKEN compiler - felix -*- Scheme -*-
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (block)
+ (uses data-structures ports srfi-1 srfi-13 utils files extras))
+
+(define-foreign-variable INSTALL_BIN_HOME c-string "C_INSTALL_BIN_HOME")
+(define-foreign-variable INSTALL_CC c-string "C_INSTALL_CC")
+(define-foreign-variable INSTALL_CXX c-string "C_INSTALL_CXX")
+(define-foreign-variable TARGET_CC c-string "C_TARGET_CC")
+(define-foreign-variable TARGET_CXX c-string "C_TARGET_CXX")
+(define-foreign-variable TARGET_CFLAGS c-string "C_TARGET_CFLAGS")
+(define-foreign-variable INSTALL_CFLAGS c-string "C_INSTALL_CFLAGS")
+(define-foreign-variable TARGET_LDFLAGS c-string "C_TARGET_LDFLAGS")
+(define-foreign-variable INSTALL_LDFLAGS c-string "C_INSTALL_LDFLAGS")
+(define-foreign-variable INSTALL_MORE_LIBS c-string "C_INSTALL_MORE_LIBS")
+(define-foreign-variable INSTALL_MORE_STATIC_LIBS c-string "C_INSTALL_MORE_STATIC_LIBS")
+(define-foreign-variable INSTALL_SHARE_HOME c-string "C_INSTALL_SHARE_HOME")
+(define-foreign-variable INSTALL_LIB_HOME c-string "C_INSTALL_LIB_HOME")
+(define-foreign-variable INSTALL_INCLUDE_HOME c-string "C_INSTALL_INCLUDE_HOME")
+(define-foreign-variable INSTALL_STATIC_LIB_HOME c-string "C_INSTALL_STATIC_LIB_HOME")
+(define-foreign-variable TARGET_MORE_LIBS c-string "C_TARGET_MORE_LIBS")
+(define-foreign-variable TARGET_MORE_STATIC_LIBS c-string "C_TARGET_MORE_STATIC_LIBS")
+(define-foreign-variable TARGET_BIN_HOME c-string "C_TARGET_BIN_HOME")
+(define-foreign-variable TARGET_SHARE_HOME c-string "C_TARGET_SHARE_HOME")
+(define-foreign-variable TARGET_LIB_HOME c-string "C_TARGET_LIB_HOME")
+(define-foreign-variable TARGET_INCLUDE_HOME c-string "C_TARGET_INCLUDE_HOME")
+(define-foreign-variable TARGET_STATIC_LIB_HOME c-string "C_TARGET_STATIC_LIB_HOME")
+(define-foreign-variable TARGET_RUN_LIB_HOME c-string "C_TARGET_RUN_LIB_HOME")
+(define-foreign-variable CHICKEN_PROGRAM c-string "C_CHICKEN_PROGRAM")
+(define-foreign-variable WINDOWS_SHELL bool "C_WINDOWS_SHELL")
+
+
+;;; Parameters:
+
+(define mingw (eq? (build-platform) 'mingw32))
+(define msvc (eq? (build-platform) 'msvc))
+(define osx (eq? (software-version) 'macosx))
+(define hpux-hppa (and (eq? (software-version) 'hpux)
+ (eq? (machine-type) 'hppa)))
+
+(define (quit msg . args)
+ (fprintf (current-error-port) "csc: ~?~%" msg args)
+ (exit 64) )
+
+(define chicken-prefix (get-environment-variable "CHICKEN_PREFIX"))
+(define arguments (command-line-arguments))
+(define host-mode (member "-host" arguments))
+(define cross-chicken (##sys#fudge 39))
+
+(define (prefix str dir default)
+ (if chicken-prefix
+ (make-pathname (list chicken-prefix dir) str)
+ default) )
+
+(define (quotewrap str)
+ (qs (normalize-pathname str)))
+
+(define home
+ (quotewrap
+ (prefix "" "share" (if host-mode INSTALL_SHARE_HOME TARGET_SHARE_HOME))))
+
+(define translator
+ (quotewrap
+ (prefix "chicken" "bin"
+ (make-pathname
+ INSTALL_BIN_HOME
+ CHICKEN_PROGRAM))))
+
+(define compiler (quotewrap (if host-mode INSTALL_CC TARGET_CC)))
+(define c++-compiler (quotewrap (if host-mode INSTALL_CXX TARGET_CXX)))
+(define linker (quotewrap (if msvc "link" (if host-mode INSTALL_CC TARGET_CC))))
+(define c++-linker (quotewrap (if msvc "link" (if host-mode INSTALL_CXX TARGET_CXX))))
+(define object-extension (if msvc "obj" "o"))
+(define library-extension (if msvc "lib" "a"))
+(define link-output-flag (if msvc "-out:" "-o "))
+(define executable-extension (if msvc "exe" ""))
+(define compile-output-flag (if msvc "-Fo" "-o "))
+(define nonstatic-compilation-options '())
+(define shared-library-extension ##sys#load-dynamic-extension)
+(define default-translation-optimization-options '())
+(define pic-options (if (or mingw msvc) '("-DPIC") '("-fPIC" "-DPIC")))
+(define windows-shell WINDOWS_SHELL)
+
+(define default-library (string-append
+ (if msvc "libchicken-static." "libchicken.")
+ library-extension))
+(define default-unsafe-library (string-append
+ (if msvc "libuchicken-static." "libuchicken.")
+ library-extension))
+
+(define cleanup-filename quotewrap)
+
+(define default-compilation-optimization-options (string-split (if host-mode INSTALL_CFLAGS TARGET_CFLAGS)))
+(define best-compilation-optimization-options default-compilation-optimization-options)
+(define default-linking-optimization-options (string-split (if host-mode INSTALL_LDFLAGS TARGET_LDFLAGS)))
+(define best-linking-optimization-options default-linking-optimization-options)
+
+(define-constant simple-options
+ '(-explicit-use -no-trace -no-warnings -no-usual-integrations -optimize-leaf-routines -unsafe
+ -block -disable-interrupts -fixnum-arithmetic -to-stdout -profile -raw -accumulate-profile
+ -check-syntax -case-insensitive -benchmark-mode -shared -compile-syntax -no-lambda-info
+ -lambda-lift -dynamic -disable-stack-overflow-checks -local
+ -emit-external-prototypes-first -inline -release -scrutinize
+ -analyze-only -keep-shadowed-macros -inline-global -ignore-repository
+ -no-symbol-escape -no-parentheses-synonyms -r5rs-syntax
+ -no-argc-checks -no-bound-checks -no-procedure-checks -no-compiler-syntax
+ -emit-all-import-libraries -setup-mode
+ -no-procedure-checks-for-usual-bindings))
+
+(define-constant complex-options
+ '(-debug -output-file -heap-size -nursery -stack-size -compiler -unit -uses -keyword-style
+ -optimize-level -include-path -database-size -extend -prelude -postlude -prologue -epilogue
+ -inline-limit -profile-name -disable-warning -emit-inline-file -types
+ -feature -debug-level -heap-growth -heap-shrinkage -heap-initial-size -consult-inline-file
+ -emit-import-library -static-extension))
+
+(define-constant shortcuts
+ '((-h "-help")
+ (-s "-shared")
+ (-S "-scrutinize")
+ (|-P| "-check-syntax")
+ (|-V| "-version")
+ (|-Ob| "-benchmark-mode")
+ (-f "-fixnum-arithmetic")
+ (|-D| "-feature")
+ (-i "-case-insensitive")
+ (|-K| "-keyword-style")
+ (|-X| "-extend")
+ (|-N| "-no-usual-integrations")
+ (|-J| "-emit-all-import-libraries")
+ (-x "-explicit-use")
+ (-u "-unsafe")
+ (-j "-emit-import-library")
+ (-n "-emit-inline-file")
+ (-b "-block") ) )
+
+(define short-options
+ (string->list "PHhsfiENxubvwAOeWkctgS") )
+
+
+;;; Variables:
+
+(define scheme-files '())
+(define generated-scheme-files '())
+(define c-files '())
+(define generated-c-files '())
+(define object-files '())
+(define generated-object-files '())
+(define cpp-mode #f)
+(define objc-mode #f)
+(define embedded #f)
+(define inquiry-only #f)
+(define show-cflags #f)
+(define show-ldflags #f)
+(define show-libs #f)
+(define dry-run #f)
+
+(define extra-libraries
+ (if host-mode
+ INSTALL_MORE_STATIC_LIBS
+ TARGET_MORE_STATIC_LIBS))
+(define extra-shared-libraries
+ (if host-mode
+ INSTALL_MORE_LIBS
+ TARGET_MORE_LIBS))
+(define default-library-files
+ (list
+ (quotewrap
+ (prefix default-library "lib"
+ (string-append
+ (if host-mode INSTALL_LIB_HOME TARGET_LIB_HOME)
+ (string-append "/" default-library)))) ))
+(define default-shared-library-files (if msvc
+ (list (string-append "libchicken." library-extension))
+ '("-lchicken")))
+(define unsafe-library-files
+ (list
+ (quotewrap
+ (prefix default-unsafe-library "lib"
+ (string-append
+ (if host-mode INSTALL_LIB_HOME TARGET_LIB_HOME)
+ (string-append "/" default-unsafe-library)))) ))
+(define unsafe-shared-library-files (if msvc
+ (list (string-append "libuchicken." library-extension))
+ '("-luchicken")))
+(define gui-library-files default-library-files)
+(define gui-shared-library-files default-shared-library-files)
+(define library-files default-library-files)
+(define shared-library-files default-shared-library-files)
+
+(define translate-options '())
+
+(define include-dir
+ (let ((id (prefix "" "include"
+ (if host-mode INSTALL_INCLUDE_HOME TARGET_INCLUDE_HOME))))
+ (and (not (member id '("/usr/include" "")))
+ id) ) )
+
+(define compile-options '())
+(define builtin-compile-options
+ (if include-dir (list (conc "-I" (quotewrap include-dir))) '()))
+
+(define compile-only-flag "-c")
+(define translation-optimization-options default-translation-optimization-options)
+(define compilation-optimization-options default-compilation-optimization-options)
+(define linking-optimization-options default-linking-optimization-options)
+
+(define library-dir
+ (prefix "" "lib"
+ (if host-mode
+ INSTALL_LIB_HOME
+ TARGET_LIB_HOME)) )
+
+(define link-options '())
+(define builtin-link-options
+ (cond ((or osx hpux-hppa mingw)
+ (list (conc "-L" (quotewrap library-dir))))
+ (msvc
+ (list (conc "-LIBPATH:" (quotewrap library-dir))))
+ (else
+ (list
+ (conc "-L" (quotewrap library-dir))
+ (conc " -Wl,-R" (quotewrap (prefix "" "lib"
+ (if host-mode
+ INSTALL_LIB_HOME
+ TARGET_RUN_LIB_HOME)))) ) ) ) )
+
+(define target-filename #f)
+(define verbose #f)
+(define keep-files #f)
+(define translate-only #f)
+(define compile-only #f)
+(define to-stdout #f)
+(define shared #f)
+(define static #f)
+(define static-libs #f)
+(define static-extensions '())
+(define required-extensions '())
+(define gui #f)
+
+
+;;; Display usage information:
+
+(define (usage)
+ (display #<<EOF
+Usage: csc FILENAME | OPTION ...
+
+ `csc' is a driver program for the CHICKEN compiler. Files given on the
+ command line are translated, compiled or linked as needed.
+
+ FILENAME is a Scheme source file name with optional extension or a
+ C/C++/Objective-C source, object or library file name with extension. OPTION
+ may be one of the following:
+
+ General options:
+
+ -h -help display this text and exit
+ -v show intermediate compilation stages
+ -vv -verbose display information about translation
+ progress
+ -vvv display information about all compilation
+ stages
+ -V -version display Scheme compiler version and exit
+ -release display release number and exit
+
+ File and pathname options:
+
+ -o -output-file FILENAME specifies target executable name
+ -I -include-path PATHNAME specifies alternative path for included
+ files
+ -to-stdout write compiler to stdout (implies -t)
+ -s -shared -dynamic generate dynamically loadable shared object
+ file
+
+ Language options:
+
+ -D -DSYMBOL -feature SYMBOL register feature identifier
+ -c++ compile via a C++ source file (.cpp)
+ -objc compile via Objective-C source file (.m)
+
+ Syntax related options:
+
+ -i -case-insensitive don't preserve case of read symbols
+ -k -keyword-style STYLE enable alternative keyword-syntax
+ (prefix, suffix or none)
+ -no-parentheses-synonyms disables list delimiter synonyms
+ -no-symbol-escape disables support for escaped symbols
+ -r5rs-syntax disables the Chicken extensions to
+ R5RS syntax
+ -compile-syntax macros are made available at run-time
+ -j -emit-import-library MODULE write compile-time module information into
+ separate file
+ -J -emit-all-import-libraries emit import-libraries for all defined modules
+ -no-compiler-syntax disable expansion of compiler-macros
+
+ Translation options:
+
+ -x -explicit-use do not use units `library' and `eval' by
+ default
+ -P -check-syntax stop compilation after macro-expansion
+ -A -analyze-only stop compilation after first analysis pass
+
+ Debugging options:
+
+ -w -no-warnings disable warnings
+ -disable-warning CLASS disable specific class of warnings
+ -d0 -d1 -d2 -debug-level NUMBER
+ set level of available debugging information
+ -no-trace disable rudimentary debugging information
+ -profile executable emits profiling information
+ -accumulate-profile executable emits profiling information in
+ append mode
+ -profile-name FILENAME name of the generated profile information
+ file
+ -S -scrutinize perform local flow analysis
+ -types FILENAME load additional type database
+
+ Optimization options:
+
+ -O -O1 -O2 -O3 -O4 -optimize-level NUMBER
+ enable certain sets of optimization options
+ -optimize-leaf-routines enable leaf routine optimization
+ -N -no-usual-integrations standard procedures may be redefined
+ -u -unsafe disable safety checks
+ -local assume globals are only modified in current
+ file
+ -b -block enable block-compilation
+ -disable-interrupts disable interrupts in compiled code
+ -f -fixnum-arithmetic assume all numbers are fixnums
+ -Ob -benchmark-mode equivalent to '-block -optimize-level 4
+ -debug-level 0 -fixnum-arithmetic
+ -lambda-lift -inline -disable-interrupts'
+ -lambda-lift perform lambda-lifting
+ -unsafe-libraries link with unsafe runtime system
+ -disable-stack-overflow-checks disables detection of stack-overflows
+ -inline enable inlining
+ -inline-limit set inlining threshold
+ -inline-global enable cross-module inlining
+ -n -emit-inline-file FILENAME generate file with globally inlinable
+ procedures (implies -inline -local)
+ -consult-inline-file FILENAME explicitly load inline file
+ -no-argc-checks disable argument count checks
+ -no-bound-checks disable bound variable checks
+ -no-procedure-checks disable procedure call checks
+ -no-procedure-checks-for-usual-bindings
+ disable procedure call checks only for usual
+ bindings
+
+ Configuration options:
+
+ -unit NAME compile file as a library unit
+ -uses NAME declare library unit as used.
+ -heap-size NUMBER specifies heap-size of compiled executable
+ -heap-initial-size NUMBER specifies heap-size at startup time
+ -heap-growth PERCENTAGE specifies growth-rate of expanding heap
+ -heap-shrinkage PERCENTAGE specifies shrink-rate of contracting heap
+ -nursery NUMBER -stack-size NUMBER
+ specifies nursery size of compiled
+ executable
+ -X -extend FILENAME load file before compilation commences
+ -prelude EXPRESSION add expression to beginning of source file
+ -postlude EXPRESSION add expression to end of source file
+ -prologue FILENAME include file before main source file
+ -epilogue FILENAME include file after main source file
+
+ -e -embedded compile as embedded
+ (don't generate `main()')
+ -W -windows compile as Windows GUI application
+ -R -require-extension NAME require extension and import in compiled
+ code
+ -dll -library compile multiple units into a dynamic
+ library
+
+ Options to other passes:
+
+ -C OPTION pass option to C compiler
+ -L OPTION pass option to linker
+ -I<DIR> pass \"-I<DIR>\" to C compiler
+ (add include path)
+ -L<DIR> pass \"-L<DIR>\" to linker
+ (add library path)
+ -k keep intermediate files
+ -c stop after compilation to object files
+ -t stop after translation to C
+ -cc COMPILER select other C compiler than the default
+ -cxx COMPILER select other C++ compiler than the default
+ -ld COMPILER select other linker than the default
+ -lLIBNAME link with given library
+ (`libLIBNAME' on UNIX,
+ `LIBNAME.lib' on Windows)
+ -static-libs link with static CHICKEN libraries
+ -static generate completely statically linked
+ executable
+ -static-extension NAME link extension NAME statically
+ (if available)
+ -F<DIR> pass \"-F<DIR>\" to C compiler
+ (add framework header path on Mac OS X)
+ -framework NAME passed to linker on Mac OS X
+ -rpath PATHNAME add directory to runtime library search path
+ -Wl,... pass linker options
+ -strip strip resulting binary
+
+ Inquiry options:
+
+ -home show home-directory (where support files go)
+ -cflags show required C-compiler flags and exit
+ -ldflags show required linker flags and exit
+ -libs show required libraries and exit
+ -cc-name show name of default C compiler used
+ -cxx-name show name of default C++ compiler used
+ -ld-name show name of default linker used
+ -dry-run just show commands executed, don't run them
+ (implies `-v')
+
+ Obscure options:
+
+ -debug MODES display debugging output for the given modes
+ -compiler PATHNAME use other compiler than default `chicken'
+ -disable-c-syntax-checks disable syntax checks of C code fragments
+ -raw do not generate implicit init- and exit code
+ -emit-external-prototypes-first
+ emit prototypes for callbacks before foreign
+ declarations
+ -ignore-repository do not refer to repository for extensions
+ -keep-shadowed-macros do not remove shadowed macro
+ -host compile for host when configured for
+ cross-compiling
+
+ Options can be collapsed if unambiguous, so
+
+ -vkfO
+
+ is the same as
+
+ -v -k -fixnum-arithmetic -optimize
+
+ The contents of the environment variable CSC_OPTIONS are implicitly passed to
+ every invocation of `csc'.
+
+EOF
+) )
+
+
+;;; Parse arguments:
+
+(define (run args)
+
+ (define (t-options . os)
+ (set! translate-options (append translate-options os)) )
+
+ (define (check o r . n)
+ (unless (>= (length r) (optional n 1))
+ (quit "not enough arguments to option `~A'" o) ) )
+
+ (define (shared-build lib)
+ (set! translate-options (cons* "-feature" "chicken-compile-shared" translate-options))
+ (set! compile-options (append pic-options '("-DC_SHARED") compile-options))
+ (set! link-options
+ (cons (cond
+ (osx (if lib "-dynamiclib" "-bundle"))
+ (msvc "-dll")
+ (else "-shared")) link-options))
+ (set! shared #t) )
+
+ (let loop ([args args])
+ (cond [(null? args)
+ ;Builtin search directory options do not override explict options
+ (set! compile-options (append compile-options builtin-compile-options))
+ (set! link-options (append link-options builtin-link-options))
+ ;
+ (when inquiry-only
+ (when show-cflags (print* (compiler-options) #\space))
+ (when show-ldflags (print* (linker-options) #\space))
+ (when show-libs (print* (linker-libraries #t) #\space))
+ (newline)
+ (exit) )
+ #; ;UNUSED
+ (when (null? scheme-files)
+ (set! scheme-files c-files)
+ (set! c-files '()) )
+ (cond [(null? scheme-files)
+ (when (and (null? c-files) (null? object-files))
+ (quit "no source files specified") )
+ (let ((f0 (last (if (null? c-files) object-files c-files))))
+ (unless target-filename
+ (set! target-filename
+ (if shared
+ (pathname-replace-extension f0 shared-library-extension)
+ (pathname-replace-extension f0 executable-extension) ) ) ) ) ]
+ [else
+ (when (and shared (not embedded))
+ (set! translate-options (cons "-dynamic" translate-options)) )
+ (unless target-filename
+ (set! target-filename
+ (if shared
+ (pathname-replace-extension (first scheme-files) shared-library-extension)
+ (pathname-replace-extension (first scheme-files) executable-extension) ) ) )
+ (run-translation) ] )
+ (unless translate-only
+ (run-compilation)
+ (unless compile-only
+ (when (member target-filename scheme-files)
+ (printf "Warning: output file will overwrite source file `~A' - renaming source to `~A.old'~%"
+ target-filename target-filename)
+ (unless (zero? ($system (sprintf "~A ~A ~A"
+ (if windows-shell "move" "mv")
+ (quotewrap target-filename)
+ (quotewrap (string-append target-filename ".old")))))
+ (exit last-exit-code) ) )
+ (run-linking)) ) ]
+ [else
+ (let* ([arg (car args)]
+ [rest (cdr args)]
+ [s (string->symbol arg)] )
+ (case s
+ [(-help --help)
+ (usage)
+ (exit) ]
+ [(-release)
+ (print (chicken-version))
+ (exit) ]
+ [(-version)
+ (system (sprintf translator " -version"))
+ (exit) ]
+ [(-c++)
+ (set! cpp-mode #t)
+ (when osx (set! compile-options (cons "-no-cpp-precomp" compile-options))) ]
+ [(-objc)
+ (set! objc-mode #t) ]
+ [(-static)
+ (set! translate-options (cons* "-feature" "chicken-compile-static" translate-options))
+ (set! static #t) ]
+ [(-static-libs)
+ (set! translate-options (cons* "-feature" "chicken-compile-static" translate-options))
+ (set! static-libs #t) ]
+ [(-cflags)
+ (set! inquiry-only #t)
+ (set! show-cflags #t) ]
+ [(-ldflags)
+ (set! inquiry-only #t)
+ (set! show-ldflags #t) ]
+ [(-cc-name) (print compiler) (exit 0)]
+ [(-cxx-name) (print c++-compiler) (exit 0)]
+ [(-ld-name) (print linker) (exit 0)]
+ [(-home) (print home) (exit 0)]
+ [(-libs)
+ (set! inquiry-only #t)
+ (set! show-libs #t) ]
+ [(-v)
+ (when (and (number? verbose) (not msvc))
+ (set! compile-options (cons* "-v" "-Q" compile-options))
+ (set! link-options (cons (if msvc "-VERBOSE" "-v") link-options)) )
+ (cond (verbose
+ (t-options "-verbose")
+ (set! verbose 2))
+ (else (set! verbose #t))) ]
+ [(-v2 -verbose) ; DEPRECATED
+ (set! verbose #t)
+ (t-options "-verbose") ]
+ [(-v3) ; DEPRECATED
+ (set! verbose #t)
+ (t-options "-verbose")
+ (if (not msvc)
+ (set! compile-options (cons* "-v" "-Q" compile-options)))
+ (set! link-options (cons (if msvc "-VERBOSE" "-v") link-options)) ]
+ [(-w -no-warnings)
+ (set! compile-options (cons "-w" compile-options))
+ (t-options "-no-warnings") ]
+ [(|-A| -analyze-only)
+ (set! translate-only #t)
+ (t-options "-analyze-only") ]
+ [(|-P| -check-syntax)
+ (set! translate-only #t)
+ (t-options "-check-syntax") ]
+ [(-k) (set! keep-files #t)]
+ [(-c) (set! compile-only #t)]
+ [(-t) (set! translate-only #t)]
+ [(-e -embedded)
+ (set! embedded #t)
+ (set! compile-options (cons "-DC_EMBEDDED" compile-options)) ]
+ [(-require-extension -R)
+ (check s rest)
+ (set! required-extensions (append required-extensions (list (car rest))))
+ (t-options "-require-extension" (car rest))
+ (set! rest (cdr rest)) ]
+ [(-static-extension)
+ (check s rest)
+ (set! static-extensions (append static-extensions (list (car rest))))
+ (t-options "-static-extension" (car rest))
+ (set! rest (cdr rest)) ]
+ [(-windows |-W|)
+ (set! gui #t)
+ (cond
+ (mingw
+ (set! link-options
+ (cons* "-lkernel32" "-luser32" "-lgdi32" "-mwindows"
+ link-options))
+ (set! compile-options (cons "-DC_WINDOWS_GUI" compile-options)))
+ (msvc
+ (set! link-options
+ (cons* "kernel32.lib" "user32.lib" "gdi32.lib" link-options))
+ (set! compile-options (cons "-DC_WINDOWS_GUI" compile-options)))) ]
+ [(-framework)
+ (check s rest)
+ (when osx
+ (set! link-options (cons* "-framework" (car rest) link-options)) )
+ (set! rest (cdr rest)) ]
+ [(-o)
+ (check s rest)
+ (let ([fn (car rest)])
+ (set! rest (cdr rest))
+ (set! target-filename fn) ) ]
+ [(|-O| |-O1|) (set! rest (cons* "-optimize-level" "1" rest))]
+ [(|-O2|) (set! rest (cons* "-optimize-level" "2" rest))]
+ [(|-O3|) (set! rest (cons* "-optimize-level" "3" rest))]
+ [(|-O4|) (set! rest (cons* "-optimize-level" "4" rest))]
+ [(-d0) (set! rest (cons* "-debug-level" "0" rest))]
+ [(-d1) (set! rest (cons* "-debug-level" "1" rest))]
+ [(-d2) (set! rest (cons* "-debug-level" "2" rest))]
+ [(-dry-run)
+ (set! verbose #t)
+ (set! dry-run #t)]
+ [(-s -shared -dynamic)
+ (shared-build #f) ]
+ [(-dll -library)
+ (shared-build #t) ]
+ [(-compiler)
+ (check s rest)
+ (set! translator (car rest))
+ (set! rest (cdr rest)) ]
+ [(-cc)
+ (check s rest)
+ (set! compiler (car rest))
+ (set! rest (cdr rest)) ]
+ [(-cxx)
+ (check s rest)
+ (set! c++-compiler (car rest))
+ (set! rest (cdr rest)) ]
+ [(-ld)
+ (check s rest)
+ (set! linker (car rest))
+ (set! rest (cdr rest)) ]
+ [(|-I|)
+ (check s rest)
+ (set! rest (cons* "-include-path" (car rest) (cdr rest))) ]
+ [(|-C|)
+ (check s rest)
+ (set! compile-options (append compile-options (string-split (car rest))))
+ (set! rest (cdr rest)) ]
+ [(-strip)
+ (set! link-options (append link-options (list "-s")))]
+ [(|-L|)
+ (check s rest)
+ (set! link-options (append link-options (string-split (car rest))))
+ (set! rest (cdr rest)) ]
+ [(-unsafe-libraries)
+ (t-options arg)
+ (set! library-files unsafe-library-files)
+ (set! shared-library-files unsafe-shared-library-files) ]
+ [(-rpath)
+ (check s rest)
+ (when (eq? 'gnu (build-platform))
+ (set! link-options (append link-options (list (string-append "-Wl,-R" (car rest)))))
+ (set! rest (cdr rest)) ) ]
+ [(-host) #f]
+ [(-)
+ (set! target-filename (make-pathname #f "a" executable-extension))
+ (set! scheme-files (append scheme-files '("-")))]
+ [else
+ (when (memq s '(-unsafe -benchmark-mode))
+ (when (eq? s '-benchmark-mode)
+ (set! library-files unsafe-library-files)
+ (set! shared-library-files unsafe-shared-library-files) ) )
+ (when (eq? s '-to-stdout)
+ (set! to-stdout #t)
+ (set! translate-only #t) )
+ (when (memq s '(-optimize-level -benchmark-mode))
+ (set! compilation-optimization-options best-compilation-optimization-options)
+ (set! linking-optimization-options best-linking-optimization-options) )
+ (cond [(assq s shortcuts) => (lambda (a) (set! rest (cons (cadr a) rest)))]
+ [(memq s simple-options) (t-options arg)]
+ [(memq s complex-options)
+ (check s rest)
+ (let* ([n (car rest)]
+ [ns (string->number n)] )
+ (t-options arg n)
+ (set! rest (cdr rest)) ) ]
+ [(and (> (string-length arg) 2) (string=? "-:" (substring arg 0 2)))
+ (t-options arg) ]
+ [(and (> (string-length arg) 1)
+ (char=? #\- (string-ref arg 0)) )
+ (cond [(char=? #\l (string-ref arg 1))
+ (set! link-options (append link-options (list arg))) ]
+ [(char=? #\L (string-ref arg 1))
+ (set! link-options (append link-options (list arg))) ]
+ [(char=? #\I (string-ref arg 1))
+ (set! compile-options (append compile-options (list arg))) ]
+ [(char=? #\D (string-ref arg 1))
+ (t-options "-feature" (substring arg 2)) ]
+ [(char=? #\F (string-ref arg 1))
+ (when osx
+ (set! compile-options (append compile-options (list arg))) ) ]
+ [(and (> (string-length arg) 3) (string=? "-Wl," (substring arg 0 4)))
+ (set! link-options (append link-options (list arg))) ]
+ [(> (string-length arg) 2)
+ (let ([opts (cdr (string->list arg))])
+ (if (null? (lset-difference char=? opts short-options))
+ (set! rest
+ (append (map (lambda (o) (string-append "-" (string o))) opts) rest) )
+ (quit "invalid option `~A'" arg) ) ) ]
+ [else (quit "invalid option `~A'" s)] ) ]
+ [(file-exists? arg)
+ (let-values ([(dirs name ext) (decompose-pathname arg)])
+ (cond [(not ext) (set! scheme-files (append scheme-files (list arg)))]
+ [(member ext '("h" "c"))
+ (set! c-files (append c-files (list arg))) ]
+ [(member ext '("cpp" "C" "cc" "cxx" "hpp"))
+ (when osx (set! compile-options (cons "-no-cpp-precomp" compile-options)))
+ (set! cpp-mode #t)
+ (set! c-files (append c-files (list arg))) ]
+ [(member ext '("m" "M" "mm"))
+ (set! objc-mode #t)
+ (set! c-files (append c-files (list arg))) ]
+ [(or (string=? ext object-extension)
+ (string=? ext library-extension) )
+ (set! object-files (append object-files (list arg))) ]
+ [else (set! scheme-files (append scheme-files (list arg)))] ) ) ]
+ [else
+ (let ([f2 (string-append arg ".scm")])
+ (if (file-exists? f2)
+ (set! rest (cons f2 rest))
+ (quit "file `~A' does not exist" arg) ) ) ] ) ] )
+ (loop rest) ) ] ) ) )
+
+
+;;; Translate all Scheme files:
+
+(define (run-translation)
+ (for-each
+ (lambda (f)
+ (let ([fc (pathname-replace-extension
+ (if (= 1 (length scheme-files))
+ target-filename
+ f)
+ (cond (cpp-mode "cpp")
+ (objc-mode "m")
+ (else "c") ) ) ] )
+ (unless (zero?
+ ($system
+ (string-intersperse
+ (cons* translator (cleanup-filename f)
+ (append
+ (if to-stdout
+ '("-to-stdout")
+ `("-output-file" ,(cleanup-filename fc)) )
+ (map quote-option (append translate-options translation-optimization-options)) ) )
+ " ") ) )
+ (exit last-exit-code) )
+ (set! c-files (append (list fc) c-files))
+ (set! generated-c-files (append (list fc) generated-c-files))))
+ scheme-files)
+ (unless keep-files (for-each $delete-file generated-scheme-files)) )
+
+
+;;; Compile all C files:
+
+(define (run-compilation)
+ (let ((ofiles '()))
+ (for-each
+ (lambda (f)
+ (let ([fo (pathname-replace-extension f object-extension)])
+ (unless (zero?
+ ($system
+ (string-intersperse
+ (list (cond (cpp-mode c++-compiler)
+ (else compiler) )
+ (cleanup-filename f)
+ (string-append compile-output-flag (cleanup-filename fo))
+ compile-only-flag
+ (compiler-options) ) ) ) )
+ (exit last-exit-code) )
+ (set! generated-object-files (cons fo generated-object-files))
+ (set! ofiles (cons fo ofiles))))
+ c-files)
+ (set! object-files (append (reverse ofiles) object-files)) ; put generated object files first
+ (unless keep-files (for-each $delete-file generated-c-files)) ) )
+
+(define (compiler-options)
+ (string-intersperse
+ (map quote-option
+ (append
+ (if (or static static-libs) '() nonstatic-compilation-options)
+ compilation-optimization-options
+ compile-options) ) ) )
+
+
+;;; Link object files and libraries:
+
+(define (run-linking)
+ (let ((files (map cleanup-filename
+ (append object-files
+ (nth-value 0 (static-extension-info)) ) ) )
+ (target (cleanup-filename target-filename)))
+ (unless (zero?
+ ($system
+ (string-intersperse
+ (cons* (cond (cpp-mode c++-linker)
+ (else linker) )
+ (append
+ files
+ (list (string-append link-output-flag target)
+ (linker-options)
+ (linker-libraries #f) ) ) ) ) ) )
+ (exit last-exit-code) )
+ (when (and osx (or (not cross-chicken) host-mode))
+ (unless (zero? ($system
+ (string-append
+ "install_name_tool -change libchicken.dylib "
+ (quotewrap
+ (make-pathname
+ (prefix "" "lib"
+ (if host-mode
+ INSTALL_LIB_HOME
+ TARGET_RUN_LIB_HOME))
+ "libchicken.dylib") )
+ " "
+ target) ) )
+ (exit last-exit-code) ) )
+ (unless keep-files (for-each $delete-file generated-object-files)) ) )
+
+(define (static-extension-info)
+ (let ((rpath (repository-path)))
+ (if (and rpath (pair? static-extensions))
+ (let loop ((exts static-extensions) (libs '()) (opts '()))
+ (if (null? exts)
+ (values (reverse libs) (reverse opts))
+ (let ((info (extension-information (car exts))))
+ (if info
+ (let ((a (assq 'static info))
+ (o (assq 'static-options info)) )
+ (loop (cdr exts)
+ (if a (cons (make-pathname rpath (cadr a)) libs) libs)
+ (if o (cons (cadr o) opts) opts) ) )
+ (loop (cdr exts) libs opts)) ) ) )
+ (values '() '()) ) ) )
+
+(define (linker-options)
+ (string-append
+ (string-intersperse
+ (append linking-optimization-options link-options
+ (nth-value 1 (static-extension-info)) ) )
+ (if (and static (not mingw) (not msvc) (not osx)) " -static" "") ) )
+
+(define (linker-libraries #!optional staticexts)
+ (string-intersperse
+ (append
+ (if staticexts (nth-value 0 (static-extension-info)) '())
+ (if (or static static-libs)
+ (if gui gui-library-files library-files)
+ (if gui gui-shared-library-files shared-library-files))
+ (if (or static static-libs)
+ (list extra-libraries)
+ (list extra-shared-libraries)))))
+
+
+;;; Helper procedures:
+
+(define-constant +hairy-chars+ '(#\\ #\#))
+
+(define (cleanup s)
+ (let* ((q #f)
+ (s (list->string
+ (let fold ([s (string->list s)])
+ (if (null? s)
+ '()
+ (let ([c (car s)])
+ (cond ((memq c +hairy-chars+) (cons* #\\ c (fold (cdr s))))
+ (else
+ (when (char-whitespace? c) (set! q #t))
+ (cons c (fold (cdr s))) ) ) ) ) ) ) ) )
+ (if q
+ (string-append "\"" (string-translate* s '(("\"" . "\\\""))) "\"")
+ s) ) )
+
+(define (quote-option x)
+ (if (string-any (lambda (c)
+ (or (char-whitespace? c) (memq c +hairy-chars+)) )
+ x)
+ (cleanup x)
+ x) )
+
+(define last-exit-code #f)
+
+(define ($system str)
+ (when verbose (print str))
+ (let ((str (if windows-shell
+ (string-append "\"" str "\"")
+ str)))
+ (let ((raw-exit-code (if dry-run 0 (system str))))
+ (unless (zero? raw-exit-code)
+ (printf "\nError: shell command terminated with non-zero exit status ~S: ~A~%" raw-exit-code str))
+ (set! last-exit-code
+ (if (zero? raw-exit-code) 0 1))
+ last-exit-code)))
+
+(define ($delete-file str)
+ (when verbose
+ (print "rm " str) )
+ (unless dry-run (delete-file str) ))
+
+
+;;; Run it:
+
+(run (append (string-split (or (get-environment-variable "CSC_OPTIONS") "")) arguments))
diff --git a/csi.1 b/csi.1
new file mode 100644
index 00000000..4f50f754
--- /dev/null
+++ b/csi.1
@@ -0,0 +1,190 @@
+-.\" dummy line
+.TH CSI 1 "20 May 2008"
+
+.SH NAME
+
+The
+.I Chicken
+Scheme interpreter
+
+.SH SYNOPSIS
+
+.B csi
+[
+.I pathname
+|
+.I option ...
+]
+
+.SH DESCRIPTION
+
+.I csi
+is an interpreter for the programming language
+.I Scheme
+supporting most of the features as described in the
+.I Revised^5 Report on
+.I the Algorithmic Language Scheme
+\.
+.I csi
+is implemented as a program compiled with the
+.B chicken
+compiler.
+
+.SH OPTIONS
+
+.TP
+.B \-\-
+Ignore everything on the command-line following this marker. Runtime options
+.B \-\:...
+are still recognized.
+
+.TP
+.B \-i\ \-case\-insensitive
+Enables the reader to read symbols case-insensitive. The default is to read case-sensitive (in violation of R5RS).
+This option registers the
+.B case\-insensitive
+feature identifier.
+
+.TP
+.B \-b\ \-batch
+Quit the interpreter after processing all command line options.
+
+.TP
+.BI \-e\ \-eval \ expressions
+Evaluate
+.I expressions
+\.
+
+.TP
+.BI \-p\ \-print \ expressions
+Evaluate
+.I expressions
+and print result(s)
+\.
+
+.TP
+.BI \-P\ \-pretty-print \ expressions
+Evaluate
+.I expressions
+and pretty-print result(s)
+\.
+
+.BI \-D\ \-feature \ symbol
+Registers
+.I symbol
+to be a valid feature identifier for
+.B cond\-expand
+
+.TP
+.B \-h\ \-help
+Write a summary of the available command line options to standard ouput and exit.
+
+.TP
+.BI \-I\ \-include\-path \ pathname
+Specifies an alternative search-path for files included via the
+.B include
+special form. This option may be given multiple times. If the environment variable
+.B CHICKEN_INCLUDE_PATH
+is set, it should contain a list of alternative include
+pathnames separated by
+.B \; .
+
+.TP
+.BI \-k\ \-keyword\-style style
+Enables alternative keyword syntax, where style may be either
+.B prefix
+(as in Common Lisp),
+.B suffix
+(as in DSSSL) or
+.B none
+Any other value is ignored. The default is \texttt{suffix}.
+
+.TP
+.B \-n\ \-no\-init
+Do not load the initialization-file
+.I ~/\.csirc
+\.
+If this option is not given and the file
+.I ~/\.csirc
+exists, then it is loaded before the read-eval-print loop commences.
+
+.TP
+.B \-w\ \-no\-warnings
+Disables any warnings that might be issued by the reader or evaluated code.
+
+.TP
+.B \-q\ \-quiet
+Do not print a startup message.
+
+.TP
+.BI \-s\ \-script\ pathname
+This is equivalent to
+.B \-batch\ \-quiet
+.I pathname
+, but also ignores all arguments after the argument following
+.B \-script
+
+.TP
+.BI \-sx\ pathname
+Similar to
+.B \-script
+but invokes prints each expression before it is evaluated,
+
+.TP
+.BI \-ss\ pathname
+Similar to
+.B \-script
+but invokes the procedure
+.B main
+after loading the file specified by
+.B pathname
+with a single argument (the list of command line arguments) returning any result as status code.
+
+.TP
+.BI \-R\ \-require\-extension\ name
+Require extension for evaluated code.
+
+.TP
+.B \-v\ \-version
+Write the banner with version information to standard output and exit.
+
+.SH ENVIRONMENT\ VARIABLES
+
+.TP
+.B CHICKEN_INCLUDE_PATH
+Contains one or more pathnames where the interpreter should also look for include-files, separated by
+.B \;
+characters.
+
+.TP
+.B CHICKEN_PREFIX
+Is used as a prefix directory for support files, include-files and libraries.
+
+.TP
+.B CSI_OPTIONS
+When set to a string of command-line options, then the options are passed implicitly
+to every direct or indirect invocation of
+.I csi
+.br
+Note that runtime options of the form
+.B \-\:\.\.\.
+can not be passed using this method.
+
+.SH DOCUMENTATION
+
+More information can be found in the
+.I Chicken\ User's\ Manual
+
+.SH BUGS
+Submit bug reports by e-mail to
+.I chicken-janitors@nongnu.org
+, preferrably using the
+.B chicken\-bug
+tool.
+
+.SH AUTHOR
+Felix Winkelmann and the Chicken Team
+
+.SH SEE ALSO
+.BR chicken(1)
+.BR chicken-bug(1)
diff --git a/csi.import.scm b/csi.import.scm
new file mode 100644
index 00000000..7f187300
--- /dev/null
+++ b/csi.import.scm
@@ -0,0 +1,29 @@
+;;;; csi.import.scm - import library for "csi" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'csi
+ '(toplevel-command set-describer!))
diff --git a/csi.scm b/csi.scm
new file mode 100644
index 00000000..02eea351
--- /dev/null
+++ b/csi.scm
@@ -0,0 +1,1015 @@
+;;;; csi.scm - Interpreter stub for CHICKEN
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (uses chicken-syntax srfi-69 ports extras)
+ (usual-integrations)
+ (disable-interrupts)
+ (disable-warning var)
+ (compile-syntax)
+ (foreign-declare #<<EOF
+#if (defined(_MSC_VER) && defined(_WIN32)) || defined(HAVE_DIRECT_H)
+# include <direct.h>
+#else
+# define _getcwd(buf, len) NULL
+#endif
+EOF
+) )
+
+(include "banner")
+
+(private csi
+ print-usage print-banner
+ run hexdump del
+ parse-option-string chop-separator lookup-script-file
+ report describe dump hexdump bytevector-data get-config
+ deldups tty-input?
+ history-list history-count history-add history-ref
+ trace-indent trace-indent-level traced-procedure-entry traced-procedure-exit)
+
+(declare
+ (always-bound
+ ##sys#windows-platform)
+ (hide parse-option-string bytevector-data member* canonicalize-args do-trace do-untrace
+ traced-procedures describer-table dirseparator? resolve-var
+ findall trace-indent command-table do-break do-unbreak broken-procedures) )
+
+
+;;; Parameters:
+
+(define-constant init-file ".csirc")
+
+(set! ##sys#repl-print-length-limit 2048)
+(set! ##sys#features (cons #:csi ##sys#features))
+
+
+;;; Print all sorts of information:
+
+(define (print-usage)
+ (display #<<EOF
+usage: csi [FILENAME | OPTION ...]
+
+ `csi' is the CHICKEN interpreter.
+
+ FILENAME is a Scheme source file name with optional extension. OPTION may be
+ one of the following:
+
+ -h -help --help display this text and exit
+ -v -version display version and exit
+ -release print release number and exit
+ -i -case-insensitive enable case-insensitive reading
+ -e -eval EXPRESSION evaluate given expression
+ -p -print EXPRESSION evaluate and print result(s)
+ -P -pretty-print EXPRESSION evaluate and print result(s) prettily
+ -D -feature SYMBOL register feature identifier
+ -q -quiet do not print banner
+
+EOF
+)
+ (display #<#EOF
+ -n -no-init do not load initialization file #{#\`} #{init-file} #{#\'}
+
+EOF
+)
+ (display #<<EOF
+ -b -batch terminate after command-line processing
+ -w -no-warnings disable all warnings
+ -k -keyword-style STYLE enable alternative keyword-syntax
+ (prefix, suffix or none)
+ -no-parentheses-synonyms disables list delimiter synonyms
+ -no-symbol-escape disables support for escaped symbols
+ -r5rs-syntax disables the Chicken extensions to
+ R5RS syntax
+ -s -script PATHNAME use interpreter for shell scripts
+ -ss PATHNAME shell script with `main' procedure
+ -sx PATHNAME same as `-s', but print each expression
+ as it is evaluated
+ -setup-mode prefer the current directory when locating extensions
+ -R -require-extension NAME require extension and import before
+ executing code
+ -I -include-path PATHNAME add PATHNAME to include path
+ -- ignore all following options
+
+EOF
+) )
+
+(define (print-banner)
+ (newline)
+ #; ;UNUSED
+ (when (and (tty-input?) (##sys#fudge 11))
+ (let* ((t (string-copy +product+))
+ (len (string-length t))
+ (c (make-string len #\x08)))
+ (do ((i (sub1 (* 2 len)) (sub1 i)))
+ ((zero? i))
+ (let* ((p (abs (- i len)))
+ (o (string-ref t p)))
+ (string-set! t p #\@)
+ (print* t)
+ (string-set! t p o)
+ (let ((t0 (+ (current-milliseconds) 20)))
+ (let loop () ; crude, but doesn't need srfi-18
+ (when (< (current-milliseconds) t0)
+ (loop))))
+ (print* c) ) ) ) )
+ (print +product+)
+ (print +banner+ (chicken-version #t) "\n") )
+
+
+;;; Reader for REPL history:
+
+(set! ##sys#user-read-hook
+ (let ([read-char read-char]
+ [read read]
+ [old-hook ##sys#user-read-hook] )
+ (lambda (char port)
+ (cond [(or (char=? #\) char) (char-whitespace? char))
+ `',(history-ref (fx- history-count 1)) ]
+ [else (old-hook char port)] ) ) ) )
+
+(set! ##sys#sharp-number-hook
+ (lambda (port n)
+ `',(history-ref n) ) )
+
+
+;;; Chop terminating separator from pathname:
+
+(define (dirseparator? c)
+ (or (char=? c #\\) (char=? c #\/)))
+
+(define chop-separator
+ (let ([substring substring] )
+ (lambda (str)
+ (let* ((len (sub1 (##sys#size str)))
+ (c (string-ref str len)))
+ (if (and (fx> len 0) (dirseparator? c))
+ (substring str 0 len)
+ str) ) ) ) )
+
+
+;;; Find script in PATH (only used for Windows/DOS):
+
+(define @ #f)
+
+(define lookup-script-file
+ (let* ([buf (make-string 256)]
+ [_getcwd (foreign-lambda nonnull-c-string "_getcwd" scheme-pointer int)] )
+ (define (addext name)
+ (if (file-exists? name)
+ name
+ (let ([n2 (string-append name ".bat")])
+ (and (file-exists? n2) n2) ) ) )
+ (define (string-index proc str1)
+ (let ((len (##sys#size str1)))
+ (let loop ((i 0))
+ (cond ((fx>= i len) #f)
+ ((proc (##core#inline "C_subchar" str1 i)) i)
+ (else (loop (fx+ i 1))) ) ) ) )
+ (lambda (name)
+ (let ([path (get-environment-variable "PATH")])
+ (and (> (##sys#size name) 0)
+ (cond [(dirseparator? (string-ref name 0)) (addext name)]
+ [(string-index dirseparator? name)
+ (and-let* ([p (_getcwd buf 256)])
+ (addext (string-append (chop-separator p) "/" name)) ) ]
+ [(addext name)]
+ [else
+ (let ([name2 (string-append "/" name)])
+ (let loop ([ps (string-split path ";")])
+ (and (pair? ps)
+ (let ([name2 (string-append (chop-separator (##sys#slot ps 0)) name2)])
+ (or (addext name2)
+ (loop (##sys#slot ps 1)) ) ) ) ) ) ] ) ) ) ) ) )
+
+
+;;; REPL customization:
+
+(define history-list (make-vector 32))
+(define history-count 1)
+
+(define history-add
+ (let ([vector-resize vector-resize])
+ (lambda (vals)
+ (let ([x (if (null? vals) (##sys#void) (##sys#slot vals 0))]
+ [size (##sys#size history-list)] )
+ (when (fx>= history-count size)
+ (set! history-list (vector-resize history-list (fx* 2 size))) )
+ (vector-set! history-list history-count x)
+ (set! history-count (fx+ history-count 1))
+ x) ) ) )
+
+(define (history-ref index)
+ (let ([i (inexact->exact index)])
+ (if (and (fx> i 0) (fx<= i history-count))
+ (vector-ref history-list i)
+ (##sys#error "history entry index out of range" index) ) ) )
+
+(repl-prompt
+ (let ([sprintf sprintf])
+ (lambda ()
+ (sprintf "#;~A> " history-count) ) ) )
+
+(define (tty-input?)
+ (or (##sys#fudge 12) (##sys#tty-port? ##sys#standard-input)) )
+
+(set! ##sys#break-on-error #f)
+
+(set! ##sys#read-prompt-hook
+ (let ([old ##sys#read-prompt-hook])
+ (lambda ()
+ (when (tty-input?) (old)) ) ) )
+
+(define command-table (make-vector 37 '()))
+
+(define (toplevel-command name proc #!optional help)
+ (##sys#check-symbol name 'toplevel-command)
+ (when help (##sys#check-string help 'toplevel-command))
+ (##sys#hash-table-set! command-table name (cons proc help)) )
+
+(set! ##sys#repl-eval-hook
+ (let ((eval eval)
+ (load-noisily load-noisily)
+ (read read)
+ (singlestep singlestep)
+ (read-line read-line)
+ (length length)
+ (display display)
+ (write write)
+ (string-split string-split)
+ (printf printf)
+ (expand expand)
+ (pretty-print pretty-print)
+ (integer? integer?)
+ (values values) )
+ (lambda (form)
+ (set! trace-indent-level 0)
+ (cond ((eof-object? form) (exit))
+ ((and (pair? form)
+ (eq? 'unquote (##sys#slot form 0)) )
+ (let ((cmd (cadr form)))
+ (cond ((and (symbol? cmd) (##sys#hash-table-ref command-table cmd)) =>
+ (lambda (p)
+ ((car p))
+ (##sys#void) ) )
+ (else
+ (case cmd
+ ((x)
+ (let ([x (read)])
+ (pretty-print (##sys#strip-syntax (expand x)))
+ (##sys#void) ) )
+ ((p)
+ (let* ([x (read)]
+ [xe (eval x)] )
+ (pretty-print xe)
+ (##sys#void) ) )
+ ((d)
+ (let* ([x (read)]
+ [xe (eval x)] )
+ (describe xe) ) )
+ ((du)
+ (let* ([x (read)]
+ [xe (eval x)] )
+ (dump xe) ) )
+ ((dur)
+ (let* ([x (read)]
+ [n (read)]
+ [xe (eval x)]
+ [xn (eval n)] )
+ (dump xe xn) ) )
+ ((r) (report))
+ ((q) (exit))
+ ((l)
+ (let ((fns (string-split (read-line))))
+ (for-each load fns)
+ (##sys#void) ) )
+ ((ln)
+ (let ((fns (string-split (read-line))))
+ (for-each (cut load-noisily <> printer: (lambda (x) (pretty-print x) (print* "==> "))) fns)
+ (##sys#void) ) )
+ ((t)
+ (let ((x (read)))
+ (receive rs (time (eval x))
+ (history-add rs)
+ (apply values rs) ) ) )
+ ((tr) (do-trace (map resolve-var (string-split (read-line)))))
+ ((utr) (do-untrace (map resolve-var (string-split (read-line)))))
+ ((br) (do-break (map resolve-var (string-split (read-line)))))
+ ((ubr) (do-unbreak (map resolve-var (string-split (read-line)))))
+ ((uba) (do-unbreak-all))
+ ((breakall)
+ (set! ##sys#break-in-thread #f) )
+ ((breakonly)
+ (set! ##sys#break-in-thread (eval (read))) )
+ ((info)
+ (when (pair? traced-procedures)
+ (printf "Traced: ~s~%" (map car traced-procedures)) )
+ (when (pair? broken-procedures)
+ (printf "Breakpoints: ~s~%" (map car broken-procedures)) ) )
+ ((c)
+ (cond (##sys#last-breakpoint
+ (let ((exn ##sys#last-breakpoint))
+ (set! ##sys#last-breakpoint #f)
+ (##sys#break-resume exn) ) )
+ (else (display "no breakpoint pending\n") ) ) )
+ ((exn)
+ (when ##sys#last-exception
+ (history-add (list ##sys#last-exception))
+ (describe ##sys#last-exception) ) )
+ ((step)
+ (let ((x (read)))
+ (read-line)
+ (singlestep (eval `(lambda () ,x))) ) )
+ ((s)
+ (let* ((str (read-line))
+ (r (system str)) )
+ (history-add (list r))
+ r) )
+ ((?)
+ (display
+ "Toplevel commands:
+
+ ,? Show this text
+ ,p EXP Pretty print evaluated expression EXP
+ ,d EXP Describe result of evaluated expression EXP
+ ,du EXP Dump data of expression EXP
+ ,dur EXP N Dump range
+ ,q Quit interpreter
+ ,l FILENAME ... Load one or more files
+ ,ln FILENAME ... Load one or more files and print result of each top-level expression
+ ,r Show system information
+ ,s TEXT ... Execute shell-command
+ ,tr NAME ... Trace procedures
+ ,utr NAME ... Untrace procedures
+ ,br NAME ... Set breakpoints
+ ,ubr NAME ... Remove breakpoints
+ ,uba Remove all breakpoints
+ ,breakall Break in all threads (default)
+ ,breakonly THREAD Break only in specified thread
+ ,c Continue from breakpoint
+ ,info List traced procedures and breakpoints
+ ,step EXPR Execute EXPR in single-stepping mode
+ ,exn Describe last exception
+ ,t EXP Evaluate form and print elapsed time
+ ,x EXP Pretty print expanded expression EXP\n")
+ (##sys#hash-table-for-each
+ (lambda (k v)
+ (let ((help (cdr v)))
+ (if help
+ (print #\space help)
+ (print " ," k) ) ) )
+ command-table)
+ (##sys#void) )
+ (else
+ (printf "Undefined toplevel command ~s - enter `,?' for help~%" form)
+ (##sys#void) ) ) ) ) ) )
+ (else
+ (receive rs (eval form)
+ (history-add rs)
+ (apply values rs) ) ) ) ) ) )
+
+(define (resolve-var str)
+ (##sys#strip-syntax (string->symbol str) (##sys#current-environment) #t))
+
+
+;;; Tracing:
+
+(define (del x lst tst)
+ (let loop ([lst lst])
+ (if (null? lst)
+ '()
+ (let ([y (car lst)])
+ (if (tst x y)
+ (cdr lst)
+ (cons y (loop (cdr lst))) ) ) ) ) )
+
+(define trace-indent-level 0)
+(define traced-procedures '())
+(define broken-procedures '())
+
+(define trace-indent
+ (lambda ()
+ (write-char #\|)
+ (do ((i trace-indent-level (sub1 i)))
+ ((<= i 0))
+ (write-char #\space) ) ) )
+
+(define traced-procedure-entry
+ (lambda (name args)
+ (trace-indent)
+ (set! trace-indent-level (add1 trace-indent-level))
+ (write (cons name args))
+ (##sys#write-char-0 #\newline ##sys#standard-output)
+ (flush-output) ) )
+
+(define traced-procedure-exit
+ (lambda (name results)
+ (set! trace-indent-level (sub1 trace-indent-level))
+ (trace-indent)
+ (write name)
+ (display " -> ")
+ (for-each
+ (lambda (x)
+ (write x)
+ (write-char #\space) )
+ results)
+ (##sys#write-char-0 #\newline ##sys#standard-output)
+ (flush-output) ) )
+
+(define do-trace
+ (lambda (names)
+ (if (null? names)
+ (for-each (lambda (a) (print (car a))) traced-procedures)
+ (for-each
+ (lambda (s)
+ (let ((s (expand s)))
+ (cond ((assq s traced-procedures)
+ (##sys#warn "procedure already traced" s) )
+ ((assq s broken-procedures)
+ (##sys#warn "procedure already has breakpoint") )
+ (else
+ (let ((old (##sys#slot s 0)))
+ (cond ((not (procedure? old)) (##sys#error "cannot trace non-procedure" s))
+ (else
+ (set! traced-procedures (cons (cons s old) traced-procedures))
+ (##sys#setslot
+ s 0
+ (lambda args
+ (traced-procedure-entry s args)
+ (call-with-values (lambda () (apply old args))
+ (lambda results
+ (traced-procedure-exit s results)
+ (apply values results) ) ) ) ) ) ) ) ) ) ) )
+ names) ) ) )
+
+(define do-untrace
+ (lambda (names)
+ (for-each
+ (lambda (s)
+ (let* ((s (expand s))
+ (p (assq s traced-procedures)) )
+ (cond ((not p) (##sys#warn "procedure not traced" s))
+ (else
+ (##sys#setslot s 0 (cdr p))
+ (set! traced-procedures (del p traced-procedures eq?) ) ) ) ) )
+ names) ) )
+
+(define do-break
+ (lambda (names)
+ (if (null? names)
+ (for-each (lambda (b) (print (car a))) broken-procedures)
+ (for-each
+ (lambda (s)
+ (let* ((s (expand s))
+ (a (assq s traced-procedures)))
+ (when a
+ (##sys#warn "un-tracing procedure" s)
+ (##sys#setslot s 0 (cdr a))
+ (set! traced-procedures (del a traced-procedures eq?)) )
+ (let ((old (##sys#slot s 0)))
+ (cond ((not (procedure? old)) (##sys#error "cannot set breakpoint on non-procedure" s))
+ (else
+ (set! broken-procedures (cons (cons s old) broken-procedures))
+ (##sys#setslot
+ s 0
+ (lambda args
+ (##sys#break-entry s args)
+ (##sys#apply old args) ) ) ) ) ) ) )
+ names) ) ) )
+
+(define do-unbreak
+ (lambda (names)
+ (for-each
+ (lambda (s)
+ (let* ((s (expand s))
+ (p (assq s broken-procedures)) )
+ (cond ((not p) (##sys#warn "procedure has no breakpoint" s))
+ (else
+ (##sys#setslot s 0 (cdr p))
+ (set! broken-procedures (del p broken-procedures eq?) ) ) ) ) )
+ names) ) )
+
+(define do-unbreak-all
+ (lambda ()
+ (for-each (lambda (bp)
+ (##sys#setslot (car bp) 0 (cdr bp)))
+ broken-procedures)
+ (set! broken-procedures '())
+ (##sys#void)))
+
+;;; Parse options from string:
+
+(define (parse-option-string str)
+ (let ([ins (open-input-string str)])
+ (map (lambda (o)
+ (if (string? o)
+ o
+ (let ([os (open-output-string)])
+ (write o os)
+ (get-output-string os) ) ) )
+ (handle-exceptions ex (##sys#error "invalid option syntax" str)
+ (do ([x (read ins) (read ins)]
+ [xs '() (cons x xs)] )
+ ((eof-object? x) (reverse xs)) ) ) ) ) )
+
+
+;;; Print status information:
+
+(define report
+ (let ((printf printf)
+ (chop chop)
+ (sort sort)
+ (with-output-to-port with-output-to-port)
+ (current-output-port current-output-port) )
+ (lambda port
+ (with-output-to-port (if (pair? port) (car port) (current-output-port))
+ (lambda ()
+ (gc)
+ (let ([sinfo (##sys#symbol-table-info)]
+ [minfo (memory-statistics)] )
+ (define (shorten n) (/ (truncate (* n 100)) 100))
+ (printf "Features:")
+ (for-each
+ (lambda (lst)
+ (display "\n ")
+ (for-each
+ (lambda (f)
+ (printf "~a~a" f (make-string (fxmax 1 (fx- 16 (string-length f))) #\space)) )
+ lst) )
+ (chop (sort (map keyword->string ##sys#features) string<?) 5))
+ (printf "~%~
+ Machine type: \t~A ~A~%~
+ Software type: \t~A~%~
+ Software version:\t~A~%~
+ Build platform: \t~A~%~
+ Include path: \t~A~%~
+ Symbol-table load:\t~S~% ~
+ Avg bucket length:\t~S~% ~
+ Total symbol count:\t~S~%~
+ Memory:\theap size is ~S bytes~A with ~S bytes currently in use~%~
+ nursery size is ~S bytes, stack grows ~A~%"
+ (machine-type)
+ (if (##sys#fudge 3) "(64-bit)" "")
+ (software-type)
+ (software-version)
+ (build-platform)
+ ##sys#include-pathnames
+ (shorten (vector-ref sinfo 0))
+ (shorten (vector-ref sinfo 1))
+ (vector-ref sinfo 2)
+ (vector-ref minfo 0)
+ (if (##sys#fudge 17) " (fixed)" "")
+ (vector-ref minfo 1)
+ (vector-ref minfo 2)
+ (if (= 1 (##sys#fudge 18)) "downward" "upward") )
+ (##sys#write-char-0 #\newline ##sys#standard-output)
+ (when (##sys#fudge 14) (display "interrupts are enabled\n"))
+ (when (##sys#fudge 15) (display "symbol gc is enabled\n"))
+ (##core#undefined) ) ) ) ) ) )
+
+
+;;; Describe & dump:
+
+(define bytevector-data
+ '((u8vector "vector of unsigned bytes" u8vector-length u8vector-ref)
+ (s8vector "vector of signed bytes" s8vector-length s8vector-ref)
+ (u16vector "vector of unsigned 16-bit words" u16vector-length u16vector-ref)
+ (s16vector "vector of signed 16-bit words" s16vector-length s16vector-ref)
+ (u32vector "vector of unsigned 32-bit words" u32vector-length u32vector-ref)
+ (s32vector "vector of signed 32-bit words" s32vector-length s32vector-ref)
+ (f32vector "vector of 32-bit floats" f32vector-length f32vector-ref)
+ (f64vector "vector of 64-bit floats" f64vector-length f64vector-ref) ) )
+
+(define-constant max-describe-lines 40)
+
+(define describer-table (make-vector 37 '()))
+
+(define describe
+ (let ([sprintf sprintf]
+ [printf printf]
+ [fprintf fprintf]
+ [length length]
+ [list-ref list-ref]
+ [string-ref string-ref])
+ (lambda (x #!optional (out ##sys#standard-output))
+ (define (descseq name plen pref start)
+ (let ((len (fx- (plen x) start)))
+ (when name (fprintf out "~A of length ~S~%" name len))
+ (let loop1 ((i 0))
+ (cond ((fx>= i len))
+ ((fx>= i max-describe-lines)
+ (fprintf out "~% (~A elements not displayed)~%" (fx- len i)) )
+ (else
+ (let ((v (pref x (fx+ start i))))
+ (let loop2 ((n 1) (j (fx+ i (fx+ start 1))))
+ (cond ((fx>= j len)
+ (fprintf out " ~S: ~S" i v)
+ (if (fx> n 1)
+ (fprintf out "\t(followed by ~A identical instance~a)~% ...~%"
+ (fx- n 1)
+ (if (eq? n 2) "" "s"))
+ (newline out) )
+ (loop1 (fx+ i n)) )
+ ((eq? v (pref x j)) (loop2 (fx+ n 1) (fx+ j 1)))
+ (else (loop2 n len)) ) ) ) ) ) ) ) )
+ (when (##sys#permanent? x)
+ (fprintf out "statically allocated (0x~X) " (##sys#block-address x)) )
+ (cond [(char? x)
+ (let ([code (char->integer x)])
+ (fprintf out "character ~S, code: ~S, #x~X, #o~O~%" x code code code) ) ]
+ [(eq? x #t) (fprintf out "boolean true~%")]
+ [(eq? x #f) (fprintf out "boolean false~%")]
+ [(null? x) (fprintf out "empty list~%")]
+ [(eof-object? x) (fprintf out "end-of-file object~%")]
+ [(eq? (##sys#void) x) (fprintf out "unspecified object~%")]
+ [(fixnum? x)
+ (fprintf out "exact integer ~S, #x~X, #o~O, #b~B" x x x x)
+ (let ([code (integer->char x)])
+ (when (fx< x #x10000) (fprintf out ", character ~S" code)) )
+ (##sys#write-char-0 #\newline ##sys#standard-output) ]
+ [(eq? x (##sys#slot '##sys#arbitrary-unbound-symbol 0))
+ (fprintf out "unbound value~%") ]
+ [(##sys#number? x) (fprintf out "number ~S~%" x)]
+ [(string? x) (descseq "string" ##sys#size string-ref 0)]
+ [(vector? x) (descseq "vector" ##sys#size ##sys#slot 0)]
+ [(symbol? x)
+ (unless (##sys#symbol-has-toplevel-binding? x) (display "unbound " out))
+ (when (and (symbol? x) (fx= 0 (##sys#byte (##sys#slot x 1) 0)))
+ (display "keyword " out) )
+ (fprintf out "~asymbol with name ~S~%"
+ (if (##sys#interned-symbol? x) "" "uninterned ")
+ (##sys#symbol->string x))
+ (let ((plist (##sys#slot x 2)))
+ (unless (null? plist)
+ (display " \nproperties:\n\n" out)
+ (do ((plist plist (cddr plist)))
+ ((null? plist))
+ (fprintf out " ~s\t" (car plist))
+ (##sys#with-print-length-limit
+ 1000
+ (lambda ()
+ (write (cadr plist) out) ) )
+ (newline out) ) ) ) ]
+ [(list? x) (descseq "list" length list-ref 0)]
+ [(pair? x) (fprintf out "pair with car ~S and cdr ~S~%" (car x) (cdr x))]
+ [(procedure? x)
+ (let ([len (##sys#size x)])
+ (if (and (> len 3)
+ (memq #:tinyclos ##sys#features)
+ (eq? ##tinyclos#entity-tag (##sys#slot x (fx- len 1))) ) ;XXX handle this in tinyclos egg (difficult)
+ (describe-object x out)
+ (descseq
+ (sprintf "procedure with code pointer ~X" (##sys#peek-unsigned-integer x 0))
+ ##sys#size ##sys#slot 1) ) ) ]
+ [(port? x)
+ (fprintf out
+ "~A port of type ~A with name ~S and file pointer ~X~%"
+ (if (##sys#slot x 1) "input" "output")
+ (##sys#slot x 7)
+ (##sys#slot x 3)
+ (##sys#peek-unsigned-integer x 0) ) ]
+ [(and (memq #:tinyclos ##sys#features) (instance? x)) ; XXX put into tinyclos egg
+ (describe-object x out) ]
+ [(##sys#locative? x)
+ (fprintf out "locative~% pointer ~X~% index ~A~% type ~A~%"
+ (##sys#peek-unsigned-integer x 0)
+ (##sys#slot x 1)
+ (case (##sys#slot x 2)
+ [(0) "slot"]
+ [(1) "char"]
+ [(2) "u8vector"]
+ [(3) "s8vector"]
+ [(4) "u16vector"]
+ [(5) "s16vector"]
+ [(6) "u32vector"]
+ [(7) "s32vector"]
+ [(8) "f32vector"]
+ [(9) "f64vector"] ) ) ]
+ [(##sys#pointer? x) (fprintf out "machine pointer ~X~%" (##sys#peek-unsigned-integer x 0))]
+ [(##sys#bytevector? x)
+ (let ([len (##sys#size x)])
+ (fprintf out "blob of size ~S:~%" len)
+ (hexdump x len ##sys#byte out) ) ]
+ [(##core#inline "C_lambdainfop" x)
+ (fprintf out "lambda information: ~s~%" (##sys#lambda-info->string x)) ]
+ [(##sys#structure? x 'hash-table)
+ (let ((n (##sys#slot x 2)))
+ (fprintf out "hash-table with ~S element~a~% comparison procedure: ~A~%"
+ n (if (fx= n 1) "" "s") (##sys#slot x 3)) )
+ (fprintf out " hash function: ~a~%" (##sys#slot x 4))
+ (hash-table-walk ; blindly assumes it is bound
+ x
+ (lambda (k v) (fprintf out " ~S\t-> ~S~%" k v)) ) ]
+ [(##sys#structure? x 'condition)
+ (fprintf out "condition: ~s~%" (##sys#slot x 1))
+ (for-each
+ (lambda (k)
+ (fprintf out " ~s~%" k)
+ (let loop ((props (##sys#slot x 2)))
+ (unless (null? props)
+ (when (eq? k (caar props))
+ (fprintf out "\t~s: ~s~%" (cdar props) (cadr props)) )
+ (loop (cddr props)) ) ) )
+ (##sys#slot x 1) ) ]
+ [(and (##sys#structure? x 'meroon-instance) (provided? 'meroon)) ; XXX put this into meroon egg (really!)
+ (unveil x out) ]
+ [(##sys#generic-structure? x)
+ (let ([st (##sys#slot x 0)])
+ (cond ((##sys#hash-table-ref describer-table st) => (cut <> x out))
+ ((assq st bytevector-data) =>
+ (lambda (data)
+ (apply descseq (append (map eval (cdr data)) (list 0)))) )
+ (else
+ (fprintf out "structure of type `~S':~%" (##sys#slot x 0))
+ (descseq #f ##sys#size ##sys#slot 1) ) ) ) ]
+ [else (fprintf out "unknown object~%")] )
+ (##sys#void) ) ) )
+
+(define (set-describer! tag proc)
+ (##sys#check-symbol tag 'symbol 'set-describer!)
+ (##sys#hash-table-set! describer-table tag proc) )
+
+
+;;; Display hexdump:
+
+(define dump
+ (lambda (x . len-out)
+ (let-optionals len-out
+ ([len #f]
+ [out ##sys#standard-output] )
+ (define (bestlen n) (if len (min len n) n))
+ (cond [(##sys#immediate? x) (##sys#error 'dump "cannot dump immediate object" x)]
+ [(##sys#bytevector? x) (hexdump x (bestlen (##sys#size x)) ##sys#byte out)]
+ [(string? x) (hexdump x (bestlen (##sys#size x)) ##sys#byte out)]
+ [(and (not (##sys#immediate? x)) (##sys#pointer? x))
+ (hexdump x 32 ##sys#peek-byte out) ]
+ [(and (##sys#generic-structure? x) (assq (##sys#slot x 0) bytevector-data))
+ (let ([bv (##sys#slot x 1)])
+ (hexdump bv (bestlen (##sys#size bv)) ##sys#byte out) ) ]
+ [else (##sys#error 'dump "cannot dump object" x)] ) ) ) )
+
+(define hexdump
+ (let ([display display]
+ [string-append string-append]
+ [make-string make-string]
+ [write-char write-char] )
+ (lambda (bv len ref out)
+
+ (define (justify n m base lead)
+ (let* ([s (number->string n base)]
+ [len (##sys#size s)] )
+ (if (fx< len m)
+ (string-append (make-string (fx- m len) lead) s)
+ s) ) )
+
+ (do ([a 0 (fx+ a 16)])
+ ((fx>= a len))
+ (display (justify a 4 10 #\space) out)
+ (write-char #\: out)
+ (do ([j 0 (fx+ j 1)]
+ [a a (fx+ a 1)] )
+ ((or (fx>= j 16) (fx>= a len))
+ (and-let* ([(fx>= a len)]
+ [o (fxmod len 16)]
+ [(not (fx= o 0))] )
+ (do ([k (fx- 16 o) (fx- k 1)])
+ ((fx= k 0))
+ (display " " out) ) ) )
+ (write-char #\space out)
+ (display (justify (ref bv a) 2 16 #\0) out) )
+ (write-char #\space out)
+ (do ([j 0 (fx+ j 1)]
+ [a a (fx+ a 1)] )
+ ((or (fx>= j 16) (fx>= a len)))
+ (let ([c (ref bv a)])
+ (if (and (fx>= c 32) (fx< c 128))
+ (write-char (integer->char c) out)
+ (write-char #\. out) ) ) )
+ (##sys#write-char-0 #\newline out) ) ) ) )
+
+
+;;; Start interpreting:
+
+(define (deldups lis . maybe-=)
+ (let ((elt= (optional maybe-= equal?)))
+ (let recur ((lis lis))
+ (if (null? lis) lis
+ (let* ((x (car lis))
+ (tail (cdr lis))
+ (new-tail (recur (del x tail elt=))))
+ (if (eq? tail new-tail) lis (cons x new-tail)))))))
+
+(define (member* keys set)
+ (let loop ((set set))
+ (and (pair? set)
+ (let find ((ks keys))
+ (cond ((null? ks) (loop (cdr set)))
+ ((equal? (car ks) (car set)) set)
+ (else (find (cdr ks))) ) ) ) ) )
+
+(define-constant short-options
+ '(#\k #\s #\v #\h #\D #\e #\i #\R #\b #\n #\q #\w #\- #\I #\p #\P) )
+
+(define-constant long-options
+ '("-ss" "-sx" "-script" "-version" "-help" "--help" "-feature" "-eval"
+ "-case-insensitive" "-keyword-style" "-no-parentheses-synonyms" "-no-symbol-escape"
+ "-r5rs-syntax" "-setup-mode"
+ "-require-extension" "-batch" "-quiet" "-no-warnings" "-no-init"
+ "-include-path" "-release" "-print" "-pretty-print" "--") )
+
+(define (canonicalize-args args)
+ (let loop ((args args))
+ (if (null? args)
+ '()
+ (let ((x (car args)))
+ (cond ((member x '("-s" "-ss" "-script" "-sx" "--")) args)
+ ((and (fx> (##sys#size x) 2)
+ (char=? #\- (##core#inline "C_subchar" x 0))
+ (not (member x long-options)) )
+ (if (char=? #\: (##core#inline "C_subchar" x 1))
+ (loop (cdr args))
+ (let ((cs (string->list (substring x 1))))
+ (if (findall cs short-options)
+ (append (map (cut string #\- <>) cs) (loop (cdr args)))
+ (##sys#error "invalid option" x) ) ) ) )
+ (else (cons x (loop (cdr args)))))))))
+
+(define (findall chars clist)
+ (let loop ((chars chars))
+ (or (null? chars)
+ (and (memq (car chars) clist)
+ (loop (cdr chars))))))
+
+(define-constant simple-options
+ '("--" "-b" "-batch" "-q" "-quiet" "-n" "-no-init" "-w" "-no-warnings" "-i" "-case-insensitive"
+ "-no-parentheses-synonyms" "-no-symbol-escape" "-r5rs-syntax" "-setup-mode"
+ ; Not "simple" but processed early
+ "-ss" "-sx" "-s" "-script") )
+
+(define-constant complex-options
+ '("-D" "-feature" "-I" "-include-path" "-k" "-keyword-style") )
+
+(define (run)
+ (let* ([extraopts (parse-option-string (or (get-environment-variable "CSI_OPTIONS") ""))]
+ [args (canonicalize-args (command-line-arguments))]
+ ; Check for these before 'args' is updated by any 'extraopts'
+ [kwstyle (member* '("-k" "-keyword-style") args)]
+ [script (member* '("-ss" "-sx" "-s" "-script") args)])
+ (cond [script
+ (when (or (not (pair? (cdr script)))
+ (zero? (string-length (cadr script)))
+ (char=? #\- (string-ref (cadr script) 0)) )
+ (##sys#error "missing or invalid script argument"))
+ (program-name (cadr script))
+ (command-line-arguments (cddr script))
+ (register-feature! 'script)
+ (set-cdr! (cdr script) '())
+ (when ##sys#windows-platform
+ (and-let* ((sname (lookup-script-file (cadr script))))
+ (set-car! (cdr script) sname) ) ) ]
+ [else
+ (set! args (append (canonicalize-args extraopts) args))
+ (and-let* ([p (member "--" args)])
+ (set-cdr! p '()) ) ] )
+ (let* ([eval? (member* '("-e" "-p" "-P" "-eval" "-print" "-pretty-print") args)]
+ [batch (or script (member* '("-b" "-batch") args) eval?)]
+ [quietflag (member* '("-q" "-quiet") args)]
+ [quiet (or script quietflag eval?)]
+ [ipath (map chop-separator (string-split (or (get-environment-variable "CHICKEN_INCLUDE_PATH") "") ";"))] )
+ (define (collect-options opt)
+ (let loop ([opts args])
+ (cond [(member opt opts)
+ => (lambda (p)
+ (if (null? (cdr p))
+ (##sys#error "missing argument to command-line option" opt)
+ (cons (cadr p) (loop (cddr p)))) ) ]
+ [else '()] ) ) )
+ (define (loadinit)
+ (let ([fn (##sys#string-append "./" init-file)])
+ (if (file-exists? fn)
+ (load fn)
+ (let* ([prefix (chop-separator (or (get-environment-variable "HOME") "."))]
+ [fn (string-append prefix "/" init-file)] )
+ (when (file-exists? fn)
+ (load fn) ) ) ) ) )
+ (define (evalstring str #!optional (rec (lambda _ (void))))
+ (let ((in (open-input-string str)))
+ (do ([x (read in) (read in)])
+ ((eof-object? x))
+ (rec (receive (eval x))) ) ) )
+ (when quietflag (set! ##sys#eval-debug-level 0))
+ (when (member* '("-h" "-help" "--help") args)
+ (print-usage)
+ (exit 0) )
+ (when (member* '("-v" "-version") args)
+ (print-banner)
+ (exit 0) )
+ (when (member "-setup-mode" args)
+ (set! ##sys#setup-mode #t))
+ (when (member "-release" args)
+ (print (chicken-version))
+ (exit 0) )
+ (when (member* '("-w" "-no-warnings") args)
+ (unless quiet (display "Warnings are disabled\n"))
+ (set! ##sys#warnings-enabled #f) )
+ (unless quiet
+ (load-verbose #t)
+ (print-banner) )
+ (when (member* '("-i" "-case-insensitive") args)
+ (unless quiet (display "Identifiers and symbols are case insensitive\n"))
+ (register-feature! 'case-insensitive)
+ (case-sensitive #f) )
+ (for-each register-feature! (collect-options "-feature"))
+ (for-each register-feature! (collect-options "-D"))
+ (set! ##sys#include-pathnames
+ (deldups
+ (append (map chop-separator (collect-options "-include-path"))
+ (map chop-separator (collect-options "-I"))
+ ##sys#include-pathnames
+ ipath)
+ string=?) )
+ (when kwstyle
+ (cond [(not (pair? (cdr kwstyle)))
+ (##sys#error "missing argument to `-keyword-style' option") ]
+ [(string=? "prefix" (cadr kwstyle))
+ (keyword-style #:prefix) ]
+ [(string=? "none" (cadr kwstyle))
+ (keyword-style #:none) ]
+ [(string=? "suffix" (cadr kwstyle))
+ (keyword-style #:suffix) ] ) )
+ (when (member* '("-no-parentheses-synonyms") args)
+ (unless quiet (display "Disabled support for parentheses synonyms\n"))
+ (parentheses-synonyms #f) )
+ (when (member* '("-no-symbol-escape") args)
+ (unless quiet (display "Disabled support for escaped symbols\n"))
+ (symbol-escape #f) )
+ (when (member* '("-r5rs-syntax") args)
+ (unless quiet (display "Disabled the Chicken extensions to R5RS syntax\n"))
+ (case-sensitive #f)
+ (keyword-style #:none)
+ (parentheses-synonyms #f)
+ (symbol-escape #f) )
+ (unless (or (member* '("-n" "-no-init") args) script) (loadinit))
+ (do ([args args (cdr args)])
+ ((null? args)
+ (unless batch
+ (repl)
+ (##sys#write-char-0 #\newline ##sys#standard-output) ) )
+ (let* ((arg (car args)))
+ (cond ((member arg simple-options) )
+ ((member arg complex-options)
+ (set! args (cdr args)) )
+ ((or (string=? "-R" arg) (string=? "-require-extension" arg))
+ (eval `(##core#require-extension (,(string->symbol (cadr args))) #t))
+ (set! args (cdr args)) )
+ ((or (string=? "-e" arg) (string=? "-eval" arg))
+ (evalstring (cadr args))
+ (set! args (cdr args)) )
+ ((or (string=? "-p" arg) (string=? "-print" arg))
+ (evalstring (cadr args) (cut for-each print <...>))
+ (set! args (cdr args)) )
+ ((or (string=? "-P" arg) (string=? "-pretty-print" arg))
+ (evalstring (cadr args) (cut for-each pretty-print <...>) )
+ (set! args (cdr args)) )
+ (else
+ (let ((scr (and script (car script))))
+ (##sys#load
+ arg
+ (and (equal? "-sx" scr)
+ (lambda (x)
+ (pretty-print x ##sys#standard-error)
+ (newline ##sys#standard-error)
+ (eval x)))
+ #f)
+ (when (equal? "-ss" scr)
+ (call-with-values (cut main (command-line-arguments))
+ (lambda results
+ (exit
+ (if (and (pair? results) (fixnum? (car results)))
+ (car results)
+ 0) ) ) ) ) ) ) ) ) ) ) ) )
+
+(run)
diff --git a/csibatch.bat b/csibatch.bat
new file mode 100644
index 00000000..8f78a00d
--- /dev/null
+++ b/csibatch.bat
@@ -0,0 +1,2 @@
+@echo off
+csi -script %1 %2 %3 %4 %5 %6 %7 %8 %9
diff --git a/data-structures.import.scm b/data-structures.import.scm
new file mode 100644
index 00000000..bad90787
--- /dev/null
+++ b/data-structures.import.scm
@@ -0,0 +1,91 @@
+;;;; data-structures.import.scm - import library for "data-structures" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'data-structures
+ '(->string
+ alist-ref
+ alist-update!
+ always?
+ any?
+ atom?
+ binary-search
+ butlast
+ chop
+ complement
+ compose
+ compress
+ conc
+ conjoin
+ constantly
+ disjoin
+ each
+ flatten
+ flip
+ identity
+ intersperse
+ join
+ left-section
+ list->queue
+ list-of?
+ make-queue
+ merge
+ merge!
+ never?
+ none?
+ noop
+ o
+ project
+ queue->list
+ queue-add!
+ queue-empty?
+ queue-first
+ queue-last
+ queue-push-back!
+ queue-push-back-list!
+ queue-remove!
+ queue?
+ rassoc
+ reverse-string-append
+ right-section
+ shuffle
+ sort
+ sort!
+ sorted?
+ topological-sort
+ string-chomp
+ string-chop
+ string-compare3
+ string-compare3-ci
+ string-intersperse
+ string-split
+ string-translate
+ string-translate*
+ substring-ci=?
+ substring-index
+ substring-index-ci
+ substring=?
+ tail?))
diff --git a/data-structures.scm b/data-structures.scm
new file mode 100644
index 00000000..23db1a00
--- /dev/null
+++ b/data-structures.scm
@@ -0,0 +1,959 @@
+;;; data-structures.scm - Optional data structures extensions
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without
+; modification, are permitted provided that the following conditions
+; are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit data-structures)
+ (usual-integrations)
+ (disable-warning redef)
+ (foreign-declare #<<EOF
+#define C_mem_compare(to, from, n) C_fix(C_memcmp(C_c_string(to), C_c_string(from), C_unfix(n)))
+EOF
+) )
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ (no-bound-checks)
+ (no-procedure-checks-for-usual-bindings)
+ (bound-to-procedure
+ ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-string
+ ##sys#substring ##sys#for-each ##sys#map ##sys#setslot
+ ##sys#allocate-vector ##sys#check-pair ##sys#error-not-a-proper-list
+ ##sys#member ##sys#assoc ##sys#error ##sys#signal-hook ##sys#read-string!
+ ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling
+ ##sys#truncate ##sys#round ##sys#check-number ##sys#cons-flonum
+ ##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg
+ ##sys#print ##sys#check-structure ##sys#make-structure make-parameter
+ ##sys#flush-output ##sys#write-char-0 ##sys#number->string
+ ##sys#fragments->string ##sys#symbol->qualified-string
+ ##sys#number? ##sys#procedure->string
+ ##sys#pointer->string ##sys#user-print-hook ##sys#peek-char-0
+ ##sys#read-char-0 ##sys#write-char ##sys#string-append ##sys#gcd ##sys#lcm
+ ##sys#fudge ##sys#check-list ##sys#user-read-hook ##sys#check-closure ##sys#check-inexact
+ input-port? make-vector list->vector sort! merge! open-output-string floor
+ get-output-string current-output-port display write port? list->string
+ make-string string pretty-print-width newline char-name read random
+ open-input-string make-string call-with-input-file read-line reverse ) ) ] )
+
+(private data-structures
+ fprintf0 generic-write )
+
+(declare
+ (hide
+ fprintf0 generic-write ) )
+
+(include "unsafe-declarations.scm")
+
+(register-feature! 'data-structures)
+
+
+
+;;; Combinators:
+
+(define (identity x) x)
+
+(define (project n)
+ (lambda args (list-ref args n)) )
+
+(define (conjoin . preds)
+ (lambda (x)
+ (let loop ([preds preds])
+ (or (null? preds)
+ (and ((##sys#slot preds 0) x)
+ (loop (##sys#slot preds 1)) ) ) ) ) )
+
+(define (disjoin . preds)
+ (lambda (x)
+ (let loop ([preds preds])
+ (and (not (null? preds))
+ (or ((##sys#slot preds 0) x)
+ (loop (##sys#slot preds 1)) ) ) ) ) )
+
+(define (constantly . xs)
+ (if (eq? 1 (length xs))
+ (let ([x (car xs)])
+ (lambda _ x) )
+ (lambda _ (apply values xs)) ) )
+
+(define (flip proc) (lambda (x y) (proc y x)))
+
+(define complement
+ (lambda (p)
+ (lambda args (not (apply p args))) ) )
+
+(define (compose . fns)
+ (define (rec f0 . fns)
+ (if (null? fns)
+ f0
+ (lambda args
+ (call-with-values
+ (lambda () (apply (apply rec fns) args))
+ f0) ) ) )
+ (if (null? fns)
+ values
+ (apply rec fns) ) )
+
+(define (o . fns)
+ (if (null? fns)
+ identity
+ (let loop ((fns fns))
+ (let ((h (##sys#slot fns 0))
+ (t (##sys#slot fns 1)) )
+ (if (null? t)
+ h
+ (lambda (x) (h ((loop t) x))))))))
+
+(define (list-of? pred)
+ (lambda (lst)
+ (let loop ([lst lst])
+ (cond [(null? lst) #t]
+ [(not-pair? lst) #f]
+ [(pred (##sys#slot lst 0)) (loop (##sys#slot lst 1))]
+ [else #f] ) ) ) )
+
+(define list-of list-of?) ; DEPRECATED
+
+(define (noop . _) (void))
+
+(define (each . procs)
+ (cond ((null? procs) (lambda _ (void)))
+ ((null? (##sys#slot procs 1)) (##sys#slot procs 0))
+ (else
+ (lambda args
+ (let loop ((procs procs))
+ (let ((h (##sys#slot procs 0))
+ (t (##sys#slot procs 1)) )
+ (if (null? t)
+ (apply h args)
+ (begin
+ (apply h args)
+ (loop t) ) ) ) ) ) ) ) )
+
+(define (any? x) #t)
+
+(define (none? x) #f)
+
+(define (always? . _) #t)
+
+(define (never? . _) #f)
+
+(define (left-section proc . args)
+ (##sys#check-closure proc 'left-section)
+ (lambda xs
+ (##sys#apply proc (##sys#append args xs)) ) )
+
+(define right-section
+ (let ([##sys#reverse reverse])
+ (lambda (proc . args)
+ (##sys#check-closure proc 'right-section)
+ (let ([revdargs (##sys#reverse args)])
+ (lambda xs
+ (##sys#apply proc (##sys#reverse (##sys#append revdargs (##sys#reverse xs)))) ) ) ) ) )
+
+
+;;; List operators:
+
+(define (atom? x) (##core#inline "C_i_not_pair_p" x))
+
+(define (tail? x y)
+ (##sys#check-list y 'tail?)
+ (or (##core#inline "C_eqp" x '())
+ (let loop ((y y))
+ (cond ((##core#inline "C_eqp" y '()) #f)
+ ((##core#inline "C_eqp" x y) #t)
+ (else (loop (##sys#slot y 1))) ) ) ) )
+
+(define intersperse
+ (lambda (lst x)
+ (let loop ((ns lst))
+ (if (##core#inline "C_eqp" ns '())
+ ns
+ (let ((tail (cdr ns)))
+ (if (##core#inline "C_eqp" tail '())
+ ns
+ (cons (##sys#slot ns 0) (cons x (loop tail))) ) ) ) ) ) )
+
+(define (butlast lst)
+ (##sys#check-pair lst 'butlast)
+ (let loop ((lst lst))
+ (let ((next (##sys#slot lst 1)))
+ (if (and (##core#inline "C_blockp" next) (##core#inline "C_pairp" next))
+ (cons (##sys#slot lst 0) (loop next))
+ '() ) ) ) )
+
+(define (flatten . lists0)
+ (let loop ([lists lists0] [rest '()])
+ (cond [(null? lists) rest]
+ [else
+ (let ([head (##sys#slot lists 0)]
+ [tail (##sys#slot lists 1)] )
+ (if (list? head)
+ (loop head (loop tail rest))
+ (cons head (loop tail rest)) ) ) ] ) ) )
+
+(define chop
+ (let ([reverse reverse])
+ (lambda (lst n)
+ (##sys#check-exact n 'chop)
+ (cond-expand
+ [(not unsafe) (when (fx<= n 0) (##sys#error 'chop "invalid numeric argument" n))]
+ [else] )
+ (let ([len (length lst)])
+ (let loop ([lst lst] [i len])
+ (cond [(null? lst) '()]
+ [(fx< i n) (list lst)]
+ [else
+ (do ([hd '() (cons (##sys#slot tl 0) hd)]
+ [tl lst (##sys#slot tl 1)]
+ [c n (fx- c 1)] )
+ ((fx= c 0)
+ (cons (reverse hd) (loop tl (fx- i n))) ) ) ] ) ) ) ) ) )
+
+(define (join lsts . lst)
+ (let ([lst (if (pair? lst) (car lst) '())])
+ (##sys#check-list lst 'join)
+ (let loop ([lsts lsts])
+ (cond [(null? lsts) '()]
+ [(cond-expand [unsafe #f] [else (not (pair? lsts))])
+ (##sys#error-not-a-proper-list lsts) ]
+ [else
+ (let ([l (##sys#slot lsts 0)]
+ [r (##sys#slot lsts 1)] )
+ (if (null? r)
+ l
+ (##sys#append l lst (loop r)) ) ) ] ) ) ) )
+
+(define compress
+ (lambda (blst lst)
+ (let ([msg "bad argument type - not a proper list"])
+ (##sys#check-list lst 'compress)
+ (let loop ([blst blst] [lst lst])
+ (cond [(null? blst) '()]
+ [(cond-expand [unsafe #f] [else (not (pair? blst))])
+ (##sys#signal-hook #:type-error 'compress msg blst) ]
+ [(cond-expand [unsafe #f] [else (not (pair? lst))])
+ (##sys#signal-hook #:type-error 'compress msg lst) ]
+ [(##sys#slot blst 0) (cons (##sys#slot lst 0) (loop (##sys#slot blst 1) (##sys#slot lst 1)))]
+ [else (loop (##sys#slot blst 1) (##sys#slot lst 1))] ) ) ) ) )
+
+(define shuffle
+ ;; this should really shadow SORT! and RANDOM...
+ (lambda (l random)
+ (let ((len (length l)))
+ (map cdr
+ (sort! (map (lambda (x) (cons (random len) x)) l)
+ (lambda (x y) (< (car x) (car y)))) ) ) ) )
+
+
+;;; Alists:
+
+(define (alist-update! x y lst #!optional (cmp eqv?))
+ (let* ([aq (cond [(eq? eq? cmp) assq]
+ [(eq? eqv? cmp) assv]
+ [(eq? equal? cmp) assoc]
+ [else
+ (lambda (x lst)
+ (let loop ([lst lst])
+ (and (pair? lst)
+ (let ([a (##sys#slot lst 0)])
+ (if (and (pair? a) (cmp (##sys#slot a 0) x))
+ a
+ (loop (##sys#slot lst 1)) ) ) ) ) ) ] ) ]
+ [item (aq x lst)] )
+ (if item
+ (begin
+ (##sys#setslot item 1 y)
+ lst)
+ (cons (cons x y) lst) ) ) )
+
+(define (alist-ref x lst #!optional (cmp eqv?) (default #f))
+ (let* ([aq (cond [(eq? eq? cmp) assq]
+ [(eq? eqv? cmp) assv]
+ [(eq? equal? cmp) assoc]
+ [else
+ (lambda (x lst)
+ (let loop ([lst lst])
+ (and (pair? lst)
+ (let ([a (##sys#slot lst 0)])
+ (if (and (pair? a) (cmp (##sys#slot a 0) x))
+ a
+ (loop (##sys#slot lst 1)) ) ) ) ) ) ] ) ]
+ [item (aq x lst)] )
+ (if item
+ (##sys#slot item 1)
+ default) ) )
+
+(define (rassoc x lst . tst)
+ (cond-expand [(not unsafe) (##sys#check-list lst 'rassoc)][else])
+ (let ([tst (if (pair? tst) (car tst) eqv?)])
+ (let loop ([l lst])
+ (and (pair? l)
+ (let ([a (##sys#slot l 0)])
+ (cond-expand [(not unsafe) (##sys#check-pair a 'rassoc)][else])
+ (if (tst x (##sys#slot a 1))
+ a
+ (loop (##sys#slot l 1)) ) ) ) ) ) )
+
+
+
+; (reverse-string-append l) = (apply string-append (reverse l))
+
+(define (reverse-string-append l)
+
+ (define (rev-string-append l i)
+ (if (pair? l)
+ (let* ((str (car l))
+ (len (string-length str))
+ (result (rev-string-append (cdr l) (+ i len))))
+ (let loop ((j 0) (k (- (- (string-length result) i) len)))
+ (if (< j len)
+ (begin
+ (string-set! result k (string-ref str j))
+ (loop (+ j 1) (+ k 1)))
+ result)))
+ (make-string i)))
+
+ (rev-string-append l 0))
+
+;;; Anything->string conversion:
+
+(define ->string
+ (let ([open-output-string open-output-string]
+ [display display]
+ [string string]
+ [get-output-string get-output-string] )
+ (lambda (x)
+ (cond [(string? x) x]
+ [(symbol? x) (symbol->string x)]
+ [(char? x) (string x)]
+ [(number? x) (##sys#number->string x)]
+ [else
+ (let ([o (open-output-string)])
+ (display x o)
+ (get-output-string o) ) ] ) ) ) )
+
+(define conc
+ (let ([string-append string-append])
+ (lambda args
+ (apply string-append (map ->string args)) ) ) )
+
+
+;;; Search one string inside another:
+
+(let ()
+ (define (traverse which where start test loc)
+ (##sys#check-string which loc)
+ (##sys#check-string where loc)
+ (let ([wherelen (##sys#size where)]
+ [whichlen (##sys#size which)] )
+ (##sys#check-exact start loc)
+ (let loop ([istart start] [iend whichlen])
+ (cond [(fx> iend wherelen) #f]
+ [(test istart whichlen) istart]
+ [else
+ (loop (fx+ istart 1)
+ (fx+ iend 1) ) ] ) ) ) )
+ (set! ##sys#substring-index
+ (lambda (which where start)
+ (traverse
+ which where start
+ (lambda (i l) (##core#inline "C_substring_compare" which where 0 i l))
+ 'substring-index) ) )
+ (set! ##sys#substring-index-ci
+ (lambda (which where start)
+ (traverse
+ which where start
+ (lambda (i l) (##core#inline "C_substring_compare_case_insensitive" which where 0 i l))
+ 'substring-index-ci) ) ) )
+
+(define (substring-index which where #!optional (start 0))
+ (##sys#substring-index which where start) )
+
+(define (substring-index-ci which where #!optional (start 0))
+ (##sys#substring-index-ci which where start) )
+
+
+;;; 3-Way string comparison:
+
+(define (string-compare3 s1 s2)
+ (##sys#check-string s1 'string-compare3)
+ (##sys#check-string s2 'string-compare3)
+ (let ((len1 (##sys#size s1))
+ (len2 (##sys#size s2)) )
+ (let* ((len-diff (fx- len1 len2))
+ (cmp (##core#inline "C_mem_compare" s1 s2 (if (fx< len-diff 0) len1 len2))))
+ (if (fx= cmp 0)
+ len-diff
+ cmp))))
+
+(define (string-compare3-ci s1 s2)
+ (##sys#check-string s1 'string-compare3-ci)
+ (##sys#check-string s2 'string-compare3-ci)
+ (let ((len1 (##sys#size s1))
+ (len2 (##sys#size s2)) )
+ (let* ((len-diff (fx- len1 len2))
+ (cmp (##core#inline "C_string_compare_case_insensitive" s1 s2 (if (fx< len-diff 0) len1 len2))))
+ (if (fx= cmp 0)
+ len-diff
+ cmp))))
+
+
+;;; Substring comparison:
+
+(define (##sys#substring=? s1 s2 start1 start2 n)
+ (##sys#check-string s1 'substring=?)
+ (##sys#check-string s2 'substring=?)
+ (let ((len (or n
+ (fxmin (fx- (##sys#size s1) start1)
+ (fx- (##sys#size s2) start2) ) ) ) )
+ (##sys#check-exact start1 'substring=?)
+ (##sys#check-exact start2 'substring=?)
+ (##core#inline "C_substring_compare" s1 s2 start1 start2 len) ) )
+
+(define (substring=? s1 s2 #!optional (start1 0) (start2 0) len)
+ (##sys#substring=? s1 s2 start1 start2 len) )
+
+(define (##sys#substring-ci=? s1 s2 start1 start2 n)
+ (##sys#check-string s1 'substring-ci=?)
+ (##sys#check-string s2 'substring-ci=?)
+ (let ((len (or n
+ (fxmin (fx- (##sys#size s1) start1)
+ (fx- (##sys#size s2) start2) ) ) ) )
+ (##sys#check-exact start1 'substring-ci=?)
+ (##sys#check-exact start2 'substring-ci=?)
+ (##core#inline "C_substring_compare_case_insensitive"
+ s1 s2 start1 start2 len) ) )
+
+(define (substring-ci=? s1 s2 #!optional (start1 0) (start2 0) len)
+ (##sys#substring-ci=? s1 s2 start1 start2 len) )
+
+
+;;; Split string into substrings:
+
+(define string-split
+ (lambda (str . delstr-and-flag)
+ (##sys#check-string str 'string-split)
+ (let* ([del (if (null? delstr-and-flag) "\t\n " (car delstr-and-flag))]
+ [flag (if (fx= (length delstr-and-flag) 2) (cadr delstr-and-flag) #f)]
+ [strlen (##sys#size str)] )
+ (##sys#check-string del 'string-split)
+ (let ([dellen (##sys#size del)]
+ [first #f] )
+ (define (add from to last)
+ (let ([node (cons (##sys#substring str from to) '())])
+ (if first
+ (##sys#setslot last 1 node)
+ (set! first node) )
+ node) )
+ (let loop ([i 0] [last #f] [from 0])
+ (cond [(fx>= i strlen)
+ (when (or (fx> i from) flag) (add from i last))
+ (or first '()) ]
+ [else
+ (let ([c (##core#inline "C_subchar" str i)])
+ (let scan ([j 0])
+ (cond [(fx>= j dellen) (loop (fx+ i 1) last from)]
+ [(eq? c (##core#inline "C_subchar" del j))
+ (let ([i2 (fx+ i 1)])
+ (if (or (fx> i from) flag)
+ (loop i2 (add from i last) i2)
+ (loop i2 last i2) ) ) ]
+ [else (scan (fx+ j 1))] ) ) ) ] ) ) ) ) ) )
+
+
+;;; Concatenate list of strings:
+
+(define (string-intersperse strs #!optional (ds " "))
+ (##sys#check-list strs 'string-intersperse)
+ (##sys#check-string ds 'string-intersperse)
+ (let ((dslen (##sys#size ds)))
+ (let loop1 ((ss strs) (n 0))
+ (cond ((##core#inline "C_eqp" ss '())
+ (if (##core#inline "C_eqp" strs '())
+ ""
+ (let ((str2 (##sys#allocate-vector (fx- n dslen) #t #\space #f)))
+ (let loop2 ((ss2 strs) (n2 0))
+ (let* ((stri (##sys#slot ss2 0))
+ (next (##sys#slot ss2 1))
+ (strilen (##sys#size stri)) )
+ (##core#inline "C_substring_copy" stri str2 0 strilen n2)
+ (let ((n3 (fx+ n2 strilen)))
+ (if (##core#inline "C_eqp" next '())
+ str2
+ (begin
+ (##core#inline "C_substring_copy" ds str2 0 dslen n3)
+ (loop2 next (fx+ n3 dslen)) ) ) ) ) ) ) ) )
+ ((and (##core#inline "C_blockp" ss) (##core#inline "C_pairp" ss))
+ (let ((stri (##sys#slot ss 0)))
+ (##sys#check-string stri 'string-intersperse)
+ (loop1 (##sys#slot ss 1)
+ (fx+ (##sys#size stri) (fx+ dslen n)) ) ) )
+ (else (##sys#error-not-a-proper-list strs)) ) ) ) )
+
+
+;;; Translate elements of a string:
+
+(define string-translate
+ (let ([make-string make-string]
+ [list->string list->string] )
+ (lambda (str from . to)
+
+ (define (instring s)
+ (let ([len (##sys#size s)])
+ (lambda (c)
+ (let loop ([i 0])
+ (cond [(fx>= i len) #f]
+ [(eq? c (##core#inline "C_subchar" s i)) i]
+ [else (loop (fx+ i 1))] ) ) ) ) )
+
+ (let* ([from
+ (cond [(char? from) (lambda (c) (eq? c from))]
+ [(pair? from) (instring (list->string from))]
+ [else
+ (##sys#check-string from 'string-translate)
+ (instring from) ] ) ]
+ [to
+ (and (pair? to)
+ (let ([tx (##sys#slot to 0)])
+ (cond [(char? tx) tx]
+ [(pair? tx) (list->string tx)]
+ [else
+ (##sys#check-string tx 'string-translate)
+ tx] ) ) ) ]
+ [tlen (and (string? to) (##sys#size to))] )
+ (##sys#check-string str 'string-translate)
+ (let* ([slen (##sys#size str)]
+ [str2 (make-string slen)] )
+ (let loop ([i 0] [j 0])
+ (if (fx>= i slen)
+ (if (fx< j i)
+ (##sys#substring str2 0 j)
+ str2)
+ (let* ([ci (##core#inline "C_subchar" str i)]
+ [found (from ci)] )
+ (cond [(not found)
+ (##core#inline "C_setsubchar" str2 j ci)
+ (loop (fx+ i 1) (fx+ j 1)) ]
+ [(not to) (loop (fx+ i 1) j)]
+ [(char? to)
+ (##core#inline "C_setsubchar" str2 j to)
+ (loop (fx+ i 1) (fx+ j 1)) ]
+ [(cond-expand [unsafe #f] [else (fx>= found tlen)])
+ (##sys#error 'string-translate "invalid translation destination" i to) ]
+ [else
+ (##core#inline "C_setsubchar" str2 j (##core#inline "C_subchar" to found))
+ (loop (fx+ i 1) (fx+ j 1)) ] ) ) ) ) ) ) ) ) )
+
+(define (string-translate* str smap)
+ (##sys#check-string str 'string-translate*)
+ (##sys#check-list smap 'string-translate*)
+ (let ([len (##sys#size str)])
+ (define (collect i from total fs)
+ (if (fx>= i len)
+ (##sys#fragments->string
+ total
+ (reverse
+ (if (fx> i from)
+ (cons (##sys#substring str from i) fs)
+ fs) ) )
+ (let loop ([smap smap])
+ (if (null? smap)
+ (collect (fx+ i 1) from (fx+ total 1) fs)
+ (let* ([p (car smap)]
+ [sm (car p)]
+ [smlen (string-length sm)]
+ [st (cdr p)] )
+ (if (##core#inline "C_substring_compare" str sm i 0 smlen)
+ (let ([i2 (fx+ i smlen)])
+ (when (fx> i from)
+ (set! fs (cons (##sys#substring str from i) fs)) )
+ (collect
+ i2 i2
+ (fx+ total (string-length st))
+ (cons st fs) ) )
+ (loop (cdr smap)) ) ) ) ) ) )
+ (collect 0 0 0 '()) ) )
+
+
+;;; Chop string into substrings:
+
+(define (string-chop str len)
+ (##sys#check-string str 'string-chop)
+ (##sys#check-exact len 'string-chop)
+ (let ([total (##sys#size str)])
+ (let loop ([total total] [pos 0])
+ (cond [(fx<= total 0) '()]
+ [(fx<= total len) (list (##sys#substring str pos (fx+ pos total)))]
+ [else (cons (##sys#substring str pos (fx+ pos len)) (loop (fx- total len) (fx+ pos len)))] ) ) ) )
+
+
+;;; Remove suffix
+
+(define (string-chomp str #!optional (suffix "\n"))
+ (##sys#check-string str 'string-chomp)
+ (##sys#check-string suffix 'string-chomp)
+ (let* ((len (##sys#size str))
+ (slen (##sys#size suffix))
+ (diff (fx- len slen)) )
+ (if (and (fx>= len slen)
+ (##core#inline "C_substring_compare" str suffix diff 0 slen) )
+ (##sys#substring str 0 diff)
+ str) ) )
+
+
+
+;;; Defines: sorted?, merge, merge!, sort, sort!
+;;; Author : Richard A. O'Keefe (based on Prolog code by D.H.D.Warren)
+;;;
+;;; This code is in the public domain.
+
+;;; Updated: 11 June 1991
+;;; Modified for scheme library: Aubrey Jaffer 19 Sept. 1991
+;;; Updated: 19 June 1995
+
+;;; (sorted? sequence less?)
+;;; is true when sequence is a list (x0 x1 ... xm) or a vector #(x0 ... xm)
+;;; such that for all 1 <= i <= m,
+;;; (not (less? (list-ref list i) (list-ref list (- i 1)))).
+
+; Modified by flw for use with CHICKEN:
+;
+
+
+(define (sorted? seq less?)
+ (cond
+ ((null? seq)
+ #t)
+ ((vector? seq)
+ (let ((n (vector-length seq)))
+ (if (<= n 1)
+ #t
+ (do ((i 1 (+ i 1)))
+ ((or (= i n)
+ (less? (vector-ref seq i)
+ (vector-ref seq (- i 1))))
+ (= i n)) )) ))
+ (else
+ (let loop ((last (car seq)) (next (cdr seq)))
+ (or (null? next)
+ (and (not (less? (car next) last))
+ (loop (car next) (cdr next)) )) )) ))
+
+
+;;; (merge a b less?)
+;;; takes two lists a and b such that (sorted? a less?) and (sorted? b less?)
+;;; and returns a new list in which the elements of a and b have been stably
+;;; interleaved so that (sorted? (merge a b less?) less?).
+;;; Note: this does _not_ accept vectors. See below.
+
+(define (merge a b less?)
+ (cond
+ ((null? a) b)
+ ((null? b) a)
+ (else (let loop ((x (car a)) (a (cdr a)) (y (car b)) (b (cdr b)))
+ ;; The loop handles the merging of non-empty lists. It has
+ ;; been written this way to save testing and car/cdring.
+ (if (less? y x)
+ (if (null? b)
+ (cons y (cons x a))
+ (cons y (loop x a (car b) (cdr b)) ))
+ ;; x <= y
+ (if (null? a)
+ (cons x (cons y b))
+ (cons x (loop (car a) (cdr a) y b)) )) )) ))
+
+
+;;; (merge! a b less?)
+;;; takes two sorted lists a and b and smashes their cdr fields to form a
+;;; single sorted list including the elements of both.
+;;; Note: this does _not_ accept vectors.
+
+(define (merge! a b less?)
+ (define (loop r a b)
+ (if (less? (car b) (car a))
+ (begin
+ (set-cdr! r b)
+ (if (null? (cdr b))
+ (set-cdr! b a)
+ (loop b a (cdr b)) ))
+ ;; (car a) <= (car b)
+ (begin
+ (set-cdr! r a)
+ (if (null? (cdr a))
+ (set-cdr! a b)
+ (loop a (cdr a) b)) )) )
+ (cond
+ ((null? a) b)
+ ((null? b) a)
+ ((less? (car b) (car a))
+ (if (null? (cdr b))
+ (set-cdr! b a)
+ (loop b a (cdr b)))
+ b)
+ (else ; (car a) <= (car b)
+ (if (null? (cdr a))
+ (set-cdr! a b)
+ (loop a (cdr a) b))
+ a)))
+
+
+;;; (sort! sequence less?)
+;;; sorts the list or vector sequence destructively. It uses a version
+;;; of merge-sort invented, to the best of my knowledge, by David H. D.
+;;; Warren, and first used in the DEC-10 Prolog system. R. A. O'Keefe
+;;; adapted it to work destructively in Scheme.
+
+(define (sort! seq less?)
+ (define (step n)
+ (cond
+ ((> 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
+ '()) ))
+ (if (vector? seq)
+ (let ((n (vector-length seq))
+ (vec seq))
+ (set! seq (vector->list seq))
+ (do ((p (step n) (cdr p))
+ (i 0 (+ i 1)))
+ ((null? p) vec)
+ (vector-set! vec i (car p)) ))
+ ;; otherwise, assume it is a list
+ (step (length seq)) ))
+
+;;; (sort sequence less?)
+;;; sorts a vector or list non-destructively. It does this by sorting a
+;;; copy of the sequence. My understanding is that the Standard says
+;;; that the result of append is always "newly allocated" except for
+;;; sharing structure with "the last argument", so (append x '()) ought
+;;; to be a standard way of copying a list x.
+
+(define (sort seq less?)
+ (if (vector? seq)
+ (list->vector (sort! (vector->list seq) less?))
+ (sort! (append seq '()) less?)))
+
+
+;;; Simple topological sort:
+;
+; Taken from SLIB (slightly adapted): Copyright (C) 1995 Mikael Djurfeldt
+
+(define (topological-sort dag pred)
+ (if (null? dag)
+ '()
+ (let* ((adj-table '())
+ (sorted '()))
+
+ (define (insert x y)
+ (let loop ([at adj-table])
+ (cond [(null? at) (set! adj-table (cons (cons x y) adj-table))]
+ [(pred x (caar at)) (set-cdr! (car at) y)]
+ [else (loop (cdr at))] ) ) )
+
+ (define (lookup x)
+ (let loop ([at adj-table])
+ (cond [(null? at) #f]
+ [(pred x (caar at)) (cdar at)]
+ [else (loop (cdr at))] ) ) )
+
+ (define (visit u adj-list)
+ ;; Color vertex u
+ (insert u 'colored)
+ ;; Visit uncolored vertices which u connects to
+ (for-each (lambda (v)
+ (let ((val (lookup v)))
+ (if (not (eq? val 'colored))
+ (visit v (or val '())))))
+ adj-list)
+ ;; Since all vertices downstream u are visited
+ ;; by now, we can safely put u on the output list
+ (set! sorted (cons u sorted)) )
+
+ ;; Hash adjacency lists
+ (for-each (lambda (def) (insert (car def) (cdr def)))
+ (cdr dag))
+ ;; Visit vertices
+ (visit (caar dag) (cdar dag))
+ (for-each (lambda (def)
+ (let ((val (lookup (car def))))
+ (if (not (eq? val 'colored))
+ (visit (car def) (cdr def)))))
+ (cdr dag))
+ sorted) ) )
+
+
+;;; Binary search:
+
+(define binary-search
+ (let ([list->vector list->vector])
+ (lambda (vec proc)
+ (if (pair? vec)
+ (set! vec (list->vector vec))
+ (##sys#check-vector vec 'binary-search) )
+ (let ([len (##sys#size vec)])
+ (and (fx> len 0)
+ (let loop ([ps 0]
+ [pe len] )
+ (let ([p (fx+ ps (##core#inline "C_fixnum_divide" (fx- pe ps) 2))])
+ (let* ([x (##sys#slot vec p)]
+ [r (proc x)] )
+ (cond [(fx= r 0) p]
+ [(fx< r 0) (and (not (fx= pe p)) (loop ps p))]
+ [else (and (not (fx= ps p)) (loop p pe))] ) ) ) ) ) ) ) ) )
+
+
+
+; Support for queues
+;
+; Written by Andrew Wilcox (awilcox@astro.psu.edu) on April 1, 1992.
+;
+; This code is in the public domain.
+;
+; (heavily adapated for use with CHICKEN by felix)
+;
+
+
+; Elements in a queue are stored in a list. The last pair in the list
+; is stored in the queue type so that datums can be added in constant
+; time.
+
+(define (make-queue) (##sys#make-structure 'queue '() '()))
+(define (queue? x) (##sys#structure? x 'queue))
+
+(define (queue-empty? q)
+ (##sys#check-structure q 'queue 'queue-empty?)
+ (eq? '() (##sys#slot q 1)) )
+
+(define queue-first
+ (lambda (q)
+ (##sys#check-structure q 'queue 'queue-first)
+ (let ((first-pair (##sys#slot q 1)))
+ (cond-expand
+ [(not unsafe)
+ (when (eq? '() first-pair)
+ (##sys#error 'queue-first "queue is empty" q)) ]
+ [else] )
+ (##sys#slot first-pair 0) ) ) )
+
+(define queue-last
+ (lambda (q)
+ (##sys#check-structure q 'queue 'queue-last)
+ (let ((last-pair (##sys#slot q 2)))
+ (cond-expand
+ [(not unsafe)
+ (when (eq? '() last-pair)
+ (##sys#error 'queue-last "queue is empty" q)) ]
+ [else] )
+ (##sys#slot last-pair 0) ) ) )
+
+(define (queue-add! q datum)
+ (##sys#check-structure q 'queue 'queue-add!)
+ (let ((new-pair (cons datum '())))
+ (cond ((eq? '() (##sys#slot q 1)) (##sys#setslot q 1 new-pair))
+ (else (##sys#setslot (##sys#slot q 2) 1 new-pair)) )
+ (##sys#setslot q 2 new-pair)
+ (##core#undefined) ) )
+
+(define queue-remove!
+ (lambda (q)
+ (##sys#check-structure q 'queue 'queue-remove!)
+ (let ((first-pair (##sys#slot q 1)))
+ (cond-expand
+ [(not unsafe)
+ (when (eq? '() first-pair)
+ (##sys#error 'queue-remove! "queue is empty" q) ) ]
+ [else] )
+ (let ((first-cdr (##sys#slot first-pair 1)))
+ (##sys#setslot q 1 first-cdr)
+ (if (eq? '() first-cdr)
+ (##sys#setslot q 2 '()) )
+ (##sys#slot first-pair 0) ) ) ) )
+
+(define (queue->list q)
+ (##sys#check-structure q 'queue 'queue->list)
+ (##sys#slot q 1) )
+
+(define (list->queue lst0)
+ (##sys#check-list lst0 'list->queue)
+ (##sys#make-structure
+ 'queue lst0
+ (if (eq? lst0 '())
+ '()
+ (do ((lst lst0 (##sys#slot lst 1)))
+ ((eq? (##sys#slot lst 1) '()) lst)
+ (if (or (not (##core#inline "C_blockp" lst))
+ (not (##core#inline "C_pairp" lst)) )
+ (##sys#error-not-a-proper-list lst0 'list->queue) ) ) ) ) )
+
+
+; (queue-push-back! queue item)
+; Pushes an item into the first position of a queue.
+
+(define (queue-push-back! q item)
+ (##sys#check-structure q 'queue 'queue-push-back!)
+ (let ((newlist (cons item (##sys#slot q 1))))
+ (##sys#setslot q 1 newlist)
+ (if (eq? '() (##sys#slot q 2))
+ (##sys#setslot q 2 newlist))))
+
+; (queue-push-back-list! queue item-list)
+; Pushes the items in item-list back onto the queue,
+; so that (car item-list) becomes the next removable item.
+
+(define-inline (last-pair lst0)
+ (do ((lst lst0 (##sys#slot lst 1)))
+ ((eq? (##sys#slot lst 1) '()) lst)))
+
+(define (queue-push-back-list! q itemlist)
+ (##sys#check-structure q 'queue 'queue-push-back-list!)
+ (##sys#check-list itemlist 'queue-push-back-list!)
+ (let* ((newlist (append itemlist (##sys#slot q 1)))
+ (newtail (if (eq? newlist '())
+ '()
+ (last-pair newlist))))
+ (##sys#setslot q 1 newlist)
+ (##sys#setslot q 2 newtail)))
diff --git a/debian/README.Debian b/debian/README.Debian
new file mode 100644
index 00000000..0a50b94b
--- /dev/null
+++ b/debian/README.Debian
@@ -0,0 +1,12 @@
+Since version 2.2-1 I decided to drop the old packaging scheme with chicken
+and chicken-dev packages and now we have a libchicken0 package, with runtime
+libs, a libchicken-dev package, with header and static libs and, finally, a
+chicken-bin package that contains the tools.
+chicken-bin needs to depend on both libchicken0 (the compiler is linked against
+it) and on libchicken-dev to be able to compile scm files into C ones: I know
+that this is not a real common approach, but the alternative (merge -bin and
+-dev package) would be probably uglier because we will need to depend on both
+libpcre3 and libpcre3-dev!
+If you want to discuss a better approach feel free to contact me.
+
+Davide Puricelli <evo@debian.org>
diff --git a/debian/changelog b/debian/changelog
new file mode 100644
index 00000000..28b97b52
--- /dev/null
+++ b/debian/changelog
@@ -0,0 +1,199 @@
+chicken (3.2.0-0.2) unstable; urgency=low
+
+ * Added directory information to texi documentation file.
+
+ -- Ivan Raikov <raikov@oist.jp> Thu, 01 May 2008 10:06:00 +0900
+
+chicken (3.2.0-0.1) unstable; urgency=low
+
+ * New upstream version.
+
+ -- Ivan Raikov <raikov@oist.jp> Wed, 30 Apr 2008 13:43:22 +0900
+
+chicken (3.1.0-0.3) unstable; urgency=low
+
+ * Chicken shared library moved to libchicken0 package.
+
+ -- Ivan Raikov <raikov@oist.jp> Sun, 20 Apr 2008 16:02:55 +0900
+
+chicken (3.1.0-0.2) unstable; urgency=low
+
+ * rules changed to link against host PCRE library.
+
+ -- Ivan Raikov <raikov@oist.jp> Sun, 20 Apr 2008 14:18:24 +0900
+
+chicken (3.1.0-0.1) unstable; urgency=low
+
+ * New upstream version.
+
+ -- Ivan Raikov <raikov@oist.jp> Mon, 24 Mar 2008 14:29:38 +0900
+
+chicken (3.0.0-0.1) unstable; urgency=low
+
+ * New upstream version.
+
+ -- Ivan Raikov <raikov@oist.jp> Fri, 01 Feb 2008 14:26:42 +0900
+
+chicken (2.732-0.1) unstable; urgency=low
+
+ * New upstream version.
+
+ -- Ivan Raikov <raikov@oist.jp> Sat, 01 Dec 2007 14:30:55 +0900
+
+chicken (2.703-0.1) unstable; urgency=low
+
+ * Minor updates from upstream.
+ * Changed Debian package version to avoid conflicts with official Debian package.
+
+ -- Ivan Raikov <raikov@oist.jp> Tue, 04 Sep 2007 21:22:01 +0900
+
+chicken (2.7-1) unstable; urgency=low
+
+ * New upstream version.
+
+ -- Ivan Raikov <raikov@oist.jp> Mon, 03 Sep 2007 12:02:18 +0900
+
+chicken (2.5-1) unstable; urgency=low
+
+ * New upstream version; closes: #388632.
+ * Installing eggs into /var/lib/chicken, not /usr/lib/chicken.
+ closes: #388644.
+
+ -- Davide Puricelli (evo) <evo@debian.org> Sun, 7 Jan 2007 17:13:09 +0100
+
+chicken (2.3-1) unstable; urgency=medium
+
+ * New upstream version.
+ * Fixed nursery size test to let chicken build on ia64 and alpha, too;
+ closes: #356996.
+
+ -- Davide Puricelli (evo) <evo@debian.org> Sun, 23 Apr 2006 12:28:15 +0200
+
+chicken (2.2-1) unstable; urgency=high
+
+ * New upstream version; closes: #282956.
+ * Repackaged from scratch:
+ - removed chicken and chicken-dev packages.
+ - three new packages, see README.Debian for details.
+ closes: #270827, #339028.
+ * Added /usr/lib/chicken directory to support external eggs;
+ closes: #337392, #277866.
+ * Added support for ppc64 architecture, closes: #322444.
+ * libchicken-dev now depends on libpcre3-dev, closes: #276981.
+ * Fixed a wrong path into chicken manpage, closes: #328193.
+
+ -- Davide Puricelli (evo) <evo@debian.org> Tue, 14 Feb 2006 21:56:39 +0100
+
+chicken (1.63-2) unstable; urgency=high
+
+ * Fixed issues with doc-base; closes: #267152, #267148, #267218.
+
+ -- Davide Puricelli (evo) <evo@debian.org> Sat, 21 Aug 2004 11:12:18 +0200
+
+chicken (1.63-1) unstable; urgency=high
+
+ * New upstream version; closes: #247517, #227115.
+ * Acknowledge NMU, thanks Tollef; closes: #260392, #249340.
+ * Enhanced description; closes: #209441, #251210.
+ * Executed libtoolize before build process; closes: #263089.
+ * Removed useless manpages; closes: #259452.
+ * Added chicken-setup script; closes: #248558.
+
+ -- Davide Puricelli (evo) <evo@debian.org> Fri, 20 Aug 2004 18:46:00 +0200
+
+chicken (1.22-1.1) unstable; urgency=low
+
+ * NMU
+ * Add amd64 support (closes: #249340)
+
+ -- Tollef Fog Heen <tfheen@debian.org> Tue, 20 Jul 2004 11:28:05 +0200
+
+chicken (1.22-1) unstable; urgency=low
+
+ * New upstream version.
+
+ -- Davide Puricelli (evo) <evo@debian.org> Mon, 19 Jan 2004 18:41:54 +0100
+
+chicken (1.17-2) unstable; urgency=medium
+
+ * Applied patch suggested by Matthias Klose to fix build failures
+ on m68k, mips and mipsel, closes: #208932.
+
+ -- Davide Puricelli (evo) <evo@debian.org> Sat, 6 Sep 2003 14:19:00 +0200
+
+chicken (1.17-1) unstable; urgency=low
+
+ * New upstream version, closes: #199560.
+
+ -- Davide Puricelli (evo) <evo@debian.org> Sat, 6 Sep 2003 11:51:39 +0200
+
+chicken (1.10-2) unstable; urgency=high
+
+ * Running libtoolize before build process should fix all those
+ horrible build failures on archs != i386.
+
+ -- Davide Puricelli (evo) <evo@debian.org> Sun, 8 Jun 2003 12:17:29 +0200
+
+chicken (1.10-1) unstable; urgency=low
+
+ * New upstream version.
+ * debian/control: fixed a spelling error, closes: #195119.
+ * chicken.doc-base: it's "manual.html", not "index.html", thanks Laurent.
+ closes: #189742.
+
+ -- Davide Puricelli (evo) <evo@debian.org> Sat, 7 Jun 2003 12:08:59 +0200
+
+chicken (1.0-1) unstable; urgency=low
+
+ * New upstream version.
+ * Documentation is now installed with install-docs; closes: #181542.
+
+ -- Davide Puricelli (evo) <evo@debian.org> Sat, 12 Apr 2003 15:42:22 +0200
+
+chicken (0.1082-1) unstable; urgency=low
+
+ * New upstream version.
+ * Removing hacks for hppa and arm, now gcc 3.2 is the default compiler
+ on all the archs, so we shouldn't need them anymore.
+
+ -- Davide Puricelli (evo) <evo@debian.org> Fri, 14 Feb 2003 14:47:38 +0100
+
+chicken (0.1072-2) unstable; urgency=low
+
+ * Removing useless hack for mips and mipsel; we need gcc-3.2, so we
+ just have to wait.
+ * Moving /usr/include/* to chicken package; closes: #157841.
+
+ -- Davide Puricelli (evo) <evo@debian.org> Thu, 12 Sep 2002 13:11:22 +0200
+
+chicken (0.1072-1) unstable; urgency=low
+
+ * New upstream version.
+ * Added highlevel-macros.scm, moremacros.scm and chicken.init;
+ closes: #156700.
+ * hppa, mips and mipsel need -ffunction-sections to build;
+ closes: #150901.
+
+ -- Davide Puricelli (evo) <evo@debian.org> Sat, 17 Aug 2002 12:16:36 +0200
+
+chicken (0.1071-1) unstable; urgency=low
+
+ * New upstream version.
+ * Now it should compile fine on Alpha; closes: #144373.
+
+ -- Davide Puricelli (evo) <evo@debian.org> Mon, 29 Jul 2002 23:07:36 +0200
+
+chicken (0.990-2) unstable; urgency=low
+
+ * New maintainer.
+ * Config.guess and config.sub are updated before building the package.
+ closes: #143490.
+
+ -- Davide Puricelli (evo) <evo@debian.org> Wed, 19 Jun 2002 20:10:09 +0200
+
+chicken (0.990-1) unstable; urgency=low
+
+ * Initial release.
+
+ -- zhaoway <zw@debian.org> Mon, 21 Jan 2002 20:40:17 +0800
+
diff --git a/debian/chicken-bin.dirs b/debian/chicken-bin.dirs
new file mode 100644
index 00000000..250a7b62
--- /dev/null
+++ b/debian/chicken-bin.dirs
@@ -0,0 +1 @@
+var/lib/chicken
diff --git a/debian/chicken-bin.docs b/debian/chicken-bin.docs
new file mode 100644
index 00000000..f6b59ad9
--- /dev/null
+++ b/debian/chicken-bin.docs
@@ -0,0 +1,3 @@
+README
+NEWS
+
diff --git a/debian/chicken-bin.files b/debian/chicken-bin.files
new file mode 100644
index 00000000..e69de29b
diff --git a/debian/chicken-bin.install b/debian/chicken-bin.install
new file mode 100644
index 00000000..06828da8
--- /dev/null
+++ b/debian/chicken-bin.install
@@ -0,0 +1,3 @@
+usr/bin
+usr/share/chicken/*.scm
+usr/share/chicken/*.exports
diff --git a/debian/chicken-bin.manpages b/debian/chicken-bin.manpages
new file mode 100644
index 00000000..157bea01
--- /dev/null
+++ b/debian/chicken-bin.manpages
@@ -0,0 +1,6 @@
+csc.1
+csi.1
+chicken.1
+chicken-setup.1
+chicken-profile.1
+chicken-bug.1
diff --git a/debian/compat b/debian/compat
new file mode 100644
index 00000000..b8626c4c
--- /dev/null
+++ b/debian/compat
@@ -0,0 +1 @@
+4
diff --git a/debian/control b/debian/control
new file mode 100644
index 00000000..54588430
--- /dev/null
+++ b/debian/control
@@ -0,0 +1,53 @@
+Source: chicken
+Homepage: http://www.call-with-current-continuation.org/
+Section: interpreters
+Priority: optional
+Maintainer: Davide Puricelli (evo) <evo@debian.org>
+Build-Depends: debhelper (>> 4.0.0), libpcre3-dev, texinfo
+Standards-Version: 3.7.3
+
+Package: chicken-bin
+Section: interpreters
+Architecture: any
+Conflicts: chicken, chicken-dev
+Depends: ${shlibs:Depends}, libchicken-dev (= ${binary:Version})
+Replaces: chicken, chicken-dev
+Description: A practical and portable Scheme system - compiler
+ CHICKEN is a Scheme compiler which compiles a subset of R5RS into C.
+ It uses the ideas presented in Baker's paper "Cheney on the MTA", and
+ has a small core and is easily extendable.
+ .
+ This package contains the compiler.
+
+
+Package: libchicken3
+Architecture: any
+Section: libs
+Priority: optional
+Replaces: chicken, chicken-dev
+Depends: ${shlibs:Depends}
+Conflicts: chicken, chicken-dev
+Description: A practical and portable Scheme system - runtime
+ CHICKEN is a Scheme compiler which compiles a subset of R5RS into C.
+ It uses the ideas presented in Baker's paper "Cheney on the MTA", and
+ has a small core and is easily extendable.
+ .
+ This package contains the shared library needed to run programs using
+ chicken.
+
+
+Package: libchicken-dev
+Architecture: any
+Section: libdevel
+Priority: optional
+Conflicts: chicken, chicken-dev
+Depends: libchicken3 (= ${binary:Version}), libpcre3-dev
+Replaces: chicken, chicken-dev
+Description: A practical and portable Scheme system - development
+ CHICKEN is a Scheme compiler which compiles a subset of R5RS into C.
+ It uses the ideas presented in Baker's paper "Cheney on the MTA", and
+ has a small core and is easily extendable.
+ .
+ This package contains the header file and static library for developing
+ with chicken.
+
diff --git a/debian/copyright b/debian/copyright
new file mode 100644
index 00000000..3d2ca529
--- /dev/null
+++ b/debian/copyright
@@ -0,0 +1,38 @@
+This package was debianized by zhaoway <zw@debian.org> on Mon, 21 Jan
+2002 20:40:17 +0800
+Davide Puricelli (evo) <evo@debian.org> is the actual maintainer.
+
+It was downloaded from http://www.call-with-current-continuation.org
+
+Upstream Author: Felix L. Winkelmann
+<felix@call-with-current-continuation.org>.
+
+Copyright (c) 2000-2007, Felix L. Winkelmann
+Copyright (c) 2008-2009, The Chicken Team
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+Redistributions of source code must retain the above copyright notice,
+this list of conditions and the following disclaimer. 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. Neither the name of
+the author nor the names of its contributors may be used to endorse or
+promote products derived from this software without specific prior
+written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
+OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
+TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
+USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
+DAMAGE.
diff --git a/debian/libchicken-dev.dirs b/debian/libchicken-dev.dirs
new file mode 100644
index 00000000..44188162
--- /dev/null
+++ b/debian/libchicken-dev.dirs
@@ -0,0 +1,2 @@
+usr/lib
+usr/include
diff --git a/debian/libchicken-dev.install b/debian/libchicken-dev.install
new file mode 100644
index 00000000..d1bffed0
--- /dev/null
+++ b/debian/libchicken-dev.install
@@ -0,0 +1,3 @@
+usr/include/*
+usr/lib/lib*.a
+usr/lib/lib*.so
diff --git a/debian/libchicken3.dirs b/debian/libchicken3.dirs
new file mode 100644
index 00000000..6a5c4634
--- /dev/null
+++ b/debian/libchicken3.dirs
@@ -0,0 +1,2 @@
+usr/share/chicken
+usr/lib
diff --git a/debian/libchicken3.install b/debian/libchicken3.install
new file mode 100644
index 00000000..8f3aac48
--- /dev/null
+++ b/debian/libchicken3.install
@@ -0,0 +1 @@
+usr/lib/lib*.so.3
diff --git a/debian/rules b/debian/rules
new file mode 100644
index 00000000..ca04c72e
--- /dev/null
+++ b/debian/rules
@@ -0,0 +1,94 @@
+#!/usr/bin/make -f
+BUILD_ARCH = $(shell dpkg --print-installation-architecture)
+
+CFLAGS= -g
+ifneq (,$(findstring noopt,$(DEB_BUILD_OPTIONS)))
+ CFLAGS += -O0
+ else
+ CFLAGS += -O2 -fno-strict-aliasing
+endif
+
+MAKE:=$(MAKE) PLATFORM=linux
+PREFIX=/usr
+BINARYVERSION=3
+
+build: build-stamp
+build-stamp:
+ dh_testdir
+ $(MAKE) \
+ USE_HOST_PCRE=1 \
+ CFLAGS="$(CFLAGS)" \
+ PREFIX="$(PREFIX)" \
+ MANDIR="$(PREFIX)/share/man" \
+ INFODIR="$(PREFIX)/share/info" \
+ SHAREDIR="$(PREFIX)/share" \
+ EGGDIR="/var/lib/chicken/$(BINARYVERSION)" \
+ MAKEINFO_PROGRAM_OPTIONS="" \
+ HOSTNAME=debian
+ touch build-stamp
+
+clean:
+ dh_testdir
+ dh_testroot
+ rm -f build-stamp
+ $(MAKE) clean
+ $(MAKE) distclean
+ rm -f c_defaults.h
+ rm -f chicken_defaults.h
+ dh_clean
+
+install: build
+ dh_testdir
+ dh_testroot
+ dh_clean -k
+ dh_installdirs
+# The directories here have to be prefixed by $(CURDIR)/debian/tmp
+# because that is the location where the binary package files are
+# placed by dpkg-buildpackage. If absolute files are specified,
+# i.e. /var/lib/chicken, then those files will be installed on the
+# build system, but will not end up in the package.
+ $(MAKE) \
+ install \
+ USE_HOST_PCRE=1 \
+ PREFIX="$(CURDIR)/debian/tmp/usr" \
+ MANDIR="$(CURDIR)/debian/tmp/usr/share/man" \
+ INFODIR="$(CURDIR)/debian/tmp/usr/share/info" \
+ SHAREDIR="$(CURDIR)/debian/tmp/usr/share" \
+ EGGDIR="$(CURDIR)/debian/tmp/var/lib/chicken/$(BINARYVERSION)" \
+ MAKEINFO_PROGRAM_OPTIONS="" \
+ HOSTNAME=debian
+
+binary-common:
+ dh_testdir
+ dh_testroot
+ dh_installdocs
+ dh_installman
+# The asterisk in chicken.info* is necessary, because Debian makeinfo
+# is very different from the standard makeinfo, and it is incredibly
+# difficult to convince it to produce standalone Texinfo files.
+ dh_installinfo chicken.info*
+ dh_installchangelogs ChangeLog.*
+ dh_install --sourcedir=debian/tmp
+ dh_link
+ifeq "$(findstring nostrip,$(DEB_BUILD_OPTIONS))" ""
+ dh_strip
+endif
+ dh_compress
+ dh_fixperms
+ dh_makeshlibs -V
+ dh_installdeb
+ dh_shlibdeps -l debian/libchicken3/usr/lib
+ dh_gencontrol
+ dh_md5sums
+ dh_builddeb
+
+binary-indep: build install
+
+binary-arch: build install
+ $(MAKE) -f debian/rules DH_OPTIONS=-a binary-common
+
+binary-%: build install
+ make -f debian/rules binary-common DH_OPTIONS=-p$*
+
+binary: binary-indep binary-arch
+.PHONY: build clean binary-indep binary-arch binary install
diff --git a/defaults.make b/defaults.make
new file mode 100644
index 00000000..36a4b0aa
--- /dev/null
+++ b/defaults.make
@@ -0,0 +1,470 @@
+# defaults.make - default settings -*- Makefile -*-
+#
+# Copyright (c) 2007, Felix L. Winkelmann
+# Copyright (c) 2008-2009, The Chicken Team
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+# conditions are met:
+#
+# Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+# disclaimer.
+# 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.
+# Neither the name of the author nor the names of its contributors may be used to endorse or promote
+# products derived from this software without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+# OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+# AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+
+
+# basic parameters
+
+BINARYVERSION = 4
+STACKDIRECTION ?= 1
+CROSS_CHICKEN ?= 0
+
+ifeq ($(ARCH),x86-64)
+NURSERY ?= (256*1024)
+else
+NURSERY ?= (128*1024)
+endif
+
+# directories
+
+SEP ?= /
+SRCDIR ?= .$(SEP)
+DESTDIR ?=
+PREFIX ?= /usr/local
+
+BINDIR = $(PREFIX)/bin
+LIBDIR = $(PREFIX)/lib
+SHAREDIR = $(PREFIX)/share
+DATADIR = $(SHAREDIR)/chicken
+TOPMANDIR = $(SHAREDIR)/man
+MANDIR = $(TOPMANDIR)/man1
+INCDIR = $(PREFIX)/include
+DOCDIR = $(DATADIR)/doc
+VARDIR ?= $(LIBDIR)
+CHICKENLIBDIR = $(VARDIR)/chicken
+EGGDIR = $(CHICKENLIBDIR)/$(BINARYVERSION)
+
+ifdef WINDOWS_SHELL
+SPREFIX = $(subst /,$(SEP),$(PREFIX))
+IBINDIR = $(SPREFIX)$(SEP)bin
+ILIBDIR = $(SPREFIX)$(SEP)lib
+ISHAREDIR = $(SPREFIX)$(SEP)share
+IDATADIR = $(ISHAREDIR)$(SEP)chicken
+ITOPMANDIR = $(ISHAREDIR)$(SEP)man
+IMANDIR = $(ITOPMANDIR)$(SEP)man1
+IINCDIR = $(SPREFIX)$(SEP)include
+IDOCDIR = $(IDATADIR)$(SEP)doc
+ICHICKENLIBDIR = $(ILIBDIR)$(SEP)chicken
+IEGGDIR = $(ICHICKENLIBDIR)$(SEP)$(BINARYVERSION)
+else
+SPREFIX = $(PREFIX)
+IBINDIR = $(BINDIR)
+ILIBDIR = $(LIBDIR)
+ISHAREDIR = $(SHAREDIR)
+IDATADIR = $(DATADIR)
+ITOPMANDIR = $(TOPMANDIR)
+IMANDIR = $(MANDIR)
+IINCDIR = $(INCDIR)
+IDOCDIR = $(DOCDIR)
+ICHICKENLIBDIR = $(CHICKENLIBDIR)
+IEGGDIR = $(EGGDIR)
+endif
+
+RUNTIME_LINKER_PATH ?= .
+
+# commands
+
+ifdef HOSTSYSTEM
+C_COMPILER ?= $(HOSTSYSTEM)-gcc
+CXX_COMPILER ?= $(HOSTSYSTEM)-g++
+LIBRARIAN ?= $(HOSTSYSTEM)-ar
+else
+C_COMPILER ?= gcc
+CXX_COMPILER ?= g++
+LIBRARIAN ?= ar
+endif
+LINKER ?= $(C_COMPILER)
+ifdef WINDOWS_SHELL
+REMOVE_COMMAND ?= del
+else
+REMOVE_COMMAND ?= rm
+endif
+ASSEMBLER ?= $(C_COMPILER)
+ifdef WINDOWS_SHELL
+INSTALL_PROGRAM ?= xcopy
+MAKEDIR_COMMAND ?= -mkdir
+else
+INSTALL_PROGRAM ?= install
+MAKEDIR_COMMAND ?= mkdir
+endif
+POSTINSTALL_STATIC_LIBRARY ?= true
+POSTINSTALL_PROGRAM ?= true
+
+# cross tools
+
+HOST_C_COMPILER ?= $(C_COMPILER)
+HOST_LIBRARIAN ?= $(LIBRARIAN)
+
+# target variables
+
+ifdef TARGETSYSTEM
+TARGET_C_COMPILER ?= $(TARGETSYSTEM)-$(C_COMPILER)
+TARGET_CXX_COMPILER ?= $(TARGETSYSTEM)-$(CXX_COMPILER)
+else
+TARGET_C_COMPILER ?= $(C_COMPILER)
+TARGET_CXX_COMPILER ?= $(CXX_COMPILER)
+endif
+
+TARGET_C_COMPILER_OPTIONS ?= $(C_COMPILER_OPTIONS)
+TARGET_C_COMPILER_OPTIMIZATION_OPTIONS ?= $(C_COMPILER_OPTIMIZATION_OPTIONS)
+TARGET_PREFIX ?= $(PREFIX)
+TARGET_RUN_PREFIX ?= $(TARGET_PREFIX)
+TARGET_LIBRARIES ?= $(LIBRARIES)
+TARGET_LINKER_OPTIONS ?= $(LINKER_OPTIONS)
+TARGET_LINKER_OPTIMIZATION_OPTIONS ?= $(LINKER_OPTIMIZATION_OPTIONS)
+
+ifneq ($(TARGET_C_COMPILER),$(C_COMPILER))
+CROSS_CHICKEN = 1
+else
+CROSS_CHICKEN = 0
+endif
+
+
+# options
+
+INCLUDES ?= -I. -I$(SRCDIR)
+C_COMPILER_COMPILE_OPTION ?= -c
+C_COMPILER_OUTPUT_OPTION ?= -o
+C_COMPILER_OUTPUT ?= $(C_COMPILER_OUTPUT_OPTION) $@
+
+ifndef NOPTABLES
+C_COMPILER_OPTIONS += -DC_ENABLE_PTABLES
+endif
+
+ifdef DEBUGBUILD
+ifeq ($(C_COMPILER),gcc)
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -g -Wall -Wno-unused
+endif
+endif
+C_COMPILER_BUILD_RUNTIME_OPTIONS ?= -DC_BUILDING_LIBCHICKEN
+C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS ?= $(C_COMPILER_BUILD_RUNTIME_OPTIONS) -DNDEBUG -DC_UNSAFE_RUNTIME
+C_COMPILER_SHARED_OPTIONS ?= -fPIC -DPIC
+LINKER_EXECUTABLE_OPTIONS ?= -L.
+LINKER_STATIC_OPTIONS ?= $(LINKER_EXECUTABLE_OPTIONS)
+LINKER_OUTPUT_OPTION ?= -o
+LINKER_OUTPUT ?= $(LINKER_OUTPUT_OPTION) $@
+LINKER_LIBRARY_OPTION ?= -l
+ifdef STATICBUILD
+LINKER_LIBRARY_PREFIX ?= lib
+LINKER_LIBRARY_SUFFIX ?= .a
+else
+LINKER_LIBRARY_PREFIX ?= -l
+LINKER_LIBRARY_SUFFIX ?=
+endif
+LINKER_LINK_SHARED_LIBRARY_OPTIONS ?= -shared
+LINKER_LINK_SHARED_DLOADABLE_OPTIONS ?= -shared -L.
+LIBRARIAN_OPTIONS ?= cru
+LIBRARIAN_OUTPUT_OPTION ?=
+LIBRARIAN_OUTPUT ?= $(LIBRARIAN_OUTPUT_OPTION) $@
+LIBRARIES ?= -lm
+ifdef WINDOWS_SHELL
+REMOVE_COMMAND_OPTIONS ?= /f /q
+REMOVE_COMMAND_RECURSIVE_OPTIONS ?= /f /s /q
+MAKE_WRITABLE_COMMAND ?= rem
+else
+REMOVE_COMMAND_OPTIONS ?= -f
+REMOVE_COMMAND_RECURSIVE_OPTIONS ?= -fr
+MAKE_WRITABLE_COMMAND ?= chmod 0755
+endif
+ifndef WINDOWS_SHELL
+INSTALL_PROGRAM_SHARED_LIBRARY_OPTIONS ?= -m755
+INSTALL_PROGRAM_STATIC_LIBRARY_OPTIONS ?= -m644
+INSTALL_PROGRAM_EXECUTABLE_OPTIONS ?= -m755
+INSTALL_PROGRAM_FILE_OPTIONS ?= -m644
+MAKEDIR_COMMAND_OPTIONS ?= -p
+endif
+ASSEMBLER_OPTIONS ?= $(C_COMPILER_OPTIONS)
+ASSEMBLER_OUTPUT_OPTION ?= -o
+ASSEMBLER_OUTPUT ?= $(ASSEMBLER_OUTPUT_OPTION) $@
+ASSEMBLER_COMPILE_OPTION ?= -c
+ifdef STATICBUILD
+PRIMARY_LIBCHICKEN ?= libchicken$(A)
+else
+ifeq ($(PLATFORM),cygwin)
+PRIMARY_LIBCHICKEN = cygchicken-0.dll
+LIBCHICKEN_SO_FILE = cygchicken-0.dll
+LIBUCHICKEN_SO_FILE = cyguchicken-0.dll
+LIBCHICKENGUI_SO_FILE ?=
+else
+PRIMARY_LIBCHICKEN ?= libchicken$(SO)
+LIBCHICKEN_SO_FILE ?= libchicken$(SO)
+LIBUCHICKEN_SO_FILE ?= libuchicken$(SO)
+LIBCHICKENGUI_SO_FILE ?=
+endif
+endif
+LIBCHICKEN_SO_LIBRARIES ?= $(LIBRARIES)
+LIBUCHICKEN_SO_LIBRARIES ?= $(LIBRARIES)
+LIBCHICKENGUI_SO_LIBRARIES ?= $(LIBRARIES)
+
+# cross settings
+
+HOST_C_COMPILER_OPTIONS ?= $(C_COMPILER_OPTIONS)
+HOST_C_COMPILER_COMPILE_OPTION ?= $(C_COMPILER_COMPILE_OPTION)
+HOST_C_COMPILER_OPTIMIZATION_OPTIONS ?= $(C_COMPILER_OPTIMIZATION_OPTIONS)
+HOST_C_COMPILER_SHARED_OPTIONS ?= $(C_COMPILER_SHARED_OPTIONS)
+HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS ?= $(C_COMPILER_BUILD_RUNTIME_OPTIONS)
+HOST_C_COMPILER_OUTPUT ?= $(C_COMPILER_OUTPUT)
+HOST_INCLUDES ?= $(INCLUDES)
+HOST_LINKER ?= $(LINKER)
+HOST_LINKER_OPTIONS ?= $(LINKER_OPTIONS)
+HOST_LINKER_LINK_SHARED_DLOADABLE_OPTIONS ?= $(LINKER_LINK_SHARED_DLOADABLE_OPTIONS)
+HOST_LINKER_OUTPUT_OPTION ?= $(LINKER_OUTPUT_OPTION)
+HOST_LINKER_LIBRARY_PREFIX ?= $(LINKER_LIBRARY_PREFIX)
+HOST_LINKER_LIBRARY_SUFFIX ?= $(LINKER_LIBRARY_SUFFIX)
+HOST_LIBRARIES ?= $(LIBRARIES)
+
+# other settings
+
+HOSTNAME ?= $(shell hostname)
+
+ifdef WINDOWS_SHELL
+BUILD_TIME ?= $(shell date /t)
+COPY_COMMAND = copy /Y
+else
+BUILD_TIME ?= $(shell date +%Y-%m-%d)
+UNAME_SYS ?= $(shell uname)
+COPY_COMMAND = cp
+endif
+BUILD_TAG ?= compiled $(BUILD_TIME) on $(HOSTNAME) ($(UNAME_SYS))
+COPYMANY =
+
+
+# file extensions
+
+O ?= .o
+A ?= .a
+# EXE ?=
+SO ?= .so
+ASM ?= .S
+
+# special files
+
+POSIXFILE ?= posixunix
+CHICKEN_CONFIG_H = chicken-config.h
+
+ifneq ($(ARCH),)
+HACKED_APPLY ?= 1
+APPLY_HACK_SRC ?= apply-hack.$(ARCH)$(ASM)
+APPLY_HACK_OBJECT ?= apply-hack.$(ARCH)$(O)
+endif
+
+# bootstrapping compiler
+
+CHICKEN ?= chicken$(EXE)
+
+# interpreter for scripts
+
+CSI ?= csi$(EXE)
+
+# Scheme compiler flags
+
+CHICKEN_OPTIONS = -optimize-level 2 -include-path . -include-path $(SRCDIR) -inline
+ifdef DEBUGBUILD
+CHICKEN_OPTIONS += -feature debugbuild -scrutinize -types $(SRCDIR)types.db
+endif
+CHICKEN_LIBRARY_OPTIONS = $(CHICKEN_OPTIONS) -explicit-use -no-trace
+CHICKEN_PROGRAM_OPTIONS = $(CHICKEN_OPTIONS) -no-lambda-info -local
+CHICKEN_COMPILER_OPTIONS = $(CHICKEN_PROGRAM_OPTIONS) -extend private-namespace.scm
+CHICKEN_UNSAFE_OPTIONS = -unsafe -no-lambda-info
+CHICKEN_DYNAMIC_OPTIONS = $(CHICKEN_OPTIONS) -feature chicken-compile-shared -dynamic
+CHICKEN_IMPORT_LIBRARY_OPTIONS = $(CHICKEN_DYNAMIC_OPTIONS)
+
+ifndef DEBUGBUILD
+CHICKEN_PROGRAM_OPTIONS += -no-trace
+CHICKEN_COMPILER_OPTIONS += -no-trace
+endif
+
+# targets
+
+CHICKEN_PROGRAM = $(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)
+CSC_PROGRAM = $(PROGRAM_PREFIX)csc$(PROGRAM_SUFFIX)
+CSI_PROGRAM = $(PROGRAM_PREFIX)csi$(PROGRAM_SUFFIX)
+CHICKEN_PROFILE_PROGRAM = $(PROGRAM_PREFIX)chicken-profile$(PROGRAM_SUFFIX)
+CHICKEN_INSTALL_PROGRAM = $(PROGRAM_PREFIX)chicken-install$(PROGRAM_SUFFIX)
+CHICKEN_SETUP_PROGRAM = $(PROGRAM_PREFIX)chicken-setup$(PROGRAM_SUFFIX)
+CHICKEN_UNINSTALL_PROGRAM = $(PROGRAM_PREFIX)chicken-uninstall$(PROGRAM_SUFFIX)
+CHICKEN_STATUS_PROGRAM = $(PROGRAM_PREFIX)chicken-status$(PROGRAM_SUFFIX)
+CHICKEN_BUG_PROGRAM = $(PROGRAM_PREFIX)chicken-bug$(PROGRAM_SUFFIX)
+IMPORT_LIBRARIES = chicken lolevel srfi-1 srfi-4 data-structures ports files posix srfi-13 srfi-69 extras \
+ regex srfi-14 tcp foreign scheme srfi-18 utils csi irregex
+IMPORT_LIBRARIES += setup-api setup-download
+SCRUTINIZED_LIBRARIES = library eval data-structures ports files extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
+ srfi-14 srfi-18 srfi-69 $(POSIXFILE) regex scheduler \
+ profiler stub expand chicken-syntax
+
+ifdef STATICBUILD
+CHICKEN_STATIC_EXECUTABLE = $(CHICKEN_PROGRAM)$(EXE)
+CSI_STATIC_EXECUTABLE = $(CSI_PROGRAM)$(EXE)
+CHICKEN_SHARED_EXECUTABLE = $(CHICKEN_PROGRAM)-shared$(EXE)
+CSI_SHARED_EXECUTABLE = $(CSI_PROGRAM)-shared$(EXE)
+TARGETLIBS ?= libchicken$(A) libuchicken$(A)
+TARGETS ?= $(TARGETLIBS) $(CHICKEN_STATIC_EXECUTABLE) \
+ $(CSI_STATIC_EXECUTABLE) $(CHICKEN_PROFILE_PROGRAM)$(EXE) \
+ $(CSC_PROGRAM)$(EXE) \
+ $(CHICKEN_BUG_PROGRAM)$(EXE)
+else
+CHICKEN_STATIC_EXECUTABLE = $(CHICKEN_PROGRAM)-static$(EXE)
+CSI_STATIC_EXECUTABLE = $(CSI_PROGRAM)-static$(EXE)
+CHICKEN_SHARED_EXECUTABLE = $(CHICKEN_PROGRAM)$(EXE)
+CSI_SHARED_EXECUTABLE = $(CSI_PROGRAM)$(EXE)
+TARGETLIBS ?= libchicken$(A) libuchicken$(A) \
+ $(LIBCHICKEN_SO_FILE) $(LIBUCHICKEN_SO_FILE)
+TARGETS ?= $(TARGETLIBS) $(CHICKEN_SHARED_EXECUTABLE) \
+ $(CSI_SHARED_EXECUTABLE) $(CHICKEN_PROFILE_PROGRAM)$(EXE) \
+ $(CSC_PROGRAM)$(EXE) $(CHICKEN_INSTALL_PROGRAM)$(EXE) $(CHICKEN_UNINSTALL_PROGRAM)$(EXE) \
+ $(CHICKEN_SETUP_PROGRAM)$(EXE) \
+ $(CHICKEN_STATUS_PROGRAM)$(EXE) setup-download.so setup-api.so \
+ $(CHICKEN_BUG_PROGRAM)$(EXE) \
+ $(IMPORT_LIBRARIES:%=%.import.so)
+endif
+
+# main rule
+
+.PHONY: all
+
+all: buildsvnrevision $(TARGETS)
+
+buildsvnrevision:
+ifdef WINDOWS_SHELL
+ echo 0 >buildsvnrevision
+else
+ sh $(SRCDIR)svnrevision.sh
+endif
+
+# generic part of chicken-config.h
+
+ifndef CUSTOM_CHICKEN_DEFAULTS
+chicken-defaults.h: buildsvnrevision
+ echo "/* generated */" >$@
+ echo "#define C_BUILD_TAG \"$(BUILD_TAG)\"" >>$@
+ echo "#define C_CHICKEN_PROGRAM \"$(CHICKEN_PROGRAM)$(EXE)\"" >>$@
+ echo "#define C_SVN_REVISION $(shell cat buildsvnrevision)" >>$@
+ echo "#ifndef C_INSTALL_CC" >>$@
+ echo "# define C_INSTALL_CC \"$(C_COMPILER)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_CXX" >>$@
+ echo "# define C_INSTALL_CXX \"$(CXX_COMPILER)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_CFLAGS" >>$@
+ echo "# define C_INSTALL_CFLAGS \"$(C_COMPILER_OPTIONS) $(C_COMPILER_OPTIMIZATION_OPTIONS)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_LDFLAGS" >>$@
+ echo "# define C_INSTALL_LDFLAGS \"$(LINKER_OPTIONS) $(LINKER_OPTIMIZATION_OPTIONS)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_SHARE_HOME" >>$@
+ echo "# define C_INSTALL_SHARE_HOME \"$(DATADIR)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_BIN_HOME" >>$@
+ echo "# define C_INSTALL_BIN_HOME \"$(BINDIR)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_EGG_HOME" >>$@
+ echo "# define C_INSTALL_EGG_HOME \"$(EGGDIR)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_LIB_HOME" >>$@
+ echo "# define C_INSTALL_LIB_HOME \"$(LIBDIR)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_STATIC_LIB_HOME" >>$@
+ echo "# define C_INSTALL_STATIC_LIB_HOME \"$(LIBDIR)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_INCLUDE_HOME" >>$@
+ echo "# define C_INSTALL_INCLUDE_HOME \"$(INCDIR)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_MORE_LIBS" >>$@
+ echo "# define C_INSTALL_MORE_LIBS \"$(LIBRARIES)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_INSTALL_MORE_STATIC_LIBS" >>$@
+ echo "# define C_INSTALL_MORE_STATIC_LIBS \"$(LIBRARIES)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_DEFAULT_TARGET_STACK_SIZE" >>$@
+ echo "# define C_DEFAULT_TARGET_STACK_SIZE $(NURSERY)" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_DEFAULT_TARGET_HEAP_SIZE" >>$@
+ echo "# define C_DEFAULT_TARGET_HEAP_SIZE 0" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_STACK_GROWS_DOWNWARD" >>$@
+ echo "# define C_STACK_GROWS_DOWNWARD $(STACKDIRECTION)" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_MORE_LIBS" >>$@
+ echo "# define C_TARGET_MORE_LIBS \"$(TARGET_LIBRARIES)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_MORE_STATIC_LIBS" >>$@
+ echo "# define C_TARGET_MORE_STATIC_LIBS \"$(TARGET_LIBRARIES)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_CC" >>$@
+ echo "# define C_TARGET_CC \"$(TARGET_C_COMPILER)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_CXX" >>$@
+ echo "# define C_TARGET_CXX \"$(TARGET_CXX_COMPILER)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_CFLAGS" >>$@
+ echo "# define C_TARGET_CFLAGS \"$(TARGET_C_COMPILER_OPTIONS) $(TARGET_C_COMPILER_OPTIMIZATION_OPTIONS)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_LDFLAGS" >>$@
+ echo "# define C_TARGET_LDFLAGS \"$(TARGET_LINKER_OPTIONS) $(TARGET_LINKER_OPTIMIZATION_OPTIONS)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_CROSS_CHICKEN" >>$@
+ echo "# define C_CROSS_CHICKEN $(CROSS_CHICKEN)" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_BIN_HOME" >>$@
+ echo "# define C_TARGET_BIN_HOME \"$(TARGET_PREFIX)/bin\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_LIB_HOME" >>$@
+ echo "# define C_TARGET_LIB_HOME \"$(TARGET_PREFIX)/lib\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_RUN_LIB_HOME" >>$@
+ echo "# define C_TARGET_RUN_LIB_HOME \"$(TARGET_RUN_PREFIX)/lib\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_SHARE_HOME" >>$@
+ echo "# define C_TARGET_SHARE_HOME \"$(TARGET_PREFIX)/share\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_INCLUDE_HOME" >>$@
+ echo "# define C_TARGET_INCLUDE_HOME \"$(TARGET_PREFIX)/include\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_TARGET_STATIC_LIB_HOME" >>$@
+ echo "# define C_TARGET_STATIC_LIB_HOME \"$(TARGET_PREFIX)/lib\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_CHICKEN_PROGRAM" >>$@
+ echo "# define C_CHICKEN_PROGRAM \"$(CHICKEN_PROGRAM)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_CSC_PROGRAM" >>$@
+ echo "# define C_CSC_PROGRAM \"$(CSC_PROGRAM)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_CSI_PROGRAM" >>$@
+ echo "# define C_CSI_PROGRAM \"$(CSI_PROGRAM)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_CHICKEN_BUG_PROGRAM" >>$@
+ echo "# define C_CHICKEN_BUG_PROGRAM \"$(CHICKEN_BUG_PROGRAM)\"" >>$@
+ echo "#endif" >>$@
+ echo "#ifndef C_WINDOWS_SHELL" >>$@
+ifdef WINDOWS_SHELL
+ echo "# define C_WINDOWS_SHELL 1" >>$@
+else
+ echo "# define C_WINDOWS_SHELL 0" >>$@
+endif
+ echo "#endif" >>$@
+ echo "#ifndef C_BINARY_VERSION" >>$@
+ echo "# define C_BINARY_VERSION $(BINARYVERSION)" >>$@
+ echo "#endif" >>$@
+endif
diff --git a/distribution/manifest b/distribution/manifest
new file mode 100644
index 00000000..10c91bf9
--- /dev/null
+++ b/distribution/manifest
@@ -0,0 +1,346 @@
+ChangeLog
+ChangeLog.20040412
+ChangeLog.20070807
+INSTALL
+LICENSE
+NEWS
+README
+config-arch.sh
+banner.scm
+batch-driver.scm
+benchmarks/0.scm
+benchmarks/cscbench.scm
+benchmarks/nbody.scm
+benchmarks/binarytrees.scm
+benchmarks/boyer.scm
+benchmarks/browse.scm
+benchmarks/conform.scm
+benchmarks/cpstak.scm
+benchmarks/ctak.scm
+benchmarks/dderiv.scm
+benchmarks/deriv.scm
+benchmarks/destructive.scm
+benchmarks/div-iter.scm
+benchmarks/div-rec.scm
+benchmarks/dynamic.scm
+benchmarks/earley.scm
+benchmarks/fft.scm
+benchmarks/fib.scm
+benchmarks/fibc.scm
+benchmarks/fprint.scm
+benchmarks/fread.scm
+benchmarks/hanoi.scm
+benchmarks/lattice.scm
+benchmarks/maze.scm
+benchmarks/nqueens.scm
+benchmarks/others/Makefile
+benchmarks/others/except.scm
+benchmarks/others/except2.scm
+benchmarks/others/exception.cpp
+benchmarks/others/results.txt
+benchmarks/others/setlongjmp.c
+benchmarks/puzzle.scm
+benchmarks/scheme.scm
+benchmarks/tak.scm
+benchmarks/takl.scm
+benchmarks/takr.scm
+benchmarks/traverse.scm
+benchmarks/travinit.scm
+benchmarks/triangl.scm
+benchmarks/regex/benchmark.pl
+benchmarks/regex/re-benchmarks.txt
+benchmarks/regex/benchmark.scm
+batch-driver.c
+c-backend.c
+c-platform.c
+chicken-profile.c
+chicken.c
+compiler.c
+csc.c
+csi.c
+eval.c
+data-structures.c
+ports.c
+files.c
+extras.c
+library.c
+lolevel.c
+optimizer.c
+compiler-syntax.c
+scrutinizer.c
+regex.c
+posixunix.c
+posixwin.c
+profiler.c
+scheduler.c
+srfi-69.c
+srfi-1.c
+srfi-13.c
+srfi-14.c
+srfi-18.c
+srfi-4.c
+stub.c
+support.c
+tcp.c
+ueval.c
+uextras.c
+udata-structures.c
+uports.c
+ufiles.c
+ulibrary.c
+ulolevel.c
+uregex.c
+uposixunix.c
+uposixwin.c
+usrfi-1.c
+usrfi-13.c
+usrfi-14.c
+usrfi-18.c
+usrfi-4.c
+usrfi-69.c
+utcp.c
+utils.c
+uutils.c
+build.scm
+version.scm
+buildversion
+buildsvnrevision
+c-backend.scm
+c-platform.scm
+chicken-ffi-syntax.scm
+chicken-primitive-object-inlines.scm
+chicken-thread-object-inlines.scm
+chicken-profile.1
+chicken-profile.scm
+chicken.1
+chicken.h
+chicken.ico
+chicken.rc
+chicken.scm
+compiler.scm
+csc.1
+csc.scm
+csi.1
+csi.scm
+csibatch.bat
+eval.scm
+extras.scm
+data-structures.scm
+ports.scm
+files.scm
+chicken-bug.1
+chicken-bug.scm
+chicken-bug.c
+hen.el
+scheme-complete.el
+html/Accessing external objects.html
+html/Acknowledgements.html
+html/Basic mode of operation.html
+html/Bibliography.html
+html/Bugs and limitations.html
+html/C interface.html
+html/Callbacks.html
+html/Data representation.html
+html/Declarations.html
+html/Deviations from the standard.html
+html/Embedding.html
+html/Extensions to the standard.html
+html/Extensions.html
+html/Foreign type specifiers.html
+html/Getting started.html
+html/Interface to external functions and variables.html
+html/Locations.html
+html/Modules and macros.html
+html/Non-standard macros and special forms.html
+html/Non-standard read syntax.html
+html/Other support procedures.html
+html/Getting Started.html
+html/Parameters.html
+html/Supported language.html
+html/The User's Manual.html
+html/Unit data-structures.html
+html/Unit eval.html
+html/Unit expand.html
+html/Unit extras.html
+html/Unit files.html
+html/Unit library.html
+html/Unit lolevel.html
+html/Unit ports.html
+html/Unit posix.html
+html/Unit regex.html
+html/Unit srfi-1.html
+html/Unit srfi-13.html
+html/Unit srfi-14.html
+html/Unit srfi-18.html
+html/Unit srfi-4.html
+html/Unit tcp.html
+html/Unit utils.html
+html/Using the compiler.html
+html/Using the interpreter.html
+html/faq.html
+html/manual.css
+library.scm
+lolevel.scm
+optimizer.scm
+compiler-syntax.scm
+scrutinizer.scm
+regex.scm
+irregex.scm
+posixunix.scm
+posixwin.scm
+profiler.scm
+runtime.c
+scheduler.scm
+srfi-69.scm
+srfi-1.scm
+srfi-13.scm
+srfi-14.scm
+srfi-18.scm
+srfi-4.scm
+toposort.scm
+stub.scm
+support.scm
+tcp.scm
+tests/library-tests.scm
+tests/compiler-tests.scm
+tests/compiler-tests-2.scm
+tests/inlining-tests.scm
+tests/locative-stress-test.scm
+tests/r4rstest.scm
+tests/runtests.sh
+tests/srfi-18-tests.scm
+tests/hash-table-tests.scm
+tests/apply-test.scm
+tests/embedded1.c
+tests/embedded2.scm
+tests/fixnum-tests.scm
+tests/path-tests.scm
+tests/posix-tests.scm
+tests/r4rstest.out
+tests/port-tests.scm
+tests/test-gc-hooks.scm
+tests/matchable.scm
+tests/match-tests.scm
+tests/module-tests.scm
+tests/test-finalizers.scm
+tests/test-finalizers-2.scm
+tests/module-tests-compiled.scm
+tests/scrutiny-tests.scm
+tests/scrutiny.expected
+tests/syntax-tests.scm
+tests/syntax-tests-2.scm
+tests/meta-syntax-test.scm
+tests/reexport-tests.scm
+tests/ec.scm
+tests/ec-tests.scm
+tests/test-chained-modules.scm
+tests/import-library-test1.scm
+tests/import-library-test2.scm
+tests/match-test.scm
+tests/test.scm
+tests/loopy-test.scm
+tests/loopy-loop.scm
+tests/r5rs_pitfalls.scm
+tests/test-irregex.scm
+tests/re-tests.txt
+tests/lolevel-tests.scm
+tests/feeley-dynwind.scm
+tests/compiler-syntax-tests.scm
+tweaks.scm
+utils.scm
+apply-hack.x86.S
+apply-hack.x86-64.S
+apply-hack.ppc.darwin.S
+apply-hack.ppc.sysv.S
+apply-hack.sparc64.S
+chicken.pdf
+Makefile
+Makefile.linux
+Makefile.macosx
+Makefile.mingw
+Makefile.mingw-msys
+Makefile.solaris
+Makefile.bsd
+Makefile.cygwin
+Makefile.cross-linux-mingw
+rules.make
+defaults.make
+private-namespace.scm
+compiler-namespace.scm
+scripts/scheme
+scripts/tools.scm
+scripts/test-dist.sh
+scripts/wiki2html.scm
+scripts/make-egg-index.scm
+scripts/makedist.scm
+scripts/README
+scripts/henrietta.scm
+scripts/henrietta.cgi
+svnrevision.sh
+synrules.scm
+expand.scm
+expand.c
+chicken-syntax.scm
+chicken-syntax.c
+unsafe-declarations.scm
+ports.import.scm
+ports.import.c
+files.import.scm
+files.import.c
+scheme.import.scm
+scheme.import.c
+chicken.import.scm
+chicken.import.c
+foreign.import.scm
+foreign.import.c
+compiler.import.scm
+compiler.import.c
+lolevel.import.scm
+srfi-1.import.scm
+srfi-4.import.scm
+data-structures.import.scm
+posix.import.scm
+srfi-13.import.scm
+srfi-69.import.scm
+extras.import.scm
+regex.import.scm
+irregex.import.scm
+srfi-14.import.scm
+tcp.import.scm
+srfi-18.import.scm
+utils.import.scm
+lolevel.import.c
+srfi-1.import.c
+srfi-4.import.c
+data-structures.import.c
+posix.import.c
+srfi-13.import.c
+srfi-69.import.c
+extras.import.c
+regex.import.c
+irregex.import.c
+srfi-14.import.c
+tcp.import.c
+srfi-18.import.c
+utils.import.c
+csi.import.scm
+csi.import.c
+setup-download.scm
+setup-api.scm
+chicken-status.scm
+chicken-status.c
+chicken-install.scm
+chicken-install.c
+chicken-setup.scm
+chicken-setup.c
+chicken-uninstall.scm
+chicken-uninstall.c
+setup.defaults
+chicken-status.1
+chicken-install.1
+chicken-uninstall.1
+setup-download.c
+setup-api.c
+setup-api.import.c
+setup-download.import.c
+types.db
diff --git a/eval.scm b/eval.scm
new file mode 100644
index 00000000..82078202
--- /dev/null
+++ b/eval.scm
@@ -0,0 +1,1873 @@
+;;;; eval.scm - Interpreter for CHICKEN
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit eval)
+ (uses expand data-structures)
+ (disable-warning var)
+ (hide ##sys#r4rs-environment ##sys#r5rs-environment
+ ##sys#interaction-environment pds pdss pxss)
+ (not inline ##sys#repl-eval-hook ##sys#repl-read-hook ##sys#repl-print-hook
+ ##sys#read-prompt-hook ##sys#alias-global-hook ##sys#user-read-hook
+ ##sys#syntax-error-hook))
+
+(define (d arg1 . more)
+ (if (null? more)
+ (pp arg1)
+ (apply print arg1 more)))
+
+(define-syntax d (syntax-rules () ((_ . _) (void))))
+
+#>
+#ifndef C_INSTALL_EGG_HOME
+# define C_INSTALL_EGG_HOME "."
+#endif
+
+#ifndef C_INSTALL_SHARE_HOME
+# define C_INSTALL_SHARE_HOME NULL
+#endif
+
+#ifndef C_BINARY_VERSION
+# define C_BINARY_VERSION 0
+#endif
+<#
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ ;***(no-bound-checks)
+ (no-procedure-checks-for-usual-bindings)
+ (bound-to-procedure
+ ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-string ##sys#load-library
+ ##sys#load-library-0
+ ##sys#for-each ##sys#map ##sys#setslot ##sys#allocate-vector ##sys#check-pair ##sys#error-not-a-proper-list
+ ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling ##sys#truncate ##sys#round
+ ##sys#check-number ##sys#cons-flonum ##sys#copy-env-table
+ ##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg ##sys#print ##sys#check-structure
+ ##sys#make-structure ##sys#feature?
+ ##sys#error-handler ##sys#hash-symbol ##sys#check-syntax
+ ##sys#hash-table-ref ##sys#hash-table-set! ##sys#canonicalize-body ##sys#decompose-lambda-list
+ ##sys#make-c-string ##sys#resolve-include-filename
+ ##sys#load ##sys#error ##sys#warn ##sys#hash-table-location ##sys#expand-home-path
+ ##sys#make-flonum ##sys#make-pointer ##sys#null-pointer ##sys#address->pointer
+ ##sys#pointer->address ##sys#compile-to-closure ##sys#make-string ##sys#make-lambda-info ##sys#lambda-info?
+ ##sys#number? ##sys#symbol->qualified-string ##sys#decorate-lambda ##sys#string-append
+ ##sys#ensure-heap-reserve ##sys#syntax-error-hook ##sys#read-prompt-hook
+ ##sys#repl-eval-hook ##sys#append ##sys#eval-decorator
+ open-output-string get-output-string make-parameter software-type software-version machine-type
+ build-platform set-extensions-specifier! ##sys#string->symbol list->vector get-environment-variable
+ extension-information syntax-error ->string chicken-home ##sys#expand-curried-define
+ vector->list store-string open-input-string eval ##sys#gc
+ with-exception-handler print-error-message read-char read ##sys#read-error
+ ##sys#reset-handler call-with-current-continuation ##sys#peek-char-0 ##sys#read-char-0
+ ##sys#clear-trace-buffer ##sys#write-char-0 print-call-chain ##sys#with-print-length-limit
+ repl-prompt ##sys#flush-output ##sys#extended-lambda-list? keyword? get-line-number
+ symbol->string string-append display ##sys#repository-path ##sys#file-info make-vector
+ ##sys#make-vector string-copy vector->list ##sys#do-the-right-thing ##sys#->feature-id
+ ##sys#extension-information ##sys#symbol->string ##sys#canonicalize-extension-path
+ file-exists? ##sys#load-extension ##sys#find-extension ##sys#substring reverse
+ dynamic-load-libraries ##sys#string->c-identifier load-verbose ##sys#load ##sys#get-keyword
+ port? ##sys#file-info ##sys#signal-hook ##sys#dload open-input-file close-input-port
+ read write newline ##sys#eval-handler ##sys#set-dlopen-flags! cadadr ##sys#lookup-runtime-requirements
+ map string->keyword ##sys#abort
+ ##sys#expand-0) ) ] )
+
+(include "unsafe-declarations.scm")
+
+(define-foreign-variable install-egg-home c-string "C_INSTALL_EGG_HOME")
+(define-foreign-variable installation-home c-string "C_INSTALL_SHARE_HOME")
+(define-foreign-variable binary-version int "C_BINARY_VERSION")
+
+(define ##sys#core-library-modules
+ '(extras lolevel utils files tcp regex posix srfi-1 srfi-4 srfi-13
+ srfi-14 srfi-18 srfi-69 data-structures ports chicken-syntax))
+
+(define ##sys#explicit-library-modules '())
+
+(define-constant default-dynamic-load-libraries '("libchicken"))
+(define-constant cygwin-default-dynamic-load-libraries '("cygchicken-0"))
+(define-constant macosx-load-library-extension ".dylib")
+(define-constant windows-load-library-extension ".dll")
+(define-constant hppa-load-library-extension ".sl")
+(define-constant default-load-library-extension ".so")
+(define-constant environment-table-size 301)
+(define-constant source-file-extension ".scm")
+(define-constant setup-file-extension "setup-info")
+(define-constant repository-environment-variable "CHICKEN_REPOSITORY")
+(define-constant prefix-environment-variable "CHICKEN_PREFIX")
+
+; these are actually in unit extras, but that is used by default
+; srfi-12 in unit library
+; srfi-98 partially in unit posix
+
+(define-constant builtin-features
+ '(chicken srfi-2 srfi-6 srfi-10 srfi-12 srfi-23 srfi-28 srfi-30 srfi-31 srfi-39
+ srfi-88 srfi-98) )
+
+(define-constant builtin-features/compiled
+ '(srfi-6 srfi-8 srfi-9 srfi-11 srfi-15 srfi-16 srfi-17 srfi-26 srfi-55) )
+
+(define ##sys#chicken-prefix
+ (let ((prefix (and-let* ((p (get-environment-variable prefix-environment-variable)))
+ (##sys#string-append
+ p
+ (if (memq (string-ref p (fx- (##sys#size p) 1)) '(#\\ #\/)) "" "/")) ) ) )
+ (lambda (#!optional dir)
+ (and prefix
+ (if dir (##sys#string-append prefix dir) prefix) ) ) ) )
+
+
+;;; System settings
+
+(define (chicken-home)
+ (or (##sys#chicken-prefix "share/chicken")
+ installation-home) )
+
+
+;;; Lo-level hashtable support:
+
+(define ##sys#hash-symbol
+ (let ([cache-s #f]
+ [cache-h #f] )
+ (lambda (s n)
+ (if (eq? s cache-s)
+ (##core#inline "C_fixnum_modulo" cache-h n)
+ (begin
+ (set! cache-s s)
+ (set! cache-h (##core#inline "C_hash_string" (##sys#slot s 1)))
+ (##core#inline "C_fixnum_modulo" cache-h n))))))
+
+(define (##sys#hash-table-ref ht key)
+ (let loop ((bucket (##sys#slot ht (##sys#hash-symbol key (##core#inline "C_block_size" ht)))))
+ (and (not (eq? '() bucket))
+ (if (eq? key (##sys#slot (##sys#slot bucket 0) 0))
+ (##sys#slot (##sys#slot bucket 0) 1)
+ (loop (##sys#slot bucket 1))))))
+
+(define (##sys#hash-table-set! ht key val)
+ (let* ((k (##sys#hash-symbol key (##core#inline "C_block_size" ht)))
+ (ib (##sys#slot ht k)))
+ (let loop ((bucket ib))
+ (if (eq? '() bucket)
+ (##sys#setslot ht k (cons (cons key val) ib))
+ (if (eq? key (##sys#slot (##sys#slot bucket 0) 0))
+ (##sys#setslot (##sys#slot bucket 0) 1 val)
+ (loop (##sys#slot bucket 1)))))))
+
+(define (##sys#hash-table-update! ht key updtfunc valufunc)
+ (##sys#hash-table-set! ht key (updtfunc (or (##sys#hash-table-ref ht key) (valufunc)))) )
+
+(define (##sys#hash-table-for-each p ht)
+ (let ((len (##core#inline "C_block_size" ht)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx>= i len))
+ (##sys#for-each (lambda (bucket) (p (##sys#slot bucket 0) (##sys#slot bucket 1)))
+ (##sys#slot ht i) ) ) ) )
+
+(define ##sys#hash-table-location
+ (let ([unbound (##sys#slot '##sys#arbitrary-unbound-symbol 0)])
+ (lambda (ht key addp)
+ (let* ([k (##sys#hash-symbol key (##sys#size ht))]
+ [bucket0 (##sys#slot ht k)] )
+ (let loop ([bucket bucket0])
+ (if (null? bucket)
+ (and addp
+ (let ([p (vector key unbound #t)])
+ (##sys#setslot ht k (cons p bucket0))
+ p) )
+ (let ([b (##sys#slot bucket 0)])
+ (if (eq? key (##sys#slot b 0))
+ b
+ (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) )
+
+
+;;; Compile lambda to closure:
+
+(define ##sys#eval-environment #f)
+(define ##sys#environment-is-mutable #f)
+
+(define (##sys#eval-decorator p ll h cntr)
+ (##sys#decorate-lambda
+ p
+ ##sys#lambda-info?
+ (lambda (p i)
+ (##sys#setslot
+ p i
+ (##sys#make-lambda-info
+ (let ((o (open-output-string)))
+ (write ll o)
+ (get-output-string o))))
+ p) ) )
+
+(define ##sys#unbound-in-eval #f)
+(define ##sys#eval-debug-level 1)
+
+(define ##sys#compile-to-closure
+ (let ([write write]
+ [reverse reverse]
+ [open-output-string open-output-string]
+ [get-output-string get-output-string]
+ [with-input-from-file with-input-from-file]
+ [unbound (##sys#slot '##sys#arbitrary-unbound-symbol 0)]
+ [display display] )
+ (lambda (exp env se #!optional cntr)
+
+ (define (find-id id se) ; ignores macro bindings
+ (cond ((null? se) #f)
+ ((and (eq? id (caar se)) (symbol? (cdar se))) (cdar se))
+ (else (find-id id (cdr se)))))
+
+ (define (rename var se)
+ (cond ((find-id var se))
+ ((##sys#get var '##core#macro-alias))
+ (else var)))
+
+ (define (lookup var0 e se)
+ (let ((var (rename var0 se)))
+ (d `(LOOKUP/EVAL: ,var0 ,var ,e ,(map car se)))
+ (let loop ((envs e) (ei 0))
+ (cond ((null? envs) (values #f var))
+ ((posq var (##sys#slot envs 0)) => (lambda (p) (values ei p)))
+ (else (loop (##sys#slot envs 1) (fx+ ei 1))) ) ) ))
+
+ (define (posq x lst)
+ (let loop ((lst lst) (i 0))
+ (cond ((null? lst) #f)
+ ((eq? x (##sys#slot lst 0)) i)
+ (else (loop (##sys#slot lst 1) (fx+ i 1))) ) ) )
+
+ (define (emit-trace-info tf info cntr)
+ (when tf
+ (##core#inline "C_emit_eval_trace_info" info cntr ##sys#current-thread) ) )
+
+ (define (emit-syntax-trace-info tf info cntr)
+ (when tf
+ (##core#inline "C_emit_syntax_trace_info" info cntr ##sys#current-thread) ) )
+
+ (define (decorate p ll h cntr)
+ (##sys#eval-decorator p ll h cntr) )
+
+ (define (eval/meta form)
+ (parameterize ((##sys#current-module #f)
+ (##sys#macro-environment (##sys#meta-macro-environment)))
+ ((##sys#compile-to-closure
+ form
+ '()
+ (##sys#current-meta-environment))
+ '() ) ))
+
+ (define (eval/elab form)
+ ((##sys#compile-to-closure
+ form
+ '()
+ (##sys#current-environment))
+ '() ) )
+
+ (define (compile x e h tf cntr se)
+ (cond ((keyword? x) (lambda v x))
+ ((symbol? x)
+ (receive (i j) (lookup x e se)
+ (cond [(not i)
+ (let ((var (if (not (assq x se)) ; global?
+ (##sys#alias-global-hook j #f)
+ (or (##sys#get j '##core#primitive) j))))
+ (if ##sys#eval-environment
+ (let ([loc (##sys#hash-table-location ##sys#eval-environment var #t)])
+ (unless loc (##sys#syntax-error-hook "reference to undefined identifier" var))
+ (cond-expand
+ [unsafe (lambda v (##sys#slot loc 1))]
+ [else
+ (lambda v
+ (let ([val (##sys#slot loc 1)])
+ (if (eq? unbound val)
+ (##sys#error "unbound variable" var)
+ val) ) ) ] ) )
+ (cond-expand
+ [unsafe (lambda v (##core#inline "C_slot" var 0))]
+ [else
+ (when (and ##sys#unbound-in-eval (not (##sys#symbol-has-toplevel-binding? var)))
+ (set! ##sys#unbound-in-eval (cons (cons var cntr) ##sys#unbound-in-eval)) )
+ (lambda v (##core#inline "C_retrieve" var))] ) ) ) ]
+ [(zero? i) (lambda (v) (##sys#slot (##sys#slot v 0) j))]
+ [else (lambda (v) (##sys#slot (##core#inline "C_u_i_list_ref" v i) j))] ) ) )
+ [(##sys#number? x)
+ (case x
+ [(-1) (lambda v -1)]
+ [(0) (lambda v 0)]
+ [(1) (lambda v 1)]
+ [(2) (lambda v 2)]
+ [else (lambda v x)] ) ]
+ [(boolean? x)
+ (if x
+ (lambda v #t)
+ (lambda v #f) ) ]
+ [(or (char? x)
+ (eof-object? x)
+ (string? x) )
+ (lambda v x) ]
+ [(not (pair? x)) (##sys#syntax-error-hook "illegal non-atomic object" x)]
+ [(symbol? (##sys#slot x 0))
+ (emit-syntax-trace-info tf x cntr)
+ (let ((x2 (##sys#expand x se #f)))
+ (d `(EVAL/EXPANDED: ,x2))
+ (if (not (eq? x2 x))
+ (compile x2 e h tf cntr se)
+ (let ((head (rename (##sys#slot x 0) se)))
+ ;; here we did't resolve ##core#primitive, but that is done in compile-call (via
+ ;; a normal walking of the operator)
+ (case head
+
+ [(quote)
+ (##sys#check-syntax 'quote x '(quote _) #f se)
+ (let* ((c (##sys#strip-syntax (cadr x))))
+ (case c
+ [(-1) (lambda v -1)]
+ [(0) (lambda v 0)]
+ [(1) (lambda v 1)]
+ [(2) (lambda v 2)]
+ [(#t) (lambda v #t)]
+ [(#f) (lambda v #f)]
+ [(()) (lambda v '())]
+ [else (lambda v c)] ) ) ]
+
+ ((syntax ##core#syntax)
+ (let ((c (cadr x)))
+ (lambda v c)))
+
+ [(##core#global-ref)
+ (let ([var (cadr x)])
+ (if ##sys#eval-environment
+ (let ([loc (##sys#hash-table-location ##sys#eval-environment var #t)])
+ (lambda v (##sys#slot loc 1)) )
+ (lambda v (##core#inline "C_slot" var 0)) ) ) ]
+
+ [(##core#check)
+ (compile (cadr x) e h tf cntr se) ]
+
+ [(##core#immutable)
+ (compile (cadr x) e #f tf cntr se) ]
+
+ [(##core#undefined) (lambda (v) (##core#undefined))]
+
+ [(if)
+ (##sys#check-syntax 'if x '(if _ _ . #(_)) #f se)
+ (let* ([test (compile (cadr x) e #f tf cntr se)]
+ [cns (compile (caddr x) e #f tf cntr se)]
+ [alt (if (pair? (cdddr x))
+ (compile (cadddr x) e #f tf cntr se)
+ (compile '(##core#undefined) e #f tf cntr se) ) ] )
+ (lambda (v) (if (##core#app test v) (##core#app cns v) (##core#app alt v))) ) ]
+
+ [(begin ##core#begin)
+ (##sys#check-syntax 'begin x '(_ . #(_ 0)) #f se)
+ (let* ([body (##sys#slot x 1)]
+ [len (length body)] )
+ (case len
+ [(0) (compile '(##core#undefined) e #f tf cntr se)]
+ [(1) (compile (##sys#slot body 0) e #f tf cntr se)]
+ [(2) (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se)]
+ [x2 (compile (cadr body) e #f tf cntr se)] )
+ (lambda (v) (##core#app x1 v) (##core#app x2 v)) ) ]
+ [else
+ (let* ([x1 (compile (##sys#slot body 0) e #f tf cntr se)]
+ [x2 (compile (cadr body) e #f tf cntr se)]
+ [x3 (compile `(##core#begin ,@(##sys#slot (##sys#slot body 1) 1)) e #f tf cntr se)] )
+ (lambda (v) (##core#app x1 v) (##core#app x2 v) (##core#app x3 v)) ) ] ) ) ]
+
+ [(set! ##core#set!)
+ (##sys#check-syntax 'set! x '(_ variable _) #f se)
+ (let ((var (cadr x)))
+ (receive (i j) (lookup var e se)
+ (let ((val (compile (caddr x) e var tf cntr se)))
+ (cond [(not i)
+ (let ((var (##sys#alias-global-hook j #t)))
+ (if ##sys#eval-environment
+ (let ([loc (##sys#hash-table-location
+ ##sys#eval-environment
+ var
+ ##sys#environment-is-mutable) ] )
+ (unless loc (##sys#error "assignment of undefined identifier" var))
+ (if (##sys#slot loc 2)
+ (lambda (v) (##sys#setslot loc 1 (##core#app val v)))
+ (lambda v (##sys#error "assignment to immutable variable" var)) ) )
+ (lambda (v)
+ (##sys#setslot var 0 (##core#app val v))) ) ) ]
+ [(zero? i) (lambda (v) (##sys#setslot (##sys#slot v 0) j (##core#app val v)))]
+ [else
+ (lambda (v)
+ (##sys#setslot
+ (##core#inline "C_u_i_list_ref" v i) j (##core#app val v)) ) ] ) ) ) ) ]
+
+ [(let ##core#let)
+ (##sys#check-syntax 'let x '(_ #((variable _) 0) . #(_ 1)) #f se)
+ (let* ([bindings (cadr x)]
+ [n (length bindings)]
+ [vars (map (lambda (x) (car x)) bindings)]
+ (aliases (map gensym vars))
+ [e2 (cons aliases e)]
+ (se2 (append (map cons vars aliases) se))
+ [body (##sys#compile-to-closure
+ (##sys#canonicalize-body (cddr x) se2 #f)
+ e2
+ se2
+ cntr) ] )
+ (case n
+ [(1) (let ([val (compile (cadar bindings) e (car vars) tf cntr se)])
+ (lambda (v)
+ (##core#app body (cons (vector (##core#app val v)) v)) ) ) ]
+ [(2) (let ([val1 (compile (cadar bindings) e (car vars) tf cntr se)]
+ [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se)] )
+ (lambda (v)
+ (##core#app body (cons (vector (##core#app val1 v) (##core#app val2 v)) v)) ) ) ]
+ [(3) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se)]
+ [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se)]
+ [t (cddr bindings)]
+ [val3 (compile (cadar t) e (caddr vars) tf cntr se)] )
+ (lambda (v)
+ (##core#app
+ body
+ (cons (vector (##core#app val1 v) (##core#app val2 v) (##core#app val3 v)) v)) ) ) ]
+ [(4) (let* ([val1 (compile (cadar bindings) e (car vars) tf cntr se)]
+ [val2 (compile (cadadr bindings) e (cadr vars) tf cntr se)]
+ [t (cddr bindings)]
+ [val3 (compile (cadar t) e (caddr vars) tf cntr se)]
+ [val4 (compile (cadadr t) e (cadddr vars) tf cntr se)] )
+ (lambda (v)
+ (##core#app
+ body
+ (cons (vector (##core#app val1 v)
+ (##core#app val2 v)
+ (##core#app val3 v)
+ (##core#app val4 v))
+ v)) ) ) ]
+ [else
+ (let ([vals (map (lambda (x) (compile (cadr x) e (car x) tf cntr se)) bindings)])
+ (lambda (v)
+ (let ([v2 (##sys#make-vector n)])
+ (do ([i 0 (fx+ i 1)]
+ [vlist vals (##sys#slot vlist 1)] )
+ ((fx>= i n))
+ (##sys#setslot v2 i (##core#app (##sys#slot vlist 0) v)) )
+ (##core#app body (cons v2 v)) ) ) ) ] ) ) ]
+
+ ((letrec ##core#letrec)
+ (##sys#check-syntax 'letrec x '(_ #((symbol _) 0) . #(_ 1)))
+ (let ((bindings (cadr x))
+ (body (cddr x)) )
+ (compile
+ `(##core#let
+ ,(##sys#map (lambda (b)
+ (list (car b) '(##core#undefined)))
+ bindings)
+ ,@(##sys#map (lambda (b)
+ `(##core#set! ,(car b) ,(cadr b)))
+ bindings)
+ (##core#let () ,@body) )
+ e h tf cntr se)))
+
+ [(lambda ##core#lambda)
+ (##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f se)
+ (let* ([llist (cadr x)]
+ [body (cddr x)]
+ [info (cons (or h '?) llist)] )
+ (when (##sys#extended-lambda-list? llist)
+ (set!-values
+ (llist body)
+ (##sys#expand-extended-lambda-list
+ llist body ##sys#syntax-error-hook se) ) )
+ (##sys#decompose-lambda-list
+ llist
+ (lambda (vars argc rest)
+ (let* ((aliases (map gensym vars))
+ (se2 (append (map cons vars aliases) se))
+ (e2 (cons aliases e))
+ (body
+ (##sys#compile-to-closure
+ (##sys#canonicalize-body body se2 #f)
+ e2
+ se2
+ (or h cntr) ) ) )
+ (case argc
+ [(0) (if rest
+ (lambda (v)
+ (decorate
+ (lambda r
+ (##core#app body (cons (vector r) v)))
+ info h cntr) )
+ (lambda (v)
+ (decorate
+ (lambda () (##core#app body (cons #f v)))
+ info h cntr) ) ) ]
+ [(1) (if rest
+ (lambda (v)
+ (decorate
+ (lambda (a1 . r)
+ (##core#app body (cons (vector a1 r) v)))
+ info h cntr) )
+ (lambda (v)
+ (decorate
+ (lambda (a1)
+ (##core#app body (cons (vector a1) v)))
+ info h cntr) ) ) ]
+ [(2) (if rest
+ (lambda (v)
+ (decorate
+ (lambda (a1 a2 . r)
+ (##core#app body (cons (vector a1 a2 r) v)))
+ info h cntr) )
+ (lambda (v)
+ (decorate
+ (lambda (a1 a2)
+ (##core#app body (cons (vector a1 a2) v)))
+ info h cntr) ) ) ]
+ [(3) (if rest
+ (lambda (v)
+ (decorate
+ (lambda (a1 a2 a3 . r)
+ (##core#app body (cons (vector a1 a2 a3 r) v)))
+ info h cntr) )
+ (lambda (v)
+ (decorate
+ (lambda (a1 a2 a3)
+ (##core#app body (cons (vector a1 a2 a3) v)))
+ info h cntr) ) ) ]
+ [(4) (if rest
+ (lambda (v)
+ (decorate
+ (lambda (a1 a2 a3 a4 . r)
+ (##core#app body (cons (vector a1 a2 a3 a4 r) v)))
+ info h cntr) )
+ (lambda (v)
+ (decorate
+ (lambda (a1 a2 a3 a4)
+ (##core#app body (##sys#cons (##sys#vector a1 a2 a3 a4) v)))
+ info h cntr) ) ) ]
+ [else
+ (if rest
+ (lambda (v)
+ (decorate
+ (lambda as
+ (##core#app
+ body
+ (##sys#cons (apply ##sys#vector (fudge-argument-list argc as)) v)) )
+ info h cntr) )
+ (lambda (v)
+ (decorate
+ (lambda as
+ (let ([len (length as)])
+ (if (not (fx= len argc))
+ (##sys#error "bad argument count" argc len)
+ (##core#app body (##sys#cons (apply ##sys#vector as) v)))))
+ info h cntr) ) ) ] ) ) ) ) ) ]
+
+ ((let-syntax)
+ (##sys#check-syntax 'let-syntax x '(let-syntax #((variable _) 0) . #(_ 1)) #f se)
+ (let ((se2 (append
+ (map (lambda (b)
+ (list
+ (car b)
+ se
+ (##sys#er-transformer
+ (eval/meta (cadr b)))))
+ (cadr x) )
+ se) ) )
+ (compile
+ (##sys#canonicalize-body (cddr x) se2 #f)
+ e #f tf cntr se2)))
+
+ ((letrec-syntax)
+ (##sys#check-syntax 'letrec-syntax x '(letrec-syntax #((variable _) 0) . #(_ 1)) #f se)
+ (let* ((ms (map (lambda (b)
+ (list
+ (car b)
+ #f
+ (##sys#er-transformer
+ (eval/meta (cadr b)))))
+ (cadr x) ) )
+ (se2 (append ms se)) )
+ (for-each
+ (lambda (sb)
+ (set-car! (cdr sb) se2) )
+ ms)
+ (compile
+ (##sys#canonicalize-body (cddr x) se2 #f)
+ e #f tf cntr se2)))
+
+ ((define-syntax define-compiled-syntax)
+ (##sys#check-syntax
+ 'define-syntax x
+ (if (and (pair? (cdr x)) (pair? (cadr x)))
+ '(_ (variable . lambda-list) . #(_ 1))
+ '(_ variable _))
+ #f se)
+ (let* ((var (if (pair? (cadr x)) (caadr x) (cadr x)))
+ (body (if (pair? (cadr x))
+ `(,(rename 'lambda se) ,(cdadr x) ,@(cddr x))
+ (caddr x)))
+ (name (rename var se)))
+ (##sys#register-syntax-export
+ name (##sys#current-module)
+ body) ;*** not really necessary, it only shouldn't be #f
+ (##sys#extend-macro-environment
+ name
+ (##sys#current-environment)
+ (##sys#er-transformer (eval/meta body)))
+ (compile '(##core#undefined) e #f tf cntr se) ) )
+
+ ((##core#define-compiler-syntax)
+ (compile '(##core#undefined) e #f tf cntr se))
+
+ ((##core#let-compiler-syntax)
+ (compile
+ (##sys#canonicalize-body (cddr x) se #f)
+ e #f tf cntr se))
+
+ ((##core#module)
+ (let* ((name (##sys#strip-syntax (cadr x)))
+ (exports
+ (or (eq? #t (caddr x))
+ (map (lambda (exp)
+ (cond ((symbol? exp) exp)
+ ((and (pair? exp)
+ (let loop ((exp exp))
+ (or (null? exp)
+ (and (symbol? (car exp))
+ (loop (cdr exp))))))
+ exp)
+ (else
+ (##sys#syntax-error-hook
+ 'module
+ "invalid export syntax" exp name))))
+ (##sys#strip-syntax (caddr x))))))
+ (when (##sys#current-module)
+ (##sys#syntax-error-hook 'module "modules may not be nested" name))
+ (parameterize ((##sys#current-module
+ (##sys#register-module name exports))
+ (##sys#current-environment '())
+ (##sys#macro-environment ##sys#initial-macro-environment))
+ (let loop ((body (cdddr x)) (xs '()))
+ (if (null? body)
+ (let ((xs (reverse xs)))
+ (##sys#finalize-module (##sys#current-module))
+ (lambda (v)
+ (let loop2 ((xs xs))
+ (if (null? xs)
+ (##sys#void)
+ (let ((n (##sys#slot xs 1)))
+ (cond ((pair? n)
+ ((##sys#slot xs 0) v)
+ (loop2 n))
+ (else
+ ((##sys#slot xs 0) v))))))))
+ (loop
+ (cdr body)
+ (cons (compile
+ (car body)
+ '() #f tf cntr
+ (##sys#current-environment))
+ xs))))) ) )
+
+ [(##core#loop-lambda)
+ (compile `(,(rename 'lambda se) ,@(cdr x)) e #f tf cntr se) ]
+
+ [(##core#named-lambda)
+ (compile `(,(rename 'lambda se) ,@(cddr x)) e (cadr x) tf cntr se) ]
+
+ [(##core#require-for-syntax)
+ (let ([ids (map (lambda (x)
+ (eval/meta x))
+ (cdr x))])
+ (apply ##sys#require ids)
+ (let ([rs (##sys#lookup-runtime-requirements ids)])
+ (compile
+ (if (null? rs)
+ '(##core#undefined)
+ `(##sys#require ,@(map (lambda (x) `',x) rs)) )
+ e #f tf cntr se) ) ) ]
+
+ [(##core#require-extension)
+ (let ((imp? (caddr x)))
+ (compile
+ (let loop ([ids (cadr x)])
+ (if (null? ids)
+ '(##core#undefined)
+ (let-values ([(exp _)
+ (##sys#do-the-right-thing (car ids) #f imp?)])
+ `(##core#begin ,exp ,(loop (cdr ids))) ) ) )
+ e #f tf cntr se) ) ]
+
+ [(##core#elaborationtimeonly ##core#elaborationtimetoo) ; <- Note this!
+ (eval/meta (cadr x))
+ (compile '(##core#undefined) e #f tf cntr se) ]
+
+ [(##core#compiletimetoo)
+ (compile (cadr x) e #f tf cntr se) ]
+
+ [(##core#compiletimeonly ##core#callunit)
+ (compile '(##core#undefined) e #f tf cntr se) ]
+
+ [(##core#declare)
+ (if (memq #:compiling ##sys#features)
+ (for-each (lambda (d) (##compiler#process-declaration d se)) (cdr x))
+ (##sys#warn "declarations are ignored in interpreted code" x) )
+ (compile '(##core#undefined) e #f tf cntr se) ]
+
+ [(define-inline define-constant)
+ (compile `(,(rename 'define se) ,@(cdr x)) e #f tf cntr se) ]
+
+ [(##core#primitive ##core#inline ##core#inline_allocate ##core#foreign-lambda
+ ##core#define-foreign-variable
+ ##core#define-external-variable ##core#let-location
+ ##core#foreign-primitive
+ ##core#foreign-lambda* ##core#define-foreign-type)
+ (##sys#syntax-error-hook "cannot evaluate compiler-special-form" x) ]
+
+ [(##core#app)
+ (compile-call (cdr x) e tf cntr se) ]
+
+ [else
+ (cond [(eq? head 'location)
+ (##sys#syntax-error-hook "cannot evaluate compiler-special-form" x) ]
+
+ [else (compile-call x e tf cntr se)] ) ] ) ) ) ) ]
+
+ [else
+ (emit-syntax-trace-info tf x cntr)
+ (compile-call x e tf cntr se)] ) )
+
+ (define (fudge-argument-list n alst)
+ (if (null? alst)
+ (list alst)
+ (do ((n n (fx- n 1))
+ (c 0 (fx+ c 1))
+ (args alst
+ (if (eq? '() args)
+ (##sys#error "bad argument count" n c)
+ (##sys#slot args 1)))
+ (last #f args) )
+ ((fx= n 0)
+ (##sys#setslot last 1 (list args))
+ alst) ) ) )
+
+ (define (checked-length lst)
+ (let loop ([lst lst] [n 0])
+ (cond [(null? lst) n]
+ [(pair? lst) (loop (##sys#slot lst 1) (fx+ n 1))]
+ [else #f] ) ) )
+
+ (define (compile-call x e tf cntr se)
+ (let* ([fn (compile (##sys#slot x 0) e #f tf cntr se)]
+ [args (##sys#slot x 1)]
+ [argc (checked-length args)]
+ [info x] )
+ (case argc
+ [(#f) (##sys#syntax-error-hook "malformed expression" x)]
+ [(0) (lambda (v)
+ (emit-trace-info tf info cntr)
+ ((fn v)))]
+ [(1) (let ([a1 (compile (##sys#slot args 0) e #f tf cntr se)])
+ (lambda (v)
+ (emit-trace-info tf info cntr)
+ ((##core#app fn v) (##core#app a1 v))) ) ]
+ [(2) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
+ [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)] )
+ (lambda (v)
+ (emit-trace-info tf info cntr)
+ ((##core#app fn v) (##core#app a1 v) (##core#app a2 v))) ) ]
+ [(3) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
+ [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)]
+ [a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se)] )
+ (lambda (v)
+ (emit-trace-info tf info cntr)
+ ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v))) ) ]
+ [(4) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
+ [a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)]
+ [a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se)]
+ [a4 (compile (##core#inline "C_u_i_list_ref" args 3) e #f tf cntr se)] )
+ (lambda (v)
+ (emit-trace-info tf info cntr)
+ ((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v) (##core#app a4 v))) ) ]
+ [else (let ([as (##sys#map (lambda (a) (compile a e #f tf cntr se)) args)])
+ (lambda (v)
+ (emit-trace-info tf info cntr)
+ (apply (##core#app fn v) (##sys#map (lambda (a) (##core#app a v)) as))) ) ] ) ) )
+
+ (compile exp env #f (fx> ##sys#eval-debug-level 0) cntr se) ) ) )
+
+(define ##sys#eval-handler
+ (make-parameter
+ (lambda (x . env)
+ (let ([mut ##sys#environment-is-mutable]
+ [e #f] )
+ (when (pair? env)
+ (let ([env (car env)])
+ (when env
+ (##sys#check-structure env 'environment)
+ (set! e (##sys#slot env 1))
+ (set! mut (##sys#slot env 2)) ) ) )
+ ((fluid-let ([##sys#environment-is-mutable mut]
+ [##sys#eval-environment e] )
+ (##sys#compile-to-closure x '() (##sys#current-environment)) )
+ '() ) ) ) ) )
+
+(define eval-handler ##sys#eval-handler)
+
+(define (eval x . env)
+ (apply (##sys#eval-handler)
+ x
+ env) )
+
+;;; Split lambda-list into its parts:
+
+(define ##sys#decompose-lambda-list
+ (let ([reverse reverse])
+ (lambda (llist0 k)
+
+ (define (err)
+ (set! ##sys#syntax-error-culprit #f)
+ (##sys#syntax-error-hook "illegal lambda-list syntax" llist0) )
+
+ (let loop ([llist llist0] [vars '()] [argc 0])
+ (cond [(eq? llist '()) (k (reverse vars) argc #f)]
+ [(not (##core#inline "C_blockp" llist)) (err)]
+ [(##core#inline "C_symbolp" llist) (k (reverse (cons llist vars)) argc llist)]
+ [(not (##core#inline "C_pairp" llist)) (err)]
+ [else (loop (##sys#slot llist 1)
+ (cons (##sys#slot llist 0) vars)
+ (fx+ argc 1) ) ] ) ) ) ) )
+
+
+;;; Loading source/object files:
+
+(define load-verbose (make-parameter (##sys#fudge 13)))
+
+(define (##sys#abort-load) #f)
+(define ##sys#current-source-filename #f)
+(define ##sys#current-load-path "")
+(define ##sys#dload-disabled #f)
+
+(define-foreign-variable _dlerror c-string "C_dlerror")
+
+(define dynamic-load-mode)
+(define set-dynamic-load-mode!) ;DEPRECATED
+(let ()
+
+ (define (dynamic-load-flags->mode flags)
+ (and flags
+ (list (if (car flags) 'now 'lazy) (if (cadr flags) 'global 'local)) ) )
+
+ (define (dynamic-load-mode->flags mode)
+ (let ((mode (if (pair? mode) mode (list mode)))
+ (now #f)
+ (global #t) )
+ (let loop ((mode mode))
+ (when (pair? mode)
+ (case (car mode)
+ ((global) (set! global #t))
+ ((local) (set! global #f))
+ ((lazy) (set! now #f))
+ ((now) (set! now #t))
+ (else
+ (##sys#signal-hook 'set-dynamic-load-mode! "invalid dynamic-load mode" (car mode)) ) )
+ (loop (cdr mode)) ) )
+ (list now global) ) )
+
+ (set! dynamic-load-mode
+ (make-parameter (dynamic-load-flags->mode (##sys#dlopen-flags))
+ (lambda (x)
+ (cond ((or (pair? x) (symbol? x))
+ (apply ##sys#set-dlopen-flags! (dynamic-load-mode->flags x))
+ (dynamic-load-flags->mode (##sys#dlopen-flags)) )
+ (else
+ '(lazy global) ) ) ) ) )
+
+ (set! set-dynamic-load-mode! (lambda (mode) (dynamic-load-mode mode) ) ) )
+
+(let ([read read]
+ [write write]
+ [display display]
+ [newline newline]
+ (flush-output flush-output)
+ [eval eval]
+ [open-input-file open-input-file]
+ [close-input-port close-input-port]
+ [string-append string-append]
+ [load-verbose load-verbose]
+ [topentry (##sys#make-c-string "C_toplevel")] )
+ (define (has-sep? str)
+ (let loop ([i (fx- (##sys#size str) 1)])
+ (and (not (zero? i))
+ (if (memq (##core#inline "C_subchar" str i) '(#\\ #\/))
+ i
+ (loop (fx- i 1)) ) ) ) )
+ (define (badfile x)
+ (##sys#signal-hook #:type-error 'load "bad argument type - not a port or string" x) )
+ (set! ##sys#load
+ (lambda (input evaluator pf #!optional timer printer)
+ (when (string? input)
+ (set! input (##sys#expand-home-path input)) )
+ (let* ([isdir #f]
+ [fname
+ (cond [(port? input) #f]
+ [(not (string? input)) (badfile input)]
+ [(and-let* ([info (##sys#file-info input)]
+ [id (##sys#slot info 4)] )
+ (set! isdir (eq? 1 id))
+ (not isdir) )
+ input]
+ [else
+ (let ([fname2 (##sys#string-append input ##sys#load-dynamic-extension)])
+ (if (and (not ##sys#dload-disabled)
+ (##sys#fudge 24) ; dload?
+ (##sys#file-info fname2))
+ fname2
+ (let ([fname3 (##sys#string-append input source-file-extension)])
+ (if (##sys#file-info fname3)
+ fname3
+ (and (not isdir) input) ) ) ) ) ] ) ]
+ [evproc (or evaluator eval)] )
+ (cond [(and (string? input) (not fname))
+ (##sys#signal-hook #:file-error 'load "cannot open file" input) ]
+ [(and (load-verbose) fname)
+ (display "; loading ")
+ (display fname)
+ (display " ...\n")
+ (flush-output)] )
+ (or (and fname
+ (or (##sys#dload (##sys#make-c-string fname) topentry #t)
+ (and (not (has-sep? fname))
+ (##sys#dload (##sys#make-c-string (##sys#string-append "./" fname)) topentry #t) ) ) )
+ (call-with-current-continuation
+ (lambda (abrt)
+ (fluid-let ([##sys#read-error-with-line-number #t]
+ [##sys#current-source-filename fname]
+ [##sys#current-load-path
+ (and fname
+ (let ((i (has-sep? fname)))
+ (if i (##sys#substring fname 0 (fx+ i 1)) "") ) ) ]
+ [##sys#abort-load (lambda () (abrt #f))] )
+ (let ([in (if fname (open-input-file fname) input)])
+ (##sys#dynamic-wind
+ (lambda () #f)
+ (lambda ()
+ (let ([c1 (peek-char in)])
+ (when (char=? c1 (integer->char 127))
+ (##sys#error 'load "unable to load compiled module" fname _dlerror) ) )
+ (let ((x1 (read in)))
+ (do ((x x1 (read in)))
+ ((eof-object? x))
+ (when printer (printer x))
+ (##sys#call-with-values
+ (lambda ()
+ (if timer
+ (time (evproc x))
+ (evproc x) ) )
+ (lambda results
+ (when pf
+ (for-each
+ (lambda (r)
+ (write r)
+ (newline) )
+ results) ) ) ) ) ) )
+ (lambda () (close-input-port in)) ) ) ) ) ) )
+ (##core#undefined) ) ) )
+ (set! load
+ (lambda (filename . evaluator)
+ (##sys#load filename (optional evaluator #f) #f) ) )
+ (set! load-relative
+ (lambda (filename . evaluator)
+ (##sys#load
+ (if (memq (string-ref filename 0) '(#\\ #\/))
+ filename
+ (##sys#string-append ##sys#current-load-path filename) )
+ (optional evaluator #f) #f) ) )
+ (set! load-noisily
+ (lambda (filename #!key (evaluator #f) (time #f) (printer #f))
+ (##sys#load filename evaluator #t time printer) ) ) )
+
+(define ##sys#load-library-extension ; this is crude...
+ (cond [(eq? (software-type) 'windows) windows-load-library-extension]
+ [(eq? (software-version) 'macosx) macosx-load-library-extension]
+ [(and (eq? (software-version) 'hpux)
+ (eq? (machine-type) 'hppa)) hppa-load-library-extension]
+ [else default-load-library-extension] ) )
+
+(define ##sys#load-dynamic-extension default-load-library-extension)
+
+(define ##sys#default-dynamic-load-libraries
+ (case (build-platform)
+ ((cygwin) cygwin-default-dynamic-load-libraries)
+ (else default-dynamic-load-libraries) ) )
+
+(define dynamic-load-libraries
+ (let ((ext
+ (if (and (memq (software-version) '(linux netbsd openbsd freebsd))
+ (not (zero? binary-version))) ; allow "configless" build
+ (string-append
+ ##sys#load-library-extension
+ "."
+ (number->string binary-version))
+ ##sys#load-library-extension)))
+ (define complete
+ (cut ##sys#string-append <> ext))
+ (make-parameter
+ (map complete ##sys#default-dynamic-load-libraries)
+ (lambda (x)
+ (##sys#check-list x)
+ x) ) ) )
+
+(define ##sys#load-library-0
+ (let ([load-verbose load-verbose]
+ [string-append string-append]
+ [dynamic-load-libraries dynamic-load-libraries]
+ [display display] )
+ (lambda (uname lib)
+ (let ([id (##sys#->feature-id uname)])
+ (or (memq id ##sys#features)
+ (let ([libs
+ (if lib
+ (##sys#list lib)
+ (cons (##sys#string-append (##sys#slot uname 1) ;symbol pname
+ ##sys#load-library-extension)
+ (dynamic-load-libraries) ) ) ]
+ [top
+ (##sys#make-c-string
+ (string-append
+ "C_"
+ (##sys#string->c-identifier (##sys#slot uname 1))
+ "_toplevel") ) ] )
+ (when (load-verbose)
+ (display "; loading library ")
+ (display uname)
+ (display " ...\n") )
+ (let loop ([libs libs])
+ (cond [(null? libs) #f]
+ [(##sys#dload (##sys#make-c-string (##sys#slot libs 0)) top #f)
+ ; Cannot be in features yet but check anyway
+ (unless (memq id ##sys#features)
+ (set! ##sys#features (cons id ##sys#features)) )
+ #t]
+ [else (loop (##sys#slot libs 1))] ) ) ) ) ) ) ) )
+
+(define ##sys#load-library
+ (lambda (uname . lib)
+ (##sys#check-symbol uname 'load-library)
+ (or (##sys#load-library-0 uname (and (pair? lib) (car lib)))
+ (##sys#error 'load-library "unable to load library" uname _dlerror) ) ) )
+
+(define load-library ##sys#load-library)
+
+(define (loaded-libraries)
+ ; Ignore the names of explicitly loaded library units
+ (let loop ((ils (##sys#dynamic-library-names)) (ols '()))
+ (if (null? ils)
+ ols
+ (let ((nam (car ils)))
+ (loop (cdr ils) (if (member nam (dynamic-load-libraries)) ols (cons nam ols))) ) ) ) )
+
+(define (dynamic-library-load name #!optional (err? #t))
+ (##sys#check-string name 'dynamic-library-load)
+ (or (##sys#dynamic-library-load name)
+ (and err?
+ (##sys#error 'dynamic-library-load "cannot load dynamic library" name _dlerror) ) ) )
+
+;; (dynamic-library-procedure mname sname handler [error?]) => procedure/n
+;; (dynamic-library-variable mname sname handler [error?]) => procedure/n
+;;
+;; The 'procedure/n' invokes the handler on (mname sname mname+sname-ptr n-args).
+;; A symbol 'sname' is converted to a string.
+;;
+;; Will attempt to load (global lazy) the library should the attempt to
+;; resolve the symbol fail. Either this succeeds and the symbol is then
+;; resolved, or an error will be signaled.
+
+(define dynamic-library-procedure)
+(define dynamic-library-variable)
+(let ()
+
+ (define (checked-pointer loc ptrfnc mname sname err?)
+ (or (ptrfnc mname sname)
+ (and (parameterize ((dynamic-load-mode '(lazy global)))
+ (dynamic-library-load mname err?))
+ (ptrfnc mname sname) )
+ (and err?
+ (##sys#error loc "cannot resolve dynamic library symbol" mname sname _dlerror) ) ) )
+
+ (define (dynlibsym loc ptrfnc mname sname handler err?)
+ (##sys#check-string mname loc)
+ (##sys#check-closure handler loc)
+ (let ((sname (if (symbol? sname) (symbol->string sname) sname)))
+ (##sys#check-string sname loc)
+ (and-let* ((ptr (checked-pointer loc ptrfnc mname sname err?)))
+ (lambda args (handler mname sname ptr args)) ) ) )
+
+ (set! dynamic-library-procedure
+ (lambda (mname sname handler #!optional (err? #t))
+ (dynlibsym 'dynamic-library-procedure
+ ##sys#dynamic-library-procedure-pointer mname sname handler err?) ) )
+
+ (set! dynamic-library-variable
+ (lambda (mname sname handler #!optional (err? #t))
+ (dynlibsym 'dynamic-library-variable
+ ##sys#dynamic-library-variable-pointer mname sname handler err?) ) ) )
+
+
+;;; Extensions:
+
+(define ##sys#canonicalize-extension-path
+ (let ([string-append string-append])
+ (lambda (id loc)
+ (define (err) (##sys#error loc "invalid extension path" id))
+ (define (sep? c) (or (char=? #\\ c) (char=? #\/ c)))
+ (let ([p (cond [(string? id) id]
+ [(symbol? id) (##sys#symbol->string id)]
+ [(list? id)
+ (let loop ([id id])
+ (if (null? id)
+ ""
+ (string-append
+ (let ([id0 (##sys#slot id 0)])
+ (cond [(symbol? id0) (##sys#symbol->string id0)]
+ [(string? id0) id0]
+ [else (err)] ) )
+ (if (null? (##sys#slot id 1))
+ ""
+ "/")
+ (loop (##sys#slot id 1)) ) ) ) ] ) ] )
+ (let check ([p p])
+ (let ([n (##sys#size p)])
+ (cond [(fx= 0 n) (err)]
+ [(sep? (string-ref p 0))
+ (check (##sys#substring p 1 n)) ]
+ [(sep? (string-ref p (fx- n 1)))
+ (check (##sys#substring p 0 (fx- n 1))) ]
+ [else p] ) ) ) ) ) ) )
+
+(define ##sys#repository-path
+ (make-parameter
+ (or (get-environment-variable repository-environment-variable)
+ (##sys#chicken-prefix
+ (##sys#string-append
+ "lib/chicken/"
+ (##sys#number->string (or (##sys#fudge 42) default-binary-version)) ) )
+ install-egg-home) ) )
+
+(define repository-path ##sys#repository-path)
+
+(define ##sys#setup-mode #f)
+
+(define ##sys#find-extension
+ (let ((file-exists? file-exists?)
+ (string-append string-append) )
+ (lambda (p inc?)
+ (let ((rp (##sys#repository-path)))
+ (define (check path)
+ (let ((p0 (string-append path "/" p)))
+ (and (or (and rp
+ (not ##sys#dload-disabled)
+ (##sys#fudge 24) ; dload?
+ (file-exists? (##sys#string-append p0 ##sys#load-dynamic-extension)))
+ (file-exists? (##sys#string-append p0 source-file-extension)) )
+ p0) ) )
+ (let loop ((paths (##sys#append
+ (if ##sys#setup-mode '(".") '())
+ (if rp (list rp) '())
+ (if inc? ##sys#include-pathnames '())
+ (if ##sys#setup-mode '() '("."))) ))
+ (and (pair? paths)
+ (let ((pa (##sys#slot paths 0)))
+ (or (check pa)
+ (loop (##sys#slot paths 1)) ) ) ) ) ) ) ))
+
+(define ##sys#loaded-extensions '())
+
+(define ##sys#load-extension
+ (let ((string->symbol string->symbol))
+ (lambda (id loc #!optional (err? #t))
+ (cond ((string? id) (set! id (string->symbol id)))
+ (else (##sys#check-symbol id loc)) )
+ (let ([p (##sys#canonicalize-extension-path id loc)])
+ (cond ((member p ##sys#loaded-extensions))
+ ((memq id ##sys#core-library-modules)
+ (or (##sys#load-library-0 id #f)
+ (and err?
+ (##sys#error loc "cannot load core library" id))))
+ (else
+ (let ([id2 (##sys#find-extension p #t)])
+ (cond (id2
+ (##sys#load id2 #f #f)
+ (set! ##sys#loaded-extensions (cons p ##sys#loaded-extensions))
+ #t)
+ (err? (##sys#error loc "cannot load extension" id))
+ (else #f) ) ) ) ) ) ) ) )
+
+(define (##sys#provide . ids)
+ (for-each
+ (lambda (id)
+ (##sys#check-symbol id 'provide)
+ (let ([p (##sys#canonicalize-extension-path id 'provide)])
+ (set! ##sys#loaded-extensions (cons p ##sys#loaded-extensions)) ) )
+ ids) )
+
+(define provide ##sys#provide)
+
+(define (##sys#provided? id)
+ (and (member (##sys#canonicalize-extension-path id 'provided?) ##sys#loaded-extensions)
+ #t) )
+
+(define provided? ##sys#provided?)
+
+(define ##sys#require
+ (lambda ids
+ (for-each
+ (cut ##sys#load-extension <> 'require)
+ ids) ) )
+
+(define require ##sys#require)
+
+(define ##sys#extension-information
+ (let ([with-input-from-file with-input-from-file]
+ [file-exists? file-exists?]
+ [string-append string-append]
+ [read read] )
+ (lambda (id loc)
+ (and-let* ((rp (##sys#repository-path)))
+ (let* ((p (##sys#canonicalize-extension-path id loc))
+ (rpath (string-append rp "/" p ".")) )
+ (cond ((file-exists? (string-append rpath setup-file-extension))
+ => (cut with-input-from-file <> read) )
+ (else #f) ) ) ) ) ))
+
+(define (extension-information ext)
+ (##sys#extension-information ext 'extension-information) )
+
+(define ##sys#lookup-runtime-requirements
+ (let ([with-input-from-file with-input-from-file]
+ [read read] )
+ (lambda (ids)
+ (let loop1 ([ids ids])
+ (if (null? ids)
+ '()
+ (append
+ (or (and-let* ([info (##sys#extension-information (car ids) #f)]
+ [a (assq 'require-at-runtime info)] )
+ (cdr a) )
+ '() )
+ (loop1 (cdr ids)) ) ) ) ) ) )
+
+(define ##sys#do-the-right-thing
+ (let ((vector->list vector->list))
+ (lambda (id comp? imp?)
+ (define (add-req id syntax?)
+ (when comp?
+ (##sys#hash-table-update!
+ ##compiler#file-requirements
+ (if syntax? 'dynamic/syntax 'dynamic)
+ (cut lset-adjoin eq? <> id) ;XXX assumes compiler has srfi-1 loaded
+ (lambda () (list id)))))
+ (define (impform x id builtin?)
+ `(##core#begin
+ ,x
+ ,@(if (and imp? (or (not builtin?) (##sys#current-module)))
+ `((import ,id)) ;XXX make hygienic
+ '())))
+ (define (doit id)
+ (cond ((or (memq id builtin-features)
+ (if comp?
+ (memq id builtin-features/compiled)
+ (##sys#feature? id) ) )
+ (values (impform '(##core#undefined) id #t) #t) )
+ ((memq id ##sys#core-library-modules)
+ (values
+ (impform
+ (if comp?
+ `(##core#declare (uses ,id))
+ `(##sys#load-library ',id #f) )
+ id #t)
+ #t) )
+ ((memq id ##sys#explicit-library-modules)
+ (let* ((info (##sys#extension-information id 'require-extension))
+ (s (assq 'syntax info)))
+ (values
+ `(##core#begin
+ ,@(if s `((##core#require-for-syntax ',id)) '())
+ ,(impform
+ (if comp?
+ `(##core#declare (uses ,id))
+ `(##sys#load-library ',id #f) )
+ id #f))
+ #t) ) )
+ (else
+ (let ((info (##sys#extension-information id 'require-extension)))
+ (cond (info
+ (let ((s (assq 'syntax info))
+ (rr (assq 'require-at-runtime info)) )
+ (when s (add-req id #t))
+ (values
+ (impform
+ `(##core#begin
+ ,@(if s `((##core#require-for-syntax ',id)) '())
+ ,@(if (and (not rr) s)
+ '()
+ `((##sys#require
+ ,@(map (lambda (id) `',id)
+ (cond (rr (cdr rr))
+ (else (list id)) ) ) ) ) ) )
+ id #f)
+ #t) ) )
+ (else
+ (add-req id #f)
+ (values
+ (impform
+ `(##sys#require ',id)
+ id #f)
+ #f)))))))
+ (if (and (pair? id) (symbol? (car id)))
+ (let ((a (assq (##sys#slot id 0) ##sys#extension-specifiers)))
+ (if a
+ (let ((a ((##sys#slot a 1) id)))
+ (cond ((string? a) (values `(load ,a) #f))
+ ((vector? a)
+ (let loop ((specs (vector->list a))
+ (exps '())
+ (f #f) )
+ (if (null? specs)
+ (values `(##core#begin ,@(reverse exps)) f)
+ (let-values (((exp fi) (##sys#do-the-right-thing (car specs) comp? imp?)))
+ (loop (cdr specs)
+ (cons exp exps)
+ (or fi f) ) ) ) ) )
+ (else (##sys#do-the-right-thing a comp? imp?)) ) )
+ (##sys#error "undefined extension specifier" id) ) )
+ (if (symbol? id)
+ (doit id)
+ (##sys#error "invalid extension specifier" id) ) ) ) ) )
+
+(define ##sys#extension-specifiers '())
+
+(define (set-extension-specifier! name proc)
+ (##sys#check-symbol name 'set-extension-specifier!)
+ (let ([a (assq name ##sys#extension-specifiers)])
+ (if a
+ (let ([old (##sys#slot a 1)])
+ (##sys#setslot a 1 (lambda (spec) (proc spec old))) )
+ (set! ##sys#extension-specifiers
+ (cons (cons name (lambda (spec) (proc spec #f)))
+ ##sys#extension-specifiers)) ) ) )
+
+
+;;; SRFI-55
+
+(set-extension-specifier!
+ 'srfi
+ (let ([list->vector list->vector])
+ (lambda (spec old)
+ (list->vector
+ (let loop ([ids (cdr spec)])
+ (if (null? ids)
+ '()
+ (let ([id (car ids)])
+ (##sys#check-exact id 'require-extension)
+ (cons (##sys#string->symbol (##sys#string-append "srfi-" (number->string id)))
+ (loop (cdr ids)) ) ) ) ) ) ) ) )
+
+
+;;; Version checking
+
+(set-extension-specifier!
+ 'version
+ (lambda (spec _)
+ (define (->string x)
+ (cond ((string? x) x)
+ ((symbol? x) (##sys#slot x 1))
+ ((number? x) (##sys#number->string x))
+ (else (error "invalid extension version" x)) ) )
+ (if (and (list? spec) (fx= 3 (length spec)))
+ (let* ((info (extension-information (cadr spec)))
+ (vv (and info (assq 'version info))) )
+ (unless (and vv (string>=? (->string (car vv)) (->string (caddr spec))))
+ (error "installed extension does not match required version" id vv (caddr spec)))
+ id)
+ (##sys#syntax-error-hook "invalid version specification" spec)) ) )
+
+
+;;; Convert string into valid C-identifier:
+
+(define ##sys#string->c-identifier
+ (let ([string-copy string-copy])
+ (lambda (str)
+ (let* ([s2 (string-copy str)]
+ [n (##sys#size s2)] )
+ (do ([i 0 (fx+ i 1)])
+ ((fx>= i n) s2)
+ (let ([c (##core#inline "C_subchar" s2 i)])
+ (when (and (not (char-alphabetic? c)) (or (not (char-numeric? c)) (fx= i 0)))
+ (##core#inline "C_setsubchar" s2 i #\_) ) ) ) ) ) ) )
+
+
+;;; Environments:
+
+(define ##sys#r4rs-environment (make-vector environment-table-size '()))
+(define ##sys#r5rs-environment #f)
+(define ##sys#interaction-environment (##sys#make-structure 'environment #f #t))
+
+(define (##sys#environment? obj)
+ (and (##sys#structure? obj 'environment) (fx= 3 (##sys#size obj))) )
+
+(define ##sys#copy-env-table
+ (lambda (e mff mf . args)
+ (let ([syms (and (pair? args) (car args))])
+ (let* ([s (##sys#size e)]
+ [e2 (##sys#make-vector s '())] )
+ (do ([i 0 (fx+ i 1)])
+ ((fx>= i s) e2)
+ (##sys#setslot
+ e2 i
+ (let copy ([b (##sys#slot e i)])
+ (if (null? b)
+ '()
+ (let ([bi (##sys#slot b 0)])
+ (let ([sym (##sys#slot bi 0)])
+ (if (or (not syms) (memq sym syms))
+ (cons (vector
+ sym
+ (##sys#slot bi 1)
+ (if mff mf (##sys#slot bi 2)))
+ (copy (##sys#slot b 1)))
+ (copy (##sys#slot b 1)) ) ) ) ) ) ) ) ) ) ) )
+
+(define ##sys#environment-symbols
+ (lambda (env . args)
+ (##sys#check-structure env 'environment)
+ (let ([pred (and (pair? args) (car args))])
+ (let ([envtbl (##sys#slot env 1)])
+ (if envtbl
+ ;then "real" environment
+ (let ([envtblsiz (vector-length envtbl)])
+ (do ([i 0 (fx+ i 1)]
+ [syms
+ '()
+ (let loop ([bucket (vector-ref envtbl i)] [syms syms])
+ (if (null? bucket)
+ syms
+ (let ([sym (vector-ref (car bucket) 0)])
+ (if (or (not pred) (pred sym))
+ (loop (cdr bucket) (cons sym syms))
+ (loop (cdr bucket) syms) ) ) ) )])
+ ((fx>= i envtblsiz) syms) ) )
+ ;else interaction-environment
+ (let ([syms '()])
+ (##sys#walk-namespace
+ (lambda (sym)
+ (when (or (not pred) (pred sym))
+ (set! syms (cons sym syms)) ) ) )
+ syms ) ) ) ) ) )
+
+(define (interaction-environment) ##sys#interaction-environment)
+
+(define scheme-report-environment
+ (lambda (n . mutable)
+ (##sys#check-exact n 'scheme-report-environment)
+ (let ([mf (and (pair? mutable) (car mutable))])
+ (case n
+ [(4) (##sys#make-structure 'environment (##sys#copy-env-table ##sys#r4rs-environment #t mf) mf)]
+ [(5) (##sys#make-structure 'environment (##sys#copy-env-table ##sys#r5rs-environment #t mf) mf)]
+ [else (##sys#error 'scheme-report-environment "no support for version" n)] ) ) ) )
+
+(define null-environment
+ (let ([make-vector make-vector])
+ (lambda (n . mutable)
+ (##sys#check-exact n 'null-environment)
+ (when (or (fx< n 4) (fx> n 5))
+ (##sys#error 'null-environment "no support for version" n) )
+ (##sys#make-structure
+ 'environment
+ (make-vector environment-table-size '())
+ (and (pair? mutable) (car mutable)) ) ) ) )
+
+(let ()
+ (define (initb ht)
+ (lambda (b)
+ (let ([loc (##sys#hash-table-location ht b #t)])
+ (##sys#setslot loc 1 (##sys#slot b 0)) ) ) )
+ (for-each
+ (initb ##sys#r4rs-environment)
+ '(not boolean? eq? eqv? equal? pair? cons car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar
+ cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr cadddr cdaaar cdaadr cdadar cdaddr
+ cddaar cddadr cdddar cddddr set-car! set-cdr! null? list? list length list-tail list-ref
+ append reverse memq memv member assq assv assoc symbol? symbol->string string->symbol
+ number? integer? exact? real? complex? inexact? rational? zero? odd? even? positive? negative?
+ max min + - * / = > < >= <= quotient remainder modulo gcd lcm abs floor ceiling truncate round
+ exact->inexact inexact->exact exp log expt sqrt sin cos tan asin acos atan number->string
+ string->number char? char=? char>? char<? char>=? char<=? char-ci=? char-ci<? char-ci>?
+ char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric? char-upper-case?
+ char-lower-case? char-upcase char-downcase char->integer integer->char string? string=?
+ string>? string<? string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci>=? string-ci<=?
+ make-string string-length string-ref string-set! string-append string-copy string->list
+ list->string substring string-fill! vector? make-vector vector-ref vector-set! string vector
+ vector-length vector->list list->vector vector-fill! procedure? map for-each apply force
+ call-with-current-continuation input-port? output-port? current-input-port current-output-port
+ call-with-input-file call-with-output-file open-input-file open-output-file close-input-port
+ close-output-port load read eof-object? read-char peek-char
+ write display write-char newline with-input-from-file with-output-to-file ##sys#call-with-values
+ ##sys#values ##sys#dynamic-wind ##sys#void
+ ##sys#list->vector ##sys#list ##sys#append ##sys#cons ##sys#make-promise) )
+ (set! ##sys#r5rs-environment (##sys#copy-env-table ##sys#r4rs-environment #t #t))
+ (for-each
+ (initb ##sys#r5rs-environment)
+ '(dynamic-wind values call-with-values eval scheme-report-environment null-environment interaction-environment) ) )
+
+
+;;; Find included file:
+
+(define ##sys#include-pathnames
+ (let ((h (chicken-home)))
+ (if h (list h) '())) )
+
+(define ##sys#resolve-include-filename
+ (let ((string-append string-append) )
+ (define (exists? fname)
+ (let ([info (##sys#file-info fname)])
+ (and info (not (eq? 1 (##sys#slot info 4)))) ) )
+ (lambda (fname prefer-source #!optional repo)
+ (define (test2 fname lst)
+ (if (null? lst)
+ (and (exists? fname) fname)
+ (let ([fn (##sys#string-append fname (car lst))])
+ (if (exists? fn)
+ fn
+ (test2 fname (cdr lst)) ) ) ) )
+ (define (test fname)
+ (test2
+ fname
+ (cond ((not (##sys#fudge 24)) (list source-file-extension)) ; no dload?
+ (prefer-source (list source-file-extension ##sys#load-dynamic-extension))
+ (else (list ##sys#load-dynamic-extension source-file-extension) ) ) ))
+ (or (test fname)
+ (let loop ((paths (if repo
+ (##sys#append
+ ##sys#include-pathnames
+ (let ((rp (##sys#repository-path)))
+ (if rp
+ (list (##sys#repository-path))
+ '())))
+ ##sys#include-pathnames) ) )
+ (cond ((eq? paths '()) fname)
+ ((test (string-append (##sys#slot paths 0)
+ "/"
+ fname) ) )
+ (else (loop (##sys#slot paths 1))) ) ) ) ) ) )
+
+
+;;; Print timing information (support for "time" macro):
+
+(define ##sys#display-times
+ (let* ((display display)
+ (spaces
+ (lambda (n)
+ (do ((i n (fx- i 1)))
+ ((fx<= i 0))
+ (display #\space) ) ) )
+ (display-rj
+ (lambda (x w)
+ (let* ((xs (if (zero? x) "0" (number->string x)))
+ (xslen (##core#inline "C_block_size" xs)) )
+ (spaces (fx- w xslen))
+ (display xs) ) ) ) )
+ (lambda (info)
+ (display-rj (##sys#slot info 0) 8)
+ (display " seconds elapsed\n")
+ (display-rj (##sys#slot info 1) 8)
+ (display " seconds in (major) GC\n")
+ (display-rj (##sys#slot info 2) 8)
+ (display " mutations\n")
+ (display-rj (##sys#slot info 3) 8)
+ (display " minor GCs\n")
+ (display-rj (##sys#slot info 4) 8)
+ (display " major GCs\n") ) ) )
+
+
+;;; SRFI-0 support code:
+
+(set! ##sys#features
+ (append '(#:srfi-8 #:srfi-6 #:srfi-2 #:srfi-0 #:srfi-10 #:srfi-9 #:srfi-55 #:srfi-61)
+ ##sys#features))
+
+
+;;;; Read-Eval-Print loop:
+
+(define ##sys#repl-eval-hook #f)
+(define ##sys#repl-print-length-limit #f)
+(define ##sys#repl-read-hook #f)
+
+(define (##sys#repl-print-hook x port)
+ (##sys#with-print-length-limit ##sys#repl-print-length-limit (cut ##sys#print x #t port))
+ (##sys#write-char-0 #\newline port) )
+
+(define repl-prompt (make-parameter (lambda () "#;> ")))
+
+(define ##sys#read-prompt-hook
+ (let ([repl-prompt repl-prompt])
+ (lambda ()
+ (##sys#print ((repl-prompt)) #f ##sys#standard-output)
+ (##sys#flush-output ##sys#standard-output) ) ) )
+
+(define ##sys#clear-trace-buffer (foreign-lambda void "C_clear_trace_buffer"))
+
+(define repl
+ (let ((eval eval)
+ (read read)
+ (call-with-current-continuation call-with-current-continuation)
+ (print-call-chain print-call-chain)
+ (flush-output flush-output)
+ (load-verbose load-verbose)
+ (reset reset) )
+ (lambda ()
+
+ (define (write-err xs)
+ (for-each (cut ##sys#repl-print-hook <> ##sys#standard-error) xs) )
+
+ (define (write-results xs)
+ (unless (or (null? xs) (eq? (##core#undefined) (car xs)))
+ (for-each (cut ##sys#repl-print-hook <> ##sys#standard-output) xs) ) )
+
+ (let ((stdin ##sys#standard-input)
+ (stdout ##sys#standard-output)
+ (stderr ##sys#standard-error)
+ (ehandler (##sys#error-handler))
+ (rhandler (##sys#reset-handler))
+ (lv #f)
+ (uie ##sys#unbound-in-eval) )
+
+ (define (saveports)
+ (set! stdin ##sys#standard-input)
+ (set! stdout ##sys#standard-output)
+ (set! stderr ##sys#standard-error) )
+
+ (define (resetports)
+ (set! ##sys#standard-input stdin)
+ (set! ##sys#standard-output stdout)
+ (set! ##sys#standard-error stderr) )
+
+ (##sys#dynamic-wind
+ (lambda ()
+ (set! lv (load-verbose))
+ (load-verbose #t)
+ (##sys#error-handler
+ (lambda (msg . args)
+ (resetports)
+ (##sys#print "\nError" #f ##sys#standard-error)
+ (when msg
+ (##sys#print ": " #f ##sys#standard-error)
+ (##sys#print msg #f ##sys#standard-error) )
+ (if (and (pair? args) (null? (cdr args)))
+ (begin
+ (##sys#print ": " #f ##sys#standard-error)
+ (write-err args) )
+ (begin
+ (##sys#write-char-0 #\newline ##sys#standard-error)
+ (write-err args) ) )
+ (print-call-chain ##sys#standard-error)
+ (flush-output ##sys#standard-error) ) ) )
+ (lambda ()
+ (let loop ()
+ (saveports)
+ (call-with-current-continuation
+ (lambda (c)
+ (##sys#reset-handler
+ (lambda ()
+ (set! ##sys#read-error-with-line-number #f)
+ (set! ##sys#enable-qualifiers #t)
+ (resetports)
+ (c #f) ) ) ) )
+ (##sys#read-prompt-hook)
+ (let ([exp ((or ##sys#repl-read-hook read))])
+ (unless (eof-object? exp)
+ (when (char=? #\newline (##sys#peek-char-0 ##sys#standard-input))
+ (##sys#read-char-0 ##sys#standard-input) )
+ (##sys#clear-trace-buffer)
+ (set! ##sys#unbound-in-eval '())
+ (receive result ((or ##sys#repl-eval-hook eval) exp)
+ (when (and ##sys#warnings-enabled (pair? ##sys#unbound-in-eval))
+ (let loop ((vars ##sys#unbound-in-eval) (u '()))
+ (cond ((null? vars)
+ (when (pair? u)
+ (##sys#print
+ "Warning: the following toplevel variables are referenced but unbound:\n"
+ #f ##sys#standard-error)
+ (for-each
+ (lambda (v)
+ (##sys#print " " #f ##sys#standard-error)
+ (##sys#print (car v) #t ##sys#standard-error)
+ (when (cdr v)
+ (##sys#print " (in " #f ##sys#standard-error)
+ (##sys#print (cdr v) #t ##sys#standard-error)
+ (##sys#write-char-0 #\) ##sys#standard-error) )
+ (##sys#write-char-0 #\newline ##sys#standard-error) )
+ u)
+ (##sys#flush-output ##sys#standard-error)))
+ ((or (memq (caar vars) u)
+ (##sys#symbol-has-toplevel-binding? (caar vars)) )
+ (loop (cdr vars) u) )
+ (else (loop (cdr vars) (cons (car vars) u))) ) 9 ) )
+ (write-results result)
+ (loop) ) ) ) ) )
+ (lambda ()
+ (load-verbose lv)
+ (set! ##sys#unbound-in-eval uie)
+ (##sys#error-handler ehandler)
+ (##sys#reset-handler rhandler) ) ) ) ) ) )
+
+
+;;; SRFI-10:
+
+(define ##sys#sharp-comma-reader-ctors (make-vector 301 '()))
+
+(define (define-reader-ctor spec proc)
+ (##sys#check-symbol spec 'define-reader-ctor)
+ (##sys#hash-table-set! ##sys#sharp-comma-reader-ctors spec proc) )
+
+(set! ##sys#user-read-hook
+ (let ((old ##sys#user-read-hook)
+ (read-char read-char)
+ (read read) )
+ (lambda (char port)
+ (cond ((char=? char #\,)
+ (read-char port)
+ (let* ((exp (read port))
+ (err (lambda () (##sys#read-error port "invalid sharp-comma external form" exp))) )
+ (if (or (null? exp) (not (list? exp)))
+ (err)
+ (let ([spec (##sys#slot exp 0)])
+ (if (not (symbol? spec))
+ (err)
+ (let ((ctor (##sys#hash-table-ref ##sys#sharp-comma-reader-ctors spec)))
+ (if ctor
+ (apply ctor (##sys#slot exp 1))
+ (##sys#read-error port "undefined sharp-comma constructor" spec) ) ) ) ) ) ) )
+ (else (old char port)) ) ) ) )
+
+
+;;; Simple invocation API:
+
+(declare
+ (hide last-error run-safe store-result store-string
+ CHICKEN_yield CHICKEN_apply_to_string
+ CHICKEN_eval CHICKEN_eval_string CHICKEN_eval_to_string CHICKEN_eval_string_to_string
+ CHICKEN_apply CHICKEN_eval_apply CHICKEN_eval_to_string
+ CHICKEN_read CHICKEN_load CHICKEN_get_error_message) )
+
+(define last-error #f)
+
+(define (run-safe thunk)
+ (set! last-error #f)
+ (handle-exceptions ex
+ (let ((o (open-output-string)))
+ (print-error-message ex o)
+ (set! last-error (get-output-string o))
+ #f)
+ (thunk) ) )
+
+#>
+#define C_store_result(x, ptr) (*((C_word *)C_block_item(ptr, 0)) = (x), C_SCHEME_TRUE)
+<#
+
+(define (store-result x result)
+ (##sys#gc #f)
+ (when result
+ (##core#inline "C_store_result" x result) )
+ #t)
+
+(define-external (CHICKEN_yield) bool
+ (run-safe (lambda () (begin (thread-yield!) #t))) )
+
+(define-external (CHICKEN_eval (scheme-object exp) ((c-pointer "C_word") result)) bool
+ (run-safe
+ (lambda ()
+ (store-result (eval exp) result) ) ) )
+
+(define-external (CHICKEN_eval_string (c-string str) ((c-pointer "C_word") result)) bool
+ (run-safe
+ (lambda ()
+ (let ([i (open-input-string str)])
+ (store-result (eval (read i)) result)) )))
+
+#>
+#define C_copy_result_string(str, buf, n) (C_memcpy((char *)C_block_item(buf, 0), C_c_string(str), C_unfix(n)), ((char *)C_block_item(buf, 0))[ C_unfix(n) ] = '\0', C_SCHEME_TRUE)
+<#
+
+(define (store-string str bufsize buf)
+ (let ((len (##sys#size str)))
+ (cond ((fx>= len bufsize)
+ (set! last-error "Error: not enough room for result string")
+ #f)
+ (else (##core#inline "C_copy_result_string" str buf len)) ) ) )
+
+(define-external (CHICKEN_eval_to_string (scheme-object exp) ((c-pointer "char") buf)
+ (int bufsize))
+ bool
+ (run-safe
+ (lambda ()
+ (let ([o (open-output-string)])
+ (write (eval exp) o)
+ (store-string (get-output-string o) bufsize buf)) ) ) )
+
+(define-external (CHICKEN_eval_string_to_string (c-string str) ((c-pointer "char") buf)
+ (int bufsize) )
+ bool
+ (run-safe
+ (lambda ()
+ (let ([o (open-output-string)])
+ (write (eval (read (open-input-string str))) o)
+ (store-string (get-output-string o) bufsize buf)) ) ) )
+
+(define-external (CHICKEN_apply (scheme-object func) (scheme-object args)
+ ((c-pointer "C_word") result))
+ bool
+ (run-safe (lambda () (store-result (apply func args) result))) )
+
+(define-external (CHICKEN_apply_to_string (scheme-object func) (scheme-object args)
+ ((c-pointer "char") buf) (int bufsize))
+ bool
+ (run-safe
+ (lambda ()
+ (let ([o (open-output-string)])
+ (write (apply func args) o)
+ (store-string (get-output-string o) bufsize buf)) ) ) )
+
+(define-external (CHICKEN_read (c-string str) ((c-pointer "C_word") result)) bool
+ (run-safe
+ (lambda ()
+ (let ([i (open-input-string str)])
+ (store-result (read i) result) ) ) ) )
+
+(define-external (CHICKEN_load (c-string str)) bool
+ (run-safe (lambda () (load str) #t)) )
+
+(define-external (CHICKEN_get_error_message ((c-pointer "char") buf) (int bufsize)) void
+ (store-string (or last-error "No error") bufsize buf) )
diff --git a/expand.scm b/expand.scm
new file mode 100644
index 00000000..853cf61f
--- /dev/null
+++ b/expand.scm
@@ -0,0 +1,1770 @@
+;;;; expand.scm
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit expand)
+ (disable-interrupts)
+ (fixnum)
+ (hide match-expression
+ macro-alias module-indirect-exports
+ d dd dm dc map-se merge-se
+ lookup check-for-redef)
+ (not inline ##sys#syntax-error-hook ##sys#compiler-syntax-hook
+ ##sys#alias-global-hook ##sys#toplevel-definition-hook))
+
+
+
+(set! ##sys#features
+ (append '(#:hygienic-macros #:syntax-rules) ##sys#features))
+
+(define (d arg1 . more)
+ (when (##sys#fudge 13)
+ (if (null? more)
+ (pp arg1)
+ (apply print arg1 more))) )
+
+(define dd d)
+(define dm d)
+(define dc d)
+
+(cond-expand
+ ((not debugbuild)
+ (declare
+ (no-bound-checks)
+ (no-procedure-checks)))
+ (else))
+
+(begin
+ (define-syntax dd (syntax-rules () ((_ . _) (void))))
+ (define-syntax dm (syntax-rules () ((_ . _) (void))))
+ (define-syntax dc (syntax-rules () ((_ . _) (void)))) )
+
+
+;;; Syntactic environments
+
+(define ##sys#current-environment (make-parameter '()))
+(define ##sys#current-meta-environment (make-parameter '()))
+
+(define (lookup id se)
+ (cond ((assq id se) => cdr)
+ ((##sys#get id '##core#macro-alias))
+ (else #f)))
+
+(define (macro-alias var se)
+ (if (or (##sys#qualified-symbol? var)
+ (let* ((str (##sys#slot var 1))
+ (len (##sys#size str)))
+ (and (fx> len 0)
+ (char=? #\# (##core#inline "C_subchar" str 0)))))
+ var
+ (let* ((alias (gensym var))
+ (ua (or (lookup var se) var)))
+ (##sys#put! alias '##core#macro-alias ua)
+ (##sys#put! alias '##core#real-name var)
+ (dd "aliasing " alias " (real: " var ") to "
+ (if (pair? ua)
+ '<macro>
+ ua))
+ alias) ) )
+
+#+debugbuild
+(define (map-se se)
+ (map (lambda (a)
+ (cons (car a) (if (symbol? (cdr a)) (cdr a) '<macro>)))
+ se))
+
+(define (##sys#strip-syntax exp #!optional se alias)
+ ;; if se is given, retain bound vars
+ (let ((seen '()))
+ (let walk ((x exp))
+ (cond ((assq x seen) => cdr)
+ ((symbol? x)
+ (let ((x2 (if se
+ (lookup x se)
+ (get x '##core#macro-alias) ) ) )
+ (cond ((get x '##core#real-name))
+ ((and alias (not (assq x se)))
+ (##sys#alias-global-hook x #f))
+ ((not x2) x)
+ ((pair? x2) x)
+ (else x2))))
+ ((pair? x)
+ (let ((cell (cons #f #f)))
+ (set! seen (cons (cons x cell) seen))
+ (set-car! cell (walk (car x)))
+ (set-cdr! cell (walk (cdr x)))
+ cell))
+ ((vector? x)
+ (let* ((len (##sys#size x))
+ (vec (make-vector len)))
+ (set! seen (cons (cons x vec) seen))
+ (do ((i 0 (fx+ i 1)))
+ ((fx>= i len) vec)
+ (##sys#setslot vec i (##sys#slot x i)))))
+ (else x)))))
+
+(define strip-syntax ##sys#strip-syntax)
+
+
+;;; Macro handling
+
+(define ##sys#macro-environment (make-parameter '()))
+(define ##sys#chicken-macro-environment '()) ; used later in chicken.import.scm
+(define ##sys#chicken-ffi-macro-environment '()) ; used later in foreign.import.scm
+
+; Workalike of '##sys#environment?' for syntactic environments
+(define (##sys#syntactic-environment? obj)
+
+ (define (simple-environment? obj)
+ (and (list? obj)
+ (or (null? obj)
+ (simple-environment-entry? (car obj))
+ #; ;enough already
+ (call-with-current-continuation
+ (lambda (return)
+ (##sys#for-each
+ (lambda (x) (unless (simple-environment-entry? x) (return #f) ) )
+ obj)
+ #t ) ) ) ) )
+
+ (define (simple-environment-entry? obj)
+ (and (pair? obj)
+ (symbol? (car obj))
+ (symbol? (cdr obj)) ) )
+
+ (define (macro-environment? obj)
+ (and (list? obj)
+ (or (null? obj)
+ (macro-environment-entry? (car obj))
+ #; ;enough already
+ (call-with-current-continuation
+ (lambda (return)
+ (##sys#for-each
+ (lambda (x) (unless (macro-environment-entry? x) (return #f) ) )
+ obj)
+ #t ) ) ) ) )
+
+ (define (macro-environment-entry? obj)
+ (and (pair? obj) (= 3 (length obj))
+ (symbol? (car obj))
+ (list? (cadr obj))
+ #;(##sys#syntactic-environment? (cadr x)) ;enough already
+ (procedure? (caddr obj)) ) )
+
+ (or (simple-environment? obj)
+ (macro-environment? obj) ) )
+
+; Workalike of '##sys#environment-symbols' for syntactic environments
+; (I think :-)
+(define (##sys#syntactic-environment-symbols env pred)
+ (define (try-alias id)
+ (or (##sys#get id '##core#real-name)
+ (let ((alias (##sys#get id '##core#macro-alias)))
+ (cond ((not alias) id)
+ ((pair? alias) id)
+ (else alias) ) ) ) )
+ (let ((syms '()))
+ (##sys#for-each
+ (lambda (cell)
+ (let ((id (car cell)))
+ (cond ((pred id)
+ (set! syms (cons id syms)) )
+ ((try-alias id) =>
+ (lambda (name)
+ (when (pred name) (set! syms (cons name syms))) ) ) ) ) )
+ env)
+ syms ) )
+
+(define (##sys#extend-macro-environment name se handler)
+ (let ((me (##sys#macro-environment)))
+ (cond ((lookup name me) =>
+ (lambda (a)
+ (set-car! a se)
+ (set-car! (cdr a) handler) ) )
+ (else
+ (##sys#macro-environment
+ (cons (list name se handler)
+ me))))))
+
+(define (##sys#copy-macro old new)
+ (let ((def (lookup old (##sys#macro-environment))))
+ (apply ##sys#extend-macro-environment new def) ) )
+
+(define (##sys#macro? sym #!optional (senv (##sys#current-environment)))
+ (or (let ((l (lookup sym senv)))
+ (pair? l))
+ (and-let* ((l (lookup sym (##sys#macro-environment))))
+ (pair? l))))
+
+(define (##sys#unregister-macro name)
+ (##sys#macro-environment
+ ;; this builds up stack, but isn't used often anyway...
+ (let loop ((me (##sys#macro-environment)) (me2 '()))
+ (cond ((null? me) '())
+ ((eq? name (caar me)) (cdr me))
+ (else (cons (car me) (loop (cdr me))))))))
+
+(define (##sys#undefine-macro! name)
+ (##sys#unregister-macro name) )
+
+
+;; The basic macro-expander
+
+(define (##sys#expand-0 exp dse cs?)
+ (define (call-handler name handler exp se cs)
+ (dd "invoking macro: " name)
+ (dd `(STATIC-SE: ,@(map-se se)))
+ (handle-exceptions ex
+ ;; modify error message in condition object to include
+ ;; currently expanded macro-name
+ (##sys#abort
+ (if (and (##sys#structure? ex 'condition)
+ (memv 'exn (##sys#slot ex 1)) )
+ (##sys#make-structure
+ 'condition
+ (##sys#slot ex 1)
+ (let copy ([ps (##sys#slot ex 2)])
+ (if (null? ps)
+ '()
+ (let ([p (car ps)]
+ [r (cdr ps)])
+ (if (and (equal? '(exn . message) p)
+ (pair? r)
+ (string? (car r)) )
+ (cons
+ '(exn . message)
+ (cons (string-append
+ "during expansion of ("
+ (##sys#slot name 1)
+ " ...) - "
+ (car r) )
+ (cdr r) ) )
+ (copy r) ) ) ) ) )
+ ex) )
+ (let ((exp2
+ (if cs
+ (fluid-let ((##sys#syntax-rules-mismatch (lambda (input) exp))) ; a bit of a hack
+ (handler exp se dse))
+ (handler exp se dse))) )
+ (when (and (not cs) (eq? exp exp2))
+ (##sys#syntax-error-hook
+ (string-append
+ "syntax transformer for `" (symbol->string name)
+ "' returns original form, which would result in endless expansion")
+ exp))
+ (dd `(,name --> ,exp2))
+ exp2)))
+ (define (expand head exp mdef)
+ (dd `(EXPAND:
+ ,head
+ ,(cond ((get head '##core#macro-alias) =>
+ (lambda (a) (if (symbol? a) a '<macro>)) )
+ (else '_))
+ ,exp
+ ,(if (pair? mdef)
+ `(SE: ,@(map-se (car mdef)))
+ mdef)))
+ (cond ((not (list? exp))
+ (##sys#syntax-error-hook "invalid syntax in macro form" exp) )
+ ((pair? mdef)
+ (values
+ ;; force ref. opaqueness by passing dynamic se [what is this comment meaning? I forgot]
+ (call-handler head (cadr mdef) exp (car mdef) #f)
+ #t))
+ (else (values exp #f)) ) )
+ (let loop ((exp exp))
+ (if (pair? exp)
+ (let ((head (car exp))
+ (body (cdr exp)) )
+ (if (symbol? head)
+ (let ((head2 (or (lookup head dse) head)))
+ (unless (pair? head2)
+ (set! head2 (or (lookup head2 (##sys#macro-environment)) head2)) )
+ (cond [(memq head2 '(let ##core#let))
+ (##sys#check-syntax 'let body '#(_ 2) #f dse)
+ (let ([bindings (car body)])
+ (cond [(symbol? bindings) ; expand named let
+ (##sys#check-syntax 'let body '(_ #((variable _) 0) . #(_ 1)) #f dse)
+ (let ([bs (cadr body)])
+ (values
+ `(##core#app
+ (##core#letrec
+ ([,bindings (##core#loop-lambda ,(map (lambda (b) (car b)) bs) ,@(cddr body))])
+ ,bindings)
+ ,@(##sys#map cadr bs) )
+ #t) ) ]
+ [else (values exp #f)] ) ) ]
+ [(and (memq head2 '(set! ##core#set!)) ; "setter" syntax
+ (pair? body)
+ (pair? (car body)) )
+ (let ([dest (car body)])
+ (##sys#check-syntax 'set! body '(#(_ 1) _) #f dse)
+ (values
+ (append (list (list '##sys#setter (car dest)))
+ (cdr dest)
+ (cdr body) )
+ #t) ) ]
+ ((and cs? (symbol? head2) (##sys#get head2 '##compiler#compiler-syntax)) =>
+ (lambda (cs)
+ (let ((result (call-handler head (car cs) exp (cdr cs) #t)))
+ (cond ((eq? result exp) (expand head exp head2))
+ (else
+ (when ##sys#compiler-syntax-hook
+ (##sys#compiler-syntax-hook head result))
+ (loop result))))))
+ [else (expand head exp head2)] ) )
+ (values exp #f) ) )
+ (values exp #f) ) ) )
+
+(define ##sys#compiler-syntax-hook #f)
+(define ##sys#enable-runtime-macros #f)
+
+(define (##sys#module-rename sym prefix)
+ (##sys#string->symbol
+ (string-append
+ (##sys#slot prefix 1)
+ "#"
+ (##sys#slot sym 1) ) ) )
+
+(define (##sys#alias-global-hook sym assign)
+ (define (mrename sym)
+ (cond ((##sys#current-module) =>
+ (lambda (mod)
+ (dm "(ALIAS) global alias " sym " in " (module-name mod))
+ (unless assign (##sys#register-undefined sym mod))
+ (##sys#module-rename sym (module-name mod))))
+ (else sym)))
+ (cond ((##sys#qualified-symbol? sym) sym)
+ ((##sys#get sym '##core#primitive) =>
+ (lambda (p)
+ (dm "(ALIAS) primitive: " p)
+ p))
+ ((##sys#get sym '##core#aliased)
+ (dm "(ALIAS) marked: " sym)
+ sym)
+ ((assq sym (##sys#current-environment)) =>
+ (lambda (a)
+ (dm "(ALIAS) in current environment: " sym)
+ (let ((sym2 (cdr a)))
+ (if (pair? sym2) ; macro (*** can this be?)
+ (mrename sym)
+ (or (##sys#get sym2 '##core#primitive) sym2)))))
+ (else (mrename sym))))
+
+
+;;; User-level macroexpansion
+
+(define (##sys#expand exp #!optional (se (##sys#current-environment)) cs?)
+ (let loop ((exp exp))
+ (let-values (((exp2 m) (##sys#expand-0 exp se cs?)))
+ (if m
+ (loop exp2)
+ exp2) ) ) )
+
+(define expand ##sys#expand)
+
+
+;;; Extended (DSSSL-style) lambda lists
+;
+; Assumptions:
+;
+; 1) #!rest must come before #!key
+; 2) default values may refer to earlier variables
+; 3) optional/key args may be either variable or (variable default)
+; 4) an argument marker may not be specified more than once
+; 5) no special handling of extra keywords (no error)
+; 6) default value of optional/key args is #f
+; 7) mixing with dotted list syntax is allowed
+
+(define (##sys#extended-lambda-list? llist)
+ (let loop ([llist llist])
+ (and (pair? llist)
+ (case (##sys#slot llist 0)
+ [(#!rest #!optional #!key) #t]
+ [else (loop (cdr llist))] ) ) ) )
+
+(define ##sys#expand-extended-lambda-list
+ (let ([reverse reverse]
+ [gensym gensym] )
+ (lambda (llist0 body errh se)
+ (define (err msg) (errh msg llist0))
+ (define (->keyword s) (string->keyword (##sys#slot s 1)))
+ (let ([rvar #f]
+ [hasrest #f]
+ (%let* (macro-alias 'let* se))
+ (%lambda '##core#lambda)
+ (%opt (macro-alias 'optional se))
+ (%let-optionals (macro-alias 'let-optionals se))
+ (%let-optionals* (macro-alias 'let-optionals* se))
+ (%let (macro-alias 'let se)))
+ (let loop ([mode 0] ; req=0, opt=1, rest=2, key=3, end=4
+ [req '()]
+ [opt '()]
+ [key '()]
+ [llist llist0] )
+ (cond [(null? llist)
+ (values
+ (if rvar (##sys#append (reverse req) rvar) (reverse req))
+ (let ([body
+ (if (null? key)
+ body
+ `((,%let*
+ ,(map (lambda (k)
+ (let ([s (car k)])
+ `(,s (##sys#get-keyword
+ ',(->keyword s) ,rvar
+ ,@(if (pair? (cdr k))
+ `((,%lambda () ,@(cdr k)))
+ '() ) ) ) ) )
+ (reverse key) )
+ ,@body) ) ) ] )
+ (cond [(null? opt) body]
+ [(and (not hasrest) (null? key) (null? (cdr opt)))
+ `((,%let
+ ([,(caar opt) (,%opt ,rvar ,(cadar opt))])
+ ,@body) ) ]
+ [(and (not hasrest) (null? key))
+ `((,%let-optionals
+ ,rvar ,(reverse opt) ,@body))]
+ [else
+ `((,%let-optionals*
+ ,rvar ,(##sys#append (reverse opt) (list (or hasrest rvar)))
+ ,@body))] ) ) ) ]
+ [(symbol? llist)
+ (if (fx> mode 2)
+ (err "rest argument list specified more than once")
+ (begin
+ (unless rvar (set! rvar llist))
+ (set! hasrest llist)
+ (loop 4 req opt '() '()) ) ) ]
+ [(not (pair? llist))
+ (err "invalid lambda list syntax") ]
+ [else
+ (let* ((var (car llist))
+ (x (or (and (symbol? var) (not (eq? 3 mode)) (lookup var se)) var))
+ (r (cdr llist)))
+ (case x
+ [(#!optional)
+ (unless rvar (set! rvar (macro-alias 'tmp se)))
+ (if (eq? mode 0)
+ (loop 1 req '() '() r)
+ (err "`#!optional' argument marker in wrong context") ) ]
+ [(#!rest)
+ (if (fx<= mode 1)
+ (if (and (pair? r) (symbol? (car r)))
+ (begin
+ (if (not rvar) (set! rvar (car r)))
+ (set! hasrest (car r))
+ (loop 2 req opt '() (cdr r)) )
+ (err "invalid syntax of `#!rest' argument") )
+ (err "`#!rest' argument marker in wrong context") ) ]
+ [(#!key)
+ (if (not rvar) (set! rvar (macro-alias 'tmp se)))
+ (if (fx<= mode 3)
+ (loop 3 req opt '() r)
+ (err "`#!key' argument marker in wrong context") ) ]
+ [else
+ (cond [(symbol? var)
+ (case mode
+ [(0) (loop 0 (cons var req) '() '() r)]
+ [(1) (loop 1 req (cons (list var #f) opt) '() r)]
+ [(2) (err "invalid lambda list syntax after `#!rest' marker")]
+ [else (loop 3 req opt (cons (list var) key) r)] ) ]
+ [(and (list? var) (eq? 2 (length var)))
+ (case mode
+ [(0) (err "invalid required argument syntax")]
+ [(1) (loop 1 req (cons var opt) '() r)]
+ [(2) (err "invalid lambda list syntax after `#!rest' marker")]
+ [else (loop 3 req opt (cons var key) r)] ) ]
+ [else (err "invalid lambda list syntax")] ) ] ) ) ] ) ) ) ) ) )
+
+
+;;; Expansion of bodies (and internal definitions)
+
+(define ##sys#canonicalize-body
+ (let ([reverse reverse]
+ [map map] )
+ (lambda (body #!optional (se (##sys#current-environment)) cs?)
+ (define (fini vars vals mvars mvals body)
+ (if (and (null? vars) (null? mvars))
+ (let loop ([body2 body] [exps '()])
+ (if (not (pair? body2))
+ (cons
+ '##core#begin
+ body) ; no more defines, otherwise we would have called `expand'
+ (let ([x (car body2)])
+ (if (and (pair? x)
+ (let ((d (car x)))
+ (and (symbol? d)
+ (or (eq? (or (lookup d se) d) 'define)
+ (eq? (or (lookup d se) d) 'define-values)))) )
+ (cons
+ '##core#begin
+ (##sys#append (reverse exps) (list (expand body2))))
+ (loop (cdr body2) (cons x exps)) ) ) ) )
+ (let* ((vars (reverse vars))
+ (result
+ `(##core#let
+ ,(##sys#map (lambda (v) (##sys#list v (##sys#list '##core#undefined)))
+ (apply ##sys#append vars mvars) )
+ ,@(map (lambda (v x) `(##core#set! ,v ,x)) vars (reverse vals))
+ ,@(map (lambda (vs x)
+ (let ([tmps (##sys#map gensym vs)])
+ `(##sys#call-with-values
+ (##core#lambda () ,x)
+ (##core#lambda
+ ,tmps
+ ,@(map (lambda (v t)
+ `(##core#set! ,v ,t))
+ vs tmps) ) ) ) )
+ (reverse mvars)
+ (reverse mvals) )
+ ,@body) ) )
+ (dd `(BODY: ,result))
+ result)))
+ (define (fini/syntax vars vals mvars mvals body)
+ (fini
+ vars vals mvars mvals
+ (let loop ((body body) (defs '()) (done #f))
+ (cond (done `((,(macro-alias 'letrec-syntax se)
+ ,(map cdr (reverse defs)) ,@body) ))
+ ((not (pair? body)) (loop body defs #t))
+ ((and (list? (car body))
+ (>= 3 (length (car body)))
+ (symbol? (caar body))
+ (eq? 'define-syntax (or (lookup (caar body) se) (caar body))))
+ (let ((def (car body)))
+ (loop
+ (cdr body)
+ (cons (if (pair? (cadr def))
+ `(define-syntax ,(caadr def)
+ (,(macro-alias 'lambda se) ,(cdadr def) ,@(cddr def)))
+ def)
+ defs)
+ #f)))
+ (else (loop body defs #t))))))
+ (define (expand body)
+ (let loop ([body body] [vars '()] [vals '()] [mvars '()] [mvals '()])
+ (if (not (pair? body))
+ (fini vars vals mvars mvals body)
+ (let* ((x (car body))
+ (rest (cdr body))
+ (exp1 (and (pair? x) (car x)))
+ (head (and exp1
+ (symbol? exp1)
+ (or (lookup exp1 se) exp1))))
+ (cond [(not (symbol? head)) (fini vars vals mvars mvals body)]
+ [(eq? 'define head)
+ (##sys#check-syntax 'define x '(define _ . #(_ 0)) #f se)
+ (let loop2 ([x x])
+ (let ([head (cadr x)])
+ (cond [(not (pair? head))
+ (##sys#check-syntax 'define x '(define variable . #(_ 0)) #f se)
+ (loop rest (cons head vars)
+ (cons (if (pair? (cddr x))
+ (caddr x)
+ '(##core#undefined) )
+ vals)
+ mvars mvals) ]
+ [(pair? (car head))
+ (##sys#check-syntax 'define x '(define (_ . lambda-list) . #(_ 1)) #f se)
+ (loop2 (cons (macro-alias 'define se)
+ (##sys#expand-curried-define head (cddr x) se))) ]
+ [else
+ (##sys#check-syntax
+ 'define x '(define (variable . lambda-list) . #(_ 1)) #f se)
+ (loop rest
+ (cons (car head) vars)
+ (cons `(##core#lambda ,(cdr head) ,@(cddr x)) vals)
+ mvars mvals) ] ) ) ) ]
+ ((eq? 'define-syntax head)
+ (##sys#check-syntax 'define-syntax x '(define-syntax _ . #(_ 1)) se)
+ (fini/syntax vars vals mvars mvals body) )
+ [(eq? 'define-values head)
+ (##sys#check-syntax 'define-values x '(define-values #(_ 0) _) #f se)
+ (loop rest vars vals (cons (cadr x) mvars) (cons (caddr x) mvals)) ]
+ [(eq? 'begin head)
+ (##sys#check-syntax 'begin x '(begin . #(_ 0)) #f se)
+ (loop (##sys#append (cdr x) rest) vars vals mvars mvals) ]
+ ((or (memq head vars) (memq head mvars))
+ (fini vars vals mvars mvals body))
+ [else
+ (let ([x2 (##sys#expand-0 x se cs?)])
+ (if (eq? x x2)
+ (fini vars vals mvars mvals body)
+ (loop (cons x2 rest) vars vals mvars mvals) ) ) ] ) ) ) ) )
+ (expand body) ) ) )
+
+
+;;; A simple expression matcher
+
+(define match-expression
+ (lambda (exp pat vars)
+ (let ((env '()))
+ (define (mwalk x p)
+ (cond ((not (pair? p))
+ (cond ((assq p env) => (lambda (a) (equal? x (cdr a))))
+ ((memq p vars)
+ (set! env (cons (cons p x) env))
+ #t)
+ (else (eq? x p)) ) )
+ ((pair? x)
+ (and (mwalk (car x) (car p))
+ (mwalk (cdr x) (cdr p)) ) )
+ (else #f) ) )
+ (and (mwalk exp pat) env) ) ) )
+
+
+;;; Expand "curried" lambda-list syntax for `define'
+
+(define (##sys#expand-curried-define head body se)
+ (let ((name #f))
+ (define (loop head body)
+ (if (symbol? (car head))
+ (begin
+ (set! name (car head))
+ `(##core#lambda ,(cdr head) ,@body) )
+ (loop (car head) `((##core#lambda ,(cdr head) ,@body)) ) ))
+ (let ([exp (loop head body)])
+ (list name exp) ) ) )
+
+
+;;; General syntax checking routine:
+
+(define ##sys#line-number-database #f)
+(define ##sys#syntax-error-culprit #f)
+
+(define (##sys#syntax-error-hook . args)
+ (apply ##sys#signal-hook #:syntax-error
+ (##sys#strip-syntax args)))
+
+(define syntax-error ##sys#syntax-error-hook)
+
+(define (##sys#syntax-rules-mismatch input)
+ (##sys#syntax-error-hook "no rule matches form" input))
+
+(define (get-line-number sexp)
+ (and ##sys#line-number-database
+ (pair? sexp)
+ (let ([head (car sexp)])
+ (and (symbol? head)
+ (cond [(##sys#hash-table-ref ##sys#line-number-database head)
+ => (lambda (pl)
+ (let ([a (assq sexp pl)])
+ (and a (cdr a)) ) ) ]
+ [else #f] ) ) ) ) )
+
+(define-constant +default-argument-count-limit+ 99999)
+
+(define ##sys#check-syntax
+ (let ([string-append string-append]
+ [keyword? keyword?]
+ [get-line-number get-line-number]
+ [symbol->string symbol->string] )
+ (lambda (id exp pat #!optional culprit (se (##sys#current-environment)))
+
+ (define (test x pred msg)
+ (unless (pred x) (err msg)) )
+
+ (define (err msg)
+ (let* ([sexp ##sys#syntax-error-culprit]
+ [ln (get-line-number sexp)] )
+ (##sys#syntax-error-hook
+ (if ln
+ (string-append "(" (symbol->string id) ") in line " (number->string ln) " - " msg)
+ (string-append "(" (symbol->string id) ") " msg) )
+ exp) ) )
+
+ (define (lambda-list? x)
+ (or (##sys#extended-lambda-list? x)
+ (let loop ((x x))
+ (cond ((null? x))
+ ((symbol? x) (not (keyword? x)))
+ ((pair? x)
+ (let ((s (car x)))
+ (and (symbol? s) (not (keyword? s))
+ (loop (cdr x)) ) ) )
+ (else #f) ) ) ) )
+
+ (define (proper-list? x)
+ (let loop ((x x))
+ (cond ((eq? x '()))
+ ((pair? x) (loop (cdr x)))
+ (else #f) ) ) )
+
+ (when culprit (set! ##sys#syntax-error-culprit culprit))
+ (let walk ((x exp) (p pat))
+ (cond ((vector? p)
+ (let* ((p2 (vector-ref p 0))
+ (vlen (##sys#size p))
+ (min (if (fx> vlen 1)
+ (vector-ref p 1)
+ 0) )
+ (max (cond ((eq? vlen 1) 1)
+ ((fx> vlen 2) (vector-ref p 2))
+ (else +default-argument-count-limit+) ) ) )
+ (do ((x x (cdr x))
+ (n 0 (fx+ n 1)) )
+ ((eq? x '())
+ (if (fx< n min)
+ (err "not enough arguments") ) )
+ (cond ((fx>= n max)
+ (err "too many arguments") )
+ ((not (pair? x))
+ (err "not a proper list") )
+ (else (walk (car x) p2) ) ) ) ) )
+ ((##sys#immediate? p)
+ (if (not (eq? p x)) (err "unexpected object")) )
+ ((symbol? p)
+ (case p
+ ((_) #t)
+ ((pair) (test x pair? "pair expected"))
+ ((variable) (test x symbol? "identifier expected"))
+ ((symbol) (test x symbol? "symbol expected"))
+ ((list) (test x proper-list? "proper list expected"))
+ ((number) (test x number? "number expected"))
+ ((string) (test x string? "string expected"))
+ ((lambda-list) (test x lambda-list? "lambda-list expected"))
+ (else
+ (test
+ x
+ (lambda (y)
+ (let ((y2 (and (symbol? y) (lookup y se))))
+ (eq? (if (symbol? y2) y2 y) p)))
+ "missing keyword")) ) )
+ ((not (pair? p))
+ (err "incomplete form") )
+ ((not (pair? x)) (err "pair expected"))
+ (else
+ (walk (car x) (car p))
+ (walk (cdr x) (cdr p)) ) ) ) ) ) )
+
+
+;;; explicit-renaming transformer
+
+(define (er-macro-transformer x) x)
+
+(define ((##sys#er-transformer handler) form se dse)
+ (let ((renv '())) ; keep rename-environment for this expansion
+ (define (rename sym)
+ (cond ((assq sym renv) =>
+ (lambda (a)
+ (dd `(RENAME/RENV: ,sym --> ,(cdr a)))
+ (cdr a)))
+ ((lookup sym se) =>
+ (lambda (a)
+ (cond ((symbol? a)
+ (dd `(RENAME/LOOKUP: ,sym --> ,a))
+ a)
+ (else
+ (let ((a2 (macro-alias sym se)))
+ (dd `(RENAME/LOOKUP/MACRO: ,sym --> ,a2))
+ (set! renv (cons (cons sym a2) renv))
+ a2)))))
+ (else
+ (let ((a (macro-alias sym se)))
+ (dd `(RENAME: ,sym --> ,a))
+ (set! renv (cons (cons sym a) renv))
+ a))))
+ (define (compare s1 s2)
+ (let ((result
+ (if (and (symbol? s1) (symbol? s2))
+ (let ((ss1 (or (##sys#get s1 '##core#macro-alias)
+ (lookup2 1 s1 dse)
+ s1) )
+ (ss2 (or (##sys#get s2 '##core#macro-alias)
+ (lookup2 2 s2 dse)
+ s2) ) )
+ (cond ((symbol? ss1)
+ (cond ((symbol? ss2)
+ (eq? (or (##sys#get ss1 '##core#primitive) ss1)
+ (or (##sys#get ss2 '##core#primitive) ss2)))
+ ((assq ss1 (##sys#macro-environment)) =>
+ (lambda (a) (eq? (cdr a) ss2)))
+ (else #f) ) )
+ ((symbol? ss2)
+ (cond ((assq ss2 (##sys#macro-environment)) =>
+ (lambda (a) (eq? ss1 (cdr a))))
+ (else #f)))
+ (else (eq? ss1 ss2))))
+ (eq? s1 s2))) )
+ (dd `(COMPARE: ,s1 ,s2 --> ,result))
+ result))
+ (define (lookup2 n sym dse)
+ (let ((r (lookup sym dse)))
+ (dd " (lookup/DSE " (list n) ": " sym " --> "
+ (if (and r (pair? r))
+ '<macro>
+ r)
+ ")")
+ r))
+ (handler form rename compare) ) )
+
+
+;;; Macro definitions:
+
+(define (##sys#expand-import x r c import-env macro-env meta? reexp? loc)
+ (let ((%only (r 'only))
+ (%rename (r 'rename))
+ (%except (r 'except))
+ (%prefix (r 'prefix)))
+ (define (resolve sym)
+ (or (lookup sym '()) sym)) ;*** empty se?
+ (define (tostr x)
+ (cond ((string? x) x)
+ ((keyword? x) (##sys#string-append (##sys#symbol->string x) ":")) ; hack
+ ((symbol? x) (##sys#symbol->string x))
+ ((number? x) (number->string x))
+ (else (syntax-error loc "invalid prefix" ))))
+ (define (import-name spec)
+ (let* ((mname (##sys#strip-syntax spec))
+ (mod (##sys#find-module mname #f)))
+ (unless mod
+ (let ((il (##sys#find-extension
+ (string-append (symbol->string mname) ".import")
+ #t)))
+ (cond (il (parameterize ((##sys#current-module #f)
+ (##sys#current-environment '())
+ (##sys#current-meta-environment (##sys#current-meta-environment))
+ (##sys#macro-environment (##sys#meta-macro-environment)))
+ (##sys#load il #f #f))
+ (set! mod (##sys#find-module mname)))
+ (else
+ (syntax-error
+ loc "cannot import from undefined module"
+ mname)))))
+ (let ((vexp (module-vexports mod))
+ (sexp (module-sexports mod)))
+ (cons vexp sexp))))
+ (define (import-spec spec)
+ (cond ((symbol? spec) (import-name spec))
+ ((or (not (list? spec)) (< (length spec) 2))
+ (syntax-error loc "invalid import specification" spec))
+ (else
+ (let* ((s (car spec))
+ (imp (import-spec (cadr spec)))
+ (impv (car imp))
+ (imps (cdr imp)))
+ (cond ((c %only (car spec))
+ (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
+ (let ((ids (map resolve (cddr spec))))
+ (let loop ((ids ids) (v '()) (s '()))
+ (cond ((null? ids) (cons v s))
+ ((assq (car ids) impv) =>
+ (lambda (a)
+ (loop (cdr ids) (cons a v) s)))
+ ((assq (car ids) imps) =>
+ (lambda (a)
+ (loop (cdr ids) v (cons a s))))
+ (else (loop (cdr ids) v s))))))
+ ((c %except (car spec))
+ (##sys#check-syntax loc spec '(_ _ . #(symbol 0)))
+ (let ((ids (map resolve (cddr spec))))
+ (let loop ((impv impv) (v '()))
+ (cond ((null? impv)
+ (let loop ((imps imps) (s '()))
+ (cond ((null? imps) (cons v s))
+ ((memq (caar imps) ids) (loop (cdr imps) s))
+ (else (loop (cdr imps) (cons (car imps) s))))))
+ ((memq (caar impv) ids) (loop (cdr impv) v))
+ (else (loop (cdr impv) (cons (car impv) v)))))))
+ ((c %rename (car spec))
+ (##sys#check-syntax loc spec '(_ _ . #((symbol symbol) 0)))
+ (let loop ((impv impv) (imps imps) (v '()) (s '()) (ids (cddr spec)))
+ (cond ((null? impv)
+ (cond ((null? imps)
+ (for-each
+ (lambda (id)
+ (##sys#warn "renamed identifier not imported" id) )
+ ids)
+ (cons v s))
+ ((assq (caar imps) ids) =>
+ (lambda (a)
+ (loop impv (cdr imps)
+ v
+ (cons (cons (cadr a) (cdar imps)) s)
+ (##sys#delq a ids))))
+ (else (loop impv (cdr imps) v (cons (car imps) s) ids))))
+ ((assq (caar impv) ids) =>
+ (lambda (a)
+ (loop (cdr impv) imps
+ (cons (cons (cadr a) (cdar impv)) v)
+ s
+ (##sys#delq a ids))))
+ (else (loop (cdr impv) imps
+ (cons (car impv) v)
+ s ids)))))
+ ((c %prefix (car spec))
+ (##sys#check-syntax loc spec '(_ _ _))
+ (let ((pref (tostr (caddr spec))))
+ (define (ren imp)
+ (cons
+ (##sys#string->symbol
+ (##sys#string-append pref (##sys#symbol->string (car imp))) )
+ (cdr imp) ) )
+ (cons (map ren impv) (map ren imps))))
+ (else (syntax-error loc "invalid import specification" spec)))))))
+ (##sys#check-syntax loc x '(_ . #(_ 1)))
+ (let ((cm (##sys#current-module)))
+ (when cm
+ ;; save import form
+ (if meta?
+ (set-module-meta-import-forms!
+ cm
+ (append (module-meta-import-forms cm) (cdr x)))
+ (set-module-import-forms!
+ cm
+ (append (module-import-forms cm) (cdr x)))))
+ (for-each
+ (lambda (spec)
+ (let* ((vs (import-spec spec))
+ (vsv (car vs))
+ (vss (cdr vs)))
+ (dd `(IMPORT: ,loc))
+ (dd `(V: ,(if cm (module-name cm) '<toplevel>) ,(map-se vsv)))
+ (dd `(S: ,(if cm (module-name cm) '<toplevel>) ,(map-se vss)))
+ (##sys#mark-imported-symbols vsv) ; mark imports as ##core#aliased
+ (for-each
+ (lambda (imp)
+ (let ((id (car imp))
+ (aid (cdr imp)))
+ (and-let* ((a (assq id (import-env)))
+ ((not (eq? aid (cdr a)))))
+ (##sys#warn "re-importing already imported identifier" id))))
+ vsv)
+ (for-each
+ (lambda (imp)
+ (and-let* ((a (assq (car imp) (macro-env)))
+ ((not (eq? (cdr imp) (cdr a)))))
+ (##sys#warn "re-importing already imported syntax" (car imp))) )
+ vss)
+ (when reexp?
+ (unless cm
+ (syntax-error loc "`reexport' only valid inside a module"))
+ (set-module-export-list!
+ cm
+ (append
+ (module-export-list cm)
+ (map car vsv)
+ (map car vss)))
+ (dm "export-list: " (module-export-list cm)))
+ (import-env (append vsv (import-env)))
+ (macro-env (append vss (macro-env)))))
+ (cdr x))
+ '(##core#undefined))))
+
+(##sys#extend-macro-environment
+ 'import '()
+ (##sys#er-transformer
+ (cut ##sys#expand-import <> <> <> ##sys#current-environment ##sys#macro-environment
+ #f #f 'import) ) )
+
+(##sys#extend-macro-environment
+ 'import-for-syntax '()
+ (##sys#er-transformer
+ (cut ##sys#expand-import <> <> <> ##sys#current-meta-environment ##sys#meta-macro-environment
+ #t #f 'import-for-syntax) ) )
+
+(##sys#extend-macro-environment
+ 'reexport '()
+ (##sys#er-transformer
+ (cut ##sys#expand-import <> <> <> ##sys#current-environment ##sys#macro-environment
+ #t #t 'reexport) ) )
+
+(define ##sys#initial-macro-environment (##sys#macro-environment))
+
+(##sys#extend-macro-environment
+ 'define
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (let loop ((form (cdr form)))
+ (let ((head (car form))
+ (body (cdr form)) )
+ (cond ((not (pair? head))
+ (##sys#check-syntax 'define head 'symbol)
+ (##sys#check-syntax 'define body '#(_ 0 1))
+ (##sys#register-export head (##sys#current-module))
+ `(##core#set! ,head ,(if (pair? body) (car body) '(##core#undefined))) )
+ ((pair? (car head))
+ (##sys#check-syntax 'define head '(_ . lambda-list))
+ (##sys#check-syntax 'define body '#(_ 1))
+ (loop (##sys#expand-curried-define head body '())) ) ;*** '() should be se
+ (else
+ (##sys#check-syntax 'define head '(symbol . lambda-list))
+ (##sys#check-syntax 'define body '#(_ 1))
+ (##sys#register-export (car head) (##sys#current-module))
+ `(##core#set!
+ ,(car head)
+ (,(r 'lambda) ,(cdr head) ,@body))) ) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'and
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (let ((body (cdr form)))
+ (if (null? body)
+ #t
+ (let ((rbody (cdr body))
+ (hbody (car body)) )
+ (if (null? rbody)
+ hbody
+ `(,(r 'if) ,hbody (,(r 'and) ,@rbody) #f) ) ) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'or
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (let ((body (cdr form)))
+ (if (null? body)
+ #f
+ (let ((rbody (cdr body))
+ (hbody (car body)))
+ (if (null? rbody)
+ hbody
+ (let ((tmp (r 'tmp)))
+ `(,(r 'let) ((,tmp ,hbody))
+ (,(r 'if) ,tmp ,tmp (,(r 'or) ,@rbody)) ) ) ) ) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'cond
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (let ((body (cdr form))
+ (%let (r 'let))
+ (%if (r 'if))
+ (%=> (r '=>))
+ (%or (r 'or))
+ (%else (r 'else))
+ (%lambda (r 'lambda)))
+ (let expand ((clauses body))
+ (if (not (pair? clauses))
+ '(##core#undefined)
+ (let ((clause (car clauses))
+ (rclauses (cdr clauses)) )
+ (##sys#check-syntax 'cond clause '#(_ 1))
+ (cond ((c %else (car clause)) `(##core#begin ,@(cdr clause)))
+ ((null? (cdr clause)) `(,%or ,(car clause) ,(expand rclauses)))
+ ((c %=> (cadr clause))
+ (let ((tmp (r 'tmp)))
+ `(,%let ((,tmp ,(car clause)))
+ (,%if ,tmp
+ (,(caddr clause) ,tmp)
+ ,(expand rclauses) ) ) ) )
+ ((and (list? clause) (fx= (length clause) 4)
+ (c %=> (caddr clause)))
+ (let ((tmp (r 'tmp)))
+ `(##sys#call-with-values
+ (,%lambda () ,(car clause))
+ (,%lambda ,tmp
+ (if (##sys#apply ,(cadr clause) ,tmp)
+ (##sys#apply ,(cadddr clause) ,tmp)
+ ,(expand rclauses) ) ) ) ) )
+ (else `(,%if ,(car clause)
+ (##core#begin ,@(cdr clause))
+ ,(expand rclauses) ) ) ) ) ) ) ) ) ))
+
+(##sys#extend-macro-environment
+ 'case
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'case form '(_ _ . #(_ 0)))
+ (let ((exp (cadr form))
+ (body (cddr form)) )
+ (let ((tmp (r 'tmp))
+ (%if (r 'if))
+ (%or (r 'or))
+ (%else (r 'else)))
+ `(let ((,tmp ,exp))
+ ,(let expand ((clauses body))
+ (if (not (pair? clauses))
+ '(##core#undefined)
+ (let ((clause (car clauses))
+ (rclauses (cdr clauses)) )
+ (##sys#check-syntax 'case clause '#(_ 1))
+ (if (c %else (car clause))
+ `(##core#begin ,@(cdr clause))
+ `(,%if (,%or ,@(##sys#map
+ (lambda (x) `(##sys#eqv? ,tmp ',x)) (car clause)))
+ (##core#begin ,@(cdr clause))
+ ,(expand rclauses) ) ) ) ) ) ) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'let*
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'let* form '(_ #((symbol _) 0) . #(_ 1)))
+ (let ((bindings (cadr form))
+ (body (cddr form))
+ (%let (r 'let)))
+ (let expand ((bs bindings))
+ (if (eq? bs '())
+ `(,%let () ,@body)
+ `(,%let (,(car bs)) ,(expand (cdr bs))) ) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'do
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'do form '(_ #((symbol _ . #(_)) 0) . #(_ 1)))
+ (let ((bindings (cadr form))
+ (test (caddr form))
+ (body (cdddr form))
+ (dovar (r 'doloop))
+ (%let (r 'let))
+ (%if (r 'if)))
+ `(,%let ,dovar ,(##sys#map (lambda (b) (list (car b) (car (cdr b)))) bindings)
+ (,%if ,(car test)
+ ,(let ((tbody (cdr test)))
+ (if (eq? tbody '())
+ '(##core#undefined)
+ `(##core#begin ,@tbody) ) )
+ (##core#begin
+ ,(if (eq? body '())
+ '(##core#undefined)
+ `(,%let () ,@body) )
+ (##core#app
+ ,dovar ,@(##sys#map (lambda (b)
+ (if (eq? (cdr (cdr b)) '())
+ (car b)
+ (car (cdr (cdr b))) ) )
+ bindings) ) ) ) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'quasiquote
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (let ((%quote (r 'quote))
+ (%quasiquote (r 'quasiquote))
+ (%unquote (r 'unquote))
+ (%unquote-splicing (r 'unquote-splicing)))
+ (define (walk x n) (simplify (walk1 x n)))
+ (define (walk1 x n)
+ (cond ((vector? x)
+ `(##sys#list->vector ,(walk (vector->list x) n)) )
+ ((not (pair? x)) `(,%quote ,x))
+ (else
+ (let ((head (car x))
+ (tail (cdr x)))
+ (cond ((c %unquote head)
+ (if (pair? tail)
+ (let ((hx (car tail)))
+ (if (eq? n 0)
+ hx
+ (list '##sys#list `(,%quote ,%unquote)
+ (walk hx (fx- n 1)) ) ) )
+ `(,%quote ,%unquote) ) )
+ ((c %quasiquote head)
+ (if (pair? tail)
+ `(##sys#list (,%quote ,%quasiquote)
+ ,(walk (car tail) (fx+ n 1)) )
+ (list '##sys#cons (list %quote %quasiquote)
+ (walk tail n)) ) )
+ ((pair? head)
+ (let ((hx (car head))
+ (tx (cdr head)))
+ (if (and (c hx %unquote-splicing) (pair? tx))
+ (let ((htx (car tx)))
+ (if (eq? n 0)
+ `(##sys#append ,htx
+ ,(walk tail n) )
+ `(##sys#cons (##sys#list %unquote-splicing
+ ,(walk htx (fx- n 1)) )
+ ,(walk tail n) ) ) )
+ `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) )
+ (else
+ `(##sys#cons ,(walk head n) ,(walk tail n)) ) ) ) ) ) )
+ (define (simplify x)
+ (cond ((match-expression x '(##sys#cons a '()) '(a))
+ => (lambda (env) (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)))) )
+ ((match-expression x '(##sys#cons a (##sys#list . b)) '(a b))
+ => (lambda (env)
+ (let ([bxs (assq 'b env)])
+ (if (fx< (length bxs) 32)
+ (simplify `(##sys#list ,(##sys#slot (assq 'a env) 1)
+ ,@(cdr bxs) ) )
+ x) ) ) )
+ ((match-expression x '(##sys#append a '()) '(a))
+ => (lambda (env) (##sys#slot (assq 'a env) 1)) )
+ (else x) ) )
+ (##sys#check-syntax 'quasiquote form '(_ _))
+ (walk (cadr form) 0) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'delay
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'delay form '(_ _))
+ `(##sys#make-promise (lambda () ,(cadr form))))))
+
+(##sys#extend-macro-environment
+ 'cond-expand
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (let ((clauses (cdr form))
+ (%or (r 'or))
+ (%not (r 'not))
+ (%else (r 'else))
+ (%and (r 'and)))
+ (define (err x)
+ (##sys#error "syntax error in `cond-expand' form"
+ x
+ (cons 'cond-expand clauses)) )
+ (define (test fx)
+ (cond ((symbol? fx) (##sys#feature? fx))
+ ((not (pair? fx)) (err fx))
+ (else
+ (let ((head (car fx))
+ (rest (cdr fx)))
+ (cond ((c %and head)
+ (or (eq? rest '())
+ (if (pair? rest)
+ (and (test (car rest))
+ (test `(,%and ,@(cdr rest))) )
+ (err fx) ) ) )
+ ((c %or head)
+ (and (not (eq? rest '()))
+ (if (pair? rest)
+ (or (test (car rest))
+ (test `(,%or ,@(cdr rest))) )
+ (err fx) ) ) )
+ ((c %not head) (not (test (cadr fx))))
+ (else (err fx)) ) ) ) ) )
+ (let expand ((cls clauses))
+ (cond ((eq? cls '())
+ (##sys#apply
+ ##sys#error "no matching clause in `cond-expand' form"
+ (map (lambda (x) (car x)) clauses) ) )
+ ((not (pair? cls)) (err cls))
+ (else
+ (let ((clause (car cls))
+ (rclauses (cdr cls)) )
+ (if (not (pair? clause))
+ (err clause)
+ (let ((id (car clause)))
+ (cond ((c id %else)
+ (let ((rest (cdr clause)))
+ (if (eq? rest '())
+ '(##core#undefined)
+ `(##core#begin ,@rest) ) ) )
+ ((test id) `(##core#begin ,@(cdr clause)))
+ (else (expand rclauses)) ) ) ) ) ) ) ) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'require-library
+ '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (let ((ids (cdr x)))
+ `(##core#require-extension ,ids #f) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'require-extension
+ '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (let ((ids (cdr x)))
+ `(##core#require-extension ,ids #t) ) ) ) )
+
+(##sys#extend-macro-environment
+ 'module
+ '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'module x '(_ symbol _ . #(_ 0)))
+ `(##core#module
+ ,(cadr x)
+ ,(if (eq? '* (##sys#strip-syntax (caddr x)))
+ #t
+ (caddr x))
+ ,@(cdddr x)))))
+
+(##sys#extend-macro-environment
+ 'begin-for-syntax
+ '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (##sys#check-syntax 'begin-for-syntax x '(_ . #(_ 0)))
+ (##sys#register-meta-expression `(##core#begin ,@(cdr x)))
+ `(##core#elaborationtimeonly (##core#begin ,@(cdr x))))))
+
+(##sys#extend-macro-environment
+ 'export
+ '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (let ((exps (cdr x))
+ (mod (##sys#current-module)))
+ (unless mod
+ (syntax-error 'export "`export' used outside module body"))
+ (for-each
+ (lambda (exp)
+ (when (and (not (symbol? exp))
+ (let loop ((iexp exp))
+ (cond ((null? iexp) #f)
+ ((not (pair? iexp)) #t)
+ ((not (symbol? (car iexp))) #t)
+ (else (loop (cdr iexp))))))
+ (syntax-error 'export "invalid export syntax" exp (module-name mod))))
+ exps)
+ (set-module-export-list!
+ mod
+ (append (module-export-list mod)
+ (map ##sys#strip-syntax exps)))
+ '(##core#undefined)))))
+
+
+;;; syntax-rules
+
+(include "synrules.scm")
+
+
+;;; the base macro environment ("scheme", essentially)
+
+(define (##sys#macro-subset me0 #!optional parent-env)
+ (let ((se (let loop ((me (##sys#macro-environment)))
+ (if (or (null? me) (eq? me me0))
+ '()
+ (cons (car me) (loop (cdr me)))))))
+ (##sys#fixup-macro-environment se parent-env)))
+
+(define (##sys#fixup-macro-environment se #!optional parent-env)
+ (let ((se2 (if parent-env (##sys#append se parent-env) se)))
+ (for-each ; fixup se
+ (lambda (sdef)
+ (when (pair? (cdr sdef))
+ (set-car!
+ (cdr sdef)
+ (if (null? (cadr sdef))
+ se2
+ (##sys#append (cadr sdef) se2)))))
+ se)
+ se))
+
+(define ##sys#default-macro-environment
+ (##sys#fixup-macro-environment (##sys#macro-environment)))
+
+
+;;; low-level module support
+
+(define ##sys#meta-macro-environment (make-parameter (##sys#macro-environment)))
+(define ##sys#current-module (make-parameter #f))
+
+(declare
+ (hide make-module module? %make-module
+ module-name module-vexports module-sexports
+ set-module-vexports! set-module-sexports!
+ module-export-list set-module-export-list!
+ module-defined-list set-module-defined-list!
+ module-import-forms set-module-import-forms!
+ module-meta-import-forms set-module-meta-import-forms!
+ module-exist-list set-module-exist-list!
+ module-meta-expressions set-module-meta-expressions!
+ module-defined-syntax-list set-module-defined-syntax-list!))
+
+(define-record-type module
+ (%make-module name export-list defined-list exist-list defined-syntax-list
+ undefined-list import-forms meta-import-forms meta-expressions
+ vexports sexports)
+ module?
+ (name module-name) ; SYMBOL
+ (export-list module-export-list set-module-export-list!) ; (SYMBOL | (SYMBOL ...) ...)
+ (defined-list module-defined-list set-module-defined-list!) ; ((SYMBOL . VALUE) ...) - *exported* value definitions
+ (exist-list module-exist-list set-module-exist-list!) ; (SYMBOL ...) - only for checking refs to undef'd
+ (defined-syntax-list module-defined-syntax-list set-module-defined-syntax-list!) ; ((SYMBOL . VALUE) ...)
+ (undefined-list module-undefined-list set-module-undefined-list!) ; (SYMBOL ...)
+ (import-forms module-import-forms set-module-import-forms!) ; (SPEC ...)
+ (meta-import-forms module-meta-import-forms set-module-meta-import-forms!) ; (SPEC ...)
+ (meta-expressions module-meta-expressions set-module-meta-expressions!) ; (EXP ...)
+ (vexports module-vexports set-module-vexports!) ; (SYMBOL . SYMBOL)
+ (sexports module-sexports set-module-sexports!) ) ; ((SYMBOL SE TRANSFORMER) ...)
+
+(define ##sys#module-name module-name)
+
+(define (##sys#module-exports m)
+ (values
+ (module-export-list m)
+ (module-vexports m)
+ (module-sexports m)))
+
+(define (make-module name explist vexports sexports)
+ (%make-module name explist '() '() '() '() '() '() '() vexports sexports))
+
+(define (##sys#find-module name #!optional (err #t))
+ (cond ((assq name ##sys#module-table) => cdr)
+ (err (error 'import "module not found" name))
+ (else #f)))
+
+(define (##sys#toplevel-definition-hook sym mod exp val) #f)
+
+(define (##sys#register-meta-expression exp)
+ (and-let* ((mod (##sys#current-module)))
+ (set-module-meta-expressions! mod (cons exp (module-meta-expressions mod)))))
+
+(define (check-for-redef sym env senv)
+ (and-let* ((a (assq sym env)))
+ (##sys#warn "redefinition of imported value binding" sym) )
+ (and-let* ((a (assq sym senv)))
+ (##sys#warn "redefinition of imported syntax binding" sym)))
+
+(define (##sys#register-export sym mod)
+ (when mod
+ (let ((exp (or (eq? #t (module-export-list mod))
+ (##sys#find-export sym mod #t)))
+ (ulist (module-undefined-list mod)))
+ (##sys#toplevel-definition-hook ; in compiler, hides unexported bindings
+ (##sys#module-rename sym (module-name mod))
+ mod exp #f)
+ (when (memq sym ulist)
+ (set-module-undefined-list! mod (##sys#delq sym ulist)))
+ (check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
+ (set-module-exist-list! mod (cons sym (module-exist-list mod)))
+ (when exp
+ (dm "defined: " sym)
+ (set-module-defined-list!
+ mod
+ (cons (cons sym #f)
+ (module-defined-list mod)))))) )
+
+(define (##sys#register-syntax-export sym mod val)
+ (when mod
+ (let ((exp (or (eq? #t (module-export-list mod))
+ (##sys#find-export sym mod #t)))
+ (ulist (module-undefined-list mod))
+ (mname (module-name mod)))
+ (when (memq sym ulist)
+ (##sys#warn "use of syntax precedes definition" sym))
+ (check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
+ (dm "defined syntax: " sym)
+ (when exp
+ (set-module-defined-list!
+ mod
+ (cons (cons sym val)
+ (module-defined-list mod))) )
+ (set-module-defined-syntax-list!
+ mod
+ (cons (cons sym val) (module-defined-syntax-list mod))))))
+
+(define (##sys#register-undefined sym mod)
+ (when mod
+ (let ((ul (module-undefined-list mod)))
+ (unless (memq sym ul)
+ (set-module-undefined-list! mod (cons sym ul))))))
+
+(define (##sys#register-module name explist #!optional (vexports '()) (sexports '()))
+ (let ((mod (make-module name explist vexports sexports)))
+ (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
+ mod) )
+
+(define (##sys#mark-imported-symbols se)
+ (for-each
+ (lambda (imp)
+ (when (and (symbol? (cdr imp)) (not (eq? (car imp) (cdr imp))))
+ (dm `(MARKING: ,(cdr imp)))
+ (##sys#put! (cdr imp) '##core#aliased #t)))
+ se))
+
+(define (module-indirect-exports mod)
+ (let ((exports (module-export-list mod))
+ (mname (module-name mod))
+ (dlist (module-defined-list mod)))
+ (define (indirect? id)
+ (let loop ((exports exports))
+ (and (not (null? exports))
+ (or (and (pair? (car exports))
+ (memq id (cdar exports)))
+ (loop (cdr exports))))))
+ (define (warn msg id)
+ (##sys#warn
+ (string-append msg " in module `" (symbol->string mname) "'")
+ id))
+ (if (eq? #t exports)
+ '()
+ (let loop ((exports exports)) ; walk export list
+ (cond ((null? exports) '())
+ ((symbol? (car exports)) (loop (cdr exports))) ; normal export
+ (else
+ (let loop2 ((iexports (cdar exports))) ; walk indirect exports for a given entry
+ (cond ((null? iexports) (loop (cdr exports)))
+ ((assq (car iexports) (##sys#macro-environment))
+ (warn "indirect export of syntax binding" (car iexports))
+ (loop2 (cdr iexports)))
+ ((assq (car iexports) dlist) => ; defined in current module?
+ (lambda (a)
+ (cons
+ (cons
+ (car iexports)
+ (or (cdr a) (##sys#module-rename (car iexports) mname)))
+ (loop2 (cdr iexports)))))
+ ((assq (car iexports) (##sys#current-environment)) =>
+ (lambda (a) ; imported in current env.
+ (cond ((symbol? (cdr a)) ; not syntax
+ (cons (cons (car iexports) (cdr a)) (loop2 (cdr iexports))) )
+ (else
+ (warn "indirect reexport of syntax" (car iexports))
+ (loop2 (cdr iexports))))))
+ (else
+ (warn "indirect export of unknown binding" (car iexports))
+ (loop2 (cdr iexports)))))))))))
+
+(define (merge-se . ses) ; later occurrences take precedence to earlier ones
+ (let ((se (apply append ses)))
+ (dm "merging " (length ses) " se's with total length of " (length se))
+ (let ((se2
+ (let loop ((se se))
+ (cond ((null? se) '())
+ ((assq (caar se) (cdr se)) (loop (cdr se)))
+ (else (cons (car se) (loop (cdr se))))))))
+ (dm " merged has length " (length se2))
+ se2)))
+
+(define (##sys#compiled-module-registration mod)
+ (let ((dlist (module-defined-list mod))
+ (mname (module-name mod))
+ (ifs (module-import-forms mod))
+ (sexports (module-sexports mod))
+ (mifs (module-meta-import-forms mod)))
+ `(,@(if (pair? ifs) `((eval '(import ,@(##sys#strip-syntax ifs)))) '())
+ ,@(if (pair? mifs) `((import ,@(##sys#strip-syntax mifs))) '())
+ ,@(reverse (map ##sys#strip-syntax (module-meta-expressions mod)))
+ (##sys#register-compiled-module
+ ',(module-name mod)
+ (list
+ ,@(map (lambda (ie)
+ (if (symbol? (cdr ie))
+ `'(,(car ie) . ,(cdr ie))
+ `(list ',(car ie) '() ,(cdr ie))))
+ (module-indirect-exports mod)))
+ ',(module-vexports mod)
+ (list
+ ,@(map (lambda (sexport)
+ (let* ((name (car sexport))
+ (a (assq name dlist)))
+ (cond ((pair? a)
+ `(cons ',(car sexport) ,(##sys#strip-syntax (cdr a))))
+ (else
+ (dm "re-exported syntax" name mname)
+ `',name))))
+ sexports))
+ (list
+ ,@(if (null? sexports)
+ '() ; no syntax exported - no more info needed
+ (let loop ((sd (module-defined-syntax-list mod)))
+ (cond ((null? sd) '())
+ ((assq (caar sd) sexports) (loop (cdr sd)))
+ (else
+ (let ((name (caar sd)))
+ (cons `(cons ',(caar sd) ,(##sys#strip-syntax (cdar sd)))
+ (loop (cdr sd)))))))))))))
+
+(define (##sys#register-compiled-module name iexports vexports sexports #!optional
+ (sdefs '()))
+ (define (find-reexport name)
+ (let ((a (assq name (##sys#macro-environment))))
+ (if (and a (pair? (cdr a)))
+ a
+ (##sys#error
+ 'import "cannot find implementation of re-exported syntax"
+ name))))
+ (let* ((sexps
+ (map (lambda (se)
+ (if (symbol? se)
+ (find-reexport se)
+ (list (car se) #f (##sys#er-transformer (cdr se)))))
+ sexports))
+ (iexps
+ (map (lambda (ie)
+ (if (pair? (cdr ie))
+ (list (car ie) (cadr ie) (##sys#er-transformer (caddr ie)))
+ ie))
+ iexports))
+ (nexps
+ (map (lambda (ne)
+ (list (car ne) #f (##sys#er-transformer (cdr ne))))
+ sdefs))
+ (mod (make-module name '() vexports sexps))
+ (senv (merge-se
+ (##sys#macro-environment)
+ (##sys#current-environment)
+ iexps vexports sexps nexps)))
+ (##sys#mark-imported-symbols iexps)
+ (for-each
+ (lambda (sexp)
+ (set-car! (cdr sexp) senv))
+ sexps)
+ (for-each
+ (lambda (iexp)
+ (when (pair? (cdr iexp))
+ (set-car! (cdr iexp) senv)))
+ iexps)
+ (for-each
+ (lambda (nexp)
+ (set-car! (cdr nexp) senv))
+ nexps)
+ (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
+ mod))
+
+(define (##sys#primitive-alias sym)
+ (let ((palias
+ (##sys#string->symbol
+ (##sys#string-append "#%" (##sys#slot sym 1)))))
+ (##sys#put! palias '##core#primitive sym)
+ palias))
+
+(define (##sys#register-primitive-module name vexports #!optional (sexports '()))
+ (let* ((me (##sys#macro-environment))
+ (mod (make-module
+ name '()
+ (map (lambda (ve)
+ (if (symbol? ve)
+ (cons ve (##sys#primitive-alias ve))
+ ve))
+ vexports)
+ (map (lambda (se)
+ (if (symbol? se)
+ (or (assq se me)
+ (##sys#error "unknown macro referenced while registering module" se name))
+ se))
+ sexports))))
+ (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
+ mod))
+
+(define (##sys#find-export sym mod indirect)
+ (let ((exports (module-export-list mod)))
+ (let loop ((xl (if (eq? #t exports) (module-exists-list mod) exports)))
+ (cond ((null? xl) #f)
+ ((eq? sym (car xl)))
+ ((pair? (car xl))
+ (or (eq? sym (caar xl))
+ (and indirect (memq sym (cdar xl)))
+ (loop (cdr xl))))
+ (else (loop (cdr xl)))))))
+
+(define (##sys#finalize-module mod)
+ (let* ((explist (module-export-list mod))
+ (name (module-name mod))
+ (dlist (module-defined-list mod))
+ (elist (module-exist-list mod))
+ (missing #f)
+ (sdlist (map (lambda (sym) (assq (car sym) (##sys#macro-environment)))
+ (module-defined-syntax-list mod)))
+ (sexports
+ (if (eq? #t explist)
+ sdlist
+ (let loop ((me (##sys#macro-environment)))
+ (cond ((null? me) '())
+ ((##sys#find-export (caar me) mod #f)
+ (cons (car me) (loop (cdr me))))
+ (else (loop (cdr me)))))))
+ (vexports
+ (let loop ((xl (if (eq? #t explist) elist explist)))
+ (if (null? xl)
+ '()
+ (let* ((h (car xl))
+ (id (if (symbol? h) h (car h))))
+ (if (assq id sexports)
+ (loop (cdr xl))
+ (cons
+ (cons
+ id
+ (let ((def (assq id dlist)))
+ (if (and def (symbol? (cdr def)))
+ (cdr def)
+ (let ((a (assq id (##sys#current-environment))))
+ (cond ((and a (symbol? (cdr a)))
+ (dm "reexporting: " id " -> " (cdr a))
+ (cdr a))
+ ((not def)
+ (set! missing #t)
+ (##sys#warn
+ (string-append
+ "exported identifier for module `"
+ (symbol->string name)
+ "' has not been defined")
+ id)
+ #f)
+ (else (##sys#module-rename id name)))))))
+ (loop (cdr xl)))))))))
+ (for-each
+ (lambda (u)
+ (unless (memq u elist)
+ (set! missing #t)
+ (##sys#warn "reference to possibly unbound identifier" u)
+ (and-let* ((a (##sys#get u '##core#db)))
+ (if (= 1 (length a))
+ (##sys#warn
+ (string-append
+ " suggesting: `(import " (symbol->string (cadar a))
+ ")'"))
+ (##sys#warn
+ (string-append
+ " suggesting one of:\n"
+ (let loop ((lst a))
+ (if (null? lst)
+ ""
+ (string-append
+ "Warning: `(import " (symbol->string (cadar lst)) ")'\n"
+ (loop (cdr lst)))))))))))
+ (module-undefined-list mod))
+ (when missing
+ (##sys#error "module unresolved" name))
+ (let* ((exports
+ (map (lambda (exp)
+ (cond ((symbol? (cdr exp)) exp)
+ ((assq (car exp) (##sys#macro-environment)))
+ (else (##sys#error "(internal) indirect export not found" (car exp)))) )
+ (module-indirect-exports mod)))
+ (new-se (merge-se
+ (##sys#macro-environment)
+ (##sys#current-environment)
+ exports)))
+ (##sys#mark-imported-symbols exports)
+ (for-each
+ (lambda (m)
+ (let ((se (merge-se (cadr m) new-se)))
+ (dm `(FIXUP: ,(car m) ,@(map-se se)))
+ (set-car! (cdr m) se)))
+ sdlist)
+ (dm `(EXPORTS:
+ ,(module-name mod)
+ (DLIST: ,@dlist)
+ (SDLIST: ,@(map-se sdlist))
+ (IEXPORTS: ,@(map-se exports))
+ (VEXPORTS: ,@(map-se vexports))
+ (SEXPORTS: ,@(map-se sexports))))
+ (set-module-vexports! mod vexports)
+ (set-module-sexports! mod sexports))))
+
+(define ##sys#module-table '())
diff --git a/extras.import.scm b/extras.import.scm
new file mode 100644
index 00000000..ce6b6980
--- /dev/null
+++ b/extras.import.scm
@@ -0,0 +1,48 @@
+;;;; extras.import.scm - import library for "extras" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'extras
+ '(format
+ fprintf
+ pp
+ pretty-print
+ pretty-print-width
+ printf
+ random
+ random-seed
+ randomize
+ read-byte
+ read-file
+ read-line
+ read-lines
+ read-string
+ read-string!
+ read-token
+ sprintf
+ write-byte
+ write-line
+ write-string))
diff --git a/extras.scm b/extras.scm
new file mode 100644
index 00000000..a4075db0
--- /dev/null
+++ b/extras.scm
@@ -0,0 +1,676 @@
+;;; extras.scm - Optional non-standard extensions
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit extras)
+ (uses data-structures ports)
+ (usual-integrations)
+ (disable-warning redef) )
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ (no-bound-checks)
+ (no-procedure-checks-for-usual-bindings)
+ (bound-to-procedure
+ ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-string
+ ##sys#substring ##sys#for-each ##sys#map ##sys#setslot
+ ##sys#allocate-vector ##sys#check-pair ##sys#error-not-a-proper-list
+ ##sys#member ##sys#assoc ##sys#error ##sys#signal-hook ##sys#read-string!
+ ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling
+ ##sys#truncate ##sys#round ##sys#check-number ##sys#cons-flonum
+ ##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg
+ ##sys#print ##sys#check-structure ##sys#make-structure make-parameter
+ ##sys#flush-output ##sys#write-char-0 ##sys#number->string
+ ##sys#fragments->string ##sys#symbol->qualified-string
+ ##sys#number? ##sys#procedure->string
+ ##sys#pointer->string ##sys#user-print-hook ##sys#peek-char-0
+ ##sys#read-char-0 ##sys#write-char ##sys#string-append ##sys#gcd ##sys#lcm
+ ##sys#fudge ##sys#check-list ##sys#user-read-hook ##sys#check-closure ##sys#check-inexact
+ input-port? make-vector list->vector sort! merge! open-output-string floor
+ get-output-string current-output-port display write port? list->string
+ make-string string pretty-print-width newline char-name read random
+ open-input-string make-string call-with-input-file read-line reverse ) ) ] )
+
+(declare
+ (hide
+ fprintf0 generic-write) )
+
+(include "unsafe-declarations.scm")
+
+(register-feature! 'extras)
+
+
+;;; Read expressions from file:
+
+(define read-file
+ (let ([read read]
+ [reverse reverse]
+ [call-with-input-file call-with-input-file] )
+ (lambda (#!optional (port ##sys#standard-input) (reader read) max)
+ (define (slurp port)
+ (do ((x (reader port) (reader port))
+ (i 0 (fx+ i 1))
+ (xs '() (cons x xs)) )
+ ((or (eof-object? x) (and max (fx>= i max))) (reverse xs)) ) )
+ (if (port? port)
+ (slurp port)
+ (call-with-input-file port slurp) ) ) ) )
+
+
+;;; Random numbers:
+
+(define random-seed
+ (let ((srand (foreign-lambda void "srand" unsigned-integer)))
+ (lambda n
+ (let ((t (if (null? n) (current-seconds) (car n))))
+ (##sys#check-integer t 'random-seed)
+ (srand t) ) ) ) )
+
+(define (randomize . n)
+ (let ((nn (if (null? n) (##sys#fudge 2) (car n))))
+ (##sys#check-exact nn 'randomize)
+ (##core#inline "C_randomize" nn) ) )
+
+(define (random n)
+ (##sys#check-exact n 'random)
+ (if (eq? n 0)
+ 0
+ (##core#inline "C_random_fixnum" n) ) )
+
+
+;;; Line I/O:
+
+(define read-line
+ (let ([make-string make-string])
+ (define (fixup str len)
+ (##sys#substring
+ str 0
+ (if (and (fx>= len 1) (char=? #\return (##core#inline "C_subchar" str (fx- len 1))))
+ (fx- len 1)
+ len) ) )
+ (lambda args
+ (let* ([parg (pair? args)]
+ [p (if parg (car args) ##sys#standard-input)]
+ [limit (and parg (pair? (cdr args)) (cadr args))])
+ (##sys#check-port p 'read-line)
+ (cond ((##sys#slot (##sys#slot p 2) 8) => (lambda (rl) (rl p limit)))
+ (else
+ (let* ((buffer-len (if limit limit 256))
+ (buffer (##sys#make-string buffer-len)))
+ (let loop ([i 0])
+ (if (and limit (fx>= i limit))
+ (##sys#substring buffer 0 i)
+ (let ([c (##sys#read-char-0 p)])
+ (if (eof-object? c)
+ (if (fx= i 0)
+ c
+ (##sys#substring buffer 0 i) )
+ (case c
+ [(#\newline) (##sys#substring buffer 0 i)]
+ [(#\return)
+ (let ([c (peek-char p)])
+ (if (char=? c #\newline)
+ (begin (##sys#read-char-0 p)
+ (##sys#substring buffer 0 i))
+ (##sys#substring buffer 0 i) ) ) ]
+ [else
+ (when (fx>= i buffer-len)
+ (set! buffer (##sys#string-append buffer (make-string buffer-len)))
+ (set! buffer-len (fx+ buffer-len buffer-len)) )
+ (##core#inline "C_setsubchar" buffer i c)
+ (loop (fx+ i 1)) ] ) ) ) ) ) ) ) ) ) ) ) )
+
+(define read-lines
+ (let ((read-line read-line)
+ (call-with-input-file call-with-input-file)
+ (reverse reverse) )
+ (lambda port-and-max
+ (let* ((port (if (pair? port-and-max) (##sys#slot port-and-max 0) ##sys#standard-input))
+ (rest (and (pair? port-and-max) (##sys#slot port-and-max 1)))
+ (max (if (pair? rest) (##sys#slot rest 0) #f)) )
+ (define (doread port)
+ (let loop ((lns '())
+ (n (or max 1000000000)) ) ; this is silly
+ (if (eq? n 0)
+ (reverse lns)
+ (let ((ln (read-line port)))
+ (if (eof-object? ln)
+ (reverse lns)
+ (loop (cons ln lns) (fx- n 1)) ) ) ) ) )
+ (if (string? port)
+ (call-with-input-file port doread)
+ (begin
+ (##sys#check-port port 'read-lines)
+ (doread port) ) ) ) ) ) )
+
+
+;;; Extended I/O
+
+(define (##sys#read-string! n dest port start)
+ (cond ((eq? n 0) 0)
+ (else
+ (when (##sys#slot port 6) ; peeked?
+ (##core#inline "C_setsubchar" dest start (##sys#read-char-0 port))
+ (set! start (fx+ start 1)) )
+ (let ((rdstring (##sys#slot (##sys#slot port 2) 7)))
+ (if rdstring
+ (let loop ((start start) (n n) (m 0))
+ (let ((n2 (rdstring port n dest start)))
+ (##sys#setislot port 5 ; update port-position
+ (fx+ (##sys#slot port 5) n2))
+ (cond ((eq? n2 0) m)
+ ((or (not n) (fx< n2 n))
+ (loop (fx+ start n2) (and n (fx- n n2)) (fx+ m n2)))
+ (else (fx+ n2 m)))))
+ (let loop ((start start) (n n) (m 0))
+ (let ((n2 (let ((c (##sys#read-char-0 port)))
+ (if (eof-object? c)
+ 0
+ (begin
+ (##core#inline "C_setsubchar" dest start c)
+ 1) ) ) ) )
+ (cond ((eq? n2 0) m)
+ ((or (not n) (fx< n2 n))
+ (loop (fx+ start n2) (and n (fx- n n2)) (fx+ m n2)) )
+ (else (fx+ n2 m))) )))))))
+
+(define (read-string! n dest #!optional (port ##sys#standard-input) (start 0))
+ (##sys#check-port port 'read-string!)
+ (##sys#check-string dest 'read-string!)
+ (when n
+ (##sys#check-exact n 'read-string!)
+ (when (fx> (fx+ start n) (##sys#size dest))
+ (set! n (fx- (##sys#size dest) start))))
+ (##sys#check-exact start 'read-string!)
+ (##sys#read-string! n dest port start) )
+
+(define-constant read-string-buffer-size 2048)
+
+(define ##sys#read-string/port
+ (let ((open-output-string open-output-string)
+ (get-output-string get-output-string) )
+ (lambda (n p)
+ (##sys#check-port p 'read-string)
+ (cond (n (##sys#check-exact n 'read-string)
+ (let* ((str (##sys#make-string n))
+ (n2 (##sys#read-string! n str p 0)) )
+ (if (eq? n n2)
+ str
+ (##sys#substring str 0 n2))))
+ (else
+ (let ([out (open-output-string)]
+ (buf (make-string read-string-buffer-size)))
+ (let loop ()
+ (let ((n (##sys#read-string! read-string-buffer-size
+ buf p 0)))
+ (cond ((eq? n 0)
+ (get-output-string out))
+ (else
+ (write-string buf n out)
+ (loop)))))))))))
+
+(define (read-string #!optional n (port ##sys#standard-input))
+ (##sys#read-string/port n port) )
+
+(define read-token
+ (let ([open-output-string open-output-string]
+ [get-output-string get-output-string] )
+ (lambda (pred . port)
+ (let ([port (optional port ##sys#standard-input)])
+ (##sys#check-port port 'read-token)
+ (let ([out (open-output-string)])
+ (let loop ()
+ (let ([c (##sys#peek-char-0 port)])
+ (if (and (not (eof-object? c)) (pred c))
+ (begin
+ (##sys#write-char-0 (##sys#read-char-0 port) out)
+ (loop) )
+ (get-output-string out) ) ) ) ) ) ) ) )
+
+(define write-string
+ (let ([display display])
+ (lambda (s . more)
+ (##sys#check-string s 'write-string)
+ (let-optionals more ([n #f] [port ##sys#standard-output])
+ (##sys#check-port port 'write-string)
+ (when n (##sys#check-exact n 'write-string))
+ (display
+ (if (and n (fx< n (##sys#size s)))
+ (##sys#substring s 0 n)
+ s)
+ port) ) ) ) )
+
+(define write-line
+ (let ((display display)
+ (newline newline) )
+ (lambda (str . port)
+ (let ((p (if (##core#inline "C_eqp" port '())
+ ##sys#standard-output
+ (##sys#slot port 0) ) ) )
+ (##sys#check-port p 'write-line)
+ (##sys#check-string str 'write-line)
+ (display str p)
+ (newline p) ) ) ) )
+
+
+;;; Binary I/O
+
+(define (read-byte #!optional (port ##sys#standard-input))
+ (##sys#check-port port 'read-byte)
+ (let ((x (##sys#read-char-0 port)))
+ (if (eof-object? x)
+ x
+ (char->integer x) ) ) )
+
+(define (write-byte byte #!optional (port ##sys#standard-output))
+ (##sys#check-exact byte 'write-byte)
+ (##sys#check-port port 'write-byte)
+ (##sys#write-char-0 (integer->char byte) port) )
+
+
+
+
+;;; Pretty print:
+;
+; Copyright (c) 1991, Marc Feeley
+; Author: Marc Feeley (feeley@iro.umontreal.ca)
+; Distribution restrictions: none
+;
+; Modified by felix for use with CHICKEN
+;
+
+(define generic-write
+ (let ([open-output-string open-output-string]
+ [get-output-string get-output-string] )
+ (lambda (obj display? width output)
+
+ (define (read-macro? l)
+ (define (length1? l) (and (pair? l) (null? (cdr l))))
+ (let ((head (car l)) (tail (cdr l)))
+ (case head
+ ((quote quasiquote unquote unquote-splicing) (length1? tail))
+ (else #f))))
+
+ (define (read-macro-body l)
+ (cadr l))
+
+ (define (read-macro-prefix l)
+ (let ((head (car l)) (tail (cdr l)))
+ (case head
+ ((quote) "'")
+ ((quasiquote) "`")
+ ((unquote) ",")
+ ((unquote-splicing) ",@"))))
+
+ (define (out str col)
+ (and col (output str) (+ col (string-length str))))
+
+ (define (wr obj col)
+
+ (define (wr-expr expr col)
+ (if (read-macro? expr)
+ (wr (read-macro-body expr) (out (read-macro-prefix expr) col))
+ (wr-lst expr col)))
+
+ (define (wr-lst l col)
+ (if (pair? l)
+ (let loop ((l (cdr l))
+ (col (and col (wr (car l) (out "(" col)))))
+ (cond ((not col) col)
+ ((pair? l)
+ (loop (cdr l) (wr (car l) (out " " col))))
+ ((null? l) (out ")" col))
+ (else (out ")" (wr l (out " . " col))))))
+ (out "()" col)))
+
+ (cond ((pair? obj) (wr-expr obj col))
+ ((null? obj) (wr-lst obj col))
+ ((eof-object? obj) (out "#!eof" col))
+ ((vector? obj) (wr-lst (vector->list obj) (out "#" col)))
+ ((boolean? obj) (out (if obj "#t" "#f") col))
+ ((##sys#number? obj) (out (##sys#number->string obj) col))
+ ((symbol? obj)
+ (let ([s (open-output-string)])
+ (##sys#print obj #t s)
+ (out (get-output-string s) col) ) )
+ ((procedure? obj) (out (##sys#procedure->string obj) col))
+ ((string? obj) (if display?
+ (out obj col)
+ (let loop ((i 0) (j 0) (col (out "\"" col)))
+ (if (and col (< j (string-length obj)))
+ (let ((c (string-ref obj j)))
+ (if (or (char=? c #\\)
+ (char=? c #\"))
+ (loop j
+ (+ j 1)
+ (out "\\"
+ (out (##sys#substring obj i j)
+ col)))
+ (loop i (+ j 1) col)))
+ (out "\""
+ (out (##sys#substring obj i j) col))))))
+ ((char? obj) (if display?
+ (out (make-string 1 obj) col)
+ (let ([code (char->integer obj)])
+ (out "#\\" col)
+ (cond [(char-name obj)
+ => (lambda (cn)
+ (out (##sys#slot cn 1) col) ) ]
+ [(fx< code 32)
+ (out "x" col)
+ (out (number->string code 16) col) ]
+ [(fx> code 255)
+ (out (if (fx> code #xffff) "U" "u") col)
+ (out (number->string code 16) col) ]
+ [else (out (make-string 1 obj) col)] ) ) ) )
+ ((eof-object? obj) (out "#<eof>" col))
+ ((##core#inline "C_undefinedp" obj) (out "#<unspecified>" col))
+ ((##core#inline "C_anypointerp" obj) (out (##sys#pointer->string obj) col))
+ ((eq? obj (##sys#slot '##sys#arbitrary-unbound-symbol 0))
+ (out "#<unbound value>" col) )
+ ((##sys#generic-structure? obj)
+ (let ([o (open-output-string)])
+ (##sys#user-print-hook obj #t o)
+ (out (get-output-string o) col) ) )
+ ((port? obj) (out (string-append "#<port " (##sys#slot obj 3) ">") col))
+ ((##core#inline "C_bytevectorp" obj)
+ (if (##core#inline "C_permanentp" obj)
+ (out "#<static blob of size" col)
+ (out "#<blob of size " col) )
+ (out (number->string (##core#inline "C_block_size" obj)) col)
+ (out ">" col) )
+ ((##core#inline "C_lambdainfop" obj)
+ (out "#<lambda info " col)
+ (out (##sys#lambda-info->string obj) col)
+ (out "#>" col) )
+ (else (out "#<unprintable object>" col)) ) )
+
+ (define (pp obj col)
+
+ (define (spaces n col)
+ (if (> n 0)
+ (if (> n 7)
+ (spaces (- n 8) (out " " col))
+ (out (##sys#substring " " 0 n) col))
+ col))
+
+ (define (indent to col)
+ (and col
+ (if (< to col)
+ (and (out (make-string 1 #\newline) col) (spaces to 0))
+ (spaces (- to col) col))))
+
+ (define (pr obj col extra pp-pair)
+ (if (or (pair? obj) (vector? obj)) ; may have to split on multiple lines
+ (let ((result '())
+ (left (max (+ (- (- width col) extra) 1) max-expr-width)))
+ (generic-write obj display? #f
+ (lambda (str)
+ (set! result (cons str result))
+ (set! left (- left (string-length str)))
+ (> left 0)))
+ (if (> left 0) ; all can be printed on one line
+ (out (reverse-string-append result) col)
+ (if (pair? obj)
+ (pp-pair obj col extra)
+ (pp-list (vector->list obj) (out "#" col) extra pp-expr))))
+ (wr obj col)))
+
+ (define (pp-expr expr col extra)
+ (if (read-macro? expr)
+ (pr (read-macro-body expr)
+ (out (read-macro-prefix expr) col)
+ extra
+ pp-expr)
+ (let ((head (car expr)))
+ (if (symbol? head)
+ (let ((proc (style head)))
+ (if proc
+ (proc expr col extra)
+ (if (> (string-length (##sys#symbol->qualified-string head))
+ max-call-head-width)
+ (pp-general expr col extra #f #f #f pp-expr)
+ (pp-call expr col extra pp-expr))))
+ (pp-list expr col extra pp-expr)))))
+
+ ; (head item1
+ ; item2
+ ; item3)
+ (define (pp-call expr col extra pp-item)
+ (let ((col* (wr (car expr) (out "(" col))))
+ (and col
+ (pp-down (cdr expr) col* (+ col* 1) extra pp-item))))
+
+ ; (item1
+ ; item2
+ ; item3)
+ (define (pp-list l col extra pp-item)
+ (let ((col (out "(" col)))
+ (pp-down l col col extra pp-item)))
+
+ (define (pp-down l col1 col2 extra pp-item)
+ (let loop ((l l) (col col1))
+ (and col
+ (cond ((pair? l)
+ (let ((rest (cdr l)))
+ (let ((extra (if (null? rest) (+ extra 1) 0)))
+ (loop rest
+ (pr (car l) (indent col2 col) extra pp-item)))))
+ ((null? l)
+ (out ")" col))
+ (else
+ (out ")"
+ (pr l
+ (indent col2 (out "." (indent col2 col)))
+ (+ extra 1)
+ pp-item)))))))
+
+ (define (pp-general expr col extra named? pp-1 pp-2 pp-3)
+
+ (define (tail1 rest col1 col2 col3)
+ (if (and pp-1 (pair? rest))
+ (let* ((val1 (car rest))
+ (rest (cdr rest))
+ (extra (if (null? rest) (+ extra 1) 0)))
+ (tail2 rest col1 (pr val1 (indent col3 col2) extra pp-1) col3))
+ (tail2 rest col1 col2 col3)))
+
+ (define (tail2 rest col1 col2 col3)
+ (if (and pp-2 (pair? rest))
+ (let* ((val1 (car rest))
+ (rest (cdr rest))
+ (extra (if (null? rest) (+ extra 1) 0)))
+ (tail3 rest col1 (pr val1 (indent col3 col2) extra pp-2)))
+ (tail3 rest col1 col2)))
+
+ (define (tail3 rest col1 col2)
+ (pp-down rest col2 col1 extra pp-3))
+
+ (let* ((head (car expr))
+ (rest (cdr expr))
+ (col* (wr head (out "(" col))))
+ (if (and named? (pair? rest))
+ (let* ((name (car rest))
+ (rest (cdr rest))
+ (col** (wr name (out " " col*))))
+ (tail1 rest (+ col indent-general) col** (+ col** 1)))
+ (tail1 rest (+ col indent-general) col* (+ col* 1)))))
+
+ (define (pp-expr-list l col extra)
+ (pp-list l col extra pp-expr))
+
+ (define (pp-lambda expr col extra)
+ (pp-general expr col extra #f pp-expr-list #f pp-expr))
+
+ (define (pp-if expr col extra)
+ (pp-general expr col extra #f pp-expr #f pp-expr))
+
+ (define (pp-cond expr col extra)
+ (pp-call expr col extra pp-expr-list))
+
+ (define (pp-case expr col extra)
+ (pp-general expr col extra #f pp-expr #f pp-expr-list))
+
+ (define (pp-and expr col extra)
+ (pp-call expr col extra pp-expr))
+
+ (define (pp-let expr col extra)
+ (let* ((rest (cdr expr))
+ (named? (and (pair? rest) (symbol? (car rest)))))
+ (pp-general expr col extra named? pp-expr-list #f pp-expr)))
+
+ (define (pp-begin expr col extra)
+ (pp-general expr col extra #f #f #f pp-expr))
+
+ (define (pp-do expr col extra)
+ (pp-general expr col extra #f pp-expr-list pp-expr-list pp-expr))
+
+ ; define formatting style (change these to suit your style)
+
+ (define indent-general 2)
+
+ (define max-call-head-width 5)
+
+ (define max-expr-width 50)
+
+ (define (style head)
+ (case head
+ ((lambda let* letrec define) pp-lambda)
+ ((if set!) pp-if)
+ ((cond) pp-cond)
+ ((case) pp-case)
+ ((and or) pp-and)
+ ((let) pp-let)
+ ((begin) pp-begin)
+ ((do) pp-do)
+ (else #f)))
+
+ (pr obj col 0 pp-expr))
+
+ (if width
+ (out (make-string 1 #\newline) (pp obj 0))
+ (wr obj 0)))) )
+
+; (pretty-print obj port) pretty prints 'obj' on 'port'. The current
+; output port is used if 'port' is not specified.
+
+(define pretty-print-width (make-parameter 79))
+
+(define (pretty-print obj . opt)
+ (let ((port (if (pair? opt) (car opt) (current-output-port))))
+ (generic-write obj #f (pretty-print-width) (lambda (s) (display s port) #t))
+ (##core#undefined) ) )
+
+(define pp pretty-print)
+
+
+;;; Write simple formatted output:
+
+(define fprintf0
+ (let ((write write)
+ (newline newline)
+ (display display)
+ (open-output-string open-output-string)
+ (get-output-string get-output-string))
+ (lambda (loc port msg args)
+ (when port (##sys#check-port port loc))
+ (let ((out (if (and port (##sys#tty-port? port))
+ port
+ (open-output-string))))
+ (let rec ([msg msg] [args args])
+ (##sys#check-string msg loc)
+ (let ((index 0)
+ (len (##sys#size msg)) )
+ (define (fetch)
+ (let ((c (##core#inline "C_subchar" msg index)))
+ (set! index (fx+ index 1))
+ c) )
+ (define (next)
+ (if (cond-expand [unsafe #f] [else (##core#inline "C_eqp" args '())])
+ (##sys#error loc "too few arguments to formatted output procedure")
+ (let ((x (##sys#slot args 0)))
+ (set! args (##sys#slot args 1))
+ x) ) )
+ (let loop ()
+ (unless (fx>= index len)
+ (let ((c (fetch)))
+ (if (and (eq? c #\~) (fx< index len))
+ (let ((dchar (fetch)))
+ (case (char-upcase dchar)
+ ((#\S) (write (next) out))
+ ((#\A) (display (next) out))
+ ((#\C) (##sys#write-char-0 (next) out))
+ ((#\B) (display (##sys#number->string (next) 2) out))
+ ((#\O) (display (##sys#number->string (next) 8) out))
+ ((#\X) (display (##sys#number->string (next) 16) out))
+ ((#\!) (##sys#flush-output out))
+ ((#\?)
+ (let* ([fstr (next)]
+ [lst (next)] )
+ (##sys#check-list lst loc)
+ (rec fstr lst) out) )
+ ((#\~) (##sys#write-char-0 #\~ out))
+ ((#\% #\N) (newline out))
+ (else
+ (if (char-whitespace? dchar)
+ (let skip ((c (fetch)))
+ (if (char-whitespace? c)
+ (skip (fetch))
+ (set! index (fx- index 1)) ) )
+ (##sys#error loc "illegal format-string character" dchar) ) ) ) )
+ (##sys#write-char-0 c out) )
+ (loop) ) ) ) ) )
+ (cond ((not port) (get-output-string out))
+ ((not (eq? out port))
+ (##sys#print (get-output-string out) #f port) ) ) ) ) ) )
+
+(define (fprintf port fstr . args)
+ (fprintf0 'fprintf port fstr args) )
+
+(define (printf fstr . args)
+ (fprintf0 'printf ##sys#standard-output fstr args) )
+
+(define (sprintf fstr . args)
+ (fprintf0 'sprintf #f fstr args) )
+
+(define format
+ (let ([fprintf fprintf]
+ [sprintf sprintf]
+ [printf printf] )
+ (lambda (fmt-or-dst . args)
+ (apply (cond [(not fmt-or-dst) sprintf]
+ [(boolean? fmt-or-dst) printf]
+ [(string? fmt-or-dst) (set! args (cons fmt-or-dst args)) sprintf]
+ [(output-port? fmt-or-dst) (set! args (cons fmt-or-dst args)) fprintf]
+ [else
+ (##sys#error 'format "illegal destination" fmt-or-dst args)])
+ args) ) ) )
+
+(register-feature! 'srfi-28)
+
diff --git a/files.import.scm b/files.import.scm
new file mode 100644
index 00000000..2c484453
--- /dev/null
+++ b/files.import.scm
@@ -0,0 +1,46 @@
+;;;; files.import.scm - import library for "files" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'files
+ '(delete-file*
+ file-copy
+ file-move
+ make-pathname
+ directory-null?
+ make-absolute-pathname
+ create-temporary-file
+ decompose-pathname
+ absolute-pathname?
+ pathname-directory
+ pathname-extension
+ pathname-file
+ pathname-replace-directory
+ pathname-replace-extension
+ pathname-replace-file
+ pathname-strip-directory
+ pathname-strip-extension
+ normalize-pathname))
diff --git a/files.scm b/files.scm
new file mode 100644
index 00000000..4edaf329
--- /dev/null
+++ b/files.scm
@@ -0,0 +1,459 @@
+;;;; files.scm - File and pathname operations
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without
+; modification, are permitted provided that the following conditions
+; are met:
+;
+; Redistributions of source code must retain the above copyright
+; notice, this list of conditions and the following disclaimer.
+;
+; 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.
+;
+; Neither the name of the author nor the names of its contributors
+; may be used to endorse or promote products derived from this
+; software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+; OF THE POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit files)
+ (uses regex data-structures)
+ (usual-integrations)
+ (fixnum)
+ (hide chop-pds absolute-pathname-root root-origin root-directory split-directory)
+ (disable-interrupts) )
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ (always-bound
+ ##sys#windows-platform)
+ (bound-to-procedure
+ string-match regexp
+ ##sys#string-append ##sys#substring string-append
+ get-environment-variable
+ file-exists? delete-file
+ call-with-output-file read-string)
+ (no-procedure-checks-for-usual-bindings)
+ (no-bound-checks))] )
+
+(include "unsafe-declarations.scm")
+
+(register-feature! 'files)
+
+
+;;; Like `delete-file', but does nothing if the file doesn't exist:
+
+(define delete-file*
+ (let ([file-exists? file-exists?]
+ [delete-file delete-file] )
+ (lambda (file)
+ (and (file-exists? file) (delete-file file) #t) ) ) )
+
+;;; file-copy and file-move : they do what you'd think.
+(define (file-copy origfile newfile #!optional (clobber #f) (blocksize 1024))
+ (##sys#check-string origfile 'file-copy)
+ (##sys#check-string newfile 'file-copy)
+ (##sys#check-number blocksize 'file-copy)
+ (or (and (integer? blocksize) (> blocksize 0))
+ (##sys#error (string-append
+ "invalid blocksize given: not a positive integer - "
+ (number->string blocksize))))
+ (or (file-exists? origfile)
+ (##sys#error (string-append "origfile does not exist - " origfile)))
+ (and (file-exists? newfile)
+ (or clobber
+ (##sys#error (string-append
+ "newfile exists but clobber is false - "
+ newfile))))
+ (let* ((i (condition-case (open-input-file origfile)
+ (val ()
+ (##sys#error (string-append
+ "could not open origfile for read - "
+ origfile)))))
+ (o (condition-case (open-output-file newfile)
+ (val ()
+ (##sys#error (string-append
+ "could not open newfile for write - "
+ newfile)))))
+ (s (make-string blocksize)))
+ (let loop ((d (read-string! blocksize s i))
+ (l 0))
+ (if (= 0 d)
+ (begin
+ (close-input-port i)
+ (close-output-port o)
+ l)
+ (begin
+ (condition-case (write-string s d o)
+ (val ()
+ (close-input-port i)
+ (close-output-port o)
+ (##sys#error (string-append
+ "error writing file starting at "
+ (number->string l)))))
+ (loop (read-string! blocksize s i) (+ d l)))))))
+
+(define (file-move origfile newfile #!optional (clobber #f) (blocksize 1024))
+ (##sys#check-string origfile 'file-move)
+ (##sys#check-string newfile 'file-move)
+ (##sys#check-number blocksize 'file-move)
+ (or (and (integer? blocksize) (> blocksize 0))
+ (##sys#error (string-append
+ "invalid blocksize given: not a positive integer - "
+ (number->string blocksize))))
+ (or (file-exists? origfile)
+ (##sys#error (string-append "origfile does not exist - " origfile)))
+ (and (file-exists? newfile)
+ (or clobber
+ (##sys#error (string-append
+ "newfile exists but clobber is false - "
+ newfile))))
+ (let* ((i (condition-case (open-input-file origfile)
+ (val ()
+ (##sys#error (string-append
+ "could not open origfile for read - "
+ origfile)))))
+ (o (condition-case (open-output-file newfile)
+ (val ()
+ (##sys#error (string-append
+ "could not open newfile for write - "
+ newfile)))))
+ (s (make-string blocksize)))
+ (let loop ((d (read-string! blocksize s i))
+ (l 0))
+ (if (= 0 d)
+ (begin
+ (close-input-port i)
+ (close-output-port o)
+ (condition-case (delete-file origfile)
+ (val ()
+ (##sys#error (string-append
+ "could not remove origfile - "
+ origfile))))
+ l)
+ (begin
+ (condition-case (write-string s d o)
+ (val ()
+ (close-input-port i)
+ (close-output-port o)
+ (##sys#error (string-append
+ "error writing file starting at "
+ (number->string l)))))
+ (loop (read-string! blocksize s i) (+ d l)))))))
+
+;;; Pathname operations:
+
+;; Platform specific absolute pathname operations:
+;; absolute-pathname-root => #f or (<match> [<origin>] <root>)
+;;
+;; Not for general consumption
+
+(define absolute-pathname-root)
+(define root-origin)
+(define root-directory)
+(let ((string-match string-match))
+ (if ##sys#windows-platform
+ (let ((rx (regexp "([A-Za-z]:)?([\\/\\\\]).*")))
+ (set! absolute-pathname-root (lambda (pn) (string-match rx pn)))
+ (set! root-origin (lambda (rt) (and rt (cadr rt))))
+ (set! root-directory (lambda (rt) (and rt (caddr rt)))) )
+ (let ((rx (regexp "([\\/\\\\]).*")))
+ (set! absolute-pathname-root (lambda (pn) (string-match rx pn)))
+ (set! root-origin (lambda (rt) #f))
+ (set! root-directory (lambda (rt) (and rt (cadr rt)))) ) ) )
+
+(define (absolute-pathname? pn)
+ (##sys#check-string pn 'absolute-pathname?)
+ (pair? (absolute-pathname-root pn)) )
+
+(define-inline (*char-pds? ch) (memq ch '(#\\ #\/)))
+
+(define (chop-pds str pds)
+ (and str
+ (let ((len (##sys#size str))
+ (pdslen (if pds (##sys#size pds) 1)))
+ (if (and (fx>= len 1)
+ (if pds
+ (##core#inline "C_substring_compare" str pds (fx- len pdslen) 0 pdslen)
+ (*char-pds? (##core#inline "C_subchar" str (fx- len pdslen)) ) ) )
+ (##sys#substring str 0 (fx- len pdslen))
+ str) ) ) )
+
+(define make-pathname)
+(define make-absolute-pathname)
+(let ([string-append string-append]
+ [absolute-pathname? absolute-pathname?]
+ [def-pds "/"] )
+
+ (define (conc-dirs dirs pds)
+ (##sys#check-list dirs 'make-pathname)
+ (let loop ([strs dirs])
+ (if (null? strs)
+ ""
+ (let ((s1 (car strs)))
+ (if (zero? (string-length s1))
+ (loop (cdr strs))
+ (string-append
+ (chop-pds (car strs) pds)
+ (or pds def-pds)
+ (loop (cdr strs))) ) ) ) ) )
+
+ (define (canonicalize-dirs dirs pds)
+ (cond [(or (not dirs) (null? dirs)) ""]
+ [(string? dirs) (conc-dirs (list dirs) pds)]
+ [else (conc-dirs dirs pds)] ) )
+
+ (define (_make-pathname loc dir file ext pds)
+ (let ([ext (or ext "")]
+ [file (or file "")]
+ [pdslen (if pds (##sys#size pds) 1)] )
+ (##sys#check-string dir loc)
+ (##sys#check-string file loc)
+ (##sys#check-string ext loc)
+ (when pds (##sys#check-string pds loc))
+ (string-append
+ dir
+ (if (and (fx>= (##sys#size file) pdslen)
+ (if pds
+ (##core#inline "C_substring_compare" pds file 0 0 pdslen)
+ (*char-pds? (##core#inline "C_subchar" file 0))))
+ (##sys#substring file pdslen (##sys#size file))
+ file)
+ (if (and (fx> (##sys#size ext) 0)
+ (not (char=? (##core#inline "C_subchar" ext 0) #\.)) )
+ "."
+ "")
+ ext) ) )
+
+ (set! make-pathname
+ (lambda (dirs file #!optional ext pds) ; The 'pds' argument is DEPRECATED
+ (_make-pathname 'make-pathname (canonicalize-dirs dirs pds) file ext pds)))
+
+ (set! make-absolute-pathname
+ (lambda (dirs file #!optional ext pds) ; The 'pds' argument is DEPRECATED
+ (_make-pathname
+ 'make-absolute-pathname
+ (let ([dir (canonicalize-dirs dirs pds)])
+ (if (absolute-pathname? dir)
+ dir
+ (##sys#string-append (or pds def-pds) dir)) )
+ file ext pds) ) ) )
+
+(define decompose-pathname
+ (let ((string-match string-match))
+ (let* ([patt1 "^(.*[\\/\\\\])?([^\\/\\\\]+)(\\.([^\\/\\\\.]+))$"]
+ [patt2 "^(.*[\\/\\\\])?((\\.)?[^\\/\\\\]+)$"]
+ [rx1 (regexp patt1)]
+ [rx2 (regexp patt2)]
+ [strip-pds
+ (lambda (dir)
+ (and dir
+ (if (member dir '("/" "\\"))
+ dir
+ (chop-pds dir #f) ) ) )] )
+ (lambda (pn)
+ (##sys#check-string pn 'decompose-pathname)
+ (if (fx= 0 (##sys#size pn))
+ (values #f #f #f)
+ (let ([ms (string-match rx1 pn)])
+ (if ms
+ (values (strip-pds (cadr ms)) (caddr ms) (car (cddddr ms)))
+ (let ([ms (string-match rx2 pn)])
+ (if ms
+ (values (strip-pds (cadr ms)) (caddr ms) #f)
+ (values (strip-pds pn) #f #f) ) ) ) ) ) ) ) ) )
+
+(define pathname-directory)
+(define pathname-file)
+(define pathname-extension)
+(define pathname-strip-directory)
+(define pathname-strip-extension)
+(define pathname-replace-directory)
+(define pathname-replace-file)
+(define pathname-replace-extension)
+(let ([decompose-pathname decompose-pathname])
+
+ (set! pathname-directory
+ (lambda (pn)
+ (let-values ([(dir file ext) (decompose-pathname pn)])
+ dir) ) )
+
+ (set! pathname-file
+ (lambda (pn)
+ (let-values ([(dir file ext) (decompose-pathname pn)])
+ file) ) )
+
+ (set! pathname-extension
+ (lambda (pn)
+ (let-values ([(dir file ext) (decompose-pathname pn)])
+ ext) ) )
+
+ (set! pathname-strip-directory
+ (lambda (pn)
+ (let-values ([(dir file ext) (decompose-pathname pn)])
+ (make-pathname #f file ext) ) ) )
+
+ (set! pathname-strip-extension
+ (lambda (pn)
+ (let-values ([(dir file ext) (decompose-pathname pn)])
+ (make-pathname dir file) ) ) )
+
+ (set! pathname-replace-directory
+ (lambda (pn dir)
+ (let-values ([(_ file ext) (decompose-pathname pn)])
+ (make-pathname dir file ext) ) ) )
+
+ (set! pathname-replace-file
+ (lambda (pn file)
+ (let-values ([(dir _ ext) (decompose-pathname pn)])
+ (make-pathname dir file ext) ) ) )
+
+ (set! pathname-replace-extension
+ (lambda (pn ext)
+ (let-values ([(dir file _) (decompose-pathname pn)])
+ (make-pathname dir file ext) ) ) ) )
+
+(define create-temporary-file
+ (let ([get-environment-variable get-environment-variable]
+ [make-pathname make-pathname]
+ [file-exists? file-exists?]
+ [call-with-output-file call-with-output-file] )
+ (lambda ext
+ (let ((dir (or (get-environment-variable "TMPDIR")
+ (get-environment-variable "TEMP")
+ (get-environment-variable "TMP")
+ (file-exists? "/tmp")))
+ (ext (if (pair? ext) (car ext) "tmp")))
+ (##sys#check-string ext 'create-temporary-file)
+ (let loop ()
+ (let* ([n (##sys#fudge 16)]
+ [pn (make-pathname dir (##sys#string-append "t" (number->string n 16)) ext)] )
+ (if (file-exists? pn)
+ (loop)
+ (call-with-output-file pn (lambda (p) pn)) ) ) ) ) ) ) )
+
+
+;;; normalize pathname for a particular platform
+
+(define normalize-pathname
+ (let ((open-output-string open-output-string)
+ (get-output-string get-output-string)
+ (get-environment-variable get-environment-variable)
+ (reverse reverse)
+ (display display)
+ (bldplt (if (memq (build-platform) '(msvc mingw32)) 'windows 'unix)) )
+ (define (addpart part parts)
+ (cond ((string=? "." part) parts )
+ ((string=? ".." part) (if (null? parts) '("..") (cdr parts)) )
+ (else (cons part parts) ) ) )
+ (lambda (path #!optional (platform bldplt))
+ (let ((sep (if (eq? platform 'windows) #\\ #\/)))
+ (##sys#check-string path 'normalize-pathname)
+ (let ((len (##sys#size path))
+ (abspath #f)
+ (drive #f))
+ (let loop ((i 0) (prev 0) (parts '()))
+ (cond ((fx>= i len)
+ (when (fx> i prev)
+ (set! parts (addpart (##sys#substring path prev i) parts)))
+ (if (null? parts)
+ (if abspath
+ (##sys#string-append (string sep) ".")
+ (##sys#string-append "." (string sep)) )
+ (let ((out (open-output-string))
+ (parts (reverse parts)))
+ (display (car parts) out)
+ (for-each
+ (lambda (p)
+ (##sys#write-char-0 sep out)
+ (display p out) )
+ (cdr parts))
+ (when (fx= i prev) (##sys#write-char-0 sep out))
+ (let* ((r1 (get-output-string out))
+ (r (##sys#expand-home-path r1)))
+ (when (string=? r1 r)
+ (when abspath
+ (set! r (##sys#string-append (string sep) r)))
+ (when drive
+ (set! r (##sys#string-append drive r))))
+ r))))
+ ((*char-pds? (string-ref path i))
+ (when (and (null? parts) (fx= i prev))
+ (set! abspath #t))
+ (if (fx= i prev)
+ (loop (fx+ i 1) (fx+ i 1) parts)
+ (loop (fx+ i 1)
+ (fx+ i 1)
+ (addpart (##sys#substring path prev i) parts))))
+ ((and (null? parts)
+ (char=? (string-ref path i) #\:)
+ (eq? 'windows platform))
+ (set! drive (##sys#substring path 0 (fx+ i 1)))
+ (loop (fx+ i 1) (fx+ i 1) '()))
+ (else (loop (fx+ i 1) prev parts)) ) ) ) ) ) ) )
+
+
+;; directory pathname => list of strings
+;; does arg check
+
+(define split-directory
+ (let ((string-split string-split) )
+ (lambda (loc dir keep?)
+ (##sys#check-string dir loc)
+ (string-split dir "/\\" keep?) ) ) )
+
+;; Directory string or list only contains path-separators
+;; and/or current-directory (".") names.
+
+(define (directory-null? dir)
+ (let loop ((ls (if (list? dir) dir (split-directory 'directory-null? dir #t))))
+ (or (null? ls)
+ (and (member (car ls) '("" "."))
+ (loop (cdr ls)) ) ) ) )
+
+;; Directory string => {<origin> <root> <directory-list>}
+;; where any maybe #f when missing
+
+(define (decompose-directory dir)
+ (define (strip-origin-prefix org decomp)
+ #;(assert (or (not org) decomp)) ;cannot have an "origin" but no "decomp"
+ (if (not org)
+ decomp
+ (let ((1st (car decomp)))
+ (let ((olen (##sys#size org)))
+ (if (not (##core#inline "C_substring_compare" org 1st 0 0 olen))
+ ; then origin is not a prefix (really shouldn't happen)
+ decomp
+ ; else is a prefix
+ (let ((rst (cdr decomp))
+ (elen (##sys#size 1st)) )
+ (if (fx= olen (##sys#size elen))
+ ; then origin is a list prefix
+ rst
+ ; else origin is a string prefix
+ (cons (##sys#substring 1st olen elen) rst) ) ) ) ) ) ) )
+ (let* ((ls (split-directory 'decompose-directory dir #f))
+ (rt (absolute-pathname-root dir))
+ (org (root-origin rt)) )
+ (values org (root-directory rt) (strip-origin-prefix org (and (not (null? ls)) ls))) ) )
diff --git a/foreign.import.scm b/foreign.import.scm
new file mode 100644
index 00000000..89bf337c
--- /dev/null
+++ b/foreign.import.scm
@@ -0,0 +1,30 @@
+;;;; foreign.import.scm - import library for "foreign" pseudo module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'foreign
+ '()
+ ##sys#chicken-ffi-macro-environment)
diff --git a/hen.el b/hen.el
new file mode 100644
index 00000000..00b3ec90
--- /dev/null
+++ b/hen.el
@@ -0,0 +1,567 @@
+;;; HEN.EL --- mode for editing chicken code
+
+;; Copyright (C) 2004 Linh Dang
+
+;; Author: Linh Dang <linhd@>
+;; Maintainer: Linh Dang <linhd@>
+;; Created: 19 Apr 2004
+;; Version: 1
+;; Keywords:
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 1, or (at your option)
+;; any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; A copy of the GNU General Public License can be obtained from this
+;; program's author (send electronic mail to <linhd@>) or from the
+;; Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139,
+;; USA.
+
+;; LCD Archive Entry:
+;; hen|Linh Dang|<linhd@>
+;; | mode for editing chicken code
+;; |$Date: 2004/11/22 22:36:11 $|$Revision: 1.13 $|~/packages/hen.el
+
+;;; Commentary:
+;; Hen is a mode derived from scheme-mode and is specialized for
+;; editing chicken scheme.
+;; This mode assumes:
+;; - the user has chicken.info install
+;; - the csi executable can be launch as "csi"
+
+;;
+;; Changes by Micky Latowicki:
+;;
+;; * Added implementation of with-temp-message, which is missing from xemacs 21.4.
+;; * Added trivial display-mouse-p, which is similarly missing.
+;; * fixed font-lock problems.
+;; * removed most calls to accept-process-output, which made
+;; hen unacceptably slow.
+;; * removed (apparently) redundant call to hen-proc-wait-prompt in
+;; hen-proc-send
+;; * updated prompt regexp pattern to include the running number.
+;; * start csi with -quiet
+;; * fixed completions, made them more like emacs lisp behaviour.
+;; Note: completions were fixed at the cost of feeding csi the commands
+;; (require 'srfi-1) and (require 'regex) before matching strings are
+;; searched for. This was done because the completions-searching code
+;; relies on these libraries. A true fix would be to statically link these
+;; libraries into csi, because the way it works now the user cannot choose
+;; to keep srfi-1 and regex out of her csi environment.
+
+;; Changes by felix:
+;;
+;; * removed hen-describe-symbol
+;; * various cleaning up
+;; * still pretty bad...
+
+;; Changes by Adhi Hargo:
+;;
+;; * automatically raise *csi* buffer on any relevant operations, and
+;; made it a read-only buffer.
+;; * changes definition-at-point evaluation command.
+;; * s-exp evaluation no longer shown in minibuffer.
+;; * added : + Hen-mode customization group.
+;; + Buffer evaluation command.
+;; + csi process-terminating command, partly so I can erase
+;; previous definitions and start anew.
+;; + close-parens-at-point command, from SLIME.
+;; + modification-check before compilation.
+
+;;; Code:
+
+(defconst hen-version (substring "$Revision: 1.13 $" 11 -2)
+ "$Id: hen.el,v 1.13 2004/11/22 22:36:11 flw Exp $
+
+Report bugs to: Felix Winkelmann <bunny351@gmail.com>")
+
+(require 'scheme)
+(require 'compile)
+
+;;; GROUP DECLARATION ================================================
+
+(defgroup hen nil
+ "Major mode for editing Scheme programs using Chicken."
+ :version "21.3"
+ :group 'scheme
+ :prefix "hen-")
+(defgroup hen-font-face nil
+ "Various font face configurations."
+ :group 'hen)
+
+(defun hen-version ()
+ "Outputs Hen's current version to the minibuffer."
+ (interactive)
+ (message "Hen %s" hen-version))
+
+;;; USER-CONFIGURABLE COMMANDS =======================================
+
+(defcustom hen-csc-program "csc"
+ "*Chicken compiler executable's filename."
+ :group 'hen
+ :type 'string)
+(defcustom hen-csi-program "csi"
+ "*Chicken interpreter executable's filename."
+ :group 'hen
+ :type 'string)
+(defcustom hen-build-exec-arg ""
+ "*Compiler-argument when building an executable file."
+ :group 'hen
+ :type 'string)
+(defcustom hen-build-obj-arg ""
+ "*Compiler-argument when building an object file."
+ :group 'hen
+ :type 'string)
+(defcustom hen-eval-init-arg ""
+ "*Additional interpreter argument."
+ :group 'hen
+ :type 'string)
+
+(defcustom hen-autosave-buffer-before-compile nil
+ "*Save modified file automatically before compilation.
+The default behavior is to ask the user whether to save or not."
+ :group 'hen
+ :type 'boolean)
+
+(defcustom hen-load-hook nil
+ "Hook run after entering Hen mode."
+ :group 'hen
+ :type 'hook)
+
+
+;; with-temp-message pasted from a mailing list. It's not available in my xemacs 21.4
+(unless (functionp 'with-temp-message)
+ (defmacro with-temp-message (message &rest body)
+ "Display MESSAGE temporarily while BODY is evaluated.
+The original message is restored to the echo area after BODY has finished.
+The value returned is the value of the last form in BODY."
+ (let ((current-message (make-symbol "current-message"))
+ (temp-message (make-symbol "with-temp-message")))
+ `(let ((,temp-message ,message)
+ (,current-message))
+ (unwind-protect
+ (progn
+ (when ,temp-message
+ (setq ,current-message (current-message))
+ (message "%s" ,temp-message))
+ ,@body)
+ (and ,temp-message ,current-message
+ (message "%s" ,current-message)))))))
+
+;; display-mouse-p not available in xemacs 21.4, so here's a quick fix, sort of.
+(unless (functionp 'display-mouse-p)
+ (defun display-mouse-p (&optional display) t))
+
+(defconst hen-syntax-table
+ (let ((tab (copy-syntax-table scheme-mode-syntax-table)))
+ (modify-syntax-entry ?# "_ " tab)
+ (modify-syntax-entry ?: "_ " tab)
+ (modify-syntax-entry ?\[ "(] " tab)
+ (modify-syntax-entry ?\] ")[ " tab)
+
+ tab))
+
+(defconst hen-font-lock-keywords-1
+ (eval-when-compile
+ (list
+ ;; Declarations
+ (list (concat "\\(?:(\\|\\[\\)"
+ "\\(" (regexp-opt
+ '("define"
+ "define-class"
+ "define-external"
+ "define-constant"
+ "define-datatype"
+ "define-foreign-type"
+ "define-foreign-variable"
+ "define-foreign-record"
+ "define-generic"
+ "define-inline"
+ "define-macro"
+ "define-method"
+ "define-reader-ctor"
+ "define-record"
+ "defstruct"
+ "define-record-printer"
+ "define-record-type"
+ "define-compiler-macro"
+ "define-syntax"
+ "define-for-syntax"
+ "define-values") 1) "\\)"
+ "\\s-+(?\\(\\(\\sw\\|\\s_\\)+\\)")
+
+ '(1 font-lock-keyword-face t t)
+ '(2 font-lock-function-name-face t t))))
+ "Basic font-locking for Hen mode.")
+
+(defconst hen-font-lock-keywords-2
+ (append hen-font-lock-keywords-1
+ (eval-when-compile
+ (list
+ ;;
+ ;; Control structures.
+ (cons
+ (concat
+ "\\<" (regexp-opt
+ '("begin" "begin0" "else"
+ "else"
+ "foreign-lambda*" "foreign-safe-lambda*" "foreign-primitive"
+ "foreign-declare" "foreign-parse" "foreign-parse/declare"
+ "foreign-lambda" "foreign-safe-lambda" "foreign-code"
+ "match" "match-lambda" "match-lambda*" "match-define" "match-let" "match-let*"
+
+ "case" "case-lambda" "cond" "cond-expand" "condition-case" "select"
+ "handle-exceptions"
+ "cut" "cute" "time" "regex-case"
+
+ "do" "else" "if" "lambda" "when" "while" "if*" "unless"
+
+ "let-location" "location" "rec"
+ "let" "let*" "let-syntax" "letrec" "letrec-syntax" "set!-values"
+ "and-let*" "let-optionals" "let-optionals*" "optional"
+ "fluid-let" "let-values" "let*-values" "letrec-values"
+ "parameterize"
+ "module" "import-only" "import" "import*"
+
+ "and" "or" "delay" "receive"
+
+ "assert" "ignore-errors" "ensure" "eval-when"
+
+ "loop" "sc-macro-transformer"
+
+ "declare" "include" "require-extension" "require" "require-for-syntax" "use" "quasiquote"
+
+ "syntax" "with-syntax" "syntax-case" "identifier-syntax" "syntax-rules") t)
+ "\\>") 'font-lock-keyword-face)
+ '("\\<set!" . font-lock-keyword-face)
+ ;;
+ ;; `:' keywords as builtins.
+ '("#?\\<:\\sw+\\>" . font-lock-builtin-face)
+ '("\\<\\sw+:\\>" . font-lock-builtin-face)
+ '(",@?\\|`" . font-lock-builtin-face)
+ '("\\(##\\sw+#\\)" (1 font-lock-builtin-face t nil))
+ '("#\\\\?\\sw+" (0 font-lock-constant-face nil t))
+;? '("(\\(declare\\|require\\(-extension\\)?\\)" . font-lock-keyword-face)
+ )))
+ "Gaudy expressions to highlight in Hen mode.")
+
+(defconst hen-font-lock-keywords hen-font-lock-keywords-2)
+
+(mapc (lambda (cell)
+ (put (car cell) 'scheme-indent-function (cdr cell)))
+ '((begin0 . 0)
+
+ (when . 1) (while . 1) (unless . 1)
+ (and-let* . 1) (fluid-let . 1)
+
+ (call-with-input-pipe . 1)
+ (call-with-ouput-pipe . 1)
+ (call-with-input-string . 1)
+ (call-with-input-string . 1)
+
+ (call-with-values . 1)
+
+ (with-input-from-pipe . 1)
+ (with-ouput-to-pipe . 0)
+ (with-input-from-string . 1)
+ (with-output-to-string . 0)
+
+ (if* . 2)))
+
+(defun hen-identifier-at-point ()
+ "Return the identifier close to the cursor."
+ (save-excursion
+ (save-match-data
+ (let ((beg (line-beginning-position))
+ (end (line-end-position))
+ (pos (point)))
+ (cond ((progn (goto-char pos)
+ (skip-chars-forward " \t" end)
+ (skip-syntax-backward "w_" beg)
+ (memq (char-syntax (following-char)) '(?w ?_)))
+ (buffer-substring-no-properties (point) (progn (forward-sexp 1) (point))))
+ ((progn (goto-char pos)
+ (skip-chars-backward " \t" beg)
+ (skip-syntax-forward "w_" end)
+ (memq (char-syntax (preceding-char)) '(?w ?_)))
+ (buffer-substring-no-properties (point) (progn (forward-sexp -1) (point))))
+ (t nil))))))
+
+(defun hen-build (cmd args)
+ (when (and (buffer-modified-p)
+ (or hen-autosave-buffer-before-compile
+ (progn (beep)
+ (y-or-n-p "File modified. Save it? "))))
+ (save-buffer))
+ (compile-internal (mapconcat 'identity (cons cmd args) " ")
+ "No more errors" "csc" nil
+ `(("Error:.+in line \\([0-9]+\\):" 0 1 nil ,(buffer-file-name)))
+ (lambda (ignored) "*csc*")))
+
+(defun hen-build-extension ()
+ (interactive)
+ (let* ((file-name (file-name-nondirectory
+ (buffer-file-name))))
+ (hen-build hen-csc-program (list "-s" file-name hen-build-obj-arg))))
+
+(defun hen-build-program ()
+ (interactive)
+ (let* ((file-name (file-name-nondirectory
+ (buffer-file-name))))
+ (hen-build hen-csc-program (list file-name hen-build-exec-arg))))
+
+(define-derived-mode hen-mode scheme-mode "Hen"
+ "Mode for editing chicken Scheme code.
+\\[hen-csi-eval-last-sexp] evaluates the sexp at/preceding point in csi.
+\\[hen-csi-eval-region] evaluates the region in csi.
+\\[hen-csi-eval-buffer] evaluates current buffer in csi.
+\\[hen-csi-eval-definition] evaluates the toplevel definition at point in csi.
+\\[hen-csi-send] reads a sexp from the user and evaluates it csi.
+\\[hen-csi-proc-delete] terminates csi subprocess.
+\\[hen-close-parens-at-point] closes parentheses for top-level sexp at point.
+\\[hen-build-extension] compiles the current file as a shared object
+\\[hen-build-program] compiles the current file as a program
+"
+
+ (set-syntax-table hen-syntax-table)
+ (setq local-abbrev-table scheme-mode-abbrev-table)
+
+ (define-key hen-mode-map (kbd "C-c C-e") 'hen-csi-eval-last-sexp)
+ (define-key hen-mode-map (kbd "C-c C-r") 'hen-csi-eval-region)
+ (define-key hen-mode-map (kbd "C-c C-b") 'hen-csi-eval-buffer)
+ (define-key hen-mode-map (kbd "C-c C-d") 'hen-csi-eval-definition)
+ (define-key hen-mode-map (kbd "C-c C-l") 'hen-build-unit)
+ (define-key hen-mode-map (kbd "C-c C-x") 'hen-csi-send)
+ (define-key hen-mode-map (kbd "C-c C-q") 'hen-csi-proc-delete)
+ (define-key hen-mode-map (kbd "C-c C-l") 'hen-build-extension)
+ (define-key hen-mode-map (kbd "C-c C-c") 'hen-build-program)
+ (define-key hen-mode-map (kbd "C-c C-]") 'hen-close-parens-at-point)
+
+ (define-key hen-mode-map [menu-bar scheme run-scheme] nil)
+ (define-key hen-mode-map [menu-bar shared build-prog] '("Compile File" hen-build-program))
+ (define-key hen-mode-map [menu-bar shared send-to-csi] '("Evaluate" . hen-csi-send))
+ (define-key hen-mode-map [menu-bar scheme build-as-extension]
+ '("Compile File as Extension" . hen-build-extension))
+ (define-key hen-mode-map [menu-bar scheme eval-buffer] '("Eval Buffer" . hen-csi-eval-buffer))
+ (define-key hen-mode-map [menu-bar scheme eval-region] '("Eval Region" . hen-csi-eval-region))
+ (define-key hen-mode-map [menu-bar scheme eval-last-sexp]
+ '("Eval Last S-Expression" . hen-csi-eval-last-sexp))
+
+ (setq font-lock-defaults
+ '((hen-font-lock-keywords
+ hen-font-lock-keywords-1 hen-font-lock-keywords-2)
+ nil t
+ ((?+ . "w") (?- . "w") (?* . "w") (?/ . "w")
+ (?. . "w") (?< . "w") (?> . "w") (?= . "w")
+ (?? . "w") (?$ . "w") (?% . "w") (?_ . "w")
+ (?& . "w") (?~ . "w") (?^ . "w") (?: . "w"))
+ beginning-of-defun
+ (font-lock-mark-block-function . mark-defun)))
+ (make-local-variable 'paragraph-start)
+ (setq paragraph-start (concat page-delimiter "\\|$" ))
+
+ (make-local-variable 'paragraph-separate)
+ (setq paragraph-separate paragraph-start)
+
+ (make-local-variable 'paragraph-ignore-fill-prefix)
+ (setq paragraph-ignore-fill-prefix t)
+
+ (make-local-variable 'adaptive-fill-mode)
+ (setq adaptive-fill-mode nil)
+
+ (make-local-variable 'parse-sexp-ignore-comments)
+ (setq parse-sexp-ignore-comments t)
+
+ (make-local-variable 'outline-regexp)
+ (setq outline-regexp ";;;;* \\|(")
+
+ (make-local-variable 'comment-start)
+ (setq comment-start ";")
+
+ (make-local-variable 'comment-column)
+ (setq comment-column 40)
+
+ (make-local-variable 'comment-add)
+ (setf comment-add 1)
+ )
+
+;;stolen from cxref
+(defun hen-looking-backward-at (regexp)
+ "Return t if text before point matches regular expression REGEXP.
+This function modifies the match data that `match-beginning',
+`match-end' and `match-data' access; save and restore the match
+data if you want to preserve them."
+ (save-excursion
+ (let ((here (point)))
+ (if (re-search-backward regexp (point-min) t)
+ (if (re-search-forward regexp here t)
+ (= (point) here))))))
+
+(defun hen-proc-wait-prompt (proc prompt-re &optional timeout msg)
+ "Wait for the prompt of interactive process PROC. PROMPT-RE must be
+a regexp matching the prompt. TIMEOUT is the amount of time to wait in
+secs before giving up. MSG is the message to display while waiting."
+ (setq timeout (if (numberp timeout) (* timeout 2) 60))
+ (unless (stringp msg)
+ (setq msg (concat "wait for " hen-csi-proc-name "'s prompt")))
+ (goto-char (process-mark proc))
+ (if (hen-looking-backward-at prompt-re)
+ t
+ (while (and (> timeout 0) (not (hen-looking-backward-at prompt-re)))
+ (with-temp-message (setq msg (concat msg "."))
+ (accept-process-output proc 0 timeout))
+ (setq timeout (1- timeout))
+ (goto-char (process-mark proc)))
+ (with-temp-message (concat msg (if (> timeout 0)
+ " got it!" " timeout!"))
+ (sit-for 0 100))
+ (> timeout 0))
+ )
+
+(defun hen-proc-send (question proc prompt-re &optional timeout msg)
+ "Send the string QUESTION to interactive process proc. PROMPT-RE is
+the regexp matching PROC's prompt. TIMEOUT is the amount of time to
+wait in secs before giving up. MSG is the message to display while
+waiting."
+ (setq timeout (if (numberp timeout) (* timeout 2) 60))
+ (save-excursion
+ (set-buffer (process-buffer proc))
+ (widen)
+ (save-match-data
+ (goto-char (process-mark proc))
+ (if (hen-looking-backward-at prompt-re)
+ (let ((start (match-end 0)))
+ (narrow-to-region start (point-max))
+ (process-send-string proc (concat question "\n"))
+ (hen-proc-wait-prompt proc prompt-re timeout msg)
+ (narrow-to-region start (match-beginning 0))
+ (current-buffer))))))
+
+(defconst hen-csi-prompt-pattern "#;[0-9]*> ")
+(defconst hen-csi-proc-name "csi")
+(defconst hen-csi-buffer-name "*csi*")
+
+(defun hen-csi-buffer-create ()
+ "Creates a new buffer for csi, make it read-only."
+ (let ((buffer (get-buffer-create hen-csi-buffer-name)))
+ (with-current-buffer buffer
+ (make-local-variable 'buffer-read-only)
+ (setf buffer-read-only t))
+ buffer))
+
+(defun hen-csi-buffer-erase ()
+ "Erases csi buffer's content, used mainly when its process was being
+reset."
+ (let ((buffer (get-buffer hen-csi-buffer-name)))
+ (unless (null buffer) (with-current-buffer buffer
+ (setf buffer-read-only '())
+ (erase-buffer)
+ (setf buffer-read-only t)))))
+
+(defun hen-csi-buffer ()
+ (let ((buffer (or (get-buffer hen-csi-buffer-name) ;check if exists
+ (hen-csi-buffer-create)))) ;... or create one
+ (display-buffer buffer)
+ buffer))
+
+(defun hen-csi-proc ()
+ (let ((proc (get-process hen-csi-proc-name)))
+ (if (and (processp proc)
+ (eq (process-status proc) 'run))
+ proc
+ (setq proc
+ (eval `(start-process hen-csi-proc-name (hen-csi-buffer)
+ hen-csi-program
+ "-no-init" "-quiet" "-:c" "-R" "srfi-1" "-R" "regex" "-R" "utils"
+ ,@(split-string hen-eval-init-arg))))
+ (with-current-buffer (hen-csi-buffer)
+ (hen-proc-wait-prompt proc hen-csi-prompt-pattern)
+ proc))))
+
+(defun hen-csi-proc-delete ()
+ (interactive)
+ (let ((proc (get-process hen-csi-proc-name)))
+ (when (and (processp proc)
+ (eq (process-status proc) 'run))
+ (delete-process proc))
+ (hen-csi-buffer-erase)
+ ()))
+
+(defun hen-csi-send (sexp)
+ "Evaluate SEXP in CSI"
+ (interactive
+ (let ((sexp (read-string "Evaluate S-expression: "))
+ (send-sexp-p nil))
+ (unwind-protect
+ (progn
+ (let ((obarray (make-vector 11 0)))
+ (read sexp)
+ (setq send-sexp-p t)))
+ (unless send-sexp-p
+ (setq send-sexp-p
+ (y-or-n-p (format "`%s' is not a valid sexp! evaluate anyway? " sexp)))))
+ (list (if send-sexp-p sexp nil))))
+ (when (stringp sexp)
+ (let* ((proc (hen-csi-proc))
+ (buf (hen-proc-send (concat sexp "\n") proc hen-csi-prompt-pattern))
+ result len)
+ (unless (buffer-live-p buf)
+ (error "Internal hen-mode failure"))
+
+ (save-excursion
+ (with-current-buffer buf
+ (setq result (buffer-string))
+ (setq len (length result))
+ (if (and (> len 0)
+ (eq (aref result (1- len)) ?\n))
+ (setq result (substring result 0 -1)))
+ result)))))
+
+(defun hen-csi-eval-buffer ()
+ "Evaluate the current buffer in CSI"
+ (interactive)
+ (hen-csi-send (buffer-string)))
+
+(defun hen-csi-eval-region (beg end)
+ "Evaluate the current region in CSI."
+ (interactive "r")
+ (hen-csi-send (buffer-substring beg end)))
+
+(defun hen-csi-eval-last-sexp ()
+ "Evaluate the s-expression at point in CSI"
+ (interactive)
+ (hen-csi-eval-region (save-excursion (backward-sexp) (point))
+ (point)))
+
+(defun hen-csi-eval-definition ()
+ "Evaluate the enclosing top-level form in CSI."
+ (interactive)
+ (hen-csi-eval-region (save-excursion
+ (end-of-defun) (beginning-of-defun)
+ (point))
+ (save-excursion
+ (end-of-defun) (point))))
+
+;; from SLIME
+(defun hen-close-parens-at-point ()
+ "Close parenthesis at point to complete the top-level-form. Simply
+inserts ')' characters at point until `beginning-of-defun' and
+`end-of-defun' execute without errors, or internal variable
+`close-parens-limit' is exceeded."
+ (interactive)
+ (let ((close-parens-limit 16))
+ (loop for i from 1 to close-parens-limit
+ until (save-excursion
+ (beginning-of-defun)
+ (ignore-errors (end-of-defun) t))
+ do (insert ")"))))
+
+(provide 'hen)
+(run-hooks 'hen-load-hook)
+;;; HEN.EL ends here
diff --git a/irregex.import.scm b/irregex.import.scm
new file mode 100644
index 00000000..ac707925
--- /dev/null
+++ b/irregex.import.scm
@@ -0,0 +1,36 @@
+;;;; irregex.import.scm - import library for "regex" module (irregex API)
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'irregex
+ '(irregex string->irregex sre->irregex string->sre
+ irregex? irregex-match-data?
+ irregex-new-matches irregex-reset-matches!
+ irregex-match-start irregex-match-end irregex-match-substring
+ irregex-search irregex-search/matches irregex-match irregex-match-string
+ irregex-fold irregex-replace irregex-replace/all irregex-apply-match
+ irregex-dfa irregex-dfa/search irregex-dfa/extract
+ irregex-nfa irregex-flags irregex-submatches irregex-lengths irregex-names))
diff --git a/irregex.scm b/irregex.scm
new file mode 100644
index 00000000..5d0f77e7
--- /dev/null
+++ b/irregex.scm
@@ -0,0 +1,2718 @@
+;;;; irregex.scm -- IrRegular Expressions
+;;
+;; Copyright (c) 2005-2008 Alex Shinn. All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; At this moment there was a loud ring at the bell, and I could
+;; hear Mrs. Hudson, our landlady, raising her voice in a wail of
+;; expostulation and dismay.
+;;
+;; "By heaven, Holmes," I said, half rising, "I believe that
+;; they are really after us."
+;;
+;; "No, it's not quite so bad as that. It is the unofficial
+;; force, -- the Baker Street irregulars."
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; History
+;;
+;; 0.6.2: 2008/07/26 - minor bugfixes, allow global disabling of utf8 mode,
+;; friendlier error messages in parsing, \Q..\E support
+;; 0.6.1: 2008/07/21 - added utf8 mode, more utils, bugfixes
+;; 0.6: 2008/05/01 - most of PCRE supported
+;; 0.5: 2008/04/24 - fully portable R4RS, many PCRE features implemented
+;; 0.4: 2008/04/17 - rewriting NFA to use efficient closure compilation,
+;; normal strings only, but all of the spencer tests pass
+;; 0.3: 2008/03/10 - adding DFA converter (normal strings only)
+;; 0.2: 2005/09/27 - adding irregex-opt (like elisp's regexp-opt) utility
+;; 0.1: 2005/08/18 - simple NFA interpreter over abstract chunked strings
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define irregex-tag '*irregex-tag*)
+
+(define (make-irregex dfa dfa/search dfa/extract nfa flags
+ submatches lengths names)
+ (vector irregex-tag dfa dfa/search dfa/extract nfa flags
+ submatches lengths names))
+
+(define (irregex? obj)
+ (and (vector? obj)
+ (= 9 (vector-length obj))
+ (eq? irregex-tag (vector-ref obj 0))))
+
+(define (irregex-dfa x) (vector-ref x 1))
+(define (irregex-dfa/search x) (vector-ref x 2))
+(define (irregex-dfa/extract x) (vector-ref x 3))
+(define (irregex-nfa x) (vector-ref x 4))
+(define (irregex-flags x) (vector-ref x 5))
+(define (irregex-submatches x) (vector-ref x 6))
+(define (irregex-lengths x) (vector-ref x 7))
+(define (irregex-names x) (vector-ref x 8))
+
+(define (irregex-new-matches irx)
+ (make-irregex-match #f (irregex-submatches irx) (irregex-names irx)))
+(define (irregex-reset-matches! m)
+ (do ((i (- (vector-length m) 1) (- i 1)))
+ ((<= i 3) m)
+ (vector-set! m i #f)))
+
+(define irregex-match-tag '*irregex-match-tag*)
+
+(define (irregex-match-data? obj)
+ (and (vector? obj)
+ (>= (vector-length obj) 5)
+ (eq? irregex-match-tag (vector-ref obj 0))))
+
+(define (make-irregex-match str count names)
+ (let ((res (make-vector (+ (* 2 (+ 1 count)) 3) #f)))
+ (vector-set! res 0 irregex-match-tag)
+ (vector-set! res 1 str)
+ (vector-set! res 2 names)
+ res))
+
+(define (irregex-match-num-submatches m)
+ (- (quotient (- (vector-length m) 3) 2) 1))
+
+(define (irregex-match-string m)
+ (vector-ref m 1))
+(define (irregex-match-names m)
+ (vector-ref m 2))
+(define (irregex-match-string-set! m str)
+ (vector-set! m 1 str))
+
+(define (irregex-match-start-index m n)
+ (vector-ref m (+ 3 (* n 2))))
+(define (irregex-match-end-index m n)
+ (vector-ref m (+ 4 (* n 2))))
+
+(define (irregex-match-start-index-set! m n start)
+ (vector-set! m (+ 3 (* n 2)) start))
+(define (irregex-match-end-index-set! m n end)
+ (vector-set! m (+ 4 (* n 2)) end))
+
+(define (irregex-match-index m opt)
+ (if (pair? opt)
+ (cond ((number? (car opt)) (car opt))
+ ((assq (car opt) (irregex-match-names m)) => cdr)
+ (else (error "unknown match name" (car opt))))
+ 0))
+
+(define (irregex-match-valid-index? m n)
+ (and (< (+ 3 (* n 2)) (vector-length m))
+ (vector-ref m (+ 4 (* n 2)))))
+
+(define (irregex-match-substring m . opt)
+ (let ((n (irregex-match-index m opt)))
+ (and (irregex-match-valid-index? m n)
+ (substring (irregex-match-string m)
+ (vector-ref m (+ 3 (* n 2)))
+ (vector-ref m (+ 4 (* n 2)))))))
+
+(define (irregex-match-start m . opt)
+ (let ((n (irregex-match-index m opt)))
+ (and (irregex-match-valid-index? m n)
+ (vector-ref m (+ 3 (* n 2))))))
+
+(define (irregex-match-end m . opt)
+ (irregex-match-valid-index? m (irregex-match-index m opt)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; string utilities
+
+;;;; Unicode version (skip surrogates)
+(define *all-chars*
+ `(/ ,(integer->char 0) ,(integer->char #xD7FF)
+ ,(integer->char #xE000) ,(integer->char #x10FFFF)))
+
+;;;; ASCII version, offset to not assume 0-255
+;; (define *all-chars* `(/ ,(integer->char (- (char->integer #\space) 32)) ,(integer->char (+ (char->integer #\space) 223))))
+
+;; set to #f to ignore even an explicit request for utf8 handling
+(define *allow-utf8-mode?* #t)
+
+;; (define *named-char-properties* '())
+
+(define (string-scan-char str c . o)
+ (let ((end (string-length str)))
+ (let scan ((i (if (pair? o) (car o) 0)))
+ (cond ((= i end) #f)
+ ((eqv? c (string-ref str i)) i)
+ (else (scan (+ i 1)))))))
+
+(define (string-scan-char-escape str c . o)
+ (let ((end (string-length str)))
+ (let scan ((i (if (pair? o) (car o) 0)))
+ (cond ((= i end) #f)
+ ((eqv? c (string-ref str i)) i)
+ ((eqv? c #\\) (scan (+ i 2)))
+ (else (scan (+ i 1)))))))
+
+(define (string-scan-pred str pred . o)
+ (let ((end (string-length str)))
+ (let scan ((i (if (pair? o) (car o) 0)))
+ (cond ((= i end) #f)
+ ((pred (string-ref str i)) i)
+ (else (scan (+ i 1)))))))
+
+(define (string-split-char str c)
+ (let ((end (string-length str)))
+ (let lp ((i 0) (from 0) (res '()))
+ (define (collect) (cons (substring str from i) res))
+ (cond ((>= i end) (reverse (collect)))
+ ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (collect)))
+ (else (lp (+ i 1) from res))))))
+
+(define (char-alphanumeric? c)
+ (or (char-alphabetic? c) (char-numeric? c)))
+
+;; SRFI-13 extracts
+
+(define (%%string-copy! to tstart from fstart fend)
+ (do ((i fstart (+ i 1))
+ (j tstart (+ j 1)))
+ ((>= i fend))
+ (string-set! to j (string-ref from i))))
+
+(define (string-cat-reverse string-list)
+ (string-cat-reverse/aux
+ (fold (lambda (s a) (+ (string-length s) a)) 0 string-list)
+ string-list))
+
+(define (string-cat-reverse/aux len string-list)
+ (let ((res (make-string len)))
+ (let lp ((i len) (ls string-list))
+ (if (pair? ls)
+ (let* ((s (car ls))
+ (slen (string-length s))
+ (i (- i slen)))
+ (%%string-copy! res i s 0 slen)
+ (lp i (cdr ls)))))
+ res))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; list utilities
+
+;; like the one-arg IOTA case
+(define (zero-to n)
+ (if (<= n 0)
+ '()
+ (let lp ((i (- n 1)) (res '()))
+ (if (zero? i) (cons 0 res) (lp (- i 1) (cons i res))))))
+
+;; take the head of list FROM up to but not including TO, which must
+;; be a tail of the list
+(define (take-up-to from to)
+ (let lp ((ls from) (res '()))
+ (if (and (pair? ls) (not (eq? ls to)))
+ (lp (cdr ls) (cons (car ls) res))
+ (reverse res))))
+
+;; SRFI-1 extracts (simplified 1-ary versions)
+
+(define (find pred ls)
+ (cond ((find-tail pred ls) => car)
+ (else #f)))
+
+(define (find-tail pred ls)
+ (let lp ((ls ls))
+ (cond ((null? ls) #f)
+ ((pred (car ls)) ls)
+ (else (lp (cdr ls))))))
+
+(define (last ls)
+ (if (not (pair? ls))
+ (error "can't take last of empty list" ls)
+ (let lp ((ls ls))
+ (if (pair? (cdr ls))
+ (lp (cdr ls))
+ (car ls)))))
+
+(define (any pred ls)
+ (and (pair? ls)
+ (let lp ((head (car ls)) (tail (cdr ls)))
+ (if (null? tail)
+ (pred head)
+ (or (pred head) (lp (car tail) (cdr tail)))))))
+
+(define (every pred ls)
+ (or (null? ls)
+ (let lp ((head (car ls)) (tail (cdr ls)))
+ (if (null? tail)
+ (pred head)
+ (and (pred head) (lp (car tail) (cdr tail)))))))
+
+(define (fold kons knil ls)
+ (let lp ((ls ls) (res knil))
+ (if (null? ls)
+ res
+ (lp (cdr ls) (kons (car ls) res)))))
+
+(define (filter pred ls)
+ (let lp ((ls ls) (res '()))
+ (if (null? ls)
+ (reverse res)
+ (lp (cdr ls) (if (pred (car ls)) (cons (car ls) res) res)))))
+
+(define (remove pred ls)
+ (let lp ((ls ls) (res '()))
+ (if (null? ls)
+ (reverse res)
+ (lp (cdr ls) (if (pred (car ls)) res (cons (car ls) res))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; flags
+
+(define (bit-shr n i)
+ (quotient n (expt 2 i)))
+
+(define (bit-shl n i)
+ (* n (expt 2 i)))
+
+(define (bit-not n) (- #xFFFF n))
+
+(define (bit-ior a b)
+ (cond
+ ((zero? a) b)
+ ((zero? b) a)
+ (else
+ (+ (if (or (odd? a) (odd? b)) 1 0)
+ (* 2 (bit-ior (quotient a 2) (quotient b 2)))))))
+
+(define (bit-and a b)
+ (cond
+ ((zero? a) 0)
+ ((zero? b) 0)
+ (else
+ (+ (if (and (odd? a) (odd? b)) 1 0)
+ (* 2 (bit-and (quotient a 2) (quotient b 2)))))))
+
+(define (flag-set? flags i)
+ (= i (bit-and flags i)))
+(define (flag-join a b)
+ (if b (bit-ior a b) a))
+(define (flag-clear a b)
+ (bit-and a (bit-not b)))
+
+(define ~none 0)
+(define ~searcher? 1)
+(define ~consumer? 2)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; parsing
+
+(define ~save? 1)
+(define ~case-insensitive? 2)
+(define ~multi-line? 4)
+(define ~single-line? 8)
+(define ~ignore-space? 16)
+(define ~utf8? 32)
+
+(define (symbol-list->flags ls)
+ (let lp ((ls ls) (res ~none))
+ (if (not (pair? ls))
+ res
+ (lp (cdr ls)
+ (flag-join
+ res
+ (case (car ls)
+ ((i ci case-insensitive) ~case-insensitive?)
+ ((m multi-line) ~multi-line?)
+ ((s single-line) ~single-line?)
+ ((x ignore-space) ~ignore-space?)
+ ((u utf8) ~utf8?)
+ (else #f)))))))
+
+(define (string->sre str . o)
+ (let ((end (string-length str))
+ (flags (symbol-list->flags o)))
+
+ (let lp ((i 0) (from 0) (flags flags) (res '()) (st '()))
+
+ ;; handle case sensitivity at the literal char/string level
+ (define (cased-char ch)
+ (if (and (flag-set? flags ~case-insensitive?)
+ (char-alphabetic? ch))
+ `(or ,ch ,(char-altcase ch))
+ ch))
+ (define (cased-string str)
+ (if (flag-set? flags ~case-insensitive?)
+ (sre-sequence (map cased-char (string->list str)))
+ str))
+ ;; accumulate the substring from..i as literal text
+ (define (collect)
+ (if (= i from) res (cons (cased-string (substring str from i)) res)))
+ ;; like collect but breaks off the last single character when
+ ;; collecting literal data, as the argument to ?/*/+ etc.
+ (define (collect/single)
+ (let* ((utf8? (flag-set? flags ~utf8?))
+ (j (if (and utf8? (> i 1))
+ (utf8-backup-to-initial-char str (- i 1))
+ (- i 1))))
+ (cond
+ ((< j from)
+ res)
+ (else
+ (let ((c (cased-char (if utf8?
+ (utf8-string-ref str j (- i j) )
+ (string-ref str j)))))
+ (cond
+ ((= j from)
+ (cons c res))
+ (else
+ (cons c
+ (cons (cased-string (substring str from j))
+ res)))))))))
+ ;; collects for use as a result, reversing and grouping OR
+ ;; terms, and some ugly tweaking of `function-like' groups and
+ ;; conditionals
+ (define (collect/terms)
+ (let* ((ls (collect))
+ (func
+ (and (pair? ls)
+ (memq (last ls)
+ '(atomic if look-ahead neg-look-ahead
+ look-behind neg-look-behind submatch-named
+ w/utf8 w/noutf8))))
+ (prefix (if (and func (eq? 'submatch-named (car func)))
+ (list 'submatch-named (cadr (reverse ls)))
+ (and func (list (car func)))))
+ (ls (if func
+ (if (eq? 'submatch-named (car func))
+ (reverse (cddr (reverse ls)))
+ (reverse (cdr (reverse ls))))
+ ls)))
+ (let lp ((ls ls) (term '()) (res '()))
+ (define (shift)
+ (cons (sre-sequence term) res))
+ (cond
+ ((null? ls)
+ (let* ((res (sre-alternate (shift)))
+ (res (if (flag-set? flags ~save?)
+ (list 'submatch res)
+ res)))
+ (if prefix
+ (if (eq? 'if (car prefix))
+ (cond
+ ((not (pair? res))
+ 'epsilon)
+ ((memq (car res)
+ '(look-ahead neg-look-ahead
+ look-behind neg-look-behind))
+ res)
+ ((eq? 'seq (car res))
+ `(if ,(cadr res)
+ ,(if (pair? (cdr res))
+ (sre-sequence (cddr res))
+ 'epsilon)))
+ (else
+ `(if ,(cadadr res)
+ ,(if (pair? (cdr res))
+ (sre-sequence (cddadr res))
+ 'epsilon)
+ ,(sre-alternate
+ (if (pair? (cdr res)) (cddr res) '())))))
+ `(,@prefix ,res))
+ res)))
+ ((eq? 'or (car ls)) (lp (cdr ls) '() (shift)))
+ (else (lp (cdr ls) (cons (car ls) term) res))))))
+ (define (save)
+ (cons (cons flags (collect)) st))
+
+ ;; main parsing
+ (if (>= i end)
+ (if (pair? st)
+ (error "unterminated parenthesis in regexp" str)
+ (collect/terms))
+ (let ((c (string-ref str i)))
+ (case c
+ ((#\.)
+ (lp (+ i 1) (+ i 1) flags
+ (cons (if (flag-set? flags ~single-line?) 'any 'nonl)
+ (collect))
+ st))
+ ((#\?)
+ (let ((res (collect/single)))
+ (if (null? res)
+ (error "? can't follow empty sre" str res)
+ (let ((x (car res)))
+ (lp (+ i 1)
+ (+ i 1)
+ flags
+ (cons
+ (if (pair? x)
+ (case (car x)
+ ((*) `(*? ,@(cdr x)))
+ ((+) `(**? 1 #f ,@(cdr x)))
+ ((?) `(?? ,@(cdr x)))
+ ((**) `(**? ,@(cdr x)))
+ ((=) `(**? ,(cadr x) ,@(cdr x)))
+ ((>=) `(**? ,(cadr x) #f ,@(cddr x)))
+ (else `(? ,x)))
+ `(? ,x))
+ (cdr res))
+ st)))))
+ ((#\+ #\*)
+ (let* ((res (collect/single))
+ (x (car res))
+ (op (string->symbol (string c))))
+ (cond
+ ((sre-repeater? x)
+ (error "duplicate repetition (e.g. **) in sre" str res))
+ ((sre-empty? x)
+ (error "can't repeat empty sre (e.g. ()*)" str res))
+ (else
+ (lp (+ i 1) (+ i 1) flags
+ (cons (list op x) (cdr res))
+ st)))))
+ ((#\()
+ (cond
+ ((>= (+ i 1) end)
+ (error "unterminated parenthesis in regexp" str))
+ ((not (eqv? #\? (string-ref str (+ i 1))))
+ (lp (+ i 1) (+ i 1) (flag-join flags ~save?) '() (save)))
+ ((>= (+ i 2) end)
+ (error "unterminated parenthesis in regexp" str))
+ (else
+ (case (string-ref str (+ i 2))
+ ((#\#)
+ (let ((j (string-scan-char str #\) (+ i 3))))
+ (lp (+ j i) (+ j 1) flags (collect) st)))
+ ((#\:)
+ (lp (+ i 3) (+ i 3) (flag-clear flags ~save?) '() (save)))
+ ((#\=)
+ (lp (+ i 3) (+ i 3) (flag-clear flags ~save?)
+ '(look-ahead) (save)))
+ ((#\!)
+ (lp (+ i 3) (+ i 3) (flag-clear flags ~save?)
+ '(neg-look-ahead) (save)))
+ ((#\<)
+ (cond
+ ((>= (+ i 3) end)
+ (error "unterminated parenthesis in regexp" str))
+ (else
+ (case (string-ref str (+ i 3))
+ ((#\=)
+ (lp (+ i 4) (+ i 4) (flag-clear flags ~save?)
+ '(look-behind) (save)))
+ ((#\!)
+ (lp (+ i 4) (+ i 4) (flag-clear flags ~save?)
+ '(neg-look-behind) (save)))
+ (else
+ (let ((j (and (char-alphabetic?
+ (string-ref str (+ i 3)))
+ (string-scan-char str #\> (+ i 4)))))
+ (if j
+ (lp (+ j 1) (+ j 1) (flag-clear flags ~save?)
+ `(,(string->symbol (substring str (+ i 3) j))
+ submatch-named)
+ (save))
+ (error "invalid (?< sequence" str))))))))
+ ((#\>)
+ (lp (+ i 3) (+ i 3) (flag-clear flags ~save?)
+ '(atomic) (save)))
+ ;;((#\' #\P) ; named subpatterns
+ ;; )
+ ;;((#\R) ; recursion
+ ;; )
+ ((#\()
+ (cond
+ ((>= (+ i 3) end)
+ (error "unterminated parenthesis in regexp" str))
+ ((char-numeric? (string-ref str (+ i 3)))
+ (let* ((j (string-scan-char str #\) (+ i 3)))
+ (n (string->number (substring str (+ i 3) j))))
+ (if (not n)
+ (error "invalid conditional reference" str)
+ (lp (+ j 1) (+ j 1) (flag-clear flags ~save?)
+ `(,n if) (save)))))
+ ((char-alphabetic? (string-ref str (+ i 3)))
+ (let* ((j (string-scan-char str #\) (+ i 3)))
+ (s (string->symbol (substring str (+ i 3) j))))
+ (lp (+ j 1) (+ j 1) (flag-clear flags ~save?)
+ `(,s if) (save))))
+ (else
+ (lp (+ i 2) (+ i 2) (flag-clear flags ~save?)
+ '(if) (save)))))
+ ((#\{)
+ (error "unsupported Perl-style cluster" str))
+ (else
+ (let ((old-flags flags))
+ (let lp2 ((j (+ i 2)) (flags flags) (invert? #f))
+ (define (join x)
+ ((if invert? flag-clear flag-join) flags x))
+ (define (new-res res)
+ (let ((before (flag-set? old-flags ~utf8?))
+ (after (flag-set? flags ~utf8?)))
+ (if (eq? before after)
+ res
+ (cons (if after 'w/utf8 'w/noutf8) res))))
+ (cond
+ ((>= j end)
+ (error "incomplete cluster" str i))
+ (else
+ (case (string-ref str j)
+ ((#\i)
+ (lp2 (+ j 1) (join ~case-insensitive?) invert?))
+ ((#\m)
+ (lp2 (+ j 1) (join ~multi-line?) invert?))
+ ((#\x)
+ (lp2 (+ j 1) (join ~ignore-space?) invert?))
+ ((#\u)
+ (if *allow-utf8-mode?*
+ (lp2 (+ j 1) (join ~utf8?) invert?)
+ (lp2 (+ j 1) flags invert?)))
+ ((#\-)
+ (lp2 (+ j 1) flags (not invert?)))
+ ((#\))
+ (lp (+ j 1) (+ j 1) flags (new-res (collect))
+ st))
+ ((#\:)
+ (lp (+ j 1) (+ j 1) flags (new-res '())
+ (cons (cons old-flags (collect)) st)))
+ (else
+ (error "unknown regex cluster modifier" str)
+ )))))))))))
+ ((#\))
+ (if (null? st)
+ (error "too many )'s in regexp" str)
+ (lp (+ i 1)
+ (+ i 1)
+ (caar st)
+ (cons (collect/terms) (cdar st))
+ (cdr st))))
+ ((#\[)
+ (apply
+ (lambda (sre j)
+ (lp (+ j 1) (+ j 1) flags (cons sre (collect)) st))
+ (string-parse-cset str (+ i 1) flags)))
+ ((#\{)
+ (if (or (>= (+ i 1) end)
+ (not (or (char-numeric? (string-ref str (+ i 1)))
+ (eqv? #\, (string-ref str (+ i 1))))))
+ (lp (+ i 1) from flags res st)
+ (let* ((res (collect/single))
+ (x (car res))
+ (tail (cdr res))
+ (j (string-scan-char str #\} (+ i 1)))
+ (s2 (string-split-char (substring str (+ i 1) j) #\,))
+ (n (or (string->number (car s2)) 0))
+ (m (and (pair? (cdr s2)) (string->number (cadr s2)))))
+ (cond
+ ((null? (cdr s2))
+ (lp (+ j 1) (+ j 1) flags `((= ,n ,x) ,@tail) st))
+ (m
+ (lp (+ j 1) (+ j 1) flags `((** ,n ,m ,x) ,@tail) st))
+ (else
+ (lp (+ j 1) (+ j 1) flags `((>= ,n ,x) ,@tail) st)
+ )))))
+ ((#\\)
+ (cond
+ ((>= (+ i 1) end)
+ (error "incomplete escape sequence" str))
+ (else
+ (let ((c (string-ref str (+ i 1))))
+ (case c
+ ((#\d)
+ (lp (+ i 2) (+ i 2) flags `(numeric ,@(collect)) st))
+ ((#\D)
+ (lp (+ i 2) (+ i 2) flags `((~ numeric) ,@(collect)) st))
+ ((#\s)
+ (lp (+ i 2) (+ i 2) flags `(space ,@(collect)) st))
+ ((#\S)
+ (lp (+ i 2) (+ i 2) flags `((~ space) ,@(collect)) st))
+ ((#\w)
+ (lp (+ i 2) (+ i 2) flags
+ `((or alphanumeric ("_")) ,@(collect)) st))
+ ((#\W)
+ (lp (+ i 2) (+ i 2) flags
+ `((~ (or alphanumeric ("_"))) ,@(collect)) st))
+ ((#\b)
+ (lp (+ i 2) (+ i 2) flags
+ `((or bow eow) ,@(collect)) st))
+ ((#\B)
+ (lp (+ i 2) (+ i 2) flags `(nwb ,@(collect)) st))
+ ((#\A)
+ (lp (+ i 2) (+ i 2) flags `(bos ,@(collect)) st))
+ ((#\Z)
+ (lp (+ i 2) (+ i 2) flags
+ `((? #\newline) eos ,@(collect)) st))
+ ((#\z)
+ (lp (+ i 2) (+ i 2) flags `(eos ,@(collect)) st))
+ ((#\R)
+ (lp (+ i 2) (+ i 2) flags `(newline ,@(collect)) st))
+ ((#\K)
+ (lp (+ i 2) (+ i 2) flags `(reset ,@(collect)) st))
+ ;; these two are from Emacs and TRE, but not PCRE
+ ((#\<)
+ (lp (+ i 2) (+ i 2) flags `(bow ,@(collect)) st))
+ ((#\>)
+ (lp (+ i 2) (+ i 2) flags `(eow ,@(collect)) st))
+ ((#\x)
+ (apply
+ (lambda (ch j)
+ (lp (+ j 1) (+ j 1) flags `(,ch ,@(collect)) st))
+ (string-parse-hex-escape str (+ i 2) end)))
+ ((#\k)
+ (let ((c (string-ref str (+ i 2))))
+ (if (not (memv c '(#\< #\{ #\')))
+ (error "bad \\k usage, expected \\k<...>" str)
+ (let* ((terminal (char-mirror c))
+ (j (string-scan-char str terminal (+ i 2)))
+ (s (and j (substring str (+ i 3) j)))
+ (backref
+ (if (flag-set? flags ~case-insensitive?)
+ 'backref-ci
+ 'backref)))
+ (if (not j)
+ (error "interminated named backref" str)
+ (lp (+ j 1) (+ j 1) flags
+ `((,backref ,(string->symbol s))
+ ,@(collect))
+ st))))))
+ ((#\Q) ;; \Q..\E escapes
+ (let ((res (collect)))
+ (let lp2 ((j (+ i 2)))
+ (cond
+ ((>= j end)
+ (lp j (+ i 2) flags res st))
+ ((eqv? #\\ (string-ref str j))
+ (cond
+ ((>= (+ j 1) end)
+ (lp (+ j 1) (+ i 2) flags res st))
+ ((eqv? #\E (string-ref str (+ j 1)))
+ (lp (+ j 2) (+ j 2) flags
+ (cons (substring str (+ i 2) j) res) st))
+ (else
+ (lp2 (+ j 2)))))
+ (else
+ (lp2 (+ j 1)))))))
+ ;;((#\p) ; XXXX unicode properties
+ ;; )
+ ;;((#\P)
+ ;; )
+ (else
+ (cond
+ ((char-numeric? c)
+ (let* ((j (or (string-scan-pred
+ str
+ (lambda (c) (not (char-numeric? c)))
+ (+ i 2))
+ end))
+ (backref
+ (if (flag-set? flags ~case-insensitive?)
+ 'backref-ci
+ 'backref))
+ (res `((,backref ,(string->number
+ (substring str (+ i 1) j)))
+ ,@(collect))))
+ (lp j j flags res st)))
+ ((char-alphabetic? c)
+ (let ((cell (assv c posix-escape-sequences)))
+ (if cell
+ (lp (+ i 2) (+ i 2) flags
+ (cons (cdr cell) (collect)) st)
+ (error "unknown escape sequence" str c))))
+ (else
+ (lp (+ i 2) (+ i 1) flags (collect) st)))))))))
+ ((#\|)
+ (lp (+ i 1) (+ i 1) flags (cons 'or (collect)) st))
+ ((#\^)
+ (let ((sym (if (flag-set? flags ~multi-line?) 'bol 'bos)))
+ (lp (+ i 1) (+ i 1) flags (cons sym (collect)) st)))
+ ((#\$)
+ (let ((sym (if (flag-set? flags ~multi-line?) 'eol 'eos)))
+ (lp (+ i 1) (+ i 1) flags (cons sym (collect)) st)))
+ ((#\space)
+ (if (flag-set? flags ~ignore-space?)
+ (lp (+ i 1) (+ i 1) flags (collect) st)
+ (lp (+ i 1) from flags res st)))
+ ((#\#)
+ (if (flag-set? flags ~ignore-space?)
+ (let ((j (or (string-scan-char str #\newline (+ i 1))
+ (- end 1))))
+ (lp (+ j 1) (+ j 1) flags (collect) st))
+ (lp (+ i 1) from flags res st)))
+ (else
+ (lp (+ i 1) from flags res st))))))))
+
+(define posix-escape-sequences
+ `((#\n . #\newline)
+ (#\r . ,(integer->char (+ (char->integer #\newline) 3)))
+ (#\t . ,(integer->char (- (char->integer #\newline) 1)))
+ (#\a . ,(integer->char (- (char->integer #\newline) 3)))
+ (#\e . ,(integer->char (+ (char->integer #\newline) #x11)))
+ (#\f . ,(integer->char (+ (char->integer #\newline) 2)))
+ ))
+
+(define (char-altcase c)
+ (if (char-upper-case? c) (char-downcase c) (char-upcase c)))
+
+(define (char-mirror c)
+ (case c ((#\<) #\>) ((#\{) #\}) ((#\() #\)) ((#\[) #\]) (else c)))
+
+(define (string-parse-hex-escape str i end)
+ (cond
+ ((>= i end)
+ (error "incomplete hex escape" str i))
+ ((eqv? #\{ (string-ref str i))
+ (let ((j (string-scan-char-escape str #\} (+ i 1))))
+ (if (not j)
+ (error "incomplete hex brace escape" str i)
+ (let* ((s (substring str (+ i 1) j))
+ (n (string->number s 16)))
+ (if n
+ (list (integer->char n) j)
+ (error "bad hex brace escape" s))))))
+ ((>= (+ i 1) end)
+ (error "incomplete hex escape" str i))
+ (else
+ (let* ((s (substring str i (+ i 2)))
+ (n (string->number s 16)))
+ (if n
+ (list (integer->char n) (+ i 2))
+ (error "bad hex escape" s))))))
+
+(define (string-parse-cset str start flags)
+ (let ((end (string-length str))
+ (invert? (eqv? #\^ (string-ref str start)))
+ (utf8? (flag-set? flags ~utf8?)))
+ (define (go i chars ranges)
+ (if (>= i end)
+ (error "incomplete char set")
+ (let ((c (string-ref str i)))
+ (case c
+ ((#\])
+ (if (and (null? chars) (null? ranges))
+ (go (+ i 1) (cons #\] chars) ranges)
+ (let ((ci? (flag-set? flags ~case-insensitive?))
+ (hi-chars (if utf8? (filter high-char? chars) '()))
+ (chars (if utf8? (remove high-char? chars) chars)))
+ (list
+ ((lambda (res)
+ (if invert? (cons '~ res) (sre-alternate res)))
+ (append
+ hi-chars
+ (if (pair? chars)
+ (list
+ (list (list->string
+ ((if ci?
+ cset-case-insensitive
+ (lambda (x) x))
+ (reverse chars)))))
+ '())
+ (if (pair? ranges)
+ (let ((res (if ci?
+ (cset-case-insensitive
+ (reverse ranges))
+ (reverse ranges))))
+ (list (cons '/ (alist->plist res))))
+ '())))
+ i))))
+ ((#\-)
+ (cond
+ ((or (= i start)
+ (and (= i (+ start 1)) (eqv? #\^ (string-ref str start)))
+ (eqv? #\] (string-ref str (+ i 1))))
+ (go (+ i 1) (cons c chars) ranges))
+ ((null? chars)
+ (error "bad char-set"))
+ (else
+ (let* ((c1 (car chars))
+ (c2 (string-ref str (+ i 1))))
+ (apply
+ (lambda (c2 j)
+ (if (char<? c2 c1)
+ (error "inverted range in char-set" c1 c2)
+ (go j (cdr chars) (cons (cons c1 c2) ranges))))
+ (cond
+ ((and (eqv? #\\ c2) (assv c2 posix-escape-sequences))
+ => (lambda (x) (list (cdr x) (+ i 3))))
+ ((and (eqv? #\\ c2)
+ (eqv? (string-ref str (+ i 2)) #\x))
+ (string-parse-hex-escape str (+ i 3) end))
+ ((and utf8? (<= #x80 (char->integer c2) #xFF))
+ (let ((len (utf8-start-char->length c2)))
+ (list (utf8-string-ref str (+ i 1) len) (+ i 1 len))))
+ (else
+ (list c2 (+ i 2)))))))))
+ ((#\[)
+ (let* ((inv? (eqv? #\^ (string-ref str (+ i 1))))
+ (i2 (if inv? (+ i 2) (+ i 1))))
+ (case (string-ref str i2)
+ ((#\:)
+ (let ((j (string-scan-char str #\: (+ i2 1))))
+ (if (or (not j) (not (eqv? #\] (string-ref str (+ j 1)))))
+ (error "incomplete character class" str)
+ (let* ((cset (sre->cset
+ (string->symbol
+ (substring str (+ i2 1) j))))
+ (cset (if inv? (cset-complement cset) cset)))
+ (go (+ j 2)
+ (append (filter char? cset) chars)
+ (append (filter pair? cset) ranges))))))
+ ((#\= #\.)
+ (error "collating sequences not supported" str))
+ (else
+ (go (+ i 1) (cons #\[ chars) ranges)))))
+ ((#\\)
+ (let ((c (string-ref str (+ i 1))))
+ (case c
+ ((#\d #\D #\s #\S #\w #\W)
+ (let ((cset (sre->cset (string->sre (string #\\ c)))))
+ (go (+ i 2)
+ (append (filter char? cset) chars)
+ (append (filter pair? cset) ranges))))
+ ((#\x)
+ (apply
+ (lambda (ch j)
+ (go j (cons ch chars) ranges))
+ (string-parse-hex-escape str (+ i 2) end)))
+ (else
+ (let ((c (cond ((assv c posix-escape-sequences) => cdr)
+ (else c))))
+ (go (+ i 2)
+ (cons (string-ref str (+ i 1)) (cons c chars))
+ ranges))))))
+ (else
+ (if (and utf8? (<= #x80 (char->integer c) #xFF))
+ (let ((len (utf8-start-char->length c)))
+ (go (+ i len)
+ (cons (utf8-string-ref str i len) chars)
+ ranges))
+ (go (+ i 1) (cons c chars) ranges)))))))
+ (if invert?
+ (go (+ start 1)
+ (if (flag-set? flags ~multi-line?) '(#\newline) '())
+ '())
+ (go start '() '()))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utf8 utilities
+
+;; Here are some hairy optimizations that need to be documented
+;; better. Thanks to these, we never do any utf8 processing once the
+;; regexp is compiled.
+
+;; two chars: ab..ef
+;; a[b..xFF]|[b-d][x80..xFF]|e[x80..xFF]
+
+;; three chars: abc..ghi
+;; ab[c..xFF]|a[d..xFF][x80..xFF]|
+;; [b..f][x80..xFF][x80..xFF]|
+;; g[x80..g][x80..xFF]|gh[x80..i]
+
+;; four chars: abcd..ghij
+;; abc[d..xFF]|ab[d..xFF][x80..xFF]|a[c..xFF][x80..xFF][x80..xFF]|
+;; [b..f][x80..xFF][x80..xFF][x80..xFF]|
+;; g[x80..g][x80..xFF][x80..xFF]|gh[x80..h][x80..xFF]|ghi[x80..j]
+
+(define (high-char? c) (<= #x80 (char->integer c)))
+
+;; number of total bytes in a utf8 char given the 1st byte
+
+(define utf8-start-char->length
+ (let ((table '#(
+1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 0x
+1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 1x
+1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 2x
+1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 3x
+1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 4x
+1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 5x
+1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 6x
+1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 7x
+1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 8x
+1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; 9x
+1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; ax
+1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ; bx
+2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ; cx
+2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 2 ; dx
+3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 3 ; ex
+4 4 4 4 4 4 4 4 5 5 5 5 6 6 0 0 ; fx
+)))
+ (lambda (c) (vector-ref table (char->integer c)))))
+
+(define (utf8-string-ref str i len)
+ (define (byte n) (char->integer (string-ref str n)))
+ (case len
+ ((1) ; shouldn't happen in this module
+ (string-ref str i))
+ ((2)
+ (integer->char
+ (+ (bit-shl (bit-and (byte i) #b00011111) 6)
+ (bit-and (byte (+ i 1)) #b00111111))))
+ ((3)
+ (integer->char
+ (+ (bit-shl (bit-and (byte i) #b00001111) 12)
+ (bit-shl (bit-and (byte (+ i 1)) #b00111111) 6)
+ (bit-and (byte (+ i 2)) #b00111111))))
+ ((4)
+ (integer->char
+ (+ (bit-shl (bit-and (byte i) #b00000111) 18)
+ (bit-shl (bit-and (byte (+ i 1)) #b00111111) 12)
+ (bit-shl (bit-and (byte (+ i 2)) #b00111111) 6)
+ (bit-and (byte (+ i 3)) #b00111111))))
+ (else
+ (error "invalid utf8 length" str len i))))
+
+(define (utf8-backup-to-initial-char str i)
+ (let lp ((i i))
+ (if (= i 0)
+ 0
+ (let ((c (char->integer (string-ref str i))))
+ (if (or (< c #x80) (>= c #xC0))
+ i
+ (lp (- i 1)))))))
+
+(define (utf8-lowest-digit-of-length len)
+ (case len
+ ((1) 0) ((2) #xC0) ((3) #xE0) ((4) #xF0)
+ (else (error "invalid utf8 length" len))))
+
+(define (utf8-highest-digit-of-length len)
+ (case len
+ ((1) #x7F) ((2) #xDF) ((3) #xEF) ((4) #xF7)
+ (else (error "invalid utf8 length" len))))
+
+(define (char->utf8-list c)
+ (let ((i (char->integer c)))
+ (cond
+ ((<= i #x7F) (list i))
+ ((<= i #x7FF)
+ (list (bit-ior #b11000000 (bit-shr i 6))
+ (bit-ior #b10000000 (bit-and i #b111111))))
+ ((<= i #xFFFF)
+ (list (bit-ior #b11100000 (bit-shr i 12))
+ (bit-ior #b10000000 (bit-and (bit-shr i 6) #b111111))
+ (bit-ior #b10000000 (bit-and i #b111111))))
+ ((<= i #x1FFFFF)
+ (list (bit-ior #b11110000 (bit-shr i 18))
+ (bit-ior #b10000000 (bit-and (bit-shr i 12) #b111111))
+ (bit-ior #b10000000 (bit-and (bit-shr i 6) #b111111))
+ (bit-ior #b10000000 (bit-and i #b111111))))
+ (else (error "unicode codepoint out of range:" i)))))
+
+(define (unicode-range->utf8-pattern lo hi)
+ (let ((lo-ls (char->utf8-list lo))
+ (hi-ls (char->utf8-list hi)))
+ (if (not (= (length lo-ls) (length hi-ls)))
+ (sre-alternate (list (unicode-range-climb-digits lo-ls hi-ls)
+ (unicode-range-up-to hi-ls)))
+ (let lp ((lo-ls lo-ls) (hi-ls hi-ls))
+ (cond
+ ((null? lo-ls)
+ '())
+ ((= (car lo-ls) (car hi-ls))
+ (sre-sequence
+ (list (integer->char (car lo-ls))
+ (lp (cdr lo-ls) (cdr hi-ls)))))
+ ((= (+ (car lo-ls) 1) (car hi-ls))
+ (sre-alternate (list (unicode-range-up-from lo-ls)
+ (unicode-range-up-to hi-ls))))
+ (else
+ (sre-alternate (list (unicode-range-up-from lo-ls)
+ (unicode-range-middle lo-ls hi-ls)
+ (unicode-range-up-to hi-ls)))))))))
+
+(define (unicode-range-helper one ls prefix res)
+ (if (null? ls)
+ res
+ (unicode-range-helper
+ one
+ (cdr ls)
+ (cons (car ls) prefix)
+ (cons (sre-sequence
+ `(,@(map integer->char prefix)
+ ,(one (car ls))
+ ,@(map (lambda (_)
+ `(/ ,(integer->char #x80)
+ ,(integer->char #xFF)))
+ (cdr ls))))
+ res))))
+
+(define (unicode-range-up-from lo-ls)
+ (sre-sequence
+ (list (integer->char (car lo-ls))
+ (sre-alternate
+ (unicode-range-helper
+ (lambda (c)
+ `(/ ,(integer->char (+ (car lo-ls) 1)) ,(integer->char #xFF)))
+ (cdr (reverse (cdr lo-ls)))
+ '()
+ (list
+ (sre-sequence
+ (append
+ (map integer->char (reverse (cdr (reverse (cdr lo-ls)))))
+ `((/ ,(integer->char (last lo-ls))
+ ,(integer->char #xFF)))))))))))
+
+(define (unicode-range-up-to hi-ls)
+ (sre-sequence
+ (list (integer->char (car hi-ls))
+ (sre-alternate
+ (unicode-range-helper
+ (lambda (c)
+ `(/ ,(integer->char #x80) ,(integer->char (- (car hi-ls) 1))))
+ (cdr (reverse (cdr hi-ls)))
+ '()
+ (list
+ (sre-sequence
+ (append
+ (map integer->char (reverse (cdr (reverse (cdr hi-ls)))))
+ `((/ ,(integer->char #x80)
+ ,(integer->char (last hi-ls))))))))))))
+
+(define (unicode-range-climb-digits lo-ls hi-ls)
+ (let ((lo-len (length lo-ls)))
+ (sre-alternate
+ (append
+ (list
+ (sre-sequence
+ (cons `(/ ,(integer->char (car lo-ls))
+ ,(integer->char (if (<= (car lo-ls) #x7F) #x7F #xFF)))
+ (map (lambda (_)
+ `(/ ,(integer->char #x80) ,(integer->char #xFF)))
+ (cdr lo-ls)))))
+ (map
+ (lambda (i)
+ (sre-sequence
+ (cons
+ `(/ ,(integer->char (utf8-lowest-digit-of-length (+ i lo-len 1)))
+ ,(integer->char (utf8-highest-digit-of-length (+ i lo-len 1))))
+ (map (lambda (_)
+ `(/ ,(integer->char #x80) ,(integer->char #xFF)))
+ (zero-to (+ i lo-len))))))
+ (zero-to (- (length hi-ls) lo-len 1)))
+ (list
+ (sre-sequence
+ (cons `(/ ,(integer->char
+ (utf8-lowest-digit-of-length
+ (utf8-start-char->length
+ (integer->char (- (car hi-ls) 1)))))
+ ,(integer->char (- (car hi-ls) 1)))
+ (map (lambda (_)
+ `(/ ,(integer->char #x80) ,(integer->char #xFF)))
+ (cdr hi-ls)))))))))
+
+(define (unicode-range-middle lo-ls hi-ls)
+ (let ((lo (integer->char (+ (car lo-ls) 1)))
+ (hi (integer->char (- (car hi-ls) 1))))
+ (sre-sequence
+ (cons (if (char=? lo hi) lo `(/ ,lo ,hi))
+ (map (lambda (_) `(/ ,(integer->char #x80) ,(integer->char #xFF)))
+ (cdr lo-ls))))))
+
+(define (cset->utf8-pattern cset)
+ (let lp ((ls cset) (alts '()) (lo-cset '()))
+ (cond
+ ((null? ls)
+ (sre-alternate (append (reverse alts)
+ (if (null? lo-cset)
+ '()
+ (list (cons '/ (reverse lo-cset)))))))
+ ((char? (car ls))
+ (if (high-char? (car ls))
+ (lp (cdr ls) (cons (car ls) alts) lo-cset)
+ (lp (cdr ls) alts (cons (car ls) lo-cset))))
+ (else
+ (if (or (high-char? (caar ls)) (high-char? (cdar ls)))
+ (lp (cdr ls)
+ (cons (unicode-range->utf8-pattern (caar ls) (cdar ls)) alts)
+ lo-cset)
+ (lp (cdr ls) alts (cons (cdar ls) (cons (caar ls) lo-cset))))))))
+
+(define (sre-adjust-utf8 sre flags)
+ (let adjust ((sre sre)
+ (utf8? (flag-set? flags ~utf8?))
+ (ci? (flag-set? flags ~case-insensitive?)))
+ (define (rec sre) (adjust sre utf8? ci?))
+ (cond
+ ((pair? sre)
+ (case (car sre)
+ ((w/utf8) (adjust (sre-sequence (cdr sre)) #t ci?))
+ ((w/noutf8) (adjust (sre-sequence (cdr sre)) #f ci?))
+ ((w/case)
+ (cons (car sre) (map (lambda (s) (adjust s utf8? #f)) (cdr sre))))
+ ((w/nocase)
+ (cons (car sre) (map (lambda (s) (adjust s utf8? #t)) (cdr sre))))
+ ((/ ~ & -)
+ (if (not utf8?)
+ sre
+ (let ((cset (sre->cset sre ci?)))
+ (if (any (lambda (x)
+ (if (pair? x)
+ (or (high-char? (car x)) (high-char? (cdr x)))
+ (high-char? x)))
+ cset)
+ (if ci?
+ (list 'w/case (cset->utf8-pattern cset))
+ (cset->utf8-pattern cset))
+ sre))))
+ ((*)
+ (case (sre-sequence (cdr sre))
+ ;; special case optimization: .* w/utf8 == .* w/noutf8
+ ((any) '(* any))
+ ((nonl) '(* nonl))
+ (else (cons '* (map rec (cdr sre))))))
+ (else
+ (cons (car sre) (map rec (cdr sre))))))
+ (else
+ (case sre
+ ((any) 'utf8-any)
+ ((nonl) 'utf8-nonl)
+ (else
+ (if (and utf8? (char? sre) (high-char? sre))
+ (sre-sequence (map integer->char (char->utf8-list sre)))
+ sre)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; compilation
+
+(define (irregex x . o)
+ (cond
+ ((irregex? x) x)
+ ((string? x) (apply string->irregex x o))
+ (else (apply sre->irregex x o))))
+
+(define (string->irregex str . o)
+ (apply sre->irregex (apply string->sre str o) o))
+
+(define (sre->irregex sre . o)
+ (let* ((pat-flags (symbol-list->flags o))
+ (sre (if *allow-utf8-mode?*
+ (sre-adjust-utf8 sre pat-flags)
+ sre))
+ (searcher? (sre-searcher? sre))
+ (sre-dfa (if searcher? (sre-remove-initial-bos sre) sre))
+ (dfa-limit (cond ((memq 'small o) 1) ((memq 'fast o) 50) (else 10)))
+ (dfa/search
+ (if searcher?
+ #t
+ (cond ((sre->nfa `(seq (* any) ,sre-dfa) pat-flags)
+ => (lambda (nfa) (nfa->dfa nfa (* dfa-limit (length nfa)))))
+ (else #f))))
+ (dfa (cond ((and dfa/search (sre->nfa sre-dfa pat-flags))
+ => (lambda (nfa) (nfa->dfa nfa (* dfa-limit (length nfa)))))
+ (else #f)))
+ (extractor (and dfa dfa/search (sre-match-extractor sre-dfa)))
+ (submatches (sre-count-submatches sre-dfa))
+ (names (sre-names sre-dfa 1 '()))
+ (lens (sre-length-ranges sre-dfa names))
+ (flags (flag-join
+ (flag-join ~none (and searcher? ~searcher?))
+ (and (sre-consumer? sre) ~consumer?))))
+ (cond
+ (dfa
+ (make-irregex dfa dfa/search extractor #f flags submatches lens names))
+ (else
+ (let ((f (sre->procedure sre pat-flags names)))
+ (make-irregex #f #f #f f flags submatches lens names))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; sre analysis
+
+;; returns #t if the sre can ever be empty
+(define (sre-empty? sre)
+ (if (pair? sre)
+ (case (car sre)
+ ((* ? look-ahead look-behind neg-look-ahead neg-look-behind) #t)
+ ((**) (or (not (number? (cadr sre))) (zero? (cadr sre))))
+ ((or) (any sre-empty? (cdr sre)))
+ ((: seq submatch + atomic) (every sre-empty? (cdr sre)))
+ (else #f))
+ (memq sre '(epsilon bos eos bol eol bow eow commit))))
+
+(define (sre-any? sre)
+ (or (eq? sre 'any)
+ (and (pair? sre)
+ (case (car sre)
+ ((seq : submatch)
+ (and (pair? (cdr sre)) (null? (cddr sre)) (sre-any? (cadr sre))))
+ ((or) (every sre-any? (cdr sre)))
+ (else #f)))))
+
+(define (sre-repeater? sre)
+ (and (pair? sre)
+ (or (memq (car sre) '(* +))
+ (and (memq (car sre) '(submatch seq :))
+ (pair? (cdr sre))
+ (null? (cddr sre))
+ (sre-repeater? (cadr sre))))))
+
+(define (sre-searcher? sre)
+ (if (pair? sre)
+ (case (car sre)
+ ((* +) (sre-any? (sre-sequence (cdr sre))))
+ ((seq : submatch) (and (pair? (cdr sre)) (sre-searcher? (cadr sre))))
+ ((or) (every sre-searcher? (cdr sre)))
+ (else #f))
+ (eq? 'bos sre)))
+
+(define (sre-consumer? sre)
+ (if (pair? sre)
+ (case (car sre)
+ ((* +) (sre-any? (sre-sequence (cdr sre))))
+ ((seq : submatch) (and (pair? (cdr sre)) (sre-consumer? (last sre))))
+ ((or) (every sre-consumer? (cdr sre)))
+ (else #f))
+ (eq? 'eos sre)))
+
+(define (sre-has-submatchs? sre)
+ (and (pair? sre)
+ (or (eq? 'submatch (car sre))
+ (any sre-has-submatchs? (cdr sre)))))
+
+(define (sre-count-submatches sre)
+ (let count ((sre sre) (sum 0))
+ (if (pair? sre)
+ (fold count
+ (+ sum (case (car sre)
+ ((submatch submatch-named) 1)
+ ((dsm) (+ (cadr sre) (caddr sre)))
+ (else 0)))
+ (cdr sre))
+ sum)))
+
+(define (sre-length-ranges sre . o)
+ (let ((names (if (pair? o) (car o) (sre-names sre 1 '())))
+ (sublens (make-vector (+ 1 (sre-count-submatches sre)) #f)))
+ (vector-set!
+ sublens
+ 0
+ (let lp ((sre sre) (n 1) (lo 0) (hi 0) (return cons))
+ (define (grow i) (return (+ lo i) (and hi (+ hi i))))
+ (cond
+ ((pair? sre)
+ (if (string? (car sre))
+ (grow 1)
+ (case (car sre)
+ ((/ ~ & -)
+ (grow 1))
+ ((posix-string)
+ (lp (string->sre (cadr sre)) n lo hi return))
+ ((seq : w/case w/nocase atomic)
+ (let lp2 ((ls (cdr sre)) (n n) (lo2 0) (hi2 0))
+ (if (null? ls)
+ (return (+ lo lo2) (and hi hi2 (+ hi hi2)))
+ (lp (car ls) n 0 0
+ (lambda (lo3 hi3)
+ (lp2 (cdr ls)
+ (+ n (sre-count-submatches (car ls)))
+ (+ lo2 lo3)
+ (and hi2 hi3 (+ hi2 hi3))))))))
+ ((or)
+ (let lp2 ((ls (cdr sre)) (n n) (lo2 #f) (hi2 0))
+ (if (null? ls)
+ (return (+ lo lo2) (and hi hi2 (+ hi hi2)))
+ (lp (car ls) n 0 0
+ (lambda (lo3 hi3)
+ (lp2 (cdr ls)
+ (+ n (sre-count-submatches (car ls)))
+ (if lo2 (min lo2 lo3) lo3)
+ (and hi2 hi3 (max hi2 hi3))))))))
+ ((if)
+ (cond
+ ((or (null? (cdr sre)) (null? (cddr sre)))
+ (return lo hi))
+ (else
+ (let ((n1 (sre-count-submatches (car sre)))
+ (n2 (sre-count-submatches (cadr sre))))
+ (lp (if (or (number? (cadr sre)) (symbol? (cadr sre)))
+ 'epsilon
+ (cadr sre))
+ n lo hi
+ (lambda (lo2 hi2)
+ (lp (caddr sre) (+ n n1) 0 0
+ (lambda (lo3 hi3)
+ (lp (if (pair? (cdddr sre))
+ (cadddr sre)
+ 'epsilon)
+ (+ n n1 n2) 0 0
+ (lambda (lo4 hi4)
+ (return (+ lo2 (min lo3 lo4))
+ (and hi2 hi3 hi4
+ (+ hi2 (max hi3 hi4))
+ ))))))))))))
+ ((dsm)
+ (lp (sre-sequence (cdddr sre)) (+ n (cadr sre)) lo hi return))
+ ((submatch submatch-named)
+ (lp (sre-sequence
+ (if (eq? 'submatch (car sre)) (cdr sre) (cddr sre)))
+ (+ n 1) lo hi
+ (lambda (lo2 hi2)
+ (vector-set! sublens n (cons lo2 hi2))
+ (return lo2 hi2))))
+ ((backref backref-ci)
+ (let ((n (cond
+ ((number? (cadr sre)) (cadr sre))
+ ((assq (cadr sre) names) => cdr)
+ (else (error "unknown backreference" (cadr sre))))))
+ (cond
+ ((or (not (integer? n))
+ (not (< 0 n (vector-length sublens))))
+ (error "sre-length: invalid backreference" sre))
+ ((not (vector-ref sublens n))
+ (error "sre-length: invalid forward backreference" sre))
+ (else
+ (let ((lo2 (car (vector-ref sublens n)))
+ (hi2 (cdr (vector-ref sublens n))))
+ (return (+ lo lo2) (and hi hi2 (+ hi hi2))))))))
+ ((* *?)
+ (lp (sre-sequence (cdr sre)) n lo hi (lambda (lo hi) #f))
+ (return lo #f))
+ ((** **?)
+ (cond
+ ((or (and (number? (cadr sre))
+ (number? (caddr sre))
+ (> (cadr sre) (caddr sre)))
+ (and (not (cadr sre)) (caddr sre)))
+ (return lo hi))
+ (else
+ (if (caddr sre)
+ (lp (sre-sequence (cdddr sre)) n 0 0
+ (lambda (lo2 hi2)
+ (return (+ lo (* (cadr sre) lo2))
+ (and hi hi2 (+ hi (* (caddr sre) hi2))))))
+ (lp (sre-sequence (cdddr sre)) n 0 0
+ (lambda (lo2 hi2)
+ (return (+ lo (* (cadr sre) lo2)) #f)))))))
+ ((+)
+ (lp (sre-sequence (cdr sre)) n lo hi
+ (lambda (lo2 hi2)
+ (return (+ lo lo2) #f))))
+ ((? ??)
+ (lp (sre-sequence (cdr sre)) n lo hi
+ (lambda (lo2 hi2)
+ (return lo (and hi hi2 (+ hi hi2))))))
+ ((= =? >= >=?)
+ (lp `(** ,(cadr sre)
+ ,(if (memq (car sre) '(>= >=?)) #f (cadr sre))
+ ,@(cddr sre))
+ n lo hi return))
+ ((look-ahead neg-look-ahead look-behind neg-look-behind)
+ (return lo hi))
+ (else
+ (error "sre-length-ranges: unknown sre operator" sre)))))
+ ((char? sre)
+ (grow 1))
+ ((string? sre)
+ (grow (string-length sre)))
+ ((memq sre '(any nonl))
+ (grow 1))
+ ((memq sre '(epsilon bos eos bol eol bow eow nwb commit))
+ (return lo hi))
+ (else
+ (let ((cell (assq sre sre-named-definitions)))
+ (if cell
+ (lp (cdr cell) n lo hi return)
+ (error "sre-length-ranges: unknown sre" sre)))))))
+ sublens))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; sre manipulation
+
+;; build a (seq ls ...) sre from a list
+(define (sre-sequence ls)
+ (cond
+ ((null? ls) 'epsilon)
+ ((null? (cdr ls)) (car ls))
+ (else (cons 'seq ls))))
+
+;; build a (or ls ...) sre from a list
+(define (sre-alternate ls)
+ (cond
+ ((null? ls) 'epsilon)
+ ((null? (cdr ls)) (car ls))
+ (else (cons 'or ls))))
+
+;; returns an equivalent SRE without any match information
+(define (sre-strip-submatches sre)
+ (if (not (pair? sre))
+ sre
+ (case (car sre)
+ ((submatch) (sre-strip-submatches (sre-sequence (cdr sre))))
+ ((dsm) (sre-strip-submatches (sre-sequence (cdddr sre))))
+ (else (map sre-strip-submatches sre)))))
+
+;; given a char-set list of chars and strings, flattens them into
+;; chars only
+(define (sre-flatten-ranges ls)
+ (let lp ((ls ls) (res '()))
+ (cond
+ ((null? ls)
+ (reverse res))
+ ((string? (car ls))
+ (lp (append (string->list (car ls)) (cdr ls)) res))
+ (else
+ (lp (cdr ls) (cons (car ls) res))))))
+
+(define (sre-names sre n names)
+ (if (not (pair? sre))
+ names
+ (case (car sre)
+ ((submatch)
+ (sre-names (sre-sequence (cdr sre)) (+ n 1) names))
+ ((submatch-named)
+ (sre-names (sre-sequence (cddr sre))
+ (+ n 1)
+ (cons (cons (cadr sre) n) names)))
+ ((dsm)
+ (sre-names (sre-sequence (cdddr sre)) (+ n (cadr sre)) names))
+ ((seq : or * + ? *? ?? w/case w/nocase atomic
+ look-ahead look-behind neg-look-ahead neg-look-behind)
+ (sre-sequence-names (cdr sre) n names))
+ ((= >=)
+ (sre-sequence-names (cddr sre) n names))
+ ((** **?)
+ (sre-sequence-names (cdddr sre) n names))
+ (else
+ names))))
+
+(define (sre-sequence-names ls n names)
+ (if (null? ls)
+ names
+ (sre-sequence-names (cdr ls)
+ (+ n (sre-count-submatches (car ls)))
+ (sre-names (car ls) n names))))
+
+(define (sre-remove-initial-bos sre)
+ (cond
+ ((pair? sre)
+ (case (car sre)
+ ((seq : submatch * +)
+ (cond
+ ((not (pair? (cdr sre)))
+ sre)
+ ((eq? 'bos (cadr sre))
+ (cons (car sre) (cddr sre)))
+ (else
+ (cons (car sre)
+ (cons (sre-remove-initial-bos (cadr sre)) (cddr sre))))))
+ ((or)
+ (sre-alternate (map sre-remove-initial-bos (cdr sre))))
+ (else
+ sre)))
+ (else
+ sre)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; matching
+
+(define (irregex-search x str . o)
+ (let ((irx (irregex x)))
+ (let ((start (if (pair? o) (car o) 0))
+ (end (if (and (pair? o) (pair? (cdr o)))
+ (cadr o) (string-length str)))
+ (matches (irregex-new-matches irx)))
+ (irregex-match-string-set! matches str)
+ (irregex-search/matches irx str start end matches))))
+
+;; internal routine, can be used in loops to avoid reallocating the
+;; match vector
+(define (irregex-search/matches irx str start end matches)
+ (cond
+ ((irregex-dfa irx)
+ (cond
+ ((flag-set? (irregex-flags irx) ~searcher?)
+ (let ((m-end (dfa-match/longest (irregex-dfa irx) str start end)))
+ (cond
+ (m-end
+ (irregex-match-start-index-set! matches 0 start)
+ (irregex-match-end-index-set! matches 0 m-end)
+ ((irregex-dfa/extract irx) str start m-end matches)
+ matches)
+ (else
+ #f))))
+ (else
+ (let ((first-match
+ (dfa-match/shortest (irregex-dfa/search irx) str start end)))
+ (and
+ first-match
+ (let* ((lo+hi (vector-ref (irregex-lengths irx) 0))
+ (m-start (if (cdr lo+hi)
+ (max start (- first-match (cdr lo+hi)))
+ start))
+ (m-limit (- first-match (car lo+hi)))
+ (dfa (irregex-dfa irx)))
+ (let lp ((m-start m-start))
+ (and (<= m-start m-limit)
+ (let ((m-end (dfa-match/longest dfa str m-start end)))
+ (cond
+ (m-end
+ (irregex-match-start-index-set! matches 0 m-start)
+ (irregex-match-end-index-set! matches 0 m-end)
+ ((irregex-dfa/extract irx) str m-start m-end matches)
+ matches)
+ (else
+ (lp (+ m-start 1)))))))))))))
+ (else
+ (let ((matcher (irregex-nfa irx)))
+ (let lp ((start start))
+ (and (<= start end)
+ (let ((i (matcher str start matches (lambda () #f))))
+ (cond
+ (i
+ (irregex-match-start-index-set! matches 0 start)
+ (irregex-match-end-index-set! matches 0 i)
+ matches)
+ (else
+ (lp (+ start 1)))))))))))
+
+(define (irregex-match irx str)
+ (let* ((irx (irregex irx))
+ (matches (irregex-new-matches irx))
+ (start 0)
+ (end (string-length str)))
+ (irregex-match-string-set! matches str)
+ (cond
+ ((irregex-dfa irx)
+ (let ((m-end (dfa-match/longest (irregex-dfa irx) str start end)))
+ (cond
+ ((equal? m-end end)
+ (irregex-match-start-index-set! matches 0 start)
+ (irregex-match-end-index-set! matches 0 m-end)
+ ((irregex-dfa/extract irx) str start m-end matches)
+ matches)
+ (else
+ #f))))
+ (else
+ (let* ((matcher (irregex-nfa irx))
+ (i (matcher str start matches (lambda () #f))))
+ (cond
+ ((equal? i end)
+ (irregex-match-start-index-set! matches 0 start)
+ (irregex-match-end-index-set! matches 0 i)
+ matches)
+ (else
+ #f)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; DFA matching
+
+;; inline these
+(define (dfa-init-state dfa)
+ (vector-ref dfa 0))
+(define (dfa-next-state dfa node)
+ (vector-ref dfa (cdr node)))
+(define (dfa-final-state? dfa state)
+ (car state))
+
+;; this searches for the first end index for which a match is possible
+(define (dfa-match/shortest dfa str start end)
+ (let lp ((i start) (state (dfa-init-state dfa)))
+ (if (dfa-final-state? dfa state)
+ i
+ (and (< i end)
+ (let* ((ch (string-ref str i))
+ (next (find (lambda (x)
+ (or (eqv? ch (car x))
+ (and (pair? (car x))
+ (char<=? (caar x) ch)
+ (char<=? ch (cdar x)))))
+ (cdr state))))
+ (and next (lp (+ i 1) (dfa-next-state dfa next))))))))
+
+;; this finds the longest match starting at a given index
+(define (dfa-match/longest dfa str start end)
+ (let lp ((i start)
+ (state (dfa-init-state dfa))
+ (res (and (dfa-final-state? dfa (dfa-init-state dfa)) start)))
+ (if (>= i end)
+ res
+ (let* ((ch (string-ref str i))
+ (cell (find (lambda (x)
+ (or (eqv? ch (car x))
+ (and (pair? (car x))
+ (char<=? (caar x) ch)
+ (char<=? ch (cdar x)))))
+ (cdr state))))
+ (if cell
+ (let ((next (dfa-next-state dfa cell)))
+ (lp (+ i 1)
+ next
+ (if (dfa-final-state? dfa next) (+ i 1) res)))
+ res)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; SRE->NFA compilation
+;;
+;; An NFA state is a numbered node with a list of patter->number
+;; transitions, where pattern is either a character, (lo . hi)
+;; character range, or epsilon (indicating an empty transition).
+;; There may be duplicate characters and overlapping ranges - since
+;; it's an NFA we process it by considering all possible transitions.
+
+(define sre-named-definitions
+ `((any . ,*all-chars*)
+ (nonl . (- ,*all-chars* (,(string #\newline))))
+ (alphabetic . (/ #\a #\z #\A #\Z))
+ (alpha . alphabetic)
+ (alphanumeric . (/ #\a #\z #\A #\Z #\0 #\9))
+ (alphanum . alphanumeric)
+ (alnum . alphanumeric)
+ (lower-case . (/ #\a #\z))
+ (lower . lower-case)
+ (upper-case . (/ #\A #\Z))
+ (upper . upper-case)
+ (numeric . (/ #\0 #\9))
+ (num . numeric)
+ (digit . numeric)
+ (punctuation . (or #\! #\" #\# #\% #\& #\' #\( #\) #\* #\, #\- #\.
+ #\/ #\: #\; #\? #\@ #\[ #\\ #\] #\_ #\{ #\}))
+ (punct . punctuation)
+ (graphic
+ . (or alphanumeric punctuation #\$ #\+ #\< #\= #\> #\^ #\` #\| #\~))
+ (graph . graphic)
+ (blank . (or #\space ,(integer->char (- (char->integer #\space) 23))))
+ (whitespace . (or blank #\newline))
+ (space . whitespace)
+ (white . whitespace)
+ (printing or graphic whitespace)
+ (print . printing)
+ ;; XXXX we assume a (possibly shifted) ASCII-based ordering
+ (control . (/ ,(integer->char (- (char->integer #\space) 32))
+ ,(integer->char (- (char->integer #\space) 1))))
+ (cntrl . control)
+ (hex-digit . (or numeric (/ #\a #\f #\A #\F)))
+ (xdigit . hex-digit)
+ (ascii . (/ ,(integer->char (- (char->integer #\space) 32))
+ ,(integer->char (+ (char->integer #\space) 95))))
+ (ascii-nonl . (/ ,(integer->char (- (char->integer #\space) 32))
+ ,(integer->char (- (char->integer #\newline) 1))
+ ,(integer->char (+ (char->integer #\newline) 1))
+ ,(integer->char (+ (char->integer #\space) 95))))
+ (newline . (or (seq ,(integer->char (+ (char->integer #\newline) 3))
+ #\newline)
+ (/ #\newline
+ ,(integer->char (+ (char->integer #\newline) 3)))))
+
+ ;; ... it's really annoying to support scheme48
+ (word . (seq bow (+ (or alphanumeric #\_)) eow))
+ (utf8-tail-char . (/ ,(integer->char (+ (char->integer #\space) #x60))
+ ,(integer->char (+ (char->integer #\space) #xA1))))
+ (utf8-2-char . (seq (/ ,(integer->char (+ (char->integer #\space) #xA2))
+ ,(integer->char (+ (char->integer #\space) #xBF)))
+ utf8-tail-char))
+ (utf8-3-char . (seq (/ ,(integer->char (+ (char->integer #\space) #xC0))
+ ,(integer->char (+ (char->integer #\space) #xCF)))
+ utf8-tail-char
+ utf8-tail-char))
+ (utf8-4-char . (seq (/ ,(integer->char (+ (char->integer #\space) #xD0))
+ ,(integer->char (+ (char->integer #\space) #xD7)))
+ utf8-tail-char
+ utf8-tail-char
+ utf8-tail-char))
+ (utf8-any . (or ascii utf8-2-char utf8-3-char utf8-4-char))
+ (utf8-nonl . (or ascii-nonl utf8-2-char utf8-3-char utf8-4-char))
+ ))
+
+;; Compile and return the list of NFA states. The start state will be
+;; at the head of the list, and all remaining states will be in
+;; descending numeric order, with state 0 being the unique accepting
+;; state.
+(define (sre->nfa sre . o)
+ ;; we loop over an implicit sequence list
+ (let lp ((ls (list sre))
+ (n 1)
+ (flags (if (pair? o) (car o) ~none))
+ (next (list (list 0))))
+ (define (new-state-number state)
+ (max n (+ 1 (caar state))))
+ (define (extend-state next . trans)
+ (and next
+ (cons (cons (new-state-number next)
+ (map (lambda (x) (cons x (caar next))) trans))
+ next)))
+ (if (null? ls)
+ next
+ (cond
+ ((string? (car ls))
+ ;; process literal strings a char at a time
+ (lp (append (string->list (car ls)) (cdr ls)) n flags next))
+ ((eq? 'epsilon (car ls))
+ ;; chars and epsilons go directly into the transition table
+ (extend-state (lp (cdr ls) n flags next) (car ls)))
+ ((char? (car ls))
+ (let ((alt (char-altcase (car ls))))
+ (if (and (flag-set? flags ~case-insensitive?)
+ (not (eqv? (car ls) alt)))
+ (extend-state (lp (cdr ls) n flags next) (car ls) alt)
+ (extend-state (lp (cdr ls) n flags next) (car ls)))))
+ ((symbol? (car ls))
+ (let ((cell (assq (car ls) sre-named-definitions)))
+ (and cell (lp (cons (cdr cell) (cdr ls)) n flags next))))
+ ((pair? (car ls))
+ (cond
+ ((string? (caar ls))
+ ;; enumerated character set
+ (lp (cons (sre-alternate (string->list (caar ls))) (cdr ls))
+ n
+ flags
+ next))
+ (else
+ (case (caar ls)
+ ((seq :)
+ ;; for an explicit sequence, just append to the list
+ (lp (append (cdar ls) (cdr ls)) n flags next))
+ ((w/case w/nocase w/utf8 w/noutf8)
+ (let* ((next (lp (cdr ls) n flags next))
+ (flags ((if (memq (caar ls) '(w/case w/utf8))
+ flag-clear
+ flag-join)
+ flags
+ (if (memq (caar ls) '(w/case w/nocase))
+ ~case-insensitive?
+ ~utf8?))))
+ (and next (lp (cdar ls) (new-state-number next) flags next))))
+ ((/ - & ~)
+ (let ((ranges (sre->cset (car ls)
+ (flag-set? flags ~case-insensitive?))))
+ (case (length ranges)
+ ((1)
+ (extend-state (lp (cdr ls) n flags next) (car ranges)))
+ (else
+ (let ((next (lp (cdr ls) n flags next)))
+ (and
+ next
+ (lp (list (sre-alternate
+ (map (lambda (x) (if (pair? x)
+ (list '/ (car x) (cdr x))
+ x))
+ ranges)))
+ (new-state-number next)
+ (flag-clear flags ~case-insensitive?)
+ next)))))))
+ ((or)
+ (let* ((next (lp (cdr ls) n flags next))
+ (b (and next
+ (lp (list (sre-alternate (cddar ls)))
+ (new-state-number next)
+ flags
+ next)))
+ (a (and b (lp (list (cadar ls))
+ (new-state-number b)
+ flags
+ next))))
+ ;; compile both branches and insert epsilon
+ ;; transitions to either
+ (and a
+ `((,(new-state-number a)
+ (epsilon . ,(caar a))
+ (epsilon . ,(caar b)))
+ ,@(take-up-to a next)
+ ,@b))))
+ ((?)
+ (let ((next (lp (cdr ls) n flags next)))
+ ;; insert an epsilon transition directly to next
+ (and
+ next
+ (let ((a (lp (cdar ls) (new-state-number next) flags next)))
+ (cond
+ (a
+ (set-cdr! (car a) `((epsilon . ,(caar next)) ,@(cdar a)))
+ a)
+ (else
+ #f))))))
+ ((+ *)
+ (let ((next (lp (cdr ls) n flags next)))
+ (and
+ next
+ (let* ((new (lp '(epsilon)
+ (new-state-number next)
+ flags
+ next))
+ (a (lp (cdar ls) (new-state-number new) flags new)))
+ (and
+ a
+ (begin
+ ;; for *, insert an epsilon transition as in ? above
+ (if (eq? '* (caar ls))
+ (set-cdr! (car a)
+ `((epsilon . ,(caar new)) ,@(cdar a))))
+ ;; for both, insert a loop back to self
+ (set-cdr! (car new)
+ `((epsilon . ,(caar a)) ,@(cdar new)))
+ a))))))
+ ((submatch submatch-named)
+ ;; ignore submatches altogether
+ (lp (cons (sre-sequence (cdar ls)) (cdr ls)) n flags next))
+ (else
+ #f)))))
+ (else
+ #f)))))
+
+;; We don't really want to use this, we use the closure compilation
+;; below instead, but this is included for reference and testing the
+;; sre->nfa conversion.
+
+;; (define (nfa-match nfa str)
+;; (let lp ((ls (string->list str)) (state (car nfa)) (epsilons '()))
+;; (if (null? ls)
+;; (zero? (car state))
+;; (any (lambda (m)
+;; (if (eq? 'epsilon (car m))
+;; (and (not (memv (cdr m) epsilons))
+;; (lp ls (assv (cdr m) nfa) (cons (cdr m) epsilons)))
+;; (and (or (eqv? (car m) (car ls))
+;; (and (pair? (car m))
+;; (char<=? (caar m) (car ls))
+;; (char<=? (car ls) (cdar m))))
+;; (lp (cdr ls) (assv (cdr m) nfa) '()))))
+;; (cdr state)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; NFA->DFA compilation
+;;
+;; During processing, the DFA is a list of the form:
+;;
+;; ((NFA-states ...) accepting-state? transitions ...)
+;;
+;; where the transitions are as in the NFA, except there are no
+;; epsilons, duplicate characters or overlapping char-set ranges, and
+;; the states moved to are closures (sets of NFA states). Multiple
+;; DFA states may be accepting states.
+
+(define (nfa->dfa nfa . o)
+ (let ((max-states (and (pair? o) (car o))))
+ (let lp ((ls (list (nfa-closure nfa (list (caar nfa)))))
+ (i 0)
+ (res '()))
+ (cond
+ ((null? ls)
+ (dfa-renumber (reverse res)))
+ ((assoc (car ls) res)
+ (lp (cdr ls) i res))
+ (else
+ (let* ((states (car ls))
+ (trans (nfa-state-transitions nfa states))
+ (accept? (and (memv 0 states) #t)))
+ (and (or (not max-states) (< (+ i 1) max-states))
+ (lp (append (map cdr trans) (cdr ls))
+ (+ i 1)
+ `((,states ,accept? ,@trans) ,@res)))))))))
+
+;; When the conversion is complete we renumber the DFA sets-of-states
+;; in order and convert the result to a vector for fast lookup.
+(define (dfa-renumber dfa)
+ (let ((states (map cons (map car dfa) (zero-to (length dfa)))))
+ (define (renumber state)
+ (cdr (assoc state states)))
+ (list->vector
+ (map
+ (lambda (node)
+ (cons (cadr node)
+ (map (lambda (x) (cons (car x) (renumber (cdr x))))
+ (cddr node))))
+ dfa))))
+
+;; Extract all distinct characters or ranges and the potential states
+;; they can transition to from a given set of states. Any ranges that
+;; would overlap with distinct characters are split accordingly.
+(define (nfa-state-transitions nfa states)
+ (let lp ((trans '()) ;; list of (char . state) or ((char . char) . state)
+ (ls states) ;; list of integers (remaining state numbers)
+ (res '())) ;; (char state ...) or ((char . char) state ...)
+ (cond
+ ((null? trans)
+ (if (null? ls)
+ (map (lambda (x) (cons (car x) (nfa-closure nfa (cdr x))))
+ res)
+ (let ((node (assv (car ls) nfa)))
+ (lp (if node (cdr node) '()) (cdr ls) res))))
+ ((eq? 'epsilon (caar trans))
+ (lp (cdr trans) ls res))
+ (else
+ (lp (cdr trans) ls (nfa-join-transitions! res (car trans)))))))
+
+(define (nfa-join-transitions! existing new)
+ (define (join ls elt state)
+ (if (not elt)
+ ls
+ (nfa-join-transitions! ls (cons elt state))))
+ (cond
+ ((char? (car new))
+ (let ((ch (car new)))
+ (let lp ((ls existing) (res '()))
+ (cond
+ ((null? ls)
+ ;; done, just cons this on to the original list
+ (cons (list ch (cdr new)) existing))
+ ((eqv? ch (caar ls))
+ ;; add a new state to an existing char
+ (set-cdr! (car ls) (insert-sorted (cdr new) (cdar ls)))
+ existing)
+ ((and (pair? (caar ls))
+ (char<=? (caaar ls) ch)
+ (char<=? ch (cdaar ls)))
+ ;; split a range
+ (apply
+ (lambda (left right)
+ (cons (cons ch (insert-sorted (cdr new) (cdar ls)))
+ (append (if left (list (cons left (cdar ls))) '())
+ (if right (list (cons right (cdar ls))) '())
+ res
+ (cdr ls))))
+ (split-char-range (caar ls) (car new))))
+ (else
+ ;; keep looking
+ (lp (cdr ls) (cons (car ls) res)))))))
+ (else
+ (let ((lo (caar new))
+ (hi (cdar new)))
+ (let lp ((ls existing) (res '()))
+ (cond
+ ((null? ls)
+ (cons (list (car new) (cdr new)) existing))
+ ((and (char? (caar ls)) (char<=? lo (caar ls)) (char<=? (caar ls) hi))
+ ;; range enclosing a character
+ (apply
+ (lambda (left right)
+ (set-cdr! (car ls) (insert-sorted (cdr new) (cdar ls)))
+ (join (join existing left (cdr new)) right (cdr new)))
+ (split-char-range (car new) (caar ls))))
+ ((and (pair? (caar ls))
+ (or (and (char<=? (caaar ls) hi) (char<=? lo (cdaar ls)))
+ (and (char<=? hi (caaar ls)) (char<=? (cdaar ls) lo))))
+ ;; overlapping ranges
+ (apply
+ (lambda (left1 left2 same right1 right2)
+ (let ((old-states (cdar ls)))
+ (set-car! (car ls) same)
+ (set-cdr! (car ls) (insert-sorted (cdr new) old-states))
+ (let* ((res (if right1
+ (cons (cons right1 old-states) existing)
+ existing))
+ (res (if right2 (cons (cons right2 old-states) res) res)))
+ (join (join res left1 (cdr new)) left2 (cdr new)))))
+ (intersect-char-ranges (car new) (caar ls))))
+ (else
+ (lp (cdr ls) (cons (car ls) res)))))))))
+
+(define (char-range c1 c2)
+ (if (eqv? c1 c2) c1 (cons c1 c2)))
+
+;; assumes ch is included in the range
+(define (split-char-range range ch)
+ (list
+ (and (not (eqv? ch (car range)))
+ (char-range (car range) (integer->char (- (char->integer ch) 1))))
+ (and (not (eqv? ch (cdr range)))
+ (char-range (integer->char (+ (char->integer ch) 1)) (cdr range)))))
+
+;; returns (possibly #f) char ranges:
+;; a-only-1 a-only-2 a-and-b b-only-1 b-only-2
+(define (intersect-char-ranges a b)
+ (if (char>? (car a) (car b))
+ (reverse (intersect-char-ranges b a))
+ (let ((a-lo (car a))
+ (a-hi (cdr a))
+ (b-lo (car b))
+ (b-hi (cdr b)))
+ (list
+ (and (char<? a-lo b-lo)
+ (char-range a-lo (integer->char (- (char->integer b-lo) 1))))
+ (and (char>? a-hi b-hi)
+ (char-range (integer->char (+ (char->integer b-hi) 1)) a-hi))
+ (char-range b-lo (if (char<? b-hi a-hi) b-hi a-hi))
+ #f
+ (and (char>? b-hi a-hi)
+ (char-range (integer->char (+ (char->integer a-hi) 1)) b-hi))))))
+
+;; The `closure' of a list of NFA states - all states that can be
+;; reached from any of them using any number of epsilon transitions.
+(define (nfa-closure nfa states)
+ (let lp ((ls states)
+ (res '()))
+ (cond
+ ((null? ls)
+ res)
+ ((memv (car ls) res)
+ (lp (cdr ls) res))
+ (else
+ (lp (append (map cdr
+ (filter (lambda (trans) (eq? 'epsilon (car trans)))
+ (cdr (assv (car ls) nfa))))
+ (cdr ls))
+ (insert-sorted (car ls) res))))))
+
+;; insert an integer uniquely into a sorted list
+(define (insert-sorted n ls)
+ (cond
+ ((null? ls)
+ (cons n '()))
+ ((<= n (car ls))
+ (if (= n (car ls))
+ ls
+ (cons n ls)))
+ (else
+ (cons (car ls) (insert-sorted n (cdr ls))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; DFAs don't give us match information, so once we match and
+;; determine the start and end, we need to recursively break the
+;; problem into smaller DFAs to get each submatch.
+;;
+;; See http://compilers.iecc.com/comparch/article/07-10-026
+
+(define (sre-match-extractor sre)
+ (let lp ((sre sre) (n 1) (submatch-deps? #f))
+ (cond
+ ((not (sre-has-submatchs? sre))
+ (if (not submatch-deps?)
+ (lambda (str i j matches) j)
+ (let ((dfa (nfa->dfa (sre->nfa sre))))
+ (lambda (str i j matches)
+ (dfa-match/longest dfa str i j)))))
+ ((pair? sre)
+ (case (car sre)
+ ((: seq)
+ (let* ((right (sre-sequence (cddr sre)))
+ (match-left (lp (cadr sre) n #t))
+ (match-right
+ (lp right (+ n (sre-count-submatches (cadr sre))) #t)))
+ (lambda (str i j matches)
+ (let lp ((k j) (best #f))
+ (if (< k i)
+ best
+ (let* ((middle (match-left str i k matches))
+ (end (and middle
+ (eqv? middle k)
+ (match-right str middle j matches))))
+ (if (eqv? end j)
+ end
+ (lp (- k 1)
+ (if (or (not best) (and end (> end best)))
+ end
+ best)))))))))
+ ((or)
+ (let* ((rest (sre-alternate (cddr sre)))
+ (match-first
+ (lp (cadr sre) n #t))
+ (match-rest
+ (lp rest
+ (+ n (sre-count-submatches (cadr sre)))
+ submatch-deps?)))
+ (lambda (str i j matches)
+ (let ((k (match-first str i j matches)))
+ (if (eqv? k j)
+ k
+ (match-rest str i j matches))))))
+ ((* +)
+ (letrec ((match-once
+ (lp (sre-sequence (cdr sre)) n #t))
+ (match-all
+ (lambda (str i j matches)
+ (let ((k (match-once str i j matches)))
+ (if (and k (< i k))
+ (match-all str k j matches)
+ i)))))
+ (if (eq? '* (car sre))
+ match-all
+ (lambda (str i j matches)
+ (let ((k (match-once str i j matches)))
+ (and k
+ (match-all str k j matches)))))))
+ ((?)
+ (let ((match-once (lp (sre-sequence (cdr sre)) n #t)))
+ (lambda (str i j matches)
+ (let ((k (match-once str i j matches)))
+ (or k i)))))
+ ((submatch)
+ (let ((match-one
+ (lp (sre-sequence (cdr sre)) (+ n 1) #t)))
+ (lambda (str i j matches)
+ (let ((res (match-one str i j matches)))
+ (cond
+ ((number? res)
+ (irregex-match-start-index-set! matches n i)
+ (irregex-match-end-index-set! matches n res)))
+ res))))
+ (else
+ (error "unknown regexp operator" (car sre)))))
+ (else
+ (error "unknown regexp" sre)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; closure compilation - we use this for non-regular expressions
+;; instead of an interpreted NFA matcher
+
+(define (sre->procedure sre . o)
+ (define names
+ (if (and (pair? o) (pair? (cdr o))) (cadr o) (sre-names sre 1 '())))
+ (let lp ((sre sre)
+ (n 1)
+ (flags (if (pair? o) (car o) ~none))
+ (next (lambda (str i matches fail) i)))
+ (define (rec sre) (lp sre n flags next))
+ (cond
+ ((pair? sre)
+ (if (string? (car sre))
+ (sre-cset->procedure
+ (sre->cset (car sre) (flag-set? flags ~case-insensitive?))
+ next)
+ (case (car sre)
+ ((~ - & /)
+ (sre-cset->procedure
+ (sre->cset sre (flag-set? flags ~case-insensitive?))
+ next))
+ ((or)
+ (case (length (cdr sre))
+ ((0) (lambda (str i matches fail) (fail)))
+ ((1) (rec (cadr sre)))
+ (else
+ (let* ((first (rec (cadr sre)))
+ (rest (lp (sre-alternate (cddr sre))
+ (+ n (sre-count-submatches (cadr sre)))
+ flags
+ next)))
+ (lambda (str i matches fail)
+ (first str i matches (lambda () (rest str i matches fail))))))))
+ ((w/case)
+ (lp (sre-sequence (cdr sre))
+ n
+ (flag-clear flags ~case-insensitive?)
+ next))
+ ((w/nocase)
+ (lp (sre-sequence (cdr sre))
+ n
+ (flag-join flags ~case-insensitive?)
+ next))
+ ((w/utf8)
+ (lp (sre-sequence (cdr sre)) n (flag-join flags ~utf8?) next))
+ ((w/noutf8)
+ (lp (sre-sequence (cdr sre)) n (flag-clear flags ~utf8?) next))
+ ((seq :)
+ (case (length (cdr sre))
+ ((0) next)
+ ((1) (rec (cadr sre)))
+ (else
+ (let ((rest (lp (sre-sequence (cddr sre))
+ (+ n (sre-count-submatches (cadr sre)))
+ flags
+ next)))
+ (lp (cadr sre) n flags rest)))))
+ ((?)
+ (let ((body (rec (sre-sequence (cdr sre)))))
+ (lambda (str i matches fail)
+ (body str i matches (lambda () (next str i matches fail))))))
+ ((??)
+ (let ((body (rec (sre-sequence (cdr sre)))))
+ (lambda (str i matches fail)
+ (next str i matches (lambda () (body str i matches fail))))))
+ ((*)
+ (cond
+ ((sre-empty? (sre-sequence (cdr sre)))
+ (error "invalid sre: empty *" sre))
+ (else
+ (letrec ((body
+ (lp (sre-sequence (cdr sre))
+ n
+ flags
+ (lambda (str i matches fail)
+ (body str
+ i
+ matches
+ (lambda () (next str i matches fail)))))))
+ (lambda (str i matches fail)
+ (body str i matches (lambda () (next str i matches fail))))))))
+ ((*?)
+ (cond
+ ((sre-empty? (sre-sequence (cdr sre)))
+ (error "invalid sre: empty *?" sre))
+ (else
+ (letrec ((body
+ (lp (sre-sequence (cdr sre))
+ n
+ flags
+ (lambda (str i matches fail)
+ (next str
+ i
+ matches
+ (lambda () (body str i matches fail)))))))
+ (lambda (str i matches fail)
+ (next str i matches (lambda () (body str i matches fail))))))))
+ ((+)
+ (lp (sre-sequence (cdr sre))
+ n
+ flags
+ (rec (list '* (sre-sequence (cdr sre))))))
+ ((=)
+ (rec `(** ,(cadr sre) ,(cadr sre) ,@(cddr sre))))
+ ((>=)
+ (rec `(** ,(cadr sre) #f ,@(cddr sre))))
+ ((** **?)
+ (cond
+ ((or (and (number? (cadr sre))
+ (number? (caddr sre))
+ (> (cadr sre) (caddr sre)))
+ (and (not (cadr sre)) (caddr sre)))
+ (lambda (str i matches fail) (fail)))
+ (else
+ (let* ((from (cadr sre))
+ (to (caddr sre))
+ (? (if (eq? '** (car sre)) '? '??))
+ (* (if (eq? '** (car sre)) '* '*?))
+ (sre (sre-sequence (cdddr sre)))
+ (x-sre (sre-strip-submatches sre))
+ (next (if to
+ (if (= from to)
+ next
+ (fold (lambda (x next)
+ (lp `(,? ,sre) n flags next))
+ next
+ (zero-to (- to from))))
+ (rec `(,* ,sre)))))
+ (if (zero? from)
+ next
+ (lp `(seq ,@(map (lambda (x) x-sre) (zero-to (- from 1)))
+ ,sre)
+ n
+ flags
+ next))))))
+ ((word)
+ (rec `(seq bow ,@(cdr sre) eow)))
+ ((word+)
+ (rec `(seq bow (+ (& (or alphanumeric "_")
+ (or ,@(cdr sre)))) eow)))
+ ((posix-string)
+ (rec (string->sre (cadr sre))))
+ ((look-ahead)
+ (let ((check
+ (lp (sre-sequence (cdr sre))
+ n
+ flags
+ (lambda (str i matches fail) i))))
+ (lambda (str i matches fail)
+ (if (check str i matches (lambda () #f))
+ (next str i matches fail)
+ (fail)))))
+ ((neg-look-ahead)
+ (let ((check
+ (lp (sre-sequence (cdr sre))
+ n
+ flags
+ (lambda (str i matches fail) i))))
+ (lambda (str i matches fail)
+ (if (check str i matches (lambda () #f))
+ (fail)
+ (next str i matches fail)))))
+ ((look-behind)
+ (let ((check
+ (lp (sre-sequence (cons '(* any) (cdr sre)))
+ n
+ flags
+ (lambda (str i matches fail) i))))
+ (lambda (str i matches fail)
+ (if (eqv? i (check (substring str 0 i) 0 matches (lambda () #f)))
+ (next str i matches fail)
+ (fail)))))
+ ((neg-look-behind)
+ (let ((check
+ (lp (sre-sequence (cons '(* any) (cdr sre)))
+ n
+ flags
+ (lambda (str i matches fail) i))))
+ (lambda (str i matches fail)
+ (if (eqv? i (check (substring str 0 i) 0 matches (lambda () #f)))
+ (fail)
+ (next str i matches fail)))))
+ ((atomic)
+ (let ((once
+ (lp (sre-sequence (cdr sre))
+ n
+ flags
+ (lambda (str i matches fail) i))))
+ (lambda (str i matches fail)
+ (let ((j (once str i matches (lambda () #f))))
+ (if j
+ (next str j matches fail)
+ (fail))))))
+ ((if)
+ (let* ((test-submatches (sre-count-submatches (cadr sre)))
+ (pass (lp (caddr sre) flags (+ n test-submatches) next))
+ (fail (if (pair? (cdddr sre))
+ (lp (cadddr sre)
+ (+ n test-submatches
+ (sre-count-submatches (caddr sre)))
+ flags
+ next)
+ (lambda (str i matches fail) (fail)))))
+ (cond
+ ((or (number? (cadr sre)) (symbol? (cadr sre)))
+ (let ((index
+ (if (symbol? (cadr sre))
+ (cond
+ ((assq (cadr sre) names) => cdr)
+ (else
+ (error "unknown named backref in SRE IF" sre)))
+ (cadr sre))))
+ (lambda (str i matches fail2)
+ (if (irregex-match-end-index matches index)
+ (pass str i matches fail2)
+ (fail str i matches fail2)))))
+ (else
+ (let ((test (lp (cadr sre) n flags pass)))
+ (lambda (str i matches fail2)
+ (test str i matches (lambda () (fail str i matches fail2)))
+ ))))))
+ ((backref backref-ci)
+ (let ((n (cond ((number? (cadr sre)) (cadr sre))
+ ((assq (cadr sre) names) => cdr)
+ (else (error "unknown backreference" (cadr sre)))))
+ (compare (if (or (eq? (car sre) 'backref-ci)
+ (flag-set? flags ~case-insensitive?))
+ string-ci=?
+ string=?)))
+ (lambda (str i matches fail)
+ (let ((s (irregex-match-substring matches n)))
+ (if (not s)
+ (fail)
+ (let ((j (+ i (string-length s))))
+ (if (and (<= j (string-length str))
+ (compare s (substring str i j)))
+ (next str j matches fail)
+ (fail))))))))
+ ((dsm)
+ (lp (sre-sequence (cdddr sre)) (+ n (cadr sre)) flags next))
+ ((submatch)
+ (let ((body
+ (lp (sre-sequence (cdr sre))
+ (+ n 1)
+ flags
+ (lambda (str i matches fail)
+ (let ((old (irregex-match-end-index matches n)))
+ (irregex-match-end-index-set! matches n i)
+ (next str i matches
+ (lambda ()
+ (irregex-match-end-index-set! matches n old)
+ (fail))))))))
+ (lambda (str i matches fail)
+ (let ((old (irregex-match-start-index matches n)))
+ (irregex-match-start-index-set! matches n i)
+ (body str i matches
+ (lambda ()
+ (irregex-match-start-index-set! matches n old)
+ (fail)))))))
+ ((submatch-named)
+ (rec `(submatch ,@(cddr sre))))
+ (else
+ (error "unknown regexp operator" sre)))))
+ ((symbol? sre)
+ (case sre
+ ((any)
+ (lambda (str i matches fail)
+ (if (< i (string-length str))
+ (next str (+ i 1) matches fail)
+ (fail))))
+ ((nonl)
+ (lambda (str i matches fail)
+ (if (and (< i (string-length str))
+ (not (eqv? #\newline (string-ref str i))))
+ (next str (+ i 1) matches fail)
+ (fail))))
+ ((bos)
+ (lambda (str i matches fail)
+ (if (zero? i) (next str i matches fail) (fail))))
+ ((bol)
+ (lambda (str i matches fail)
+ (if (or (zero? i) (eqv? #\newline (string-ref str (- i 1))))
+ (next str i matches fail)
+ (fail))))
+ ((bow)
+ (lambda (str i matches fail)
+ (if (and (or (zero? i)
+ (not (char-alphanumeric? (string-ref str (- i 1)))))
+ (< i (string-length str))
+ (char-alphanumeric? (string-ref str i)))
+ (next str i matches fail)
+ (fail))))
+ ((eos)
+ (lambda (str i matches fail)
+ (if (>= i (string-length str)) (next str i matches fail) (fail))))
+ ((eol)
+ (lambda (str i matches fail)
+ (if (or (>= i (string-length str))
+ (eqv? #\newline (string-ref str i)))
+ (next str i matches fail)
+ (fail))))
+ ((eow)
+ (lambda (str i matches fail)
+ (if (and (or (>= i (string-length str))
+ (not (char-alphanumeric? (string-ref str i))))
+ (> i 0)
+ (char-alphanumeric? (string-ref str (- i 1))))
+ (next str i matches fail)
+ (fail))))
+ ((nwb) ;; non-word-boundary
+ (lambda (str i matches fail)
+ (if (and (not (zero? i))
+ (< i (string-length str))
+ (if (char-alphanumeric? (string-ref str (- i 1)))
+ (char-alphanumeric? (string-ref str i))
+ (not (char-alphanumeric? (string-ref str i)))))
+ (next str i matches fail)
+ (fail))))
+ ((epsilon)
+ next)
+ (else
+ (let ((cell (assq sre sre-named-definitions)))
+ (if cell
+ (rec (cdr cell))
+ (error "unknown regexp" sre))))))
+ ((char? sre)
+ (if (flag-set? flags ~case-insensitive?)
+ (lambda (str i matches fail)
+ (if (and (< i (string-length str))
+ (char-ci=? sre (string-ref str i)))
+ (next str (+ i 1) matches fail)
+ (fail)))
+ (lambda (str i matches fail)
+ (if (and (< i (string-length str))
+ (eqv? sre (string-ref str i)))
+ (next str (+ i 1) matches fail)
+ (fail)))))
+ ((string? sre)
+ (rec (sre-sequence (string->list sre))))
+ (else
+ (error "unknown regexp" sre)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Simple character sets as lists of ranges, as used in the NFA/DFA
+;; compilation. This is not especially efficient, but is portable and
+;; scalable for any range of character sets.
+
+(define (sre-cset->procedure cset next)
+ (lambda (str i matches fail)
+ (if (and (< i (string-length str))
+ (cset-contains? cset (string-ref str i)))
+ (next str (+ i 1) matches fail)
+ (fail))))
+
+(define (plist->alist ls)
+ (let lp ((ls ls) (res '()))
+ (if (null? ls)
+ (reverse res)
+ (lp (cddr ls) (cons (cons (car ls) (cadr ls)) res)))))
+
+(define (alist->plist ls)
+ (let lp ((ls ls) (res '()))
+ (if (null? ls)
+ (reverse res)
+ (lp (cdr ls) (cons (cdar ls) (cons (caar ls) res))))))
+
+(define (sre->cset sre . o)
+ (let lp ((sre sre) (ci? (and (pair? o) (car o))))
+ (define (rec sre) (lp sre ci?))
+ (cond
+ ((pair? sre)
+ (if (string? (car sre))
+ (if ci?
+ (cset-case-insensitive (string->list (car sre)))
+ (string->list (car sre)))
+ (case (car sre)
+ ((~)
+ (cset-complement
+ (fold cset-union (rec (cadr sre)) (map rec (cddr sre)))))
+ ((&)
+ (fold cset-intersection (rec (cadr sre)) (map rec (cddr sre))))
+ ((-)
+ (fold (lambda (x res) (cset-difference res x))
+ (rec (cadr sre))
+ (map rec (cddr sre))))
+ ((/)
+ (let ((res (plist->alist (sre-flatten-ranges (cdr sre)))))
+ (if ci?
+ (cset-case-insensitive res)
+ res)))
+ ((or)
+ (fold cset-union (rec (cadr sre)) (map rec (cddr sre))))
+ ((w/case)
+ (lp (sre-alternate (cdr sre)) #f))
+ ((w/nocase)
+ (lp (sre-alternate (cdr sre)) #t))
+ (else
+ (error "not a valid sre char-set operator" sre)))))
+ ((char? sre) (rec (list (string sre))))
+ ((string? sre) (rec (list sre)))
+ (else
+ (let ((cell (assq sre sre-named-definitions)))
+ (if cell
+ (rec (cdr cell))
+ (error "not a valid sre char-set" sre)))))))
+
+;;;; another debugging utility
+;; (define (cset->sre cset)
+;; (let lp ((ls cset) (chars '()) (ranges '()))
+;; (cond
+;; ((null? ls)
+;; (sre-alternate
+;; (append
+;; (if (pair? chars) (list (list (list->string chars))) '())
+;; (if (pair? ranges) (list (cons '/ (alist->plist ranges))) '()))))
+;; ((char? (car ls)) (lp (cdr ls) (cons (car ls) chars) ranges))
+;; (else (lp (cdr ls) chars (cons (car ls) ranges))))))
+
+(define (cset-contains? cset ch)
+ (find (lambda (x)
+ (or (eqv? x ch)
+ (and (pair? x) (char<=? (car x) ch) (char<=? ch (cdr x)))))
+ cset))
+
+(define (cset-range x)
+ (if (char? x) (cons x x) x))
+
+(define (char-ranges-overlap? a b)
+ (if (pair? a)
+ (if (pair? b)
+ (or (and (char<=? (car a) (cdr b)) (char<=? (car b) (cdr a)))
+ (and (char<=? (cdr b) (car a)) (char<=? (cdr a) (car b))))
+ (and (char<=? (car a) b) (char<=? b (cdr a))))
+ (if (pair? b)
+ (char-ranges-overlap? b a)
+ (eqv? a b))))
+
+(define (char-ranges-union a b)
+ (cons (if (char<=? (car a) (car b)) (car a) (car b))
+ (if (char>=? (cdr a) (cdr b)) (cdr a) (cdr b))))
+
+(define (cset-union a b)
+ (cond ((null? b) a)
+ ((find-tail (lambda (x) (char-ranges-overlap? x (car b))) a)
+ => (lambda (ls)
+ (cset-union
+ (cset-union (append (take-up-to a ls) (cdr ls))
+ (list (char-ranges-union (cset-range (car ls))
+ (cset-range (car b)))))
+ (cdr b))))
+ (else (cset-union (cons (car b) a) (cdr b)))))
+
+(define (cset-difference a b)
+ (cond ((null? b) a)
+ ((not (car b)) (cset-difference a (cdr b)))
+ ((find-tail (lambda (x) (char-ranges-overlap? x (car b))) a)
+ => (lambda (ls)
+ (apply
+ (lambda (left1 left2 same right1 right2)
+ (let* ((a (append (take-up-to a ls) (cdr ls)))
+ (a (if left1 (cons left1 a) a))
+ (a (if left2 (cons left2 a) a))
+ (b (if right1 (cset-union b (list right1)) b))
+ (b (if right2 (cset-union b (list right2)) b)))
+ (cset-difference a b)))
+ (intersect-char-ranges (cset-range (car ls))
+ (cset-range (car b))))))
+ (else (cset-difference a (cdr b)))))
+
+(define (cset-intersection a b)
+ (let intersect ((a a) (b b) (res '()))
+ (cond ((null? b) res)
+ ((find-tail (lambda (x) (char-ranges-overlap? x (car b))) a)
+ => (lambda (ls)
+ (apply
+ (lambda (left1 left2 same right1 right2)
+ (let* ((a (append (take-up-to a ls) (cdr ls)))
+ (a (if left1 (cons left1 a) a))
+ (a (if left2 (cons left2 a) a))
+ (b (if right1 (cset-union b (list right1)) b))
+ (b (if right2 (cset-union b (list right2)) b)))
+ (intersect a b (cset-union res (list same)))))
+ (intersect-char-ranges (cset-range (car ls))
+ (cset-range (car b))))))
+ (else (intersect a (cdr b) res)))))
+
+(define (cset-complement a)
+ (cset-difference (sre->cset *all-chars*) a))
+
+(define (cset-case-insensitive a)
+ (let lp ((ls a) (res '()))
+ (cond ((null? ls) (reverse res))
+ ((and (char? (car ls)) (char-alphabetic? (car ls)))
+ (let ((c2 (char-altcase (car ls)))
+ (res (cons (car ls) res)))
+ (lp (cdr ls) (if (cset-contains? res c2) res (cons c2 res)))))
+ ((and (pair? (car ls))
+ (char-alphabetic? (caar ls))
+ (char-alphabetic? (cdar ls)))
+ (lp (cdr ls)
+ (cset-union (cset-union res (list (car ls)))
+ (list (cons (char-altcase (caar ls))
+ (char-altcase (cdar ls)))))))
+ (else (lp (cdr ls) (cset-union res (list (car ls))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; match and replace utilities
+
+(define (irregex-fold irx kons knil str . o)
+ (let* ((irx (irregex irx))
+ (matches (irregex-new-matches irx))
+ (finish (if (pair? o) (car o) (lambda (i acc) acc)))
+ (start (if (and (pair? o) (pair? (cdr o))) (cadr o) 0))
+ (end (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
+ (caddr o)
+ (string-length str))))
+ (irregex-match-string-set! matches str)
+ (let lp ((i start) (acc knil))
+ (if (>= i end)
+ (finish i acc)
+ (let ((m (irregex-search/matches irx str i end matches)))
+ (if (not m)
+ (finish i acc)
+ (let* ((end (irregex-match-end m 0))
+ (acc (kons i m acc)))
+ (irregex-reset-matches! matches)
+ (lp end acc))))))))
+
+(define (irregex-replace irx str . o)
+ (let ((m (irregex-search (irregex irx) str)))
+ (and
+ m
+ (string-cat-reverse
+ (cons (substring str (irregex-match-end m 0) (string-length str))
+ (append (irregex-apply-match m o)
+ (list (substring str 0 (irregex-match-start m 0)))))))))
+
+(define (irregex-replace/all irx str . o)
+ (irregex-fold
+ irx
+ (lambda (i m acc)
+ (let ((m-start (irregex-match-start m 0)))
+ (append (irregex-apply-match m o)
+ (if (= i m-start)
+ acc
+ (cons (substring str i m-start) acc)))))
+ '()
+ str
+ (lambda (i acc)
+ (let ((end (string-length str)))
+ (string-cat-reverse (if (= i end)
+ acc
+ (cons (substring str i end) acc)))))))
+
+(define (irregex-apply-match m ls)
+ (let lp ((ls ls) (res '()))
+ (if (null? ls)
+ res
+ (cond
+ ((integer? (car ls))
+ (lp (cdr ls)
+ (cons (or (irregex-match-substring m (car ls)) "") res)))
+ ((procedure? (car ls))
+ (lp (cdr ls) (cons ((car ls) m) res)))
+ ((symbol? (car ls))
+ (case (car ls)
+ ((pre)
+ (lp (cdr ls)
+ (cons (substring (irregex-match-string m)
+ 0
+ (irregex-match-start m 0))
+ res)))
+ ((post)
+ (lp (cdr ls)
+ (cons (substring (irregex-match-string m)
+ (irregex-match-end m 0)
+ (string-length (irregex-match-string m)))
+ res)))
+ (else (error "unknown match replacement" (car ls)))))
+ (else
+ (lp (cdr ls) (cons (car ls) res)))))))
diff --git a/library.scm b/library.scm
new file mode 100644
index 00000000..c364a87c
--- /dev/null
+++ b/library.scm
@@ -0,0 +1,4814 @@
+;;;; library.scm - R5RS library for the CHICKEN compiler
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit library)
+ (disable-interrupts)
+ (disable-warning var redef)
+ (usual-integrations)
+ (hide ##sys#dynamic-unwind ##sys#find-symbol
+ ##sys#grow-vector ##sys#default-parameter-vector
+ print-length-limit current-print-length setter-tag read-marks
+ ##sys#print-exit
+ ##sys#format-here-doc-warning)
+ (not inline ##sys#user-read-hook ##sys#error-hook ##sys#signal-hook ##sys#schedule
+ ##sys#default-read-info-hook ##sys#infix-list-hook ##sys#sharp-number-hook
+ ##sys#user-print-hook ##sys#user-interrupt-hook ##sys#step-hook)
+ (foreign-declare #<<EOF
+#include <string.h>
+#include <ctype.h>
+#include <errno.h>
+#include <time.h>
+#include <float.h>
+
+#ifdef HAVE_SYSEXITS_H
+# include <sysexits.h>
+#endif
+
+#if !defined(_MSC_VER)
+# include <unistd.h>
+#endif
+
+#ifndef EX_SOFTWARE
+# define EX_SOFTWARE 70
+#endif
+
+#ifndef C_BUILD_TAG
+# define C_BUILD_TAG ""
+#endif
+
+#define C_close_file(p) (C_fclose((C_FILEPTR)(C_port_file(p))), C_SCHEME_UNDEFINED)
+#define C_f64peek(b, i) (C_temporary_flonum = ((double *)C_data_pointer(b))[ C_unfix(i) ], C_SCHEME_UNDEFINED)
+#define C_fetch_c_strlen(b, i) C_fix(strlen((C_char *)C_block_item(b, C_unfix(i))))
+#define C_peek_c_string(b, i, to, len) (C_memcpy(C_data_pointer(to), (C_char *)C_block_item(b, C_unfix(i)), C_unfix(len)), C_SCHEME_UNDEFINED)
+#define C_free_mptr(p, i) (C_free((void *)C_block_item(p, C_unfix(i))), C_SCHEME_UNDEFINED)
+#define C_free_sptr(p, i) (C_free((void *)(((C_char **)C_block_item(p, 0))[ C_unfix(i) ])), C_SCHEME_UNDEFINED)
+
+#define C_direct_continuation(dummy) t1
+
+#define C_get_current_seconds(dummy) (C_temporary_flonum = time(NULL), C_SCHEME_UNDEFINED)
+#define C_peek_c_string_at(ptr, i) ((C_char *)(((C_char **)ptr)[ i ]))
+
+static C_word fast_read_line_from_file(C_word str, C_word port, C_word size) {
+ int n = C_unfix(size);
+ int i;
+ int c;
+ char *buf = C_c_string(str);
+ C_FILEPTR fp = C_port_file(port);
+
+ if ((c = C_getc(fp)) == EOF)
+ return C_SCHEME_END_OF_FILE;
+
+ C_ungetc(c, fp);
+
+ for (i = 0; i < n; i++) {
+ c = C_getc(fp);
+ switch (c) {
+ case '\r': if ((c = C_getc(fp)) != '\n') C_ungetc(c, fp);
+ case EOF: clearerr(fp);
+ case '\n': return C_fix(i);
+ }
+ buf[i] = c;
+ }
+ return C_SCHEME_FALSE;
+}
+
+static C_word
+fast_read_string_from_file (C_word dest, C_word port, C_word len, C_word pos)
+{
+ int n = C_unfix (len);
+ char * buf = ((char *)C_data_pointer (dest) + C_unfix (pos));
+ C_FILEPTR fp = C_port_file (port);
+
+ size_t m = fread (buf, sizeof (char), n, fp);
+
+ if (m < n) {
+ if (feof (fp)) {
+ clearerr (fp);
+ if (0 == m)
+ return C_SCHEME_END_OF_FILE;
+ } else if (ferror (fp)) {
+ if (0 == m) {
+ return C_SCHEME_FALSE;
+ } else {
+ clearerr (fp);
+ }
+ }
+ }
+
+ return C_fix (m);
+}
+EOF
+) )
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ (no-bound-checks)
+ (no-procedure-checks-for-usual-bindings)
+ (bound-to-procedure
+ ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-port* ##sys#check-string ##sys#substring ##sys#check-port-mode
+ ##sys#for-each ##sys#map ##sys#setslot ##sys#allocate-vector ##sys#check-pair
+ ##sys#error-not-a-proper-list ##sys#error ##sys#warn ##sys#signal-hook
+ ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling ##sys#truncate ##sys#round
+ ##sys#check-number ##sys#cons-flonum ##sys#check-integer ##sys#check-special
+ ##sys#flonum-fraction ##sys#make-port ##sys#print
+ ##sys#check-structure ##sys#make-structure ##sys#procedure->string
+ ##sys#gcd ##sys#lcm ##sys#ensure-heap-reserve ##sys#check-list
+ ##sys#enable-interrupts ##sys#disable-interrupts ##sys#->feature-id
+ ##sys#fudge ##sys#user-read-hook ##sys#check-range ##sys#read
+ ##sys#string->symbol ##sys#symbol->string ##sys#dynamic-unwind ##sys#pathname-resolution
+ ##sys#platform-fixup-pathname ##sys#expand-home-path ##sys#string-append ##sys#symbol->qualified-string
+ ##sys#error-handler ##sys#signal ##sys#abort ##sys#port-data ##sys#set-port-data!
+ ##sys#reset-handler ##sys#exit-handler ##sys#dynamic-wind ##sys#port-line
+ ##sys#grow-vector ##sys#run-pending-finalizers ##sys#peek-char-0 ##sys#read-char-0
+ ##sys#read-char/port ##sys#write-char/port
+ ##sys#schedule ##sys#make-thread ##sys#print-to-string ##sys#scan-buffer-line
+ ##sys#update-thread-state-buffer ##sys#restore-thread-state-buffer ##sys#user-print-hook
+ ##sys#current-exception-handler ##sys#default-exception-handler ##sys#abandon-mutexes ##sys#make-mutex
+ ##sys#port-has-file-pointer? ##sys#infix-list-hook char-name ##sys#open-file-port make-parameter
+ ##sys#intern-symbol ##sys#make-string ##sys#number? software-type build-platform
+ open-output-string get-output-string print-call-chain ##sys#symbol-has-toplevel-binding? repl
+ argv condition-property-accessor ##sys#decorate-lambda ##sys#become! ##sys#lambda-decoration
+ getter-with-setter ##sys#lambda-info? ##sys#lambda-info ##sys#lambda-info->string open-input-string ##sys#gc
+ ##sys#memory-info ##sys#make-c-string ##sys#find-symbol-table display
+ newline string-append ##sys#with-print-length-limit write print vector-fill! ##sys#context-switch
+ ##sys#set-finalizer! open-output-string get-output-string read ##sys#make-pointer
+ ##sys#pointer->address number->string ##sys#flush-output ##sys#break-entry ##sys#step
+ ##sys#apply-values ##sys#get-call-chain ##sys#really-print-call-chain
+ string->keyword keyword? string->keyword get-environment-variable ##sys#number->string ##sys#copy-bytes
+ call-with-current-continuation ##sys#string->number ##sys#inexact->exact ##sys#exact->inexact
+ ##sys#reverse-list->string reverse ##sys#inexact? list? string ##sys#char->utf8-string
+ ##sys#unicode-surrogate? ##sys#surrogates->codepoint ##sys#write-char/port
+ ##sys#update-errno ##sys#file-info close-output-port close-input-port ##sys#peek-unsigned-integer
+ continuation-graft char-downcase string-copy remainder floor ##sys#exact? list->string
+ ##sys#append ##sys#list ##sys#cons ##sys#list->vector ##sys#list ##sys#apply ##sys#make-vector
+ ##sys#write-char ##sys#force-finalizers ##sys#cleanup-before-exit ##sys#write-char-0
+ ##sys#default-read-info-hook ##sys#read-error) ) ] )
+
+
+(include "version.scm")
+(include "banner.scm")
+
+
+(define-constant namespace-max-id-len 31)
+(define-constant char-name-table-size 37)
+(define-constant output-string-initial-size 256)
+(define-constant read-line-buffer-initial-size 1024)
+(define-constant default-parameter-vector-size 16)
+(define-constant maximal-string-length #x00ffffff)
+
+(define-foreign-variable +build-tag+ c-string "C_BUILD_TAG")
+
+
+;;; System routines:
+
+(define (exit . code) (apply (##sys#exit-handler) code))
+(define (reset) ((##sys#reset-handler)))
+
+(define (##sys#error . args)
+ (if (pair? args)
+ (apply ##sys#signal-hook #:error args)
+ (##sys#signal-hook #:error #f)))
+
+(define ##sys#warnings-enabled #t)
+
+(define (##sys#warn msg . args)
+ (when ##sys#warnings-enabled
+ (apply ##sys#signal-hook #:warning msg args) ) )
+
+(define (enable-warnings . bool)
+ (if (pair? bool)
+ (set! ##sys#warnings-enabled (car bool))
+ ##sys#warnings-enabled) )
+
+(define error ##sys#error)
+(define warning ##sys#warn)
+
+(define-foreign-variable main_argc int "C_main_argc")
+(define-foreign-variable main_argv c-pointer "C_main_argv")
+(define-foreign-variable strerror c-string "strerror(errno)")
+
+(define (set-gc-report! flag) (##core#inline "C_set_gc_report" flag))
+(define ##sys#gc (##core#primitive "C_gc"))
+(define (##sys#setslot x i y) (##core#inline "C_i_setslot" x i y))
+(define (##sys#setislot x i y) (##core#inline "C_i_set_i_slot" x i y))
+(define ##sys#allocate-vector (##core#primitive "C_allocate_vector"))
+(define argv (##core#primitive "C_get_argv"))
+(define (argc+argv) (##sys#values main_argc main_argv))
+(define ##sys#make-structure (##core#primitive "C_make_structure"))
+(define ##sys#ensure-heap-reserve (##core#primitive "C_ensure_heap_reserve"))
+(define (##sys#fudge fudge-factor) (##core#inline "C_fudge" fudge-factor))
+(define ##sys#call-host (##core#primitive "C_return_to_host"))
+(define return-to-host ##sys#call-host)
+(define ##sys#file-info (##core#primitive "C_file_info"))
+(define ##sys#symbol-table-info (##core#primitive "C_get_symbol_table_info"))
+(define ##sys#memory-info (##core#primitive "C_get_memory_info"))
+(define (current-milliseconds) (##sys#fudge 16))
+(define (current-gc-milliseconds) (##sys#fudge 31))
+(define cpu-time (##core#primitive "C_cpu_time"))
+(define ##sys#decode-seconds (##core#primitive "C_decode_seconds"))
+(define get-environment-variable (##core#primitive "C_get_environment_variable"))
+(define getenv get-environment-variable) ; DEPRECATED
+(define (##sys#start-timer) (##core#inline "C_start_timer"))
+(define ##sys#stop-timer (##core#primitive "C_stop_timer"))
+(define (##sys#immediate? x) (not (##core#inline "C_blockp" x)))
+(define (##sys#message str) (##core#inline "C_message" str))
+(define (##sys#byte x i) (##core#inline "C_subbyte" x i))
+(define (##sys#setbyte x i n) (##core#inline "C_setbyte" x i n))
+(define (##sys#void) (##core#undefined))
+(define void ##sys#void)
+(define ##sys#undefined-value (##core#undefined))
+(define (##sys#halt) (##core#inline "C_halt" #f))
+(define (##sys#flo2fix n) (##core#inline "C_quickflonumtruncate" n))
+(define ##sys#become! (##core#primitive "C_become"))
+(define (##sys#block-ref x i) (##core#inline "C_i_block_ref" x i))
+(define ##sys#apply-values (##core#primitive "C_apply_values"))
+(define ##sys#copy-closure (##core#primitive "C_copy_closure"))
+(define ##sys#apply-argument-limit (##sys#fudge 34))
+
+(define (##sys#block-set! x i y)
+ (cond-expand
+ [(not unsafe)
+ (when (or (not (##core#inline "C_blockp" x))
+ (and (##core#inline "C_specialp" x) (fx= i 0))
+ (##core#inline "C_byteblockp" x) )
+ (##sys#signal-hook '#:type-error '##sys#block-set! "slot not accessible" x) )
+ (##sys#check-range i 0 (##sys#size x) '##sys#block-set!) ]
+ [else] )
+ (##sys#setslot x i y) )
+
+(define (current-seconds)
+ (##core#inline "C_get_current_seconds" #f)
+ (##sys#cons-flonum) )
+
+(define (##sys#check-structure x y . loc)
+ (if (pair? loc)
+ (##core#inline "C_i_check_structure_2" x y (car loc))
+ (##core#inline "C_i_check_structure" x y) ) )
+
+(define (##sys#check-blob x . loc)
+ (if (pair? loc)
+ (##core#inline "C_i_check_bytevector_2" x (car loc))
+ (##core#inline "C_i_check_bytevector" x) ) )
+
+(define ##sys#check-byte-vector ##sys#check-blob)
+
+(define (##sys#check-pair x . loc)
+ (if (pair? loc)
+ (##core#inline "C_i_check_pair_2" x (car loc))
+ (##core#inline "C_i_check_pair" x) ) )
+
+(define (##sys#check-list x . loc)
+ (if (pair? loc)
+ (##core#inline "C_i_check_list_2" x (car loc))
+ (##core#inline "C_i_check_list" x) ) )
+
+(define (##sys#check-string x . loc)
+ (if (pair? loc)
+ (##core#inline "C_i_check_string_2" x (car loc))
+ (##core#inline "C_i_check_string" x) ) )
+
+(define (##sys#check-number x . loc)
+ (if (pair? loc)
+ (##core#inline "C_i_check_number_2" x (car loc))
+ (##core#inline "C_i_check_number" x) ) )
+
+(define (##sys#check-exact x . loc)
+ (if (pair? loc)
+ (##core#inline "C_i_check_exact_2" x (car loc))
+ (##core#inline "C_i_check_exact" x) ) )
+
+(define (##sys#check-inexact x . loc)
+ (if (pair? loc)
+ (##core#inline "C_i_check_inexact_2" x (car loc))
+ (##core#inline "C_i_check_inexact" x) ) )
+
+(define (##sys#check-symbol x . loc)
+ (if (pair? loc)
+ (##core#inline "C_i_check_symbol_2" x (car loc))
+ (##core#inline "C_i_check_symbol" x) ) )
+
+(define (##sys#check-vector x . loc)
+ (if (pair? loc)
+ (##core#inline "C_i_check_vector_2" x (car loc))
+ (##core#inline "C_i_check_vector" x) ) )
+
+(define (##sys#check-char x . loc)
+ (if (pair? loc)
+ (##core#inline "C_i_check_char_2" x (car loc))
+ (##core#inline "C_i_check_char" x) ) )
+
+(define (##sys#check-integer x . loc)
+ (unless (##core#inline "C_i_integerp" x)
+ (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR" int)
+ (and (pair? loc) (car loc)) x) ) )
+
+(define (##sys#check-range i from to . loc)
+ (##sys#check-exact i loc)
+ (unless (and (fx<= from i) (fx< i to))
+ (##sys#error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int)
+ (and (pair? loc) (car loc)) i from to) ) )
+
+(define (##sys#check-special ptr . loc)
+ (unless (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr))
+ (##sys#signal-hook #:type-error (and (pair? loc) (car loc)) "bad argument type - not a pointer-like object" ptr) ) )
+
+(define (##sys#check-closure x . loc)
+ (if (pair? loc)
+ (##core#inline "C_i_check_closure_2" x (car loc))
+ (##core#inline "C_i_check_closure" x) ) )
+
+(include "unsafe-declarations.scm")
+
+(define (##sys#force promise)
+ (if (##sys#structure? promise 'promise)
+ ((##sys#slot promise 1))
+ promise) )
+
+(define force ##sys#force)
+
+(define (system cmd)
+ (##sys#check-string cmd 'system)
+ (let ((r (##core#inline "C_execute_shell_command" cmd)))
+ (cond ((fx< r 0)
+ (##sys#update-errno)
+ (##sys#signal-hook #:process-error 'system "`system' invocation failed" cmd) )
+ (else r) ) ) )
+
+
+;;; Dynamic Load
+
+;; Library load mode (only active when HAVE_DLFCN_H at the momemnt)
+
+(define ##sys#dlopen-flags (##core#primitive "C_dlopen_flags"))
+(define ##sys#set-dlopen-flags! (##core#primitive "C_set_dlopen_flags"))
+
+;; Chicken library load
+
+(define ##sys#dload (##core#primitive "C_dload"))
+
+; Dynamic Unload not available on all platforms and to be used with caution!
+(define (##sys#dunload name)
+ (and-let* (((##core#inline "C_dunload" (##sys#make-c-string name))))
+ (##sys#gc #t)
+ #t ) )
+
+;; Non-Chicken library load
+
+(define ##sys#dynamic-library-load (##core#primitive "C_dynamic_library_load"))
+
+; Dynamic Unload not available on all platforms and to be used with caution!
+(define ##sys#dynamic-library-unload (##core#primitive "C_dynamic_library_unload"))
+
+;; Introspection of loaded libraries
+
+; (##sys#dynamic-library-procedure-pointer mname sname) => mname+sname-ptr or #f
+; (##sys#dynamic-library-variable-pointer mname sname) => mname+sname-ptr or #f
+
+(define (##sys#dynamic-library-procedure-pointer mname sname)
+ ((##core#primitive "C_dynamic_library_symbol") mname sname #t) )
+
+(define (##sys#dynamic-library-variable-pointer mname sname)
+ ((##core#primitive "C_dynamic_library_symbol") mname sname #f) )
+
+; (##sys#dynamic-library-names) => (<pathname>...)
+; Does not return the "name" of the running program (i.e. #f) but
+; does return any default libraries.
+
+(define ##sys#dynamic-library-names (##core#primitive "C_dynamic_library_names"))
+
+; (##sys#dynamic-library-data name)
+; => ((<dload-handle> <literal-frame-count> <ptable?>)...)
+; <dload-handle> is a pointer to the actual dload handle or #f
+; <literal-frame-count> is the total of entrypoints (toplevel)
+; <ptable?> is a boolean indicating whether the lib has a ptable
+
+(define ##sys#dynamic-library-data (##core#primitive "C_dynamic_library_data"))
+
+; (##sys#chicken-library-literal-frame name handle count) => (<lf[0]>...)
+
+(define ##sys#chicken-library-literal-frame (##core#primitive "C_chicken_library_literal_frame"))
+
+; (##sys#chicken-library-ptable name handle count pointer?)
+; => ((<ptable[0].id> . <ptable[0].ptr>)...) when pointer?
+; => (<ptable[0].id>...) when (not pointer?)
+
+(define ##sys#chicken-library-ptable (##core#primitive "C_chicken_library_ptable"))
+
+
+;;; Operations on booleans:
+
+(define (not x) (##core#inline "C_i_not" x))
+(define (boolean? x) (##core#inline "C_booleanp" x))
+
+
+;;; Equivalence predicates:
+
+(define (eq? x y) (##core#inline "C_eqp" x y))
+(define (eqv? x y) (##core#inline "C_i_eqvp" x y))
+(define (equal? x y) (##core#inline "C_i_equalp" x y))
+
+
+;;; Pairs and lists:
+
+(define (pair? x) (##core#inline "C_i_pairp" x))
+(define (cons x y) (##core#inline_allocate ("C_a_i_cons" 3) x y))
+(define (car x) (##core#inline "C_i_car" x))
+(define (cdr x) (##core#inline "C_i_cdr" x))
+
+(define (set-car! x y) (##core#inline "C_i_set_car" x y))
+(define (set-cdr! x y) (##core#inline "C_i_set_cdr" x y))
+(define (cadr x) (##core#inline "C_i_cadr" x))
+(define (caddr x) (##core#inline "C_i_caddr" x))
+(define (cadddr x) (##core#inline "C_i_cadddr" x))
+(define (cddddr x) (##core#inline "C_i_cddddr" x))
+
+(define (caar x) (car (car x)))
+(define (cdar x) (cdr (car x)))
+(define (cddr x) (cdr (cdr x)))
+(define (caaar x) (car (car (car x))))
+(define (caadr x) (car (##core#inline "C_i_cadr" x)))
+(define (cadar x) (##core#inline "C_i_cadr" (car x)))
+(define (cdaar x) (cdr (car (car x))))
+(define (cdadr x) (cdr (##core#inline "C_i_cadr" x)))
+(define (cddar x) (cdr (cdr (car x))))
+(define (cdddr x) (cdr (cdr (cdr x))))
+(define (caaaar x) (car (car (car (car x)))))
+(define (caaadr x) (car (car (##core#inline "C_i_cadr" x))))
+(define (caadar x) (car (##core#inline "C_i_cadr" (car x))))
+(define (caaddr x) (car (##core#inline "C_i_caddr" x)))
+(define (cadaar x) (##core#inline "C_i_cadr" (car (car x))))
+(define (cadadr x) (##core#inline "C_i_cadr" (##core#inline "C_i_cadr" x)))
+(define (caddar x) (##core#inline "C_i_caddr" (car x)))
+(define (cdaaar x) (cdr (car (car (car x)))))
+(define (cdaadr x) (cdr (car (##core#inline "C_i_cadr" x))))
+(define (cdadar x) (cdr (##core#inline "C_i_cadr" (car x))))
+(define (cdaddr x) (cdr (##core#inline "C_i_caddr" x)))
+(define (cddaar x) (cdr (cdr (car (car x)))))
+(define (cddadr x) (cdr (cdr (##core#inline "C_i_cadr" x))))
+(define (cdddar x) (cdr (cdr (cdr (car x)))))
+
+(define (null? x) (eq? x '()))
+(define (list . lst) lst)
+(define (length lst) (##core#inline "C_i_length" lst))
+(define (list-tail lst i) (##core#inline "C_i_list_tail" lst i))
+(define (list-ref lst i) (##core#inline "C_i_list_ref" lst i))
+
+(define (##sys#delq x lst)
+ (let loop ([lst lst])
+ (cond ((null? lst) lst)
+ ((eq? x (##sys#slot lst 0)) (##sys#slot lst 1))
+ (else (cons (##sys#slot lst 0) (loop (##sys#slot lst 1)))) ) ) )
+
+(define (##sys#error-not-a-proper-list arg . loc)
+ (##sys#error-hook (foreign-value "C_NOT_A_PROPER_LIST_ERROR" int) (and (pair? loc) (car loc)) arg) )
+
+(define ##sys#not-a-proper-list-error ##sys#error-not-a-proper-list) ;DEPRECATED
+
+(define (append . lsts)
+ (if (eq? lsts '())
+ lsts
+ (let loop ((lsts lsts))
+ (if (eq? (##sys#slot lsts 1) '())
+ (##sys#slot lsts 0)
+ (let copy ((node (##sys#slot lsts 0)))
+ (cond-expand
+ [unsafe
+ (if (eq? node '())
+ (loop (##sys#slot lsts 1))
+ (cons (##sys#slot node 0) (copy (##sys#slot node 1))) ) ]
+ [else
+ (cond ((eq? node '()) (loop (##sys#slot lsts 1)))
+ ((pair? node)
+ (cons (##sys#slot node 0) (copy (##sys#slot node 1))) )
+ (else (##sys#error-not-a-proper-list (##sys#slot lsts 0) 'append)) ) ] ) ) ) ) ) )
+
+(define (reverse lst0)
+ (let loop ((lst lst0) (rest '()))
+ (cond-expand
+ [unsafe
+ (if (eq? lst '())
+ rest
+ (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest)) ) ]
+ [else
+ (cond ((eq? lst '()) rest)
+ ((pair? lst)
+ (loop (##sys#slot lst 1) (cons (##sys#slot lst 0) rest)) )
+ (else (##sys#error-not-a-proper-list lst0 'reverse)) ) ] ) ) )
+
+(define (memq x lst) (##core#inline "C_i_memq" x lst))
+(define (memv x lst) (##core#inline "C_i_memv" x lst))
+(define (member x lst) (##core#inline "C_i_member" x lst))
+(define (assq x lst) (##core#inline "C_i_assq" x lst))
+(define (assv x lst) (##core#inline "C_i_assv" x lst))
+(define (assoc x lst) (##core#inline "C_i_assoc" x lst))
+
+(define (list? x) (##core#inline "C_i_listp" x))
+
+
+;;; Strings:
+
+(define (string? x) (##core#inline "C_i_stringp" x))
+(define (string-length s) (##core#inline "C_i_string_length" s))
+(define (string-ref s i) (##core#inline "C_i_string_ref" s i))
+(define (string-set! s i c) (##core#inline "C_i_string_set" s i c))
+
+(define-inline (%make-string size fill)
+ (##sys#allocate-vector size #t fill #f) )
+
+(define (##sys#make-string size #!optional (fill #\space))
+ (%make-string size fill))
+
+(define (make-string size . fill)
+ (##sys#check-exact size 'make-string)
+ #+(not unsafe)
+ (when (fx< size 0)
+ (##sys#signal-hook #:bounds-error 'make-string "size is negative" size))
+ (%make-string size
+ (if (null? fill)
+ #\space
+ (let ((c (car fill)))
+ (##sys#check-char c 'make-string)
+ c ) ) ) )
+
+(define ##sys#string->list
+ (lambda (s)
+ (##sys#check-string s 'string->list)
+ (let ((len (##core#inline "C_block_size" s)))
+ (let loop ((i 0))
+ (if (fx>= i len)
+ '()
+ (cons (##core#inline "C_subchar" s i)
+ (loop (fx+ i 1)) ) ) ) ) ) )
+
+(define string->list ##sys#string->list)
+
+(define (##sys#list->string lst0)
+ (cond-expand
+ [unsafe
+ (let* ([len (length lst0)]
+ [s (##sys#make-string len)] )
+ (do ([i 0 (fx+ i 1)]
+ [lst lst0 (##sys#slot lst 1)] )
+ ((fx>= i len) s)
+ (##core#inline "C_setsubchar" s i (##sys#slot lst 0)) ) )]
+ [else
+ (if (not (list? lst0))
+ (##sys#error-not-a-proper-list lst0 'list->string)
+ (let* ([len (length lst0)]
+ [s (##sys#make-string len)] )
+ (do ([i 0 (fx+ i 1)]
+ [lst lst0 (##sys#slot lst 1)] )
+ ((fx>= i len) s)
+ (let ([c (##sys#slot lst 0)])
+ (##sys#check-char c 'list->string)
+ (##core#inline "C_setsubchar" s i c) ) ) ) )]
+ ))
+
+(define list->string ##sys#list->string)
+
+;;; By Sven Hartrumpf:
+
+(define (##sys#reverse-list->string l)
+ (cond-expand
+ [unsafe
+ (let* ((n (length l))
+ (s (##sys#make-string n)))
+ (let iter ((l2 l) (n2 (fx- n 1)))
+ (cond ((fx>= n2 0)
+ (##core#inline "C_setsubchar" s n2 (##sys#slot l2 0))
+ (iter (##sys#slot l2 1) (fx- n2 1)) ) ) )
+ s ) ]
+ [else
+ (if (list? l)
+ (let* ((n (length l))
+ (s (##sys#make-string n)))
+ (let iter ((l2 l) (n2 (fx- n 1)))
+ (cond ((fx>= n2 0)
+ (let ((c (##sys#slot l2 0)))
+ (##sys#check-char c 'reverse-list->string)
+ (##core#inline "C_setsubchar" s n2 c) )
+ (iter (##sys#slot l2 1) (fx- n2 1)) ) ) )
+ s )
+ (##sys#error-not-a-proper-list l 'reverse-list->string) ) ]
+ ) )
+
+(define reverse-list->string ##sys#reverse-list->string)
+
+(define (string-fill! s c)
+ (##sys#check-string s 'string-fill!)
+ (##sys#check-char c 'string-fill!)
+ (##core#inline "C_set_memory" s c (##sys#size s))
+ (##core#undefined) )
+
+(define string-copy
+ (lambda (s)
+ (##sys#check-string s 'string-copy)
+ (let* ([len (##sys#size s)]
+ [s2 (##sys#make-string len)] )
+ (##core#inline "C_copy_memory" s2 s len)
+ s2) ) )
+
+(define (substring s start . end)
+ (##sys#check-string s 'substring)
+ (##sys#check-exact start 'substring)
+ (let ([end (if (pair? end)
+ (let ([end (car end)])
+ (##sys#check-exact end 'substring)
+ end)
+ (##sys#size s) ) ] )
+ (cond-expand
+ [unsafe (##sys#substring s start end)]
+ [else
+ (let ([len (##sys#size s)])
+ (if (and (fx<= start end)
+ (fx>= start 0)
+ (fx<= end len) )
+ (##sys#substring s start end)
+ (##sys#error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int) 'substring start end) ) ) ] ) ) )
+
+(define (##sys#substring s start end)
+ (let ([s2 (##sys#make-string (fx- end start))])
+ (##core#inline "C_substring_copy" s s2 start end 0)
+ s2 ) )
+
+(define (string=? x y)
+ (cond-expand [unsafe (##core#inline "C_u_i_string_equal_p" x y)]
+ [else (##core#inline "C_i_string_equal_p" x y)] ) )
+
+(define (string-ci=? x y) (##core#inline "C_i_string_ci_equal_p" x y))
+
+(letrec ((compare
+ (lambda (s1 s2 loc k)
+ (##sys#check-string s1 loc)
+ (##sys#check-string s2 loc)
+ (let ((len1 (##core#inline "C_block_size" s1))
+ (len2 (##core#inline "C_block_size" s2)) )
+ (k len1 len2
+ (##core#inline "C_string_compare"
+ s1
+ s2
+ (if (fx< len1 len2)
+ len1
+ len2) ) ) ) ) ) )
+ (set! string<? (lambda (s1 s2)
+ (compare
+ s1 s2 'string<?
+ (lambda (len1 len2 cmp)
+ (or (fx< cmp 0)
+ (and (fx< len1 len2)
+ (eq? cmp 0) ) ) ) ) ) )
+ (set! string>? (lambda (s1 s2)
+ (compare
+ s1 s2 'string>?
+ (lambda (len1 len2 cmp)
+ (or (fx> cmp 0)
+ (and (fx< len2 len1)
+ (eq? cmp 0) ) ) ) ) ) )
+ (set! string<=? (lambda (s1 s2)
+ (compare
+ s1 s2 'string<=?
+ (lambda (len1 len2 cmp)
+ (if (eq? cmp 0)
+ (fx<= len1 len2)
+ (fx< cmp 0) ) ) ) ) )
+ (set! string>=? (lambda (s1 s2)
+ (compare
+ s1 s2 'string>=?
+ (lambda (len1 len2 cmp)
+ (if (eq? cmp 0)
+ (fx>= len1 len2)
+ (fx> cmp 0) ) ) ) ) ) )
+
+(letrec ((compare
+ (lambda (s1 s2 loc k)
+ (##sys#check-string s1 loc)
+ (##sys#check-string s2 loc)
+ (let ((len1 (##core#inline "C_block_size" s1))
+ (len2 (##core#inline "C_block_size" s2)) )
+ (k len1 len2
+ (##core#inline "C_string_compare_case_insensitive"
+ s1
+ s2
+ (if (fx< len1 len2)
+ len1
+ len2) ) ) ) ) ) )
+ (set! string-ci<? (lambda (s1 s2)
+ (compare
+ s1 s2 'string-ci<?
+ (lambda (len1 len2 cmp)
+ (or (fx< cmp 0)
+ (and (fx< len1 len2)
+ (eq? cmp 0) ) ) ) ) ) )
+ (set! string-ci>? (lambda (s1 s2)
+ (compare
+ s1 s2 'string-ci>?
+ (lambda (len1 len2 cmp)
+ (or (fx> cmp 0)
+ (and (fx< len2 len1)
+ (eq? cmp 0) ) ) ) ) ) )
+ (set! string-ci<=? (lambda (s1 s2)
+ (compare
+ s1 s2 'string-ci<=?
+ (lambda (len1 len2 cmp)
+ (if (eq? cmp 0)
+ (fx>= len1 len2)
+ (fx< cmp 0) ) ) ) ) )
+ (set! string-ci>=? (lambda (s1 s2)
+ (compare
+ s1 s2 'string-ci>=?
+ (lambda (len1 len2 cmp)
+ (if (eq? cmp 0)
+ (fx<= len1 len2)
+ (fx> cmp 0) ) ) ) ) ) )
+
+(define (##sys#string-append x y)
+ (let* ([s1 (##sys#size x)]
+ [s2 (##sys#size y)]
+ [z (##sys#make-string (fx+ s1 s2))] )
+ (##core#inline "C_substring_copy" x z 0 s1 0)
+ (##core#inline "C_substring_copy" y z 0 s2 s1)
+ z) )
+
+(define (string-append . all)
+ (let ([snew #f])
+ (let loop ([strs all] [n 0])
+ (if (eq? strs '())
+ (set! snew (##sys#make-string n))
+ (let ([s (##sys#slot strs 0)])
+ (##sys#check-string s 'string-append)
+ (let ([len (##sys#size s)])
+ (loop (##sys#slot strs 1) (fx+ n len))
+ (##core#inline "C_substring_copy" s snew 0 len n) ) ) ) )
+ snew ) )
+
+(define string
+ (let ([list->string list->string])
+ (lambda chars (list->string chars)) ) )
+
+(define (##sys#fragments->string total fs)
+ (let ([dest (##sys#make-string total)])
+ (let loop ([fs fs] [pos 0])
+ (if (null? fs)
+ dest
+ (let* ([f (##sys#slot fs 0)]
+ [flen (##sys#size f)] )
+ (##core#inline "C_substring_copy" f dest 0 flen pos)
+ (loop (##sys#slot fs 1) (fx+ pos flen)) ) ) ) ) )
+
+
+;;; Numeric routines:
+
+(define most-positive-fixnum (foreign-value "C_MOST_POSITIVE_FIXNUM" int))
+(define most-negative-fixnum (foreign-value "C_MOST_NEGATIVE_FIXNUM" int))
+(define fixnum-bits (foreign-value "(C_WORD_SIZE - 1)" int))
+(define fixnum-precision (foreign-value "(C_WORD_SIZE - (1 + 1))" int))
+
+(define (fixnum? x) (##core#inline "C_fixnump" x))
+(define (fx+ x y) (##core#inline "C_fixnum_plus" x y))
+(define (fx- x y) (##core#inline "C_fixnum_difference" x y))
+(define (fx* x y) (##core#inline "C_fixnum_times" x y))
+(define (fx= x y) (eq? x y))
+(define (fx> x y) (##core#inline "C_fixnum_greaterp" x y))
+(define (fx< x y) (##core#inline "C_fixnum_lessp" x y))
+(define (fx>= x y) (##core#inline "C_fixnum_greater_or_equal_p" x y))
+(define (fx<= x y) (##core#inline "C_fixnum_less_or_equal_p" x y))
+(define (fxmin x y) (##core#inline "C_i_fixnum_min" x y))
+(define (fxmax x y) (##core#inline "C_i_fixnum_max" x y))
+(define (fxneg x) (##core#inline "C_fixnum_negate" x))
+(define (fxand x y) (##core#inline "C_fixnum_and" x y))
+(define (fxior x y) (##core#inline "C_fixnum_or" x y))
+(define (fxxor x y) (##core#inline "C_fixnum_xor" x y))
+(define (fxnot x) (##core#inline "C_fixnum_not" x))
+(define (fxshl x y) (##core#inline "C_fixnum_shift_left" x y))
+(define (fxshr x y) (##core#inline "C_fixnum_shift_right" x y))
+
+(define-inline (fx-check-divison-by-zero x y loc)
+ (when (eq? 0 y)
+ (##sys#error-hook (foreign-value "C_DIVISION_BY_ZERO_ERROR" int) loc x y) ) )
+
+(define (fx/ x y)
+ (cond-expand
+ [unsafe (##core#inline "C_fixnum_divide" x y)]
+ [else
+ (fx-check-divison-by-zero x y 'fx/)
+ (##core#inline "C_fixnum_divide" x y) ] ) )
+
+(define (fxmod x y)
+ (cond-expand
+ [unsafe (##core#inline "C_fixnum_modulo" x y)]
+ [else
+ (fx-check-divison-by-zero x y 'fxmod)
+ (##core#inline "C_fixnum_modulo" x y) ] ) )
+
+(define maximum-flonum (foreign-value "DBL_MAX" double))
+(define minimum-flonum (foreign-value "DBL_MIN" double))
+(define flonum-radix (foreign-value "FLT_RADIX" int))
+(define flonum-epsilon (foreign-value "DBL_EPSILON" double))
+(define flonum-precision (foreign-value "DBL_MANT_DIG" int))
+(define flonum-decimal-precision (foreign-value "DBL_DIG" int))
+(define flonum-maximum-exponent (foreign-value "DBL_MAX_EXP" int))
+(define flonum-minimum-exponent (foreign-value "DBL_MIN_EXP" int))
+(define flonum-maximum-decimal-exponent (foreign-value "DBL_MAX_10_EXP" int))
+(define flonum-minimum-decimal-exponent (foreign-value "DBL_MIN_10_EXP" int))
+
+(define (flonum? x) (##core#inline "C_i_flonump" x))
+
+(define (finite? x)
+ (##sys#check-number x 'finite?)
+ (##core#inline "C_i_finitep" x) )
+
+(define-inline (fp-check-flonum x loc)
+ (unless (flonum? x)
+ (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int) loc x) ) )
+
+(define-inline (fp-check-flonums x y loc)
+ (unless (and (flonum? x) (flonum? y))
+ (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int) loc x y) ) )
+
+(define (fp+ x y)
+ (cond-expand
+ [unsafe (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y)]
+ [else
+ (fp-check-flonums x y 'fp+)
+ (##core#inline_allocate ("C_a_i_flonum_plus" 4) x y) ] ) )
+
+(define (fp- x y)
+ (cond-expand
+ [unsafe (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y)]
+ [else
+ (fp-check-flonums x y 'fp-)
+ (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y) ] ) )
+
+(define (fp* x y)
+ (cond-expand
+ [unsafe (##core#inline_allocate ("C_a_i_flonum_times" 4) x y)]
+ [else
+ (fp-check-flonums x y 'fp*)
+ (##core#inline_allocate ("C_a_i_flonum_times" 4) x y) ] ) )
+
+(define (fp/ x y)
+ (cond-expand
+ [unsafe (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y)]
+ [else
+ (fp-check-flonums x y 'fp/)
+ (##core#inline_allocate ("C_a_i_flonum_quotient" 4) x y) ] ) )
+
+(define (fp= x y)
+ (cond-expand
+ [unsafe (##core#inline "C_flonum_equalp" x y)]
+ [else
+ (fp-check-flonums x y 'fp=)
+ (##core#inline "C_flonum_equalp" x y) ] ) )
+
+(define (fp> x y)
+ (cond-expand
+ [unsafe (##core#inline "C_flonum_greaterp" x y)]
+ [else
+ (fp-check-flonums x y 'fp>)
+ (##core#inline "C_flonum_greaterp" x y) ] ) )
+
+(define (fp< x y)
+ (cond-expand
+ [unsafe (##core#inline "C_flonum_lessp" x y)]
+ [else
+ (fp-check-flonums x y 'fp<)
+ (##core#inline "C_flonum_lessp" x y) ] ) )
+
+(define (fp>= x y)
+ (cond-expand
+ [unsafe (##core#inline "C_flonum_greater_or_equal_p" x y)]
+ [else
+ (fp-check-flonums x y 'fp>=)
+ (##core#inline "C_flonum_greater_or_equal_p" x y) ] ) )
+
+(define (fp<= x y)
+ (cond-expand
+ [unsafe (##core#inline "C_flonum_less_or_equal_p" x y)]
+ [else
+ (fp-check-flonums x y 'fp<=)
+ (##core#inline "C_flonum_less_or_equal_p" x y) ] ) )
+
+(define (fpneg x)
+ (cond-expand
+ [unsafe (##core#inline_allocate ("C_a_i_flonum_negate" 4) x)]
+ [else
+ (fp-check-flonum x 'fpneg)
+ (##core#inline_allocate ("C_a_i_flonum_negate" 4) x) ] ) )
+
+(define (fpmax x y)
+ (cond-expand
+ [unsafe (##core#inline "C_i_flonum_max" x y)]
+ [else
+ (fp-check-flonums x y 'fpmax)
+ (##core#inline "C_i_flonum_max" x y) ] ) )
+
+(define (fpmin x y)
+ (cond-expand
+ [unsafe (##core#inline "C_i_flonum_min" x y)]
+ [else
+ (fp-check-flonums x y 'fpmin)
+ (##core#inline "C_i_flonum_min" x y) ] ) )
+
+(define * (##core#primitive "C_times"))
+(define - (##core#primitive "C_minus"))
+(define + (##core#primitive "C_plus"))
+(define / (##core#primitive "C_divide"))
+(define = (##core#primitive "C_nequalp"))
+(define > (##core#primitive "C_greaterp"))
+(define < (##core#primitive "C_lessp"))
+(define >= (##core#primitive "C_greater_or_equal_p"))
+(define <= (##core#primitive "C_less_or_equal_p"))
+
+(define add1 (lambda (n) (+ n 1)))
+(define sub1 (lambda (n) (- n 1)))
+
+(define ##sys#floor (##core#primitive "C_flonum_floor"))
+(define ##sys#ceiling (##core#primitive "C_flonum_ceiling"))
+(define ##sys#truncate (##core#primitive "C_flonum_truncate"))
+(define ##sys#round (##core#primitive "C_flonum_round"))
+(define quotient (##core#primitive "C_quotient"))
+(define ##sys#cons-flonum (##core#primitive "C_cons_flonum"))
+(define (##sys#number? x) (##core#inline "C_i_numberp" x))
+(define number? ##sys#number?)
+(define complex? number?)
+(define real? number?)
+(define (rational? n) (##core#inline "C_i_rationalp" n))
+(define ##sys#flonum-fraction (##core#primitive "C_flonum_fraction"))
+(define (##sys#integer? x) (##core#inline "C_i_integerp" x))
+(define integer? ##sys#integer?)
+(define (##sys#exact? x) (##core#inline "C_i_exactp" x))
+(define (##sys#inexact? x) (##core#inline "C_i_inexactp" x))
+(define exact? ##sys#exact?)
+(define inexact? ##sys#inexact?)
+(define expt (##core#primitive "C_expt"))
+(define (##sys#fits-in-int? n) (##core#inline "C_fits_in_int_p" n))
+(define (##sys#fits-in-unsigned-int? n) (##core#inline "C_fits_in_unsigned_int_p" n))
+(define (##sys#flonum-in-fixnum-range? n) (##core#inline "C_flonum_in_fixnum_range_p" n))
+(define (##sys#double->number n) (##core#inline "C_double_to_number" n))
+(define (zero? n) (##core#inline "C_i_zerop" n))
+(define (positive? n) (##core#inline "C_i_positivep" n))
+(define (negative? n) (##core#inline "C_i_negativep" n))
+(define (abs n) (##core#inline_allocate ("C_a_i_abs" 4) n)) ; 4 => words-per-flonum
+
+(define (angle n)
+ (##sys#check-number n 'angle)
+ (if (< n 0) (fp* 2.0 (acos 0.0)) 0.0) )
+
+(define (real-part n)
+ (##sys#check-number n 'real-part)
+ n)
+
+(define (imag-part n)
+ (##sys#check-number n 'imag-part)
+ 0)
+
+(define (numerator n)
+ (##sys#check-number n 'numerator)
+ (if (##core#inline "C_i_integerp" n)
+ n
+ (##sys#signal-hook #:type-error 'numerator "bad argument type - not a rational number" n) ) )
+
+(define (denominator n)
+ (##sys#check-number n 'denominator)
+ (if (##core#inline "C_i_integerp" n)
+ 1
+ (##sys#signal-hook #:type-error 'numerator "bad argument type - not a rational number" n) ) )
+
+(define magnitude abs)
+
+(define (signum n)
+ (cond ((> n 0) (if (##sys#exact? n) 1 1.0))
+ ((< n 0) (if (##sys#exact? n) -1 -1.0))
+ (else (if (##sys#exact? n) 0 0.0) ) ) )
+
+(define ##sys#exact->inexact (##core#primitive "C_exact_to_inexact"))
+(define exact->inexact ##sys#exact->inexact)
+(define (##sys#inexact->exact n) (##core#inline "C_i_inexact_to_exact" n))
+(define inexact->exact ##sys#inexact->exact)
+
+(define (floor x)
+ (##sys#check-number x 'floor)
+ (if (##core#inline "C_fixnump" x)
+ x
+ (##sys#floor x) ) )
+
+(define (ceiling x)
+ (##sys#check-number x 'ceiling)
+ (if (##core#inline "C_fixnump" x)
+ x
+ (##sys#ceiling x) ) )
+
+(define (truncate x)
+ (##sys#check-number x 'truncate)
+ (if (##core#inline "C_fixnump" x)
+ x
+ (##sys#truncate x) ) )
+
+(define (round x)
+ (##sys#check-number x 'round)
+ (if (##core#inline "C_fixnump" x)
+ x
+ (##sys#round x) ) )
+
+(define remainder
+ (lambda (x y) (- x (* (quotient x y) y))) )
+
+(define modulo
+ (let ([floor floor])
+ (lambda (x y)
+ (let ((div (/ x y)))
+ (- x (* (if (integer? div)
+ div
+ (let* ([fd (floor div)]
+ [fdx (##core#inline "C_quickflonumtruncate" fd)] )
+ (if (= fd fdx)
+ fdx
+ fd) ) )
+ y) ) ) ) ) )
+
+(define (even? n) (##core#inline "C_i_evenp" n))
+(define (odd? n) (##core#inline "C_i_oddp" n))
+
+(define max)
+(define min)
+
+(let ([> >]
+ [< <] )
+ (letrec ([maxmin
+ (lambda (n1 ns pred)
+ (let loop ((nbest n1) (ns ns))
+ (if (eq? ns '())
+ nbest
+ (let ([ni (##sys#slot ns 0)])
+ (loop (if (pred ni nbest)
+ (if (and (##core#inline "C_blockp" nbest)
+ (##core#inline "C_flonump" nbest)
+ (not (##core#inline "C_blockp" ni)) )
+ (exact->inexact ni)
+ ni)
+ nbest)
+ (##sys#slot ns 1) ) ) ) ) ) ] )
+
+ (set! max (lambda (n1 . ns) (maxmin n1 ns >)))
+ (set! min (lambda (n1 . ns) (maxmin n1 ns <))) ) )
+
+(define (exp n)
+ (##core#inline_allocate ("C_a_i_exp" 4) n) )
+
+(define (log n)
+ (##core#inline_allocate ("C_a_i_log" 4) n) )
+
+(define (sin n)
+ (##core#inline_allocate ("C_a_i_sin" 4) n) )
+
+(define (cos n)
+ (##core#inline_allocate ("C_a_i_cos" 4) n) )
+
+(define (tan n)
+ (##core#inline_allocate ("C_a_i_tan" 4) n) )
+
+(define (asin n)
+ (##core#inline_allocate ("C_a_i_asin" 4) n) )
+
+(define (acos n)
+ (##core#inline_allocate ("C_a_i_acos" 4) n) )
+
+(define (sqrt n)
+ (##core#inline_allocate ("C_a_i_sqrt" 4) n) )
+
+(define (atan n1 . n2)
+ (if (null? n2)
+ (##core#inline_allocate ("C_a_i_atan" 4) n1)
+ (let ([n2 (car n2)])
+ (##core#inline_allocate ("C_a_i_atan2" 4) n1 n2) ) ) )
+
+(define ##sys#gcd
+ (let ((remainder remainder))
+ (lambda (x y)
+ (let loop ((x x) (y y))
+ (if (zero? y)
+ (abs x)
+ (loop y (remainder x y)) ) ) ) ) )
+
+(define (gcd . ns)
+ (if (eq? ns '())
+ 0
+ (let loop ([ns ns] [f #t])
+ (let ([head (##sys#slot ns 0)]
+ [next (##sys#slot ns 1)] )
+ (cond-expand [unsafe] [else (when f (##sys#check-integer head 'gcd))])
+ (if (null? next)
+ (abs head)
+ (let ([n2 (##sys#slot next 0)])
+ (cond-expand [unsafe] [else (##sys#check-integer n2 'gcd)])
+ (loop (cons (##sys#gcd head n2) (##sys#slot next 1)) #f) ) ) ) ) ) )
+
+(define (##sys#lcm x y)
+ (quotient (* x y) (##sys#gcd x y)) )
+
+(define (lcm . ns)
+ (if (null? ns)
+ 1
+ (let loop ([ns ns] [f #t])
+ (let ([head (##sys#slot ns 0)]
+ [next (##sys#slot ns 1)] )
+ (cond-expand [unsafe] [else (when f (##sys#check-integer head 'lcm))])
+ (if (null? next)
+ (abs head)
+ (let ([n2 (##sys#slot next 0)])
+ (cond-expand [unsafe] [else (##sys#check-integer n2 'lcm)])
+ (loop (cons (##sys#lcm head (##sys#slot next 0)) (##sys#slot next 1)) #f) ) ) ) ) ) )
+
+(define ##sys#string->number (##core#primitive "C_string_to_number"))
+(define string->number ##sys#string->number)
+(define ##sys#number->string (##core#primitive "C_number_to_string"))
+(define number->string ##sys#number->string)
+
+(define (flonum-print-precision #!optional prec)
+ (let ([prev (##core#inline "C_get_print_precision")])
+ (when prec
+ (##sys#check-exact prec 'flonum-print-precision)
+ (##core#inline "C_set_print_precision" prec) )
+ prev ) )
+
+
+;;; Symbols:
+
+(define ##sys#make-symbol (##core#primitive "C_make_symbol"))
+(define (symbol? x) (##core#inline "C_i_symbolp" x))
+(define ##sys#snafu '##sys#fnord)
+(define ##sys#intern-symbol (##core#primitive "C_string_to_symbol"))
+(define (##sys#interned-symbol? x) (##core#inline "C_lookup_symbol" x))
+
+(define (##sys#string->symbol str)
+ (##sys#check-string str)
+ (##sys#intern-symbol str) )
+
+(define ##sys#symbol->string)
+(define ##sys#symbol->qualified-string)
+(define ##sys#qualified-symbol-prefix)
+
+(let ([string-append string-append]
+ [string-copy string-copy] )
+
+ (define (split str len)
+ (let ([b0 (##sys#byte str 0)]) ; we fetch the byte, wether len is 0 or not
+ (if (and (fx> len 0) (fx< b0 len) (fx<= b0 namespace-max-id-len))
+ (fx+ b0 1)
+ #f) ) )
+
+ (set! ##sys#symbol->string
+ (lambda (s)
+ (let* ([str (##sys#slot s 1)]
+ [len (##sys#size str)]
+ [i (split str len)] )
+ (if i (##sys#substring str i len) str) ) ) )
+
+ (set! ##sys#symbol->qualified-string
+ (lambda (s)
+ (let* ([str (##sys#slot s 1)]
+ [len (##sys#size str)]
+ [i (split str len)] )
+ (if i
+ (string-append "##" (##sys#substring str 1 i) "#" (##sys#substring str i len))
+ str) ) ) )
+
+ (set! ##sys#qualified-symbol-prefix
+ (lambda (s)
+ (let* ([str (##sys#slot s 1)]
+ [len (##sys#size str)]
+ [i (split str len)] )
+ (and i (##sys#substring str 0 i)) ) ) ) )
+
+(define (##sys#qualified-symbol? s)
+ (let ((str (##sys#slot s 1)))
+ (and (fx> (##sys#size str) 0)
+ (fx<= (##sys#byte str 0) namespace-max-id-len))))
+
+(define ##sys#string->qualified-symbol
+ (lambda (prefix str)
+ (##sys#string->symbol
+ (if prefix
+ (##sys#string-append prefix str)
+ str) ) ) )
+
+(define (symbol->string s)
+ (##sys#check-symbol s 'symbol->string)
+ (string-copy (##sys#symbol->string s) ) )
+
+(define string->symbol
+ (let ([string-copy string-copy])
+ (lambda (str)
+ (##sys#check-string str 'string->symbol)
+ (##sys#intern-symbol (string-copy str)) ) ) )
+
+(define string->uninterned-symbol
+ (let ([string-copy string-copy])
+ (lambda (str)
+ (##sys#check-string str 'string->uninterned-symbol)
+ (##sys#make-symbol (string-copy str)) ) ) )
+
+(define gensym
+ (let ([counter -1])
+ (lambda str-or-sym
+ (let ([err (lambda (prefix) (##sys#signal-hook #:type-error 'gensym "argument is not a string or symbol" prefix))])
+ (set! counter (fx+ counter 1))
+ (##sys#make-symbol
+ (##sys#string-append
+ (if (eq? str-or-sym '())
+ "g"
+ (let ([prefix (car str-or-sym)])
+ (or (and (##core#inline "C_blockp" prefix)
+ (cond [(##core#inline "C_stringp" prefix) prefix]
+ [(##core#inline "C_symbolp" prefix) (##sys#symbol->string prefix)]
+ [else (err prefix)] ) )
+ (err prefix) ) ) )
+ (##sys#number->string counter) ) ) ) ) ) )
+
+
+;;; Keywords:
+
+(define (keyword? x)
+ (and (symbol? x) (fx= 0 (##sys#byte (##sys#slot x 1) 0))) )
+
+(define string->keyword
+ (let ([string string] )
+ (lambda (s)
+ (##sys#check-string s 'string->keyword)
+ (##sys#intern-symbol (##sys#string-append (string (integer->char 0)) s)) ) ) )
+
+(define keyword->string
+ (let ([keyword? keyword?])
+ (lambda (kw)
+ (if (keyword? kw)
+ (##sys#symbol->string kw)
+ (##sys#signal-hook #:type-error 'keyword->string "bad argument type - not a keyword" kw) ) ) ) )
+
+(define (##sys#get-keyword key args0 . default)
+ (##sys#check-list args0 'get-keyword)
+ (let ([a (memq key args0)])
+ (if a
+ (let ([r (##sys#slot a 1)])
+ (if (pair? r)
+ (##sys#slot r 0)
+ (##sys#error 'get-keyword "missing keyword argument" args0 key) ) )
+ (and (pair? default) ((car default))) ) ) )
+
+(define get-keyword ##sys#get-keyword)
+
+
+;;; Blob:
+
+(define (##sys#make-blob size)
+ (let ([bv (##sys#allocate-vector size #t #f #t)])
+ (##core#inline "C_string_to_bytevector" bv)
+ bv) )
+
+(define (make-blob size)
+ (##sys#check-exact size 'make-blob)
+ (##sys#make-blob size) )
+
+(define (blob? x)
+ (and (##core#inline "C_blockp" x)
+ (##core#inline "C_bytevectorp" x) ) )
+
+(define (blob-size bv)
+ (##sys#check-blob bv 'blob-size)
+ (##sys#size bv) )
+
+(define (string->blob s)
+ (##sys#check-string s 'string->blob)
+ (let* ([n (##sys#size s)]
+ [bv (##sys#make-blob n)] )
+ (##core#inline "C_copy_memory" bv s n)
+ bv) )
+
+(define (blob->string bv)
+ (##sys#check-blob bv 'blob->string)
+ (let* ([n (##sys#size bv)]
+ [s (##sys#make-string n)] )
+ (##core#inline "C_copy_memory" s bv n)
+ s) )
+
+(define (blob=? b1 b2)
+ (##sys#check-blob b1 'blob=?)
+ (##sys#check-blob b2 'blob=?)
+ (let ((n (##sys#size b1)))
+ (and (eq? (##sys#size b2) n)
+ (zero? (##core#inline "C_string_compare" b1 b2 n)))))
+
+
+;;; Vectors:
+
+(define (vector? x) (##core#inline "C_i_vectorp" x))
+(define (vector-length v) (##core#inline "C_i_vector_length" v))
+(define (vector-ref v i) (##core#inline "C_i_vector_ref" v i))
+(define (vector-set! v i x) (##core#inline "C_i_vector_set" v i x))
+
+(define (##sys#make-vector size . fill)
+ (##sys#check-exact size 'make-vector)
+ (cond-expand [unsafe] [else (when (fx< size 0) (##sys#error 'make-vector "size is negative" size))])
+ (##sys#allocate-vector
+ size #f
+ (if (null? fill)
+ (##core#undefined)
+ (car fill) )
+ #f) )
+
+(define make-vector ##sys#make-vector)
+
+(define (list->vector lst0)
+ (cond-expand
+ [unsafe
+ (let* ([len (length lst0)]
+ [v (##sys#make-vector len)] )
+ (let loop ([lst lst0]
+ [i 0])
+ (if (null? lst)
+ v
+ (begin
+ (##sys#setslot v i (##sys#slot lst 0))
+ (loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) )]
+ [else
+ (if (not (list? lst0))
+ (##sys#error-not-a-proper-list lst0 'list->vector)
+ (let* ([len (length lst0)]
+ [v (##sys#make-vector len)] )
+ (let loop ([lst lst0]
+ [i 0])
+ (if (null? lst)
+ v
+ (begin
+ (##sys#setslot v i (##sys#slot lst 0))
+ (loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) ) )]
+ ))
+
+(define (vector->list v)
+ (##sys#check-vector v 'vector->list)
+ (let ((len (##core#inline "C_block_size" v)))
+ (let loop ((i 0))
+ (if (fx>= i len)
+ '()
+ (cons (##sys#slot v i)
+ (loop (fx+ i 1)) ) ) ) ) )
+
+(define (vector . xs)
+ (##sys#list->vector xs) )
+
+(define (vector-fill! v x)
+ (##sys#check-vector v 'vector-fill!)
+ (let ((len (##core#inline "C_block_size" v)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx>= i len))
+ (##sys#setslot v i x) ) ) )
+
+(define (vector-copy! from to . n)
+ (##sys#check-vector from 'vector-copy!)
+ (##sys#check-vector to 'vector-copy!)
+ (let* ([len-from (##sys#size from)]
+ [len-to (##sys#size to)]
+ [n (if (pair? n) (car n) (fxmin len-to len-from))] )
+ (##sys#check-exact n 'vector-copy!)
+ (cond-expand
+ [(not unsafe)
+ (when (or (fx> n len-to) (fx> n len-from))
+ (##sys#signal-hook
+ #:bounds-error 'vector-copy!
+ "cannot copy vector - count exceeds length" from to n) ) ]
+ [else] )
+ (do ([i 0 (fx+ i 1)])
+ ((fx>= i n))
+ (##sys#setslot to i (##sys#slot from i)) ) ) )
+
+(define (vector-resize v n #!optional init)
+ (##sys#check-vector v 'vector-resize)
+ (##sys#check-exact n 'vector-resize)
+ (##sys#grow-vector v n init) )
+
+(define (##sys#grow-vector v n init)
+ (let ([v2 (##sys#make-vector n init)]
+ [len (##sys#size v)] )
+ (do ([i 0 (fx+ i 1)])
+ ((fx>= i len) v2)
+ (##sys#setslot v2 i (##sys#slot v i)) ) ) )
+
+
+;;; Characters:
+
+(define (char? x) (##core#inline "C_charp" x))
+
+(define (char->integer c)
+ (##sys#check-char c 'char->integer)
+ (##core#inline "C_fix" (##core#inline "C_character_code" c)) )
+
+(define (integer->char n)
+ (##sys#check-exact n 'integer->char)
+ (##core#inline "C_make_character" (##core#inline "C_unfix" n)) )
+
+(define (char=? c1 c2)
+ (##sys#check-char c1 'char=?)
+ (##sys#check-char c2 'char=?)
+ (eq? c1 c2) )
+
+(define (char>? c1 c2)
+ (##sys#check-char c1 'char>?)
+ (##sys#check-char c2 'char>?)
+ (fx> c1 c2) )
+
+(define (char<? c1 c2)
+ (##sys#check-char c1 'char<?)
+ (##sys#check-char c2 'char<?)
+ (fx< c1 c2) )
+
+(define (char>=? c1 c2)
+ (##sys#check-char c1 'char>=?)
+ (##sys#check-char c2 'char>=?)
+ (fx>= c1 c2) )
+
+(define (char<=? c1 c2)
+ (##sys#check-char c1 'char<=?)
+ (##sys#check-char c2 'char<=?)
+ (fx<= c1 c2) )
+
+(define (char-upcase c)
+ (##sys#check-char c 'char-upcase)
+ (##core#inline "C_u_i_char_upcase" c))
+
+(define (char-downcase c)
+ (##sys#check-char c 'char-downcase)
+ (##core#inline "C_u_i_char_downcase" c))
+
+(define char-ci=?)
+(define char-ci>?)
+(define char-ci<?)
+(define char-ci>=?)
+(define char-ci<=?)
+
+(let ((char-downcase char-downcase))
+ (set! char-ci=? (lambda (x y) (eq? (char-downcase x) (char-downcase y))))
+ (set! char-ci>? (lambda (x y) (fx> (char-downcase x) (char-downcase y))))
+ (set! char-ci<? (lambda (x y) (fx< (char-downcase x) (char-downcase y))))
+ (set! char-ci>=? (lambda (x y) (fx>= (char-downcase x) (char-downcase y))))
+ (set! char-ci<=? (lambda (x y) (fx<= (char-downcase x) (char-downcase y)))) )
+
+(define (char-upper-case? c)
+ (##sys#check-char c 'char-upper-case?)
+ (##core#inline "C_u_i_char_upper_casep" c) )
+
+(define (char-lower-case? c)
+ (##sys#check-char c 'char-lower-case?)
+ (##core#inline "C_u_i_char_lower_casep" c) )
+
+(define (char-numeric? c)
+ (##sys#check-char c 'char-numeric?)
+ (##core#inline "C_u_i_char_numericp" c) )
+
+(define (char-whitespace? c)
+ (##sys#check-char c 'char-whitespace?)
+ (##core#inline "C_u_i_char_whitespacep" c) )
+
+(define (char-alphabetic? c)
+ (##sys#check-char c 'char-alphabetic?)
+ (##core#inline "C_u_i_char_alphabeticp" c) )
+
+(define char-name
+ (let ([chars-to-names (make-vector char-name-table-size '())]
+ [names-to-chars '()] )
+ (define (lookup-char c)
+ (let* ([code (char->integer c)]
+ [key (##core#inline "C_fixnum_modulo" code char-name-table-size)] )
+ (let loop ([b (##sys#slot chars-to-names key)])
+ (and (pair? b)
+ (let ([a (##sys#slot b 0)])
+ (if (eq? (##sys#slot a 0) c)
+ a
+ (loop (##sys#slot b 1)) ) ) ) ) ) )
+ (lambda (x . y)
+ (let ([chr (if (pair? y) (car y) #f)])
+ (cond [(char? x)
+ (and-let* ([a (lookup-char x)])
+ (##sys#slot a 1) ) ]
+ [chr
+ (##sys#check-symbol x 'char-name)
+ (##sys#check-char chr 'char-name)
+ (when (fx< (##sys#size (##sys#slot x 1)) 2)
+ (##sys#signal-hook #:type-error 'char-name "invalid character name" x) )
+ (let ([a (lookup-char chr)])
+ (if a
+ (let ([b (assq x names-to-chars)])
+ (##sys#setslot a 1 x)
+ (if b
+ (##sys#setislot b 1 chr)
+ (set! names-to-chars (cons (cons x chr) names-to-chars)) ) )
+ (let ([key (##core#inline "C_fixnum_modulo" (char->integer chr) char-name-table-size)])
+ (set! names-to-chars (cons (cons x chr) names-to-chars))
+ (##sys#setslot
+ chars-to-names key
+ (cons (cons chr x) (##sys#slot chars-to-names key))) ) ) ) ]
+ [else
+ (##sys#check-symbol x 'char-name)
+ (and-let* ([a (assq x names-to-chars)])
+ (##sys#slot a 1) ) ] ) ) ) ) )
+
+(char-name 'space #\space)
+(char-name 'tab #\tab)
+(char-name 'linefeed #\linefeed)
+(char-name 'newline #\newline)
+(char-name 'vtab (integer->char 11))
+(char-name 'delete (integer->char 127))
+(char-name 'esc (integer->char 27))
+(char-name 'alarm (integer->char 7))
+(char-name 'nul (integer->char 0))
+(char-name 'return #\return)
+(char-name 'page (integer->char 12))
+(char-name 'backspace (integer->char 8))
+
+
+;;; Procedures:
+
+(define (procedure? x) (##core#inline "C_i_closurep" x))
+(define apply (##core#primitive "C_apply"))
+(define ##sys#call-with-current-continuation (##core#primitive "C_call_cc"))
+(define (##sys#call-with-direct-continuation k) (##core#app k (##core#inline "C_direct_continuation" #f)))
+(define ##sys#call-with-cthulhu (##core#primitive "C_call_with_cthulhu"))
+(define (##sys#direct-return dk x) (##core#inline "C_direct_return" dk x))
+(define values (##core#primitive "C_values"))
+(define ##sys#call-with-values (##core#primitive "C_call_with_values"))
+(define call-with-values ##sys#call-with-values)
+
+(define (##sys#for-each p lst0)
+ (let loop ((lst lst0))
+ (cond-expand
+ [unsafe
+ (if (eq? lst '())
+ (##core#undefined)
+ (begin
+ (p (##sys#slot lst 0))
+ (loop (##sys#slot lst 1)) ) ) ]
+ [else
+ (cond ((eq? lst '()) (##core#undefined))
+ ((pair? lst)
+ (p (##sys#slot lst 0))
+ (loop (##sys#slot lst 1)) )
+ (else (##sys#error-not-a-proper-list lst0 'for-each)) ) ] ) ) )
+
+(define (##sys#map p lst0)
+ (let loop ((lst lst0))
+ (cond-expand
+ [unsafe
+ (if (eq? lst '())
+ lst
+ (cons (p (##sys#slot lst 0)) (loop (##sys#slot lst 1))) ) ]
+ [else
+ (cond ((eq? lst '()) lst)
+ ((pair? lst)
+ (cons (p (##sys#slot lst 0)) (loop (##sys#slot lst 1))) )
+ (else (##sys#error-not-a-proper-list lst0 'map)) ) ] ) ) )
+
+(define for-each)
+(define map)
+
+(let ([car car]
+ [cdr cdr] )
+ (letrec ((mapsafe
+ (lambda (p lsts start loc)
+ (if (eq? lsts '())
+ lsts
+ (let ((item (##sys#slot lsts 0)))
+ (cond ((eq? item '())
+ (cond-expand [unsafe (##core#undefined)]
+ [else (check lsts start loc)] ) )
+ ((pair? item)
+ (cons (p item) (mapsafe p (##sys#slot lsts 1) #f loc)) )
+ (else (##sys#error-not-a-proper-list item loc)) ) ) ) ) )
+ (check
+ (lambda (lsts start loc)
+ (if (or (not start)
+ (let loop ((lsts lsts))
+ (and (not (eq? lsts '()))
+ (not (eq? (##sys#slot lsts 0) '()))
+ (loop (##sys#slot lsts 1)) ) ) )
+ (##sys#error loc "lists are not of same length" lsts) ) ) ) )
+
+ (set! for-each
+ (lambda (fn lst1 . lsts)
+ (if (null? lsts)
+ (##sys#for-each fn lst1)
+ (let loop ((all (cons lst1 lsts)))
+ (let ((first (##sys#slot all 0)))
+ (cond ((pair? first)
+ (apply fn (mapsafe car all #t 'for-each))
+ (loop (mapsafe cdr all #t 'for-each)) )
+ (else (check all #t 'for-each)) ) ) ) ) ) )
+
+ (set! map
+ (lambda (fn lst1 . lsts)
+ (if (null? lsts)
+ (##sys#map fn lst1)
+ (let loop ((all (cons lst1 lsts)))
+ (let ((first (##sys#slot all 0)))
+ (cond ((pair? first)
+ (cons (apply fn (mapsafe car all #t 'map))
+ (loop (mapsafe cdr all #t 'map)) ) )
+ (else (check (##core#inline "C_i_cdr" all) #t 'map)
+ '() ) ) ) ) ) ) ) ) )
+
+
+;;; dynamic-wind:
+;
+; (taken more or less directly from SLIB)
+;
+; This implementation is relatively costly: we have to shadow call/cc
+; with a new version that unwinds suspended thunks, but for this to
+; happen the return-values of the escaping procedure have to be saved
+; temporarily in a list. Since call/cc is very efficient under this
+; implementation, and because allocation of memory that is to be
+; garbage soon has also quite low overhead, the performance-penalty
+; might be acceptable (ctak needs about 4 times longer).
+
+(define ##sys#dynamic-winds '())
+
+(define (dynamic-wind before thunk after)
+ (before)
+ (set! ##sys#dynamic-winds (cons (cons before after) ##sys#dynamic-winds))
+ (##sys#call-with-values
+ thunk
+ (lambda results
+ (set! ##sys#dynamic-winds (##sys#slot ##sys#dynamic-winds 1))
+ (after)
+ (apply ##sys#values results) ) ) )
+
+(define ##sys#dynamic-wind dynamic-wind)
+
+(define (call-with-current-continuation proc)
+ (let ((winds ##sys#dynamic-winds))
+ (##sys#call-with-current-continuation
+ (lambda (cont)
+ (proc
+ (lambda results
+ (unless (eq? ##sys#dynamic-winds winds)
+ (##sys#dynamic-unwind winds (fx- (length ##sys#dynamic-winds) (length winds))) )
+ (apply cont results) ) ) ) ) ) )
+
+(define call/cc call-with-current-continuation)
+
+(define (##sys#dynamic-unwind winds n)
+ (cond [(eq? ##sys#dynamic-winds winds)]
+ [(fx< n 0)
+ (##sys#dynamic-unwind (##sys#slot winds 1) (fx+ n 1))
+ ((##sys#slot (##sys#slot winds 0) 0))
+ (set! ##sys#dynamic-winds winds) ]
+ [else
+ (let ([after (##sys#slot (##sys#slot ##sys#dynamic-winds 0) 1)])
+ (set! ##sys#dynamic-winds (##sys#slot ##sys#dynamic-winds 1))
+ (after)
+ (##sys#dynamic-unwind winds (fx- n 1)) ) ] ) )
+
+(define (continuation-capture proc)
+ (let ([winds ##sys#dynamic-winds]
+ [k (##core#inline "C_direct_continuation" #f)] )
+ (proc (##sys#make-structure 'continuation k winds))) )
+
+(define (continuation? x)
+ (##sys#structure? x 'continuation) )
+
+(define ##sys#continuation-graft (##core#primitive "C_continuation_graft"))
+
+(define (continuation-graft k thunk)
+ (##sys#check-structure k 'continuation 'continuation-graft)
+ (let ([winds (##sys#slot k 2)])
+ (unless (eq? ##sys#dynamic-winds winds)
+ (##sys#dynamic-unwind winds (fx- (length ##sys#dynamic-winds) (length winds))) )
+ (##sys#continuation-graft k thunk) ) )
+
+(define continuation-return
+ (let ([continuation-graft continuation-graft])
+ (lambda (k . vals)
+ (##sys#check-structure k 'continuation 'continuation-return)
+ (continuation-graft k (lambda () (apply values vals))) ) ) )
+
+
+;;; Ports:
+
+(define (port? x) (##core#inline "C_i_portp" x))
+
+(define-inline (%port? x)
+ (and (##core#inline "C_blockp" x)
+ (##core#inline "C_portp" x)) )
+
+(define (input-port? x)
+ (and (%port? x)
+ (##sys#slot x 1) ) )
+
+(define (output-port? x)
+ (and (%port? x)
+ (not (##sys#slot x 1)) ) )
+
+;;; Port layout:
+;
+; 0: FP (special)
+; 1: input/output (bool)
+; 2: class (vector of procedures)
+; 3: name (string)
+; 4: row (fixnum)
+; 5: col (fixnum)
+; 6: EOF (bool)
+; 7: type ('stream | 'custom | 'string | 'socket)
+; 8: closed (bool)
+; 9: data
+; 10-15: reserved, port class specific
+;
+; Port-class:
+;
+; 0: (read-char PORT) -> CHAR | EOF
+; 1: (peek-char PORT) -> CHAR | EOF
+; 2: (write-char PORT CHAR)
+; 3: (write-string PORT STRING)
+; 4: (close PORT)
+; 5: (flush-output PORT)
+; 6: (char-ready? PORT) -> BOOL
+; 7: (read-string! PORT COUNT STRING START) -> COUNT'
+; 8: (read-line PORT LIMIT) -> STRING | EOF
+
+(define (##sys#make-port i/o class name type)
+ (let ([port (##core#inline_allocate ("C_a_i_port" 17))])
+ (##sys#setislot port 1 i/o)
+ (##sys#setslot port 2 class)
+ (##sys#setslot port 3 name)
+ (##sys#setislot port 4 1)
+ (##sys#setislot port 5 0)
+ (##sys#setslot port 7 type)
+ port) )
+
+;;; Stream ports:
+; Input port slots:
+; 12: Static buffer for read-line, allocated on-demand
+
+(define ##sys#stream-port-class
+ (vector (lambda (p) ; read-char
+ (##core#inline "C_read_char" p) )
+ (lambda (p) ; peek-char
+ (##core#inline "C_peek_char" p) )
+ (lambda (p c) ; write-char
+ (##core#inline "C_display_char" p c) )
+ (lambda (p s) ; write-string
+ (##core#inline "C_display_string" p s) )
+ (lambda (p) ; close
+ (##core#inline "C_close_file" p)
+ (##sys#update-errno) )
+ (lambda (p) ; flush-output
+ (##core#inline "C_flush_output" p) )
+ (lambda (p) ; char-ready?
+ (##core#inline "C_char_ready_p" p) )
+ (lambda (p n dest start) ; read-string!
+ (let loop ([rem (or n (fx- (##sys#size dest) start))] [act 0] [start start])
+ (let ([len (##core#inline "fast_read_string_from_file" dest p rem start)])
+ (cond [(or (not len) ; error returns EOF
+ (eof-object? len)) ; EOF returns 0 bytes read
+ act]
+ [(fx< len rem)
+ (loop (fx- rem len) (fx+ act len) (fx+ start len))]
+ [else
+ (fx+ act len) ] ) )))
+ (lambda (p limit) ; read-line
+ (if limit (##sys#check-exact limit 'read-line))
+ (let ((sblen read-line-buffer-initial-size))
+ (unless (##sys#slot p 12)
+ (##sys#setslot p 12 (##sys#make-string sblen)))
+ (let loop ([len sblen]
+ [limit (or limit maximal-string-length)] ; guaranteed fixnum?
+ [buffer (##sys#slot p 12)]
+ [result ""]
+ [f #f])
+ (let ([n (##core#inline "fast_read_line_from_file" buffer p
+ (fxmin limit len))])
+ (cond [(eof-object? n) (if f result #!eof)]
+ [(not n)
+ (if (fx< limit len)
+ (##sys#string-append result (##sys#substring buffer 0 limit))
+ (loop (fx* len 2)
+ (fx- limit len)
+ (##sys#make-string (fx* len 2))
+ (##sys#string-append result buffer)
+ #t)) ]
+ [f (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
+ (##sys#string-append result (##sys#substring buffer 0 n))]
+ [else
+ (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
+ (##sys#substring buffer 0 n)] ) ) ) ) )
+ ) )
+
+(define ##sys#open-file-port (##core#primitive "C_open_file_port"))
+
+(define ##sys#standard-input (##sys#make-port #t ##sys#stream-port-class "(stdin)" 'stream))
+(define ##sys#standard-output (##sys#make-port #f ##sys#stream-port-class "(stdout)" 'stream))
+(define ##sys#standard-error (##sys#make-port #f ##sys#stream-port-class "(stderr)" 'stream))
+
+(##sys#open-file-port ##sys#standard-input 0 #f)
+(##sys#open-file-port ##sys#standard-output 1 #f)
+(##sys#open-file-port ##sys#standard-error 2 #f)
+
+(define (##sys#check-port x . loc)
+ (unless (%port? x)
+ (##sys#signal-hook #:type-error (and (pair? loc) (car loc)) "argument is not a port" x) ) )
+
+(define (##sys#check-port-mode port mode . loc)
+ (unless (eq? mode (##sys#slot port 1))
+ (##sys#signal-hook
+ #:type-error (and (pair? loc) (car loc))
+ (if mode "port is not an input port" "port is not an output-port") port) ) )
+
+(define (##sys#check-port* p loc)
+ (##sys#check-port p)
+ (when (##sys#slot p 8)
+ (##sys#signal-hook #:file-error loc "port already closed" p) )
+ p )
+
+(define (current-input-port . arg)
+ (if (pair? arg)
+ (let ([p (car arg)])
+ (##sys#check-port p 'current-input-port)
+ (set! ##sys#standard-input p) )
+ ##sys#standard-input) )
+
+(define (current-output-port . arg)
+ (if (pair? arg)
+ (let ([p (car arg)])
+ (##sys#check-port p 'current-output-port)
+ (set! ##sys#standard-output p) )
+ ##sys#standard-output) )
+
+(define (current-error-port . arg)
+ (if (pair? arg)
+ (let ([p (car arg)])
+ (##sys#check-port p 'current-error-port)
+ (set! ##sys#standard-error p) )
+ ##sys#standard-error) )
+
+(define (##sys#tty-port? port)
+ (and (not (zero? (##sys#peek-unsigned-integer port 0)))
+ (##core#inline "C_tty_portp" port) ) )
+
+(define (##sys#port-data port) (##sys#slot port 9))
+(define (##sys#set-port-data! port data) (##sys#setslot port 9 data))
+
+(define ##sys#platform-fixup-pathname
+ (let* ([bp (string->symbol ((##core#primitive "C_build_platform")))]
+ [fixsuffix (eq? bp 'mingw32)])
+ (lambda (name)
+ (if fixsuffix
+ (let ([end (fx- (##sys#size name) 1)])
+ (if (fx>= end 0)
+ (let ([c (##core#inline "C_subchar" name end)])
+ (if (or (eq? c #\\) (eq? c #\/))
+ (##sys#substring name 0 end)
+ name) )
+ name) )
+ name) ) ) )
+
+(define (##sys#pathname-resolution name thunk . _)
+ (thunk (##sys#expand-home-path name)) )
+
+(define ##sys#expand-home-path
+ (let ((get-environment-variable get-environment-variable))
+ (lambda (path)
+ (let ((len (##sys#size path)))
+ (if (fx> len 0)
+ (case (##core#inline "C_subchar" path 0)
+ ((#\~)
+ (let ((rest (##sys#substring path 1 len)))
+ (##sys#string-append (or (get-environment-variable "HOME") "") rest) ) )
+ ((#\$)
+ (let loop ((i 1))
+ (if (fx>= i len)
+ path
+ (let ((c (##core#inline "C_subchar" path i)))
+ (if (or (eq? c #\/) (eq? c #\\))
+ (##sys#string-append
+ (or (get-environment-variable (##sys#substring path 1 i)) "")
+ (##sys#substring path i len))
+ (loop (fx+ i 1)) ) ) ) ) )
+ (else path) )
+ "") ) ) ) )
+
+(define open-input-file)
+(define open-output-file)
+(define close-input-port)
+(define close-output-port)
+
+(let ()
+
+ (define (open name inp modes loc)
+ (##sys#check-string name loc)
+ (##sys#pathname-resolution
+ name
+ (lambda (name)
+ (let ([fmode (if inp "r" "w")]
+ [bmode ""] )
+ (do ([modes modes (##sys#slot modes 1)])
+ ((null? modes))
+ (let ([o (##sys#slot modes 0)])
+ (case o
+ [(#:binary) (set! bmode "b")]
+ [(#:text) (set! bmode "")]
+ [(#:append)
+ (if inp
+ (##sys#error loc "cannot use append mode with input file")
+ (set! fmode "a") ) ]
+ [else (##sys#error loc "invalid file option" o)] ) ) )
+ (let ([port (##sys#make-port inp ##sys#stream-port-class name 'stream)])
+ (unless (##sys#open-file-port port name (##sys#string-append fmode bmode))
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error loc (##sys#string-append "cannot open file - " strerror) name) )
+ port) ) )
+ #:open (not inp) modes) )
+
+ (define (close port loc)
+ (##sys#check-port port loc)
+ (unless (##sys#slot port 8) ; closed?
+ ((##sys#slot (##sys#slot port 2) 4) port) ; close
+ (##sys#setislot port 8 #t) )
+ (##core#undefined) )
+
+ (set! open-input-file (lambda (name . mode) (open name #t mode 'open-input-file)))
+ (set! open-output-file (lambda (name . mode) (open name #f mode 'open-output-file)))
+ (set! close-input-port (lambda (port) (close port 'close-input-port)))
+ (set! close-output-port (lambda (port) (close port 'close-output-port))) )
+
+(define call-with-input-file
+ (let ([open-input-file open-input-file]
+ [close-input-port close-input-port] )
+ (lambda (name p . mode)
+ (let ([f (apply open-input-file name mode)])
+ (##sys#call-with-values
+ (lambda () (p f))
+ (lambda results
+ (close-input-port f)
+ (apply ##sys#values results) ) ) ) ) ) )
+
+(define call-with-output-file
+ (let ([open-output-file open-output-file]
+ [close-output-port close-output-port] )
+ (lambda (name p . mode)
+ (let ([f (apply open-output-file name mode)])
+ (##sys#call-with-values
+ (lambda () (p f))
+ (lambda results
+ (close-output-port f)
+ (apply ##sys#values results) ) ) ) ) ) )
+
+(define with-input-from-file
+ (let ((open-input-file open-input-file)
+ (close-input-port close-input-port) )
+ (lambda (str thunk . mode)
+ (let ((old ##sys#standard-input)
+ (file (apply open-input-file str mode)) )
+ (set! ##sys#standard-input file)
+ (##sys#call-with-values thunk
+ (lambda results
+ (close-input-port file)
+ (set! ##sys#standard-input old)
+ (apply ##sys#values results) ) ) ) ) ) )
+
+(define with-output-to-file
+ (let ((open-output-file open-output-file)
+ (close-output-port close-output-port) )
+ (lambda (str thunk . mode)
+ (let ((old ##sys#standard-output)
+ (file (apply open-output-file str mode)) )
+ (set! ##sys#standard-output file)
+ (##sys#call-with-values thunk
+ (lambda results
+ (close-output-port file)
+ (set! ##sys#standard-output old)
+ (apply ##sys#values results) ) ) ) ) ) )
+
+(define (file-exists? name)
+ (##sys#check-string name 'file-exists?)
+ (##sys#pathname-resolution
+ name
+ (lambda (name)
+ (and (##sys#file-info (##sys#platform-fixup-pathname name)) name) )
+ #:exists?) )
+
+(define (directory-exists? name)
+ (##sys#check-string name 'directory-exists?)
+ (##sys#pathname-resolution
+ name
+ (lambda (name)
+ (and-let* ((info (##sys#file-info (##sys#platform-fixup-pathname name))))
+ (eq? 1 (vector-ref info 4))
+ name))
+ #:exists?) )
+
+(define (##sys#flush-output port)
+ ((##sys#slot (##sys#slot port 2) 5) port) ; flush-output
+ (##core#undefined) )
+
+(define (flush-output #!optional (port ##sys#standard-output))
+ (##sys#check-port* port 'flush-output)
+ (##sys#check-port-mode port #f 'flush-output)
+ (##sys#flush-output port) )
+
+(define (port-name #!optional (port ##sys#standard-input))
+ (##sys#check-port port 'port-name)
+ (##sys#slot port 3) )
+
+(define (set-port-name! port name)
+ (##sys#check-port port 'set-port-name!)
+ (##sys#check-string name 'set-port-name!)
+ (##sys#setslot port 3 name) )
+
+(define (##sys#port-line port)
+ (and (##sys#slot port 1)
+ (##sys#slot port 4) ) )
+
+(define (port-position #!optional (port ##sys#standard-input))
+ (##sys#check-port port 'port-position)
+ (if (##sys#slot port 1)
+ (##sys#values (##sys#slot port 4) (##sys#slot port 5))
+ (##sys#error 'port-position "cannot compute position of port" port) ) )
+
+(define (delete-file filename)
+ (##sys#check-string filename 'delete-file)
+ (##sys#pathname-resolution
+ filename
+ (lambda (filename)
+ (unless (eq? 0 (##core#inline "C_delete_file" (##sys#make-c-string filename)))
+ (##sys#update-errno)
+ (##sys#signal-hook
+ #:file-error 'delete-file
+ (##sys#string-append "cannot delete file - " strerror) filename) ) )
+ #:delete) )
+
+(define (rename-file old new)
+ (##sys#check-string old 'rename-file)
+ (##sys#check-string new 'rename-file)
+ (##sys#pathname-resolution
+ old
+ (lambda (old)
+ (##sys#pathname-resolution
+ new
+ (lambda (new)
+ (unless (eq? 0 (##core#inline "C_rename_file" (##sys#make-c-string old) (##sys#make-c-string new)))
+ (##sys#update-errno)
+ (##sys#signal-hook
+ #:file-error 'rename-file
+ (##sys#string-append "cannot rename file - " strerror) old new) ) ) ) )
+ #:rename new) )
+
+
+;;; Parameters:
+
+(define ##sys#default-parameter-vector (##sys#make-vector default-parameter-vector-size))
+(define ##sys#current-parameter-vector '#())
+
+(define make-parameter
+ (let ([count 0])
+ (lambda (init . guard)
+ (let* ([guard (if (pair? guard) (car guard) (lambda (x) x))]
+ [val (guard init)]
+ [i count] )
+ (set! count (fx+ count 1))
+ (when (fx>= i (##sys#size ##sys#default-parameter-vector))
+ (set! ##sys#default-parameter-vector
+ (##sys#grow-vector ##sys#default-parameter-vector (fx+ i 1) (##core#undefined)) ) )
+ (##sys#setslot ##sys#default-parameter-vector i val)
+ (lambda arg
+ (let ([n (##sys#size ##sys#current-parameter-vector)])
+ (cond [(pair? arg)
+ (when (fx>= i n)
+ (set! ##sys#current-parameter-vector
+ (##sys#grow-vector ##sys#current-parameter-vector (fx+ i 1) ##sys#snafu) ) )
+ (##sys#setslot ##sys#current-parameter-vector i (guard (##sys#slot arg 0)))
+ (##core#undefined) ]
+ [(fx>= i n)
+ (##sys#slot ##sys#default-parameter-vector i) ]
+ [else
+ (let ([val (##sys#slot ##sys#current-parameter-vector i)])
+ (if (eq? val ##sys#snafu)
+ (##sys#slot ##sys#default-parameter-vector i)
+ val) ) ] ) ) ) ) ) ) )
+
+
+;;; Input:
+
+(define (eof-object? x) (##core#inline "C_eofp" x))
+
+(define (char-ready? #!optional (port ##sys#standard-input))
+ (##sys#check-port* port 'char-ready?)
+ (##sys#check-port-mode port #t 'char-ready?)
+ ((##sys#slot (##sys#slot port 2) 6) port) ) ; char-ready?
+
+(define (read-char #!optional (port ##sys#standard-input))
+ (##sys#read-char/port port) )
+
+(define (##sys#read-char-0 p)
+ (let ([c (if (##sys#slot p 6)
+ (begin
+ (##sys#setislot p 6 #f)
+ #!eof)
+ ((##sys#slot (##sys#slot p 2) 0) p) ) ] ) ; read-char
+ (cond [(eq? c #\newline)
+ (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
+ (##sys#setislot p 5 0) ]
+ [(not (##core#inline "C_eofp" c))
+ (##sys#setislot p 5 (fx+ (##sys#slot p 5) 1)) ] )
+ c) )
+
+(define (##sys#read-char/port port)
+ (##sys#check-port* port 'read-char)
+ (##sys#check-port-mode port #t 'read-char)
+ (##sys#read-char-0 port) )
+
+(define (##sys#peek-char-0 p)
+ (if (##sys#slot p 6)
+ #!eof
+ (let ([c ((##sys#slot (##sys#slot p 2) 1) p)]) ; peek-char
+ (when (##core#inline "C_eofp" c)
+ (##sys#setislot p 6 #t) )
+ c) ) )
+
+(define (peek-char #!optional (port ##sys#standard-input))
+ (##sys#check-port* port 'peek-char)
+ (##sys#check-port-mode port #t 'peek-char)
+ (##sys#peek-char-0 port) )
+
+(define (read #!optional (port ##sys#standard-input))
+ (##sys#check-port* port 'read)
+ (##sys#check-port-mode port #t 'read)
+ (##sys#read port ##sys#default-read-info-hook) )
+
+(define ##sys#default-read-info-hook #f)
+(define ##sys#read-error-with-line-number #f)
+(define ##sys#enable-qualifiers #t)
+(define (##sys#read-prompt-hook) #f) ; just here so that srfi-18 works without eval
+(define (##sys#infix-list-hook lst) lst)
+
+(define (##sys#sharp-number-hook port n)
+ (##sys#read-error port "invalid parameterized read syntax" n) )
+
+(define case-sensitive (make-parameter #t))
+(define keyword-style (make-parameter #:suffix))
+(define parentheses-synonyms (make-parameter #t))
+(define symbol-escape (make-parameter #t))
+
+(define current-read-table (make-parameter (##sys#make-structure 'read-table #f #f #f)))
+
+(define ##sys#read-warning
+ (let ([string-append string-append])
+ (lambda (port msg . args)
+ (apply
+ ##sys#warn
+ (let ((ln (##sys#port-line port)))
+ (if (and ##sys#read-error-with-line-number ln)
+ (string-append msg " in line " (##sys#number->string ln))
+ msg) )
+ args) ) ) )
+
+(define ##sys#read-error
+ (let ([string-append string-append] )
+ (lambda (port msg . args)
+ (apply
+ ##sys#signal-hook
+ #:syntax-error
+ (let ((ln (##sys#port-line port)))
+ (if (and ##sys#read-error-with-line-number ln)
+ (string-append msg " in line " (##sys#number->string ln))
+ msg) )
+ args) ) ) )
+
+(define ##sys#read
+ (let ([reverse reverse]
+ [list? list?]
+ [string-append string-append]
+ [string string]
+ [char-name char-name]
+ [csp case-sensitive]
+ [ksp keyword-style]
+ [psp parentheses-synonyms]
+ [sep symbol-escape]
+ [crt current-read-table]
+ [kwprefix (string (integer->char 0))])
+ (lambda (port infohandler)
+ (let ([csp (csp)]
+ [ksp (ksp)]
+ [psp (psp)]
+ [sep (sep)]
+ [crt (crt)]
+ [rat-flag #f]
+ ; set below - needs more state to make a decision
+ (terminating-characters '(#\, #\; #\( #\) #\' #\" #\[ #\] #\{ #\}))
+ [reserved-characters #f] )
+
+ (define (container c)
+ (##sys#read-error port "unexpected list terminator" c) )
+
+ (define (info class data val)
+ (if infohandler
+ (infohandler class data val)
+ data) )
+
+ (define (skip-to-eol)
+ (let skip ((c (##sys#read-char-0 port)))
+ (if (and (not (##core#inline "C_eofp" c)) (not (eq? #\newline c)))
+ (skip (##sys#read-char-0 port)) ) ) )
+
+ (define (reserved-character c)
+ (##sys#read-char-0 port)
+ (##sys#read-error port "reserved character" c) )
+
+ (define (read-unreserved-char-0 port)
+ (let ((c (##sys#read-char-0 port)))
+ (if (memq c reserved-characters)
+ (reserved-character c)
+ c) ) )
+
+ (define (readrec)
+
+ (define (r-spaces)
+ (let loop ([c (##sys#peek-char-0 port)])
+ (cond ((##core#inline "C_eofp" c))
+ ((eq? #\; c)
+ (skip-to-eol)
+ (loop (##sys#peek-char-0 port)) )
+ ((char-whitespace? c)
+ (##sys#read-char-0 port)
+ (loop (##sys#peek-char-0 port)) ) ) ) )
+
+ (define (r-usequence u n)
+ (let loop ([seq '()] [n n])
+ (if (eq? n 0)
+ (let* ([str (##sys#reverse-list->string seq)]
+ [n (string->number str 16)])
+ (or n
+ (##sys#read-error port (string-append "invalid escape-sequence '\\" u str "\'")) ) )
+ (let ([x (##sys#read-char-0 port)])
+ (if (or (eof-object? x) (char=? #\" x))
+ (##sys#read-error port "unterminated string constant")
+ (loop (cons x seq) (fx- n 1)) ) ) ) ) )
+
+ (define (r-cons-codepoint cp lst)
+ (let* ((s (##sys#char->utf8-string (integer->char cp)))
+ (len (##sys#size s)))
+ (let lp ((i 0) (lst lst))
+ (if (fx>= i len)
+ lst
+ (lp (fx+ i 1) (cons (##core#inline "C_subchar" s i) lst))))))
+
+ (define (r-string term)
+ (if (eq? (##sys#read-char-0 port) term)
+ (let loop ((c (##sys#read-char-0 port)) (lst '()))
+ (cond ((##core#inline "C_eofp" c)
+ (##sys#read-error port "unterminated string") )
+ ((eq? #\\ c)
+ (set! c (##sys#read-char-0 port))
+ (case c
+ ((#\t) (loop (##sys#read-char-0 port) (cons #\tab lst)))
+ ((#\r) (loop (##sys#read-char-0 port) (cons #\return lst)))
+ ((#\b) (loop (##sys#read-char-0 port) (cons #\backspace lst)))
+ ((#\n) (loop (##sys#read-char-0 port) (cons #\newline lst)))
+ ((#\a) (loop (##sys#read-char-0 port) (cons (integer->char 7) lst)))
+ ((#\v) (loop (##sys#read-char-0 port) (cons (integer->char 11) lst)))
+ ((#\f) (loop (##sys#read-char-0 port) (cons (integer->char 12) lst)))
+ ((#\x)
+ (let ([ch (integer->char (r-usequence "x" 2))])
+ (loop (##sys#read-char-0 port) (cons ch lst)) ) )
+ ((#\u)
+ (let ([n (r-usequence "u" 4)])
+ (if (##sys#unicode-surrogate? n)
+ (if (and (eqv? #\\ (##sys#read-char-0 port))
+ (eqv? #\u (##sys#read-char-0 port)))
+ (let* ((m (r-usequence "u" 4))
+ (cp (##sys#surrogates->codepoint n m)))
+ (if cp
+ (loop (##sys#read-char-0 port)
+ (r-cons-codepoint cp lst))
+ (##sys#read-error port "bad surrogate pair" n m)))
+ (##sys#read-error port "unpaired escaped surrogate" n))
+ (loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) ) ))
+ ((#\U)
+ (let ([n (r-usequence "U" 8)])
+ (if (##sys#unicode-surrogate? n)
+ (##sys#read-error port (string-append "invalid escape (surrogate)" n))
+ (loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) )))
+ ((#\\ #\' #\")
+ (loop (##sys#read-char-0 port) (cons c lst)))
+ (else
+ (##sys#read-warning
+ port
+ "undefined escape sequence in string - probably forgot backslash"
+ c)
+ (loop (##sys#read-char-0 port) (cons c lst))) ) )
+ ((eq? term c) (##sys#reverse-list->string lst))
+ (else (loop (##sys#read-char-0 port) (cons c lst))) ) )
+ (##sys#read-error port (string-append "missing `" (string term) "'")) ) )
+
+ (define (r-list start end)
+ (if (eq? (##sys#read-char-0 port) start)
+ (let ([first #f]
+ [ln0 #f]
+ [outer-container container] )
+ (##sys#call-with-current-continuation
+ (lambda (return)
+ (set! container
+ (lambda (c)
+ (if (eq? c end)
+ (return #f)
+ (##sys#read-error port "list-terminator mismatch" c end) ) ) )
+ (let loop ([last '()])
+ (r-spaces)
+ (unless first (set! ln0 (##sys#port-line port)))
+ (let ([c (##sys#peek-char-0 port)])
+ (cond ((##core#inline "C_eofp" c)
+ (##sys#read-error port "unterminated list") )
+ ((eq? c end)
+ (##sys#read-char-0 port) )
+ ((eq? c #\.)
+ (##sys#read-char-0 port)
+ (let ([c2 (##sys#peek-char-0 port)])
+ (cond [(or (char-whitespace? c2)
+ (eq? c2 #\()
+ (eq? c2 #\))
+ (eq? c2 #\")
+ (eq? c2 #\;) )
+ (unless (pair? last)
+ (##sys#read-error port "invalid use of `.'") )
+ (r-spaces)
+ (##sys#setslot last 1 (readrec))
+ (r-spaces)
+ (unless (eq? (##sys#read-char-0 port) end)
+ (##sys#read-error port "missing list terminator" end) ) ]
+ [else
+ (let* ((tok (##sys#string-append "." (r-token)))
+ (n (and (char-numeric? c2)
+ (##sys#string->number tok)))
+ (val (or n (resolve-symbol tok)))
+ (node (cons val '())) )
+ (if first
+ (##sys#setslot last 1 node)
+ (set! first node) )
+ (loop node) ) ] ) ) )
+ (else
+ (let ([node (cons (readrec) '())])
+ (if first
+ (##sys#setslot last 1 node)
+ (set! first node) )
+ (loop node) ) ) ) ) ) ) )
+ (set! container outer-container)
+ (if first
+ (info 'list-info (##sys#infix-list-hook first) ln0)
+ '() ) )
+ (##sys#read-error port "missing token" start) ) )
+
+ (define (r-vector)
+ (let ([lst (r-list #\( #\))])
+ (if (list? lst)
+ (##sys#list->vector lst)
+ (##sys#read-error port "invalid vector syntax" lst) ) ) )
+
+ (define (r-number radix)
+ (set! rat-flag #f)
+ (let ([tok (r-token)])
+ (if (string=? tok ".")
+ (##sys#read-error port "invalid use of `.'")
+ (let ([val (##sys#string->number tok (or radix 10))] )
+ (cond [val
+ (when (and (##sys#inexact? val) rat-flag)
+ (##sys#read-warning port "cannot represent exact fraction - coerced to flonum" tok) )
+ val]
+ [radix (##sys#read-error port "illegal number syntax" tok)]
+ [else (resolve-symbol tok)] ) ) ) ) )
+
+ (define (r-number-with-exactness radix)
+ (cond [(char=? #\# (##sys#peek-char-0 port))
+ (##sys#read-char-0 port)
+ (let ([c2 (##sys#read-char-0 port)])
+ (cond [(eof-object? c2) (##sys#read-error port "unexpected end of numeric literal")]
+ [(char=? c2 #\i) (##sys#exact->inexact (r-number radix))]
+ [(char=? c2 #\e) (##sys#inexact->exact (r-number radix))]
+ [else (##sys#read-error port "illegal number syntax - invalid exactness prefix" c2)] ) ) ]
+ [else (r-number radix)] ) )
+
+ (define (r-number-with-radix)
+ (cond [(char=? #\# (##sys#peek-char-0 port))
+ (##sys#read-char-0 port)
+ (let ([c2 (##sys#read-char-0 port)])
+ (cond [(eof-object? c2) (##sys#read-error port "unexpected end of numeric literal")]
+ [(char=? c2 #\x) (r-number 16)]
+ [(char=? c2 #\d) (r-number 10)]
+ [(char=? c2 #\o) (r-number 8)]
+ [(char=? c2 #\b) (r-number 2)]
+ [else (##sys#read-error port "illegal number syntax - invalid radix" c2)] ) ) ]
+ [else (r-number 10)] ) )
+
+ (define (r-token)
+ (let loop ([c (##sys#peek-char-0 port)] [lst '()])
+ (cond [(or (eof-object? c)
+ (char-whitespace? c)
+ (memq c terminating-characters) )
+ (##sys#reverse-list->string lst) ]
+ [else
+ (when (char=? c #\/) (set! rat-flag #t))
+ (read-unreserved-char-0 port)
+ (loop (##sys#peek-char-0 port)
+ (cons (if csp c (char-downcase c)) lst) ) ] ) ) )
+
+ (define (r-digits)
+ (let loop ((c (##sys#peek-char-0 port)) (lst '()))
+ (cond ((or (eof-object? c) (not (char-numeric? c)))
+ (##sys#reverse-list->string lst) )
+ (else
+ (##sys#read-char-0 port)
+ (loop (##sys#peek-char-0 port) (cons c lst)) ) ) ) )
+
+ (define (r-next-token)
+ (r-spaces)
+ (r-token) )
+
+ (define (r-symbol)
+ (let ((s (resolve-symbol
+ (if (char=? (##sys#peek-char-0 port) #\|)
+ (r-xtoken)
+ (r-token) ) ) ) )
+ (info 'symbol-info s (##sys#port-line port)) ) )
+
+ (define (r-xtoken)
+ (if (char=? #\| (read-unreserved-char-0 port))
+ (let loop ((c (##sys#read-char-0 port)) (lst '()))
+ (cond ((eof-object? c) (##sys#read-error port "unexpected end of `| ... |' symbol"))
+ ((char=? c #\\)
+ (let ((c (##sys#read-char-0 port)))
+ (loop (##sys#read-char-0 port) (cons c lst)) ) )
+ ((char=? c #\|)
+ (##sys#reverse-list->string lst) )
+ (else (loop (##sys#read-char-0 port) (cons c lst))) ) )
+ (##sys#read-error port "missing \'|\'") ) )
+
+ (define (r-char)
+ ;; Code contributed by Alex Shinn
+ (let* ([c (##sys#peek-char-0 port)]
+ [tk (r-token)]
+ [len (##sys#size tk)])
+ (cond [(fx> len 1)
+ (cond [(and (or (char=? #\x c) (char=? #\u c) (char=? #\U c))
+ (##sys#string->number (##sys#substring tk 1 len) 16) )
+ => (lambda (n) (integer->char n)) ]
+ [(and-let* ((c0 (char->integer (##core#inline "C_subchar" tk 0)))
+ ((fx<= #xC0 c0)) ((fx<= c0 #xF7))
+ (n0 (fxand (fxshr c0 4) 3))
+ (n (fx+ 2 (fxand (fxior n0 (fxshr n0 1)) (fx- n0 1))))
+ ((fx= len n))
+ (res (fx+ (fxshl (fxand c0 (fx- (fxshl 1 (fx- 8 n)) 1)) 6)
+ (fxand (char->integer
+ (##core#inline "C_subchar" tk 1))
+ #b111111))))
+ (cond ((fx>= n 3)
+ (set! res (fx+ (fxshl res 6)
+ (fxand
+ (char->integer
+ (##core#inline "C_subchar" tk 2))
+ #b111111)))
+ (if (fx= n 4)
+ (set! res (fx+ (fxshl res 6)
+ (fxand (char->integer
+ (##core#inline "C_subchar" tk 3))
+ #b111111))))))
+ (integer->char res))]
+ [(char-name (##sys#intern-symbol tk))]
+ [else (##sys#read-error port "unknown named character" tk)] ) ]
+ [(memq c terminating-characters) (##sys#read-char-0 port)]
+ [else c] ) ) )
+
+ (define (r-comment)
+ (let loop ((i 0))
+ (let ((c (##sys#read-char-0 port)))
+ (case c
+ ((#\|) (if (eq? #\# (##sys#read-char-0 port))
+ (if (not (eq? i 0))
+ (loop (fx- i 1)) )
+ (loop i) ) )
+ ((#\#) (loop (if (eq? #\| (##sys#read-char-0 port))
+ (fx+ i 1)
+ i) ) )
+ (else (if (eof-object? c)
+ (##sys#read-error port "unterminated block-comment")
+ (loop i) ) ) ) ) ) )
+
+ (define (r-ext-symbol)
+ (let* ([p (##sys#make-string 1)]
+ [tok (r-token)]
+ [toklen (##sys#size tok)] )
+ (unless ##sys#enable-qualifiers
+ (##sys#read-error port "qualified symbol syntax is not allowed" tok) )
+ (let loop ([i 0])
+ (cond [(fx>= i toklen)
+ (##sys#read-error port "invalid qualified symbol syntax" tok) ]
+ [(fx= (##sys#byte tok i) (char->integer #\#))
+ (when (fx> i namespace-max-id-len)
+ (set! tok (##sys#substring tok 0 namespace-max-id-len)) )
+ (##sys#setbyte p 0 i)
+ (##sys#intern-symbol
+ (string-append p (##sys#substring tok 0 i) (##sys#substring tok (fx+ i 1) toklen)) ) ]
+ [else (loop (fx+ i 1))] ) ) ) )
+
+ (define (resolve-symbol tok)
+ (let ([len (##sys#size tok)])
+ (cond [(and (fx> len 1)
+ (or (and (eq? ksp #:prefix)
+ (char=? #\: (##core#inline "C_subchar" tok 0))
+ (##sys#substring tok 1 len) )
+ (and (eq? ksp #:suffix)
+ (char=? #\: (##core#inline "C_subchar" tok (fx- len 1)))
+ (##sys#substring tok 0 (fx- len 1)) ) ) )
+ => build-keyword] ; ugh
+ [else (build-symbol tok)])))
+
+ (define (build-symbol tok)
+ (##sys#intern-symbol tok) )
+
+ (define (build-keyword tok)
+ (##sys#intern-symbol (##sys#string-append kwprefix tok)) )
+
+ ; now have the state to make a decision.
+ (set! reserved-characters
+ (if psp
+ (if sep
+ '()
+ '(#\[ #\] #\{ #\}) )
+ (if sep
+ '(#\|)
+ '(#\[ #\] #\{ #\} #\|))))
+
+ (r-spaces)
+ (let* ([c (##sys#peek-char-0 port)]
+ [srst (##sys#slot crt 1)]
+ [h (and srst (##sys#slot srst (char->integer c)) ) ] )
+ (if h
+ ;then handled by read-table entry
+ (h c port)
+ ;otherwise chicken extended r5rs syntax
+ (case c
+ ((#\')
+ (##sys#read-char-0 port)
+ (list 'quote (readrec)) )
+ ((#\`)
+ (##sys#read-char-0 port)
+ (list 'quasiquote (readrec)) )
+ ((#\,)
+ (##sys#read-char-0 port)
+ (cond ((eq? (##sys#peek-char-0 port) #\@)
+ (##sys#read-char-0 port)
+ (list 'unquote-splicing (readrec)) )
+ (else (list 'unquote (readrec))) ) )
+ ((#\#)
+ (##sys#read-char-0 port)
+ (let ((dchar (##sys#peek-char-0 port)))
+ (if (char-numeric? dchar)
+ (let* ((n (string->number (r-digits)))
+ (dchar (##sys#peek-char-0 port))
+ (spdrst (##sys#slot crt 3))
+ (h (and spdrst (##sys#slot spdrst (char->integer dchar)) ) ) )
+ ;#<num> handled by parameterized # read-table entry?
+ (cond (h (h dchar port n))
+ ;#<num>?
+ ((or (eq? dchar #\)) (char-whitespace? dchar)) (##sys#sharp-number-hook port n))
+ (else (##sys#read-error port "invalid parameterized read syntax" dchar n) ) ) )
+ (let* ((sdrst (##sys#slot crt 2))
+ (h (and sdrst (##sys#slot sdrst (char->integer dchar)) ) ) )
+ (if h
+ ;then handled by # read-table entry
+ (h dchar port)
+ ;otherwise chicken extended r5rs syntax
+ (case (char-downcase dchar)
+ ((#\x) (##sys#read-char-0 port) (r-number-with-exactness 16))
+ ((#\d) (##sys#read-char-0 port) (r-number-with-exactness 10))
+ ((#\o) (##sys#read-char-0 port) (r-number-with-exactness 8))
+ ((#\b) (##sys#read-char-0 port) (r-number-with-exactness 2))
+ ((#\i) (##sys#read-char-0 port) (##sys#exact->inexact (r-number-with-radix)))
+ ((#\e) (##sys#read-char-0 port) (##sys#inexact->exact (r-number-with-radix)))
+ ((#\c)
+ (##sys#read-char-0 port)
+ (let ([c (##sys#read-char-0 port)])
+ (fluid-let ([csp
+ (cond [(eof-object? c)
+ (##sys#read-error port "unexpected end of input while reading `#c...' sequence")]
+ [(eq? c #\i) #f]
+ [(eq? c #\s) #t]
+ [else (##sys#read-error port "invalid case specifier in `#c...' sequence" c)] ) ] )
+ (readrec) ) ) )
+ ((#\() (r-vector))
+ ((#\\) (##sys#read-char-0 port) (r-char))
+ ((#\|)
+ (##sys#read-char-0 port)
+ (r-comment) (readrec) )
+ ((#\#)
+ (##sys#read-char-0 port)
+ (r-ext-symbol) )
+ ((#\;)
+ (##sys#read-char-0 port)
+ (readrec) (readrec) )
+ ((#\')
+ (##sys#read-char-0 port)
+ (list 'syntax (readrec)) )
+ ((#\`)
+ (##sys#read-char-0 port)
+ (list 'quasisyntax (readrec)) )
+ ((#\$)
+ (##sys#read-char-0 port)
+ (list 'location (readrec)) )
+ ((#\:)
+ (##sys#read-char-0 port)
+ (build-keyword (r-token)) )
+ ((#\%)
+ (build-symbol (##sys#string-append "#" (r-token))) )
+ ((#\+)
+ (##sys#read-char-0 port)
+ (let ((tst (readrec)))
+ (list 'cond-expand (list tst (readrec)) '(else)) ) )
+ ((#\!)
+ (##sys#read-char-0 port)
+ (let ((c (##sys#peek-char-0 port)))
+ (cond ((or (char-whitespace? c) (char=? #\/ c))
+ (skip-to-eol)
+ (readrec) )
+ (else
+ (let ([tok (r-token)])
+ (cond [(string=? "eof" tok) #!eof]
+ [(member tok '("optional" "rest" "key"))
+ (build-symbol (##sys#string-append "#!" tok)) ]
+ [(string=? "current-line" tok)
+ (##sys#slot port 4)]
+ [(string=? "current-file" tok)
+ (port-name port)]
+ [else
+ (let ((a (assq (string->symbol tok) read-marks)))
+ (if a
+ ((##sys#slot a 1) port)
+ (##sys#read-error port "invalid `#!' token" tok) ) ) ] ) ) ) ) ) )
+ (else (##sys#user-read-hook dchar port)) ) ) ) ) ) )
+ ((#\( #;#\)) (r-list #\( #\)))
+ ((#;#\( #\)) (##sys#read-char-0 port) (container c))
+ ((#\") (r-string #\"))
+ ((#\.) (r-number #f))
+ ((#\- #\+) (r-number #f))
+ (else
+ (cond [(eof-object? c) c]
+ [(char-numeric? c) (r-number #f)]
+ ((memq c reserved-characters)
+ (reserved-character c))
+ (else
+ (case c
+ ((#\[ #;#\]) (r-list #\[ #\]))
+ ((#\{ #;#\}) (r-list #\{ #\}))
+ ((#;#\[ #\] #;#\{ #\}) (##sys#read-char-0 port) (container c))
+ (else (r-symbol) ) ) ) ) ) ) ) ) )
+
+ (readrec) ) ) ) )
+
+
+;;; This is taken from Alex Shinn's UTF8 egg:
+
+(define (##sys#char->utf8-string c)
+ (let ([i (char->integer c)])
+ (cond [(fx<= i #x7F)
+ (string c) ]
+ [(fx<= i #x7FF)
+ (string (integer->char (fxior #b11000000 (fxshr i 6)))
+ (integer->char (fxior #b10000000 (fxand i #b111111)))) ]
+ [(fx<= i #xFFFF)
+ (string (integer->char (fxior #b11100000 (fxshr i 12)))
+ (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
+ (integer->char (fxior #b10000000 (fxand i #b111111)))) ]
+ [(fx<= i #x1FFFFF)
+ (string (integer->char (fxior #b11110000 (fxshr i 18)))
+ (integer->char (fxior #b10000000 (fxand (fxshr i 12) #b111111)))
+ (integer->char (fxior #b10000000 (fxand (fxshr i 6) #b111111)))
+ (integer->char (fxior #b10000000 (fxand i #b111111)))) ]
+ [else
+ (error "UTF-8 codepoint out of range:" i) ] ) ) )
+
+(define (##sys#unicode-surrogate? n)
+ (and (fx<= #xD800 n) (fx<= n #xDFFF)) )
+
+;; returns #f if the inputs are not a valid surrogate pair (hi followed by lo)
+(define (##sys#surrogates->codepoint hi lo)
+ (and (fx<= #xD800 hi) (fx<= hi #xDBFF)
+ (fx<= #xDC00 lo) (fx<= lo #xDFFF)
+ (fxior (fxshl (fx+ 1 (fxand (fxshr hi 6) #b11111)) 16)
+ (fxior (fxshl (fxand hi #b111111) 10)
+ (fxand lo #b1111111111)))) )
+
+;;; Hooks for user-defined read-syntax:
+;
+; - Redefine this to handle new read-syntaxes. If 'char' doesn't match
+; your character then call the previous handler.
+; - Don't forget to read 'char', it's only peeked at this point.
+
+(define (##sys#user-read-hook char port)
+ (case char
+ ;; I put it here, so the SRFI-4 unit can intercept '#f...'
+ [(#\f #\F) (##sys#read-char-0 port) #f ]
+ [(#\t #\T) (##sys#read-char-0 port) #t ]
+ [else (##sys#read-error port "invalid sharp-sign read syntax" char) ] ) )
+
+
+;;; Table for specially handled read-syntax:
+;
+; - should be either #f or a 256-element vector containing procedures
+; - the procedure is called with two arguments, a char (peeked) and a port and should return an expression
+
+(define read-marks '())
+
+(define (##sys#set-read-mark! sym proc)
+ (let ((a (assq sym read-marks)))
+ (if a
+ (##sys#setslot a 1 proc)
+ (set! read-marks (cons (cons sym proc) read-marks)) ) ) )
+
+(define set-read-syntax!)
+(define set-sharp-read-syntax!)
+(define set-parameterized-read-syntax!)
+
+(let ((crt current-read-table))
+
+ (define ((syntax-setter loc slot wrap) chr proc)
+ (cond ((symbol? chr) (##sys#set-read-mark! chr proc))
+ (else
+ (let ((crt (crt)))
+ (unless (##sys#slot crt slot)
+ (##sys#setslot crt slot (##sys#make-vector 256 #f)) )
+ (##sys#check-char chr loc)
+ (let ([i (char->integer chr)])
+ (##sys#check-range i 0 256 loc)
+ (##sys#setslot (##sys#slot crt slot) i (wrap proc)) ) ) ) ) )
+
+ (set! set-read-syntax!
+ (syntax-setter
+ 'set-read-syntax! 1
+ (lambda (proc)
+ (lambda (_ port)
+ (##sys#read-char-0 port)
+ (proc port) ) ) ) )
+
+ (set! set-sharp-read-syntax!
+ (syntax-setter
+ 'set-sharp-read-syntax! 2
+ (lambda (proc)
+ (lambda (_ port)
+ (##sys#read-char-0 port)
+ (proc port) ) ) ) )
+
+ (set! set-parameterized-read-syntax!
+ (syntax-setter
+ 'set-parameterized-read-syntax! 3
+ (lambda (proc)
+ (lambda (_ port num)
+ (##sys#read-char-0 port)
+ (proc port num) ) ) ) ) )
+
+
+;;; Read-table operations:
+
+(define (copy-read-table rt)
+ (##sys#check-structure rt 'read-table 'copy-read-table)
+ (##sys#make-structure
+ 'read-table
+ (let ((t1 (##sys#slot rt 1)))
+ (and t1 (##sys#grow-vector t1 (##sys#size t1) #f) ) )
+ (let ((t2 (##sys#slot rt 2)))
+ (and t2 (##sys#grow-vector t2 (##sys#size t2) #f) ) )
+ (let ((t3 (##sys#slot rt 3)))
+ (and t3 (##sys#grow-vector t3 (##sys#size t3) #f) ) ) ))
+
+
+;;; Output:
+
+(define (##sys#write-char-0 c p)
+ ((##sys#slot (##sys#slot p 2) 2) p c) )
+
+(define (##sys#write-char/port c port)
+ (##sys#check-port* port 'write-char)
+ (##sys#check-char c 'write-char)
+ (##sys#write-char-0 c port) )
+
+(define (write-char c #!optional (port ##sys#standard-output))
+ (##sys#check-char c 'write-char)
+ (##sys#check-port* port 'write-char)
+ (##sys#check-port-mode port #f 'write-char)
+ (##sys#write-char-0 c port) )
+
+(define (newline #!optional (port ##sys#standard-output))
+ (##sys#write-char/port #\newline port) )
+
+(define (write x #!optional (port ##sys#standard-output))
+ (##sys#check-port* port 'write)
+ (##sys#print x #t port) )
+
+(define (display x #!optional (port ##sys#standard-output))
+ (##sys#check-port* port 'display)
+ (##sys#print x #f port) )
+
+(define-inline (*print-each lst)
+ (for-each (cut ##sys#print <> #f ##sys#standard-output) lst) )
+
+(define (print . args)
+ (*print-each args)
+ (##sys#write-char-0 #\newline ##sys#standard-output)
+ (void) )
+
+(define (print* . args)
+ (*print-each args)
+ (##sys#flush-output ##sys#standard-output)
+ (void) )
+
+(define current-print-length (make-parameter 0))
+(define print-length-limit (make-parameter #f))
+(define ##sys#print-exit (make-parameter #f))
+
+(define ##sys#print
+ (let ([char-name char-name]
+ [csp case-sensitive]
+ [ksp keyword-style]
+ [cpp current-print-length]
+ [string-append string-append])
+ (lambda (x readable port)
+ (##sys#check-port-mode port #f)
+ (let ([csp (csp)]
+ [ksp (ksp)]
+ [length-limit (print-length-limit)]
+ [special-characters '(#\( #\) #\, #\[ #\] #\{ #\} #\' #\" #\; #\ #\` #\|)] )
+
+ (define (outstr port str)
+ (if length-limit
+ (let* ((len (##sys#size str))
+ (cpp0 (cpp))
+ (cpl (fx+ cpp0 len)) )
+ (if (fx>= cpl length-limit)
+ (cond ((fx> len 3)
+ (let ((n (fx- length-limit cpp0)))
+ (when (fx> n 0) (outstr0 port (##sys#substring str 0 n)))
+ (outstr0 port "...") ) )
+ (else (outstr0 port str)) )
+ (outstr0 port str) )
+ (cpp cpl) )
+ (outstr0 port str) ) )
+
+ (define (outstr0 port str)
+ ((##sys#slot (##sys#slot port 2) 3) port str) )
+
+ (define (outchr port chr)
+ (let ((cpp0 (cpp)))
+ (cpp (fx+ cpp0 1))
+ (when (and length-limit (fx>= cpp0 length-limit))
+ (outstr0 port "...")
+ ((##sys#print-exit) #t) )
+ ((##sys#slot (##sys#slot port 2) 2) port chr) ) )
+
+ (define (specialchar? chr)
+ (let ([c (char->integer chr)])
+ (or (fx<= c 32)
+ (fx>= c 128)
+ (memq chr special-characters) ) ) )
+
+ (define (outreadablesym port str)
+ (let ([len (##sys#size str)])
+ (outchr port #\|)
+ (let loop ([i 0])
+ (if (fx>= i len)
+ (outchr port #\|)
+ (let ([c (##core#inline "C_subchar" str i)])
+ (when (or (eq? c #\|) (eq? c #\\)) (outchr port #\\))
+ (outchr port c)
+ (loop (fx+ i 1)) ) ) ) ) )
+
+ (define (sym-is-readable? str)
+ (let ([len (##sys#size str)])
+ (and (fx> len 0)
+ (if (eq? len 1)
+ (case (##core#inline "C_subchar" str 0)
+ ((#\. #\#) #f)
+ (else #t) ) )
+ (not (##core#inline "C_substring_compare" "#!" str 0 0 2))
+ (let loop ((i (fx- len 1)))
+ (if (eq? i 0)
+ (let ((c (##core#inline "C_subchar" str 0)))
+ (cond ((or (char-numeric? c)
+ (eq? c #\+)
+ (eq? c #\-)
+ (eq? c #\.) )
+ (not (##sys#string->number str)) )
+ ((specialchar? c) #f)
+ (else #t) ) )
+ (let ([c (##core#inline "C_subchar" str i)])
+ (and (or csp (not (char-upper-case? c)))
+ (not (specialchar? c))
+ (loop (fx- i 1)) ) ) ) ) ) ) )
+
+ (let out ([x x])
+ (cond ((eq? x '()) (outstr port "()"))
+ ((eq? x #t) (outstr port "#t"))
+ ((eq? x #f) (outstr port "#f"))
+ ((##core#inline "C_eofp" x) (outstr port "#!eof"))
+ ((##core#inline "C_undefinedp" x) (outstr port "#<unspecified>"))
+ ((##core#inline "C_charp" x)
+ (cond [readable
+ (outstr port "#\\")
+ (let ([code (char->integer x)])
+ (cond [(char-name x)
+ => (lambda (cn)
+ (outstr port (##sys#slot cn 1)) ) ]
+ [(fx< code 32)
+ (outchr port #\x)
+ (outstr port (##sys#number->string code 16)) ]
+ [(fx> code 255)
+ (outchr port (if (fx> code #xffff) #\U #\u))
+ (outstr port (##sys#number->string code 16)) ]
+ [else (outchr port x)] ) ) ]
+ [else (outchr port x)] ) )
+ ((##core#inline "C_fixnump" x) (outstr port (##sys#number->string x)))
+ ((eq? x (##sys#slot '##sys#arbitrary-unbound-symbol 0))
+ (outstr port "#<unbound value>") )
+ ((not (##core#inline "C_blockp" x)) (outstr port "#<invalid immediate object>"))
+ ((##core#inline "C_forwardedp" x) (outstr port "#<invalid forwarded object>"))
+ ((##core#inline "C_symbolp" x)
+ (cond [(fx= 0 (##sys#byte (##sys#slot x 1) 0))
+ (let ([str (##sys#symbol->string x)])
+ (case ksp
+ [(#:prefix)
+ (outchr port #\:)
+ (outstr port str) ]
+ [(#:suffix)
+ (outstr port str)
+ (outchr port #\:) ]
+ [else
+ (outstr port "#:")
+ (outstr port str) ] ) ) ]
+ [(memq x '(#!optional #!key #!rest)) (outstr port (##sys#slot x 1))]
+ [else
+ (let ([str (##sys#symbol->qualified-string x)])
+ (if (or (not readable) (sym-is-readable? str))
+ (outstr port str)
+ (outreadablesym port str) ) ) ] ) )
+ ((##sys#number? x) (outstr port (##sys#number->string x)))
+ ((##core#inline "C_anypointerp" x) (outstr port (##sys#pointer->string x)))
+ ((##core#inline "C_stringp" x)
+ (cond (readable
+ (outchr port #\")
+ (do ((i 0 (fx+ i 1))
+ (c (##core#inline "C_block_size" x) (fx- c 1)) )
+ ((eq? c 0)
+ (outchr port #\") )
+ (let ((chr (##core#inline "C_subbyte" x i)))
+ (case chr
+ ((34) (outstr port "\\\""))
+ ((92) (outstr port "\\\\"))
+ (else
+ (cond ((fx< chr 32)
+ (outchr port #\\)
+ (case chr
+ ((9) (outchr port #\t))
+ ((10) (outchr port #\n))
+ ((13) (outchr port #\r))
+ ((11) (outchr port #\v))
+ ((12) (outchr port #\f))
+ ((8) (outchr port #\b))
+ (else
+ (outchr port #\x)
+ (when (fx< chr 16) (outchr port #\0))
+ (outstr port (##sys#number->string chr 16)) ) ) )
+ (else (outchr port (##core#inline "C_fix_to_char" chr)) ) ) ) ) ) ) )
+ (else (outstr port x)) ) )
+ ((##core#inline "C_pairp" x)
+ (outchr port #\()
+ (out (##sys#slot x 0))
+ (do ((x (##sys#slot x 1) (##sys#slot x 1)))
+ ((or (not (##core#inline "C_blockp" x)) (not (##core#inline "C_pairp" x)))
+ (if (not (eq? x '()))
+ (begin
+ (outstr port " . ")
+ (out x) ) )
+ (outchr port #\)) )
+ (outchr port #\space)
+ (out (##sys#slot x 0)) ) )
+ ((##core#inline "C_bytevectorp" x)
+ (if (##core#inline "C_permanentp" x)
+ (outstr port "#<static blob of size")
+ (outstr port "#<blob of size ") )
+ (outstr port (number->string (##core#inline "C_block_size" x)))
+ (outchr port #\>) )
+ ((##core#inline "C_structurep" x) (##sys#user-print-hook x readable port))
+ ((##core#inline "C_closurep" x) (outstr port (##sys#procedure->string x)))
+ ((##core#inline "C_locativep" x) (outstr port "#<locative>"))
+ ((##core#inline "C_lambdainfop" x)
+ (outstr port "#<lambda info ")
+ (outstr port (##sys#lambda-info->string x))
+ (outchr port #\>) )
+ ((##core#inline "C_portp" x)
+ (if (##sys#slot x 1)
+ (outstr port "#<input port \"")
+ (outstr port "#<output port \"") )
+ (outstr port (##sys#slot x 3))
+ (outstr port "\">") )
+ ((##core#inline "C_vectorp" x)
+ (let ((n (##core#inline "C_block_size" x)))
+ (cond ((eq? 0 n)
+ (outstr port "#()") )
+ (else
+ (outstr port "#(")
+ (out (##sys#slot x 0))
+ (do ((i 1 (fx+ i 1))
+ (c (fx- n 1) (fx- c 1)) )
+ ((eq? c 0)
+ (outchr port #\)) )
+ (outchr port #\space)
+ (out (##sys#slot x i)) ) ) ) ) )
+ (else (##sys#error "unprintable non-immediate object encountered")) ) ) ) ) ) )
+
+(define ##sys#procedure->string
+ (let ((string-append string-append))
+ (lambda (x)
+ (let ((info (##sys#lambda-info x)))
+ (if info
+ (string-append "#<procedure " (##sys#lambda-info->string info) ">")
+ "#<procedure>") ) ) ) )
+
+(define ##sys#record-printers '())
+
+(define (##sys#register-record-printer type proc)
+ (let ([a (assq type ##sys#record-printers)])
+ (if a
+ (##sys#setslot a 1 proc)
+ (set! ##sys#record-printers (cons (cons type proc) ##sys#record-printers)) )
+ (##core#undefined) ) )
+
+(define (##sys#user-print-hook x readable port)
+ (let* ([type (##sys#slot x 0)]
+ [a (assq type ##sys#record-printers)] )
+ (cond [a ((##sys#slot a 1) x port)]
+ [else
+ (##sys#print "#<" #f port)
+ (##sys#print (##sys#symbol->string type) #f port)
+ (case type
+ [(condition)
+ (##sys#print ": " #f port)
+ (##sys#print (##sys#slot x 1) #f port) ]
+ [(thread)
+ (##sys#print ": " #f port)
+ (##sys#print (##sys#slot x 6) #f port) ] )
+ (##sys#print #\> #f port) ] ) ) )
+
+(define ##sys#with-print-length-limit
+ (let ([call-with-current-continuation call-with-current-continuation])
+ (lambda (limit thunk)
+ (call-with-current-continuation
+ (lambda (return)
+ (parameterize ((print-length-limit limit)
+ (##sys#print-exit return)
+ (current-print-length 0))
+ (thunk)))))))
+
+
+;;; Bitwise fixnum operations:
+
+(define (bitwise-and . xs)
+ (let loop ([x -1] [xs xs])
+ (if (null? xs)
+ x
+ (loop (##core#inline_allocate ("C_a_i_bitwise_and" 4) x (##sys#slot xs 0))
+ (##sys#slot xs 1)) ) ) )
+
+(define (bitwise-ior . xs)
+ (let loop ([x 0] [xs xs])
+ (if (null? xs)
+ x
+ (loop (##core#inline_allocate ("C_a_i_bitwise_ior" 4) x (##sys#slot xs 0))
+ (##sys#slot xs 1)) ) ) )
+
+(define (bitwise-xor . xs)
+ (let loop ([x 0] [xs xs])
+ (if (null? xs)
+ x
+ (loop (##core#inline_allocate ("C_a_i_bitwise_xor" 4) x (##sys#slot xs 0))
+ (##sys#slot xs 1)) ) ) )
+
+(define (bitwise-not x)
+ (##core#inline_allocate ("C_a_i_bitwise_not" 4) x) )
+
+(define (arithmetic-shift x y)
+ (##core#inline_allocate ("C_a_i_arithmetic_shift" 4) x y) )
+
+(define (bit-set? n i)
+ (##core#inline "C_i_bit_setp" n i) )
+
+
+;;; String ports:
+;
+; - Port-slots:
+;
+; Input:
+;
+; 10: position
+; 11: len
+; 12: string
+;
+; Output:
+;
+; 10: position
+; 11: limit
+; 12: output
+
+(define ##sys#string-port-class
+ (letrec ([check
+ (lambda (p n)
+ (let* ([position (##sys#slot p 10)]
+ [limit (##sys#slot p 11)]
+ [output (##sys#slot p 12)]
+ [limit2 (fx+ position n)] )
+ (when (fx>= limit2 limit)
+ (when (fx>= limit2 maximal-string-length)
+ (##sys#error "string buffer full" p) )
+ (let* ([limit3 (fxmin maximal-string-length (fx+ limit limit))]
+ [buf (##sys#make-string limit3)] )
+ (##sys#copy-bytes output buf 0 0 position)
+ (##sys#setslot p 12 buf)
+ (##sys#setislot p 11 limit3)
+ (check p n) ) ) ) ) ] )
+ (vector
+ (lambda (p) ; read-char
+ (let ([position (##sys#slot p 10)]
+ [string (##sys#slot p 12)]
+ [len (##sys#slot p 11)] )
+ (if (>= position len)
+ #!eof
+ (let ((c (##core#inline "C_subchar" string position)))
+ (##sys#setislot p 10 (fx+ position 1))
+ c) ) ) )
+ (lambda (p) ; peek-char
+ (let ([position (##sys#slot p 10)]
+ [string (##sys#slot p 12)]
+ [len (##sys#slot p 11)] )
+ (if (fx>= position len)
+ #!eof
+ (##core#inline "C_subchar" string position) ) ) )
+ (lambda (p c) ; write-char
+ (check p 1)
+ (let ([position (##sys#slot p 10)]
+ [output (##sys#slot p 12)] )
+ (##core#inline "C_setsubchar" output position c)
+ (##sys#setislot p 10 (fx+ position 1)) ) )
+ (lambda (p str) ; write-string
+ (let ([len (##core#inline "C_block_size" str)])
+ (check p len)
+ (let ([position (##sys#slot p 10)]
+ [output (##sys#slot p 12)] )
+ (##core#inline "C_substring_copy" str output 0 len position)
+ (##sys#setislot p 10 (fx+ position len)) ) ) )
+ (lambda (p) ; close
+ (##sys#setislot p 10 (##sys#slot p 11)) )
+ (lambda (p) #f) ; flush-output
+ (lambda (p) ; char-ready?
+ (fx< (##sys#slot p 10) (##sys#slot p 11)) )
+ (lambda (p n dest start) ; read-string!
+ (let* ((pos (##sys#slot p 10))
+ (n2 (fx- (##sys#slot p 11) pos) ) )
+ (when (or (not n) (fx> n n2)) (set! n n2))
+ (##core#inline "C_substring_copy" (##sys#slot p 12) dest pos (fx+ pos n) start)
+ (##sys#setislot p 10 (fx+ pos n))
+ n))
+ (lambda (p limit) ; read-line
+ (let* ((pos (##sys#slot p 10))
+ (size (##sys#slot p 11))
+ (buf (##sys#slot p 12))
+ (end (if limit (fx+ pos limit) size)))
+ (if (fx>= pos size)
+ #!eof
+ (##sys#scan-buffer-line
+ buf
+ (if (fx> end size) size end)
+ pos
+ (lambda (pos2 next)
+ (when (not (eq? pos2 next))
+ (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1)) )
+ (let ((dest (##sys#make-string (fx- pos2 pos))))
+ (##core#inline "C_substring_copy" buf dest pos pos2 0)
+ (##sys#setislot p 10 next)
+ dest) ) ) ) ) ) ) ) )
+
+; Invokes the eol handler when EOL or EOS is reached.
+(define (##sys#scan-buffer-line buf limit pos k)
+ (let loop ((pos2 pos))
+ (if (fx>= pos2 limit)
+ (k pos2 pos2)
+ (let ((c (##core#inline "C_subchar" buf pos2)))
+ (cond ((eq? c #\newline) (k pos2 (fx+ pos2 1)))
+ ((and (eq? c #\return)
+ (fx> limit (fx+ pos2 1))
+ (eq? (##core#inline "C_subchar" buf (fx+ pos2 1)) #\newline) )
+ (k pos2 (fx+ pos2 2)) )
+ (else (loop (fx+ pos2 1))) ) ) ) ) )
+
+; Scans a string, 'buf', from a start index, 'pos', to an end index,
+; 'lim'. During the scan the current position of the 'port' is updated to
+; reflect the rows & columns encountered.
+#; ;UNUSED (at the moment)
+(define (##sys#update-port-position/scan port buf pos lim)
+ (let loop ([pos pos])
+ (let ([bumper
+ (lambda (cur ptr)
+ (cond [(eq? cur ptr) ; at EOB
+ (##sys#setislot port 5 (fx+ (##sys#slot port 5) (fx- cur pos)))
+ #f ]
+ [else ; at EOL
+ (##sys#setislot port 4 (fx+ (##sys#slot port 4) 1))
+ (##sys#setislot port 5 0)
+ ptr ] ) ) ] )
+ (when pos
+ (loop (##sys#scan-buffer-line buf lim pos bumper)) ) ) ) )
+
+(define (open-input-string string)
+ (##sys#check-string string 'open-input-string)
+ (let ([port (##sys#make-port #t ##sys#string-port-class "(string)" 'string)])
+ (##sys#setislot port 11 (##core#inline "C_block_size" string))
+ (##sys#setislot port 10 0)
+ (##sys#setslot port 12 string)
+ port ) )
+
+(define (open-output-string)
+ (let ([port (##sys#make-port #f ##sys#string-port-class "(string)" 'string)])
+ (##sys#setislot port 10 0)
+ (##sys#setislot port 11 output-string-initial-size)
+ (##sys#setslot port 12 (##sys#make-string output-string-initial-size))
+ port ) )
+
+(define (get-output-string port)
+ (##sys#check-port port 'get-output-string)
+ (##sys#check-port-mode port #f 'get-output-string)
+ (if (not (eq? 'string (##sys#slot port 7)))
+ (##sys#signal-hook
+ #:type-error 'get-output-string "argument is not a string-output-port" port)
+ (##sys#substring (##sys#slot port 12) 0 (##sys#slot port 10)) ) )
+
+(define ##sys#print-to-string
+ (let ([get-output-string get-output-string]
+ [open-output-string open-output-string] )
+ (lambda (xs)
+ (let ([out (open-output-string)])
+ (for-each (lambda (x) (##sys#print x #f out)) xs)
+ (get-output-string out) ) ) ) )
+
+(define ##sys#pointer->string
+ (let ((string-append string-append))
+ (lambda (x)
+ (cond ((##core#inline "C_taggedpointerp" x)
+ (string-append
+ "#<tagged pointer "
+ (##sys#print-to-string
+ (let ((tag (##sys#slot x 1)))
+ (list (if (pair? tag) (car tag) tag) ) ) )
+ " "
+ (##sys#number->string (##sys#pointer->address x) 16)
+ ">") )
+ ((##core#inline "C_swigpointerp" x)
+ (string-append "#<SWIG pointer 0x" (##sys#number->string (##sys#pointer->address x) 16) ">") )
+ (else
+ (string-append "#<pointer 0x" (##sys#number->string (##sys#pointer->address x) 16) ">") ) ) ) ) )
+
+
+;;; Platform configuration inquiry:
+
+(define software-type
+ (let ([sym (string->symbol ((##core#primitive "C_software_type")))])
+ (lambda () sym) ) )
+
+(define machine-type
+ (let ([sym (string->symbol ((##core#primitive "C_machine_type")))])
+ (lambda () sym) ) )
+
+(define machine-byte-order
+ (let ([sym (string->symbol ((##core#primitive "C_machine_byte_order")))])
+ (lambda () sym) ) )
+
+(define software-version
+ (let ([sym (string->symbol ((##core#primitive "C_software_version")))])
+ (lambda () sym) ) )
+
+(define build-platform
+ (let ([sym (string->symbol ((##core#primitive "C_build_platform")))])
+ (lambda () sym) ) )
+
+(define c-runtime
+ (let ([sym (string->symbol ((##core#primitive "C_c_runtime")))])
+ (lambda () sym) ) )
+
+(define ##sys#windows-platform
+ (and (eq? 'windows (software-type))
+ ;; Still windows even if 'Linux-like'
+ (not (eq? 'cygwin (build-platform)))) )
+
+(define (chicken-version #!optional full)
+ (define (get-config)
+ (let ([bp (build-platform)]
+ [st (software-type)]
+ [sv (software-version)]
+ [mt (machine-type)] )
+ (define (str x)
+ (if (eq? 'unknown x)
+ ""
+ (string-append (symbol->string x) "-") ) )
+ (string-append (str sv) (str st) (str bp) (##sys#symbol->string mt)) ) )
+ (if full
+ (let ((rev (##sys#fudge 38))
+ (spec (string-append
+ (if (##sys#fudge 3) " 64bit" "")
+ (if (##sys#fudge 15) " symbolgc" "")
+ (if (##sys#fudge 40) " manyargs" "")
+ (if (##sys#fudge 24) " dload" "")
+ (if (##sys#fudge 28) " ptables" "")
+ (if (##sys#fudge 32) " gchooks" "")
+ (if (##sys#fudge 35) " applyhook" "")
+ (if (##sys#fudge 39) " cross" "") ) ) )
+ (string-append
+ "Version " +build-version+
+ (if (not (zero? rev))
+ (string-append
+ " - SVN rev. " (number->string rev) "\n")
+ "\n")
+ (get-config)
+ (if (zero? (##sys#size spec))
+ ""
+ (string-append " [" spec " ]") )
+ "\n"
+ +build-tag+))
+ +build-version+) )
+
+(define ##sys#pathname-directory-separator #\/) ; DEPRECATED
+
+
+;;; Feature identifiers:
+
+(define ##sys#->feature-id
+ (let ([string->keyword string->keyword]
+ [keyword? keyword?] )
+ (define (err . args)
+ (apply ##sys#signal-hook #:type-error "bad argument type - not a valid feature identifer" args) )
+ (define (prefix s)
+ (if s
+ (##sys#string-append s "-")
+ "") )
+ (lambda (x)
+ (cond [(string? x) (string->keyword x)]
+ [(keyword? x) x]
+ [(symbol? x) (string->keyword (##sys#symbol->string x))]
+ [else (err x)] ) ) ) )
+
+(define ##sys#features
+ '(#:chicken #:srfi-23 #:srfi-30 #:srfi-39 #:srfi-62 #:srfi-17 #:srfi-12 #:srfi-88 #:srfi-98))
+
+;; Add system features:
+
+(let ((check (lambda (f)
+ (unless (eq? 'unknown f)
+ (set! ##sys#features (cons (##sys#->feature-id f) ##sys#features))))))
+ (check (software-type))
+ (check (software-version))
+ (check (build-platform))
+ (check (machine-type))
+ (check (machine-byte-order)) )
+
+(when (##sys#fudge 40) (set! ##sys#features (cons #:manyargs ##sys#features)))
+(when (##sys#fudge 24) (set! ##sys#features (cons #:dload ##sys#features)))
+(when (##sys#fudge 28) (set! ##sys#features (cons #:ptables ##sys#features)))
+(when (##sys#fudge 35) (set! ##sys#features (cons #:applyhook ##sys#features)))
+(when (##sys#fudge 39) (set! ##sys#features (cons #:cross-chicken ##sys#features)))
+
+(define (register-feature! . fs)
+ (for-each
+ (lambda (f)
+ (let ([id (##sys#->feature-id f)])
+ (unless (memq id ##sys#features) (set! ##sys#features (cons id ##sys#features))) ) )
+ fs)
+ (##core#undefined) )
+
+(define (unregister-feature! . fs)
+ (let ([fs (map ##sys#->feature-id fs)])
+ (set! ##sys#features
+ (let loop ([ffs ##sys#features])
+ (if (null? ffs)
+ '()
+ (let ([f (##sys#slot ffs 0)]
+ [r (##sys#slot ffs 1)] )
+ (if (memq f fs)
+ (loop r)
+ (cons f (loop r)) ) ) ) ) )
+ (##core#undefined) ) )
+
+(define (features) ##sys#features)
+
+(define (##sys#feature? . ids)
+ (let loop ([ids ids])
+ (or (null? ids)
+ (and (memq (##sys#->feature-id (##sys#slot ids 0)) ##sys#features)
+ (loop (##sys#slot ids 1)) ) ) ) )
+
+(define feature? ##sys#feature?)
+
+
+;;; Access backtrace:
+
+(define ##sys#get-call-chain
+ (let ((extract (foreign-lambda* nonnull-c-string ((scheme-object x)) "return((C_char *)x);")))
+ (lambda (#!optional (start 0) (thread ##sys#current-thread))
+ (let* ((tbl (foreign-value "C_trace_buffer_size" int))
+ (vec (##sys#make-vector (fx* 4 tbl) #f))
+ (r (##core#inline "C_fetch_trace" start vec))
+ (n (if (fixnum? r) r (fx* 4 tbl))) )
+ (let loop ((i 0))
+ (if (fx>= i n)
+ '()
+ (let ((t (##sys#slot vec (fx+ i 3))))
+ (if (or (not t) (not thread) (eq? thread t))
+ (cons (vector (extract (##sys#slot vec i))
+ (##sys#slot vec (fx+ i 1))
+ (##sys#slot vec (fx+ i 2)) )
+ (loop (fx+ i 4)) )
+ (loop (fx+ i 4))) ) ) ) ) ) ) )
+
+(define (##sys#really-print-call-chain port chain header)
+ (when (pair? chain)
+ (##sys#print header #f port)
+ (for-each
+ (lambda (info)
+ (let ((more1 (##sys#slot info 1))
+ (more2 (##sys#slot info 2))
+ (t (##sys#slot info 3)))
+ (##sys#print "\n\t" #f port)
+ (##sys#print (##sys#slot info 0) #f port)
+ (##sys#print "\t\t" #f port)
+ (when more2
+ (##sys#write-char-0 #\[ port)
+ (##sys#print more2 #f port)
+ (##sys#print "] " #f port) )
+ (when more1
+ (##sys#with-print-length-limit
+ 100
+ (lambda ()
+ (##sys#print more1 #t port) ) ) ) ) )
+ chain)
+ (##sys#print "\t<--\n" #f port) ) )
+
+(define (print-call-chain #!optional (port ##sys#standard-output) (start 0)
+ (thread ##sys#current-thread)
+ (header "\n\tCall history:\n") )
+ (##sys#check-port port 'print-call-chain)
+ (##sys#check-exact start 'print-call-chain)
+ (##sys#check-string header 'print-call-chain)
+ (##sys#really-print-call-chain port (##sys#get-call-chain start thread) header) )
+
+(define get-call-chain ##sys#get-call-chain)
+
+
+;;; Interrupt handling:
+
+(define (##sys#user-interrupt-hook)
+ (define (break) (##sys#signal-hook #:user-interrupt #f))
+ (if (eq? ##sys#current-thread ##sys#primordial-thread)
+ (break)
+ (##sys#setslot ##sys#primordial-thread 1 break) ) )
+
+
+;;; Breakpoints
+
+(define ##sys#last-breakpoint #f)
+(define ##sys#break-in-thread #f)
+
+(define (##sys#break-entry name args)
+ ;; Does _not_ unwind!
+ (##sys#call-with-current-continuation
+ (lambda (c)
+ (let ((exn (##sys#make-structure
+ 'condition
+ '(exn breakpoint)
+ (list '(exn . message) "*** breakpoint ***"
+ '(exn . arguments) (list (cons name args))
+ '(exn . location) name
+ '(exn . continuation) c) ) ) )
+ (set! ##sys#last-breakpoint exn)
+ (##sys#signal exn) ) ) ) )
+
+(define (##sys#break-resume exn)
+ (let ((a (member '(exn . continuation) (##sys#slot exn 2))))
+ (if a
+ ((cadr a) (##core#undefined))
+ (##sys#signal-hook #:type-error "condition has no continuation" exn) ) ) )
+
+(define (breakpoint #!optional name)
+ (##sys#break-entry (or name 'breakpoint) '()) )
+
+
+;;; Single stepping
+
+(define ##sys#stepped-thread #f)
+(define ##sys#step-ports (cons ##sys#standard-input ##sys#standard-output))
+
+(define (##sys#step thunk)
+ (when (eq? ##sys#stepped-thread ##sys#current-thread)
+ (##sys#call-with-values
+ (lambda ()
+ (set! ##sys#apply-hook ##sys#step-hook)
+ (##core#app thunk) )
+ (lambda vals
+ (set! ##sys#apply-hook #f)
+ (set! ##sys#stepped-thread #f)
+ (##sys#apply-values vals) ) ) ) )
+
+(define (singlestep thunk)
+ (unless (##sys#fudge 35)
+ (##sys#signal-hook #:runtime-error 'singlestep "apply-hook not available") )
+ (##sys#check-closure thunk 'singlestep)
+ (set! ##sys#stepped-thread ##sys#current-thread)
+ (##sys#step thunk) )
+
+(define (##sys#step-hook . args)
+ (set! ##sys#apply-hook #f)
+ (let ((o (##sys#slot ##sys#step-ports 1))
+ (i (##sys#slot ##sys#step-ports 0))
+ (p ##sys#last-applied-procedure))
+ (define (skip-to-nl)
+ (let ((c (##sys#read-char-0 i)))
+ (unless (or (eof-object? c) (char=? #\newline c))
+ (sip-to-nl) ) ) )
+ (define (cont)
+ (set! ##sys#stepped-thread #f)
+ (##sys#apply p args) )
+ (##sys#print "\n " #f o)
+ (##sys#with-print-length-limit
+ 1024
+ (lambda () (##sys#print (cons p args) #t o)) )
+ (flush-output o)
+ (let loop ()
+ (##sys#print "\n step (RETURN), (s)kip, (c)ontinue or (b)reak ? " #f o)
+ (let ((c (##sys#read-char-0 i)))
+ (if (eof-object? c)
+ (cont)
+ (case c
+ ((#\newline)
+ (set! ##sys#apply-hook ##sys#step-hook)
+ (##core#app ##sys#apply p args))
+ ((#\return #\tab #\space) (loop))
+ ((#\c) (skip-to-nl) (cont))
+ ((#\s)
+ (skip-to-nl)
+ (##sys#call-with-values
+ (lambda () (##core#app ##sys#apply p args))
+ (lambda results
+ (set! ##sys#apply-hook ##sys#step-hook)
+ (##core#app ##sys#apply-values results) ) ) )
+ ((#\b)
+ (skip-to-nl)
+ (set! ##sys#stepped-thread #f)
+ (##sys#break-entry '<step> '())
+ (##sys#apply p args) )
+ (else
+ (cond ((eof-object? c) (cont))
+ (else
+ (skip-to-nl)
+ (loop))))))))))
+
+
+;;; Default handlers
+
+(define ##sys#break-on-error (##sys#fudge 25))
+
+(define-foreign-variable _ex_software int "EX_SOFTWARE")
+
+(define ##sys#error-handler
+ (make-parameter
+ (let ([string-append string-append]
+ [open-output-string open-output-string]
+ [get-output-string get-output-string]
+ [print-call-chain print-call-chain] )
+ (lambda (msg . args)
+ (##sys#error-handler (lambda args (##core#inline "C_halt" "error in error")))
+ (cond ((##sys#fudge 4)
+ (##sys#print "\nError" #f ##sys#standard-error)
+ (when msg
+ (##sys#print ": " #f ##sys#standard-error)
+ (##sys#print msg #f ##sys#standard-error) )
+ (cond [(fx= 1 (length args))
+ (##sys#print ": " #f ##sys#standard-error)
+ (##sys#print (##sys#slot args 0) #t ##sys#standard-error) ]
+ [else
+ (##sys#for-each
+ (lambda (x)
+ (##sys#print #\newline #f ##sys#standard-error)
+ (##sys#print x #t ##sys#standard-error) )
+ args) ] )
+ (##sys#print #\newline #f ##sys#standard-error)
+ (print-call-chain ##sys#standard-error)
+ (when (and ##sys#break-on-error (##sys#symbol-has-toplevel-binding? 'repl))
+ (repl)
+ (##sys#print #\newline #f ##sys#standard-error)
+ (##core#inline "C_exit_runtime" _ex_software) )
+ (##core#inline "C_halt" #f) )
+ (else
+ (let ((out (open-output-string)))
+ (when msg (##sys#print msg #f out))
+ (##sys#print #\newline #f out)
+ (##sys#for-each (lambda (x) (##sys#print x #t out) (##sys#print #\newline #f out)) args)
+ (##core#inline "C_halt" (get-output-string out)) ) ) ) ) ) ) )
+
+(define reset-handler
+ (make-parameter
+ (lambda ()
+ ((##sys#exit-handler) _ex_software)) ) )
+
+(define exit-handler
+ (make-parameter
+ (lambda code
+ (##sys#cleanup-before-exit)
+ (##core#inline
+ "C_exit_runtime"
+ (if (null? code)
+ 0
+ (let ([code (car code)])
+ (##sys#check-exact code)
+ code) ) ) ) ) )
+
+(define implicit-exit-handler
+ (make-parameter
+ (lambda ()
+ (##sys#cleanup-before-exit) ) ) )
+
+(define ##sys#exit-handler exit-handler)
+(define ##sys#reset-handler reset-handler)
+(define ##sys#implicit-exit-handler implicit-exit-handler)
+
+(define force-finalizers (make-parameter #t))
+
+(define ##sys#cleanup-before-exit
+ (let ([ffp force-finalizers])
+ (lambda ()
+ (when (##sys#fudge 13)
+ (##sys#print "[debug] forcing finalizers...\n" #f ##sys#standard-output) )
+ (when (ffp) (##sys#force-finalizers)) ) ) )
+
+(define (on-exit thunk)
+ (set! ##sys#cleanup-before-exit
+ (let ((old ##sys#cleanup-before-exit))
+ (lambda () (old) (thunk)) ) ) )
+
+
+;;; Condition handling:
+
+(define (##sys#signal-hook mode msg . args)
+ (##core#inline "C_dbg_hook" #f)
+ (case mode
+ [(#:user-interrupt)
+ (##sys#abort
+ (##sys#make-structure
+ 'condition
+ '(user-interrupt)
+ '() ) ) ]
+ [(#:warning)
+ (##sys#print "\nWarning: " #f ##sys#standard-error)
+ (##sys#print msg #f ##sys#standard-error)
+ (if (or (null? args) (fx> (length args) 1))
+ (##sys#write-char-0 #\newline ##sys#standard-error)
+ (##sys#print ": " #f ##sys#standard-error))
+ (for-each
+ (lambda (x)
+ (##sys#print x #t ##sys#standard-error)
+ (##sys#write-char-0 #\newline ##sys#standard-error) )
+ args)
+ (##sys#flush-output ##sys#standard-error) ]
+ [else
+ (when (and (symbol? msg) (null? args))
+ (set! msg (##sys#symbol->string msg)) )
+ (let* ([hasloc (and (or (not msg) (symbol? msg)) (pair? args))]
+ [loc (and hasloc msg)]
+ [msg (if hasloc (##sys#slot args 0) msg)]
+ [args (if hasloc (##sys#slot args 1) args)] )
+ (##sys#abort
+ (##sys#make-structure
+ 'condition
+ (case mode
+ [(#:type-error) '(exn type)]
+ [(#:syntax-error) '(exn syntax)]
+ [(#:bounds-error) '(exn bounds)]
+ [(#:arithmetic-error) '(exn arithmetic)]
+ [(#:file-error) '(exn i/o file)]
+ [(#:runtime-error) '(exn runtime)]
+ [(#:process-error) '(exn process)]
+ [(#:network-error) '(exn i/o net)]
+ [(#:limit-error) '(exn runtime limit)]
+ [(#:arity-error) '(exn arity)]
+ [(#:access-error) '(exn access)]
+ [(#:domain-error) '(exn domain)]
+ [else '(exn)] )
+ (list '(exn . message) msg
+ '(exn . arguments) args
+ '(exn . location) loc) ) ) ) ] ) )
+
+(define (##sys#abort x)
+ (##sys#current-exception-handler x)
+ (##sys#abort
+ (##sys#make-structure
+ 'condition
+ '(exn)
+ (list '(exn . message) "exception handler returned"
+ '(exn . arguments) '()
+ '(exn . location) #f) ) ) )
+
+(define (##sys#signal x)
+ (##sys#current-exception-handler x) )
+
+(define abort ##sys#abort)
+(define signal ##sys#signal)
+
+(define ##sys#last-exception #f)
+
+(define ##sys#current-exception-handler
+ ;; Exception-handler for the primordial thread:
+ (let ([string-append string-append])
+ (lambda (c)
+ (when (##sys#structure? c 'condition)
+ (set! ##sys#last-exception c)
+ (let ([kinds (##sys#slot c 1)])
+ (cond [(memq 'exn kinds)
+ (let* ([props (##sys#slot c 2)]
+ [msga (member '(exn . message) props)]
+ [argsa (member '(exn . arguments) props)]
+ [loca (member '(exn . location) props)] )
+ (apply
+ (##sys#error-handler)
+ (if msga
+ (let ([msg (cadr msga)]
+ [loc (and loca (cadr loca))] )
+ (if (and loc (symbol? loc))
+ (string-append
+ "(" (##sys#symbol->qualified-string loc) ") "
+ (cond ((symbol? msg) (##sys#slot msg 1))
+ ((string? msg) msg)
+ (else "") ) ) ; Hm...
+ msg) )
+ "<exn: has no `message' property>")
+ (if argsa
+ (cadr argsa)
+ '() ) )
+ ((##sys#reset-handler)) ) ]
+ [(eq? 'user-interrupt (##sys#slot kinds 0))
+ (##sys#print "\n*** user interrupt ***\n" #f ##sys#standard-error)
+ ((##sys#reset-handler)) ]
+ [(eq? 'uncaught-exception (##sys#slot kinds 0))
+ ((##sys#error-handler)
+ "uncaught exception"
+ (cadr (member '(uncaught-exception . reason) (##sys#slot c 2))) )
+ ((##sys#reset-handler)) ] ) ) )
+ (##sys#abort
+ (##sys#make-structure
+ 'condition
+ '(uncaught-exception)
+ (list '(uncaught-exception . reason) c)) ) ) ) )
+
+(define (with-exception-handler handler thunk)
+ (let ([oldh ##sys#current-exception-handler])
+ (##sys#dynamic-wind
+ (lambda () (set! ##sys#current-exception-handler handler))
+ thunk
+ (lambda () (set! ##sys#current-exception-handler oldh)) ) ) )
+
+(define (current-exception-handler) ##sys#current-exception-handler)
+
+(define (make-property-condition kind . props)
+ (##sys#make-structure
+ 'condition (list kind)
+ (let loop ((props props))
+ (if (null? props)
+ '()
+ (cons (cons kind (car props)) (cons (cadr props) (loop (cddr props)))) ) ) ) )
+
+(define (make-composite-condition c1 . conds)
+ (let ([conds (cons c1 conds)])
+ (for-each (lambda (c) (##sys#check-structure c 'condition 'make-composite-condition)) conds)
+ (##sys#make-structure
+ 'condition
+ (apply ##sys#append (map (lambda (c) (##sys#slot c 1)) conds))
+ (apply ##sys#append (map (lambda (c) (##sys#slot c 2)) conds)) ) ) )
+
+(define (condition? x) (##sys#structure? x 'condition))
+
+(define (condition-predicate kind)
+ (lambda (c)
+ (##sys#check-structure c 'condition)
+ (if (memv kind (##sys#slot c 1)) #t #f) ) )
+
+(define (condition-property-accessor kind prop . err-def)
+ (let ((err? (null? err-def))
+ (k+p (cons kind prop)) )
+ (lambda (c)
+ (##sys#check-structure c 'condition)
+ (and (memv kind (##sys#slot c 1))
+ (let ([a (member k+p (##sys#slot c 2))])
+ (cond [a (cadr a)]
+ [err? (##sys#signal-hook
+ #:type-error 'condition-property-accessor
+ "condition has no such property" prop) ]
+ [else (car err-def)] ) ) ) ) ) )
+
+(define get-condition-property
+ (let ((condition-property-accessor condition-property-accessor))
+ (lambda (c kind prop . err-def)
+ (apply (condition-property-accessor kind prop err-def) c))))
+
+
+;;; Error hook (called by runtime-system):
+
+(define ##sys#error-hook
+ (let ([string-append string-append])
+ (lambda (code loc . args)
+ (case code
+ ((1) (let ([c (car args)]
+ [n (cadr args)]
+ [fn (caddr args)] )
+ (apply
+ ##sys#signal-hook
+ #:arity-error loc
+ (string-append "bad argument count - received " (##sys#number->string n) " but expected "
+ (##sys#number->string c) )
+ (if fn (list fn) '())) ) )
+ ((2) (let ([c (car args)]
+ [n (cadr args)]
+ [fn (caddr args)] )
+ (apply
+ ##sys#signal-hook
+ #:arity-error loc
+ (string-append "too few arguments - received " (##sys#number->string n) " but expected "
+ (##sys#number->string c) )
+ (if fn (list fn) '()))))
+ ((3) (apply ##sys#signal-hook #:type-error loc "bad argument type" args))
+ ((4) (apply ##sys#signal-hook #:runtime-error loc "unbound variable" args))
+ ((5) (apply ##sys#signal-hook #:limit-error loc "parameter limit exceeded" args))
+ ((6) (apply ##sys#signal-hook #:limit-error loc "out of memory" args))
+ ((7) (apply ##sys#signal-hook #:arithmetic-error loc "division by zero" args))
+ ((8) (apply ##sys#signal-hook #:bounds-error loc "out of range" args))
+ ((9) (apply ##sys#signal-hook #:type-error loc "call of non-procedure" args))
+ ((10) (apply ##sys#signal-hook #:arity-error loc "continuation cannot receive multiple values" args))
+ ((11) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a non-cyclic list" args))
+ ((12) (apply ##sys#signal-hook #:limit-error loc "recursion too deep" args))
+ ((13) (apply ##sys#signal-hook #:type-error loc "inexact number cannot be represented as an exact number" args))
+ ((14) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a proper list" args))
+ ((15) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" args))
+ ((16) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a number" args))
+ ((17) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a string" args))
+ ((18) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a pair" args))
+ ((19) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a list" args))
+ ((20) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a character" args))
+ ((21) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a vector" args))
+ ((22) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a symbol" args))
+ ((23) (apply ##sys#signal-hook #:limit-error loc "stack overflow" args))
+ ((24) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a structure of the required type" args))
+ ((25) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a blob" args))
+ ((26) (apply ##sys#signal-hook #:type-error loc "locative refers to reclaimed object" args))
+ ((27) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a non-immediate value" args))
+ ((28) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a number vector" args))
+ ((29) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an integer" args))
+ ((30) (apply ##sys#signal-hook #:type-error loc "bad argument type - not an unsigned integer" args))
+ ((31) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a pointer" args))
+ ((32) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a tagged pointer" args))
+ ((33) (apply ##sys#signal-hook #:runtime-error loc
+ "code to load dynamically was linked with safe runtime libraries, but executing runtime was not"
+ args) )
+ ((34) (apply ##sys#signal-hook #:runtime-error loc
+ "code to load dynamically was linked with unsafe runtime libraries, but executing runtime was not"
+ args) )
+ ((35) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a flonum" args))
+ ((36) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a procedure" args))
+ (else (apply ##sys#signal-hook #:runtime-error loc "unknown internal error" args)) ) ) ) )
+
+
+;;; Miscellaneous low-level routines:
+
+(define (##sys#structure? x s) (##core#inline "C_i_structurep" x s))
+(define (##sys#generic-structure? x) (##core#inline "C_structurep" x))
+(define (##sys#slot x i) (##core#inline "C_slot" x i))
+(define (##sys#size x) (##core#inline "C_block_size" x))
+(define ##sys#make-pointer (##core#primitive "C_make_pointer"))
+(define ##sys#make-tagged-pointer (##core#primitive "C_make_tagged_pointer"))
+(define (##sys#pointer? x) (##core#inline "C_anypointerp" x))
+(define (##sys#set-pointer-address! ptr addr) (##core#inline "C_update_pointer" addr ptr))
+(define (##sys#bytevector? x) (##core#inline "C_bytevectorp" x))
+(define (##sys#string->pbytevector s) (##core#inline "C_string_to_pbytevector" s))
+(define (##sys#permanent? x) (##core#inline "C_permanentp" x))
+(define (##sys#block-address x) (##core#inline_allocate ("C_block_address" 4) x))
+(define (##sys#locative? x) (##core#inline "C_locativep" x))
+
+(define (##sys#null-pointer)
+ (let ([ptr (##sys#make-pointer)])
+ (##core#inline "C_update_pointer" 0 ptr)
+ ptr) )
+
+(define (##sys#null-pointer? x)
+ (eq? 0 (##sys#pointer->address x)) )
+
+(define (##sys#address->pointer addr)
+ (let ([ptr (##sys#make-pointer)])
+ (##core#inline "C_update_pointer" addr ptr)
+ ptr) )
+
+(define (##sys#pointer->address ptr)
+ ;; *** '4' is platform dependent!
+ (##core#inline_allocate ("C_a_unsigned_int_to_num" 4) (##sys#slot ptr 0)) )
+
+(define (##sys#make-c-string str)
+ (##sys#string-append
+ str
+ (string (##core#inline "C_make_character" (##core#inline "C_unfix" 0)))) )
+
+(define ##sys#peek-signed-integer (##core#primitive "C_peek_signed_integer"))
+(define ##sys#peek-unsigned-integer (##core#primitive "C_peek_unsigned_integer"))
+(define (##sys#peek-fixnum b i) (##core#inline "C_peek_fixnum" b i))
+(define (##sys#peek-byte ptr i) (##core#inline "C_peek_byte" ptr i))
+
+(define (##sys#vector->structure! vec) (##core#inline "C_vector_to_structure" vec))
+
+(define (##sys#peek-double b i)
+ (##core#inline "C_f64peek" b i)
+ (##sys#cons-flonum) )
+
+(define (##sys#peek-c-string b i)
+ (and (not (##sys#null-pointer? b))
+ (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
+ [str2 (##sys#make-string len)] )
+ (##core#inline "C_peek_c_string" b i str2 len)
+ str2 ) ) )
+
+(define (##sys#peek-nonnull-c-string b i)
+ (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
+ [str2 (##sys#make-string len)] )
+ (##core#inline "C_peek_c_string" b i str2 len)
+ str2 ) )
+
+(define (##sys#peek-and-free-c-string b i)
+ (and (not (##sys#null-pointer? b))
+ (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
+ [str2 (##sys#make-string len)] )
+ (##core#inline "C_peek_c_string" b i str2 len)
+ (##core#inline "C_free_mptr" b i)
+ str2 ) ) )
+
+(define (##sys#peek-and-free-nonnull-c-string b i)
+ (let* ([len (##core#inline "C_fetch_c_strlen" b i)]
+ [str2 (##sys#make-string len)] )
+ (##core#inline "C_peek_c_string" b i str2 len)
+ (##core#inline "C_free_mptr" b i)
+ str2 ) )
+
+(define (##sys#poke-c-string b i s)
+ (##core#inline "C_poke_c_string" b i (##sys#make-c-string s)) )
+
+(define (##sys#poke-integer b i n) (##core#inline "C_poke_integer" b i n))
+(define (##sys#poke-double b i n) (##core#inline "C_poke_double" b i n))
+
+(define ##sys#peek-c-string-list
+ (let ((fetch (foreign-lambda c-string "C_peek_c_string_at" c-pointer int)))
+ (lambda (ptr n)
+ (let loop ((i 0))
+ (if (and n (fx>= i n))
+ '()
+ (let ((s (fetch ptr i)))
+ (if s
+ (cons s (loop (fx+ i 1)))
+ '() ) ) ) ) ) ) )
+
+(define ##sys#peek-and-free-c-string-list
+ (let ((fetch (foreign-lambda c-string "C_peek_c_string_at" c-pointer int))
+ (free (foreign-lambda void "C_free" c-pointer)))
+ (lambda (ptr n)
+ (let ((lst (let loop ((i 0))
+ (if (and n (fx>= i n))
+ '()
+ (let ((s (fetch ptr i)))
+ (cond (s
+ (##core#inline "C_free_sptr" ptr i)
+ (cons s (loop (fx+ i 1))) )
+ (else '() ) ) ) ) ) ) )
+ (free ptr)
+ lst) ) ) )
+
+(define (##sys#vector->closure! vec addr)
+ (##core#inline "C_vector_to_closure" vec)
+ (##core#inline "C_update_pointer" addr vec) )
+
+(define (##sys#symbol-has-toplevel-binding? s)
+ (not (eq? (##sys#slot s 0) (##sys#slot '##sys#arbitrary-unbound-symbol 0))) )
+
+(define (##sys#copy-bytes from to offset1 offset2 bytes)
+ (##core#inline
+ "C_substring_copy"
+ from to
+ offset1 (fx+ offset1 bytes)
+ offset2) )
+
+(define (##sys#copy-words from to offset1 offset2 words)
+ (##core#inline
+ "C_subvector_copy"
+ from to
+ offset1 (fx+ offset1 words)
+ offset2) )
+
+(define (##sys#compare-bytes from to offset1 offset2 bytes)
+ (##core#inline
+ "C_substring_compare"
+ from to
+ offset1 offset2 bytes) )
+
+(define ##sys#zap-strings (foreign-lambda void "C_zap_strings" scheme-object))
+
+(define (##sys#block-pointer x)
+ (let ([ptr (##sys#make-pointer)])
+ (##core#inline "C_pointer_to_block" ptr x)
+ ptr) )
+
+
+;;; Support routines for foreign-function calling:
+
+(define (##sys#foreign-char-argument x) (##core#inline "C_i_foreign_char_argumentp" x))
+(define (##sys#foreign-fixnum-argument x) (##core#inline "C_i_foreign_fixnum_argumentp" x))
+(define (##sys#foreign-flonum-argument x) (##core#inline "C_i_foreign_flonum_argumentp" x))
+(define (##sys#foreign-block-argument x) (##core#inline "C_i_foreign_block_argumentp" x))
+(define (##sys#foreign-number-vector-argument t x) (##core#inline "C_i_foreign_number_vector_argumentp" t x))
+(define (##sys#foreign-string-argument x) (##core#inline "C_i_foreign_string_argumentp" x))
+(define (##sys#foreign-symbol-argument x) (##core#inline "C_i_foreign_symbol_argumentp" x))
+(define (##sys#foreign-pointer-argument x) (##core#inline "C_i_foreign_pointer_argumentp" x))
+(define (##sys#foreign-tagged-pointer-argument x tx) (##core#inline "C_i_foreign_tagged_pointer_argumentp" x tx))
+(define (##sys#foreign-integer-argument x) (##core#inline "C_i_foreign_integer_argumentp" x))
+(define (##sys#foreign-unsigned-integer-argument x) (##core#inline "C_i_foreign_unsigned_integer_argumentp" x))
+
+
+;;; Low-level threading interface:
+
+(define ##sys#default-thread-quantum 10000)
+
+(define (##sys#default-exception-handler arg)
+ (##core#inline "C_halt" "internal error: default exception handler shouldn't be called!") )
+
+(define (##sys#make-thread thunk state name q)
+ (##sys#make-structure
+ 'thread
+ thunk ; #1 thunk
+ #f ; #2 result list
+ state ; #3 state
+ #f ; #4 block-timeout
+ (vector ; #5 state buffer
+ ##sys#dynamic-winds
+ ##sys#standard-input
+ ##sys#standard-output
+ ##sys#standard-error
+ ##sys#default-exception-handler
+ (##sys#grow-vector ##sys#current-parameter-vector (##sys#size ##sys#current-parameter-vector) #f) )
+ name ; #6 name
+ (##core#undefined) ; #7 end-exception
+ '() ; #8 owned mutexes
+ q ; #9 quantum
+ (##core#undefined) ; #10 specific
+ #f ; #11 block object (type depends on blocking type)
+ '() ; #12 recipients (currently unused)
+ #f) ) ; #13 unblocked by timeout?
+
+(define ##sys#primordial-thread (##sys#make-thread #f 'running 'primordial ##sys#default-thread-quantum))
+(define ##sys#current-thread ##sys#primordial-thread)
+
+(define (##sys#make-mutex id owner)
+ (##sys#make-structure
+ 'mutex
+ id ; #1 name
+ owner ; #2 thread or #f
+ '() ; #3 list of waiting threads
+ #f ; #4 abandoned
+ #f ; #5 locked
+ (##core#undefined) ) ) ; #6 specific
+
+(define (##sys#abandon-mutexes thread)
+ (let ([ms (##sys#slot thread 8)])
+ (unless (null? ms)
+ (##sys#for-each
+ (lambda (m)
+ (##sys#setislot m 2 #f)
+ (##sys#setislot m 4 #t)
+ (##sys#setislot m 5 #f)
+ (##sys#setislot m 3 '()) )
+ ms) ) ) )
+
+(define (##sys#schedule) ((##sys#slot ##sys#current-thread 1)))
+
+(define (##sys#thread-yield!)
+ (##sys#call-with-current-continuation
+ (lambda (return)
+ (let ((ct ##sys#current-thread))
+ (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
+ (##sys#schedule) ) ) ) )
+
+
+;;; Interrupt-handling:
+
+(define ##sys#context-switch (##core#primitive "C_context_switch"))
+
+(define (##sys#interrupt-hook reason state)
+ (cond ((fx> (##sys#slot ##sys#pending-finalizers 0) 0)
+ (##sys#run-pending-finalizers state) )
+ (else (##sys#context-switch state) ) ) )
+
+
+;;; Accessing "errno":
+
+(define-foreign-variable ##sys#errno int "errno")
+
+(define ##sys#update-errno)
+(define errno)
+
+(let ([rn 0])
+ (set! ##sys#update-errno (lambda () (set! rn ##sys#errno) rn))
+ (set! errno (lambda () rn)) )
+
+
+;;; Format error string for unterminated here-docs:
+
+(define (##sys#format-here-doc-warning end)
+ (##sys#print-to-string `("unterminated here-doc string literal `" ,end "'")))
+
+;;; Special string quoting syntax:
+
+(set! ##sys#user-read-hook
+ (let ([old ##sys#user-read-hook]
+ [open-output-string open-output-string]
+ [get-output-string get-output-string]
+ [reverse reverse]
+ [read read]
+ [display display] )
+ (define (readln port)
+ (let ([ln (open-output-string)])
+ (do ([c (##sys#read-char-0 port) (##sys#read-char-0 port)])
+ ((or (eof-object? c) (char=? #\newline c))
+ (cond [(char? c) (get-output-string ln)]
+ [else c] ) )
+ (##sys#write-char-0 c ln) ) ) )
+ (define (read-escaped-sexp port skip-brace?)
+ (when skip-brace? (##sys#read-char-0 port))
+ (let* ((form (read port)))
+ (when skip-brace?
+ (let loop ()
+ ;; Skips all characters until #\}
+ (let ([c (##sys#read-char-0 port)])
+ (cond [(eof-object? c)
+ (##sys#read-error port "unexpected end of file - unterminated `#{...}' item in `here' string literal") ]
+ [(not (char=? #\} c)) (loop)] ) ) ) )
+ form))
+ (lambda (char port)
+ (cond [(not (char=? #\< char)) (old char port)]
+ [else
+ (read-char port)
+ (case (##sys#peek-char-0 port)
+ [(#\<)
+ (##sys#read-char-0 port)
+ (let ([str (open-output-string)]
+ [end (readln port)]
+ [f #f] )
+ (let ((endlen (string-length end)))
+ (cond
+ ((fx= endlen 0)
+ (##sys#read-warning
+ port "Missing tag after #<< here-doc token"))
+ ((or (char=? (string-ref end (fx- endlen 1)) #\space)
+ (char=? (string-ref end (fx- endlen 1)) #\tab))
+ (##sys#read-warning
+ port "Whitespace after #<< here-doc tag"))
+ ))
+ (do ([ln (readln port) (readln port)])
+ ((or (eof-object? ln) (string=? end ln))
+ (when (eof-object? ln)
+ (##sys#read-warning port
+ (##sys#format-here-doc-warning end)))
+ (get-output-string str) )
+ (if f
+ (##sys#write-char-0 #\newline str)
+ (set! f #t) )
+ (display ln str) ) ) ]
+ [(#\#)
+ (##sys#read-char-0 port)
+ (let ([end (readln port)]
+ [str (open-output-string)] )
+ (define (get/clear-str)
+ (let ((s (get-output-string str)))
+ (set! str (open-output-string))
+ s))
+
+ (let ((endlen (string-length end)))
+ (cond
+ ((fx= endlen 0)
+ (##sys#read-warning
+ port "Missing tag after #<# here-doc token"))
+ ((or (char=? (string-ref end (fx- endlen 1)) #\space)
+ (char=? (string-ref end (fx- endlen 1)) #\tab))
+ (##sys#read-warning
+ port "Whitespace after #<# here-doc tag"))
+ ))
+
+ (let loop [(lst '())]
+ (let ([c (##sys#read-char-0 port)])
+ (case c
+ [(#\newline #!eof)
+ (let ([s (get/clear-str)])
+ (cond [(or (eof-object? c) (string=? end s))
+ (when (eof-object? c)
+ (##sys#read-warning
+ port (##sys#format-here-doc-warning end))
+ )
+ `(##sys#print-to-string
+ ;;Can't just use `(list ,@lst) because of 126 argument apply limit
+ ,(let loop2 ((lst (cdr lst)) (next-string '()) (acc ''())) ; drop last newline
+ (cond ((null? lst)
+ `(cons ,(##sys#print-to-string next-string) ,acc))
+ ((or (string? (car lst)) (char? (car lst)))
+ (loop2 (cdr lst) (cons (car lst) next-string) acc))
+ (else
+ (loop2 (cdr lst)
+ '()
+ `(cons ,(car lst)
+ (cons ,(##sys#print-to-string next-string) ,acc))))))) ]
+ [else (loop (cons #\newline (cons s lst)))] ) ) ]
+ [(#\#)
+ (let ([c (##sys#peek-char-0 port)])
+ (case c
+ [(#\#)
+ (##sys#write-char-0 (##sys#read-char-0 port) str)
+ (loop lst) ]
+ [(#\{) (loop (cons (read-escaped-sexp port #t)
+ (cons (get/clear-str) lst) ) ) ]
+ [else (loop (cons (read-escaped-sexp port #f)
+ (cons (get/clear-str) lst) ) ) ] ) ) ]
+ [else
+ (##sys#write-char-0 c str)
+ (loop lst) ] ) ) ) ) ]
+ [else (##sys#read-error port "unreadable object")] ) ] ) ) ) )
+
+
+;;; Script invocation:
+
+(define program-name
+ (make-parameter
+ (let* ((av (argv)))
+ (if (pair? av) (car av) "<unknown>") )
+ (lambda (x)
+ (##sys#check-string x 'program-name)
+ x) ) )
+
+(define command-line-arguments
+ (make-parameter
+ (let ([args (argv)])
+ (if (pair? args)
+ (let loop ([args (##sys#slot args 1)])
+ (if (null? args)
+ '()
+ (let ([arg (##sys#slot args 0)]
+ [r (##sys#slot args 1)] )
+ (if (and (fx>= (##sys#size arg) 3)
+ (string=? "-:" (##sys#substring arg 0 2)))
+ (loop r)
+ (cons arg (loop r)) ) ) ) )
+ args) )
+ (lambda (x)
+ (##sys#check-list x 'command-line-arguments)
+ x) ) )
+
+
+;;; Finalization:
+
+(define-foreign-variable _max_pending_finalizers int "C_max_pending_finalizers")
+
+(define ##sys#pending-finalizers
+ (##sys#make-vector (fx+ (fx* 2 _max_pending_finalizers) 1) (##core#undefined)) )
+
+(##sys#setislot ##sys#pending-finalizers 0 0)
+
+(define ##sys#set-finalizer! (##core#primitive "C_register_finalizer"))
+
+(define set-finalizer!
+ (let ((print print))
+ (lambda (x y)
+ (when (fx> (##sys#fudge 26) _max_pending_finalizers)
+ (if (##core#inline "C_resize_pending_finalizers" (fx* 2 _max_pending_finalizers))
+ (begin
+ (set! ##sys#pending-finalizers (##sys#grow-vector ##sys#pending-finalizers
+ (fx+ (fx* 2 _max_pending_finalizers) 1)
+ (##core#undefined)))
+ (when (##sys#fudge 13)
+ (print "[debug] too many finalizers (" (##sys#fudge 26)
+ "), resized max finalizers to " _max_pending_finalizers "...") ) )
+ (begin
+ (when (##sys#fudge 13)
+ (print "[debug] too many finalizers (" (##sys#fudge 26) "), forcing ...") )
+ (##sys#force-finalizers) ) ) )
+ (##sys#set-finalizer! x y) ) ) )
+
+(define ##sys#run-pending-finalizers
+ (let ([vector-fill! vector-fill!]
+ [print print]
+ [working #f] )
+ (lambda (state)
+ (unless working
+ (set! working #t)
+ (let* ([n (##sys#size ##sys#pending-finalizers)]
+ [c (##sys#slot ##sys#pending-finalizers 0)] )
+ (when (##sys#fudge 13)
+ (print "[debug] running " c " finalizers (" (##sys#fudge 26) " live, "
+ (##sys#fudge 27) " allocated) ..."))
+ (do ([i 0 (fx+ i 1)])
+ ((fx>= i c))
+ (let ([i2 (fx+ 1 (fx* i 2))])
+ ((##sys#slot ##sys#pending-finalizers (fx+ i2 1))
+ (##sys#slot ##sys#pending-finalizers i2)) ) )
+ (vector-fill! ##sys#pending-finalizers (##core#undefined))
+ (##sys#setislot ##sys#pending-finalizers 0 0)
+ (set! working #f) ) )
+ (when state (##sys#context-switch state) ) ) ) )
+
+(define (##sys#force-finalizers)
+ (let loop ()
+ (let ([n (##sys#gc)])
+ (if (fx> (##sys#slot ##sys#pending-finalizers 0) 0)
+ (begin
+ (##sys#run-pending-finalizers #f)
+ (loop) )
+ n) ) ) )
+
+(define (gc . arg)
+ (let ([a (and (pair? arg) (car arg))])
+ (if a
+ (##sys#force-finalizers)
+ (apply ##sys#gc arg) ) ) )
+
+
+;;; Auxilliary definitions for safe use in quasiquoted forms and evaluated code:
+
+(define ##sys#list->vector list->vector)
+(define ##sys#list list)
+(define ##sys#cons cons)
+(define ##sys#append append)
+(define ##sys#vector vector)
+(define ##sys#apply apply)
+(define ##sys#values values)
+(define ##sys#equal? equal?)
+(define ##sys#car car)
+(define ##sys#cdr cdr)
+(define ##sys#pair? pair?)
+(define ##sys#vector? vector?)
+(define ##sys#vector->list vector->list)
+(define ##sys#vector-length vector-length)
+(define ##sys#vector-ref vector-ref)
+(define ##sys#>= >=)
+(define ##sys#= =)
+(define ##sys#+ +)
+(define ##sys#eq? eq?)
+(define ##sys#eqv? eqv?)
+(define ##sys#list? list?)
+(define ##sys#null? null?)
+(define ##sys#map-n map)
+(define ##sys#list-ref list-ref)
+
+
+;;; Promises:
+
+(define (##sys#make-promise proc)
+ (let ([result-ready #f]
+ [results #f] )
+ (##sys#make-structure
+ 'promise
+ (lambda ()
+ (if result-ready
+ (apply ##sys#values results)
+ (##sys#call-with-values
+ proc
+ (lambda xs
+ (if result-ready
+ (apply ##sys#values results)
+ (begin
+ (set! result-ready #t)
+ (set! results xs)
+ (apply ##sys#values results) ) ) ) ) ) ) ) ) )
+
+(define (promise? x)
+ (##sys#structure? x 'promise) )
+
+
+;;; Internal string-reader:
+
+(define ##sys#read-from-string
+ (let ([open-input-string open-input-string])
+ (lambda (s)
+ (let ([i (open-input-string s)])
+ (read i) ) ) ) )
+
+
+;;; Convenient error printing:
+
+(define print-error-message
+ (let* ([display display]
+ [newline newline]
+ [write write]
+ [string-append string-append]
+ [errmsg (condition-property-accessor 'exn 'message #f)]
+ [errloc (condition-property-accessor 'exn 'location #f)]
+ [errargs (condition-property-accessor 'exn 'arguments #f)]
+ [writeargs
+ (lambda (args port)
+ (##sys#for-each
+ (lambda (x)
+ (##sys#with-print-length-limit 80 (lambda () (write x port)))
+ (newline port) )
+ args) ) ] )
+ (lambda (ex . args)
+ (let-optionals args ([port ##sys#standard-output]
+ [header "Error"] )
+ (##sys#check-port port 'print-error-message)
+ (display header port)
+ (cond [(and (not (##sys#immediate? ex)) (eq? 'condition (##sys#slot ex 0)))
+ (cond ((errmsg ex) =>
+ (lambda (msg)
+ (display ": " port)
+ (let ([loc (errloc ex)])
+ (when (and loc (symbol? loc))
+ (display (string-append "(" (##sys#symbol->qualified-string loc) ") ") port) ) )
+ (display msg port) ) )
+ (else
+ (let ((kinds (##sys#slot ex 1)))
+ (if (equal? '(user-interrupt) kinds)
+ (display ": *** user interrupt ***" port)
+ (begin
+ (display ": <condition> " port)
+ (display (##sys#slot ex 1) port) ) ) ) ) )
+ (and-let* ([args (errargs ex)])
+ (if (fx= 1 (length args))
+ (begin
+ (display ": " port)
+ (writeargs args port) )
+ (begin
+ (newline port)
+ (writeargs args port) ) ) ) ]
+ [(string? ex)
+ (display ": " port)
+ (display ex port)
+ (newline port) ]
+ [else
+ (display ": uncaught exception: " port)
+ (writeargs (list ex) port) ] ) ) ) ) )
+
+
+;;; We need this here so `location' works:
+
+(define (##sys#make-locative obj index weak? loc)
+ (cond [(##sys#immediate? obj)
+ (##sys#signal-hook #:type-error loc "locative cannot refer to immediate object" obj) ]
+ [(or (vector? obj) (pair? obj))
+ (##sys#check-range index 0 (##sys#size obj) loc)
+ (##core#inline_allocate ("C_a_i_make_locative" 5) 0 obj index weak?) ]
+ #;[(symbol? obj)
+ (##sys#check-range index 0 1 loc)
+ (##core#inline_allocate ("C_a_i_make_locative" 5) 0 obj index weak?) ]
+ [(and (##core#inline "C_blockp" obj)
+ (##core#inline "C_bytevectorp" obj) )
+ (##sys#check-range index 0 (##sys#size obj) loc)
+ (##core#inline_allocate ("C_a_i_make_locative" 5) 2 obj index weak?) ]
+ [(##sys#generic-structure? obj)
+ (case (##sys#slot obj 0)
+ [(u8vector)
+ (let ([v (##sys#slot obj 1)])
+ (##sys#check-range index 0 (##sys#size v) loc)
+ (##core#inline_allocate ("C_a_i_make_locative" 5) 2 v index weak?)) ]
+ [(s8vector)
+ (let ([v (##sys#slot obj 1)])
+ (##sys#check-range index 0 (##sys#size v) loc)
+ (##core#inline_allocate ("C_a_i_make_locative" 5) 3 v index weak?) ) ]
+ [(u16vector)
+ (let ([v (##sys#slot obj 1)])
+ (##sys#check-range index 0 (##sys#size v) loc)
+ (##core#inline_allocate ("C_a_i_make_locative" 5) 4 v index weak?) ) ]
+ [(s16vector)
+ (let ([v (##sys#slot obj 1)])
+ (##sys#check-range index 0 (##sys#size v) loc)
+ (##core#inline_allocate ("C_a_i_make_locative" 5) 5 v index weak?) ) ]
+ [(u32vector)
+ (let ([v (##sys#slot obj 1)])
+ (##sys#check-range index 0 (##sys#size v) loc)
+ (##core#inline_allocate ("C_a_i_make_locative" 5) 6 v index weak?) ) ]
+ [(s32vector)
+ (let ([v (##sys#slot obj 1)])
+ (##sys#check-range index 0 (##sys#size v) loc)
+ (##core#inline_allocate ("C_a_i_make_locative" 5) 7 v index weak?) ) ]
+ [(f32vector)
+ (let ([v (##sys#slot obj 1)])
+ (##sys#check-range index 0 (##sys#size v) loc)
+ (##core#inline_allocate ("C_a_i_make_locative" 5) 8 v index weak?) ) ]
+ [(f64vector)
+ (let ([v (##sys#slot obj 1)])
+ (##sys#check-range index 0 (##sys#size v) loc)
+ (##core#inline_allocate ("C_a_i_make_locative" 5) 9 v index weak?) ) ]
+ [else
+ (##sys#check-range index 0 (fx- (##sys#size obj) 1) loc)
+ (##core#inline_allocate ("C_a_i_make_locative" 5) 0 obj (fx+ index 1) weak?) ] ) ]
+ [(string? obj)
+ (##sys#check-range index 0 (##sys#size obj) loc)
+ (##core#inline_allocate ("C_a_i_make_locative" 5) 1 obj index weak?) ]
+ [else
+ (##sys#signal-hook
+ #:type-error loc
+ "bad argument type - locative cannot refer to objects of this type"
+ obj) ] ) )
+
+
+;;; Importing from other namespaces:
+;
+; Some of these should go. Are they used anywhere?
+
+(define ##sys#find-symbol
+ (foreign-lambda scheme-object "C_find_symbol" scheme-object c-pointer) )
+
+(define ##sys#find-symbol-table
+ (foreign-lambda c-pointer "C_find_symbol_table" c-string) )
+
+(define ##sys#import
+ (let ([enum-syms! (foreign-lambda scheme-object "C_enumerate_symbols" c-pointer scheme-object)])
+ (lambda (ns . more)
+ (let-optionals more ([syms '()] [prefix #f])
+ (let ([prefix
+ (and prefix
+ (cond [(symbol? prefix) (##sys#slot prefix 1)]
+ [(string? prefix) prefix]
+ [else (##sys#signal-hook #:type-error "bad argument type - invalid prefix" prefix)] ) ) ] )
+ (let ([nsp (##sys#find-symbol-table (##sys#make-c-string (##sys#slot ns 1)))])
+ (define (copy s str)
+ (let ([s2 (##sys#intern-symbol
+ (if prefix
+ (##sys#string-append prefix str)
+ str) ) ] )
+ (##sys#setslot s2 0 (##sys#slot s 0)) ) )
+ (unless nsp (##sys#error "undefined namespace" ns))
+ (if (null? syms)
+ (let ([it (cons -1 '())])
+ (let loop ()
+ (let ([s (enum-syms! nsp it)])
+ (when s
+ (copy s (##sys#slot s 1))
+ (loop) ) ) ) )
+ (for-each
+ (lambda (ss)
+ (let ([old #f]
+ [new #f] )
+ (if (and (pair? ss) (pair? (##sys#slot ss 1)))
+ (begin
+ (set! old (##sys#slot ss 0))
+ (set! new (##sys#slot (##sys#slot ss 1) 0)) )
+ (begin
+ (set! old ss)
+ (set! new ss) ) )
+ (let* ([str (##sys#slot old 1)]
+ [s (##sys#find-symbol str nsp)] )
+ (unless s
+ (##sys#error "symbol not exported from namespace" ss ns) )
+ (copy s (##sys#slot new 1)) ) ) )
+ syms) ) ) ) ) ) ) )
+
+(define (##sys#namespace-ref ns sym . default)
+ (let ([s (##sys#find-symbol
+ (cond [(symbol? sym) (##sys#slot sym 1)]
+ [(string? sym) sym]
+ [else (##sys#signal-hook #:type-error "bad argument type - not a valid import name" sym)] )
+ (##sys#find-symbol-table (##sys#make-c-string (##sys#slot ns 1))) ) ] )
+ (cond [s (##core#inline "C_retrieve" s)]
+ [(pair? default) (car default)]
+ [else (##sys#error "symbol not exported from namespace" sym ns)] ) ) )
+
+(define (##sys#walk-namespace proc . args)
+ (let ([ns (if (pair? args) (car args) ".")])
+ (let ([nsp (##sys#find-symbol-table ns)]
+ [enum-syms! (foreign-lambda scheme-object "C_enumerate_symbols" c-pointer scheme-object)]
+ [pos (cons -1 '())])
+ (unless nsp (##sys#error "undefined namespace" ns))
+ (let loop ()
+ (let ([sym (enum-syms! nsp pos)])
+ (when sym
+ (proc sym)
+ (loop) ) ) ) ) ) )
+
+;;; More memory info
+
+(define (memory-statistics)
+ (let* ([free (##sys#gc #t)]
+ [info (##sys#memory-info)]
+ [hsize (##sys#slot info 0)] )
+ (vector hsize (fx- hsize free) (##sys#slot info 1)) ) )
+
+
+;;; Decorate procedure with arbitrary data
+
+(define (##sys#decorate-lambda proc pred decorator)
+ (let ((len (##sys#size proc)))
+ (let loop ((i (fx- len 1)))
+ (cond ((zero? i)
+ (let ((p2 (make-vector (fx+ len 1))))
+ (do ((i 1 (fx+ i 1)))
+ ((fx>= i len)
+ (##core#inline "C_vector_to_closure" p2)
+ (##core#inline "C_copy_pointer" proc p2)
+ (decorator p2 i) )
+ (##sys#setslot p2 i (##sys#slot proc i)) ) ) )
+ (else
+ (let ((x (##sys#slot proc i)))
+ (if (pred x)
+ (decorator proc i)
+ (loop (fx- i 1)) ) ) ) ) ) ) )
+
+(define (##sys#lambda-decoration proc pred)
+ (let loop ((i (fx- (##sys#size proc) 1)))
+ (and (fx> i 0)
+ (let ((x (##sys#slot proc i)))
+ (if (pred x)
+ x
+ (loop (fx- i 1)) ) ) ) ) )
+
+
+;;; Function debug info:
+
+(define (##sys#make-lambda-info str)
+ (let* ((sz (##sys#size str))
+ (info (##sys#make-string sz)) )
+ (##core#inline "C_copy_memory" info str sz)
+ (##core#inline "C_string_to_lambdainfo" info)
+ info) )
+
+(define (##sys#lambda-info? x)
+ (and (not (##sys#immediate? x)) (##core#inline "C_lambdainfop" x)) )
+
+(define (##sys#lambda-info proc)
+ (##sys#lambda-decoration proc ##sys#lambda-info?) )
+
+(define (##sys#lambda-info->string info)
+ (let* ((sz (##sys#size info))
+ (s (##sys#make-string sz)) )
+ (##core#inline "C_copy_memory" s info sz)
+ s) )
+
+(define procedure-information
+ (let ((open-input-string open-input-string))
+ (lambda (x)
+ (##sys#check-closure x 'procedure-information)
+ (and-let* ((info (##sys#lambda-info x)))
+ (##sys#read (open-input-string (##sys#lambda-info->string info)) #f) ) ) ) )
+
+
+;;; SRFI-17
+
+(define setter-tag (vector 'setter))
+
+(define-inline (setter? x)
+ (and (pair? x) (eq? setter-tag (##sys#slot x 0))) )
+
+(define ##sys#setter
+ (##sys#decorate-lambda
+ (lambda (proc)
+ (or (and-let* (((procedure? proc))
+ (d (##sys#lambda-decoration proc setter?)) )
+ (##sys#slot d 1) )
+ (##sys#error 'setter "no setter defined" proc) ) )
+ setter?
+ (lambda (proc i)
+ (##sys#setslot
+ proc i
+ (cons
+ setter-tag
+ (lambda (get set)
+ (if (procedure? get)
+ (let ((get2 (##sys#decorate-lambda
+ get
+ setter?
+ (lambda (proc i) (##sys#setslot proc i (cons setter-tag set)) proc))))
+ (if (eq? get get2)
+ get
+ (##sys#become! (list (cons get get2))) ) )
+ (error "can't set setter of non-procedure" get) ) ) ) )
+ proc) ) )
+
+(define setter ##sys#setter)
+
+(define (getter-with-setter get set)
+ (##sys#decorate-lambda
+ get
+ setter?
+ (lambda (proc i)
+ (##sys#setslot proc i (cons setter-tag set))
+ proc) ) )
+
+(define car (getter-with-setter car set-car!))
+(define cdr (getter-with-setter cdr set-cdr!))
+(define caar (getter-with-setter caar (lambda (x y) (set-car! (car x) y))))
+(define cadr (getter-with-setter cadr (lambda (x y) (set-car! (cdr x) y))))
+(define cdar (getter-with-setter cdar (lambda (x y) (set-cdr! (car x) y))))
+(define cddr (getter-with-setter cddr (lambda (x y) (set-cdr! (cdr x) y))))
+(define caaar (getter-with-setter caaar (lambda (x y) (set-car! (caar x) y))))
+(define caadr (getter-with-setter caadr (lambda (x y) (set-car! (cadr x) y))))
+(define cadar (getter-with-setter cadar (lambda (x y) (set-car! (cdar x) y))))
+(define caddr (getter-with-setter caddr (lambda (x y) (set-car! (cddr x) y))))
+(define cdaar (getter-with-setter cdaar (lambda (x y) (set-cdr! (caar x) y))))
+(define cdadr (getter-with-setter cdadr (lambda (x y) (set-cdr! (cadr x) y))))
+(define cddar (getter-with-setter cddar (lambda (x y) (set-cdr! (cdar x) y))))
+(define cdddr (getter-with-setter cdddr (lambda (x y) (set-cdr! (cddr x) y))))
+(define string-ref (getter-with-setter string-ref string-set!))
+(define vector-ref (getter-with-setter vector-ref vector-set!))
+
+
+;;; Property lists
+
+(define (##sys#put! sym prop val)
+ (##sys#check-symbol sym 'put!)
+ (let loop ((plist (##sys#slot sym 2)))
+ (cond ((null? plist) (##sys#setslot sym 2 (cons prop (cons val (##sys#slot sym 2)))) )
+ ((eq? (##sys#slot plist 0) prop) (##sys#setslot (##sys#slot plist 1) 0 val))
+ (else (loop (##sys#slot (##sys#slot plist 1) 1)))) )
+ val)
+
+(define put! ##sys#put!)
+
+(define (##sys#get sym prop . default)
+ (##sys#check-symbol sym 'get)
+ (let loop ((plist (##sys#slot sym 2)))
+ (cond ((null? plist) (optional default #f))
+ ((eq? (##sys#slot plist 0) prop) (##sys#slot (##sys#slot plist 1) 0))
+ (else (loop (##sys#slot (##sys#slot plist 1) 1))))) )
+
+(define get (getter-with-setter ##sys#get put!))
+
+(define (remprop! sym prop)
+ (##sys#check-symbol sym 'remprop!)
+ (let loop ((plist (##sys#slot sym 2)) (ptl #f))
+ (and (not (null? plist))
+ (let* ((tl (##sys#slot plist 1))
+ (nxt (##sys#slot tl 1)))
+ (or (and (eq? (##sys#slot plist 0) prop)
+ (begin
+ (if ptl
+ (##sys#setslot ptl 1 nxt)
+ (##sys#setslot sym 2 nxt) )
+ #t ) )
+ (loop nxt tl) ) ) ) ) )
+
+(define symbol-plist
+ (getter-with-setter
+ (lambda (sym)
+ (##sys#check-symbol sym 'symbol-plist)
+ (##sys#slot sym 2) )
+ (lambda (sym lst)
+ (##sys#check-symbol sym 'symbol-plist)
+ (##sys#check-list lst 'symbol-plist/setter)
+ (##sys#setslot sym 2 lst) ) ) )
+
+(define (get-properties sym props)
+ (##sys#check-symbol sym 'get-properties)
+ (when (symbol? props)
+ (set! props (list props)) )
+ (##sys#check-list props 'get-properties)
+ (let loop ((plist (##sys#slot sym 2)))
+ (if (null? plist)
+ (values #f #f #f)
+ (let* ((prop (##sys#slot plist 0))
+ (tl (##sys#slot plist 1))
+ (nxt (##sys#slot tl 1)))
+ (if (memq prop props)
+ (values prop (##sys#slot tl 0) nxt)
+ (loop nxt) ) ) ) ) )
diff --git a/lolevel.import.scm b/lolevel.import.scm
new file mode 100644
index 00000000..58ea8f22
--- /dev/null
+++ b/lolevel.import.scm
@@ -0,0 +1,103 @@
+;;;; lolevel.import.scm - import library for "lolevel" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'lolevel
+ '(address->pointer
+ align-to-word
+ allocate
+ block-ref
+ block-set!
+ clear-unbound-variable-value!
+ extend-procedure
+ extended-procedure?
+ free
+ global-bound?
+ global-make-unbound!
+ global-ref
+ global-set!
+ invalid-procedure-call-handler
+ locative->object
+ locative-ref
+ locative-set!
+ locative?
+ make-locative
+ make-record-instance
+ make-weak-locative
+ move-memory!
+ mutate-procedure
+ null-pointer
+ null-pointer?
+ number-of-bytes
+ number-of-slots
+ object->pointer
+ object-become!
+ object-copy
+ object-evict
+ object-evict-to-location
+ object-evicted?
+ object-release
+ object-size
+ object-unevict
+ pointer->address
+ pointer-like?
+ pointer->object
+ pointer-f32-ref
+ pointer-f32-set!
+ pointer-f64-ref
+ pointer-f64-set!
+ pointer-offset
+ pointer-s16-ref
+ pointer-s16-set!
+ pointer-s32-ref
+ pointer-s32-set!
+ pointer-s8-ref
+ pointer-s8-set!
+ pointer-tag
+ pointer-u16-ref
+ pointer-u16-set!
+ pointer-u32-ref
+ pointer-u32-set!
+ pointer-u8-ref
+ pointer-u8-set!
+ pointer=?
+ pointer?
+ procedure-data
+ record->vector
+ record-instance?
+ record-instance-length
+ record-instance-slot
+ record-instance-slot-set!
+ record-instance-type
+ set-invalid-procedure-call-handler!
+ set-procedure-data!
+ set-unbound-variable-value!
+ tag-pointer
+ tagged-pointer?
+ unbound-variable-value
+ unbound-variable-given-value
+ unbound-variable-signals-error?
+ vector-like?))
diff --git a/lolevel.scm b/lolevel.scm
new file mode 100644
index 00000000..b27036a2
--- /dev/null
+++ b/lolevel.scm
@@ -0,0 +1,699 @@
+;;;; lolevel.scm - Low-level routines for CHICKEN
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit lolevel)
+ (uses srfi-69)
+ (usual-integrations)
+ (disable-warning var redef)
+ (hide ipc-hook-0 *set-invalid-procedure-call-handler! xproc-tag
+ ##sys#check-block
+ ##sys#check-become-alist
+ ##sys#check-generic-structure
+ ##sys#check-generic-vector )
+ (not inline ipc-hook-0 ##sys#invalid-procedure-call-hook)
+ (foreign-declare #<<EOF
+#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__)
+# include <sys/types.h>
+#endif
+#ifndef C_NONUNIX
+# include <sys/mman.h>
+#endif
+
+#define C_w2b(x) C_fix(C_wordstobytes(C_unfix(x)))
+#define C_pointer_eqp(x, y) C_mk_bool(C_c_pointer_nn(x) == C_c_pointer_nn(y))
+#define C_memmove_o(to, from, n, toff, foff) C_memmove((char *)(to) + (toff), (char *)(from) + (foff), (n))
+EOF
+) )
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ (no-bound-checks)
+ (no-procedure-checks-for-usual-bindings)
+ (bound-to-procedure
+ ##sys#check-pointer ##sys#check-closure ##sys#check-integer ##sys#check-special
+ ##sys#error ##sys#signal-hook ##sys#error-hook
+ ##sys#error-not-a-proper-list
+ make-hash-table hash-table-ref/default hash-table-set!
+ ##sys#make-pointer ##sys#make-tagged-pointer ##sys#make-locative ##sys#locative?
+ ##sys#become!
+ ##sys#make-string ##sys#make-vector ##sys#vector->closure!
+ make-property-condition make-composite-condition signal
+ ##sys#generic-structure?
+ ##sys#set-pointer-address! ##sys#address->pointer ##sys#pointer->address
+ ##sys#lambda-decoration ##sys#decorate-lambda
+ extend-procedure ) ) ] )
+
+(include "unsafe-declarations.scm")
+
+(register-feature! 'lolevel)
+
+
+;;; Helpers:
+
+(define-inline (%pointer? x)
+ (and (##core#inline "C_blockp" x) (##core#inline "C_anypointerp" x)) )
+
+(define-inline (%generic-pointer? x)
+ (or (%pointer? x)
+ (##core#inline "C_locativep" x) ) )
+
+(define-inline (%special-block? x)
+ ; generic-pointer, port, closure
+ (and (##core#inline "C_blockp" x) (##core#inline "C_specialp" x)) )
+
+(define-inline (%generic-vector? x)
+ (and (##core#inline "C_blockp" x)
+ (not (or (##core#inline "C_specialp" x)
+ (##core#inline "C_byteblockp" x)))) )
+
+(define-inline (%record-structure? x)
+ (and (##core#inline "C_blockp" x) (##core#inline "C_structurep" x)) )
+
+
+
+;;; Argument checking:
+
+(define (##sys#check-block x . loc)
+ (unless (##core#inline "C_blockp" x)
+ (##sys#error-hook
+ (foreign-value "C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR" int) (and (pair? loc) (car loc))
+ x) ) )
+
+(define (##sys#check-become-alist x loc)
+ (##sys#check-list x loc)
+ (let loop ([lst x])
+ (cond [(null? lst) ]
+ [(pair? lst)
+ (let ([a (car lst)])
+ (##sys#check-pair a loc)
+ (##sys#check-block (car a) loc)
+ (##sys#check-block (cdr a) loc)
+ (loop (cdr lst)) ) ]
+ [else
+ (##sys#signal-hook
+ #:type-error loc
+ "bad argument type - not an a-list of non-immediate objects" x) ] ) ) )
+
+(define (##sys#check-generic-structure x . loc)
+ (unless (%record-structure? x)
+ (##sys#signal-hook
+ #:type-error (and (pair? loc) (car loc))
+ "bad argument type - not a structure" x) ) )
+
+;; Vector, Structure, Pair, and Symbol
+
+(define (##sys#check-generic-vector x . loc)
+ (unless (%generic-vector? x)
+ (##sys#signal-hook
+ #:type-error (and (pair? loc) (car loc))
+ "bad argument type - not a vector-like object" x) ) )
+
+(define (##sys#check-pointer x . loc)
+ (unless (%pointer? x)
+ (##sys#error-hook
+ (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int)
+ (and (pair? loc) (car loc))
+ "bad argument type - not a pointer" x) ) )
+
+(cond-expand
+ [unsafe
+ (define-syntax ##sys#check-pointer
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-block
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-become-alist
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-generic-structure
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-generic-vector
+ (syntax-rules ()
+ ((_ . _) (##core#undefined)))) ]
+ [else] )
+
+
+;;; Move arbitrary blocks of memory around:
+
+(define move-memory!
+ (let ([memmove1 (foreign-lambda void "C_memmove_o" c-pointer c-pointer int int int)]
+ [memmove2 (foreign-lambda void "C_memmove_o" c-pointer scheme-pointer int int int)]
+ [memmove3 (foreign-lambda void "C_memmove_o" scheme-pointer c-pointer int int int)]
+ [memmove4 (foreign-lambda void "C_memmove_o" scheme-pointer scheme-pointer int int int)]
+ [typerr (lambda (x)
+ (##sys#error-hook
+ (foreign-value "C_BAD_ARGUMENT_TYPE_ERROR" int)
+ 'move-memory! x))]
+ [slot1structs '(mmap
+ u8vector u16vector u32vector s8vector s16vector s32vector
+ f32vector f64vector)] )
+ (lambda (from to #!optional n (foffset 0) (toffset 0))
+ ;
+ (define (nosizerr)
+ (##sys#error 'move-memory! "need number of bytes to move" from to))
+ ;
+ (define (sizerr . args)
+ (apply ##sys#error 'move-memory! "number of bytes to move too large" from to args))
+ ;
+ (define (checkn1 n nmax off)
+ (if (cond-expand [unsafe #t] [else (fx<= n (fx- nmax off))])
+ n
+ (sizerr n nmax) ) )
+ ;
+ (define (checkn2 n nmax nmax2 off1 off2)
+ (if (cond-expand [unsafe #t] [else (and (fx<= n (fx- nmax off1)) (fx<= n (fx- nmax2 off2)))])
+ n
+ (sizerr n nmax nmax2) ) )
+ ;
+ (##sys#check-block from 'move-memory!)
+ (##sys#check-block to 'move-memory!)
+ (let move ([from from] [to to])
+ (cond [(##sys#generic-structure? from)
+ (if (memq (##sys#slot from 0) slot1structs)
+ (move (##sys#slot from 1) to)
+ (typerr from) ) ]
+ [(##sys#generic-structure? to)
+ (if (memq (##sys#slot to 0) slot1structs)
+ (move from (##sys#slot to 1))
+ (typerr to) ) ]
+ [(%generic-pointer? from)
+ (cond [(%generic-pointer? to)
+ (memmove1 to from (or n (nosizerr)) toffset foffset)]
+ [(or (##sys#bytevector? to) (string? to))
+ (memmove3 to from (checkn1 (or n (nosizerr)) (##sys#size to) toffset) toffset foffset) ]
+ [else
+ (typerr to)] ) ]
+ [(or (##sys#bytevector? from) (string? from))
+ (let ([nfrom (##sys#size from)])
+ (cond [(%generic-pointer? to)
+ (memmove2 to from (checkn1 (or n nfrom) nfrom foffset) toffset foffset)]
+ [(or (##sys#bytevector? to) (string? to))
+ (memmove4 to from (checkn2 (or n nfrom) nfrom (##sys#size to) foffset toffset)
+ toffset foffset) ]
+ [else
+ (typerr to)] ) ) ]
+ [else
+ (typerr from)] ) ) ) ) )
+
+
+;;; Copy arbitrary object:
+
+(define (object-copy x)
+ (let copy ([x x])
+ (cond [(not (##core#inline "C_blockp" x)) x]
+ [(symbol? x) (##sys#intern-symbol (##sys#slot x 1))]
+ [else
+ (let* ([n (##sys#size x)]
+ [words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n)]
+ [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
+ (unless (or (##core#inline "C_byteblockp" x) (symbol? x))
+ (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
+ [(fx>= i n)]
+ (##sys#setslot y i (copy (##sys#slot y i))) ) )
+ y) ] ) ) )
+
+
+;;; Pointer operations:
+
+(define allocate (foreign-lambda c-pointer "C_malloc" int))
+(define free (foreign-lambda void "C_free" c-pointer))
+
+(define (pointer? x) (%pointer? x))
+
+(define (pointer-like? x) (%special-block? x))
+
+(define (address->pointer addr)
+ (##sys#check-integer addr 'address->pointer)
+ (##sys#address->pointer addr) )
+
+(define (pointer->address ptr)
+ (##sys#check-special ptr 'pointer->address)
+ (##sys#pointer->address ptr) )
+
+(define null-pointer ##sys#null-pointer)
+
+(define (null-pointer? ptr)
+ (##sys#check-special ptr 'null-pointer?)
+ (eq? 0 (##sys#pointer->address ptr) ) )
+
+(define (object->pointer x)
+ (and (##core#inline "C_blockp" x)
+ ((foreign-lambda* nonnull-c-pointer ((scheme-object x)) "return((void *)x);") x) ) )
+
+(define (pointer->object ptr)
+ (##sys#check-pointer ptr 'pointer->object)
+ (##core#inline "C_pointer_to_object" ptr) )
+
+(define (pointer=? p1 p2)
+ (##sys#check-special p1 'pointer=?)
+ (##sys#check-special p2 'pointer=?)
+ (##core#inline "C_pointer_eqp" p1 p2) )
+
+(define pointer-offset
+ (foreign-lambda* nonnull-c-pointer ([c-pointer ptr] [integer off])
+ "return((unsigned char *)ptr + off);") )
+
+(define align-to-word
+ (let ([align (foreign-lambda integer "C_align" integer)])
+ (lambda (x)
+ (cond [(integer? x)
+ (align x)]
+ [(%special-block? x)
+ (##sys#address->pointer (align (##sys#pointer->address x))) ]
+ [else
+ (##sys#signal-hook
+ #:type-error 'align-to-word
+ "bad argument type - not a pointer or integer" x)] ) ) ) )
+
+
+;;; Tagged-pointers:
+
+(define (tag-pointer ptr tag)
+ (let ([tp (##sys#make-tagged-pointer tag)])
+ (if (%special-block? ptr)
+ (##core#inline "C_copy_pointer" ptr tp)
+ (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'tag-pointer ptr) )
+ tp) )
+
+(define (tagged-pointer? x #!optional tag)
+ (and (##core#inline "C_blockp" x) (##core#inline "C_taggedpointerp" x)
+ (or (not tag)
+ (equal? tag (##sys#slot x 1)) ) ) )
+
+(define (pointer-tag x)
+ (if (%special-block? x)
+ (and (##core#inline "C_taggedpointerp" x)
+ (##sys#slot x 1) )
+ (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR" int) 'pointer-tag x) ) )
+
+
+;;; locatives:
+
+;; Locative layout:
+;
+; 0 Object-address + Byte-offset (address)
+; 1 Byte-offset (fixnum)
+; 2 Type (fixnum)
+; 0 vector or pair (C_SLOT_LOCATIVE)
+; 1 string (C_CHAR_LOCATIVE)
+; 2 u8vector or blob (C_U8_LOCATIVE)
+; 3 s8vector (C_S8_LOCATIVE)
+; 4 u16vector (C_U16_LOCATIVE)
+; 5 s16vector (C_S16_LOCATIVE)
+; 6 u32vector (C_U32_LOCATIVE)
+; 7 s32vector (C_S32_LOCATIVE)
+; 8 f32vector (C_F32_LOCATIVE)
+; 9 f64vector (C_F64_LOCATIVE)
+; 3 Object or #f, if weak (C_word)
+
+(define (make-locative obj . index)
+ (##sys#make-locative obj (optional index 0) #f 'make-locative) )
+
+(define (make-weak-locative obj . index)
+ (##sys#make-locative obj (optional index 0) #t 'make-weak-locative) )
+
+(define (locative-set! x y) (##core#inline "C_i_locative_set" x y))
+(define locative-ref (getter-with-setter (##core#primitive "C_locative_ref") locative-set!))
+(define (locative->object x) (##core#inline "C_i_locative_to_object" x))
+(define (locative? x) (and (##core#inline "C_blockp" x) (##core#inline "C_locativep" x)))
+
+
+;;; SRFI-4 number-vector:
+
+(define pointer-u8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned char *)p) = n;"))
+(define pointer-s8-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((char *)p) = n;"))
+(define pointer-u16-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((unsigned short *)p) = n;"))
+(define pointer-s16-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((short *)p) = n;"))
+(define pointer-u32-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((C_u32 *)p) = n;"))
+(define pointer-s32-set! (foreign-lambda* void ([c-pointer p] [int n]) "*((C_s32 *)p) = n;"))
+(define pointer-f32-set! (foreign-lambda* void ([c-pointer p] [double n]) "*((float *)p) = n;"))
+(define pointer-f64-set! (foreign-lambda* void ([c-pointer p] [float n]) "*((double *)p) = n;"))
+
+(define pointer-u8-ref
+ (getter-with-setter
+ (foreign-lambda* int ([c-pointer p]) "return(*((unsigned char *)p));")
+ pointer-u8-set!) )
+
+(define pointer-s8-ref
+ (getter-with-setter
+ (foreign-lambda* int ([c-pointer p]) "return(*((signed char *)p));")
+ pointer-s8-set!) )
+
+(define pointer-u16-ref
+ (getter-with-setter
+ (foreign-lambda* int ([c-pointer p]) "return(*((unsigned short *)p));")
+ pointer-u16-set!) )
+
+(define pointer-s16-ref
+ (getter-with-setter
+ (foreign-lambda* int ([c-pointer p]) "return(*((short *)p));")
+ pointer-s6-set!) )
+
+(define pointer-u32-ref
+ (getter-with-setter
+ (foreign-lambda* integer ([c-pointer p]) "return(*((C_u32 *)p));")
+ pointer-u32-set!) )
+
+(define pointer-s32-ref
+ (getter-with-setter
+ (foreign-lambda* integer ([c-pointer p]) "return(*((C_s32 *)p));")
+ pointer-s32-set!) )
+
+(define pointer-f32-ref
+ (getter-with-setter
+ (foreign-lambda* float ([c-pointer p]) "return(*((float *)p));")
+ pointer-f32-set!) )
+
+(define pointer-f64-ref
+ (getter-with-setter
+ (foreign-lambda* double ([c-pointer p]) "return(*((double *)p));")
+ pointer-f64-set!) )
+
+
+;;; Procedures extended with data:
+
+; Unique id for extended-procedures
+(define xproc-tag (vector 'extended))
+
+(define (extend-procedure proc data)
+ (##sys#check-closure proc 'extend-procedure)
+ (##sys#decorate-lambda
+ proc
+ (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0))))
+ (lambda (x i) (##sys#setslot x i (cons xproc-tag data)) x) ) )
+
+(define-inline (%procedure-data proc)
+ (##sys#lambda-decoration proc (lambda (x) (and (pair? x) (eq? xproc-tag (##sys#slot x 0))))) )
+
+(define (extended-procedure? x)
+ (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
+ (%procedure-data x)
+ #t) )
+
+(define (procedure-data x)
+ (and (##core#inline "C_blockp" x) (##core#inline "C_closurep" x)
+ (and-let* ([d (%procedure-data x)])
+ (##sys#slot d 1) ) ) )
+
+(define set-procedure-data!
+ (let ((extend-procedure extend-procedure))
+ (lambda (proc x)
+ (let ((p2 (extend-procedure proc x)))
+ (if (eq? p2 proc)
+ proc
+ (##sys#signal-hook
+ #:type-error 'set-procedure-data!
+ "bad argument type - not an extended procedure" proc) ) ) ) ) )
+
+
+;;; Accessors for arbitrary vector-like block objects:
+
+(define block-set! ##sys#block-set!)
+(define block-ref (getter-with-setter ##sys#block-ref ##sys#block-set!))
+
+(define (vector-like? x)
+ (%generic-vector? x) )
+
+(define (number-of-slots x)
+ (##sys#check-generic-vector x 'number-of-slots)
+ (##sys#size x) )
+
+(define (number-of-bytes x)
+ (cond [(not (##core#inline "C_blockp" x))
+ (##sys#signal-hook
+ #:type-error 'number-of-bytes
+ "cannot compute number of bytes of immediate object" x) ]
+ [(##core#inline "C_byteblockp" x)
+ (##sys#size x)]
+ [else
+ (##core#inline "C_w2b" (##sys#size x))] ) )
+
+
+;;; Record objects:
+
+;; Record layout:
+;
+; 0 Tag (symbol)
+; 1..N Slot (object)
+
+(define (make-record-instance type . args)
+ (##sys#check-symbol type 'make-record-instance)
+ (apply ##sys#make-structure type args) )
+
+(define (record-instance? x #!optional type)
+ (and (%record-structure? x)
+ (or (not type)
+ (eq? type (##sys#slot x 0)))) )
+
+(define (record-instance-type x)
+ (##sys#check-generic-structure x 'record-instance-type)
+ (##sys#slot x 0) )
+
+(define (record-instance-length x)
+ (##sys#check-generic-structure x 'record-instance-length)
+ (fx- (##sys#size x) 1) )
+
+(define (record-instance-slot-set! x i y)
+ (##sys#check-generic-structure x 'record-instance-slot-set!)
+ (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot-set!)
+ (##sys#setslot x (fx+ i 1) y) )
+
+(define record-instance-slot
+ (getter-with-setter
+ (lambda (x i)
+ (##sys#check-generic-structure x 'record-instance-slot)
+ (##sys#check-range i 0 (fx- (##sys#size x) 1) 'record-instance-slot)
+ (##sys#slot x (fx+ i 1)) )
+ record-instance-slot-set!))
+
+(define (record->vector x)
+ (##sys#check-generic-structure x 'record->vector)
+ (let* ([n (##sys#size x)]
+ [v (##sys#make-vector n)] )
+ (do ([i 0 (fx+ i 1)])
+ [(fx>= i n) v]
+ (##sys#setslot v i (##sys#slot x i)) ) ) )
+
+
+
+;;; Evict objects into static memory:
+
+(define-constant evict-table-size 301)
+
+(define (object-evicted? x) (##core#inline "C_permanentp" x))
+
+(define (object-evict x . allocator)
+ (let ([allocator
+ (if (pair? allocator) (car allocator) (foreign-lambda c-pointer "C_malloc" int) ) ]
+ [tab (make-hash-table eq?)] )
+ (##sys#check-closure allocator 'object-evict)
+ (let evict ([x x])
+ (cond [(not (##core#inline "C_blockp" x)) x ]
+ [(hash-table-ref/default tab x #f) ]
+ [else
+ (let* ([n (##sys#size x)]
+ [bytes (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))]
+ [y (##core#inline "C_evict_block" x (allocator (fx+ bytes (##core#inline "C_bytes" 1))))] )
+ (when (symbol? x) (##sys#setislot y 0 (void)))
+ (hash-table-set! tab x y)
+ (unless (##core#inline "C_byteblockp" x)
+ (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
+ [(fx>= i n)]
+ ;; Note the use of `##sys#setislot' to avoid an entry in the mutations-table:
+ (##sys#setislot y i (evict (##sys#slot x i))) ) )
+ y ) ] ) ) ) )
+
+(define (object-evict-to-location x ptr . limit)
+ (cond-expand [(not unsafe) (##sys#check-special ptr 'object-evict-to-location)] [else])
+ (let* ([limit (and (pair? limit)
+ (let ([limit (car limit)])
+ (##sys#check-exact limit 'object-evict-to-location)
+ limit)) ]
+ [ptr2 (##sys#address->pointer (##sys#pointer->address ptr))]
+ [tab (make-hash-table eq?)]
+ [x2
+ (let evict ([x x])
+ (cond [(not (##core#inline "C_blockp" x)) x ]
+ [(hash-table-ref/default tab x #f) ]
+ [else
+ (let* ([n (##sys#size x)]
+ [bytes
+ (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
+ (##core#inline "C_bytes" 1) ) ] )
+ (when limit
+ (set! limit (fx- limit bytes))
+ (when (fx< limit 0)
+ (signal
+ (make-composite-condition
+ (make-property-condition
+ 'exn 'location 'object-evict-to-location
+ 'message "cannot evict object - limit exceeded"
+ 'arguments (list x limit))
+ (make-property-condition 'evict 'limit limit) ) ) ) )
+ (let ([y (##core#inline "C_evict_block" x ptr2)])
+ (when (symbol? x) (##sys#setislot y 0 (void)))
+ (##sys#set-pointer-address! ptr2 (+ (##sys#pointer->address ptr2) bytes))
+ (hash-table-set! tab x y)
+ (unless (##core#inline "C_byteblockp" x)
+ (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)] )
+ [(fx>= i n)]
+ (##sys#setislot y i (evict (##sys#slot x i))) ) ) ; see above
+ y) ) ] ) ) ] )
+ (values x2 ptr2) ) )
+
+(define (object-release x . releaser)
+ (let ([free (if (pair? releaser)
+ (car releaser)
+ (foreign-lambda void "C_free" c-pointer) ) ]
+ [released '() ] )
+ (let release ([x x])
+ (cond [(not (##core#inline "C_blockp" x)) x ]
+ [(not (##core#inline "C_permanentp" x)) x ]
+ [(memq x released) x ]
+ [else
+ (let ([n (##sys#size x)])
+ (set! released (cons x released))
+ (unless (##core#inline "C_byteblockp" x)
+ (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
+ [(fx>= i n)]
+ (release (##sys#slot x i))) )
+ (free (##sys#address->pointer (##core#inline_allocate ("C_block_address" 4) x))) ) ] ) ) ) )
+
+(define (object-size x)
+ (let ([tab (make-hash-table eq?)])
+ (let evict ([x x])
+ (cond [(not (##core#inline "C_blockp" x)) 0 ]
+ [(hash-table-ref/default tab x #f) 0 ]
+ [else
+ (let* ([n (##sys#size x)]
+ [bytes
+ (fx+ (if (##core#inline "C_byteblockp" x) (align-to-word n) (##core#inline "C_bytes" n))
+ (##core#inline "C_bytes" 1) ) ] )
+ (hash-table-set! tab x #t)
+ (unless (##core#inline "C_byteblockp" x)
+ (do ([i (if (or (##core#inline "C_specialp" x) (symbol? x)) 1 0) (fx+ i 1)])
+ [(fx>= i n)]
+ (set! bytes (fx+ (evict (##sys#slot x i)) bytes)) ) )
+ bytes) ] ) ) ) )
+
+(define (object-unevict x #!optional full)
+ (let ([tab (make-hash-table eq?)])
+ (let copy ([x x])
+ (cond [(not (##core#inline "C_blockp" x)) x ]
+ [(not (##core#inline "C_permanentp" x)) x ]
+ [(hash-table-ref/default tab x #f) ]
+ [(##core#inline "C_byteblockp" x)
+ (if full
+ (let ([y (##core#inline "C_copy_block" x (##sys#make-string (##sys#size x)))])
+ (hash-table-set! tab x y)
+ y)
+ x) ]
+ [(symbol? x)
+ (let ([y (##sys#intern-symbol (##sys#slot x 1))])
+ (hash-table-set! tab x y)
+ y) ]
+ [else
+ (let* ([words (##sys#size x)]
+ [y (##core#inline "C_copy_block" x (##sys#make-vector words))] )
+ (hash-table-set! tab x y)
+ (do ([i (if (##core#inline "C_specialp" x) 1 0) (fx+ i 1)])
+ ((fx>= i words))
+ (##sys#setslot y i (copy (##sys#slot y i))) )
+ y) ] ) ) ) )
+
+
+;;; `become':
+
+(define (object-become! alst)
+ (cond-expand [(not unsafe) (##sys#check-become-alist alst 'object-become!)] [else])
+ (##sys#become! alst) )
+
+(define (mutate-procedure old proc)
+ (##sys#check-closure old 'mutate-procedure)
+ (##sys#check-closure proc 'mutate-procedure)
+ (let* ([n (##sys#size old)]
+ [words (##core#inline "C_words" n)]
+ [new (##core#inline "C_copy_block" old (##sys#make-vector words))] )
+ (##sys#become! (list (cons old (proc new))))
+ new ) )
+
+
+;;; Hooks:
+
+; we need this because `##sys#invalid-procedure-call-hook' cannot
+; have free variables.
+(define ipc-hook-0 #f)
+
+(define (invalid-procedure-call-handler) ipc-hook-0)
+
+(define (set-invalid-procedure-call-handler! proc)
+ (##sys#check-closure proc 'set-invalid-procedure-call-handler!)
+ (set! ipc-hook-0 proc)
+ (set! ##sys#invalid-procedure-call-hook
+ (lambda args (ipc-hook-0 ##sys#last-invalid-procedure args))) )
+
+(define (unbound-variable-signals-error?) (not ##sys#unbound-variable-value-hook))
+
+; result only trusted when (unbound-variable-signals-error?) is #f
+(define (unbound-variable-given-value)
+ (and ##sys#unbound-variable-value-hook
+ (vector-ref ##sys#unbound-variable-value-hook 0)) )
+
+(define (set-unbound-variable-value! val) (set! ##sys#unbound-variable-value-hook (vector val)))
+
+(define (clear-unbound-variable-value!) (set! ##sys#unbound-variable-value-hook #f))
+
+; this should be the current value procedure
+(define (unbound-variable-value . val)
+ (set! ##sys#unbound-variable-value-hook
+ (and (pair? val)
+ (vector (car val)))) )
+
+
+;;; Access computed globals:
+
+(define (global-ref sym)
+ (##sys#check-symbol sym 'global-ref)
+ (##core#inline "C_retrieve" sym) )
+
+(define (global-set! sym x)
+ (##sys#check-symbol sym 'global-set!)
+ (##sys#setslot sym 0 x) )
+
+(define (global-bound? sym)
+ (##sys#check-symbol sym 'global-bound?)
+ (##sys#symbol-has-toplevel-binding? sym) )
+
+(define (global-make-unbound! sym)
+ (##sys#check-symbol sym 'global-make-unbound!)
+ (##sys#setslot sym 0 (##sys#slot '##sys#arbitrary-unbound-symbol 0))
+ sym )
diff --git a/manual/Accessing external objects b/manual/Accessing external objects
new file mode 100644
index 00000000..4da3c0cb
--- /dev/null
+++ b/manual/Accessing external objects
@@ -0,0 +1,161 @@
+[[tags: manual]]
+
+[[toc:]]
+
+== Accessing external objects
+
+=== foreign-code
+
+ [syntax] (foreign-code STRING ...)
+
+Executes the embedded C/C++ code {{STRING ...}}, which should
+be a sequence of C statements, which are executed and return an unspecified result.
+
+<enscript highlight=scheme>
+(foreign-code "doSomeInitStuff();") => #<unspecified>
+</enscript>
+
+Code wrapped inside {{foreign-code}} may not invoke callbacks into Scheme.
+
+
+=== foreign-value
+
+ [syntax] (foreign-value CODE TYPE)
+
+Evaluates the embedded C/C++ expression {{CODE}} (which may be a string or symbol), returning a value of type given
+in the foreign-type specifier {{TYPE}}.
+
+<enscript highlight=scheme>
+(print (foreign-value "my_version_string" c-string))
+</enscript>
+
+
+=== foreign-declare
+
+ [syntax] (foreign-declare STRING ...)
+
+Include given strings verbatim into header of generated file.
+
+
+=== define-foreign-type
+
+ [syntax] (define-foreign-type NAME TYPE [ARGCONVERT [RETCONVERT]])
+
+Defines an alias for {{TYPE}} with the name {{NAME}} (a symbol).
+{{TYPE}} may be a type-specifier or a string naming a C type. The
+namespace of foreign type specifiers is separate from the normal
+Scheme namespace. The optional arguments {{ARGCONVERT}} and
+{{RETCONVERT}} should evaluate to procedures that map argument- and
+result-values to a value that can be transformed to {{TYPE}}:
+
+<enscript highlight=scheme>
+(define-foreign-type char-vector
+ nonnull-c-string
+ (compose list->string vector->list)
+ (compose list->vector string->list) )
+
+(define strlen
+ (foreign-lambda int "strlen" char-vector) )
+
+(strlen '#(#\a #\b #\c)) ==> 3
+
+(define memset
+ (foreign-lambda char-vector "memset" char-vector char int) )
+
+(memset '#(#_ #_ #_) #\X 3) ==> #(#\X #\X #\X)
+</enscript>
+
+Foreign type-definitions are only visible in the compilation-unit in which
+they are defined, so use {{include}} to use the same definitions
+in multiple files.
+
+
+=== define-foreign-variable
+
+ [syntax] (define-foreign-variable NAME TYPE [STRING])
+
+Defines a foreign variable of name {{NAME}} (a symbol). {{STRING}}
+should be the real name of a foreign variable or parameterless
+macro. If {{STRING}} is not given, then the variable name {{NAME}}
+will be converted to a string and used instead. All references and
+assignments (via {{set!}}) are modified to correctly convert values
+between Scheme and C representation. This foreign variable can only be
+accessed in the current compilation unit, but the name can be
+lexically shadowed. Note that {{STRING}} can name an arbitrary C
+expression. If no assignments are performed, then {{STRING}} doesn't
+even have to specify an lvalue.
+
+
+=== foreign-lambda
+
+ [syntax] (foreign-lambda RETURNTYPE NAME ARGTYPE ...)
+
+Represents a
+binding to an external routine. This form can be used in the position
+of an ordinary {{lambda}} expression. {{NAME}} specifies the
+name of the external procedure and should be a string or a symbol.
+
+
+=== foreign-lambda*
+
+ [syntax] (foreign-lambda* RETURNTYPE ((ARGTYPE VARIABLE) ...) STRING ...)
+
+Similar to {{foreign-lambda}}, but instead of generating code to
+call an external function, the body of the C procedure is directly given
+in {{STRING ...}}:
+
+<enscript highlight=scheme>
+(define my-strlen
+ (foreign-lambda* int ((c-string str))
+ "int n = 0;
+ while(*(str++)) ++n;
+ C_return(n);") )
+
+(my-strlen "one two three") ==> 13
+</enscript>
+
+For obscure technical reasons you should use the {{C_return}} macro instead of the normal {{return}} statement
+to return a result from the foreign lambda body as some cleanup code has to be run before execution
+commences in the calling code.
+
+=== foreign-safe-lambda
+
+ [syntax] (foreign-safe-lambda RETURNTYPE NAME ARGTYPE ...)
+
+This is similar to {{foreign-lambda}}, but also allows the called
+function to call Scheme functions and allocate Scheme data-objects. See [[Callbacks]].
+
+
+=== foreign-safe-lambda*
+
+ [syntax] (foreign-safe-lambda* RETURNTYPE ((ARGTYPE VARIABLE)...) STRING ...)
+
+This is similar to {{foreign-lambda*}}, but also allows the called
+function to call Scheme functions and allocate Scheme data-objects. See [[Callbacks]].
+
+
+
+=== foreign-primitive
+
+ [syntax] (foreign-primitive [RETURNTYPE] ((ARGTYPE VARIABLE) ...) STRING ...)
+
+This is also similar to {{foreign-lambda*}} but the code will be executed
+in a ''primitive'' CPS context, which means it will not actually return, but
+call it's continuation on exit. This means that code inside this form may
+allocate Scheme data on the C stack (the ''nursery'') with {{C_alloc}}
+(see below). If the {{RETURNTYPE}} is omitted it defaults to {{void}}.
+You can return multiple values inside the body of the {{foreign-primitive}}
+form by calling this C function:
+
+<enscript highlight=scheme>
+C_values(N + 2, C_SCHEME_UNDEFINED, C_k, X1, ...)
+</enscript>
+
+where {{N}} is the number of values to be returned, and {{X1, ...}} are the
+results, which should be Scheme data objects. When returning multiple values, the
+return-type should be omitted.
+
+---
+Previous: [[Interface to external functions and variables]]
+
+Next: [[Foreign type specifiers]]
diff --git a/manual/Acknowledgements b/manual/Acknowledgements
new file mode 100644
index 00000000..8bee3a6d
--- /dev/null
+++ b/manual/Acknowledgements
@@ -0,0 +1,80 @@
+[[tags: manual]]
+
+== Acknowledgements
+
+Many thanks to Nico Amtsberg, Alonso Andres, William Annis, Marc
+Baily, Peter Barabas, Jonah Beckford, Arto Bendiken, Kevin Beranek,
+Peter Bex, Jean-Francois Bignolles, Alaric Blagrave-Snellpym, Dave
+Bodenstab, Fabian Boehlke, T. Kurt Bond, Ashley Bone, Dominique
+Boucher, Terence Brannon, Roy Bryant, Adam Buchbinder, Hans Bulfone,
+Category 5, Taylor Campbell, Naruto Canada, Esteban U. Caamano Castro,
+Franklin Chen, Thomas Chust, Gian Paolo Ciceri, Fulvio Ciriaco, Tobia
+Conforto, John Cowan, Grzegorz Chrupała, James Crippen, Tollef
+Fog Heen, Drew Hess, Alejandro Forero Cuervo, Linh Dang, Brian
+Denheyer, dgym, Don, Chris Double, Brown Dragon, Jarod Eells, Petter
+Egesund, Steve Elkins, Daniel B. Faken, Will Farr, Graham Fawcett,
+Marc Feeley, Fizzie, Matthew Flatt, Kimura Fuyuki, Tony Garnock-Jones,
+Martin Gasbichler, Abdulaziz Ghuloum, Joey Gibson, Stephen C. Gilardi,
+Mario Domenech Goulart, Joshua Griffith, Johannes Groedem, Damian
+Gryski, Andreas Gustafsson, Sven Hartrumpf, Jun-ichiro itojun Hagino,
+Ahdi Hargo, Matthias Heiler, Karl M. Hegbloom, William P. Heinemann,
+Bill Hoffman, Bruce Hoult, Hans Huebner, Markus Huelsmann, Goetz
+Isenmann, Paulo Jabardo, Wietse Jacobs, David Janssens, Christian
+Jaeger, Matt Jones, Dale Jordan, Valentin Kamyshenko, Daishi Kato,
+Peter Keller, Brad Kind, Ron Kneusel, Matthias Koeppe, Krysztof
+Kowałczyk, Andre Kuehne, Todd R. Kueny Sr, Goran Krampe, David
+Krentzlin, Ben Kurtz, Micky Latowicki, John Lenz, Kirill Lisovsky,
+Juergen Lorenz, Kon Lovett, Lam Luu, Leonardo Valeri Manera, Dennis
+Marti, Charles Martin, Bob McIsaac, Alain Mellan, Eric Merrit, Perry
+Metzger, Scott G. Miller, Mikael, Bruce Mitchener, Fadi Moukayed,
+Chris Moline, Eric E. Moore, Julian Morrison, Dan Muresan, David
+N. Murray, Lars Nilsson, Ian Oversby, o.t., Gene Pavlovsky, Levi
+Pearson, Nicolas Pelletier, Carlos Pita, Robin Lee Powell, Pupeno,
+Davide Puricelli, presto, Doug Quale, Eric Raible, Ivan Raikov, Joel
+Reymont, Eric Rochester, Andreas Rottman, David Rush, Lars Rustemeier,
+Daniel Sadilek, Oskar Schirmer, Burton Samograd, Reed Sheridan, Ronald
+Schroeder, Spencer Schumann, Ivan Shcheklein, Alex Shinn, Ivan
+Shmakov, Shmul, Tony Sidaway, Jeffrey B. Siegal, Andrey Sidorenko,
+Michele Simionato, Volker Stolz, Jon Strait, Dorai Sitaram, Robert
+Skeels, Jason Songhurst, Clifford Stein, Sunnan, Zbigniew Szadkowski,
+Rick Taube, Nathan Thern, Mike Thomas, Minh Thu, Christian Tismer,
+Andre van Tonder, John Tobey, Henrik Tramberend, Vladimir Tsichevsky,
+Neil van Dyke, Sam Varner, Taylor Venable, Sander Vesik, Jaques
+Vidrine, Panagiotis Vossos, Shawn Wagner, Peter Wang, Ed Watkeys, Brad
+Watson, Thomas Weidner, Goeran Weinholt, Matthew Welland, Drake
+Wilson, Joerg Wittenberger, Peter Wright, Mark Wutka, Richard Zidlicky
+and Houman Zolfaghari for bug-fixes, tips and suggestions.
+
+CHICKEN uses the "irregex" regular expression package written by Alex Shinn.
+
+Special thanks to Brandon van Every for contributing the (now defunct)
+[[http://www.cmake.org|CMake]] support and for helping with Windows
+build issues.
+
+Also special thanks to Benedikt Rosenau for his constant encouragement.
+
+Thanks to Dunja Winkelmann for putting up with all of this.
+
+CHICKEN contains code from several people:
+
+; Richard Kelsey, Jonathan Rees and Taylor Campbell : {{syntax-rules}} expander
+; Eli Barzilay : some performance tweaks used in TinyCLOS.
+; Mikael Djurfeldt : topological sort used by compiler.
+; Marc Feeley : pretty-printer.
+; Aubrey Jaffer : implementation of {{dynamic-wind}}.
+; Richard O'Keefe : sorting routines.
+; Olin Shivers : implementation of {{let-optionals[*]}} and reference implementations of SRFI-1, SRFI-13 and SRFI-14.
+; Andrew Wilcox : queues.
+; [[http://chicken.wiki.br/users/Alex-Shinn|Alex Shinn]] : {{scheme-complete.el}} emacs tab-completion
+
+The documentation and examples for explicit renaming macros was taken from
+the following paper:
+
+William D. Clinger.
+[["Hygienic macros through explicit renaming"|ftp://ftp.cs.indiana.edu/pub/scheme-repository/doc/prop/exrename.ps.gz]]
+Lisp Pointers. IV(4). December 1991.
+
+---
+Previous: [[FAQ]]
+
+Next: [[Bibliography]]
diff --git a/manual/Basic mode of operation b/manual/Basic mode of operation
new file mode 100644
index 00000000..adf30a1c
--- /dev/null
+++ b/manual/Basic mode of operation
@@ -0,0 +1,59 @@
+[[tags: manual]]
+
+== Basic mode of operation
+
+The compiler translates Scheme source code into fairly portable C that
+can be compiled and linked with most available C compilers. CHICKEN supports
+the generation of executables and libraries, linked either statically or
+dynamically. Compiled Scheme code can be loaded dynamically, or can be
+embedded in applications written in other languages. Separate compilation
+of modules is fully supported.
+
+The most portable way of creating separately linkable entities is
+supported by so-called ''unit''s. A unit is a single
+compiled object module that contains a number of toplevel expressions that
+are executed either when the unit is the ''main'' unit or if the
+unit is ''used''. To use a unit, the unit has to be ''declare''ed
+as used, like this:
+
+<enscript highlight=scheme>
+(declare (uses UNITNAME))
+</enscript>
+
+The toplevel expressions of used units are executed in the order in
+which the units appear in the {{uses}} declaration. Units
+may be used multiple times and {{uses}} declarations may
+be circular (the unit is initialized at most once). To compile a file
+as a unit, add a {{unit}} declaration:
+
+<enscript highlight=scheme>
+(declare (unit UNITNAME))
+</enscript>
+
+When compiling different object modules, make sure to have one main
+unit. This unit is called initially and initializes all used units
+before executing its toplevel expressions. The main-unit has no
+{{unit}} declaration.
+
+Another method of using definitions in separate source files is to
+''include'' them. This simply inserts the code in a given file into
+the current file:
+
+<enscript highlight=scheme>
+(include "FILENAME")
+</enscript>
+
+Macro definitions are only available when processed by {{include}} or
+{{import}}. Macro definitions in separate units are not available,
+since they are defined at compile time, i.e the time when that other
+unit was compiled (macros can optionally be available at runtime, see
+{{define-syntax}} in [[Non-standard macros and special forms|Substitution forms and macros]]).
+
+On platforms that support dynamic loading of compiled code (Windows, most ELF based
+systems like Linux or BSD, MacOS X, and others) code can be compiled into a shared object {{.dll}}, {{.so}}, {{.dylib}}) and loaded
+dynamically into a running application.
+
+---
+Previous: [[Getting started]]
+
+Next: [[Using the compiler]]
diff --git a/manual/Bibliography b/manual/Bibliography
new file mode 100644
index 00000000..5ec19aba
--- /dev/null
+++ b/manual/Bibliography
@@ -0,0 +1,10 @@
+[[tags: manual]]
+
+== Bibliography
+
+Henry Baker: ''CONS Should Not CONS Its Arguments, Part II: Cheney on the M.T.A.'' [[http://home.pipeline.com/~hbaker1/CheneyMTA.html]]
+
+''Revised^5 Report on the Algorithmic Language Scheme'' [[http://www.schemers.org/Documents/Standards/R5RS]]
+
+---
+Previous: [[Acknowledgements]]
diff --git a/manual/Bugs and limitations b/manual/Bugs and limitations
new file mode 100644
index 00000000..213c9c35
--- /dev/null
+++ b/manual/Bugs and limitations
@@ -0,0 +1,16 @@
+[[tags: manual]]
+
+== Bugs and limitations
+
+* Compiling large files takes too much time.
+
+* If a known procedure has unused arguments, but is always called without those parameters, then the optimizer ''repairs'' the procedure in certain situations and removes the parameter from the lambda-list.
+
+* {{port-position}} currently works only for input ports.
+
+* Leaf routine optimization can theoretically result in code that thrashes, if tight loops perform excessively many mutations.
+
+---
+Previous: [[Data representation]]
+
+Next: [[FAQ]]
diff --git a/manual/C interface b/manual/C interface
new file mode 100644
index 00000000..c94fbbe8
--- /dev/null
+++ b/manual/C interface
@@ -0,0 +1,392 @@
+[[tags: manual]]
+[[toc:]]
+
+
+== C interface
+
+
+The following functions and macros are available for C code that invokes
+Scheme or foreign procedures that are called by Scheme:
+
+
+
+=== C_save
+
+ [C macro] void C_save (C_word x) :
+
+Saves the Scheme data object {{x}} on the temporary stack.
+
+
+=== C_restore
+
+ [C macro] void C_restore
+
+Pops and returns the topmost value from the temporary stack.
+
+
+=== C_fix
+
+ [C macro] C_word C_fix (int integer)
+
+=== C_make_character
+
+ [C macro] C_word C_make_character (int char_code)
+
+=== C_SCHEME_END_OF_LIST
+
+ [C macro] C_SCHEME_END_OF_LIST
+
+=== C_word C_SCHEME_END_OF_FILE
+
+ [C macro] C_SCHEME_END_OF_FILE
+
+=== C_word C_SCHEME_FALSE
+
+ [C macro] C_SCHEME_FALSE
+
+=== C_word C_SCHEME_TRUE
+
+ [C macro] C_SCHEME_TRUE
+
+These macros return immediate Scheme data objects.
+
+
+=== C_string
+
+ [C function] C_word C_string (C_word **ptr, int length, char *string)
+
+=== C_string2
+
+ [C function] C_word C_string2 (C_word **ptr, char *zero_terminated_string)
+
+=== C_intern2
+
+ [C function] C_word C_intern2 (C_word **ptr, char *zero_terminated_string)
+
+=== C_intern3
+
+ [C function] C_word C_intern3 (C_word **ptr, char *zero_terminated_string, C_word initial_value)
+
+=== C_pair
+
+ [C function] C_word C_pair (C_word **ptr, C_word car, C_word cdr)
+
+=== C_flonum
+
+ [C function] C_word C_flonum (C_word **ptr, double number)
+
+=== C_int_to_num
+
+ [C function] C_word C_int_to_num (C_word **ptr, int integer)
+
+=== C_mpointer
+
+ [C function] C_word C_mpointer (C_word **ptr, void *pointer)
+
+=== C_vector
+
+ [C function] C_word C_vector (C_word **ptr, int length, ...)
+
+=== C_list
+
+ [C function] C_word C_list (C_word **ptr, int length, ...)
+
+These functions allocate memory from {{ptr}} and initialize a fresh
+data object. The new data object is returned. {{ptr}} should be the
+'''address''' of an allocation pointer created with {{C_alloc}}.
+
+
+=== C_alloc
+
+ [C macro] C_word* C_alloc (int words)
+
+Allocates memory from the C stack ({{C_alloc}}) and returns a pointer to
+it. {{words}} should be the number of words needed for all data
+objects that are to be created in this function. Note that stack-allocated
+data objects have to be passed to Scheme callback functions, or they will
+not be seen by the garbage collector. This is really only usable for
+callback procedure invocations, make sure not to use it in normal code,
+because the allocated memory will be re-used after the foreign procedure
+returns. When invoking Scheme callback procedures a minor garbage
+collection is performed, so data allocated with {{C_alloc}}
+will already have moved to a safe place.
+
+Note that {{C_alloc}} is really just a wrapper around {{alloca}},
+and can also be simulated by declaring a stack-allocated array of
+{{C_word}}s:
+
+
+=== C_SIZEOF_LIST
+
+ [C macro] int C_SIZEOF_LIST (int length)
+
+=== C_SIZEOF_STRING
+
+ [C macro] int C_SIZEOF_STRING (int length)
+
+=== C_SIZEOF_VECTOR
+
+ [C macro] int C_SIZEOF_VECTOR (int length)
+
+=== C_SIZEOF_INTERNED_SYMBOL
+
+ [C macro] int C_SIZEOF_INTERNED_SYMBOL (int length)
+
+=== C_SIZEOF_PAIR
+
+ [C macro] int C_SIZEOF_PAIR
+
+=== C_SIZEOF_FLONUM
+
+ [C macro] int C_SIZEOF_FLONUM
+
+=== C_SIZEOF_POINTER
+
+ [C macro] int C_SIZEOF_POINTER
+
+=== C_SIZEOF_LOCATIVE
+
+ [C macro] int C_SIZEOF_LOCATIVE
+
+=== C_SIZEOF_TAGGED_POINTER
+
+ [C macro] int C_SIZEOF_TAGGED_POINTER
+
+These are macros that return the size in words needed for a data object
+of a given type.
+
+
+=== C_character_code
+
+ [C macro] int C_character_code (C_word character)
+
+=== C_unfix
+
+ [C macro] int C_unfix (C_word fixnum)
+
+=== C_flonum_magnitude
+
+ [C macro] double C_flonum_magnitude (C_word flonum)
+
+=== C_c_string
+
+ [C function] char* C_c_string (C_word string)
+
+=== C_num_to_int
+
+ [C function] int C_num_to_int (C_word fixnum_or_flonum)
+
+=== C_pointer_address
+
+ [C function] void* C_pointer_address (C_word pointer)
+
+These macros and functions can be used to convert Scheme data objects
+back to C data. Note that {{C_c_string()}} returns a pointer
+to the character buffer of the actual Scheme object and is not
+zero-terminated.
+
+
+=== C_header_size
+
+ [C macro] int C_header_size (C_word x)
+
+=== C_header_bits
+
+ [C macro] int C_header_bits (C_word x)
+
+Return the number of elements and the type-bits of the non-immediate
+Scheme data object {{x}}.
+
+
+=== C_block_item
+
+ [C macro] C_word C_block_item (C_word x, int index)
+
+This macro can be used to access slots of the non-immediate Scheme data
+object {{x}}. {{index}} specifies the index of the slot to
+be fetched, starting at 0. Pairs have 2 slots, one for the '''car'''
+and one for the '''cdr'''. Vectors have one slot for each element.
+
+
+=== C_u_i_car
+
+ [C macro] C_word C_u_i_car (C_word x)
+
+=== C_u_i_cdr
+
+ [C macro] C_word C_u_i_cdr (C_word x)
+
+Aliases for {{C_block_item(x, 0)}} and {{C_block_item(x, 1)}}, respectively.
+
+
+=== C_data_pointer
+
+ [C macro] void* C_data_pointer (C_word x)
+
+Returns a pointer to the data-section of a non-immediate Scheme object.
+
+
+=== C_make_header
+
+ [C macro] C_word C_make_header (C_word bits, C_word size)
+
+A macro to build a Scheme object header from its bits and size parts.
+
+
+=== C_mutate
+
+ [C function] C_word C_mutate (C_word *slot, C_word val)
+
+Assign the Scheme value {{val}} to the location specified by
+{{slot}}. If the value points to data inside the nursery (the first
+heap-generation), then the garbage collector will remember to handle the
+data appropriately. Assigning nursery-pointers directly will otherwise
+result in lost data. Note that no copying takes place at the moment
+when {{C_mutate}} is called, but later - at the next (minor) garbage
+collection.
+
+
+=== C_symbol_value
+
+ [C macro] C_word C_symbol_value (C_word symbol)
+
+Returns the global value of the variable with the name {{symbol}}. If the
+variable is unbound {{C_SCHEME_UNBOUND}} is returned. You can set a variable's
+value with {{C_mutate(&C_symbol_value(SYMBOL), VALUE)}}.
+
+
+=== C_gc_protect
+
+ [C function] void C_gc_protect (C_word *ptrs[], int n)
+
+Registers {{n}} variables at address {{ptrs}} to be garbage collection roots.
+The locations should not contain pointers to data allocated in the nursery, only
+immediate values or pointers to heap-data are valid. Any
+assignment of potential nursery data into a root-array should be done
+via {{C_mutate()}}. The variables have to be initialized to sensible values
+before the next garbage collection starts (when in doubt, set all locations
+in {{ptrs}} to {{C_SCHEME_UNDEFINED}})
+{{C_gc_protect}} may not called before the runtime system has been
+initialized (either by {{CHICKEN_initialize}}, {{CHICKEN_run}} or
+{{CHICKEN_invoke}}.
+
+For a slightly simpler interface to creating and using GC roots see
+{{CHICKEN_new_gc_root}}.
+
+
+=== C_gc_unprotect
+
+ [C function] void C_gc_unprotect (int n)
+
+Removes the last {{n}} registered variables from the set of
+root variables.
+
+
+=== C_pre_gc_hook
+
+ [C Variable] void (*C_pre_gc_hook)(int mode)
+
+If not {{NULL}}, the function pointed to by this variable will be
+called before each garbage collection with a flag indicating what kind
+of collection was performed (either {{0}} for a minor collection or
+{{2}} for a resizing collection). A "resizing" collection means a
+secondary collection that moves all live data into a enlarged (or
+shrinked) heap-space. Minor collections happen very frequently, so the
+hook function should not consume too much time. The hook function may
+not invoke Scheme callbacks.
+
+Note that resizing collections may be nested in normal major collections.
+
+=== C_post_gc_hook
+
+ [C Variable] void (*C_post_gc_hook)(int mode, long ms)
+
+If not {{NULL}}, the function pointed to by this variable will be
+called after each garbage collection with a flag indicating what kind
+of collection was performed (either {{0}} for a minor collection,
+{{1}} for a major collection or {{2}} for a resizing
+collection). Minor collections happen very frequently, so the hook
+function should not consume too much time. The hook function may not
+invoke Scheme callbacks. The {{ms}} argument records the number of
+milliseconds required for the garbage collection, if the collection
+was a major one. For minor collections the value of the {{ms}} argument
+is undefined.
+
+
+
+=== An example for simple calls to foreign code involving callbacks
+
+ % cat foo.scm
+ #>
+ extern int callout(int, int, int);
+ <#
+
+ (define callout (foreign-safe-lambda int "callout" int int int))
+
+ (define-external (callin (scheme-object xyz)) int
+ (print "This is 'callin': " xyz)
+ 123)
+
+ (print (callout 1 2 3))
+
+ % cat bar.c
+ #include <stdio.h>
+ #include "chicken.h"
+
+ extern int callout(int, int, int);
+ extern int callin(C_word x);
+
+ int callout(int x, int y, int z)
+ {
+ C_word *ptr = C_alloc(C_SIZEOF_LIST(3));
+ C_word lst;
+
+ printf("This is 'callout': %d, %d, %d\n", x, y, z);
+ lst = C_list(&ptr, 3, C_fix(x), C_fix(y), C_fix(z));
+ return callin(lst); /* Note: `callin' will have GC'd the data in `ptr' */
+ }
+
+ % csc foo.scm bar.c -o foo
+ % foo
+ This is 'callout': 1, 2, 3
+ This is 'callin': (1 2 3)
+ 123
+
+
+=== Notes:
+
+* Scheme procedures can call C functions, and C functions can call
+ Scheme procedures, but for every pending C stack frame, the available
+ size of the first heap generation (the ''nursery'') will be decreased,
+ because the C stack is identical to the nursery. On systems with a small
+ nursery this might result in thrashing, since the C code between the
+ invocation of C from Scheme and the actual calling back to Scheme might
+ build up several stack-frames or allocates large amounts of stack data.
+ To prevent this it is advisable to increase the default nursery size,
+ either when compiling the file (using the {{-nursery}} option)
+ or when running the executable (using the {{-:s}} runtime option).
+* Calls to Scheme/C may be nested arbitrarily, and Scheme
+ continuations can be invoked as usual, but keep in mind that C stack
+ frames will not be recovered, when a Scheme procedure call from C does
+ not return normally.
+* When multiple threads are running concurrently, and control switches
+ from one thread to another, then the continuation of the current thread
+ is captured and saved. Any pending C stack frame still active from a
+ callback will remain on the stack until the threads is re-activated
+ again. This means that in a multithreading situation, when C callbacks
+ are involved, the available nursery space can be smaller than expected.
+ So doing many nested Scheme->C->Scheme calls can reduce the available
+ memory up to the point of thrashing. It is advisable to have only a
+ single thread with pending C stack-frames at any given time.
+* Pointers to Scheme data objects should not be stored in local or
+ global variables while calling back to Scheme. Any Scheme object not
+ passed back to Scheme will be reclaimed or moved by the garbage collector.
+* Calls from C to Scheme are never tail-recursive.
+* Continuations captured via {{call-with-current-continuation}}
+ and passed to C code can be invoked like any other Scheme procedure.
+
+
+---
+Previous: [[Other support procedures]]
+
+Next: [[Extensions]]
diff --git a/manual/Callbacks b/manual/Callbacks
new file mode 100644
index 00000000..8490b583
--- /dev/null
+++ b/manual/Callbacks
@@ -0,0 +1,99 @@
+[[tags: manual]]
+[[toc:]]
+
+== Callbacks
+
+
+To enable an external C function to call back to Scheme, the form
+{{foreign-safe-lambda}} (or {{foreign-safe-lambda*}})
+has to be used. This generates special code to save and restore important
+state information during execution of C code. There are two ways of
+calling Scheme procedures from C: the first is to invoke the runtime
+function {{C_callback}} with the closure to be called and the number
+of arguments. The second is to define an externally visible wrapper
+function around a Scheme procedure with the {{define-external}}
+form.
+
+Note: the names of all functions, variables and macros exported by the
+CHICKEN runtime system start with {{C_}}. It is advisable to
+use a different naming scheme for your own code to avoid name clashes.
+Callbacks (defined by {{define-external}})
+do not capture the lexical environment.
+
+Non-local exits leaving the scope of the invocation of a callback from Scheme into C
+will not remove the C call-frame from the stack (and will result in a memory
+leak). '''Note:''' The same applies to
+SRFI-18 threading, which is implemented with {{call/cc}};
+additionally, if you enter one callback, switch threads and then exit
+a different callback, your program is likely to crash.
+
+
+=== define-external
+
+ [syntax] (define-external [QUALIFIERS] (NAME (ARGUMENTTYPE1 VARIABLE1) ...) RETURNTYPE BODY ...)
+ [syntax] (define-external NAME TYPE [INIT])
+
+The first form defines an externally callable Scheme
+procedure. {{NAME}} should be a symbol, which, when converted to a
+string, represents a legal C identifier. {{ARGUMENTTYPE1 ...}} and
+{{RETURNTYPE}} are foreign type specifiers for the argument variables
+{{VAR1 ...}} and the result, respectively. {{QUALIFIERS}}
+is an optional qualifier for the foreign procedure definition, like
+{{__stdcall}}.
+
+<enscript highlight=scheme>
+(define-external (foo (c-string x)) int (string-length x))
+</enscript>
+
+The second form of {{define-external}} can be used to define
+variables that are accessible from foreign code. It declares
+a global variable named by the symbol {{NAME}} that
+has the type {{TYPE}}. {{INIT}} can be an arbitrary
+expression that is used to initialize the variable. {{NAME}} is
+accessible from Scheme just like any other foreign variable defined by
+{{define-foreign-variable}}.
+
+<enscript highlight=scheme>
+(define-external foo int 42)
+((foreign-lambda* int ()
+ "C_return(foo);")) ==> 42
+</enscript>
+
+'''Note:''' don't be tempted to
+assign strings or bytevectors to external variables. Garbage collection
+moves those objects around, so it is very bad idea to assign pointers
+to heap-data. If you have to do so, then copy the data object into
+statically allocated memory (for example by using {{object-evict}}).
+
+Results of type {{scheme-object}} returned by {{define-external}}
+are always allocated in the secondary heap, that is, not in the stack.
+=== C_callback
+
+ [C function] C_word C_callback (C_word closure, int argc)
+
+This function can be used to invoke the Scheme procedure {{closure}}.
+{{argc}} should contain the number of arguments that are passed to
+the procedure on the temporary stack. Values are put onto the temporary
+stack with the {{C_save}} macro.
+
+=== C_callback_adjust_stack
+
+ [C function] void C_callback_adjust_stack (C_word *ptr, int size)
+
+The runtime-system uses the stack as a special allocation area and
+internally holds pointers to estimated limits to distinguish between
+Scheme data objects inside the stack from objects outside of it. If
+you invoke callbacks at wildly differing stack-levels, these limits
+may shift from invocation to invocation. Callbacks defined with
+{{define-external}} will perform appropriate adjustments
+automatically, but if you invoke {{C_callback}} manually, you should
+perform a {{C_callback_adjust_stack}} to make sure the internal limits
+are set properly. {{ptr}} should point to some data object on the
+stack and {{size}} is the number of words contained in the data object
+(or some estimate). The call will make sure the limits are adjusted so
+that the value pointed to by {{ptr}} is located in the stack.
+
+---
+Previous: [[Embedding]]
+
+Next: [[Locations]]
diff --git a/manual/Data representation b/manual/Data representation
new file mode 100644
index 00000000..53049dc2
--- /dev/null
+++ b/manual/Data representation
@@ -0,0 +1,117 @@
+[[tags: manual]]
+
+== Data representation
+
+''Note: In all cases below, bits are numbered starting at 1 and beginning with the lowest-order bit.''
+
+There exist two different kinds of data objects in the CHICKEN system:
+immediate and non-immediate objects.
+
+=== Immediate objects
+
+Immediate objects are represented by a single machine word, which is usually of 32 bits length, or 64 bits
+on 64-bit architectures. The immediate objects
+come in four different flavors:
+
+'''fixnums''', that is, small exact integers, where bit 1 is
+set to 1. This gives fixnums a range of 31 bits for the actual
+numeric value (63 bits on 64-bit architectures).
+
+'''characters''', where bits 1-4 are equal to {{C_CHARACTER_BITS}}. The
+Unicode code point of the character is encoded in bits 9 to 32.
+
+'''booleans''', where bits 1-4 are equal to {{C_BOOLEAN_BITS}}. Bit 5
+is one for #t and zero for #f.
+
+'''other values''': the empty list, the value of unbound identifiers,
+the undefined value (void), and end-of-file. Bits 1-4 are equal to {{C_SPECIAL_BITS}}; bits 5 to 8 contain an identifying
+number for this type of object. The following constants are
+defined: {{C_SCHEME_END_OF_LIST C_SCHEME_UNDEFINED C_SCHEME_UNBOUND
+C_SCHEME_END_OF_FILE}}
+
+Collectively, bits 1 and 2 are known as the ''immediate mark bits''. When bit 1 is set, the object is a fixnum, as described above, and bit 2 is part of its value. When bit 1 is clear but bit 2 is set, it is an immediate object other than a fixnum. If neither bit 1 nor bit 2 is set, the object is non-immediate, as described below.
+
+=== Non-immediate objects
+
+Non-immediate objects are blocks of data represented by a pointer into
+the heap. The pointer's immediate mark bits (bits 1 and 2) must be zero to indicate the object is non-immediate;
+this guarantees the data block is aligned on a 4-byte boundary, at minimum. Alignment of data words
+is required on modern architectures anyway, so we get the ability to distinguish between immediate and non-immediate objects for free.
+
+The first word of the data block contains a header, which gives
+information about the type of the object. The header has the size of a
+machine word, usually 32 bits (64 bits on 64 bit architectures).
+
+Bits 1 to 24 contain the length of the data object, which is either
+the number of bytes in a string (or byte-vector) or the the number
+of elements for a vector or for a structure type.
+
+Bits 25 to 28 contain the type code of the object.
+
+Bits 29 to 32 contain miscellaneous flags used for garbage
+collection or internal data type dispatching.
+These flags are:
+
+; C_GC_FORWARDING_BIT : Flag used for forwarding garbage collected object pointers.
+
+; C_BYTEBLOCK_BIT : Flag that specifies whether this data object contains raw bytes (a string or byte-vector) or pointers to other data objects.
+
+; C_SPECIALBLOCK_BIT : Flag that specifies whether this object contains a ''special'' non-object pointer value in its first slot. An example for this kind of objects are closures, which are a vector-type object with the code-pointer as the first item.
+
+; C_8ALIGN_BIT : Flag that specifies whether the data area of this block should be aligned on an 8-byte boundary (floating-point numbers, for example).
+
+The actual data follows immediately after the header. Note that
+block-addresses are always aligned to the native machine-word
+boundary. Scheme data objects map to blocks in the following manner:
+
+'''pairs''': vector-like object (type bits {{C_PAIR_TYPE}}),
+where the car and the cdr are contained in the first and second slots,
+respectively.
+
+'''vectors''': vector object (type bits {{C_VECTOR_TYPE}}).
+
+'''strings''': byte-vector object (type bits {{C_STRING_TYPE}}).
+
+'''procedures''': special vector object (type bits
+{{C_CLOSURE_TYPE}}). The first slot contains a pointer to a
+compiled C function. Any extra slots contain the free variables (since
+a flat closure representation is used).
+
+'''flonums''': a byte-vector object (type bits
+{{C_FLONUM_BITS}}). Slots one and two (or a single slot on
+64 bit architectures) contain a 64-bit floating-point number, in the
+representation used by the host systems C compiler.
+
+'''symbols''': a vector object (type bits {{C_SYMBOL_TYPE}}). Slots
+one and two contain the toplevel variable value and the print-name
+(a string) of the symbol, respectively.
+
+'''ports''': a special vector object (type bits
+{{C_PORT_TYPE}}). The first slot contains a pointer to a file-
+stream, if this is a file-pointer, or NULL if not. The other slots
+contain housekeeping data used for this port.
+
+'''structures''': a vector object (type bits
+{{C_STRUCTURE_TYPE}}). The first slot contains a symbol that
+specifies the kind of structure this record is an instance of. The other
+slots contain the actual record items.
+
+'''pointers''': a special vector object (type bits
+{{C_POINTER_TYPE}}). The single slot contains a machine pointer.
+
+'''tagged pointers''': similar to a pointer (type bits
+{{C_TAGGED_POINTER_TYPE}}), but the object contains an additional
+slot with a tag (an arbitrary data object) that identifies the type
+of the pointer.
+
+Data objects may be allocated outside of the garbage collected heap, as
+long as their layout follows the above mentioned scheme. But care has to
+be taken not to mutate these objects with heap-data (i.e. non-immediate
+objects), because this will confuse the garbage collector.
+
+For more information see the header file {{chicken.h}}.
+
+---
+Previous: [[Extensions]]
+
+Next: [[Bugs and limitations]]
diff --git a/manual/Declarations b/manual/Declarations
new file mode 100644
index 00000000..e62a79ce
--- /dev/null
+++ b/manual/Declarations
@@ -0,0 +1,381 @@
+[[tags: manual]]
+[[toc:]]
+
+
+== Declarations
+
+
+=== declare
+
+ [syntax] (declare DECLSPEC ...)
+
+Process declaration specifiers. Declarations always override
+any command-line settings. Declarations are valid for the whole
+compilation-unit (source file), the position of the declaration in
+the source file can be arbitrary. Declarations are ignored in the interpreter
+but not in code evaluated at compile-time (by {{eval-when}} or in
+syntax extensions loaded via {{require-extension}}).
+{{DECLSPEC}} may be any of the following:
+
+
+=== always-bound
+
+ [declaration specifier] (always-bound SYMBOL ...)
+
+Declares that the given variables are always bound and
+accesses to those have not to be checked.
+
+
+=== block
+
+ [declaration specifier] (block)
+
+Assume global variables are never redefined. This is the same as
+specifying the {{-block}} option.
+
+
+=== block-global
+=== hide
+
+ [declaration specifier] (block-global SYMBOL ...)
+ [declaration specifier] (hide SYMBOL ...)
+
+Declares that the toplevel bindings for {{SYMBOL ...}}
+should not be accessible from code in other compilation units or by
+{{eval}}. Access to toplevel bindings declared as block global is
+also more efficient. {{(declare (hide))}} is equivalent to {{(declare (block))}}.
+
+
+=== bound-to-procedure
+
+ [declaration specifier] (bound-to-procedure SYMBOL ...)
+
+Declares that the given identifiers are always bound to procedure values.
+
+
+=== check-c-syntax
+
+ [declaration specifier] (check-c-syntax)
+ [declaration specifier] (not check-c-syntax)
+
+Enables or disables syntax-checking of embedded C/C++ code fragments. Checking C syntax is the default.
+
+
+=== constant
+
+ [declaration specifier] (constant SYMBOL ...)
+
+Declares the procedures with the names {{SYMBOL ...}} as constant, that is, as not having any
+side effects. This can help the compiler to remove non-side-effecting expressions.
+
+
+=== export
+
+ [declaration specifier] (export SYMBOL ...)
+
+The opposite of {{hide}}. All given identifiers will be exported and all toplevel variables
+not listed will be hidden and not be accessible outside of this compilation unit.
+
+
+=== emit-exports
+
+ [declaration specifier] (emit-exports STRING)
+
+Write exported toplevel variables to file with name {{STRING}}.
+
+
+=== emit-external-prototypes-first
+
+ [declaration specifier] (emit-external-prototypes-first)
+
+Emit prototypes for callbacks defined with {{define-external}} before any
+other foreign declarations. Equivalent to giving the {{-emit-external-prototypes-first}}
+option to the compiler.
+
+
+=== disable-interrupts
+
+ [declaration specifier] (disable-interrupts)
+ [declaration specifier] (not interrupts-enabled)
+
+Disable timer-interrupts checks in the compiled program. Threads can
+not be preempted in main- or library-units that contain this declaration.
+
+
+=== disable-warning
+
+ [declaration specifier] (disable-warning CLASS ...)
+
+Disable warnings of type {{CLASS ...}} (equivalent to the {{-disable-warning CLASS}}
+compiler option).
+
+
+=== emit-import-library
+
+ [declaration specifier] (emit-import-library MODULENAME | (MODULENAME FILENAME) ...)
+
+Declares that any following definition of a module named {{MODULENAME}} should be written to
+an external file (either a specified one or a file named {{"MODULENAME.import.scm"}}).
+The compiler option {{-emit-import-library}} may also be used.
+
+
+=== inline
+
+ [declaration specifier] (inline)
+ [declaration specifier] (not inline)
+ [declaration specifier] (inline IDENTIFIER ...)
+ [declaration specifier] (not inline IDENTIFIER ...)
+
+If given without an identifier-list, inlining of known procedures is enabled (this is equivalent to the {{-inline}}
+compiler option). When an identifier-list is given, then inlining is enabled only for the specified global procedures.
+The negated forms {{(not inline)}} and {{(not inline IDENTIFIER)}} disable global inlining, or inlining for
+the given global procedures only, respectively.
+
+
+=== inline-global
+
+ [declaration specifier] (inline-global)
+ [declaration specifier] (not inline-global)
+ [declaration specifier] (inline-global IDENTIFIER ...)
+ [declaration specifier] (not inline-global IDENTIFIER ...)
+
+Declare that then given toplevel procedures (or all) are subject to
+cross-module inlining. Potentially inlinable procedures in the current
+compilation unit will be written to an external
+{{<source-filename>.inline}} file in the current directory. Globally
+inlinable procedures from other compilation units referred to via
+{{(declare (uses ...))}} or {{require-extension}} are loaded from
+{{.inline}} files (if available in the current include path) and inlined
+in the current compilation unit.
+
+Enabling global inlining implies {{(declare (inline))}}.
+
+
+=== inline-limit
+
+ [declaration specifier] (inline-limit THRESHOLD)
+
+Sets the maximum size of procedures which may potentially be inlined. The default threshold is {{20}}.
+
+
+=== interrupts-enabled
+
+ [declaration specifier] (interrupts-enabled)
+
+Enable timer-interrupts checks in the compiled program (the default).
+
+
+=== keep-shadowed-macros
+
+ [declaration specifier] (keep-shadowed-macros)
+
+Normally, when a toplevel variable is assigned or defined that has the same name as a macro, the macro-definition
+will be removed (in addition to showing a warning). This declaration will disable the removal of the macro.
+
+
+=== lambda-lift
+
+ [declaration specifier] (lambda-lift)
+
+Enables lambda-lifting (equivalent to the {{-lambda-lift}} option).
+
+
+=== local
+
+ [declaration specifier] (local)
+ [declaration specifier] (local SYMBOL ...)
+
+Declares that the listed (or all) toplevel variables defined in the
+current compilation unit are not modified from code outside of this
+compilation unit.
+
+
+=== no-argc-checks
+
+ [declaration specifier] (no-argc-checks)
+
+Disables argument count checking.
+
+
+=== no-bound-checks
+
+ [declaration specifier] (no-bound-checks)
+
+Disables the bound-checking of toplevel bindings.
+
+
+=== no-procedure-checks
+
+ [declaration specifier] (no-procedure-checks)
+
+Disables checking of values in operator position for being of procedure type.
+
+
+=== post-process
+
+ [declaration specifier] (post-process STRING ...)
+
+Arranges for the shell commands {{STRING ...}} to be invoked after the current
+file has been translated to C. Any occurrences of the substring {{$@@}} in the
+strings given for this declaration will be replaced by the pathname of the currently
+compiled file, without the file-extension.
+This declaration will only work if the source file is compiled
+with the {{csc}} compiler driver.
+
+
+=== profile
+
+ [declaration specifier] (profile IDENTIFIER ...)
+
+Enable profiling exclusively for given identifiers. Normally the compiler
+enables profiling decorations for all globally defined procedures. With
+this declaration, profiling can be enabled for selected procedures.
+
+
+=== number-type
+=== fixnum-arithmetic
+
+ [declaration specifier] ([number-type] TYPE)
+ [declaration specifier] (fixnum-arithmetic)
+
+Declares that only numbers of the given type are used. {{TYPE}}
+may be {{fixnum}} or {{generic}} (which is
+the default).
+
+
+=== compile-syntax
+
+ [declaration specifier] (compile-syntax)
+
+Equivalent to the compiler option of the same name - macros defined in the compiled code are also made available at
+runtime.
+
+
+=== scrutinize
+
+ [declaration specifier] (scrutinize)
+
+Enables scrutiny. This is equivalent to passing the {{-scrutinize}} option to the compiler.
+
+
+=== standard-bindings
+
+ [declaration specifier] (standard-bindings SYMBOL ...)
+ [declaration specifier] (not standard-bindings SYMBOL ...)
+
+Declares that all given standard procedures (or all if no symbols are
+specified) are never globally redefined. If {{not}} is specified,
+then all but the given standard bindings are assumed to be never
+redefined.
+
+
+=== type
+
+ [declaration specifier] (type (SYMBOL TYPESPEC) ...)
+
+Declares toplevel procedures to have a specific type for scrutiny. {{SYMBOL}} should name
+a toplevel variable and {{TYPESPEC}} should be a type specification, following the syntax
+given here:
+
+ TYPESPEC --> *
+ | ( VAL1 ... )
+
+ VAL --> (or VAL1 ...)
+ | (struct NAME)
+ | (procedure (VAL1 ... [#!optional VALOPT1 ...] [#!rest [VAL]]) . RESULTS)
+ | BASIC
+ | deprecated
+
+ BASIC --> *
+ | string
+ | symbol
+ | char
+ | number
+ | boolean
+ | list
+ | pair
+ | procedure
+ | vector
+ | null
+ | eof
+ | port
+ | blob
+ | pointer
+ | locative
+ | fixnum
+ | float
+
+ RESULTS --> *
+ | (RVAL1 ...)
+
+ RVAL --> undefined
+ | noreturn
+
+A type-declaration overrides any previous declaration for the same identifier.
+
+
+=== extended-bindings
+
+ [declaration specifier] (extended-bindings SYMBOL ...)
+ [declaration specifier] (not extended-bindings SYMBOL ...)
+
+Declares that all given non-standard and CHICKEN-specific procedures (or all if no symbols are specified) are never globally redefined.
+If {{not}} is specified, then all but the given extended bindings
+are assumed to be never redefined.
+
+
+=== usual-integrations
+
+ [declaration specifier] (usual-integrations SYMBOL ...)
+ [declaration specifier] (not usual-integrations SYMBOL ...)
+
+Declares that all given standard and extended bindings (or all if no
+symbols are specified) are never globally redefined. If {{not}}
+is specified, then all but the given standard and extended bindings are
+assumed to be never redefined. Note that this is the default behaviour,
+unless the {{-no-usual-integrations}} option has been given.
+
+
+=== unit
+
+ [declaration specifier] (unit SYMBOL)
+
+Specify compilation unit-name (if this is a library)
+
+
+=== unsafe
+
+ [declaration specifier] (unsafe)
+ [declaration specifier] (not safe)
+
+Do not generate safety-checks. This is the same as specifying the
+{{-unsafe}} option. Also implies
+
+
+ (declare (no-bound-checks) (no-procedure-checks) (no-argc-checks))
+
+
+=== unused
+
+ [declaration specifier] (unused SYMBOL ...)
+
+Disables any warnings when the global variable {{SYMBOL}} is not defined but used,
+or defined but never used and not exported.
+
+
+=== uses
+
+ [declaration specifier] (uses SYMBOL ...)
+
+Gives a list of used library-units. Before the toplevel-expressions
+of the main-module are executed, all used units evaluate their
+toplevel-expressions in the order in which they appear in this
+declaration. If a library unit A uses another unit B, then B's toplevel
+expressions are evaluated before A's. Furthermore, the used symbols
+are registered as features during compile-time, so {{cond-expand}}
+knows about them.
+
+---
+Previous: [[Modules and macros]]
+
+Next: [[Parameters]]
diff --git a/manual/Deviations from the standard b/manual/Deviations from the standard
new file mode 100644
index 00000000..c8c01fdc
--- /dev/null
+++ b/manual/Deviations from the standard
@@ -0,0 +1,99 @@
+[[tags: manual]]
+
+== Confirmed deviations
+
+Identifiers are by default case-sensitive (see
+[[http://galinha.ucpel.tche.br:8080/Using%20the%20compiler#Compiler%20command%20line%20format|Compiler command line format]]).
+
+[4.1.3] The maximal number of arguments that may be passed to a
+compiled procedure or macro is 120. (However, a macro-definition
+that has a single rest-parameter can have any number of arguments.)
+Likewise, [6.4] the maximum number of values that can be passed
+to continuations captured using {{call-with-current-continuation}}
+is 120. This is an implementation restriction that is unlikely
+to be lifted.
+
+[6.2.5] The {{numerator}} and {{denominator}} procedures cannot be
+applied to inexact numbers, and the procedure {{rationalize}} is not
+implemented at all. This will be fixed in a later release.
+
+[6.2.4] The runtime system uses the numerical string-conversion
+routines of the underlying C library and so does only understand
+standard (C-library) syntax for floating-point constants. Consequently,
+the procedures [6.2.6] {{string->number}}, [6.6.2] {{read}},
+[6.6.3] {{write}}, and [6.6.3] {{display}} do not obey
+read/write invariance to inexact numbers.
+
+[6.5] Code evaluated in {{scheme-report-environment}} or
+{{null-environment}} still sees non-standard syntax.
+
+== Unconfirmed deviations
+
+[6.6.2] The procedure {{char-ready?}} always returns {{#t}} for
+terminal ports.
+
+== Doubtful deviations
+
+[4.2.2] {{letrec}} does evaluate the initial values for the bound
+variables sequentially and not in parallel, that is:
+
+ (letrec ((x 1) (y 2)) (cons x y))
+
+is equivalent to
+
+ (let ((x (void)) (y (void)))
+ (set! x 1)
+ (set! y 2)
+ (cons x y) )
+
+where R5RS requires
+
+ (let ((x (void)) (y (void)))
+ (let ((tmp1 1) (tmp2 2))
+ (set! x tmp1)
+ (set! y tmp2)
+ (cons x y) ) )
+
+It is unclear whether R5RS permits this behavior or not; in any case,
+this only affects letrecs where the bound values are not
+lambda-expressions.
+
+== Non-deviations that might surprise you
+
+[6.1] {{equal?}} compares all structured data recursively, while R5RS
+specifies that {{eqv?}} is used for data other than pairs, strings and
+vectors. However, R5RS does not dictate the treatment of data types
+that are not specified by R5RS.
+
+[6.2.5] There is no built-in support for exact rationals, complex
+numbers or extended-precision integers (bignums). The routines
+{{complex?}}, {{real?}} and {{rational?}} are identical to
+the standard procedure {{number?}}. The procedures {{make-rectangular}}
+and {{make-polar}} are not implemented. Fixnums are limited to
+±2<nowiki><sup>30</sup></nowiki> (or ±2<nowiki><sup>62</sup></nowiki>
+on 64-bit hardware). Support for the full numeric tower is available
+as a separate package, provided the GNU multiprecision library is installed.
+
+[6.2.6] The procedure {{string->number}} does not obey read/write
+invariance on inexact numbers.
+
+[6.4] The maximum number of values that can be passed to continuations
+captured using {{call-with-current-continuation}} is 120.
+
+[6.5] Code evaluated in {{scheme-report-environment}} or
+{{null-environment}} still sees non-standard syntax.
+
+[6.6.2] The procedure {{char-ready?}} always returns {{#t}} for
+terminal ports. The procedure {{read}} does not obey read/write
+invariance on inexact numbers.
+
+[6.6.3] The procedures {{write}} and {{display}} do not obey
+read/write invariance to inexact numbers.
+
+[6.6.4] The {{transcript-on}} and {{transcript-off}} procedures are
+not implemented. R5RS does not require them.
+
+---
+Previous: [[Supported language]]
+
+Next: [[Extensions to the standard]]
diff --git a/manual/Embedding b/manual/Embedding
new file mode 100644
index 00000000..45c6c5c2
--- /dev/null
+++ b/manual/Embedding
@@ -0,0 +1,340 @@
+[[tags: manual]]
+[[toc:]]
+
+
+== Embedding
+
+Compiled Scheme files can be linked with C code, provided the Scheme code was compiled
+in ''embedded'' mode by passing {{-DC_EMBEDDED}} to the C compiler (this will
+disable generation of a {{main()}} function). {{csc}} will do this, when given
+the {{-embedded}} option. Alternatively pass {{-embedded}} to {{csc}}.
+
+The following C API is available:
+
+=== CHICKEN_parse_command_line
+
+ [C function] void CHICKEN_parse_command_line (int argc, char *argv[], int *heap, int *stack int *symbols)
+
+Parse the programs command-line contained in {{argc}} and
+{{argv}} and return the heap-, stack- and symbol table limits
+given by runtime options of the form {{-:...}}, or choose default
+limits. The library procedure {{argv}} can access the command-line
+only if this function has been called by the containing application.
+
+
+=== CHICKEN_initialize
+
+ [C function] int CHICKEN_initialize (int heap, int stack, int symbols, void *toplevel)
+
+Initializes the Scheme execution context and memory. {{heap}}
+holds the number of bytes that are to be allocated for the secondary
+heap. {{stack}} holds the number of bytes for the primary
+heap. {{symbols}} contains the size of the symbol table. Passing
+{{0}} to one or more of these parameters will select a default
+size.
+{{toplevel}} should be a pointer to the toplevel entry point
+procedure. You should pass {{C_toplevel}} here. In any subsequent
+call to {{CHICKEN_run}} you can simply
+pass {{NULL}}.
+Calling this function more than once has no effect. If enough
+memory is available and initialization was successful, then {{1}}
+is returned, otherwise this function returns {{0}}.
+
+=== CHICKEN_run
+
+ [C function] C_word CHICKEN_run (void *toplevel)
+
+Starts the Scheme program. Call this function once to execute all toplevel expressions in your
+compiled Scheme program. If the runtime system was not initialized before,
+then {{CHICKEN_initialize}} is called with default sizes.
+{{toplevel}} is the toplevel entry-point procedure, you usually pass {{C_toplevel}} here.
+The result value is the continuation that can be used to re-invoke the Scheme code from the
+point after it called {{return-to-host}} (see below).
+
+If you just need a Scheme interpreter, you can also pass {{CHICKEN_default_toplevel}} as
+the toplevel procedure, which just uses the default library units.
+
+
+Once {{CHICKEN_run}} has been called, Scheme code is executing until all toplevel
+expressions have been evaluated or until {{return-to-host}} is called inside the
+Scheme program.
+
+=== return-to-host
+
+ [procedure] (return-to-host)
+
+Exits the Scheme code and returns to the invoking context that called {{CHICKEN_run}}
+or {{CHICKEN_continue}}.
+
+After {{return-to-host}} has been executed and once {{CHICKEN_run}} returns,
+you can invoke callbacks which have been defined with {{define-external}}.
+The {{eval}} library unit also provides ''boilerplate'' callbacks, that simplify invoking Scheme
+code embedded in a C or C++ application a lot.
+
+=== CHICKEN_eval
+
+ [C macro] int CHICKEN_eval (C_word exp, C_word *result)
+
+Evaluates the Scheme object passed in {{exp}}, writing the result value to {{result}}.
+The return value is 1 if the operation succeeded,
+or 0 if an error occurred. Call {{CHICKEN_get_error_message}} to obtain a description
+of the error.
+
+
+=== CHICKEN_eval_string
+
+ [C macro] int CHICKEN_eval_string (char *str, C_word *result)
+
+Evaluates the Scheme expression passed in the string {{str}}, writing the result value to {{result}}.
+
+
+=== CHICKEN_eval_to_string
+
+ [C macro] int CHICKEN_eval_to_string (C_word exp, char *result, int size)
+
+Evaluates the Scheme expression passed in {{exp}}, writing a textual representation
+of the result into {{result}}. {{size}} should specify the maximal size of the result string.
+
+
+=== CHICKEN_eval_string_to_string
+
+ [C macro] int CHICKEN_eval_string_to_string (char *str, char *result, int size)
+
+Evaluates the Scheme expression passed in the string {{str}}, writing a textual representation
+of the result into {{result}}. {{size}} should specify the maximal size of the result string.
+
+
+=== CHICKEN_apply
+
+ [C macro] int CHICKEN_apply (C_word func, C_word args, C_word *result)
+
+Applies the procedure passed in {{func}} to the list of arguments {{args}}, writing the result value to {{result}}.
+
+
+=== CHICKEN_apply_to_string
+
+ [C macro] int CHICKEN_apply_to_string (C_word func, C_word args, char *result, int size)
+
+Applies the procedure passed in {{func}} to the list of arguments {{args}}, writing a textual
+representation of the result into {{result}}.
+
+
+=== CHICKEN_read
+
+ [C macro] int CHICKEN_read (char *str, C_word *result)
+
+Reads a Scheme object from the string {{str}}, writing the result value to {{result}}.
+
+
+=== CHICKEN_load
+
+ [C macro] int CHICKEN_load (char *filename)
+
+Loads the Scheme file {{filename}} (either in source form or compiled).
+
+
+=== CHICKEN_get_error_message
+
+ [C macro] void CHICKEN_get_error_message (char *result, int size)
+
+Returns a textual description of the most recent error that occurred in executing embedded Scheme code.
+
+
+=== CHICKEN_yield
+
+ [C macro] int CHICKEN_yield (int *status)
+
+If threads have been spawned during earlier invocations of embedded Scheme code, then this function
+will run the next scheduled thread for one complete time-slice. This is useful, for example, inside
+an ''idle'' handler in a GUI application with background Scheme threads. Note that the
+{{srfi-18}} library unit has to be linked in for this.
+
+
+
+An example:
+
+ % cat x.scm
+ ;;; x.scm
+
+ (define (bar x) (gc) (* x x))
+
+ (define-external (baz (int i)) double
+ (sqrt i))
+ (return-to-host)
+
+
+ % cat y.c
+ /* y.c */
+
+ #include <chicken.h>
+ #include <assert.h>
+
+ extern double baz(int);
+
+ int main() {
+ char buffer[ 256 ];
+ int status;
+ C_word val = C_SCHEME_UNDEFINED;
+ C_word *data[ 1 ];
+
+ data[ 0 ] = &val;
+
+ CHICKEN_run(C_toplevel);
+
+ status = CHICKEN_read("(bar 99)", &val);
+ assert(status);
+
+ C_gc_protect(data, 1);
+
+ printf("data: %08x\n", val);
+
+ status = CHICKEN_eval_string_to_string("(bar)", buffer, 255);
+ assert(!status);
+
+ CHICKEN_get_error_message(buffer, 255);
+ printf("ouch: %s\n", buffer);
+
+ status = CHICKEN_eval_string_to_string("(bar 23)", buffer, 255);
+ assert(status);
+
+ printf("-> %s\n", buffer);
+ printf("data: %08x\n", val);
+
+ status = CHICKEN_eval_to_string(val, buffer, 255);
+ assert(status);
+ printf("-> %s\n", buffer);
+
+ printf("->` %g\n", baz(22));
+
+ return 0;
+ }
+
+ % csc x.scm y.c -embedded
+
+It is also possible to re-enter the computation following the call to {{return-to-host}} by calling
+{{CHICKEN_continue}}:
+
+=== CHICKEN_continue
+
+ [C function] C_word CHICKEN_continue (C_word k)
+
+Re-enters Scheme execution. {{k}} is the continuation received from the previous invocation
+of {{CHICKEN_run}} or {{CHICKEN_continue}}. When {{return-to-host}} is called again,
+this function returns another continuation that can be used to restart again.
+
+If you invoke callbacks prior to calling {{CHICKEN_continue}}, make sure that the
+continuation is not reclaimed by garbage collection. This can be avoided by using {{C_gc_protect}}
+or gc-roots.
+
+Another example:
+
+ % cat x.scm
+ (require-extension srfi-18)
+
+ (define m (make-mutex))
+
+ (define (t)
+ (mutex-lock! m)
+ (thread-sleep! 1)
+ (print (thread-name (current-thread)))
+ (mutex-unlock! m)
+ (t) )
+
+ (thread-start! (make-thread t 'PING!))
+ (thread-start! (make-thread t 'PONG!))
+
+ (let loop ()
+ (return-to-host)
+ (thread-yield!)
+ (loop) )
+
+ % cat y.c
+ #include <chicken.h>
+
+ int main()
+ {
+ C_word k = CHICKEN_run(C_toplevel);
+
+ for(;;)
+ k = CHICKEN_continue(k);
+
+ return 0;
+ }
+
+ % csc x.scm y.c -embedded
+
+It is advisable not to mix repeated uses of {{CHICKEN_continue}}/{{return-to-host}}
+(as in the example above) with callbacks. Once {{return-to-host}} is invoked, the runtime system
+and any Scheme code executed prior to the invocation is initialized and can be conveniently
+used via callbacks.
+
+A simpler interface For handling GC-safe references to Scheme data are the so called ''gc-roots'':
+
+=== CHICKEN_new_gc_root
+
+ [C function] void* CHICKEN_new_gc_root ()
+
+Returns a pointer to a ''GC root'', which is an object that holds a reference to a Scheme value
+that will always be valid, even after a garbage collection. The content of the gc root is initialized to
+an unspecified value.
+
+
+=== CHICKEN_new_finalizable_gc_root
+
+ [C function] void* CHICKEN_new_finalizable_gc_root ()
+
+Similar to {{CHICKEN_new_gc_root}}, but allows the stored value to
+be finalized: if this gc root holds reference to an otherwise
+unreferenced data object that has a finalizer, the finalizer is still
+invoked.
+
+
+=== CHICKEN_delete_gc_root
+
+ [C function] void CHICKEN_delete_gc_root (void *root)
+
+Deletes the gc root.
+
+
+=== CHICKEN_gc_root_ref
+
+ [C macro] C_word CHICKEN_gc_root_ref (void *root)
+
+Returns the value stored in the gc root.
+
+
+=== CHICKEN_gc_root_set
+
+ [C macro] void CHICKEN_gc_root_set (void *root, C_word value)
+
+Sets the content of the GC root to a new value.
+
+
+
+Sometimes it is handy to access global variables from C code:
+
+=== CHICKEN_global_lookup
+
+ [C function] void* CHICKEN_global_lookup (char *name)
+
+Returns a GC root that holds the global variable with the name {{name}}. If no such variable
+exists, {{NULL}} is returned.
+
+
+=== CHICKEN_global_ref
+
+ [C function] C_word CHICKEN_global_ref (void *global)
+
+Returns the value of the global variable referenced by the GC root {{global}}.
+
+
+=== CHICKEN_global_set
+
+ [C function] void CHICKEN_global_set (void *global, C_word value)
+
+Sets the value of the global variable referenced by the GC root {{global}} to {{value}}.
+
+---
+Previous: [[Foreign type specifiers]]
+
+Next: [[Callbacks]]
diff --git a/manual/Extensions b/manual/Extensions
new file mode 100644
index 00000000..4984cfc1
--- /dev/null
+++ b/manual/Extensions
@@ -0,0 +1,564 @@
+[[tags: manual]]
+[[toc:]]
+
+== Extensions
+
+=== Extension libraries
+
+Extension libraries (''eggs'') are extensions to the core
+functionality provided by the basic CHICKEN system, to be built and
+installed separately. The mechanism for loading compiled extensions
+is based on dynamically loadable code and as such is only available on
+systems on which loading compiled code at runtime is
+supported. Currently these are most UNIX-compatible platforms that
+provide the {{libdl}} functionality like Linux, Solaris, BSD, Mac OS X
+and Windows using Cygwin.
+
+Note: Extension may also be normal applications or shell scripts, but
+are usually libraries.
+
+Extensions are technically nothing but dynamically loadable compiled
+files with added meta-data that describes dependencies to other
+extensions, version information and things like the author/maintainer
+of the extension. Three tools provide an easy to use interface for
+installing extensions, removing them and querying the current
+status of installed extensions.
+
+
+=== Installing extensions
+
+To install an extension library, run the {{chicken-install}} program
+with the extension name as argument. The extension archive is
+downloaded, its contents extracted and the contained ''setup'' script
+is executed. This setup script is a normal Scheme source file, which
+will be interpreted by {{chicken-install}}. The complete language
+supported by {{csi}} is available, and the library units {{srfi-1
+regex utils posix tcp}} are loaded. Additional libraries can be loaded
+at run-time.
+
+The setup script should perform all necessary steps to build the new
+library (or application). After a successful build, the extension can
+be installed by invoking one of the procedures {{install-extension}},
+{{install-program}} or {{install-script}}. These procedures will copy
+a number of given files into the local extension repository or in the
+path where the CHICKEN executables are located (in the case of
+executable programs or scripts). Additionally the list of installed
+files, and user-defined metadata is stored in the repository.
+
+If no extension name is given on the command-line, then all {{.setup}}
+scripts in the current directory are processed, in the order given
+on the command line.
+
+==== Installing extensions that use libraries
+
+Sometimes an extension requires a C library to compile. Compilation
+can fail when your system has this library in a nonstandard
+location. Luckily, normally Chicken searches in the default locations
+{{/usr}} and {{/usr/local}}, and in the prefix where Chicken itself
+was installed. Sometimes this is not enough, so you'll need to supply
+{{chicken-install}} with some extra hints to the C compiler/linker. Here's
+an example:
+
+ CSC_OPTIONS='-I/usr/pkg/include/mysql -L/usr/pkg/lib/mysql -L -R/usr/pkg/lib/mysql' chicken-install mysql
+
+This installs the mysql egg with the extra compiler options -I and -L
+to set the include path and the library search path. The second -L
+switch passes the -R option directly to the linker, which causes the
+library path to get hardcoded into the resulting extension file (for
+systems that do not use {{ld.so.conf}}).
+
+=== Creating extensions
+
+Extensions can be created by creating an (optionally gzipped) {{tar}}
+archive named {{EXTENSION.egg}} containing all needed files plus a
+{{.setup}} script in the root directory. After {{chicken-install}} has
+extracted the files, the setup script will be invoked. There are no
+additional constraints on the structure of the archive, but the setup
+script has to be in the root path of the archive.
+
+
+=== Procedures and macros available in setup scripts
+
+==== install-extension
+
+ (install-extension ID FILELIST [INFOLIST])
+
+Installs the extension library with the name {{ID}}. All files given in the list of strings
+{{FILELIST}} will be copied to the extension repository. It should be noted here that
+the extension id has to be identical to the name of the file implementing the extension. The
+extension may load or include other files, or may load other extensions at runtime specified
+by the {{require-at-runtime}} property.
+
+{{FILELIST}} may be a filename, a list of filenames, or a list of pairs of
+the form {{(SOURCE DEST)}} (if you want to copy into a particular sub-directory - the
+destination directory will be created as needed). If {{DEST}} is a relative pathname,
+< it will be copied into the extension repository.
+
+The optional argument {{INFOLIST}} should be an association list that
+maps symbols to values, this list will be stored as {{ID.setup-info}} at the same
+location as the extension code. Currently the following properties are used:
+
+===== syntax
+
+ [extension property] (syntax)
+
+Marks the extension as syntax-only. No code is compiled, the extension is intended
+as a file containing macros to be loaded at compile/macro-expansion time.
+
+===== require-at-runtime
+
+ [extension property] (require-at-runtime ID ...)
+
+Specifies extensions that should be loaded (via {{require}}) at runtime. This is mostly
+useful for syntax extensions that need additional support code at runtime.
+
+===== version
+
+ [extension property] (version STRING)
+
+Specifies version string.
+
+===== static
+
+ [extension property] (static STRING)
+
+If the extension also provides a static library, then STRING should
+contain the name of that library. Used by {{csc}} when compiling with
+the {{-static-extensions}} option.
+
+===== static-options
+
+ [extension property] (static-options STRING)
+
+Additional options that should be passed to the linker when linking
+with the static version of an extension (see {{static}} above). Used
+by {{csc}} when compiling with the {{-static-extensions}} option.
+
+All other properties are currently ignored. The {{FILELIST}} argument may also be a single
+string.
+
+==== install-program
+
+ [procedure] (install-program ID FILELIST [INFOLIST])
+
+Similar to {{install-extension}}, but installs an executable program in the
+executable path (usually {{/usr/local/bin}}).
+
+==== install-script
+
+ [procedure] (install-script ID FILELIST [INFOLIST])
+
+Similar to {{install-program}}, but additionally changes the file permissions of all
+files in {{FILELIST}} to executable (for installing shell-scripts).
+
+==== standard-extension
+
+ [procedure] (standard-extension ID VERSION)
+
+A convenience procedure that combines the compilation and installation of
+a simple single-file extension. This is roughly equivalent to:
+
+ (compile -s -O2 -d1 ID.scm -j ID)
+ (compile -c -O2 -d1 ID.scm -j ID -unit ID)
+ (compile -s -O2 -d0 ID.import.scm)
+
+ (install-extension
+ 'ID
+ '("ID.o" "ID.so" "ID.import.so")
+ '((version 1.0)
+ (static "ID.o")))
+
+
+==== run
+
+ [syntax] (run FORM ...)
+
+Runs the shell command {{FORM}}, which is wrapped in an implicit {{quasiquote}}.
+{{(run (csc ...))}} is treated specially and passes {{-v}} (if {{-verbose}} has been given
+to {{chicken-install}}) and {{-feature compiling-extension}} options to the compiler.
+
+==== compile
+
+ [syntax] (compile FORM ...)
+
+Equivalent to {{(run (csc FORM ...))}}.
+
+==== make
+
+ [syntax] (make ((TARGET (DEPENDENT ...) COMMAND ...) ...) ARGUMENTS)
+
+A ''make'' macro that executes the expressions {{COMMAND ...}}, when any of the dependents
+{{DEPENDENT ...}} have changed, to build {{TARGET}}. This is the same as the {{make}}
+extension, which is available separately. For more information, see
+[[http://www.call-with-current-continuation.org/eggs/make.html|make]].
+
+
+==== patch
+
+ [procedure] (patch WHICH REGEX SUBST)
+
+Replaces all occurrences of the regular expression {{REGEX}} with the string {{SUBST}},
+in the file given in {{WHICH}}. If {{WHICH}} is a string, the file will be patched and
+overwritten. If {{WHICH}} is a list of the form {{OLD NEW}}, then a different file named
+{{NEW}} will be generated.
+
+==== copy-file
+
+ [procedure] (copy-file FROM TO)
+
+Copies the file or directory (recursively) given in the string {{FROM}} to the destination
+file or directory {{TO}}.
+
+==== move-file
+
+ [procedure] (move-file FROM TO)
+
+Moves the file or directory (recursively) given in the string {{FROM}} to the destination
+file or directory {{TO}}.
+
+==== remove-file*
+
+ [procedure] (remove-file* PATH)
+
+Removes the file or directory given in the string {{PATH}}.
+
+
+==== find-library
+
+ [procedure] (find-library NAME PROC)
+
+Returns {{#t}} if the library named {{libNAME.[a|so]}} (unix) or {{NAME.lib}} (windows)
+could be found by compiling and linking a test program. {{PROC}} should be the name of a
+C function that must be provided by the library. If no such library was found or the function could not
+be resolved, {{#f}} is returned.
+
+==== find-header
+
+ [procedure] (find-header NAME)
+
+Returns {{#t}} if a C include-file with the given name is available, or {{#f}} otherwise.
+
+==== try-compile
+
+ [procedure] (try-compile CODE #!key cc cflags ldflags compile-only c++)
+
+Returns {{#t}} if the C code in {{CODE}} compiles and links successfully, or {{#f}} otherwise.
+The keyword parameters {{cc}} (compiler name, defaults to the C compiler used to build this system),
+{{cflags}} and {{ldflags}} accept additional compilation and
+linking options. If {{compile-only}} is true, then no linking step takes place.
+If the keyword argument {{c++}} is given and true, then the code will be compiled in C++ mode.
+
+
+==== create-directory
+
+ [procedure] (create-directory PATH)
+
+Creates the directory given in the string {{PATH}}, with all parent directories as needed.
+
+
+==== chicken-prefix
+
+ [parameter] chicken-prefix
+
+The installation prefix specified when CHICKEN was built.
+
+==== installation-prefix
+
+ [parameter] installation-prefix
+
+An alternative installation prefix that will be prepended to extension
+installation paths if specified. It is set by the {{-install-prefix}}
+option or environment variable {{CHICKEN_INSTALL_PREFIX}}.
+
+==== program-path
+
+ [parameter] (program-path [PATH])
+
+Holds the path where executables are installed and defaults to either {{$CHICKEN_PREFIX/bin}},
+if the environment variable {{CHICKEN_PREFIX}} is set or the
+path where the CHICKEN binaries ({{chicken}}, {{csi}}, etc.) are installed.
+
+
+==== setup-root-directory
+
+ [parameter] (setup-root-directory [PATH])
+
+Contains the path of the directory where {{chicken-install}} was invoked.
+
+
+==== setup-install-mode
+
+ [parameter] (setup-install-mode [BOOL])
+
+Reflects the setting of the {{-no-install}} option, i.e. is {{#f}}, if {{-no-install}} was
+given to {{chicken-install}}.
+
+==== required-chicken-version
+
+ [procedure] (required-chicken-version VERSION)
+
+Signals an error if the version of CHICKEN that this script runs under is lexicographically less than
+{{VERSION}} (the argument will be converted to a string, first).
+
+
+==== required-extension-version
+
+ [procedure] (required-extension-version EXTENSION1 VERSION1 ...)
+
+Checks whether the extensions {{EXTENSION1 ...}} are installed and at least of version {{VERSION1 ...}}.
+The test is made by lexicographically comparing the string-representations of the given version with the version
+of the installed extension. If one of the listed extensions is not installed, has no associated version information
+or is of a version older than the one specified.
+
+
+==== host-extension
+
+ [parameter] host-extension
+
+For a cross-compiling CHICKEN, when compiling an extension, then it
+should be built for the host environment (as opposed to the target
+environment). This parameter is controlled by the {{-host-extension}} command-line
+option. A setup script should perform the proper steps of compiling any
+code by passing {{-host}} when invoking {{csc}} or using the {{compile}}
+macro.
+
+
+=== Examples for extensions
+
+The simplest case is a single file that does not export any syntax. For example
+
+<enscript highlight=scheme>
+;;;; hello.scm
+
+(define (hello name)
+ (print "Hello, " name " !") )
+</enscript>
+
+We need a {{.setup}} script to build and install our nifty extension:
+
+<enscript highlight=scheme>
+;;;; hello.setup
+
+;; compile the code into a dynamically loadable shared object
+;; (will generate hello.so)
+(compile -s hello.scm)
+
+;; Install as extension library
+(install-extension 'hello "hello.so")
+</enscript>
+
+Lastly, we need a file {{hello.meta}} defining a minimal set of properties:
+
+<enscript highlight=scheme>
+;;;; hello.meta
+
+((author "Me")
+ (synopsis "A cool hello-world library")
+ (license "GPLv3")
+ (files "hello.scm" "hello.setup"))
+</enscript>
+
+(for more information about available properties, see {{Metafile reference}})
+
+After entering
+
+ $ chicken-install
+
+at the shell prompt (and in the same directory where the two files
+exist), the file {{hello.scm}} will be compiled into a dynamically
+loadable library. If the compilation succeeds, {{hello.so}} will
+be stored in the repository, together with a file named
+{{hello.setup-info}} containing an a-list with metadata (what
+you stored above in {{hello.meta}}).
+If no extension name is given to {{chicken-install}}, it will simply
+execute the any files with the {{.setup}} extension it can find.
+
+Use it like any other CHICKEN extension:
+
+ $ csi -q
+ #;1> (require-extension hello)
+ ; loading /usr/local/lib/chicken/4/hello.so ...
+ #;2> (hello "me")
+ Hello, me!
+ #;3>
+
+Here we create a simple application:
+
+<enscript highlight=scheme>
+;;;; hello2.scm
+
+(print "Hello, ")
+(for-each (lambda (x) (printf "~A " x)) (command-line-arguments))
+(print "!")
+</enscript>
+
+We also need a setup script:
+
+<enscript highlight=scheme>
+;;;; hello2.setup
+
+(compile hello2.scm) ; compile `hello2'
+(install-program 'hello2 "hello2") ; name of the extension and files to be installed
+</enscript>
+
+<enscript highlight=scheme>
+;;;; hello2.meta
+
+((author "Me")
+ (synopsis "A cool hello-world application")
+ (license "proprietary")
+ (files "hello.scm" "hello.setup"))
+</enscript>
+
+To use it, just run {{chicken-install}} in the same directory:
+
+ $ chicken-install
+
+(Here we omit the extension name)
+
+Now the program {{hello2}} will be installed in the same location as
+the other CHICKEN tools (like {{chicken}}, {{csi}}, etc.), which will
+normally be {{/usr/local/bin}}. Note that you need write-permissions
+for those locations and may have to run {{chicken-install}} with
+administrative rights or use the {{-sudo}} option.
+
+De-installation is just as easy - use the {{chicken-uninstall}}
+program to remove one or more extensions from the local repository:
+
+ $ chicken-uninstall hello2
+
+When running {{chicken-install}} with an argument {{NAME}}, for which
+no associated {{.setup}} file exists, then it will try to download the
+extension via HTTP from the CHICKEN code repository at
+[[http://chicken.wiki.br/svn/chicken-eggs/]]. Extensions that are
+required to compile and/or use the requested extension are downloaded
+and installed automatically.
+
+To query the list of currently installed extensions, use
+{{chicken-status}}. It can list what extensions are installed and
+what files belong to a particular installed extension.
+
+
+=== chicken-install reference
+
+Available options:
+
+; {{-h -help}} : show this message and exit
+; {{-v -version}} : show version and exit
+; {{-force}} : don't ask, install even if versions don't match
+; {{-k -keep}} : keep temporary files
+; {{-l -location LOCATION}} : install from given location instead of default
+; {{-t -transport TRANSPORT}} : use given transport instead of default
+; {{-s -sudo}} : use {{sudo(1)}} for installing or removing files
+; {{-r -retrieve}} : only retrieve egg into current directory, don't install
+; {{-n -no-install}} : do not install, just build (implies {{-keep}})
+; {{-p -prefix PREFIX}} : change installation prefix to {{PREFIX}}
+; {{-host-extension}} : when cross-compiling, compile extension for host
+; {{-test}} : run included test-cases, if available
+; {{-username USER}} : set username for transports that require this
+; {{-password PASS}} : set password for transports that require this
+; {{-i -init DIRECTORY}} : initialize empty alternative repository
+; {{-u -update-db}} : update export database
+
+
+=== chicken-uninstall reference
+
+; {{-h -help}} : show usage information and exit
+; {{-v -version}} : show version and exit
+; {{-force}} : don't ask, delete whatever matches
+; {{-s -sudo}} : use {{sudo(1)}} for deleting files
+
+
+=== chicken-status reference
+
+; {{-h -help}} : show usage information and exit
+; {{-v -version}} : show version and exit
+; {{-f -files}} : list installed files
+
+
+=== Security
+
+When extensions are downloaded and installed one is executing code
+from potentially compromised systems. This applies also when
+{{chicken-install}} executes system tests for required extensions. As
+the code has been retrieved over the network effectively untrusted
+code is going to be evaluated. When {{chicken-install}} is run as
+''root'' the whole system is at the mercy of the build instructions
+(note that this is also the case every time you install software via
+{{sudo make install}}, so this is not specific to the CHICKEN
+extension mechanism).
+
+Security-conscious users should never run {{chicken-install}} as root.
+A simple remedy is to set the environment variable
+{{CHICKEN_REPOSITORY}}, which will transparently place the repository
+at an arbitrary user-selected location (don't forget to initialize it
+first with {{chicken-install -init <directory>}}). Alternatively
+obtain write/execute access to the default location of the repository
+(usually {{/usr/local/lib/chicken}}) to avoid running as
+root. {{chicken-install}} also provides a {{-sudo}} option to perform
+the last installation steps as root user, but do building and other
+.setup script processing as normal.
+
+
+=== Other modes of installation
+
+It is possible to install extensions directly from a
+[[http://subversion.tigris.org|Subversion]] repository or from a local
+checkout of the repository tree by using the {{-transport}} and
+{{-location}} options when invoking {{chicken-install}}. Three possible
+transport mechanisms are currently supported:
+
+; {{http}} : download extension sources via HTTP from a web-server (this is the default)
+; {{svn}} : perform an {{svn export}} from the central extension repository; this will require a {{svn(1)}} client to be installed on the machine
+; {{local}} : use sources from the local filesystem and build directly in the source directory
+
+The {{-location}} option specifies where to look for the source
+repository and names a web URL, a subversion repository URL or a
+filesystem path, respectively. A list of locations to try when
+retrieving extensions is stored in the file {{setup.defaults}}
+(usually installed in {{/usr/local/share/chicken}}). For {{http}}
+transports, {{chicken-install}} will detect networking timeouts and
+try alternative locations, as listed in the file.
+
+Dependency information, which is necessary to ensure required
+extensions are also installed, is processed automatically.
+
+=== Linking extensions statically
+
+The compiler and {{chicken-install}} support statically linked
+eggs. The general approach is to generate an object file or static
+library (in addition to the usual
+shared library) in your {{.setup}} script and install it along with the
+dynamically loadable extension. The setup properties {{static}}
+should contain the name of the object file (or static library) to be
+linked, when {{csc}} gets passed the {{-static-extensions}} option:
+
+<enscript highlight=scheme>
+ (compile -s -O2 -d1 my-ext.scm) ; dynamically loadable "normal" version
+ (compile -c -O2 -d1 my-ext -unit my-ext) ; statically linkable version
+ (install-extension
+ 'my-ext
+ '("my-ext.so" "my-ext.o")
+ '((static "my-ext.o")) )
+</enscript>
+
+Note the use of the {{-unit}} option in the second compilation step: static
+linking must use static library units. {{chicken-install}} will perform
+platform-dependent file-extension translation for the file list, but does currently
+not do that for the {{static}} extension property.
+
+To actually link with the static version of {{my-ext}}, do:
+
+ % csc -static-extensions my-program.scm -uses my-ext
+
+The compiler will try to do the right thing, but can not handle all
+extensions, since the ability to statically link eggs is relatively
+new. Eggs that support static linking are designated as being able to
+do so. If you require a statically linkable version of an egg that has
+not been converted yet, contact the extension author or the CHICKEN
+mailing list.
+
+---
+Previous: [[Interface to external functions and variables]]
+
+Next: [[Data representation]]
diff --git a/manual/Extensions to the standard b/manual/Extensions to the standard
new file mode 100644
index 00000000..9937906a
--- /dev/null
+++ b/manual/Extensions to the standard
@@ -0,0 +1,209 @@
+[[tags: manual]]
+
+== Extensions to the standard
+
+=== [2.1]
+
+Identifiers may contain special characters if delimited with
+{{| ... |}}.
+
+=== [2.3]
+
+The brackets {{[ ... ]}} and the braces {{ { ... } }} are
+provided as an alternative syntax for {{( ... )}}. A number of reader
+extensions is provided. See [[Non-standard read syntax]].
+
+=== [4]
+
+Numerous non-standard macros are provided. See
+[[Non-standard macros and special forms]] for more information.
+
+=== [4.1.4]
+
+Extended DSSSL style lambda lists are supported. DSSSL parameter lists are defined by the following grammar:
+
+ <parameter-list> ==> <required-parameter>*
+ [(#!optional <optional-parameter>*)]
+ [(#!rest <rest-parameter>)]
+ [(#!key <keyword-parameter>*)]
+ <required-parameter> ==> <ident>
+ <optional-parameter> ==> <ident>
+ | (<ident> <initializer>)
+ <rest-parameter> ==> <ident>
+ <keyword-parameter> ==> <ident>
+ | (<ident> <initializer>)
+ <initializer> ==> <expr>
+
+When a procedure is applied to a list of arguments, the parameters and arguments are processed from left to right as follows:
+
+* Required-parameters are bound to successive arguments starting with the first argument. It shall be an error if there are fewer arguments than required-parameters.
+* Next, the optional-parameters are bound with the remaining arguments. If there are fewer arguments than optional-parameters, then the remaining optional-parameters are bound to the result of the evaluation of their corresponding <initializer>, if one was specified, otherwise {{#f}}. The corresponding <initializer> is evaluated in an environment in which all previous parameters have been bound.
+* If there is a rest-parameter, then it is bound to a list containing all the remaining arguments left over after the argument bindings with required-parameters and optional-parameters have been made.
+* If {{#!key}} was specified in the parameter-list, there should be an even number of remaining arguments. These are interpreted as a series of pairs, where the first member of each pair is a keyword specifying the parameter name, and the second member is the corresponding value. If the same keyword occurs more than once in the list of arguments, then the corresponding value of the first keyword is the binding value. If there is no argument for a particular keyword-parameter, then the variable is bound to the result of evaluating <initializer>, if one was specified, otherwise {{#f}}. The corresponding <initializer> is evaluated in an environment in which all previous parameters have been bound.
+
+Needing a special mention is the close relationship between the rest-parameter and possible keyword-parameters. Declaring a rest-parameter binds up all remaining arguments in a list, as described above. These same remaining arguments are also used for attempted matches with declared keyword-parameters, as described above, in which case a matching keyword-parameter binds to the corresponding value argument at the same time that both the keyword and value arguments are added to the rest parameter list.
+Note that for efficiency reasons, the keyword-parameter matching does nothing more than simply attempt to match with pairs that may exist in the remaining arguments. Extra arguments that don't match are simply unused and forgotten if no rest-parameter has been declared. Because of this, the caller of a procedure containing one or more keyword-parameters cannot rely on any kind of system error to report wrong keywords being passed in.
+
+It shall be an error for an {{<ident>}} to appear more than once in a parameter-list.
+
+If there is no rest-parameter and no keyword-parameters in the parameter-list, then it shall be an error for any extra arguments to be passed to the procedure.
+
+
+Example:
+
+ ((lambda x x) 3 4 5 6) => (3 4 5 6)
+ ((lambda (x y #!rest z) z)
+ 3 4 5 6) => (5 6)
+ ((lambda (x y #!optional z #!rest r #!key i (j 1))
+ (list x y z i: i j: j))
+ 3 4 5 i: 6 i: 7) => (3 4 5 i: 6 j: 1)
+
+=== [4.1.6]
+
+{{set!}} for unbound toplevel variables is allowed. {{set! (PROCEDURE ...) ...)}}
+is supported, as CHICKEN implements [[http://srfi.schemers.org/srfi-17/srfi-17.html|SRFI-17]].
+
+=== [4.2.1]
+
+The {{cond}} form supports [[http://srfi.schemers.org/srfi-61|SRFI-61]].
+
+=== [4.2.2]
+
+It is allowed for initialization values of bindings in a {{letrec}}
+construct to refer to previous variables in the same set of bindings, so
+
+ (letrec ((foo 123)
+ (bar foo) )
+ bar)
+
+is allowed and returns {{123}}.
+
+=== [4.2.3]
+
+{{(begin)}} is allowed in non-toplevel contexts and evaluates
+to an unspecified value.
+
+=== [4.2.5]
+
+Delayed expressions may return multiple values.
+
+=== [5.2.2]
+
+CHICKEN extends standard semantics by allowing internal definitions
+everywhere, and not only at the beginning of a body. A set of internal definitions
+is equivalent to a {{letrec}} form enclosing all following expressions
+in the body:
+
+ (let ((foo 123))
+ (bar)
+ (define foo 456)
+ (baz foo) )
+
+expands into
+
+ (let ((foo 123))
+ (bar)
+ (letrec ((foo 456))
+ (baz foo) ) )
+
+Local sequences of {{define-syntax}} forms are translated into equivalent
+{{letrec-syntax}} forms that enclose the following forms as the body of
+the expression.
+
+=== [5.2]
+
+{{define}} with a single argument is allowed and initializes the toplevel or local binding
+to an unspecified value. CHICKEN supports ''curried'' definitions, where the variable name
+may also be a list specifying a name and a nested lambda list. So
+
+ (define ((make-adder x) y) (+ x y))
+
+is equivalent to
+
+ (define (make-adder x) (lambda (y) (+ x y)))
+
+=== [6]
+
+CHICKEN provides numerous non-standard procedures. See the manual
+sections on library units for more information.
+
+=== [6.2.4]
+
+The special IEEE floating-point numbers ''+nan'', ''+inf'' and ''-inf''
+are supported, as is negative zero.
+
+=== [6.3.4]
+
+User defined character names are supported. See
+{{char-name}}. Characters can be given
+in hexadecimal notation using the ''#\xXX'' syntax where ''XX'' specifies the
+character code. Character codes above 255 are supported and can be read (and are
+written) using the ''#\uXXXX'' and ''#\UXXXXXXXX'' notations.
+
+Non-standard characters names supported are {{#\tab}}, {{#\linefeed}}, {{#\return}}, {{#\alarm}},
+{{#\vtab}}, {{#\nul}}, {{#\page}}, {{#\esc}}, {{#\delete}} and {{#\backspace}}.
+
+=== [6.3.5]
+
+CHICKEN supports special characters preceded with
+a backslash ''\'' in quoted string
+constants. ''\n'' denotes the newline-character,
+''\r'' carriage return, ''\b''
+backspace, ''\t'' TAB, ''\v'' vertical TAB, ''\a'' alarm, ''\f'' formfeed,
+''\xXX'' a character with the code {{XX}} in hex and
+''\uXXXX'' (and ''\UXXXXXXXX'') a unicode character with the code {{XXXX}}.
+The latter is encoded in UTF-8 format.
+
+The third argument to {{substring}} is optional and defaults to the length
+of the string.
+
+=== [6.4]
+
+{{force}} called with an argument that is not a promise returns
+that object unchanged. Captured continuations can be safely invoked
+inside before- and after-thunks of a {{dynamic-wind}} form and
+execute in the outer dynamic context of the {{dynamic-wind}} form.
+
+'''Implicit''' non-multival continuations accept multiple values by discarding all
+but the first result. Zero values result in the continuation receiving an
+unspecified value. Note that this slight relaxation of the behaviour of
+returning mulitple values to non-multival continuations does not apply to
+explicit continuations (created with {{call-with-current-continuation}}).
+
+=== [6.5]
+
+The second argument to {{eval}} is optional and
+defaults to the value of {{(interaction-environment)}}.
+{{scheme-report-environment}} and {{null-environment}} accept
+an optional 2nd parameter: if not {{#f}} (which is the default),
+toplevel bindings to standard procedures are mutable and new toplevel
+bindings may be introduced.
+
+=== [6.6]
+
+The ''tilde'' character ({{~}}) is automatically expanded in pathnames.
+Additionally, if a pathname starts with {{$VARIABLE...}}, then the prefix is replaced
+by the value of the given environment variable.
+
+=== [6.6.1]
+
+If the procedures {{current-input-port}} and
+{{current-output-port}} are called with an argument (which should
+be a port), then that argument is selected as the new current input- and
+output-port, respectively. The procedures {{open-input-file}},
+{{open-output-file}}, {{with-input-from-file}},
+{{with-output-to-file}}, {{call-with-input-file}} and
+{{call-with-output-file}} accept an optional second (or third)
+argument which should be one or more keywords, if supplied. These
+arguments specify the mode in which the file is opened. Possible
+values are the keywords {{#:text}}, {{#:binary}} or
+{{#:append}}.
+
+=== [6.7]
+
+The {{exit}} procedure exits a program right away and does ''not'' invoke pending {{dynamic-wind}} thunks.
+
+---
+Previous: [[Deviations from the standard]]
+
+Next: [[Non-standard read syntax]]
diff --git a/manual/Foreign type specifiers b/manual/Foreign type specifiers
new file mode 100644
index 00000000..b8a6093c
--- /dev/null
+++ b/manual/Foreign type specifiers
@@ -0,0 +1,298 @@
+[[tags: manual]]
+
+== Foreign type specifiers
+
+Here is a list of valid foreign type specifiers:
+
+=== scheme-object
+
+An arbitrary Scheme data object (immediate or non-immediate).
+
+=== bool
+
+As argument: any value ({{#f}} is false, anything else is true).
+
+As result: anything different from 0 and the {{NULL}} pointer is {{#t}}.
+
+=== byte unsigned-byte
+
+A byte.
+
+=== char unsigned-char
+
+A character.
+
+=== short unsigned-short
+
+A short integer number.
+
+=== int unsigned-int int32 unsigned-int32
+
+An small integer number in fixnum range (at least 30 bit).
+
+=== integer unsigned-integer integer32 unsigned-integer32 integer64
+
+Either a fixnum or a flonum in the range of a (unsigned) machine ''int''
+or with 32/64 bit width.
+
+=== long unsigned-long
+
+Either a fixnum or a flonum in the range of a (unsigned) machine ''long''
+or with 32 bit width.
+
+=== float double
+
+A floating-point number. If an exact integer is passed as an argument,
+then it is automatically converted to a float.
+
+=== number
+
+A floating-point number. Similar to {{double}}, but when used as a result type,
+then either an exact integer or a floating-point number is returned, depending
+on whether the result fits into an exact integer or not.
+
+=== symbol
+
+A symbol, which will be passed to foreign code as a zero-terminated string.
+
+When declared as the result of foreign code, the result should be a string and
+a symbol with the same name will be interned in the symbol table (and returned
+to the caller).
+
+=== scheme-pointer
+
+An untyped pointer to the contents of a non-immediate Scheme object (not
+allowed as return type). The value {{#f}} is also allowed and is passed as a
+{{NULL}} pointer.
+
+Don't confuse this type with {{(c-pointer ...)}} which means something
+different (a machine-pointer object).
+
+=== nonnull-scheme-pointer
+
+As {{scheme-pointer}}, but guaranteed not to be {{#f}}.
+
+Don't confuse this type with {{(nonnull-c-pointer ...)}} which means something
+different (a machine-pointer object).
+
+=== c-pointer
+
+An untyped operating-system pointer or a locative. The value {{#f}} is also
+allowed and is passed as a {{NULL}} pointer. If uses as the type of
+a return value, a {{NULL}} pointer will be returned as {{#f}}.
+
+=== nonnull-c-pointer
+
+As {{c-pointer}}, but guaranteed not to be {{#f/NULL}}.
+
+=== blob
+
+A blob object, passed as a pointer to its contents. Arguments of type {{blob}}
+may optionally be {{#f}}, which is passed as a NULL pointer.
+
+This is not allowed as a return type.
+
+=== nonnull-blob
+
+As {{blob}}, but guaranteed not to be {{#f}}.
+
+=== u8vector
+=== u16vector
+=== u32vector
+=== s8vector
+=== s16vector
+=== s32vector
+=== f32vector
+=== f64vector
+
+A SRFI-4 number-vector object, passed as a pointer to its contents.
+
+These type specifiers are not allowed as return types.
+
+=== nonnull-u8vector
+=== nonnull-u16vector
+=== nonnull-u32vector
+=== nonnull-s8vector
+=== nonnull-s16vector
+=== nonnull-s32vector
+=== nonnull-f32vector
+=== nonnull-f64vector
+
+As {{u8vector ...}}, but guaranteed not to be {{#f}}.
+
+=== c-string
+
+A C string (zero-terminated). The value {{#f}} is also allowed and is passed as
+a {{NULL}} pointer. If uses as the type of a return value, a {{NULL}} pointer
+will be returned as {{#f}}. Note that the string is copied (with a zero-byte
+appended) when passed as an argument to a foreign function. Also a return value
+of this type is copied into garbage collected memory.
+
+=== nonnull-c-string
+
+As {{c-string}}, but guaranteed not to be {{#f/NULL}}.
+
+=== [nonnull-] c-string*
+
+Similar to {{[nonnull-] c-string}}, but if used as a result-type, the pointer
+returned by the foreign code will be freed (using the C-libraries {{free(1)}})
+after copying. This type specifier is not valid as a result type for callbacks
+defined with {{define-external}}.
+
+=== [nonnull-] unsigned-c-string[*]
+
+Same as {{c-string}}, but maps to the {{unsigned char *}} C type.
+
+=== c-string-list
+
+Expects a pointer to a list of C strings teminated by a {{NULL}} pointer and
+returns a list of strings.
+
+Only valid as a result type of non-callback functions.
+
+=== c-string-list*
+
+Similar to {{c-string-list}} but releases the storage of each string and
+the pointer array using {{free(1)}}.
+
+=== void
+
+Specifies an undefined return value.
+
+Not allowed as argument type.
+
+=== (const TYPE)
+
+The foreign type {{TYPE}} with an additional {{const}} specifier.
+
+=== (enum NAME)
+
+An enumeration type. Handled internally as an {{integer}}.
+
+=== (c-pointer TYPE)
+
+An operating-system pointer or a locative to an object of {{TYPE}}.
+
+=== (nonnull-c-pointer TYPE)
+
+As {{(c-pointer TYPE)}}, but guaranteed not to be {{#f/NULL}}.
+
+=== (ref TYPE)
+
+A C++ reference type. Reference types are handled the same way as pointers
+inside Scheme code.
+
+=== (struct NAME)
+
+A struct of the name {{NAME}}, which should be a string.
+
+Structs cannot be directly passed as arguments to foreign function, neither
+can they be result values. Pointers to structs are allowed, though.
+
+=== (template TYPE ARGTYPE ...)
+
+A C++ template type. For example {{vector<int>}} would be specified as
+{{(template "vector" int)}}.
+
+Template types cannot be directly passed as arguments or returned as results.
+
+=== (union NAME)
+
+A union of the name {{NAME}}, which should be a string.
+
+Unions cannot be directly passed as arguments to foreign function, neither can
+they be result values. Pointers to unions are allowed, though.
+
+=== (instance CNAME SCHEMECLASS)
+
+A pointer to a C++ class instance. {{CNAME}} should designate the name of the
+C++ class, and {{SCHEMECLASS}} should be the class that wraps the instance
+pointer. Normally {{SCHEMECLASS}} should be a subclass of {{<c++-object>}}.
+
+=== (instance-ref CNAME SCHEMECLASS)
+
+A reference to a C++ class instance.
+
+=== (function RESULTTYPE (ARGUMENTTYPE1 ... [...]) [CALLCONV])
+
+A function pointer. {{CALLCONV}} specifies an optional calling convention and
+should be a string. The meaning of this string is entirely platform dependent.
+The value {{#f}} is also allowed and is passed as a {{NULL}} pointer.
+
+=== Mappings
+
+Foreign types are mapped to C types in the following manner:
+
+<table>
+<tr><td>bool</td><td>
+int
+</td></tr><tr><td>[unsigned-]char</td><td>
+[unsigned] char
+</td></tr><tr><td>[unsigned-]short</td><td>
+[unsigned] short
+</td></tr><tr><td>[unsigned-]int</td><td>
+[unsigned] int
+</td></tr><tr><td>[unsigned-]integer</td><td>
+[unsigned] int
+</td></tr><tr><td>[unsigned-]long</td><td>
+[unsigned] long
+</td></tr><tr><td>float</td><td>
+float
+</td></tr><tr><td>double</td><td>
+double
+</td></tr><tr><td>number</td><td>
+double
+</td></tr><tr><td>[nonnull-]c-pointer</td><td>
+void *
+</td></tr><tr><td>[nonnull-]blob</td><td>
+unsigned char *
+</td></tr><tr><td>[nonnull-]u8vector</td><td>
+unsigned char *
+</td></tr><tr><td>[nonnull-]s8vector</td><td>
+char *
+</td></tr><tr><td>[nonnull-]u16vector</td><td>
+unsigned short *
+</td></tr><tr><td>[nonnull-]s16vector</td><td>
+short *
+</td></tr><tr><td>[nonnull-]u32vector</td><td>
+uint32_t *
+</td></tr><tr><td>[nonnull-]s32vector</td><td>
+int32_t *
+</td></tr><tr><td>[nonnull-]f32vector</td><td>
+float *
+</td></tr><tr><td>[nonnull-]f64vector</td><td>
+double *
+</td></tr><tr><td>[nonnull-]c-string</td><td>
+char *
+</td></tr><tr><td>[nonnull-]unsigned-c-string</td><td>
+unsigned char *
+</td></tr>
+<tr><td>c-string-list</td><td>char **</td></tr>
+<tr><td>symbol</td><td>
+char *
+</td></tr><tr><td>void</td><td>
+void
+</td></tr><tr><td>([nonnull-]c-pointer TYPE)</td><td>
+TYPE *
+</td></tr><tr><td>(enum NAME)</td><td>
+enum NAME
+</td></tr><tr><td>(struct NAME)</td><td>
+struct NAME
+</td></tr><tr><td>(ref TYPE)</td><td>
+TYPE &
+</td></tr><tr><td>(template T1 T2 ...)</td><td>
+T1<T2, ...>
+</td></tr><tr><td>(union NAME)</td><td>
+union NAME
+</td></tr><tr><td>(function RTYPE (ATYPE ...) [CALLCONV])</td><td>
+[CALLCONV] RTYPE (*)(ATYPE, ...)
+</td></tr><tr><td>(instance CNAME SNAME)</td><td>
+CNAME *
+</td></tr><tr><td>(instance-ref CNAME SNAME)</td><td>
+CNAME &
+</td></tr></table>
+
+---
+Previous: [[Accessing external objects]]
+
+Next: [[Embedding]]
diff --git a/manual/Getting started b/manual/Getting started
new file mode 100644
index 00000000..63cad4a1
--- /dev/null
+++ b/manual/Getting started
@@ -0,0 +1,633 @@
+[[tags: manual]]
+
+== Getting started
+
+Chicken is a compiler that translates Scheme source files into
+C, which in turn can be fed to a C compiler to generate a
+standalone executable. An interpreter is also available and can be
+used as a scripting environment or for testing programs before
+compilation.
+
+This chapter is designed to get you started with Chicken programming,
+describing what it is and what it will do for you, and covering basic
+use of the system. With almost everything discussed here, there is
+more to the story, which the remainder of the manual reveals. Here, we
+only cover enough to get you started. Nonetheless, someone who knows
+Scheme already should be able to use this chapter as the basis for
+writing and running small Chicken programs.
+
+=== Scheme
+
+Scheme is a member of the Lisp family of languages, of which Common
+Lisp and Emacs Lisp are the other two widely-known members. As with
+Lisp dialects, Scheme features
+
+* a wide variety of programming paradigms, including imperative, functional, and object-oriented
+* a very simple syntax, based upon nested parenthesization
+* the ability to extend the language in meaningful and useful ways
+
+In contrast to Common Lisp, Scheme is very minimal, and tries to
+include only those features absolutely necessary in programming. In
+contrast to Emacs Lisp, Scheme is not anchored into any one program
+(Emacs), and has a somewhat more modern language design.
+
+Scheme is defined in a document called ''The Revised^5 Report on the
+Algorithmic Language Scheme'', or ''R5RS'' for short. (Yes, it really
+has been revised five times, so an expanded version of its name would
+be ''The Revised Revised Revised Revised Revised Report''.) A newer
+report, ''R6RS'', was
+released in 2007, but this report has attracted considerable
+controversy, and not all Scheme implementations will be made compliant
+with it. Chicken essentially complies with R5RS.
+
+Even though Scheme is consciously minimalist, it is recognized that a
+language must be more than a minimal core in order to be
+useful. Accordingly, the Scheme community uses a process known as
+`Scheme Requests For Implementation' (SRFI, pronounced `SUR-fee') to
+define new language features. A typical Scheme system therefore
+complies with one of the Scheme reports plus some or all of the
+accepted SRFIs.
+
+A good starting point for Scheme knowledge is
+[[http://www.schemers.org]]. There you will find the defining reports,
+FAQs, lists of useful books and other resources, and the SRFIs.
+
+The Chicken community is at present developing tutorials for
+programmers who are new to Scheme but experienced with Python, Ruby,
+or other languages. These can be found on the Chicken wiki.
+
+=== Chicken
+
+Chicken is an implementation of Scheme that has many advantages.
+
+<blockquote>
+Chicken Scheme combines an optimising compiler with a reasonably fast
+interpreter. It supports almost all of R5RS and the important SRFIs.
+The compiler generates portable C code that supports tail recursion,
+first-class continuations, and lightweight threads, and the interface to
+and from C libraries is flexible, efficient, and easy to use. There are
+hundreds of contributed Chicken libraries that make the programmer's
+task easier. The interpreter allows interactive use, fast prototyping,
+debugging, and scripting. The active and helpful Chicken community
+fixes bugs and provides support. Extensive documentation is supplied.
+</blockquote>
+
+Chicken was developed by Felix L. Winkelmann over the period from 2000
+through 2007. In early 2008, Felix
+asked the community to take over the responsibility of developing and
+maintaining the system, though he still takes a strong interest in it,
+and participates actively.
+
+Chicken includes
+
+* a Scheme interpreter that supports almost all of R5RS Scheme, with
+ only a few relatively minor omissions, and with many extensions
+* a compatible compiler whose target is C, thus making porting to new
+ machines and architectures relatively straightforward
+** the C support allows Scheme code to include `embedded' C code,
+ thus making it relatively easy to invoke host OS or library
+ functions
+* a framework for language extensions, library modules that broaden
+ the functionality of the system
+
+This package is distributed under the '''BSD license''' and as such is free
+to use and modify.
+
+Scheme cognoscenti will appreciate the method of compilation and the
+design of the runtime-system, which follow closely Henry Baker's
+[[http://home.pipeline.com/~hbaker1/CheneyMTA.html|CONS Should Not
+CONS Its Arguments, Part II: Cheney on the M.T.A.]] paper and expose a
+number of interesting properties.
+
+* Consing (creation of data on the heap) is relatively inexpensive,
+ because a generational garbage collection scheme is used, in which
+ short-lived data structures are reclaimed extremely quickly.
+
+* Moreover, {{call-with-current-continuation}} is practically for free
+ and Chicken does not suffer under any performance penalties if
+ first-class continuations are used in complex ways.
+
+The generated C code is fully tail-recursive.
+
+Some of the features supported by Chicken:
+
+* SRFIs 0, 1, 2, 4, 6-19, 23, 25-31, 37-40, 42, 43, 45, 47, 55, 57,
+ 60-63, 66, 69, 72, 78, 85, 95 and 98.
+* Lightweight threads based on first-class continuations
+* Pattern matching with Andrew Wright's {{match}} package
+* Record structures
+* Extended comment- and string-literal syntaxes
+* Libraries for regular expressions, string handling
+* UNIX system calls and extended data structures
+* Create interpreted or compiled shell scripts written in Scheme for
+ UNIX or Windows
+* Compiled C files can be easily distributed
+* Allows the creation of fully self-contained statically linked executables
+* On systems that support it, compiled code can be loaded dynamically
+
+Chicken has been used in many environments ranging from embedded
+systems through desktop machines to large-scale server deployments.
+The number of language extensions, or '''eggs''', is constantly growing.
+
+* extended language features
+* development tools, such as documentation generators, debugging, and
+ automated testing libraries
+* interfaces to other languages such as Java, Python, and Objective-C
+* interfaces to database systems, GUIs, and other large-scale
+ libraries,
+* network applications, such as servers and clients for ftp,
+ smtp/pop3, irc, and http
+* web servers and related tools, including URL parsing, HTML
+ generation, AJAX, and HTTP session management
+* data formats, including XML, JSON, and Unicode support
+
+Chicken is supported by SWIG (Simplified Wrapper and Interface
+Generator), a tool that produces quick-and-dirty interface modules
+for C libraries ([[http://www.swig.org]]).
+
+This chapter provides you with an overview of the entire system, with
+enough information to get started writing and running small Scheme
+programs. Subsequent chapters cover
+
+* [[Basic mode of operation]]: Compiling Scheme files.
+
+* [[Using the compiler]]: Explains how to use Chicken to compile
+ programs and execute them.
+
+* [[Using the interpreter]]: Invocation and usage of {{csi}}, the
+ Chicken interpreter
+
+* [[Supported language]]: The language implemented by Chicken
+ (deviations from the standard and extensions).
+
+* [[Interface to external functions and variables]]: Accessing C and
+ C++ code and data.
+
+* [[Extensions]]: Packaging and installing extension libraries.
+
+* [[Data representation]]: How Scheme data is internally represented.
+
+* [[Bugs and limitations]]: Yes, there are some.
+
+* [[FAQ]]: A list of Frequently Asked Questions about Chicken (and
+ their answers!).
+
+* [[Acknowledgements]]: A list of some of the people that have
+ contributed to make Chicken what it is.
+
+* [[Bibliography]]: Links to documents that may be of interest.
+
+=== Chicken repositories, websites, and community
+
+At present, the URLs for Chicken information and download are somewhat
+confusing. It is envisaged that everything will eventually be
+accessible via the
+domain {{chicken-scheme.org}}, but this hasn't been completely done.
+
+At present, the master Chicken website is
+[[http://www.call-with-current-continuation.org]]. Here you can find
+basic information about Chicken, downloads, and pointers to other key
+resources.
+
+The Chicken wiki ([[http://chicken.wiki.br]]) contains the most
+current version of the User's manual, along with various tutorials and
+other useful documents. The list of eggs is at
+[[http://chicken.wiki.br/Eggs%20Unlimited]].
+
+A very useful search facility for questions about Chicken is found at
+[[http://www.callcc.org]]. The Chicken issue tracker is at
+[[http://trac.callcc.org]].
+
+The Chicken community has two major mailing lists. If you are a
+Chicken user, {{Chicken-Users}}
+([[http://lists.nongnu.org/mailman/listinfo/chicken-users]]) will be
+of interest. The crew working on the Chicken system itself uses the
+very low-volume {{Chicken-Hackers}} list
+([[http://lists.nongnu.org/mailman/listinfo/chicken-hackers]]) for
+communication.
+
+=== Installing Chicken
+
+Chicken is available in binary form for Windows and Linux/x86
+systems, and in source form for all other platforms. Refer to the
+{{README}} file in the distribution for instructions on installing it
+on your system.
+
+Because it compiles to C, Chicken requires that a C compiler be
+installed on your system. (If you're not writing embedded C code, you
+can pretty much ignore the C compiler once you have installed it.)
+
+* On a Linux system, the GNU Compiler Collection ({{gcc}}) should be
+ installed as part of the basic operating system, or should be
+ available through the package management system (e.g., APT,
+ Synaptic, RPM, or Yum, depending upon your Linux distribution).
+* On Macintosh OS X, you will need the XCode tools, which are shipped
+ on the OS X DVD with recent versions of the operating system.
+* On Windows, you have three choices.
+** Cygwin ([[http://sources.redhat.com/cygwin]]) provides a relatively
+ full-featured Unix environment for Windows. Chicken works
+ substantially the same in Cygwin and Unix.
+** The GNU Compiler Collection has been ported to Windows, in the
+ MinGW system ([[http://mingw.sourceforge.net]]). Unlike Cygwin,
+ executables produced with MinGW do not need the Cygwin DLLs in order
+ to run. MSys is a companion package to MinGW; it provides a minimum
+ Unix-style development/build environment, again ported from free
+ software.
+*** You can build Chicken either with MinGW alone or with MinGW plus
+ MSys. Both approaches produce a Chicken built against the mingw headers
+ and import libraries.
+ The only difference is the environment where you actually run make.
+ {{Makefile.mingw}} is can be used in {{cmd.exe}} with the version of make
+ that comes with mingw. {{Makefile.mingw-msys}}
+ uses unix commands such as {{cp}} and {{rm}}. The end product is the
+ same.
+** Microsoft Visual Studio will soon be supported, including the
+ Express edition, which is a non-free but no-cost compiler suite
+ available from Microsoft
+ ([[http://www.microsoft.com/express/vc]]). Chicken supports
+ command-line building using the command-line C/C++ compiler.
+*** Visual
+ Studio users will want to install the Unix Utilities, available at
+ [[http://www.call-with-current-continuation.org/tarballs/UnxUtils.zip]],
+ in order to get suitable versions of {{make}}, {{tar}}, {{gzip}}, and
+ similar commands.
+
+Refer to the {{README}} file for the version you're installing for
+more information on the installation process.
+
+=== Development environments
+
+The simplest development environment is a text editor and terminal
+window (Windows: Command Prompt, OSX: Terminal, Linux/Unix: xterm) for
+using the interpreter and/or calling the compiler. If you
+[[/egg/readline|install the {{readline}} egg]], you
+have all the benefits of command history in the interpreter, Emacs or
+vi-compatible line editing, and customization.
+
+You will need a text editor that knows Scheme; it's just too painful
+with editors that don't do parenthesis matching and proper
+indentation. Some editors allow you to execute Scheme code directly in
+the editor. This makes programming very interactive: you can type in a
+function and then try it right away. This feature is very highly
+recommended.
+
+As programmers have very specific tastes about editors, the editors
+listed here are shown in alphabetic order. We aren't about to tell you
+which editor to use, and there may be editors not shown here that
+might satisfy your needs. We would be very interested in reports of
+other editors that have been used with Chicken, especially those that
+support interactive evaluation of forms during editing. Pointers to
+these (and to any editor customization files appropriate) should be
+put on the Chicken wiki, and will likely be added to future editions
+of this manual. (We have had a request for editors that support
+proportional fonts, in particular.)
+
+* Emacs ([[http://www.gnu.org/software/emacs]]) is an
+extensible, customizable, self-documenting editor available for
+Linux/Unix, Macintosh, and Windows systems; CHICKEN provides Emacs
+support out of the box, with the {{hen.el}} Emacs Lisp file. Consult
+the `Emacs Guide for Chicken Users' (which will be available on the
+Chicken Wiki soon) for information on setting up and using Emacs with
+Chicken.
+
+* Epsilon ([[http://www.lugaru.com]]) is a commercial (proprietary) text
+editor whose design was inspired by Emacs. Although Scheme support
+isn't provided, a Lisp mode is available on Lugaru's FTP site, and
+could with some work be made to duplicate the Emacs support.
+
+* SciTE ([[http://scintilla.sourceforge.net/SciTE.html]]),
+unlike Emacs or Vim, follows typical graphical UI design conventions
+and control-key mappings, and for simple tasks is as familiar and
+easy to use as Notepad, KEdit, TeachText etc. However it has many
+programming features such as multiple open files, syntax
+highlighting for a large number of languages (including Lisps),
+matching of brackets, ability to fold sections of code based on the
+matched brackets, column selections, comment/uncomment, and the
+ability to run commands in the same directory as the current file
+(such as make, grep, etc.) SciTE is written with the GTK toolkit
+and is portable to any GTK platform, including Windows, Linux and
+MacOS. It uses the Scintilla text-editing component, which lends
+itself well to embedding within other IDEs and graphical toolkits.
+It does not have any other Scheme-specific features, but being
+open-source and modular, features like auto-formatting of
+S-expressions could be added. The syntax highlighting can be
+configured to use different fonts for different types of syntax,
+including proportional fonts.
+
+* Vim ([[http://www.vim.org]]) is a highly configurable text
+editor built to enable efficient and fast text editing. It is an
+improved version of the vi editor distributed with most UNIX
+systems. Vim comes with generic Lisp (and therefore Scheme) editing
+capabilities out of the
+box. A few tips on using Vim with Chicken can be found at
+[[http://cybertiggyr.com/gene/15-vim/]].
+
+In the rest of this chapter, we'll assume that you are using an editor
+of your choice and a regular terminal window for executing your
+Chicken code.
+
+=== The Read-Eval-Print loop
+
+To invoke the Chicken interpreter, you use the {{csi}} command.
+
+ $ csi
+ CHICKEN
+ (c)2008 The Chicken Team
+ (c)2000-2007 Felix L. Winkelmann
+ Version 3.1.2 - macosx-unix-gnu-x86 [ manyargs dload ptables applyhook ]
+ SVN rev. 10185 compiled 2008-03-27 on argyre.local (Darwin)
+ #;1>
+
+This brings up a brief banner, and then the prompt. You can use this
+pretty much like any other Scheme system, e.g.,
+
+ #;1> (define (twice f) (lambda (x) (f (f x))))
+ #;2> ((twice (lambda (n) (* n 10))) 3)
+ 300
+
+Suppose we have already created a file {{fact.scm}} containing a
+function definition.
+
+ (define (fact n)
+ (if (= n 0)
+ 1
+ (* n (fact (- n 1)))))
+
+We can now load this file and try out the function.
+
+ #;3> (load "fact.scm")
+ ; loading fact.scm ...
+ #;4> (fact 3)
+ 6
+
+The '''read-eval-print loop''' ('''REPL''') is the component of the
+Scheme system that ''reads'' a Scheme expression, ''eval''uates it,
+and ''prints'' out the result. The REPL's prompt can be customized
+(see the [[http:Using%20the%20interpreter|`Using the Interpreter']])
+but the default prompt, showing the number of the form, is quite
+convenient.
+
+The REPL also supports debugging commands:
+input lines beginning with a {{,}} (comma) are treated as special
+commands. (See the [[Using the interpreter#Toplevel commands|full list]].) We can
+'''trace''' {{fact}} to see how it works.
+
+ #;5> ,tr fact
+ #;5> (fact 3)
+ |(fact 3)
+ | (fact 2)
+ | (fact 1)
+ | (fact 0)
+ | fact -> 1
+ | fact -> 1
+ | fact -> 2
+ |fact -> 6
+ 6
+
+The command number didn't increment, because the {{tr}} command isn't
+actually a Scheme ''form''.
+
+==== Scripts
+
+You can use the interpreter to run a Scheme program from the command
+line. Here we create a program that does a quick search-and-replace on
+an input file; the arguments are a regular expression and a
+replacement string.
+
+ $ cat quickrep.dat
+ xyzabcghi
+ abxawxcgh
+ foonly
+ $ csi -ss quickrep.scm <quickrep.dat 'a.*c' A
+ xyzAghi
+ Agh
+ foonly
+
+The {{-ss}} option sets several options that work smoothly together to
+execute a script. You can make the command directly executable from
+the shell by inserting a `[[Using the interpreter#Writing Scheme scripts|shebang line]]' at the beginning of the
+program.
+
+{{regex}}, the regular expression library, is one of the libraries
+included with Chicken.
+
+ (use regex)
+ (define (process-line line re rplc)
+ (string-substitute re rplc line 'all))
+ (define (quickrep re rplc)
+ (let ((line (read-line)))
+ (if (not (eof-object? line))
+ (begin
+ (display (process-line line re rplc))
+ (newline)
+ (quickrep re rplc)))))
+ ;;; Does a lousy job of error checking!
+ (define (main args)
+ (quickrep (regexp (car args)) (cadr args)))
+
+The {{-ss}} option arranges to call a procedure named {{main}}, with
+the command line arguments, packed in a list, as its arguments. (There
+are a number of ways this program could be made more idiomatic Chicken
+Scheme, see the rest of the manual for details.)
+
+=== The compiler
+
+There are several reasons you might want to compile your code.
+
+* Compiled code executes substantially faster than interpreted
+ code.
+* You might want to deploy an application onto machines where the
+ users aren't expected to have Chicken installed: compiled
+ applications can be self-contained.
+
+The Chicken compiler is provided as the command {{chicken}}, but in
+almost all cases, you will want to use the {{csc}} command
+instead. {{csc}} is a convenient driver that automates compiling
+Scheme programs into C, compiling C code into object code, and linking
+the results into an executable file. (Note: in a Windows environment
+with Visual Studio, you may find that {{csc}} refers to Microsoft's
+C# compiler. There are a number of ways of sorting this out, of which
+the simplest is to rename one of the two tools, and/or to
+organize your {{PATH}} according to the task at hand.)
+
+Compiled code can be intermixed with interpreted code on systems that
+support dynamic loading, which includes modern versions of *BSD,
+Linux, Mac OS X, Solaris, and Windows.
+
+We can compile our factorial function, producing a file named
+{{fact.so}} (`shared object' in Linux-ese, the same file type is used
+in OS X and Windows, rather than {{dylib}} or {{dll}}, respectively).
+
+ chicken$ csc -dynamic fact.scm
+ chicken$ csi -quiet
+ #;1> (load "fact.so")
+ ; loading fact.so ...
+ #;2> (fact 6)
+ 720
+
+On any system, we can just compile a program directly into an
+executable. Here's a program that tells you whether its argument is a
+palindrome.
+
+ (define (palindrome? x)
+ (define (check left right)
+ (if (>= left right)
+ #t
+ (and (char=? (string-ref x left) (string-ref x right))
+ (check (add1 left) (sub1 right)))))
+ (check 0 (sub1 (string-length x))))
+ (let ((arg (car (command-line-arguments))))
+ (display
+ (string-append arg
+ (if (palindrome? arg)
+ " is a palindrome\n"
+ " isn't a palindrome\n"))))
+
+We can compile this program using {{csc}}, creating an executable
+named {{palindrome}}.
+
+ $ csc -o palindrome palindrome.scm
+ $ ./palindrome level
+ level is a palindrome
+ $ ./palindrome liver
+ liver isn't a palindrome
+
+Chicken supports separate compilation, using some extensions to
+Scheme. Let's divide our palindrome program into a library module
+({{pal-proc.scm}}) and a client module ({{pal-user.scm}}).
+
+Here's the external library. We {{declare}} that {{pal-proc}} is a
+`unit', which is the basis of separately-compiled modules in
+Chicken. (Units deal with separate compilation, but don't involve
+separated namespaces; namespaced module systems are available as
+eggs.)
+
+ ;;; Library pal-proc.scm
+ (declare (unit pal-proc))
+ (define (palindrome? x)
+ (define (check left right)
+ (if (>= left right)
+ #t
+ (and (char=? (string-ref x left) (string-ref x right))
+ (check (add1 left) (sub1 right)))))
+ (check 0 (sub1 (string-length x))))
+
+Next we have some client code that `uses' this separately-compiled
+module.
+
+ ;;; Client pal-user.scm
+ (declare (uses pal-proc))
+ (let ((arg (car (command-line-arguments))))
+ (display
+ (string-append arg
+ (if (palindrome? arg)
+ " is a palindrome\n"
+ " isn't a palindrome\n"))))
+
+Now we can compile and link everything together. (We show the compile
+and link operations separately, but they can of course be combined
+into one command.)
+
+ $ csc -c pal-proc.scm
+ $ csc -c pal-user.scm
+ $ csc -o pal-separate pal-proc.o pal-user.o
+ $ ./pal-separate level
+ level is a palindrome
+
+=== Installing an egg
+
+Installing eggs is quite straightforward on systems that support
+dynamic loading (again, that would include *BSD, Linux, Mac OS X,
+Solaris, and Windows). The command {{chicken-install}} will fetch an
+egg from the master Chicken repository, and install it on your local
+system.
+
+In this example, we install the {{uri}} egg, for parsing Uniform
+Resource Identifiers. The installation produces a lot of output, which
+we have edited for space reasons.
+
+ $ chicken-install uri
+
+ The extension uri does not exist.
+ Do you want to download it ? (yes/no/abort) [yes] yes
+ downloading uri.egg from (www.call-with-current-continuation.org eggs/3 80)
+ gzip -d -c ../uri.egg | tar xf -
+ . /Users/vmanis/local/bin/csc -feature compiling-extension
+ -s -O2 -d1 uri.scm -o uri.so -check-imports -emit-exports uri.exports
+ ... (lots of stuff elided)
+ . rm -fr /Users/vmanis/project/chicken/uri.egg
+
+First, {{chicken-install}} asks us if we want to download the egg. It
+then uncompresses the egg, compiles the code, and installs the egg in
+the local Chicken repository.
+
+Now we can use our new egg.
+
+ #;1> (use uri)
+ ; loading /Users/vmanis/local/lib/chicken/3/uri.so ...
+ ; loading /Users/vmanis/local/lib/chicken/3/coerce-support.so ...
+ ; loading /Users/vmanis/local/lib/chicken/3/misc-extn-list-support.so ...
+ ; loading /Users/vmanis/local/lib/chicken/3/synch-support.so ...
+ ; loading /Users/vmanis/local/lib/chicken/3/lookup-table.so ...
+ ; loading /Users/vmanis/local/lib/chicken/3/misc-extn-control-support.so ...
+ #;2> (uri-host (uri "http://www.foobar.org/blah"))
+ "www.foobar.org"
+
+=== Accessing C libraries
+
+Because Chicken compiles to C, and because a foreign function
+interface is built into the compiler, interfacing to a C library is
+quite straightforward. This means that nearly any facility available
+on the host system is accessible from Chicken, with more or less
+work.
+
+Let's create a simple C library, to demonstrate how this
+works. Here we have a function that will compute and return the '''n'''th
+Fibonacci number. (This isn't a particularly good use of C here,
+because we could write this function just as easily in Scheme, but a
+real example would take far too much space here.)
+
+ /* fib.c */
+ int fib(int n) {
+ int prev = 0, curr = 1;
+ int next;
+ int i;
+ for (i = 0; i < n; i++) {
+ next = prev + curr;
+ prev = curr;
+ curr = next;
+ }
+ return curr;
+ }
+
+Now we can call this function from Chicken.
+
+ ;;; fib-user.scm
+ #>
+ extern int fib(int n);
+ <#
+ (define xfib (foreign-lambda int "fib" int))
+ (do ((i 0 (+ i 1))) ((> i 10))
+ (printf "~A " (xfib i)))
+ (newline)
+
+The syntax {{#>...<#}} allows you to include literal C (typically
+external declarations) in your Chicken code. We access {{fib}} by
+defining a {{foreign-lambda}} for it, in this case saying that the
+function takes one integer argument (the {{int}} after the function
+name), and that it returns an integer result (the {{int}} before.) Now we can invoke
+{{xfib}} as though it were an ordinary Scheme function.
+
+ $ gcc -c fib.c
+ $ csc -o fib-user fib.o fib-user.scm
+ $ ./fib-user
+ 0 1 1 2 3 5 8 13 21 34 55
+
+Those who are interfacing to substantial C libraries should consider
+using the [[easyffi]] egg.
+
+---
+
+Back to [[The User's Manual]]
+
+Next: [[Basic mode of operation]]
diff --git a/manual/Interface to external functions and variables b/manual/Interface to external functions and variables
new file mode 100644
index 00000000..07ce9c18
--- /dev/null
+++ b/manual/Interface to external functions and variables
@@ -0,0 +1,20 @@
+[[tags: manual]]
+
+== Interface to external functions and variables
+
+The macros in this section, such as {{define-foreign-type}} and {{define-external}}, are available in the {{foreign}} import library. To access them:
+
+ (import foreign)
+
+* [[Accessing external objects]]
+* [[Foreign type specifiers]]
+* [[Embedding]]
+* [[Callbacks]]
+* [[Locations]]
+* [[Other support procedures]]
+* [[C interface]]
+
+---
+Previous: [[Supported language]]
+
+Next: [[Extensions]]
diff --git a/manual/Locations b/manual/Locations
new file mode 100644
index 00000000..c2fd820f
--- /dev/null
+++ b/manual/Locations
@@ -0,0 +1,82 @@
+[[tags: manual]]
+
+[[toc:]]
+
+
+== Locations
+
+It is also possible to define variables containing unboxed C data,
+so called ''locations''. It should be noted that locations may
+only contain simple data, that is: everything that fits into a
+machine word, and double-precision floating point values.
+
+
+
+=== define-location
+
+ [syntax] (define-location NAME TYPE [INIT])
+
+Identical to {{(define-external NAME TYPE [INIT])}}, but the variable
+is not accessible from outside of the current compilation unit (it is
+declared {{static}}).
+
+=== let-location
+
+ [syntax] (let-location ((NAME TYPE [INIT]) ...) BODY ...)
+
+Defines a lexically bound location.
+
+=== location
+
+ [syntax] (location NAME)
+ [syntax] (location X)
+
+This form returns a pointer object
+that contains the address of the variable {{NAME}}.
+If the argument to {{location}} is not a location defined by {{define-location}},
+{{define-external}} or {{let-location}}, then
+
+ (location X)
+
+is essentially equivalent to
+
+ (make-locative X)
+
+(See the manual chapter or {{locatives}} for more information about
+locatives.
+
+Note that {{(location X)}} may be abbreviated as {{#$X}}.
+
+<enscript highlight=scheme>
+(define-external foo int)
+((foreign-lambda* void (((c-pointer int) ip)) "*ip = 123;")
+ (location foo))
+foo ==> 123
+</enscript>
+
+This facility is especially useful in situations, where a C function
+returns more than one result value:
+
+<enscript highlight=scheme>
+#>
+#include <math.h>
+<#
+
+(define modf
+ (foreign-lambda double "modf" double (c-pointer double)) )
+
+(let-location ([i double])
+ (let ([f (modf 1.99 (location i))])
+ (print "i=" i ", f=" f) ) )
+</enscript>
+
+See [[http://chicken.wiki.br/location-and-c-string-star|location and c-string*]]
+for a tip on returning a {{c-string*}} type.
+
+{{location}} returns a value of type {{c-pointer}}, when given
+the name of a callback-procedure defined with {{define-external}}.
+
+---
+Previous: [[Callbacks]]
+
+Next: [[Other support procedures]]
diff --git a/manual/Modules and macros b/manual/Modules and macros
new file mode 100644
index 00000000..bc4be9d2
--- /dev/null
+++ b/manual/Modules and macros
@@ -0,0 +1,522 @@
+[[tags: manual]]
+[[toc:]]
+
+
+== Modules and macros
+
+
+CHICKEN supports standard R5RS {{syntax-rules}} macros and a low-level
+macro system based on ''explicit renaming''.
+
+
+=== Macro definitions
+
+==== define-syntax
+
+ [syntax] (define-syntax IDENTIFIER TRANSFORMER)
+
+Defines a macro named {{IDENTIFIER}} that will transform an expression
+with {{IDENTIFIER}} in operator position according to {{TRANSFORMER}}.
+The transformer expression must be a procedure with three arguments or
+a {{syntax-rules}} form. If {{syntax-rules}} is used, the usual R5RS
+semantics apply. If {{TRANSFORMER}} is a procedure, then it will
+be called on expansion with the complete s-expression of the macro
+invocation, a rename procedure that hygienically renames identifiers
+and a comparison procedure that compares (possibly renamed) identifiers.
+
+{{define-syntax}} may be used to define local macros that are visible
+throughout the rest of the body in which the definition occurred, i.e.
+
+ (let ()
+ ...
+ (define-syntax foo ...)
+ (define-syntax bar ...)
+ ...)
+
+is expanded into
+
+ (let ()
+ ...
+ (letrec-syntax ((foo ...) (bar ...))
+ ...) )
+
+{{syntax-rules}} partially supports [[http://srfi.schemers.org/srfi-46/|SRFI-46]]
+in allowing the ellipsis identifier to be user-defined by passing it as the first
+argument to the {{syntax-rules}} form.
+
+The effect of destructively modifying the s-expression passed to a
+transformer procedure is undefined.
+
+
+==== define-compiled-syntax
+
+ [syntax] (define-compiled-syntax IDENTIFIER TRANSFORMER)
+
+Equivalent to {{define-syntax}}, but when compiled, will also define the macro
+at runtime.
+
+
+==== syntax
+
+ [syntax] (syntax EXPRESSION)
+
+Similar to {{quote}} but retains syntactical context information for
+embedded identifiers.
+
+
+==== strip-syntax
+
+ [procedure] (strip-syntax EXPRESSION)
+
+Strips all syntactical information from {{EXPRESSION}}, returning a new expression
+where symbols have all context-information removed.
+
+
+=== Explicit renaming macros
+
+The low-level macro facility that CHICKEN provides is called "explicit
+renaming" and allows writing hygienic or non-hygienic macros procedurally.
+When given a lambda-expression instead of a {{syntax-rules}} form,
+{{define-syntax}} evaluates the procedure in a distinct expansion
+environment (initially having access to the exported identifiers
+of the {{scheme}} module). The procedure takes an expression and two
+other arguments and returns a transformed expression.
+
+For example, the transformation
+procedure for a {{call}} macro such that
+{{(call proc arg ...)}} expands
+into {{(proc arg ...)}} can be written as
+
+ (lambda (exp rename compare)
+ (cdr exp))
+
+Expressions are represented as lists in the traditional manner,
+except that identifiers are represented as special uninterned symbols.
+
+The second argument to a transformation procedure is a renaming procedure that
+takes the representation of an identifier as its argument and returns the
+representation of a fresh identifier that occurs nowhere else in the
+program. For example, the transformation procedure for a simplified
+version of the {{let}} macro might be written as
+
+ (lambda (exp rename compare)
+ (let ((vars (map car (cadr exp)))
+ (inits (map cadr (cadr exp)))
+ (body (cddr exp)))
+ `((lambda ,vars ,@body)
+ ,@inits)))
+
+This would not be hygienic, however. A
+hygienic {{let}} macro must rename the identifier {{lambda}} to protect it
+from being captured by a local binding. The renaming effectively
+creates a fresh alias for {{lambda}}, one that cannot be captured by
+any subsequent binding:
+
+ (lambda (exp rename compare)
+ (let ((vars (map car (cadr exp)))
+ (inits (map cadr (cadr exp)))
+ (body (cddr exp)))
+ `((,(rename 'lambda) ,vars ,@body)
+ ,@inits)))
+
+The expression returned by the transformation procedure will be
+expanded in the syntactic environment obtained from the syntactic
+environment of the macro application by binding any fresh identifiers
+generated by the renaming procedure to the denotations of the original
+identifiers in the syntactic environment in which the macro was
+defined. This means that a renamed identifier will denote the same
+thing as the original identifier unless the transformation procedure
+that renamed the identifier placed an occurrence of it in a binding
+position.
+
+Identifiers obtained from any two calls to the renaming procedure with
+the same argument will necessarily be the same, but will denote the
+same syntactical binding. It is an error if the renaming procedure is
+called after the transformation procedure has returned.
+
+The third argument to a transformation procedure is a comparison
+predicate that takes the representations of two identifiers as its
+arguments and returns true if and only if they denote the same thing
+in the syntactic environment that will be used to expand the
+transformed macro application. For example, the transformation
+procedure for a simplified version of the {{cond}} macro can be written
+as
+
+ (lambda (exp rename compare)
+ (let ((clauses (cdr exp)))
+ (if (null? clauses)
+ `(,(rename 'quote) unspecified)
+ (let* ((first (car clauses))
+ (rest (cdr clauses))
+ (test (car first)))
+ (cond ((and (symbol? test)
+ (compare test (rename 'else)))
+ `(,(rename 'begin) ,@(cdr first)))
+ (else `(,(rename 'if)
+ ,test
+ (,(rename 'begin) ,@(cdr first))
+ (cond ,@rest))))))))
+
+In this example the identifier {{else}} is renamed before being passed
+to the comparison predicate, so the comparison will be true if and
+only if the test expression is an identifier that denotes the same
+thing in the syntactic environment of the expression being transformed
+as {{else}} denotes in the syntactic environment in which the {{cond}}
+macro was defined. If {{else}} were not renamed before being passed to
+the comparison predicate, then it would match a local variable that
+happened to be named {{else}}, and the macro would not be hygienic.
+
+Some macros are non-hygienic by design. For example, the
+following defines a {{loop}} macro that implicitly binds {{exit}} to an
+escape procedure. The binding of {{exit}} is intended to capture free
+references to {{exit}} in the body of the loop, so {{exit}} is not
+renamed.
+
+ (define-syntax loop
+ (lambda (x r c)
+ (let ((body (cdr x)))
+ `(,(r 'call-with-current-continuation)
+ (,(r 'lambda) (exit)
+ (,(r 'let) ,(r 'f) () ,@body (,(r 'f))))))))
+
+Suppose a {{while}} macro is implemented using {{loop}}, with the intent
+that {{exit}} may be used to escape from the {{while}} loop. The {{while}}
+macro cannot be written as
+
+ (define-syntax while
+ (syntax-rules ()
+ ((while test body ...)
+ (loop (if (not test) (exit #f))
+ body ...))))
+
+because the reference to {{exit}} that is inserted by the {{while}} macro
+is intended to be captured by the binding of {{exit}} that will be
+inserted by the {{loop}} macro. In other words, this {{while}} macro is
+not hygienic. Like {{loop}}, it must be written using procedurally:
+
+ (define-syntax while
+ (lambda (x r c)
+ (let ((test (cadr x))
+ (body (cddr x)))
+ `(,(r 'loop)
+ (,(r 'if) (,(r 'not) ,test) (exit #f))
+ ,@body))))
+
+
+=== Modules
+
+To allow some control over visible bindings and to organize code at
+the global level, a simple module system is available. A ''module''
+defines a set of toplevel expressions that are initially evaluated in
+an empty syntactical environment. By ''importing'' other modules,
+exported value- and macro-bindings are made visible inside the
+environment of the module that imports them.
+
+Note that modules are purely syntactical - they do not change the
+control flow or delay the execution of the contained toplevel
+forms. The body of a module is executed at load-time, when code is
+loaded or accessed via the {{uses}} declaration, just like normal
+toplevel expressions. Exported macro-definitions are compiled as
+well, and can be accessed in interpreted or compiled code by loading
+and importing the compiled file that contains the module.
+
+Imported toplevel bindings can be assigned (with {{set!}}), any modifications
+to these will change the global value and will be visible to other
+modules that export or import the same toplevel binding.
+
+A module is initially empty (has no visible bindings). You must at least
+import the {{scheme}} module to do anything useful. To access any
+of the non-standard macros and procedures, import the {{chicken}}
+module.
+
+CHICKEN's module system has the following features and shortcomings:
+
+* Indirect exports for syntax definitions must be listed
+* Separation of compile/expansion-time and run-time code is provided, which allows cross compilation
+* Module-generating code is only created, when needed
+* Supports batch-compilation of separate compilation units
+* No separate "identifier" type is used, all identifiers appearing in code and processed in expansions are symbols
+* The module system is fully optional
+
+
+==== module
+
+ [syntax] (module NAME (EXPORT ...) BODY ...)
+ [syntax] (module NAME * BODY ...)
+
+Defines a module with the name {{NAME}}, a set of exported bindings
+and a contained sequence of toplevel expressions that are evaluated in
+an empty syntactical environment. {{EXPORT}} may be a symbol or a list
+of the form {{(IDENTIFIER1 IDENTIFIER2 ...)}}. In the former case the
+identifier given is exported from the module and can be imported at
+the toplevel or in other modules. The latter case exports
+{{IDENTIFIER1}} (which should name a macro) and also arranges for the
+remaining identifiers in the list to be visible in the expansion of
+the macro (this is a hint to the module expander to export bindings
+referenced by syntax-definitions which make use of them, but which
+would normally be internal to the module - that allows some
+optimization and also records).
+
+Nested modules, modules not at toplevel (i.e. local modules) or
+mutually recursive modules are not supported.
+
+When compiled, the module information, including exported macros
+is stored in the generated binary and available when loading
+it into interpreted or compiled code. Note that this is different
+to normal macros (outside of module declarations), which are normally
+not exported from compiled code.
+
+As a special case, specifying {{*}} instead of an export-list
+will export all definitions.
+
+Note that the module system is only a device for controlling the
+mapping of identifiers to value or syntax bindings. Modules do not
+instantiate separate environments that contain their own bindings, as
+do many other module systems. Redefinition of value or syntax bindings
+will modify the original, imported definition.
+
+
+==== export
+
+ [syntax] (export EXPORT ...)
+
+Allows augmenting module-exports from inside the module-body.
+{{EXPORT}} is if the same form as an export-specifier in a
+{{module}} export list. An export must precede its first occurrence
+(either use or definition).
+
+==== import
+
+ [syntax] (import IMPORT ...)
+
+Imports module bindings into the current syntactical environment.
+The visibility of any imported bindings is limited to the current
+module, if used inside a module-definition, or to the current
+compilation unit, if compiled and used outside of a module.
+
+Importing a module does not load or link it - this is a separate
+operation from importing its bindings.
+
+{{IMPORT}} may be a module name, or an ''import specifier''.
+An {{IMPORT}} defines a set of bindings that are to be made visible
+in the current scope.
+
+Note that the imported bindings are only visible in the next toplevel
+expression (regardless of whether the import appears inside or outside
+a module):
+
+ (begin
+ (import m1)
+ ... ; imports not visible here
+
+ ... ; imports visible here
+
+===== only
+
+ [import specifier] (only IMPORT IDENTIFIER ...)
+
+Only import the listed value- or syntax bindings from the set given
+by {{IMPORT}}.
+
+===== except
+
+ [import specifier] (except IMPORT IDENTIFIER ...)
+
+Remove the listed identifiers from the import-set defined by {{IMPORT}}.
+
+===== rename
+
+ [import specifier] (rename IMPORT (OLD1 NEW1) ...)
+
+Renames identifiers imported from {{IMPORT}}.
+
+===== prefix
+
+ [import specifier] (prefix IMPORT SYMBOL)
+
+Prefixes all imported identifiers with {{SYMBOL}}.
+
+
+==== import-for-syntax
+
+ [syntax] (import-for-syntax IMPORT ...)
+
+Similar to {{import}}, but imports exported bindings of a module into
+the environment in which macro transformers are evaluated.
+
+Note: currently this isn't fully correct - value bindings are still
+imported into the normal environment because a separate import
+environment for syntax has not been implemented (syntactic bindings
+are kept separate correctly).
+
+
+==== reexport
+
+ [syntax] (reexport IMPORT ...)
+
+Imports {{IMPORT ...}} and automatically exports all imported identifiers.
+This can be used to build ''compound modules'': modules that just extend
+other modules:
+
+<scheme>
+(module r4rs ()
+ (import scheme chicken)
+ (reexport
+ (except scheme
+ dynamic-wind values call-with-values eval scheme-report-environment
+ null-environment interaction-environment)))
+</scheme>
+
+
+=== import libraries
+
+''import libraries'' allow the syntactical (compile-time)
+and run-time parts of a compiled module to be separated into a normal
+compiled file and a shared library that only contains macro definitions
+and module information. This reduces the size of executables and
+simplifies compiling code that uses modules for a different architecture
+than the machine the compiler is executing on (i.e. "cross" compilation).
+
+By using the {{emit-import-library}} compiler-option or declaration,
+a separate file is generated that only contains syntactical information
+(including macros) for a module. {{import}} will automatically find and
+load an import library for a currently unknown module, if the import-
+library is either in the extension repository or the current include
+path. Import libraries may also be explicitly loaded into the
+compiler by using the {{-extend}} compiler option. Interpreted code
+can simply load the import library to make the module-definition
+available. Macro-support definitions defined with {{define-for-syntax}}
+and expansion-time expressions of the form {{(begin-for-syntax ...)}}
+will be added to import libraries to make them available for exported
+macros. Note that these definitions will ruthlessly pollute the
+toplevel namespace and so they should be used sparingly.
+
+
+=== Predefined modules
+
+Import libraries for the following modules are initially
+available:
+
+ [module] scheme
+
+Exports the standard R5RS bindings.
+
+ [module] chicken
+
+Everything from the {{library}}, {{eval}} and {{expand}} library units.
+
+ [module] extras
+ [module] data-structures
+ [module] ports
+ [module] lolevel
+ [module] posix
+ [module] regex
+ [module] srfi-1
+ [module] srfi-4
+ [module] srfi-13
+ [module] srfi-14
+ [module] srfi-18
+ [module] srfi-69
+ [module] tcp
+ [module] utils
+
+Modules exporting the bindings from the respective library units.
+
+ [module] foreign
+
+Exports all macros and procedures that are used to access foreign
+C/C++ code.
+
+
+=== Examples of using modules
+
+Here is a silly little test module to demonstrate how modules
+are defined and used:
+
+ ;; hello.scm
+
+ (module test (hello greet)
+ (import scheme)
+
+ (define-syntax greet
+ (syntax-rules ()
+ ((_ whom)
+ (begin
+ (display "Hello, ")
+ (display whom)
+ (display " !\n") ) ) ) )
+
+ (define (hello)
+ (greet "world") ) )
+
+The module {{test}} exports one value ({{hello}}) and one syntax
+binding ({{greet}}). To use it in {{csi}}, the interpreter,
+simply load and import it:
+
+ #;1> ,l hello.scm
+ ; loading hello.scm ...
+ ; loading /usr/local/lib/chicken/4/scheme.import.so ...
+ #;1> (import test)
+ #;2> (hello)
+ Hello, world !
+ #;3> (greet "you")
+ Hello, you !
+
+The module can easily be compiled
+
+ % csc -s hello.scm
+
+and used in an identical manner:
+
+ #;1> ,l hello.so
+ ; loading hello.so ...
+ #;1> (import test)
+ #;2> (hello)
+ Hello, world !
+ #;3> (greet "you")
+ Hello, you !
+
+If you want to keep macro-definitions in a separate file, use import
+libraries:
+
+ % csc -s hello.scm -j test
+ % csc -s test.import.scm
+
+ #;1> ,l hello.so
+ ; loading hello.so ...
+ #;1> (import test)
+ ; loading ./test.import.so ...
+ #;2> (hello)
+ Hello, world !
+ #;3> (greet "you")
+ Hello, you !
+
+If an import library (compiled or in source-form) is located
+somewhere in the extensions-repository or include path, it
+is automatically loaded on import. Otherwise you have to
+load it manually:
+
+ #;1> ,l hello.so
+ ; loading hello.so ...
+ #;1> ,l test.import.so
+ ; loading test.import.so ...
+ #;1> (import test)
+ #;2>
+
+
+=== Caveats
+
+The macro- and module system has been implemented relatively
+recently and is likely to contain bugs. Please contact the
+maintainers if you encounter behavior that you think is
+not correct or that triggers an error where there shouldn't
+be one.
+
+* In evaluated code, loading a file containing module information and importing from a module contained in that file will not work when the loading and import is performed in the same toplevel expression (this does not apply, when import libraries are used)
+* Currently value bindings imported by {{import}} and {{import-for-syntax}} share the same import-environment.
+
+
+---
+Previous: [[Non-standard macros and special forms]]
+
+Next: [[Declarations]]
diff --git a/manual/Non-standard macros and special forms b/manual/Non-standard macros and special forms
new file mode 100644
index 00000000..430e981c
--- /dev/null
+++ b/manual/Non-standard macros and special forms
@@ -0,0 +1,503 @@
+[[tags: manual]]
+
+[[toc:]]
+
+== Non-standard macros and special forms
+
+=== Making extra libraries and extensions available
+
+==== require-library
+
+ [syntax] (require-library ID ...)
+
+This form does all the necessary steps to make the libraries or extensions given
+in {{ID ...}} available. It loads syntactic extensions, if needed and generates
+code for loading/linking with core library modules or separately installed
+extensions.
+
+During interpretation/evaluation {{require-library}} performs one of the
+following:
+
+* If {{ID}} names a built-in feature {{chicken srfi-0 srfi-2 srfi-6 srfi-8 srfi-9 srfi-10 srfi-17 srfi-23 srfi-30 srfi-39 srfi-55}}, then nothing is done.
+* If {{ID}} names one of the syntactic extensions {{chicken-syntax chicken-ffi-syntax}}, then this extension will be loaded.
+* If {{ID}} names one of the core library units shipped with CHICKEN, then a {{(load-library 'ID)}} will be performed.
+* If {{ID}} names an installed extension with the {{syntax}} or {{require-at-runtime}} attribute, then the extensions is loaded at compile-time, probably doing a run-time {{(require ...)}} for any run-time requirements.
+* Otherwise, {{(require-library ID)}} is equivalent to {{(require 'ID)}}.
+
+During compilation, one of the following happens instead:
+
+* If {{ID}} names a built-in feature {{chicken srfi-0 srfi-2 srfi-6 srfi-8 srfi-9 srfi-10 srfi-17 srfi-23 srfi-30 srfi-39 srfi-55}}, then nothing is done.
+* If {{ID}} names one of the syntactic extensions {{chicken-syntax chicken-ffi-syntax}}, then this extension will be loaded at compile-time, making the syntactic extensions available in compiled code.
+* If {{ID}} names one of the core library units shipped with CHICKEN, or if the option {{-uses ID}} has been passed to the compiler, then a {{(declare (uses ID))}} is generated.
+* If {{ID}} names an installed extension with the {{syntax}} or {{require-at-runtime}} attribute, then the extension is loaded at compile-time, and code is emitted to {{(require ...)}} any needed run-time requirements.
+* Otherwise {{(require-library ID)}} is equivalent to {{(require 'ID)}}.
+
+To make long matters short - just use {{require-library}} and it will normally figure everything out for dynamically
+loadable extensions and core library units.
+
+{{ID}} should be a pure extension name and should not contain any path prefixes (for example {{dir/lib...}}) is illegal).
+
+{{ID}} may also be a list that designates an extension-specifier. Currently the following extension specifiers are
+defined:
+
+* {{(srfi NUMBER ...)}} is required for SRFI-55 compatibility and is fully implemented
+* {{(version ID NUMBER)}} is equivalent to {{ID}}, but checks at compile-time whether the extension named {{ID}} is installed and whether its version is equal or higher than {{NUMBER}}. {{NUMBER}} may be a string or a number, the comparison is done lexicographically (using {{string>=?}}).
+
+See also: {{set-extension-specifier!}}
+
+==== require-extension
+
+ [syntax] (require-extension ID ...)
+
+This is equivalent to {{(require-library ID ...)}} but performs an implicit
+{{import}}.
+This implementation of {{require-extension}} is compliant with [[http://srfi.schemers.org/srfi-55/srfi-55.html|SRFI-55]]
+(see the [[http://srfi.schemers.org/srfi-55/srfi-55.html|SRFI-55]] document for more information).
+
+==== use
+
+ [syntax] (use ID ...)
+
+{{use}} is just a shorter alias for {{require-extension}}.
+
+
+=== Binding forms for optional arguments
+
+==== optional
+
+ [syntax] (optional ARGS DEFAULT)
+
+Use this form for procedures that take a single optional argument. If
+{{ARGS}} is the empty list {{DEFAULT}} is evaluated and
+returned, otherwise the first element of the list {{ARGS}}. It is
+an error if {{ARGS}} contains more than one value.
+
+<enscript highlight=scheme>
+(define (incr x . i) (+ x (optional i 1)))
+(incr 10) ==> 11
+(incr 12 5) ==> 17
+</enscript>
+==== case-lambda
+
+ [syntax] (case-lambda (LAMBDA-LIST1 EXP1 ...) ...)
+
+Expands into a lambda that invokes the body following the first
+matching lambda-list.
+
+<enscript highlight=scheme>
+(define plus
+ (case-lambda
+ (() 0)
+ ((x) x)
+ ((x y) (+ x y))
+ ((x y z) (+ (+ x y) z))
+ (args (apply + args))))
+
+(plus) ==> 0
+(plus 1) ==> 1
+(plus 1 2 3) ==> 6
+</enscript>
+
+For more information see the documentation for
+[[http://srfi.schemers.org/srfi-16/srfi-16.html|SRFI-16]]
+
+==== let-optionals
+
+ [syntax] (let-optionals ARGS ((VAR1 DEFAULT1) ...) BODY ...)
+
+Binding constructs for optional procedure arguments. {{ARGS}} should
+be a rest-parameter taken from a lambda-list. {{let-optionals}}
+binds {{VAR1 ...}} to available arguments in parallel, or
+to {{DEFAULT1 ...}} if not enough arguments were provided.
+{{let-optionals*}} binds {{VAR1 ...}} sequentially, so every
+variable sees the previous ones. it is an error if any excess
+arguments are provided.
+
+<enscript highlight=scheme>
+(let-optionals '(one two) ((a 1) (b 2) (c 3))
+ (list a b c) ) ==> (one two 3)
+</enscript>
+
+==== let-optionals*
+
+ [syntax] (let-optionals* ARGS ((VAR1 DEFAULT1) ... [RESTVAR]) BODY ...)
+
+Binding constructs for optional procedure arguments. {{ARGS}} should
+be a rest-parameter taken from a lambda-list. {{let-optionals}}
+binds {{VAR1 ...}} to available arguments in parallel, or
+to {{DEFAULT1 ...}} if not enough arguments were provided.
+{{let-optionals*}} binds {{VAR1 ...}} sequentially, so every
+variable sees the previous ones. If a single variable {{RESTVAR}}
+is given, then it is bound to any remaining arguments, otherwise it is
+an error if any excess arguments are provided.
+
+<enscript highlight=scheme>
+(let-optionals* '(one two) ((a 1) (b 2) (c a))
+ (list a b c) ) ==> (one two one)
+</enscript>
+
+
+=== Other binding forms
+
+==== and-let*
+
+ [syntax] (and-let* (BINDING ...) EXP1 EXP2 ...)
+
+SRFI-2. Bind sequentially and execute body. {{BINDING}} can
+be a list of a variable and an expression, a list with a single
+expression, or a single variable. If the value of an expression
+bound to a variable is {{#f}}, the {{and-let*}} form
+evaluates to {{#f}} (and the subsequent bindings and the body
+are not executed). Otherwise the next binding is performed. If
+all bindings/expressions evaluate to a true result, the body is
+executed normally and the result of the last expression is the
+result of the {{and-let*}} form. See also the documentation for
+[[http://srfi.schemers.org/srfi-2/srfi-2.html|SRFI-2]].
+
+==== rec
+
+ [syntax] (rec NAME EXPRESSION)
+ [syntax] (rec (NAME VARIABLE ...) BODY ...)
+
+Allows simple definition of recursive definitions. {{(rec NAME EXPRESSION)}} is
+equivalent to {{(letrec ((NAME EXPRESSION)) NAME)}} and {{(rec (NAME VARIABLE ...) BODY ...)}}
+is the same as {{(letrec ((NAME (lambda (VARIABLE ...) BODY ...))) NAME)}}.
+
+==== cut
+
+ [syntax] (cut SLOT ...)
+ [syntax] (cute SLOT ...)
+
+[[http://srfi.schemers.org/srfi-26/srfi-26.html|Syntactic sugar for specializing parameters]].
+
+==== define-values
+
+ [syntax] (define-values (NAME ...) EXP)
+
+Defines several variables at once, with the result values of expression
+{{EXP}}.
+
+==== fluid-let
+
+ [syntax] (fluid-let ((VAR1 X1) ...) BODY ...)
+
+Binds the variables {{VAR1 ...}} dynamically to the values {{X1 ...}}
+during execution of {{BODY ...}}.
+
+==== let-values
+
+ [syntax] (let-values (((NAME ...) EXP) ...) BODY ...)
+
+SRFI 11. Binds multiple variables to the result values of {{EXP ...}}.
+All variables are bound simultaneously.
+
+==== let*-values
+
+ [syntax] (let*-values (((NAME ...) EXP) ...) BODY ...)
+
+SRFI 11. Binds multiple variables to the result values of {{EXP ...}}.
+The variables are bound sequentially.
+
+<enscript highlight=scheme>
+(let*-values (((a b) (values 2 3))
+ ((p) (+ a b)) )
+ p) ==> 5
+</enscript>
+
+==== letrec-values
+
+ [syntax] (letrec-values (((NAME ...) EXP) ...) BODY ...)
+
+Binds the result values of {{EXP ...}} to multiple variables at once.
+All variables are mutually recursive.
+
+<enscript highlight=scheme>
+(letrec-values (((odd even)
+ (values
+ (lambda (n) (if (zero? n) #f (even (sub1 n))))
+ (lambda (n) (if (zero? n) #t (odd (sub1 n)))) ) ) )
+ (odd 17) ) ==> #t
+</enscript>
+
+==== parameterize
+
+ [syntax] (parameterize ((PARAMETER1 X1) ...) BODY ...)
+
+Binds the parameters {{PARAMETER1 ...}} dynamically to the values
+{{X1 ...}} during execution of {{BODY ...}}. (see also:
+{{make-parameter}} in [[Parameters]]). Note that {{PARAMETER}} may be any
+expression that evaluates to a parameter procedure.
+
+==== receive
+
+ [syntax] (receive (NAME1 ... [. NAMEn]) VALUEEXP BODY ...)
+ [syntax] (receive VALUEEXP)
+
+SRFI-8. Syntactic sugar for {{call-with-values}}. Binds variables
+to the result values of {{VALUEEXP}} and evaluates {{BODY ...}}.
+
+The syntax
+
+<enscript highlight=scheme>
+(receive VALUEEXP)
+</enscript>
+
+is equivalent to
+
+<enscript highlight=scheme>
+(receive _ VALUEEXP _)
+</enscript>
+
+==== set!-values
+
+ [syntax] (set!-values (NAME ...) EXP)
+
+Assigns the result values of expression {{EXP}} to multiple
+variables.
+
+
+=== Substitution forms and macros
+
+==== define-constant
+
+ [syntax] (define-constant NAME CONST)
+
+Define a variable with a constant value, evaluated at compile-time.
+Any reference to such a
+constant should appear textually '''after''' its definition. This
+construct is equivalent to {{define}} when evaluated or interpreted.
+Constant definitions should only appear at toplevel. Note that constants
+are local to the current compilation unit and are not available outside
+of the source file in which they are defined. Names of constants still
+exist in the Scheme namespace and can be lexically shadowed. If the
+value is mutable, then the compiler is careful to preserve its identity.
+{{CONST}} may be any constant expression, and may also refer to
+constants defined via {{define-constant}} previously.
+This for should only be used at top-level.
+
+==== define-inline
+
+ [syntax] (define-inline (NAME VAR ... [. VAR]) BODY ...)
+ [syntax] (define-inline NAME EXP)
+
+Defines an inline procedure. Any occurrence of {{NAME}} will be
+replaced by {{EXP}} or {{(lambda (VAR ... [. VAR]) BODY ...)}}.
+This is similar to a macro, but variable-names and -scope will
+be correctly handled. Inline substitutions take place '''after'''
+macro-expansion. {{EXP}} should be a lambda-expression. Any
+reference to {{NAME}} should appear textually '''after'''
+its definition. Note that inline procedures are local to the current
+compilation unit and are not available outside of the source file in
+which they are defined. Names of inline procedures still exist in the
+Scheme namespace and can be lexically shadowed. This construct is
+equivalent to {{define}} when evaluated or interpreted. Inline
+definitions should only appear at toplevel.
+
+==== define-for-syntax
+
+ [syntax] (define-for-syntax (NAME VAR ... [. VAR]) EXP1 ...)
+ [syntax] (define-for-syntax NAME [VALUE])
+
+Defines the toplevel variable {{NAME}} at macro-expansion time. This can
+be helpful when you want to define support procedures for use in macro-transformers,
+for example.
+
+
+=== Conditional forms
+
+==== select
+
+ [syntax] (select EXP ((KEY ...) EXP1 ...) ... [(else EXPn ...)])
+
+This is similar to {{case}}, but the keys are evaluated.
+
+==== unless
+
+ [syntax] (unless TEST EXP1 EXP2 ...)
+
+Equivalent to:
+
+<enscript highlight=scheme>
+(if (not TEST) (begin EXP1 EXP2 ...))
+</enscript>
+
+==== when
+
+ [syntax] (when TEST EXP1 EXP2 ...)
+
+Equivalent to:
+
+<enscript highlight=scheme>
+(if TEST (begin EXP1 EXP2 ...))
+</enscript>
+
+
+=== Record structures
+
+==== define-record
+
+ [syntax] (define-record NAME SLOTNAME ...)
+
+Defines a record type. Call {{make-NAME}} to create an instance
+of the structure (with one initialization-argument for each slot).
+{{(NAME? STRUCT)}} tests any object for being an instance of this
+structure. Slots are accessed via {{(NAME-SLOTNAME STRUCT)}}
+and updated using {{(NAME-SLOTNAME-set!}} {{STRUCT}} {{VALUE)}}.
+
+<enscript highlight=scheme>
+(define-record point x y)
+(define p1 (make-point 123 456))
+(point? p1) ==> #t
+(point-x p1) ==> 123
+(point-y-set! p1 99)
+(point-y p1) ==> 99
+</enscript>
+
+==== define-record-type
+
+ [syntax] (define-record-type NAME
+ (CONSTRUCTOR TAG ...)
+ PREDICATE
+ (FIELD ACCESSOR [MODIFIER]) ...)
+
+SRFI-9 record types. For more information see the documentation for
+[[http://srfi.schemers.org/srfi-9/srfi-9.html|SRFI-9]].
+
+
+==== define-record-printer
+
+ [syntax] (define-record-printer (NAME RECORDVAR PORTVAR) BODY ...)
+ [syntax] (define-record-printer NAME PROCEDURE)
+
+Defines a printing method for record of the type {{NAME}} by
+associating a procedure with the record type. When a record of this
+type is written using {{display, write}} or {{print}}, then
+the procedure is called with two arguments: the record to be printed
+and an output-port.
+
+<enscript highlight=scheme>
+(define-record-type foo (make-foo x y z) foo?
+ (x foo-x)
+ (y foo-y)
+ (z foo-z))
+(define f (make-foo 1 2 3))
+(define-record-printer (foo x out)
+ (fprintf out "#,(foo ~S ~S ~S)"
+ (foo-x x) (foo-y x) (foo-z x)) )
+(define-reader-ctor 'foo make-foo)
+(define s (with-output-to-string
+ (lambda () (write f))))
+s ==> "#,(foo 1 2 3)"
+(equal? f (with-input-from-string
+ s read))) ==> #t
+</enscript>
+
+=== Other forms
+
+==== assert
+
+ [syntax] (assert EXP [STRING ARG ...])
+
+Signals an error if {{EXP}} evaluates to false. An optional message
+{{STRING}} and arguments {{ARG ...}} may be supplied to give a
+more informative error-message. If compiled in ''unsafe'' mode (either
+by specifying the {{-unsafe}} compiler option or by declaring
+{{(unsafe)}}), then this expression expands to an unspecified value.
+The result is the value of {{EXP}}.
+
+
+==== begin-for-syntax
+
+ [syntax] (begin-for-syntax EXP ...)
+
+Equivalent to {{(begin EXP ...)}}, but performs the evaluation of
+the expression during macro-expansion time.
+
+
+==== cond-expand
+
+ [syntax] (cond-expand FEATURE-CLAUSE ...)
+
+Expands by selecting feature clauses. This form is allowed to appear in non-toplevel expressions.
+
+Predefined feature-identifiers are "situation" specific:
+
+; compile : {{eval}}, {{library}}, {{match}}, {{compiling}}, {{srfi-11}}, {{srfi-15}}, {{srfi-31}}, {{srfi-26}}, {{srfi-16}}, {{utils}}, {{regex}}, {{srfi-4}}, {{match}}, {{srfi-1}}, {{srfi-69}}, {{srfi-28}}, {{extras}}, {{srfi-8}}, {{srfi-6}}, {{srfi-2}}, {{srfi-0}}, {{srfi-10}}, {{srfi-9}}, {{srfi-55}}, {{srfi-61}} {{chicken}}, {{srfi-23}}, {{srfi-30}}, {{srfi-39}}, {{srfi-62}}, {{srfi-17}}, {{srfi-12}}.
+
+; load : {{srfi-69}}, {{srfi-28}}, {{extras}}, {{srfi-8}}, {{srfi-6}}, {{srfi-2}}, {{srfi-0}}, {{srfi-10}}, {{srfi-9}}, {{srfi-55}}, {{srfi-61}}, {{chicken}}, {{srfi-23}}, {{srfi-30}}, {{srfi-39}}, {{srfi-62}}, {{srfi-17}}, {{srfi-12}}. {{library}} is implicit.
+
+; eval : {{match}}, {{csi}}, {{srfi-11}}, {{srfi-15}}, {{srfi-31}}, {{srfi-26}}, {{srfi-16}}, {{srfi-69}}, {{srfi-28}}, {{extras}}, {{srfi-8}}, {{srfi-6}}, {{srfi-2}}, {{srfi-0}}, {{srfi-10}}, {{srfi-9}}, {{srfi-55}}, {{srfi-61}}, {{chicken}}, {{srfi-23}}, {{srfi-30}}, {{srfi-39}}, {{srfi-62}}, {{srfi-17}}, {{srfi-12}}. {{library}} is implicit.
+
+The following feature-identifiers are available in all situations: {{(machine-byte-order)}}, {{(machine-type)}}, {{(software-type)}}, {{(software-version)}}, where the actual feature-identifier is platform dependent.
+
+In addition the following feature-identifiers may exist: {{applyhook}}, {{extraslot}}, {{ptables}}, {{dload}}.
+
+For further information, see the documentation for [[http://srfi.schemers.org/srfi-0/srfi-0.html|SRFI-0]].
+
+==== ensure
+
+ [syntax] (ensure PREDICATE EXP [ARGUMENTS ...])
+
+Evaluates the expression {{EXP}} and applies the one-argument
+procedure {{PREDICATE}} to the result. If the predicate returns
+{{#f}} an error is signaled, otherwise the result of {{EXP}}
+is returned. If compiled in ''unsafe'' mode (either by specifying
+the {{-unsafe}} compiler option or by declaring {{(unsafe)}}),
+then this expression expands to an unspecified value. If specified,
+the optional {{ARGUMENTS}} are used as arguments to the invocation
+of the error-signalling code, as in {{(error ARGUMENTS ...)}}. If
+no {{ARGUMENTS}} are given, a generic error message is displayed
+with the offending value and {{PREDICATE}} expression.
+
+==== eval-when
+
+ [syntax] (eval-when (SITUATION ...) EXP ...)
+
+Controls evaluation/compilation of subforms. {{SITUATION}} should
+be one of the symbols {{eval}}, {{compile}} or {{load}}.
+When encountered in the evaluator, and the situation specifier
+{{eval}} is not given, then this form is not evaluated and an
+unspecified value is returned. When encountered while compiling code,
+and the situation specifier {{compile}} is given, then this form is
+evaluated at compile-time. When encountered while compiling code, and the
+situation specifier {{load}} is not given, then this form is ignored
+and an expression resulting into an unspecified value is compiled instead.
+
+The following table should make this clearer:
+
+<table>
+<tr><th></th><th>In compiled code</th><th>In interpreted code</th></tr>
+<tr><td>{{eval}}</td><td>ignore</td><td>evaluate</td></tr>
+<tr><td>{{compile}}</td><td>evaluate at compile time</td><td>ignore</td></tr>
+<tr><td>{{load}}</td><td>compile as normal</td><td>ignore</td></tr>
+</table>
+
+==== include
+
+ [syntax] (include STRING)
+
+Include toplevel-expressions from the given source file in the currently
+compiled/interpreted program. If the included file has the extension
+{{.scm}}, then it may be omitted. The file is searched in the
+current directory and, if not found, in all directories specified in the
+{{-include-path}} option.
+
+==== nth-value
+
+ [syntax] (nth-value N EXP)
+
+Returns the {{N}}th value (counting from zero) of the values returned
+by expression {{EXP}}.
+
+==== time
+
+ [syntax] (time EXP1 ...)
+
+Evaluates {{EXP1 ...}} and prints elapsed time and some
+values about GC use, like time spent in major GCs, number of minor
+and major GCs.
+
+---
+Previous: [[Non-standard read syntax]]
+
+Next: [[Modules and macros]]
diff --git a/manual/Non-standard read syntax b/manual/Non-standard read syntax
new file mode 100644
index 00000000..09a5f131
--- /dev/null
+++ b/manual/Non-standard read syntax
@@ -0,0 +1,137 @@
+[[tags: manual]]
+
+[[toc:]]
+
+== Non-standard read syntax
+
+=== Multiline Block Comment
+
+ #| ... |#
+
+A multiline ''block'' comment. May be nested. Implements [[http://srfi.schemers.org/srfi-30/srfi-30.html|SRFI-30]]
+
+=== Expression Comment
+
+ #;EXPRESSION
+
+Treats {{EXPRESSION}} as a comment. That is, the comment runs through the whole S-expression, regardless of newlines, which saves you from having to comment out every line, or add a newline in the middle of your parens to make the commenting of the last line work, or other things like that.
+=== External Representation
+
+ #,(CONSTRUCTORNAME DATUM ...)
+
+Allows user-defined extension of external representations. (For more information see the documentation for
+[[http://srfi.schemers.org/srfi-10/srfi-10.html|SRFI-10]])
+
+=== Syntax Expression
+
+ #'EXPRESSION
+
+An abbreviation for {{(syntax EXPRESSION)}}.
+
+=== Location Expression
+
+ #$EXPRESSION
+
+An abbreviation for {{(location EXPRESSION)}}.
+
+=== Keyword
+
+ #:SYMBOL
+ SYMBOL:
+ :SYMBOL
+
+Syntax for keywords. Keywords are symbols that evaluate to themselves, and as such don't have to be quoted. Either {{SYMBOL:}} or {{:SYMBOL}} is accepted, depending on the setting of the {{keyword-style}} parameter, but never both. {{#:SYMBOL}} is always accepted.
+
+=== Multiline String Constant
+
+ #<<TAG
+
+Specifies a multiline string constant. Anything up to a line equal to {{TAG}} (or end of file) will be returned as a single string:
+
+ (define msg #<<END
+ "Hello, world!", she said.
+ END
+ )
+
+is equivalent to
+
+ (define msg "\"Hello, world!\", she said.")
+
+=== Multiline String Constant with Embedded Expressions
+
+ #<#TAG
+
+Similar to {{#<<}}, but allows substitution of embedded Scheme expressions prefixed with {{#}} and optionally enclosed in curly brackets. Two consecutive {{#}}s are translated to a single {{#}}:
+
+ (define three 3)
+ (display #<#EOF
+ This is a simple string with an embedded `##' character
+ and substituted expressions: (+ three 99) ==> #(+ three 99)
+ (three is "#{three}")
+ EOF
+ )
+
+prints
+
+ This is a simple string with an embedded `#' character
+ and substituted expressions: (+ three 99) ==> 102
+ (three is "3")
+
+=== Foreign Declare
+
+ #> ... <#
+
+Abbreviation for {{foreign-declare " ... ")}}.
+
+=== Sharp Prefixed Symbol
+
+ #%...
+
+Reads like a normal symbol.
+
+=== Bang
+
+ #!...
+
+Interpretation depends on the directly following characters. Only the following are recognized. Any other case results in a read error.
+
+==== Line Comment
+
+* If followed by whitespace or a slash, then everything up the end of the current line is ignored
+
+==== Eof Object
+
+* If followed by the character sequence {{eof}}, then the (self-evaluating) end-of-file object is returned
+
+==== DSSSL Formal Parameter List Annotation
+
+* If followed by any of the character sequences {{optional}}, {{rest}} or {{key}}, then a symbol with the same name (and prefixed with {{#!}}) is returned
+
+==== Read Mark Invocation
+
+* If a ''read mark'' with the same name as the token is registered, then its procedure is called and the result of the read-mark procedure will be returned
+
+=== Case Sensitive Expression
+
+ #cs...
+
+Read the next expression in case-sensitive mode (regardless of the current global setting).
+
+=== Case Insensitive Expression
+
+ #ci...
+
+Read the next expression in case-insensitive mode (regardless of the current global setting).
+
+=== Conditional Expansion
+
+ #+FEATURE EXPR
+
+Equivalent to
+
+ (cond-expand (FEATURE EXPR) (else))
+
+---
+Previous: [[Extensions to the standard]]
+
+Next: [[Non-standard macros and special forms]]
diff --git a/manual/Other support procedures b/manual/Other support procedures
new file mode 100644
index 00000000..23d915b6
--- /dev/null
+++ b/manual/Other support procedures
@@ -0,0 +1,16 @@
+[[tags: manual]]
+[[toc:]]
+
+== Other support procedures
+
+=== argc+argv
+
+ [procedure] (argc+argv)
+
+Returns two values: an integer and a foreign-pointer object representing the {{argc}}
+and {{argv}} arguments passed to the current process.
+
+---
+Previous: [[Locations]]
+
+Next: [[C interface]]
diff --git a/manual/Parameters b/manual/Parameters
new file mode 100644
index 00000000..e6343bc0
--- /dev/null
+++ b/manual/Parameters
@@ -0,0 +1,150 @@
+[[tags: manual]]
+[[toc:]]
+
+== Parameters
+
+Parameters are Chicken's form of dynamic variables, except that they are
+procedures rather than actual variables. A parameter is a procedure of
+zero or one arguments. To retrieve the value of a parameter call the
+parameter-procedure with zero arguments. To change the setting of the
+parameter, call the parameter-procedure with the new value as argument:
+
+<enscript highlight=scheme>
+(define foo (make-parameter 123))
+(foo) ==> 123
+(foo 99)
+(foo) ==> 99
+</enscript>
+
+Parameters are fully thread-local, each thread of execution
+owns a local copy of a parameters' value.
+
+CHICKEN implements [[http://srfi.schemers.org/srfi-39/srfi-39.html|SRFI-39]].
+
+
+
+=== make-parameter
+
+ [procedure] (make-parameter VALUE [GUARD])
+
+Returns a procedure that accepts zero or one argument. Invoking the
+procedure with zero arguments returns {{VALUE}}. Invoking the
+procedure with one argument changes its value to the value of that
+argument (subsequent invocations with zero parameters return the new
+value). {{GUARD}} should be a procedure of a single argument. Any
+new values of the parameter (even the initial value) are passed to this
+procedure. The guard procedure should check the value and/or convert it
+to an appropriate form.
+
+== Built-in parameters
+
+Certain behavior of the interpreter and compiled programs can be
+customized via the following built-in parameters:
+
+=== case-sensitive
+If true, then {{read}} reads symbols and identifiers in
+case-sensitive mode and uppercase characters in symbols are printed
+escaped. Defaults to {{#t}}.
+
+
+=== dynamic-load-libraries
+A list of strings containing shared libraries that should be checked
+for explicitly loaded library units (this facility is not available on
+all platforms). See {{load-library}}.
+
+
+=== command-line-arguments
+Contains the list of arguments passed to this program, with the name of
+the program and any runtime options (all options starting with {{-:}})
+removed.
+
+
+=== current-read-table
+A read-table object that holds read-procedures for special non-standard
+read-syntax (see {{set-read-syntax!}} for more information).
+
+
+=== exit-handler
+A procedure of a single optional argument. When {{exit}} is called,
+then this procedure will be invoked with the exit-code as argument. The
+default behavior is to terminate the program.
+
+
+=== eval-handler
+A procedure of one or two arguments. When {{eval}} is invoked, it
+calls the value of this parameter with the same arguments. The default
+behavior is to evaluate the argument expression and to ignore the
+second parameter.
+
+
+=== force-finalizers
+If true, force and execute all pending finalizers before exiting the
+program (either explicitly by {{exit}} or implicitly when the last
+toplevel expression has been executed). Default is {{#t}}.
+
+
+=== implicit-exit-handler
+A procedure of no arguments. When the last toplevel expression of the
+program has executed, then the value of this parameter is called. The
+default behaviour is to invoke all pending finalizers.
+
+
+=== keyword-style
+Enables alternative keyword syntax, where {{STYLE}} may be either
+{{#:prefix}} (as in Common Lisp), which recognizes symbols beginning
+with a colon as keywords, or {{#:suffix}} (as in DSSSL), which recognizes
+symbols ending with a colon as keywords.
+Any other value disables the alternative syntaxes. In the interpreter
+the default is {{#:suffix}}.
+
+
+=== parenthesis-synonyms
+If true, then the list delimiter synonyms {{#\[}} {{#\]}} and {{#\{}} {{#\}}} are enabled. Defaults to {{#t}}.
+
+
+=== symbol-escape
+If true, then the symbol escape {{#\|}} {{#\|}} is enabled. Defaults to {{#t}}.
+
+
+=== load-verbose
+A boolean indicating whether loading of source files, compiled code
+(if available) and compiled libraries should display a message.
+
+
+=== program-name
+The name of the currently executing program. This is equivalent to
+{{(car (argv))}} for compiled programs or the filename following the
+{{-script}} option in interpreted scripts.
+
+
+=== repl-prompt
+A procedure that should evaluate to a string that will be printed before reading
+interactive input from the user in a read-eval-print loop. Defaults to
+{{(lambda () "#;N> ")}}.
+
+
+=== reset-handler
+A procedure of zero arguments that is called via {{reset}}. The
+default behavior in compiled code is to invoke the value of
+{{(exit-handler)}}. The default behavior in the interpreter is to
+abort the current computation and to restart the read-eval-print loop.
+
+
+=== dynamic-load-mode
+On systems that support dynamic loading of compiled code via the {{dlopen(3)}}
+interface (for example Linux and Solaris), some options can be specified to
+fine-tune the behaviour of the dynamic linker. {{MODE}} should be a list of
+symbols (or a single symbol) taken from the following set:
+
+; {{local}} : If {{local}} is given, then any C/C++ symbols defined in the dynamically loaded file are not available for subsequently loaded files and libraries. Use this if you have linked foreign code into your dynamically loadable file and if you don't want to export them (for example because you want to load another file that defines the same symbols).
+; {{global}} : The default is {{global}}, which means all C/C++ symbols are available to code loaded at a later stage.
+; {{now}} : If {{now}} is specified, all symbols are resolved immediately.
+; {{lazy}} : Unresolved symbols are resolved as code from the file is executed. This is the default.
+
+Note that this procedure does not control the way Scheme variables are handled -
+this facility is mainly of interest when accessing foreign code.
+
+---
+Previous: [[Declarations]]
+
+Next: [[Unit library]]
diff --git a/manual/Supported language b/manual/Supported language
new file mode 100644
index 00000000..8f546a16
--- /dev/null
+++ b/manual/Supported language
@@ -0,0 +1,34 @@
+[[tags: manual]]
+
+== Supported language
+
+* [[Deviations from the standard]]
+* [[Extensions to the standard]]
+* [[Non-standard read syntax]]
+* [[Non-standard macros and special forms]]
+* [[Modules and macros]]
+* [[Declarations]]
+* [[Parameters]]
+* [[Unit library]] Basic Scheme definitions
+* [[Unit eval]] Evaluation
+* [[Unit expand]] Modules and macros handling
+* [[Unit data-structures]] Data structures
+* [[Unit ports]] I/O ports
+* [[Unit files]] File and pathname operations
+* [[Unit extras]] Useful utility definitions
+* [[Unit regex]] Regular expressions
+* [[Unit srfi-1]] List Library
+* [[Unit srfi-4]] Homogeneous numeric vectors
+* [[Unit srfi-13]] String library
+* [[Unit srfi-14]] Character set library
+* [[Unit srfi-18]] multithreading
+* [[Unit srfi-69]] Hashtable Library
+* [[Unit posix]] Unix-like services
+* [[Unit utils]] Shell scripting and file operations
+* [[Unit tcp]] Basic TCP-sockets
+* [[Unit lolevel]] Low-level operations
+
+---
+Previous: [[Using the interpreter]]
+
+Next: [[Interface to external functions and variables]]
diff --git a/manual/The User's Manual b/manual/The User's Manual
new file mode 100644
index 00000000..6d5aba8b
--- /dev/null
+++ b/manual/The User's Manual
@@ -0,0 +1,34 @@
+[[tags:manual]]
+
+== The CHICKEN User's Manual
+
+<nowiki>
+<img style="float:right; border-left:1px solid #ccc;border-bottom:1px solid #ccc;margin-left:1em;" src="http://www.call-with-current-continuation.org/chicken4.png" alt="Stylized picture of a chicken"/>
+</nowiki>
+
+This is the manual for Chicken Scheme, version 4.2.2
+
+; [[Getting started]] : What is CHICKEN and how do I use it?
+
+; [[Basic mode of operation]] : Compiling Scheme files.
+
+; [[Using the compiler]] : Explains how to use CHICKEN to compile programs and execute them.
+
+; [[Using the interpreter]] : Invocation and usage of {{csi}}, the CHICKEN interpreter
+
+; [[Supported language]] : The language implemented by CHICKEN (deviations from the standard and extensions).
+
+; [[Interface to external functions and variables]] : Accessing C and C++ code and data.
+
+; [[Extensions]] : Packaging and installing extension libraries.
+
+; [[Data representation]] : How Scheme data is internally represented.
+
+; [[Bugs and limitations]] : Things that do not work yet.
+
+; [[FAQ]] : A list of Frequently Asked Questions about CHICKEN (and their answers).
+
+; [[Acknowledgements]] : A list of some of the people that have contributed to make CHICKEN what it is.
+
+; [[Bibliography]] : Links to documents that may be of interest.
+
diff --git a/manual/Unit data-structures b/manual/Unit data-structures
new file mode 100644
index 00000000..dd50f236
--- /dev/null
+++ b/manual/Unit data-structures
@@ -0,0 +1,648 @@
+[[tags: manual]]
+[[toc:]]
+
+== Unit data-structures
+
+This unit contains a collection of procedures related to data
+structures.
+
+
+=== Lists
+
+
+==== alist-ref
+
+ [procedure] (alist-ref KEY ALIST [TEST [DEFAULT]])
+
+Looks up {{KEY}} in {{ALIST}} using {{TEST}} as the comparison function (or {{eqv?}} if
+no test was given) and returns the cdr of the found pair, or {{DEFAULT}} (which defaults to {{#f}}).
+
+
+==== alist-update!
+
+ [procedure] (alist-update! KEY VALUE ALIST [TEST])
+
+If the list {{ALIST}} contains a pair of the form {{(KEY . X)}}, then this procedure
+replaces {{X}} with {{VALUE}} and returns {{ALIST}}. If {{ALIST}} contains no such item, then
+{{alist-update!}} returns {{((KEY . VALUE) . ALIST)}}. The optional argument
+{{TEST}} specifies the comparison procedure to search a matching pair in {{ALIST}}
+and defaults to {{eqv?}}.
+
+
+==== atom?
+
+ [procedure] (atom? X)
+
+Returns {{#t}} if {{X}} is not a pair. This is identical to {{not-pair?}} from [[Unit srfi-1]] but
+kept for historical reasons.
+
+
+==== rassoc
+
+ [procedure] (rassoc KEY LIST [TEST])
+
+Similar to {{assoc}}, but compares {{KEY}} with the {{cdr}} of each pair in {{LIST}} using
+{{TEST}} as the comparison procedures (which defaults to {{eqv?}}.
+
+
+==== butlast
+
+ [procedure] (butlast LIST)
+
+Returns a fresh list with all elements but the last of {{LIST}}.
+
+
+==== chop
+
+ [procedure] (chop LIST N)
+
+Returns a new list of sublists, where each sublist contains {{N}}
+elements of {{LIST}}. If {{LIST}} has a length that is not
+a multiple of {{N}}, then the last sublist contains the remaining
+elements.
+
+<enscript highlight=scheme>
+(chop '(1 2 3 4 5 6) 2) ==> ((1 2) (3 4) (5 6))
+(chop '(a b c d) 3) ==> ((a b c) (d))
+</enscript>
+
+
+==== compress
+
+ [procedure] (compress BLIST LIST)
+
+Returns a new list with elements taken from {{LIST}} with
+corresponding true values in the list {{BLIST}}.
+
+<enscript highlight=scheme>
+(define nums '(99 100 110 401 1234))
+(compress (map odd? nums) nums) ==> (99 401)
+</enscript>
+
+
+==== flatten
+
+ [procedure] (flatten LIST1 ...)
+
+Returns {{LIST1 ...}} concatenated together, with nested lists
+removed (flattened).
+
+
+==== intersperse
+
+ [procedure] (intersperse LIST X)
+
+Returns a new list with {{X}} placed between each element.
+
+
+==== join
+
+ [procedure] (join LISTOFLISTS [LIST])
+
+Concatenates the lists in {{LISTOFLISTS}} with {{LIST}} placed
+between each sublist. {{LIST}} defaults to the empty list.
+
+<enscript highlight=scheme>
+(join '((a b) (c d) (e)) '(x y)) ==> (a b x y c d x y e)
+(join '((p q) () (r (s) t)) '(-)) ==> (p q - - r (s) t)
+</enscript>
+
+{{join}} could be implemented as follows:
+
+<enscript highlight=scheme>
+(define (join lstoflsts #!optional (lst '()))
+ (apply append (intersperse lstoflists lst)) )
+</enscript>
+
+
+==== shuffle
+
+ [procedure] (shuffle LIST RANDOM)
+
+Returns {{LIST}} with its elements sorted in a random order given by
+procedure {{RANDOM}}.
+
+
+==== tail?
+
+ [procedure] (tail? X LIST)
+
+Returns true if {{X}} is one of the tails (cdr's) of {{LIST}}.
+
+=== Queues
+
+
+==== list->queue
+
+ [procedure] (list->queue LIST)
+
+Returns {{LIST}} converted into a queue, where the first element
+of the list is the same as the first element of the queue. The resulting
+queue may share memory with the list and the list should not be modified
+after this operation.
+
+
+==== make-queue
+
+ [procedure] (make-queue)
+
+Returns a newly created queue.
+
+
+==== queue?
+
+ [procedure] (queue? X)
+
+Returns {{#t}} if {{X}} is a queue, or {{#f}} otherwise.
+
+
+==== queue->list
+
+ [procedure] (queue->list QUEUE)
+
+Returns {{QUEUE}} converted into a list, where the first element
+of the list is the same as the first element of the queue. The resulting
+list may share memory with the queue object and should not be modified.
+
+
+==== queue-add!
+
+ [procedure] (queue-add! QUEUE X)
+
+Adds {{X}} to the rear of {{QUEUE}}.
+
+
+==== queue-empty?
+
+ [procedure] (queue-empty? QUEUE)
+
+Returns {{#t}} if {{QUEUE}} is empty, or {{#f}} otherwise.
+
+
+==== queue-first
+
+ [procedure] (queue-first QUEUE)
+
+Returns the first element of {{QUEUE}}. If {{QUEUE}} is empty
+an error is signaled
+
+
+==== queue-last
+
+ [procedure] (queue-last QUEUE)
+
+Returns the last element of {{QUEUE}}. If {{QUEUE}} is empty
+an error is signaled
+
+
+==== queue-remove!
+
+ [procedure] (queue-remove! QUEUE)
+
+Removes and returns the first element of {{QUEUE}}. If {{QUEUE}}
+is empty an error is signaled
+
+
+==== queue-push-back!
+
+ [procedure] (queue-push-back! QUEUE ITEM)
+
+Pushes an item into the first position of a queue, i.e. the next
+{{queue-remove!}} will return {{ITEM}}.
+
+
+==== queue-push-back-list!
+
+ [procedure] (queue-push-back-list! QUEUE LIST)
+
+Pushes the items in item-list back onto the queue,
+so that {{(car LIST)}} becomes the next removable item.
+
+
+
+=== Sorting
+
+
+==== merge
+
+ [procedure] (merge LIST1 LIST2 LESS?)
+ [procedure] (merge! LIST1 LIST2 LESS?)
+
+Joins two lists in sorted order. {{merge!}} is the destructive
+version of merge. {{LESS? }} should be a procedure of two arguments,
+that returns true if the first argument is to be ordered before the
+second argument.
+
+
+==== sort
+
+ [procedure] (sort SEQUENCE LESS?)
+ [procedure] (sort! SEQUENCE LESS?)
+
+Sort {{SEQUENCE}}, which should be a list or a vector. {{sort!}}
+is the destructive version of sort.
+
+
+==== sorted?
+
+ [procedure] (sorted? SEQUENCE LESS?)
+
+Returns true if the list or vector {{SEQUENCE}} is already sorted.
+
+
+==== topological-sort
+
+ [procedure] (topological-sort DAG PRED)
+
+Sorts the directed acyclic graph dag {{DAG}} so that for every edge from vertex
+u to v, u will come before v in the resulting list of vertices.
+
+{{DAG}} is a list of sublists. The car of each sublist is a
+vertex. The cdr is the adjacency list of that vertex, i.e. a list of
+all vertices to which there exists an edge from the car vertex.
+{{pred}} is procedure of two arguments that should compare vertices
+for equality.
+
+Time complexity: O (|V| + |E|)
+
+<enscript highlight=scheme>
+(require 'tsort)
+(topological-sort
+ '((shirt tie belt)
+ (tie jacket)
+ (belt jacket)
+ (watch)
+ (pants shoes belt)
+ (undershorts pants shoes)
+ (socks shoes))
+ eq?)
+
+=>
+
+(socks undershorts pants shoes watch shirt belt tie jacket)
+</enscript>
+
+
+=== Strings
+
+
+==== conc
+
+ [procedure] (conc X ...)
+
+Returns a string with the string-represenation of all arguments concatenated
+together. {{conc}} could be implemented as
+
+<enscript highlight=scheme>
+(define (conc . args)
+ (apply string-append (map ->string args)) )
+</enscript>
+
+
+
+==== ->string
+
+ [procedure] (->string X)
+
+Returns a string-representation of {{X}}.
+
+
+==== string-chop
+
+ [procedure] (string-chop STRING LENGTH)
+
+Returns a list of substrings taken by ''chopping'' {{STRING}} every {{LENGTH}}
+characters:
+
+<enscript highlight=scheme>
+(string-chop "one two three" 4) ==> ("one " "two " "thre" "e")
+</enscript>
+
+
+
+==== string-chomp
+
+ [procedure] (string-chomp STRING [SUFFIX])
+
+If {{STRING}} ends with {{SUFFIX}}, then this procedure returns a copy of its first argument with the suffix
+removed, otherwise returns {{STRING}} unchanged. {{SUFFIX}} defaults to {{"\n"}}.
+
+
+==== string-compare3
+
+ [procedure] (string-compare3 STRING1 STRING2)
+ [procedure] (string-compare3-ci STRING1 STRING2)
+
+Perform a three-way comparison between the {{STRING1}} and {{STRING2}},
+returning either {{-1}} if {{STRING1}} is lexicographically less
+than {{STRING2}}, {{0}} if it is equal, or {{1}} if it s greater.
+{{string-compare3-ci}} performs a case-insensitive comparison.
+
+
+==== string-intersperse
+
+ [procedure] (string-intersperse LIST [STRING])
+
+Returns a string that contains all strings in {{LIST}} concatenated
+together. {{STRING}} is placed between each concatenated string and
+defaults to {{" "}}.
+
+<enscript highlight=scheme>
+(string-intersperse '("one" "two") "three")
+</enscript>
+
+is equivalent to
+
+<enscript highlight=scheme>
+(apply string-append (intersperse '("one" "two") "three"))
+</enscript>
+
+
+==== string-split
+
+ [procedure] (string-split STRING [DELIMITER-STRING [KEEPEMPTY]])
+
+Split string into substrings separated by the given delimiters. If
+no delimiters are specified, a string comprising the tab, newline and space characters
+is assumed. If the
+parameter {{KEEPEMPTY}} is given and not {{#f}}, then empty
+substrings are retained:
+
+<enscript highlight=scheme>
+(string-split "one two three") ==> ("one" "two" "three")
+(string-split "foo:bar::baz:" ":" #t) ==> ("foo" "bar" "" "baz" "")
+</enscript>
+
+
+==== string-translate
+
+ [procedure] (string-translate STRING FROM [TO])
+
+Returns a fresh copy of {{STRING}} with characters matching
+{{FROM}} translated to {{TO}}. If {{TO}} is omitted, then
+matching characters are removed. {{FROM}} and {{TO}} may be
+a character, a string or a list. If both {{FROM}} and {{TO}}
+are strings, then the character at the same position in {{TO}}
+as the matching character in {{FROM}} is substituted.
+
+
+==== string-translate*
+
+ [procedure] (string-translate* STRING SMAP)
+
+Substitutes elements of {{STRING}} according to {{SMAP}}.
+{{SMAP}} should be an association-list where each element of the list
+is a pair of the form {{(MATCH \. REPLACEMENT)}}. Every occurrence of
+the string {{MATCH}} in {{STRING}} will be replaced by the string
+{{REPLACEMENT}}:
+
+<enscript highlight=scheme>
+(string-translate*
+ "<h1>this is a \"string\"</h1>"
+ '(("<" . "<") (">" . ">") ("\"" . """)) )
+=> "<h1>this is a "string"</h1>"
+</enscript>
+
+
+==== substring=?
+
+ [procedure] (substring=? STRING1 STRING2 [START1 [START2 [LENGTH]]])
+ [procedure] (substring-ci=? STRING1 STRING2 [START1 [START2 [LENGTH]]])
+
+Returns {{#t}} if the strings {{STRING1}} and {{STRING2}} are equal, or
+{{#f}} otherwise.
+The comparison starts at the positions {{START1}} and {{START2}} (which default
+to 0), comparing {{LENGTH}} characters (which defaults to the minimum of the remaining
+length of both strings).
+
+
+==== substring-index
+
+ [procedure] (substring-index WHICH WHERE [START])
+ [procedure] (substring-index-ci WHICH WHERE [START])
+
+Searches for first index in string {{WHERE}} where string
+{{WHICH}} occurs. If the optional argument {{START}} is given,
+then the search starts at that index. {{substring-index-ci}}
+is a case-insensitive version of {{substring-index}}.
+
+
+==== reverse-string-append
+
+ [procedure] (reverse-string-append LIST)
+
+{{(apply string-append (reverse LIST))}}
+
+
+=== Combinators
+
+
+==== any?
+
+ [procedure] (any? X)
+
+Ignores its argument and always returns {{#t}}. This is actually useful sometimes.
+
+
+==== none?
+
+ [procedure] (none? X)
+
+Ignores its argument and always returns {{#f}}. This is actually useful sometimes.
+
+
+==== always?
+
+ [procedure] (always? X)
+
+Ignores its arguments and always returns {{#t}}. This is actually useful sometimes.
+
+
+==== never?
+
+ [procedure] (never? X)
+
+Ignores its arguments and always returns {{#f}}. This is actually useful sometimes.
+
+
+==== constantly
+
+ [procedure] (constantly X ...)
+
+Returns a procedure that always returns the values {{X ...}} regardless of the number and value of its arguments.
+
+<enscript highlight=scheme>
+(constantly X) <=> (lambda args X)
+</enscript>
+
+
+==== complement
+
+ [procedure] (complement PROC)
+
+Returns a procedure that returns the boolean inverse of {{PROC}}.
+
+<enscript highlight=scheme>
+(complement PROC) <=> (lambda (x) (not (PROC x)))
+</enscript>
+
+
+==== compose
+
+ [procedure] (compose PROC1 PROC2 ...)
+
+Returns a procedure that represents the composition of the
+argument-procedures {{PROC1 PROC2 ...}}.
+
+<enscript highlight=scheme>
+(compose F G) <=> (lambda args
+ (call-with-values
+ (lambda () (apply G args))
+ F))
+</enscript>
+
+{{(compose)}} is equivalent to {{values}}.
+
+
+==== conjoin
+
+ [procedure] (conjoin PRED ...)
+
+Returns a procedure that returns {{#t}} if its argument satisfies the
+predicates {{PRED ...}}.
+<enscript highlight=scheme>
+((conjoin odd? positive?) 33) ==> #t
+((conjoin odd? positive?) -33) ==> #f
+</enscript>
+
+
+==== disjoin
+
+ [procedure] (disjoin PRED ...)
+
+Returns a procedure that returns {{#t}} if its argument satisfies any
+predicate {{PRED ...}}.
+<enscript highlight=scheme>
+((disjoin odd? positive?) 32) ==> #t
+((disjoin odd? positive?) -32) ==> #f
+</enscript>
+
+
+==== each
+
+ [procedure] (each PROC ...)
+
+Returns a procedure that applies {{PROC ...}} to its arguments, and returns the result(s)
+of the last procedure application. For example
+
+<enscript highlight=scheme>
+(each pp eval)
+</enscript>
+
+is equivalent to
+
+<enscript highlight=scheme>
+(lambda args
+ (apply pp args)
+ (apply eval args) )
+</enscript>
+
+{{(each PROC)}} is equivalent to {{PROC}} and {{(each)}} is equivalent to
+{{noop}}.
+
+
+==== flip
+
+ [procedure] (flip PROC)
+
+Returns a two-argument procedure that calls {{PROC}} with its
+arguments swapped:
+<enscript highlight=scheme>
+(flip PROC) <=> (lambda (x y) (PROC y x))
+</enscript>
+
+
+==== identity
+
+ [procedure] (identity X)
+
+Returns its sole argument {{X}}.
+
+
+==== project
+
+ [procedure] (project N)
+
+Returns a procedure that returns its {{N}}th argument (starting from 0).
+
+
+==== list-of?
+
+ [procedure] (list-of? PRED)
+
+Returns a procedure of one argument that returns {{#t}} when
+applied to a list of elements that all satisfy the predicate procedure
+{{PRED}}, or {{#f}} otherwise.
+
+<enscript highlight=scheme>
+((list-of? even?) '(1 2 3)) ==> #f
+((list-of? number?) '(1 2 3)) ==> #t
+</enscript>
+
+
+==== noop
+
+ [procedure] (noop X ...)
+
+Ignores its arguments, does nothing and returns an unspecified value.
+
+
+==== o
+
+ [procedure] (o PROC ...)
+
+A single value version of {{compose}} (slightly faster). {{(o)}} is equivalent
+to {{identity}}.
+
+
+==== left-section
+
+ [procedure] (left-section PROC ARG0 ...)
+
+Returns a procedure that partially applies some of its arguments starting from the left.
+
+{{PROC}} a procedure.
+
+{{ARG0 ...}} some prefix of the arguments for {{PROC}}.
+
+
+==== right-section
+
+ [procedure] (right-section PROC ARG0 ...)
+
+Returns a procedure that partially applies some of its arguments starting from the right.
+
+{{PROC}} a procedure.
+
+{{ARG0 ...}} some reversed suffix of the arguments for {{PROC}}.
+
+
+
+=== Binary searching
+
+
+==== binary-search
+
+ [procedure] (binary-search SEQUENCE PROC)
+
+Performs a binary search in {{SEQUENCE}}, which should be a sorted
+list or vector. {{PROC}} is called to compare items in the sequence,
+should accept a single argument and return an exact integer: zero if the
+searched value is equal to the current item, negative if the searched
+value is ''less'' than the current item, and positive otherwise.
+Returns the index of the found value or {{#f}} otherwise.
+
+---
+Previous: [[Unit expand]]
+
+Next: [[Unit ports]]
diff --git a/manual/Unit eval b/manual/Unit eval
new file mode 100644
index 00000000..4aa1e7c9
--- /dev/null
+++ b/manual/Unit eval
@@ -0,0 +1,283 @@
+[[tags: manual]]
+[[toc:]]
+
+== Unit eval
+
+This unit has support for evaluation and macro-handling. This unit is used
+by default, unless the program is compiled with the {{-explicit-use}}
+option.
+
+=== Loading code
+
+==== load
+
+ [procedure] (load FILE [EVALPROC])
+
+Loads and evaluates expressions from the given source file, which may
+be either a string or an input port. Each expression read is passed to
+{{EVALPROC}} (which defaults to {{eval}}). On platforms that
+support it (currently native Windows, Linux ELF and Solaris), {{load}} can be used
+to load compiled programs:
+
+ % cat x.scm
+ (define (hello) (print "Hello!"))
+ % csc -s x.scm
+ % csi -q
+ #;1> (load "x.so")
+ ; loading x.so ...
+ #;2> (hello)
+ Hello!
+ #;3>
+
+The second argument to {{load}} is ignored when loading compiled
+code.
+If source code is loaded from a port, then that port is closed after
+all expressions have been read.
+
+Compiled code can be re-loaded, but care has to be taken, if code
+from the replaced dynamically loaded module is still executing (i.e.
+if an active continuation refers to compiled code in the old module).
+
+Support for reloading compiled code dynamically is still experimental.
+
+==== load-relative
+
+ [procedure] (load-relative FILE [EVALPROC])
+
+Similar to {{load}}, but loads {{FILE}} relative to the path
+of the currently loaded file.
+
+==== load-noisily
+
+ [procedure] (load-noisily FILE #!key EVALUATOR TIME PRINTER)
+
+As {{load}} but the result(s) of each evaluated toplevel-expression
+is written to standard output. If {{EVALUATOR}} is given and not {{#f}},
+then each expression is evaluated by calling this argument with the read
+expression as argument. If {{TIME}} is given and not false, then
+the execution time of each expression is shown (as with the {{time}} macro).
+If {{PRINTER}} is given and not false, then each expression is
+printed before evaluation by applying the expression to the value of this
+argument, which should be a one-argument procedure.
+
+See also the [[http://chicken.wiki.br/Parameters#load-verbose|load-verbose]] parameter.
+
+==== load-library
+
+ [procedure] (load-library UNIT [LIBRARYFILE])
+
+On platforms that support dynamic loading, {{load-library}} loads
+the compiled library unit {{UNIT}} (which should be a symbol). If the
+string {{LIBRARYFILE}} is given, then the given shared library will
+be loaded and the toplevel code of the contained unit will be executed.
+If no {{LIBRARYFILE}} argument is given, then the following libraries
+are checked for the required unit:
+
+* a file named ''{{<UNIT>.so}}''
+* the files given in the parameter {{dynamic-load-libraries}}
+
+If the unit is not found, an error is signaled. When the library unit
+can be successfully loaded, a feature-identifier named {{UNIT}}
+is registered. If the feature is already registered before loading,
+the {{load-library}} does nothing.
+
+==== loaded-libraries
+
+ [procedure] (loaded-libraries)
+
+Returns a list of the dynamic library names.
+
+==== dynamic-library-load
+
+ [procedure] (dynamic-library-load LIBRARYFILE [ERROR?])
+
+Performs a dynamic load of the binary file {{LIBRARYFILE}}.
+
+WIll raise an error upon failure to find the symbol. Unless {{ERROR?}} is
+{{#f}}, in which case {{#f}} is returned.
+
+==== dynamic-library-procedure
+
+ [procedure] (dynamic-library-procedure LIBRARYFILE SYMBOLNAME HANDLER [ERROR?])
+
+Performs a symbol to address lookup in the dynamic load library
+{{LIBRARYFILE}}. Attempts to load the library if not already loaded.
+
+A {{symbol}} {{SYMBOLNAME}} will be converted to a {{string}}.
+
+{{HANDLER}} is a procedure of 4 arguments.
+
+Returns a {{procedure}} of N arguments, {{ARGS}}, with body
+{{(HANDLER LIBRARYFILE SYMBOLNAME POINTER ARGS)}}. {{PONTER}} is a {{pointer}}
+with an address value of the symbol in the library.
+
+WIll raise an error upon failure to find the symbol. Unless {{ERROR?}} is
+{{#f}}, in which case {{#f}} is returned.
+
+On platforms other than Windows the literal form of the symbol is attempted
+first, followed by a lookup with a leading underscore {{#\_}}.
+
+==== dynamic-library-variable
+
+ [procedure] (dynamic-library-variable LIBRARYFILE SYMBOLNAME HANDLER [ERROR?])
+
+Performs a symbol to address lookup in the dynamic load library
+{{LIBRARYFILE}}. Attempts to load the library if not already loaded.
+
+A {{symbol}} {{SYMBOLNAME}} will be converted to a {{string}}.
+
+{{HANDLER}} is a procedure of 4 arguments.
+
+Returns a {{procedure}} of N arguments, {{ARGS}}, with body
+{{(HANDLER LIBRARYFILE SYMBOLNAME POINTER ARGS)}}. {{PONTER}} is a {{pointer}}
+with an address value of the symbol in the library.
+
+WIll raise an error upon failure to find the symbol. Unless {{ERROR?}} is
+{{#f}}, in which case {{#f}} is returned.
+
+On platforms other than Windows the literal form of the symbol is attempted
+first, followed by a lookup with a leading underscore {{#\_}}.
+
+The distinction between a procedure and variable symbol lookup is platform
+dependent, if even possible. On Windows {{dynamic-library-variable}} will
+always fail. On all other supported platforms {{dynamic-library-variable}} will
+do the right thing.
+
+==== set-dynamic-load-mode!
+
+ [procedure] (set-dynamic-load-mode! MODELIST)
+
+On systems that support dynamic loading of compiled code via the {{dlopen(3)}}
+interface (for example Linux and Solaris), some options can be specified to
+fine-tune the behaviour of the dynamic linker. {{MODE}} should be a list of
+symbols (or a single symbol) taken from the following set:
+
+; {{local}} : If {{local}} is given, then any C/C++ symbols defined in the dynamically loaded file are not available for subsequently loaded files and libraries. Use this if you have linked foreign code into your dynamically loadable file and if you don't want to export them (for example because you want to load another file that defines the same symbols).
+; {{global}} : The default is {{global}}, which means all C/C++ symbols are available to code loaded at a later stage.
+; {{now}} : If {{now}} is specified, all symbols are resolved immediately.
+; {{lazy}} : Unresolved symbols are resolved as code from the file is executed. This is the default.
+
+Note that this procedure does not control the way Scheme variables are handled -
+this facility is mainly of interest when accessing foreign code.
+
+DEPRECATED - See the [[http://chicken.wiki.br/Parameters#dynamic-load-mode|dynamic-load-mode]] parameter
+
+
+=== Read-eval-print loop
+
+==== repl
+
+ [procedure] (repl)
+
+Start a new read-eval-print loop. Sets the {{reset-handler}} so that
+any invocation of {{reset}} restarts the read-eval-print loop. Also
+changes the current exception-handler to display a message, write
+any arguments to the value of {{(current-error-port)}} and reset.
+
+
+=== Loading extension libraries
+
+This functionality is only available on platforms that support dynamic
+loading of compiled code. Currently Linux, BSD, Solaris, Windows (with Cygwin) and HP/UX are supported.
+
+==== repository-path
+
+; [parameter] repository-path :
+Contains a string naming the path to the extension repository, which defaults to
+either the value of the environment variable {{CHICKEN_REPOSITORY}}
+or the default library path
+(usually {{/usr/local/lib/chicken}} on UNIX systems).
+
+==== extension-information
+
+ [procedure] (extension-information ID)
+
+If an extension with the name {{ID}} is installed and if it has a setup-information
+list registered in the extension repository, then the info-list is returned. Otherwise
+{{extension-information}} returns {{#f}}.
+
+==== provide
+
+ [procedure] (provide ID ...)
+
+Registers the extension IDs {{ID ...}} as loaded. This is mainly
+intended to provide aliases for certain extension identifiers.
+
+==== provided?
+
+ [procedure] (provided? ID ...)
+
+Returns {{#t}} if the extension with the IDs {{ID ...}}
+are currently loaded, or {{#f}} otherwise.
+
+==== require
+
+ [procedure] (require ID ...)
+
+If the extension library {{ID}} is not already loaded into the
+system, then {{require}} will lookup the location of the shared
+extension library and load it. If {{ID}} names a library-unit of
+the base system, then it is loaded via {{load-library}}. If no
+extension library is available for the given ID, then an attempt is
+made to load the file {{ID.so}} or {{ID.scm}} (in that order)
+from one of the following locations:
+
+* the current include path, which defaults to the pathnames given in {{CHICKEN_INCLUDE_PATH}}.
+* the current directory
+
+{{ID}} should be a string or a symbol.
+
+==== set-extension-specifier!
+
+ [procedure] (set-extension-specifier! SYMBOL PROC)
+
+Registers the handler-procedure {{PROC}} as a extension-specifier with the
+name {{SYMBOL}}. This facility allows extending the set of valid extension
+specifiers to be used with {{require-extension}}. When {{register-extension}}
+is called with an extension specifier of the form {{(SPEC ...)}} and {{SPEC}}
+has been registered with {{set-extension-specifier!}}, then {{PROC}} will
+be called with two arguments: the specifier and the previously installed handler
+(or {{#f}} if no such handler was defined). The handler should return a new
+specifier that will be processed recursively. If the handler returns a vector,
+then each element of the vector will be processed recursively.
+Alternatively the handler may return a string which specifies a file to be loaded:
+
+<enscript highlight=scheme>
+(eval-when (compile eval)
+ (set-extension-specifier!
+ 'my-package
+ (lambda (spec old)
+ (make-pathname my-package-directory (->string (cadr spec))) ) ) )
+
+(require-extension (my-package stuff)) ; --> expands into '(load "my-package-dir/stuff")
+</enscript>
+
+Note that the handler has to be registered at compile time, if it is to be
+visible in compiled code.
+
+
+=== System information
+
+==== chicken-home
+
+ [procedure] (chicken-home)
+
+Returns a string given the installation directory (usually {{/usr/local/share/chicken}} on UNIX-like systems).
+As a last option,
+if the environment variable {{CHICKEN_PREFIX}} is set, then {{chicken-home}} will return
+{{$CHICKEN_PREFIX/share}}.
+
+
+=== Eval
+
+==== eval
+
+ [procedure] (eval EXP [ENVIRONMENT])
+
+Evaluates {{EXP}} and returns the result of the evaluation. The second argument is optional
+and defaults to the value of {{(interaction-environment)}}.
+
+---
+Previous: [[Unit library]]
+
+Next: [[Unit expand]]
diff --git a/manual/Unit expand b/manual/Unit expand
new file mode 100644
index 00000000..47f0ad82
--- /dev/null
+++ b/manual/Unit expand
@@ -0,0 +1,49 @@
+[[tags: manual]]
+[[toc:]]
+
+== Unit expand
+
+This unit has support for syntax- and module handling. This unit is used
+by default, unless the program is compiled with the {{-explicit-use}}
+option.
+
+=== Macros
+
+==== get-line-number
+
+ [procedure] (get-line-number EXPR)
+
+If {{EXPR}} is a pair with the car being a symbol, and line-number
+information is available for this expression, then this procedure returns
+the associated line number. If line-number information is not available,
+then {{#f}} is returned. Note that line-number information for
+expressions is only available in the compiler.
+
+==== expand
+
+ [procedure] (expand X)
+
+If {{X}} is a macro-form, expand the macro (and repeat expansion
+until expression is a non-macro form). Returns the resulting expression.
+
+==== syntax-error
+
+ [procedure] (syntax-error [LOCATION] MESSAGE ARGUMENT ...)
+
+Signals an exception of the kind {{(exn syntax)}}. Otherwise identical to
+{{error}}.
+
+
+==== er-macro-transformer
+
+ [procedure] (er-macro-transformer TRANSFORMER)
+
+This procedure does nothing and is available for writing low-level
+macros in a more portable fashion, without hard-coding the signature
+of a transformer procedure.
+
+
+---
+Previous: [[Unit library]]
+
+Next: [[Unit data-structures]]
diff --git a/manual/Unit extras b/manual/Unit extras
new file mode 100644
index 00000000..7ca63497
--- /dev/null
+++ b/manual/Unit extras
@@ -0,0 +1,194 @@
+[[tags: manual]]
+[[toc:]]
+
+== Unit extras
+
+This unit contains a collection of useful utility definitions. The unit is
+used by default, unless the program is compiled with the {{-explicit-use}}
+option.
+
+
+
+=== Random numbers
+
+
+==== random-seed
+
+ [procedure] (random-seed [SEED])
+
+Seeds the random number generator with {{SEED}} (an {{integer}}) or
+{{(current-seconds)}} if {{SEED}} is not given.
+
+
+==== randomize
+
+ [procedure] (randomize [SEED])
+
+Set random-number seed. If {{SEED}} (an {{exact integer}}) is not supplied, the
+current time is used. On startup (when Unit {{extras}} is initialized), the
+random number generator is initialized with the current time.
+
+
+==== random
+
+ [procedure] (random N)
+
+Returns a random {{integer}} in {{[0 N-1]}}. {{N}} is an {{integer}}.
+
+On '''Windows''' {{N}} and the random value are {{exact integer}}.
+
+
+
+=== Formatted output
+
+
+==== printf
+==== fprintf
+==== sprintf
+
+ [procedure] (fprintf PORT FORMATSTRING [ARG...])
+ [procedure] (printf FORMATSTRING [ARG...])
+ [procedure] (sprintf FORMATSTRING [ARG...])
+
+Simple formatted output to a given port ({{fprintf}}), the
+value of {{(current-output-port)}} ({{printf}}), or a string
+({{sprintf}}). The {{FORMATSTRING}} can contain any sequence
+of characters. There must be at least as many {{ARG}} arguments given as there are format directives that require an argument in {{FORMATSTRING}}. Extra {{ARG}} arguments are ignored. The character `~' prefixes special formatting directives:
+
+<table>
+<tr><td>~%</td><td>
+write newline character
+</td></tr><tr><td> ~N</td><td>
+the same as {{~%}}
+</td></tr><tr><td> ~S</td><td>
+write the next argument
+</td></tr><tr><td> ~A</td><td>
+display the next argument
+</td></tr><tr><td> ~\n</td><td>
+skip all whitespace in the format-string until the next non-whitespace character
+</td></tr><tr><td> ~B</td><td>
+write the next argument as a binary number
+</td></tr><tr><td> ~O</td><td>
+write the next argument as an octal number
+</td></tr><tr><td> ~X</td><td>
+write the next argument as a hexadecimal number
+</td></tr><tr><td> ~C</td><td>
+write the next argument as a character
+</td></tr><tr><td> ~~</td><td>
+display `~'
+</td></tr><tr><td> ~!</td><td>
+flush all pending output
+</td></tr><tr><td> ~?</td><td>
+invoke formatted output routine recursively with the next two arguments as format-string and list of parameters
+</td></tr></table>
+
+
+==== format
+
+ [procedure] (format [DESTINATION] FORMATSTRING [ARG...])
+
+The parameters {{FORMATSTRING}} and {{ARG...}} are as for {{printf}}.
+
+The optional {{DESTINATION}}, when supplied, performs:
+
+; {{#f}} : {{sprintf}}
+; {{#t}} : {{printf}}
+; {{output-port}} : {{fprintf}}
+; : {{sprintf}}
+
+
+=== Pretty-printing
+
+
+==== pretty-print
+
+ [procedure] (pretty-print EXP [PORT])
+ [procedure] (pp EXP [PORT])
+
+Print expression nicely formatted. {{PORT}} defaults to the value
+of {{(current-output-port)}}.
+
+
+==== pretty-print-width
+(Parameter) Specifies the maximal line-width for pretty printing, after which line
+wrap will occur.
+
+
+=== Input/Output extensions
+
+==== read-byte
+==== write-byte
+
+ [procedure] (read-byte [PORT])
+ [procedure] (write-byte BYTE [PORT])
+
+Read/write a byte to the port given in {{PORT}}, which default to the values
+of {{(current-input-port)}} and {{(current-output-port)}}, respectively.
+
+==== read-file
+
+ [procedure] (read-file [FILE-OR-PORT [READER [MAXCOUNT]]])
+
+Returns a list containing all toplevel expressions
+read from the file or port {{FILE-OR-PORT}}. If no argument is given,
+input is read from the port that is the current value of {{(current-input-port)}}.
+After all expressions are read, and if the argument is a port, then the port will
+not be closed. The {{READER}} argument specifies the procedure used to read
+expressions from the given file or port and defaults to {{read}}. The reader
+procedure will be called with a single argument (an input port).
+If {{MAXCOUNT}} is given then only up to {{MAXCOUNT}} expressions will be read in.
+
+
+==== read-line
+==== write-line
+
+ [procedure] (read-line [PORT [LIMIT]])
+ [procedure] (write-line STRING [PORT])
+
+Line-input and -output. {{PORT}} defaults to the value of
+{{(current-input-port)}} and {{(current-output-port)}},
+respectively. If the optional argument {{LIMIT}} is given and
+not {{#f}}, then {{read-line}} reads at most {{LIMIT}}
+characters per line. {{read-line}} returns a string without the terminating newline and {{write-line}} adds a terminating newline before outputting.
+
+
+==== read-lines
+
+ [procedure] (read-lines [PORT [MAX]])
+
+Read {{MAX}} or fewer lines from {{PORT}}. {{PORT}}
+defaults to the value of {{(current-input-port)}}. {{PORT}} may optionally be
+a string naming a file. Returns a list of strings, each string representing a line read, not including any line separation character(s).
+
+
+==== read-string
+==== read-string!
+==== write-string
+
+ [procedure] (read-string [NUM [PORT]])
+ [procedure] (read-string! NUM STRING [PORT [START]])
+ [procedure] (write-string STRING [NUM [PORT]]
+
+Read or write {{NUM}} characters from/to {{PORT}}, which defaults to the
+value of {{(current-input-port)}} or {{(current-output-port)}}, respectively.
+If {{NUM}} is {{#f}} or not given, then all data
+up to the end-of-file is read, or, in the case of {{write-string}} the whole
+string is written. If no more input is available, {{read-string}} returns the
+empty string. {{read-string!}} reads destructively into the given {{STRING}} argument,
+but never more characters that would fit into {{STRING}}. If {{START}} is given, then
+the read characters are stored starting at that position.
+{{read-string!}} returns the actual number of characters read.
+
+
+==== read-token
+
+ [procedure] (read-token PREDICATE [PORT])
+
+Reads characters from {{PORT}} (which defaults to the value of {{(current-input-port)}})
+and calls the procedure {{PREDICATE}} with each character until {{PREDICATE}} returns
+false. Returns a string with the accumulated characters.
+
+---
+Previous: [[Unit files]]
+
+Next: [[Unit regex]]
diff --git a/manual/Unit files b/manual/Unit files
new file mode 100644
index 00000000..f4cc74be
--- /dev/null
+++ b/manual/Unit files
@@ -0,0 +1,176 @@
+[[tags: manual]]
+[[toc:]]
+
+
+== Unit files
+
+This unit contains file- and pathname-oriented procedures. It uses the {{regex}} unit.
+
+
+=== Pathname operations
+
+==== absolute-pathname?
+
+<procedure>(absolute-pathname? PATHNAME)</procedure>
+
+Returns {{#t}} if the string {{PATHNAME}} names an absolute
+pathname, and returns {{#f}} otherwise.
+
+==== decompose-pathname
+
+<procedure>(decompose-pathname PATHNAME)</procedure>
+
+Returns three values: the directory-, filename- and extension-components
+of the file named by the string {{PATHNAME}}.
+For any component that is not contained in {{PATHNAME}}, {{#f}} is returned.
+
+==== make-pathname
+==== make-absolute-pathname
+
+<procedure>(make-pathname DIRECTORY FILENAME [EXTENSION])</procedure>
+<procedure>(make-absolute-pathname DIRECTORY FILENAME [EXTENSION])</procedure>
+
+Returns a string that names the file with the
+components {{DIRECTORY, FILENAME}} and (optionally)
+{{EXTENSION}} with {{SEPARATOR}} being the directory separation indicator
+(usually {{/}} on UNIX systems and {{\}} on Windows, defaulting to whatever
+platform this is running on).
+{{DIRECTORY}} can be {{#f}} (meaning no
+directory component), a string or a list of strings. {{FILENAME}}
+and {{EXTENSION}} should be strings or {{#f}}.
+{{make-absolute-pathname}} returns always an absolute pathname.
+
+The {{[SEPARATOR]}} argument is deprecated.
+
+==== pathname-directory
+
+<procedure>(pathname-directory PATHNAME)</procedure>
+
+==== pathname-file
+
+<procedure>(pathname-file PATHNAME)</procedure>
+
+==== pathname-extension
+
+<procedure>(pathname-extension PATHNAME)</procedure>
+
+Accessors for the components of {{PATHNAME}}. If the pathname does
+not contain the accessed component, then {{#f}} is returned.
+
+==== pathname-replace-directory
+
+<procedure>(pathname-replace-directory PATHNAME DIRECTORY)</procedure>
+
+==== pathname-replace-file
+
+<procedure>(pathname-replace-file PATHNAME FILENAME)</procedure>
+
+==== pathname-replace-extension
+
+<procedure>(pathname-replace-extension PATHNAME EXTENSION)</procedure>
+
+Return a new pathname with the specified component of {{PATHNAME}}
+replaced by a new value.
+
+==== pathname-strip-directory
+
+<procedure>(pathname-strip-directory PATHNAME)</procedure>
+
+==== pathname-strip-extension
+
+<procedure>(pathname-strip-extension PATHNAME)</procedure>
+
+Return a new pathname with the specified component of {{PATHNAME}}
+stripped.
+
+==== normalize-pathname
+
+<procedure>(normalize-pathname PATHNAME [PLATFORM])</procedure>
+
+Performs a simple "normalization" on the {{PATHNAME}}, suitably for
+{{PLATFORM}}, which should be one of the symbols {{windows}}
+or {{unix}} and defaults to on whatever platform is currently
+in use. All relative path elements and duplicate separators are processed
+and removed. If {{NAME}} ends with
+a {{/}} or is empty, the appropriate slash is appended to the tail.
+Tilde {{~}} and variable {{$<name>/...}} expansion is also done.
+
+No directories or files are actually tested for existence; this
+procedure only canonicalises path syntax.
+
+==== directory-null?
+
+<procedure>(directory-null? DIRECTORY)</procedure>
+
+Does the {{DIRECTORY}} consist only of path separators and the period?
+
+{{DIRECTORY}} may be a string or a list of strings.
+
+==== decompose-directory
+
+<procedure>(decompose-directory DIRECTORY)</procedure>
+
+Returns 3 values: the {{base-origin}}, {{base-directory}}, and the
+{{directory-elements}} for the {{DIRECTORY}}.
+
+; {{base-origin}} : a {{string}} or {{#f}}. The drive, if any.
+; {{base-directory}} : a {{string}} or {{#f}}. A directory-separator when {{DIRECTORY}} is an {{absolute-pathname}}.
+; {{directory-elements}} : a {{list-of string}} or {{#f}}. The non-directory-separator bits.
+
+{{DIRECTORY}} is a {{string}}.
+
+* On WIndows {{(decompose-directory "c:foo/bar")}} => {{"c:" #f ("foo" "bar")}}
+
+
+=== Temporary files
+
+==== create-temporary-file
+
+<procedure>(create-temporary-file [EXTENSION])</procedure>
+
+Creates an empty temporary file and returns its pathname. If
+{{EXTENSION}} is not given, then {{.tmp}} is used. If the
+environment variable {{TMPDIR, TEMP}} or {{TMP}} is set,
+then the pathname names a file in that directory.
+
+
+=== Deleting a file without signalling an error
+
+==== delete-file*
+
+<procedure>(delete-file* FILENAME)</procedure>
+
+If the file {{FILENAME}} exists, it is deleted and {{#t}}
+is returned. If the file does not exist, nothing happens and {{#f}}
+is returned.
+
+
+=== File move/copy
+
+==== file-copy
+
+<procedure>(file-copy ORIGFILE NEWFILE #!optional CLOBBER BLOCKSIZE)</procedure>
+
+Copies {{ORIGFILE}} (a string denoting some filename) to {{NEWFILE}},
+{{BLOCKSIZE}} bytes at a time. {{BLOCKSIZE}} defaults to 1024, and must be
+a positive integer. Returns the number of bytes copied on success, or errors
+on failure. {{CLOBBER}} determines the behaviour of {{file-copy}} when
+{{NEWFILE}} is already extant. When set to {{#f}} (default), an error is
+signalled. When set to any other value, {{NEWFILE}} is overwritten.
+{{file-copy}} will work across filesystems and devices and is not
+platform-dependent.
+
+==== file-move
+
+<procedure>(file-move ORIGFILE NEWFILE #!optional CLOBBER BLOCKSIZE)</procedure>
+
+Moves {{ORIGFILE}} (a string denoting some filename) to {{NEWFILE}}, with
+the same semantics as {{file-copy}}, above. {{file-move}} is safe across
+filesystems and devices (unlike {{file-rename}}). It is possible for an
+error to be signalled despite partial success if {{NEWFILE}} could be created
+and fully written but removing {{ORIGFILE}} fails.
+
+---
+Previous: [[Unit ports]]
+
+Next: [[Unit extras]]
diff --git a/manual/Unit library b/manual/Unit library
new file mode 100644
index 00000000..e6c2ad40
--- /dev/null
+++ b/manual/Unit library
@@ -0,0 +1,1267 @@
+[[tags: manual]]
+[[toc:]]
+
+== Unit library
+
+This unit contains basic Scheme definitions. This unit is used by default,
+unless the program is compiled with the {{-explicit-use}} option.
+
+=== Arithmetic
+
+
+==== add1/sub1
+
+<procedure>(add1 N)</procedure>
+<procedure>(sub1 N)</procedure>
+
+Adds/subtracts 1 from {{N}}.
+
+
+==== Binary integer operations
+
+Binary integer operations. {{arithmetic-shift}} shifts the argument {{N1}} by
+{{N2}} bits to the left. If {{N2}} is negative, than {{N1}} is shifted to the
+right. These operations only accept exact integers or inexact integers in word
+range (32 bit signed on 32-bit platforms, or 64 bit signed on 64-bit
+platforms).
+
+<procedure>(bitwise-and N1 ...)</procedure>
+<procedure>(bitwise-ior N1 ...)</procedure>
+<procedure>(bitwise-xor N1 ...)</procedure>
+<procedure>(bitwise-not N)</procedure>
+<procedure>(arithmetic-shift N1 N2)</procedure>
+
+==== bit-set?
+
+<procedure>(bit-set? N INDEX)</procedure>
+
+Returns {{#t}} if the bit at the position {{INDEX}} in the integer {{N}} is
+set, or {{#f}} otherwise. The rightmost/least-significant bit is bit 0.
+
+
+==== Arithmetic fixnum operations
+
+These procedures do not check their arguments, so non-fixnum parameters will
+result in incorrect results. {{fxneg}} negates its argument.
+
+On division by zero, {{fx/}} and {{fxmod}} signal a condition of kind
+{{(exn arithmetic)}}.
+
+{{fxshl}} and {{fxshr}} perform arithmetic shift left and right,
+respectively.
+
+<procedure>(fx+ N1 N2)</procedure>
+<procedure>(fx- N1 N2)</procedure>
+<procedure>(fx* N1 N2)</procedure>
+<procedure>(fx/ N1 N2)</procedure>
+<procedure>(fxmod N1 N2)</procedure>
+<procedure>(fxneg N)</procedure>
+<procedure>(fxmin N1 N2)</procedure>
+<procedure>(fxmax N1 N2)</procedure>
+<procedure>(fx= N1 N2)</procedure>
+<procedure>(fx> N1 N2)</procedure>
+<procedure>(fx< N1 N2)</procedure>
+<procedure>(fx>= N1 N2)</procedure>
+<procedure>(fx<= N1 N2)</procedure>
+<procedure>(fxand N1 N2)</procedure>
+<procedure>(fxior N1 N2)</procedure>
+<procedure>(fxxor N1 N2)</procedure>
+<procedure>(fxnot N)</procedure>
+<procedure>(fxshl N1 N2)</procedure>
+<procedure>(fxshr N1 N2)</procedure>
+
+==== fixnum?
+
+ [procedure] (fixnum? X)
+
+Returns {{#t}} if {{X}} is a fixnum, or {{#f}} otherwise.
+
+==== Fixnum limits
+
+{{most-positive-fixnum}}
+
+{{most-negative-fixnum}}
+
+{{fixnum-bits}}
+
+{{fixnum-precision}}
+
+
+==== Arithmetic floating-point operations
+
+arguments (except {{flonum?}}, which returns {{#f}}). In unsafe mode,
+these procedures do not check their arguments. A non-flonum argument
+in unsafe mode can crash the system.
+
+<procedure>(flonum? X)</procedure>
+<procedure>(fp+ X Y)</procedure>
+<procedure>(fp- X Y)</procedure>
+<procedure>(fp* X Y)</procedure>
+<procedure>(fp/ X Y)</procedure>
+<procedure>(fpneg X)</procedure>
+<procedure>(fpmin X Y)</procedure>
+<procedure>(fpmax X Y)</procedure>
+<procedure>(fp= X Y)</procedure>
+<procedure>(fp> X Y)</procedure>
+<procedure>(fp< X Y)</procedure>
+<procedure>(fp>= X Y)</procedure>
+<procedure>(fp<= X Y)</procedure>
+
+==== flonum?
+
+ [procedure] (flonum? X)
+
+Returns {{#t}} if {{X}} is a flonum, or {{#f}} otherwise.
+
+==== Flonum limits
+
+{{maximum-flonum}}
+
+{{minimum-flonum}}
+
+{{flonum-radix}}
+
+{{flonum-epsilon}}
+
+{{flonum-precision}}
+
+{{flonum-decimal-precision}}
+
+{{flonum-maximum-exponent}}
+
+{{flonum-minimum-exponent}}
+
+{{flonum-maximum-decimal-exponent}}
+
+{{flonum-minimum-decimal-exponent}}
+
+==== finite?
+
+<procedure>(finite? N)</procedure>
+
+Returns {{#f}} if {{N}} is negative or positive infinity, and {{#t}} otherwise.
+
+==== signum
+
+ [procedure] (signum N)
+
+Returns {{1}} if {{N}} is positive, {{-1}} if {{N}}
+is negative or {{0}} if {{N}} is zero. {{signum}} is exactness preserving.
+
+
+
+=== File Input/Output
+
+==== current-output-port
+
+<procedure>(current-output-port [PORT])</procedure>
+
+Returns default output port. If {{PORT}} is given, then that port is selected
+as the new current output port.
+
+Note that the default output port is not buffered. Use [[Unit posix#Setting the
+file buffering mode|{{set-buffering-mode!}}]] if you need a different behavior.
+
+==== current-error-port
+
+<procedure>(current-error-port [PORT])</procedure>
+
+Returns default error output port. If {{PORT}} is given, then that port is
+selected as the new current error output port.
+
+Note that the default error output port is not buffered. Use [[Unit
+posix#Setting the file buffering mode|{{set-buffering-mode!}}]] if you need a
+different behavior.
+
+==== flush-output
+
+<procedure>(flush-output [PORT])</procedure>
+
+Write buffered output to the given output-port. {{PORT}} defaults
+to the value of {{(current-output-port)}}.
+
+
+==== port-name
+
+<procedure>(port-name [PORT])</procedure>
+
+Fetch filename from {{PORT}}. This returns the filename that was used to open
+this file. Returns a special tag string, enclosed into parentheses for
+non-file ports. {{PORT}} defaults to the value of {{(current-input-port)}}.
+
+
+==== port-position
+
+<procedure>(port-position [PORT])</procedure>
+
+Returns the current position of {{PORT}} as two values: row and column number.
+If the port does not support such an operation an error is signaled. This
+procedure is currently only available for input ports. {{PORT}} defaults to the
+value of {{(current-input-port)}}.
+
+
+==== set-port-name!
+
+<procedure>(set-port-name! PORT STRING)</procedure>
+
+Sets the name of {{PORT}} to {{STRING}}.
+
+
+
+=== Files
+
+==== delete-file
+
+<procedure>(delete-file STRING)</procedure>
+
+Deletes the file with the pathname {{STRING}}. If the file does
+not exist, an error is signaled.
+
+
+==== directory-exists?
+
+<procedure>(directory-exists? STRING)</procedure>
+
+Returns {{STRING}} if a directory with the given pathname exists, or
+{{#f}} otherwise.
+
+
+==== file-exists?
+
+<procedure>(file-exists? STRING)</procedure>
+
+Returns {{STRING}} if a file or directory with the given pathname exists, or
+{{#f}} otherwise.
+
+
+==== rename-file
+
+<procedure>(rename-file OLD NEW)</procedure>
+
+Renames the file or directory with the pathname {{OLD}} to
+{{NEW}}. If the operation does not succeed, an error is signaled.
+
+
+=== String ports
+
+==== get-output-string
+
+<procedure>(get-output-string PORT)</procedure>
+
+Returns accumulated output of a port created with
+{{(open-output-string)}}.
+
+
+==== open-input-string
+
+<procedure>(open-input-string STRING)</procedure>
+
+Returns a port for reading from {{STRING}}.
+
+
+==== open-output-string
+
+<procedure>(open-output-string)</procedure>
+
+Returns a port for accumulating output in a string.
+
+
+
+
+
+=== Feature identifiers
+
+
+CHICKEN maintains a global list of ''features'' naming functionality available
+in the current system. Additionally the {{cond-expand}} form accesses this
+feature list to infer what features are provided. Predefined features are
+{{chicken}}, and the SRFIs (Scheme Request For Implementation) provided by the
+base system: {{srfi-23, srfi-30, srfi-39}}. If the {{eval}} unit
+is used (the default), the features {{srfi-0, srfi-2, srfi-6, srfi-8, srfi-9}}
+and {{srfi-10}} are defined. When compiling code (during compile-time) the
+feature {{compiling}} is registered. When evaluating code in the interpreter
+(csi), the feature {{csi}} is registered.
+
+
+==== features
+
+<procedure>(features)</procedure>
+
+Returns a list of all registered features that will be accepted as valid
+feature-identifiers by {{cond-expand}}.
+
+
+==== feature?
+
+<procedure>(feature? ID ...)</procedure>
+
+Returns {{#t}} if all features with the given feature-identifiers {{ID ...}}
+are registered.
+
+
+==== register-feature!
+
+<procedure>(register-feature! FEATURE ...)</procedure>
+
+Register one or more features that will be accepted as valid
+feature-identifiers by {{cond-expand}}. {{FEATURE ...}} may
+be a keyword, string or symbol.
+
+
+==== unregister-feature!
+
+<procedure>(unregister-feature! FEATURE ...)</procedure>
+
+Unregisters the specified feature-identifiers. {{FEATURE ...}}
+may be a keyword, string or symbol.
+
+
+
+
+
+=== Keywords
+
+Keywords are special symbols prefixed with {{#:}} that evaluate
+to themselves. Procedures can use keywords to accept optional named
+parameters in addition to normal required parameters. Assignment to
+and bindings of keyword symbols is not allowed.
+The parameter {{keyword-style}} and the compiler/interpreter option
+{{-keyword-style}} can be used to allow an additional keyword
+syntax, either compatible to Common LISP, or to DSSSL. As long as this
+parameter is set to {{#:suffix}}, Chicken conforms to
+[[http://srfi.schemers.org/srfi-88/srfi-88.html|SRFI-88]].
+
+
+==== get-keyword
+
+<procedure>(get-keyword KEYWORD ARGLIST [THUNK])</procedure>
+
+Returns the argument from {{ARGLIST}} specified under the keyword
+{{KEYWORD}}. If the keyword is not found, then the zero-argument
+procedure {{THUNK}} is invoked and the result value is returned. If
+{{THUNK}} is not given, {{#f}} is returned.
+
+<enscript highlight=scheme>
+(define (increase x . args)
+ (+ x (get-keyword #:amount args (lambda () 1))) )
+(increase 123) ==> 124
+(increase 123 #:amount 10) ==> 133
+</enscript>
+
+Note: the {{KEYWORD}} may actually be any kind of object.
+
+
+==== keyword?
+
+<procedure>(keyword? X)</procedure>
+
+Returns {{#t}} if {{X}} is a keyword symbol, or {{#f}}
+otherwise.
+
+
+==== keyword->string
+
+<procedure>(keyword->string KEYWORD)</procedure>
+
+Transforms {{KEYWORD}} into a string.
+
+
+==== string->keyword
+
+<procedure>(string->keyword STRING)</procedure>
+
+Returns a keyword with the name {{STRING}}.
+
+
+
+
+
+=== Exceptions
+
+
+CHICKEN implements the (currently withdrawn)
+[[http://srfi.schemers.org/srfi-12/srfi-12.html|SRFI-12]] exception system. For
+more information, see the
+[[http://srfi.schemers.org/srfi-12/srfi-12.html|SRFI-12]] document.
+
+
+
+==== condition-case
+
+ [syntax] (condition-case EXPRESSION CLAUSE ...)
+
+Evaluates {{EXPRESSION}} and handles any exceptions that are covered by
+{{CLAUSE ...}}, where {{CLAUSE}} should be of the following form:
+
+<enscript highlight=scheme>
+CLAUSE = ([VARIABLE] (KIND ...) BODY ...)
+</enscript>
+
+If provided, {{VARIABLE}} will be bound to the signaled exception
+object. {{BODY ...}} is executed when the exception is a property-
+or composite condition with the kinds given {{KIND ...}} (unevaluated).
+If no clause applies, the exception is re-signaled in the same dynamic
+context as the {{condition-case}} form.
+
+<enscript highlight=scheme>
+(define (check thunk)
+ (condition-case (thunk)
+ [(exn file) (print "file error")]
+ [(exn) (print "other error")]
+ [var () (print "something else")] ) )
+
+(check (lambda () (open-input-file ""))) ; -> "file error"
+(check (lambda () some-unbound-variable)) ; -> "othererror"
+(check (lambda () (signal 99))) ; -> "something else"
+
+(condition-case some-unbound-variable
+ [(exn file) (print "ignored")] ) ; -> signals error
+
+</enscript>
+
+
+==== breakpoint
+
+<procedure>(breakpoint [NAME])</procedure>
+
+Programmatically triggers a breakpoint (similar to the {{,br}} top-level csi
+command).
+
+
+==== get-condition-property
+
+<procedure>(get-condition-property CONDITION KIND PROPERTY [DEFAULT])</procedure>
+
+A slightly more convenient condition property accessor, equivalent to
+
+ ((condition-property-accessor KIND PROPERTY [DEFAULT]) CONDITION)
+
+
+==== System conditions
+
+All error-conditions signaled by the system are of kind {{exn}}.
+The following composite conditions are additionally defined:
+
+<table>
+
+<tr><td> (exn arity)
+
+Signaled when a procedure is called with the wrong number of arguments.
+
+</td></tr><tr><td> (exn type)
+
+Signaled on type-mismatch errors, for example when an argument of the wrong
+type is passed to a built-in procedure.
+
+</td></tr><tr><td> (exn arithmetic)
+
+Signaled on arithmetic errors, like division by zero.
+
+</td></tr><tr><td> (exn i/o)
+
+Signaled on input/output errors.
+
+</td></tr><tr><td> (exn i/o file)
+
+Signaled on file-related errors.
+
+</td></tr><tr><td> (exn i/o net)
+
+Signaled on network errors.
+
+</td></tr><tr><td> (exn bounds)
+
+Signaled on errors caused by accessing non-existent elements of a collection.
+
+</td></tr><tr><td> (exn runtime)
+
+Signaled on low-level runtime-system error-situations.
+
+</td></tr><tr><td> (exn runtime limit)
+
+Signaled when an internal limit is exceeded (like running out of memory).
+
+</td></tr><tr><td> (exn match)
+
+Signaled on errors raised by failed matches (see the section on {{match}}).
+
+</td></tr><tr><td> (exn syntax)
+
+Signaled on syntax errors.
+
+</td></tr><tr><td> (exn breakpoint)
+
+Signaled when a breakpoint is reached.
+
+</td></tr>
+
+</table>
+
+Notes:
+
+* All error-exceptions (of the kind {{exn}}) are non-continuable.
+
+* Error-exceptions of the {{exn}} kind have additional {{arguments}} and
+{{location}} properties that contain the arguments passed to the
+exception-handler and the name of the procedure where the error occurred (if
+available).
+
+* When the {{posix}} unit is available and used, then a user-interrupt
+({{signal/int}}) signals an exception of the kind {{user-interrupt}}.
+
+* the procedure {{condition-property-accessor}} accepts an optional third
+argument. If the condition does not have a value for the desired property and
+if the optional argument is given, no error is signaled and the accessor
+returns the third argument.
+
+* In composite conditions all properties are currently collected in a single
+property-list, so in the case that to conditions have the same named property,
+only one will be visible.
+
+
+
+=== Environment information and system interface
+
+
+
+==== argv
+
+<procedure>(argv)</procedure>
+
+Return a list of all supplied command-line arguments. The first item in
+the list is a string containing the name of the executing program. The
+other items are the arguments passed to the application. This list is
+freshly created on every invocation of {{(argv)}}. It depends on
+the host-shell whether arguments are expanded ('globbed') or not.
+
+
+==== exit
+
+<procedure>(exit [CODE])</procedure>
+
+Exit the running process and return exit-code, which defaults to 0
+(Invokes {{exit-handler}}).
+
+Note that pending {{dynamic-wind}} thunks are ''not'' invoked when exiting your program in this way.
+
+==== build-platform
+
+<procedure>(build-platform)</procedure>
+
+Returns a symbol specifying the toolset which has been used for
+building the executing system, which is one of the following:
+
+ cygwin
+ mingw32
+ gnu
+ intel
+ unknown
+
+
+==== chicken-version
+
+<procedure>(chicken-version [FULL])</procedure>
+
+Returns a string containing the version number of the CHICKEN runtime
+system. If the optional argument {{FULL}} is given and true, then
+a full version string is returned.
+
+
+==== errno
+
+<procedure>(errno)</procedure>
+
+Returns the error code of the last system call.
+
+
+==== get-environment-variable
+
+ [procedure] (get-environment-variable STRING)
+ [procedure] (getenv STRING)
+
+Returns the value of the environment variable {{STRING}} or
+{{#f}} if that variable is not defined. See also [[http://srfi.schemers.org/srfi-98/|SRFI-98]].
+{{getenv}} is an alias for {{get-environment-variable}}.
+
+
+==== machine-byte-order
+
+<procedure>(machine-byte-order)</procedure>
+
+Returns the symbol {{little-endian}} or {{big-endian}}, depending on the
+machine's byte-order.
+
+
+==== machine-type
+
+<procedure>(machine-type)</procedure>
+
+Returns a symbol specifying the processor on which this process is
+currently running, which is one of the following:
+
+ alpha
+ mips
+ hppa
+ ultrasparc
+ sparc
+ ppc
+ ppc64
+ ia64
+ x86
+ x86-64
+ unknown
+
+
+==== on-exit
+
+<procedure>(on-exit THUNK)</procedure>
+
+Schedules the zero-argument procedures {{THUNK}} to be executed before
+the process exits, either explicitly via {{exit}} or implicitly after execution
+of the last top-level form. Note that finalizers for unreferenced finalized
+data are run before exit procedures.
+
+
+==== software-type
+
+<procedure>(software-type)</procedure>
+
+Returns a symbol specifying the operating system on which this process
+is currently running, which is one of the following:
+
+ windows
+ unix
+ macos
+ ecos
+ unknown
+
+
+==== software-version
+
+<procedure>(software-version)</procedure>
+
+Returns a symbol specifying the operating system version on which this
+process is currently running, which is one of the following:
+
+ linux
+ freebsd
+ netbsd
+ openbsd
+ macosx
+ hpux
+ solaris
+ sunos
+ unknown
+
+
+
+==== c-runtime
+
+<procedure>(c-runtime)</procedure>
+
+Returns a symbol that designates what kind of C runtime library has been linked
+with this version of the Chicken libraries. Possible return values are
+{{static}}, {{dynamic}} or {{unknown}}. On systems not compiled with the
+Microsoft C compiler, {{c-runtime}} always returns {{unknown}}.
+
+
+==== system
+
+<procedure>(system STRING)</procedure>
+
+Execute shell command. The functionality offered by this procedure
+depends on the capabilities of the host shell. If the forking of a subprocess
+failed, an exception is raised. Otherwise the return status of the
+subprocess is returned unaltered.
+
+
+On a UNIX system, that value is the raw return value of waitpid(2), which contains signal, core dump and exit status. It is 0 on success. To pull out the signal number or exit status portably requires POSIX calls, but in a pinch you can use something like this:
+
+ ;; Returns two values: #t if the process exited normally or #f otherwise;
+ ;; and either the exit status, or the signal number if terminated via signal.
+ (define (process-status rc)
+ (define (wait-signaled? x) (not (= 0 (bitwise-and x 127))))
+ (define (wait-signal x) (bitwise-and x 127))
+ (define (wait-exit-status x) (arithmetic-shift x -8))
+ (if (wait-signaled? rc)
+ (values #f (wait-signal rc))
+ (values #t (wait-exit-status rc))))
+
+ #;> (process-status (system "exit 42"))
+ #t
+ 42
+
+=== Execution time
+
+
+
+==== cpu-time
+
+<procedure>(cpu-time)</procedure>
+
+Returns the used CPU time of the current process in milliseconds as
+two values: the time spent in user code, and the time spent in system
+code. On platforms where user and system time can not be differentiated,
+system time will be always be 0.
+
+
+==== current-milliseconds
+
+<procedure>(current-milliseconds)</procedure>
+
+Returns the number of milliseconds since process- or machine startup.
+
+
+==== current-seconds
+
+<procedure>(current-seconds)</procedure>
+
+Returns the number of seconds since midnight, Jan. 1, 1970.
+
+
+==== current-gc-milliseconds
+
+<procedure>(current-gc-milliseconds)</procedure>
+
+Returns the number of milliseconds spent in major garbage collections since
+the last call of {{current-gc-milliseconds}} and returns an exact
+integer.
+
+
+
+=== Interrupts and error-handling
+
+
+
+==== enable-warnings
+
+<procedure>(enable-warnings [BOOL])</procedure>
+
+Enables or disables warnings, depending on wether {{BOOL}} is true or false.
+If called with no arguments, this procedure returns {{#t}} if warnings are
+currently enabled, or {{#f}} otherwise. Note that this is not a parameter.
+The current state (whether warnings are enabled or disabled) is global and not
+thread-local.
+
+
+==== error
+
+<procedure>(error [LOCATION] [STRING] EXP ...)</procedure>
+
+Prints error message, writes all extra arguments to the
+value of {{(current-error-port)}} and invokes the
+current exception-handler. This conforms to
+[[http://srfi.schemers.org/srfi-23/srfi-23.html|SRFI-23]].
+If {{LOCATION}} is given and a symbol, it specifies the ''location'' (the name
+of the procedure) where the error occurred.
+
+
+
+==== get-call-chain
+
+<procedure>(get-call-chain [START [THREAD]])</procedure>
+
+Returns a list with the call history. Backtrace information
+is only generated in code compiled without {{-no-trace}} and evaluated code.
+If the optional argument {{START}} is given, the backtrace starts
+at this offset, i.e. when {{START}} is 1, the next to last trace-entry
+is printed, and so on. If the optional argument {{THREAD}} is given, then
+the call-chain will only be constructed for calls performed by this thread.
+
+
+
+==== print-call-chain
+
+<procedure>(print-call-chain [PORT [START [THREAD]]])</procedure>
+
+Prints a backtrace of the procedure call history to {{PORT}},
+which defaults to {{(current-output-port)}}.
+
+
+==== print-error-message
+
+<procedure>(print-error-message EXN [PORT [STRING]])</procedure>
+
+Prints an appropriate error message to {{PORT}} (which defaults to the
+value of {{(current-output-port)}} for the object {{EXN}}.
+{{EXN}} may be a condition, a string or any other object.
+If the optional argument {{STRING}} is given, it is printed before the
+error-message. {{STRING}} defaults to {{"Error:"}}.
+
+
+
+==== procedure-information
+
+<procedure>(procedure-information PROC)</procedure>
+
+Returns an s-expression with debug information for the procedure {{PROC}}, or
+{{#f}}, if {{PROC}} has no associated debug information.
+
+
+==== reset
+
+<procedure>(reset)</procedure>
+
+Reset program (Invokes {{reset-handler}}).
+
+
+==== warning
+
+<procedure>(warning STRING EXP ...)</procedure>
+
+Displays a warning message (if warnings are enabled with {{enable-warnings}}) and
+continues execution.
+
+
+==== singlestep
+
+<procedure>(singlestep THUNK)</procedure>
+
+Executes the code in the zero-procedure {{THUNK}} in single-stepping mode.
+
+
+
+=== Garbage collection
+
+
+
+==== gc
+
+<procedure>(gc [FLAG])</procedure>
+
+Invokes a garbage-collection and returns the number of free bytes in the heap.
+The flag specifies whether a minor ({{#f}}) or major ({{#t}}) GC is to be
+triggered. If no argument is given, {{#t}} is assumed. An explicit {{#t}}
+argument will cause all pending finalizers to be executed.
+
+==== memory-statistics
+
+<procedure>(memory-statistics)</procedure>
+
+Performs a major garbage collection and returns a three element vector
+containing the total heap size in bytes, the number of bytes currently
+used and the size of the nursery (the first heap generation). Note
+that the actual heap is actually twice the size given in the heap size,
+because CHICKEN uses a copying semi-space collector.
+
+
+==== set-finalizer!
+
+<procedure>(set-finalizer! X PROC)</procedure>
+
+Registers a procedure of one argument {{PROC}}, that will be
+called as soon as the non-immediate data object {{X}} is about to
+be garbage-collected (with that object as its argument). Note that
+the finalizer will '''not''' be called while interrupts are disabled.
+This procedure returns {{X}}.
+
+Finalizers are invoked asynchronously, in the thread that happens
+to be currently running.
+
+
+==== set-gc-report!
+
+<procedure>(set-gc-report! FLAG)</procedure>
+
+Print statistics after every GC, depending on {{FLAG}}. A value of
+{{#t}} shows statistics after every major GC. A true value different
+from {{#t}} shows statistics after every minor GC. {{#f}}
+switches statistics off.
+
+
+
+
+
+=== Other control structures
+
+
+
+==== promise?
+
+<procedure>(promise? X)</procedure>
+
+Returns {{#t}} if {{X}} is a promise returned by {{delay}}, or
+{{#f}} otherwise.
+
+
+
+=== String utilities
+
+
+==== reverse-list->string
+
+<procedure>(reverse-list->string LIST)</procedure>
+
+Returns a string with the characters in {{LIST}} in reverse order. This is
+equivalent to {{(list->string (reverse LIST))}}, but much more efficient.
+
+
+
+=== Generating uninterned symbols
+
+==== gensym
+
+<procedure>(gensym [STRING-OR-SYMBOL])</procedure>
+
+Returns a newly created uninterned symbol. If an argument is provided,
+the new symbol is prefixed with that argument.
+
+
+==== string->uninterned-symbol
+
+<procedure>(string->uninterned-symbol STRING)</procedure>
+
+Returns a newly created, unique symbol with the name {{STRING}}.
+
+
+
+=== Standard Input/Output
+
+==== port?
+
+<procedure>(port? X)</procedure>
+
+Returns {{#t}} if {{X}} is a port object or {{#f}}
+otherwise.
+
+
+==== print
+
+<procedure>(print [EXP1 ...])</procedure>
+
+Outputs the optional arguments {{EXP1 ...}} using {{display}} and
+writes a newline character to the port that is the value of
+{{(current-output-port)}}. Returns {{(void)}}.
+
+
+==== print*
+
+<procedure>(print* [EXP1 ...])</procedure>
+
+Similar to {{print}}, but does not output a terminating newline
+character and performs a {{flush-output}} after writing its arguments.
+
+
+
+
+=== User-defined named characters
+
+==== char-name
+
+<procedure>(char-name SYMBOL-OR-CHAR [CHAR])</procedure>
+
+This procedure can be used to inquire about character names or to
+define new ones. With a single argument the behavior is as follows:
+If {{SYMBOL-OR-CHAR}} is a symbol, then {{char-name}} returns
+the character with this name, or {{#f}} if no character is defined
+under this name. If {{SYMBOL-OR-CHAR}} is a character, then the
+name of the character is returned as a symbol, or {{#f}} if the
+character has no associated name.
+
+If the optional argument {{CHAR}} is provided, then
+{{SYMBOL-OR-CHAR}} should be a symbol that will be the new name of
+the given character. If multiple names designate the same character,
+then the {{write}} will use the character name that was defined last.
+
+<enscript highlight=scheme>
+(char-name 'space) ==> #\space
+(char-name #\space) ==> space
+(char-name 'bell) ==> #f
+(char-name (integer->char 7)) ==> #f
+(char-name 'bell (integer->char 7))
+(char-name 'bell) ==> #\bell
+(char->integer (char-name 'bell)) ==> 7
+</enscript>
+
+
+
+=== Blobs
+
+"blobs" are collections of unstructured bytes. You can't do much
+with them, but allow conversion to and from SRFI-4 number vectors.
+
+==== make-blob
+
+<procedure>(make-blob SIZE)</procedure>
+
+Returns a blob object of {{SIZE}} bytes, aligned on an 8-byte boundary,
+uninitialized.
+
+==== blob?
+
+<procedure>(blob? X)</procedure>
+
+Returns {{#t}} if {{X}} is a blob object, or
+{{#f}} otherwise.
+
+==== blob-size
+
+<procedure>(blob-size BLOB)</procedure>
+
+Returns the number of bytes in {{BLOB}}.
+
+==== blob->string
+
+<procedure>(blob->string BLOB)</procedure>
+
+Returns a string with the contents of {{BLOB}}.
+
+==== string->blob
+
+<procedure>(string->blob STRING)</procedure>
+
+Returns a blob with the contents of {{STRING}}.
+
+==== blob=?
+
+<procedure>(blob=? BLOB1 BLOB2)</procedure>
+
+Returns {{#t}} if the two argument blobs are of the same
+size and have the same content.
+
+
+
+=== Vectors
+
+==== vector-copy!
+
+<procedure>(vector-copy! VECTOR1 VECTOR2 [COUNT])</procedure>
+
+Copies contents of {{VECTOR1}} into {{VECTOR2}}. If the
+argument {{COUNT}} is given, it specifies the maximal number of
+elements to be copied. If not given, the minimum of the lengths of the
+argument vectors is copied.
+
+Exceptions: {{(exn bounds)}}
+
+
+==== vector-resize
+
+<procedure>(vector-resize VECTOR N [INIT])</procedure>
+
+Creates and returns a new vector with the contents of {{VECTOR}} and length
+{{N}}. If {{N}} is greater than the original length of {{VECTOR}}, then all
+additional items are initialized to {{INIT}}. If {{INIT}} is not specified, the
+contents are initialized to some unspecified value.
+
+
+
+=== The unspecified value
+
+==== void
+
+<procedure>(void)</procedure>
+
+Returns an unspecified value.
+
+
+
+=== Continuations
+
+==== call/cc
+
+<procedure>(call/cc PROCEDURE)</procedure>
+
+An alias for {{call-with-current-continuation}}.
+
+
+==== continuation-capture
+
+<procedure>(continuation-capture PROCEDURE)</procedure>
+
+Creates a continuation object representing the current continuation and
+tail-calls {{PROCEDURE}} with this continuation as the single argument.
+
+More information about this continuation API can be found in the paper
+[[http://repository.readscheme.org/ftp/papers/sw2001/feeley.pdf]] ''A Better
+API for first class Continuations'' by Marc Feeley.
+
+
+==== continuation?
+
+<procedure>(continuation? X)</procedure>
+
+Returns {{#t}} if {{X}} is a continuation object, or {{#f}} otherwise. Please
+note that this applies only to continuations created by the Continuation API,
+but not by call/cc, i.e.: {{(call-with-current-continuation continuation?)}}
+returns {{#f}}, whereas {{(continuation-capture continuation?)}} returns
+{{#t}}.
+
+
+==== continuation-graft
+
+<procedure>(continuation-graft CONT THUNK)</procedure>
+
+Calls the procedure {{THUNK}} with no arguments and the implicit continuation
+{{CONT}}.
+
+
+==== continuation-return
+
+<procedure>(continuation-return CONT VALUE ...)</procedure>
+
+Returns the value(s) to the continuation {{CONT}}. {{continuation-return}} could
+be implemented like this:
+
+<enscript highlight=scheme>
+(define (continuation-return k . vals)
+ (continuation-graft
+ k
+ (lambda () (apply values vals)) ) )
+</enscript>
+
+
+
+=== Setters
+
+SRFI-17 is fully implemented. For more information see:
+[[http://srfi.schemers.org/srfi-17/srfi-17.html|SRFI-17]].
+
+==== setter
+
+<procedure>(setter PROCEDURE)</procedure>
+
+Returns the setter-procedure of {{PROCEDURE}}, or signals an error if
+{{PROCEDURE}} has no associated setter-procedure.
+
+Note that {{(set! (setter PROC) ...)}} for a procedure that has no associated
+setter procedure yet is a very slow operation (the old procedure is replaced by
+a modified copy, which involves a garbage collection).
+
+
+==== getter-with-setter
+
+<procedure>(getter-with-setter GETTER SETTER)</procedure>
+
+Returns a copy of the procedure {{GETTER}} with the associated setter procedure
+{{SETTER}}. Contrary to the SRFI specification, the setter of the returned
+procedure may be changed.
+
+
+
+=== Reader extensions
+
+==== define-reader-ctor
+
+<procedure>(define-reader-ctor SYMBOL PROC)</procedure>
+
+Define new read-time constructor for {{#,}} read syntax. For further information, see
+the documentation for [[http://srfi.schemers.org/srfi-10/srfi-10.html|SRFI-10]].
+
+
+==== set-read-syntax!
+
+<procedure>(set-read-syntax! CHAR-OR-SYMBOL PROC)</procedure>
+
+When the reader encounters the non-whitespace character {{CHAR}} while reading
+an expression from a given port, then the procedure {{PROC}} will be called with
+that port as its argument. The procedure should return a value that will be returned
+to the reader:
+
+<enscript highlight=scheme>
+ ; A simple RGB color syntax:
+
+ (set-read-syntax! #\%
+ (lambda (port)
+ (apply vector
+ (map (cut string->number <> 16)
+ (string-chop (read-string 6 port) 2) ) ) ) )
+
+ (with-input-from-string "(1 2 %f0f0f0 3)" read)
+ ; ==> (1 2 #(240 240 240) 3)
+</enscript>
+
+If {{CHAR-OR-SYMBOL}} is a symbol, then a so-called ''read-mark'' handler is defined.
+In that case the handler procedure will be called when a character-sequence of the
+form
+
+ #!SYMBOL
+
+is encountered.
+
+You can undo special handling of read-syntax by passing {{#f}} as the second argument
+(if the syntax was previously defined via {{set-read-syntax!}}).
+
+Note that all of CHICKEN's special non-standard read-syntax is handled directly by the reader.
+To disable built-in read-syntax, define a handler that triggers an error (for example).
+
+
+==== set-sharp-read-syntax!
+
+<procedure>(set-sharp-read-syntax! CHAR-OR-SYMBOL PROC)</procedure>
+
+Similar to {{set-read-syntax!}}, but allows defining new {{#<CHAR> ...}} reader syntax.
+If the first argument is a symbol, then this procedure is equivalent to {{set-read-syntax!}}.
+
+
+==== set-parameterized-read-syntax!
+
+<procedure>(set-parameterized-read-syntax! CHAR-OR-SYMBOL PROC)</procedure>
+
+Similar to {{set-sharp-read-syntax!}}, but intended for defining reader syntax of the
+form {{#<NUMBER><CHAR> ...}}. The handler procedure {{PROC}} will be called with two
+arguments: the input port and the number preceding
+the dispatching character.
+If the first argument is a symbol, then this procedure is equivalent to {{set-read-syntax!}}.
+
+
+==== copy-read-table
+
+<procedure>(copy-read-table READ-TABLE)</procedure>
+
+Returns a copy of the given read-table. You can access the currently active read-table
+with {{(current-read-table)}}.
+
+
+=== Property lists
+
+As in other Lisp dialects, CHICKEN supports "property lists" associated with symbols.
+Properties are accessible via a key that can be any kind of value but which will
+be compared using {{eq?}}.
+
+==== get
+
+ [procedure] (get SYMBOL PROPERTY [DEFAULT])
+
+Returns the value stored under the key {{PROPERTY}} in the property
+list of {{SYMBOL}}. If no such property is stored, returns
+{{DEFAULT}}. The {{DEFAULT}} is optional and defaults to {{#f}}.
+
+==== put!
+
+ [procedure] (put! SYMBOL PROPERTY VALUE)
+ [setter] (set! (get SYMBOL PROPERTY) VALUE)
+
+Stores {{VALUE}} under the key {{PROPERTY}} in the property list of
+{{SYMBOL}} replacing any previously stored value.
+
+==== remprop!
+
+ [procedure] (remprop! SYMBOL PROPERTY)
+
+Deletes the first property matching the key {{PROPERTY}} in the property list
+of {{SYMBOL}}. Returns {{#t}} when a deletion performed, and {{#f}} otherwise.
+
+==== symbol-plist
+
+ [procedure] (symbol-plist SYMBOL)
+ [setter] (set! (symbol-plist SYMBOL) LST)
+
+Returns the property list of {{SYMBOL}} or sets it.
+
+==== get-properties
+
+ [procedure] (get-properties SYMBOL PROPERTIES)
+
+Searches the property list of {{SYMBOL}} for the first property with a key in
+the list {{PROPERTIES}}. Returns 3 values: the matching property key, value,
+and the tail of property list after the matching property. When no match found
+all values are {{#f}}.
+
+{{PROPERTIES}} may also be an atom, in which case it is treated as a list of
+one element.
+
+---
+Previous: [[Parameters]]
+
+Next: [[Unit eval]]
diff --git a/manual/Unit lolevel b/manual/Unit lolevel
new file mode 100644
index 00000000..ff57013d
--- /dev/null
+++ b/manual/Unit lolevel
@@ -0,0 +1,794 @@
+[[tags: manual internals]]
+[[toc:]]
+
+
+== Unit lolevel
+
+This unit provides a number of handy low-level operations. '''Use
+at your own risk.'''
+
+This unit uses the {{srfi-4}} and {{extras}} units.
+
+
+
+=== Foreign pointers
+
+The abstract class of ''pointer'' is divided into 2 categories:
+
+; ''pointer object'' : is a foreign pointer object, a tagged foreign pointer object (see {{Tagged pointers}}), or a SWIG-pointer.
+
+; ''pointer-like object'' " is a closure, port, locative (see {{Locatives}}, or a pointer object.
+
+SWIG-pointers are currently an issue due to "bitrot" in the SWIG Chicken
+translator. While they are considered a pointer object unexpected results are
+possible.
+
+Note that Locatives, while technically pointers, are not considered a ''pointer
+object'', but a ''pointer-like object''. The distinction is artificial.
+
+
+==== address->pointer
+
+ [procedure] (address->pointer ADDRESS)
+
+Creates a new foreign pointer object initialized to point to the address
+given in the integer {{ADDRESS}}.
+
+
+==== allocate
+
+ [procedure] (allocate BYTES)
+
+Returns a foreign pointer object to a freshly allocated region of static
+memory.
+
+This procedure could be defined as follows:
+
+<enscript highlight=scheme>
+(define allocate (foreign-lambda c-pointer "malloc" integer))
+</enscript>
+
+
+==== free
+
+ [procedure] (free POINTER)
+
+Frees the memory pointed to by {{POINTER}}.
+
+This procedure could be defined as follows:
+
+<enscript highlight=scheme>
+(define free (foreign-lambda void "free" c-pointer))
+</enscript>
+
+
+==== null-pointer
+
+ [procedure] (null-pointer)
+
+Another way to say {{(address->pointer 0)}}.
+
+
+==== null-pointer?
+
+ [procedure] (null-pointer? POINTER*)
+
+Returns {{#t}} if the pointer-like object {{POINTER*}} contains a {{NULL}} pointer,
+or {{#f}} otherwise.
+
+
+==== object->pointer
+
+ [procedure] (object->pointer X)
+
+Returns a foreign pointer object pointing to the Scheme object X, which should
+be a non-immediate object. ("foreign" here is a bit of a misnomer.)
+
+Note that data in the garbage collected heap moves during garbage collection.
+
+
+==== pointer->object
+
+ [procedure] (pointer->object POINTER)
+
+Returns the Scheme object pointed to by the pointer object {{POINTER}}.
+
+Whether the {{POINTER}} actually points to a Scheme object is not guaranteed. Use
+at your own risk.
+
+==== pointer?
+
+ [procedure] (pointer? X)
+
+Returns {{#t}} if {{X}} is a pointer object, or {{#f}} otherwise.
+
+
+==== pointer-like?
+
+ [procedure] (pointer-like? X)
+
+Returns {{#t}} if {{X}} is a pointer-like object, or {{#f}} otherwise.
+
+
+==== pointer=?
+
+ [procedure] (pointer=? POINTER*1 POINTER*2)
+
+Returns {{#t}} if the pointer-like objects {{POINTER*1}} and {{POINTER*2}} point
+to the same address, or {{#f}} otherwise.
+
+
+==== pointer->address
+
+ [procedure] (pointer->address POINTER*)
+
+Returns the address, to which the pointer-like object {{POINTER*}} points.
+
+
+==== pointer-offset
+
+ [procedure] (pointer-offset POINTER* N)
+
+Returns a new foreign pointer object representing the pointer-like object
+{{POINTER*}} address value increased by the byte-offset {{N}}.
+
+Use of anything other than a pointer object as an argument is questionable.
+
+
+==== align-to-word
+
+ [procedure] (align-to-word POINTER*-OR-INT)
+
+Accepts either a pointer-like object or an integer as the argument and returns
+a new foreign pointer or integer aligned to the native word size of the host
+platform.
+
+Use of anything other than an integer or pointer object as an argument is
+questionable.
+
+
+
+=== SRFI-4 Foreign pointers
+
+These procedures actually accept a pointer-like object as the {{POINTER}} argument.
+However, as usual, use of anything other than a pointer object is questionable.
+
+==== pointer-u8-ref
+
+ [procedure] (pointer-u8-ref POINTER)
+
+Returns the unsigned byte at the address designated by {{POINTER}}.
+
+
+==== pointer-s8-ref
+
+ [procedure] (pointer-s8-ref POINTER)
+
+Returns the signed byte at the address designated by {{POINTER}}.
+
+
+==== pointer-u16-ref
+
+ [procedure] (pointer-u16-ref POINTER)
+
+Returns the unsigned 16-bit integer at the address designated by {{POINTER}}.
+
+
+==== pointer-s16-ref
+
+ [procedure] (pointer-s16-ref POINTER)
+
+Returns the signed 16-bit integer at the address designated by {{POINTER}}.
+
+
+==== pointer-u32-ref
+
+ [procedure] (pointer-u32-ref POINTER)
+
+Returns the unsigned 32-bit integer at the address designated by {{POINTER}}.
+
+
+==== pointer-s32-ref
+
+ [procedure] (pointer-s32-ref POINTER)
+
+Returns the signed 32-bit integer at the address designated by {{POINTER}}.
+
+
+==== pointer-f32-ref
+
+ [procedure] (pointer-f32-ref POINTER)
+
+Returns the 32-bit float at the address designated by {{POINTER}}.
+
+
+==== pointer-f64-ref
+
+ [procedure] (pointer-f64-ref POINTER)
+
+Returns the 64-bit double at the address designated by {{POINTER}}.
+
+
+==== pointer-u8-set!
+
+ [procedure] (pointer-u8-set! POINTER N)
+ [procedure] (set! (pointer-u8-ref POINTER) N)
+
+Stores the unsigned byte {{N}} at the address designated by {{POINTER}}.
+
+
+==== pointer-s8-set!
+
+ [procedure] (pointer-s8-set! POINTER N)
+ [procedure] (set! (pointer-s8-ref POINTER) N)
+
+Stores the signed byte {{N}} at the address designated by {{POINTER}}.
+
+
+==== pointer-u16-set!
+
+ [procedure] (pointer-u16-set! POINTER N)
+ [procedure] (set! (pointer-u16-ref POINTER) N)
+
+Stores the unsigned 16-bit integer {{N}} at the address designated by {{POINTER}}.
+
+
+==== pointer-s16-set!
+
+ [procedure] (pointer-s16-set! POINTER N)
+ [procedure] (set! (pointer-s16-ref POINTER) N)
+
+Stores the signed 16-bit integer {{N}} at the address designated by {{POINTER}}.
+
+
+==== pointer-u32-set!
+
+ [procedure] (pointer-u32-set! POINTER N)
+ [procedure] (set! (pointer-u32-ref POINTER) N)
+
+Stores the unsigned 32-bit integer {{N}} at the address designated by {{POINTER}}.
+
+
+==== pointer-s32-set!
+
+ [procedure] (pointer-s32-set! POINTER N)
+ [procedure] (set! (pointer-s32-ref POINTER) N)
+
+Stores the 32-bit integer {{N}} at the address designated by {{POINTER}}.
+
+
+==== pointer-f32-set!
+
+ [procedure] (pointer-f32-set! POINTER N)
+ [procedure] (set! (pointer-f32-ref POINTER) N)
+
+Stores the 32-bit floating-point number {{N}} at the address designated by {{POINTER}}.
+
+
+==== pointer-f64-set!
+
+ [procedure] (pointer-f64-set! POINTER N)
+ [procedure] (set! (pointer-f64-ref POINTER) N)
+
+Stores the 64-bit floating-point number {{N}} at the address designated by {{POINTER}}.
+
+
+
+=== Tagged pointers
+
+''Tagged'' pointers are foreign pointer objects with an extra tag object.
+
+
+==== tag-pointer
+
+ [procedure] (tag-pointer POINTER* TAG)
+
+Creates a new tagged foreign pointer object from the pointer-like object
+{{POINTER*}} with the tag {{TAG}}, which may an arbitrary Scheme object.
+
+Use of anything other than a pointer object is questionable.
+
+==== tagged-pointer?
+
+ [procedure] (tagged-pointer? X [TAG])
+
+Returns {{#t}} if {{X}} is a tagged foreign pointer object, or {{#f}} otherwise.
+
+Further, returns {{#t}} when {{X}} has the optional tag {{TAG}} (using an
+{{equal?}} comparison), or {{#f}} otherwise.
+
+
+==== pointer-tag
+
+ [procedure] (pointer-tag POINTER*)
+
+If {{POINTER}} is a tagged foreign pointer object, its tag is returned. If {{POINTER*}}
+is any other kind of pointer-like object {{#f}} is returned. Otherwise an
+error is signalled.
+
+
+
+=== Locatives
+
+
+A ''locative'' is an object that points to an element of a containing object,
+much like a ''pointer'' in low-level, imperative programming languages like ''C''. The element can
+be accessed and changed indirectly, by performing access or change operations
+on the locative. The container object can be computed by calling the
+{{location->object}} procedure.
+
+Locatives may be passed to foreign procedures that expect pointer arguments.
+The effect of creating locatives for evicted data (see {{object-evict}}) is undefined.
+
+
+==== make-locative
+
+ [procedure] (make-locative OBJ [INDEX])
+
+Creates a locative that refers to the element of the non-immediate object
+{{OBJ}} at position {{INDEX}}. {{OBJ}} may be a vector, pair, string, blob,
+SRFI-4 number-vector, or record structure. {{INDEX}} should be a fixnum.
+{{INDEX}} defaults to 0.
+
+
+==== make-weak-locative
+
+ [procedure] (make-weak-locative OBJ [INDEX])
+
+Creates a ''weak'' locative. Even though the locative refers to an element of a container object,
+the container object will still be reclaimed by garbage collection if no other references
+to it exist.
+
+
+==== locative?
+
+ [procedure] (locative? X)
+
+Returns {{#t}} if {{X}} is a locative, or {{#f}} otherwise.
+
+
+==== locative-ref
+
+ [procedure] (locative-ref LOC)
+
+Returns the element to which the locative {{LOC}} refers. If the containing
+object has been reclaimed by garbage collection, an error is signalled.
+
+ (locative-ref (make-locative "abc" 1)) ==> #\b
+
+==== locative-set!
+
+ [procedure] (locative-set! LOC X)
+ [procedure] (set! (locative-ref LOC) X)
+
+Changes the element to which the locative {{LOC}} refers to {{X}}.
+If the containing
+object has been reclaimed by garbage collection, an error is signalled.
+
+
+==== locative->object
+
+ [procedure] (locative->object LOC)
+
+Returns the object that contains the element referred to by {{LOC}} or
+{{#f}} if the container has been reclaimed by garbage collection.
+
+ (locative->object (make-locative "abc" 1)) ==> "abc"
+
+
+
+=== Extending procedures with data
+
+
+==== extend-procedure
+
+ [procedure] (extend-procedure PROCEDURE X)
+
+Returns a copy of the procedure {{PROCEDURE}} which contains an additional data
+slot initialized to {{X}}. If {{PROCEDURE}} is already an extended procedure,
+then its data slot is changed to contain {{X}} and the same procedure is
+returned. Signals an error when {{PROCEDURE}} is not a procedure.
+
+
+==== extended-procedure?
+
+ [procedure] (extended-procedure? PROCEDURE)
+
+Returns {{#t}} if {{PROCEDURE}} is an extended procedure,
+or {{#f}} otherwise.
+
+
+==== procedure-data
+
+ [procedure] (procedure-data PROCEDURE)
+
+Returns the data object contained in the extended procedure {{PROCEDURE}}, or
+{{#f}} if it is not an extended procedure.
+
+
+==== set-procedure-data!
+
+ [procedure] (set-procedure-data! PROCEDURE X)
+
+Changes the data object contained in the extended procedure {{PROCEDURE}} to
+{{X}}. Signals an error when {{PROCEDURE}} is not an extended procedure.
+
+<enscript highlight=scheme>
+(define foo
+ (letrec ((f (lambda () (procedure-data x)))
+ (x #f) )
+ (set! x (extend-procedure f 123))
+ x) )
+(foo) ==> 123
+(set-procedure-data! foo 'hello)
+(foo) ==> hello
+</enscript>
+
+
+
+=== Low-level data access
+
+These procedures operate with what are known as {{vector-like objects}}. A
+{{vector-like object}} is a vector, record structure, pair, symbol or keyword.
+
+Note that strings and blobs are not considered vector-like.
+
+
+==== vector-like?
+
+ [procedure] (vector-like? X)
+
+Returns {{#t}} when {{X}} is a vector-like object, returns {{#f}}
+otherwise.
+
+
+==== block-ref
+
+ [procedure] (block-ref VECTOR* INDEX)
+
+Returns the contents of the {{INDEX}}th slot of the vector-like object
+{{VECTOR*}}.
+
+
+==== block-set!
+
+ [procedure] (block-set! VECTOR* INDEX X)
+ [procedure] (set! (block-ref VECTOR* INDEX) X)
+
+Sets the contents of the {{INDEX}}th slot of the vector-like object {{VECTOR*}}
+to the value of {{X}}.
+
+==== number-of-slots
+
+ [procedure] (number-of-slots VECTOR*)
+
+Returns the number of slots that the vector-like object {{VECTOR*}} contains.
+
+
+==== number-of-bytes
+
+ [procedure] (number-of-bytes BLOCK)
+
+Returns the number of bytes that the object {{BLOCK}} contains. {{BLOCK}} may
+be any non-immediate value.
+
+
+==== object-copy
+
+ [procedure] (object-copy X)
+
+Copies {{X}} recursively and returns the fresh copy. Objects allocated in
+static memory are copied back into garbage collected storage.
+
+
+==== move-memory!
+
+ [procedure] (move-memory! FROM TO [BYTES [FROM-OFFSET [TO-OFFSET]])
+
+Copies {{BYTES}} bytes of memory from {{FROM}} to {{TO}}. {{FROM}} and {{TO}}
+may be strings, blobs, SRFI-4 number-vectors (see: @ref{Unit srfi-4}), memory
+mapped files, foreign pointers (as obtained from a call to {{foreign-lambda}},
+for example), tagged-pointers or locatives. if {{BYTES}} is not given and the
+size of the source or destination operand is known then the maximal number of
+bytes will be copied. Moving memory to the storage returned by locatives will
+cause havoc, if the locative refers to containers of non-immediate data, like
+vectors or pairs.
+
+The additional fourth and fifth argument specify starting offsets (in bytes)
+for the source and destination arguments.
+
+Signals an error if any of the above constraints is violated.
+
+
+
+=== Data in unmanaged memory
+
+
+==== object-evict
+
+ [procedure] (object-evict X [ALLOCATOR])
+
+Copies the object {{X}} recursively into the memory pointed to by the foreign
+pointer object returned by {{ALLOCATOR}}, which should be a procedure of a
+single argument (the number of bytes to allocate). The freshly copied object is
+returned.
+
+This facility allows moving arbitrary objects into static memory, but care
+should be taken when mutating evicted data: setting slots in evicted
+vector-like objects to non-evicted data is not allowed. It '''is''' possible to
+set characters/bytes in evicted strings or byte-vectors, though. It is
+advisable '''not''' to evict ports, because they might be mutated by certain
+file-operations. {{object-evict}} is able to handle circular and shared
+structures, but evicted symbols are no longer unique: a fresh copy of the
+symbol is created, so
+
+<enscript highlight=scheme>
+(define x 'foo)
+(define y (object-evict 'foo))
+y ==> foo
+(eq? x y) ==> #f
+(define z (object-evict '(bar bar)))
+(eq? (car z) (cadr z)) ==> #t
+</enscript>
+
+The {{ALLOCATOR}} defaults to {{allocate}}.
+
+
+==== object-evict-to-location
+
+ [procedure] (object-evict-to-location X POINTER* [LIMIT])
+
+As {{object-evict}} but moves the object at the address pointed to by
+the pointer-like object {{POINTER*}}. If the number of copied bytes exceeds
+the optional {{LIMIT}} then an error is signalled (specifically a composite
+condition of types {{exn}} and {{evict}}. The latter provides
+a {{limit}} property which holds the exceeded limit. Two values are
+returned: the evicted object and a new pointer pointing to the first
+free address after the evicted object.
+
+Use of anything other than a pointer object as the {{POINTER*}} argument is
+questionable.
+
+==== object-evicted?
+
+ [procedure] (object-evicted? X)
+
+Returns {{#t}} if {{X}} is a non-immediate evicted data object, or {{#f}}
+otherwise.
+
+
+==== object-release
+
+ [procedure] (object-release X [RELEASER])
+
+Frees memory occupied by the evicted object {{X}} recursively.
+{{RELEASER}} should be a procedure of a single argument (a foreign
+pointer object to the static memory to be freed) and defaults to
+{{free}}.
+
+
+==== object-unevict
+
+ [procedure] (object-unevict X [FULL])
+
+Copies the object {{X}} and nested objects back into the normal Scheme heap.
+Symbols are re-interned into the symbol table. Strings and byte-vectors are
+'''not''' copied, unless {{FULL}} is given and not {{#f}}.
+
+
+==== object-size
+
+ [procedure] (object-size X)
+
+Returns the number of bytes that would be needed to evict the data object
+{{X}}.
+
+
+
+=== Accessing toplevel variables
+
+
+==== global-bound?
+
+ [procedure] (global-bound? SYMBOL)
+
+Returns {{#t}}, if the global (''toplevel'') variable with the name {{SYMBOL}}
+is bound to a value, or {{#f}} otherwise.
+
+
+==== global-ref
+
+ [procedure] (global-ref SYMBOL)
+
+Returns the value of the global variable {{SYMBOL}}.
+If no variable under that name is bound, an error is signalled.
+
+Note that it is not possible to access a toplevel binding with {{global-ref}} or
+{{global-set!}} if it has been hidden in compiled code via {{(declare (hide ...))}},
+or if the code has been compiled in {{block}} mode.
+
+
+==== global-set!
+
+ [procedure] (global-set! SYMBOL X)
+ [procedure] (set! (global-ref SYMBOL) X)
+
+Sets the global variable named {{SYMBOL}} to the value {{X}}.
+
+
+
+=== Record instance
+
+
+==== make-record-instance
+
+ [procedure] (make-record-instance SYMBOL ARG1 ...)
+
+Returns a new instance of the record type {{SYMBOL}}, with its
+slots initialized to {{ARG1 ...}}. To illustrate:
+
+<enscript highlight=scheme>
+(define-record-type point (make-point x y) point?
+ (x point-x point-x-set!)
+ (y point-y point-y-set!))
+</enscript>
+
+expands into something quite similar to:
+
+<enscript highlight=scheme>
+(begin
+ (define (make-point x y)
+ (make-record-instance 'point x y) )
+ (define (point? x)
+ (and (record-instance? x)
+ (eq? 'point (block-ref x 0)) ) )
+ (define (point-x p) (block-ref p 1))
+ (define (point-x-set! p x) (block-set! p 1 x))
+ (define (point-y p) (block-ref p 2))
+ (define (point-y-set! p y) (block-set! p 1 y)) )
+</enscript>
+
+
+==== record-instance?
+
+ [procedure] (record-instance? X [SYMBOL])
+
+Returns {{#t}} if {{X}} is a record structure, or {{#f}} otherwise.
+
+Further, returns {{#t}} if {{X}} is of type {{SYMBOL}}, or {{#f}} otherwise.
+
+
+==== record-instance-type
+
+ [procedure] (record-instance-type RECORD)
+
+Returns type symbol of the record structure {{RECORD}}. Signals an error if
+{{RECORD}} is not a record structure.
+
+
+==== record-instance-length
+
+ [procedure] (record-instance-length RECORD)
+
+Returns number of slots for the record structure {{RECORD}}. The
+record-instance type is not counted. Signals an error if
+{{RECORD}} is not a record structure.
+
+
+==== record-instance-slot
+
+ [procedure] (record-instance-slot RECORD INDEX)
+
+Returns the contents of the {{INDEX}}th slot of the record structure
+{{RECORD}}. The slot index range is the open interval (([0
+record-instance-length)}}. Signals an error if {{RECORD}} is not a record
+structure.
+
+
+==== record-instance-slot-set!
+
+ [procedure] (record-instance-slot-set! RECORD INDEX X)
+ [procedure] (set! (record-instance-slot RECORD INDEX) X)
+
+Sets the {{INDEX}}th slot of the record structure {{RECORD}} to {{X}}. The slot
+index range is the open interval (([0 record-instance-length)}}. Signals an
+error if {{RECORD}} is not a record structure.
+
+
+==== record->vector
+
+ [procedure] (record->vector RECORD)
+
+Returns a new vector with the type and the elements of the record structure
+{{RECORD}}. Signals an error if {{RECORD}} is not a record structure.
+
+
+
+=== Procedure-call- and variable reference hooks
+
+
+==== set-invalid-procedure-call-handler!
+
+ [procedure] (set-invalid-procedure-call-handler! PROC)
+
+Sets an internal hook that is invoked when a call to an object other than a
+procedure is executed at runtime. The procedure {{PROC}} will in that case be
+called with two arguments: the object being called and a list of the passed
+arguments.
+
+<enscript highlight=scheme>
+;;; Access sequence-elements as in ARC:
+
+(set-invalid-procedure-call-handler!
+ (lambda (proc args)
+ (cond [(string? proc) (apply string-ref proc args)]
+ [(vector? proc) (apply vector-ref proc args)]
+ [else (error "call of non-procedure" proc)] ) ) )
+
+("hello" 4) ==> #\o
+</enscript>
+
+This facility does not work in code compiled with the ''unsafe'' setting.
+
+
+==== unbound-variable-value
+
+ [procedure] (unbound-variable-value [X])
+
+Defines the value that is returned for unbound variables. Normally an error is
+signalled, use this procedure to override the check and return {{X}} instead.
+To set the default behavior (of signalling an error), call
+{{unbound-variable-value}} with no arguments.
+
+This facility does not work in code compiled with the ''unsafe'' setting.
+
+
+
+=== Magic
+
+
+==== object-become!
+
+ [procedure] (object-become! ALIST)
+
+Changes the identity of the value of the car of each pair in {{ALIST}} to the
+value of the cdr. Both values may not be immediate (i.e. exact integers,
+characters, booleans or the empty list).
+
+<enscript highlight=scheme>
+(define x "i used to be a string")
+(define y '#(and now i am a vector))
+(object-become! (list (cons x y)))
+x ==> #(and now i am a vector)
+y ==> #(and now i am a vector)
+(eq? x y) ==> #t
+</enscript>
+
+Note: this operation invokes a major garbage collection.
+
+The effect of using {{object-become!}} on evicted data (see {{object-evict}})
+is undefined.
+
+
+==== mutate-procedure
+
+ [procedure] (mutate-procedure OLD PROC)
+
+Replaces the procedure {{OLD}} with the result of calling the one-argument
+procedure {{PROC}}. {{PROC}} will receive a copy of {{OLD}} that will be
+identical in behaviour to the result of {{PROC}}:
+
+<enscript highlight=scheme>
+ ;;; Replace arbitrary procedure with tracing one:
+
+ (mutate-procedure my-proc
+ (lambda (new)
+ (lambda args
+ (printf "~s called with arguments: ~s~%" new args)
+ (apply new args) ) ) )
+</enscript>
+
+---
+Previous: [[Unit tcp]]
+
+Next: [[Interface to external functions and variables]]
diff --git a/manual/Unit ports b/manual/Unit ports
new file mode 100644
index 00000000..6a50e398
--- /dev/null
+++ b/manual/Unit ports
@@ -0,0 +1,145 @@
+[[tags: manual]]
+[[toc:]]
+
+== Unit ports
+
+This unit contains various extended port definitions. This unit is
+used by default, unless the program is compiled with the
+{{-explicit-use}} option.
+
+=== Input/output port extensions
+
+==== with-output-to-port
+
+<procedure>(with-output-to-port PORT THUNK)</procedure>
+
+Call procedure {{THUNK}} with the current output-port temporarily
+bound to {{PORT}}.
+
+==== make-input-port
+
+<procedure>(make-input-port READ READY? CLOSE [PEEK])</procedure>
+
+Returns a custom input port. Common operations on this
+port are handled by the given parameters, which should be
+procedures of no arguments. {{READ}} is called when the
+next character is to be read and should return a character or
+{{#!eof}}. {{READY?}} is called
+when {{char-ready?}} is called on this port and should return
+{{#t}} or {{#f}}. {{CLOSE}} is called when the port is
+closed. {{PEEK}} is called when {{peek-char}} is called on this
+port and should return a character or {{#!eof}}.
+if the argument {{PEEK}} is not given, then {{READ}} is used
+instead and the created port object handles peeking automatically (by
+calling {{READ}} and buffering the character).
+
+
+==== make-output-port
+
+<procedure>(make-output-port WRITE CLOSE [FLUSH])</procedure>
+
+Returns a custom output port. Common operations on this port are handled
+by the given parameters, which should be procedures. {{WRITE}} is
+called when output is sent to the port and receives a single argument,
+a string. {{CLOSE}} is called when the port is closed and should
+be a procedure of no arguments. {{FLUSH}} (if provided) is called
+for flushing the output port.
+
+
+==== with-error-output-to-port
+
+<procedure>(with-error-output-to-port PORT THUNK)</procedure>
+
+Call procedure {{THUNK}} with the current error output-port
+temporarily bound to {{PORT}}.
+
+
+==== with-input-from-port
+
+<procedure>(with-input-from-port PORT THUNK)</procedure>
+
+Call procedure {{THUNK}} with the current input-port temporarily
+bound to {{PORT}}.
+
+
+=== String-port extensions
+
+==== call-with-input-string
+
+<procedure>(call-with-input-string STRING PROC)</procedure>
+
+Calls the procedure {{PROC}} with a single argument that is a
+string-input-port with the contents of {{STRING}}.
+
+
+==== call-with-output-string
+
+<procedure>(call-with-output-string PROC)</procedure>
+
+Calls the procedure {{PROC}} with a single argument that is a
+string-output-port. Returns the accumulated output-string.
+
+
+==== with-input-from-string
+
+<procedure>(with-input-from-string STRING THUNK)</procedure>
+
+Call procedure {{THUNK}} with the current input-port temporarily
+bound to an input-string-port with the contents of {{STRING}}.
+
+
+==== with-output-to-string
+
+<procedure>(with-output-to-string THUNK)</procedure>
+
+Call procedure {{THUNK}} with the current output-port temporarily
+bound to a string-output-port and return the accumulated output string.
+
+
+=== Port iterators
+
+==== port-for-each
+
+<procedure>(port-for-each FN THUNK)</procedure>
+
+Apply {{FN}} to successive results of calling the zero argument procedure {{THUNK}}
+until it returns {{#!eof}}, discarding the results.
+
+==== port-map
+
+<procedure>(port-map FN THUNK)</procedure>
+
+Apply {{FN}} to successive results of calling the zero argument procedure {{THUNK}}
+until it returns {{#!eof}}, returning a list of the collected results.
+
+==== port-fold
+
+<procedure>(port-fold FN ACC THUNK)</procedure>
+
+Apply {{FN}} to successive results of calling the zero argument procedure {{THUNK}},
+passing the {{ACC}} value as the second argument. The {{FN}} result becomes the new
+{{ACC}} value. When {{THUNK}} returns {{#!eof}}, the last {{FN}} result is returned.
+
+
+=== Funky ports
+
+==== make-broadcast-port
+
+<procedure>(make-broadcast-port PORT ...)</procedure>
+
+Returns a custom output port that emits everything written into it to
+the ports given as {{PORT ...}}. Closing the broadcast port does not close
+any of the argument ports.
+
+==== make-concatenated-port
+
+<procedure>(make-concatenated-port PORT1 PORT2 ...)</procedure>
+
+Returns a custom input port that reads its input from {{PORT1}}, until it
+is empty, then from {{PORT2}} and so on. Closing the concatenated port
+does not close any of the argument ports.
+
+---
+Previous: [[Unit data-structures]]
+
+Next: [[Unit files]]
diff --git a/manual/Unit posix b/manual/Unit posix
new file mode 100644
index 00000000..0281a37c
--- /dev/null
+++ b/manual/Unit posix
@@ -0,0 +1,1307 @@
+[[tags: manual]]
+[[toc:]]
+
+== Unit posix
+
+This unit provides services as used on many UNIX-like systems. Note that
+the following definitions are not all available on non-UNIX systems like
+Windows. See below for Windows specific notes.
+
+This unit uses the {{regex}}, {{scheduler}}, {{extras}} and {{utils}} units.
+
+All errors related to failing file-operations will signal a condition
+of kind {{(exn i/o file)}}.
+
+
+=== Constants
+
+==== File-control Commands
+
+===== fcntl/dupfd
+===== fcntl/getfd
+===== fcntl/setfd
+===== fcntl/getfl
+===== fcntl/setfl
+
+==== Standard I/O file-descriptors
+
+===== fileno/stdin
+===== fileno/stdout
+===== fileno/stderr
+
+==== Open flags
+
+===== open/rdonly
+===== open/wronly
+===== open/rdwr
+===== open/read
+Synonym for {{open/rdonly}}.
+
+===== open/write
+Synonym for {{open/wronly}}.
+
+===== open/creat
+===== open/append
+===== open/excl
+===== open/noctty
+===== open/nonblock
+===== open/trunc
+===== open/sync
+===== open/fsync
+===== open/binary
+===== open/text
+
+==== Permission bits
+
+===== perm/irusr
+===== perm/iwusr
+===== perm/ixusr
+===== perm/irgrp
+===== perm/iwgrp
+===== perm/ixgrp
+===== perm/iroth
+===== perm/iwoth
+===== perm/ixoth
+===== perm/irwxu
+===== perm/irwxg
+===== perm/irwxo
+===== perm/isvtx
+===== perm/isuid
+===== perm/isgid
+
+
+=== Directories
+
+==== change-directory
+
+<procedure>(change-directory NAME)</procedure>
+
+Changes the current working directory to {{NAME}}.
+
+==== current-directory
+
+<procedure>(current-directory [DIR])</procedure>
+
+Returns the name of the current working directory. If the optional argument {{DIR}} is given,
+then {{(current-directory DIR)}} is equivalent to {{(change-directory DIR)}}.
+
+==== create-directory
+
+<procedure>(create-directory NAME #!optional PARENTS?)</procedure>
+
+Creates a directory with the pathname {{NAME}}. If the {{PARENTS?}} argument
+is given and not false, any nonextant parent directories are also created.
+
+==== delete-directory
+
+<procedure>(delete-directory NAME)</procedure>
+
+Deletes the directory with the pathname {{NAME}}. The directory has
+to be empty.
+
+==== directory
+
+<procedure>(directory [PATHNAME [SHOW-DOTFILES?]])</procedure>
+
+Returns a list with all files that are contained in the directory with the name {{PATHNAME}}
+(which defaults to the value of {{(current-directory)}}).
+Files beginning with {{.}} are included only if {{SHOW-DOTFILES?}} is given and not {{#f}}.
+
+==== directory?
+
+<procedure>(directory? NAME)</procedure>
+
+Returns {{#t}} if there exists a file with the name {{NAME}}
+and if that file is a directory, or {{#f}} otherwise.
+
+==== glob
+
+<procedure>(glob PATTERN1 ...)</procedure>
+
+Returns a list of the pathnames of all existing files matching
+{{PATTERN1 ...}}, which should be strings containing the usual
+file-patterns (with {{*}} matching zero or more characters and
+{{?}} matching zero or one character).
+
+==== set-root-directory!
+
+<procedure>(set-root-directory! STRING)</procedure>
+
+Sets the root directory for the current process to the path given in {{STRING}}
+(using the {{chroot}} function).
+If the current process has no root permissions, the operation will fail.
+
+
+=== Pipes
+
+==== call-with-input-pipe
+==== call-with-output-pipe
+
+<procedure>(call-with-input-pipe CMDLINE PROC [MODE])</procedure>
+<procedure>(call-with-output-pipe CMDLINE PROC [MODE])</procedure>
+
+Call {{PROC}} with a single argument: a input- or output port
+for a pipe connected to the subprocess named in {{CMDLINE}}. If
+{{PROC}} returns normally, the pipe is closed and any result values
+are returned.
+
+==== close-input-pipe
+==== close-output-pipe
+
+<procedure>(close-input-pipe PORT)</procedure>
+<procedure>(close-output-pipe PORT)</procedure>
+
+Closes the pipe given in {{PORT}} and waits until the connected
+subprocess finishes. The exit-status code of the invoked process
+is returned.
+
+==== create-pipe
+
+<procedure>(create-pipe)</procedure>
+
+The fundamental pipe-creation operator. Calls the C function
+{{pipe()}} and returns 2 values: the file-descriptors of the input-
+and output-ends of the pipe.
+
+==== open-input-pipe
+
+<procedure>(open-input-pipe CMDLINE [MODE])</procedure>
+
+Spawns a subprocess with the command-line string {{CMDLINE}} and
+returns a port, from which the output of the process can be read. If
+{{MODE}} is specified, it should be the keyword {{#:text}}
+(the default) or {{#:binary}}.
+
+==== open-output-pipe
+
+<procedure>(open-output-pipe CMDLINE [MODE])</procedure>
+
+Spawns a subprocess with the command-line string {{CMDLINE}} and
+returns a port. Anything written to that port is treated as the input
+for the process. If {{MODE}} is specified, it should be the keyword
+{{#:text}} (the default) or {{#:binary}}.
+
+==== pipe/buf
+This variable contains the maximal number of bytes that can be written
+atomically into a pipe or FIFO.
+
+==== with-input-from-pipe
+==== with-output-to-pipe
+
+<procedure>(with-input-from-pipe CMDLINE THUNK [MODE])</procedure>
+<procedure>(with-output-to-pipe CMDLINE THUNK [MODE])</procedure>
+
+Temporarily set the value of
+{{current-input-port/current-output-port}} to a port for a
+pipe connected to the subprocess named in {{CMDLINE}} and call
+the procedure {{THUNK}} with no arguments. After {{THUNK}}
+returns normally the pipe is closed and the standard input-/output port
+is restored to its previous value and any result values are returned.
+
+<enscript highlight=scheme>
+(with-output-to-pipe
+ "gs -dNOPAUSE -sDEVICE=jpeg -dBATCH -sOutputFile=signballs.jpg -g600x600 -q -"
+ (lambda ()
+ (print #<<EOF
+ %!IOPSC-1993 %%Creator: HAYAKAWA Takashi<xxxxxxxx@xx.xxxxxx.xx.xx>
+ /C/neg/d/mul/R/rlineto/E/exp/H{{cvx def}repeat}def/T/dup/g/gt/r/roll/J/ifelse 8
+ H/A/copy(z&v4QX&93r9AxYQOZomQalxS2w!!O&vMYa43d6r93rMYvx2dca!D&cjSnjSnjjS3o!v&6A
+ X&55SAxM1CD7AjYxTTd62rmxCnTdSST0g&12wECST!&!J0g&D1!&xM0!J0g!l&544dC2Ac96ra!m&3A
+ F&&vGoGSnCT0g&wDmlvGoS8wpn6wpS2wTCpS1Sd7ov7Uk7o4Qkdw!&Mvlx1S7oZES3w!J!J!Q&7185d
+ Z&lx1CS9d9nE4!k&X&MY7!&1!J!x&jdnjdS3odS!N&mmx1C2wEc!G&150Nx4!n&2o!j&43r!U&0777d
+ ]&2AY2A776ddT4oS3oSnMVC00VV0RRR45E42063rNz&v7UX&UOzF!F!J![&44ETCnVn!a&1CDN!Y&0M
+ V1c&j2AYdjmMdjjd!o&1r!M){( )T 0 4 3 r put T(/)g{T(9)g{cvn}{cvi}J}{($)g[]J}J
+ cvx}forall/moveto/p/floor/w/div/S/add 29 H[{[{]setgray fill}for Y}for showpage
+ EOF
+ ) ) )
+</enscript>
+
+
+=== Fifos
+
+==== create-fifo
+
+<procedure>(create-fifo FILENAME [MODE])</procedure>
+
+Creates a FIFO with the name {{FILENAME}} and the permission bits
+{{MODE}}, which defaults to
+
+<enscript highlight=scheme>
+ (+ perm/irwxu perm/irwxg perm/irwxo)
+</enscript>
+
+==== fifo?
+
+<procedure>(fifo? FILENAME)</procedure>
+
+Returns {{#t}} if the file with the name {{FILENAME}} names
+a FIFO.
+
+
+=== File descriptors and low-level I/O
+
+==== duplicate-fileno
+
+<procedure>(duplicate-fileno OLD [NEW])</procedure>
+
+If {{NEW}} is given, then the file-descriptor {{NEW}} is opened
+to access the file with the file-descriptor {{OLD}}. Otherwise a
+fresh file-descriptor accessing the same file as {{OLD}} is returned.
+
+==== file-close
+
+<procedure>(file-close FILENO)</procedure>
+
+Closes the input/output file with the file-descriptor {{FILENO}}.
+
+==== file-open
+
+<procedure>(file-open FILENAME FLAGS [MODE])</procedure>
+
+Opens the file specified with the string {{FILENAME}} and open-flags
+{{FLAGS}} using the C function {{open(2)}}. On success a
+file-descriptor for the opened file is returned.
+
+{{FLAGS}} is a bitmask of {{open/...}}
+values '''or'''ed together using {{bitwise-ior}} (or simply added
+together). You must provide exactly one of the access flags {{open/rdonly}}, {{open/wronly}}, or {{open/rdwr}}. Additionally, you may provide zero or more creation flags ({{open/creat}}, {{open/excl}}, {{open/trunc}}, and {{open/noctty}}) and status flags (the remaining {{open/...}} values). For example, to open a possibly new output file for appending:
+
+ (file-open "/tmp/hen.txt" (+ open/wronly open/append open/creat))
+
+The optional {{MODE}} should be a bitmask composed of one
+or more permission values like {{perm/irusr}} and is only relevant
+when a new file is created. The default mode is
+{{perm/irwxu | perm/irgrp | perm/iroth}}.
+
+==== file-mkstemp
+
+<procedure>(file-mkstemp TEMPLATE-FILENAME)</procedure>
+
+Create a file based on the given {{TEMPLATE-FILENAME}}, in which
+the six last characters must be ''XXXXXX''. These will be replaced
+with a string that makes the filename unique. The file descriptor of
+the created file and the generated filename is returned. See the
+{{mkstemp(3)}} manual page for details on how this function
+works. The template string given is not modified.
+
+Example usage:
+
+<enscript highlight=scheme>
+ (let-values (((fd temp-path) (file-mkstemp "/tmp/mytemporary.XXXXXX")))
+ (let ((temp-port (open-output-file* fd)))
+ (format temp-port "This file is ~A.~%" temp-path)
+ (close-output-port temp-port)))
+</enscript>
+
+==== file-read
+
+<procedure>(file-read FILENO SIZE [BUFFER])</procedure>
+
+Reads {{SIZE}} bytes from the file with the file-descriptor
+{{FILENO}}. If a string or bytevector is passed in the optional
+argument {{BUFFER}}, then this string will be destructively modified
+to contain the read data. This procedure returns a list with two values:
+the buffer containing the data and the number of bytes read.
+
+==== file-select
+
+<procedure>(file-select READFDLIST WRITEFDLIST [TIMEOUT])</procedure>
+
+Waits until any of the file-descriptors given in the lists
+{{READFDLIST}} and {{WRITEFDLIST}} is ready for input or
+output, respectively. If the optional argument {{TIMEOUT}} is
+given and not false, then it should specify the number of seconds after
+which the wait is to be aborted (the value may be a floating point
+number). This procedure returns two values:
+the lists of file-descriptors ready for input and output, respectively.
+{{READFDLIST}} and '''WRITEFDLIST''' may also by file-descriptors
+instead of lists. In this case the returned values are booleans
+indicating whether input/output is ready by {{#t}} or {{#f}}
+otherwise. You can also pass {{#f}} as {{READFDLIST}} or
+{{WRITEFDLIST}} argument, which is equivalent to {{()}}.
+
+==== file-write
+
+<procedure>(file-write FILENO BUFFER [SIZE])</procedure>
+
+Writes the contents of the string or bytevector {{BUFFER}} into
+the file with the file-descriptor {{FILENO}}. If the optional
+argument {{SIZE}} is given, then only the specified number of bytes
+are written.
+
+==== file-control
+
+<procedure>(file-control FILENO COMMAND [ARGUMENT])</procedure>
+
+Performs the fcntl operation {{COMMAND}} with the given
+{{FILENO}} and optional {{ARGUMENT}}. The return value is
+meaningful depending on the {{COMMAND}}.
+
+==== open-input-file*
+==== open-output-file*
+
+<procedure>(open-input-file* FILENO [OPENMODE])</procedure>
+<procedure>(open-output-file* FILENO [OPENMODE])</procedure>
+
+Opens file for the file-descriptor {{FILENO}} for input or output
+and returns a port. {{FILENO}} should be a positive exact integer.
+{{OPENMODE}} specifies an additional mode for opening the file
+(currently only the keyword {{#:append}} is supported, which opens
+an output-file for appending).
+
+==== port->fileno
+
+<procedure>(port->fileno PORT)</procedure>
+
+If {{PORT}} is a file- or tcp-port, then a file-descriptor is returned for
+this port. Otherwise an error is signaled.
+
+
+=== Retrieving file attributes
+
+==== file-access-time
+==== file-change-time
+==== file-modification-time
+
+<procedure>(file-access-time FILE)</procedure>
+<procedure>(file-change-time FILE)</procedure>
+<procedure>(file-modification-time FILE)</procedure>
+
+Returns time (in seconds) of the last access, modification or change of {{FILE}}. {{FILE}}
+may be a filename or a file-descriptor. If the file does not exist,
+an error is signaled.
+
+==== file-stat
+
+<procedure>(file-stat FILE [LINK])</procedure>
+
+Returns a 13-element vector with the following contents: inode-number,
+mode (as with {{file-permissions}}), number of hard links, uid of
+owner (as with {{file-owner}}), gid of owner, size (as with
+{{file-size}}) and access-, change- and modification-time (as with
+{{file-access-time}}, {{file-change-time}} and
+{{file-modification-time}}, device id, device type (for special file
+inode, blocksize and blocks allocated. On Windows systems the last 4
+values are undefined.
+
+By default, symbolic links are followed and
+the status of the referenced file is returned;
+however, if the optional argument {{LINK}} is given and
+not {{#f}}, the status of the link itself is returned.
+
+Note that for very large files, the {{file-size}} value may be an
+inexact integer.
+
+==== file-position
+
+<procedure>(file-position FILE)</procedure>
+
+Returns the current file position of {{FILE}}, which should be a
+port or a file-descriptor.
+
+==== file-size
+
+<procedure>(file-size FILENAME)</procedure>
+
+Returns the size of the file designated by {{FILE}}. {{FILE}}
+may be a filename or a file-descriptor. If the file does not exist,
+an error is signaled. Note that for very large files, {{file-size}} may
+return an inexact integer.
+
+==== regular-file?
+
+<procedure>(regular-file? FILENAME)</procedure>
+
+Returns true, if {{FILENAME}} names a regular file (not a directory or symbolic link).
+
+==== file-owner
+
+<procedure>(file-owner FILE)</procedure>
+
+Returns the user-id of {{FILE}}. {{FILE}} may be a filename
+or a file-descriptor.
+
+==== file-permissions
+
+<procedure>(file-permissions FILE)</procedure>
+
+Returns the permission bits for {{FILE}}. You can test this value
+by performing bitwise operations on the result and the {{perm/...}}
+values. {{FILE}} may be a filename or a file-descriptor.
+
+==== file-read-access?
+==== file-write-access?
+==== file-execute-access?
+
+<procedure>(file-read-access? FILENAME)</procedure>
+<procedure>(file-write-access? FILENAME)</procedure>
+<procedure>(file-execute-access? FILENAME)</procedure>
+
+These procedures return {{#t}} if the current user has read,
+write or execute permissions on the file named {{FILENAME}}.
+
+
+==== character-device?
+==== block-device?
+==== fifo?
+==== socket?
+
+<procedure>(character-device? FILENAME)</procedure>
+<procedure>(block-device? FILENAME)</procedure>
+<procedure>(fifo? FILENAME)</procedure>
+<procedure>(socket? FILENAME)</procedure>
+
+These procedures return {{#t}} if the {{FILENAME}} given is of the
+appropriate type.
+
+
+=== Changing file attributes
+
+==== file-truncate
+
+<procedure>(file-truncate FILE OFFSET)</procedure>
+
+Truncates the file {{FILE}} to the length {{OFFSET}},
+which should be an integer. If the file-size is smaller or equal to
+{{OFFSET}} then nothing is done. {{FILE}} should be a filename
+or a file-descriptor.
+
+==== set-file-position!
+
+<procedure>(set-file-position! FILE POSITION [WHENCE])</procedure>
+<procedure>(set! (file-position FILE) POSITION)</procedure>
+
+Sets the current read/write position of {{FILE}} to
+{{POSITION}}, which should be an exact integer. {{FILE}}
+should be a port or a file-descriptor. {{WHENCE}} specifies
+how the position is to interpreted and should be one of the values
+{{seek/set, seek/cur}} and {{seek/end}}. It defaults to
+{{seek/set}}.
+
+Exceptions: {{(exn bounds)}}, {{(exn i/o file)}}
+
+==== change-file-mode
+
+<procedure>(change-file-mode FILENAME MODE)</procedure>
+
+Changes the current file mode of the file named {{FILENAME}}
+to {{MODE}} using the {{chmod()}} system call. The
+{{perm/...}} variables contain the various permission bits and can
+be combinded with the {{bitwise-ior}} procedure.
+
+==== change-file-owner
+
+<procedure>(change-file-owner FILENAME UID GID)</procedure>
+
+Changes the owner information of the file named {{FILENAME}} to
+the user- and group-ids {{UID}} and {{GID}} (which should be
+exact integers) using the {{chown()}} system call.
+
+
+=== Processes
+
+==== current-process-id
+
+<procedure>(current-process-id)</procedure>
+
+Returns the process ID of the current process.
+
+==== parent-process-id
+
+<procedure>(parent-process-id)</procedure>
+
+Returns the process ID of the parent of the current process.
+
+==== process-group-id
+
+<procedure>(process-group-id PID)</procedure>
+
+Returns the process group ID of the process specified by {{PID}}.
+
+==== process-execute
+
+<procedure>(process-execute PATHNAME [ARGUMENT-LIST [ENVIRONMENT-LIST]])</procedure>
+
+Creates a new child process and replaces the running process with it
+using the C library function {{execvp(3)}}. If the optional argument
+{{ARGUMENT-LIST}} is given, then it should contain a list of strings which
+are passed as arguments to the subprocess. If the optional argument
+{{ENVIRONMENT-LIST}} is supplied, then the library function {{execve(2)}}
+is used, and the environment passed in {{ENVIRONMENT-LIST}} (which should
+be of the form {{("<NAME>=<VALUE>" ...)}} is given
+to the invoked process. Note that {{execvp(3)}} respects the current setting
+of the {{PATH}} environment variable while {{execve(3)}} does not.
+
+==== process-fork
+
+<procedure>(process-fork [THUNK])</procedure>
+
+Creates a new child process with the UNIX system call
+{{fork()}}. Returns either the PID of the child process or 0. If
+{{THUNK}} is given, then the child process calls it as a procedure
+with no arguments and terminates.
+
+==== process-run
+
+<procedure>(process-run COMMANDLINE])</procedure>
+<procedure>(process-run COMMAND ARGUMENT-LIST)</procedure>
+
+Creates a new child process. The PID of the new process is returned.
+
+* The single parameter version passes the {{COMMANDLINE}} to the system shell, so usual
+argument expansion can take place.
+* The multiple parameter version directly invokes the {{COMMAND}} with the {{ARGUMENT-LIST}}.
+
+==== process-signal
+
+<procedure>(process-signal PID [SIGNAL])</procedure>
+
+Sends {{SIGNAL}} to the process with the id {{PID}} using the
+UNIX system call {{kill()}}. {{SIGNAL}} defaults to the value
+of the variable {{signal/term}}.
+
+==== process-wait
+
+<procedure>(process-wait [PID [NOHANG]])</procedure>
+
+Suspends the current process until the child process with
+the id {{PID}} has terminated using the UNIX system call
+{{waitpid()}}. If {{PID}} is not given, then this procedure
+waits for any child process. If {{NOHANG}} is given and not
+{{#f}} then the current process is not suspended. This procedure
+returns three values:
+
+* {{PID}} or 0, if {{NOHANG}} is true and the child process has not terminated yet.
+* {{#t}} if the process exited normally or {{#f}} otherwise.
+* either the exit status, if the process terminated normally or the signal number that terminated/stopped the process.
+
+==== process
+
+<procedure>(process COMMANDLINE)</procedure>
+<procedure>(process COMMAND ARGUMENT-LIST [ENVIRONMENT-LIST])</procedure>
+
+Creates a subprocess and returns three values: an input port from
+which data written by the sub-process can be read, an output port from
+which any data written to will be received as input in the sub-process
+and the process-id of the started sub-process. Blocking reads and writes
+to or from the ports returned by {{process}} only block the current
+thread, not other threads executing concurrently.
+
+* The single parameter version passes the string {{COMMANDLINE}} to the host-system's shell that
+is invoked as a subprocess.
+* The multiple parameter version directly invokes the {{COMMAND}} as a subprocess. The {{ARGUMENT-LIST}}
+is directly passed, as is {{ENVIRONMENT-LIST}}.
+
+Not using the shell may be preferrable for security reasons.
+
+==== process*
+
+<procedure>(process* COMMANDLINE)</procedure>
+<procedure>(process* COMMAND ARGUMENT-LIST [ENVIRONMENT-LIST])</procedure>
+
+Like {{process}} but returns 4 values: an input port from
+which data written by the sub-process can be read, an output port from
+which any data written to will be received as input in the sub-process,
+the process-id of the started sub-process, and an input port from
+which data written by the sub-process to {{stderr}} can be read.
+
+==== sleep
+
+<procedure>(sleep SECONDS)</procedure>
+
+Puts the process to sleep for {{SECONDS}}. Returns either 0 if
+the time has completely elapsed, or the number of remaining seconds,
+if a signal occurred.
+
+==== create-session
+
+<procedure>(create-session)</procedure>
+
+Creates a new session if the calling process is not a process group leader and returns
+the session ID.
+
+
+=== Hard and symbolic links
+
+==== symbolic-link?
+
+<procedure>(symbolic-link? FILENAME)</procedure>
+
+Returns true, if {{FILENAME}} names a symbolic link.
+
+==== create-symbolic-link
+
+<procedure>(create-symbolic-link OLDNAME NEWNAME)</procedure>
+
+Creates a symbolic link with the filename {{NEWNAME}} that points
+to the file named {{OLDNAME}}.
+
+==== read-symbolic-link
+
+<procedure>(read-symbolic-link FILENAME [CANONICALIZE])</procedure>
+
+Returns the filename to which the symbolic link {{FILENAME}} points.
+If {{CANONICALIZE}} is given and true, then symbolic links are
+resolved repeatedly until the result is not a link.
+
+==== file-link
+
+<procedure>(file-link OLDNAME NEWNAME)</procedure>
+
+Creates a hard link from {{OLDNAME}} to {{NEWNAME}} (both strings).
+
+
+=== Retrieving user & group information
+
+==== current-user-id
+
+<procedure>(current-user-id)</procedure>
+ [setter] (set! (current-user-id) UID)
+
+Get or set the real user-id of the current process.
+
+==== current-effective-user-id
+
+<procedure>(current-effective-user-id)</procedure>
+ [setter] (set! (current-effective-user-id) UID)
+
+Get or set the effective user-id of the current process.
+
+==== user-information
+
+<procedure>(user-information USER [AS-VECTOR])</procedure>
+
+If {{USER}} specifes a valid username (as a string) or user ID, then the user
+database is consulted and a list of 7 values are returned: the user-name, the
+encrypted password, the user ID, the group ID, a user-specific string, the home
+directory and the default shell. When {{AS-VECTOR}} is {{#t}} a vector of 7
+elements is returned instead of a list. If no user with this name or id then
+{{#f}} is returned.
+
+==== current-group-id
+
+<procedure>(current-group-id)</procedure>
+ [setter] (set! (current-group-id) GID)
+
+Get or set the real group-id of the current process.
+
+==== current-effective-group-id
+
+<procedure>(current-effective-group-id)</procedure>
+ [setter] (set! (current-effective-group-id) GID)
+
+Get or set the effective group-id of the current process.
+ID can be found, then {{#f}} is returned.
+
+==== group-information
+
+<procedure>(group-information GROUP)</procedure>
+
+If {{GROUP}} specifies a valid group-name or group-id, then this
+procedure returns a list of four values: the group-name, the encrypted group password,
+the group ID and a list of the names of all group members. If no group with the
+given name or ID exists, then {{#f}} is returned.
+
+==== get-groups
+
+<procedure>(get-groups)</procedure>
+
+Returns a list with the supplementary group IDs of the current user.
+
+
+=== Changing user & group information
+
+==== set-groups!
+
+<procedure>(set-groups! GIDLIST)</procedure>
+
+Sets the supplementrary group IDs of the current user to the IDs given in the list {{GIDLIST}}.
+
+Only the superuser may invoke this procedure.
+
+==== initialize-groups
+
+<procedure>(initialize-groups USERNAME BASEGID)</procedure>
+
+Sets the supplementrary group IDs of the current user to the IDs from the user with name {{USERNAME}}
+(a string), including {{BASEGID}}.
+
+Only the superuser may invoke this procedure.
+
+==== set-process-group-id!
+
+<procedure>(set-process-group-id! PID PGID)</procedure>
+ [setter] (set! (process-group-id PID) PGID)
+
+Sets the process group ID of the process specifed by {{PID}} to {{PGID}}.
+
+
+=== Record locking
+
+==== file-lock
+
+<procedure>(file-lock PORT [START [LEN]])</procedure>
+
+Locks the file associated with {{PORT}} for reading or
+writing (according to whether {{PORT}} is an input- or
+output-port). {{START}} specifies the starting position in the
+file to be locked and defaults to 0. {{LEN}} specifies the length
+of the portion to be locked and defaults to {{#t}}, which means
+the complete file. {{file-lock}} returns a ''lock''-object.
+
+==== file-lock/blocking
+
+<procedure>(file-lock/blocking PORT [START [LEN]])</procedure>
+
+Similar to {{file-lock}}, but if a lock is held on the file,
+the current process blocks (including all threads) until the lock is released.
+
+==== file-test-lock
+
+<procedure>(file-test-lock PORT [START [LEN]])</procedure>
+
+Tests whether the file associated with {{PORT}} is locked for reading
+or writing (according to whether {{PORT}} is an input- or output-port)
+and returns either {{#f}} or the process-id of the locking process.
+
+==== file-unlock
+
+<procedure>(file-unlock LOCK)</procedure>
+
+Unlocks the previously locked portion of a file given in {{LOCK}}.
+
+
+=== Signal handling
+
+==== set-alarm!
+
+<procedure>(set-alarm! SECONDS)</procedure>
+
+Sets an internal timer to raise the {{signal/alrm}}
+after {{SECONDS}} are elapsed. You can use the
+{{set-signal-handler!}} procedure to write a handler for this signal.
+
+==== set-signal-handler!
+
+<procedure>(set-signal-handler! SIGNUM PROC)</procedure>
+
+Establishes the procedure of one argument {{PROC}} as the handler
+for the signal with the code {{SIGNUM}}. {{PROC}} is called
+with the signal number as its sole argument. If the argument {{PROC}} is {{#f}}
+then any signal handler will be removed, and the corresponding signal set to {{SIG_IGN}}.
+
+Note that is is unspecified in which thread of execution the signal handler will be invoked.
+
+==== signal-handler
+
+<procedure>(signal-handler SIGNUM)</procedure>
+
+Returns the signal handler for the code {{SIGNUM}} or {{#f}}.
+
+==== set-signal-mask!
+
+<procedure>(set-signal-mask! SIGLIST)</procedure>
+
+Sets the signal mask of the current process to block all signals given
+in the list {{SIGLIST}}. Signals masked in that way will not be
+delivered to the current process.
+
+==== signal-mask
+
+<procedure>(signal-mask)</procedure>
+
+Returns the signal mask of the current process.
+
+==== signal-masked?
+
+<procedure>(signal-masked? SIGNUM)</procedure>
+
+Returns whether the signal for the code {{SIGNUM}} is currently masked.
+
+==== signal-mask!
+
+<procedure>(signal-mask! SIGNUM)</procedure>
+
+Masks (blocks) the signal for the code {{SIGNUM}}.
+
+==== signal-unmask!
+
+<procedure>(signal-unmask! SIGNUM)</procedure>
+
+Unmasks (unblocks) the signal for the code {{SIGNUM}}.
+
+==== signal/term
+==== signal/kill
+==== signal/int
+==== signal/hup
+==== signal/fpe
+==== signal/ill
+==== signal/segv
+==== signal/abrt
+==== signal/trap
+==== signal/quit
+==== signal/alrm
+==== signal/vtalrm
+==== signal/prof
+==== signal/io
+==== signal/urg
+==== signal/chld
+==== signal/cont
+==== signal/stop
+==== signal/tstp
+==== signal/pipe
+==== signal/xcpu
+==== signal/xfsz
+==== signal/usr1
+==== signal/usr2
+==== signal/winch
+
+These variables contain signal codes for use with {{process-signal}}, {{set-signal-handler!}}, {{signal-handler}}, {{signal-masked?}}, {{signal-mask!}}, or {{signal-unmask!}}.
+
+
+=== Environment access
+
+==== current-environment
+
+ [procedure] (get-environment-variables)
+
+Returns a association list of the environment variables and their
+current values (see also [[http://srfi.schemers.org/srfi-98/|SRFI-98]]).
+
+==== setenv
+
+<procedure>(setenv VARIABLE VALUE)</procedure>
+
+Sets the environment variable named {{VARIABLE}} to
+{{VALUE}}. Both arguments should be strings. If the variable is
+not defined in the environment, a new definition is created.
+
+==== unsetenv
+
+<procedure>(unsetenv VARIABLE)</procedure>
+
+Removes the definition of the environment variable {{VARIABLE}} from
+the environment of the current process. If the variable is not defined,
+nothing happens.
+
+
+=== Memory mapped I/O
+
+==== memory-mapped-file?
+
+ [pocedure] (memory-mapped-file? X)
+
+Returns {{#t}}, if {{X}} is an object representing a memory
+mapped file, or {{#f}} otherwise.
+
+==== map-file-to-memory
+
+<procedure>(map-file-to-memory ADDRESS LEN PROTECTION FLAG FILENO [OFFSET])</procedure>
+
+Maps a section of a file to memory using the C function
+{{mmap()}}. {{ADDRESS}} should be a foreign pointer object
+or {{#f}}; {{LEN}} specifies the size of the section to
+be mapped; {{PROTECTION}} should be one or more of the flags
+{{prot/read, prot/write, prot/exec}} or {{prot/none}}
+'''bitwise-ior'''ed together; {{FLAG}} should be one or more of
+the flags {{map/fixed, map/shared, map/private, map/anonymous}} or
+{{map/file}}; {{FILENO}} should be the file-descriptor of the
+mapped file. The optional argument {{OFFSET}} gives the offset of
+the section of the file to be mapped and defaults to 0. This procedure
+returns an object representing the mapped file section. The procedure
+{{move-memory!}} can be used to access the mapped memory.
+
+==== memory-mapped-file-pointer
+
+<procedure>(memory-mapped-file-pointer MMAP)</procedure>
+
+Returns a machine pointer to the start of the memory region to which
+the file is mapped.
+
+==== unmap-file-from-memory
+
+<procedure>(unmap-file-from-memory MMAP [LEN])</procedure>
+
+Unmaps the section of a file mapped to memory using the C function
+{{munmap()}}. {{MMAP}} should be a mapped file as returned
+by the procedure {{map-file-to-memory}}. The optional argument
+{{LEN}} specifies the length of the section to be unmapped and
+defaults to the complete length given when the file was mapped.
+
+
+=== Date and time routines
+
+==== seconds->local-time
+
+<procedure>(seconds->local-time SECONDS)</procedure>
+
+Breaks down the time value represented in {{SECONDS}} into a 10
+element vector of the form {{#(seconds minutes hours mday month
+year wday yday dstflag timezone)}}, in the following format:
+
+; seconds (0) : the number of seconds after the minute (0 - 59)
+; minutes (1) : the number of minutes after the hour (0 - 59)
+; hours (2) : the number of hours past midnight (0 - 23)
+; mday (3) : the day of the month (1 - 31)
+; month (4) : the number of months since january (0 - 11)
+; year (5) : the number of years since 1900
+; wday (6) : the number of days since Sunday (0 - 6)
+; yday (7) : the number of days since January 1 (0 - 365)
+; dstflag (8) : a flag that is true if Daylight Saving Time is in effect at the time described.
+; timezone (9) : the difference between UTC and the latest local standard time, in seconds west of UTC.
+
+==== local-time->seconds
+
+<procedure>(local-time->seconds VECTOR)</procedure>
+
+Converts the ten-element vector {{VECTOR}} representing the time value relative to
+the current timezone into
+the number of seconds since the first of January, 1970 UTC.
+
+==== local-timezone-abbreviation
+
+<procedure>(local-timezone-abbreviation)</procedure>
+
+Returns the abbreviation for the local timezone as a string.
+
+==== seconds->string
+
+<procedure>(seconds->string SECONDS)</procedure>
+
+Converts the local time represented in {{SECONDS}} into a string
+of the form {{"Tue May 21 13:46:22 1991"}}.
+
+==== seconds->utc-time
+
+<procedure>(seconds->utc-time SECONDS)</procedure>
+
+Similar to {{seconds->local-time}}, but interpretes {{SECONDS}}
+as UTC time.
+
+==== utc-time->seconds
+
+<procedure>(utc-time->seconds VECTOR)</procedure>
+
+Converts the ten-element vector {{VECTOR}} representing the UTC time value into
+the number of seconds since the first of January, 1970 UTC.
+
+==== time->string
+
+<procedure>(time->string VECTOR [FORMAT])</procedure>
+
+Converts the broken down time represented in the 10 element vector
+{{VECTOR}} into a string of the form represented by the {{FORMAT}}
+string. The default time form produces something like {{"Tue May 21 13:46:22 1991"}}.
+
+The {{FORMAT}} string follows the rules for the C library procedure {{strftime}}. The default {{FORMAT}} string is "%a %b %e %H:%M:%S %Z %Y".
+
+==== string->time
+
+ [procedure] (string->time TIME [FORMAT])
+
+Converts a string of the form represented by the {{FORMAT}} string
+into the broken down time represented in a 10 element vector. The
+default time form understands something like {{"Tue May 21 13:46:22 1991"}}.
+
+The {{FORMAT}} string follows the rules for the C library procedure {{strptime}}. The default {{FORMAT}} string is "%a %b %e %H:%M:%S %Z %Y".
+
+
+=== Raw exit
+
+==== _exit
+
+<procedure>(_exit [CODE])</procedure>
+
+Exits the current process without flushing any buffered output (using
+the C function {{_exit}}). Note that the {{exit-handler}}
+is not called when this procedure is invoked. The optional return-code
+{{CODE}} defaults to {{0}}.
+
+
+=== ERRNO values
+
+==== errno/perm
+==== errno/noent
+==== errno/srch
+==== errno/intr
+==== errno/io
+==== errno/noexec
+==== errno/badf
+==== errno/child
+==== errno/nomem
+==== errno/acces
+==== errno/fault
+==== errno/busy
+==== errno/notdir
+==== errno/isdir
+==== errno/inval
+==== errno/mfile
+==== errno/nospc
+==== errno/spipe
+==== errno/pipe
+==== errno/again
+==== errno/rofs
+==== errno/exist
+==== errno/wouldblock
+These variables contain error codes as returned by {{errno}}.
+
+
+=== Finding files
+
+==== find-files
+
+<procedure>(find-files DIRECTORY PREDICATE [ACTION [IDENTITY [LIMIT]]])</procedure>
+
+Recursively traverses the contents of {{DIRECTORY}} (which should
+be a string) and invokes the procedure {{ACTION}} for all files
+in which the procedure {{PREDICATE}} is true. {{PREDICATE}}
+may me a procedure of one argument or a regular-expression string.
+{{ACTION}} should be a procedure of two arguments: the currently
+encountered file and the result of the previous invocation of
+{{ACTION}}, or, if this is the first invocation, the value
+of {{IDENTITY}}. {{ACTION}} defaults to {{cons}},
+{{IDENTITY}} defaults to {{()}}. {{LIMIT}} should be a
+procedure of one argument that is called for each nested directory
+and which should return true, if that directory is to be traversed
+recursively. {{LIMIT}} may also be an exact integer that
+gives the maximum recursion depth. For example, a depth of {{0}} means that only files in the top-level, specified directory are to be traversed. In this case, all nested directories are ignored. {{LIMIT}} may also be {{#f}} (the default),
+which is equivalent to {{(constantly #t)}}.
+
+Note that {{ACTION}} is called with the full pathname of each file,
+including the directory prefix.
+
+
+=== Getting the hostname and system information
+
+==== get-host-name
+
+<procedure>(get-host-name)</procedure>
+
+Returns the hostname of the machine that this process is running on.
+
+==== system-information
+
+<procedure>(system-information)</procedure>
+
+Invokes the UNIX system call {{uname()}} and returns a list of 5 values:
+system-name, node-name, OS release, OS version and machine.
+
+=== Setting the file buffering mode
+
+==== set-buffering-mode!
+
+<procedure>(set-buffering-mode! PORT MODE [BUFSIZE])</procedure>
+
+Sets the buffering-mode for the file associated with {{PORT}} to
+{{MODE}}, which should be one of the keywords {{#:full}},
+{{#:line}} or {{#:none}}. If {{BUFSIZE}} is specified it
+determines the size of the buffer to be used (if any).
+
+
+=== Terminal ports
+
+==== terminal-name
+
+<procedure>(terminal-name PORT)</procedure>
+
+Returns the name of the terminal that is connected to {{PORT}}.
+
+==== terminal-port?
+
+<procedure>(terminal-port? PORT)</procedure>
+
+Returns {{#t}} if {{PORT}} is connected to a terminal and
+{{#f}} otherwise.
+
+
+==== terminal-size
+
+ [procedure] (terminal-size)
+
+Returns two values, the number of columns and rows of the
+current terminal window or {{0}}, {{0}} if the terminal
+size can not be obtained. On Windows, this procedure
+always returns {{0}}, {{0}}.
+
+
+=== How Scheme procedures relate to UNIX C functions
+
+; {{change-directory}} : {{chdir}}
+; {{change-file-mode}} : {{chmod}}
+; {{change-file-owner}} : {{chown}}
+; {{create-directory}} : {{mkdir}}
+; {{create-fifo}} : {{mkfifo}}
+; {{create-pipe}} : {{pipe}}
+; {{create-session}} : {{setsid}}
+; {{create-symbolic-link}} : {{link}}
+; {{current-directory}} : {{curdir}}
+; {{current-effective-groupd-id}} : {{getegid}}
+; {{current-effective-user-id}} : {{geteuid}}
+; {{current-group-id}} : {{getgid}}
+; {{current-parent-id}} : {{getppid}}
+; {{current-process-id}} : {{getpid}}
+; {{current-user-id}} : {{getuid}}
+; {{delete-directory}} : {{rmdir}}
+; {{duplicate-fileno}} : {{dup/dup2}}
+; {{_exit}} : {{_exit}}
+; {{file-close}} : {{close}}
+; {{file-access-time}} : {{stat}}
+; {{file-change-time}} : {{stat}}
+; {{file-modification-time}} : {{stat}}
+; {{file-execute-access?}} : {{access}}
+; {{file-open}} : {{open}}
+; {{file-lock}} : {{fcntl}}
+; {{file-position}} : {{ftell/lseek}}
+; {{file-read}} : {{read}}
+; {{file-read-access?}} : {{access}}
+; {{file-select}} : {{select}}
+; {{file-control}} : {{fcntl}}
+; {{file-stat}} : {{stat}}
+; {{file-test-lock}} : {{fcntl}}
+; {{file-truncate}} : {{truncate/ftruncate}}
+; {{file-unlock}} : {{fcntl}}
+; {{file-write}} : {{write}}
+; {{file-write-access?}} : {{access}}
+; {{get-groups}} : {{getgroups}}
+; {{get-host-name}} : {{gethostname}}
+; {{initialize-groups}} : {{initgroups}}
+; {{local-time->seconds}} : {{mktime}}
+; {{local-timezone-abbreviation}} : {{localtime}}
+; {{map-file-to-memory}} : {{mmap}}
+; {{open-input-file*}} : {{fdopen}}
+; {{open-output-file*}} : {{fdopen}}
+; {{open-input-pipe}} : {{popen}}
+; {{open-output-pipe}} : {{popen}}
+; {{port->fileno}} : {{fileno}}
+; {{process-execute}} : {{execvp}}
+; {{process-fork}} : {{fork}}
+; {{process-group-id}} : {{getpgid}}
+; {{process-signal}} : {{kill}}
+; {{process-wait}} : {{waitpid}}
+; {{close-input-pipe}} : {{pclose}}
+; {{close-output-pipe}} : {{pclose}}
+; {{read-symbolic-link}} : {{readlink}}
+; {{seconds->local-time}} : {{localtime}}
+; {{seconds->string}} : {{ctime}}
+; {{seconds->utc-time}} : {{gmtime}}
+; {{set-alarm!}} : {{alarm}}
+; {{set-buffering-mode!}} : {{setvbuf}}
+; {{set-file-position!}} : {{fseek/seek}}
+; {{set-groups!}} : {{setgroups}}
+; {{set-signal-mask!}} : {{sigprocmask}}
+; {{set-group-id!}} : {{setgid}}
+; {{set-process-group-id!}} : {{setpgid}}
+; {{set-user-id!}} : {{setuid}}
+; {{set-root-directory!}} : {{chroot}}
+; {{setenv}} : {{setenv/putenv}}
+; {{sleep}} : {{sleep}}
+; {{system-information}} : {{uname}}
+; {{terminal-name}} : {{ttyname}}
+; {{terminal-port?}} : {{isatty}}
+; {{time->string}} : {{asctime}}
+; {{unsetenv}} : {{putenv}}
+; {{unmap-file-from-memory}} : {{munmap}}
+; {{user-information}} : {{getpwnam/getpwuid}}
+; {{utc-time->seconds}} : {{timegm}}
+
+
+=== Windows specific notes
+
+Use of UTF8 encoded strings is for pathnames is not supported. Windows uses a
+16-bit UNICODE encoding with special system calls for wide-character support.
+Only single-byte string encoding can be used.
+
+==== Procedure Changes
+
+Exceptions to the above procedure definitions.
+
+<procedure>(create-pipe [MODE])</procedure>
+
+The optional parameter {{MODE}}, default {{open/binary | open/noinherit}}. This can be {{open/binary}} or
+{{open/text}}, optionally or'ed with {{open/noinherit}}.
+
+<procedure>(process-wait [PID [NOHANG]])</procedure>
+
+{{process-wait}} always returns {{#t}} for a terminated process and only the exit
+status is available. (Windows does not provide signals as an interprocess
+communication method.)
+
+<procedure>(process-execute PATHNAME [ARGUMENT-LIST [ENVIRONMENT-LIST [EXACT-FLAG]]])</procedure>
+<procedure>(process COMMAND ARGUMENT-LIST [ENVIRONMENT-LIST [EXACT-FLAG]])</procedure>
+<procedure>(process* COMMAND ARGUMENT-LIST [ENVIRONMENT-LIST [EXACT-FLAG]])</procedure>
+
+The optional parameter {{EXACT-FLAG}}, default {{#f}}. When {{#f}} any argument string with
+embedded whitespace will be wrapped in quotes. When {{#t}} no such wrapping occurs.
+
+==== Unsupported Definitions
+
+The following definitions are not supported for native Windows builds (compiled with the
+Microsoft tools or with MinGW):
+
+ open/noctty open/nonblock open/fsync open/sync
+ perm/isvtx perm/isuid perm/isgid
+ file-select file-control
+ signal/... (except signal/term, signal/int, signal/fpe, signal/ill, signal/segv, signal/abrt, signal/break)
+ set-signal-mask! signal-mask signal-masked? signal-mask! signal-unmask!
+ user-information group-information get-groups set-groups! initialize-groups
+ errno/wouldblock
+ change-file-owner
+ current-user-id current-group-id current-effective-user-id current-effective-groupd-id
+ set-user-id! set-group-id!
+ create-session
+ process-group-id set-process-group-id!
+ create-symbolic-link read-symbolic-link
+ file-truncate
+ file-lock file-lock/blocking file-unlock file-test-lock
+ create-fifo fifo?
+ prot/...
+ map/...
+ map-file-to-memory unmap-file-from-memory memory-mapped-file-pointer memory-mapped-file?
+ set-alarm!
+ terminal-port? terminal-name
+ process-fork process-signal
+ parent-process-id
+ set-root-directory!
+ utc-time->seconds
+
+==== Additional Definitions
+
+Only available for Windows
+
+* open/noinherit
+
+This variable is a mode value for {{create-pipe}}. Useful when spawning a child process.
+
+* spawn/overlay
+* spawn/wait
+* spawn/nowait
+* spawn/nowaito
+* spawn/detach
+
+These variables contains special flags that specify the exact semantics of {{process-spawn}}:
+{{spawn/overlay}} replaces the current process with the new one.
+{{spawn/wait}} suspends execution of the current process until the spawned process returns.
+{{spawn/nowait}} does the opposite ({{spawn/nowaito}} is identical, according to the Microsoft
+documentation) and runs the process asynchronously.
+{{spawn/detach}} runs the new process in the background, without being attached to a console.
+
+==== process-spawn
+
+<procedure>(process-spawn MODE COMMAND [ARGUMENT-LIST [ENVIRONMENT-LIST [EXACT-FLAG]]])</procedure>
+
+Creates and runs a new process with the given {{COMMAND}} filename and the optional
+{{ARGUMENT-LIST}} and {{ENVIRONMENT-LIST}}. {{MODE}} specifies how exactly the process
+should be executed and must be one or more of the {{spawn/...}} flags defined above.
+
+The {{EXACT-FLAG}}, default {{#f}}, controls quote-wrapping of argument strings. When {{#t}}
+quote-wrapping is not performed.
+
+Returns:
+* the exit status when synchronous
+* the PID when asynchronous
+* -1 when failure
+
+---
+Previous: [[Unit srfi-69]]
+
+Next: [[Unit utils]]
diff --git a/manual/Unit regex b/manual/Unit regex
new file mode 100644
index 00000000..5c21e75f
--- /dev/null
+++ b/manual/Unit regex
@@ -0,0 +1,463 @@
+[[tags: manual]]
+[[toc:]]
+
+== Unit regex
+
+This library unit provides support for regular expressions. The regular
+expression package used is {{irregex}}
+written by Alex Shinn. Irregex supports most Perl-extensions and is
+written completely in Scheme.
+
+This library unit exposes two APIs: the standard Chicken API described below, and the
+original irregex API. You may use either API or both:
+
+ (require-library regex) ; required for either API, or both
+ (import regex) ; import the Chicken regex API
+ (import irregex) ; import the original irregex API
+
+Regular expressions may be either POSIX-style strings (with most PCRE
+extensions) or an SCSH-style SRE. There is no {{(rx ...)}} syntax -
+just use normal Scheme lists, with quasiquote if you like.
+
+=== grep
+
+ [procedure] (grep REGEX LIST)
+
+Returns all items of {{LIST}} that match the regular expression
+{{REGEX}}. This procedure could be defined as follows:
+
+<enscript highlight=scheme>
+(define (grep regex lst)
+ (filter (lambda (x) (string-search regex x)) lst) )
+</enscript>
+
+
+=== glob->regexp
+
+ [procedure] (glob->regexp PATTERN)
+
+Converts the file-pattern {{PATTERN}} into a regular expression.
+
+<enscript highlight=scheme>
+(glob->regexp "foo.*")
+=> "foo\..*"
+</enscript>
+
+{{PATTERN}} should follow "glob" syntax. Allowed wildcards are
+
+ *
+ [C...]
+ [C1-C2]
+ [-C...]
+ ?
+
+
+=== glob?
+
+ [procedure] (glob? STRING)
+
+Does the {{STRING}} have any "glob" wildcards?
+
+A string without any "glob" wildcards does not meet the criteria,
+even though it technically is a valid "glob" file-pattern.
+
+
+=== regexp
+
+ [procedure] (regexp STRING [IGNORECASE [IGNORESPACE [UTF8]]])
+
+Returns a precompiled regular expression object for {{string}}.
+The optional arguments {{IGNORECASE}}, {{IGNORESPACE}} and {{UTF8}}
+specify whether the regular expression should be matched with case- or whitespace-differences
+ignored, or whether the string should be treated as containing UTF-8 encoded
+characters, respectively.
+
+Note that code that uses regular expressions heavily should always
+use them in precompiled form, which is likely to be much faster than
+passing strings to any of the regular-expression routines described
+below.
+
+
+=== regexp?
+
+ [procedure] (regexp? X)
+
+Returns {{#t}} if {{X}} is a precompiled regular expression,
+or {{#f}} otherwise.
+
+
+=== string-match
+=== string-match-positions
+
+ [procedure] (string-match REGEXP STRING [START])
+ [procedure] (string-match-positions REGEXP STRING [START])
+
+Matches the regular expression in {{REGEXP}} (a string or a precompiled
+regular expression) with
+{{STRING}} and returns either {{#f}} if the match failed,
+or a list of matching groups, where the first element is the complete
+match. If the optional argument {{START}} is supplied, it specifies
+the starting position in {{STRING}}. For each matching group the
+result-list contains either: {{#f}} for a non-matching but optional
+group; a list of start- and end-position of the match in {{STRING}}
+(in the case of {{string-match-positions}}); or the matching
+substring (in the case of {{string-match}}). Note that the exact string
+is matched. For searching a pattern inside a string, see below.
+Note also that {{string-match}} is implemented by calling
+{{string-search}} with the regular expression wrapped in {{^ ... $}}.
+If invoked with a precompiled regular expression argument (by using
+{{regexp}}), {{string-match}} is identical to {{string-search}}.
+
+
+=== string-search
+=== string-search-positions
+
+ [procedure] (string-search REGEXP STRING [START [RANGE]])
+ [procedure] (string-search-positions REGEXP STRING [START [RANGE]])
+
+Searches for the first match of the regular expression in
+{{REGEXP}} with {{STRING}}. The search can be limited to
+{{RANGE}} characters.
+
+
+=== string-split-fields
+
+ [procedure] (string-split-fields REGEXP STRING [MODE [START]])
+
+Splits {{STRING}} into a list of fields according to {{MODE}},
+where {{MODE}} can be the keyword {{#:infix}} ({{REGEXP}}
+matches field separator), the keyword {{#:suffix}} ({{REGEXP}}
+matches field terminator) or {{#t}} ({{REGEXP}} matches field),
+which is the default.
+
+<enscript highlight=scheme>
+(define s "this is a string 1, 2, 3,")
+
+(string-split-fields "[^ ]+" s)
+
+ => ("this" "is" "a" "string" "1," "2," "3,")
+
+(string-split-fields " " s #:infix)
+
+ => ("this" "is" "a" "string" "1," "2," "3,")
+
+(string-split-fields "," s #:suffix)
+
+ => ("this is a string 1" " 2" " 3")
+</enscript>
+
+
+=== string-substitute
+
+ [procedure] (string-substitute REGEXP SUBST STRING [MODE])
+
+Searches substrings in {{STRING}} that match {{REGEXP}}
+and substitutes them with the string {{SUBST}}. The substitution
+can contain references to subexpressions in
+{{REGEXP}} with the {{\NUM}} notation, where {{NUM}}
+refers to the NUMth parenthesized expression. The optional argument
+{{MODE}} defaults to 1 and specifies the number of the match to
+be substituted. Any non-numeric index specifies that all matches are to
+be substituted.
+
+<enscript highlight=scheme>
+(string-substitute "([0-9]+) (eggs|chicks)" "\\2 (\\1)" "99 eggs or 99 chicks" 2)
+=> "99 eggs or chicks (99)"
+</enscript>
+
+Note that a regular expression that matches an empty string will
+signal an error.
+
+
+=== string-substitute*
+
+ [procedure] (string-substitute* STRING SMAP [MODE])
+
+Substitutes elements of {{STRING}} with {{string-substitute}} according to {{SMAP}}.
+{{SMAP}} should be an association-list where each element of the list
+is a pair of the form {{(MATCH . REPLACEMENT)}}. Every occurrence of
+the regular expression {{MATCH}} in {{STRING}} will be replaced by the string
+{{REPLACEMENT}}
+
+<enscript highlight=scheme>
+(string-substitute* "<h1>Hello, world!</h1>" '(("<[/A-Za-z0-9]+>" . "")))
+
+=> "Hello, world!"
+</enscript>
+
+
+=== regexp-escape
+
+ [procedure] (regexp-escape STRING)
+
+Escapes all special characters in {{STRING}} with {{\}}, so that the string can be embedded
+into a regular expression.
+
+<enscript highlight=scheme>
+(regexp-escape "^[0-9]+:.*$")
+=> "\\^\\[0-9\\]\\+:.\n.\\*\\$"
+</enscript>
+
+=== Extended SRE Syntax
+
+The following table summarizes the SRE syntax, with detailed explanations following.
+
+ ;; basic patterns
+ <string> ; literal string
+ (seq <sre> ...) ; sequence
+ (: <sre> ...)
+ (or <sre> ...) ; alternation
+
+ ;; optional/multiple patterns
+ (? <sre> ...) ; 0 or 1 matches
+ (* <sre> ...) ; 0 or more matches
+ (+ <sre> ...) ; 1 or more matches
+ (= <n> <sre> ...) ; exactly <n> matches
+ (>= <n> <sre> ...) ; <n> or more matches
+ (** <from> <to> <sre> ...) ; <n> to <m> matches
+ (?? <sre> ...) ; non-greedy (non-greedy) pattern: (0 or 1)
+ (*? <sre> ...) ; non-greedy kleene star
+ (**? <from> <to> <sre> ...) ; non-greedy range
+
+ ;; submatch patterns
+ (submatch <sre> ...) ; numbered submatch
+ (submatch-named <name> <sre> ...) ; named submatch
+ (=> <name> <sre> ...)
+ (backref <n-or-name>) ; match a previous submatch
+
+ ;; toggling case-sensitivity
+ (w/case <sre> ...) ; enclosed <sre>s are case-sensitive
+ (w/nocase <sre> ...) ; enclosed <sre>s are case-insensitive
+
+ ;; character sets
+ <char> ; singleton char set
+ (<string>) ; set of chars
+ (or <cset-sre> ...) ; set union
+ (~ <cset-sre> ...) ; set complement (i.e. [^...])
+ (- <cset-sre> ...) ; set difference
+ (& <cset-sre> ...) ; set intersection
+ (/ <range-spec> ...) ; pairs of chars as ranges
+
+ ;; named character sets
+ any
+ nonl
+ ascii
+ lower-case lower
+ upper-case upper
+ alphabetic alpha
+ numeric num
+ alphanumeric alphanum alnum
+ punctuation punct
+ graphic graph
+ whitespace white space
+ printing print
+ control cntrl
+ hex-digit xdigit
+
+ ;; assertions and conditionals
+ bos eos ; beginning/end of string
+ bol eol ; beginning/end of line
+ bow eow ; beginning/end of word
+ nwb ; non-word-boundary
+ (look-ahead <sre> ...) ; zero-width look-ahead assertion
+ (look-behind <sre> ...) ; zero-width look-behind assertion
+ (neg-look-ahead <sre> ...) ; zero-width negative look-ahead assertion
+ (neg-look-behind <sre> ...) ; zero-width negative look-behind assertion
+ (atomic <sre> ...) ; for (?>...) independent patterns
+ (if <test> <pass> [<fail>]) ; conditional patterns
+ commit ; don't backtrack beyond this (i.e. cut)
+
+ ;; backwards compatibility
+ (posix-string <string>) ; embed a POSIX string literal
+
+==== Basic SRE Patterns
+
+The simplest SRE is a literal string, which matches that string exactly.
+
+ (string-search "needle" "hayneedlehay") => <match>
+
+By default the match is case-sensitive, though you can control this either with the compiler flags or local overrides:
+
+ (string-search "needle" "haynEEdlehay") => #f
+
+ (string-search (irregex "needle" 'i) "haynEEdlehay") => <match>
+
+ (string-search '(w/nocase "needle") "haynEEdlehay") => <match>
+
+You can use {{w/case}} to switch back to case-sensitivity inside a {{w/nocase}}:
+
+ (string-search '(w/nocase "SMALL" (w/case "BIG")) "smallBIGsmall") => <match>
+
+ (string-search '(w/nocase "small" (w/case "big")) "smallBIGsmall") => #f
+
+Of course, literal strings by themselves aren't very interesting
+regular expressions, so we want to be able to compose them. The most
+basic way to do this is with the {{seq}} operator (or its abbreviation {{:}}),
+which matches one or more patterns consecutively:
+
+ (string-search '(: "one" space "two" space "three") "one two three") => <match>
+
+As you may have noticed above, the {{w/case}} and {{w/nocase}} operators
+allowed multiple SREs in a sequence - other operators that take any
+number of arguments (e.g. the repetition operators below) allow such
+implicit sequences.
+
+To match any one of a set of patterns use the or alternation operator:
+
+ (string-search '(or "eeney" "meeney" "miney") "meeney") => <match>
+
+ (string-search '(or "eeney" "meeney" "miney") "moe") => #f
+
+==== SRE Repetition Patterns
+
+There are also several ways to control the number of times a pattern
+is matched. The simplest of these is {{?}} which just optionally matches
+the pattern:
+
+ (string-search '(: "match" (? "es") "!") "matches!") => <match>
+
+ (string-search '(: "match" (? "es") "!") "match!") => <match>
+
+ (string-search '(: "match" (? "es") "!") "matche!") => #f
+
+To optionally match any number of times, use {{*}}, the Kleene star:
+
+ (string-search '(: "<" (* (~ #\>)) ">") "<html>") => <match>
+
+ (string-search '(: "<" (* (~ #\>)) ">") "<>") => <match>
+
+ (string-search '(: "<" (* (~ #\>)) ">") "<html") => #f
+
+Often you want to match any number of times, but at least one time is required, and for that you use {{+}}:
+
+ (string-search '(: "<" (+ (~ #\>)) ">") "<html>") => <match>
+
+ (string-search '(: "<" (+ (~ #\>)) ">") "<a>") => <match>
+
+ (string-search '(: "<" (+ (~ #\>)) ">") "<>") => #f
+
+More generally, to match at least a given number of times, use {{>=}}:
+
+ (string-search '(: "<" (>= 3 (~ #\>)) ">") "<table>") => <match>
+
+ (string-search '(: "<" (>= 3 (~ #\>)) ">") "<pre>") => <match>
+
+ (string-search '(: "<" (>= 3 (~ #\>)) ">") "<tr>") => #f
+
+To match a specific number of times exactly, use {=}:
+
+ (string-search '(: "<" (= 4 (~ #\>)) ">") "<html>") => <match>
+
+ (string-search '(: "<" (= 4 (~ #\>)) ">") "<table>") => #f
+
+And finally, the most general form is {{**}} which specifies a range
+of times to match. All of the earlier forms are special cases of this.
+
+ (string-search '(: (= 3 (** 1 3 numeric) ".") (** 1 3 numeric)) "192.168.1.10") => <match>
+
+ (string-search '(: (= 3 (** 1 3 numeric) ".") (** 1 3 numeric)) "192.0168.1.10") => #f
+
+There are also so-called "non-greedy" variants of these repetition
+operators, by convention suffixed with an additional {{?}}. Since the
+normal repetition patterns can match any of the allotted repetition
+range, these operators will match a string if and only if the normal
+versions matched. However, when the endpoints of which submatch
+matched where are taken into account (specifically, all matches when
+using string-search since the endpoints of the match itself matter),
+the use of a non-greedy repetition can change the result.
+
+So, whereas {{?}} can be thought to mean "match or don't match," {{??}} means
+"don't match or match." {{*}} typically consumes as much as possible, but
+{{*?}} tries first to match zero times, and only consumes one at a time if
+that fails. If you have a greedy operator followed by a non-greedy
+operator in the same pattern, they can produce surprisins results as
+they compete to make the match longer or shorter. If this seems
+confusing, that's because it is. Non-greedy repetitions are defined
+only in terms of the specific backtracking algorithm used to implement
+them, which for compatibility purposes always means the Perl
+algorithm. Thus, when using these patterns you force IrRegex to use a
+backtracking engine, and can't rely on efficient execution.
+
+==== SRE Character Sets
+
+Perhaps more common than matching specific strings is matching any of
+a set of characters. You can use the or alternation pattern on a list
+of single-character strings to simulate a character set, but this is
+too clumsy for everyday use so SRE syntax allows a number of
+shortcuts.
+
+A single character matches that character literally, a trivial
+character class. More conveniently, a list holding a single element
+which is a string refers to the character set composed of every
+character in the string.
+
+ (string-match '(* #\-) "---") => <match>
+
+ (string-match '(* #\-) "-_-") => #f
+
+ (string-match '(* ("aeiou")) "oui") => <match>
+
+ (string-match '(* ("aeiou")) "ouais") => #f
+
+Ranges are introduced with the {{/}} operator. Any strings or characters
+in the {{/}} are flattened and then taken in pairs to represent the start
+and end points, inclusive, of character ranges.
+
+ (string-match '(* (/ "AZ09")) "R2D2") => <match>
+
+ (string-match '(* (/ "AZ09")) "C-3PO") => #f
+
+In addition, a number of set algebra operations are provided. or, of
+course, has the same meaning, but when all the options are character
+sets it can be thought of as the set union operator. This is further
+extended by the {{&}} set intersection, {{-}} set difference, and {{~}} set
+complement operators.
+
+ (string-match '(* (& (/ "az") (~ ("aeiou")))) "xyzzy") => <match>
+
+ (string-match '(* (& (/ "az") (~ ("aeiou")))) "vowels") => #f
+
+ (string-match '(* (- (/ "az") ("aeiou"))) "xyzzy") => <match>
+
+ (string-match '(* (- (/ "az") ("aeiou"))) "vowels") => #f
+
+==== SRE Assertion Patterns
+
+There are a number of times it can be useful to assert something about
+the area around a pattern without explicitly making it part of the
+pattern. The most common cases are specifically anchoring some pattern
+to the beginning or end of a word or line or even the whole
+string. For example, to match on the end of a word:
+
+ (string-match '(: "foo" eow) "foo") => <match>
+
+ (string-match '(: "foo" eow) "foo!") => <match>
+
+ (string-match '(: "foo" eow) "foof") => #f
+
+The {{bow}}, {{bol}}, {{eol}}, {{bos}} and {{eos}} work similarly. {{nwb}} asserts that you
+are not in a word-boundary - if replaced for {{eow}} in the above examples
+it would reverse all the results.
+
+There is no {{wb}}, since you tend to know from context whether it
+would be the beginning or end of a word, but if you need it you can
+always use (or bow eow).
+
+Somewhat more generally, Perl introduced positive and negative
+look-ahead and look-behind patterns. Perl look-behind patterns are
+limited to a fixed length, however the IrRegex versions have no such
+limit.
+
+ (string-match '(: "regular" (look-ahead " expression")) "regular expression") => <match>
+
+The most general case, of course, would be an and pattern to
+complement the or pattern - all the patterns must match or the whole
+pattern fails. This may be provided in a future release, although it
+(and look-ahead and look-behind assertions) are unlikely to be
+compiled efficiently.
+
+
+---
+Previous: [[Unit extras]]
+
+Next: [[Unit srfi-1]]
diff --git a/manual/Unit srfi-1 b/manual/Unit srfi-1
new file mode 100644
index 00000000..6881a6d1
--- /dev/null
+++ b/manual/Unit srfi-1
@@ -0,0 +1,11 @@
+[[tags: manual]]
+
+== Unit srfi-1
+
+List library, see the documentation for
+[[http://srfi.schemers.org/srfi-1/srfi-1.html|SRFI-1]]
+
+---
+Previous: [[Unit regex]]
+
+Next: [[Unit srfi-4]]
diff --git a/manual/Unit srfi-13 b/manual/Unit srfi-13
new file mode 100644
index 00000000..08ac36b3
--- /dev/null
+++ b/manual/Unit srfi-13
@@ -0,0 +1,24 @@
+[[tags: manual]]
+== Unit srfi-13
+
+
+String library, see the documentation for
+[[http://srfi.schemers.org/srfi-13/srfi-13.html|SRFI-13]]
+
+
+On systems that support dynamic loading, the {{srfi-13}} unit can
+be made available in the interpreter ({{csi}}) by entering
+
+<enscript highlight=scheme>
+(require-extension srfi-13)
+</enscript>
+
+The {{string-hash}} and {{string-hash-ci}} procedures are
+not provided in this library unit, [[Unit srfi-69]] has
+compatible definitions.
+
+
+---
+Previous: [[Unit srfi-4]]
+
+Next: [[Unit srfi-14]]
diff --git a/manual/Unit srfi-14 b/manual/Unit srfi-14
new file mode 100644
index 00000000..975191ab
--- /dev/null
+++ b/manual/Unit srfi-14
@@ -0,0 +1,20 @@
+[[tags: manual]]
+
+== Unit srfi-14
+
+Character set library, see the documentation for
+[[http://srfi.schemers.org/srfi-14/srfi-14.html|SRFI-14]]
+
+On systems that support dynamic loading, the {{srfi-14}} unit can
+be made available in the interpreter ({{csi}}) by entering
+
+<enscript highlight=scheme>
+(require-extension srfi-14)
+</enscript>
+
+This library provides only the Latin-1 character set.
+
+---
+Previous: [[Unit srfi-13]]
+
+Next: [[Unit srfi-18]]
diff --git a/manual/Unit srfi-18 b/manual/Unit srfi-18
new file mode 100644
index 00000000..eacf6ea3
--- /dev/null
+++ b/manual/Unit srfi-18
@@ -0,0 +1,105 @@
+[[tags: manual]]
+
+[[toc:]]
+
+== Unit srfi-18
+
+A simple multithreading package. This threading package follows largely
+the specification of SRFI-18. For more information see the documentation
+for [[http://srfi.schemers.org/srfi-18/srfi-18.html|SRFI-18]].
+
+'''Notes:'''
+
+* {{thread-start!}} accepts a thunk (a zero argument procedure) as argument, which is equivalent to {{(thread-start! (make-thread THUNK))}}.
+
+* {{thread-sleep!}} accepts a seconds real number value in addition to a time object.
+
+* When an uncaught exception (i.e. an error) is signalled in a thread other than the primordial thread and warnings are enabled (see: {{enable-warnings}}, then a warning message is written to the port that is the value of {{(current-error-port)}}.
+
+* Blocking I/O will block all threads, except for some socket operations (see the section about the {{tcp}} unit). An exception is the read-eval-print loop on UNIX platforms: waiting for input will not block other threads, provided the current input port reads input from a console.
+
+* It is generally not a good idea for one thread to call a continuation created by another thread, if {{dynamic-wind}} is involved.
+
+* When more than one thread compete for the current time-slice, the thread that was waiting first will become the next runnable thread.
+
+* The dynamic environment of a thread consists of the following state:
+
+** The current input-, output- and error-port
+
+** The current exception handler
+
+** The values of all current parameters (created by {{make-parameter}})
+
+** Any pending {{dynamic-wind}} thunks.
+
+* When an error is triggered inside the execution context of a thread, the default exception-handler will simply terminate the thread (and store the error condition for later use). Pending {{dynamic-wind}} thunks will ''not'' be invoked. Use a custom exception handler for the thread in that case.
+
+The following procedures are provided, in addition to the procedures defined in SRFI-18:
+
+
+
+=== thread-signal!
+
+ [procedure] (thread-signal! THREAD X)
+
+This will cause {{THREAD}} to signal the condition {{X}} once it is scheduled
+for execution. After signalling the condition, the thread continues with its normal
+execution.
+
+=== thread-quantum
+
+ [procedure] (thread-quantum THREAD)
+
+Returns the quantum of {{THREAD}}, which is an exact integer
+specifying the approximate time-slice of the thread in milliseconds.
+
+=== thread-quantum-set!
+
+ [procedure] (thread-quantum-set! THREAD QUANTUM)
+
+Sets the quantum of {{THREAD}} to {{QUANTUM}}.
+
+=== thread-suspend!
+
+ [procedure] (thread-suspend! THREAD)
+
+Suspends the execution of {{THREAD}} until resumed.
+
+=== thread-resume!
+
+ [procedure] (thread-resume! THREAD)
+
+Readies the suspended thread {{THREAD}}.
+
+=== thread-wait-for-i/o!
+
+ [procedure] (thread-wait-for-i/o! FD [MODE])
+
+Suspends the current thread until input ({{MODE}} is {{#:input}}), output ({{MODE}} is {{#:output}})
+or both ({{MODE}} is {{#:all}}) is available. {{FD}} should be a file-descriptor (not a port!) open
+for input or output, respectively.
+
+=== time->milliseconds
+
+ [procedure] (time->milliseconds TIME)
+
+Converts a time object (as created via {{current-time}}) into an exact integer representing
+the number of milliseconds since process startup.
+
+=== milliseconds->time
+
+ [procedure] (milliseconds->time ms)
+
+Converts into a time object an exact integer representing
+the number of milliseconds since process startup.
+
+This procedure may be useful in combination with {{thread-sleep!}} when your compilation unit is using {{(declare fixnum-arithmetic)}}. In that case you won't be able to pass an inexact value to {{thread-sleep!}}, but you can do the following:
+
+ (define (thread-sleep!/ms ms)
+ (thread-sleep!
+ (milliseconds->time (+ ms (current-milliseconds)))))
+
+---
+Previous: [[Unit srfi-14]]
+
+Next: [[Unit srfi-69]]
diff --git a/manual/Unit srfi-4 b/manual/Unit srfi-4
new file mode 100644
index 00000000..6e629199
--- /dev/null
+++ b/manual/Unit srfi-4
@@ -0,0 +1,162 @@
+[[tags: manual]]
+[[toc:]]
+
+== Unit srfi-4
+
+Homogeneous numeric vectors, see the documentation for [[http://srfi.schemers.org/srfi-4/srfi-4.html|SRFI-4]]
+64-bit integer vectors ({{u64vector}} and {{s64vector}} are not supported.
+
+The basic constructor procedures for number vectors are extended to allow allocating the storage in non garbage
+collected memory:
+
+=== make-XXXvector
+
+ [procedure] (make-XXXvector SIZE [INIT NONGC FINALIZE])
+
+Creates a SRFI-4 homogenous number vector of length {{SIZE}}. If {{INIT}} is given, it specifies the initial
+value for each slot in the vector. The optional arguments {{NONGC}} and {{FINALIZE}} define whether the
+vector should be allocated in a memory area not subject to garbage collection and whether the associated storage
+should be automatically freed (using finalization) when there are no references from Scheme variables and data.
+{{NONGC}} defaults to {{#f}} (the vector will be located in normal garbage collected memory) and
+{{FINALIZE}} defaults to {{#t}}. Note that the {{FINALIZE}} argument is only used when {{NONGC}}
+is true.
+
+
+Additionally, the following procedures are provided:
+
+=== u8vector->blob
+=== s8vector->blob
+=== u16vector->blob
+=== s16vector->blob
+=== u32vector->blob
+=== s32vector->blob
+=== f32vector->blob
+=== f64vector->blob
+=== u8vector->blob/shared
+=== s8vector->blob/shared
+=== u16vector->blob/shared
+=== s16vector->blob/shared
+=== u32vector->blob/shared
+=== s32vector->blob/shared
+=== f32vector->blob/shared
+=== f64vector->blob/shared
+
+ [procedure] (u8vector->blob U8VECTOR)
+ [procedure] (s8vector->blob S8VECTOR)
+ [procedure] (u16vector->blob U16VECTOR)
+ [procedure] (s16vector->blob S16VECTOR)
+ [procedure] (u32vector->blob U32VECTOR)
+ [procedure] (s32vector->blob S32VECTOR)
+ [procedure] (f32vector->blob F32VECTOR)
+ [procedure] (f64vector->blob F64VECTOR)
+ [procedure] (u8vector->blob/shared U8VECTOR)
+ [procedure] (s8vector->blob/shared S8VECTOR)
+ [procedure] (u16vector->blob/shared U16VECTOR)
+ [procedure] (s16vector->blob/shared S16VECTOR)
+ [procedure] (u32vector->blob/shared U32VECTOR)
+ [procedure] (s32vector->blob/shared S32VECTOR)
+ [procedure] (f32vector->blob/shared F32VECTOR)
+ [procedure] (f64vector->blob/shared F64VECTOR)
+
+Each of these procedures return the contents of the given vector as a
+'packed' blob. The byte order in that vector is platform-dependent
+(for example little-endian on an '''Intel''' processor). The {{/shared}}
+variants return a blob that shares memory with the contents of the vector.
+
+
+=== blob->u8vector
+=== blob->s8vector
+=== blob->u16vector
+=== blob->s16vector
+=== blob->u32vector
+=== blob->s32vector
+=== blob->f32vector
+=== blob->f64vector
+=== blob->u8vector/shared
+=== blob->s8vector/shared
+=== blob->u16vector/shared
+=== blob->s16vector/shared
+=== blob->u32vector/shared
+=== blob->s32vector/shared
+=== blob->f32vector/shared
+=== blob->f64vector/shared
+
+ [procedure] (blob->u8vector BLOB)
+ [procedure] (blob->s8vector BLOB)
+ [procedure] (blob->u16vector BLOB)
+ [procedure] (blob->s16vector BLOB)
+ [procedure] (blob->u32vector BLOB)
+ [procedure] (blob->s32vector BLOB)
+ [procedure] (blob->f32vector BLOB)
+ [procedure] (blob->f64vector BLOB)
+ [procedure] (blob->u8vector/shared BLOB)
+ [procedure] (blob->s8vector/shared BLOB)
+ [procedure] (blob->u16vector/shared BLOB)
+ [procedure] (blob->s16vector/shared BLOB)
+ [procedure] (blob->u32vector/shared BLOB)
+ [procedure] (blob->s32vector/shared BLOB)
+ [procedure] (blob->f32vector/shared BLOB)
+ [procedure] (blob->f64vector/shared BLOB)
+
+Each of these procedures return a vector where the argument
+{{BLOB}} is taken as a 'packed' representation of the contents
+of the vector. The {{/shared}} variants return a vector that
+shares memory with the contents of the blob.
+
+
+=== subu8vector
+=== subu16vector
+=== subu32vector
+=== subs8vector
+=== subs16vector
+=== subs32vector
+=== subf32vector
+=== subf64vector
+
+ [procedure] (subu8vector U8VECTOR FROM TO)
+ [procedure] (subu16vector U16VECTOR FROM TO)
+ [procedure] (subu32vector U32VECTOR FROM TO)
+ [procedure] (subs8vector S8VECTOR FROM TO)
+ [procedure] (subs16vector S16VECTOR FROM TO)
+ [procedure] (subs32vector S32VECTOR FROM TO)
+ [procedure] (subf32vector F32VECTOR FROM TO)
+ [procedure] (subf64vector F64VECTOR FROM TO)
+
+Creates a number vector of the same type as the argument vector with the elements at the positions {{FROM}} up to but
+not including {{TO}}.
+
+SRFI-17 Setters for {{XXXvector-ref}} are defined.
+
+
+=== read-u8vector
+
+ [procedure] (read-u8vector LENGTH [PORT])
+
+Reads {{LENGTH}} bytes from the {{PORT}} and returns a fresh
+{{u8vector}} or less if end-of-file is encountered. {{PORT}} defaults to the
+value of {{(current-input-port)}}.
+If {{LENGTH}} is {{#f}}, the vector will be filled completely until end-of-file is reached.
+
+
+=== read-u8vector!
+
+ [procedure] (read-u8vector! LENGTH U8VECTOR [PORT [START]])
+
+Reads {{LENGTH}} bytes from the {{PORT}} writing the read input into
+{{U8VECTOR}} beginning at {{START}} (or 0 if not given). {{PORT}} defaults
+to the value of {{(current-input-port)}}.
+If {{LENGTH}} is {{#f}}, the vector will be filled completely until end-of-file is reached.
+This procedure returns the number of bytes read.
+
+
+=== write-u8vector
+
+ [procedure] (write-u8vector U8VECTOR [PORT [START [END]]])
+
+Writes the bytes {{U8VECTOR}} between the indices {{START}} (inclusive) and {{END}} (exclusive) to {{PORT}}.
+{{PORT}} defaults to the value of {{(current-output-port)}}.
+
+---
+Previous: [[Unit srfi-1]]
+
+Next: [[Unit srfi-13]]
diff --git a/manual/Unit srfi-69 b/manual/Unit srfi-69
new file mode 100644
index 00000000..c215ee30
--- /dev/null
+++ b/manual/Unit srfi-69
@@ -0,0 +1,370 @@
+[[tags: manual]]
+[[toc:]]
+
+== Unit srfi-69
+
+CHICKEN implements SRFI 69 with SRFI 90 extensions. For more information, see
+[[http://srfi.schemers.org/srfi-69/srfi-69.html|SRFI-69]] and
+[[http://srfi.schemers.org/srfi-90/srfi-90.html|SRFI-90]].
+
+
+=== Hash Table Procedures
+
+
+==== make-hash-table
+
+ [procedure] (make-hash-table [TEST HASH SIZE] [#:test TEST] [#:hash HASH] [#:size SIZE] [#:initial INITIAL] [#:min-load MIN-LOAD] [#:max-load MAX-LOAD] [#:weak-keys WEAK-KEYS] [#:weak-values WEAK-VALUES])
+
+Returns a new {{HASH-TABLE}} with the supplied configuration.
+
+; {{TEST}} : The equivalence function.
+; {{HASH}} : The hash function.
+; {{SIZE}} : The expected number of table elements.
+; {{INITIAL}} : The default initial value.
+; {{MIN-LOAD}} : The minimum load factor. A {{flonum}} in (0.0 1.0).
+; {{MAX-LOAD}} : The maximum load factor. A {{flonum}} in (0.0 1.0).
+; {{WEAK-KEYS}} : Use weak references for keys. (Ignored)
+; {{WEAK-VALUES}} : Use weak references for values. (Ignored)
+
+
+==== alist->hash-table
+
+ [procedure] (alist->hash-table A-LIST [#:test TEST] [#:hash HASH] [#:size SIZE] [#:initial INITIAL] [#:min-load MIN-LOAD] [#:max-load MAX-LOAD] [#:weak-keys WEAK-KEYS] [#:weak-values WEAK-VALUES])
+
+Returns a new {{HASH-TABLE}}. The {{HASH-TABLE}} is populated from the
+{{A-LIST}}. The keyword arguments are per {{make-hash-table}}.
+
+
+==== hash-table?
+
+ [procedure] (hash-table? OBJECT)
+
+Is the {{OBJECT}} a {{hash-table}}?
+
+
+==== hash-table-size
+
+ [procedure] (hash-table-size HASH-TABLE)
+
+The {{HASH-TABLE}} size.
+
+
+==== hash-table-equivalence-function
+
+ [procedure] (hash-table-equivalence-function HASH-TABLE)
+
+The {{HASH-TABLE}} {{equivalence-function}}.
+
+
+==== hash-table-hash-function
+
+ [procedure] (hash-table-hash-function HASH-TABLE)
+
+The {{HASH-TABLE}} {{hash-function}}.
+
+
+==== hash-table-min-load
+
+ [procedure] (hash-table-min-load HASH-TABLE)
+
+The {{HASH-TABLE}} minimum load factor.
+
+
+==== hash-table-max-load
+
+ [procedure] (hash-table-max-load HASH-TABLE)
+
+The {{HASH-TABLE}} maximum load factor.
+
+
+==== hash-table-weak-keys
+
+ [procedure] (hash-table-weak-keys HASH-TABLE)
+
+Does the {{HASH-TABLE}} weak references for keys?
+
+
+==== hash-table-weak-values
+
+ [procedure] (hash-table-weak-values HASH-TABLE)
+
+Does the {{HASH-TABLE}} weak references for values?
+
+
+==== hash-table-has-initial?
+
+ [procedure] (hash-table-has-initial? HASH-TABLE)
+
+Does the {{HASH-TABLE}} have a default initial value?
+
+
+==== hash-table-initial
+
+ [procedure] (hash-table-initial HASH-TABLE)
+
+The {{HASH-TABLE}} default initial value.
+
+
+==== hash-table-keys
+
+ [procedure] (hash-table-keys HASH-TABLE)
+
+Returns a list of the keys in the {{HASH-TABLE}} population.
+
+
+==== hash-table-values
+
+ [procedure] (hash-table-values HASH-TABLE)
+
+Returns a list of the values in the {{HASH-TABLE}} population.
+
+
+==== hash-table->alist
+
+ [procedure] (hash-table->alist HASH-TABLE)
+
+Returns the population of the {{HASH-TABLE}} as an {{a-list}}.
+
+
+
+==== hash-table-ref
+
+ [procedure] (hash-table-ref HASH-TABLE KEY)
+
+Returns the {{VALUE}} for the {{KEY}} in the {{HASH-TABLE}}.
+
+Aborts with an exception when the {{KEY}} is missing.
+
+
+==== hash-table-ref/default
+
+ [procedure] (hash-table-ref/default HASH-TABLE KEY DEFAULT)
+
+Returns the {{VALUE}} for the {{KEY}} in the {{HASH-TABLE}}, or the {{DEFAULT}}
+when the {{KEY}} is missing.
+
+
+==== hash-table-exists?
+
+ [procedure] (hash-table-exists? HASH-TABLE KEY)
+
+Does the {{KEY}} exist in the {{HASH-TABLE}}?
+
+
+==== hash-table-set!
+
+ [procedure] (hash-table-set! HASH-TABLE KEY VALUE)
+
+Set the {{VALUE}} for the {{KEY}} in the {{HASH-TABLE}}.
+
+A setter for {{hash-table-ref}} is defined, so
+
+<enscript highlight=scheme>
+(set! (hash-table-ref HASH-TABLE KEY) VALUE)
+</enscript>
+
+is equivalent to
+
+<enscript highlight=scheme>
+(hash-table-set! HASH-TABLE KEY VALUE)
+</enscript>
+
+
+==== hash-table-update!
+
+ [procedure] (hash-table-update! HASH-TABLE KEY [UPDATE-FUNCTION [DEFAULT-VALUE-FUNCTION]])
+
+Sets or replaces the {{VALUE}} for {{KEY}} in the {{HASH-TABLE}}.
+
+The {{UPDATE-FUNCTION}} takes the existing {{VALUE}} for {{KEY}} and returns
+the new {{VALUE}}. The default is {{identity}}
+
+The {{DEFAULT-VALUE-FUNCTION}} is called when the entry for {{KEY}} is missing.
+The default uses the {{(hash-table-initial-value)}}, if provided. Otherwise
+aborts with an exception.
+
+Returns the new {{VALUE}}.
+
+
+==== hash-table-update!/default
+
+ [procedure] (hash-table-update! HASH-TABLE KEY UPDATE-FUNCTION DEFAULT-VALUE)
+
+Sets or replaces the {{VALUE}} for {{KEY}} in the {{HASH-TABLE}}.
+
+The {{UPDATE-FUNCTION}} takes the existing {{VALUE}} for {{KEY}} and returns
+the new {{VALUE}}.
+
+The {{DEFAULT-VALUE}} is used when the entry for {{KEY}} is missing.
+
+Returns the new {{VALUE}}.
+
+
+==== hash-table-copy
+
+ [procededure] (hash-table-copy HASH-TABLE)
+
+Returns a shallow copy of the {{HASH-TABLE}}.
+
+
+==== hash-table-delete!
+
+ [procedure] (hash-table-delete! HASH-TABLE KEY)
+
+Deletes the entry for {{KEY}} in the {{HASH-TABLE}}.
+
+
+==== hash-table-remove!
+
+ [procedure] (hash-table-remove! HASH-TABLE PROC)
+
+Calls {{PROC}} for all entries in {{HASH-TABLE}} with the key and value of each
+entry. If {{PROC}} returns true, then that entry is removed.
+
+
+==== hash-table-clear!
+
+ [procedure] (hash-table-clear! HASH-TABLE)
+
+Deletes all entries in {{HASH-TABLE}}.
+
+
+==== hash-table-merge
+
+ [procedure] (hash-table-merge HASH-TABLE-1 HASH-TABLE-2)
+
+Returns a new {{HASH-TABLE}} with the union of {{HASH-TABLE-1}} and
+{{HASH-TABLE-2}}.
+
+
+==== hash-table-merge!
+
+ [procedure] (hash-table-merge! HASH-TABLE-1 HASH-TABLE-2)
+
+Returns {{HASH-TABLE-1}} as the union of {{HASH-TABLE-1}} and
+{{HASH-TABLE-2}}.
+
+
+==== hash-table-map
+
+ [procedure] (hash-table-map HASH-TABLE FUNC)
+
+Calls {{FUNC}} for all entries in {{HASH-TABLE}} with the key and value of each
+entry.
+
+Returns a list of the results of each call.
+
+
+==== hash-table-fold
+
+ [procedure] (hash-table-fold HASH-TABLE FUNC INIT)
+
+Calls {{FUNC}} for all entries in {{HASH-TABLE}} with the key and value of each
+entry, and the current folded value. The initial folded value is {{INIT}}.
+
+Returns the final folded value.
+
+
+==== hash-table-for-each
+
+ [procedure] (hash-table-for-each HASH-TABLE PROC)
+
+Calls {{PROC}} for all entries in {{HASH-TABLE}} with the key and value of each
+entry.
+
+
+==== hash-table-walk
+
+ [procedure] (hash-table-walk HASH-TABLE PROC)
+
+Calls {{PROC}} for all entries in {{HASH-TABLE}} with the key and value of each
+entry.
+
+
+=== Hashing Functions
+
+All hash functions return a {{fixnum}} in the range [0 {{BOUND}}).
+
+
+==== number-hash
+
+ [procedure] (number-hash NUMBER [BOUND])
+
+For use with {{=}} as a {{hash-table-equivalence-function}}.
+
+
+==== object-uid-hash
+
+ [procedure] (object-uid-hash OBJECT [BOUND])
+
+Currently a synonym for {{equal?-hash}}.
+
+
+==== symbol-hash
+
+ [procedure] (symbol-hash SYMBOL [BOUND])
+
+For use with {{eq?}} as a {{hash-table-equivalence-function}}.
+
+
+==== keyword-hash
+
+ [procedure] (keyword-hash KEYWORD [BOUND])
+
+For use with {{eq?}} as a {{hash-table-equivalence-function}}.
+
+
+==== string-hash
+
+ [procedure] (string-hash STRING [BOUND START END])
+
+For use with {{string=?}} as a {{hash-table-equivalence-function}}.
+The optional {{START}} and {{END}} arguments may be given to limit
+the hash calculation to a specific sub-section of {{STRING}}.
+
+
+==== string-ci-hash
+
+ [procedure] (string-hash-ci STRING [BOUND START END])
+ [procedure] (string-ci-hash STRING [BOUND START END])
+
+For use with {{string-ci=?}} as a {{hash-table-equivalence-function}}.
+
+
+==== eq?-hash
+
+ [procedure] (eq?-hash OBJECT [BOUND])
+
+For use with {{eq?}} as a {{hash-table-equivalence-function}}.
+
+
+==== eqv?-hash
+
+ [procedure] (eqv?-hash OBJECT [BOUND])
+
+For use with {{eqv?}} as a {{hash-table-equivalence-function}}.
+
+
+==== equal?-hash
+
+ [procedure] (equal?-hash OBJECT [BOUND])
+
+For use with {{equal?}} as a {{hash-table-equivalence-function}}.
+
+
+==== hash
+
+ [procedure] (hash OBJECT [BOUND])
+
+Synonym for {{equal?-hash}}.
+
+
+==== hash-by-identity
+
+ [procedure] (hash-by-identity OBJECT [BOUND])
+
+Synonym for {{eq?-hash}}.
+
+Previous: [[Unit srfi-18]]
+Next: [[Unit posix]]
+
diff --git a/manual/Unit tcp b/manual/Unit tcp
new file mode 100644
index 00000000..5b984c0d
--- /dev/null
+++ b/manual/Unit tcp
@@ -0,0 +1,212 @@
+[[tags: manual]]
+[[toc:]]
+
+== Unit tcp
+
+This unit provides basic facilities for communicating over TCP sockets.
+The socket interface should be mostly compatible to the one found in
+PLT Scheme.
+
+This unit uses the {{extras}} unit.
+
+All errors related to failing network operations will raise a condition
+of kind {{(exn i/o network)}}.
+
+
+=== tcp-listen
+
+<procedure>(tcp-listen TCPPORT [BACKLOG [HOST]])</procedure>
+
+Creates and returns a TCP listener object that listens for connections on {{TCPPORT}}, which
+should be an exact integer. {{BACKLOG}} specifies the number of maximally pending
+connections (and defaults to 4). If the optional argument {{HOST}} is given and not
+{{#f}}, then only incoming connections for the given host (or IP) are accepted.
+
+
+=== tcp-listener?
+
+<procedure>(tcp-listener? X)</procedure>
+
+Returns {{#t}} if {{X}} is a TCP listener object, or {{#f}} otherwise.
+
+
+=== tcp-close
+
+<procedure>(tcp-close LISTENER)</procedure>
+
+Reclaims any resources associated with {{LISTENER}}.
+
+
+=== tcp-accept
+
+<procedure>(tcp-accept LISTENER)</procedure>
+
+Waits until a connection is established on the port on which
+{{LISTENER}} is listening and returns two values: an input- and
+output-port that can be used to communicate with the remote
+process. The current value of {{tcp-accept-timeout}} is used to
+determine the maximal number of milliseconds (if any) to wait
+until a connection is established. When a client connects any
+read- and write-operations on the returned ports will use the
+current values (at the time of the connection) of {{tcp-read-timeout}}
+and {{tcp-write-timeout}}, respectively, to determine the maximal
+number of milliseconds to wait for input/output before a timeout
+error is signalled.
+
+Note: this operation and any I/O on the ports returned will not block
+other running threads.
+
+
+=== tcp-accept-ready?
+
+<procedure>(tcp-accept-ready? LISTENER)</procedure>
+
+Returns {{#t}} if there are any connections pending on {{LISTENER}}, or {{#f}}
+otherwise.
+
+
+=== tcp-listener-port
+
+<procedure>(tcp-listener-port LISTENER)</procedure>
+
+Returns the port number assigned to {{LISTENER}} (If you pass {{0}} to {{tcp-listen}},
+then the system will choose a port-number for you).
+
+=== tcp-listener-fileno
+
+<procedure>(tcp-listener-fileno LISTENER)</procedure>
+
+Returns the file-descriptor associated with {{LISTENER}}.
+
+
+=== tcp-connect
+
+<procedure>(tcp-connect HOSTNAME [TCPPORT])</procedure>
+
+Establishes a client-side TCP connection to the machine with the name
+{{HOSTNAME}} (a string) at {{TCPPORT}} (an exact integer) and returns
+two values: an input- and output-port for communicating with the
+remote process. The current value of {{tcp-connect-timeout}} is used
+to determine the maximal number of milliseconds (if any) to wait until
+the connection is established. When the connection takes place any
+read- and write-operations on the returned ports will use the current
+values (at the time of the call to {{tcp-connect}}) of {{tcp-read-timeout}} and
+{{tcp-write-timeout}}, respectively, to determine the maximal number
+of milliseconds to wait for input/output before a timeout error is
+signalled.
+
+If the {{TCPPORT}} is omitted, the port is parsed from the {{HOSTNAME}} string. The format expected is {{HOSTNAME:PORT}}. The {{PORT}} can either be a string representation of an integer or a service name which is translated to an integer using the POSIX function [[http://www.opengroup.org/onlinepubs/009695399/functions/getservbyname.html|{{getservbyname}}]].
+
+Note: any I/O on the ports returned will not block other running threads.
+
+
+=== tcp-addresses
+
+<procedure>(tcp-addresses PORT)</procedure>
+
+Returns two values for the input- or output-port {{PORT}} (which should be a port returned
+by either {{tcp-accept}} or {{tcp-connect}}): the IP address of the local and the remote
+machine that are connected over the socket associated with {{PORT}}. The returned addresses
+are strings in {{XXX.XXX.XXX.XXX}} notation.
+
+
+=== tcp-port-numbers
+
+<procedure>(tcp-port-numbers PORT)</procedure>
+
+Returns two values for the input- or output-port {{PORT}} (which should be a port returned
+by either {{tcp-accept}} or {{tcp-connect}}): the TCP port numbers of the local and the remote
+machine that are connected over the socket associated with {{PORT}}.
+
+
+=== tcp-abandon-port
+
+<procedure>(tcp-abandon-port PORT)</procedure>
+
+Marks the socket port {{PORT}} as abandoned. This is mainly useful to close down a port
+without breaking the connection.
+
+
+=== tcp-buffer-size
+
+ [parameter] tcp-buffer-size
+
+Sets the size of the output buffer. By default no output-buffering for
+TCP output is done, but to improve performance by minimizing the
+number of TCP packets, buffering may be turned on by setting this
+parameter to an exact integer greater zero. A buffer size of zero or {{#f}}
+turns buffering off. The setting of this parameter takes effect at the time
+when the I/O ports for a particular socket are created, i.e. when {{tcp-connect}}
+or {{tcp-accept}} is called.
+
+Note that since output is not immediately written to the associated socket, you
+may need to call {{flush-output}}, once you want the output to be transmitted.
+Closing the output port will flush automatically.
+
+=== tcp-read-timeout
+
+ [parameter] tcp-read-timeout
+
+Determines the timeout for TCP read operations in milliseconds. A timeout of
+{{#f}} disables timeout checking. The default read timeout is 60000, i.e.
+1 minute.
+
+=== tcp-write-timeout
+
+ [parameter] tcp-write-timeout
+
+Determines the timeout for TCP write operations in milliseconds. A timeout of
+{{#f}} disables timeout checking. The default write timeout is 60000, i.e.
+1 minute.
+
+=== tcp-connect-timeout
+
+ [parameter] tcp-connect-timeout
+
+Determines the timeout for {{tcp-connect}} operations in milliseconds. A timeout of
+{{#f}} disables timeout checking and is the default.
+
+
+=== tcp-accept-timeout
+
+ [parameter] tcp-accept-timeout
+
+Determines the timeout for {{tcp-accept}} operations in milliseconds. A timeout of
+{{#f}} disables timeout checking and is the default.
+
+
+=== Example
+
+A very simple example follows. Say we have the two files {{client.scm}}
+and {{server.scm}}:
+
+<enscript highlight=scheme>
+ ; client.scm
+ (declare (uses tcp))
+ (define-values (i o) (tcp-connect "localhost" 4242))
+ (write-line "Good Bye!" o)
+ (print (read-line i))
+</enscript>
+
+<enscript highlight=scheme>
+ ; server.scm
+ (declare (uses tcp))
+ (define l (tcp-listen 4242))
+ (define-values (i o) (tcp-accept l))
+ (write-line "Hello!" o)
+ (print (read-line i))
+ (close-input-port i)
+ (close-output-port o)
+</enscript>
+
+ % csc server.scm
+ % csc client.scm
+ % ./server &
+ % ./client
+ Good Bye!
+ Hello!
+
+---
+Previous: [[Unit utils]]
+
+Next: [[Unit lolevel]]
diff --git a/manual/Unit utils b/manual/Unit utils
new file mode 100644
index 00000000..8e5b88e4
--- /dev/null
+++ b/manual/Unit utils
@@ -0,0 +1,99 @@
+[[tags: manual]]
+[[toc:]]
+
+
+== Unit utils
+
+This unit contains a "grab bag" of procedures without a good home, and which
+don't have to be available by default (as compared to the [[Unit
+extras|extras]] unit).
+
+This unit uses the {{extras}} and {{srfi-13}} units.
+
+
+=== Executing shell commands with formatstring and error checking
+
+==== system*
+
+ [procedure] (system* FORMATSTRING ARGUMENT1 ...)
+
+Similar to {{(system (sprintf FORMATSTRING ARGUMENT1 ...))}},
+but signals an error if the invoked program should return a nonzero
+exit status.
+
+=== Reading a file's contents
+
+==== read-all
+
+ [procedure] (read-all [FILE-OR-PORT])
+
+If {{FILE-OR-PORT}} is a string, then this procedure returns the contents of the file
+as a string. If {{FILE-OR-PORT}} is a port, all remaining input is read and returned as
+a string. The port is not closed. If no argument is provided, input will be read from the
+port that is the current value of {{(current-input-port)}}.
+
+
+=== Shell argument quoting
+
+==== qs
+
+ [procedure] (qs STRING [PLATFORM])
+
+Escapes {{STRING}} suitably for passing to a shell command on {{PLATFORM}}.
+{{PLATFORM}} defaults to the value of {{(build-platform)}} and indicates in
+which style the argument should be quoted. On Windows systems, the string
+is simply enclosed in double-quote ({{"}}) characters, on UNIXish systems,
+characters that would have a special meaning to the shell are escaped
+using backslash ({{\}}).
+
+
+=== Dynamic compilation
+
+==== compile-file
+
+ [procedure] (compile-file FILENAME #!key options output-file load)
+
+Compiles the Scheme source file {{FILENAME}} into a dynamically
+loadable library by invoking the {{csc}} compiler driver. If the
+library can be successfully created and {{load}} is not given or
+true, the file is loaded into the current
+Scheme process. {{options}} may be a list of strings which are passed
+as additional command line options to {{csc}}. If {{output-file}} is
+not given, then the compiled file is stored in a temporary location
+and will be deleted when the process exits successfully.
+When compilation and loading succeeds, the name of the compiled file
+is returned.
+
+Notes:
+
+* loading the same compiled file multiple times is only supported on Linux
+ in the moment and should be considered unreliable. For this reason, a new temporary
+ file is created for every invocation of {{compile-file}}, unless an explicit
+ output file name is given.
+
+* this procedure is compatible to the {{scheme-compile-file}} command in {{emacs}}' {{scheme-mode}}.
+
+==== compile-file-options
+
+ [parameter] compile-file-options
+
+A parameter that holds a list of default options that should be given
+to {{csc}} after invocation of the {{compile-file}} procedure.
+The initial default options are {{-scrutinize -O2 -d2}}.
+
+=== Shell argument quoting
+
+==== qs
+
+ [procedure] (qs STRING [PLATFORM])
+
+Escapes {{STRING}} suitably for passing to a shell command on {{PLATFORM}}.
+{{PLATFORM}} defaults to the value of {{(build-platform)}} and indicates in
+which style the argument should be quoted. On Windows systems, the string
+is simply enclosed in double-quote ({{"}}) characters, on UNIXish systems,
+characters that would have a special meaning to the shell are escaped
+using backslash ({{\}}).
+
+Previous: [[Unit posix]]
+
+Next: [[Unit tcp]]
diff --git a/manual/Using the compiler b/manual/Using the compiler
new file mode 100644
index 00000000..7a751e2f
--- /dev/null
+++ b/manual/Using the compiler
@@ -0,0 +1,466 @@
+[[tags: manual]]
+[[toc:]]
+
+== Using the compiler
+
+The interface to {{chicken}} is intentionally simple. System
+dependent makefiles, shell-scripts or batch-files should perform
+any necessary steps before and after invocation of {{chicken}}.
+A program named {{csc}} provides a more convenient and concise
+interface to the Scheme- and C-compilers and linker. Enter
+
+ csc -help
+
+on the command line for more information.
+
+=== Compiler command line format
+
+ chicken FILENAME {OPTION}
+
+{{FILENAME}} is the complete pathname of the source file that is to
+be translated into C. A filename argument of {{-}} specifies that
+the source text should be read from standard input. Note that the filename
+has to be the first argument to {{chicken}}.
+
+Possible options are:
+
+; -analyze-only : Stop compilation after first analysis pass.
+
+; -benchmark-mode : Equivalent to {{-no-trace -no-lambda-info -optimize-level 4}} {{-fixnum-arithmetic -disable-interrupts -block -inline -lambda-lift}}.
+
+; -block : Enable block-compilation. When this option is specified, the compiler assumes that global variables are not modified outside this compilation-unit. Specifically, toplevel bindings are not seen by {{eval}} and unused toplevel bindings are removed.
+
+; -case-insensitive : Enables the reader to read symbols case insensitive. The default is to read case sensitive (in violation of R5RS). This option registers the {{case-insensitive}} feature identifier.
+
+; -check-syntax : Aborts compilation process after macro-expansion and syntax checks.
+
+; -consult-inline-file FILENAME : load file with definitions for cross-module inlining generated by a previous compiloer invocation via {{-emit-inline-file}}. Implies {{-inline}}.
+
+; -debug MODES : Enables one or more compiler debugging modes. {{MODES}} is a string of characters that select debugging information about the compiler that will be printed to standard output.
+
+ t show time needed for compilation
+ b show breakdown of time needed for each compiler pass
+ o show performed optimizations
+ r show invocation parameters
+ s show program-size information and other statistics
+ a show node-matching during simplification
+ p show execution of compiler sub-passes
+ l show lambda-lifting information
+ m show GC statistics during compilation
+ n print the line-number database
+ c print every expression before macro-expansion
+ u lists all unassigned global variable references
+ d lists all assigned global variables
+ x display information about experimental features
+ D when printing nodes, use node-tree output
+ N show the real-name mapping table
+ 0 show database before lambda-lifting pass
+ T show expressions after converting to node tree
+ L show expressions after lambda-lifting
+ M show syntax-/runtime-requirements
+ 1 show source expressions
+ 2 show canonicalized expressions
+ 3 show expressions converted into CPS
+ 4 show database after each analysis pass
+ 5 show expressions after each optimization pass
+ 6 show expressions after each inlining pass
+ 7 show expressions after complete optimization
+ 8 show database after final analysis
+ 9 show expressions after closure conversion
+
+; -debug-level LEVEL : Selects amount of debug-information. {{LEVEL}} should be an integer.
+
+ -debug-level 0 is equivalent to -no-trace -no-lambda-info
+ -debug-level 1 is equivalent to -no-trace
+ -debug-level 2 does nothing (the default)
+
+; -disable-interrupts : Equivalent to the {{(disable-interrupts)}} declaration. No interrupt-checks are generated for compiled programs.
+
+; -disable-stack-overflow-checks : Disables detection of stack overflows. This is equivalent to running the compiled executable with the {{-:o}} runtime option.
+
+; -disable-warning CLASS : Disables specific class of warnings, may be given multiple times. The following classes are defined:
+
+ usage warnings related to command-line arguments
+ type warnings related to type-conversion
+ ext warnings related to extension libraries
+ var warnings related to variable- and syntax-definitions and use
+ const warnings related to constant-definitions
+ syntax syntax-related warnings
+ redef warnings about redefinitions of standard- or extended-bindings
+ call warnings related to known procedure calls
+ ffi warnings related to the foreign function interface
+
+; -dynamic : This option should be used when compiling files intended to be loaded dynamically into a running Scheme program.
+
+; -epilogue FILENAME : Includes the file named {{FILENAME}} at the end of the compiled source file. The include-path is not searched. This option may be given multiple times.
+
+; -emit-all-import-libraries : emit import libraries for all modules defined in the current compulation unit (see also: {{-emit-import-library}}).
+
+; -emit-external-prototypes-first : Emit prototypes for callbacks defined with {{define-external}} before any other foreign declarations. This is sometimes useful, when C/C++ code embedded into the a Scheme program has to access the callbacks. By default the prototypes are emitted after foreign declarations.
+
+; -emit-import-library MODULE : Specifies that an import library named {{MODULE.import.scm}} for the named module should be generated (equivalent to using the {{emit-import-library}} declaration).
+
+; -emit-inline-file FILENAME : Write procedures that can be globally inlined in internal form to {{FILENAME}}, if global inlining is enabled. Implies {{-inline -local}}.
+
+; -explicit-use : Disables automatic use of the units {{library, eval}} and {{extras}}. Use this option if compiling a library unit instead of an application unit.
+
+; -extend FILENAME : Loads a Scheme source file or compiled Scheme program (on systems that support it) before compilation commences. This feature can be used to extend the compiler. This option may be given multiple times. The file is also searched in the current include path and in the extension-repository.
+
+; -feature SYMBOL : Registers {{SYMBOL}} to be a valid feature identifier for {{cond-expand}}. Multiple symbols may be given, if comma-separated.
+
+; -fixnum-arithmetic : Equivalent to {{(fixnum-arithmetic)}} declaration. Assume all mathematical operations use small integer arguments.
+
+; -heap-size NUMBER : Sets a fixed heap size of the generated executable to {{NUMBER}} bytes. The parameter may be followed by a {{M}} ({{m}}) or {{K}} ({{k}}) suffix which stand for mega- and kilobytes, respectively. The default heap size is 5 kilobytes. Note that only half of it is in use at every given time.
+
+; -heap-initial-size NUMBER : Sets the size that the heap of the compiled application should have at startup time.
+
+; -heap-growth PERCENTAGE : Sets the heap-growth rate for the compiled program at compile time (see: {{-:hg}}).
+
+; -heap-shrinkage PERCENTAGE : Sets the heap-shrinkage rate for the compiled program at compile time (see: {{-:hs}}).
+
+; -help : Print a summary of available options and the format of the command line parameters and exit the compiler.
+
+; -ignore-repository : Do not load any extensions from the repository (treat repository as empty). Also do not consult compiled (only interpreted) import libraries in {{import}} forms.
+
+; -include-path PATHNAME : Specifies an additional search path for files included via the {{include}} special form. This option may be given multiple times. If the environment variable {{CHICKEN_INCLUDE_PATH}} is set, it should contain a list of alternative include pathnames separated by {{;}}.
+
+; -inline : Enable procedure inlining for known procedures of a size below the threshold (which can be set through the {{-inline-limit}} option).
+
+; -inline-global : Enable cross-module inlining (in addition to local inlining). Implies {{-inline}}. For more information, see also [[Declarations]].
+
+; -inline-limit THRESHOLD : Sets the maximum size of a potentially inlinable procedure. The default threshold is {{20}}.
+
+; -keyword-style STYLE : Enables alternative keyword syntax, where {{STYLE}} may be either {{prefix}} (as in Common Lisp), {{suffix}} (as in DSSSL) or {{none}}. Any other value is ignored. The default is {{suffix}}.
+
+; -keep-shadowed-macros : Do not remove macro definitions with the same name as assigned toplevel variables (the default is to remove the macro definition).
+
+; -lambda-lift : Enable the optimization known as lambda-lifting.
+
+; -local : Assume toplevel variables defined in the current compilation unit are not externally modified.
+
+; -no-argc-checks : disable argument count checks
+
+; -no-bound-checks : disable bound variable checks
+
+; -no-lambda-info : Don't emit additional information for each {{lambda}} expression (currently the argument-list, after alpha-conversion/renaming).
+
+; -no-parentheses-synonyms STYLE : Disables list delimiter synonyms, [..] and {...} for (...).
+
+; -no-procedure-checks : disable procedure call checks
+
+; -no-procedure-checks-for-usual-bindings : disable procedure call checks only for usual bindings
+
+; -no-symbol-escape : Disables support for escaped symbols, the |...| form.
+
+; -no-trace : Disable generation of tracing information. If a compiled executable should halt due to a runtime error, then a list of the name and the line-number (if available) of the last procedure calls is printed, unless {{-no-trace}} is specified. With this option the generated code is slightly faster.
+
+; -no-warnings : Disable generation of compiler warnings.
+
+; -nursery NUMBER :
+; -stack-size NUMBER : Sets the size of the first heap-generation of the generated executable to {{NUMBER}} bytes. The parameter may be followed by a {{M}} ({{m}}) or {{K}} ({{k}}) suffix. The default stack-size depends on the target platform.
+
+; -optimize-leaf-routines : Enable leaf routine optimization.
+
+; -optimize-level LEVEL : Enables certain sets of optimization options. {{LEVEL}} should be an integer.
+
+ -optimize-level 0 does nothing.
+ -optimize-level 1 is equivalent to -optimize-leaf-routines
+ -optimize-level 2 is currently the same as -optimize-level 1 -inline
+ -optimize-level 3 is equivalent to -optimize-leaf-routines -local -inline
+ -optimize-level 4 is equivalent to -optimize-leaf-routines -local -inline -unsafe
+
+; -output-file FILENAME : Specifies the pathname of the generated C file. Default is {{FILENAME.c}}.
+
+; -postlude EXPRESSIONS : Add {{EXPRESSIONS}} after all other toplevel expressions in the compiled file. This option may be given multiple times. Processing of this option takes place after processing of {{-epilogue}}.
+
+; -prelude EXPRESSIONS : Add {{EXPRESSIONS}} before all other toplevel expressions in the compiled file. This option may be given multiple times. Processing of this option takes place before processing of {{-prologue}}.
+
+; -profile :
+; -accumulate-profile : Instruments the source code to count procedure calls and execution times. After the program terminates (either via an explicit {{exit}} or implicitly), profiling statistics are written to a file named {{PROFILE}}. Each line of the generated file contains a list with the procedure name, the number of calls and the time spent executing it. Use the {{chicken-profile}} program to display the profiling information in a more user-friendly form. Enter {{chicken-profile}} with no arguments at the command line to get a list of available options. The {{-accumulate-profile}} option is similar to {{-profile}}, but the resulting profile information will be appended to any existing {{PROFILE}} file. {{chicken-profile}} will merge and sum up the accumulated timing information, if several entries for the same procedure calls exist.
+
+; -profile-name FILENAME : Specifies name of the generated profile information (which defaults to {{PROFILE}}. Implies {{-profile}}.
+
+; -prologue FILENAME : Includes the file named {{FILENAME}} at the start of the compiled source file. The include-path is not searched. This option may be given multiple times.
+
+; -r5rs-syntax : Disables the Chicken extensions to R5RS syntax. Does not disable [[Non-standard read syntax|non-standard read syntax]].
+
+; -raw : Disables the generation of any implicit code that uses the Scheme libraries (that is all runtime system files besides {{runtime.c}} and {{chicken.h}}).
+
+; -require-extension NAME : Loads the extension {{NAME}} before the compilation process commences. This is identical to adding {{(require-extension NAME)}} at the start of the compiled program. If {{-uses NAME}} is also given on the command line, then any occurrences of {{-require-extension NAME}} are replaced with {{(declare (uses NAME))}}. Multiple names may be given and should be separated by {{,}}.
+
+; -setup-mode : When locating extension, search the current directory first. By default, extensions are located first in the ''extension repository'', where {{chicken-install}} stores compiled extensions and their associated metadata.
+
+; -scrutinize : Enable simple flow-analysis to catch common type errors and argument/result mismatches. You can also use the {{scrutinize}} declaration to enable scrutiny.
+
+; -static-extension NAME : similar to {{-require-extension NAME}}, but links extension statically (also applies for an explicit {{(require-extension NAME)}}).
+
+; -types FILENAME : load additional type database from {{FILENAME}}. Type-definitions in {{FILENAME}} will override previous type-definitions.
+
+; -compile-syntax : Makes macros also available at run-time. By default macros are not available at run-time.
+
+; -to-stdout : Write compiled code to standard output instead of creating a {{.c}} file.
+
+; -unit NAME : Compile this file as a library unit. Equivalent to {{-prelude "(declare (unit NAME))"}}
+
+; -unsafe : Disable runtime safety checks.
+
+; -unsafe-libraries : Marks the generated file for being linked with the unsafe runtime system. This should be used when generating shared object files that are to be loaded dynamically. If the marker is present, any attempt to load code compiled with this option will signal an error.
+
+; -uses NAME : Use definitions from the library unit {{NAME}}. This is equivalent to {{-prelude "(declare (uses NAME))"}}. Multiple arguments may be given, separated by {{,}}.
+
+; -no-usual-integrations : Specifies that standard procedures and certain internal procedures may be redefined, and can not be inlined. This is equivalent to declaring {{(not usual-integrations)}}.
+
+; -version : Prints the version and some copyright information and exit the compiler.
+
+; -verbose : Prints progress information to standard output during compilation.
+
+The environment variable {{CHICKEN_OPTIONS}} can be set to a string
+with default command-line options for the compiler.
+
+=== Runtime options
+
+After successful compilation a C source file is generated and can be
+compiled with a C compiler. Executables generated with CHICKEN (and the
+compiler itself) accept a small set of runtime options:
+
+; {{-:?}} : Shows a list of the available runtime options and exits the program.
+
+; {{-:aNUMBER}} : Specifies the length of the buffer for recording a trace of the last invoked procedures. Defaults to 16.
+
+; {{-:b}} : Enter a read-eval-print-loop when an error is encountered.
+
+; {{-:B}} : Sounds a bell (ASCII 7) on every major garbage collection.
+
+; {{-:c}} : Forces console mode. Currently this is only used in the interpreter ({{csi}}) to force output of the {{#;N>}} prompt even if stdin is not a terminal (for example if running in an {{emacs}} buffer under Windows).
+
+; {{-:d}} : Prints some debug-information at runtime.
+
+; {{-:D}} : Prints some more debug-information at runtime.
+
+; {{-:fNUMBER}} : Specifies the maximal number of currently pending finalizers before finalization is forced.
+
+; {{-:hNUMBER}} : Specifies fixed heap size
+
+; {{-:hgPERCENTAGE}} : Sets the growth rate of the heap in percent. If the heap is exhausted, then it will grow by {{PERCENTAGE}}. The default is 200.
+
+; {{-:hiNUMBER}} : Specifies the initial heap size
+
+; {{-:hmNUMBER}} : Specifies a maximal heap size. The default is (2GB - 15).
+
+; {{-:hsPERCENTAGE}} : Sets the shrink rate of the heap in percent. If no more than a quarter of {{PERCENTAGE}} of the heap is used, then it will shrink to {{PERCENTAGE}}. The default is 50. Note: If you want to make sure that the heap never shrinks, specify a value of {{0}}. (this can be useful in situations where an optimal heap-size is known in advance).
+
+; {{-:o}} : Disables detection of stack overflows at run-time.
+
+; {{-:r}} : Writes trace output to stderr. This option has no effect with in files compiled with the {{-no-trace}} options.
+
+; {{-:sNUMBER}} : Specifies stack size.
+
+; {{-:tNUMBER}} : Specifies symbol table size.
+
+; {{-:w}} : Enables garbage collection of unused symbols. By default unused and unbound symbols are not garbage collected.
+
+; {{-:x}} : Raises uncaught exceptions of separately spawned threads in primordial thread. By default uncaught exceptions in separate threads are not handled, unless the primordial one explicitly joins them. When warnings are enabled (the default) and {{-:x}} is not given, a warning will be shown, though.
+
+The argument values may be given in bytes, in kilobytes (suffixed with
+{{K}} or {{k}}), in megabytes (suffixed with {{M}}
+or {{m}}), or in gigabytes (suffixed with {{G}}
+or {{g}}). Runtime options may be combined, like {{-:dc}},
+but everything following a {{NUMBER}} argument is ignored. So
+{{-:wh64m}} is OK, but {{-:h64mw}} will not enable GC of
+unused symbols.
+=== Examples
+
+==== A simple example (with one source file)
+
+To compile a Scheme program (assuming a UNIX-like environment) consisting of a single source file, perform the following steps.
+
+===== Writing your source file
+
+In this example we will assume your source file is called {{foo.scm}}:
+
+<enscript highlight=scheme>
+;;; foo.scm
+
+(define (fac n)
+ (if (zero? n)
+ 1
+ (* n (fac (- n 1))) ) )
+
+(write (fac 10))
+(newline)
+</enscript>
+
+===== Compiling your program
+
+Compile the file {{foo.scm}}:
+
+ % csc foo.scm
+
+This will produce the {{foo}} executable:
+
+ % ls
+ foo foo.scm
+
+===== Running your program
+
+To run your newly compiled executable use:
+
+ % foo
+ 3628800
+
+If you get a {{foo: command not found}} error, you might want to try with {{./foo}} instead
+(or, in Unix machines, modify your {{PATH}} environment variable to include your current directory).
+==== An example with multiple files
+
+If multiple bodies of Scheme code are to be combined into a single
+executable, then we have to compile each file and link the resulting
+object files together with the runtime system.
+
+Let's consider an example where your program consists of multiple source files.
+
+===== Writing your source files
+
+The declarations in these files specify which of the compiled files is the main
+module, and which is the library module. An executable can only have
+one main module, since a program has only a single entry-point. In this
+case {{foo.scm}} is the main module, because it doesn't have a
+{{unit}} declaration:
+
+<enscript highlight=scheme>
+;;; foo.scm
+
+; The declaration marks this source file as dependant on the symbols provided
+; by the bar unit:
+(declare (uses bar))
+
+(write (fac 10)) (newline)
+</enscript>
+
+{{bar.scm}} will be our library:
+
+<enscript highlight=scheme>
+;;; bar.scm
+
+; The declaration marks this source file as the bar unit. The names of the
+; units and your files don't need to match.
+(declare (unit bar))
+
+(define (fac n)
+ (if (zero? n)
+ 1
+ (* n (fac (- n 1))) ) )
+</enscript>
+
+===== Compiling and running your program
+
+You should compile your two files with the following commands:
+
+ % csc -c bar.scm
+ % csc -c foo.scm
+
+That should produce two files, {{bar.o}} and {{foo.o}}.
+They contain the code from your source files in compiled form.
+
+To link your compiled files use the following command:
+
+ % csc foo.o bar.o -o foo
+
+This should produce the {{foo}} executable, which you can run just as in the previous example.
+At this point you can also erase the {{*.o}} files.
+
+You could avoid one step and link the two files just as {{foo.scm}} is compiled:
+
+ % csc -c bar.scm
+ % csc foo.scm bar.o -o foo
+
+Note that if you want to distribute your program, you might want it to
+follow the GNU Coding Standards. One relatively easy way to achieve
+this is to use Autoconf and Automake, two tools made for this specific
+purpose.
+
+=== Extending the compiler
+
+The compiler supplies a couple of hooks to add user-level passes to the
+compilation process. Before compilation commences any Scheme source files
+or compiled code specified using the {{-extend}} option are loaded
+and evaluated. The parameters {{user-options-pass, user-read-pass,
+user-preprocessor-pass, user-pass}} and {{user-post-analysis-pass}} can be set
+to procedures that are called to perform certain compilation passes
+instead of the usual processing (for more information about parameters
+see: [[Supported language]].
+
+; [parameter] user-options-pass : Holds a procedure that will be called with a list of command-line arguments and should return two values: the source filename and the actual list of options, where compiler switches have their leading {{-}} (hyphen) removed and are converted to symbols. Note that this parameter is invoked '''before''' processing of the {{-extend}} option, and so can only be changed in compiled user passes.
+
+; [parameter] user-read-pass : Holds a procedure of three arguments. The first argument is a list of strings with the code passed to the compiler via {{-prelude}} options. The second argument is a list of source files including any files specified by {{-prologue}} and {{-epilogue}}. The third argument is a list of strings specified using {{-postlude}} options. The procedure should return a list of toplevel Scheme expressions.
+
+; [parameter] user-preprocessor-pass : Holds a procedure of one argument. This procedure is applied to each toplevel expression in the source file '''before''' macro-expansion. The result is macro-expanded and compiled in place of the original expression.
+
+; [parameter] user-pass : Holds a procedure of one argument. This procedure is applied to each toplevel expression '''after''' macro-expansion. The result of the procedure is then compiled in place of the original expression.
+
+; [parameter] user-post-analysis-pass : Holds a procedure that will be called after every performed program analysis pass. The procedure (when defined) will be called with seven arguments: a symbol indicating the analysis pass, the program database, the current node graph, a getter and a setter-procedure which can be used to access and manipulate the program database, which holds various information about the compiled program, a pass iteration count, and an analysis continuation flag. The getter procedure should be called with two arguments: a symbol representing the binding for which information should be retrieved, and a symbol that specifies the database-entry. The current value of the database entry will be returned or {{#f}}, if no such entry is available. The setter procedure is called with three arguments: the symbol and key and the new value. The pass iteration count currently is meaningful only for the 'opt pass. The analysis continuation flag will be {{#f}} for the last 'opt pass. For information about the contents of the program database contact the author.
+
+Loaded code (via the {{-extend}} option) has access to the library
+units {{extras, srfi-1, srfi-4, utils, regex}} and the pattern matching macros.
+Multithreading is not available.
+
+Note that the macroexpansion/canonicalization phase of the compiler adds
+certain forms to the source program. These extra expressions are not
+seen by {{user-preprocessor-pass}} but by {{user-pass}}.
+
+=== Distributing compiled C files
+
+It is relatively easy to create distributions of Scheme projects that
+have been compiled to C. The runtime system of CHICKEN consists of only
+two handcoded C files ({{runtime.c}} and {{chicken.h}}), plus
+the file {{chicken-config.h}}, which is generated by the build process. All
+other modules of the runtime system and the extension libraries are just
+compiled Scheme code. The following example shows a minimal application, which
+should run without changes on the most frequent operating systems, like Windows,
+Linux or FreeBSD:
+
+Let's take a simple example.
+
+<enscript highlight=scheme>
+; hello.scm
+
+(print "Hello, world!")
+</enscript>
+
+ % chicken hello.scm -optimize-level 3 -output-file hello.c
+
+Compiled to C, we get {{hello.c}}. We need the files {{chicken.h}} and
+{{runtime.c}}, which contain the basic runtime system, plus the three
+basic library files {{library.c}}, {{eval.c}} and {{extras.c}} which
+contain the same functionality as the library linked into a plain
+CHICKEN-compiled application, or which is available by default in the
+interpreter, {{csi}}:
+
+ % cd /tmp
+ %echo '(print "Hello World.")' > hello.scm
+ % cp $CHICKEN_BUILD/runtime.c .
+ % cp $CHICKEN_BUILD/library.c .
+ % cp $CHICKEN_BUILD/eval.c .
+ % cp $CHICKEN_BUILD/extras.c .
+ % gcc -static -Os -fomit-frame-pointer runtime.c library.c eval.c \
+ extras.c hello.c -o hello -lm
+
+Now we have all files together, and can create an tarball containing all the files:
+
+ % tar cf hello.tar Makefile hello.c runtime.c library.c eval.c extras.c chicken.h
+ % gzip hello.tar
+
+This is naturally rather simplistic. Things like enabling dynamic loading, estimating
+the optimal stack-size and selecting supported features of the host system would need
+more configuration- and build-time support. All this can be addressed using more
+elaborate build-scripts, makefiles or by using autoconf/automake.
+
+Note also that the size of the application can still be reduced by removing {{extras}} and
+{{eval}} and compiling {{hello.scm}} with the {{-explicit-use}} option.
+
+For more information, study the CHICKEN source code and/or get in
+contact with the author.
+
+---
+Previous: [[Basic mode of operation]]
+
+Next: [[Using the interpreter]]
diff --git a/manual/Using the interpreter b/manual/Using the interpreter
new file mode 100644
index 00000000..e9f878c3
--- /dev/null
+++ b/manual/Using the interpreter
@@ -0,0 +1,250 @@
+[[tags: manual]]
+[[toc:]]
+
+== Using the interpreter
+
+CHICKEN provides an interpreter named {{csi}} for evaluating Scheme programs
+and expressions interactively.
+
+=== Interpreter command line format
+
+{{csi {FILENAME|OPTION}}}
+
+where {{FILENAME}} specifies a file with Scheme source-code. If the
+extension of the source file is {{.scm}}, it may be omitted. The
+runtime options described in [[http://galinha.ucpel.tche.br/Using%20the%20compiler#Compiler%20command%20line%20format|Compiler command line format]] are also available
+for the interpreter. If the environment variable {{CSI_OPTIONS}}
+is set to a list of options, then these options are additionally passed
+to every direct or indirect invocation of {{csi}}. Please note that
+runtime options (like {{-:...}}) can not be passed using this method.
+The options recognized by the interpreter are:
+
+; -- : Ignore everything on the command-line following this marker. Runtime options ({{-:...}}) are still recognized.
+
+; -i -case-insensitive : Enables the reader to read symbols case insensitive. The default is to read case sensitive (in violation of R5RS). This option registers the {{case-insensitive}} feature identifier.
+
+; -b -batch : Quit the interpreter after processing all command line options.
+
+; -e -eval EXPRESSIONS : Evaluate {{EXPRESSIONS}}. This option implies {{-batch}} and {{-quiet}}, so no startup message will be printed and the interpreter exits after processing all {{-eval}} options and/or loading files given on the command-line.
+
+; -p -print EXPRESSIONS : Evaluate {{EXPRESSIONS}} and print the results of each expression using {{print}}. Implies {{-batch}} and {{-quiet}}.
+
+; -P -pretty-print EXPRESSIONS : Evaluate {{EXPRESSIONS}} and print the results of each expression using {{pretty-print}}. Implies {{-batch}} and {{-quiet}}.
+
+; -D -feature SYMBOL : Registers {{SYMBOL}} to be a valid feature identifier for {{cond-expand}} and {{feature?}}.
+
+; -h -help : Write a summary of the available command line options to standard output and exit.
+
+; -I -include-path PATHNAME : Specifies an alternative search-path for files included via the {{include}} special form. This option may be given multiple times. If the environment variable {{CHICKEN_INCLUDE_PATH}} is set, it should contain a list of alternative include pathnames separated by {{;}}.
+
+; -k -keyword-style STYLE : Enables alternative keyword syntax, where {{STYLE}} may be either {{prefix}} (as in Common Lisp) or {{suffix}} (as in DSSSL). Any other value is ignored.
+
+; -n -no-init : Do not load initialization-file. If this option is not given and the file {{./.csirc}} or {{$HOME/.csirc}} exists, then it is loaded before the read-eval-print loop commences.
+
+; -no-parentheses-synonyms STYLE : Disables list delimiter synonyms, [..] and {...} for (...).
+
+; -no-symbol-escape : Disables support for escaped symbols, the |...| form.
+
+; -w -no-warnings : Disables any warnings that might be issued by the reader or evaluated code.
+
+; -q -quiet : Do not print a startup message. Also disables generation of call-trace information for interpreted code.
+
+; -r5rs-syntax : Disables the Chicken extensions to R5RS syntax. Does not disable [[Non-standard read syntax|non-standard read syntax]].
+
+; -s -script PATHNAME : This is equivalent to {{-batch -quiet -no-init PATHNAME}}. Arguments following {{PATHNAME}} are available by using {{command-line-arguments}} and are not processed as interpreter options. Extra options in the environment variable {{CSI_OPTIONS}} are ignored.
+
+; -sx PATHNAME : The same as {{-s PATHNAME}} but prints each expression to {{(current-error-port)}} before it is evaluated.
+
+; -ss PATHNAME : The same as {{-s PATHNAME}} but invokes the procedure {{main}} with the value of {{(command-line-arguments)}} as its single argument. If the main procedure returns an integer result, then the interpreter is terminated, returning the integer as the status code back to the invoking process. Any other result terminates the interpreter with a zero exit status.
+
+; -setup-mode : When locating extension, search the current directory first. By default, extensions are located first in the ''extension repository'', where {{chicken-install}} stores compiled extensions and their associated metadata.
+
+; -R -require-extension NAME : Equivalent to evaluating {{(require-extension NAME)}}.
+
+; -v -version : Write the banner with version information to standard output and exit.
+
+
+=== Writing Scheme scripts
+
+Since UNIX shells use the {{#!}} notation for starting scripts,
+anything following the characters {{#!}} is ignored, with the exception of the special
+symbols {{#!optional, #!key, #!rest}} and {{#!eof}}.
+
+The easiest way is to use the {{-script}} option like this:
+
+ % cat foo
+ #! /usr/local/bin/csi -script
+ (print (eval (with-input-from-string
+ (car (command-line-arguments))
+ read)))
+
+ % chmod +x foo
+ % foo "(+ 3 4)"
+ 7
+
+The parameter {{command-line-arguments}} is set to a list of the
+parameters that were passed to the Scheme script. Scripts can be compiled
+to standalone executables (don't forget to declare used library units).
+
+CHICKEN supports writing shell scripts in Scheme for other platforms as well,
+using a slightly different approach. The first example would look like
+this on Windows:
+
+ C:>type foo.bat
+ @;csibatch %0 %1 %2 %3 %4 %5 %6 %7 %8 %9
+ (print (eval (with-input-from-string
+ (car (command-line-arguments))
+ read)))
+
+ C:>foo "(+ 3 4)"
+ 7
+
+Like UNIX scripts, batch files can be compiled. Windows batch scripts do not
+accept more than 8 arguments.
+
+Since it is sometimes useful to run a script in the interpreter without actually executing it
+(for example to test specific parts of it), the option {{-ss}} can be used as an alternative to {{-script}}.
+{{-ss PATHNAME}} is equivalent to {{-script PATHNAME}} but invokes {{(main (command-line-arguments))}}
+after loading all top-level forms of the script file. The result of {{main}} is returned as the exit status
+to the shell. Any non-numeric result exits with status zero:
+
+ % cat hi.scm
+ (define (main args)
+ (print "Hi, " (car args))
+ 0)
+ % csi -ss hi.scm you
+ Hi, you
+ % csi -q
+ #;1> ,l hi.scm
+ #;2> (main (list "ye all"))
+ Hi, ye all
+ 0
+ #;3>
+
+=== Toplevel commands
+
+The toplevel loop understands a number of special commands:
+
+; ,? : Show summary of available toplevel commands.
+
+; ,l FILENAME ... : Load files with given {{FILENAME}}s
+
+; ,ln FILENAME ... : Load files and print result(s) of each top-level expression.
+
+; ,p EXP : Pretty-print evaluated expression {{EXP}}.
+
+; ,d EXP : Describe result of evaluated expression {{EXP}}.
+
+; ,du EXP : Dump contents of the result of evaluated expression {{EXP}}.
+
+; ,dur EXP N : Dump {{N}} bytes of the result of evaluated expression {{EXP}}.
+
+; ,exn : Describes the last exception that occurred and adds it to the result history (it can be accessed using the {{#}} notation).
+
+; ,q : Quit the interpreter.
+
+; ,r : Show system information.
+
+; ,s TEXT ... : Execute shell-command.
+
+; ,t EXP : Evaluate form and print elapsed time.
+
+; ,x EXP : Pretty-print macroexpanded expression {{EXP}} (the expression is not evaluated).
+
+; ,tr SYMBOL ... : Enables tracing of the toplevel procedures with the given names.
+
+<enscript highlight=scheme>
+#;1> (fac 10) ==> 3628800
+#;2> ,tr fac
+#;3> (fac 3)
+|(fac 3)
+| (fac 2)
+| (fac 1)
+| (fac 0)
+| fac -> 1
+| fac -> 1
+| fac -> 2
+|fac -> 6 ==> 6
+#;4> ,utr fac
+#;5> (fac 3) ==> 6
+</enscript>
+k
+
+; ,utr SYMBOL ... : Disables tracing of the given toplevel procedures.
+
+; ,br SYMBOL ... : Sets a breakpoint at the procedures named {{SYMBOL ...}}. Breakpoint can also be trigged using the {{breakpoint}} procedure.
+
+; ,ubr SYMBOL ... : Removes breakpoints.
+
+; ,c : Continues execution from the last invoked breakpoint.
+
+; ,breakall : Enable breakpoints for all threads (this is the default).
+
+; ,breakonly THREAD : Enable breakpoints only for the thread returned by the expression {{THREAD}}.
+
+; ,info : Lists traced procedures and breakpoints.
+
+; ,step EXPR : Evaluates {{EXPR}} in single-stepping mode. On each procedure call you will be presented with a menu that allows stepping to the next call, leaving single-stepping mode or triggering a breakpoint. Note that you will see some internal calls, and unsafe or heavily optimized compiled code might not be stepped at all. Single-stepping mode is also possible by invoking the {{singlestep}} procedure.
+
+You can define your own toplevel commands using the {{toplevel-command}}
+procedure:
+
+=== toplevel-command
+
+ [procedure] (toplevel-command SYMBOL PROC [HELPSTRING])
+
+Defines or redefines a toplevel interpreter command which can be invoked by entering
+{{,SYMBOL}}. {{PROC}} will be invoked when the command is entered and may
+read any required argument via {{read}} (or {{read-line}}). If the optional
+argument {{HELPSTRING}} is given, it will be listed by the {{,?}} command.
+
+=== History access
+
+The interpreter toplevel accepts the special object {{#[INDEX]}} which
+returns the result of entry number {{INDEX}} in the history list. If the expression
+for that entry resulted in multiple values, the first result (or an unspecified value for no values)
+is returned. If no {{INDEX}} is given (and if a whitespace or closing paranthesis character follows
+the {{#}}, then the result of the last expression is returned.
+Note that the value returned is implicitly quoted.
+
+=== set-describer!
+
+ [procedure] (set-describer! TAG PROC)
+
+Sets a custom description handler that invokes {{PROC}} when the {{,d}} command is invoked
+with a record-type object that has the type {{TAG}} (a symbol). {{PROC}} is called with
+two arguments: the object to be described and an output-port. It should write a possibly useful
+textual description of the object to the passed output-port. For example:
+
+ #;1> (define-record-type point (make-point x y) point?
+ (x point-x)
+ (y point-y))
+ #;2> (set-describer! 'point
+ (lambda (pt o)
+ (print "a point with x=" (point-x pt) " and y=" (point-y pt))))
+ #;3> ,d (make-point 1 2)
+ a point with x=1 and y=2
+
+=== Auto-completion and edition
+
+On platforms that support it, it is possible to get auto-completion of symbols,
+history (over different {{csi}} sessions) and a more feature-full
+editor for the expressions you type
+using the [[http://www.call-with-current-continuation.org/eggs/readline.html]] egg by
+Tony Garnock Jones.
+It is very useful for interactive use of csi.
+
+To enable it install the egg and put this in your {{~/.csirc}} file:
+
+ (use readline regex)
+ (current-input-port (make-gnu-readline-port))
+ (gnu-history-install-file-manager
+ (string-append (or (getenv "HOME") ".") "/.csi.history"))
+
+More details are available in [[http://www.call-with-current-continuation.org/eggs/readline.html|the egg's documentation]].
+
+
+---
+Previous: [[Using the compiler]]
+
+Next: [[Supported language]]
diff --git a/manual/faq b/manual/faq
new file mode 100644
index 00000000..9563fb7d
--- /dev/null
+++ b/manual/faq
@@ -0,0 +1,621 @@
+[[toc:]]
+[[tags:faq manual]]
+
+== FAQ
+
+This is the list of Frequently Asked Questions about Chicken Scheme.
+If you have a question not answered here, feel free to post to the chicken-users mailing list;
+if you consider your question general enough, feel free to add it to this list.
+
+=== General
+
+==== Why yet another Scheme implementation?
+
+Since Scheme is a relatively simple language, a large number of implementations exist and
+each has its specific advantages and disadvantages. Some are fast, some provide a rich
+programming environment. Some are free, others are tailored to specific domains, and so on. The reasons
+for the existence of CHICKEN are:
+
+* CHICKEN is portable because it generates C code that runs on a large number of platforms.
+
+* CHICKEN is extendable, since its code generation scheme and runtime system/garbage collector fits neatly into a C environment.
+
+* CHICKEN is free and can be freely distributed, including its source code.
+
+* CHICKEN offers better performance than nearly all interpreter based implementations, but still provides full Scheme semantics.
+
+* As far as we know, CHICKEN is the first implementation of Scheme that uses Henry Baker's [[http://home.pipeline.com/~hbaker1/CheneyMTA.html|Cheney on the M.T.A]] concept.
+
+==== What should I do if I find a bug?
+
+Send e-mail to felix@call-with-current-continuation.org
+with some hints about the problem, like
+version/build of the compiler, platform, system configuration, code that
+causes the bug, etc.
+
+=== Specific
+
+==== Why are values defined with {{define-foreign-variable}} or {{define-constant}} or {{define-inline}} not seen outside of the containing source file?
+
+Accesses to foreign variables are translated directly into C constructs that access the variable,
+so the Scheme name given to that variable does only exist during compile-time.
+The same goes for constant- and inline-definitions: The name is only there to tell the compiler
+that this reference is to be replaced with the actual value.
+
+==== How does {{cond-expand}} know which features are registered in used units?
+
+Each unit used via {{(declare (uses ...))}} is registered as a feature and
+so a symbol with the unit-name can be tested by {{cond-expand}} during macro-expansion-time.
+Features registered using the {{register-feature!}} procedure are only
+available during run-time of the compiled file. You can use the {{eval-when}} form
+to register features at compile time.
+
+==== Why are constants defined by {{define-constant}} not honoured in {{case}} constructs?
+
+{{case}} expands into a cascaded {{if}} expression, where the first item in each arm
+is treated as a quoted list. So the {{case}} macro can not infer whether
+a symbol is to be treated as a constant-name (defined via {{define-constant}}) or
+a literal symbol.
+
+
+==== How can I enable case sensitive reading/writing in user code?
+
+To enable the {{read}} procedure to read symbols and identifiers case sensitive, you can set the
+parameter {{case-sensitivity}} to {{#t}}.
+
+
+==== Why doesn't CHICKEN support the full numeric tower by default?
+
+The short answer:
+
+<enscript highlight=scheme>
+% chicken-install numbers
+% csi -q
+#;1> (use numbers)
+</enscript>
+
+The long answer:
+
+There are a number of reasons for this:
+
+- For most applications of Scheme fixnums (exact word-sized integers) and flonums (64-bit floating-point
+numbers) are more than sufficient;
+
+- Interfacing to C is simpler;
+
+- Dispatching of arithmetic operations is more efficient.
+
+There is an extension based on the GNU Multiprecision Package that implements most of the full
+numeric tower, see [[http://chicken.wiki.br/egg/numbers|numbers]].
+
+
+==== Does CHICKEN support native threads?
+
+Native threads are not supported for two reasons. One, the runtime
+system is not reentrant. Two, concurrency implemented properly would
+require mandatory locking of every object that could be potentially
+shared between two threads. The garbage-collection algorithm would
+then become much more complex and inefficient, since the location of
+every object has to be accessed via a thread synchronization
+protocol. Such a design would make native threads in Chicken
+essentially equivalent to Unix processes and shared memory.
+
+For a different approach to concurrency, please see the
+[[http://www.call-with-current-continuation.org/eggs/3/mpi.html|mpi]]
+egg.
+
+==== Does CHICKEN support Unicode strings?
+
+The system does not directly support Unicode, but an extension for UTF8 strings
+exists for CHICKEN 3, which may be ported to the current CHICKEN version at some
+stage.
+
+=== Why are `dynamic-wind' thunks not executed when a SRFI-18 thread signals an error?
+
+Here is what Marc Feeley, the author of [[http://srfi.schemers.org/srfi-18|SRFI-18]] has to
+say about this subject:
+
+ >No the default exception handler shouldn't invoke the after
+ > thunks of the current continuation. That's because the
+ > exception handler doesn't "continue" at the initial
+ > continuation of that thread. Here are the relevant words of
+ > SRFI 18:
+
+ >
+ > Moreover, in this dynamic environment the exception handler
+ > is bound to the "initial exception handler" which is a unary
+ > procedure which causes the (then) current thread to store in
+ > its end-exception field an "uncaught exception" object whose
+ > "reason" is the argument of the handler, abandon all mutexes
+ > it owns, and finally terminate.
+ >
+
+ >The rationale is that, when an uncaught exception occurs in a
+ >thread the thread is in bad shape and things have gone
+ >sufficiently wrong that there is no universally acceptable way to
+ >continue execution. Executing after thunks could require a
+ >whole lot of processing that the thread is not in a shape to do.
+ >So the safe thing is to terminate the thread. If the programmer
+ >knows how to recover from an exception, then he can capture the
+ >continuation early on, and install an exception handler which
+ >invokes the continuation. When the continuation is invoked the
+ >after thunks will execute.
+
+
+=== Platform specific
+
+==== How do I generate a DLL under MS Windows (tm) ?
+
+Use {{csc}} in combination with the {{-dll}} option:
+
+{{C:\> csc foo.scm -dll}}
+
+==== How do I generate a GUI application under Windows(tm)?
+
+Invoke {{csc}} with the {{-windows}} option. Or pass the {{-DC_WINDOWS_GUI}}
+option to the C compiler and link with the GUI version of the runtime system (that's {{libchicken-gui[-static].lib}}.
+The GUI runtime displays error messages in a message box and does some rudimentary command-line
+parsing.
+
+==== Compiling very large files under Windows with the Microsoft C compiler fails with a message indicating insufficient heap space.
+
+It seems that the Microsoft C compiler can only handle files up to a certain size, and it doesn't utilize virtual memory as
+well as the GNU C compiler, for example. Try closing running applications. If that fails, try to break up the Scheme code
+into several library units.
+
+==== When I run {{csi}} inside an emacs buffer under Windows, nothing happens.
+
+Invoke {{csi}} with the {{-:c}} runtime option. Under Windows the interpreter thinks it
+is not running under control of a terminal and doesn't print the prompt and does not flush the output stream properly.
+
+==== I load compiled code dynamically in a Windows GUI application and it crashes.
+
+Code compiled into a DLL to be loaded dynamically must be linked with the same runtime system as the loading
+application. That means that all dynamically loaded entities (including extensions built and installed with
+{{chicken-install}}) must be compiled with the {{-windows}} {{csc}} option.
+
+==== On Windows, {{csc.exe}} seems to be doing something wrong.
+
+The Windows development tools include a C# compiler with the same name. Either invoke {{csc.exe}} with a full
+pathname, or put the directory where you installed CHICKEN in front of the MS development tool path in the {{PATH}}
+environment variable.
+
+==== On Windows source and/or output filenames with embedded whitespace are not found.
+
+There is no current workaround. Do not use filenames with embedded whitespace for code. However, command
+names with embedded whitespace will work correctly.
+=== Customization
+
+
+==== How do I run custom startup code before the runtime-system is invoked?
+
+When you invoke the C compiler for your translated Scheme source program, add the C compiler option
+{{-DC_EMBEDDED}}, or pass {{-embedded}} to the {{csc}}
+driver program, so no entry-point function will be generated ({{main()}}).
+When your are finished with your startup processing, invoke:
+
+<enscript highlight=c>
+CHICKEN_main(argc, argv, C_toplevel);
+</enscript>
+
+where {{C_toplevel}} is the entry-point into the compiled Scheme code. You
+should add the following declarations at the head of your code:
+
+<enscript highlight=c>
+#include "chicken.h"
+extern void C_toplevel(C_word,C_word,C_word) C_noret;
+</enscript>
+
+==== How can I add compiled user passes?
+
+To add a compiled user pass instead of an interpreted one, create a library unit and recompile
+the main unit of the compiler (in the file {{chicken.scm}}) with an additional {{uses}}
+declaration. Then link all compiler modules and your (compiled) extension to create a new version of
+the compiler, like this (assuming all sources are in the
+current directory):
+
+<enscript highlight=scheme>
+ % cat userpass.scm
+ ;;;; userpass.scm - My very own compiler pass
+
+ (declare (unit userpass))
+
+ ;; Perhaps more user passes/extensions are added:
+ (let ([old (user-pass)])
+ (user-pass
+ (lambda (x)
+ (let ([x2 (do-something-with x)])
+ (if old
+ (old x2)
+ x2) ) ) ) )
+</enscript>
+
+ % csc -c -x userpass.scm
+ % csc chicken.scm -c -o chicken-extended.o -uses userpass
+ % gcc chicken-extended.o support.o easyffi.o compiler.o optimizer.o batch-driver.o c-platform.o \
+ c-backend.o userpass.o `csc -ldflags -libs` -o chicken-extended
+
+On platforms that support it (Linux ELF, Solaris, Windows + VC++), compiled code can be loaded via {{-extend}}
+just like source files (see {{load}} in the User's Manual).
+
+
+=== Macros
+
+==== Where is {{define-macro}}?
+
+With CHICKEN 4, the macro-expansion subsystem is now hygienic where old Lisp-style low-level macros
+are not available anymore. {{define-syntax}} can define hygienic macros using {{syntax-rules}}
+or low-level macros with user-controlled hygienic with ''explicit renaming'' macros. Translating
+old-style macros into ER-macros isn't that hard, see [[Modules and macros]] for more information.
+
+==== Why are low-level macros defined with {{define-syntax}} complaining about unbound variables?
+
+Macro bodies that are defined and used in a compiled source-file are
+evaluated during compilation and so have no access to anything created with {{define}}. Use {{define-for-syntax}} instead.
+
+==== Why isn't {{load}} properly loading my library of macros?
+
+During compile-time, macros are only available in the source file in which they are defined. Files included via {{include}} are considered part of the containing file.
+
+=== Warnings and errors
+
+==== Why does my program crash when I use callback functions (from Scheme to C and back to Scheme again)?
+
+There are two reasons why code involving callbacks can crash out of no apparent reason:
+
+# It is important to use {{foreign-safe-lambda/foreign-safe-lambda*}} for the C code that is to call back into Scheme. If this is not done than sooner or later the available stack space will be exhausted.
+
+# If the C code uses a large amount of stack storage, or if Scheme-to-C-to-Scheme calls are nested deeply, then the available nursery space on the stack will run low. To avoid this it might be advisable to run the compiled code with a larger nursery setting, i.e. run the code with {{-:s...}} and a larger value than the default (for example {{-:s300k}}), or use the {{-nursery}} compiler option. Note that this can decrease runtime performance on some platforms.
+
+==== Why does the linker complain about a missing function {{_C_..._toplevel}}?
+
+This message indicates that your program uses a library-unit, but that the
+object-file or library was not supplied to the linker. If you have the unit
+{{foo}}, which is contained in {{foo.o}} than you have to supply it to the
+linker like this (assuming a GCC environment):
+
+{{% csc program.scm foo.o -o program}}
+
+==== Why does the linker complain about a missing function {{_C_toplevel}}?
+
+This means you have compiled a library unit as an application. When a unit-declaration (as in {{(declare (unit ...))}})
+is given, then this file has a specially named toplevel entry procedure. Just remove the declaration,
+or compile this file to an object-module and link it to your application code.
+
+==== Why does my program crash when I compile a file with {{-unsafe}} or unsafe declarations?
+
+The compiler option {{-unsafe}} or the declaration {{(declare (unsafe))}} disable
+certain safety-checks to improve performance, so code that would normally
+trigger an error will work unexpectedly or even crash the running application.
+It is advisable to develop and debug a program in safe mode (without unsafe
+declarations) and use this feature only if the application works properly.
+
+==== Why don't toplevel-continuations captured in interpreted code work?
+
+Consider the following piece of code:
+
+<enscript highlight=scheme>
+(define k (call-with-current-continuation (lambda (k) k)))
+(k k)
+</enscript>
+
+When compiled, this will loop endlessly. But when interpreted, {{(k k)}} will return
+to the read-eval-print loop! This happens because the continuation captured will eventually read the
+next toplevel expression from the standard-input (or an input-file if loading from a file). At the moment
+{{k}} was defined, the next expression was {{(k k)}}. But when {{k}}
+is invoked, the next expression will be whatever follows after {{(k k)}}.
+In other words, invoking a captured continuation will not rewind the file-position of the input source.
+A solution is to wrap the whole code into a {{(begin ...)}} expression, so all toplevel
+expressions will be loaded together.
+
+==== Why does {{define-reader-ctor}} not work in my compiled program?
+
+The following piece of code does not work as expected:
+
+<enscript highlight=scheme>
+ (eval-when (compile)
+ (define-reader-ctor 'integer->char integer->char) )
+ (print #,(integer->char 33))
+</enscript>
+
+The problem is that the compiler reads the complete source-file before doing any processing on it,
+so the sharp-comma form is encountered before the reader-ctor is defined. A possible solution is to include
+the file containing the sharp-comma form, like this:
+
+<enscript highlight=scheme>
+ (eval-when (compile)
+ (define-reader-ctor 'integer->char integer->char) )
+
+ (include "other-file")
+</enscript>
+
+<enscript highlight=scheme>
+ ;;; other-file.scm:
+ (print #,(integer->char 33))
+</enscript>
+
+==== Why do built-in units, such as srfi-1, srfi-18, and posix fail to load?
+
+When you try to {{use}} a built-in unit such as {{srfi-18}}, you may get the following error:
+
+<enscript highlight=scheme>
+ #;1> (use srfi-18)
+ ; loading library srfi-18 ...
+ Error: (load-library) unable to load library
+ srfi-18
+ "dlopen(libchicken.dylib, 9): image not found" ;; on a Mac
+ "libchicken.so: cannot open shared object file: No such file or directory" ;; Linux
+</enscript>
+
+Another symptom is that {{(require 'srfi-18)}} will silently fail.
+
+This typically happens because the Chicken libraries have been installed in a non-standard location, such as your home directory. The workaround is to explicitly tell the dynamic linker where to look for your libraries:
+
+ export DYLD_LIBRARY_PATH=~/scheme/chicken/lib:$DYLD_LIBRARY_PATH ;; Mac
+ export LD_LIBRARY_PATH=~/scheme/chicken/lib:$LD_LIBRARY_PATH ;; Linux
+
+==== How can I increase the size of the trace shown when runtime errors are detected?
+
+When a runtime error is detected, Chicken will print the last entries from the trace of functions called
+(unless your executable was compiled with the {{-no-trace}} option.
+By default, only 16 entries will be shown.
+To increase this number pass the {{-:aN}} parameter to your executable.
+
+
+=== Optimizations
+
+==== How can I obtain smaller executables?
+
+If you don't need {{eval}} or the stuff in the {{extras}} library unit,
+you can just use the {{library}} unit:
+
+<enscript highlight=scheme>
+ (declare (uses library))
+ (display "Hello, world!\n")
+</enscript>
+
+(Don't forget to compile with the {{-explicit-use}} option)
+Compiled with Visual C++ this generates an executable of around 240 kilobytes.
+It is theoretically possible to compile something without the library, but
+a program would have to implement quite a lot of support code on its own.
+
+==== How can I obtain faster executables?
+
+There are a number of declaration specifiers that should be used to speed up
+compiled files: declaring {{(standard-bindings)}} is mandatory, since this enables
+most optimizations. Even if some standard procedures should be redefined, you can
+list untouched bindings in the declaration.
+Declaring {{(extended-bindings)}} lets the compiler choose faster versions of certain
+internal library functions. This might give another speedup. You can also use the
+the {{usual-integrations}} declaration, which is identical to declaring
+{{standard-bindings}} and {{extended-bindings}}
+(note that {{usual-integrations}} is set by default).
+Declaring {{(block)}} tells the compiler that global procedures are not changed
+outside the current compilation unit, this gives the compiler some more
+opportunities for optimization.
+If no floating point arithmetic is required, then declaring {{(number-type fixnum)}}
+can give a big performance improvement, because the compiler can now inline
+most arithmetic operations.
+Declaring {{(unsafe)}} will switch off most safety checks.
+If threads are not used, you can declare {{(disable-interrupts)}}.
+You should always use maximum optimizations settings for your C compiler.
+Good GCC compiler options on Pentium (and compatible) hardware are:
+{{-Os -fomit-frame-pointer -fno-strict-aliasing}}
+Some programs are very sensitive to the setting of the nursery (the first heap-generation). You
+should experiment with different nursery settings (either by compiling with the {{-nursery}}
+option or by using the {{-:s...}} runtime option).
+
+==== Which non-standard procedures are treated specially when the {{extended-bindings}} or {{usual-integrations}} declaration or compiler option is used?
+
+The following standard bindings are handled specially, depending on optimization options
+and compiler settings:
+
+{{+}} {{*}} {{-}} {{/}} {{quotient}} {{eq?}} {{eqv?}} {{equal?}} {{apply}} {{c...r}} {{values}} {{call-with-values}}
+{{list-ref}} {{null?}} {{length}} {{not}} {{char?}} {{string?}} {{symbol?}} {{vector?}} {{pair?}} {{procedure?}}
+{{boolean?}} {{number?}} {{complex?}} {{rational?}} {{real?}} {{exact?}} {{inexact?}} {{list?}} {{eof-object?}}
+{{string-ref}} {{string-set!}} {{vector-ref}} {{vector-set!}} {{char=?}} {{char<?}} {{char>?}} {{char<=?}} {{char>=?}}
+{{char-numeric?}} {{char-alphabetic?}} {{char-whitespace?}} {{char-upper-case?}} {{for-each}}
+{{char-lower-case?}} {{char-upcae}} {{char-downcase}} {{list-tail}} {{assv}} {{memv}} {{memq}} {{assoc}}
+{{member}} {{set-car!}} {{set-cdr!}} {{abs}} {{exp}} {{sin}} {{cos}} {{tan}} {{log}} {{asin}} {{acos}} {{atan}} {{sqrt}}
+{{zero?}} {{positive?}} {{negative?}} {{vector-length}} {{string-length}} {{char->integer}}
+{{integer->char}} {{inexact->exact}} {{=}} {{>}} {{<}} {{>=}} {{<=}} {{for-each}} {{map}} {{substring}}
+{{string-append}} {{gcd}} {{lcm}} {{list}} {{exact->inexact}} {{string->number}} {{number->string}}
+{{even?}} {{odd?}} {{remainder}} {{floor}} {{ceiling}} {{truncate}} {{round}} {{cons}} {{vector}} {{string}}
+{{string=?}} {{string-ci=?}} {{make-vector}} {{call-with-current-continuation}}
+{{write-char}} {{read-string}}
+
+The following extended bindings are handled specially:
+
+{{bitwise-and}} {{bitwise-ior}} {{bitwise-xor}} {{bitwise-not}}
+{{bit-set?}} {{add1}} {{sub1}}
+{{fx+}}
+{{fx-}} {{fx*}} {{fx/}} {{fxmod}}
+{{fx=}} {{fx>}} {{fx>=}} {{fixnum?}} {{fxneg}} {{fxmax}} {{fxmin}}
+{{fxand}} {{fxior}} {{fxxor}} {{fxnot}} {{fxshl}} {{fxshr}}
+{{flonum?}} {{fp+}}
+{{fp-}} {{fp*}} {{fp/}} {{atom?}}
+{{fp=}} {{fp>}} {{fp>=}} {{fpneg}} {{fpmax}} {{fpmin}}
+{{arithmetic-shift}} {{signum}} {{flush-output}} {{thread-specific}} {{thread-specific-set!}}
+{{not-pair?}} {{null-list?}} {{print}} {{print*}} {{u8vector->blob/shared}}
+{{s8vector->blob/shared}} {{u16vector->blob/shared}} {{s16vector->blob/shared}}
+{{u32vector->blob/shared}}
+{{s32vector->blob/shared}} {{f32vector->blob/shared}} {{f64vector->blob/shared}} {{block-ref}}
+{{blob-size}}
+{{u8vector-length}}
+{{s8vector-length}}
+{{u16vector-length}}
+{{s16vector-length}}
+{{u32vector-length}}
+{{s32vector-length}}
+{{f32vector-length}}
+{{f64vector-length}}
+{{u8vector-ref}}
+{{s8vector-ref}}
+{{u16vector-ref}}
+{{s16vector-ref}}
+{{u32vector-ref}}
+{{s32vector-ref}}
+{{f32vector-ref}}
+{{f64vector-ref}}
+{{u8vector-set!}}
+{{s8vector-set!}}
+{{u16vector-set!}}
+{{s16vector-set!}}
+{{u32vector-set!}}
+{{s32vector-set!}}
+{{hash-table-ref}}
+{{block-set!}} {{number-of-slots}}
+{{first}} {{second}} {{third}} {{fourth}} {{null-pointer?}} {{pointer->object}}
+{{make-record-instance}}
+{{locative-ref}} {{locative-set!}} {{locative?}} {{locative->object}} {{identity}}
+{{cpu-time}} {{error}} {{call/cc}} {{any?}}
+{{substring=?}} {{substring-ci=?}} {{substring-index}} {{substring-index-ci}}
+{{printf}} {{sprintf}} {{fprintf}} {{format}} {{o}}
+
+==== What's the difference betweem "block" and "local" mode?
+
+In {{block}} mode, the compiler assumes that definitions in the current file
+are not visible from outside of the current compilation unit, so unused
+definitions can be removed and calls can be inlined. In {{local}} mode,
+definitions are not hidden, but the compiler assumes that they are
+not modified from other compilation units (or code evaluated at runtime),
+and thus allows inlining of them.
+
+==== Can I load compiled code at runtime?
+
+Yes.
+You can load compiled at code at runtime with {{load}} just as
+well as you can load Scheme source code.
+Compiled code will, of course, run faster.
+
+To do this, pass to {{load}} a path for a shared object.
+Use a form such as {{(load "foo.so")}} and run
+{{csc -shared foo.scm}} to produce {{foo.so}} from {{foo.scm}} (at
+which point {{foo.scm}} will no longer be required).
+
+==== Why is my program which uses regular expressions so slow?
+
+The regular expression engine has recently be replaced by [[/users/alex shinn|alex shinn]]'s excellent
+{{irregex}} library, which is fully implemented in Scheme. Precompiling regular
+expressions to internal form is somewhat slower than with the old PCRE-based
+regex engine. It is advisable to use {{regexp}} to precompile regular expressions
+outside of time-critical loops and use them where performance matters.
+
+
+=== Garbage collection
+
+==== Why does a loop that doesn't {{cons}} still trigger garbage collections?
+
+Under CHICKENs implementation policy, tail recursion is achieved simply by avoiding
+to return from a function call. Since the programs are CPS converted, a continuous
+sequence of nested procedure calls is performed. At some stage the stack-space has
+to run out and the current procedure and its parameters (including the current
+continuation) are stored somewhere in the runtime system. Now a minor garbage collection
+occurs and rescues all live
+data from the stack (the first heap generation) and moves it into the the second heap
+generation. Then the stack is cleared (using
+a {{longjmp}}) and execution can continue from the saved state.
+With this method arbitrary recursion (in tail- or non-tail position) can happen,
+provided the application doesn't run out of heap-space.
+(The difference between a tail- and a non-tail call is that the tail-call has no
+live data after it invokes its continuation - and so the amount of heap-space needed stays constant)
+
+==== Why do finalizers not seem to work in simple cases in the interpeter?
+
+Consider the following interaction in CSI:
+
+ #;1> (define x '(1 2 3))
+ #;2> (define (yammer x) (print x " is dead"))
+ #;3> (set-finalizer! x yammer)
+ (1 2 3)
+ #;4> (gc #t)
+ 157812
+ #;5> (define x #f)
+ #;6> (gc #t)
+ 157812
+ #;7>
+
+While you might expect objects to be reclaimed and "''(1 2 3) is dead''" printed, it won't happen:
+the literal list gets held in the interpreter history, because it is the
+result value of the set-finalizer! call.
+Running this in a normal program will work fine.
+
+When testing finalizers from the interpreter, you might want to define a trivial macro such as
+
+ (define-syntax v
+ (syntax-rules ()
+ ((_ x) (begin (print x) (void)))))
+
+and wrap calls to {{set-finalizer!}} in it.
+
+=== Interpreter
+
+==== Does CSI support history and autocompletion?
+
+CSI doesn't support it natively but it can be activated with the [[http://www.call-with-current-continuation.org/eggs/readline.html]] egg.
+After installing the egg, add the following to your {{~/.csirc}} or equivalent file:
+
+<enscript highlight=scheme>
+ (require-extension readline)
+ (current-input-port (make-gnu-readline-port))
+ (gnu-history-install-file-manager (string-append (or (getenv "HOME") ".") "/.csi.history"))
+</enscript>
+
+Users of *nix-like systems (including Cygwin), may also want to check out [[http://utopia.knoware.nl/~hlub/rlwrap/|rlwrap]]. This program lets you "wrap" another process (e.g. {{rlwrap csi}}) with the readline library, giving you history, autocompletion, and the ability to set the keystroke set. Vi fans can get vi keystrokes by adding "set editing-mode vi" to their {{.inputrc}} file.
+
+==== Does code loaded with {{load}} run compiled or interpreted?
+
+If you compile a file with a call to {{load}}, the code will be loaded at
+runtime and, if the file loaded is a Scheme source code file
+(instead of a shared object), it will be
+interpreted (even if the caller program is compiled).
+
+==== How do I use extended (non-standard) syntax in evaluated code at run-time?
+
+Normally, only standard Scheme syntax is available to the evaluator. To
+use the extensions provided in the CHICKEN compiler and interpreter,
+add:
+
+<enscript highlight=scheme>
+(require-library chicken-syntax)
+</enscript>
+
+=== Extensions
+
+==== Where is "chicken-setup" ?
+
+{{chicken-setup}} has been rewritten from scratch and its functionality is now
+contained in the three tools {{chicken-install}}, {{chicken-uninstall}} and {{chicken-status}}.
+See the [[Extensions]] chapter for more information.
+
+==== How can I install Chicken eggs to a non-default location?
+
+You can just set the {{CHICKEN_REPOSITORY}} environment variable.
+It should contain the path where you want eggs to be installed:
+
+ $ export CHICKEN_REPOSITORY=~/chicken/
+ $ chicken-install extensionname
+
+In order to make programs (including csi) see these eggs, you should set this variable when you run them.
+Alternatively, you can call the {{repository-path}} Scheme procedure before loading the eggs, as in:
+
+<enscript highlight=scheme>
+(repository-path "/home/azul/chicken")
+(use format-modular)
+</enscript>
+
+Note, however, that using {{repository-path}} as above hard-codes the location of your eggs in your source files. While this might not be an issue in your case, it might be safe to keep this configuration outside of the source code (that is, specifying it as an environment variable) to make it easier to maintain.
+
+==== Can I install chicken eggs as a non-root user?
+
+Yes, just [[FAQ#Extensions#How can I install Chicken eggs to a non-default location?|install them in a directory you can write]].
+
+==== Why does downloading an extension via {{chicken-install}} fail on Windows Vista?
+
+Possibly the Windows Firewall is active, which prevents {{chicken-install}} from opening a TCP
+connection to the egg repository. Try disabling the firewall temporarily.
+
+---
+Previous: [[Bugs and limitations]]
+
+Next: [[Acknowledgements]]
diff --git a/misc/Chicken Runtime Data Type Proposal b/misc/Chicken Runtime Data Type Proposal
new file mode 100644
index 00000000..63dcc68f
--- /dev/null
+++ b/misc/Chicken Runtime Data Type Proposal
@@ -0,0 +1,445 @@
+* Chicken Runtime Data Type Proposal *
+
+Based on SRFI-99. I really like the SRFI-9 compatibility combined with the R6RS
+features.
+
+
+- Procedural Layer -
+
+- Suggested canonical name form of a condition identifier is '&<condition
+name>' where <condition name> is descriptive.
+
+- Suggested canonical name form of an rtd identifier is ':<rtd name>'. I know
+this conflicts with keyword-style; ':optional' redux.
+
+- Procedural Layer per SRFI-99 with some extensions.
+
+- Procedure rtd-constructor
+
+(rtd-constructor RTD [FIELDSPECS [INIT ...]]) => CTOR
+
+{{FIELDSPECS}} per SRFI-99.
+
+{{INIT}} is an '<initial value>'
+
+{{CTOR}} per SRFI-99, except when {{INIT}} specified, in which case the initial
+value of the constructed rtd-object is supplied. Otherwise the field must named
+in {{FIELDSPECS}}.
+
+<initial value> -> initializer <field> <procedure/(-> object)>
+ -> initial <field> <object>
+
+- Procedure rtd-mutator
+
+(rtd-mutator RTD FIELD [CHECKER]) => MUTATOR
+
+{{CHECKER}} is a 'procedure' with signature '(object -> boolean)'.
+
+{{MUTATOR}} per SRFI-99, except when a {{CHECKER}} specified. In which case the
+mutating object is validated with the {{CHECKER}} before mutation and an
+'&invalid-field-value' condition is raised if necessary.
+
+- Procedure rtd-operator
+
+(rtd-operator RTD OPERATION ...)
+
+{{OPERATION}} is an '<operation>'.
+
+<operation> -> printer <procedure/(rtd-object output-port)>
+ -> displayer <procedure/(rtd-object output-port)>
+ -> writer <procedure/(rtd-object output-port)>
+ -> comparator <procedure/(rtd-object rtd-object -> (union -1 0 1))>
+ -> hasher <procedure/(rtd-object (optional fixnum) -> fixnum)>
+
+- Procedure rtd-operation
+
+(rtd-operation RTD OPER) => PROCEDURE
+
+{{OPER}} is an '<operation>'.
+
+<operation> -> printer
+ -> displayer
+ -> writer
+ -> comparator
+ -> hasher
+
+Default rtd operators can be generated when a user-supplied procedure is
+unspecified.
+
+- Can have routines like '(rtd-comparator RTD) => PROCEDURE'.
+
+- make-rtd-parameter
+
+(make-rtd-parameter RTD SETTER VALUE [GUARD]) => PARAMETER-PROCEDURE
+
+{{SETTER}} is a 'procedure/(rtd-object object)'.
+
+Returns a {{PARAMETER-PROCEDURE}} closed over the {{RTD}}.
+
+'(make-parameter VALUE (lambda (x) (SETTER RTD (GUARD x))))'
+
+- Procedure rtd-print-syntax
+
+(rtd-print-syntax RTD [SYNTAX])
+(rtd-print-syntax RTD) => '<print-syntax>'
+
+{{SYNTAX}} is a '<print-syntax>'.
+
+<print-syntax> -> srfi-10
+ -> character
+ -> sharp
+ -> parameterized
+ -> none
+
+'<print-syntax>' should probably be a keyword.
+
+See - Discussion - below.
+
+- Parameter current-print-syntax
+
+(current-print-syntax [SYNTAX])
+(current-print-syntax) => '<print-syntax>'
+
+{{SYNTAX}} is a '<print-syntax>'.
+
+Very unsure about this one.
+
+- While SRFI-99 uses symbols to represent keyed arguments Chicken can use
+keywords. The flag symbols of SRFI-99 would need to be represented as boolean
+keyword arguments. Ex: 'opaque?' -> opaque?: #f/#t.
+
+Both styles can be supported. However, an existing example of a keyword only
+interpretation of a SRFI is "srfi-69.scm".
+
+The symbol style is Scheme-y while the keyword style is CommonLisp-y. But I
+like DSSSL lambda-lists so my preference is the keyword style, if only one must
+be chosen.
+
+Really think both should be supported when features are advertised as a SRFI
+implementation. (Unit srfi-69 needs work.)
+
+
+- Syntactic Layer -
+
+- Macro define-record-type
+
+(define-record-type TYPESPEC CTORSPEC PREDSPEC FLDSPEC ...)
+
+{{TYPESPEC}} is a '<type spec>'.
+
+{{CTORSPEC}} is a '<constructor spec>'.
+
+{{PREDSPEC}} is a '<predicate spec>'.
+
+{{FLDSPEC}} is a '<field spec>'.
+
+<type spec> -> <type name>
+ -> (<type name> <parent>)
+ -> (<type name> <parent> <option> ...)
+
+<constructor spec> -> #f {no constructor procedure}
+ -> #t {default constructor procedure}
+ -> <constructor name>
+ -> (<constructor name> <field name> ...)
+ -> (<constructor name> (<field name> <initial value>) ...)
+
+<predicate spec> -> #f {no predicate procedure}
+ -> #t {default predicate procedure}
+ -> <predicate name>
+
+<field spec> -> <field name>
+ -> (<field name>)
+ -> (<field name> <accessor spec>)
+ -> (<field name> <accessor spec> <mutator spec>)
+ -> (<field name> <accessor spec> <mutator spec> <check spec>)
+ -> (<field name> <accessor spec> <mutator spec> <check spec>)
+
+<accessor spec> -> #f {no accessor procedure}
+ -> #t {default accessor procedure}
+ -> <accessor name>
+
+<mutator spec> -> #f {no mutator procedure}
+ -> #t {default mutator procedure}
+ -> <mutator name>
+
+<check spec> -> #f {no check procedure}
+ -> #t {default check procedure}
+ -> <expression> {=> procedure/(object -> boolean)}
+
+<parent> -> #f {no parent}
+ -> #t {default parent}
+ -> <expression> {=> rtd-object}
+
+<option> -> sealed?
+ -> opaque?
+ -> uid <expression> {=> symbol}
+ -> printer <expression> {=> procedure/(rtd-object output-port)}
+ -> displayer <expression> {=> procedure/(rtd-object output-port)}
+ -> writer <expression> {=> procedure/(rtd-object output-port)}
+ -> comparator <expression> {=> procedure/(rtd-object rtd-object -> (union -1 0 1))}
+ -> hasher <expression> {=> procedure/(rtd-object (optional fixnum) -> fixnum)}
+
+<initial value> -> initializer <expression> {=> <procedure/(-> object)}
+ -> initial <expression> {=> object}
+
+<type name> -> <identifier>
+<constructor name> -> <identifier>
+<predicate name> -> <identifier>
+<accessor name> -> <identifier>
+<mutator name> -> <identifier>
+<field name> -> <identifier>
+<type predicate name> -> <identifier>
+
+- Procedure define-reader-ctor
+
+(define-reader-ctor RTD () PROC)
+
+Is this necessary, useful?
+
+- Macro define-record-printer
+
+(define-record-printer RTD (RTDVAR PORTVAR) EXPRESSION ...)
+
+Does "(rtd-operator RTD 'printer (lambda (RTDVAR PORTVAR) EXPRESSION ...))"
+
+(define-record-printer RTD () PROC)
+
+Does "(rtd-operator RTD 'printer PROC)"
+
+- Macro define-record-displayer
+
+(define-record-displayer RTD (RTDVAR OUTPUT-PORT) EXPRESSION ...)
+
+Does "(rtd-operator RTD 'displayer (lambda (RTDVAR PORTVAR) EXPRESSION ...))"
+
+(define-record-displayer RTD () PROC)
+
+Does "(rtd-operator RTD 'displayer PROC)"
+
+- Macro define-record-writer
+
+(define-record-writer RTD (RTDVAR OUTPUT-PORT) EXPRESSION ...)
+
+Does "(rtd-operator RTD 'writer (lambda (RTDVAR PORTVAR) EXPRESSION ...))"
+
+(define-record-writer RTD () PROC)
+
+Does "(rtd-operator RTD 'writer PROC)"
+
+- Macro define-record-comparator
+
+(define-record-comparator RTD (RTDVAR1 RTDVAR2) EXPRESSION ...)
+
+Does "(rtd-operator RTD 'comparator (lambda (RTDVAR1 RTDVAR2) EXPRESSION ...))"
+
+(define-record-comparator RTD () FUNC)
+
+Does "(rtd-operator RTD 'comparator FUNC)"
+
+- Macro define-record-hasher
+
+(define-record-hasher RTD (RTDVAR) EXPRESSION ...)
+
+Does "(rtd-operator RTD 'hasher (lambda (RTDVAR) EXPRESSION ...))"
+
+(define-record-hasher RTD () FUNC)
+
+Does "(rtd-operator RTD 'hasher FUNC)"
+
+- Macro define-record-operator
+
+(define-record-operator RTD OPERATION ...)
+
+Something like this possible but I don't see the point.
+
+
+- Data Representation -
+
+The core structure-type is a vector-like object with a reference to a
+runtime-type-descriptor or rtd structure-type object in slot 0. So a
+structure-type object always has at least 1 element.
+
+For backwards compatibility a structure-type with a symbol in slot
+0 can be given the current semantics. A synthetic rtd can be generated
+on-the-fly for such cases.
+
+- The rtd structure-type layout:
+
+0 Definition rtd
+1 Parent rtd or #f
+2 Name symbol
+3 Fields vector-of (union symbol (symbol mutable) (symbol immutable))
+4 Sealed? boolean
+5 Opaque? boolean
+6 Uid symbol
+
+- The "rtd" rtd structure-type object:
+
+0 self-reference
+1 #f
+2 'rtd
+3 #(parent name uid names kinds sealed opaque types inits)
+4 #t
+5 #t
+6 #f
+
+The Definition is not considered a "field" since it is always present.
+
+The Uid violates the contract deliberately since user rtd's Uid must be a
+symbol.
+
+R6RS suggests an automatically generated Uid to be in the UUID namespace
+prefixed with the rtd's Name. For example: 'rtd:uuid:f81d4fae-7dec-11d0-a765-00a0c91e6bf6'.
+
+- Operations
+
+-- The 'rtd-object' operations data-structure is a 'mapset' since it is
+associative, unique-valued and extensible. Called the 'rtd-operation-mapset'.
+
+-- Represention options:
+
+1) Use an associative data-structure keyed by 'rtd-object' returning
+'rtd-operation-mapset' for that 'rtd-object'.
+
+2) Store the 'rtd-operation-mapset' in the 'rtd-object'.
+
+Both have their merits but the 1st option can coexist more easily with the
+symbol-tag style. The '##sys#record-printers' would become
+'##sys#record-operations'. Need routines to abstract the lookup of
+'rtd-operation-mapset' so it can be generated automatically when not found.
+Should also have finer-grained routines that return specific opration
+procedures.
+
+'##sys#record-operations' should probably be a hash-table since the current
+a-list will be inefficient after some 'magic-limit' of about 12.
+
+(The 'magic-limit' value is based on tests w/ Chicken 3 on my platfrom, YMMV.
+This is the value used by "lookup-table" to switch between a-list & hash-table
+representations.)
+
+--- Extending utility of '##sys#hash-table'
+
+The '##sys#hash-table' API currently only supports symbols. However, changing
+the signature of the various '##sys#hash-table' routines to allow an optional
+hash function is straight-forward. Affected are '##sys#hash-table-ref',
+'##sys#hash-table-set!' and '##sys#hash-table-update!'. (The
+'##sys#hash-table-location' routine doesn't need this change since only used
+for environments.)
+
+
+- Discussion -
+
+-- The rtd-operations used by system routines:
+
+'display' '(rtd-displayer RTD)'
+
+'write' '(rtd-writer RTD)'
+
+'equal?' '(zero? ((rtd-comparator RTD) X Y))'
+
+'equal?-hash' '(rtd-hasher RTD)'
+
+The 'rtd-printer' is used as a default for 'displayer' & 'writer', but will
+not override.
+
+-- Kinda think an 'rtd-object' should differentiate SRFI-10 syntax from other
+forms:
+
+The 'rtd-printer' could always produce SRFI-10 'read-syntax' while
+'rtd-displayer' produces human-readable output & 'rtd-writer' uses the
+'read-table'.
+
+-- Identifiers
+
+The identifiers are subject to the same rules as any other identifier in a
+module. So the syntactic layer will "(define <type name> (make-rtd '<type name>
+...))". So there is an identifier in the module namespace of '<type name>'.
+
+But the Name rtd field is not in a module namespace! Any two rtd's w/ the same
+Name but different Uid's are unique, no matter what the correspondence, if any,
+between the fields. Any two rtd's w/ the same Uid must be eqv?/equal? in all
+fields, except the Name can be different.
+
+-- Slot access performance
+
+Direct access to field slots by accessor & mutator procedures is tricky
+w/Êinheritance. If the parent 'rtd-object' is available at expand time then the
+syntactic layer can open code the slot index. Otherwise runtime fieldname ->
+slot-index is needed. Kinda implies that an imported 'rtd-object' used as a
+parent needs to be instantiated at compile time - how to determine an automatic
+'-extend' is beyond me.
+
+-- Unresolved:
+
+--- Generative vs. Nongenerative
+
+(Shiro Kawai comp.lang.scheme Sun, 8 Mar 2009 01:14:37 -0800 (PST) Generative/nongenerative record types)
+This is just a rough idea from top of my head. Feedbacks are welcome.
+
+I've been feeling very uncomfortable about "nongenerative" record type
+creation feature in R6RS but couldn't point my finger to what made me
+feel so. I see why the feature like that is needed, but it doesn't
+look
+like Scheme-way as I perceive (what Scheme-way is may vary widely
+among people, though). I dug the discussion about it and so far got
+an impression that (1) first, make-record-type is understood to be
+generative, in order to guarantee to create distinct types, and then
+(2) uid for nongenerative record type creation is introduced, mainly
+to accomodate efficient local record definitions.
+
+Record type descriptor is an immutable object, and I tend to think
+equality of immutable objects should, ideally, defined by equality of
+its components (as Henry Baker suggests in [1]). Implementation may
+take advantage of immutability to share the same storage for
+equivalent object. Anyway, it seems weird that two immutalbe objects
+are not equivalent even though I cannot distinguish one from the other
+any way except the system-provided equivalence predicate (e.g. eqv?).
+
+The only reason I can think of that immutable record types with
+exactly the same definitions need to be distinguished is the necessity
+of distinct types.
+
+Then, how about separate type identity from structure definitions?
+
+The record type in R6RS are burdened by two roles; creating distinct
+types, and creating aggregate types. These two are not the same;
+sometimes I merely need an aggregate type for code readability and do
+not care if it is distinct from other types. I've been happily using
+a macro that expands aggregate type definition into bunch of
+procedures that operate on vectors.
+
+Specifically,
+
+* make-record-type-descriptor (or equivalent) is *allowed* to return
+the
+ identical rtd if all the given arguments are equivalent.
+
+* Record type equivalence is based on equivalence of rtd's components.
+(If the implementation returns identical rtd for equivalent arguments,
+the comparison is effectively eq?).
+
+* If you need distinct types, give make-record-type-descriptor
+something
+different. An easiest way may be to add "type-id" component to rtd,
+and
+use eqv? to compare that component to determine equivalence of rtds.
+It is easy to create distinct rtd by giving (cons #f #f) as type-id.
+
+* For the syntactic layer, I'm not sure whether the define-record-type
+macro should create a distinct type or not. But I feel it better to
+have different macros for distinct type creation and mere aggregate
+type creation. Local aggregate structure for readability requires
+latter, while the record type which is part of external API of some
+module may require former.
+
+On the surface, this idea just reverses the default perception of
+generative/nongenerative behavior of make-record-type-descriptor;
+R6RS's is generative unless unique uid is given. This one is
+nongenerative unless unique type-id is given. But this one eliminates
+explicit bookkeeping of uids, which is effectively creating another
+namespace in R6RS.
+
+[1] http://home.pipeline.com/~hbaker1/ObjectIdentity.html
+
+--- Conflicts between structure-type 'symbol' tags & 'rtd-object' names is an
+open issue.
diff --git a/misc/compiler.files b/misc/compiler.files
new file mode 100644
index 00000000..58295742
--- /dev/null
+++ b/misc/compiler.files
@@ -0,0 +1,7 @@
+compiler.scm
+optimizer.scm
+support.scm
+batch-driver.scm
+c-backend.scm
+c-platform.scm
+chicken.scm
diff --git a/misc/inline.scm b/misc/inline.scm
new file mode 100644
index 00000000..6be85cf9
--- /dev/null
+++ b/misc/inline.scm
@@ -0,0 +1,418 @@
+;;; this assumes that :
+;;; a) nothing has been evaluated yet
+;;; b) basic syntactical correctness has been assured (so a list l starting
+;;; with 'define-inline will have the procedure-name as (caadr l) and
+;;; arity for all procedure calls is correct)
+;;; c) alpha substitution has occurred so all named symbols are guaranteed
+;;; unique across all procedures
+;;; d) optional, keyword, and rest arguments are not allowed for inline
+;;; procedures (although it should be possible to add them)
+
+;; beginning of the pass
+;; takes the ordered quoted list of all top-level statements
+;; ends by calling either
+;; inline-pass:final with the input list (if no inline procedures exist) and
+;; null, or
+;; inline-pass:graph-inline with two lists, the inline procedures (with some
+;; metadata) and all non-inline-procedure statements.
+(define (inline-pass:start qlst)
+ (let find-inline ((q qlst) ; quoted top-level statements
+ (i 0) ; index of inline procedure for later steps
+ (l '()) ; inline procedures
+ (r '())) ; non-inline statements
+ (cond ((null? q)
+ (if (= 0 i)
+ (inline-pass:final (reverse r) '())
+ (inline-pass:graph-inline i (reverse l) (reverse r))))
+ ((and (list? (car q)) (eq? 'define-inline (caar q)))
+ (find-inline
+ (cdr q)
+ (+ 1 i)
+ (cons (cons (caadar q)
+ (vector i 0 (cddar q) (cdadar q)))
+ l)
+ r))
+ (else
+ (find-inline (cdr q) i l (cons (car q) r))))))
+
+
+;; walks through a list
+;; takes a list, an index vector, and the metadata inline list from above
+;; ends by returning the (possibly modified) vector
+(define (inline-pass:walk l v ilst)
+ (let walk ((l l)
+ (t 0))
+ (cond ((null? l)
+ v)
+ ((list? (car l))
+ (cond ((null? (car l))
+ (walk (cdr l) t))
+ ((eq? 'quote (caar l))
+ (or (= 0 t)
+ (walk (cdar l) 3))
+ (walk (cdr l) t))
+ ((eq? 'quasiquote (caar l))
+ (walk (cdar l) 2)
+ (walk (cdr l) t))
+ ((or (eq? 'unquote (caar l))
+ (eq? 'unquote-splicing (caar l)))
+ (walk (cdar l) 1)
+ (walk (cdr l) t))
+ (else
+ (walk (car l) t)
+ (walk (cdr l) t))))
+ ((pair? (car l))
+ (walk (unfold not-pair? car cdr (car l) list) t)
+ (walk (cdr l) t))
+ ((vector? (car l))
+ (walk (vector->list (car l)) t)
+ (walk (cdr l) t))
+ ((not (symbol? (car l)))
+ (walk (cdr l) t))
+ ((> t 1)
+ (walk (cdr l) t))
+ ((alist-ref (car l) ilst) =>
+ (lambda (d)
+ (vector-set! v (vector-ref d 0) #t)
+ (walk (cdr l) t)))
+ (else
+ (walk (cdr l) t)))))
+
+
+;; builds a graph of calls to inline procedures from inline procedures
+;; takes the inline-list-length, inline metadata list, and other statements
+;; ends by calling inline-pass:simplify1 with the graph and input args
+(define (inline-pass:graph-inline i ilst rlst)
+ (inline-pass:simplify1
+ (map
+ (lambda (iv)
+ (cons (car iv)
+ (inline-pass:walk
+ (vector-ref (cdr iv) 3)
+ (make-vector i #f)
+ ilst)))
+ ilst)
+ i ilst rlst))
+
+
+;; simplifies direct self-call, no further inline, and only-self cases
+;; takes the graph, inline list length, inline metadata list, and statements
+;; ends by calling either:
+;; inline-pass:simplify2 with the further inline, no-further-but-self inline,
+;; graph, inline length, all inline, and other statements, or
+;; inline-pass:final with the statements and inlines
+(define (inline-pass:simplify1 g i ilst rlst)
+ (for-each
+ (lambda (x)
+ (and (vector-ref (cdr x) (car x))
+ (vector-set! (cdr (list-ref ilst (car x))) 1 1)))
+ g)
+ (let simple ((h g) ; graph
+ (l ilst) ; inline metadata
+ (r '()) ; no further inlines (except possibly self)
+ (s '())) ; further inlining
+ (cond ((null? h)
+ (if (null? s)
+ (inline-pass:final rlst r)
+ (inline-pass:simplify2 s r g i ilst rlst)))
+ ((every (lambda (x i) (or (= i (caar h)) (not x)))
+ (vector->list (cdar h)) (iota i))
+ (simple (cdr h) (cdr l) (cons (car l) r) s))
+ (else
+ (simple (cdr h) (cdr l) r (cons (car l) s))))))
+
+;; substitutes in inlined procedures
+;; takes the procedure in which to do the substitution (as a list) and the
+;; list of inlined procedures with metadata
+;; ends with the new procedure-as-list
+;; note: there are four distinct cases -
+;; 1) inline procedure in application position, no self call :
+;; becomes a (begin ...) with the arguments set locally
+;; 2) inline procedure in application position, with self call :
+;; becomes a (let <name> (vars ...) ...)
+;; 3) inline procedure not in application position, no self call :
+;; becomes a (lambda (arglist) ...)
+;; 4) inline procedure not in application position, with self call :
+;; becomes a (lambda (arglist) (let <name> (vars ...) ...) with new
+;; symbols generated for arglist
+(define (inline-pass:subst1 l ilst)
+ (let walk ((l l)
+ (t 0))
+ (cond ((null? l)
+ l)
+ ((vector? l)
+ (list->vector (walk (vector->list l) t)))
+ ((symbol? l)
+ (cond ((> t 1)
+ l)
+ ((alist-ref l ilst) =>
+ (lambda (d)
+ (if (= 1 (vector-ref d 1))
+ (let* ((a (map
+ (lambda (x) (gensym 'ia))
+ (vector-ref d 2)))
+ (m (map
+ (lambda (a x) (list a x))
+ (vector-ref d 2) a)))
+ `(lambda ,a (let ,l ,m
+ ,@(vector-ref d 3))))
+ `(lambda ,(vector-ref d 2)
+ ,@(vector-ref d 3)))))
+ (else
+ l)))
+ ((not (pair? l))
+ l)
+ ((list? (car l))
+ (cond ((null? (car l))
+ (cons (car l) (walk (cdr l) t)))
+ ((not (symbol? (caar l)))
+ (cons (walk (car l) t) (walk (cdr l) t)))
+ ((eq? 'quote (caar l))
+ (if (= t 0)
+ (cons (car l) (walk (cdr l) t))
+ (cons `(quote ,(walk (cadr l) 3))
+ (walk (cdr l) t))))
+ ((eq? 'quasiquote (caar l))
+ (cons `(quasiquote ,(walk (cadr l) 2))
+ (walk (cdr l) t)))
+ ((or (eq? 'unquote (caar l))
+ (eq? 'unquote-splicing (caar l)))
+ (cons `(,(caar l) ,(walk (cadr l) 1))
+ (walk (cdr l) t)))
+ ((> t 1)
+ (cons (walk (car l) t) (walk (cdr l) t)))
+ ((alist-ref (caar l) ilst) =>
+ (lambda (d)
+ (cons
+ (if (= 1 (vector-ref d 1))
+ (let ((m (map
+ (lambda (a x) (list a x))
+ (vector-ref d 2)
+ (walk (cdar l) t))))
+ `(let ,(caar l) ,m
+ ,@(vector-ref d 3)))
+ `(begin
+ ,@(map
+ (lambda (a x)
+ `(set-local! ,a ,x))
+ (vector-ref d 2)
+ (walk (cdar l) t))
+ ,@(vector-ref d 3)))
+ (walk (cdr l) t))))
+ (else
+ (cons (walk (car l) t) (walk (cdr l) t)))))
+ ((pair? (car l))
+ (cons (cons (walk (caar l) t) (walk (cdar l) t))
+ (walk (cdr l) t)))
+ ((vector? (car l))
+ (cons (list->vector (walk (vector->list (car l)) t))
+ (walk (cdr l) t)))
+ ((not (symbol? (car l)))
+ (cons (car l) (walk (cdr l) t)))
+ ((> t 1)
+ (cons (car l) (walk (cdr l) t)))
+ ((alist-ref (car l) ilst) =>
+ (lambda (d)
+ (cons
+ (if (= 1 (vector-ref d 1))
+ (let* ((a (map
+ (lambda (x) (gensym 'ia))
+ (vector-ref d 2)))
+ (m (map
+ (lambda (a x) (list a x))
+ (vector-ref d 2) a)))
+ `(lambda ,a (let ,(car l) ,m
+ ,@(vector-ref d 3))))
+ `(lambda ,(vector-ref d 2) ,@(vector-ref d 3)))
+ (walk (cdr l) t))))
+ (else
+ (cons (car l) (walk (cdr l) t))))))
+
+
+;; substitutes in inlined procedures with further processing
+;; takes the procedure in which to do the substitution (as a list), the
+;; list of inlined procedures with metadata, and a list of procedures to
+;; not treat as inline
+;; ends with the new procedure-as-list
+;; note: there are four distinct cases -
+;; 1) inline procedure in application position, no self call :
+;; becomes a (begin ...) with the arguments set locally
+;; 2) inline procedure in application position, with self call :
+;; becomes a (let <name> (vars ...) ...)
+;; 3) inline procedure not in application position, no self call :
+;; becomes a (lambda (arglist) ...)
+;; 4) inline procedure not in application position, with self call :
+;; becomes a (lambda (arglist) (let <name> (vars ...) ...) with new
+;; symbols generated for arglist
+(define (inline-pass:subst2 l ilst nof)
+ (let walk ((l l)
+ (n nof)
+ (t 0))
+ (cond ((null? l)
+ l)
+ ((vector? l)
+ (list->vector (walk (vector->list l) t n)))
+ ((symbol? l)
+ (cond ((> t 1)
+ l)
+ ((memq l n) =>
+ (lambda (m)
+ (let ((d (alist-ref l ilst)))
+ (if (= 1 (vector-ref d 1))
+ l
+ (begin
+ (vector-set! d 1 1)
+ (if (= 1 (length m))
+ l
+ (walk l t (cdr m))))))))
+ ((alist-ref l ilst) =>
+ (lambda (d)
+ (if (= 1 (vector-ref d 1))
+ (let* ((a (map
+ (lambda (x) (gensym 'ia))
+ (vector-ref d 2)))
+ (m (map
+ (lambda (a x) (list a x))
+ (vector-ref d 2) a)))
+ `(lambda ,a (let ,l ,m
+ ,@(walk (vector-ref d 3) t
+ (cons l n)))))
+ `(lambda ,(vector-ref d 2)
+ ,@(walk (vector-ref d 3) t
+ (cons l n))))))
+ (else
+ l)))
+ ((not (pair? l))
+ l)
+ ((list? (car l))
+ (cond ((null? (car l))
+ (cons (car l) (walk (cdr l) t n)))
+ ((not (symbol? (caar l)))
+ (cons (walk (car l) t n) (walk (cdr l) t n)))
+ ((eq? 'quote (caar l))
+ (if (= t 0)
+ (cons (car l) (walk (cdr l) t n))
+ (cons `(quote ,(walk (cadr l) 3 n))
+ (walk (cdr l) t n))))
+ ((eq? 'quasiquote (caar l))
+ (cons `(quasiquote ,(walk (cadr l) 2 n))
+ (walk (cdr l) t n)))
+ ((or (eq? 'unquote (caar l))
+ (eq? 'unquote-splicing (caar l)))
+ (cons `(,(caar l) ,(walk (cadr l) 1 n))
+ (walk (cdr l) t n)))
+ ((> t 1)
+ (cons (walk (car l) t n) (walk (cdr l) t n)))
+ ((memq (caar l) n) =>
+ (lambda (m)
+ (let ((d (alist-ref (caar l) ilst)))
+ (if (= 1 (vector-ref d 1))
+ (cons (cons (caar l)
+ (walk (cdar l) t n))
+ (walk (cdr l) t n))
+ (begin
+ (vector-set! d 1 1)
+ (if (= 1 (length m))
+ (cons (cons (caar l)
+ (walk (cdar l) t n))
+ (walk (cdr l) t n))
+ (walk l t
+ (cdr m))))))))
+ ((alist-ref (caar l) ilst) =>
+ (lambda (d)
+ (cons
+ (if (= 1 (vector-ref d 1))
+ (let ((m (map
+ (lambda (a x) (list a x))
+ (vector-ref d 2)
+ (walk (cdar l) t
+ (cons (caar l) n)))))
+ `(let ,(caar l) ,m
+ ,@(walk (vector-ref d 3) t
+ (cons (caar l) n))))
+ `(begin
+ ,@(map
+ (lambda (a x)
+ `(set-local! ,a ,x))
+ (vector-ref d 2)
+ (walk (cdar l) t
+ (cons (caar l) n)))
+ ,@(walk (vector-ref d 3) t
+ (cons (caar l) n))))
+ (walk (cdr l) t n))))
+ (else
+ (cons (walk (car l) t n) (walk (cdr l) t n)))))
+ ((pair? (car l))
+ (cons (cons (walk (caar l) t n) (walk (cdar l) t n))
+ (walk (cdr l) t n)))
+ ((vector? (car l))
+ (cons (list->vector (walk (vector->list (car l)) t n))
+ (walk (cdr l) t n)))
+ ((not (symbol? (car l)))
+ (cons (car l) (walk (cdr l) t n)))
+ ((> t 1)
+ (cons (car l) (walk (cdr l) t)))
+ ((memq (car l) n) =>
+ (lambda (m)
+ (let ((d (alist-ref (car l) ilst)))
+ (if (= 1 (vector-ref d 1))
+ (cons (car l) (walk (cdr l) t n))
+ (begin
+ (vector-set! d 1 1)
+ (if (= 1 (length m))
+ (cons (car l) (walk (cdr l) t n))
+ (walk l t (cdr m))))))))
+ ((alist-ref (car l) ilst) =>
+ (lambda (d)
+ (cons
+ (if (= 1 (vector-ref d 1))
+ (let* ((a (map
+ (lambda (x) (gensym 'ia))
+ (vector-ref d 2)))
+ (m (map
+ (lambda (a x) (list a x))
+ (vector-ref d 2) a)))
+ `(lambda ,a (let ,l ,m
+ ,@(walk (vector-ref d 3) t
+ (cons (car l) n)))))
+ `(lambda ,(vector-ref d 2)
+ ,@(walk (vector-ref d 3) t (cons (car l) n))))
+ (walk (cdr l) t n))))
+ (else
+ (cons (car l) (walk (cdr l) t n))))))
+
+;; finds which inlined procedures are called from non-inlined procedures
+;; performs substitutions for all inline procedures
+;; takes the further inline procedures, no further inline procedures, graph,
+;; inlined procedures list, and statements list
+;; ends by calling inline-pass:final with the statements and inline procedures
+;; ready for substitution
+(define (inline-pass:simplify2 fur nof g ilst rlst)
+ (for-each
+ (lambda (x)
+ (vector-set! (cdr x) 3
+ (inline-pass:subst1 (vector-ref (cdr x) 3) nof)))
+ fur)
+ (let ((v (inline-pass:walk rlst (make-vector i #f) fur)))
+ (for-each
+ (lambda (x)
+ (vector-set! (cdr x) 3
+ (inline-pass:subst2 (vector-ref (cdr x) 3) ilst
+ (list (car x)))))
+ (vector-fold
+ (lambda (i r x)
+ (if x
+ (cons (list-ref ilst i) r)
+ r))
+ '() v))
+ (inline-pass:final rlst ilst)))
+
+
+;; inlines all procedures
+;; takes the list of statements and the list of inline procedures with metadata
+;; returns the list of statements with all procedures inlined
+(define (inline-pass:final rlst ilst)
+ (if (null? ilst)
+ rlst
+ (inline-pass:subst1 rlst ilst)))
+
diff --git a/misc/library.files b/misc/library.files
new file mode 100644
index 00000000..f2e08464
--- /dev/null
+++ b/misc/library.files
@@ -0,0 +1,22 @@
+ports.scm
+posixunix.scm
+posixwin.scm
+profiler.scm
+regex.scm
+scheduler.scm
+srfi-13.scm
+srfi-14.scm
+srfi-18.scm
+data-structures.scm
+srfi-1.scm
+eval.scm
+srfi-4.scm
+expand.scm
+srfi-69.scm
+extras.scm
+stub.scm
+files.scm
+tcp.scm
+library.scm
+lolevel.scm
+utils.scm
diff --git a/misc/linux-runner.c b/misc/linux-runner.c
new file mode 100644
index 00000000..8a3205a7
--- /dev/null
+++ b/misc/linux-runner.c
@@ -0,0 +1,212 @@
+/*
+ * getexename.c
+ *
+ * written by Nicolai Haehnle <prefect_@gmx.net>
+ * I hereby release this trivial piece of code to the public domain.
+ *
+ * The function getexename() returns the filename of the currently loaded
+ * executable.
+ *
+ * Intended use of this function is to facilitate easier packaging of
+ * third-party software for the Linux operating system. The FHS mandates
+ * that files that belong to one package are scattered throughout the
+ * file system. This works as long as packages are maintained by a
+ * package management program. However, it is impossible for application
+ * developers to provide packages for every Linux distribution out there.
+ * Finding the file locations is also difficult when an application is
+ * installed locally by a user inside her own home directory.
+ *
+ * The simplest and most straight-forward solution to this problem is to
+ * put all files belonging to a package into the same directory. The program
+ * executable can then reference the necessary data files by using paths
+ * relative to the executable location.
+ * To give an example:
+ *
+ * A simple game, consisting of an executable and a number of data files
+ * (e.g. images), resides entirely in one directory, with absolute filenames
+ * like this:
+ * /the/path/foogame
+ * /the/path/images/hero.png
+ * /the/path/images/badass.png
+ * The game executable can use getexename() to find its own location, strip
+ * off the last component to get the directory the executable is located in,
+ * and append the relative paths "images/hero.png" and "images/badass.png"
+ * to reference the data files.
+ * The game will be completely position independent. The user is free to
+ * move it somewhere else in the filesystem, and it will just work; it will
+ * no longer be necessary to change configuration files or even recompile the
+ * executable.
+ *
+ * If you are concerned about executables showing up in a user's PATH, you
+ * should somehow arrange for symlinks to be made. For example, if
+ * /usr/games/foogame is a symlink to /the/path/foogame, the user can run the
+ * game simply by typing "foogame" in the shell (provided that /usr/games is in
+ * the user's PATH); since symlinks cannot fool getexename(), the game will
+ * still work. (Do note that a hard link will defeat getexename()).
+ *
+ * Note that while it is possible to reference data files based on the current
+ * working directory, this technique only works if the user explicitly sets
+ * the CWD to the application's base directory. Therefore, using the executable
+ * name as a base is more robust.
+ *
+ * Also note that while argv[0] can be used as the executable name in many
+ * cases as well, it is easily fooled by symlinks and may not contain an
+ * absolute filename. argv[0] can also be set to something entirely different
+ * from the executable filename by the executing process, either delibaretly
+ * or by invoking scripts.
+ *
+ * Note that this function relies on the layout of the /proc file system, so
+ * portability is an issue. While I assume that this part of /proc is fairly
+ * stable, I have no documentation whatsoever about potential differences
+ * between Linux kernel versions in this area.
+ *
+ */
+
+#include <stdlib.h>
+#include <stdio.h>
+#include <errno.h>
+
+#include <sys/types.h>
+#include <unistd.h>
+
+#ifndef PROGRAM
+# define PROGRAM "main"
+#endif
+
+
+/*
+ * getexename - Get the filename of the currently running executable
+ *
+ * The getexename() function copies an absolute filename of the currently
+ * running executable to the array pointed to by buf, which is of length size.
+ *
+ * If the filename would require a buffer longer than size elements, NULL is
+ * returned, and errno is set to ERANGE; an application should check for this
+ * error, and allocate a larger buffer if necessary.
+ *
+ * Return value:
+ * NULL on failure, with errno set accordingly, and buf on success. The
+ * contents of the array pointed to by buf is undefined on error.
+ *
+ * Notes:
+ * This function is tested on Linux only. It relies on information supplied by
+ * the /proc file system.
+ * The returned filename points to the final executable loaded by the execve()
+ * system call. In the case of scripts, the filename points to the script
+ * handler, not to the script.
+ * The filename returned points to the actual exectuable and not a symlink.
+ *
+ */
+char* getexename(char* buf, size_t size)
+{
+ char linkname[64]; /* /proc/<pid>/exe */
+ pid_t pid;
+ int ret;
+
+ /* Get our PID and build the name of the link in /proc */
+ pid = getpid();
+
+ if (snprintf(linkname, sizeof(linkname), "/proc/%i/exe", pid) < 0)
+ {
+ /* This should only happen on large word systems. I'm not sure
+ what the proper response is here.
+ Since it really is an assert-like condition, aborting the
+ program seems to be in order. */
+ abort();
+ }
+
+
+ /* Now read the symbolic link */
+ ret = readlink(linkname, buf, size);
+
+ /* In case of an error, leave the handling up to the caller */
+ if (ret == -1)
+ return NULL;
+
+ /* Report insufficient buffer size */
+ if (ret >= size)
+ {
+ errno = ERANGE;
+ return NULL;
+ }
+
+ /* Ensure proper NUL termination */
+ buf[ret] = 0;
+
+ return buf;
+}
+
+
+int main(int argc, char *argv[], char *envp[])
+{
+ char* buf, buf2[ 256 ], buf3[ 256 ];
+ int size;
+ static char *env2[ 1024 ];
+ char **ep, *cp;
+
+ buf = NULL;
+ size = 32; /* Set an initial size estimate */
+
+ for(;;)
+ {
+ char* res;
+
+ /* Allocate and fill the buffer */
+ buf = (char*)malloc(size);
+ res = getexename(buf, size);
+
+ /* Get out of the loop on success */
+ if (res)
+ break;
+
+ /* Anything but ERANGE indicates a real error */
+ if (errno != ERANGE)
+ {
+ perror("getexename() failed");
+ free(buf);
+ buf = NULL;
+ break;
+ }
+
+ /* ERANGE means the buffer was too small. Free the current
+ buffer and retry with a bigger one. */
+ free(buf);
+ size *= 2;
+ }
+
+ /* Exit on failure */
+ if (buf == NULL)
+ return -1;
+
+ cp = strrchr(buf, '/');
+
+ if(cp != NULL) *cp = '\0';
+
+ ep = env2;
+ sprintf(buf2, "LD_LIBRARY_PATH=%s", buf);
+ *(ep++) = buf2;
+ sprintf(buf3, "CHICKEN_REPOSITORY=%s", buf);
+ *(ep++) = buf3;
+
+ while(*envp != NULL) {
+ char *p2 = strchr(*envp, '=');
+
+ if(!strncmp(p2, "CHICKEN_REPOSITORY", strlen("CHICKEN_REPOSITORY")) ||
+ !strncmp(p2, "LD_LIBRARY_PATH", strlen("LD_LIBRARY_PATH")))
+ ++envp;
+ else {
+ *ep = *(envp++);
+
+ if(*(ep++) == NULL) break;
+ }
+ }
+
+ *ep = NULL;
+ strcat(buf, "/");
+ strcat(buf, PROGRAM);
+
+ if(execve(buf, argv + 1, env2) == -1)
+ perror("execve failed");
+
+ return 0; /* Indicate success */
+}
diff --git a/misc/manual.css b/misc/manual.css
new file mode 100644
index 00000000..786b36e1
--- /dev/null
+++ b/misc/manual.css
@@ -0,0 +1,33 @@
+/* manual.css - Stylesheet for HTML manual */
+
+
+CODE {
+ color: #666666;
+}
+
+a:link {
+ color: #336;
+}
+
+a:visited { color: #666; }
+
+a:active { color: #966; }
+
+a:hover { color: #669; }
+
+body {
+ background: #fff;
+ color: #000;
+ font: 9pt "Lucida Grande", "Verdana", sans-serif;
+ margin: 8em;
+}
+
+TABLE {
+ font: 9pt "Lucida Grande", "Verdana", sans-serif;
+}
+
+H3 {
+ color: #113;
+}
+
+PRE { font-family: "Andale Mono", monospace; }
diff --git a/misc/mini-runtime/Makefile b/misc/mini-runtime/Makefile
new file mode 100644
index 00000000..c32bc888
--- /dev/null
+++ b/misc/mini-runtime/Makefile
@@ -0,0 +1,21 @@
+.PHONY: all clean
+
+CC=gcc
+LD=gcc
+CFLAGS=-Os -fomit-frame-pointer -fno-strict-aliasing
+LDFLAGS=-s
+LIBS=-lm
+
+all: mini
+
+mini: lib.o runtime.o
+ $(LD) $(LDFLAGS) $^ -o $@ $(LIBS)
+
+runtime.o: ../../runtime.c ../../chicken.h
+ $(CC) -c $< -o $@ $(CFLAGS)
+
+lib.o: lib.scm ../../chicken.h
+ csc -cx -I../.. $< -o $@ -O2 -d0 -kv -raw -C "$(CFLAGS)"
+
+clean:
+ rm -f *.o mini
diff --git a/misc/mini-runtime/lib.scm b/misc/mini-runtime/lib.scm
new file mode 100644
index 00000000..cae0319c
--- /dev/null
+++ b/misc/mini-runtime/lib.scm
@@ -0,0 +1,7 @@
+;;;; lib.scm
+
+
+(define (##sys#interrupt-hook reason state) #f)
+(define (##sys#error-hook code loc . args) (##core#inline "C_halt" "error"))
+
+(##core#inline "C_halt" "yo!")
diff --git a/misc/osx-deploy-bundle.scm b/misc/osx-deploy-bundle.scm
new file mode 100644
index 00000000..d3f22018
--- /dev/null
+++ b/misc/osx-deploy-bundle.scm
@@ -0,0 +1,29 @@
+;;;; osx-deploy-bundle.scm
+;
+; Use like this:
+;
+; % csc <your-application-main-module> -prologue osx-deploy-bundle.scm -framework CoreFoundation
+
+
+(use posix easyffi)
+
+#>
+#include <CoreFoundation/CoreFoundation.h>
+<#
+
+(foreign-parse/declare #<<EOF
+static char *get_bundle_path()
+{
+ CFBundleRef bundle = CFBundleGetMainBundle();
+ CFURLRef url = CFBundleCopyExecutableURL(bundle);
+ static char buffer[ 256 ];
+
+ if(CFURLGetFileSystemRepresentation(url, true, buffer, sizeof(buffer))) return buffer;
+ else return NULL;
+}
+EOF
+)
+
+(let ((application-path (get_bundle_path)))
+ (assert application-path "unable to compute executable path")
+ (repository-path (pathname-directory application-path) ) )
diff --git a/misc/programs.files b/misc/programs.files
new file mode 100644
index 00000000..84f90222
--- /dev/null
+++ b/misc/programs.files
@@ -0,0 +1,8 @@
+chicken-bug.scm
+chicken-install.scm
+chicken-profile.scm
+chicken-setup.scm
+chicken-status.scm
+chicken-uninstall.scm
+csc.scm
+csi.scm
diff --git a/optimizer.scm b/optimizer.scm
new file mode 100644
index 00000000..dc0bdaeb
--- /dev/null
+++ b/optimizer.scm
@@ -0,0 +1,1778 @@
+;;;; optimizer.scm - The CHICKEN Scheme compiler (optimizations)
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit optimizer)
+ (not inline ##sys#compiler-syntax-hook) )
+
+
+(include "compiler-namespace")
+(include "tweaks")
+
+(define-constant maximal-number-of-free-variables-for-liftable 16)
+
+
+;;; Scan toplevel expressions for assignments:
+
+(define (scan-toplevel-assignments node)
+ (let ([safe '()]
+ [unsafe '()] )
+
+ (define (mark v)
+ (if (not (memq v unsafe)) (set! safe (cons v safe))) )
+
+ (debugging 'p "scanning toplevel assignments...")
+ (call-with-current-continuation
+ (lambda (return)
+
+ (define (scan-each ns e)
+ (for-each (lambda (n) (scan n e)) ns) )
+
+ (define (scan n e)
+ (let ([params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case (node-class n)
+
+ [(##core#variable)
+ (let ([var (first params)])
+ (if (and (not (memq var e)) (not (memq var safe)))
+ (set! unsafe (cons var unsafe)) ) ) ]
+
+ [(if ##core#cond ##core#switch)
+ (scan (first subs) e)
+ (return #f) ]
+
+ [(let)
+ (scan (first subs) e)
+ (scan (second subs) (append params e)) ]
+
+ [(lambda ##core#callunit) #f]
+
+ [(##core#call) (return #f)]
+
+ [(set!)
+ (let ([var (first params)])
+ (if (not (memq var e)) (mark var))
+ (scan (first subs) e) ) ]
+
+ [else (scan-each subs e)] ) ) )
+
+ (scan node '()) ) )
+ (debugging 'o "safe globals" safe)
+ (for-each (cut mark-variable <> '##compiler#always-bound) safe)))
+
+
+;;; Do some optimizations:
+;
+; - optimize tail recursion by replacing trivial continuations.
+; - perform beta-contraction (inline procedures called only once).
+; - remove empty 'let' nodes.
+; - evaluate constant expressions.
+; - substitute variables bound to constants with the value.
+; - remove variable-bindings which are never used (and which are not bound to side-effecting expressions).
+; - perform simple copy-propagation.
+; - remove assignments to unused variables if the assigned value is free of side-effects and the variable is
+; not global.
+; - remove unused formal parameters from functions and change all call-sites accordingly.
+; - rewrite calls to standard bindings into more efficient forms.
+; - rewrite calls to known non-escaping procedures with rest parameter to cons up rest-list at call-site,
+; also: change procedure's lambda-list.
+
+(define simplifications (make-vector 301 '()))
+(define simplified-ops '())
+
+(define (perform-high-level-optimizations node db)
+ (let ([removed-lets 0]
+ [removed-ifs 0]
+ [replaced-vars 0]
+ [rest-consers '()]
+ [simplified-classes '()]
+ [dirty #f] )
+
+ (define (test sym item) (get db sym item))
+ (define (constant-node? n) (eq? 'quote (node-class n)))
+ (define (node-value n) (first (node-parameters n)))
+ (define (touch) (set! dirty #t))
+
+ (define (simplify n)
+ (or (and-let* ([entry (##sys#hash-table-ref simplifications (node-class n))])
+ (any (lambda (s)
+ (and-let* ([vars (second s)]
+ [env (match-node n (first s) vars)]
+ [n2 (apply (third s) db
+ (map (lambda (v) (cdr (assq v env))) vars) ) ] )
+ (let* ([name (caar s)]
+ [counter (assq name simplified-classes)] )
+ (if counter
+ (set-cdr! counter (add1 (cdr counter)))
+ (set! simplified-classes (alist-cons name 1 simplified-classes)) )
+ (touch)
+ (simplify n2) ) ) )
+ entry) )
+ n) )
+
+ (define (walk n fids)
+ (if (memq n broken-constant-nodes)
+ n
+ (simplify
+ (let* ((odirty dirty)
+ (n1 (walk1 n fids))
+ (subs (node-subexpressions n1)) )
+ (case (node-class n1)
+
+ ((if) ; (This can be done by the simplificator...)
+ (cond ((constant-node? (car subs))
+ (set! removed-ifs (+ removed-ifs 1))
+ (touch)
+ (walk (if (node-value (car subs))
+ (cadr subs)
+ (caddr subs) )
+ fids) )
+ (else n1) ) )
+
+ ((##core#call)
+ (if (eq? '##core#variable (node-class (car subs)))
+ (let ((var (first (node-parameters (car subs)))))
+ (if (and (intrinsic? var)
+ (foldable? var)
+ (every constant-node? (cddr subs)) )
+ (let ((form (cons var (map (lambda (arg) `(quote ,(node-value arg)))
+ (cddr subs) ) ) ) )
+ (handle-exceptions ex
+ (begin
+ (unless odirty (set! dirty #f))
+ (set! broken-constant-nodes (lset-adjoin eq? broken-constant-nodes n1))
+ n1)
+ (let ((x (eval form)))
+ (debugging 'o "folding constant expression" form)
+ (touch)
+ (make-node ; Build call to continuation with new result...
+ '##core#call
+ '(#t)
+ (list (cadr subs) (qnode x)) ) ) ) )
+ n1) )
+ n1) )
+
+ (else n1) ) ) ) ) )
+
+ (define (walk1 n fids)
+ (let ((subs (node-subexpressions n))
+ (params (node-parameters n))
+ (class (node-class n)) )
+ (case class
+
+ ((##core#variable)
+ (let replace ((var (first params)))
+ (cond ((test var 'replacable) => replace)
+ ((test var 'collapsable)
+ (touch)
+ (debugging 'o "substituted constant variable" var)
+ (qnode (car (node-parameters (test var 'value)))) )
+ (else
+ (if (not (eq? var (first params)))
+ (begin
+ (touch)
+ (set! replaced-vars (+ replaced-vars 1)) ) )
+ (varnode var) ) ) ) )
+
+ ((let)
+ (let ([var (first params)])
+ (cond [(or (test var 'removable)
+ (and (test var 'contractable) (not (test var 'replacing))) )
+ (touch)
+ (set! removed-lets (add1 removed-lets))
+ (walk (second subs) fids) ]
+ [else (make-node 'let params (map (cut walk <> fids) subs))] ) ) )
+
+ ((##core#lambda)
+ (let ((llist (third params))
+ (id (first params)))
+ (cond [(test id 'has-unused-parameters)
+ (decompose-lambda-list
+ llist
+ (lambda (vars argc rest)
+ (receive (unused used) (partition (lambda (v) (test v 'unused)) vars)
+ (touch)
+ (debugging 'o "removed unused formal parameters" unused)
+ (make-node
+ '##core#lambda
+ (list (first params) (second params)
+ (cond [(and rest (test id 'explicit-rest))
+ (debugging 'o "merged explicitly consed rest parameter" rest)
+ (build-lambda-list used (add1 argc) #f) ]
+ [else (build-lambda-list used argc rest)] )
+ (fourth params) )
+ (list (walk (first subs) (cons id fids))) ) ) ) ) ]
+ [(test id 'explicit-rest)
+ (decompose-lambda-list
+ llist
+ (lambda (vars argc rest)
+ (touch)
+ (debugging 'o "merged explicitly consed rest parameter" rest)
+ (make-node
+ '##core#lambda
+ (list (first params)
+ (second params)
+ (build-lambda-list vars (add1 argc) #f)
+ (fourth params) )
+ (list (walk (first subs) (cons id fids))) ) ) ) ]
+ [else (walk-generic n class params subs (cons id fids))] ) ) )
+
+ ((##core#call)
+ (let* ([fun (car subs)]
+ [funclass (node-class fun)] )
+ (case funclass
+ [(##core#variable)
+ ;; Call to named procedure:
+ (let* ([var (first (node-parameters fun))]
+ [lval (and (not (test var 'unknown))
+ (or (test var 'value)
+ (test var 'local-value)))]
+ [args (cdr subs)] )
+ (cond [(test var 'contractable)
+ (let* ([lparams (node-parameters lval)]
+ [llist (third lparams)] )
+ (check-signature var args llist)
+ (debugging 'o "contracted procedure" var)
+ (touch)
+ (for-each (cut put! db <> 'inline-target #t) fids)
+ (walk
+ (inline-lambda-bindings llist args (first (node-subexpressions lval)) #f db)
+ fids) ) ]
+ [(memq var constant-declarations)
+ (or (and-let* ((k (car args))
+ ((eq? '##core#variable (node-class k)))
+ (kvar (first (node-parameters k)))
+ (lval (and (not (test kvar 'unknown)) (test kvar 'value)))
+ ((eq? '##core#lambda (node-class lval)))
+ (llist (third (node-parameters lval)))
+ ((or (test (car llist) 'unused)
+ (and (not (test (car llist) 'references))
+ (not (test (car llist) 'assigned)))))
+ ((not (any (cut expression-has-side-effects? <> db) (cdr args) ))))
+ (debugging 'x "removed call to constant procedure with unused result" var)
+ (make-node
+ '##core#call '(#t)
+ (list k (make-node '##core#undefined '() '())) ) )
+ (walk-generic n class params subs fids)) ]
+ [(and lval
+ (eq? '##core#lambda (node-class lval)))
+ (let* ([lparams (node-parameters lval)]
+ [llist (third lparams)] )
+ (decompose-lambda-list
+ llist
+ (lambda (vars argc rest)
+ (let ([ifid (first lparams)])
+ (cond [(and inline-locally
+ (test var 'inlinable)
+ (not (test (first lparams) 'inline-target)) ; inlinable procedure has changed
+ (case (variable-mark var '##compiler#inline)
+ ((yes) #t)
+ ((no) #f)
+ (else
+ (< (fourth lparams) inline-max-size) ) ))
+ (debugging
+ 'i
+ (if (node? (variable-mark var '##compiler#inline-global))
+ "global inlining"
+ "inlining")
+ var ifid (fourth lparams))
+ (for-each (cut put! db <> 'inline-target #t) fids)
+ (check-signature var args llist)
+ (debugging 'o "inlining procedure" var)
+ (touch)
+ (walk
+ (inline-lambda-bindings llist args (first (node-subexpressions lval)) #t db)
+ fids) ]
+ [(test ifid 'has-unused-parameters)
+ (if (< (length args) argc) ; Expression was already optimized (should this happen?)
+ (walk-generic n class params subs fids)
+ (let loop ((vars vars) (argc argc) (args args) (used '()))
+ (cond [(or (null? vars) (zero? argc))
+ (touch)
+ (make-node
+ '##core#call
+ params
+ (map (cut walk <> fids) (cons fun (append-reverse used args))) ) ]
+ [(test (car vars) 'unused)
+ (touch)
+ (debugging
+ 'o "removed unused parameter to known procedure"
+ (car vars) var)
+ (if (expression-has-side-effects? (car args) db)
+ (make-node
+ 'let
+ (list (gensym 't))
+ (list (walk (car args) fids)
+ (loop (cdr vars) (sub1 argc) (cdr args) used) ) )
+ (loop (cdr vars) (sub1 argc) (cdr args) used) ) ]
+ [else (loop (cdr vars)
+ (sub1 argc)
+ (cdr args)
+ (cons (car args) used) ) ] ) ) ) ]
+ [(and (test ifid 'explicit-rest)
+ (not (memq n rest-consers)) ) ; make sure we haven't inlined rest-list already
+ (let ([n (llist-length llist)])
+ (if (< (length args) n)
+ (walk-generic n class params subs fids)
+ (begin
+ (debugging 'o "consed rest parameter at call site" var n)
+ (let-values ([(args rargs) (split-at args n)])
+ (let ([n2 (make-node
+ '##core#call
+ params
+ (map (cut walk <> fids)
+ (cons fun
+ (append
+ args
+ (list
+ (if (null? rargs)
+ (qnode '())
+ (make-node
+ '##core#inline_allocate
+ (list "C_a_i_list" (* 3 (length rargs)))
+ rargs) ) ) ) ) ) ) ] )
+ (set! rest-consers (cons n2 rest-consers))
+ n2) ) ) ) ) ]
+ [else (walk-generic n class params subs fids)] ) ) ) ) ) ]
+ [else (walk-generic n class params subs fids)] ) ) ]
+ [(##core#lambda)
+ (if (first params)
+ (walk-generic n class params subs fids)
+ (make-node '##core#call (cons #t (cdr params)) (map (cut walk <> fids) subs)) ) ]
+ [else (walk-generic n class params subs fids)] ) ) )
+
+ ((set!)
+ (let ([var (first params)])
+ (cond [(or (test var 'contractable) (test var 'replacable))
+ (touch)
+ (make-node '##core#undefined '() '()) ]
+ [(and (or (not (test var 'global))
+ (not (variable-visible? var)))
+ (not (test var 'inline-transient))
+ (not (test var 'references))
+ (not (expression-has-side-effects? (first subs) db)) )
+ (touch)
+ (debugging 'o "removed side-effect free assignment to unused variable" var)
+ (make-node '##core#undefined '() '()) ]
+ [else (make-node 'set! params (list (walk (car subs) fids)))] ) ) )
+
+ (else (walk-generic n class params subs fids)) ) ) )
+
+ (define (walk-generic n class params subs fids)
+ (let ((subs2 (map (cut walk <> fids) subs)))
+ (if (every eq? subs subs2)
+ n
+ (make-node class params subs2) ) ) )
+
+ (if (perform-pre-optimization! node db)
+ (values node #t)
+ (begin
+ (debugging 'p "traversal phase...")
+ (set! simplified-ops '())
+ (let ((node2 (walk node '())))
+ (when (pair? simplified-classes) (debugging 'o "simplifications" simplified-classes))
+ (when (and (pair? simplified-ops) (debugging 'o " call simplifications:"))
+ (for-each
+ (lambda (p)
+ (print* #\tab (car p))
+ (if (> (cdr p) 1)
+ (print #\tab (cdr p))
+ (newline) ) )
+ simplified-ops) )
+ (when (> replaced-vars 0) (debugging 'o "replaced variables" replaced-vars))
+ (when (> removed-lets 0) (debugging 'o "removed binding forms" removed-lets))
+ (when (> removed-ifs 0) (debugging 'o "removed conditional forms" removed-ifs))
+ (values node2 dirty) ) ) ) ) )
+
+
+;;; Pre-optimization phase:
+;
+; - Transform expressions of the form '(if (not <x>) <y> <z>)' into '(if <x> <z> <y>)'.
+; - Transform expressions of the form '(if (<x> <y> ...) <z> <q>)' into '<z>' if <x> names a
+; standard-binding that is never #f and if it's arguments are free of side-effects.
+
+(define (perform-pre-optimization! node db)
+ (let ((dirty #f)
+ (removed-nots 0) )
+
+ (define (touch) (set! dirty #t) #t)
+ (define (test sym prop) (get db sym prop))
+
+ (debugging 'p "pre-optimization phase...")
+
+ ;; Handle '(if (not ...) ...)':
+ (if (intrinsic? 'not)
+ (for-each
+ (lambda (site)
+ (let* ((n (cdr site))
+ (subs (node-subexpressions n))
+ (kont (first (node-parameters (second subs))))
+ (lnode (and (not (test kont 'unknown)) (test kont 'value)))
+ (krefs (get-list db kont 'references)) )
+ ;; Call-site has one argument and a known continuation (which is a ##core#lambda)
+ ;; that has only one use:
+ (when (and lnode krefs (= 1 (length krefs)) (= 3 (length subs))
+ (eq? '##core#lambda (node-class lnode)) )
+ (let* ((llist (third (node-parameters lnode)))
+ (body (first (node-subexpressions lnode)))
+ (bodysubs (node-subexpressions body)) )
+ ;; Continuation has one parameter?
+ (if (and (proper-list? llist) (null? (cdr llist)))
+ (let* ((var (car llist))
+ (refs (get-list db var 'references)) )
+ ;; Parameter is only used once?
+ (if (and refs (= 1 (length refs)) (eq? 'if (node-class body)))
+ ;; Continuation contains an 'if' node?
+ (let ((iftest (first (node-subexpressions body))))
+ ;; Parameter is used only once and is the test-argument?
+ (if (and (eq? '##core#variable (node-class iftest))
+ (eq? var (first (node-parameters iftest))) )
+ ;; Modify call-site to call continuation directly and swap branches
+ ;; in the conditional:
+ (begin
+ (set! removed-nots (+ removed-nots 1))
+ (node-parameters-set! n '(#t))
+ (node-subexpressions-set! n (cdr subs))
+ (node-subexpressions-set!
+ body
+ (cons (car bodysubs) (reverse (cdr bodysubs))) )
+ (touch) ) ) ) ) ) ) ) ) ) )
+ (or (test 'not 'call-sites) '()) ) )
+
+ (when (> removed-nots 0) (debugging 'o "Removed `not' forms" removed-nots))
+ dirty) )
+
+
+;;; Simplifications:
+
+(define (register-simplifications class . ss)
+ (##sys#hash-table-set! simplifications class ss) )
+
+
+(register-simplifications
+ '##core#call
+ ;; (<named-call> ...) -> (<primitive-call/inline> ...)
+ `((##core#call d (##core#variable (a)) b . c)
+ (a b c d)
+ ,(lambda (db a b c d)
+ (let loop ((entries (or (##sys#hash-table-ref substitution-table a) '())))
+ (cond ((null? entries) #f)
+ ((simplify-named-call db d a b (caar entries) (cdar entries) c)
+ => (lambda (r)
+ (let ((as (assq a simplified-ops)))
+ (if as
+ (set-cdr! as (add1 (cdr as)))
+ (set! simplified-ops (alist-cons a 1 simplified-ops)) ) )
+ r) )
+ (else (loop (cdr entries))) ) ) ) ) )
+
+
+(register-simplifications
+ 'let
+
+ ;; (let ((<var1> (##core#inline <eq-inline-operator> <var0> <const1>)))
+ ;; (if <var1> <body1>
+ ;; (let ((<var2> (##core#inline <eq-inline-operator> <var0> <const2>)))
+ ;; (if <var2> <body2>
+ ;; <etc.>
+ ;; -> (##core#switch (2) <var0> <const1> <body1> <const2> <body2> <etc.>)
+ ;; - <var1> and <var2> have to be referenced once only.
+ `((let (var1) (##core#inline (op) (##core#variable (var0)) (quote (const1)))
+ (if d1 (##core#variable (var1))
+ body1
+ (let (var2) (##core#inline (op) (##core#variable (var0)) (quote (const2)))
+ (if d2 (##core#variable (var2))
+ body2
+ rest) ) ) )
+ (var0 var1 var2 op const1 const2 body1 body2 d1 d2 rest)
+ ,(lambda (db var0 var1 var2 op const1 const2 body1 body2 d1 d2 rest)
+ (and (equal? op eq-inline-operator)
+ (immediate? const1)
+ (immediate? const2)
+ (= 1 (length (get-list db var1 'references)))
+ (= 1 (length (get-list db var2 'references)))
+ (make-node
+ '##core#switch
+ '(2)
+ (list (varnode var0)
+ (qnode const1)
+ body1
+ (qnode const2)
+ body2
+ rest) ) ) ) )
+
+ ;; (let ((<var> (##core#inline <eq-inline-operator> <var0> <const>)))
+ ;; (if <var>
+ ;; <body>
+ ;; (##core#switch <n> <var0> <const1> <body1> ... <rest>) ) )
+ ;; -> (##core#switch <n+1> <var0> <const> <body> <const1> <body1> ... <rest>)
+ ;; - <var> has to be referenced once only.
+ `((let (var) (##core#inline (op) (##core#variable (var0)) (quote (const)))
+ (if d (##core#variable (var))
+ body
+ (##core#switch (n) (##core#variable (var0)) . clauses) ) )
+ (var op var0 const d body n clauses)
+ ,(lambda (db var op var0 const d body n clauses)
+ (and (equal? op eq-inline-operator)
+ (immediate? const)
+ (= 1 (length (get-list db var 'references)))
+ (make-node
+ '##core#switch
+ (list (add1 n))
+ (cons* (varnode var0)
+ (qnode const)
+ body
+ clauses) ) ) ) )
+
+ ;; (let ((<var1> (##core#undefined)))
+ ;; (let ((<var2> (##core#undefined)))
+ ;; ...
+ ;; (let ((<tmp1> (set! <var1> <x1>))
+ ;; (let ((<tmp2> (set! <var2> <x2>)))
+ ;; ...
+ ;; <body>) ... )
+ ;; -> <a simpler sequence of let's>
+ ;; - <tmpI> may not be used.
+ `((let (var1) (##core#undefined ())
+ more)
+ (var1 more)
+ ,(lambda (db var1 more)
+ (let loop1 ([vars (list var1)]
+ [body more] )
+ (let ([c (node-class body)]
+ [params (node-parameters body)]
+ [subs (node-subexpressions body)] )
+ (and (eq? c 'let)
+ (null? (cdr params))
+ (let* ([val (first subs)]
+ [valparams (node-parameters val)]
+ [valsubs (node-subexpressions val)] )
+ (case (node-class val)
+ [(##core#undefined) (loop1 (cons (first params) vars) (second subs))]
+ [(set!)
+ (let ([allvars (reverse vars)])
+ (and (pair? allvars)
+ (eq? (first valparams) (first allvars))
+ (let loop2 ([vals (list (first valsubs))]
+ [vars (cdr allvars)]
+ [body (second subs)] )
+ (let ([c (node-class body)]
+ [params (node-parameters body)]
+ [subs (node-subexpressions body)] )
+ (cond [(and (eq? c 'let)
+ (null? (cdr params))
+ (not (get db (first params) 'inline-transient))
+ (not (get db (first params) 'references))
+ (pair? vars)
+ (eq? 'set! (node-class (first subs)))
+ (eq? (car vars) (first (node-parameters (first subs)))) )
+ (loop2 (cons (first (node-subexpressions (first subs))) vals)
+ (cdr vars)
+ (second subs) ) ]
+ [(null? vars)
+ (receive (n progress)
+ (reorganize-recursive-bindings allvars (reverse vals) body)
+ (and progress n) ) ]
+ [else #f] ) ) ) ) ) ]
+ [else #f] ) ) ) ) ) ) )
+
+ ;; (let ((<var1> <var2>))
+ ;; (<var1> ...) )
+ ;; -> (<var2> ...)
+ ;; - <var1> used only once
+ #| this doesn't seem to work (Sven Hartrumpf):
+ `((let (var1) (##core#variable (var2))
+ (##core#call p (##core#variable (var1)) . more) ) ; `p' was `#t', bombed also
+ (var1 var2 p more)
+ ,(lambda (db var1 var2 p more)
+ (and (= 1 (length (get-list db var1 'references)))
+ (make-node
+ '##core#call p
+ (cons (varnode var2) more) ) ) ) )
+ |#
+
+ ;; (let ((<var> (##core#inline <op> ...)))
+ ;; (if <var> <x> <y>) )
+ ;; -> (if (##core#inline <op> ...) <x> <y>)
+ ;; - <op> may not be the eq-inline operator (so rewriting to "##core#switch" works).
+ ;; - <var> has to be referenced only once.
+ `((let (var) (##core#inline (op) . args)
+ (if d (##core#variable (var))
+ x
+ y) )
+ (var op args d x y)
+ ,(lambda (db var op args d x y)
+ (and (not (equal? op eq-inline-operator))
+ (= 1 (length (get-list db var 'references)))
+ (make-node
+ 'if d
+ (list (make-node '##core#inline (list op) args)
+ x y) ) ) ) ) )
+
+
+(register-simplifications
+ 'if
+
+ ;; (if <x>
+ ;; (<var> <y>)
+ ;; (<var> <z>) )
+ ;; -> (<var> (##core#cond <x> <y> <z>))
+ ;; - inline-substitutions have to be enabled (so IF optimizations have already taken place).
+ `((if d1 x
+ (##core#call d2 (##core#variable (var)) y)
+ (##core#call d3 (##core#variable (var)) z) )
+ (d1 d2 d3 x y z var)
+ ,(lambda (db d1 d2 d3 x y z var)
+ (and inline-substitutions-enabled
+ (make-node
+ '##core#call d2
+ (list (varnode var)
+ (make-node '##core#cond '() (list x y z)) ) ) ) ) )
+
+ ;; (if (##core#inline <memXXX> <x> '(<c1> ...)) ...)
+ ;; -> (let ((<var> <x>))
+ ;; (if (##core#cond (##core#inline XXX? <var> '<c1>) #t ...) ...)
+ ;; - there is a limit on the number of items in the list of constants.
+ `((if d1 (##core#inline (op) x (quote (clist)))
+ y
+ z)
+ (d1 op x clist y z)
+ ,(lambda (db d1 op x clist y z)
+ (and-let* ([opa (assoc op membership-test-operators)]
+ [(proper-list? clist)]
+ [(< (length clist) membership-unfold-limit)] )
+ (let ([var (gensym)]
+ [eop (list (cdr opa))] )
+ (make-node
+ 'let (list var)
+ (list
+ x
+ (make-node
+ 'if d1
+ (list
+ (fold-right
+ (lambda (c rest)
+ (make-node
+ '##core#cond '()
+ (list
+ (make-node '##core#inline eop (list (varnode var) (qnode c)))
+ (qnode #t)
+ rest) ) )
+ (qnode #f)
+ clist)
+ y
+ z) ) ) ) ) ) ) ) )
+
+
+;;; Perform dependency-analysis and transform letrec's into simpler constructs (if possible):
+
+(define (reorganize-recursive-bindings vars vals body)
+ (let ([graph '()]
+ [valmap (map cons vars vals)] )
+
+ (define (find-path var1 var2)
+ (let find ([var var1] [traversed '()])
+ (and (not (memq var traversed))
+ (let ([arcs (cdr (assq var graph))])
+ (or (memq var2 arcs)
+ (let ([t2 (cons var traversed)])
+ (any (lambda (v) (find v t2)) arcs) ) ) ) ) ) )
+
+ ;; Build dependency graph:
+ (for-each
+ (lambda (var val) (set! graph (alist-cons var (scan-used-variables val vars) graph)))
+ vars vals)
+
+ ;; Compute recursive groups:
+ (let ([groups '()]
+ [done '()] )
+ (for-each
+ (lambda (var)
+ (when (not (memq var done))
+ (let ([g (filter
+ (lambda (v) (and (not (eq? v var)) (find-path var v) (find-path v var)))
+ vars) ] )
+ (set! groups (alist-cons (gensym) (cons var g) groups))
+ (set! done (append (list var) g done)) ) ) )
+ vars)
+
+ ;; Coalesce groups into a new graph:
+ (let ([cgraph '()])
+ (for-each
+ (lambda (g)
+ (let ([id (car g)]
+ [deps
+ (append-map
+ (lambda (var) (filter (lambda (v) (find-path var v)) vars))
+ (cdr g) ) ] )
+ (set! cgraph
+ (alist-cons
+ id
+ (filter-map
+ (lambda (g2) (and (not (eq? g2 g)) (lset<= eq? (cdr g2) deps) (car g2)))
+ groups)
+ cgraph) ) ) )
+ groups)
+
+ ;; Topologically sort secondary dependency graph:
+ (let ([sgraph (topological-sort cgraph eq?)]
+ [optimized '()] )
+
+ ;; Construct new bindings:
+ (let ([n2
+ (fold
+ (lambda (gn body)
+ (let* ([svars (cdr (assq gn groups))]
+ [svar (car svars)] )
+ (cond [(and (null? (cdr svars))
+ (not (memq svar (cdr (assq svar graph)))) )
+ (set! optimized (cons svar optimized))
+ (make-node 'let svars (list (cdr (assq svar valmap)) body)) ]
+ [else
+ (fold-right
+ (lambda (var rest)
+ (make-node
+ 'let (list var)
+ (list (make-node '##core#undefined '() '()) rest) ) )
+ (fold-right
+ (lambda (var rest)
+ (make-node
+ 'let (list (gensym))
+ (list (make-node 'set! (list var) (list (cdr (assq var valmap))))
+ rest) ) )
+ body
+ svars)
+ svars) ] ) ) )
+ body
+ sgraph) ] )
+ (cond [(pair? optimized)
+ (debugging 'o "eliminated assignments" optimized)
+ (values n2 #t) ]
+ [else (values n2 #f)] ) ) ) ) ) ) )
+
+
+;;;; Rewrite named calls to more primitive forms:
+
+(define substitution-table (make-vector 301 '()))
+
+(define (rewrite name . class-and-args)
+ (let ((old (or (##sys#hash-table-ref substitution-table name) '())))
+ (##sys#hash-table-set! substitution-table name (append old (list class-and-args))) ) )
+
+(define (simplify-named-call db params name cont class classargs callargs)
+ (define (test sym prop) (get db sym prop))
+ (define (defarg x)
+ (cond ((symbol? x) (varnode x))
+ ((and (pair? x) (eq? 'quote (car x))) (qnode (cadr x)))
+ (else (qnode x))))
+
+ (case class
+
+ ;; (eq?/eqv?/equal? <var> <var>) -> (quote #t)
+ ;; (eq?/eqv?/equal? ...) -> (##core#inline <iop> ...)
+ ((1) ; classargs = (<argc> <iop>)
+ (and (intrinsic? name)
+ (or (and (= (length callargs) (first classargs))
+ (let ((arg1 (first callargs))
+ (arg2 (second callargs)) )
+ (and (eq? '##core#variable (node-class arg1))
+ (eq? '##core#variable (node-class arg2))
+ (equal? (node-parameters arg1) (node-parameters arg2))
+ (make-node '##core#call '(#t) (list cont (qnode #t))) ) ) )
+ (and inline-substitutions-enabled
+ (make-node
+ '##core#call '(#t)
+ (list cont (make-node '##core#inline (list (second classargs)) callargs)) ) ) ) ) )
+
+ ;; (<op> ...) -> (##core#inline <iop> ...)
+ ;; (<op> <rest-vector>) -> (##core#inline <iopv> <rest-vector>)
+ ((2) ; classargs = (<argc> <iop> <safe> <iopv>)
+ (and inline-substitutions-enabled
+ (= (length callargs) (first classargs))
+ (intrinsic? name)
+ (or (third classargs) unsafe)
+ (let ([arg1 (first callargs)]
+ [iopv (fourth classargs)] )
+ (make-node
+ '##core#call '(#t)
+ (list
+ cont
+ (cond [(and iopv
+ (eq? '##core#variable (node-class arg1))
+ (eq? 'vector (get db (first (node-parameters arg1)) 'rest-parameter)) )
+ (make-node '##core#inline (list iopv) callargs) ]
+ [else (make-node '##core#inline (list (second classargs)) callargs)] ) ) ) ) ) )
+
+ ;; (<op>) -> <var>
+ ((3) ; classargs = (<var>)
+ (and inline-substitutions-enabled
+ (null? callargs)
+ (intrinsic? name)
+ (make-node '##core#call '(#t) (list cont (varnode (first classargs)))) ) )
+
+ ;; (<op> a b) -> (<primitiveop> a (quote <i>) b)
+ ((4) ; classargs = (<primitiveop> <i>)
+ (and inline-substitutions-enabled
+ unsafe
+ (= 2 (length callargs))
+ (intrinsic? name)
+ (make-node '##core#call (list #f (first classargs))
+ (list (varnode (first classargs))
+ cont
+ (first callargs)
+ (qnode (second classargs))
+ (second callargs) ) ) ) )
+
+ ;; (<op> a) -> (##core#inline <iop> a (quote <x>))
+ ((5) ; classargs = (<iop> <x> <numtype>)
+ ;; - <numtype> may be #f
+ (and inline-substitutions-enabled
+ (intrinsic? name)
+ (= 1 (length callargs))
+ (let ((ntype (third classargs)))
+ (or (not ntype) (eq? ntype number-type)) )
+ (make-node '##core#call '(#t)
+ (list cont
+ (make-node '##core#inline (list (first classargs))
+ (list (first callargs)
+ (qnode (second classargs)) ) ) ) ) ) )
+
+ ;; (<op> a) -> (##core#inline <iop1> (##core#inline <iop2> a))
+ ((6) ; classargs = (<iop1> <iop2> <safe>)
+ (and (or (third classargs) unsafe)
+ inline-substitutions-enabled
+ (= 1 (length callargs))
+ (intrinsic? name)
+ (make-node '##core#call '(#t)
+ (list cont
+ (make-node '##core#inline (list (first classargs))
+ (list (make-node '##core#inline (list (second classargs))
+ callargs) ) ) ) ) ) )
+
+ ;; (<op> ...) -> (##core#inline <iop> ... (quote <x>))
+ ((7) ; classargs = (<argc> <iop> <x> <safe>)
+ (and (or (fourth classargs) unsafe)
+ inline-substitutions-enabled
+ (= (length callargs) (first classargs))
+ (intrinsic? name)
+ (make-node '##core#call '(#t)
+ (list cont
+ (make-node '##core#inline (list (second classargs))
+ (append callargs
+ (list (qnode (third classargs))) ) ) ) ) ) )
+
+ ;; (<op> ...) -> <<call procedure <proc> with <classargs>, <cont> and <callargs> >>
+ ((8) ; classargs = (<proc> ...)
+ (and inline-substitutions-enabled
+ (intrinsic? name)
+ ((first classargs) db classargs cont callargs) ) )
+
+ ;; (<op> <x1> ...) -> (##core#inline "C_and" (##core#inline <iop> <x1> <x2>) ...)
+ ;; (<op> [<x>]) -> (quote #t)
+ ((9) ; classargs = (<iop-fixnum> <iop-flonum> <fixnum-safe> <flonum-safe>)
+ (and inline-substitutions-enabled
+ (intrinsic? name)
+ (if (< (length callargs) 2)
+ (make-node '##core#call '(#t) (list cont (qnode #t)))
+ (and (or (and unsafe (not (eq? number-type 'generic)))
+ (and (eq? number-type 'fixnum) (third classargs))
+ (and (eq? number-type 'flonum) (fourth classargs)) )
+ (let* ([names (map (lambda (z) (gensym)) callargs)]
+ [vars (map varnode names)] )
+ (fold-right
+ (lambda (x n y) (make-node 'let (list n) (list x y)))
+ (make-node
+ '##core#call '(#t)
+ (list
+ cont
+ (let ([op (list
+ (if (eq? number-type 'fixnum)
+ (first classargs)
+ (second classargs) ) ) ] )
+ (fold-boolean
+ (lambda (x y) (make-node '##core#inline op (list x y)))
+ vars) ) ) )
+ callargs names) ) ) ) ) )
+
+ ;; (<op> a [b]) -> (<primitiveop> a (quote <i>) b)
+ ((10) ; classargs = (<primitiveop> <i> <bvar> <safe>)
+ (and inline-substitutions-enabled
+ (or (fourth classargs) unsafe)
+ (intrinsic? name)
+ (let ((n (length callargs)))
+ (and (< 0 n 3)
+ (make-node '##core#call (list #f (first classargs))
+ (list (varnode (first classargs))
+ cont
+ (first callargs)
+ (qnode (second classargs))
+ (if (null? (cdr callargs))
+ (varnode (third classargs))
+ (second callargs) ) ) ) ) ) ) )
+
+ ;; (<op> ...) -> (<primitiveop> ...)
+ ((11) ; classargs = (<argc> <primitiveop> <safe>)
+ ;; <argc> may be #f.
+ (and inline-substitutions-enabled
+ (or (third classargs) unsafe)
+ (intrinsic? name)
+ (let ([argc (first classargs)])
+ (and (or (not argc)
+ (= (length callargs) (first classargs)) )
+ (make-node '##core#call (list #t (second classargs))
+ (cons* (varnode (second classargs))
+ cont
+ callargs) ) ) ) ) )
+
+ ;; (<op> a) -> a
+ ;; (<op> ...) -> (<primitiveop> ...)
+ ((12) ; classargs = (<primitiveop> <safe> <maxargc>)
+ (and inline-substitutions-enabled
+ (intrinsic? name)
+ (or (second classargs) unsafe)
+ (let ((n (length callargs)))
+ (and (<= n (third classargs))
+ (case n
+ ((1) (make-node '##core#call '(#t) (cons cont callargs)))
+ (else (make-node '##core#call (list #t (first classargs))
+ (cons* (varnode (first classargs))
+ cont callargs) ) ) ) ) ) ) )
+
+ ;; (<op> ...) -> ((##core#proc <primitiveop>) ...)
+ ((13) ; classargs = (<primitiveop> <safe>)
+ (and inline-substitutions-enabled
+ (intrinsic? name)
+ (or (second classargs) unsafe)
+ (let ((pname (first classargs)))
+ (make-node '##core#call (if (pair? params) (cons #t (cdr params)) params)
+ (cons* (make-node '##core#proc (list pname #t) '())
+ cont callargs) ) ) ) )
+
+ ;; (<op> <x> ...) -> (##core#inline <iop-safe>/<iop-unsafe> <x> ...)
+ ((14) ; classargs = (<numtype> <argc> <iop-safe> <iop-unsafe>)
+ (and inline-substitutions-enabled
+ (= (second classargs) (length callargs))
+ (intrinsic? name)
+ (eq? number-type (first classargs))
+ (or (fourth classargs) unsafe)
+ (make-node
+ '##core#call '(#t)
+ (list cont
+ (make-node
+ '##core#inline
+ (list (if unsafe (fourth classargs) (third classargs)))
+ callargs) ) ) ) )
+
+ ;; (<op> <x>) -> (<primitiveop> <x>) - if numtype1
+ ;; | <x> - if numtype2
+ ((15) ; classargs = (<numtype1> <numtype2> <primitiveop> <safe>)
+ (and inline-substitutions-enabled
+ (= 1 (length callargs))
+ (or unsafe (fourth classargs))
+ (intrinsic? name)
+ (cond ((eq? number-type (first classargs))
+ (make-node '##core#call (list #t (third classargs))
+ (cons* (varnode (third classargs)) cont callargs) ) )
+ ((eq? number-type (second classargs))
+ (make-node '##core#call '(#t) (cons cont callargs)) )
+ (else #f) ) ) )
+
+ ;; (<alloc-op> ...) -> (##core#inline_allocate (<aiop> <words>) ...)
+ ((16) ; classargs = (<argc> <aiop> <safe> <words>)
+ ;; - <argc> may be #f, saying that any number of arguments is allowed,
+ ;; - <words> may be a list of one element (the number of words), meaning that
+ ;; the words are to be multiplied with the number of arguments.
+ ;; - <words> may also be #t, meaning that the number of words is the same as the
+ ;; number of arguments plus 1.
+ (let ([argc (first classargs)]
+ [rargc (length callargs)]
+ [w (fourth classargs)] )
+ (and inline-substitutions-enabled
+ (or (not argc) (= rargc argc))
+ (intrinsic? name)
+ (or (third classargs) unsafe)
+ (make-node
+ '##core#call '(#t)
+ (list cont
+ (make-node
+ '##core#inline_allocate
+ (list (second classargs)
+ (cond [(eq? #t w) (add1 rargc)]
+ [(pair? w) (* rargc (car w))]
+ [else w] ) )
+ callargs) ) ) ) ) )
+
+ ;; (<op> ...) -> (##core#inline <iop>/<unsafe-iop> ...)
+ ((17) ; classargs = (<argc> <iop-safe> [<iop-unsafe>])
+ (and inline-substitutions-enabled
+ (= (length callargs) (first classargs))
+ (intrinsic? name)
+ (make-node
+ '##core#call '(#t)
+ (list cont
+ (make-node '##core#inline
+ (list (if (and unsafe (pair? (cddr classargs)))
+ (third classargs)
+ (second classargs) ) )
+ callargs)) ) ) )
+
+ ;; (<op>) -> (quote <null>)
+ ((18) ; classargs = (<null>)
+ (and inline-substitutions-enabled
+ (null? callargs)
+ (intrinsic? name)
+ (make-node '##core#call '(#t) (list cont (qnode (first classargs))) ) ) )
+
+ ;; (<op>) -> <id>
+ ;; (<op> <x>) -> <x>
+ ;; (<op> <x1> ...) -> (##core#inline <fixop> <x1> (##core#inline <fixop> ...)) [fixnum-mode]
+ ;; (<op> <x1> ...) -> (##core#inline <ufixop> <x1> (##core#inline <ufixop> ...)) [fixnum-mode + unsafe]
+ ;; - Remove "<id>" from arguments.
+ ((19) ; classargs = (<id> <fixop> <ufixop> <fixmode>)
+ (and inline-substitutions-enabled
+ (intrinsic? name)
+ (let* ([id (first classargs)]
+ [fixop (if unsafe (third classargs) (second classargs))]
+ [callargs
+ (remove
+ (lambda (x)
+ (and (eq? 'quote (node-class x))
+ (eq? id (first (node-parameters x))) ) )
+ callargs) ] )
+ (cond [(null? callargs) (make-node '##core#call '(#t) (list cont (qnode id)))]
+ [(null? (cdr callargs))
+ (make-node '##core#call '(#t) (list cont (first callargs))) ]
+ [(or (fourth classargs) (eq? number-type 'fixnum))
+ (make-node
+ '##core#call '(#t)
+ (list
+ cont
+ (fold-inner
+ (lambda (x y)
+ (make-node '##core#inline (list fixop) (list x y)) )
+ callargs) ) ) ]
+ [else #f] ) ) ) )
+
+ ;; (<op> ...) -> (##core#inline <iop> <arg1> ... (quote <x>) <argN>)
+ ((20) ; classargs = (<argc> <iop> <x> <safe>)
+ (let ([n (length callargs)])
+ (and (or (fourth classargs) unsafe)
+ inline-substitutions-enabled
+ (= n (first classargs))
+ (intrinsic? name)
+ (make-node
+ '##core#call '(#t)
+ (list cont
+ (make-node
+ '##core#inline (list (second classargs))
+ (let-values ([(head tail) (split-at callargs (sub1 n))])
+ (append head
+ (list (qnode (third classargs)))
+ tail) ) ) ) ) ) ) )
+
+ ;; (<op>) -> <id>
+ ;; (<op> <x>) -> <x>
+ ;; (<op> <x1> ...) -> (##core#inline_allocate (<genop> <words>) <x1> (##core#inline_allocate (<genop> <words>) ...))
+ ;; (<op> <x1> ...) -> (##core#inline <[u]fixop> <x1> (##core#inline <[u]fixop> ...)) [fixnum-mode (perhaps unsafe)]
+ ;; - Remove "<id>" from arguments.
+ ((21) ; classargs = (<id> <fixop> <ufixop> <genop> <words>)
+ (and inline-substitutions-enabled
+ (intrinsic? name)
+ (let* ([id (first classargs)]
+ [words (fifth classargs)]
+ [genop (fourth classargs)]
+ [fixop (if unsafe (third classargs) (second classargs))]
+ [callargs
+ (remove
+ (lambda (x)
+ (and (eq? 'quote (node-class x))
+ (eq? id (first (node-parameters x))) ) )
+ callargs) ] )
+ (cond [(null? callargs) (make-node '##core#call '(#t) (list cont (qnode id)))]
+ [(null? (cdr callargs))
+ (make-node '##core#call '(#t) (list cont (first callargs))) ]
+ [else
+ (make-node
+ '##core#call '(#t)
+ (list
+ cont
+ (fold-inner
+ (lambda (x y)
+ (if (eq? number-type 'fixnum)
+ (make-node '##core#inline (list fixop) (list x y))
+ (make-node '##core#inline_allocate (list genop words) (list x y)) ) )
+ callargs) ) ) ] ) ) ) )
+
+ ;; (<alloc-op> ...) -> (##core#inline_allocate (<aiop> <words>) ...)
+ ;; (<alloc-op> ...) -> (##core#inline <fxop> ...) [fixnum mode]
+ ((22) ; classargs = (<argc> <aiop> <safe> <words> <fxop>)
+ (let ([argc (first classargs)]
+ [rargc (length callargs)]
+ [w (fourth classargs)] )
+ (and inline-substitutions-enabled
+ (= rargc argc)
+ (intrinsic? name)
+ (or (third classargs) unsafe)
+ (make-node
+ '##core#call '(#t)
+ (list cont
+ (if (eq? number-type 'fixnum)
+ (make-node
+ '##core#inline
+ (list (fifth classargs))
+ callargs)
+ (make-node
+ '##core#inline_allocate
+ (list (second classargs) w)
+ callargs) ) ) ) ) ) )
+
+ ;; (<op> <arg1> ... <argN>) -> (<primitiveop> ...)
+ ;; (<op> <arg1> ... <argN-I> <defargN-I>) -> (<primitiveop> ...)
+ ;; - default args in classargs should be either symbol or (optionally)
+ ;; quoted literal
+ ((23) ; classargs = (<minargc> <primitiveop> <literal1>|<varable1> ...)
+ (and inline-substitutions-enabled
+ (intrinsic? name)
+ (let ([argc (first classargs)])
+ (and (>= (length callargs) (first classargs))
+ (make-node
+ '##core#call (list #t (second classargs))
+ (cons*
+ (varnode (second classargs))
+ cont
+ (let-values (((req opt) (split-at callargs argc)))
+ (append
+ req
+ (let loop ((ca opt)
+ (da (cddr classargs)) )
+ (cond ((null? ca)
+ (if (null? da)
+ '()
+ (cons (defarg (car da)) (loop '() (cdr da))) ) )
+ ((null? da) '())
+ (else (cons (car ca) (loop (cdr ca) (cdr da))))))))))))))
+
+ (else (bomb "bad type (optimize)")) ) )
+
+
+;;; Optimize direct leaf routines:
+
+(define (transform-direct-lambdas! node db)
+ (let ([dirty #f]
+ [inner-ks '()]
+ [hoistable '()]
+ [allocated 0] )
+
+ ;; Process node tree and walk lambdas that meet the following constraints:
+ ;; - Only external lambdas (no CPS redexes),
+ ;; - All calls are either to the direct continuation or (tail-) recursive calls.
+ ;; - No allocation, no rest parameter.
+ ;; - The lambda has a known container variable and all it's call-sites are known.
+
+ (define (walk d n dn)
+ (let ([params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case (node-class n)
+ [(##core#lambda)
+ (let ([llist (third params)])
+ (if (and d
+ (second params)
+ (not (get db d 'unknown))
+ (proper-list? llist)
+ (and-let* ([val (get db d 'value)]
+ [refs (get-list db d 'references)]
+ [sites (get-list db d 'call-sites)] )
+ (and (eq? n val)
+ (= (length refs) (length sites))
+ (scan (first subs) (first llist) d dn (cons d llist)) ) ) )
+ (transform n d inner-ks hoistable dn allocated)
+ (walk #f (first subs) #f) ) ) ]
+ [(set!) (walk (first params) (first subs) #f)]
+ [(let)
+ (walk (first params) (first subs) n)
+ (walk #f (second subs) #f) ]
+ [else (for-each (lambda (x) (walk #f x #f)) subs)] ) ) )
+
+ (define (scan n kvar fnvar destn env)
+ (let ([closures '()]
+ [recursive #f] )
+ (define (rec n v vn e)
+ (let ([params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case (node-class n)
+ [(##core#variable)
+ (let ([v (first params)])
+ (or (not (get db v 'boxed))
+ (not (memq v env))
+ (and (not recursive)
+ (begin
+ (set! allocated (+ allocated 2))
+ #t) ) ) ) ]
+ [(##core#lambda)
+ (and v
+ (decompose-lambda-list
+ (third params)
+ (lambda (vars argc rest)
+ (set! closures (cons v closures))
+ (rec (first subs) #f #f (append vars e)) ) ) ) ]
+ [(##core#inline_allocate)
+ (and (not recursive)
+ (begin
+ (set! allocated (+ allocated (second params)))
+ (every (lambda (x) (rec x #f #f e)) subs) ) ) ]
+ [(##core#direct_lambda)
+ (and vn destn
+ (null? (scan-used-variables (first subs) e))
+ (begin
+ (set! hoistable (alist-cons v vn hoistable))
+ #t) ) ]
+ [(##core#inline_ref)
+ (and (let ([n (estimate-foreign-result-size (second params))])
+ (or (zero? n)
+ (and (not recursive)
+ (begin
+ (set! allocated (+ allocated n))
+ #t) ) ) )
+ (every (lambda (x) (rec x #f #f e)) subs) ) ]
+ [(##core#inline_loc_ref)
+ (and (let ([n (estimate-foreign-result-size (first params))])
+ (or (zero? n)
+ (and (not recursive)
+ (begin
+ (set! allocated (+ allocated n))
+ #t) ) ) )
+ (every (lambda (x) (rec x #f #f e)) subs) ) ]
+ [(##core#call)
+ (let ([fn (first subs)])
+ (and (eq? '##core#variable (node-class fn))
+ (let ([v (first (node-parameters fn))])
+ (cond [(eq? v fnvar)
+ (and (zero? allocated)
+ (let ([k (second subs)])
+ (when (eq? '##core#variable (node-class k))
+ (set! inner-ks (cons (first (node-parameters k)) inner-ks)) )
+ (set! recursive #t)
+ #t) ) ]
+ [else (eq? v kvar)] ) )
+ (every (lambda (x) (rec x #f #f e)) (cdr subs)) ) ) ]
+ [(##core#direct_call)
+ (let ([n (fourth params)])
+ (or (zero? n)
+ (and (not recursive)
+ (begin
+ (set! allocated (+ allocated n))
+ (every (lambda (x) (rec x #f #f e)) subs) ) ) ) ) ]
+ [(set!) (rec (first subs) (first params) #f e)]
+ [(let)
+ (and (rec (first subs) (first params) n e)
+ (rec (second subs) #f #f (append params e)) ) ]
+ [else (every (lambda (x) (rec x #f #f e)) subs)] ) ) )
+ (set! inner-ks '())
+ (set! hoistable '())
+ (set! allocated 0)
+ (and (rec n #f #f env)
+ (lset= eq? closures (delete kvar inner-ks eq?)) ) ) )
+
+ (define (transform n fnvar ks hoistable destn allocated)
+ (if (pair? hoistable)
+ (debugging 'o "direct leaf routine with hoistable closures/allocation" fnvar (delay (unzip1 hoistable)) allocated)
+ (debugging 'o "direct leaf routine/allocation" fnvar allocated) )
+ (set! dirty #t)
+ (let* ([params (node-parameters n)]
+ [argc (length (third params))]
+ [klambdas '()]
+ [sites (or (get db fnvar 'call-sites) '())]
+ [ksites '()] )
+ (if (and (list? params) (= (length params) 4) (list? (caddr params)))
+ (let ((id (car params))
+ (kvar (caaddr params))
+ (vars (cdaddr params)) )
+ ;; Remove continuation argument:
+ (set-car! (cddr params) vars)
+ ;; Make "##core#direct_lambda":
+ (node-class-set! n '##core#direct_lambda)
+ ;; Transform recursive calls and remove unused continuations:
+
+ (let rec ([n (first (node-subexpressions n))])
+ (let ([params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case (node-class n)
+ [(##core#call)
+ (let* ([fn (first subs)]
+ [arg0 (second subs)]
+ [fnp (node-parameters fn)]
+ [arg0p (node-parameters arg0)] )
+ (when (eq? '##core#variable (node-class fn))
+ (cond [(eq? fnvar (first fnp))
+ (set! ksites (alist-cons #f n ksites))
+ (cond [(eq? kvar (first arg0p))
+ (unless (= argc (length (cdr subs)))
+ (quit
+ "known procedure called recursively with wrong number of arguments: `~A'"
+ fnvar) )
+ (node-class-set! n '##core#recurse)
+ (node-parameters-set! n (list #t id))
+ (node-subexpressions-set! n (cddr subs)) ]
+ [(assq (first arg0p) klambdas)
+ => (lambda (a)
+ (let* ([klam (cdr a)]
+ [kbody (first (node-subexpressions klam))] )
+ (unless (= argc (length (cdr subs)))
+ (quit
+ "known procedure called recursively with wrong number of arguments: `~A'"
+ fnvar) )
+ (node-class-set! n 'let)
+ (node-parameters-set! n (take (third (node-parameters klam)) 1))
+ (node-subexpressions-set!
+ n
+ (list (make-node '##core#recurse (list #f id) (cddr subs)) kbody) )
+ (rec kbody) ) ) ]
+ [else (bomb "missing kvar" arg0p)] ) ]
+ [(eq? kvar (first fnp))
+ (node-class-set! n '##core#return)
+ (node-parameters-set! n '())
+ (node-subexpressions-set! n (cdr subs)) ]
+ [else (bomb "bad call (leaf)")] ) ) ) ]
+ [(let)
+ (let ([var (first params)]
+ [val (first subs)] )
+ (cond [(memq var ks)
+ (set! klambdas (alist-cons var val klambdas))
+ (copy-node! (second subs) n)
+ (rec n) ]
+ [else (for-each rec subs)] ) ) ]
+
+ [else (for-each rec subs)] ) ) )
+
+ ;; Transform call-sites:
+ (for-each
+ (lambda (site)
+ (let* ([n (cdr site)]
+ [nsubs (node-subexpressions n)] )
+ (unless (= argc (length (cdr nsubs)))
+ (quit
+ "known procedure called with wrong number of arguments: `~A'"
+ fnvar) )
+ (node-subexpressions-set!
+ n
+ (list (second nsubs)
+ (make-node
+ '##core#direct_call
+ (list #t #f id allocated)
+ (cons (car nsubs) (cddr nsubs)) ) ) ) ) )
+ (lset-difference (lambda (s1 s2) (eq? (cdr s1) (cdr s2))) sites ksites) )
+
+ ;; Hoist direct lambdas out of container:
+ (when (and destn (pair? hoistable))
+ (let ([destn0 (make-node #f #f #f)])
+ (copy-node! destn destn0) ; get copy of container binding
+ (let ([hoisted
+ (fold-right ; build cascade of bindings for each hoistable direct lambda...
+ (lambda (h rest)
+ (make-node
+ 'let (list (car h))
+ (let ([dlam (first (node-subexpressions (cdr h)))])
+ (list (make-node (node-class dlam) (node-parameters dlam) (node-subexpressions dlam))
+ rest) ) ) )
+ destn0
+ hoistable) ] )
+ (copy-node! hoisted destn) ; mutate container binding to hold hoistable bindings
+ (for-each
+ (lambda (h) ; change old direct lambdas bindings to dummy ones...
+ (let ([vn (cdr h)])
+ (node-parameters-set! vn (list (gensym)))
+ (set-car! (node-subexpressions vn) (make-node '##core#undefined '() '())) ) )
+ hoistable) ) ) ) )
+ (bomb "invalid parameter list" params))))
+
+ (debugging 'p "direct leaf routine optimization pass...")
+ (walk #f node #f)
+ dirty) )
+
+
+;;; Lambda lift:
+;
+; - Find lambda-liftable local procedures and lift them to toplevel.
+; - Pass free variables as extra parameters, including the free variables of
+; other lifted procedures. This implies that lifted procedures that call each
+; other have to be in the same scope.
+; - Declare the lifted procedures (effectively) as bound-to-procedure and block-global.
+
+(define (perform-lambda-lifting! node db)
+ (let ([lambda-values '()]
+ [eliminated '()] )
+
+ (define (find-lifting-candidates)
+ ;; Collect potentially liftable procedures and return as a list of (<name> . <value>) pairs:
+ ;; - Also build a-list that maps lambda-nodes to names.
+ (let ([cs '()])
+ (##sys#hash-table-for-each
+ (lambda (sym plist)
+ (and-let* ([val (assq 'value plist)]
+ [refs (assq 'references plist)]
+ [css (assq 'call-sites plist)]
+ [nrefs (length (cdr refs))] )
+ (when (and (not (assq 'unknown plist))
+ (eq? 'lambda (node-class (cdr val)))
+ (not (assq 'global plist))
+ #;(> nrefs 1)
+ (= nrefs (length (cdr css))) )
+ (set! lambda-values (alist-cons (cdr val) sym lambda-values))
+ (set! cs (alist-cons sym (cdr val) cs)) ) ) )
+ db)
+ cs) )
+
+ (define (build-call-graph cs)
+ ;; Build call-graph of the form ((<name> (<free1> ...) <called1> ...) ...):
+ (let ([g '()]
+ [free '()]
+ [called '()] )
+
+ (define (walk n env)
+ (let ([class (node-class n)]
+ [params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case class
+ [(##core#variable set!)
+ (let ([var (first params)])
+ (unless (or (memq var env) (get db var 'global))
+ (set! free (cons var free)) )
+ (when (assq var cs) (set! called (cons var called)))
+ (for-each (lambda (n) (walk n env)) subs) ) ]
+ [(let)
+ (let loop ([vars params] [vals subs])
+ (if (null? vars)
+ (walk (car vals) (append params env))
+ (let ([var (car vars)])
+ (walk (car vals) env)
+ (loop (cdr vars) (cdr vals)) ) ) ) ]
+ [(lambda)
+ (decompose-lambda-list
+ (first params)
+ (lambda (vars argc rest) (walk (first subs) (append vars env))) ) ]
+ [else (for-each (lambda (n) (walk n env)) subs)] ) ) )
+
+ (for-each
+ (lambda (cs)
+ (let* ([here (car cs)]
+ [lval (cdr cs)]
+ [llist (car (node-parameters lval))] )
+ (set! free '())
+ (set! called '())
+ (decompose-lambda-list
+ llist
+ (lambda (vars arg rest)
+ (walk (car (node-subexpressions lval)) vars) ) )
+ (set! g (alist-cons here (cons free called) g)) ) )
+ cs)
+ g) )
+
+ (define (eliminate cs graph)
+ ;; Eliminate all liftables that have free variables that are assigned to (and are not liftable),
+ ;; or that have more than N free variables (including free variables of called liftables):
+ (remove
+ (lambda (gn)
+ (or (> (count-free-variables (car gn) graph) maximal-number-of-free-variables-for-liftable)
+ (any (lambda (v)
+ (and (get db v 'assigned)
+ (not (assq v cs)) ) )
+ (second gn) ) ) )
+ graph) )
+
+ (define (count-free-variables name graph)
+ (let ([gnames (unzip1 graph)])
+ (let count ([n name] [walked '()])
+ (let* ([a (assq n graph)]
+ [cs (lset-difference eq? (cddr a) walked gnames)]
+ [f (length (delete-duplicates (second a) eq?))]
+ [w2 (cons n (append cs walked))] )
+ (fold + f (map (lambda (c) (count c w2)) cs)) ) ) ) )
+
+ (define (collect-accessibles graph)
+ ;; Collect accessible variables for each liftable into list of the form (<name> <accessible1> ...):
+ (let ([al '()])
+ (let walk ([n node] [vars '()])
+ (let ([class (node-class n)]
+ [params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case class
+ [(##core#variable quote ##core#undefined ##core#primitive ##core#proc) #f]
+ [(let)
+ (let loop ([vars2 params] [vals subs])
+ (if (null? vars2)
+ (walk (car vals) (append params vars))
+ (begin
+ (walk (car vals) vars)
+ (loop (cdr vars2) (cdr vals)) ) ) ) ]
+ [(lambda)
+ (let ([lval (assq n lambda-values)])
+ (when lval
+ (let ([name (cdr lval)])
+ (when (assq name graph)
+ (set! al (alist-cons (cdr lval) vars al))) ) ) )
+ (decompose-lambda-list
+ (first params)
+ (lambda (vars2 argc rest)
+ (walk (car subs) (append vars2 vars)) ) ) ]
+ [else
+ (for-each (lambda (n) (walk n vars)) subs) ] ) ) )
+ al) )
+
+ (define (eliminate2 graph al)
+ ;; Eliminate liftables that have call-sites without access to all free variables;
+ (remove
+ (lambda (gn)
+ (let* ([name (first gn)]
+ [free (second gn)] )
+ (any (lambda (gn2)
+ (and (memq name (cddr gn2)) ; callee?
+ (lset<= eq? (cdr (assq (car gn2) al)) free) ) )
+ graph) ) )
+ graph) )
+
+ (define (eliminate3 graph)
+ ;; Eliminate liftables that call other eliminated liftables:
+ ;; - repeat until nothing changes.
+ (let loop ([graph graph] [n (length graph)])
+ (let* ([g2 (filter (lambda (gn) (every (lambda (n) (assq n graph)) (cddr gn))) graph)]
+ [n2 (length g2)] )
+ (if (= n n2)
+ g2
+ (loop g2 n2) ) ) ) )
+
+ (define (eliminate4 graph)
+ ;; Eliminate liftables that have unknown call-sites which do not have access to
+ ;; any of the free variables of all callees:
+ (let walk ([n node] [vars '()])
+ (let ([class (node-class n)]
+ [params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case class
+ [(##core#variable quote ##core#undefined ##core#primitive ##core#proc) #f]
+ [(let)
+ (let loop ([vars2 params] [vals subs])
+ (if (null? vars2)
+ (walk (car vals) (append params vars))
+ (begin
+ (walk (car vals) vars)
+ (loop (cdr vars2) (cdr vals)) ) ) ) ]
+ [(lambda)
+ (decompose-lambda-list
+ (first params)
+ (lambda (vars2 argc rest)
+ (walk (car subs) (append vars2 vars)) ) ) ]
+ [(##core#call)
+ (let ([fn (first subs)])
+ (call-with-current-continuation
+ (lambda (return)
+ (when (eq? '##core#variable (node-class fn))
+ (let ([done '()])
+ (let loop ([name (first (node-parameters fn))])
+ (unless (memq name done)
+ (set! done (cons name done))
+ (let ([gn (assq name graph)])
+ (when gn
+ (unless (lset<= eq? (second gn) vars)
+ #;(print "*** " (first (node-parameters fn)) " | " name ": " vars " / " (second gn))
+ (set! graph (delete! gn graph eq?))
+ (return #f) )
+ (for-each loop (cddr gn)) ) ) ) ) ) ) ) )
+ (for-each (lambda (n) (walk n vars)) subs) ) ]
+ [else (for-each (lambda (n) (walk n vars)) subs)] ) ) )
+ graph)
+
+ (define (compute-extra-variables graph)
+ ;; Gather variables that have to be passed additionally:
+ ;; - do not pass variables that are defined inside the body of a liftable.
+ (define (defined n)
+ (let ([defd '()])
+ (let walk ([n n])
+ (let ([class (node-class n)]
+ [params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case class
+ [(let)
+ (set! defd (append params defd))
+ (for-each walk subs) ]
+ [(lambda)
+ (decompose-lambda-list
+ (first params)
+ (lambda (vars argc rest)
+ (set! defd (append vars defd))
+ (walk (first subs)) ) ) ]
+ [else (for-each walk subs)] ) ) )
+ defd) )
+ (let ([extras (map (lambda (gn) (cons (first gn) (second gn))) graph)]
+ [walked '()] )
+ (define (walk gn)
+ (let ([name (car gn)])
+ ;; Hm. To handle liftables that are called recursively (but indirect) I use this kludge. Is it safe?
+ (unless (> (count (cut eq? name <>) walked) 1)
+ (set! walked (cons name walked))
+ (let ([callees (cddr gn)])
+ (for-each (lambda (c) (walk (assq c graph))) callees)
+ (let ([f (assq name extras)])
+ (set-cdr! f (append (cdr f) (concatenate (map (lambda (n2) (cdr (assq n2 extras))) callees)))) ) ) ) ) )
+ (for-each walk graph)
+ (map (lambda (xt)
+ (let* ([name (car xt)]
+ [defd (defined (get db name 'value))] )
+ (cons name
+ (remove
+ (lambda (v)
+ (or (assq v graph)
+ (memq v defd) ) )
+ (delete-duplicates (cdr xt) eq?)) ) ) )
+ extras) ) )
+
+ (define (reconstruct! graph extra)
+ ;; Reconstruct node tree by adding global definitions:
+ (node-subexpressions-set!
+ node
+ (list
+ (fold-right
+ (lambda (gn body)
+ (let* ([name (car gn)]
+ [lval (get db name 'value)] )
+ (hide-variable name)
+ (decompose-lambda-list
+ (first (node-parameters lval))
+ (lambda (vars argc rest)
+ (let* ([xvars (cdr (assq name extra))]
+ [xaliases (map gensym xvars)]
+ [xmap (map cons xvars xaliases)] )
+ (rename-extra-variables! (first (node-subexpressions lval)) xmap)
+ (make-node
+ 'let (list (gensym 't))
+ (list (make-node
+ 'set! (list name)
+ (list
+ (make-node
+ 'lambda
+ (list (build-lambda-list (append xaliases vars) (+ argc (length xvars)) rest))
+ (node-subexpressions lval) ) ) )
+ body) ) ) ) ) ) )
+ (first (node-subexpressions node))
+ graph) ) ) )
+
+ (define (rename-extra-variables! node xmap)
+ ;; Rename variables from a given map:
+ (define (rename v)
+ (let ([a (assq v xmap)])
+ (if a (cdr a) v) ) )
+ (let walk ([n node])
+ (let ([class (node-class n)]
+ [params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case class
+ [(let)
+ (node-parameters-set! n (map rename params))
+ (for-each walk subs) ]
+ [(##core#variable)
+ (node-parameters-set! n (list (rename (first params)))) ]
+ [(set!)
+ (node-parameters-set! n (list (rename (first params))))
+ (for-each walk subs) ]
+ [(lambda)
+ (decompose-lambda-list
+ (first params)
+ (lambda (vars argc rest)
+ (set-car! params (build-lambda-list (map rename vars) argc rest))
+ (walk (first subs)) ) ) ]
+ [else (for-each walk subs)] ) ) ) )
+
+ (define (extend-call-sites! extra)
+ ;; Change call sites by adding extra variables:
+ (let walk ([n node])
+ (let ([class (node-class n)]
+ [params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case class
+ [(##core#call)
+ (let ([fn (first subs)])
+ (when (eq? '##core#variable (node-class fn))
+ (let ([a (assq (first (node-parameters fn)) extra)])
+ (when a
+ (set-car! params #t)
+ (node-subexpressions-set!
+ n
+ (cons fn (append (map varnode (cdr a)) (cdr subs))) ) ) ) )
+ (for-each walk (node-subexpressions n)) ) ]
+ [else (for-each walk subs)] ) ) ) )
+
+ (define (remove-local-bindings! graph)
+ ;; Remove local definitions of lifted procedures:
+ (let walk ([n node])
+ (let ([class (node-class n)]
+ [params (node-parameters n)]
+ [subs (node-subexpressions n)] )
+ (case class
+ [(let)
+ (for-each walk (node-subexpressions n))
+ (let ([vars2 '()]
+ [vals2 '()] )
+ (do ([vars params (cdr vars)]
+ [vals subs (cdr vals)] )
+ ((null? vars)
+ (cond [(null? vars2) (copy-node! (car vals) n)]
+ [else
+ (node-parameters-set! n (reverse vars2))
+ (node-subexpressions-set! n (append (reverse vals2) vals)) ] ) )
+ (unless (assq (car vars) graph)
+ (set! vars2 (cons (car vars) vars2))
+ (set! vals2 (cons (car vals) vals2)) ) ) ) ]
+ [(set!)
+ (for-each walk (node-subexpressions n))
+ (when (assq (first params) graph)
+ (node-class-set! n '##core#undefined)
+ (node-parameters-set! n '())
+ (node-subexpressions-set! n '()) ) ]
+ [else (for-each walk subs)] ) ) ) )
+
+ (debugging 'p "gathering liftables...")
+ (let ([cs (find-lifting-candidates)])
+ (debugging 'p "building call graph...")
+ (let ([g (build-call-graph cs)])
+ (debugging 'p "eliminating non-liftables...")
+ (let ([g2 (eliminate cs g)])
+ (when (debugging 'l "call-graph:") (pretty-print g2))
+ (debugging 'p "computing access-lists...")
+ (let ([al (collect-accessibles g2)])
+ (when (debugging 'l "accessibles:") (pretty-print al))
+ (debugging 'p "eliminating liftables by access-lists and non-liftable callees...")
+ (let ([ls (eliminate3 (eliminate4 g2))]) ;(eliminate2 g2 al)))]) - why isn't this used?
+ (debugging 'o "liftable local procedures" (delay (unzip1 ls)))
+ (debugging 'p "gathering extra parameters...")
+ (let ([extra (compute-extra-variables ls)])
+ (when (debugging 'l "additional parameters:") (pretty-print extra))
+ (debugging 'p "changing call sites...")
+ (extend-call-sites! extra)
+ (debugging 'p "removing local bindings...")
+ (remove-local-bindings! ls)
+ (debugging 'p "moving liftables to toplevel...")
+ (reconstruct! ls extra) ) ) ) ) ) ) ) )
diff --git a/patches/finalizer-closures.diff b/patches/finalizer-closures.diff
new file mode 100644
index 00000000..f209c0a5
--- /dev/null
+++ b/patches/finalizer-closures.diff
@@ -0,0 +1,55 @@
+Index: runtime.c
+===================================================================
+--- runtime.c (Revision 12825)
++++ runtime.c (Revision 12869)
+@@ -2701,10 +2701,15 @@
+ /* Mark collectibles: */
+ for(msp = collectibles; msp < collectibles_top; ++msp)
+ if(*msp != NULL) mark(*msp);
+-
++
++ /* mark GC roots: */
+ for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next)
+ mark(&gcrp->value);
+
++ /* mark finalizer procedures: */
++ for(flist = finalizer_list; flist != NULL; flist = flist->next)
++ mark(&flist->finalizer);
++
+ mark_system_globals();
+ }
+ else {
+@@ -2769,7 +2774,6 @@
+
+ for(flist = finalizer_list; flist != NULL; flist = flist->next) {
+ mark(&flist->item);
+- mark(&flist->finalizer);
+ ++fcount;
+ }
+
+@@ -2786,7 +2790,6 @@
+ }
+
+ mark(&flist->item);
+- mark(&flist->finalizer);
+ }
+ }
+
+@@ -2794,7 +2797,7 @@
+ finalizers_checked = 1;
+
+ if(pending_finalizer_count > 0 && gc_report_flag)
+- C_printf(C_text("[GC] finalizers pending for rescan:\t %d (%d live)\n"),
++ C_printf(C_text("[GC] finalizers pending: %d (%d live)\n"),
+ pending_finalizer_count, live_finalizer_count);
+
+ goto rescan;
+@@ -2803,7 +2806,7 @@
+ /* Copy finalized items with remembered indices into `##sys#pending-finalizers'
+ (and release finalizer node): */
+ if(pending_finalizer_count > 0) {
+- if(gc_report_flag) C_printf(C_text("[GC] queueing %d finalizers\n"), pending_finalizer_count);
++ if(gc_report_flag) C_printf(C_text("[GC] finalizers queued: %d\n"), pending_finalizer_count);
+
+ last = C_block_item(pending_finalizers_symbol, 0);
+ assert(C_u_i_car(last) == C_fix(0));
diff --git a/patches/finalizer-exceptions.diff b/patches/finalizer-exceptions.diff
new file mode 100644
index 00000000..ef07c8b7
--- /dev/null
+++ b/patches/finalizer-exceptions.diff
@@ -0,0 +1,26 @@
+Index: library.scm
+===================================================================
+@@ -4250,6 +4257,7 @@
+ (define ##sys#run-pending-finalizers
+ (let ([vector-fill! vector-fill!]
+ [print print]
++ [with-exception-handler with-exception-handler]
+ [working #f] )
+ (lambda (state)
+ (unless working
+@@ -4262,8 +4270,13 @@
+ (do ([i 0 (fx+ i 1)])
+ ((fx>= i c))
+ (let ([i2 (fx+ 1 (fx* i 2))])
+- ((##sys#slot ##sys#pending-finalizers (fx+ i2 1))
+- (##sys#slot ##sys#pending-finalizers i2)) ) )
++ (##sys#call-with-current-continuation
++ (lambda (ret)
++ (with-exception-handler
++ ret
++ (lambda ()
++ ((##sys#slot ##sys#pending-finalizers (fx+ i2 1))
++ (##sys#slot ##sys#pending-finalizers i2)))))) ) )
+ (vector-fill! ##sys#pending-finalizers (##core#undefined))
+ (##sys#setislot ##sys#pending-finalizers 0 0)
+ (set! working #f) ) )
diff --git a/patches/record-rename.diff b/patches/record-rename.diff
new file mode 100644
index 00000000..ce98e287
--- /dev/null
+++ b/patches/record-rename.diff
@@ -0,0 +1,54 @@
+Index: chicken-syntax.scm
+===================================================================
+--- chicken-syntax.scm (revision 13204)
++++ chicken-syntax.scm (working copy)
+@@ -46,8 +46,11 @@
+ (lambda (x r c)
+ (##sys#check-syntax 'define-record x '(_ symbol . #(symbol 0)))
+ (let* ((name (cadr x))
++ (prefix (symbol->string name))
++ (name (if (##sys#current-module)
++ (##sys#module-rename name (##sys#module-name (##sys#current-module)))
++ name))
+ (slots (cddr x))
+- (prefix (symbol->string name))
+ (setters (memq #:record-setters ##sys#features))
+ (%begin (r 'begin))
+ (%define (r 'define))
+@@ -807,11 +810,21 @@
+ 'define-record-printer (cons head body)
+ '((symbol symbol symbol) . #(_ 1)))
+ `(##sys#register-record-printer
+- ',(##sys#slot head 0)
++ ',(if (##sys#current-module)
++ (##sys#module-rename (##sys#slot head 0)
++ (##sys#module-name
++ (##sys#current-module)))
++ (##sys#slot head 0))
+ (,(r 'lambda) ,(##sys#slot head 1) ,@body)) ]
+ [else
+ (##sys#check-syntax 'define-record-printer (cons head body) '(symbol _))
+- `(##sys#register-record-printer ',head ,@body) ] ) ))))
++ `(##sys#register-record-printer
++ ',(if (##sys#current-module)
++ (##sys#module-rename head
++ (##sys#module-name
++ (##sys#current-module)))
++ head)
++ ,@body) ] ) ))))
+
+
+ ;;; Exceptions:
+@@ -874,7 +887,11 @@
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'define-record-type form '(_ variable #(variable 1) variable . _))
+- (let* ((t (cadr form))
++ (let* ((t (if (##sys#current-module)
++ (##sys#module-rename (cadr form)
++ (##sys#module-name
++ (##sys#current-module)))
++ (cadr form)))
+ (conser (caddr form))
+ (pred (cadddr form))
+ (slots (cddddr form))
diff --git a/ports.import.scm b/ports.import.scm
new file mode 100644
index 00000000..54d183c0
--- /dev/null
+++ b/ports.import.scm
@@ -0,0 +1,43 @@
+;;;; ports.import.scm - import library for "ports" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'ports
+ '(call-with-input-string
+ call-with-output-string
+ make-input-port
+ make-output-port
+ port-for-each
+ port-map
+ port-fold
+ make-broadcast-port
+ make-concatenated-port
+ with-error-output-to-port
+ with-input-from-port
+ with-input-from-string
+ with-output-to-port
+ with-output-to-string
+ with-error-output-to-port))
diff --git a/ports.scm b/ports.scm
new file mode 100644
index 00000000..60f05140
--- /dev/null
+++ b/ports.scm
@@ -0,0 +1,254 @@
+;;; ports.scm - Optional non-standard ports
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without
+; modification, are permitted provided that the following conditions
+; are met:
+;
+; Redistributions of source code must retain the above copyright
+; notice, this list of conditions and the following disclaimer.
+
+; 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.
+
+; Neither the name of the author nor the names of its contributors
+; may be used to endorse or promote products derived from this
+; software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+; OF THE POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit ports)
+; (uses data-structures)
+ (usual-integrations)
+ (disable-warning redef) )
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ (no-bound-checks)
+ (no-procedure-checks-for-usual-bindings)
+ (bound-to-procedure
+ ##sys#check-char ##sys#check-exact ##sys#check-port ##sys#check-string
+ ##sys#substring ##sys#for-each ##sys#map ##sys#setslot
+ ##sys#allocate-vector ##sys#check-pair ##sys#error-not-a-proper-list
+ ##sys#member ##sys#assoc ##sys#error ##sys#signal-hook ##sys#read-string!
+ ##sys#check-symbol ##sys#check-vector ##sys#floor ##sys#ceiling
+ ##sys#truncate ##sys#round ##sys#check-number ##sys#cons-flonum
+ ##sys#flonum-fraction ##sys#make-port ##sys#fetch-and-check-port-arg
+ ##sys#print ##sys#check-structure ##sys#make-structure make-parameter
+ ##sys#flush-output ##sys#write-char-0 ##sys#number->string
+ ##sys#fragments->string ##sys#symbol->qualified-string
+ ##sys#number? ##sys#procedure->string
+ ##sys#pointer->string ##sys#user-print-hook ##sys#peek-char-0
+ ##sys#read-char-0 ##sys#write-char ##sys#string-append ##sys#gcd ##sys#lcm
+ ##sys#fudge ##sys#check-list ##sys#user-read-hook ##sys#check-closure ##sys#check-inexact
+ input-port? make-vector list->vector open-output-string floor
+ get-output-string current-output-port display write port? list->string
+ call-with-input-string with-input-from-string
+ make-string string newline char-name read
+ open-input-string call-with-input-file reverse ) ) ] )
+
+(include "unsafe-declarations.scm")
+
+(register-feature! 'ports)
+
+
+;;;; Port-mapping (found in Gauche):
+
+(define (port-for-each fn thunk)
+ (let loop ()
+ (let ((x (thunk)))
+ (unless (eof-object? x)
+ (fn x)
+ (loop) ) ) ) )
+
+(define port-map
+ (let ((reverse reverse))
+ (lambda (fn thunk)
+ (let loop ((xs '()))
+ (let ((x (thunk)))
+ (if (eof-object? x)
+ (reverse xs)
+ (loop (cons (fn x) xs))))))))
+
+(define (port-fold fn acc thunk)
+ (let loop ([acc acc])
+ (let ([x (thunk)])
+ (if (eof-object? x)
+ acc
+ (loop (fn x acc))) ) ) )
+
+;;;; funky-ports
+
+(define (make-broadcast-port . ports)
+ (make-output-port
+ (lambda (s) (for-each (cut write-string s #f <>) ports))
+ noop
+ (lambda () (for-each flush-output ports)) ) )
+
+(define (make-concatenated-port p1 . ports)
+ (let ((ports (cons p1 ports)))
+ (make-input-port
+ (lambda ()
+ (let loop ()
+ (if (null? ports)
+ #!eof
+ (let ((c (read-char (car ports))))
+ (cond ((eof-object? c)
+ (set! ports (cdr ports))
+ (loop) )
+ (else c) ) ) ) ) )
+ (lambda ()
+ (and (not (null? ports))
+ (char-ready? (car ports))))
+ noop
+ (lambda ()
+ (let loop ()
+ (if (null? ports)
+ #!eof
+ (let ((c (peek-char (car ports))))
+ (cond ((eof-object? c)
+ (set! ports (cdr ports))
+ (loop) )
+ (else c))))))
+ (lambda (p n dest start)
+ (let loop ((n n) (c 0))
+ (cond ((null? ports) c)
+ ((fx<= n 0) c)
+ (else
+ (let ((m (read-string! n dest (car ports) (fx+ start c))))
+ (when (fx< m n)
+ (set! ports (cdr ports)) )
+ (loop (fx- n m) (fx+ c m))))))))))
+
+
+;;; Redirect standard ports:
+
+(define (with-input-from-port port thunk)
+ (##sys#check-port port 'with-input-from-port)
+ (fluid-let ([##sys#standard-input port])
+ (thunk) ) )
+
+(define (with-output-to-port port thunk)
+ (##sys#check-port port 'with-output-from-port)
+ (fluid-let ([##sys#standard-output port])
+ (thunk) ) )
+
+(define (with-error-output-to-port port thunk)
+ (##sys#check-port port 'with-error-output-from-port)
+ (fluid-let ([##sys#standard-error port])
+ (thunk) ) )
+
+;;; Extended string-port operations:
+
+(define call-with-input-string
+ (let ([open-input-string open-input-string])
+ (lambda (str proc)
+ (let ((in (open-input-string str)))
+ (proc in) ) ) ) )
+
+(define call-with-output-string
+ (let ((open-output-string open-output-string)
+ (get-output-string get-output-string) )
+ (lambda (proc)
+ (let ((out (open-output-string)))
+ (proc out)
+ (get-output-string out) ) ) ) )
+
+(define with-input-from-string
+ (let ((open-input-string open-input-string))
+ (lambda (str thunk)
+ (fluid-let ([##sys#standard-input (open-input-string str)])
+ (thunk) ) ) ) )
+
+(define with-output-to-string
+ (let ([open-output-string open-output-string]
+ [get-output-string get-output-string] )
+ (lambda (thunk)
+ (fluid-let ([##sys#standard-output (open-output-string)])
+ (thunk)
+ (get-output-string ##sys#standard-output) ) ) ) )
+
+
+;;; Custom ports:
+;
+; - Port-slots:
+;
+; 10: last
+
+(define make-input-port
+ (lambda (read ready? close #!optional peek read-string read-line)
+ (let* ((class
+ (vector
+ (lambda (p) ; read-char
+ (let ([last (##sys#slot p 10)])
+ (cond [peek (read)]
+ [last
+ (##sys#setislot p 10 #f)
+ last]
+ [else (read)] ) ) )
+ (lambda (p) ; peek-char
+ (let ([last (##sys#slot p 10)])
+ (cond [peek (peek)]
+ [last last]
+ [else
+ (let ([last (read)])
+ (##sys#setslot p 10 last)
+ last) ] ) ) )
+ #f ; write-char
+ #f ; write-string
+ (lambda (p) ; close
+ (close)
+ (##sys#setislot p 8 #t) )
+ #f ; flush-output
+ (lambda (p) ; char-ready?
+ (ready?) )
+ read-string ; read-string!
+ read-line) ) ; read-line
+ (data (vector #f))
+ (port (##sys#make-port #t class "(custom)" 'custom)) )
+ (##sys#set-port-data! port data)
+ port) ) )
+
+(define make-output-port
+ (let ([string string])
+ (lambda (write close #!optional flush)
+ (let* ((class
+ (vector
+ #f ; read-char
+ #f ; peek-char
+ (lambda (p c) ; write-char
+ (write (string c)) )
+ (lambda (p s) ; write-string
+ (write s) )
+ (lambda (p) ; close
+ (close)
+ (##sys#setislot p 8 #t) )
+ (lambda (p) ; flush-output
+ (when flush (flush)) )
+ #f ; char-ready?
+ #f ; read-string!
+ #f) ) ; read-line
+ (data (vector #f))
+ (port (##sys#make-port #f class "(custom)" 'custom)) )
+ (##sys#set-port-data! port data)
+ port) ) ) )
diff --git a/posix.import.scm b/posix.import.scm
new file mode 100644
index 00000000..b66a7dff
--- /dev/null
+++ b/posix.import.scm
@@ -0,0 +1,265 @@
+;;;; posix.import.scm - import library for "posix" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'posix
+ '(_exit
+ call-with-input-pipe
+ call-with-output-pipe
+ canonical-path ; DEPRECATED
+ change-directory
+ change-file-mode
+ change-file-owner
+ close-input-pipe
+ close-output-pipe
+ create-directory
+ create-fifo
+ create-pipe
+ create-session
+ create-symbolic-link
+ current-directory
+ current-effective-group-id
+ current-effective-user-id
+ current-effective-user-name
+ current-environment ; DEPRECATED
+ get-environment-variables
+ current-group-id
+ current-process-id
+ current-user-id
+ current-user-name
+ delete-directory
+ directory
+ directory?
+ duplicate-fileno
+ errno/2big
+ errno/acces
+ errno/again
+ errno/badf
+ errno/busy
+ errno/child
+ errno/deadlk
+ errno/dom
+ errno/exist
+ errno/fault
+ errno/fbig
+ errno/ilseq
+ errno/intr
+ errno/inval
+ errno/io
+ errno/isdir
+ errno/mfile
+ errno/mlink
+ errno/nametoolong
+ errno/nfile
+ errno/nodev
+ errno/noent
+ errno/noexec
+ errno/nolck
+ errno/nomem
+ errno/nospc
+ errno/nosys
+ errno/notdir
+ errno/notempty
+ errno/notty
+ errno/nxio
+ errno/perm
+ errno/pipe
+ errno/range
+ errno/rofs
+ errno/spipe
+ errno/srch
+ errno/wouldblock
+ errno/xdev
+ fcntl/dupfd
+ fcntl/getfd
+ fcntl/getfl
+ fcntl/setfd
+ fcntl/setfl
+ fifo?
+ file-access-time
+ file-change-time
+ file-close
+ file-control
+ file-execute-access?
+ file-link
+ file-lock
+ file-lock/blocking
+ file-mkstemp
+ file-modification-time
+ file-open
+ file-owner
+ file-permissions
+ file-position
+ set-file-position!
+ file-read
+ file-read-access?
+ file-select
+ file-size
+ file-stat
+ file-test-lock
+ file-truncate
+ file-unlock
+ file-write
+ file-write-access?
+ fileno/stderr
+ fileno/stdin
+ fileno/stdout
+ find-files
+ get-groups
+ get-host-name
+ glob
+ group-information
+ initialize-groups
+ local-time->seconds
+ local-timezone-abbreviation
+ map-file-to-memory
+ map/anonymous
+ map/file
+ map/fixed
+ map/private
+ map/shared
+ memory-mapped-file-pointer
+ memory-mapped-file?
+ open-input-file*
+ open-input-pipe
+ open-output-file*
+ open-output-pipe
+ open/append
+ open/binary
+ open/creat
+ open/excl
+ open/fsync
+ open/noctty
+ open/nonblock
+ open/rdonly
+ open/rdwr
+ open/read
+ open/sync
+ open/text
+ open/trunc
+ open/write
+ open/wronly
+ parent-process-id
+ perm/irgrp
+ perm/iroth
+ perm/irusr
+ perm/irwxg
+ perm/irwxo
+ perm/irwxu
+ perm/isgid
+ perm/isuid
+ perm/isvtx
+ perm/iwgrp
+ perm/iwoth
+ perm/iwusr
+ perm/ixgrp
+ perm/ixoth
+ perm/ixusr
+ pipe/buf
+ port->fileno
+ process
+ process*
+ process-execute
+ process-fork
+ process-group-id
+ process-run
+ process-signal
+ process-wait
+ prot/exec
+ prot/none
+ prot/read
+ prot/write
+ read-symbolic-link
+ regular-file?
+ seconds->local-time
+ seconds->string
+ seconds->utc-time
+ seek/cur
+ seek/end
+ seek/set
+ set-alarm!
+ set-buffering-mode!
+ set-groups!
+ set-root-directory!
+ set-signal-handler!
+ set-signal-mask!
+ setenv
+ signal-handler
+ signal-mask
+ signal-mask!
+ signal-masked?
+ signal-unmask!
+ signal/abrt
+ signal/alrm
+ signal/chld
+ signal/cont
+ signal/fpe
+ signal/hup
+ signal/ill
+ signal/int
+ signal/io
+ signal/kill
+ signal/pipe
+ signal/prof
+ signal/quit
+ signal/segv
+ signal/stop
+ signal/term
+ signal/trap
+ signal/tstp
+ signal/urg
+ signal/usr1
+ signal/usr2
+ signal/vtalrm
+ signal/winch
+ signal/xcpu
+ signal/xfsz
+ signals-list
+ sleep
+ stat-block-device? ; DEPRECATED
+ block-device?
+ character-device?
+ stat-char-device? ; DEPRECATED
+ stat-directory? ; DEPRECATED
+ stat-fifo? ; DEPRECATED
+ fifo?
+ stat-regular? ; DEPRECATED
+ stat-socket? ; DEPRECATED
+ socket?
+ stat-symlink? ; DEPRECATED
+ string->time
+ symbolic-link?
+ system-information
+ terminal-name
+ terminal-port?
+ terminal-size
+ time->string
+ unmap-file-from-memory
+ unsetenv
+ user-information
+ utc-time->seconds
+ with-input-from-pipe
+ with-output-to-pipe))
\ No newline at end of file
diff --git a/posixunix.scm b/posixunix.scm
new file mode 100644
index 00000000..87e37882
--- /dev/null
+++ b/posixunix.scm
@@ -0,0 +1,2395 @@
+;;;; posixunix.scm - Miscellaneous file- and process-handling routines
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit posix)
+ (uses scheduler regex extras utils files ports)
+ (disable-interrupts)
+ (usual-integrations)
+ (hide ##sys#stat group-member _get-groups _ensure-groups posix-error
+ ##sys#terminal-check
+ check-time-vector)
+ (not inline ##sys#interrupt-hook ##sys#user-interrupt-hook)
+ (foreign-declare #<<EOF
+#include <signal.h>
+#include <errno.h>
+#include <math.h>
+
+static int C_not_implemented(void);
+int C_not_implemented() { return -1; }
+
+static C_TLS int C_wait_status;
+
+#include <unistd.h>
+#include <sys/types.h>
+#include <sys/time.h>
+#include <sys/wait.h>
+#include <sys/utsname.h>
+#include <sys/stat.h>
+#include <sys/ioctl.h>
+#include <fcntl.h>
+#include <dirent.h>
+#include <pwd.h>
+
+#if defined(__sun__) && defined(__svr4__)
+# include <sys/tty.h>
+#endif
+
+#ifdef HAVE_GRP_H
+#include <grp.h>
+#endif
+
+#include <sys/mman.h>
+#include <time.h>
+
+#ifndef O_FSYNC
+# define O_FSYNC O_SYNC
+#endif
+
+#ifndef PIPE_BUF
+# ifdef __CYGWIN__
+# define PIPE_BUF _POSIX_PIPE_BUF
+# else
+# define PIPE_BUF 1024
+# endif
+#endif
+
+#ifndef O_BINARY
+# define O_BINARY 0
+#endif
+#ifndef O_TEXT
+# define O_TEXT 0
+#endif
+
+#ifndef ARG_MAX
+# define ARG_MAX 256
+#endif
+
+#ifndef MAP_FILE
+# define MAP_FILE 0
+#endif
+
+#ifndef MAP_ANON
+# define MAP_ANON 0
+#endif
+
+#if defined(HAVE_CRT_EXTERNS_H)
+# include <crt_externs.h>
+# define C_getenventry(i) ((*_NSGetEnviron())[ i ])
+#elif defined(C_MACOSX)
+# define C_getenventry(i) NULL
+#else
+extern char **environ;
+# define C_getenventry(i) (environ[ i ])
+#endif
+
+#ifndef ENV_MAX
+# define ENV_MAX 1024
+#endif
+
+#ifndef FILENAME_MAX
+# define FILENAME_MAX 1024
+#endif
+
+static C_TLS char *C_exec_args[ ARG_MAX ];
+static C_TLS char *C_exec_env[ ENV_MAX ];
+static C_TLS struct utsname C_utsname;
+static C_TLS struct flock C_flock;
+static C_TLS DIR *temphandle;
+static C_TLS struct passwd *C_user;
+#ifdef HAVE_GRP_H
+static C_TLS struct group *C_group;
+#else
+static C_TLS struct {
+ char *gr_name, gr_passwd;
+ int gr_gid;
+ char *gr_mem[ 1 ];
+} C_group = { "", "", 0, { "" } };
+#endif
+static C_TLS int C_pipefds[ 2 ];
+static C_TLS time_t C_secs;
+static C_TLS struct tm C_tm;
+static C_TLS fd_set C_fd_sets[ 2 ];
+static C_TLS struct timeval C_timeval;
+static C_TLS char C_hostbuf[ 256 ];
+static C_TLS struct stat C_statbuf;
+
+#define C_mkdir(str) C_fix(mkdir(C_c_string(str), S_IRWXU | S_IRWXG | S_IRWXO))
+#define C_chdir(str) C_fix(chdir(C_c_string(str)))
+#define C_rmdir(str) C_fix(rmdir(C_c_string(str)))
+
+#define C_opendir(x,h) C_set_block_item(h, 0, (C_word) opendir(C_c_string(x)))
+#define C_closedir(h) (closedir((DIR *)C_block_item(h, 0)), C_SCHEME_UNDEFINED)
+#define C_readdir(h,e) C_set_block_item(e, 0, (C_word) readdir((DIR *)C_block_item(h, 0)))
+#define C_foundfile(e,b) (strcpy(C_c_string(b), ((struct dirent *) C_block_item(e, 0))->d_name), C_fix(strlen(((struct dirent *) C_block_item(e, 0))->d_name)))
+
+#define C_curdir(buf) (getcwd(C_c_string(buf), 256) ? C_fix(strlen(C_c_string(buf))) : C_SCHEME_FALSE)
+
+#define open_binary_input_pipe(a, n, name) C_mpointer(a, popen(C_c_string(name), "r"))
+#define open_text_input_pipe(a, n, name) open_binary_input_pipe(a, n, name)
+#define open_binary_output_pipe(a, n, name) C_mpointer(a, popen(C_c_string(name), "w"))
+#define open_text_output_pipe(a, n, name) open_binary_output_pipe(a, n, name)
+#define close_pipe(p) C_fix(pclose(C_port_file(p)))
+
+#define C_set_file_ptr(port, ptr) (C_set_block_item(port, 0, (C_block_item(ptr, 0))), C_SCHEME_UNDEFINED)
+
+#define C_fork fork
+#define C_waitpid(id, o) C_fix(waitpid(C_unfix(id), &C_wait_status, C_unfix(o)))
+#define C_getpid getpid
+#define C_getppid getppid
+#define C_kill(id, s) C_fix(kill(C_unfix(id), C_unfix(s)))
+#define C_getuid getuid
+#define C_getgid getgid
+#define C_geteuid geteuid
+#define C_getegid getegid
+#define C_chown(fn, u, g) C_fix(chown(C_data_pointer(fn), C_unfix(u), C_unfix(g)))
+#define C_chmod(fn, m) C_fix(chmod(C_data_pointer(fn), C_unfix(m)))
+#define C_setuid(id) C_fix(setuid(C_unfix(id)))
+#define C_setgid(id) C_fix(setgid(C_unfix(id)))
+#define C_seteuid(id) C_fix(seteuid(C_unfix(id)))
+#define C_setegid(id) C_fix(setegid(C_unfix(id)))
+#define C_setsid(dummy) C_fix(setsid())
+#define C_setpgid(x, y) C_fix(setpgid(C_unfix(x), C_unfix(y)))
+#define C_getpgid(x) C_fix(getpgid(C_unfix(x)))
+#define C_symlink(o, n) C_fix(symlink(C_data_pointer(o), C_data_pointer(n)))
+#define C_readlink(f, b) C_fix(readlink(C_data_pointer(f), C_data_pointer(b), FILENAME_MAX))
+#define C_getpwnam(n) C_mk_bool((C_user = getpwnam((char *)C_data_pointer(n))) != NULL)
+#define C_getpwuid(u) C_mk_bool((C_user = getpwuid(C_unfix(u))) != NULL)
+#ifdef HAVE_GRP_H
+#define C_getgrnam(n) C_mk_bool((C_group = getgrnam((char *)C_data_pointer(n))) != NULL)
+#define C_getgrgid(u) C_mk_bool((C_group = getgrgid(C_unfix(u))) != NULL)
+#else
+#define C_getgrnam(n) C_SCHEME_FALSE
+#define C_getgrgid(n) C_SCHEME_FALSE
+#endif
+#define C_pipe(d) C_fix(pipe(C_pipefds))
+#define C_truncate(f, n) C_fix(truncate((char *)C_data_pointer(f), C_num_to_int(n)))
+#define C_ftruncate(f, n) C_fix(ftruncate(C_unfix(f), C_num_to_int(n)))
+#define C_uname C_fix(uname(&C_utsname))
+#define C_fdopen(a, n, fd, m) C_mpointer(a, fdopen(C_unfix(fd), C_c_string(m)))
+#define C_C_fileno(p) C_fix(fileno(C_port_file(p)))
+#define C_dup(x) C_fix(dup(C_unfix(x)))
+#define C_dup2(x, y) C_fix(dup2(C_unfix(x), C_unfix(y)))
+#define C_alarm alarm
+#define C_setvbuf(p, m, s) C_fix(setvbuf(C_port_file(p), NULL, C_unfix(m), C_unfix(s)))
+#define C_access(fn, m) C_fix(access((char *)C_data_pointer(fn), C_unfix(m)))
+#define C_close(fd) C_fix(close(C_unfix(fd)))
+#define C_sleep sleep
+
+#define C_stat(fn) C_fix(stat((char *)C_data_pointer(fn), &C_statbuf))
+#define C_lstat(fn) C_fix(lstat((char *)C_data_pointer(fn), &C_statbuf))
+#define C_fstat(f) C_fix(fstat(C_unfix(f), &C_statbuf))
+
+#define C_islink ((C_statbuf.st_mode & S_IFMT) == S_IFLNK)
+#define C_isreg ((C_statbuf.st_mode & S_IFMT) == S_IFREG)
+#define C_isdir ((C_statbuf.st_mode & S_IFMT) == S_IFDIR)
+#define C_ischr ((C_statbuf.st_mode & S_IFMT) == S_IFCHR)
+#define C_isblk ((C_statbuf.st_mode & S_IFMT) == S_IFBLK)
+#define C_isfifo ((C_statbuf.st_mode & S_IFMT) == S_IFIFO)
+#ifdef S_IFSOCK
+#define C_issock ((C_statbuf.st_mode & S_IFMT) == S_IFSOCK)
+#else
+#define C_issock ((C_statbuf.st_mode & S_IFMT) == 0140000)
+#endif
+
+#ifdef C_GNU_ENV
+# define C_unsetenv(s) (unsetenv((char *)C_data_pointer(s)), C_SCHEME_TRUE)
+# define C_setenv(x, y) C_fix(setenv((char *)C_data_pointer(x), (char *)C_data_pointer(y), 1))
+#else
+# define C_unsetenv(s) C_fix(putenv((char *)C_data_pointer(s)))
+static C_word C_fcall C_setenv(C_word x, C_word y) {
+ char *sx = C_data_pointer(x),
+ *sy = C_data_pointer(y);
+ int n1 = C_strlen(sx), n2 = C_strlen(sy);
+ char *buf = (char *)C_malloc(n1 + n2 + 2);
+ if(buf == NULL) return(C_fix(0));
+ else {
+ C_strcpy(buf, sx);
+ buf[ n1 ] = '=';
+ C_strcpy(buf + n1 + 1, sy);
+ return(C_fix(putenv(buf)));
+ }
+}
+#endif
+
+static void C_fcall C_set_arg_string(char **where, int i, char *a, int len) {
+ char *ptr;
+ if(a != NULL) {
+ ptr = (char *)C_malloc(len + 1);
+ C_memcpy(ptr, a, len);
+ ptr[ len ] = '\0';
+ }
+ else ptr = NULL;
+ where[ i ] = ptr;
+}
+
+static void C_fcall C_free_arg_string(char **where) {
+ while((*where) != NULL) C_free(*(where++));
+}
+
+static void C_set_timeval(C_word num, struct timeval *tm)
+{
+ if((num & C_FIXNUM_BIT) != 0) {
+ tm->tv_sec = C_unfix(num);
+ tm->tv_usec = 0;
+ }
+ else {
+ double i;
+ tm->tv_usec = (int)(modf(C_flonum_magnitude(num), &i) * 1000000);
+ tm->tv_sec = (int)i;
+ }
+}
+
+#define C_set_exec_arg(i, a, len) C_set_arg_string(C_exec_args, i, a, len)
+#define C_free_exec_args() C_free_arg_string(C_exec_args)
+#define C_set_exec_env(i, a, len) C_set_arg_string(C_exec_env, i, a, len)
+#define C_free_exec_env() C_free_arg_string(C_exec_env)
+
+#define C_execvp(f) C_fix(execvp(C_data_pointer(f), C_exec_args))
+#define C_execve(f) C_fix(execve(C_data_pointer(f), C_exec_args, C_exec_env))
+
+#if defined(__FreeBSD__) || defined(C_MACOSX) || defined(__NetBSD__) || defined(__OpenBSD__) || defined(__sgi__) || defined(sgi) || defined(__DragonFly__) || defined(__SUNPRO_C)
+static C_TLS int C_uw;
+# define C_WIFEXITED(n) (C_uw = C_unfix(n), C_mk_bool(WIFEXITED(C_uw)))
+# define C_WIFSIGNALED(n) (C_uw = C_unfix(n), C_mk_bool(WIFSIGNALED(C_uw)))
+# define C_WIFSTOPPED(n) (C_uw = C_unfix(n), C_mk_bool(WIFSTOPPED(C_uw)))
+# define C_WEXITSTATUS(n) (C_uw = C_unfix(n), C_fix(WEXITSTATUS(C_uw)))
+# define C_WTERMSIG(n) (C_uw = C_unfix(n), C_fix(WTERMSIG(C_uw)))
+# define C_WSTOPSIG(n) (C_uw = C_unfix(n), C_fix(WSTOPSIG(C_uw)))
+#else
+# define C_WIFEXITED(n) C_mk_bool(WIFEXITED(C_unfix(n)))
+# define C_WIFSIGNALED(n) C_mk_bool(WIFSIGNALED(C_unfix(n)))
+# define C_WIFSTOPPED(n) C_mk_bool(WIFSTOPPED(C_unfix(n)))
+# define C_WEXITSTATUS(n) C_fix(WEXITSTATUS(C_unfix(n)))
+# define C_WTERMSIG(n) C_fix(WTERMSIG(C_unfix(n)))
+# define C_WSTOPSIG(n) C_fix(WSTOPSIG(C_unfix(n)))
+#endif
+
+#ifdef __CYGWIN__
+# define C_mkfifo(fn, m) C_fix(-1);
+#else
+# define C_mkfifo(fn, m) C_fix(mkfifo((char *)C_data_pointer(fn), C_unfix(m)))
+#endif
+
+#define C_flock_setup(t, s, n) (C_flock.l_type = C_unfix(t), C_flock.l_start = C_num_to_int(s), C_flock.l_whence = SEEK_SET, C_flock.l_len = C_num_to_int(n), C_SCHEME_UNDEFINED)
+#define C_flock_test(p) (fcntl(fileno(C_port_file(p)), F_GETLK, &C_flock) >= 0 ? (C_flock.l_type == F_UNLCK ? C_fix(0) : C_fix(C_flock.l_pid)) : C_SCHEME_FALSE)
+#define C_flock_lock(p) C_fix(fcntl(fileno(C_port_file(p)), F_SETLK, &C_flock))
+#define C_flock_lockw(p) C_fix(fcntl(fileno(C_port_file(p)), F_SETLKW, &C_flock))
+
+static C_TLS sigset_t C_sigset;
+#define C_sigemptyset(d) (sigemptyset(&C_sigset), C_SCHEME_UNDEFINED)
+#define C_sigaddset(s) (sigaddset(&C_sigset, C_unfix(s)), C_SCHEME_UNDEFINED)
+#define C_sigdelset(s) (sigdelset(&C_sigset, C_unfix(s)), C_SCHEME_UNDEFINED)
+#define C_sigismember(s) C_mk_bool(sigismember(&C_sigset, C_unfix(s)))
+#define C_sigprocmask_set(d) C_fix(sigprocmask(SIG_SETMASK, &C_sigset, NULL))
+#define C_sigprocmask_block(d) C_fix(sigprocmask(SIG_BLOCK, &C_sigset, NULL))
+#define C_sigprocmask_unblock(d) C_fix(sigprocmask(SIG_UNBLOCK, &C_sigset, NULL))
+
+#define C_open(fn, fl, m) C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m)))
+#define C_read(fd, b, n) C_fix(read(C_unfix(fd), C_data_pointer(b), C_unfix(n)))
+#define C_write(fd, b, n) C_fix(write(C_unfix(fd), C_data_pointer(b), C_unfix(n)))
+#define C_mkstemp(t) C_fix(mkstemp(C_c_string(t)))
+
+/* It is assumed that 'int' is-a 'long' */
+#define C_ftell(p) C_fix(ftell(C_port_file(p)))
+#define C_fseek(p, n, w) C_mk_nbool(fseek(C_port_file(p), C_num_to_int(n), C_unfix(w)))
+#define C_lseek(fd, o, w) C_fix(lseek(C_unfix(fd), C_unfix(o), C_unfix(w)))
+
+#define C_zero_fd_set(i) FD_ZERO(&C_fd_sets[ i ])
+#define C_set_fd_set(i, fd) FD_SET(fd, &C_fd_sets[ i ])
+#define C_test_fd_set(i, fd) FD_ISSET(fd, &C_fd_sets[ i ])
+#define C_C_select(m) C_fix(select(C_unfix(m), &C_fd_sets[ 0 ], &C_fd_sets[ 1 ], NULL, NULL))
+#define C_C_select_t(m, t) (C_set_timeval(t, &C_timeval), \
+ C_fix(select(C_unfix(m), &C_fd_sets[ 0 ], &C_fd_sets[ 1 ], NULL, &C_timeval)))
+
+#define C_ctime(n) (C_secs = (n), ctime(&C_secs))
+
+#if defined(__SVR4)
+/* Seen here: http://lists.samba.org/archive/samba-technical/2002-November/025571.html */
+
+static time_t timegm(struct tm *t)
+{
+ time_t tl, tb;
+ struct tm *tg;
+
+ tl = mktime (t);
+ if (tl == -1)
+ {
+ t->tm_hour--;
+ tl = mktime (t);
+ if (tl == -1)
+ return -1; /* can't deal with output from strptime */
+ tl += 3600;
+ }
+ tg = gmtime (&tl);
+ tg->tm_isdst = 0;
+ tb = mktime (tg);
+ if (tb == -1)
+ {
+ tg->tm_hour--;
+ tb = mktime (tg);
+ if (tb == -1)
+ return -1; /* can't deal with output from gmtime */
+ tb += 3600;
+ }
+ return (tl - (tb - tl));
+}
+#endif
+
+#define cpy_tmvec_to_tmstc08(ptm, v) \
+ (memset((ptm), 0, sizeof(struct tm)), \
+ (ptm)->tm_sec = C_unfix(C_block_item((v), 0)), \
+ (ptm)->tm_min = C_unfix(C_block_item((v), 1)), \
+ (ptm)->tm_hour = C_unfix(C_block_item((v), 2)), \
+ (ptm)->tm_mday = C_unfix(C_block_item((v), 3)), \
+ (ptm)->tm_mon = C_unfix(C_block_item((v), 4)), \
+ (ptm)->tm_year = C_unfix(C_block_item((v), 5)), \
+ (ptm)->tm_wday = C_unfix(C_block_item((v), 6)), \
+ (ptm)->tm_yday = C_unfix(C_block_item((v), 7)), \
+ (ptm)->tm_isdst = (C_block_item((v), 8) != C_SCHEME_FALSE))
+
+#define cpy_tmvec_to_tmstc9(ptm, v) \
+ (((struct tm *)ptm)->tm_gmtoff = C_unfix(C_block_item((v), 9)))
+
+#define cpy_tmstc08_to_tmvec(v, ptm) \
+ (C_set_block_item((v), 0, C_fix(((struct tm *)ptm)->tm_sec)), \
+ C_set_block_item((v), 1, C_fix((ptm)->tm_min)), \
+ C_set_block_item((v), 2, C_fix((ptm)->tm_hour)), \
+ C_set_block_item((v), 3, C_fix((ptm)->tm_mday)), \
+ C_set_block_item((v), 4, C_fix((ptm)->tm_mon)), \
+ C_set_block_item((v), 5, C_fix((ptm)->tm_year)), \
+ C_set_block_item((v), 6, C_fix((ptm)->tm_wday)), \
+ C_set_block_item((v), 7, C_fix((ptm)->tm_yday)), \
+ C_set_block_item((v), 8, ((ptm)->tm_isdst ? C_SCHEME_TRUE : C_SCHEME_FALSE)))
+
+#define cpy_tmstc9_to_tmvec(v, ptm) \
+ (C_set_block_item((v), 9, C_fix((ptm)->tm_gmtoff)))
+
+#define C_tm_set_08(v) cpy_tmvec_to_tmstc08( &C_tm, (v) )
+#define C_tm_set_9(v) cpy_tmvec_to_tmstc9( &C_tm, (v) )
+
+#define C_tm_get_08(v) cpy_tmstc08_to_tmvec( (v), &C_tm )
+#define C_tm_get_9(v) cpy_tmstc9_to_tmvec( (v), &C_tm )
+
+#if !defined(C_GNU_ENV) || defined(__CYGWIN__) || defined(__uClinux__)
+
+static struct tm *
+C_tm_set( C_word v )
+{
+ C_tm_set_08( v );
+ return &C_tm;
+}
+
+static C_word
+C_tm_get( C_word v )
+{
+ C_tm_get_08( v );
+ return v;
+}
+
+#else
+
+static struct tm *
+C_tm_set( C_word v )
+{
+ C_tm_set_08( v );
+ C_tm_set_9( v );
+ return &C_tm;
+}
+
+static C_word
+C_tm_get( C_word v )
+{
+ C_tm_get_08( v );
+ C_tm_get_9( v );
+ return v;
+}
+
+#endif
+
+#define C_asctime(v) (asctime(C_tm_set(v)))
+#define C_mktime(v) ((C_temporary_flonum = mktime(C_tm_set(v))) != -1)
+#define C_timegm(v) ((C_temporary_flonum = timegm(C_tm_set(v))) != -1)
+
+#define TIME_STRING_MAXLENGTH 255
+static char C_time_string [TIME_STRING_MAXLENGTH + 1];
+#undef TIME_STRING_MAXLENGTH
+
+#define C_strftime(v, f) \
+ (strftime(C_time_string, sizeof(C_time_string), C_c_string(f), C_tm_set(v)) ? C_time_string : NULL)
+
+#define C_strptime(s, f, v) \
+ (strptime(C_c_string(s), C_c_string(f), &C_tm) ? C_tm_get(v) : C_SCHEME_FALSE)
+
+static gid_t *C_groups = NULL;
+
+#define C_get_gid(n) C_fix(C_groups[ C_unfix(n) ])
+#define C_set_gid(n, id) (C_groups[ C_unfix(n) ] = C_unfix(id), C_SCHEME_UNDEFINED)
+#define C_set_groups(n) C_fix(setgroups(C_unfix(n), C_groups))
+
+#ifdef TIOCGWINSZ
+static int get_tty_size(int p, int *rows, int *cols)
+{
+ struct winsize tty_size;
+ int r;
+
+ memset(&tty_size, 0, sizeof tty_size);
+
+ r = ioctl(p, TIOCGWINSZ, &tty_size);
+ if (r == 0) {
+ *rows = tty_size.ws_row;
+ *cols = tty_size.ws_col;
+ }
+ return r;
+}
+#else
+static int get_tty_size(int p, int *rows, int *cols)
+{
+ *rows = *cols = 0;
+ return -1;
+}
+#endif
+
+EOF
+) )
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ (no-bound-checks)
+ (no-procedure-checks-for-usual-bindings)
+ (bound-to-procedure
+ string-match glob->regexp regexp
+ ##sys#thread-yield! ##sys#make-string
+ ##sys#make-port ##sys#file-info ##sys#update-errno ##sys#fudge ##sys#make-c-string ##sys#check-port
+ ##sys#error ##sys#signal-hook ##sys#peek-unsigned-integer make-pathname glob directory?
+ pathname-file process-fork file-close duplicate-fileno process-execute get-environment-variable
+ make-string make-input-port make-output-port ##sys#thread-block-for-i/o create-pipe
+ process-wait pathname-strip-directory pathname-directory ##sys#expand-home-path directory
+ decompose-pathname ##sys#cons-flonum ##sys#decode-seconds ##sys#null-pointer ##sys#pointer->address
+ ##sys#substring ##sys#context-switch close-input-pipe close-output-pipe change-directory
+ current-directory ##sys#make-pointer port? ##sys#schedule ##sys#process
+ ##sys#peek-fixnum ##sys#make-structure ##sys#check-structure ##sys#enable-interrupts
+ make-nonblocking-input-port make-nonblocking-output-port
+ canonical-path) ) ] )
+
+(include "unsafe-declarations.scm")
+
+(register-feature! 'posix)
+
+(define posix-error
+ (let ([strerror (foreign-lambda c-string "strerror" int)]
+ [string-append string-append] )
+ (lambda (type loc msg . args)
+ (let ([rn (##sys#update-errno)])
+ (apply ##sys#signal-hook type loc (string-append msg " - " (strerror rn)) args) ) ) ) )
+
+;; Faster versions of common operations
+
+(define ##sys#posix-error posix-error)
+
+(define ##sys#file-nonblocking!
+ (foreign-lambda* bool ([int fd])
+ "int val = fcntl(fd, F_GETFL, 0);"
+ "if(val == -1) return(0);"
+ "return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);" ) )
+
+(define ##sys#file-select-one
+ (foreign-lambda* int ([int fd])
+ "fd_set in;"
+ "struct timeval tm;"
+ "FD_ZERO(&in);"
+ "FD_SET(fd, &in);"
+ "tm.tv_sec = tm.tv_usec = 0;"
+ "if(select(fd + 1, &in, NULL, NULL, &tm) == -1) return(-1);"
+ "else return(FD_ISSET(fd, &in) ? 1 : 0);" ) )
+
+
+;;; Lo-level I/O:
+
+(define-foreign-variable _pipe_buf int "PIPE_BUF")
+
+(define pipe/buf _pipe_buf)
+
+(define-foreign-variable _f_dupfd int "F_DUPFD")
+(define-foreign-variable _f_getfd int "F_GETFD")
+(define-foreign-variable _f_setfd int "F_SETFD")
+(define-foreign-variable _f_getfl int "F_GETFL")
+(define-foreign-variable _f_setfl int "F_SETFL")
+
+(define fcntl/dupfd _f_dupfd)
+(define fcntl/getfd _f_getfd)
+(define fcntl/setfd _f_setfd)
+(define fcntl/getfl _f_getfl)
+(define fcntl/setfl _f_setfl)
+
+(define-foreign-variable _o_rdonly int "O_RDONLY")
+(define-foreign-variable _o_wronly int "O_WRONLY")
+(define-foreign-variable _o_rdwr int "O_RDWR")
+(define-foreign-variable _o_creat int "O_CREAT")
+(define-foreign-variable _o_append int "O_APPEND")
+(define-foreign-variable _o_excl int "O_EXCL")
+(define-foreign-variable _o_noctty int "O_NOCTTY")
+(define-foreign-variable _o_nonblock int "O_NONBLOCK")
+(define-foreign-variable _o_trunc int "O_TRUNC")
+(define-foreign-variable _o_fsync int "O_FSYNC")
+(define-foreign-variable _o_binary int "O_BINARY")
+(define-foreign-variable _o_text int "O_TEXT")
+
+(define open/rdonly _o_rdonly)
+(define open/wronly _o_wronly)
+(define open/rdwr _o_rdwr)
+(define open/read _o_rdonly)
+(define open/write _o_wronly)
+(define open/creat _o_creat)
+(define open/append _o_append)
+(define open/excl _o_excl)
+(define open/noctty _o_noctty)
+(define open/nonblock _o_nonblock)
+(define open/trunc _o_trunc)
+(define open/sync _o_fsync)
+(define open/fsync _o_fsync)
+(define open/binary _o_binary)
+(define open/text _o_text)
+
+(define-foreign-variable _s_irusr int "S_IRUSR")
+(define-foreign-variable _s_iwusr int "S_IWUSR")
+(define-foreign-variable _s_ixusr int "S_IXUSR")
+(define-foreign-variable _s_irgrp int "S_IRGRP")
+(define-foreign-variable _s_iwgrp int "S_IWGRP")
+(define-foreign-variable _s_ixgrp int "S_IXGRP")
+(define-foreign-variable _s_iroth int "S_IROTH")
+(define-foreign-variable _s_iwoth int "S_IWOTH")
+(define-foreign-variable _s_ixoth int "S_IXOTH")
+(define-foreign-variable _s_irwxu int "S_IRWXU")
+(define-foreign-variable _s_irwxg int "S_IRWXG")
+(define-foreign-variable _s_irwxo int "S_IRWXO")
+(define-foreign-variable _s_isuid int "S_ISUID")
+(define-foreign-variable _s_isgid int "S_ISGID")
+(define-foreign-variable _s_isvtx int "S_ISVTX")
+
+(define perm/irusr _s_irusr)
+(define perm/iwusr _s_iwusr)
+(define perm/ixusr _s_ixusr)
+(define perm/irgrp _s_irgrp)
+(define perm/iwgrp _s_iwgrp)
+(define perm/ixgrp _s_ixgrp)
+(define perm/iroth _s_iroth)
+(define perm/iwoth _s_iwoth)
+(define perm/ixoth _s_ixoth)
+(define perm/irwxu _s_irwxu)
+(define perm/irwxg _s_irwxg)
+(define perm/irwxo _s_irwxo)
+(define perm/isvtx _s_isvtx)
+(define perm/isuid _s_isuid)
+(define perm/isgid _s_isgid)
+
+(define file-control
+ (let ([fcntl (foreign-lambda int fcntl int int long)])
+ (lambda (fd cmd #!optional (arg 0))
+ (##sys#check-exact fd 'file-control)
+ (##sys#check-exact cmd 'file-control)
+ (let ([res (fcntl fd cmd arg)])
+ (if (fx= res -1)
+ (posix-error #:file-error 'file-control "cannot control file" fd cmd)
+ res ) ) ) ) )
+
+(define file-open
+ (let ([defmode (bitwise-ior _s_irwxu (bitwise-ior _s_irgrp _s_iroth))] )
+ (lambda (filename flags . mode)
+ (let ([mode (if (pair? mode) (car mode) defmode)])
+ (##sys#check-string filename 'file-open)
+ (##sys#check-exact flags 'file-open)
+ (##sys#check-exact mode 'file-open)
+ (let ([fd (##core#inline "C_open" (##sys#make-c-string (##sys#expand-home-path filename)) flags mode)])
+ (when (eq? -1 fd)
+ (posix-error #:file-error 'file-open "cannot open file" filename flags mode) )
+ fd) ) ) ) )
+
+(define file-close
+ (lambda (fd)
+ (##sys#check-exact fd 'file-close)
+ (when (fx< (##core#inline "C_close" fd) 0)
+ (posix-error #:file-error 'file-close "cannot close file" fd) ) ) )
+
+(define file-read
+ (let ([make-string make-string] )
+ (lambda (fd size . buffer)
+ (##sys#check-exact fd 'file-read)
+ (##sys#check-exact size 'file-read)
+ (let ([buf (if (pair? buffer) (car buffer) (make-string size))])
+ (unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))
+ (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or blob" buf) )
+ (let ([n (##core#inline "C_read" fd buf size)])
+ (when (eq? -1 n)
+ (posix-error #:file-error 'file-read "cannot read from file" fd size) )
+ (list buf n) ) ) ) ) )
+
+(define file-write
+ (lambda (fd buffer . size)
+ (##sys#check-exact fd 'file-write)
+ (unless (and (##core#inline "C_blockp" buffer) (##core#inline "C_byteblockp" buffer))
+ (##sys#signal-hook #:type-error 'file-write "bad argument type - not a string or blob" buffer) )
+ (let ([size (if (pair? size) (car size) (##sys#size buffer))])
+ (##sys#check-exact size 'file-write)
+ (let ([n (##core#inline "C_write" fd buffer size)])
+ (when (eq? -1 n)
+ (posix-error #:file-error 'file-write "cannot write to file" fd size) )
+ n) ) ) )
+
+(define file-mkstemp
+ (lambda (template)
+ (##sys#check-string template 'file-mkstemp)
+ (let* ([buf (##sys#make-c-string template)]
+ [fd (##core#inline "C_mkstemp" buf)]
+ [path-length (##sys#size buf)])
+ (when (eq? -1 fd)
+ (posix-error #:file-error 'file-mkstemp "cannot create temporary file" template) )
+ (values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) )
+
+
+;;; I/O multiplexing:
+
+(define file-select
+ (let ([fd_zero (foreign-lambda void "C_zero_fd_set" int)]
+ [fd_set (foreign-lambda void "C_set_fd_set" int int)]
+ [fd_test (foreign-lambda bool "C_test_fd_set" int int)] )
+ (lambda (fdsr fdsw . timeout)
+ (let ([fdmax 0]
+ [tm (if (pair? timeout) (car timeout) #f)] )
+ (fd_zero 0)
+ (fd_zero 1)
+ (cond [(not fdsr)]
+ [(fixnum? fdsr)
+ (set! fdmax fdsr)
+ (fd_set 0 fdsr) ]
+ [else
+ (##sys#check-list fdsr 'file-select)
+ (for-each
+ (lambda (fd)
+ (##sys#check-exact fd 'file-select)
+ (set! fdmax (##core#inline "C_i_fixnum_max" fdmax fd))
+ (fd_set 0 fd) )
+ fdsr) ] )
+ (cond [(not fdsw)]
+ [(fixnum? fdsw)
+ (set! fdmax fdsw)
+ (fd_set 1 fdsw) ]
+ [else
+ (##sys#check-list fdsw 'file-select)
+ (for-each
+ (lambda (fd)
+ (##sys#check-exact fd 'file-select)
+ (set! fdmax (##core#inline "C_i_fixnum_max" fdmax fd))
+ (fd_set 1 fd) )
+ fdsw) ] )
+ (let ([n (cond [tm
+ (##sys#check-number tm 'file-select)
+ (##core#inline "C_C_select_t" (fx+ fdmax 1) tm) ]
+ [else (##core#inline "C_C_select" (fx+ fdmax 1))] ) ] )
+ (cond [(fx< n 0)
+ (posix-error #:file-error 'file-select "failed" fdsr fdsw) ]
+ [(fx= n 0) (values (if (pair? fdsr) '() #f) (if (pair? fdsw) '() #f))]
+ [else
+ (values
+ (and fdsr
+ (if (fixnum? fdsr)
+ (fd_test 0 fdsr)
+ (let ([lstr '()])
+ (for-each (lambda (fd) (when (fd_test 0 fd) (set! lstr (cons fd lstr)))) fdsr)
+ lstr) ) )
+ (and fdsw
+ (if (fixnum? fdsw)
+ (fd_test 1 fdsw)
+ (let ([lstw '()])
+ (for-each (lambda (fd) (when (fd_test 1 fd) (set! lstw (cons fd lstw)))) fdsw)
+ lstw) ) ) ) ] ) ) ) ) ) )
+
+
+;;; File attribute access:
+
+(define-foreign-variable _seek_set int "SEEK_SET")
+(define-foreign-variable _seek_cur int "SEEK_CUR")
+(define-foreign-variable _seek_end int "SEEK_END")
+
+(define seek/set _seek_set)
+(define seek/end _seek_end)
+(define seek/cur _seek_cur)
+
+(define-foreign-variable _stat_st_ino unsigned-int "C_statbuf.st_ino")
+(define-foreign-variable _stat_st_nlink unsigned-int "C_statbuf.st_nlink")
+(define-foreign-variable _stat_st_gid unsigned-int "C_statbuf.st_gid")
+(define-foreign-variable _stat_st_size integer64 "C_statbuf.st_size")
+(define-foreign-variable _stat_st_mtime double "C_statbuf.st_mtime")
+(define-foreign-variable _stat_st_atime double "C_statbuf.st_atime")
+(define-foreign-variable _stat_st_ctime double "C_statbuf.st_ctime")
+(define-foreign-variable _stat_st_uid unsigned-int "C_statbuf.st_uid")
+(define-foreign-variable _stat_st_mode unsigned-int "C_statbuf.st_mode")
+(define-foreign-variable _stat_st_dev unsigned-int "C_statbuf.st_dev")
+(define-foreign-variable _stat_st_rdev unsigned-int "C_statbuf.st_rdev")
+(define-foreign-variable _stat_st_blksize unsigned-int "C_statbuf.st_blksize")
+(define-foreign-variable _stat_st_blocks unsigned-int "C_statbuf.st_blocks")
+
+(define (##sys#stat file link loc)
+ (let ([r (cond [(fixnum? file) (##core#inline "C_fstat" file)]
+ [(string? file)
+ (let ([path (##sys#make-c-string (##sys#expand-home-path file))])
+ (if link
+ (##core#inline "C_lstat" path)
+ (##core#inline "C_stat" path) ) ) ]
+ [else (##sys#signal-hook #:type-error "bad argument type - not a fixnum or string" file)] ) ] )
+ (when (fx< r 0)
+ (posix-error #:file-error loc "cannot access file" file) ) ) )
+
+(define (file-stat f . link)
+ (##sys#stat f (optional link #f) 'file-stat)
+ (vector _stat_st_ino _stat_st_mode _stat_st_nlink
+ _stat_st_uid _stat_st_gid _stat_st_size
+ _stat_st_atime _stat_st_ctime _stat_st_mtime
+ _stat_st_dev _stat_st_rdev
+ _stat_st_blksize _stat_st_blocks) )
+
+(define (file-size f) (##sys#stat f #f 'file-size) _stat_st_size)
+(define (file-modification-time f) (##sys#stat f #f 'file-modification-time) _stat_st_mtime)
+(define (file-access-time f) (##sys#stat f #f 'file-access-time) _stat_st_atime)
+(define (file-change-time f) (##sys#stat f #f 'file-change-time) _stat_st_ctime)
+(define (file-owner f) (##sys#stat f #f 'file-owner) _stat_st_uid)
+(define (file-permissions f) (##sys#stat f #f 'file-permissions) _stat_st_mode)
+
+(define (regular-file? fname)
+ (##sys#check-string fname 'regular-file?)
+ (##sys#stat fname #t 'regular-file?)
+ (foreign-value "C_isreg" bool) )
+
+(define (symbolic-link? fname)
+ (##sys#check-string fname 'symbolic-link?)
+ (##sys#stat fname #t 'symbolic-link?)
+ (foreign-value "C_islink" bool) )
+
+(define (stat-regular? fname) ; DEPRECATED
+ (##sys#check-string fname 'stat-regular?)
+ (##sys#stat fname #f 'stat-regular?)
+ (foreign-value "C_isreg" bool))
+
+(define (stat-directory? fname) ; DEPRECATED
+ (##sys#check-string fname 'stat-directory?)
+ (##sys#stat fname #f 'stat-directory?)
+ (foreign-value "C_isdir" bool))
+
+(define (character-device? fname)
+ (##sys#check-string fname 'character-device?)
+ (##sys#stat fname #f 'character-device?)
+ (foreign-value "C_ischr" bool))
+
+(define stat-char-device? character-device?) ; DEPRECATED
+
+(define (block-device? fname)
+ (##sys#check-string fname 'block-device?)
+ (##sys#stat fname #f 'block-device?)
+ (foreign-value "C_isblk" bool))
+
+(define stat-block-device? block-device?) ; DEPRECATED
+
+(define (fifo? fname)
+ (##sys#check-string fname 'stat-fifo?)
+ (##sys#stat fname #f 'stat-fifo?)
+ (foreign-value "C_isfifo" bool))
+
+(define stat-fifo? fifo?) ; DEPRECATED
+(define stat-symlink? symbolic-link?) ; DEPRECATED
+
+(define (socket? fname)
+ (##sys#check-string fname 'socket?)
+ (##sys#stat fname #f 'socket?)
+ (foreign-value "C_issock" bool))
+
+(define stat-socket? socket?) ; DEPRECATED
+
+(define set-file-position!
+ (lambda (port pos . whence)
+ (let ((whence (if (pair? whence) (car whence) _seek_set)))
+ (##sys#check-exact pos 'set-file-position!)
+ (##sys#check-exact whence 'set-file-position!)
+ (when (negative? pos)
+ (##sys#signal-hook #:bounds-error 'set-file-position! "invalid negative port position" pos port))
+ (unless (cond ((port? port)
+ (and (eq? (##sys#slot port 7) 'stream)
+ (##core#inline "C_fseek" port pos whence) ) )
+ ((fixnum? port)
+ (##core#inline "C_lseek" port pos whence))
+ (else
+ (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)) )
+ (posix-error #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )
+
+(define file-position
+ (getter-with-setter
+ (lambda (port)
+ (let ((pos (cond ((port? port)
+ (if (eq? (##sys#slot port 7) 'stream)
+ (##core#inline "C_ftell" port)
+ -1) )
+ ((fixnum? port)
+ (##core#inline "C_lseek" port 0 _seek_cur) )
+ (else
+ (##sys#signal-hook #:type-error 'file-position "invalid file" port)) ) ) )
+ (when (< pos 0)
+ (posix-error #:file-error 'file-position "cannot retrieve file position of port" port) )
+ pos) )
+ set-file-position!) ) ; doesn't accept WHENCE
+
+
+;;; Directory stuff:
+
+(define-inline (*directory? loc name)
+ (and (fx= 0 (##core#inline "C_stat" (##sys#make-c-string name)))
+ (foreign-value "C_isdir" bool) ) )
+
+(define-inline (*create-directory loc name)
+ (unless (fx= 0 (##core#inline "C_mkdir" (##sys#make-c-string name)))
+ (posix-error #:file-error loc "cannot create directory" name)) )
+
+(define create-directory
+ (let ((decompose-pathname decompose-pathname)
+ (pathname-directory pathname-directory) )
+ (lambda (name #!optional parents?)
+ (##sys#check-string name 'create-directory)
+ (let ((name (##sys#expand-home-path name)))
+ (unless (or (fx= 0 (##sys#size name)) (*directory? 'create-directory name))
+ (if parents?
+ (let loop ((dir (let-values (((dir file ext) (decompose-pathname name)))
+ (if file (make-pathname dir file ext) dir))))
+ (when (and dir (not (*directory? 'create-directory dir)))
+ (loop (pathname-directory dir))
+ (*create-directory 'create-directory dir)) )
+ (*create-directory 'create-directory name) ) ) ) ) ) )
+
+(define change-directory
+ (lambda (name)
+ (##sys#check-string name 'change-directory)
+ (unless (fx= 0 (##core#inline "C_chdir" (##sys#make-c-string (##sys#expand-home-path name))))
+ (posix-error #:file-error 'change-directory "cannot change current directory" name) ) ) )
+
+(define delete-directory
+ (lambda (name)
+ (##sys#check-string name 'delete-directory)
+ (unless (fx= 0 (##core#inline "C_rmdir" (##sys#make-c-string (##sys#expand-home-path name))))
+ (posix-error #:file-error 'delete-directory "cannot delete directory" name) ) ) )
+
+(define directory
+ (let ([string-ref string-ref]
+ [make-string make-string]
+ [string string] )
+ (lambda (#!optional (spec (current-directory)) show-dotfiles?)
+ (##sys#check-string spec 'directory)
+ (let ([buffer (make-string 256)]
+ [handle (##sys#make-pointer)]
+ [entry (##sys#make-pointer)] )
+ (##core#inline "C_opendir" (##sys#make-c-string (##sys#expand-home-path spec)) handle)
+ (if (##sys#null-pointer? handle)
+ (posix-error #:file-error 'directory "cannot open directory" spec)
+ (let loop ()
+ (##core#inline "C_readdir" handle entry)
+ (if (##sys#null-pointer? entry)
+ (begin
+ (##core#inline "C_closedir" handle)
+ '() )
+ (let* ([flen (##core#inline "C_foundfile" entry buffer)]
+ [file (##sys#substring buffer 0 flen)]
+ [char1 (string-ref file 0)]
+ [char2 (and (fx> flen 1) (string-ref file 1))] )
+ (if (and (eq? #\. char1)
+ (or (not char2)
+ (and (eq? #\. char2) (eq? 2 flen))
+ (not show-dotfiles?) ) )
+ (loop)
+ (cons file (loop)) ) ) ) ) ) ) ) ) )
+
+(define (directory? fname)
+ (##sys#check-string fname 'directory?)
+ (*directory? 'directory? (##sys#expand-home-path fname)) )
+
+(define current-directory
+ (let ([make-string make-string])
+ (lambda (#!optional dir)
+ (if dir
+ (change-directory dir)
+ (let* ([buffer (make-string 256)]
+ [len (##core#inline "C_curdir" buffer)] )
+ (if len
+ (##sys#substring buffer 0 len)
+ (posix-error #:file-error 'current-directory "cannot retrieve current directory") ) ) ) ) ) )
+
+(define canonical-path ; DEPRECATED
+ (let ((null? null?)
+ (char=? char=?)
+ (string=? string=?)
+ (alpha? char-alphabetic?)
+ (sref string-ref)
+ (ssplit (cut string-split <> "/\\"))
+ (sappend string-append)
+ (isperse (cut string-intersperse <> "/"))
+ (sep? (lambda (c) (or (char=? #\/ c) (char=? #\\ c))))
+ (get-environment-variable get-environment-variable)
+ (user current-user-name)
+ (cwd (let ((cw current-directory))
+ (lambda ()
+ (condition-case (cw)
+ (var () "/"))))))
+ (lambda (path)
+ (##sys#check-string path 'canonical-path)
+ (let ((p (cond ((fx= 0 (##sys#size path))
+ (sappend (cwd) "/"))
+ ((and (fx< (##sys#size path) 3)
+ (sep? (sref path 0)))
+ path)
+ ((fx= 1 (##sys#size path))
+ (sappend (cwd) "/" path))
+ ((and (char=? #\~ (sref path 0))
+ (sep? (sref path 1)))
+ (sappend
+ (or (get-environment-variable "HOME")
+ (sappend "/home/" (user)))
+ (##sys#substring path 1
+ (##sys#size path))))
+ ((fx= 2 (##sys#size path))
+ (sappend (cwd) "/" path))
+ ((and (alpha? (sref path 0))
+ (char=? #\: (sref path 1))
+ (sep? (sref path 2)))
+ (##sys#substring path 3 (##sys#size path)))
+ ((and (char=? #\/ (sref path 0))
+ (alpha? (sref path 1))
+ (char=? #\: (sref path 2)))
+ (##sys#substring path 3 (##sys#size path)))
+ ((sep? (sref path 0))
+ path)
+ (else
+ (sappend (cwd) "/" path)))))
+ (let loop ((l (ssplit p))
+ (r '()))
+ (if (null? l)
+ (if (null? r)
+ "/"
+ (if (sep? (sref p (- (##sys#size p) 1)))
+ (sappend
+ "/"
+ (isperse (reverse (cons "" r))))
+ (sappend
+ "/"
+ (isperse (reverse r)))))
+ (loop
+ (cdr l)
+ (if (string=? ".." (car l))
+ (cdr r)
+ (if (string=? "." (car l))
+ r
+ (cons (car l) r))))))))))
+
+
+;;; Pipes:
+
+(let ()
+ (define (mode arg) (if (pair? arg) (##sys#slot arg 0) '###text))
+ (define (badmode m) (##sys#error "illegal input/output mode specifier" m))
+ (define (check loc cmd inp r)
+ (if (##sys#null-pointer? r)
+ (posix-error #:file-error loc "cannot open pipe" cmd)
+ (let ([port (##sys#make-port inp ##sys#stream-port-class "(pipe)" 'stream)])
+ (##core#inline "C_set_file_ptr" port r)
+ port) ) )
+ (set! open-input-pipe
+ (lambda (cmd . m)
+ (##sys#check-string cmd 'open-input-pipe)
+ (let ([m (mode m)])
+ (check
+ 'open-input-pipe
+ cmd #t
+ (case m
+ ((#:text) (##core#inline_allocate ("open_text_input_pipe" 2) (##sys#make-c-string cmd)))
+ ((#:binary) (##core#inline_allocate ("open_binary_input_pipe" 2) (##sys#make-c-string cmd)))
+ (else (badmode m)) ) ) ) ) )
+ (set! open-output-pipe
+ (lambda (cmd . m)
+ (##sys#check-string cmd 'open-output-pipe)
+ (let ((m (mode m)))
+ (check
+ 'open-output-pipe
+ cmd #f
+ (case m
+ ((#:text) (##core#inline_allocate ("open_text_output_pipe" 2) (##sys#make-c-string cmd)))
+ ((#:binary) (##core#inline_allocate ("open_binary_output_pipe" 2) (##sys#make-c-string cmd)))
+ (else (badmode m)) ) ) ) ) )
+ (set! close-input-pipe
+ (lambda (port)
+ (##sys#check-port port 'close-input-pipe)
+ (let ((r (##core#inline "close_pipe" port)))
+ (when (eq? -1 r) (posix-error #:file-error 'close-input/output-pipe "error while closing pipe" port))
+ r) ) )
+ (set! close-output-pipe close-input-pipe) )
+
+(let ([open-input-pipe open-input-pipe]
+ [open-output-pipe open-output-pipe]
+ [close-input-pipe close-input-pipe]
+ [close-output-pipe close-output-pipe] )
+ (set! call-with-input-pipe
+ (lambda (cmd proc . mode)
+ (let ([p (apply open-input-pipe cmd mode)])
+ (##sys#call-with-values
+ (lambda () (proc p))
+ (lambda results
+ (close-input-pipe p)
+ (apply values results) ) ) ) ) )
+ (set! call-with-output-pipe
+ (lambda (cmd proc . mode)
+ (let ([p (apply open-output-pipe cmd mode)])
+ (##sys#call-with-values
+ (lambda () (proc p))
+ (lambda results
+ (close-output-pipe p)
+ (apply values results) ) ) ) ) )
+ (set! with-input-from-pipe
+ (lambda (cmd thunk . mode)
+ (let ([old ##sys#standard-input]
+ [p (apply open-input-pipe cmd mode)] )
+ (set! ##sys#standard-input p)
+ (##sys#call-with-values thunk
+ (lambda results
+ (close-input-pipe p)
+ (set! ##sys#standard-input old)
+ (apply values results) ) ) ) ) )
+ (set! with-output-to-pipe
+ (lambda (cmd thunk . mode)
+ (let ([old ##sys#standard-output]
+ [p (apply open-output-pipe cmd mode)] )
+ (set! ##sys#standard-output p)
+ (##sys#call-with-values thunk
+ (lambda results
+ (close-output-pipe p)
+ (set! ##sys#standard-output old)
+ (apply values results) ) ) ) ) ) )
+
+(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")
+(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")
+
+(define create-pipe
+ (lambda ()
+ (when (fx< (##core#inline "C_pipe" #f) 0)
+ (posix-error #:file-error 'create-pipe "cannot create pipe") )
+ (values _pipefd0 _pipefd1) ) )
+
+
+;;; Signal processing:
+
+(define-foreign-variable _nsig int "NSIG")
+(define-foreign-variable _sigterm int "SIGTERM")
+(define-foreign-variable _sigkill int "SIGKILL")
+(define-foreign-variable _sigint int "SIGINT")
+(define-foreign-variable _sighup int "SIGHUP")
+(define-foreign-variable _sigfpe int "SIGFPE")
+(define-foreign-variable _sigill int "SIGILL")
+(define-foreign-variable _sigsegv int "SIGSEGV")
+(define-foreign-variable _sigabrt int "SIGABRT")
+(define-foreign-variable _sigtrap int "SIGTRAP")
+(define-foreign-variable _sigquit int "SIGQUIT")
+(define-foreign-variable _sigalrm int "SIGALRM")
+(define-foreign-variable _sigpipe int "SIGPIPE")
+(define-foreign-variable _sigusr1 int "SIGUSR1")
+(define-foreign-variable _sigusr2 int "SIGUSR2")
+(define-foreign-variable _sigvtalrm int "SIGVTALRM")
+(define-foreign-variable _sigprof int "SIGPROF")
+(define-foreign-variable _sigio int "SIGIO")
+(define-foreign-variable _sigurg int "SIGURG")
+(define-foreign-variable _sigchld int "SIGCHLD")
+(define-foreign-variable _sigcont int "SIGCONT")
+(define-foreign-variable _sigstop int "SIGSTOP")
+(define-foreign-variable _sigtstp int "SIGTSTP")
+(define-foreign-variable _sigxcpu int "SIGXCPU")
+(define-foreign-variable _sigxfsz int "SIGXFSZ")
+(define-foreign-variable _sigwinch int "SIGWINCH")
+
+(define signal/term _sigterm)
+(define signal/kill _sigkill)
+(define signal/int _sigint)
+(define signal/hup _sighup)
+(define signal/fpe _sigfpe)
+(define signal/ill _sigill)
+(define signal/segv _sigsegv)
+(define signal/abrt _sigabrt)
+(define signal/trap _sigtrap)
+(define signal/quit _sigquit)
+(define signal/alrm _sigalrm)
+(define signal/vtalrm _sigvtalrm)
+(define signal/prof _sigprof)
+(define signal/io _sigio)
+(define signal/urg _sigurg)
+(define signal/chld _sigchld)
+(define signal/cont _sigcont)
+(define signal/stop _sigstop)
+(define signal/tstp _sigtstp)
+(define signal/pipe _sigpipe)
+(define signal/xcpu _sigxcpu)
+(define signal/xfsz _sigxfsz)
+(define signal/usr1 _sigusr1)
+(define signal/usr2 _sigusr2)
+(define signal/winch _sigwinch)
+
+(define signals-list
+ (list
+ signal/term signal/kill signal/int signal/hup signal/fpe signal/ill
+ signal/segv signal/abrt signal/trap signal/quit signal/alrm signal/vtalrm
+ signal/prof signal/io signal/urg signal/chld signal/cont signal/stop
+ signal/tstp signal/pipe signal/xcpu signal/xfsz signal/usr1 signal/usr2
+ signal/winch))
+
+(let ([oldhook ##sys#interrupt-hook]
+ [sigvector (make-vector 256 #f)] )
+ (set! signal-handler
+ (lambda (sig)
+ (##sys#check-exact sig 'signal-handler)
+ (##sys#slot sigvector sig) ) )
+ (set! set-signal-handler!
+ (lambda (sig proc)
+ (##sys#check-exact sig 'set-signal-handler!)
+ (##core#inline "C_establish_signal_handler" sig (and proc sig))
+ (vector-set! sigvector sig proc) ) )
+ (set! ##sys#interrupt-hook
+ (lambda (reason state)
+ (let ([h (##sys#slot sigvector reason)])
+ (if h
+ (begin
+ (h reason)
+ (##sys#context-switch state) )
+ (oldhook reason state) ) ) ) ) )
+
+(define set-signal-mask!
+ (lambda (sigs)
+ (##sys#check-list sigs 'set-signal-mask!)
+ (##core#inline "C_sigemptyset" 0)
+ (for-each
+ (lambda (s)
+ (##sys#check-exact s 'set-signal-mask!)
+ (##core#inline "C_sigaddset" s) )
+ sigs)
+ (when (fx< (##core#inline "C_sigprocmask_set" 0) 0)
+ (posix-error #:process-error 'set-signal-mask! "cannot set signal mask") ) ) )
+
+(define (signal-mask)
+ (let loop ([sigs signals-list] [mask '()])
+ (if (null? sigs)
+ mask
+ (let ([sig (car sigs)])
+ (loop (cdr sigs) (if (##core#inline "C_sigismember" sig) (cons sig mask) mask)) ) ) ) )
+
+(define (signal-masked? sig)
+ (##sys#check-exact sig 'signal-masked?)
+ (##core#inline "C_sigismember" sig) )
+
+(define (signal-mask! sig)
+ (##sys#check-exact sig 'signal-mask!)
+ (##core#inline "C_sigaddset" sig)
+ (when (fx< (##core#inline "C_sigprocmask_block" 0) 0)
+ (posix-error #:process-error 'signal-mask! "cannot block signal") ) )
+
+(define (signal-unmask! sig)
+ (##sys#check-exact sig 'signal-unmask!)
+ (##core#inline "C_sigdelset" sig)
+ (when (fx< (##core#inline "C_sigprocmask_unblock" 0) 0)
+ (posix-error #:process-error 'signal-unmask! "cannot unblock signal") ) )
+
+;;; Set SIGINT handler:
+
+(set-signal-handler!
+ signal/int
+ (lambda (n) (##sys#user-interrupt-hook)) )
+
+
+;;; Getting system-, group- and user-information:
+
+(define-foreign-variable _uname int "C_uname")
+(define-foreign-variable _uname-sysname nonnull-c-string "C_utsname.sysname")
+(define-foreign-variable _uname-nodename nonnull-c-string "C_utsname.nodename")
+(define-foreign-variable _uname-release nonnull-c-string "C_utsname.release")
+(define-foreign-variable _uname-version nonnull-c-string "C_utsname.version")
+(define-foreign-variable _uname-machine nonnull-c-string "C_utsname.machine")
+
+(define system-information
+ (lambda ()
+ (when (fx< _uname 0)
+ (##sys#update-errno)
+ (##sys#error 'system-information "cannot retrieve system information") )
+ (list _uname-sysname
+ _uname-nodename
+ _uname-release
+ _uname-version
+ _uname-machine) ) )
+
+(define current-user-id
+ (getter-with-setter
+ (foreign-lambda int "C_getuid")
+ (lambda (id)
+ (when (fx< (##core#inline "C_setuid" id) 0)
+ (##sys#update-errno)
+ (##sys#error 'set-user-id! "cannot set user ID" id) ) ) ) )
+
+(define current-effective-user-id
+ (getter-with-setter
+ (foreign-lambda int "C_geteuid")
+ (lambda (id)
+ (when (fx< (##core#inline "C_seteuid" id) 0)
+ (##sys#update-errno)
+ (##sys#error
+ 'effective-user-id!-setter "cannot set effective user ID" id) ) ) ) )
+
+(define current-group-id
+ (getter-with-setter
+ (foreign-lambda int "C_getgid")
+ (lambda (id)
+ (when (fx< (##core#inline "C_setgid" id) 0)
+ (##sys#update-errno)
+ (##sys#error 'set-user-id! "cannot set group ID" id) ) ) ) )
+
+(define current-effective-group-id
+ (getter-with-setter
+ (foreign-lambda int "C_getegid")
+ (lambda (id)
+ (when (fx< (##core#inline "C_setegid" id) 0)
+ (##sys#update-errno)
+ (##sys#error
+ 'effective-group-id!-setter "cannot set effective group ID" id) ) ) ) )
+
+(define-foreign-variable _user-name nonnull-c-string "C_user->pw_name")
+(define-foreign-variable _user-passwd nonnull-c-string "C_user->pw_passwd")
+(define-foreign-variable _user-uid int "C_user->pw_uid")
+(define-foreign-variable _user-gid int "C_user->pw_gid")
+(define-foreign-variable _user-gecos nonnull-c-string "C_user->pw_gecos")
+(define-foreign-variable _user-dir c-string "C_user->pw_dir")
+(define-foreign-variable _user-shell c-string "C_user->pw_shell")
+
+(define (user-information user #!optional as-vector)
+ (let ([r (if (fixnum? user)
+ (##core#inline "C_getpwuid" user)
+ (begin
+ (##sys#check-string user 'user-information)
+ (##core#inline "C_getpwnam" (##sys#make-c-string user)) ) ) ] )
+ (and r
+ ((if as-vector vector list)
+ _user-name
+ _user-passwd
+ _user-uid
+ _user-gid
+ _user-gecos
+ _user-dir
+ _user-shell) ) ) )
+
+(define (current-user-name)
+ (list-ref (user-information (current-user-id)) 0) )
+
+(define (current-effective-user-name)
+ (list-ref (user-information (current-effective-user-id)) 0) )
+
+(define-foreign-variable _group-name nonnull-c-string "C_group->gr_name")
+(define-foreign-variable _group-passwd nonnull-c-string "C_group->gr_passwd")
+(define-foreign-variable _group-gid int "C_group->gr_gid")
+
+(define group-member
+ (foreign-lambda* c-string ([int i])
+ "return(C_group->gr_mem[ i ]);") )
+
+(define (group-information group #!optional as-vector)
+ (let ([r (if (fixnum? group)
+ (##core#inline "C_getgrgid" group)
+ (begin
+ (##sys#check-string group 'group-information)
+ (##core#inline "C_getgrnam" (##sys#make-c-string group)) ) ) ] )
+ (and r
+ ((if as-vector vector list)
+ _group-name
+ _group-passwd
+ _group-gid
+ (let loop ([i 0])
+ (let ([n (group-member i)])
+ (if n
+ (cons n (loop (fx+ i 1)))
+ '() ) ) ) ) ) ) )
+
+(define _get-groups
+ (foreign-lambda* int ([int n])
+ "return(getgroups(n, C_groups));") )
+
+(define _ensure-groups
+ (foreign-lambda* bool ([int n])
+ "if(C_groups != NULL) C_free(C_groups);"
+ "C_groups = (gid_t *)C_malloc(sizeof(gid_t) * n);"
+ "if(C_groups == NULL) return(0);"
+ "else return(1);") )
+
+(define (get-groups)
+ (let ([n (foreign-value "getgroups(0, C_groups)" int)])
+ (when (fx< n 0)
+ (##sys#update-errno)
+ (##sys#error 'get-groups "cannot retrieve supplementary group ids") )
+ (unless (_ensure-groups n)
+ (##sys#error 'get-groups "out of memory") )
+ (when (fx< (_get-groups n) 0)
+ (##sys#update-errno)
+ (##sys#error 'get-groups "cannot retrieve supplementary group ids") )
+ (let loop ([i 0])
+ (if (fx>= i n)
+ '()
+ (cons (##core#inline "C_get_gid" i) (loop (fx+ i 1))) ) ) ) )
+
+(define (set-groups! lst0)
+ (unless (_ensure-groups (length lst0))
+ (##sys#error 'set-groups! "out of memory") )
+ (do ([lst lst0 (##sys#slot lst 1)]
+ [i 0 (fx+ i 1)] )
+ ((null? lst)
+ (when (fx< (##core#inline "C_set_groups" i) 0)
+ (##sys#update-errno)
+ (##sys#error 'set-groups! "cannot set supplementary group ids" lst0) ) )
+ (let ([n (##sys#slot lst 0)])
+ (##sys#check-exact n 'set-groups!)
+ (##core#inline "C_set_gid" i n) ) ) )
+
+(define initialize-groups
+ (let ([init (foreign-lambda int "initgroups" c-string int)])
+ (lambda (user id)
+ (##sys#check-string user 'initialize-groups)
+ (##sys#check-exact id 'initialize-groups)
+ (when (fx< (init user id) 0)
+ (##sys#update-errno)
+ (##sys#error 'initialize-groups "cannot initialize supplementary group ids" user id) ) ) ) )
+
+
+;;; More errno codes:
+
+(define-foreign-variable _errno int "errno")
+
+(define-foreign-variable _eperm int "EPERM")
+(define-foreign-variable _enoent int "ENOENT")
+(define-foreign-variable _esrch int "ESRCH")
+(define-foreign-variable _eintr int "EINTR")
+(define-foreign-variable _eio int "EIO")
+(define-foreign-variable _efault int "EFAULT")
+(define-foreign-variable _echild int "ECHILD")
+(define-foreign-variable _enoexec int "ENOEXEC")
+(define-foreign-variable _ebadf int "EBADF")
+(define-foreign-variable _enomem int "ENOMEM")
+(define-foreign-variable _eacces int "EACCES")
+(define-foreign-variable _ebusy int "EBUSY")
+(define-foreign-variable _eexist int "EEXIST")
+(define-foreign-variable _enotdir int "ENOTDIR")
+(define-foreign-variable _eisdir int "EISDIR")
+(define-foreign-variable _einval int "EINVAL")
+(define-foreign-variable _emfile int "EMFILE")
+(define-foreign-variable _enospc int "ENOSPC")
+(define-foreign-variable _espipe int "ESPIPE")
+(define-foreign-variable _epipe int "EPIPE")
+(define-foreign-variable _eagain int "EAGAIN")
+(define-foreign-variable _erofs int "EROFS")
+(define-foreign-variable _ewouldblock int "EWOULDBLOCK")
+
+(define errno/perm _eperm)
+(define errno/noent _enoent)
+(define errno/srch _esrch)
+(define errno/intr _eintr)
+(define errno/io _eio)
+(define errno/noexec _enoexec)
+(define errno/badf _ebadf)
+(define errno/child _echild)
+(define errno/nomem _enomem)
+(define errno/acces _eacces)
+(define errno/fault _efault)
+(define errno/busy _ebusy)
+(define errno/notdir _enotdir)
+(define errno/isdir _eisdir)
+(define errno/inval _einval)
+(define errno/mfile _emfile)
+(define errno/nospc _enospc)
+(define errno/spipe _espipe)
+(define errno/pipe _epipe)
+(define errno/again _eagain)
+(define errno/rofs _erofs)
+(define errno/exist _eexist)
+(define errno/wouldblock _ewouldblock)
+
+(define errno/2big 0)
+(define errno/deadlk 0)
+(define errno/dom 0)
+(define errno/fbig 0)
+(define errno/ilseq 0)
+(define errno/mlink 0)
+(define errno/nametoolong 0)
+(define errno/nfile 0)
+(define errno/nodev 0)
+(define errno/nolck 0)
+(define errno/nosys 0)
+(define errno/notempty 0)
+(define errno/notty 0)
+(define errno/nxio 0)
+(define errno/range 0)
+(define errno/xdev 0)
+
+;;; Permissions and owners:
+
+(define change-file-mode
+ (lambda (fname m)
+ (##sys#check-string fname 'change-file-mode)
+ (##sys#check-exact m 'change-file-mode)
+ (when (fx< (##core#inline "C_chmod" (##sys#make-c-string (##sys#expand-home-path fname)) m) 0)
+ (posix-error #:file-error 'change-file-mode "cannot change file mode" fname m) ) ) )
+
+(define change-file-owner
+ (lambda (fn uid gid)
+ (##sys#check-string fn 'change-file-owner)
+ (##sys#check-exact uid 'change-file-owner)
+ (##sys#check-exact gid 'change-file-owner)
+ (when (fx< (##core#inline "C_chown" (##sys#make-c-string (##sys#expand-home-path fn)) uid gid) 0)
+ (posix-error #:file-error 'change-file-owner "cannot change file owner" fn uid gid) ) ) )
+
+(define-foreign-variable _r_ok int "R_OK")
+(define-foreign-variable _w_ok int "W_OK")
+(define-foreign-variable _x_ok int "X_OK")
+
+(let ()
+ (define (check filename acc loc)
+ (##sys#check-string filename loc)
+ (let ([r (fx= 0 (##core#inline "C_access" (##sys#make-c-string (##sys#expand-home-path filename)) acc))])
+ (unless r (##sys#update-errno))
+ r) )
+ (set! file-read-access? (lambda (filename) (check filename _r_ok 'file-read-access?)))
+ (set! file-write-access? (lambda (filename) (check filename _w_ok 'file-write-access?)))
+ (set! file-execute-access? (lambda (filename) (check filename _x_ok 'file-execute-access?))) )
+
+(define (create-session)
+ (let ([a (##core#inline "C_setsid" #f)])
+ (when (fx< a 0)
+ (##sys#update-errno)
+ (##sys#error 'create-session "cannot create session") )
+ a) )
+
+(define process-group-id
+ (getter-with-setter
+ (lambda (pid)
+ (##sys#check-exact pid 'process-group-id)
+ (let ([a (##core#inline "C_getpgid" pid)])
+ (when (fx< a 0)
+ (##sys#update-errno)
+ (##sys#error 'process-group-id "cannot retrieve process group ID" pid) )
+ a))
+ (lambda (pid pgid)
+ (##sys#check-exact pid 'set-process-group-id!)
+ (##sys#check-exact pgid 'set-process-group-id!)
+ (when (fx< (##core#inline "C_setpgid" pid pgid) 0)
+ (##sys#update-errno)
+ (##sys#error 'set-process-group-id! "cannot set process group ID" pid pgid) ) ) ) )
+
+
+;;; Hard and symbolic links:
+
+(define create-symbolic-link
+ (lambda (old new)
+ (##sys#check-string old 'create-symbolic-link)
+ (##sys#check-string new 'create-symbolic-link)
+ (when (fx< (##core#inline
+ "C_symlink"
+ (##sys#make-c-string (##sys#expand-home-path old))
+ (##sys#make-c-string (##sys#expand-home-path new)) )
+ 0)
+ (posix-error #:file-error 'create-symbol-link "cannot create symbolic link" old new) ) ) )
+
+(define-foreign-variable _filename_max int "FILENAME_MAX")
+
+(define read-symbolic-link
+ (let ([substring substring]
+ [buf (make-string (fx+ _filename_max 1))] )
+ (lambda (fname #!optional canonicalize)
+ (##sys#check-string fname 'read-symbolic-link)
+ (let ([len (##core#inline "C_readlink" (##sys#make-c-string (##sys#expand-home-path fname)) buf)])
+ (when (fx< len 0)
+ (posix-error #:file-error 'read-symbolic-link "cannot read symbolic link" fname) )
+ (let ((pathname (substring buf 0 len)))
+ (if (and canonicalize (symbolic-link? pathname))
+ (read-symbolic-link pathname 'canonicalize)
+ pathname ) ) ) ) ) )
+
+(define file-link
+ (let ([link (foreign-lambda int "link" c-string c-string)])
+ (lambda (old new)
+ (##sys#check-string old 'file-link)
+ (##sys#check-string new 'file-link)
+ (when (fx< (link old new) 0)
+ (posix-error #:file-error 'hard-link "could not create hard link" old new) ) ) ) )
+
+
+;;; Using file-descriptors:
+
+(define-foreign-variable _stdin_fileno int "STDIN_FILENO")
+(define-foreign-variable _stdout_fileno int "STDOUT_FILENO")
+(define-foreign-variable _stderr_fileno int "STDERR_FILENO")
+
+(define fileno/stdin _stdin_fileno)
+(define fileno/stdout _stdout_fileno)
+(define fileno/stderr _stderr_fileno)
+
+(let ()
+ (define (mode inp m)
+ (##sys#make-c-string
+ (cond [(pair? m)
+ (let ([m (car m)])
+ (case m
+ [(###append) (if (not inp) "a" (##sys#error "invalid mode for input file" m))]
+ [else (##sys#error "invalid mode argument" m)] ) ) ]
+ [inp "r"]
+ [else "w"] ) ) )
+ (define (check loc fd inp r)
+ (if (##sys#null-pointer? r)
+ (posix-error #:file-error loc "cannot open file" fd)
+ (let ([port (##sys#make-port inp ##sys#stream-port-class "(fdport)" 'stream)])
+ (##core#inline "C_set_file_ptr" port r)
+ port) ) )
+ (set! open-input-file*
+ (lambda (fd . m)
+ (##sys#check-exact fd 'open-input-file*)
+ (check 'open-input-file* fd #t (##core#inline_allocate ("C_fdopen" 2) fd (mode #t m))) ) )
+ (set! open-output-file*
+ (lambda (fd . m)
+ (##sys#check-exact fd 'open-output-file*)
+ (check 'open-output-file* fd #f (##core#inline_allocate ("C_fdopen" 2) fd (mode #f m)) ) ) ) )
+
+(define port->fileno
+ (lambda (port)
+ (##sys#check-port port 'port->fileno)
+ (cond [(eq? 'socket (##sys#slot port 7)) (##sys#tcp-port->fileno port)]
+ [(not (zero? (##sys#peek-unsigned-integer port 0)))
+ (let ([fd (##core#inline "C_C_fileno" port)])
+ (when (fx< fd 0)
+ (posix-error #:file-error 'port->fileno "cannot access file-descriptor of port" port) )
+ fd) ]
+ [else (posix-error #:type-error 'port->fileno "port has no attached file" port)] ) ) )
+
+(define duplicate-fileno
+ (lambda (old . new)
+ (##sys#check-exact old duplicate-fileno)
+ (let ([fd (if (null? new)
+ (##core#inline "C_dup" old)
+ (let ([n (car new)])
+ (##sys#check-exact n 'duplicate-fileno)
+ (##core#inline "C_dup2" old n) ) ) ] )
+ (when (fx< fd 0)
+ (posix-error #:file-error 'duplicate-fileno "cannot duplicate file-descriptor" old) )
+ fd) ) )
+
+(define ##sys#custom-input-port
+ (let ([make-input-port make-input-port]
+ [set-port-name! set-port-name!] )
+ (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 1) (on-close noop) (more? #f))
+ (when nonblocking? (##sys#file-nonblocking! fd) )
+ (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))]
+ [buf (if (fixnum? bufi) (##sys#make-string bufi) bufi)]
+ [buflen 0]
+ [bufpos 0] )
+ (let (
+ [ready?
+ (lambda ()
+ (let ((res (##sys#file-select-one fd)))
+ (if (fx= -1 res)
+ (if (fx= _errno _ewouldblock)
+ #f
+ (posix-error #:file-error loc "cannot select" fd nam))
+ (fx= 1 res))))]
+ [peek
+ (lambda ()
+ (if (fx>= bufpos buflen)
+ #!eof
+ (##core#inline "C_subchar" buf bufpos)) )]
+ [fetch
+ (lambda ()
+ (when (fx>= bufpos buflen)
+ (let loop ()
+ (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
+ (cond [(fx= cnt -1)
+ (if (fx= _errno _ewouldblock)
+ (begin
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
+ (##sys#thread-yield!)
+ (loop) )
+ (posix-error #:file-error loc "cannot read" fd nam) )]
+ [(and more? (fx= cnt 0))
+ ; When "more" keep trying, otherwise read once more
+ ; to guard against race conditions
+ (if (more?)
+ (begin
+ (##sys#thread-yield!)
+ (loop) )
+ (let ([cnt (##core#inline "C_read" fd buf bufsiz)])
+ (when (fx= cnt -1)
+ (if (fx= _errno _ewouldblock)
+ (set! cnt 0)
+ (posix-error #:file-error loc "cannot read" fd nam) ) )
+ (set! buflen cnt)
+ (set! bufpos 0) ) )]
+ [else
+ (set! buflen cnt)
+ (set! bufpos 0)]) ) ) ) )] )
+ (letrec (
+ [this-port
+ (make-input-port
+ (lambda () ; read-char
+ (fetch)
+ (let ([ch (peek)])
+ #; ; Allow increment since overflow is far, far away
+ (unless (eof-object? ch) (set! bufpos (fx+ bufpos 1)))
+ (set! bufpos (fx+ bufpos 1))
+ ch ) )
+ (lambda () ; char-ready?
+ (or (fx< bufpos buflen)
+ (ready?)) )
+ (lambda () ; close
+ ; Do nothing when closed already
+ (unless (##sys#slot this-port 8)
+ (when (fx< (##core#inline "C_close" fd) 0)
+ (posix-error #:file-error loc "cannot close" fd nam) )
+ (on-close) ) )
+ (lambda () ; peek-char
+ (fetch)
+ (peek) )
+ (lambda (port n dest start) ; read-string!
+ (let loop ([n (or n (fx- (##sys#size dest) start))] [m 0] [start start])
+ (cond [(eq? 0 n) m]
+ [(fx< bufpos buflen)
+ (let* ([rest (fx- buflen bufpos)]
+ [n2 (if (fx< n rest) n rest)])
+ (##core#inline "C_substring_copy" buf dest bufpos (fx+ bufpos n2) start)
+ (set! bufpos (fx+ bufpos n2))
+ (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ]
+ [else
+ (fetch)
+ (if (eq? 0 buflen)
+ m
+ (loop n m start) ) ] ) ) )
+ (lambda (port limit) ; read-line
+ (let loop ([str #f])
+ (let ([bumper
+ (lambda (cur ptr)
+ (let* ([cnt (fx- cur bufpos)]
+ [dest
+ (if (eq? 0 cnt)
+ (or str "")
+ (let ([dest (##sys#make-string cnt)])
+ (##core#inline "C_substring_copy"
+ buf dest bufpos cur 0)
+ (##sys#setislot port 5
+ (fx+ (##sys#slot port 5) cnt))
+ (if str
+ (##sys#string-append str dest)
+ dest ) ) ) ] )
+ (set! bufpos ptr)
+ (cond [(eq? cur ptr) ; no EOL encountered
+ (fetch)
+ (values dest (fx< bufpos buflen)) ]
+ [else ; at EOL
+ (##sys#setislot port 4 (fx+ (##sys#slot port 4) 1))
+ (##sys#setislot port 5 0)
+ (values dest #f) ] ) ) ) ] )
+ (cond [(fx< bufpos buflen)
+ (let-values ([(dest cont?)
+ (##sys#scan-buffer-line buf buflen bufpos bumper)])
+ (if cont?
+ (loop dest)
+ dest ) ) ]
+ [else
+ (fetch)
+ (if (fx< bufpos buflen)
+ (loop str)
+ #!eof) ] ) ) ) ) ) ] )
+ (set-port-name! this-port nam)
+ this-port ) ) ) ) ) )
+
+(define ##sys#custom-output-port
+ (let ([make-output-port make-output-port]
+ [set-port-name! set-port-name!] )
+ (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 0) (on-close noop))
+ (when nonblocking? (##sys#file-nonblocking! fd) )
+ (letrec (
+ [poke
+ (lambda (str len)
+ (let ([cnt (##core#inline "C_write" fd str len)])
+ (cond [(fx= -1 cnt)
+ (if (fx= _errno _ewouldblock)
+ (begin
+ (##sys#thread-yield!)
+ (poke str len) )
+ (posix-error loc #:file-error "cannot write" fd nam) ) ]
+ [(fx< cnt len)
+ (poke (##sys#substring str cnt len) (fx- len cnt)) ] ) ) )]
+ [store
+ (let ([bufsiz (if (fixnum? bufi) bufi (##sys#size bufi))])
+ (if (fx= 0 bufsiz)
+ (lambda (str)
+ (when str
+ (poke str (##sys#size str)) ) )
+ (let ([buf (if (fixnum? bufi) (##sys#make-string bufi) bufi)]
+ [bufpos 0])
+ (lambda (str)
+ (if str
+ (let loop ([rem (fx- bufsiz bufpos)] [start 0] [len (##sys#size str)])
+ (cond [(fx= 0 rem)
+ (poke buf bufsiz)
+ (set! bufpos 0)
+ (loop bufsiz 0 len)]
+ [(fx< rem len)
+ (##core#inline "C_substring_copy" str buf start rem bufpos)
+ (loop 0 rem (fx- len rem))]
+ [else
+ (##core#inline "C_substring_copy" str buf start len bufpos)
+ (set! bufpos (fx+ bufpos len))] ) )
+ (when (fx< 0 bufpos)
+ (poke buf bufpos) ) ) ) ) ) )])
+ (letrec (
+ [this-port
+ (make-output-port
+ (lambda (str) ; write-string
+ (store str) )
+ (lambda () ; close
+ ; Do nothing when closed already
+ (unless (##sys#slot this-port 8)
+ (when (fx< (##core#inline "C_close" fd) 0)
+ (posix-error #:file-error loc "cannot close" fd nam) )
+ (on-close) ) )
+ (lambda () ; flush
+ (store #f) ) )] )
+ (set-port-name! this-port nam)
+ this-port ) ) ) ) )
+
+
+;;; Other file operations:
+
+(define file-truncate
+ (lambda (fname off)
+ (##sys#check-number off 'file-truncate)
+ (when (fx< (cond [(string? fname) (##core#inline "C_truncate" (##sys#make-c-string (##sys#expand-home-path fname)) off)]
+ [(fixnum? fname) (##core#inline "C_ftruncate" fname off)]
+ [else (##sys#error 'file-truncate "invalid file" fname)] )
+ 0)
+ (posix-error #:file-error 'file-truncate "cannot truncate file" fname off) ) ) )
+
+
+;;; Record locking:
+
+(define-foreign-variable _f_wrlck int "F_WRLCK")
+(define-foreign-variable _f_rdlck int "F_RDLCK")
+(define-foreign-variable _f_unlck int "F_UNLCK")
+
+(let ()
+ (define (setup port args loc)
+ (let-optionals* args ([start 0]
+ [len #t] )
+ (##sys#check-port port loc)
+ (##sys#check-number start loc)
+ (if (eq? #t len)
+ (set! len 0)
+ (##sys#check-number len loc) )
+ (##core#inline "C_flock_setup" (if (##sys#slot port 1) _f_rdlck _f_wrlck) start len)
+ (##sys#make-structure 'lock port start len) ) )
+ (define (err msg lock loc)
+ (posix-error #:file-error loc msg (##sys#slot lock 1) (##sys#slot lock 2) (##sys#slot lock 3)) )
+ (set! file-lock
+ (lambda (port . args)
+ (let ([lock (setup port args 'file-lock)])
+ (if (fx< (##core#inline "C_flock_lock" port) 0)
+ (err "cannot lock file" lock 'file-lock)
+ lock) ) ) )
+ (set! file-lock/blocking
+ (lambda (port . args)
+ (let ([lock (setup port args 'file-lock/blocking)])
+ (if (fx< (##core#inline "C_flock_lockw" port) 0)
+ (err "cannot lock file" lock 'file-lock/blocking)
+ lock) ) ) )
+ (set! file-test-lock
+ (lambda (port . args)
+ (let ([lock (setup port args 'file-test-lock)])
+ (cond [(##core#inline "C_flock_test" port) => (lambda (c) (and (not (fx= c 0)) c))]
+ [else (err "cannot unlock file" lock 'file-test-lock)] ) ) ) ) )
+
+(define file-unlock
+ (lambda (lock)
+ (##sys#check-structure lock 'lock 'file-unlock)
+ (##core#inline "C_flock_setup" _f_unlck (##sys#slot lock 2) (##sys#slot lock 3))
+ (when (fx< (##core#inline "C_flock_lock" (##sys#slot lock 1)) 0)
+ (posix-error #:file-error 'file-unlock "cannot unlock file" lock) ) ) )
+
+
+;;; FIFOs:
+
+(define create-fifo
+ (lambda (fname . mode)
+ (##sys#check-string fname 'create-fifo)
+ (let ([mode (if (pair? mode) (car mode) (fxior _s_irwxu (fxior _s_irwxg _s_irwxo)))])
+ (##sys#check-exact mode 'create-fifo)
+ (when (fx< (##core#inline "C_mkfifo" (##sys#make-c-string (##sys#expand-home-path fname)) mode) 0)
+ (posix-error #:file-error 'create-fifo "cannot create FIFO" fname mode) ) ) ) )
+
+(define fifo?
+ (lambda (filename)
+ (##sys#check-string filename 'fifo?)
+ (let ([v (##sys#file-info (##sys#expand-home-path filename))])
+ (if v
+ (fx= 3 (##sys#slot v 4))
+ (posix-error #:file-error 'fifo? "file does not exist" filename) ) ) ) )
+
+
+;;; Environment access:
+
+(define setenv
+ (lambda (var val)
+ (##sys#check-string var 'setenv)
+ (##sys#check-string val 'setenv)
+ (##core#inline "C_setenv" (##sys#make-c-string var) (##sys#make-c-string val))
+ (##core#undefined) ) )
+
+(define (unsetenv var)
+ (##sys#check-string var 'unsetenv)
+ (##core#inline "C_unsetenv" (##sys#make-c-string var))
+ (##core#undefined) )
+
+(define get-environment-variables
+ (let ([get (foreign-lambda c-string "C_getenventry" int)])
+ (lambda ()
+ (let loop ([i 0])
+ (let ([entry (get i)])
+ (if entry
+ (let scan ([j 0])
+ (if (char=? #\= (##core#inline "C_subchar" entry j))
+ (cons (cons (##sys#substring entry 0 j)
+ (##sys#substring entry (fx+ j 1) (##sys#size entry)))
+ (loop (fx+ i 1)))
+ (scan (fx+ j 1)) ) )
+ '() ) ) ) ) ) )
+
+(define current-environment get-environment-variables) ; DEPRECATED
+
+
+;;; Memory mapped I/O:
+
+(define-foreign-variable _prot_read int "PROT_READ")
+(define-foreign-variable _prot_write int "PROT_WRITE")
+(define-foreign-variable _prot_exec int "PROT_EXEC")
+(define-foreign-variable _prot_none int "PROT_NONE")
+
+(define prot/read _prot_read)
+(define prot/write _prot_write)
+(define prot/exec _prot_exec)
+(define prot/none _prot_none)
+
+(define-foreign-variable _map_fixed int "MAP_FIXED")
+(define-foreign-variable _map_shared int "MAP_SHARED")
+(define-foreign-variable _map_private int "MAP_PRIVATE")
+(define-foreign-variable _map_anonymous int "MAP_ANON")
+(define-foreign-variable _map_file int "MAP_FILE")
+
+(define map/fixed _map_fixed)
+(define map/shared _map_shared)
+(define map/private _map_private)
+(define map/anonymous _map_anonymous)
+(define map/file _map_file)
+
+(define map-file-to-memory
+ (let ([mmap (foreign-lambda c-pointer "mmap" c-pointer integer int int int integer)] )
+ (lambda (addr len prot flag fd . off)
+ (let ([addr (if (not addr) (##sys#null-pointer) addr)]
+ [off (if (pair? off) (car off) 0)] )
+ (unless (and (##core#inline "C_blockp" addr) (##core#inline "C_specialp" addr))
+ (##sys#signal-hook #:type-error 'map-file-to-memory "bad argument type - not a foreign pointer" addr) )
+ (let ([addr2 (mmap addr len prot flag fd off)])
+ (when (eq? -1 (##sys#pointer->address addr2))
+ (posix-error #:file-error 'map-file-to-memory "cannot map file to memory" addr len prot flag fd off) )
+ (##sys#make-structure 'mmap addr2 len) ) ) ) ) )
+
+(define unmap-file-from-memory
+ (let ([munmap (foreign-lambda int "munmap" c-pointer integer)] )
+ (lambda (mmap . len)
+ (##sys#check-structure mmap 'mmap 'unmap-file-from-memory)
+ (let ([len (if (pair? len) (car len) (##sys#slot mmap 2))])
+ (unless (eq? 0 (munmap (##sys#slot mmap 1) len))
+ (posix-error #:file-error 'unmap-file-from-memory "cannot unmap file from memory" mmap len) ) ) ) ) )
+
+(define (memory-mapped-file-pointer mmap)
+ (##sys#check-structure mmap 'mmap 'memory-mapped-file-pointer)
+ (##sys#slot mmap 1) )
+
+(define (memory-mapped-file? x)
+ (##sys#structure? x 'mmap) )
+
+;;; Time related things:
+
+(define (check-time-vector loc tm)
+ (##sys#check-vector tm loc)
+ (when (fx< (##sys#size tm) 10)
+ (##sys#error loc "time vector too short" tm) ) )
+
+(define (seconds->local-time secs)
+ (##sys#check-number secs 'seconds->local-time)
+ (##sys#decode-seconds secs #f) )
+
+(define (seconds->utc-time secs)
+ (##sys#check-number secs 'seconds->utc-time)
+ (##sys#decode-seconds secs #t) )
+
+(define seconds->string
+ (let ([ctime (foreign-lambda c-string "C_ctime" integer)])
+ (lambda (secs)
+ (##sys#check-number secs 'seconds->string)
+ (let ([str (ctime secs)])
+ (if str
+ (##sys#substring str 0 (fx- (##sys#size str) 1))
+ (##sys#error 'seconds->string "cannot convert seconds to string" secs) ) ) ) ) )
+
+(define time->string
+ (let ([asctime (foreign-lambda c-string "C_asctime" scheme-object)]
+ [strftime (foreign-lambda c-string "C_strftime" scheme-object scheme-object)])
+ (lambda (tm #!optional fmt)
+ (check-time-vector 'time->string tm)
+ (if fmt
+ (begin
+ (##sys#check-string fmt 'time->string)
+ (or (strftime tm (##sys#make-c-string fmt))
+ (##sys#error 'time->string "time formatting overflows buffer" tm)) )
+ (let ([str (asctime tm)])
+ (if str
+ (##sys#substring str 0 (fx- (##sys#size str) 1))
+ (##sys#error 'time->string "cannot convert time vector to string" tm) ) ) ) ) ) )
+
+(define string->time
+ (let ([strptime (foreign-lambda scheme-object "C_strptime" scheme-object scheme-object scheme-object)])
+ (lambda (tim #!optional (fmt "%a %b %e %H:%M:%S %Z %Y"))
+ (##sys#check-string tim 'string->time)
+ (##sys#check-string fmt 'string->time)
+ (strptime (##sys#make-c-string tim) (##sys#make-c-string fmt) (make-vector 10 #f)) ) ) )
+
+(define (local-time->seconds tm)
+ (check-time-vector 'local-time->seconds tm)
+ (if (##core#inline "C_mktime" tm)
+ (##sys#cons-flonum)
+ (##sys#error 'local-time->seconds "cannot convert time vector to seconds" tm) ) )
+
+(define (utc-time->seconds tm)
+ (check-time-vector 'utc-time->seconds tm)
+ (if (##core#inline "C_timegm" tm)
+ (##sys#cons-flonum)
+ (##sys#error 'utc-time->seconds "cannot convert time vector to seconds" tm) ) )
+
+(define local-timezone-abbreviation
+ (foreign-lambda* c-string ()
+ "\n#if !defined(__CYGWIN__) && !defined(__SVR4) && !defined(__uClinux__) && !defined(__hpux__)\n"
+ "time_t clock = time(NULL);"
+ "struct tm *ltm = C_localtime(&clock);"
+ "char *z = ltm ? (char *)ltm->tm_zone : 0;"
+ "\n#else\n"
+ "char *z = (daylight ? tzname[1] : tzname[0]);"
+ "\n#endif\n"
+ "return(z);") )
+
+;;; Other things:
+
+(define _exit
+ (let ([ex0 (foreign-lambda void "_exit" int)])
+ (lambda code
+ (ex0 (if (pair? code) (car code) 0)) ) ) )
+
+(define set-alarm! (foreign-lambda int "C_alarm" int))
+
+(define-foreign-variable _iofbf int "_IOFBF")
+(define-foreign-variable _iolbf int "_IOLBF")
+(define-foreign-variable _ionbf int "_IONBF")
+(define-foreign-variable _bufsiz int "BUFSIZ")
+
+(define set-buffering-mode!
+ (lambda (port mode . size)
+ (##sys#check-port port 'set-buffering-mode!)
+ (let ([size (if (pair? size) (car size) _bufsiz)]
+ [mode (case mode
+ [(###full) _iofbf]
+ [(###line) _iolbf]
+ [(###none) _ionbf]
+ [else (##sys#error 'set-buffering-mode! "invalid buffering-mode" mode port)] ) ] )
+ (##sys#check-exact size 'set-buffering-mode!)
+ (when (fx< (if (eq? 'stream (##sys#slot port 7))
+ (##core#inline "C_setvbuf" port mode size)
+ -1)
+ 0)
+ (##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size) ) ) ) )
+
+(define (terminal-port? port)
+ (##sys#check-port port 'terminal-port?)
+ (let ([fp (##sys#peek-unsigned-integer port 0)])
+ (and (not (eq? 0 fp)) (##core#inline "C_tty_portp" port) ) ) )
+
+(define (##sys#terminal-check caller port)
+ (##sys#check-port port caller)
+ (unless (and (eq? 'stream (##sys#slot port 7))
+ (##core#inline "C_tty_portp" port))
+ (##sys#error caller "port is not connected to a terminal" port)))
+
+(define terminal-name
+ (let ([ttyname (foreign-lambda nonnull-c-string "ttyname" int)] )
+ (lambda (port)
+ (##sys#terminal-check 'terminal-name port)
+ (ttyname (##core#inline "C_C_fileno" port) ) ) ) )
+
+(define terminal-size
+ (let ((ttysize (foreign-lambda int "get_tty_size" int
+ (nonnull-c-pointer int)
+ (nonnull-c-pointer int))))
+ (lambda (port)
+ (##sys#terminal-check 'terminal-size port)
+ (let-location ((columns int)
+ (rows int))
+ (if (fx= 0
+ (ttysize (##core#inline "C_C_fileno" port)
+ (location columns)
+ (location rows)))
+ (values columns rows)
+ (posix-error #:error 'terminal-size
+ "Unable to get size of terminal" port))))))
+
+(define get-host-name
+ (let ([getit
+ (foreign-lambda* c-string ()
+ "if(gethostname(C_hostbuf, 256) == -1) return(NULL);"
+ "else return(C_hostbuf);") ] )
+ (lambda ()
+ (let ([host (getit)])
+ (unless host
+ (posix-error #:error 'get-host-name "cannot retrieve host-name") )
+ host) ) ) )
+
+
+;;; Filename globbing:
+
+(define glob
+ (let ([regexp regexp]
+ [string-match string-match]
+ [glob->regexp glob->regexp]
+ [directory directory]
+ [make-pathname make-pathname]
+ [decompose-pathname decompose-pathname] )
+ (lambda paths
+ (let conc-loop ([paths paths])
+ (if (null? paths)
+ '()
+ (let ([path (car paths)])
+ (let-values ([(dir fil ext) (decompose-pathname path)])
+ (let* ([patt (glob->regexp (make-pathname #f (or fil "*") ext))]
+ [rx (regexp patt)])
+ (let loop ([fns (directory (or dir ".") #t)])
+ (cond [(null? fns) (conc-loop (cdr paths))]
+ [(string-match rx (car fns))
+ => (lambda (m) (cons (make-pathname dir (car m)) (loop (cdr fns)))) ]
+ [else (loop (cdr fns))] ) ) ) ) ) ) ) ) ) )
+
+
+;;; Process handling:
+
+(define process-fork
+ (let ([fork (foreign-lambda int "C_fork")])
+ (lambda thunk
+ (let ([pid (fork)])
+ (cond [(fx= -1 pid) (posix-error #:process-error 'process-fork "cannot create child process")]
+ [(and (pair? thunk) (fx= pid 0))
+ ((car thunk))
+ ((foreign-lambda void "_exit" int) 0) ]
+ [else pid] ) ) ) ) )
+
+(define process-execute
+ (let ([setarg (foreign-lambda void "C_set_exec_arg" int scheme-pointer int)]
+ [freeargs (foreign-lambda void "C_free_exec_args")]
+ [setenv (foreign-lambda void "C_set_exec_env" int scheme-pointer int)]
+ [freeenv (foreign-lambda void "C_free_exec_env")]
+ [pathname-strip-directory pathname-strip-directory] )
+ (lambda (filename #!optional (arglist '()) envlist)
+ (##sys#check-string filename 'process-execute)
+ (##sys#check-list arglist 'process-execute)
+ (let ([s (pathname-strip-directory filename)])
+ (setarg 0 s (##sys#size s)) )
+ (do ([al arglist (cdr al)]
+ [i 1 (fx+ i 1)] )
+ ((null? al)
+ (setarg i #f 0)
+ (when envlist
+ (##sys#check-list envlist 'process-execute)
+ (do ([el envlist (cdr el)]
+ [i 0 (fx+ i 1)] )
+ ((null? el) (setenv i #f 0))
+ (let ([s (car el)])
+ (##sys#check-string s 'process-execute)
+ (setenv i s (##sys#size s)) ) ) )
+ (let* ([prg (##sys#make-c-string (##sys#expand-home-path filename))]
+ [r (if envlist
+ (##core#inline "C_execve" prg)
+ (##core#inline "C_execvp" prg) )] )
+ (when (fx= r -1)
+ (freeargs)
+ (freeenv)
+ (posix-error #:process-error 'process-execute "cannot execute process" filename) ) ) )
+ (let ([s (car al)])
+ (##sys#check-string s 'process-execute)
+ (setarg i s (##sys#size s)) ) ) ) ) )
+
+(define-foreign-variable _wnohang int "WNOHANG")
+(define-foreign-variable _wait-status int "C_wait_status")
+
+(define (##sys#process-wait pid nohang)
+ (let* ([res (##core#inline "C_waitpid" pid (if nohang _wnohang 0))]
+ [norm (##core#inline "C_WIFEXITED" _wait-status)] )
+ (values
+ res
+ norm
+ (cond [norm (##core#inline "C_WEXITSTATUS" _wait-status)]
+ [(##core#inline "C_WIFSIGNALED" _wait-status)
+ (##core#inline "C_WTERMSIG" _wait-status)]
+ [else (##core#inline "C_WSTOPSIG" _wait-status)] ) ) ) )
+
+(define process-wait
+ (lambda args
+ (let-optionals* args ([pid #f] [nohang #f])
+ (let ([pid (or pid -1)])
+ (##sys#check-exact pid 'process-wait)
+ (receive [epid enorm ecode] (##sys#process-wait pid nohang)
+ (if (fx= epid -1)
+ (posix-error #:process-error 'process-wait "waiting for child process failed" pid)
+ (values epid enorm ecode) ) ) ) ) ) )
+
+(define current-process-id (foreign-lambda int "C_getpid"))
+(define parent-process-id (foreign-lambda int "C_getppid"))
+
+(define sleep (foreign-lambda int "C_sleep" int))
+
+(define process-signal
+ (lambda (id . sig)
+ (let ([sig (if (pair? sig) (car sig) _sigterm)])
+ (##sys#check-exact id 'process-signal)
+ (##sys#check-exact sig 'process-signal)
+ (let ([r (##core#inline "C_kill" id sig)])
+ (when (fx= r -1) (posix-error #:process-error 'process-signal "could not send signal to process" id sig) ) ) ) ) )
+
+(define (##sys#shell-command)
+ (or (get-environment-variable "SHELL") "/bin/sh") )
+
+(define (##sys#shell-command-arguments cmdlin)
+ (list "-c" cmdlin) )
+
+(define process-run
+ (let ([process-fork process-fork]
+ [process-execute process-execute])
+ (lambda (f . args)
+ (let ([args (if (pair? args) (car args) #f)]
+ [pid (process-fork)] )
+ (cond [(not (eq? 0 pid)) pid]
+ [args (process-execute f args)]
+ [else
+ (process-execute (##sys#shell-command) (##sys#shell-command-arguments f)) ] ) ) ) ) )
+
+;;; Run subprocess connected with pipes:
+
+;; ##sys#process
+; loc caller procedure symbol
+; cmd pathname or commandline
+; args string-list or '()
+; env string-list or #f
+; stdoutf #f then share, or #t then create
+; stdinf #f then share, or #t then create
+; stderrf #f then share, or #t then create
+;
+; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)
+; where stdin-input-port?, etc. is a port or #f, indicating no port created.
+
+(define-constant DEFAULT-INPUT-BUFFER-SIZE 256)
+(define-constant DEFAULT-OUTPUT-BUFFER-SIZE 0)
+
+;FIXME process-execute, process-fork don't show parent caller
+
+(define ##sys#process
+ (let (
+ [create-pipe create-pipe]
+ [process-wait process-wait]
+ [process-fork process-fork]
+ [process-execute process-execute]
+ [duplicate-fileno duplicate-fileno]
+ [file-close file-close]
+ [replace-fd
+ (lambda (loc fd stdfd)
+ (unless (fx= stdfd fd)
+ (duplicate-fileno fd stdfd)
+ (file-close fd) ) )] )
+ (let (
+ [make-on-close
+ (lambda (loc pid clsvec idx idxa idxb)
+ (lambda ()
+ (vector-set! clsvec idx #t)
+ (when (and (vector-ref clsvec idxa) (vector-ref clsvec idxb))
+ (receive [_ flg cod] (process-wait pid)
+ (unless flg
+ (##sys#signal-hook #:process-error loc
+ "abnormal process exit" pid cod)) ) ) ) )]
+ [needed-pipe
+ (lambda (loc port)
+ (and port
+ (receive [i o] (create-pipe) (cons i o))) )]
+ [connect-parent
+ (lambda (loc pipe port fd)
+ (and port
+ (let ([usefd (car pipe)] [clsfd (cdr pipe)])
+ (file-close clsfd)
+ usefd) ) )]
+ [connect-child
+ (lambda (loc pipe port stdfd)
+ (when port
+ (let ([usefd (car pipe)] [clsfd (cdr pipe)])
+ (file-close clsfd)
+ (replace-fd loc usefd stdfd)) ) )] )
+ (let (
+ [spawn
+ (let ([swapped-ends
+ (lambda (pipe)
+ (and pipe
+ (cons (cdr pipe) (car pipe)) ) )])
+ (lambda (loc cmd args env stdoutf stdinf stderrf)
+ (let ([ipipe (needed-pipe loc stdinf)]
+ [opipe (needed-pipe loc stdoutf)]
+ [epipe (needed-pipe loc stderrf)])
+ (values
+ ipipe (swapped-ends opipe) epipe
+ (process-fork
+ (lambda ()
+ (connect-child loc opipe stdinf fileno/stdin)
+ (connect-child loc (swapped-ends ipipe) stdoutf fileno/stdout)
+ (connect-child loc (swapped-ends epipe) stderrf fileno/stderr)
+ (process-execute cmd args env)))) ) ) )]
+ [input-port
+ (lambda (loc pid cmd pipe stdf stdfd on-close)
+ (and-let* ([fd (connect-parent loc pipe stdf stdfd)])
+ (##sys#custom-input-port loc cmd fd #t DEFAULT-INPUT-BUFFER-SIZE on-close) ) )]
+ [output-port
+ (lambda (loc pid cmd pipe stdf stdfd on-close)
+ (and-let* ([fd (connect-parent loc pipe stdf stdfd)])
+ (##sys#custom-output-port loc cmd fd #t DEFAULT-OUTPUT-BUFFER-SIZE on-close) ) )] )
+ (lambda (loc cmd args env stdoutf stdinf stderrf)
+ (receive [inpipe outpipe errpipe pid]
+ (spawn loc cmd args env stdoutf stdinf stderrf)
+ ;When shared assume already "closed", since only created ports
+ ;should be explicitly closed, and when one is closed we want
+ ;to wait.
+ (let ([clsvec (vector (not stdinf) (not stdoutf) (not stderrf))])
+ (values
+ (input-port loc pid cmd inpipe stdinf fileno/stdin
+ (make-on-close loc pid clsvec 0 1 2))
+ (output-port loc pid cmd outpipe stdoutf fileno/stdout
+ (make-on-close loc pid clsvec 1 0 2))
+ pid
+ (input-port loc pid cmd errpipe stderrf fileno/stderr
+ (make-on-close loc pid clsvec 2 0 1)) ) ) ) ) ) ) ) )
+
+;;; Run subprocess connected with pipes:
+
+(define process)
+(define process*)
+(let ([%process
+ (lambda (loc err? cmd args env)
+ (let ([chkstrlst
+ (lambda (lst)
+ (##sys#check-list lst loc)
+ (for-each (cut ##sys#check-string <> loc) lst) )])
+ (##sys#check-string cmd loc)
+ (if args
+ (chkstrlst args)
+ (begin
+ (set! args (##sys#shell-command-arguments cmd))
+ (set! cmd (##sys#shell-command)) ) )
+ (when env (chkstrlst env))
+ (receive [in out pid err] (##sys#process loc cmd args env #t #t err?)
+ (if err?
+ (values in out pid err)
+ (values in out pid) ) ) ) )] )
+ (set! process
+ (lambda (cmd #!optional args env)
+ (%process 'process #f cmd args env) ))
+ (set! process*
+ (lambda (cmd #!optional args env)
+ (%process 'process* #t cmd args env) )) )
+
+;;; Find matching files:
+
+(define find-files
+ (let ([glob glob]
+ [string-match string-match]
+ [make-pathname make-pathname]
+ [pathname-file pathname-file]
+ [directory? directory?] )
+ (lambda (dir pred . action-id-limit)
+ (let-optionals
+ action-id-limit
+ ([action (lambda (x y) (cons x y))] ; we want cons inlined
+ [id '()]
+ [limit #f] )
+ (##sys#check-string dir 'find-files)
+ (let* ([depth 0]
+ [lproc
+ (cond [(not limit) (lambda _ #t)]
+ [(fixnum? limit) (lambda _ (fx< depth limit))]
+ [else limit] ) ]
+ [pproc
+ (if (or (string? pred) (regexp? pred))
+ (lambda (x) (string-match pred x))
+ pred) ] )
+ (let loop ([fs (glob (make-pathname dir "*"))]
+ [r id] )
+ (if (null? fs)
+ r
+ (let ([f (##sys#slot fs 0)]
+ [rest (##sys#slot fs 1)] )
+ (cond [(directory? f)
+ (cond [(member (pathname-file f) '("." "..")) (loop rest r)]
+ [(lproc f)
+ (loop rest
+ (fluid-let ([depth (fx+ depth 1)])
+ (loop (glob (make-pathname f "*"))
+ (if (pproc f) (action f r) r)) ) ) ]
+ [else (loop rest (if (pproc f) (action f r) r))] ) ]
+ [(pproc f) (loop rest (action f r))]
+ [else (loop rest r)] ) ) ) ) ) ) ) ) )
+
+
+;;; chroot:
+
+(define set-root-directory!
+ (let ([chroot (foreign-lambda int "chroot" c-string)])
+ (lambda (dir)
+ (##sys#check-string dir 'set-root-directory!)
+ (when (fx< (chroot dir) 0)
+ (posix-error #:file-error 'set-root-directory! "unable to change root directory" dir) ) ) ) )
diff --git a/posixwin.scm b/posixwin.scm
new file mode 100644
index 00000000..7b01c92c
--- /dev/null
+++ b/posixwin.scm
@@ -0,0 +1,2145 @@
+;;;; posixwin.scm - Miscellaneous file- and process-handling routines, available on Windows
+;
+; By Sergey Khorev
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+; Not implemented:
+;
+; open/noctty open/nonblock open/fsync open/sync
+; perm/isvtx perm/isuid perm/isgid
+; file-select
+; symbolic-link?
+; set-signal-mask! signal-mask signal-masked? signal-mask! signal-unmask!
+; user-information group-information get-groups set-groups! initialize-groups
+; errno/wouldblock
+; change-file-owner
+; current-user-id current-group-id current-effective-user-id current-effective-group-id
+; current-effective-user-name
+; set-user-id! set-group-id!
+; create-session
+; process-group-id set-process-group-id!
+; create-symbolic-link read-symbolic-link
+; file-truncate
+; file-lock file-lock/blocking file-unlock file-test-lock
+; create-fifo fifo?
+; prot/...
+; map/...
+; map-file-to-memory unmap-file-from-memory memory-mapped-file-pointer memory-mapped-file?
+; set-alarm!
+; terminal-port? terminal-name
+; process-fork process-wait
+; parent-process-id
+; process-signal
+
+
+; Issues
+;
+; - Use of a UTF8 encoded string will not work properly. Windows uses a
+; 16-bit UNICODE character string encoding and specialized system calls
+; and/or structure settings for the use of such strings.
+
+
+(declare
+ (unit posix)
+ (uses scheduler regex extras utils files ports)
+ (disable-interrupts)
+ (usual-integrations)
+ (hide ##sys#stat posix-error
+ $quote-args-list $exec-setup $exec-teardown
+ check-time-vector)
+ (not inline ##sys#interrupt-hook ##sys#user-interrupt-hook)
+ (foreign-declare #<<EOF
+#ifndef WIN32_LEAN_AND_MEAN
+# define WIN32_LEAN_AND_MEAN
+#endif
+
+/*
+MinGW should have winsock2.h and ws2tcpip.h as well.
+The CMake build will set HAVE_WINSOCK2_H and HAVE_WS2TCPIP_H.
+However, the _MSC_VER test is still needed for vcbuild.bat.
+./configure doesn't test for these. It should, for MinGW.
+*/
+#if (_MSC_VER > 1300) || (defined(HAVE_WINSOCK2_H) && defined(HAVE_WS2TCPIP_H))
+# include <winsock2.h>
+# include <ws2tcpip.h>
+#else
+# include <winsock.h>
+#endif
+
+#include <signal.h>
+#include <errno.h>
+#include <io.h>
+#include <stdio.h>
+#include <process.h>
+
+static int C_not_implemented(void);
+int C_not_implemented() { return -1; }
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+#include <direct.h>
+
+#include <time.h>
+
+#define ARG_MAX 256
+#define PIPE_BUF 512
+#ifndef ENV_MAX
+# define ENV_MAX 1024
+#endif
+
+static C_TLS char *C_exec_args[ ARG_MAX ];
+static C_TLS char *C_exec_env[ ENV_MAX ];
+static C_TLS struct group *C_group;
+static C_TLS int C_pipefds[ 2 ];
+static C_TLS time_t C_secs;
+static C_TLS struct tm C_tm;
+static C_TLS struct stat C_statbuf;
+
+/* pipe handles */
+static C_TLS HANDLE C_rd0, C_wr0, C_wr0_, C_rd1, C_wr1, C_rd1_;
+static C_TLS HANDLE C_save0, C_save1; /* saved I/O handles */
+static C_TLS char C_rdbuf; /* one-char buffer for read */
+static C_TLS int C_exstatus;
+
+/* platform information; initialized for cached testing */
+static C_TLS char C_hostname[256] = "";
+static C_TLS char C_osver[16] = "";
+static C_TLS char C_osrel[16] = "";
+static C_TLS char C_processor[16] = "";
+static C_TLS char C_shlcmd[256] = "";
+
+/* Windows NT or better */
+static int C_isNT = 0;
+
+/* Current user name */
+static C_TLS TCHAR C_username[255 + 1] = "";
+
+/* Directory Operations */
+
+#define C_mkdir(str) C_fix(mkdir(C_c_string(str)))
+#define C_chdir(str) C_fix(chdir(C_c_string(str)))
+#define C_rmdir(str) C_fix(rmdir(C_c_string(str)))
+
+#ifndef __WATCOMC__
+/* DIRENT stuff */
+struct dirent
+{
+ char * d_name;
+};
+
+typedef struct
+{
+ struct _finddata_t fdata;
+ int handle;
+ struct dirent current;
+} DIR;
+
+static DIR * C_fcall
+opendir(const char *name)
+{
+ int name_len = strlen(name);
+ DIR *dir = (DIR *)malloc(sizeof(DIR));
+ char *what;
+ if (!dir)
+ {
+ errno = ENOMEM;
+ return NULL;
+ }
+ what = (char *)malloc(name_len + 3);
+ if (!what)
+ {
+ free(dir);
+ errno = ENOMEM;
+ return NULL;
+ }
+ strcpy(what, name);
+ if (strchr("\\/", name[name_len - 1]))
+ strcat(what, "*");
+ else
+ strcat(what, "\\*");
+
+ dir->handle = _findfirst(what, &dir->fdata);
+ if (dir->handle == -1)
+ {
+ free(what);
+ free(dir);
+ return NULL;
+ }
+ dir->current.d_name = NULL; /* as the first-time indicator */
+ free(what);
+ return dir;
+}
+
+static int C_fcall
+closedir(DIR * dir)
+{
+ if (dir)
+ {
+ int res = _findclose(dir->handle);
+ free(dir);
+ return res;
+ }
+ return -1;
+}
+
+static struct dirent * C_fcall
+readdir(DIR * dir)
+{
+ if (dir)
+ {
+ if (!dir->current.d_name /* first time after opendir */
+ || _findnext(dir->handle, &dir->fdata) != -1)
+ {
+ dir->current.d_name = dir->fdata.name;
+ return &dir->current;
+ }
+ }
+ return NULL;
+}
+#endif /* ifndef __WATCOMC__ */
+
+#ifdef __WATCOMC__
+# define mktemp _mktemp
+/* there is no P_DETACH in Watcom CRTL */
+# define P_DETACH P_NOWAIT
+#endif
+
+#define C_opendir(x,h) C_set_block_item(h, 0, (C_word) opendir(C_c_string(x)))
+#define C_closedir(h) (closedir((DIR *)C_block_item(h, 0)), C_SCHEME_UNDEFINED)
+#define C_readdir(h,e) C_set_block_item(e, 0, (C_word) readdir((DIR *)C_block_item(h, 0)))
+#define C_foundfile(e,b) (strcpy(C_c_string(b), ((struct dirent *) C_block_item(e, 0))->d_name), C_fix(strlen(((struct dirent *) C_block_item(e, 0))->d_name)))
+
+#define C_curdir(buf) (getcwd(C_c_string(buf), 256) ? C_fix(strlen(C_c_string(buf))) : C_SCHEME_FALSE)
+
+#define open_binary_input_pipe(a, n, name) C_mpointer(a, _popen(C_c_string(name), "r"))
+#define open_text_input_pipe(a, n, name) open_binary_input_pipe(a, n, name)
+#define open_binary_output_pipe(a, n, name) C_mpointer(a, _popen(C_c_string(name), "w"))
+#define open_text_output_pipe(a, n, name) open_binary_output_pipe(a, n, name)
+#define close_pipe(p) C_fix(_pclose(C_port_file(p)))
+
+#define C_set_file_ptr(port, ptr) (C_set_block_item(port, 0, (C_block_item(ptr, 0))), C_SCHEME_UNDEFINED)
+
+#define C_getpid getpid
+#define C_chmod(fn, m) C_fix(chmod(C_data_pointer(fn), C_unfix(m)))
+#define C_fdopen(a, n, fd, m) C_mpointer(a, fdopen(C_unfix(fd), C_c_string(m)))
+#define C_C_fileno(p) C_fix(fileno(C_port_file(p)))
+#define C_dup(x) C_fix(dup(C_unfix(x)))
+#define C_dup2(x, y) C_fix(dup2(C_unfix(x), C_unfix(y)))
+#define C_setvbuf(p, m, s) C_fix(setvbuf(C_port_file(p), NULL, C_unfix(m), C_unfix(s)))
+#define C_access(fn, m) C_fix(access((char *)C_data_pointer(fn), C_unfix(m)))
+#define C_pipe(d, m) C_fix(_pipe(C_pipefds, PIPE_BUF, C_unfix(m)))
+#define C_close(fd) C_fix(close(C_unfix(fd)))
+
+#define C_getenventry(i) environ[ i ]
+
+#define C_putenv(s) C_fix(putenv((char *)C_data_pointer(s)))
+#define C_stat(fn) C_fix(stat((char *)C_data_pointer(fn), &C_statbuf))
+#define C_fstat(f) C_fix(fstat(C_unfix(f), &C_statbuf))
+
+static C_word C_fcall
+C_setenv(C_word x, C_word y)
+{
+ char *sx = C_data_pointer(x),
+ *sy = C_data_pointer(y);
+ int n1 = C_strlen(sx),
+ n2 = C_strlen(sy);
+ char *buf = (char *)C_malloc(n1 + n2 + 2);
+ if (buf == NULL)
+ return(C_fix(0));
+ else
+ {
+ C_strcpy(buf, sx);
+ buf[ n1 ] = '=';
+ C_strcpy(buf + n1 + 1, sy);
+ return(C_fix(putenv(buf)));
+ }
+}
+
+static void C_fcall
+C_set_arg_string(char **where, int i, char *dat, int len)
+{
+ char *ptr;
+ if (dat)
+ {
+ ptr = (char *)C_malloc(len + 1);
+ C_memcpy(ptr, dat, len);
+ ptr[ len ] = '\0';
+ }
+ else
+ ptr = NULL;
+ where[ i ] = ptr;
+}
+
+static void C_fcall
+C_free_arg_string(char **where) {
+ while (*where) C_free(*(where++));
+}
+
+#define C_set_exec_arg(i, a, len) C_set_arg_string(C_exec_args, i, a, len)
+#define C_set_exec_env(i, a, len) C_set_arg_string(C_exec_env, i, a, len)
+
+#define C_free_exec_args() (C_free_arg_string(C_exec_args), C_SCHEME_TRUE)
+#define C_free_exec_env() (C_free_arg_string(C_exec_env), C_SCHEME_TRUE)
+
+#define C_execvp(f) C_fix(execvp(C_data_pointer(f), (const char *const *)C_exec_args))
+#define C_execve(f) C_fix(execve(C_data_pointer(f), (const char *const *)C_exec_args, (const char *const *)C_exec_env))
+
+/* MS replacement for the fork-exec pair */
+#define C_spawnvp(m, f) C_fix(spawnvp(C_unfix(m), C_data_pointer(f), (const char *const *)C_exec_args))
+#define C_spawnvpe(m, f) C_fix(spawnvpe(C_unfix(m), C_data_pointer(f), (const char *const *)C_exec_args, (const char *const *)C_exec_env))
+
+#define C_open(fn, fl, m) C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m)))
+#define C_read(fd, b, n) C_fix(read(C_unfix(fd), C_data_pointer(b), C_unfix(n)))
+#define C_write(fd, b, n) C_fix(write(C_unfix(fd), C_data_pointer(b), C_unfix(n)))
+#define C_mkstemp(t) C_fix(mktemp(C_c_string(t)))
+
+/* It is assumed that 'int' is-a 'long' */
+#define C_ftell(p) C_fix(ftell(C_port_file(p)))
+#define C_fseek(p, n, w) C_mk_nbool(fseek(C_port_file(p), C_num_to_int(n), C_unfix(w)))
+#define C_lseek(fd, o, w) C_fix(lseek(C_unfix(fd), C_unfix(o), C_unfix(w)))
+
+#define C_flushall() C_fix(_flushall())
+
+#define C_ctime(n) (C_secs = (n), ctime(&C_secs))
+
+#define C_tm_set_08(v) \
+ (memset(&C_tm, 0, sizeof(struct tm)), \
+ C_tm.tm_sec = C_unfix(C_block_item(v, 0)), \
+ C_tm.tm_min = C_unfix(C_block_item(v, 1)), \
+ C_tm.tm_hour = C_unfix(C_block_item(v, 2)), \
+ C_tm.tm_mday = C_unfix(C_block_item(v, 3)), \
+ C_tm.tm_mon = C_unfix(C_block_item(v, 4)), \
+ C_tm.tm_year = C_unfix(C_block_item(v, 5)), \
+ C_tm.tm_wday = C_unfix(C_block_item(v, 6)), \
+ C_tm.tm_yday = C_unfix(C_block_item(v, 7)), \
+ C_tm.tm_isdst = (C_block_item(v, 8) != C_SCHEME_FALSE))
+
+#define C_tm_set(v) (C_tm_set_08(v), &C_tm)
+
+#define C_asctime(v) (asctime(C_tm_set(v)))
+#define C_mktime(v) ((C_temporary_flonum = mktime(C_tm_set(v))) != -1)
+
+#define TIME_STRING_MAXLENGTH 255
+static char C_time_string [TIME_STRING_MAXLENGTH + 1];
+#undef TIME_STRING_MAXLENGTH
+
+#define C_strftime(v, f) \
+ (strftime(C_time_string, sizeof(C_time_string), C_c_string(f), C_tm_set(v)) ? C_time_string : NULL)
+
+/*
+ mapping from Win32 error codes to errno
+*/
+
+typedef struct
+{
+ DWORD win32;
+ int libc;
+} errmap_t;
+
+static errmap_t errmap[] =
+{
+ {ERROR_INVALID_FUNCTION, EINVAL},
+ {ERROR_FILE_NOT_FOUND, ENOENT},
+ {ERROR_PATH_NOT_FOUND, ENOENT},
+ {ERROR_TOO_MANY_OPEN_FILES, EMFILE},
+ {ERROR_ACCESS_DENIED, EACCES},
+ {ERROR_INVALID_HANDLE, EBADF},
+ {ERROR_ARENA_TRASHED, ENOMEM},
+ {ERROR_NOT_ENOUGH_MEMORY, ENOMEM},
+ {ERROR_INVALID_BLOCK, ENOMEM},
+ {ERROR_BAD_ENVIRONMENT, E2BIG},
+ {ERROR_BAD_FORMAT, ENOEXEC},
+ {ERROR_INVALID_ACCESS, EINVAL},
+ {ERROR_INVALID_DATA, EINVAL},
+ {ERROR_INVALID_DRIVE, ENOENT},
+ {ERROR_CURRENT_DIRECTORY, EACCES},
+ {ERROR_NOT_SAME_DEVICE, EXDEV},
+ {ERROR_NO_MORE_FILES, ENOENT},
+ {ERROR_LOCK_VIOLATION, EACCES},
+ {ERROR_BAD_NETPATH, ENOENT},
+ {ERROR_NETWORK_ACCESS_DENIED, EACCES},
+ {ERROR_BAD_NET_NAME, ENOENT},
+ {ERROR_FILE_EXISTS, EEXIST},
+ {ERROR_CANNOT_MAKE, EACCES},
+ {ERROR_FAIL_I24, EACCES},
+ {ERROR_INVALID_PARAMETER, EINVAL},
+ {ERROR_NO_PROC_SLOTS, EAGAIN},
+ {ERROR_DRIVE_LOCKED, EACCES},
+ {ERROR_BROKEN_PIPE, EPIPE},
+ {ERROR_DISK_FULL, ENOSPC},
+ {ERROR_INVALID_TARGET_HANDLE, EBADF},
+ {ERROR_INVALID_HANDLE, EINVAL},
+ {ERROR_WAIT_NO_CHILDREN, ECHILD},
+ {ERROR_CHILD_NOT_COMPLETE, ECHILD},
+ {ERROR_DIRECT_ACCESS_HANDLE, EBADF},
+ {ERROR_NEGATIVE_SEEK, EINVAL},
+ {ERROR_SEEK_ON_DEVICE, EACCES},
+ {ERROR_DIR_NOT_EMPTY, ENOTEMPTY},
+ {ERROR_NOT_LOCKED, EACCES},
+ {ERROR_BAD_PATHNAME, ENOENT},
+ {ERROR_MAX_THRDS_REACHED, EAGAIN},
+ {ERROR_LOCK_FAILED, EACCES},
+ {ERROR_ALREADY_EXISTS, EEXIST},
+ {ERROR_FILENAME_EXCED_RANGE, ENOENT},
+ {ERROR_NESTING_NOT_ALLOWED, EAGAIN},
+ {ERROR_NOT_ENOUGH_QUOTA, ENOMEM},
+ {0, 0}
+};
+
+static void C_fcall
+set_errno(DWORD w32err)
+{
+ errmap_t *map = errmap;
+ for (; errmap->win32; ++map)
+ {
+ if (errmap->win32 == w32err)
+ {
+ errno = errmap->libc;
+ return;
+ }
+ }
+}
+
+static int C_fcall
+set_last_errno()
+{
+ set_errno(GetLastError());
+ return 0;
+}
+
+/* Functions for creating process with redirected I/O */
+
+static int C_fcall
+zero_handles()
+{
+ C_rd0 = C_wr0 = C_wr0_ = INVALID_HANDLE_VALUE;
+ C_rd1 = C_wr1 = C_rd1_ = INVALID_HANDLE_VALUE;
+ C_save0 = C_save1 = INVALID_HANDLE_VALUE;
+ return 1;
+}
+
+static int C_fcall
+close_handles()
+{
+ if (C_rd0 != INVALID_HANDLE_VALUE)
+ CloseHandle(C_rd0);
+ if (C_rd1 != INVALID_HANDLE_VALUE)
+ CloseHandle(C_rd1);
+ if (C_wr0 != INVALID_HANDLE_VALUE)
+ CloseHandle(C_wr0);
+ if (C_wr1 != INVALID_HANDLE_VALUE)
+ CloseHandle(C_wr1);
+ if (C_rd1_ != INVALID_HANDLE_VALUE)
+ CloseHandle(C_rd1_);
+ if (C_wr0_ != INVALID_HANDLE_VALUE)
+ CloseHandle(C_wr0_);
+ if (C_save0 != INVALID_HANDLE_VALUE)
+ {
+ SetStdHandle(STD_INPUT_HANDLE, C_save0);
+ CloseHandle(C_save0);
+ }
+ if (C_save1 != INVALID_HANDLE_VALUE)
+ {
+ SetStdHandle(STD_OUTPUT_HANDLE, C_save1);
+ CloseHandle(C_save1);
+ }
+ return zero_handles();
+}
+
+static int C_fcall
+redir_io()
+{
+ SECURITY_ATTRIBUTES sa;
+ sa.nLength = sizeof(SECURITY_ATTRIBUTES);
+ sa.bInheritHandle = TRUE;
+ sa.lpSecurityDescriptor = NULL;
+
+ zero_handles();
+
+ C_save0 = GetStdHandle(STD_INPUT_HANDLE);
+ C_save1 = GetStdHandle(STD_OUTPUT_HANDLE);
+ if (!CreatePipe(&C_rd0, &C_wr0, &sa, 0)
+ || !SetStdHandle(STD_INPUT_HANDLE, C_rd0)
+ || !DuplicateHandle(GetCurrentProcess(), C_wr0, GetCurrentProcess(),
+ &C_wr0_, 0, FALSE, DUPLICATE_SAME_ACCESS)
+ || !CreatePipe(&C_rd1, &C_wr1, &sa, 0)
+ || !SetStdHandle(STD_OUTPUT_HANDLE, C_wr1)
+ || !DuplicateHandle(GetCurrentProcess(), C_rd1, GetCurrentProcess(),
+ &C_rd1_, 0, FALSE, DUPLICATE_SAME_ACCESS))
+ {
+ set_last_errno();
+ close_handles();
+ return 0;
+ }
+
+ CloseHandle(C_wr0);
+ C_wr0 = INVALID_HANDLE_VALUE;
+ CloseHandle(C_rd1);
+ C_rd1 = INVALID_HANDLE_VALUE;
+ return 1;
+}
+
+static int C_fcall
+run_process(char *cmdline)
+{
+ PROCESS_INFORMATION pi;
+ STARTUPINFO si;
+
+ ZeroMemory(&pi, sizeof(PROCESS_INFORMATION));
+ ZeroMemory(&si, sizeof(STARTUPINFO));
+ si.cb = sizeof(STARTUPINFO);
+
+ C_wr0_ = C_rd1_ = INVALID_HANDLE_VALUE; /* these handles are saved */
+
+ if (CreateProcess(NULL, cmdline, NULL, NULL, TRUE, 0, NULL,
+ NULL, &si, &pi))
+ {
+ CloseHandle(pi.hThread);
+
+ SetStdHandle(STD_INPUT_HANDLE, C_save0);
+ SetStdHandle(STD_OUTPUT_HANDLE, C_save1);
+ C_save0 = C_save1 = INVALID_HANDLE_VALUE;
+
+ CloseHandle(C_rd0);
+ CloseHandle(C_wr1);
+ C_rd0 = C_wr1 = INVALID_HANDLE_VALUE;
+ return (int)pi.hProcess;
+ }
+ else
+ return set_last_errno();
+}
+
+static int C_fcall
+pipe_write(int hpipe, void* buf, int count)
+{
+ DWORD done = 0;
+ if (WriteFile((HANDLE)hpipe, buf, count, &done, NULL))
+ return 1;
+ else
+ return set_last_errno();
+}
+
+static int C_fcall
+pipe_read(int hpipe)
+{
+ DWORD done = 0;
+ /* TODO:
+ if (!pipe_ready(hpipe))
+ go_to_sleep;
+ */
+ if (ReadFile((HANDLE)hpipe, &C_rdbuf, 1, &done, NULL))
+ {
+ if (done > 0) /* not EOF yet */
+ return 1;
+ else
+ return -1;
+ }
+ return set_last_errno();
+}
+
+static int C_fcall
+pipe_ready(int hpipe)
+{
+ DWORD avail = 0;
+ if (PeekNamedPipe((HANDLE)hpipe, NULL, 0, NULL, &avail, NULL) && avail)
+ return 1;
+ else
+ {
+ Sleep(0); /* give pipe a chance */
+ if (PeekNamedPipe((HANDLE)hpipe, NULL, 0, NULL, &avail, NULL))
+ return (avail > 0);
+ else
+ return 0;
+ }
+}
+
+#define C_zero_handles() C_fix(zero_handles())
+#define C_close_handles() C_fix(close_handles())
+#define C_redir_io() (redir_io() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
+#define C_run_process(cmdline) C_fix(run_process(C_c_string(cmdline)))
+#define C_pipe_write(h, b, n) (pipe_write(C_unfix(h), C_c_string(b), C_unfix(n)) ? C_SCHEME_TRUE : C_SCHEME_FALSE)
+#define C_pipe_read(h) C_fix(pipe_read(C_unfix(h)))
+#define C_pipe_ready(h) (pipe_ready(C_unfix(h)) ? C_SCHEME_TRUE : C_SCHEME_FALSE)
+#define close_handle(h) CloseHandle((HANDLE)h)
+
+static int C_fcall
+process_wait(int h, int t)
+{
+ if (WaitForSingleObject((HANDLE)h, (t ? 0 : INFINITE)) == WAIT_OBJECT_0)
+ {
+ DWORD ret;
+ if (GetExitCodeProcess((HANDLE)h, &ret))
+ {
+ CloseHandle((HANDLE)h);
+ C_exstatus = ret;
+ return 1;
+ }
+ }
+ return set_last_errno();
+}
+
+#define C_process_wait(p, t) (process_wait(C_unfix(p), C_truep(t)) ? C_SCHEME_TRUE : C_SCHEME_FALSE)
+#define C_sleep(t) (Sleep(C_unfix(t) * 1000), C_SCHEME_UNDEFINED)
+
+static int C_fcall
+get_hostname()
+{
+ /* Do we already have hostname? */
+ if (strlen(C_hostname))
+ {
+ return 1;
+ }
+ else
+ {
+ WSADATA wsa;
+ if (WSAStartup(MAKEWORD(1, 1), &wsa) == 0)
+ {
+ int nok = gethostname(C_hostname, sizeof(C_hostname));
+ WSACleanup();
+ return !nok;
+ }
+ return 0;
+ }
+}
+
+static int C_fcall
+sysinfo()
+{
+ /* Do we need to build the sysinfo? */
+ if (!strlen(C_osrel))
+ {
+ OSVERSIONINFO ovf;
+ ZeroMemory(&ovf, sizeof(ovf));
+ ovf.dwOSVersionInfoSize = sizeof(ovf);
+ if (get_hostname() && GetVersionEx(&ovf))
+ {
+ SYSTEM_INFO si;
+ _snprintf(C_osver, sizeof(C_osver) - 1, "%d.%d.%d",
+ ovf.dwMajorVersion, ovf.dwMinorVersion, ovf.dwBuildNumber);
+ strncpy(C_osrel, "Win", sizeof(C_osrel) - 1);
+ switch (ovf.dwPlatformId)
+ {
+ case VER_PLATFORM_WIN32s:
+ strncpy(C_osrel, "Win32s", sizeof(C_osrel) - 1);
+ break;
+ case VER_PLATFORM_WIN32_WINDOWS:
+ if (ovf.dwMajorVersion == 4)
+ {
+ if (ovf.dwMinorVersion == 0)
+ strncpy(C_osrel, "Win95", sizeof(C_osrel) - 1);
+ else if (ovf.dwMinorVersion == 10)
+ strncpy(C_osrel, "Win98", sizeof(C_osrel) - 1);
+ else if (ovf.dwMinorVersion == 90)
+ strncpy(C_osrel, "WinMe", sizeof(C_osrel) - 1);
+ }
+ break;
+ case VER_PLATFORM_WIN32_NT:
+ C_isNT = 1;
+ if (ovf.dwMajorVersion == 6)
+ strncpy(C_osrel, "WinVista", sizeof(C_osrel) - 1);
+ else if (ovf.dwMajorVersion == 5)
+ {
+ if (ovf.dwMinorVersion == 2)
+ strncpy(C_osrel, "WinServer2003", sizeof(C_osrel) - 1);
+ else if (ovf.dwMinorVersion == 1)
+ strncpy(C_osrel, "WinXP", sizeof(C_osrel) - 1);
+ else if ( ovf.dwMinorVersion == 0)
+ strncpy(C_osrel, "Win2000", sizeof(C_osrel) - 1);
+ }
+ else if (ovf.dwMajorVersion <= 4)
+ strncpy(C_osrel, "WinNT", sizeof(C_osrel) - 1);
+ break;
+ }
+ GetSystemInfo(&si);
+ strncpy(C_processor, "Unknown", sizeof(C_processor) - 1);
+ switch (si.wProcessorArchitecture)
+ {
+ case PROCESSOR_ARCHITECTURE_INTEL:
+ strncpy(C_processor, "x86", sizeof(C_processor) - 1);
+ break;
+# ifdef PROCESSOR_ARCHITECTURE_IA64
+ case PROCESSOR_ARCHITECTURE_IA64:
+ strncpy(C_processor, "IA64", sizeof(C_processor) - 1);
+ break;
+# endif
+# ifdef PROCESSOR_ARCHITECTURE_AMD64
+ case PROCESSOR_ARCHITECTURE_AMD64:
+ strncpy(C_processor, "x64", sizeof(C_processor) - 1);
+ break;
+# endif
+# ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64
+ case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64:
+ strncpy(C_processor, "WOW64", sizeof(C_processor) - 1);
+ break;
+# endif
+ }
+ }
+ else
+ return set_last_errno();
+ }
+ return 1;
+}
+
+static int C_fcall
+get_shlcmd()
+{
+ /* Do we need to build the shell command pathname? */
+ if (!strlen(C_shlcmd))
+ {
+ if (sysinfo())
+ {
+ char *cmdnam = C_isNT ? "\\cmd.exe" : "\\command.com";
+ UINT len = GetSystemDirectory(C_shlcmd, sizeof(C_shlcmd) - strlen(cmdnam));
+ if (len)
+ strcpy(C_shlcmd + len, cmdnam);
+ else
+ return set_last_errno();
+ }
+ else
+ return 0;
+ }
+ return 1;
+}
+
+#define C_get_hostname() (get_hostname() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
+#define C_sysinfo() (sysinfo() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
+#define C_get_shlcmd() (get_shlcmd() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
+
+/* GetUserName */
+
+static int C_fcall
+get_user_name()
+{
+ if (!strlen(C_username))
+ {
+ DWORD bufCharCount = sizeof(C_username) / sizeof(C_username[0]);
+ if (!GetUserName(C_username, &bufCharCount))
+ return set_last_errno();
+ }
+ return 1;
+}
+
+#define C_get_user_name() (get_user_name() ? C_SCHEME_TRUE : C_SCHEME_FALSE)
+
+/* User Information */
+
+#if 0
+static int C_fcall
+get_netinfo()
+{
+ HINSTANCE hNet = 0,
+ hLoc = 0;
+
+ if (isNT)
+ hNet = LoadLibrary("netapi32.dll");
+ else
+ {
+ hLoc = LoadLibrary("rlocal32.dll");
+ hNet = LoadLibrary("radmin32.dll");
+ //hNet = LoadLibrary("netapi.dll");
+ }
+
+ if (!hNet)
+ return 0;
+
+
+}
+#endif
+
+/*
+ Spawn a process directly.
+ Params:
+ app Command to execute.
+ cmdlin Command line (arguments).
+ env Environment for the new process (may be NULL).
+ handle, stdin, stdout, stderr
+ Spawned process info are returned in integers.
+ When spawned process shares standard io stream with the parent
+ process the respective value in handle, stdin, stdout, stderr
+ is -1.
+ params A bitmask controling operation.
+ Bit 1: Child & parent share standard input if this bit is set.
+ Bit 2: Share standard output if bit is set.
+ Bit 3: Share standard error if bit is set.
+
+ Returns: zero return value indicates failure.
+*/
+static int C_fcall
+C_process(const char * app, const char * cmdlin, const char ** env,
+ int * phandle,
+ int * pstdin_fd, int * pstdout_fd, int * pstderr_fd,
+ int params)
+{
+ int i;
+ int success = TRUE;
+ const int f_share_io[3] = { params & 1, params & 2, params & 4};
+ int io_fds[3] = { -1, -1, -1 };
+ HANDLE
+ child_io_handles[3] = { NULL, NULL, NULL },
+ standard_io_handles[3] = {
+ GetStdHandle(STD_INPUT_HANDLE),
+ GetStdHandle(STD_OUTPUT_HANDLE),
+ GetStdHandle(STD_ERROR_HANDLE)};
+ const char modes[3] = "rww";
+ HANDLE cur_process = GetCurrentProcess(), child_process = NULL;
+ void* envblk = NULL;
+
+ /****** create io handles & fds ***/
+
+ for (i=0; i<3 && success; ++i)
+ {
+ if (f_share_io[i])
+ {
+ success = DuplicateHandle(
+ cur_process, standard_io_handles[i],
+ cur_process, &child_io_handles[i],
+ 0, FALSE, DUPLICATE_SAME_ACCESS);
+ }
+ else
+ {
+ HANDLE a, b;
+ success = CreatePipe(&a,&b,NULL,0);
+ if(success)
+ {
+ HANDLE parent_end;
+ if (modes[i]=='r') { child_io_handles[i]=a; parent_end=b; }
+ else { parent_end=a; child_io_handles[i]=b; }
+ success = (io_fds[i] = _open_osfhandle((long)parent_end,0)) >= 0;
+ }
+ }
+ }
+
+ /****** make handles inheritable */
+
+ for (i=0; i<3 && success; ++i)
+ success = SetHandleInformation(child_io_handles[i], HANDLE_FLAG_INHERIT, -1);
+
+#if 0 /* Requires a sorted list by key! */
+ /****** create environment block if necessary ****/
+
+ if (env && success)
+ {
+ char** p;
+ int len = 0;
+
+ for (p = env; *p; ++p) len += strlen(*p) + 1;
+
+ if (envblk = C_malloc(len + 1))
+ {
+ char* pb = (char*)envblk;
+ for (p = env; *p; ++p)
+ {
+ strcpy(pb, *p);
+ pb += strlen(*p) + 1;
+ }
+ *pb = '\0';
+ }
+ else
+ success = FALSE;
+ }
+#endif
+
+ /****** finally spawn process ****/
+
+ if (success)
+ {
+ PROCESS_INFORMATION pi;
+ STARTUPINFO si;
+
+ ZeroMemory(&pi,sizeof pi);
+ ZeroMemory(&si,sizeof si);
+ si.cb = sizeof si;
+ si.dwFlags = STARTF_USESTDHANDLES;
+ si.hStdInput = child_io_handles[0];
+ si.hStdOutput = child_io_handles[1];
+ si.hStdError = child_io_handles[2];
+
+ /* FIXME passing 'app' param causes failure & possible stack corruption */
+ success = CreateProcess(
+ NULL, (char*)cmdlin, NULL, NULL, TRUE, 0, envblk, NULL, &si, &pi);
+
+ if (success)
+ {
+ child_process=pi.hProcess;
+ CloseHandle(pi.hThread);
+ }
+ else
+ set_last_errno();
+ }
+ else
+ set_last_errno();
+
+ /****** cleanup & return *********/
+
+ /* parent must close child end */
+ for (i=0; i<3; ++i) CloseHandle(child_io_handles[i]);
+
+ if (success)
+ {
+ *phandle = (int)child_process;
+ *pstdin_fd = io_fds[0];
+ *pstdout_fd = io_fds[1];
+ *pstderr_fd = io_fds[2];
+ }
+ else
+ {
+ for (i=0; i<3; ++i) _close(io_fds[i]);
+ }
+
+ return success;
+}
+EOF
+) )
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ (no-bound-checks)
+ (no-procedure-checks-for-usual-bindings)
+ (bound-to-procedure
+ ##sys#make-port ##sys#file-info ##sys#update-errno ##sys#fudge ##sys#make-c-string ##sys#check-port
+ ##sys#error ##sys#signal-hook ##sys#peek-unsigned-integer ##sys#process
+ ##sys#peek-fixnum ##sys#make-structure ##sys#check-structure ##sys#enable-interrupts) ) ] )
+
+(include "unsafe-declarations.scm")
+
+(register-feature! 'posix)
+
+(define posix-error
+ (let ([strerror (foreign-lambda c-string "strerror" int)]
+ [string-append string-append] )
+ (lambda (type loc msg . args)
+ (let ([rn (##sys#update-errno)])
+ (apply ##sys#signal-hook type loc (string-append msg " - " (strerror rn)) args) ) ) ) )
+
+(define ##sys#posix-error posix-error)
+
+
+;;; Lo-level I/O:
+
+(define-foreign-variable _pipe_buf int "PIPE_BUF")
+
+(define pipe/buf _pipe_buf)
+
+(define-foreign-variable _o_rdonly int "O_RDONLY")
+(define-foreign-variable _o_wronly int "O_WRONLY")
+(define-foreign-variable _o_rdwr int "O_RDWR")
+(define-foreign-variable _o_creat int "O_CREAT")
+(define-foreign-variable _o_append int "O_APPEND")
+(define-foreign-variable _o_excl int "O_EXCL")
+(define-foreign-variable _o_trunc int "O_TRUNC")
+(define-foreign-variable _o_binary int "O_BINARY")
+(define-foreign-variable _o_text int "O_TEXT")
+(define-foreign-variable _o_noinherit int "O_NOINHERIT")
+
+(define open/rdonly _o_rdonly)
+(define open/wronly _o_wronly)
+(define open/rdwr _o_rdwr)
+(define open/read _o_rdwr)
+(define open/write _o_wronly)
+(define open/creat _o_creat)
+(define open/append _o_append)
+(define open/excl _o_excl)
+(define open/trunc _o_trunc)
+(define open/binary _o_binary)
+(define open/text _o_text)
+(define open/noinherit _o_noinherit)
+
+(define-foreign-variable _s_irusr int "S_IREAD")
+(define-foreign-variable _s_iwusr int "S_IWRITE")
+(define-foreign-variable _s_ixusr int "S_IEXEC")
+(define-foreign-variable _s_irgrp int "S_IREAD")
+(define-foreign-variable _s_iwgrp int "S_IWRITE")
+(define-foreign-variable _s_ixgrp int "S_IEXEC")
+(define-foreign-variable _s_iroth int "S_IREAD")
+(define-foreign-variable _s_iwoth int "S_IWRITE")
+(define-foreign-variable _s_ixoth int "S_IEXEC")
+(define-foreign-variable _s_irwxu int "S_IREAD | S_IWRITE | S_IEXEC")
+(define-foreign-variable _s_irwxg int "S_IREAD | S_IWRITE | S_IEXEC")
+(define-foreign-variable _s_irwxo int "S_IREAD | S_IWRITE | S_IEXEC")
+
+(define perm/irusr _s_irusr)
+(define perm/iwusr _s_iwusr)
+(define perm/ixusr _s_ixusr)
+(define perm/irgrp _s_irgrp)
+(define perm/iwgrp _s_iwgrp)
+(define perm/ixgrp _s_ixgrp)
+(define perm/iroth _s_iroth)
+(define perm/iwoth _s_iwoth)
+(define perm/ixoth _s_ixoth)
+(define perm/irwxu _s_irwxu)
+(define perm/irwxg _s_irwxg)
+(define perm/irwxo _s_irwxo)
+
+(define file-open
+ (let ([defmode (bitwise-ior _s_irwxu (fxior _s_irgrp _s_iroth))] )
+ (lambda (filename flags . mode)
+ (let ([mode (if (pair? mode) (car mode) defmode)])
+ (##sys#check-string filename 'file-open)
+ (##sys#check-exact flags 'file-open)
+ (##sys#check-exact mode 'file-open)
+ (let ([fd (##core#inline "C_open" (##sys#make-c-string (##sys#expand-home-path filename)) flags mode)])
+ (when (eq? -1 fd)
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error 'file-open "cannot open file" filename flags mode) )
+ fd) ) ) ) )
+
+(define file-close
+ (lambda (fd)
+ (##sys#check-exact fd 'file-close)
+ (when (fx< (##core#inline "C_close" fd) 0)
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error 'file-close "cannot close file" fd) ) ) )
+
+(define file-read
+ (let ([make-string make-string] )
+ (lambda (fd size . buffer)
+ (##sys#check-exact fd 'file-read)
+ (##sys#check-exact size 'file-read)
+ (let ([buf (if (pair? buffer) (car buffer) (make-string size))])
+ (unless (and (##core#inline "C_blockp" buf) (##core#inline "C_byteblockp" buf))
+ (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or blob" buf) )
+ (let ([n (##core#inline "C_read" fd buf size)])
+ (when (eq? -1 n)
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error 'file-read "cannot read from file" fd size) )
+ (list buf n) ) ) ) ) )
+
+(define file-write
+ (lambda (fd buffer . size)
+ (##sys#check-exact fd 'file-write)
+ (unless (and (##core#inline "C_blockp" buffer) (##core#inline "C_byteblockp" buffer))
+ (##sys#signal-hook #:type-error 'file-write "bad argument type - not a string or blob" buffer) )
+ (let ([size (if (pair? size) (car size) (##sys#size buffer))])
+ (##sys#check-exact size 'file-write)
+ (let ([n (##core#inline "C_write" fd buffer size)])
+ (when (eq? -1 n)
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error 'file-write "cannot write to file" fd size) )
+ n) ) ) )
+
+(define file-mkstemp
+ (let ([string-length string-length])
+ (lambda (template)
+ (##sys#check-string template 'file-mkstemp)
+ (let* ([buf (##sys#make-c-string template)]
+ [fd (##core#inline "C_mkstemp" buf)]
+ [path-length (string-length buf)])
+ (when (eq? -1 fd)
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error 'file-mkstemp "cannot create temporary file" template) )
+ (values fd (##sys#substring buf 0 (fx- path-length 1) ) ) ) ) ) )
+
+
+;;; File attribute access:
+
+(define-foreign-variable _seek_set int "SEEK_SET")
+(define-foreign-variable _seek_cur int "SEEK_CUR")
+(define-foreign-variable _seek_end int "SEEK_END")
+
+(define seek/set _seek_set)
+(define seek/end _seek_end)
+(define seek/cur _seek_cur)
+
+(define-foreign-variable _stat_st_ino unsigned-int "C_statbuf.st_ino")
+(define-foreign-variable _stat_st_nlink unsigned-int "C_statbuf.st_nlink")
+(define-foreign-variable _stat_st_gid unsigned-int "C_statbuf.st_gid")
+(define-foreign-variable _stat_st_size unsigned-int "C_statbuf.st_size")
+(define-foreign-variable _stat_st_mtime double "C_statbuf.st_mtime")
+(define-foreign-variable _stat_st_atime double "C_statbuf.st_atime")
+(define-foreign-variable _stat_st_ctime double "C_statbuf.st_ctime")
+(define-foreign-variable _stat_st_uid unsigned-int "C_statbuf.st_uid")
+(define-foreign-variable _stat_st_mode unsigned-int "C_statbuf.st_mode")
+
+(define (##sys#stat file)
+ (let ([r (cond [(fixnum? file) (##core#inline "C_fstat" file)]
+ [(string? file) (##core#inline "C_stat" (##sys#make-c-string (##sys#expand-home-path file)))]
+ [else (##sys#signal-hook #:type-error "bad argument type - not a fixnum or string" file)] ) ] )
+ (when (fx< r 0)
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error "cannot access file" file) ) ) )
+
+(define (file-stat f #!optional link)
+ (##sys#stat f)
+ (vector _stat_st_ino _stat_st_mode _stat_st_nlink
+ _stat_st_uid _stat_st_gid _stat_st_size
+ _stat_st_atime _stat_st_ctime _stat_st_mtime
+ 0 0 0 0) )
+
+(define (file-size f) (##sys#stat f) _stat_st_size)
+(define (file-modification-time f) (##sys#stat f) _stat_st_mtime)
+(define (file-access-time f) (##sys#stat f) _stat_st_atime)
+(define (file-change-time f) (##sys#stat f) _stat_st_ctime)
+(define (file-owner f) (##sys#stat f) _stat_st_uid)
+(define (file-permissions f) (##sys#stat f) _stat_st_mode)
+
+(define (regular-file? fname)
+ (##sys#check-string fname 'regular-file?)
+ (let ((info (##sys#file-info (##sys#expand-home-path fname))))
+ (and info (fx= 0 (##sys#slot info 4))) ) )
+
+(define (symbolic-link? fname)
+ (##sys#check-string fname 'symbolic-link?)
+ #f)
+
+(let ((stat-type
+ (lambda (name)
+ (lambda (fname)
+ (##sys#check-string fname name)
+ #f))))
+ (set! stat-regular? regular-file?) ; DEPRECATED
+ (set! stat-directory? (stat-type 'stat-directory?)) ; DEPRECATED
+ (set! stat-device? (stat-type 'stat-char-device?)) ; DEPRECATED
+ (set! character-device? (stat-type 'character-device?))
+ (set! block-device? (stat-type 'block-device?))
+ (set! stat-block-device? (stat-type 'stat-block-device?)) ; DEPRECATED
+ (set! stat-fifo? (stat-type 'stat-fifo?)) ; DEPRECATED
+ (set! fifo? (stat-type 'fifo?))
+ (set! stat-symlink? (stat-type 'stat-symlink?)) ; DEPRECATED
+ (set! socket? (stat-type 'socket?))
+ (set! stat-socket? (stat-type 'stat-socket?))) ; DEPRECATED
+
+(define set-file-position!
+ (lambda (port pos . whence)
+ (let ((whence (if (pair? whence) (car whence) _seek_set)))
+ (##sys#check-exact pos 'set-file-position!)
+ (##sys#check-exact whence 'set-file-position!)
+ (when (negative? pos)
+ (##sys#signal-hook #:bounds-error 'set-file-position! "invalid negative port position" pos port))
+ (unless (cond ((port? port)
+ (and (eq? (##sys#slot port 7) 'stream)
+ (##core#inline "C_fseek" port pos whence) ) )
+ ((fixnum? port)
+ (##core#inline "C_lseek" port pos whence))
+ (else
+ (##sys#signal-hook #:type-error 'set-file-position! "invalid file" port)) )
+ (posix-error #:file-error 'set-file-position! "cannot set file position" port pos) ) ) ) )
+
+(define file-position
+ (getter-with-setter
+ (lambda (port)
+ (let ((pos (cond ((port? port)
+ (if (eq? (##sys#slot port 7) 'stream)
+ (##core#inline "C_ftell" port)
+ -1) )
+ ((fixnum? port)
+ (##core#inline "C_lseek" port 0 _seek_cur))
+ (else
+ (##sys#signal-hook #:type-error 'file-position "invalid file" port)) ) ) )
+ (when (< pos 0)
+ (posix-error #:file-error 'file-position "cannot retrieve file position of port" port) )
+ pos) )
+ set-file-position!) ) ; doesn't accept WHENCE
+
+
+;;; Directory stuff:
+
+(define-inline (create-directory-helper name)
+ (unless (fx= 0 (##core#inline "C_mkdir" (##sys#make-c-string name)))
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error 'create-directory
+ "cannot create directory" name)))
+
+(define-inline (create-directory-check name)
+ (if (file-exists? name)
+ (let ((i (##sys#file-info name)))
+ (and i
+ (fx= 1 (##sys#slot i 4))))
+ #f))
+
+(define-inline (create-directory-helper-silent name)
+ (unless (create-directory-check name)
+ (create-directory-helper name)))
+
+(define-inline (create-directory-helper-parents name)
+ (let* ((l (string-split name "\\"))
+ (c (car l)))
+ (for-each
+ (lambda (x)
+ (set! c (string-append c "\\" x))
+ (create-directory-helper-silent c))
+ (cdr l))))
+
+(define create-directory
+ (lambda (name #!optional parents?)
+ (##sys#check-string name 'create-directory)
+ (let ((name (##sys#expand-home-path name)))
+ (if parents?
+ (create-directory-helper-parents name)
+ (create-directory-helper name)))) )
+
+(define change-directory
+ (lambda (name)
+ (##sys#check-string name 'change-directory)
+ (unless (fx= 0 (##core#inline "C_chdir" (##sys#make-c-string (##sys#expand-home-path name))))
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error 'change-directory "cannot change current directory" name) ) ) )
+
+(define delete-directory
+ (lambda (name)
+ (##sys#check-string name 'delete-directory)
+ (unless (fx= 0 (##core#inline "C_rmdir" (##sys#make-c-string (##sys#expand-home-path name))))
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error 'delete-directory "cannot delete directory" name) ) ) )
+
+(define directory
+ (let ([string-append string-append]
+ [make-string make-string]
+ [string string])
+ (lambda (#!optional (spec (current-directory)) show-dotfiles?)
+ (##sys#check-string spec 'directory)
+ (let ([buffer (make-string 256)]
+ [handle (##sys#make-pointer)]
+ [entry (##sys#make-pointer)] )
+ (##core#inline "C_opendir" (##sys#make-c-string (##sys#expand-home-path spec)) handle)
+ (if (##sys#null-pointer? handle)
+ (begin
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error 'directory "cannot open directory" spec) )
+ (let loop ()
+ (##core#inline "C_readdir" handle entry)
+ (if (##sys#null-pointer? entry)
+ (begin
+ (##core#inline "C_closedir" handle)
+ '() )
+ (let* ([flen (##core#inline "C_foundfile" entry buffer)]
+ [file (##sys#substring buffer 0 flen)]
+ [char1 (string-ref file 0)]
+ [char2 (and (> flen 1) (string-ref file 1))] )
+ (if (and (eq? char1 #\.)
+ (or (not char2)
+ (and (eq? char2 #\.) (eq? flen 2))
+ (not show-dotfiles?) ) )
+ (loop)
+ (cons file (loop)) ) ) ) ) ) ) ) ) )
+
+(define (directory? fname)
+ (##sys#check-string fname 'directory?)
+ (let ((info (##sys#file-info
+ (##sys#platform-fixup-pathname (##sys#expand-home-path fname)))))
+ (and info (fx= 1 (##sys#slot info 4))) ) )
+
+(define current-directory
+ (let ([make-string make-string])
+ (lambda (#!optional dir)
+ (if dir
+ (change-directory dir)
+ (let* ([buffer (make-string 256)]
+ [len (##core#inline "C_curdir" buffer)] )
+ (##sys#update-errno)
+ (if len
+ (##sys#substring buffer 0 len)
+ (##sys#signal-hook #:file-error 'current-directory "cannot retrieve current directory") ) ) ) ) ) )
+
+
+(define canonical-path ;;DEPRECATED
+ (let ((null? null?)
+ (char=? char=?)
+ (string=? string=?)
+ (alpha? char-alphabetic?)
+ (sref string-ref)
+ (ssplit (cut string-split <> "/\\"))
+ (sappend string-append)
+ (isperse (cut string-intersperse <> "\\"))
+ (sep? (lambda (c) (or (char=? #\/ c) (char=? #\\ c))))
+ (user current-user-name)
+ (cwd (let ((cw current-directory))
+ (lambda ()
+ (condition-case (cw)
+ (var () "c:\\"))))))
+ (lambda (path)
+ (##sys#check-string path 'canonical-path)
+ (let ((p (cond ((fx= 0 (##sys#size path))
+ (sappend (cwd) "\\"))
+ ((and (fx< (##sys#size path) 3)
+ (sep? (sref path 0)))
+ (sappend
+ (##sys#substring (cwd) 0 2)
+ path))
+ ((fx= 1 (##sys#size path))
+ (sappend (cwd) "\\" path))
+ ((and (char=? #\~ (sref path 0))
+ (sep? (sref path 1)))
+ (sappend
+ (##sys#substring (cwd) 0 3)
+ "Documents and Settings\\"
+ (user)
+ (##sys#substring path 1
+ (##sys#size path))))
+ ((fx= 2 (##sys#size path))
+ (sappend (cwd) "\\" path))
+ ((and (alpha? (sref path 0))
+ (char=? #\: (sref path 1))
+ (sep? (sref path 2)))
+ path)
+ ((and (char=? #\/ (sref path 0))
+ (alpha? (sref path 1))
+ (char=? #\: (sref path 2)))
+ (sappend
+ (##sys#substring path 1 3)
+ "\\"
+ (##sys#substring path 3
+ (##sys#size path))))
+ ((sep? (sref path 0))
+ (sappend
+ (##sys#substring (cwd) 0 2)
+ path))
+ (else
+ (sappend (cwd) "\\" path)))))
+ (let loop ((l (ssplit (##sys#substring p 3 (##sys#size p))))
+ (r '()))
+ (if (null? l)
+ (if (null? r)
+ (##sys#substring p 0 3)
+ (if (sep? (sref p (- (##sys#size p) 1)))
+ (sappend
+ (##sys#substring p 0 3)
+ (isperse (reverse (cons "" r))))
+ (sappend
+ (##sys#substring p 0 3)
+ (isperse (reverse r)))))
+ (loop
+ (cdr l)
+ (if (string=? ".." (car l))
+ (cdr r)
+ (if (string=? "." (car l))
+ r
+ (cons (car l) r))))))))))
+
+
+;;; Pipes:
+
+(let ()
+ (define (mode arg) (if (pair? arg) (##sys#slot arg 0) '###text))
+ (define (badmode m) (##sys#error "illegal input/output mode specifier" m))
+ (define (check cmd inp r)
+ (##sys#update-errno)
+ (if (##sys#null-pointer? r)
+ (##sys#signal-hook #:file-error "cannot open pipe" cmd)
+ (let ([port (##sys#make-port inp ##sys#stream-port-class "(pipe)" 'stream)])
+ (##core#inline "C_set_file_ptr" port r)
+ port) ) )
+ (set! open-input-pipe
+ (lambda (cmd . m)
+ (##sys#check-string cmd 'open-input-pipe)
+ (let ([m (mode m)])
+ (check
+ cmd #t
+ (case m
+ ((###text) (##core#inline_allocate ("open_text_input_pipe" 2) (##sys#make-c-string cmd)))
+ ((###binary) (##core#inline_allocate ("open_binary_input_pipe" 2) (##sys#make-c-string cmd)))
+ (else (badmode m)) ) ) ) ) )
+ (set! open-output-pipe
+ (lambda (cmd . m)
+ (##sys#check-string cmd 'open-output-pipe)
+ (let ((m (mode m)))
+ (check
+ cmd #f
+ (case m
+ ((###text) (##core#inline_allocate ("open_text_output_pipe" 2) (##sys#make-c-string cmd)))
+ ((###binary) (##core#inline_allocate ("open_binary_output_pipe" 2) (##sys#make-c-string cmd)))
+ (else (badmode m)) ) ) ) ) )
+ (set! close-input-pipe
+ (lambda (port)
+ (##sys#check-port port 'close-input-pipe)
+ (let ((r (##core#inline "close_pipe" port)))
+ (##sys#update-errno)
+ (when (eq? -1 r) (##sys#signal-hook #:file-error 'close-input-pipe "error while closing pipe" port)) ) ) )
+ (set! close-output-pipe close-input-pipe) )
+
+(let ([open-input-pipe open-input-pipe]
+ [open-output-pipe open-output-pipe]
+ [close-input-pipe close-input-pipe]
+ [close-output-pipe close-output-pipe] )
+ (set! call-with-input-pipe
+ (lambda (cmd proc . mode)
+ (let ([p (apply open-input-pipe cmd mode)])
+ (##sys#call-with-values
+ (lambda () (proc p))
+ (lambda results
+ (close-input-pipe p)
+ (apply values results) ) ) ) ) )
+ (set! call-with-output-pipe
+ (lambda (cmd proc . mode)
+ (let ([p (apply open-output-pipe cmd mode)])
+ (##sys#call-with-values
+ (lambda () (proc p))
+ (lambda results
+ (close-output-pipe p)
+ (apply values results) ) ) ) ) )
+ (set! with-input-from-pipe
+ (lambda (cmd thunk . mode)
+ (let ([old ##sys#standard-input]
+ [p (apply open-input-pipe cmd mode)] )
+ (set! ##sys#standard-input p)
+ (##sys#call-with-values thunk
+ (lambda results
+ (close-input-pipe p)
+ (set! ##sys#standard-input old)
+ (apply values results) ) ) ) ) )
+ (set! with-output-to-pipe
+ (lambda (cmd thunk . mode)
+ (let ([old ##sys#standard-output]
+ [p (apply open-output-pipe cmd mode)] )
+ (set! ##sys#standard-output p)
+ (##sys#call-with-values thunk
+ (lambda results
+ (close-output-pipe p)
+ (set! ##sys#standard-output old)
+ (apply values results) ) ) ) ) ) )
+
+
+;;; Pipe primitive:
+
+(define-foreign-variable _pipefd0 int "C_pipefds[ 0 ]")
+(define-foreign-variable _pipefd1 int "C_pipefds[ 1 ]")
+
+(define create-pipe
+ (lambda (#!optional (mode (fxior open/binary open/noinherit)))
+ (when (fx< (##core#inline "C_pipe" #f mode) 0)
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error 'create-pipe "cannot create pipe") )
+ (values _pipefd0 _pipefd1) ) )
+
+;;; Signal processing:
+
+(define-foreign-variable _nsig int "NSIG")
+(define-foreign-variable _sigterm int "SIGTERM")
+(define-foreign-variable _sigint int "SIGINT")
+(define-foreign-variable _sigfpe int "SIGFPE")
+(define-foreign-variable _sigill int "SIGILL")
+(define-foreign-variable _sigsegv int "SIGSEGV")
+(define-foreign-variable _sigabrt int "SIGABRT")
+(define-foreign-variable _sigbreak int "SIGBREAK")
+
+(define signal/term _sigterm)
+(define signal/int _sigint)
+(define signal/fpe _sigfpe)
+(define signal/ill _sigill)
+(define signal/segv _sigsegv)
+(define signal/abrt _sigabrt)
+(define signal/break _sigbreak)
+(define signal/alrm 0)
+(define signal/chld 0)
+(define signal/cont 0)
+(define signal/hup 0)
+(define signal/io 0)
+(define signal/kill 0)
+(define signal/pipe 0)
+(define signal/prof 0)
+(define signal/quit 0)
+(define signal/stop 0)
+(define signal/trap 0)
+(define signal/tstp 0)
+(define signal/urg 0)
+(define signal/usr1 0)
+(define signal/usr2 0)
+(define signal/vtalrm 0)
+(define signal/winch 0)
+(define signal/xcpu 0)
+(define signal/xfsz 0)
+
+(define signals-list
+ (list
+ signal/term signal/int signal/fpe signal/ill
+ signal/segv signal/abrt signal/break))
+
+(let ([oldhook ##sys#interrupt-hook]
+ [sigvector (make-vector 256 #f)] )
+ (set! signal-handler
+ (lambda (sig)
+ (##sys#check-exact sig 'signal-handler)
+ (##sys#slot sigvector sig) ) )
+ (set! set-signal-handler!
+ (lambda (sig proc)
+ (##sys#check-exact sig 'set-signal-handler!)
+ (##core#inline "C_establish_signal_handler" sig (and proc sig))
+ (vector-set! sigvector sig proc) ) )
+ (set! ##sys#interrupt-hook
+ (lambda (reason state)
+ (let ([h (##sys#slot sigvector reason)])
+ (if h
+ (begin
+ (h reason)
+ (##sys#context-switch state) )
+ (oldhook reason state) ) ) ) ) )
+
+;;; More errno codes:
+
+(define-foreign-variable _errno int "errno")
+
+(define-foreign-variable _eperm int "EPERM")
+(define-foreign-variable _enoent int "ENOENT")
+(define-foreign-variable _esrch int "ESRCH")
+(define-foreign-variable _eintr int "EINTR")
+(define-foreign-variable _eio int "EIO")
+(define-foreign-variable _enoexec int "ENOEXEC")
+(define-foreign-variable _ebadf int "EBADF")
+(define-foreign-variable _echild int "ECHILD")
+(define-foreign-variable _enomem int "ENOMEM")
+(define-foreign-variable _eacces int "EACCES")
+(define-foreign-variable _efault int "EFAULT")
+(define-foreign-variable _ebusy int "EBUSY")
+(define-foreign-variable _eexist int "EEXIST")
+(define-foreign-variable _enotdir int "ENOTDIR")
+(define-foreign-variable _eisdir int "EISDIR")
+(define-foreign-variable _einval int "EINVAL")
+(define-foreign-variable _emfile int "EMFILE")
+(define-foreign-variable _enospc int "ENOSPC")
+(define-foreign-variable _espipe int "ESPIPE")
+(define-foreign-variable _epipe int "EPIPE")
+(define-foreign-variable _eagain int "EAGAIN")
+(define-foreign-variable _erofs int "EROFS")
+(define-foreign-variable _enxio int "ENXIO")
+(define-foreign-variable _e2big int "E2BIG")
+(define-foreign-variable _exdev int "EXDEV")
+(define-foreign-variable _enodev int "ENODEV")
+(define-foreign-variable _enfile int "ENFILE")
+(define-foreign-variable _enotty int "ENOTTY")
+(define-foreign-variable _efbig int "EFBIG")
+(define-foreign-variable _emlink int "EMLINK")
+(define-foreign-variable _edom int "EDOM")
+(define-foreign-variable _erange int "ERANGE")
+(define-foreign-variable _edeadlk int "EDEADLK")
+(define-foreign-variable _enametoolong int "ENAMETOOLONG")
+(define-foreign-variable _enolck int "ENOLCK")
+(define-foreign-variable _enosys int "ENOSYS")
+(define-foreign-variable _enotempty int "ENOTEMPTY")
+(define-foreign-variable _eilseq int "EILSEQ")
+
+(define errno/perm _eperm)
+(define errno/noent _enoent)
+(define errno/srch _esrch)
+(define errno/intr _eintr)
+(define errno/io _eio)
+(define errno/noexec _enoexec)
+(define errno/badf _ebadf)
+(define errno/child _echild)
+(define errno/nomem _enomem)
+(define errno/acces _eacces)
+(define errno/fault _efault)
+(define errno/busy _ebusy)
+(define errno/exist _eexist)
+(define errno/notdir _enotdir)
+(define errno/isdir _eisdir)
+(define errno/inval _einval)
+(define errno/mfile _emfile)
+(define errno/nospc _enospc)
+(define errno/spipe _espipe)
+(define errno/pipe _epipe)
+(define errno/again _eagain)
+(define errno/rofs _erofs)
+(define errno/nxio _enxio)
+(define errno/2big _e2big)
+(define errno/xdev _exdev)
+(define errno/nodev _enodev)
+(define errno/nfile _enfile)
+(define errno/notty _enotty)
+(define errno/fbig _efbig)
+(define errno/mlink _emlink)
+(define errno/dom _edom)
+(define errno/range _erange)
+(define errno/deadlk _edeadlk)
+(define errno/nametoolong _enametoolong)
+(define errno/nolck _enolck)
+(define errno/nosys _enosys)
+(define errno/notempty _enotempty)
+(define errno/ilseq _eilseq)
+
+;;; Permissions and owners:
+
+(define change-file-mode
+ (lambda (fname m)
+ (##sys#check-string fname 'change-file-mode)
+ (##sys#check-exact m 'change-file-mode)
+ (when (fx< (##core#inline "C_chmod" (##sys#make-c-string (##sys#expand-home-path fname)) m) 0)
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error 'change-file-mode "cannot change file mode" fname m) ) ) )
+
+(define-foreign-variable _r_ok int "2")
+(define-foreign-variable _w_ok int "4")
+(define-foreign-variable _x_ok int "2")
+
+(let ()
+ (define (check filename acc loc)
+ (##sys#check-string filename loc)
+ (let ([r (fx= 0 (##core#inline "C_access" (##sys#make-c-string (##sys#expand-home-path filename)) acc))])
+ (unless r (##sys#update-errno))
+ r) )
+ (set! file-read-access? (lambda (filename) (check filename _r_ok 'file-read-access?)))
+ (set! file-write-access? (lambda (filename) (check filename _w_ok 'file-write-access?)))
+ (set! file-execute-access? (lambda (filename) (check filename _x_ok 'file-execute-access?))) )
+
+(define-foreign-variable _filename_max int "FILENAME_MAX")
+
+;;; Using file-descriptors:
+
+(define-foreign-variable _stdin_fileno int "0")
+(define-foreign-variable _stdout_fileno int "1")
+(define-foreign-variable _stderr_fileno int "2")
+
+(define fileno/stdin _stdin_fileno)
+(define fileno/stdout _stdout_fileno)
+(define fileno/stderr _stderr_fileno)
+
+(let ()
+ (define (mode inp m)
+ (##sys#make-c-string
+ (cond [(pair? m)
+ (let ([m (car m)])
+ (case m
+ [(###append) (if (not inp) "a" (##sys#error "invalid mode for input file" m))]
+ [else (##sys#error "invalid mode argument" m)] ) ) ]
+ [inp "r"]
+ [else "w"] ) ) )
+ (define (check fd inp r)
+ (##sys#update-errno)
+ (if (##sys#null-pointer? r)
+ (##sys#signal-hook #:file-error "cannot open file" fd)
+ (let ([port (##sys#make-port inp ##sys#stream-port-class "(fdport)" 'stream)])
+ (##core#inline "C_set_file_ptr" port r)
+ port) ) )
+ (set! open-input-file*
+ (lambda (fd . m)
+ (##sys#check-exact fd 'open-input-file*)
+ (check fd #t (##core#inline_allocate ("C_fdopen" 2) fd (mode #t m))) ) )
+ (set! open-output-file*
+ (lambda (fd . m)
+ (##sys#check-exact fd 'open-output-file*)
+ (check fd #f (##core#inline_allocate ("C_fdopen" 2) fd (mode #f m)) ) ) ) )
+
+(define port->fileno
+ (lambda (port)
+ (##sys#check-port port 'port->fileno)
+ (if (not (zero? (##sys#peek-unsigned-integer port 0)))
+ (let ([fd (##core#inline "C_C_fileno" port)])
+ (when (fx< fd 0)
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error 'port->fileno "cannot access file-descriptor of port" port) )
+ fd)
+ (##sys#signal-hook #:type-error 'port->fileno "port has no attached file" port) ) ) )
+
+(define duplicate-fileno
+ (lambda (old . new)
+ (##sys#check-exact old duplicate-fileno)
+ (let ([fd (if (null? new)
+ (##core#inline "C_dup" old)
+ (let ([n (car new)])
+ (##sys#check-exact n 'duplicate-fileno)
+ (##core#inline "C_dup2" old n) ) ) ] )
+ (when (fx< fd 0)
+ (##sys#update-errno)
+ (##sys#signal-hook #:file-error 'duplicate-fileno "cannot duplicate file descriptor" old) )
+ fd) ) )
+
+
+;;; Environment access:
+
+(define setenv
+ (lambda (var val)
+ (##sys#check-string var 'setenv)
+ (##sys#check-string val 'setenv)
+ (##core#inline "C_setenv" (##sys#make-c-string var) (##sys#make-c-string val))
+ (##core#undefined) ) )
+
+(define (unsetenv var)
+ (##sys#check-string var 'unsetenv)
+ (##core#inline "C_putenv" (##sys#make-c-string var))
+ (##core#undefined) )
+
+(define get-environment-variables
+ (let ([get (foreign-lambda c-string "C_getenventry" int)]
+ [substring substring] )
+ (lambda ()
+ (let loop ([i 0])
+ (let ([entry (get i)])
+ (if entry
+ (let scan ([j 0])
+ (if (char=? #\= (##core#inline "C_subchar" entry j))
+ (cons (cons (substring entry 0 j) (substring entry (fx+ j 1) (##sys#size entry))) (loop (fx+ i 1)))
+ (scan (fx+ j 1)) ) )
+ '() ) ) ) ) ) )
+
+(define current-environment get-environment-variables) ; DEPRECATED
+
+;;; Time related things:
+
+(define (check-time-vector loc tm)
+ (##sys#check-vector tm loc)
+ (when (fx< (##sys#size tm) 10)
+ (##sys#error loc "time vector too short" tm) ) )
+
+(define (seconds->local-time secs)
+ (##sys#check-number secs 'seconds->local-time)
+ (##sys#decode-seconds secs #f) )
+
+(define (seconds->utc-time secs)
+ (##sys#check-number secs 'seconds->utc-time)
+ (##sys#decode-seconds secs #t) )
+
+(define seconds->string
+ (let ([ctime (foreign-lambda c-string "C_ctime" integer)])
+ (lambda (secs)
+ (let ([str (ctime secs)])
+ (if str
+ (##sys#substring str 0 (fx- (##sys#size str) 1))
+ (##sys#error 'seconds->string "cannot convert seconds to string" secs) ) ) ) ) )
+
+(define time->string
+ (let ([asctime (foreign-lambda c-string "C_asctime" scheme-object)]
+ [strftime (foreign-lambda c-string "C_strftime" scheme-object scheme-object)])
+ (lambda (tm #!optional fmt)
+ (check-time-vector 'time->string tm)
+ (if fmt
+ (begin
+ (##sys#check-string fmt 'time->string)
+ (or (strftime tm (##sys#make-c-string fmt))
+ (##sys#error 'time->string "time formatting overflows buffer" tm)) )
+ (let ([str (asctime tm)])
+ (if str
+ (##sys#substring str 0 (fx- (##sys#size str) 1))
+ (##sys#error 'time->string "cannot convert time vector to string" tm) ) ) ) ) ) )
+
+(define (local-time->seconds tm)
+ (check-time-vector 'local-time->seconds tm)
+ (if (##core#inline "C_mktime" tm)
+ (##sys#cons-flonum)
+ (##sys#error 'local-time->seconds "cannot convert time vector to seconds" tm) ) )
+
+(define local-timezone-abbreviation
+ (foreign-lambda* c-string ()
+ "char *z = (_daylight ? _tzname[1] : _tzname[0]);\n"
+ "return(z);") )
+
+;;; Other things:
+
+(define _exit
+ (let ([ex0 (foreign-lambda void "_exit" int)])
+ (lambda code
+ (ex0 (if (pair? code) (car code) 0)) ) ) )
+
+(define (terminal-port? port)
+ (##sys#check-port port 'terminal-port?)
+ #f)
+
+(define-foreign-variable _iofbf int "_IOFBF")
+(define-foreign-variable _iolbf int "_IOLBF")
+(define-foreign-variable _ionbf int "_IONBF")
+(define-foreign-variable _bufsiz int "BUFSIZ")
+
+(define set-buffering-mode!
+ (lambda (port mode . size)
+ (##sys#check-port port 'set-buffering-mode!)
+ (let ([size (if (pair? size) (car size) _bufsiz)]
+ [mode (case mode
+ [(###full) _iofbf]
+ [(###line) _iolbf]
+ [(###none) _ionbf]
+ [else (##sys#error 'set-buffering-mode! "invalid buffering-mode" mode port)] ) ] )
+ (##sys#check-exact size 'set-buffering-mode!)
+ (when (fx< (if (eq? 'stream (##sys#slot port 7))
+ (##core#inline "C_setvbuf" port mode size)
+ -1)
+ 0)
+ (##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size) ) ) ) )
+
+;;; Filename globbing:
+
+(define glob
+ (let ([regexp regexp]
+ [string-match string-match]
+ [glob->regexp glob->regexp]
+ [directory directory]
+ [make-pathname make-pathname]
+ [decompose-pathname decompose-pathname] )
+ (lambda paths
+ (let conc-loop ([paths paths])
+ (if (null? paths)
+ '()
+ (let ([path (car paths)])
+ (let-values ([(dir fil ext) (decompose-pathname path)])
+ (let* ([patt (glob->regexp (make-pathname #f (or fil "*") ext))]
+ [rx (regexp patt)])
+ (let loop ([fns (directory (or dir ".") #t)])
+ (cond [(null? fns) (conc-loop (cdr paths))]
+ [(string-match rx (car fns))
+ => (lambda (m) (cons (make-pathname dir (car m)) (loop (cdr fns)))) ]
+ [else (loop (cdr fns))] ) ) ) ) ) ) ) ) ) )
+
+
+;;; Process handling:
+
+(define-foreign-variable _p_overlay int "P_OVERLAY")
+(define-foreign-variable _p_wait int "P_WAIT")
+(define-foreign-variable _p_nowait int "P_NOWAIT")
+(define-foreign-variable _p_nowaito int "P_NOWAITO")
+(define-foreign-variable _p_detach int "P_DETACH")
+
+(define spawn/overlay _p_overlay)
+(define spawn/wait _p_wait)
+(define spawn/nowait _p_nowait)
+(define spawn/nowaito _p_nowaito)
+(define spawn/detach _p_detach)
+
+; Windows uses a commandline style for process arguments. Thus any
+; arguments with embedded whitespace will parse incorrectly. Must
+; string-quote such arguments.
+(define $quote-args-list
+ (let ([char-whitespace? char-whitespace?]
+ [string-length string-length]
+ [string-ref string-ref]
+ [string-append string-append])
+ (lambda (lst exactf)
+ (if exactf
+ lst
+ (let ([needs-quoting?
+ ; This is essentially (string-any char-whitespace? s) but we don't
+ ; want a SRFI-13 dependency. (Do we?)
+ (lambda (s)
+ (let ([len (string-length s)])
+ (let loop ([i 0])
+ (cond
+ [(fx= i len) #f]
+ [(char-whitespace? (string-ref s i)) #t]
+ [else (loop (fx+ i 1))]))))])
+ (let loop ([ilst lst] [olst '()])
+ (if (null? ilst)
+ (reverse olst)
+ (let ([str (car ilst)])
+ (loop
+ (cdr ilst)
+ (cons
+ (if (needs-quoting? str) (string-append "\"" str "\"") str)
+ olst)) ) ) ) ) ) ) ) )
+
+(define $exec-setup
+ (let ([setarg (foreign-lambda void "C_set_exec_arg" int scheme-pointer int)]
+ [setenv (foreign-lambda void "C_set_exec_env" int scheme-pointer int)]
+ [pathname-strip-directory pathname-strip-directory]
+ [build-exec-argvec
+ (lambda (loc lst argvec-setter idx)
+ (if lst
+ (begin
+ (##sys#check-list lst loc)
+ (do ([l lst (cdr l)]
+ [i idx (fx+ i 1)] )
+ ((null? l) (argvec-setter i #f 0))
+ (let ([s (car l)])
+ (##sys#check-string s loc)
+ (argvec-setter i s (##sys#size s)) ) ) )
+ (argvec-setter idx #f 0) ) )])
+ (lambda (loc filename arglst envlst exactf)
+ (##sys#check-string filename loc)
+ (let ([s (pathname-strip-directory filename)])
+ (setarg 0 s (##sys#size s)) )
+ (build-exec-argvec loc ($quote-args-list arglst exactf) setarg 1)
+ (build-exec-argvec loc envlst setenv 0)
+ (##core#inline "C_flushall")
+ (##sys#make-c-string (##sys#expand-home-path filename)) ) ) )
+
+(define ($exec-teardown loc msg filename res)
+ (##sys#update-errno)
+ (##core#inline "C_free_exec_args")
+ (##core#inline "C_free_exec_env")
+ (if (fx= res -1)
+ (##sys#error loc msg filename)
+ res ) )
+
+(define (process-execute filename #!optional arglst envlst exactf)
+ (let ([prg ($exec-setup 'process-execute filename arglst envlst exactf)])
+ ($exec-teardown 'process-execute "cannot execute process" filename
+ (if envlst (##core#inline "C_execve" prg) (##core#inline "C_execvp" prg))) ) )
+
+(define (process-spawn mode filename #!optional arglst envlst exactf)
+ (let ([prg ($exec-setup 'process-spawn filename arglst envlst exactf)])
+ ($exec-teardown 'process-spawn "cannot spawn process" filename
+ (if envlst (##core#inline "C_spawnvpe" mode prg) (##core#inline "C_spawnvp" mode prg))) ) )
+
+(define current-process-id (foreign-lambda int "C_getpid"))
+
+(define-foreign-variable _shlcmd c-string "C_shlcmd")
+
+(define (##sys#shell-command)
+ (or (get-environment-variable "COMSPEC")
+ (if (##core#inline "C_get_shlcmd")
+ _shlcmd
+ (begin
+ (##sys#update-errno)
+ (##sys#error '##sys#shell-command "cannot retrieve system directory") ) ) ) )
+
+(define (##sys#shell-command-arguments cmdlin)
+ (list "/c" cmdlin) )
+
+(define process-run
+ (let ([process-spawn process-spawn]
+ [get-environment-variable get-environment-variable] )
+ (lambda (f . args)
+ (let ([args (if (pair? args) (car args) #f)])
+ (if args
+ (process-spawn spawn/nowait f args)
+ (process-spawn spawn/nowait (##sys#shell-command) (##sys#shell-command-arguments f)) ) ) ) ) )
+
+;;; Run subprocess connected with pipes:
+(define-foreign-variable _rdbuf char "C_rdbuf")
+(define-foreign-variable _wr0 int "C_wr0_")
+(define-foreign-variable _rd1 int "C_rd1_")
+
+; from original by Mejedi
+;; ##sys#process
+; loc caller procedure symbol
+; cmd pathname or commandline
+; args string-list or '()
+; env string-list or #f (currently ignored)
+; stdoutf #f then share, or #t then create
+; stdinf #f then share, or #t then create
+; stderrf #f then share, or #t then create
+;
+; (values stdin-input-port? stdout-output-port? pid stderr-input-port?)
+; where stdin-input-port?, etc. is a port or #f, indicating no port created.
+
+(define ##sys#process
+ (let ([c-process
+ (foreign-lambda bool "C_process" c-string c-string c-pointer
+ (pointer int) (pointer int) (pointer int) (pointer int) int)])
+ ; The environment list must be sorted & include current directory
+ ; information for the system drives. i.e !C:=...
+ ; For now any environment is ignored.
+ (lambda (loc cmd args env stdoutf stdinf stderrf #!optional exactf)
+ (let ([cmdlin (string-intersperse ($quote-args-list (cons cmd args) exactf))])
+ (let-location ([handle int -1]
+ [stdin_fd int -1] [stdout_fd int -1] [stderr_fd int -1])
+ (let ([res
+ (c-process cmd cmdlin #f
+ (location handle)
+ (location stdin_fd) (location stdout_fd) (location stderr_fd)
+ (+ (if stdinf 0 1) (if stdoutf 0 2) (if stderrf 0 4)))])
+ (if res
+ (values
+ (and stdoutf (open-input-file* stdout_fd)) ;Parent stdin
+ (and stdinf (open-output-file* stdin_fd)) ;Parent stdout
+ handle
+ (and stderrf (open-input-file* stderr_fd)))
+ (begin
+ (##sys#update-errno)
+ (##sys#signal-hook #:process-error loc "cannot execute process" cmdlin))) ) ) ) ) ) )
+
+#;(define process (void))
+#;(define process* (void))
+(let ([%process
+ (lambda (loc err? cmd args env exactf)
+ (let ([chkstrlst
+ (lambda (lst)
+ (##sys#check-list lst loc)
+ (for-each (cut ##sys#check-string <> loc) lst) )])
+ (##sys#check-string cmd loc)
+ (if args
+ (chkstrlst args)
+ (begin
+ (set! exactf #t)
+ (set! args (##sys#shell-command-arguments cmd))
+ (set! cmd (##sys#shell-command)) ) )
+ (when env (chkstrlst env))
+ (receive [in out pid err] (##sys#process loc cmd args env #t #t err? exactf)
+ (if err?
+ (values in out pid err)
+ (values in out pid) ) ) ) )] )
+ (set! process
+ (lambda (cmd #!optional args env exactf)
+ (%process 'process #f cmd args env exactf) ))
+ (set! process*
+ (lambda (cmd #!optional args env exactf)
+ (%process 'process* #t cmd args env exactf) )) )
+
+(define-foreign-variable _exstatus int "C_exstatus")
+
+(define (##sys#process-wait pid nohang)
+ (if (##core#inline "C_process_wait" pid nohang)
+ (values pid #t _exstatus)
+ (values -1 #f #f) ) )
+
+(define process-wait
+ (lambda (pid . args)
+ (let-optionals* args ([nohang #f])
+ (##sys#check-exact pid 'process-wait)
+ (receive [epid enorm ecode] (##sys#process-wait pid nohang)
+ (if (fx= epid -1)
+ (begin
+ (##sys#update-errno)
+ (##sys#signal-hook #:process-error 'process-wait "waiting for child process failed" pid) )
+ (values epid enorm ecode) ) ) ) ) )
+
+(define sleep
+ (lambda (t)
+ (##core#inline "C_sleep" t)
+ 0) )
+
+(define-foreign-variable _hostname c-string "C_hostname")
+(define-foreign-variable _osver c-string "C_osver")
+(define-foreign-variable _osrel c-string "C_osrel")
+(define-foreign-variable _processor c-string "C_processor")
+
+(define get-host-name
+ (lambda ()
+ (if (##core#inline "C_get_hostname")
+ _hostname
+ (##sys#error 'get-host-name "cannot retrieve host-name") ) ) )
+
+
+;;; Getting system-, group- and user-information:
+
+(define system-information
+ (lambda ()
+ (if (##core#inline "C_sysinfo")
+ (list "windows" _hostname _osrel _osver _processor)
+ (begin
+ (##sys#update-errno)
+ (##sys#error 'system-information "cannot retrieve system-information") ) ) ) )
+
+(define-foreign-variable _username c-string "C_username")
+
+(define (current-user-name)
+ (if (##core#inline "C_get_user_name")
+ _username
+ (begin
+ (##sys#update-errno)
+ (##sys#error 'current-user-name "cannot retrieve current user-name") ) ) )
+
+
+;;; Find matching files:
+
+(define find-files
+ (let ([glob glob]
+ [string-match string-match]
+ [make-pathname make-pathname]
+ [pathname-file pathname-file]
+ [directory? directory?] )
+ (lambda (dir pred . action-id-limit)
+ (let-optionals action-id-limit
+ ([action (lambda (x y) (cons x y))] ; no eta reduction here - we want cons inlined.
+ [id '()]
+ [limit #f] )
+ (##sys#check-string dir 'find-files)
+ (let* ([depth 0]
+ [lproc
+ (cond [(not limit) (lambda _ #t)]
+ [(fixnum? limit) (lambda _ (fx< depth limit))]
+ [else limit] ) ]
+ [pproc
+ (if (string? pred)
+ (lambda (x) (string-match pred x))
+ pred) ] )
+ (let loop ([fs (glob (make-pathname dir "*"))]
+ [r id] )
+ (if (null? fs)
+ r
+ (let ([f (##sys#slot fs 0)]
+ [rest (##sys#slot fs 1)] )
+ (cond [(directory? f)
+ (cond [(member (pathname-file f) '("." "..")) (loop rest r)]
+ [(lproc f)
+ (loop rest
+ (fluid-let ([depth (fx+ depth 1)])
+ (loop (glob (make-pathname f "*")) r) ) ) ]
+ [else (loop rest r)] ) ]
+ [(pproc f) (loop rest (action f r))]
+ [else (loop rest r)] ) ) ) ) ) ) ) ) )
+
+;;; unimplemented stuff:
+
+(define-syntax define-unimplemented
+ (syntax-rules ()
+ [(_ ?name)
+ (define (?name . _)
+ (error '?name (##core#immutable '"this function is not available on this platform")) ) ] ) )
+
+(define-unimplemented change-file-owner)
+(define-unimplemented create-fifo)
+(define-unimplemented create-session)
+(define-unimplemented create-symbolic-link)
+(define-unimplemented current-effective-group-id)
+(define-unimplemented current-effective-user-id)
+(define-unimplemented current-effective-user-name)
+(define-unimplemented current-group-id)
+(define-unimplemented current-user-id)
+(define-unimplemented map-file-to-memory)
+(define-unimplemented file-link)
+(define-unimplemented file-lock)
+(define-unimplemented file-lock/blocking)
+(define-unimplemented file-select)
+(define-unimplemented file-test-lock)
+(define-unimplemented file-truncate)
+(define-unimplemented file-unlock)
+(define-unimplemented get-groups)
+(define-unimplemented group-information)
+(define-unimplemented initialize-groups)
+(define-unimplemented memory-mapped-file-pointer)
+(define-unimplemented parent-process-id)
+(define-unimplemented process-fork)
+(define-unimplemented process-group-id)
+(define-unimplemented process-signal)
+(define-unimplemented read-symbolic-link)
+(define-unimplemented set-alarm!)
+(define-unimplemented set-group-id!)
+(define-unimplemented set-groups!)
+(define-unimplemented set-process-group-id!)
+(define-unimplemented set-root-directory!)
+(define-unimplemented set-signal-mask!)
+(define-unimplemented set-user-id!)
+(define-unimplemented signal-mask)
+(define-unimplemented signal-mask!)
+(define-unimplemented signal-masked?)
+(define-unimplemented signal-unmask!)
+(define-unimplemented terminal-name)
+(define-unimplemented terminal-size)
+(define-unimplemented unmap-file-from-memory)
+(define-unimplemented user-information)
+(define-unimplemented utc-time->seconds)
+(define-unimplemented string->time)
+
+(define errno/wouldblock 0)
+
+(define (fifo? _) #f)
+(define (memory-mapped-file? _) #f)
+
+(define map/anonymous 0)
+(define map/file 0)
+(define map/fixed 0)
+(define map/private 0)
+(define map/shared 0)
+(define open/fsync 0)
+(define open/noctty 0)
+(define open/nonblock 0)
+(define open/sync 0)
+(define perm/isgid 0)
+(define perm/isuid 0)
+(define perm/isvtx 0)
+(define prot/exec 0)
+(define prot/none 0)
+(define prot/read 0)
+(define prot/write 0)
diff --git a/private-namespace.scm b/private-namespace.scm
new file mode 100644
index 00000000..f8c01384
--- /dev/null
+++ b/private-namespace.scm
@@ -0,0 +1,47 @@
+;;;; compiler-namespace.scm - A simple namespace system to keep compiler variables hidden
+;
+; Copyright (c) 2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(define-syntax private
+ (lambda (form r c)
+ (let ((namespace (cadr form))
+ (vars (cddr form)))
+ (##sys#check-symbol namespace 'private)
+ (let* ((str (symbol->string namespace)) ; somewhat questionable (renaming)
+ (prefix (string-append
+ (string (integer->char (string-length str)))
+ (symbol->string namespace))))
+ (for-each
+ (lambda (var)
+ (put!
+ var 'c:namespace
+ (##sys#string->qualified-symbol prefix (symbol->string var))))
+ vars)
+ '(##core#undefined) ) ) ) )
+
+(set! ##sys#alias-global-hook
+ (lambda (var . assign) ; must work with old chicken
+ (or (get var 'c:namespace) var) ) )
diff --git a/profiler.scm b/profiler.scm
new file mode 100644
index 00000000..3493dad8
--- /dev/null
+++ b/profiler.scm
@@ -0,0 +1,149 @@
+;;;; profiler.scm - Support code for profiling applications
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit profiler)
+ (usual-integrations)
+ (hide ##sys#profile-name ##sys#profile-vector-list)
+ (disable-interrupts)
+ (fixnum-arithmetic) )
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ (bound-to-procedure
+ write-char write make-vector)
+ (no-bound-checks) ) ] )
+
+(foreign-declare #<<EOF
+#if !defined(_MSC_VER)
+# include <unistd.h>
+#endif
+EOF
+)
+
+(define-foreign-variable profile-id int "getpid()")
+
+(define-constant profile-info-entry-size 5)
+
+
+;;; Globals:
+
+(define ##sys#profile-vector-list '())
+(define ##sys#profile-name #f)
+(define ##sys#profile-append-mode #f)
+
+
+;;; Initialize profile counter vector:
+
+(define ##sys#register-profile-info
+ (let ([make-vector make-vector])
+ (lambda (size filename)
+ (when filename
+ (set! ##sys#profile-name
+ (string-append filename "." (number->string profile-id)))
+ (let ([oldeh (##sys#exit-handler)]
+ [oldieh (##sys#implicit-exit-handler)] )
+ (##sys#exit-handler
+ (lambda args
+ (##sys#finish-profile)
+ (apply oldeh args) ) )
+ (##sys#implicit-exit-handler
+ (lambda ()
+ (##sys#finish-profile)
+ (oldieh) ) ) ) )
+ ;; entry: [name, count, time0, total, pending]
+ (let ([vec (make-vector (* size profile-info-entry-size) 0)])
+ (set! ##sys#profile-vector-list (cons vec ##sys#profile-vector-list))
+ vec) ) ) )
+
+(define (##sys#set-profile-info-vector! vec i x)
+ (##sys#setslot vec (* i profile-info-entry-size) x) )
+
+
+;;; Entry and exit into/out of profiled lambda:
+
+(define ##sys#profile-entry
+ (let ((maxfix (##sys#fudge 21)))
+ (lambda (index vec)
+ (let* ([i (* index profile-info-entry-size)]
+ [ic (add1 i)]
+ [count (##sys#slot vec ic)]
+ [it0 (+ i 2)]
+ [ip (+ i 4)]
+ [ipc (##sys#slot vec ip)] )
+ (##sys#setislot
+ vec ic
+ (cond ((not count) #f)
+ ((eq? maxfix count) #f)
+ (else (add1 count))))
+ (when (zero? ipc)
+ (##sys#setislot vec it0 (##sys#fudge 6)) )
+ (##sys#setislot vec ip (add1 ipc)) ) ) ) )
+
+(define (##sys#profile-exit index vec)
+ (let* ([i (* index profile-info-entry-size)]
+ [it0 (+ i 2)]
+ [it (+ i 3)]
+ [ip (+ i 4)]
+ [ipc (sub1 (##sys#slot vec ip))] )
+ (##sys#setislot vec ip ipc)
+ (when (zero? ipc)
+ (##sys#setislot vec it (+ (##sys#slot vec it) (- (##sys#fudge 6) (##sys#slot vec it0))))
+ (##sys#setislot vec it0 0) ) ) )
+
+
+;;; Generate profile:
+
+(define ##sys#finish-profile
+ (let ([with-output-to-file with-output-to-file]
+ [write-char write-char]
+ [write write] )
+ (lambda ()
+ (when (##sys#fudge 13)
+ (##sys#print "[debug] writing profile...\n" #f ##sys#standard-output) )
+ (apply
+ with-output-to-file ##sys#profile-name
+ (lambda ()
+ (for-each
+ (lambda (vec)
+ (let ([len (##sys#size vec)])
+ (do ([i 0 (+ i profile-info-entry-size)])
+ ((>= i len))
+ (write-char #\()
+ (write (##sys#slot vec i))
+ (write-char #\space)
+ (write (##sys#slot vec (add1 i)))
+ (write-char #\space)
+ (write (##sys#slot vec (+ i 3)))
+ (write-char #\))
+ (write-char #\newline) ) ) )
+ ##sys#profile-vector-list) )
+ (if ##sys#profile-append-mode
+ '(append:)
+ '() ) ) ) ) )
diff --git a/regex.import.scm b/regex.import.scm
new file mode 100644
index 00000000..37c728c9
--- /dev/null
+++ b/regex.import.scm
@@ -0,0 +1,41 @@
+;;;; regex.import.scm - import library for "regex" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'regex
+ '(glob->regexp
+ glob?
+ grep
+ regexp
+ regexp-escape
+ regexp?
+ string-match
+ string-match-positions
+ string-search
+ string-search-positions
+ string-split-fields
+ string-substitute
+ string-substitute*))
diff --git a/regex.scm b/regex.scm
new file mode 100644
index 00000000..fab3e9d2
--- /dev/null
+++ b/regex.scm
@@ -0,0 +1,329 @@
+;;;; regex.scm
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(cond-expand
+ [chicken-compile-shared]
+ [else (declare (unit regex))] )
+
+(declare
+ (usual-integrations)
+ (disable-interrupts)
+; (disable-warning var)
+ (export
+ regexp? regexp
+ string-match string-match-positions string-search string-search-positions
+ string-split-fields string-substitute string-substitute*
+ glob? glob->regexp
+ grep
+ regexp-escape
+
+ irregex string->irregex sre->irregex string->sre
+ irregex? irregex-match-data?
+ irregex-new-matches irregex-reset-matches!
+ irregex-match-start irregex-match-end irregex-match-substring
+ irregex-match-num-submatches
+ irregex-search irregex-search/matches irregex-match irregex-match-string
+ irregex-fold irregex-replace irregex-replace/all irregex-apply-match
+ irregex-dfa irregex-dfa/search irregex-dfa/extract
+ irregex-nfa irregex-flags irregex-submatches irregex-lengths irregex-names
+ ))
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ (no-bound-checks)
+ (no-procedure-checks-for-usual-bindings) ) ] )
+
+(include "unsafe-declarations.scm")
+
+(register-feature! 'regex 'irregex)
+
+(include "irregex.scm")
+
+
+;;; Record `regexp'
+
+(define-record regexp x)
+
+(define (regexp pat #!optional caseless extended utf8)
+ (make-regexp
+ (apply
+ irregex
+ pat
+ (let ((opts '()))
+ (when caseless (set! opts (cons 'i opts)))
+ (when extended (set! opts (cons 'x opts)))
+ (when utf8 (set! opts (cons 'utf8 opts)))
+ opts))) )
+
+(define (unregexp x)
+ (cond ((regexp? x) (regexp-x x))
+ ((irregex? x) x)
+ (else (irregex x))))
+
+
+;;; Basic `regexp' operations
+
+(define (string-match rx str)
+ (let ((rx (unregexp rx)))
+ (and-let* ((m (irregex-match rx str)))
+ (let loop ((i (irregex-match-num-submatches m))
+ (res '()))
+ (if (fx<= i 0)
+ (cons str res)
+ (loop (fx- i 1) (cons (irregex-match-substring m i) res)))))))
+
+(define (string-match-positions rx str)
+ (let ((rx (unregexp rx)))
+ (and-let* ((m (irregex-match rx str)))
+ (let loop ((i (irregex-match-num-submatches m))
+ (res '()))
+ (if (fx<= i 0)
+ (cons (list 0 (string-length str)) res)
+ (loop (fx- i 1) (cons (list (irregex-match-start-index m i)
+ (irregex-match-end-index m i))
+ res)))))))
+
+(define (string-search rx str #!optional (start 0) (range (string-length str)))
+ (let ((rx (unregexp rx)))
+ (and-let* ((n (string-length str))
+ (m (irregex-search rx str start (min n (fx+ start range)))))
+ (let loop ((i (irregex-match-num-submatches m))
+ (res '()))
+ (if (fx< i 0)
+ res
+ (loop (fx- i 1) (cons (irregex-match-substring m i) res)))))))
+
+(define (string-search-positions rx str #!optional (start 0) (range (string-length str)))
+ (let ((rx (unregexp rx)))
+ (and-let* ((n (string-length str))
+ (m (irregex-search rx str start (min n (fx+ start range)))))
+ (let loop ((i (irregex-match-num-submatches m))
+ (res '()))
+ (if (fx< i 0)
+ res
+ (loop (fx- i 1) (cons (list (irregex-match-start-index m i)
+ (irregex-match-end-index m i))
+ res)))))))
+
+
+;;; Split string into fields:
+
+(define string-split-fields
+ (let ([reverse reverse]
+ [substring substring]
+ [string-search-positions string-search-positions] )
+ (lambda (rx str . mode-and-start)
+ (##sys#check-string str 'string-split-fields)
+ (let* ([argc (length mode-and-start)]
+ [len (##sys#size str)]
+ [mode (if (fx> argc 0) (car mode-and-start) #t)]
+ [start (if (fx> argc 1) (cadr mode-and-start) 0)]
+ [fini (case mode
+ [(#:suffix)
+ (lambda (ms start)
+ (if (fx< start len)
+ (##sys#error 'string-split-fields
+ "record does not end with suffix" str rx)
+ (reverse ms) ) ) ]
+ [(#:infix)
+ (lambda (ms start)
+ (if (fx>= start len)
+ (reverse (cons "" ms))
+ (reverse (cons (substring str start len) ms)) ) ) ]
+ [else (lambda (ms start) (reverse ms)) ] ) ]
+ [fetch (case mode
+ [(#:infix #:suffix) (lambda (start from to) (substring str start from))]
+ [else (lambda (start from to) (substring str from to))] ) ] )
+ (let loop ([ms '()] [start start])
+ (let ([m (string-search-positions rx str start)])
+ (if m
+ (let* ([mp (car m)]
+ [from (car mp)]
+ [to (cadr mp)] )
+ (if (fx= from to)
+ (if (fx= to len)
+ (fini ms start)
+ (loop (cons (fetch start (fx+ from 1) (fx+ to 2)) ms) (fx+ to 1)) )
+ (loop (cons (fetch start from to) ms) to) ) )
+ (fini ms start) ) ) ) ) ) ) )
+
+
+;;; Substitute matching strings:
+
+(define string-substitute
+ (let ([substring substring]
+ [reverse reverse]
+ [make-string make-string]
+ [string-search-positions string-search-positions] )
+ (lambda (rx subst string . flag)
+ (##sys#check-string subst 'string-substitute)
+ (##sys#check-string string 'string-substitute)
+ (let* ([which (if (pair? flag) (car flag) 1)]
+ [substlen (##sys#size subst)]
+ (strlen (##sys#size string))
+ [substlen-1 (fx- substlen 1)]
+ [result '()]
+ [total 0] )
+ (define (push x)
+ (set! result (cons x result))
+ (set! total (fx+ total (##sys#size x))) )
+ (define (substitute matches)
+ (let loop ([start 0] [index 0])
+ (if (fx>= index substlen-1)
+ (push (if (fx= start 0) subst (substring subst start substlen)))
+ (let ([c (##core#inline "C_subchar" subst index)]
+ [index+1 (fx+ index 1)] )
+ (if (char=? c #\\)
+ (let ([c2 (##core#inline "C_subchar" subst index+1)])
+ (if (and (not (char=? #\\ c2)) (char-numeric? c2))
+ (let ([mi (list-ref matches (fx- (char->integer c2) 48))])
+ (push (substring subst start index))
+ (push (substring string (car mi) (cadr mi)))
+ (loop (fx+ index 2) index+1) )
+ (loop start (fx+ index+1 1)) ) )
+ (loop start index+1) ) ) ) ) )
+ (let loop ([index 0] [count 1])
+ (let ((matches (and (fx< index strlen)
+ (string-search-positions rx string index))))
+ (cond [matches
+ (let* ([range (car matches)]
+ [upto (cadr range)] )
+ (cond ((fx= 0 (fx- (cadr range) (car range)))
+ (##sys#error
+ 'string-substitute "empty substitution match"
+ rx) )
+ ((or (not (fixnum? which)) (fx= count which))
+ (push (substring string index (car range)))
+ (substitute matches)
+ (loop upto #f) )
+ (else
+ (push (substring string index upto))
+ (loop upto (fx+ count 1)) ) ) ) ]
+ [else
+ (push (substring string index (##sys#size string)))
+ (##sys#fragments->string total (reverse result)) ] ) ) ) ) ) ) )
+
+(define string-substitute*
+ (let ([string-substitute string-substitute])
+ (lambda (str smap . mode)
+ (##sys#check-string str 'string-substitute*)
+ (##sys#check-list smap 'string-substitute*)
+ (let ((mode (and (pair? mode) (car mode))))
+ (let loop ((str str) (smap smap))
+ (if (null? smap)
+ str
+ (let ((sm (car smap)))
+ (loop (string-substitute (car sm) (cdr sm) str mode)
+ (cdr smap) ) ) ) ) ) ) ) )
+
+
+;;; Glob support:
+
+;FIXME is it worthwhile making this accurate?
+(define (glob? str)
+ (##sys#check-string str 'glob?)
+ (let loop ([idx (fx- (string-length str) 1)])
+ (and (fx<= 0 idx)
+ (case (string-ref str idx)
+ [(#\* #\] #\?)
+ (or (fx= 0 idx)
+ (not (char=? #\\ (string-ref str (fx- idx 1))))
+ (loop (fx- idx 2)))]
+ [else
+ (loop (fx- idx 1))]) ) ) )
+
+(define glob->regexp
+ (let ([list->string list->string]
+ [string->list string->list] )
+ (lambda (s)
+ (##sys#check-string s 'glob->regexp)
+ (list->string
+ (let loop ((cs (string->list s)))
+ (if (null? cs)
+ '()
+ (let ([c (car cs)]
+ [rest (cdr cs)] )
+ (cond [(char=? c #\*) `(#\. #\* ,@(loop rest))]
+ [(char=? c #\?) (cons '#\. (loop rest))]
+ [(char=? c #\[)
+ (cons
+ #\[
+ (let loop2 ((rest rest))
+ (if (pair? rest)
+ (cond ((char=? #\] (car rest))
+ (cons #\] (loop (cdr rest))))
+ ((and (char=? #\- (car rest)) (pair? (cdr rest)))
+ `(#\- ,(cadr rest) ,@(loop2 (cddr rest))))
+ ((and (pair? (cdr rest)) (pair? (cddr rest))
+ (char=? #\- (cadr rest)) )
+ `(,(car rest) #\- ,(caddr rest)
+ ,@(loop2 (cdddr rest))))
+ ((pair? rest)
+ (cons (car rest) (loop2 (cdr rest))))
+ ((null? rest)
+ (error 'glob->regexp "unexpected end of character class" s))))))]
+ [(or (char-alphabetic? c) (char-numeric? c)) (cons c (loop rest))]
+ [else `(#\\ ,c ,@(loop rest))] ) ) ) ) ) ) ) )
+
+
+;;; Grep-like function on list:
+
+(define grep
+ (let ([string-search string-search])
+ (lambda (rx lst)
+ (##sys#check-list lst 'grep)
+ (let loop ([lst lst])
+ (if (null? lst)
+ '()
+ (let ([x (car lst)]
+ [r (cdr lst)] )
+ (if (string-search rx x)
+ (cons x (loop r))
+ (loop r) ) ) ) ) ) ) )
+
+
+;;; Escape regular expression (suggested by Peter Bex):
+
+(define regexp-escape
+ (let ([open-output-string open-output-string]
+ [get-output-string get-output-string] )
+ (lambda (str)
+ (##sys#check-string str 'regexp-escape)
+ (let ([out (open-output-string)]
+ [len (##sys#size str)] )
+ (let loop ([i 0])
+ (cond [(fx>= i len) (get-output-string out)]
+ [(memq (##core#inline "C_subchar" str i)
+ '(#\. #\\ #\? #\* #\+ #\^ #\$ #\( #\) #\[ #\] #\| #\{ #\}))
+ (##sys#write-char-0 #\\ out)
+ (##sys#write-char-0 (##core#inline "C_subchar" str i) out)
+ (loop (fx+ i 1)) ]
+ [else
+ (##sys#write-char-0 (##core#inline "C_subchar" str i) out)
+ (loop (fx+ i 1)) ] ) ) ) ) ) )
diff --git a/rules.make b/rules.make
new file mode 100644
index 00000000..a5cfc255
--- /dev/null
+++ b/rules.make
@@ -0,0 +1,1358 @@
+# rules.make - basic build rules -*- Makefile -*-
+#
+# Copyright (c) 2000-2007, Felix L. Winkelmann
+# Copyright (c) 2008-2009, The Chicken Team
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+# conditions are met:
+#
+# Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+# disclaimer.
+# 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.
+# Neither the name of the author nor the names of its contributors may be used to endorse or promote
+# products derived from this software without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+# OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+# AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+
+VPATH=$(SRCDIR)
+
+# object files
+
+LIBCHICKEN_OBJECTS_1 = \
+ library eval data-structures ports files extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
+ srfi-14 srfi-18 srfi-69 $(POSIXFILE) regex scheduler \
+ profiler stub expand chicken-syntax runtime
+LIBCHICKEN_SHARED_OBJECTS = $(LIBCHICKEN_OBJECTS_1:=$(O))
+LIBCHICKEN_STATIC_OBJECTS = $(LIBCHICKEN_OBJECTS_1:=-static$(O))
+
+LIBUCHICKEN_OBJECTS_1 = \
+ ulibrary ueval udata-structures uports ufiles uextras ulolevel uutils utcp usrfi-1 usrfi-4 \
+ usrfi-13 usrfi-14 usrfi-18 usrfi-69 u$(POSIXFILE) uregex scheduler \
+ profiler stub expand chicken-syntax uruntime
+LIBUCHICKEN_SHARED_OBJECTS = $(LIBUCHICKEN_OBJECTS_1:=$(O))
+LIBUCHICKEN_STATIC_OBJECTS = $(LIBUCHICKEN_OBJECTS_1:=-static$(O))
+
+LIBCHICKENGUI_OBJECTS_1 = \
+ library eval data-structures ports files extras lolevel utils tcp srfi-1 srfi-4 srfi-13 \
+ srfi-14 srfi-18 srfi-69 $(POSIXFILE) regex scheduler \
+ profiler stub expand chicken-syntax gui-runtime
+LIBCHICKENGUI_SHARED_OBJECTS = $(LIBCHICKENGUI_OBJECTS_1:=$(O))
+LIBCHICKENGUI_STATIC_OBJECTS = $(LIBCHICKENGUI_OBJECTS_1:=-static$(O))
+
+COMPILER_OBJECTS_1 = \
+ chicken batch-driver compiler optimizer compiler-syntax scrutinizer support \
+ c-platform c-backend
+COMPILER_OBJECTS = $(COMPILER_OBJECTS_1:=$(O))
+COMPILER_STATIC_OBJECTS = $(COMPILER_OBJECTS_1:=-static$(O))
+
+
+# library objects
+
+runtime$(O): runtime.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+gui-runtime$(O): runtime.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $(C_COMPILER_GUI_RUNTIME_OPTIONS) $< \
+ $(C_COMPILER_OUTPUT)
+eval$(O): eval.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+expand$(O): expand.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+chicken-syntax$(O): chicken-syntax.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+data-structures$(O): data-structures.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+ports$(O): ports.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+files$(O): files.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+extras$(O): extras.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+library$(O): library.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+lolevel$(O): lolevel.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+posixunix$(O): posixunix.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+posixwin$(O): posixwin.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+profiler$(O): profiler.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+regex$(O): regex.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+scheduler$(O): scheduler.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+srfi-1$(O): srfi-1.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+srfi-13$(O): srfi-13.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+srfi-14$(O): srfi-14.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+srfi-18$(O): srfi-18.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+srfi-69$(O): srfi-69.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+srfi-4$(O): srfi-4.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+stub$(O): stub.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+tcp$(O): tcp.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+utils$(O): utils.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+
+uruntime$(O): runtime.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+ueval$(O): ueval.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+udata-structures$(O): udata-structures.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+uports$(O): uports.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+ufiles$(O): ufiles.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+uextras$(O): uextras.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+ulibrary$(O): ulibrary.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+ulolevel$(O): ulolevel.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+uposixunix$(O): uposixunix.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+uposixwin$(O): uposixwin.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+uregex$(O): uregex.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+usrfi-1$(O): usrfi-1.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+usrfi-13$(O): usrfi-13.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+usrfi-14$(O): usrfi-14.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+usrfi-18$(O): usrfi-18.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+usrfi-69$(O): usrfi-69.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+usrfi-4$(O): usrfi-4.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+utcp$(O): utcp.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+uutils$(O): uutils.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+
+runtime-static$(O): runtime.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+gui-runtime-static$(O): runtime.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $(C_COMPILER_GUI_RUNTIME_OPTIONS) $< \
+ $(C_COMPILER_OUTPUT)
+eval-static$(O): eval.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+expand-static$(O): expand.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+chicken-syntax-static$(O): chicken-syntax.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+data-structures-static$(O): data-structures.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+ports-static$(O): ports.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+files-static$(O): files.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+extras-static$(O): extras.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+library-static$(O): library.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+lolevel-static$(O): lolevel.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+posixunix-static$(O): posixunix.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+posixwin-static$(O): posixwin.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+profiler-static$(O): profiler.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+regex-static$(O): regex.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+scheduler-static$(O): scheduler.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+srfi-1-static$(O): srfi-1.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+srfi-13-static$(O): srfi-13.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+srfi-14-static$(O): srfi-14.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+srfi-18-static$(O): srfi-18.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+srfi-69-static$(O): srfi-69.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+srfi-4-static$(O): srfi-4.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+stub-static$(O): stub.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+tcp-static$(O): tcp.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+utils-static$(O): utils.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+
+uruntime-static$(O): runtime.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+ueval-static$(O): ueval.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+udata-structures-static$(O): udata-structures.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+uports-static$(O): uports.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+ufiles-static$(O): ufiles.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+uextras-static$(O): uextras.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+ulibrary-static$(O): ulibrary.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+ulolevel-static$(O): ulolevel.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+uposixunix-static$(O): uposixunix.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+uposixwin-static$(O): uposixwin.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+uregex-static$(O): uregex.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+usrfi-1-static$(O): usrfi-1.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+usrfi-13-static$(O): usrfi-13.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+usrfi-14-static$(O): usrfi-14.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+usrfi-18-static$(O): usrfi-18.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+usrfi-69-static$(O): usrfi-69.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+usrfi-4-static$(O): usrfi-4.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+utcp-static$(O): utcp.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+uutils-static$(O): uutils.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_BUILD_UNSAFE_RUNTIME_OPTIONS) $< $(C_COMPILER_OUTPUT)
+
+# import library objects
+
+scheme.import$(O): scheme.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(HOST_INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+csi.import$(O): csi.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+chicken.import$(O): chicken.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+lolevel.import$(O): lolevel.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+srfi-1.import$(O): srfi-1.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+srfi-4.import$(O): srfi-4.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+data-structures.import$(O): data-structures.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+ports.import$(O): ports.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+files.import$(O): files.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+posix.import$(O): posix.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+srfi-13.import$(O): srfi-13.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+srfi-69.import$(O): srfi-69.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+extras.import$(O): extras.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+regex.import$(O): regex.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+irregex.import$(O): irregex.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+srfi-14.import$(O): srfi-14.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+tcp.import$(O): tcp.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+foreign.import$(O): foreign.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+srfi-18.import$(O): srfi-18.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+utils.import$(O): utils.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+setup-api.import$(O): setup-api.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+setup-download.import$(O): setup-download.import.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+
+# setup extension objects
+setup-api$(O): setup-api.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+setup-download$(O): setup-download.c chicken.h $(CHICKEN_CONFIG_H)
+ $(HOST_C_COMPILER) $(HOST_C_COMPILER_OPTIONS) $(HOST_C_COMPILER_PTABLES_OPTIONS) $(INCLUDES) -DC_SHARED \
+ $(HOST_C_COMPILER_COMPILE_OPTION) $(HOST_C_COMPILER_OPTIMIZATION_OPTIONS) $(HOST_C_COMPILER_SHARED_OPTIONS) \
+ $(HOST_C_COMPILER_BUILD_RUNTIME_OPTIONS) $< $(HOST_C_COMPILER_OUTPUT)
+
+# compiler objects
+
+batch-driver$(O): batch-driver.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) $< \
+ $(C_COMPILER_OUTPUT)
+c-backend$(O): c-backend.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) $< \
+ $(C_COMPILER_OUTPUT)
+c-platform$(O): c-platform.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) $< \
+ $(C_COMPILER_OUTPUT)
+optimizer$(O): optimizer.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) $< \
+ $(C_COMPILER_OUTPUT)
+compiler-syntax$(O): compiler-syntax.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) $< \
+ $(C_COMPILER_OUTPUT)
+scrutinizer$(O): scrutinizer.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) $< \
+ $(C_COMPILER_OUTPUT)
+chicken$(O): chicken.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) $< \
+ $(C_COMPILER_OUTPUT)
+compiler$(O): compiler.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) $< \
+ $(C_COMPILER_OUTPUT)
+support$(O): support.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $(C_COMPILER_SHARED_OPTIONS) $< \
+ $(C_COMPILER_OUTPUT)
+
+# static compiler objects
+
+batch-driver-static$(O): batch-driver.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+c-backend-static$(O): c-backend.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+c-platform-static$(O): c-platform.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+chicken-static$(O): chicken.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+compiler-static$(O): compiler.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+support-static$(O): support.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+optimizer-static$(O): optimizer.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+compiler-syntax-static$(O): compiler-syntax.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+scrutinizer-static$(O): scrutinizer.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+
+# assembler objects
+
+ifneq ($(HACKED_APPLY),)
+$(APPLY_HACK_OBJECT): $(SRCDIR)apply-hack.$(ARCH)$(ASM)
+ $(ASSEMBLER) $(ASSEMBLER_OPTIONS) $(ASSEMBLER_COMPILE_OPTION) $< $(ASSEMBLER_OUTPUT)
+endif
+
+# program objects
+
+chicken-profile$(O): chicken-profile.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+chicken-install$(O): chicken-install.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+chicken-uninstall$(O): chicken-uninstall.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+chicken-status$(O): chicken-status.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+chicken-setup$(O): chicken-setup.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+csc$(O): csc.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+csi$(O): csi.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) $(C_COMPILER_SHARED_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+
+# static program objects
+
+csi-static$(O): csi.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+chicken-bug$(O): chicken-bug.c chicken.h $(CHICKEN_CONFIG_H)
+ $(C_COMPILER) $(C_COMPILER_OPTIONS) $(INCLUDES) \
+ $(C_COMPILER_STATIC_OPTIONS) \
+ $(C_COMPILER_COMPILE_OPTION) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< $(C_COMPILER_OUTPUT)
+
+# libraries
+
+.PHONY: libs
+
+libs: $(TARGETLIBS)
+
+libchicken$(SO): $(LIBCHICKEN_SHARED_OBJECTS) $(APPLY_HACK_OBJECT)
+ $(LINKER) $(LINKER_OPTIONS) $(LINKER_LINK_SHARED_LIBRARY_OPTIONS) $(LIBCHICKEN_SO_LINKER_OPTIONS) \
+ $(LINKER_OUTPUT) $^ $(LIBCHICKEN_SO_LIBRARIES)
+ifdef USES_SONAME
+ ln -sf $(LIBCHICKEN_SO_FILE) $(LIBCHICKEN_SO_FILE).$(BINARYVERSION)
+endif
+
+libuchicken$(SO): $(LIBUCHICKEN_SHARED_OBJECTS) $(APPLY_HACK_OBJECT)
+ $(LINKER) $(LINKER_OPTIONS) $(LINKER_LINK_SHARED_LIBRARY_OPTIONS) $(LIBUCHICKEN_SO_LINKER_OPTIONS) \
+ $(LINKER_OUTPUT) $^ $(LIBUCHICKEN_SO_LIBRARIES)
+ifdef USES_SONAME
+ ln -sf $(LIBUCHICKEN_SO_FILE) $(LIBUCHICKEN_SO_FILE).$(BINARYVERSION)
+endif
+
+cygchicken-0.dll: $(LIBCHICKEN_SHARED_OBJECTS) $(APPLY_HACK_OBJECT)
+ gcc -shared -o $(LIBCHICKEN_SO_FILE) -Wl,--dll -Wl,--add-stdcall-alias \
+ -Wl,--enable-stdcall-fixup -Wl,--warn-unresolved-symbols \
+ -Wl,--dll-search-prefix=cyg -Wl,--allow-multiple-definition \
+ -Wl,--allow-shlib-undefined -Wl,--export-dynamic \
+ -Wl,--out-implib=libchicken.dll.a -Wl,--export-all-symbols \
+ -Wl,--enable-auto-import \
+ -Wl,--whole-archive $(LIBCHICKEN_SHARED_OBJECTS) $(APPLY_HACK_OBJECT) \
+ -Wl,--no-whole-archive $(LIBCHICKEN_SO_LIBRARIES)
+
+cyguchicken-0.dll: $(LIBUCHICKEN_SHARED_OBJECTS) $(APPLY_HACK_OBJECT)
+ gcc -shared -o $(LIBUCHICKEN_SO_FILE) -Wl,--dll -Wl,--add-stdcall-alias \
+ -Wl,--enable-stdcall-fixup -Wl,--warn-unresolved-symbols \
+ -Wl,--dll-search-prefix=cyg -Wl,--allow-multiple-definition \
+ -Wl,--allow-shlib-undefined -Wl,--export-dynamic \
+ -Wl,--out-implib=libuchicken.dll.a -Wl,--export-all-symbols \
+ -Wl,--enable-auto-import \
+ -Wl,--whole-archive $(LIBUCHICKEN_SHARED_OBJECTS) $(APPLY_HACK_OBJECT) \
+ -Wl,--no-whole-archive $(LIBUCHICKEN_SO_LIBRARIES)
+
+
+libchickengui$(SO): $(APPLY_HACK_OBJECT) $(LIBCHICKENGUI_SHARED_OBJECTS)
+ $(LINKER) $(LINKER_OPTIONS) $(LINKER_LINK_SHARED_LIBRARY_OPTIONS) $(LIBCHICKENGUI_SO_LINKER_OPTIONS) \
+ $(LINKER_OUTPUT) $^ $(LIBCHICKENGUI_SO_LIBRARIES)
+
+libchicken$(A): $(APPLY_HACK_OBJECT) $(LIBCHICKEN_STATIC_OBJECTS)
+ $(LIBRARIAN) $(LIBRARIAN_OPTIONS) $(LIBRARIAN_OUTPUT) $^
+
+libuchicken$(A): $(APPLY_HACK_OBJECT) $(LIBUCHICKEN_STATIC_OBJECTS)
+ $(LIBRARIAN) $(LIBRARIAN_OPTIONS) $(LIBRARIAN_OUTPUT) $^
+
+libchickengui$(A): $(APPLY_HACK_OBJECT) $(LIBCHICKENGUI_STATIC_OBJECTS)
+ $(LIBRARIAN) $(LIBRARIAN_OPTIONS) $(LIBRARIAN_OUTPUT) $^
+
+# import libraries and extensions
+
+.SUFFIXES: .so
+
+%.so: %.o
+ $(HOST_LINKER) $(HOST_LINKER_OPTIONS) $(HOST_LINKER_LINK_SHARED_DLOADABLE_OPTIONS) $^ $(HOST_LINKER_OUTPUT_OPTION) $@ \
+ $(HOST_LINKER_LIBRARY_PREFIX)chicken$(HOST_LINKER_LIBRARY_SUFFIX) \
+ $(HOST_LIBRARIES)
+
+# executables
+
+$(CHICKEN_SHARED_EXECUTABLE): $(COMPILER_OBJECTS) $(PRIMARY_LIBCHICKEN)
+ $(LINKER) $(LINKER_OPTIONS) $(LINKER_EXECUTABLE_OPTIONS) $(COMPILER_OBJECTS) $(LINKER_OUTPUT) \
+ $(LINKER_LIBRARY_PREFIX)chicken$(LINKER_LIBRARY_SUFFIX) $(LINKER_LINK_SHARED_PROGRAM_OPTIONS) $(LIBRARIES)
+
+$(CSI_SHARED_EXECUTABLE): csi$(O) $(PRIMARY_LIBCHICKEN)
+ $(LINKER) $(LINKER_OPTIONS) $(LINKER_EXECUTABLE_OPTIONS) $< $(LINKER_OUTPUT) \
+ $(LINKER_LIBRARY_PREFIX)chicken$(LINKER_LIBRARY_SUFFIX) $(LINKER_LINK_SHARED_PROGRAM_OPTIONS) $(LIBRARIES)
+
+$(CHICKEN_INSTALL_PROGRAM)$(EXE): chicken-install$(O) $(PRIMARY_LIBCHICKEN)
+ $(LINKER) $(LINKER_OPTIONS) $(LINKER_EXECUTABLE_OPTIONS) $< $(LINKER_OUTPUT) \
+ $(LINKER_LIBRARY_PREFIX)chicken$(LINKER_LIBRARY_SUFFIX) $(LINKER_LINK_SHARED_PROGRAM_OPTIONS) $(LIBRARIES)
+$(CHICKEN_UNINSTALL_PROGRAM)$(EXE): chicken-uninstall$(O) $(PRIMARY_LIBCHICKEN)
+ $(LINKER) $(LINKER_OPTIONS) $(LINKER_EXECUTABLE_OPTIONS) $< $(LINKER_OUTPUT) \
+ $(LINKER_LIBRARY_PREFIX)chicken$(LINKER_LIBRARY_SUFFIX) $(LINKER_LINK_SHARED_PROGRAM_OPTIONS) $(LIBRARIES)
+$(CHICKEN_STATUS_PROGRAM)$(EXE): chicken-status$(O) $(PRIMARY_LIBCHICKEN)
+ $(LINKER) $(LINKER_OPTIONS) $(LINKER_EXECUTABLE_OPTIONS) $< $(LINKER_OUTPUT) \
+ $(LINKER_LIBRARY_PREFIX)chicken$(LINKER_LIBRARY_SUFFIX) $(LINKER_LINK_SHARED_PROGRAM_OPTIONS) $(LIBRARIES)
+$(CHICKEN_SETUP_PROGRAM)$(EXE): chicken-setup$(O) $(PRIMARY_LIBCHICKEN)
+ $(LINKER) $(LINKER_OPTIONS) $(LINKER_EXECUTABLE_OPTIONS) $< $(LINKER_OUTPUT) \
+ $(LINKER_LIBRARY_PREFIX)chicken$(LINKER_LIBRARY_SUFFIX) $(LINKER_LINK_SHARED_PROGRAM_OPTIONS) $(LIBRARIES)
+
+$(CHICKEN_PROFILE_PROGRAM)$(EXE): chicken-profile$(O) $(PRIMARY_LIBCHICKEN)
+ $(LINKER) $(LINKER_OPTIONS) $(LINKER_EXECUTABLE_OPTIONS) $< $(LINKER_OUTPUT) \
+ $(LINKER_LIBRARY_PREFIX)chicken$(LINKER_LIBRARY_SUFFIX) $(LINKER_LINK_SHARED_PROGRAM_OPTIONS) $(LIBRARIES)
+
+$(CSC_PROGRAM)$(EXE): csc$(O) $(PRIMARY_LIBCHICKEN)
+ $(LINKER) $(LINKER_OPTIONS) $(LINKER_EXECUTABLE_OPTIONS) $< $(LINKER_OUTPUT) \
+ $(LINKER_LIBRARY_PREFIX)chicken$(LINKER_LIBRARY_SUFFIX) $(LINKER_LINK_SHARED_PROGRAM_OPTIONS) $(LIBRARIES)
+
+# static executables
+
+$(CHICKEN_STATIC_EXECUTABLE): $(COMPILER_STATIC_OBJECTS) libchicken$(A)
+ $(LINKER) $(LINKER_OPTIONS) $(LINKER_STATIC_OPTIONS) $(COMPILER_STATIC_OBJECTS) \
+ $(LINKER_OUTPUT) libchicken$(A) $(LIBRARIES)
+$(CSI_STATIC_EXECUTABLE): csi$(O) libchicken$(A)
+ $(LINKER) $(LINKER_OPTIONS) $(LINKER_STATIC_OPTIONS) $< $(LINKER_OUTPUT) \
+ libchicken$(A) $(LIBRARIES)
+$(CHICKEN_BUG_PROGRAM)$(EXE): chicken-bug$(O) libchicken$(A)
+ $(LINKER) $(LINKER_OPTIONS) $(LINKER_STATIC_OPTIONS) $< $(LINKER_OUTPUT) \
+ libchicken$(A) $(LIBRARIES)
+
+# installation
+
+.PHONY: install uninstall install-libs install-import-libs install-setup-files \
+ install-dirs
+
+install-libs:
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_STATIC_LIBRARY_OPTIONS) libchicken$(A) $(DESTDIR)$(ILIBDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_STATIC_LIBRARY_OPTIONS) libuchicken$(A) $(DESTDIR)$(ILIBDIR)
+ifneq ($(LIBCHICKEN_IMPORT_LIBRARY),)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_STATIC_LIBRARY_OPTIONS) $(LIBCHICKEN_IMPORT_LIBRARY) $(DESTDIR)$(ILIBDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_STATIC_LIBRARY_OPTIONS) $(LIBUCHICKEN_IMPORT_LIBRARY) $(DESTDIR)$(ILIBDIR)
+ifdef WINDOWS
+ -$(INSTALL_PROGRAM) $(INSTALL_PROGRAM_STATIC_LIBRARY_OPTIONS) libchickengui$(A) $(DESTDIR)$(ILIBDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_STATIC_LIBRARY_OPTIONS) $(LIBCHICKENGUI_IMPORT_LIBRARY) $(DESTDIR)$(ILIBDIR)
+endif
+endif
+ifneq ($(POSTINSTALL_STATIC_LIBRARY),true)
+ $(POSTINSTALL_STATIC_LIBRARY) $(POSTINSTALL_STATIC_LIBRARY_FLAGS) \
+ $(ILIBDIR)$(SEP)libchicken$(A)
+ $(POSTINSTALL_STATIC_LIBRARY) $(POSTINSTALL_STATIC_LIBRARY_FLAGS) \
+ $(ILIBDIR)$(SEP)libuchicken$(A)
+endif
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)chicken.h $(DESTDIR)$(IINCDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(CHICKEN_CONFIG_H) $(DESTDIR)$(IINCDIR)
+ifndef STATICBUILD
+ifdef DLLSINPATH
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_SHARED_LIBRARY_OPTIONS) $(LIBCHICKEN_SO_FILE) $(DESTDIR)$(IBINDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_SHARED_LIBRARY_OPTIONS) $(LIBUCHICKEN_SO_FILE) $(DESTDIR)$(IBINDIR)
+else
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_SHARED_LIBRARY_OPTIONS) $(LIBCHICKEN_SO_FILE) \
+ $(DESTDIR)$(ILIBDIR)$(SEP)$(LIBCHICKEN_SO_FILE)$(SONAME_VERSION)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_SHARED_LIBRARY_OPTIONS) $(LIBUCHICKEN_SO_FILE) \
+ $(DESTDIR)$(ILIBDIR)$(SEP)$(LIBUCHICKEN_SO_FILE)$(SONAME_VERSION)
+endif
+ifdef WINDOWS
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_SHARED_LIBRARY_OPTIONS) libchickengui$(SO) $(DESTDIR)$(IBINDIR)
+endif
+ifdef USES_SONAME
+ cd $(DESTDIR)$(ILIBDIR) && ln -sf $(LIBCHICKEN_SO_FILE).$(BINARYVERSION) libchicken$(SO)
+ cd $(DESTDIR)$(ILIBDIR) && ln -sf $(LIBUCHICKEN_SO_FILE).$(BINARYVERSION) libuchicken$(SO)
+endif
+endif
+
+install-dirs:
+ifneq ($(DESTDIR),)
+ $(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) $(DESTDIR)
+endif
+ $(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) $(DESTDIR)$(ILIBDIR)
+ $(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) $(DESTDIR)$(ICHICKENLIBDIR)
+ $(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) $(DESTDIR)$(IEGGDIR)
+ $(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) $(DESTDIR)$(IDATADIR)
+ $(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) $(DESTDIR)$(IINCDIR)
+ $(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) $(DESTDIR)$(IBINDIR)
+ $(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) $(DESTDIR)$(IMANDIR)
+ $(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) $(DESTDIR)$(ITOPMANDIR)
+ $(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) $(DESTDIR)$(IDOCDIR)
+
+ifeq ($(NEEDS_RELINKING),yes)
+install:
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(CHICKEN_PROGRAM)$(EXE) \
+ $(CSI_PROGRAM)$(EXE) $(CSC_PROGRAM)$(EXE) $(CHICKEN_PROFILE_PROGRAM)$(EXE) \
+ $(CHICKEN_INSTALL_PROGRAM)$(EXE) $(CHICKEN_UNINSTALL_PROGRAM)$(EXE) \
+ $(CHICKEN_STATUS_PROGRAM)$(EXE) $(CHICKEN_SETUP_PROGRAM)$(EXE) \
+ $(LIBCHICKEN_SO_FILE) $(LIBUCHICKEN_SO_FILE) \
+ $(IMPORT_LIBRARIES:%=%.so) $(IMPORT_LIBRARIES:%=%.import.so)
+ $(MAKE) -f $(SRCDIR)Makefile.$(PLATFORM) NEEDS_RELINKING=no RUNTIME_LINKER_PATH=$(LIBDIR) \
+ SONAME_VERSION=.$(BINARYVERSION) install
+ $(MAKE_WRITABLE_COMMAND) $(CHICKEN_PROGRAM)$(EXE) $(CSI_PROGRAM)$(EXE) \
+ $(CSC_PROGRAM)$(EXE) $(CHICKEN_PROFILE_PROGRAM)$(EXE)
+ifndef STATICBUILD
+ $(MAKE_WRITABLE_COMMAND) $(CHICKEN_INSTALL_PROGRAM)$(EXE)
+ $(MAKE_WRITABLE_COMMAND) $(CHICKEN_UNINSTALL_PROGRAM)$(EXE)
+ $(MAKE_WRITABLE_COMMAND) $(CHICKEN_STATUS_PROGRAM)$(EXE)
+endif
+else
+install: $(TARGETS) install-dirs install-libs install-import-libs \
+ install-setup-files
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) $(CHICKEN_PROGRAM)$(EXE) $(DESTDIR)$(IBINDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) $(CSI_PROGRAM)$(EXE) $(DESTDIR)$(IBINDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) $(CHICKEN_PROFILE_PROGRAM)$(EXE) $(DESTDIR)$(IBINDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) $(CSC_PROGRAM)$(EXE) $(DESTDIR)$(IBINDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) $(CHICKEN_BUG_PROGRAM)$(EXE) $(DESTDIR)$(IBINDIR)
+ifneq ($(POSTINSTALL_PROGRAM),true)
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IBINDIR)$(SEP)$(CHICKEN_PROGRAM)
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IBINDIR)$(SEP)$(CSI_PROGRAM)
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IBINDIR)$(SEP)$(CHICKEN_PROFILE_PROGRAM)
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IBINDIR)$(SEP)$(CSC_PROGRAM)
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IBINDIR)$(SEP)$(CHICKEN_BUG_PROGRAM)
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)setup-api.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)setup-download.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)setup-api.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)setup-download.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)chicken.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)lolevel.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)srfi-1.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)srfi-4.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)data-structures.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)ports.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)files.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)posix.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)srfi-13.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)srfi-69.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)extras.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)regex.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)irregex.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)srfi-14.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)tcp.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)foreign.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)scheme.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)csi.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)srfi-18.import.so
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IEGGDIR)$(SEP)utils.import.so
+endif
+ifndef STATICBUILD
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) $(CHICKEN_INSTALL_PROGRAM)$(EXE) $(DESTDIR)$(IBINDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) $(CHICKEN_UNINSTALL_PROGRAM)$(EXE) $(DESTDIR)$(IBINDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) $(CHICKEN_STATUS_PROGRAM)$(EXE) $(DESTDIR)$(IBINDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) $(CHICKEN_SETUP_PROGRAM)$(EXE) $(DESTDIR)$(IBINDIR)
+ifneq ($(POSTINSTALL_PROGRAM),true)
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IBINDIR)$(SEP)$(CHICKEN_INSTALL_PROGRAM)
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IBINDIR)$(SEP)$(CHICKEN_UNINSTALL_PROGRAM)
+ $(POSTINSTALL_PROGRAM) $(POSTINSTALL_PROGRAM_FLAGS) $(DESTDIR)$(IBINDIR)$(SEP)$(CHICKEN_STATUS_PROGRAM)
+endif
+# this might be left over from older version and will break `chicken-install -update-db'
+ -$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(IEGGDIR)$(SEP)compiler.import.so
+ifneq ($(CROSS_CHICKEN),1)
+ifeq ($(DESTDIR),)
+ -$(DESTDIR)$(IBINDIR)$(SEP)$(CHICKEN_INSTALL_PROGRAM) -update-db
+else
+ @echo
+ @echo "Warning: cannot run chicken-install -update-db when DESTDIR is set"
+ @echo
+endif
+endif
+endif
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)chicken.1 $(DESTDIR)$(IMANDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)csi.1 $(DESTDIR)$(IMANDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)csc.1 $(DESTDIR)$(IMANDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)chicken-install.1 $(DESTDIR)$(IMANDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)chicken-uninstall.1 $(DESTDIR)$(IMANDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)chicken-status.1 $(DESTDIR)$(IMANDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)chicken-profile.1 $(DESTDIR)$(IMANDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)chicken-bug.1 $(DESTDIR)$(IMANDIR)
+ $(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) $(DESTDIR)$(IDOCDIR)$(SEP)html
+ -$(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)html$(SEP)* $(DESTDIR)$(IDOCDIR)$(SEP)html
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)README $(DESTDIR)$(IDOCDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)LICENSE $(DESTDIR)$(IDOCDIR)
+ifdef WINDOWS_SHELL
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) $(SRCDIR)csibatch.bat $(DESTDIR)$(IBINDIR)
+endif
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)types.db $(DESTDIR)$(IEGGDIR)
+endif
+
+ifdef STATICBUILD
+# copy/xcopy is too dumb on Windows
+install-import-libs:
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) scheme.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) chicken.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) lolevel.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) srfi-1.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) srfi-4.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) data-structures.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) ports.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) files.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) posix.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) srfi-13.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) srfi-69.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) extras.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) regex.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) srfi-14.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) tcp.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) foreign.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) srfi-18.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) utils.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) csi.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) irregex.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) setup-api.import.scm $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) setup-download.import.scm $(DESTDIR)$(IEGGDIR)
+else
+install-import-libs:
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) scheme.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) chicken.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) lolevel.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) srfi-1.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) srfi-4.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) data-structures.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) ports.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) files.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) posix.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) srfi-13.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) srfi-69.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) extras.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) regex.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) srfi-14.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) tcp.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) foreign.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) srfi-18.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) utils.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) csi.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) irregex.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) setup-api.import.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) setup-download.import.so $(DESTDIR)$(IEGGDIR)
+endif
+
+install-setup-files:
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)setup.defaults $(DESTDIR)$(IDATADIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) setup-api.so $(DESTDIR)$(IEGGDIR)
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) setup-download.so $(DESTDIR)$(IEGGDIR)
+
+uninstall:
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(IBINDIR)$(SEP)$(CHICKEN_PROGRAM)$(EXE) \
+ $(DESTDIR)$(IBINDIR)$(SEP)$(CSI_PROGRAM)$(EXE) $(DESTDIR)$(IBINDIR)$(SEP)$(CHICKEN_PROFILE_PROGRAM)$(EXE) \
+ $(DESTDIR)$(IBINDIR)$(SEP)$(CHICKEN_INSTALL_PROGRAM)$(EXE) \
+ $(DESTDIR)$(IBINDIR)$(SEP)$(CHICKEN_UNINSTALL_PROGRAM)$(EXE) \
+ $(DESTDIR)$(IBINDIR)$(SEP)$(CHICKEN_STATUS_PROGRAM)$(EXE) \
+ $(DESTDIR)$(IBINDIR)$(SEP)$(CSC_PROGRAM)$(EXE) \
+ $(DESTDIR)$(IBINDIR)$(SEP)$(CHICKEN_BUG_PROGRAM)$(EXE) \
+ $(DESTDIR)$(IBINDIR)$(SEP)$(CHICKEN_SETUP_PROGRAM)$(EXE)
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(ILIBDIR)$(SEP)libchicken$(A)
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(ILIBDIR)$(SEP)libuchicken$(A)
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(ILIBDIR)$(SEP)libchicken$(SO)
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(ILIBDIR)$(SEP)libuchicken$(SO)
+ifdef USES_SONAME
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(ILIBDIR)$(SEP)libchicken$(SO).$(BINARYVERSION)
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(ILIBDIR)$(SEP)libuchicken$(SO).$(BINARYVERSION)
+endif
+ifdef WINDOWS
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(IBINDIR)$(SEP)libchicken$(SO)
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(IBINDIR)$(SEP)libuchicken$(SO)
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(IBINDIR)$(SEP)libchickengui$(SO)
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(ILIBDIR)$(SEP)libchickengui$(A)
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(ILIBDIR)$(SEP)$(LIBCHICKEN_IMPORT_LIBRARY)
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(ILIBDIR)$(SEP)$(LIBUCHICKEN_IMPORT_LIBRARY)
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(ILIBDIR)$(SEP)$(LIBCHICKENGUI_IMPORT_LIBRARY)
+endif
+ifdef ($(PLATFORM),cygwin)
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(IBINDIR)$(SEP)cygchicken* $(DESTDIR)$(IBINDIR)$(SEP)cyguchicken*
+endif
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(IMANDIR)$(SEP)chicken.1 $(DESTDIR)$(IMANDIR)$(SEP)csi.1 \
+ $(DESTDIR)$(IMANDIR)$(SEP)csc.1 $(DESTDIR)$(IMANDIR)$(SEP)chicken-profile.1 $(DESTDIR)$(IMANDIR)$(SEP)chicken-install.1 \
+ $(DESTDIR)$(IMANDIR)$(SEP)chicken-bug.1 $(DESTDIR)$(IMANDIR)$(SEP)chicken-uninstall.1 \
+ $(DESTDIR)$(IMANDIR)$(SEP)chicken-status.1
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(IINCDIR)$(SEP)chicken.h $(DESTDIR)$(IINCDIR)$(SEP)chicken-config.h
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_RECURSIVE_OPTIONS) $(DESTDIR)$(IDATADIR)
+ifdef WINDOWS_SHELL
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DESTDIR)$(IBINDIR)$(SEP)csibatch.bat
+endif
+
+# bootstrapping c sources
+
+.SUFFIXES: .scm
+.SECONDARY: setup-api.import.scm setup-download.import.scm
+
+setup-api.import.scm: setup-api.c
+setup-download.import.scm: setup-download.c
+
+library.c: $(SRCDIR)library.scm $(SRCDIR)version.scm $(SRCDIR)banner.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+eval.c: $(SRCDIR)eval.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+expand.c: $(SRCDIR)expand.scm $(SRCDIR)synrules.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+chicken-syntax.c: $(SRCDIR)chicken-syntax.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+data-structures.c: $(SRCDIR)data-structures.scm $(SRCDIR)private-namespace.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@ -extend $(SRCDIR)private-namespace.scm
+ports.c: $(SRCDIR)ports.scm $(SRCDIR)private-namespace.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@ -extend $(SRCDIR)private-namespace.scm
+files.c: $(SRCDIR)files.scm $(SRCDIR)private-namespace.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@ -extend $(SRCDIR)private-namespace.scm
+extras.c: $(SRCDIR)extras.scm $(SRCDIR)private-namespace.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@ -extend $(SRCDIR)private-namespace.scm
+lolevel.c: $(SRCDIR)lolevel.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+tcp.c: $(SRCDIR)tcp.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+srfi-1.c: $(SRCDIR)srfi-1.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+srfi-4.c: $(SRCDIR)srfi-4.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+srfi-13.c: $(SRCDIR)srfi-13.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+srfi-14.c: $(SRCDIR)srfi-14.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+srfi-18.c: $(SRCDIR)srfi-18.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+srfi-69.c: $(SRCDIR)srfi-69.scm $(SRCDIR)private-namespace.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@ -extend $(SRCDIR)private-namespace.scm
+utils.c: $(SRCDIR)utils.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+posixunix.c: $(SRCDIR)posixunix.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+posixwin.c: $(SRCDIR)posixwin.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+regex.c: $(SRCDIR)regex.scm $(SRCDIR)irregex.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+scheduler.c: $(SRCDIR)scheduler.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+profiler.c: $(SRCDIR)profiler.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+stub.c: $(SRCDIR)stub.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) -output-file $@
+
+ulibrary.c: $(SRCDIR)library.scm $(SRCDIR)version.scm $(SRCDIR)banner.scm $(SRCDIR)unsafe-declarations.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
+ueval.c: $(SRCDIR)eval.scm $(SRCDIR)unsafe-declarations.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
+udata-structures.c: $(SRCDIR)data-structures.scm $(SRCDIR)private-namespace.scm $(SRCDIR)unsafe-declarations.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@ -extend $(SRCDIR)private-namespace.scm
+uports.c: $(SRCDIR)ports.scm $(SRCDIR)private-namespace.scm $(SRCDIR)unsafe-declarations.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
+ufiles.c: $(SRCDIR)files.scm $(SRCDIR)private-namespace.scm $(SRCDIR)unsafe-declarations.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
+uextras.c: $(SRCDIR)extras.scm $(SRCDIR)private-namespace.scm $(SRCDIR)unsafe-declarations.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@ -extend $(SRCDIR)private-namespace.scm
+ulolevel.c: $(SRCDIR)lolevel.scm $(SRCDIR)unsafe-declarations.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
+utcp.c: $(SRCDIR)tcp.scm $(SRCDIR)unsafe-declarations.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
+usrfi-1.c: $(SRCDIR)srfi-1.scm $(SRCDIR)unsafe-declarations.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
+usrfi-4.c: $(SRCDIR)srfi-4.scm $(SRCDIR)unsafe-declarations.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
+usrfi-13.c: $(SRCDIR)srfi-13.scm $(SRCDIR)unsafe-declarations.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
+usrfi-14.c: $(SRCDIR)srfi-14.scm $(SRCDIR)unsafe-declarations.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
+usrfi-18.c: $(SRCDIR)srfi-18.scm $(SRCDIR)unsafe-declarations.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
+usrfi-69.c: $(SRCDIR)srfi-69.scm $(SRCDIR)private-namespace.scm $(SRCDIR)unsafe-declarations.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@ -extend $(SRCDIR)private-namespace.scm
+uutils.c: $(SRCDIR)utils.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
+uposixunix.c: $(SRCDIR)posixunix.scm $(SRCDIR)unsafe-declarations.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
+uposixwin.c: $(SRCDIR)posixwin.scm $(SRCDIR)unsafe-declarations.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
+uregex.c: $(SRCDIR)regex.scm $(SRCDIR)irregex.scm $(SRCDIR)unsafe-declarations.scm
+ $(CHICKEN) $< $(CHICKEN_LIBRARY_OPTIONS) $(CHICKEN_UNSAFE_OPTIONS) -output-file $@
+
+chicken.import.c: $(SRCDIR)chicken.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+lolevel.import.c: $(SRCDIR)lolevel.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+srfi-1.import.c: $(SRCDIR)srfi-1.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+srfi-4.import.c: $(SRCDIR)srfi-4.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+data-structures.import.c: $(SRCDIR)data-structures.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+ports.import.c: $(SRCDIR)ports.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+files.import.c: $(SRCDIR)files.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+posix.import.c: $(SRCDIR)posix.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+srfi-13.import.c: $(SRCDIR)srfi-13.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+srfi-69.import.c: $(SRCDIR)srfi-69.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+extras.import.c: $(SRCDIR)extras.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+regex.import.c: $(SRCDIR)regex.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+irregex.import.c: $(SRCDIR)irregex.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+srfi-14.import.c: $(SRCDIR)srfi-14.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+tcp.import.c: $(SRCDIR)tcp.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+foreign.import.c: $(SRCDIR)foreign.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+scheme.import.c: $(SRCDIR)scheme.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+csi.import.c: $(SRCDIR)csi.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+srfi-18.import.c: $(SRCDIR)srfi-18.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+utils.import.c: $(SRCDIR)utils.import.scm
+ $(CHICKEN) $< $(CHICKEN_IMPORT_LIBRARY_OPTIONS) -output-file $@
+setup-api.import.c: $(SRCDIR)setup-api.scm
+ $(CHICKEN) $(SRCDIR)setup-api.import.scm $(CHICKEN_IMPORT_LIBRARY_OPTIONS) \
+ -ignore-repository -output-file $@
+setup-download.import.c: $(SRCDIR)setup-download.scm
+ $(CHICKEN) $(SRCDIR)setup-download.import.scm $(CHICKEN_IMPORT_LIBRARY_OPTIONS) \
+ -ignore-repository -output-file $@
+
+chicken.c: $(SRCDIR)chicken.scm $(SRCDIR)chicken-ffi-syntax.scm $(SRCDIR)compiler-namespace.scm \
+ $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
+ $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
+support.c: $(SRCDIR)support.scm $(SRCDIR)banner.scm $(SRCDIR)compiler-namespace.scm \
+ $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
+ $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
+compiler.c: $(SRCDIR)compiler.scm $(SRCDIR)compiler-namespace.scm \
+ $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
+ $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
+optimizer.c: $(SRCDIR)optimizer.scm $(SRCDIR)compiler-namespace.scm \
+ $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
+ $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
+compiler-syntax.c: $(SRCDIR)compiler-syntax.scm $(SRCDIR)compiler-namespace.scm \
+ $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
+ $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
+scrutinizer.c: $(SRCDIR)scrutinizer.scm $(SRCDIR)compiler-namespace.scm \
+ $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
+ $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
+batch-driver.c: $(SRCDIR)batch-driver.scm $(SRCDIR)compiler-namespace.scm \
+ $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
+ $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
+c-platform.c: $(SRCDIR)c-platform.scm $(SRCDIR)compiler-namespace.scm \
+ $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
+ $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
+c-backend.c: $(SRCDIR)c-backend.scm $(SRCDIR)compiler-namespace.scm \
+ $(SRCDIR)private-namespace.scm $(SRCDIR)tweaks.scm
+ $(CHICKEN) $< $(CHICKEN_COMPILER_OPTIONS) -output-file $@
+
+csi.c: $(SRCDIR)csi.scm $(SRCDIR)banner.scm $(SRCDIR)private-namespace.scm
+ $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@ -extend $(SRCDIR)private-namespace.scm
+chicken-profile.c: $(SRCDIR)chicken-profile.scm
+ $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
+chicken-install.c: $(SRCDIR)chicken-install.scm setup-download.c
+ $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -ignore-repository -output-file $@
+chicken-uninstall.c: $(SRCDIR)chicken-uninstall.scm
+ $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -ignore-repository -output-file $@
+chicken-status.c: $(SRCDIR)chicken-status.scm
+ $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -ignore-repository -output-file $@
+chicken-setup.c: $(SRCDIR)chicken-setup.scm
+ $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -ignore-repository -output-file $@
+csc.c: $(SRCDIR)csc.scm
+ $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
+chicken-bug.c: $(SRCDIR)chicken-bug.scm
+ $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
+
+setup-api.c: $(SRCDIR)setup-api.scm
+ $(CHICKEN) $< $(CHICKEN_DYNAMIC_OPTIONS) -emit-import-library setup-api \
+ -ignore-repository -output-file $@
+setup-download.c: $(SRCDIR)setup-download.scm setup-api.c
+ $(CHICKEN) $< $(CHICKEN_DYNAMIC_OPTIONS) -emit-import-library setup-download \
+ -ignore-repository -output-file $@
+
+# distribution files
+
+.PHONY: distfiles dist html
+
+distfiles: buildsvnrevision library.c eval.c expand.c chicken-syntax.c \
+ data-structures.c ports.c files.c extras.c lolevel.c utils.c \
+ tcp.c srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c srfi-69.c \
+ posixunix.c posixwin.c regex.c scheduler.c profiler.c stub.c \
+ ulibrary.c ueval.c udata-structures.c uports.c ufiles.c uextras.c ulolevel.c \
+ uutils.c utcp.c usrfi-1.c usrfi-4.c usrfi-13.c usrfi-14.c \
+ usrfi-18.c usrfi-69.c uposixunix.c uposixwin.c uregex.c \
+ chicken-profile.c chicken-install.c chicken-uninstall.c chicken-status.c chicken-setup.c \
+ csc.c csi.c chicken.c batch-driver.c compiler.c optimizer.c \
+ compiler-syntax.c scrutinizer.c support.c \
+ c-platform.c c-backend.c chicken-bug.c $(IMPORT_LIBRARIES:=.import.c)
+
+dist: distfiles
+ CSI=$(CSI) $(CSI) -s $(SRCDIR)scripts$(SEP)makedist.scm --platform=$(PLATFORM) CHICKEN=$(CHICKEN)
+
+html:
+ $(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) $(SRCDIR)html
+ $(COPY_COMMAND) $(SRCDIR)misc$(SEP)manual.css $(SRCDIR)html
+ $(CSI) -s $(SRCDIR)scripts$(SEP)wiki2html.scm --outdir=html manual$(SEP)*
+
+# cleaning up
+
+.PHONY: clean distclean spotless confclean testclean
+
+ifeq ($(PLATFORM),mingw)
+CLEAN_MINGW_LIBS = libchickengui.a libchickengui.dll libchickengui.dll.a
+else
+CLEAN_MINGW_LIBS =
+endif
+
+clean:
+ -$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) chicken$(EXE) csi$(EXE) csc$(EXE) \
+ chicken-profile$(EXE) csi-static$(EXE) \
+ chicken-install$(EXE) chicken-uninstall$(EXE) chicken-status$(EXE) chicken-setup$(EXE) \
+ csc-static$(EXE) chicken-static$(EXE) chicken-bug$(EXE) *$(O) \
+ $(LIBCHICKEN_SO_FILE) $(LIBUCHICKEN_SO_FILE) $(LIBCHICKENGUI_SO_FILE) \
+ libchicken$(A) libuchicken$(A) libchickengui$(A) libchicken$(SO) $(PROGRAM_IMPORT_LIBRARIES) \
+ $(IMPORT_LIBRARIES:=.import.so) $(LIBCHICKEN_IMPORT_LIBRARY) $(LIBUCHICKEN_IMPORT_LIBRARY) \
+ $(LIBCHICKENGUI_IMPORT_LIBRARY) setup-api.so setup-download.so \
+ $(CLEAN_MINGW_LIBS)
+ifdef USES_SONAME
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) libchicken.so.$(BINARYVERSION)
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) libuchicken.so.$(BINARYVERSION)
+endif
+
+confclean:
+ -$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) chicken-config.h chicken-defaults.h buildsvnrevision
+
+spotless: distclean testclean
+ -$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) library.c eval.c data-structures.c \
+ ports.c files.c extras.c lolevel.c utils.c chicken-syntax.c \
+ tcp.c srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c srfi-69.c expand.c \
+ posixunix.c posixwin.c regex.c scheduler.c profiler.c stub.c \
+ ulibrary.c ueval.c udata-structures.c uports.c ufiles.c uextras.c ulolevel.c \
+ uutils.c utcp.c usrfi-1.c usrfi-4.c usrfi-13.c usrfi-14.c \
+ usrfi-18.c usrfi-69.c uposixunix.c uposixwin.c uregex.c chicken-profile.c chicken-bug.c \
+ csc.c csi.c chicken-install.c chicken-setup.c chicken-uninstall.c chicken-status.c \
+ chicken.c batch-driver.c compiler.c optimizer.c compiler-syntax.c \
+ scrutinizer.c support.c \
+ c-platform.c c-backend.c chicken-boot$(EXE) setup-api.c setup-download.c \
+ $(IMPORT_LIBRARIES:=.import.c)
+
+distclean: clean confclean
+
+testclean:
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(SRCDIR)tests$(SEP)a.out $(SRCDIR)tests$(SEP)scrutiny.out \
+ $(SRCDIR)tests$(SEP)tmp* $(SRCDIR)tests$(SEP)*.so $(SRCDIR)tests$(SEP)*.import.scm $(SRCDIR)tests$(SEP)repository
+
+# run tests
+
+.PHONY: check fullcheck compiler-check
+
+check: $(CHICKEN_SHARED_EXECUTABLE) $(CSI_SHARED_EXECUTABLE) $(CSC_PROGRAM)
+ cd tests; sh runtests.sh
+
+# Only for UNIX, yet:
+
+fullcheck: check compiler-check
+
+compiler-check:
+ @echo "======================================== packing ..."
+ $(MAKE) -f $(SRCDIR)Makefile.$(PLATFORM) dist
+ $(REMOVE_COMMAND $(REMOVE_COMMAND_RECURSIVE_OPTIONS) tests$(SEP)chicken-*
+ tar -C tests -xzf `ls -t chicken-*.tar.gz | head -1`
+ @echo "======================================== building stage 1 ..."
+ $(MAKE) -f $(SRCDIR)Makefile.$(PLATFORM) STATICBUILD=1 -C tests$(SEP)chicken-* confclean all
+ touch tests$(SEP)chicken-*$(SEP)*.scm
+ @echo "======================================== building stage 2 ..."
+ $(MAKE) -f $(SRCDIR)Makefile.$(PLATFORM) STATICBUILD=1 -C tests$(SEP)chicken-* confclean all
+ cat tests$(SEP)chicken-*$(SEP)*.c >tests$(SEP)stage2.out
+ @echo "======================================== building stage 3 ..."
+ $(MAKE) -f $(SRCDIR)Makefile.$(PLATFORM) STATICBUILD=1 -C tests$(SEP)chicken-* confclean all
+ cat tests$(SEP)chicken-*$(SEP)*.c >tests$(SEP)stage3.out
+ diff tests$(SEP)stage2.out tests$(SEP)stage3.out >tests$(SEP)stages.diff
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_RECURSIVE_OPTIONS) tests$(SEP)chicken-*
+
+
+# bootstrap from C source tarball
+
+.PHONY: bootstrap bootstrap.tar.gz
+
+bootstrap:
+ gzip -d -c $(SRCDIR)bootstrap.tar.gz | tar xvf -
+ touch *.c
+ $(MAKE) -f $(SRCDIR)Makefile.$(PLATFORM) STATICBUILD=1 DEBUGBUILD=1 PLATFORM=$(PLATFORM) \
+ chicken$(EXE)
+ $(COPY_COMMAND) chicken$(EXE) chicken-boot$(EXE)
+ touch *.scm
+ $(MAKE) -f $(SRCDIR)Makefile.$(PLATFORM) PLATFORM=$(PLATFORM) confclean
+
+$(SRCDIR)bootstrap.tar.gz: distfiles
+ tar cfz $@ library.c eval.c data-structures.c ports.c files.c extras.c lolevel.c utils.c tcp.c \
+ srfi-1.c srfi-4.c srfi-13.c srfi-14.c srfi-18.c srfi-69.c posixunix.c posixwin.c regex.c \
+ scheduler.c profiler.c stub.c expand.c chicken-syntax.c \
+ $(COMPILER_OBJECTS_1:=.c)
+
+
+# benchmarking
+
+.PHONY: bench
+
+bench:
+ @here=`pwd`; \
+ cd $(SRCDIR)benchmarks; \
+ LD_LIBRARY_PATH=$$here DYLD_LIBRARY_PATH=$$here PATH=$$here:$$PATH \
+ $(CSI) -s cscbench.scm $(BENCHMARK_OPTIONS)
diff --git a/runtime.c b/runtime.c
new file mode 100644
index 00000000..9a10ba07
--- /dev/null
+++ b/runtime.c
@@ -0,0 +1,9571 @@
+/* runtime.c - Runtime code for compiler generated executables
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+*/
+
+#include "chicken.h"
+#include <errno.h>
+#include <signal.h>
+#include <assert.h>
+#include <limits.h>
+#include <math.h>
+
+#ifdef HAVE_SYSEXITS_H
+# include <sysexits.h>
+#endif
+
+#if !defined(PIC)
+# define NO_DLOAD2
+#endif
+
+#ifndef NO_DLOAD2
+# ifdef HAVE_DLFCN_H
+# include <dlfcn.h>
+# endif
+
+# ifdef HAVE_DL_H
+# include <dl.h>
+# endif
+#endif
+
+#ifndef EX_SOFTWARE
+# define EX_SOFTWARE 70
+#endif
+
+#if !defined(C_NONUNIX)
+
+# include <sys/types.h>
+# include <sys/stat.h>
+# include <sys/time.h>
+# include <sys/resource.h>
+# include <sys/wait.h>
+
+#else
+
+# include <sys/types.h>
+# include <sys/stat.h>
+
+#ifdef ECOS
+#include <cyg/kernel/kapi.h>
+static C_TLS int timezone;
+#define NSIG 32
+#endif
+
+#endif
+
+#ifndef RTLD_GLOBAL
+# define RTLD_GLOBAL 0
+#endif
+
+#ifndef RTLD_NOW
+# define RTLD_NOW 0
+#endif
+
+#ifndef RTLD_LOCAL
+# define RTLD_LOCAL 0
+#endif
+
+#ifndef RTLD_LAZY
+# define RTLD_LAZY 0
+#endif
+
+#ifdef HAVE_WINDOWS_H
+# include <windows.h>
+#endif
+
+#ifdef HAVE_CONFIG_H
+# ifdef PACKAGE
+# undef PACKAGE
+# endif
+# ifdef VERSION
+# undef VERSION
+# endif
+# include <chicken-config.h>
+
+# ifndef HAVE_ALLOCA
+# error this package requires "alloca()"
+# endif
+#endif
+
+#ifdef _MSC_VER
+# define S_IFMT _S_IFMT
+# define S_IFDIR _S_IFDIR
+# define timezone _timezone
+# if defined(_M_IX86)
+# ifndef C_HACKED_APPLY
+# define C_HACKED_APPLY
+# endif
+# endif
+#else
+# ifdef C_HACKED_APPLY
+# if defined(__MACH__) || defined(__MINGW32__) || defined(__CYGWIN__)
+extern void C_do_apply_hack(void *proc, C_word *args, int count) C_noret;
+# else
+extern void _C_do_apply_hack(void *proc, C_word *args, int count) C_noret;
+# define C_do_apply_hack _C_do_apply_hack
+# endif
+# endif
+#endif
+
+#if defined(C_NO_HACKED_APPLY) && defined(C_HACKED_APPLY)
+# undef C_HACKED_APPLY
+#endif
+
+/* Parameters: */
+
+#define RELAX_MULTIVAL_CHECK
+
+#define DEFAULT_STACK_SIZE 64000
+#define DEFAULT_SYMBOL_TABLE_SIZE 2999
+#define DEFAULT_HEAP_SIZE 500000
+#define MINIMAL_HEAP_SIZE 500000
+#define DEFAULT_MAXIMAL_HEAP_SIZE 0x7ffffff0
+#define DEFAULT_HEAP_GROWTH 200
+#define DEFAULT_HEAP_SHRINKAGE 50
+#define DEFAULT_HEAP_SHRINKAGE_USED 25
+#define DEFAULT_FORWARDING_TABLE_SIZE 32
+#define DEFAULT_LOCATIVE_TABLE_SIZE 32
+#define DEFAULT_COLLECTIBLES_SIZE 1024
+#define DEFAULT_TRACE_BUFFER_SIZE 8
+
+#define MAX_HASH_PREFIX 64
+
+#define WEAK_TABLE_SIZE 997
+#define WEAK_HASH_ITERATIONS 4
+#define WEAK_HASH_DISPLACEMENT 7
+#define WEAK_COUNTER_MASK 3
+#define WEAK_COUNTER_MAX 2
+
+#define TEMPORARY_STACK_SIZE 2048
+#define STRING_BUFFER_SIZE 4096
+#define DEFAULT_MUTATION_STACK_SIZE 1024
+#define MUTATION_STACK_GROWTH 1024
+
+#define FILE_INFO_SIZE 7
+
+#ifdef C_DOUBLE_IS_32_BITS
+# define FLONUM_PRINT_PRECISION 7
+#else
+# define FLONUM_PRINT_PRECISION 15
+#endif
+
+#define WORDS_PER_FLONUM C_SIZEOF_FLONUM
+
+#define MAXIMAL_NUMBER_OF_COMMAND_LINE_ARGUMENTS 32
+
+#define INITIAL_TIMER_INTERRUPT_PERIOD 10000
+
+
+/* Constants: */
+
+#ifdef C_SIXTY_FOUR
+# define ALIGNMENT_HOLE_MARKER ((C_word)0xfffffffffffffffeL)
+# define FORWARDING_BIT_SHIFT 63
+# define UWORD_FORMAT_STRING "0x%lx"
+# define UWORD_COUNT_FORMAT_STRING "%ld"
+#else
+# define ALIGNMENT_HOLE_MARKER ((C_word)0xfffffffe)
+# define FORWARDING_BIT_SHIFT 31
+# define UWORD_FORMAT_STRING "0x%x"
+# define UWORD_COUNT_FORMAT_STRING "%d"
+#endif
+
+#define GC_MINOR 0
+#define GC_MAJOR 1
+#define GC_REALLOC 2
+
+
+/* Macros: */
+
+#ifdef PARANOIA
+# define check_alignment(p) assert(((C_word)(p) & 3) == 0)
+#else
+# ifndef NDEBUG
+# define NDEBUG
+# endif
+# define check_alignment(p)
+#endif
+
+#define aligned8(n) ((((C_word)(n)) & 7) == 0)
+#define nmax(x, y) ((x) > (y) ? (x) : (y))
+#define nmin(x, y) ((x) < (y) ? (x) : (y))
+#define percentage(n, p) ((long)(((double)(n) * (double)p) / 100))
+
+#define is_fptr(x) (((x) & C_GC_FORWARDING_BIT) != 0)
+#define ptr_to_fptr(x) ((((x) >> FORWARDING_BIT_SHIFT) & 1) | C_GC_FORWARDING_BIT | ((x) & ~1))
+#define fptr_to_ptr(x) (((x) << FORWARDING_BIT_SHIFT) | ((x) & ~(C_GC_FORWARDING_BIT | 1)))
+
+#ifdef C_UNSAFE_RUNTIME
+# define C_check_flonum(x, w)
+# define C_check_real(x, w, v) if(((x) & C_FIXNUM_BIT) != 0) v = C_unfix(x); \
+ else v = C_flonum_magnitude(x);
+# define resolve_procedure(x, w) (x)
+#else
+# define C_check_flonum(x, w) if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) \
+ barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, w, x);
+# define C_check_real(x, w, v) if(((x) & C_FIXNUM_BIT) != 0) v = C_unfix(x); \
+ else if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) \
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \
+ else v = C_flonum_magnitude(x);
+#endif
+
+#define C_isnan(f) (!((f) == (f)))
+#define C_isinf(f) ((f) == (f) + (f) && (f) != 0.0)
+
+
+/* these could be shorter in unsafe mode: */
+#define C_check_int(x, f, n, w) if(((x) & C_FIXNUM_BIT) != 0) n = C_unfix(x); \
+ else if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) \
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \
+ else { double _m; \
+ f = C_flonum_magnitude(x); \
+ if(modf(f, &_m) != 0.0 || f < C_WORD_MIN || f > C_WORD_MAX) \
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, w, x); \
+ else n = (C_word)f; \
+ }
+
+#ifdef BITWISE_UINT_ONLY
+#define C_check_uint(x, f, n, w) if(((x) & C_FIXNUM_BIT) != 0) n = C_unfix(x); \
+ else if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) \
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \
+ else { double _m; \
+ f = C_flonum_magnitude(x); \
+ if(modf(f, &_m) != 0.0 || f < 0 || f > C_UWORD_MAX) \
+ barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, w, x); \
+ else n = (C_uword)f; \
+ }
+#else
+#define C_check_uint(x, f, n, w) if(((x) & C_FIXNUM_BIT) != 0) n = C_unfix(x); \
+ else if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) \
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, w, x); \
+ else { double _m; \
+ f = C_flonum_magnitude(x); \
+ if(modf(f, &_m) != 0.0 || f > C_UWORD_MAX) \
+ barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, w, x); \
+ else n = (C_uword)f; \
+ }
+#endif
+
+#ifdef C_SIXTY_FOUR
+#define C_limit_fixnum(n) ((n) & C_MOST_POSITIVE_FIXNUM)
+#else
+#define C_limit_fixnum(n) (n)
+#endif
+
+#define C_pte(name) pt[ i ].id = #name; pt[ i++ ].ptr = (void *)name;
+
+
+/* Type definitions: */
+
+typedef void (*TOPLEVEL)(C_word c, C_word self, C_word k) C_noret;
+typedef void (C_fcall *TRAMPOLINE)(void *proc) C_regparm C_noret;
+
+typedef struct lf_list_struct
+{
+ C_word *lf;
+ int count;
+ struct lf_list_struct *next, *prev;
+ C_PTABLE_ENTRY *ptable;
+ void *module_handle;
+ char *module_name;
+} LF_LIST;
+
+typedef struct weak_table_entry_struct
+{
+ C_word item,
+ container;
+} WEAK_TABLE_ENTRY;
+
+typedef struct finalizer_node_struct
+{
+ struct finalizer_node_struct
+ *next,
+ *previous;
+ C_word
+ item,
+ finalizer;
+} FINALIZER_NODE;
+
+typedef struct trace_info_struct
+{
+ C_char *raw;
+ C_word cooked1, cooked2, thread;
+} TRACE_INFO;
+
+
+/* Variables: */
+
+C_TLS C_word
+ *C_temporary_stack,
+ *C_temporary_stack_bottom,
+ *C_temporary_stack_limit,
+ *C_stack_limit;
+C_TLS long
+ C_timer_interrupt_counter,
+ C_initial_timer_interrupt_period;
+C_TLS C_byte
+ *C_fromspace_top,
+ *C_fromspace_limit;
+C_TLS double C_temporary_flonum;
+C_TLS jmp_buf C_restart;
+C_TLS void *C_restart_address;
+C_TLS int C_entry_point_status;
+C_TLS int (*C_gc_mutation_hook)(C_word *slot, C_word val);
+C_TLS void (*C_gc_trace_hook)(C_word *var, int mode);
+C_TLS C_word(*C_get_unbound_variable_value_hook)(C_word sym);
+C_TLS void (*C_panic_hook)(C_char *msg) = NULL;
+C_TLS void (*C_pre_gc_hook)(int mode) = NULL;
+C_TLS void (*C_post_gc_hook)(int mode, long ms) = NULL;
+C_TLS void (C_fcall *C_restart_trampoline)(void *proc) C_regparm C_noret;
+
+C_TLS int
+ C_abort_on_thread_exceptions,
+ C_enable_repl,
+ C_interrupts_enabled,
+ C_disable_overflow_check,
+#ifdef C_COLLECT_ALL_SYMBOLS
+ C_enable_gcweak = 1,
+#else
+ C_enable_gcweak = 0,
+#endif
+ C_heap_size_is_fixed,
+ C_trace_buffer_size = DEFAULT_TRACE_BUFFER_SIZE,
+ C_max_pending_finalizers = C_DEFAULT_MAX_PENDING_FINALIZERS,
+ C_main_argc;
+C_TLS C_uword
+ C_heap_growth,
+ C_heap_shrinkage;
+C_TLS C_uword C_maximal_heap_size;
+C_TLS time_t C_startup_time_seconds;
+
+C_TLS char
+ **C_main_argv,
+ *C_dlerror;
+
+static C_TLS TRACE_INFO
+ *trace_buffer,
+ *trace_buffer_limit,
+ *trace_buffer_top;
+
+static C_TLS C_byte
+ *heapspace1,
+ *heapspace2,
+ *fromspace_start,
+ *tospace_start,
+ *tospace_top,
+ *tospace_limit,
+ *new_tospace_start,
+ *new_tospace_top,
+ *new_tospace_limit,
+ *heap_scan_top,
+ *timer_start_fromspace_top;
+static C_TLS size_t
+ heapspace1_size,
+ heapspace2_size;
+static C_TLS C_char
+ buffer[ STRING_BUFFER_SIZE ],
+ *current_module_name,
+ *save_string;
+static C_TLS C_SYMBOL_TABLE
+ *symbol_table,
+ *symbol_table_list;
+static C_TLS C_word
+ **collectibles,
+ **collectibles_top,
+ **collectibles_limit,
+ *saved_stack_limit,
+ **mutation_stack_bottom,
+ **mutation_stack_limit,
+ **mutation_stack_top,
+ *stack_bottom,
+ *locative_table,
+ error_location,
+ interrupt_hook_symbol,
+ current_thread_symbol,
+ error_hook_symbol,
+ invalid_procedure_call_hook_symbol,
+ unbound_variable_value_hook_symbol,
+ last_invalid_procedure_symbol,
+ identity_unbound_value_symbol,
+ apply_hook_symbol,
+ last_applied_procedure_symbol,
+ pending_finalizers_symbol,
+ callback_continuation_stack_symbol,
+ *forwarding_table;
+static C_TLS int
+ trace_buffer_full,
+ forwarding_table_size,
+ return_to_host,
+ page_size,
+ show_trace,
+ fake_tty_flag,
+ debug_mode,
+ gc_bell,
+ gc_report_flag,
+ gc_mode,
+ gc_count_1,
+ gc_count_2,
+ timer_start_gc_count_1,
+ timer_start_gc_count_2,
+ interrupt_reason,
+ stack_size_changed,
+ dlopen_flags,
+ heap_size_changed,
+ chicken_is_running,
+ chicken_ran_once,
+ callback_continuation_level;
+static C_TLS unsigned int
+ mutation_count,
+ stack_size,
+ heap_size,
+ timer_start_mutation_count;
+static C_TLS int chicken_is_initialized;
+static C_TLS jmp_buf gc_restart;
+static C_TLS long
+ timer_start_ms,
+ timer_start_gc_ms,
+ timer_accumulated_gc_ms,
+ interrupt_time,
+ last_interrupt_latency;
+static C_TLS LF_LIST
+ *lf_list,
+ *reload_lf;
+static C_TLS int signal_mapping_table[ NSIG ];
+static C_TLS int
+ locative_table_size,
+ locative_table_count,
+ live_finalizer_count,
+ allocated_finalizer_count,
+ pending_finalizer_count,
+ callback_returned_flag;
+static C_TLS WEAK_TABLE_ENTRY *weak_item_table;
+static C_TLS C_GC_ROOT *gc_root_list = NULL;
+static C_TLS FINALIZER_NODE
+ *finalizer_list,
+ *finalizer_free_list,
+ **pending_finalizer_indices;
+static C_TLS void *current_module_handle;
+static C_TLS int flonum_print_precision = FLONUM_PRINT_PRECISION;
+
+/* Prototypes: */
+
+static void parse_argv(C_char *cmds);
+static void initialize_symbol_table(void);
+static void global_signal_handler(int signum);
+static C_word arg_val(C_char *arg);
+static void barf(int code, char *loc, ...) C_noret;
+static void panic(C_char *msg) C_noret;
+static void usual_panic(C_char *msg) C_noret;
+static void horror(C_char *msg) C_noret;
+static void C_fcall initial_trampoline(void *proc) C_regparm C_noret;
+static C_ccall void termination_continuation(C_word c, C_word self, C_word result) C_noret;
+static void C_fcall mark_system_globals(void) C_regparm;
+static void C_fcall mark(C_word *x) C_regparm;
+static WEAK_TABLE_ENTRY *C_fcall lookup_weak_table_entry(C_word item, C_word container) C_regparm;
+static C_ccall void values_continuation(C_word c, C_word closure, C_word dummy, ...) C_noret;
+static C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stable);
+static int C_fcall hash_string(int len, C_char *str, unsigned int m) C_regparm;
+static C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
+static double compute_symbol_table_load(double *avg_bucket_len, int *total);
+static C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word *fix, double *flo) C_regparm;
+static long C_fcall milliseconds(void);
+static long C_fcall cpu_milliseconds(void);
+static void C_fcall remark_system_globals(void) C_regparm;
+static void C_fcall remark(C_word *x) C_regparm;
+static C_word C_fcall intern0(C_char *name) C_regparm;
+static void C_fcall update_locative_table(int mode) C_regparm;
+static C_word get_unbound_variable_value(C_word sym);
+static LF_LIST *find_lf_list_node(C_char *name);
+static C_char *checked_string_argument(char *loc, C_word hstr);
+static C_char *checked_string_or_null_argument(char *loc, C_word hstr);
+static void checked_library_query_arguments(char *loc,
+ C_word libnam, C_word libhdl, C_word lfcnt,
+ char **name, void **handle, int *count);
+static LF_LIST *make_lf_list_node(C_word *lf, int count, C_PTABLE_ENTRY *ptable, C_char *name, void *handle);
+static void link_lf_list_node(LF_LIST *node);
+static void unlink_lf_list_node(LF_LIST *node);
+static void destroy_lf_list_node(LF_LIST *node);
+static C_char *make_underscore_symstr(C_char *sym);
+
+static C_ccall void call_cc_wrapper(C_word c, C_word closure, C_word k, C_word result) C_noret;
+static C_ccall void call_cc_values_wrapper(C_word c, C_word closure, C_word k, ...) C_noret;
+static void cons_flonum_trampoline(void *dummy) C_noret;
+static void gc_2(void *dummy) C_noret;
+static void allocate_vector_2(void *dummy) C_noret;
+static void get_argv_2(void *dummy) C_noret;
+static void make_structure_2(void *dummy) C_noret;
+static void generic_trampoline(void *dummy) C_noret;
+static void file_info_2(void *dummy) C_noret;
+static void get_environment_variable_2(void *dummy) C_noret;
+static void handle_interrupt(void *trampoline, void *proc) C_noret;
+static void callback_trampoline(void *dummy) C_noret;
+static C_ccall void callback_return_continuation(C_word c, C_word self, C_word r) C_noret;
+static void become_2(void *dummy) C_noret;
+static void copy_closure_2(void *dummy) C_noret;
+
+static C_PTABLE_ENTRY *create_initial_ptable();
+
+#if !defined(NO_DLOAD2) && (defined(HAVE_DLFCN_H) || defined(HAVE_DL_H) || (defined(HAVE_LOADLIBRARY) && defined(HAVE_GETPROCADDRESS)))
+static void dload_2(void *dummy) C_noret;
+#endif
+
+
+/* Startup code: */
+
+int CHICKEN_main(int argc, char *argv[], void *toplevel)
+{
+ C_word h, s, n;
+
+#if defined(C_WINDOWS_GUI)
+ parse_argv(GetCommandLine());
+ argc = C_main_argc;
+ argv = C_main_argv;
+#endif
+
+ CHICKEN_parse_command_line(argc, argv, &h, &s, &n);
+
+ if(!CHICKEN_initialize(h, s, n, toplevel))
+ panic(C_text("cannot initialize - out of memory"));
+
+ CHICKEN_run(NULL);
+ return 0;
+}
+
+
+/* Custom argv parser for Windoze: */
+
+#ifdef C_WINDOWS_GUI
+void parse_argv(C_char *cmds)
+{
+ C_char *ptr = cmds,
+ *bptr0, *bptr, *aptr;
+ int n = 0;
+
+ C_main_argv = (C_char **)malloc(MAXIMAL_NUMBER_OF_COMMAND_LINE_ARGUMENTS * sizeof(C_char *));
+
+ if(C_main_argv == NULL)
+ panic(C_text("cannot allocate argument-list buffer"));
+
+ C_main_argc = 0;
+
+ for(;;) {
+ while(isspace(*ptr)) ++ptr;
+
+ if(*ptr == '\0') break;
+
+ for(bptr0 = bptr = buffer; !isspace(*ptr) && *ptr != '\0'; *(bptr++) = *(ptr++))
+ ++n;
+
+ *bptr = '\0';
+ aptr = (C_char *)malloc(sizeof(C_char) * (n + 1));
+
+ if(aptr == NULL)
+ panic(C_text("cannot allocate argument buffer"));
+
+ C_strcpy(aptr, bptr0);
+ C_main_argv[ C_main_argc++ ] = aptr;
+ }
+}
+#endif
+
+
+/* Initialize runtime system: */
+
+int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
+{
+ int i;
+
+ /*FIXME Should have C_tzset in chicken.h? */
+#ifdef C_NONUNIX
+ C_startup_time_seconds = (time_t)0;
+# if defined(_MSC_VER) || defined(__MINGW32__)
+ /* Make sure _tzname, _timezone, and _daylight are set */
+ _tzset();
+# endif
+#else
+ struct timeval tv;
+ C_gettimeofday(&tv, NULL);
+ C_startup_time_seconds = tv.tv_sec;
+ /* Make sure tzname, timezone, and daylight are set */
+ tzset();
+#endif
+
+ if(chicken_is_initialized) return 1;
+ else chicken_is_initialized = 1;
+
+ if(debug_mode) C_printf(C_text("[debug] application startup...\n"));
+
+ C_panic_hook = usual_panic;
+ symbol_table_list = NULL;
+
+ if((symbol_table = C_new_symbol_table(".", symbols ? symbols : DEFAULT_SYMBOL_TABLE_SIZE)) == NULL)
+ return 0;
+
+ page_size = 0;
+ stack_size = stack ? stack : DEFAULT_STACK_SIZE;
+ C_set_or_change_heap_size(heap ? heap : DEFAULT_HEAP_SIZE, 0);
+
+ /* Allocate temporary stack: */
+ if((C_temporary_stack_limit = (C_word *)C_malloc(TEMPORARY_STACK_SIZE * sizeof(C_word))) == NULL)
+ return 0;
+
+ C_temporary_stack_bottom = C_temporary_stack_limit + TEMPORARY_STACK_SIZE;
+ C_temporary_stack = C_temporary_stack_bottom;
+
+ /* Allocate mutation stack: */
+ mutation_stack_bottom = (C_word **)C_malloc(DEFAULT_MUTATION_STACK_SIZE * sizeof(C_word *));
+
+ if(mutation_stack_bottom == NULL) return 0;
+
+ mutation_stack_top = mutation_stack_bottom;
+ mutation_stack_limit = mutation_stack_bottom + DEFAULT_MUTATION_STACK_SIZE;
+ C_gc_mutation_hook = NULL;
+ C_gc_trace_hook = NULL;
+ C_get_unbound_variable_value_hook = get_unbound_variable_value;
+
+ /* Allocate weak item table: */
+ if(C_enable_gcweak) {
+ if((weak_item_table = (WEAK_TABLE_ENTRY *)C_calloc(WEAK_TABLE_SIZE, sizeof(WEAK_TABLE_ENTRY))) == NULL)
+ return 0;
+ }
+
+ /* Initialize finalizer lists: */
+ finalizer_list = NULL;
+ finalizer_free_list = NULL;
+ pending_finalizer_indices =
+ (FINALIZER_NODE **)C_malloc(C_max_pending_finalizers * sizeof(FINALIZER_NODE *));
+
+ if(pending_finalizer_indices == NULL) return 0;
+
+ /* Initialize forwarding table: */
+ forwarding_table =
+ (C_word *)C_malloc((DEFAULT_FORWARDING_TABLE_SIZE + 1) * 2 * sizeof(C_word));
+
+ if(forwarding_table == NULL) return 0;
+
+ *forwarding_table = 0;
+ forwarding_table_size = DEFAULT_FORWARDING_TABLE_SIZE;
+
+ /* Initialize locative table: */
+ locative_table = (C_word *)C_malloc(DEFAULT_LOCATIVE_TABLE_SIZE * sizeof(C_word));
+
+ if(locative_table == NULL) return 0;
+
+ locative_table_size = DEFAULT_LOCATIVE_TABLE_SIZE;
+ locative_table_count = 0;
+
+ /* Setup collectibles: */
+ collectibles = (C_word **)C_malloc(sizeof(C_word *) * DEFAULT_COLLECTIBLES_SIZE);
+
+ if(collectibles == NULL) return 0;
+
+ collectibles_top = collectibles;
+ collectibles_limit = collectibles + DEFAULT_COLLECTIBLES_SIZE;
+ gc_root_list = NULL;
+
+ /* Initialize global variables: */
+ if(C_heap_growth == 0) C_heap_growth = DEFAULT_HEAP_GROWTH;
+
+ if(C_heap_shrinkage == 0) C_heap_shrinkage = DEFAULT_HEAP_SHRINKAGE;
+
+ if(C_maximal_heap_size == 0) C_maximal_heap_size = DEFAULT_MAXIMAL_HEAP_SIZE;
+
+#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)
+ dlopen_flags = RTLD_LAZY | RTLD_GLOBAL;
+#else
+ dlopen_flags = 0;
+#endif
+
+ gc_report_flag = 0;
+ mutation_count = gc_count_1 = gc_count_2 = 0;
+ lf_list = NULL;
+ C_register_lf2(NULL, 0, create_initial_ptable());
+ C_restart_address = toplevel;
+ C_restart_trampoline = initial_trampoline;
+ trace_buffer = NULL;
+ C_clear_trace_buffer();
+ chicken_is_running = chicken_ran_once = 0;
+ interrupt_reason = 0;
+ last_interrupt_latency = 0;
+ C_interrupts_enabled = 1;
+ C_initial_timer_interrupt_period = INITIAL_TIMER_INTERRUPT_PERIOD;
+ C_timer_interrupt_counter = INITIAL_TIMER_INTERRUPT_PERIOD;
+ memset(signal_mapping_table, 0, sizeof(int) * NSIG);
+ initialize_symbol_table();
+ C_dlerror = "cannot load compiled code dynamically - this is a statically linked executable";
+ error_location = C_SCHEME_FALSE;
+ C_pre_gc_hook = NULL;
+ C_post_gc_hook = NULL;
+ live_finalizer_count = 0;
+ allocated_finalizer_count = 0;
+ current_module_name = NULL;
+ current_module_handle = NULL;
+ reload_lf = NULL;
+ callback_continuation_level = 0;
+ timer_start_gc_ms = 0;
+ C_randomize(time(NULL));
+ return 1;
+}
+
+
+static C_PTABLE_ENTRY *create_initial_ptable()
+{
+ C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 74);
+ int i = 0;
+
+ if(pt == NULL)
+ panic(C_text("out of memory - cannot create initial ptable"));
+
+ C_pte(termination_continuation);
+ C_pte(callback_return_continuation);
+ C_pte(values_continuation);
+ C_pte(call_cc_values_wrapper);
+ C_pte(call_cc_wrapper);
+ C_pte(C_gc);
+ C_pte(C_allocate_vector);
+ C_pte(C_get_argv);
+ C_pte(C_make_structure);
+ C_pte(C_ensure_heap_reserve);
+ C_pte(C_return_to_host);
+ C_pte(C_file_info);
+ C_pte(C_get_symbol_table_info);
+ C_pte(C_get_memory_info);
+ C_pte(C_cpu_time);
+ C_pte(C_decode_seconds);
+ C_pte(C_get_environment_variable);
+ C_pte(C_stop_timer);
+ C_pte(C_dlopen_flags);
+ C_pte(C_set_dlopen_flags);
+ C_pte(C_dload);
+ C_pte(C_dunload);
+ C_pte(C_dynamic_library_names);
+ C_pte(C_dynamic_library_data);
+ C_pte(C_chicken_library_literal_frame);
+ C_pte(C_chicken_library_ptable);
+ C_pte(C_dynamic_library_load);
+ C_pte(C_dynamic_library_symbol);
+ C_pte(C_dynamic_library_unload);
+ C_pte(C_become);
+ C_pte(C_apply_values);
+ C_pte(C_times);
+ C_pte(C_minus);
+ C_pte(C_plus);
+ C_pte(C_divide);
+ C_pte(C_nequalp);
+ C_pte(C_greaterp);
+ C_pte(C_lessp);
+ C_pte(C_greater_or_equal_p);
+ C_pte(C_less_or_equal_p);
+ C_pte(C_flonum_floor);
+ C_pte(C_flonum_ceiling);
+ C_pte(C_flonum_truncate);
+ C_pte(C_flonum_round);
+ C_pte(C_quotient);
+ C_pte(C_cons_flonum);
+ C_pte(C_flonum_fraction);
+ C_pte(C_expt);
+ C_pte(C_exact_to_inexact);
+ C_pte(C_string_to_number);
+ C_pte(C_number_to_string);
+ C_pte(C_make_symbol);
+ C_pte(C_string_to_symbol);
+ C_pte(C_apply);
+ C_pte(C_call_cc);
+ C_pte(C_values);
+ C_pte(C_call_with_values);
+ C_pte(C_continuation_graft);
+ C_pte(C_open_file_port);
+ C_pte(C_software_type);
+ C_pte(C_machine_type);
+ C_pte(C_machine_byte_order);
+ C_pte(C_software_version);
+ C_pte(C_build_platform);
+ C_pte(C_c_runtime);
+ C_pte(C_make_pointer);
+ C_pte(C_make_tagged_pointer);
+ C_pte(C_peek_signed_integer);
+ C_pte(C_peek_unsigned_integer);
+ C_pte(C_context_switch);
+ C_pte(C_register_finalizer);
+ C_pte(C_locative_ref);
+ C_pte(C_call_with_cthulhu);
+ pt[ i ].id = NULL;
+ return pt;
+}
+
+
+void *CHICKEN_new_gc_root_2(int finalizable)
+{
+ C_GC_ROOT *r = (C_GC_ROOT *)C_malloc(sizeof(C_GC_ROOT));
+
+ if(r == NULL)
+ panic(C_text("out of memory - cannot allocate GC root"));
+
+ r->value = C_SCHEME_UNDEFINED;
+ r->next = gc_root_list;
+ r->prev = NULL;
+ r->finalizable = finalizable;
+
+ if(gc_root_list != NULL) gc_root_list->prev = r;
+
+ gc_root_list = r;
+ return (void *)r;
+}
+
+
+void *CHICKEN_new_gc_root()
+{
+ return CHICKEN_new_gc_root_2(0);
+}
+
+
+void *CHICKEN_new_finalizable_gc_root()
+{
+ return CHICKEN_new_gc_root_2(1);
+}
+
+
+void CHICKEN_delete_gc_root(void *root)
+{
+ C_GC_ROOT *r = (C_GC_ROOT *)root;
+
+ if(r->prev == NULL) gc_root_list = r->next;
+ else r->prev->next = r->next;
+
+ if(r->next != NULL) r->next->prev = r->prev;
+
+ C_free(root);
+}
+
+
+void *CHICKEN_global_lookup(char *name)
+{
+ int
+ len = C_strlen(name),
+ key = hash_string(len, name, symbol_table->size);
+ C_word s;
+ void *root = CHICKEN_new_gc_root();
+
+ if(C_truep(s = lookup(key, len, name, symbol_table))) {
+ if(C_u_i_car(s) != C_SCHEME_UNBOUND) {
+ CHICKEN_gc_root_set(root, s);
+ return root;
+ }
+ }
+
+ return NULL;
+}
+
+
+int CHICKEN_is_running()
+{
+ return chicken_is_running;
+}
+
+
+void CHICKEN_interrupt()
+{
+ C_timer_interrupt_counter = 0;
+}
+
+
+C_regparm C_SYMBOL_TABLE *C_new_symbol_table(char *name, unsigned int size)
+{
+ C_SYMBOL_TABLE *stp;
+ int i;
+
+ if((stp = C_find_symbol_table(name)) != NULL) return stp;
+
+ if((stp = (C_SYMBOL_TABLE *)C_malloc(sizeof(C_SYMBOL_TABLE))) == NULL)
+ return NULL;
+
+ stp->name = name;
+ stp->size = size;
+ stp->next = symbol_table_list;
+
+ if((stp->table = (C_word *)C_malloc(size * sizeof(C_word))) == NULL)
+ return NULL;
+
+ for(i = 0; i < stp->size; stp->table[ i++ ] = C_SCHEME_END_OF_LIST);
+
+ symbol_table_list = stp;
+ return stp;
+}
+
+
+C_regparm void C_delete_symbol_table(C_SYMBOL_TABLE *st)
+{
+ C_SYMBOL_TABLE *stp, *prev = NULL;
+
+ for(stp = symbol_table_list; stp != NULL; stp = stp->next)
+ if(stp == st) {
+ if(prev != NULL) prev->next = stp->next;
+ else symbol_table_list = stp->next;
+
+ return;
+ }
+}
+
+
+C_regparm void C_set_symbol_table(C_SYMBOL_TABLE *st)
+{
+ symbol_table = st;
+}
+
+
+C_regparm C_SYMBOL_TABLE *C_find_symbol_table(char *name)
+{
+ C_SYMBOL_TABLE *stp;
+
+ for(stp = symbol_table_list; stp != NULL; stp = stp->next)
+ if(!C_strcmp(name, stp->name)) return stp;
+
+ return NULL;
+}
+
+
+C_regparm C_word C_find_symbol(C_word str, C_SYMBOL_TABLE *stable)
+{
+ char *sptr = C_c_string(str);
+ int
+ len = C_header_size(str),
+ key = hash_string(len, sptr, stable->size);
+ C_word s;
+
+ if(C_truep(s = lookup(key, len, sptr, stable))) return s;
+ else return C_SCHEME_FALSE;
+}
+
+
+C_regparm C_word C_enumerate_symbols(C_SYMBOL_TABLE *stable, C_word pos)
+{
+ int i;
+ C_word
+ sym,
+ bucket = C_u_i_car(pos);
+
+ if(!C_truep(bucket)) return C_SCHEME_FALSE; /* end already reached */
+ else i = C_unfix(bucket);
+
+ bucket = C_u_i_cdr(pos);
+
+ while(bucket == C_SCHEME_END_OF_LIST) {
+ if(++i >= stable->size) {
+ C_set_block_item(pos, 0, C_SCHEME_FALSE); /* no more buckets */
+ return C_SCHEME_FALSE;
+ }
+ else bucket = stable->table[ i ];
+ }
+
+ sym = C_u_i_car(bucket);
+ C_set_block_item(pos, 0, C_fix(i));
+ C_mutate(&C_u_i_cdr(pos), C_u_i_cdr(bucket));
+ return sym;
+}
+
+
+/* Setup symbol-table with internally used symbols; */
+
+void initialize_symbol_table(void)
+{
+ int i;
+
+ for(i = 0; i < symbol_table->size; symbol_table->table[ i++ ] = C_SCHEME_END_OF_LIST);
+
+ /* Obtain reference to hooks for later: */
+ interrupt_hook_symbol = C_intern2(C_heaptop, C_text("\003sysinterrupt-hook"));
+ error_hook_symbol = C_intern2(C_heaptop, C_text("\003syserror-hook"));
+ callback_continuation_stack_symbol = C_intern3(C_heaptop, C_text("\003syscallback-continuation-stack"), C_SCHEME_END_OF_LIST);
+ pending_finalizers_symbol = C_intern2(C_heaptop, C_text("\003syspending-finalizers"));
+ invalid_procedure_call_hook_symbol = C_intern3(C_heaptop, C_text("\003sysinvalid-procedure-call-hook"), C_SCHEME_FALSE);
+ unbound_variable_value_hook_symbol = C_intern3(C_heaptop, C_text("\003sysunbound-variable-value-hook"), C_SCHEME_FALSE);
+ last_invalid_procedure_symbol = C_intern3(C_heaptop, C_text("\003syslast-invalid-procedure"), C_SCHEME_FALSE);
+ identity_unbound_value_symbol = C_intern3(C_heaptop, C_text("\003sysidentity-unbound-value"), C_SCHEME_FALSE);
+ current_thread_symbol = C_intern3(C_heaptop, C_text("\003syscurrent-thread"), C_SCHEME_FALSE);
+ apply_hook_symbol = C_intern3(C_heaptop, C_text("\003sysapply-hook"), C_SCHEME_FALSE);
+ last_applied_procedure_symbol = C_intern2(C_heaptop, C_text("\003syslast-applied-procedure"));
+}
+
+
+/* This is called from POSIX signals: */
+
+void global_signal_handler(int signum)
+{
+ C_raise_interrupt(signal_mapping_table[ signum ]);
+ signal(signum, global_signal_handler);
+}
+
+
+/* Align memory to page boundary */
+
+static void *align_to_page(void *mem)
+{
+ return (void *)C_align((C_uword)mem);
+}
+
+
+static C_byte *
+heap_alloc (size_t size, C_byte **page_aligned)
+{
+ C_byte *p;
+ p = (C_byte *)C_malloc (size + page_size);
+
+ if (p != NULL && page_aligned) *page_aligned = align_to_page (p);
+
+ return p;
+}
+
+
+static void
+heap_free (C_byte *ptr, size_t size)
+{
+ C_free (ptr);
+}
+
+
+static C_byte *
+heap_realloc (C_byte *ptr, size_t old_size,
+ size_t new_size, C_byte **page_aligned)
+{
+ C_byte *p;
+ p = (C_byte *)C_realloc (ptr, new_size + page_size);
+
+ if (p != NULL && page_aligned) *page_aligned = align_to_page (p);
+
+ return p;
+}
+
+
+/* Modify heap size at runtime: */
+
+void C_set_or_change_heap_size(C_word heap, int reintern)
+{
+ C_byte *ptr1, *ptr2, *ptr1a, *ptr2a;
+ C_word size = heap / 2;
+
+ if(heap_size_changed && fromspace_start) return;
+
+ if(fromspace_start && heap_size >= heap) return;
+
+ if(debug_mode) C_printf(C_text("[debug] heap resized to %d bytes\n"), (int)heap);
+
+ heap_size = heap;
+
+ if((ptr1 = heap_realloc (fromspace_start,
+ C_fromspace_limit - fromspace_start,
+ size, &ptr1a)) == NULL ||
+ (ptr2 = heap_realloc (tospace_start,
+ tospace_limit - tospace_start,
+ size, &ptr2a)) == NULL)
+ panic(C_text("out of memory - cannot allocate heap"));
+
+ heapspace1 = ptr1, heapspace1_size = size;
+ heapspace2 = ptr2, heapspace2_size = size;
+ fromspace_start = ptr1a;
+ C_fromspace_top = fromspace_start;
+ C_fromspace_limit = fromspace_start + size;
+ tospace_start = ptr2a;
+ tospace_top = tospace_start;
+ tospace_limit = tospace_start + size;
+ mutation_stack_top = mutation_stack_bottom;
+
+ if(reintern) initialize_symbol_table();
+}
+
+
+/* Modify stack-size at runtime: */
+
+void C_do_resize_stack(C_word stack)
+{
+ C_uword old = stack_size,
+ diff = stack - old;
+
+ if(diff != 0 && !stack_size_changed) {
+ if(debug_mode) C_printf(C_text("[debug] stack resized to %d bytes\n"), (int)stack);
+
+ stack_size = stack;
+
+#if C_STACK_GROWS_DOWNWARD
+ C_stack_limit = (C_word *)((C_byte *)C_stack_limit - diff);
+#else
+ C_stack_limit = (C_word *)((C_byte *)C_stack_limit + diff);
+#endif
+ }
+}
+
+
+/* Check whether nursery is sufficiently big: */
+
+void C_check_nursery_minimum(C_word words)
+{
+ if(words >= C_bytestowords(stack_size))
+ panic(C_text("nursery is too small - try higher setting using the `-:s' option"));
+}
+
+C_word C_resize_pending_finalizers(C_word size) {
+ int sz = C_num_to_int(size);
+
+ FINALIZER_NODE **newmem =
+ (FINALIZER_NODE **)C_realloc(pending_finalizer_indices, sz * sizeof(FINALIZER_NODE *));
+
+ if (newmem == NULL)
+ return C_SCHEME_FALSE;
+
+ pending_finalizer_indices = newmem;
+ C_max_pending_finalizers = sz;
+ return C_SCHEME_TRUE;
+}
+
+
+/* Parse runtime options from command-line: */
+
+void CHICKEN_parse_command_line(int argc, char *argv[], C_word *heap, C_word *stack, C_word *symbols)
+{
+ int i;
+ char *ptr;
+ C_word x;
+
+ C_main_argc = argc;
+ C_main_argv = argv;
+ *heap = DEFAULT_HEAP_SIZE;
+ *stack = DEFAULT_STACK_SIZE;
+ *symbols = DEFAULT_SYMBOL_TABLE_SIZE;
+
+ for(i = 1; i < C_main_argc; ++i)
+ if(!strncmp(C_main_argv[ i ], C_text("-:"), 2)) {
+ for(ptr = &C_main_argv[ i ][ 2 ]; *ptr != '\0';) {
+ switch(*(ptr++)) {
+ case '?':
+ C_printf("\nRuntime options:\n\n"
+ " -:? display this text\n"
+ " -:c always treat stdin as console\n"
+ " -:d enable debug output\n"
+ " -:D enable more debug output\n"
+ " -:o disable stack overflow checks\n"
+ " -:hiSIZE set initial heap size\n"
+ " -:hmSIZE set maximal heap size\n"
+ " -:hgPERCENTAGE set heap growth percentage\n"
+ " -:hsPERCENTAGE set heap shrink percentage\n"
+ " -:hSIZE set fixed heap size\n"
+ " -:r write trace output to stderr\n"
+ " -:sSIZE set nursery (stack) size\n"
+ " -:tSIZE set symbol-table size\n"
+ " -:fSIZE set maximal number of pending finalizers\n"
+ " -:w enable garbage collection of unused symbols\n"
+ " -:x deliver uncaught exceptions of other threads to primordial one\n"
+ " -:b enter REPL on error\n"
+ " -:B sound bell on major GC\n"
+ " -:aSIZE set trace-buffer/call-chain size\n"
+ "\n SIZE may have a `k' (`K'), `m' (`M') or `g' (`G') suffix, meaning size\n"
+ " times 1024, 1048576, and 1073741824, respectively.\n\n");
+ exit(0);
+
+ case 'h':
+ switch(*ptr) {
+ case 'i':
+ *heap = arg_val(ptr + 1);
+ heap_size_changed = 1;
+ goto next;
+ case 'g':
+ C_heap_growth = arg_val(ptr + 1);
+ goto next;
+ case 'm':
+ C_maximal_heap_size = arg_val(ptr + 1);
+ goto next;
+ case 's':
+ C_heap_shrinkage = arg_val(ptr + 1);
+ goto next;
+ default:
+ *heap = arg_val(ptr);
+ heap_size_changed = 1;
+ C_heap_size_is_fixed = 1;
+ goto next;
+ }
+
+ case 'o':
+ C_disable_overflow_check = 1;
+ break;
+
+ case 'B':
+ gc_bell = 1;
+ break;
+
+ case 's':
+ *stack = arg_val(ptr);
+ stack_size_changed = 1;
+ goto next;
+
+ case 'f':
+ C_max_pending_finalizers = arg_val(ptr);
+ goto next;
+
+ case 'a':
+ C_trace_buffer_size = arg_val(ptr);
+ goto next;
+
+ case 't':
+ *symbols = arg_val(ptr);
+ goto next;
+
+ case 'c':
+ fake_tty_flag = 1;
+ break;
+
+ case 'd':
+ debug_mode = 1;
+ break;
+
+ case 'D':
+ debug_mode = 2;
+ break;
+
+ case 'w':
+ C_enable_gcweak = 1;
+ break;
+
+ case 'r':
+ show_trace = 1;
+ break;
+
+ case 'x':
+ C_abort_on_thread_exceptions = 1;
+ break;
+
+ case 'b':
+ C_enable_repl = 1;
+ break;
+
+ default: panic(C_text("illegal runtime option"));
+ }
+ }
+
+ next:;
+ }
+}
+
+
+C_word arg_val(C_char *arg)
+{
+ int len;
+
+ if (arg == NULL) panic(C_text("illegal runtime-option argument"));
+
+ len = C_strlen(arg);
+
+ if(len < 1) panic(C_text("illegal runtime-option argument"));
+
+ switch(arg[ len - 1 ]) {
+ case 'k':
+ case 'K':
+ return atol(arg) * 1024;
+
+ case 'm':
+ case 'M':
+ return atol(arg) * 1024 * 1024;
+
+ case 'g':
+ case 'G':
+ return atol(arg) * 1024 * 1024 * 1024;
+
+ default:
+ return atol(arg);
+ }
+}
+
+
+/* Run embedded code with arguments: */
+
+C_word CHICKEN_run(void *toplevel)
+{
+ if(!chicken_is_initialized && !CHICKEN_initialize(0, 0, 0, toplevel))
+ panic(C_text("could not initialize"));
+
+ if(chicken_is_running)
+ panic(C_text("re-invocation of Scheme world while process is already running"));
+
+ chicken_is_running = chicken_ran_once = 1;
+ return_to_host = 0;
+
+#if C_STACK_GROWS_DOWNWARD
+ C_stack_limit = (C_word *)((C_byte *)C_stack_pointer - stack_size);
+#else
+ C_stack_limit = (C_word *)((C_byte *)C_stack_pointer + stack_size);
+#endif
+
+ stack_bottom = C_stack_pointer;
+
+ if(debug_mode)
+ C_printf(C_text("[debug] stack bottom is 0x%lx.\n"), (long)stack_bottom);
+
+ /* The point of (usually) no return... */
+ C_setjmp(C_restart);
+
+ if(!return_to_host)
+ (C_restart_trampoline)(C_restart_address);
+
+ chicken_is_running = 0;
+ return C_restore;
+}
+
+
+C_word CHICKEN_continue(C_word k)
+{
+ if(C_temporary_stack_bottom != C_temporary_stack)
+ panic(C_text("invalid temporary stack level"));
+
+ if(!chicken_is_initialized)
+ panic(C_text("runtime system has not been initialized - `CHICKEN_run' has probably not been called"));
+
+ C_save(k);
+ return CHICKEN_run(NULL);
+}
+
+
+/* Trampoline called at system startup: */
+
+C_regparm void C_fcall initial_trampoline(void *proc)
+{
+ TOPLEVEL top = (TOPLEVEL)proc;
+ C_word closure = (C_word)C_alloc(2);
+
+ ((C_SCHEME_BLOCK *)closure)->header = C_CLOSURE_TYPE | 1;
+ C_set_block_item(closure, 0, (C_word)termination_continuation);
+ (top)(2, C_SCHEME_UNDEFINED, closure);
+}
+
+
+/* The final continuation: */
+
+void C_ccall termination_continuation(C_word c, C_word self, C_word result)
+{
+ if(debug_mode) C_printf(C_text("[debug] application terminated normally.\n"));
+
+ exit(0);
+}
+
+
+/* Signal unrecoverable runtime error: */
+
+void panic(C_char *msg)
+{
+ if(C_panic_hook != NULL) C_panic_hook(msg);
+
+ usual_panic(msg);
+}
+
+
+void usual_panic(C_char *msg)
+{
+ C_char *dmp = C_dump_trace(0);
+
+ C_dbg_hook(C_SCHEME_UNDEFINED);
+
+#ifdef C_MICROSOFT_WINDOWS
+ C_sprintf(buffer, C_text("%s\n\n%s"), msg, dmp);
+
+ MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK);
+ ExitProcess(1);
+#else
+ C_fprintf(C_stderr, C_text("\n%s - execution terminated\n\n%s"), msg, dmp);
+
+ C_exit(1);
+#endif
+}
+
+
+void horror(C_char *msg)
+{
+ C_dbg_hook(C_SCHEME_UNDEFINED);
+
+#ifdef C_MICROSOFT_WINDOWS
+ C_sprintf(buffer, C_text("%s"), msg);
+
+ MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK);
+ ExitProcess(1);
+#else
+ C_fprintf(C_stderr, C_text("\n%s - execution terminated"), msg);
+
+ C_exit(1);
+#endif
+}
+
+
+/* Error-hook, called from C-level runtime routines: */
+
+void barf(int code, char *loc, ...)
+{
+ C_char *msg;
+ C_word err = error_hook_symbol;
+ int c, i;
+ va_list v;
+
+ C_dbg_hook(C_SCHEME_UNDEFINED);
+
+ C_temporary_stack = C_temporary_stack_bottom;
+ err = C_u_i_car(err);
+
+ if(C_immediatep(err))
+ panic(C_text("`##sys#error-hook' is not defined - the `library' unit was probably not linked with this executable"));
+
+ switch(code) {
+ case C_BAD_ARGUMENT_COUNT_ERROR:
+ msg = C_text("bad argument count");
+ c = 3;
+ break;
+
+ case C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR:
+ msg = C_text("too few arguments");
+ c = 3;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_ERROR:
+ msg = C_text("bad argument type");
+ c = 1;
+ break;
+
+ case C_UNBOUND_VARIABLE_ERROR:
+ msg = C_text("unbound variable");
+ c = 1;
+ break;
+
+ case C_TOO_MANY_PARAMETERS_ERROR:
+ msg = C_text("parameter limit exceeded");
+ c = 0;
+ break;
+
+ case C_OUT_OF_MEMORY_ERROR:
+ msg = C_text("not enough memory");
+ c = 0;
+ break;
+
+ case C_DIVISION_BY_ZERO_ERROR:
+ msg = C_text("division by zero");
+ c = 0;
+ break;
+
+ case C_OUT_OF_RANGE_ERROR:
+ msg = C_text("out of range");
+ c = 2;
+ break;
+
+ case C_NOT_A_CLOSURE_ERROR:
+ msg = C_text("call of non-procedure");
+ c = 1;
+ break;
+
+ case C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR:
+ msg = C_text("continuation cannot receive multiple values");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR:
+ msg = C_text("bad argument type - not a non-cyclic list");
+ c = 1;
+ break;
+
+ case C_TOO_DEEP_RECURSION_ERROR:
+ msg = C_text("recursion too deep");
+ c = 0;
+ break;
+
+ case C_CANT_REPRESENT_INEXACT_ERROR:
+ msg = C_text("inexact number cannot be represented as an exact number");
+ c = 1;
+ break;
+
+ case C_NOT_A_PROPER_LIST_ERROR:
+ msg = C_text("bad argument type - not a proper list");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR:
+ msg = C_text("bad argument type - not a fixnum");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR:
+ msg = C_text("bad argument type - not a string");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR:
+ msg = C_text("bad argument type - not a pair");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR:
+ msg = C_text("bad argument type - not a list");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR:
+ msg = C_text("bad argument type - not a number");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR:
+ msg = C_text("bad argument type - not a symbol");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR:
+ msg = C_text("bad argument type - not a vector");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR:
+ msg = C_text("bad argument type - not a character");
+ c = 1;
+ break;
+
+ case C_STACK_OVERFLOW_ERROR:
+ msg = C_text("stack overflow");
+ c = 0;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR:
+ msg = C_text("bad argument type - not a structure of the required type");
+ c = 2;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR:
+ msg = C_text("bad argument type - not a blob");
+ c = 1;
+ break;
+
+ case C_LOST_LOCATIVE_ERROR:
+ msg = C_text("locative refers to reclaimed object");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR:
+ msg = C_text("bad argument type - not a non-immediate value");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_NUMBER_VECTOR_ERROR:
+ msg = C_text("bad argument type - not a number vector");
+ c = 2;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR:
+ msg = C_text("bad argument type - not an integer");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR:
+ msg = C_text("bad argument type - not an unsigned integer");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR:
+ msg = C_text("bad argument type - not a pointer");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR:
+ msg = C_text("bad argument type - not a tagged pointer");
+ c = 2;
+ break;
+
+ case C_RUNTIME_UNSAFE_DLOAD_SAFE_ERROR:
+ msg = C_text("code to load dynamically was linked with safe runtime libraries, but executing runtime was not");
+ c = 0;
+ break;
+
+ case C_RUNTIME_SAFE_DLOAD_UNSAFE_ERROR:
+ msg = C_text("code to load dynamically was linked with unsafe runtime libraries, but executing runtime was not");
+ c = 0;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR:
+ msg = C_text("bad argument type - not a flonum");
+ c = 1;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR:
+ msg = C_text("bad argument type - not a procedure");
+ c = 1;
+ break;
+
+ default: panic(C_text("illegal internal error code"));
+ }
+
+ if(!C_immediatep(err)) {
+ C_save(C_fix(code));
+
+ if(loc != NULL)
+ C_save(intern0(loc));
+ else {
+ C_save(error_location);
+ error_location = C_SCHEME_FALSE;
+ }
+
+ va_start(v, loc);
+ i = c;
+
+ while(i--)
+ C_save(va_arg(v, C_word));
+
+ va_end(v);
+ /* No continuation is passed: '##sys#error-hook' may not return: */
+ C_do_apply(c + 2, err, C_SCHEME_UNDEFINED);
+ }
+ else panic(msg);
+}
+
+
+/* Hook for setting breakpoints */
+
+C_word C_dbg_hook(C_word dummy)
+{
+ return dummy;
+}
+
+
+/* Timing routines: */
+
+long C_fcall milliseconds(void)
+{
+#ifdef C_NONUNIX
+ if(CLOCKS_PER_SEC == 1000) return clock();
+ else return ((double)clock() / (double)CLOCKS_PER_SEC) * 1000;
+#else
+ struct timeval tv;
+
+ if(C_gettimeofday(&tv, NULL) == -1) return 0;
+ else return (tv.tv_sec - C_startup_time_seconds) * 1000 + tv.tv_usec / 1000;
+#endif
+}
+
+
+C_regparm time_t C_fcall C_seconds(long *ms)
+{
+#ifdef C_NONUNIX
+ if(ms != NULL) *ms = 0;
+
+ return (time_t)(clock() / CLOCKS_PER_SEC);
+#else
+ struct timeval tv;
+
+ if(C_gettimeofday(&tv, NULL) == -1) {
+ if(ms != NULL) *ms = 0;
+
+ return (time_t)0;
+ }
+ else {
+ if(ms != NULL) *ms = tv.tv_usec / 1000;
+
+ return tv.tv_sec;
+ }
+#endif
+}
+
+
+long C_fcall cpu_milliseconds(void)
+{
+#if defined(C_NONUNIX) || defined(__CYGWIN__)
+ if(CLOCKS_PER_SEC == 1000) return clock();
+ else return ((double)clock() / (double)CLOCKS_PER_SEC) * 1000;
+#else
+ struct rusage ru;
+
+ if(C_getrusage(RUSAGE_SELF, &ru) == -1) return 0;
+ else return (ru.ru_utime.tv_sec + ru.ru_stime.tv_sec) * 1000
+ + (ru.ru_utime.tv_usec + ru.ru_stime.tv_usec) / 1000;
+#endif
+}
+
+
+/* Support code for callbacks: */
+
+int C_fcall C_save_callback_continuation(C_word **ptr, C_word k)
+{
+ C_word p = C_pair(ptr, k, C_block_item(callback_continuation_stack_symbol, 0));
+
+ C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), p);
+ return ++callback_continuation_level;
+}
+
+
+C_word C_fcall C_restore_callback_continuation(void)
+{
+ /* obsolete, but retained for keeping old code working */
+ C_word p = C_block_item(callback_continuation_stack_symbol, 0),
+ k;
+
+ assert(!C_immediatep(p) && C_block_header(p) == C_PAIR_TAG);
+ k = C_u_i_car(p);
+
+ C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));
+ --callback_continuation_level;
+ return k;
+}
+
+
+C_word C_fcall C_restore_callback_continuation2(int level)
+{
+ C_word p = C_block_item(callback_continuation_stack_symbol, 0),
+ k;
+
+#ifndef C_UNSAFE_RUNTIME
+ if(level != callback_continuation_level || C_immediatep(p) || C_block_header(p) != C_PAIR_TAG)
+ panic(C_text("unbalanced callback continuation stack"));
+#endif
+
+ k = C_u_i_car(p);
+
+ C_mutate(&C_block_item(callback_continuation_stack_symbol, 0), C_u_i_cdr(p));
+ --callback_continuation_level;
+ return k;
+}
+
+
+C_word C_fcall C_callback(C_word closure, int argc)
+{
+ jmp_buf prev;
+ C_word
+ *a = C_alloc(2),
+ k = C_closure(&a, 1, (C_word)callback_return_continuation);
+ int old = chicken_is_running;
+
+#ifndef C_UNSAFE_RUNTIME
+ if(old && C_block_item(callback_continuation_stack_symbol, 0) == C_SCHEME_END_OF_LIST)
+ panic(C_text("callback invoked in non-safe context"));
+#endif
+
+ C_memcpy(&prev, &C_restart, sizeof(jmp_buf));
+ callback_returned_flag = 0;
+ chicken_is_running = 1;
+
+ if(!C_setjmp(C_restart)) C_do_apply(argc, closure, k);
+
+ if(!callback_returned_flag) (C_restart_trampoline)(C_restart_address);
+ else {
+ C_memcpy(&C_restart, &prev, sizeof(jmp_buf));
+ callback_returned_flag = 0;
+ }
+
+ chicken_is_running = old;
+ return C_restore;
+}
+
+
+void C_fcall C_callback_adjust_stack(C_word *a, int size)
+{
+ if(!chicken_is_running && !C_in_stackp((C_word)a)) {
+ if(debug_mode)
+ C_printf(C_text("[debug] callback invoked in lower stack region - adjusting limits:\n"
+ "[debug] current: \t%p\n"
+ "[debug] previous: \t%p (bottom) - %p (limit)\n"),
+ a, stack_bottom, C_stack_limit);
+
+#if C_STACK_GROWS_DOWNWARD
+ C_stack_limit = (C_word *)((C_byte *)a - stack_size);
+ stack_bottom = a + size;
+#else
+ C_stack_limit = (C_word *)((C_byte *)a + stack_size);
+ stack_bottom = a;
+#endif
+
+ if(debug_mode)
+ C_printf(C_text("[debug] new: \t%p (bottom) - %p (limit)\n"),
+ stack_bottom, C_stack_limit);
+ }
+}
+
+
+void C_fcall C_callback_adjust_stack_limits(C_word *a) /* DEPRECATED */
+{
+ if(!chicken_is_running && !C_in_stackp((C_word)a)) {
+ if(debug_mode)
+ C_printf(C_text("[debug] callback invoked in lower stack region - adjusting limits:\n"
+ "[debug] current: \t%p\n"
+ "[debug] previous: \t%p (bottom) - %p (limit)\n"),
+ a, stack_bottom, C_stack_limit);
+
+#if C_STACK_GROWS_DOWNWARD
+ C_stack_limit = (C_word *)((C_byte *)a - stack_size);
+#else
+ C_stack_limit = (C_word *)((C_byte *)a + stack_size);
+#endif
+ stack_bottom = a;
+
+ if(debug_mode)
+ C_printf(C_text("[debug] new: \t%p (bottom) - %p (limit)\n"),
+ stack_bottom, C_stack_limit);
+ }
+}
+
+
+C_word C_fcall C_callback_wrapper(void *proc, int argc)
+{
+ C_word
+ *a = C_alloc(2),
+ closure = C_closure(&a, 1, (C_word)proc),
+ result;
+
+ result = C_callback(closure, argc);
+ assert(C_temporary_stack == C_temporary_stack_bottom);
+ return result;
+}
+
+
+void C_ccall callback_return_continuation(C_word c, C_word self, C_word r)
+{
+ assert(callback_returned_flag == 0);
+ callback_returned_flag = 1;
+ C_save(r);
+ C_reclaim(NULL, NULL);
+}
+
+
+/* Zap symbol names: */
+
+void C_zap_strings(C_word str)
+{
+ int i;
+
+ for(i = 0; i < symbol_table->size; ++i) {
+ C_word bucket, sym;
+
+ for(bucket = symbol_table->table[ i ];
+ bucket != C_SCHEME_END_OF_LIST;
+ bucket = C_u_i_cdr(bucket)) {
+ sym = C_u_i_car(bucket);
+ C_set_block_item(sym, 1, str);
+ }
+ }
+}
+
+
+/* Register/unregister literal frame: */
+
+static LF_LIST *
+make_lf_list_node(C_word *lf, int count, C_PTABLE_ENTRY *ptable, C_char *name, void *handle)
+{
+ LF_LIST *node = (LF_LIST *)C_malloc(sizeof(LF_LIST));
+
+ if(NULL == node)
+ barf(C_OUT_OF_MEMORY_ERROR, "make_lf_list_node");
+
+ node->lf = lf;
+ node->count = count;
+ node->ptable = ptable;
+ node->module_name = name;
+ node->module_handle = handle;
+
+ return node;
+}
+
+
+static void
+link_lf_list_node(LF_LIST *node)
+{
+ if(lf_list) lf_list->prev = node;
+ node->next = lf_list;
+ node->prev = NULL;
+ lf_list = node;
+}
+
+
+static void
+unlink_lf_list_node(LF_LIST *node)
+{
+ if (node->next) node->next->prev = node->prev;
+ if (node->prev) node->prev->next = node->next;
+ if (lf_list == node) lf_list = node->next;
+}
+
+
+static void
+destroy_lf_list_node(LF_LIST *node)
+{
+ unlink_lf_list_node(node);
+ C_free(node->module_name);
+ C_free(node);
+}
+
+
+static LF_LIST *
+find_lf_list_node(C_char *name)
+{
+ LF_LIST *np;
+
+ for(np = lf_list; np != NULL; np = np->next) {
+ if(np->module_name != NULL && !C_strcmp(np->module_name, name))
+ return np;
+ }
+
+ return NULL;
+}
+
+
+void C_initialize_lf(C_word *lf, int count)
+{
+ while(count-- > 0)
+ *(lf++) = C_SCHEME_UNBOUND;
+}
+
+
+void *C_register_lf(C_word *lf, int count)
+{
+ return C_register_lf2(lf, count, NULL);
+}
+
+
+void *C_register_lf2(C_word *lf, int count, C_PTABLE_ENTRY *ptable)
+{
+ LF_LIST *np;
+ LF_LIST *node = make_lf_list_node(lf, count, ptable, NULL, NULL);
+ int status = 0;
+
+ if(reload_lf != NULL) {
+ if(debug_mode)
+ C_printf(C_text("[debug] replacing previous LF-entry for `%s'\n"), current_module_name);
+
+ C_free(reload_lf->module_name);
+ reload_lf->lf = lf;
+ reload_lf->count = count;
+ reload_lf->ptable = ptable;
+ C_free(node);
+ node = reload_lf;
+ }
+
+ node->module_name = current_module_name;
+ node->module_handle = current_module_handle;
+ current_module_handle = NULL;
+
+ if(reload_lf != node) link_lf_list_node(node);
+ else reload_lf = NULL;
+
+ return (void *)node;
+}
+
+
+void C_unregister_lf(void *handle)
+{
+ destroy_lf_list_node((LF_LIST *)handle);
+}
+
+
+void C_ccall
+C_dynamic_library_names(C_word c, C_word closure, C_word k)
+{
+ LF_LIST *np;
+ C_word olst = C_SCHEME_END_OF_LIST;
+
+ if(c != 2) C_bad_argc(c, 2);
+
+ for(np = lf_list; np; np = np->next) {
+ if(NULL != np->module_name && NULL != np->module_handle) {
+ C_word str = C_string2(C_heaptop, np->module_name);
+ olst = C_h_pair(str, olst);
+ }
+ }
+
+ C_kontinue(k, olst);
+}
+
+
+static C_char *
+checked_string_argument(char *loc, C_word hstr)
+{
+ int len;
+ C_char *cstr;
+
+ if (!C_immediatep(hstr) && C_STRING_TYPE == C_header_bits(hstr)) {
+ /* make copy of heap string so movement unnoticeable */
+ len = C_header_size(hstr);
+ if(NULL == (cstr = (char *)C_malloc(len + 1)))
+ barf(C_OUT_OF_MEMORY_ERROR, loc);
+ C_memcpy(cstr, C_c_string(hstr), len); (cstr)[ len ] = '\0';
+ } else
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, loc, hstr);
+
+ return cstr;
+}
+
+
+static C_char *
+checked_string_or_null_argument(char *loc, C_word hstr)
+{
+ C_char *cstr = NULL;
+
+ if(!C_immediatep(hstr) || C_SCHEME_FALSE != hstr)
+ cstr = checked_string_argument(loc, hstr);
+
+ return cstr;
+}
+
+
+void C_ccall
+C_dynamic_library_data(C_word c, C_word closure, C_word k, C_word libnam)
+{
+ LF_LIST *np;
+ char *name;
+ C_word olst = C_SCHEME_END_OF_LIST;
+
+ if(c != 3) C_bad_argc(c, 3);
+
+ name = checked_string_or_null_argument("##sys#dynamic-library-data", libnam);
+
+ for(np = lf_list; np; np = np->next) {
+ if( (!name && !np->module_name)
+ || (name && np->module_name && !strcmp(name, np->module_name))) {
+ C_word ptr = C_mpointer_or_false(C_heaptop, np->module_handle);
+ C_word ent = C_h_list(3, ptr, C_fix(np->count), C_mk_bool(np->ptable));
+ olst = C_h_pair(ent, olst);
+ }
+ }
+
+ if(name) C_free(name);
+
+ C_kontinue(k, olst);
+}
+
+
+static void
+checked_library_query_arguments(char *loc,
+ C_word libnam, C_word libhdl, C_word lfcnt,
+ char **name, void **handle, int *count)
+{
+ if(C_immediatep(libhdl) && C_SCHEME_FALSE == libhdl)
+ *handle = NULL;
+ else if (!C_immediatep(libhdl) && C_POINTER_TAG == C_block_header(libhdl))
+ *handle = C_c_pointer_nn(libhdl);
+ else
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, loc, libhdl);
+
+ if(C_immediatep(lfcnt) && (C_FIXNUM_BIT & lfcnt))
+ *count = C_unfix(lfcnt);
+ else
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, loc, lfcnt);
+
+ if(*count < 0)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, loc, lfcnt);
+
+ *name = checked_string_or_null_argument(loc, libnam);
+}
+
+
+void C_ccall
+C_chicken_library_literal_frame(C_word c, C_word closure, C_word k,
+ C_word libnam, C_word libhdl, C_word lfcnt)
+{
+ int count;
+ void *handle;
+ char *name;
+ LF_LIST *np;
+ C_word olst = C_SCHEME_END_OF_LIST;
+
+ if(c != 5) C_bad_argc(c, 5);
+
+ checked_library_query_arguments(C_text("##sys#chicken-library-literal-frame"),
+ libnam, libhdl, lfcnt,
+ &name, &handle, &count);
+
+ for(np = lf_list; np; np = np->next) {
+ if( (!name && !np->module_name)
+ || (name && np->module_name && !strcmp(name, np->module_name))) {
+ C_word *lf = np->lf;
+ if(lf && handle == np->module_handle && count == np->count) {
+ int cnt;
+ for(cnt = np->count; cnt--; ++lf) {
+ olst = C_h_pair(*lf, olst);
+ }
+ }
+ }
+ }
+
+ if(name) C_free(name);
+
+ C_kontinue(k, olst);
+}
+
+
+void C_ccall
+C_chicken_library_ptable(C_word c, C_word closure, C_word k,
+ C_word libnam, C_word libhdl, C_word lfcnt, C_word inclptrs)
+{
+ int count;
+ void *handle;
+ char *name;
+ LF_LIST *np;
+ C_word olst = C_SCHEME_END_OF_LIST;
+
+ if(c != 6) C_bad_argc(c, 6);
+
+ checked_library_query_arguments(C_text("##sys#chicken-library-ptable"),
+ libnam, libhdl, lfcnt,
+ &name, &handle, &count);
+
+ for(np = lf_list; np; np = np->next) {
+ if( (!name && !np->module_name)
+ || (name && np->module_name && !strcmp(name, np->module_name))) {
+ C_PTABLE_ENTRY *pt = np->ptable;
+ if(pt && handle == np->module_handle && count == np->count) {
+ for(; pt->id; ++pt) {
+ C_word str = C_string2(C_heaptop, pt->id);
+ C_word ent = str;
+ if(C_truep(inclptrs)) {
+ C_word ptr = C_mpointer_or_false(C_heaptop, pt->ptr);
+ ent = C_h_pair(str, ptr);
+ }
+ olst = C_h_pair(ent, olst);
+ }
+ }
+ }
+ }
+
+ if(name) C_free(name);
+
+ C_kontinue(k, olst);
+}
+
+
+/* Intern symbol into symbol-table: */
+
+C_regparm C_word C_fcall C_intern(C_word **ptr, int len, C_char *str)
+{
+ return C_intern_in(ptr, len, str, symbol_table);
+}
+
+
+C_regparm C_word C_fcall C_h_intern(C_word *slot, int len, C_char *str)
+{
+ return C_h_intern_in(slot, len, str, symbol_table);
+}
+
+
+C_regparm C_word C_fcall C_intern_in(C_word **ptr, int len, C_char *str, C_SYMBOL_TABLE *stable)
+{
+ int key;
+ C_word s;
+
+ if(stable == NULL) stable = symbol_table;
+
+ key = hash_string(len, str, stable->size);
+
+ if(C_truep(s = lookup(key, len, str, stable))) return s;
+
+ s = C_string(ptr, len, str);
+ return add_symbol(ptr, key, s, stable);
+}
+
+
+C_regparm C_word C_fcall C_h_intern_in(C_word *slot, int len, C_char *str, C_SYMBOL_TABLE *stable)
+{
+ /* Intern as usual, but remember slot, if looked up symbol is in nursery.
+ also: allocate in static memory. */
+ int key;
+ C_word s;
+
+ if(stable == NULL) stable = symbol_table;
+
+ key = hash_string(len, str, stable->size);
+
+ if(C_truep(s = lookup(key, len, str, stable))) {
+ if(C_in_stackp(s)) C_mutate(slot, s);
+
+ return s;
+ }
+
+ s = C_static_string(C_heaptop, len, str);
+ return add_symbol(C_heaptop, key, s, stable);
+}
+
+
+C_regparm C_word C_fcall intern0(C_char *str)
+{
+ int len = C_strlen(str);
+ int key = hash_string(len, str, symbol_table->size);
+ C_word s;
+
+ if(C_truep(s = lookup(key, len, str, symbol_table))) return s;
+ else return C_SCHEME_FALSE;
+}
+
+
+C_regparm C_word C_fcall C_lookup_symbol(C_word sym)
+{
+ int key;
+ C_word str = C_block_item(sym, 1);
+ int len = C_header_size(str);
+
+ key = hash_string(len, C_c_string(str), symbol_table->size);
+
+ return lookup(key, len, C_c_string(str), symbol_table);
+}
+
+
+C_regparm C_word C_fcall C_intern2(C_word **ptr, C_char *str)
+{
+ return C_intern_in(ptr, C_strlen(str), str, symbol_table);
+}
+
+
+C_regparm C_word C_fcall C_intern3(C_word **ptr, C_char *str, C_word value)
+{
+ C_word s = C_intern_in(ptr, C_strlen(str), str, symbol_table);
+
+ C_mutate(&C_u_i_car(s), value);
+ return s;
+}
+
+
+C_regparm int C_fcall hash_string(int len, C_char *str, unsigned int m)
+{
+ unsigned int key = 0;
+
+# if 0
+ /* Zbigniew's suggested change for extended significance & ^2 table sizes. */
+ while(len--) key += (key << 5) + *(str++);
+# else
+ while(len--) key = (key << 4) + *(str++);
+# endif
+
+ return (int)(key % m);
+}
+
+
+C_regparm C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable)
+{
+ C_word bucket, sym, s;
+
+ for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_u_i_cdr(bucket)) {
+ sym = C_u_i_car(bucket);
+ s = C_u_i_cdr(sym);
+
+ if(C_header_size(s) == (C_word)len
+ && !C_memcmp(str, (C_char *)((C_SCHEME_BLOCK *)s)->data, len))
+ return sym;
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
+double compute_symbol_table_load(double *avg_bucket_len, int *total_n)
+{
+ C_word bucket;
+ int i, j, alen = 0, bcount = 0, total = 0;
+
+ for(i = 0; i < symbol_table->size; ++i) {
+ bucket = symbol_table->table[ i ];
+
+ for(j = 0; bucket != C_SCHEME_END_OF_LIST; ++j)
+ bucket = C_u_i_cdr(bucket);
+
+ if(j > 0) {
+ alen += j;
+ ++bcount;
+ }
+
+ total += j;
+ }
+
+ if(avg_bucket_len != NULL)
+ *avg_bucket_len = (double)alen / (double)bcount;
+
+ *total_n = total;
+
+ /* return load: */
+ return (double)total / (double)symbol_table->size;
+}
+
+
+C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stable)
+{
+ C_word bucket, sym, b2, *p;
+ int keyw = C_header_size(string) > 0 && *((char *)C_data_pointer(string)) == 0;
+
+ p = *ptr;
+ sym = (C_word)p;
+ p += C_SIZEOF_SYMBOL;
+ ((C_SCHEME_BLOCK *)sym)->header = C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1);
+ C_set_block_item(sym, 0, keyw ? sym : C_SCHEME_UNBOUND); /* keyword? */
+ C_set_block_item(sym, 1, string);
+ C_set_block_item(sym, 2, C_SCHEME_END_OF_LIST);
+ *ptr = p;
+ b2 = stable->table[ key ]; /* previous bucket */
+ bucket = C_pair(ptr, sym, b2); /* create new bucket */
+ ((C_SCHEME_BLOCK *)bucket)->header =
+ (((C_SCHEME_BLOCK *)bucket)->header & ~C_HEADER_TYPE_BITS) | C_BUCKET_TYPE;
+
+ if(ptr != C_heaptop) C_mutate(&stable->table[ key ], bucket);
+ else {
+ /* If a stack-allocated bucket was here, and we allocate from
+ heap-top (say, in a toplevel literal frame allocation) then we have
+ to inform the memory manager that a 2nd gen. block points to a
+ 1st gen. block, hence the mutation: */
+ C_mutate(&C_u_i_cdr(bucket), b2);
+ stable->table[ key ] = bucket;
+ }
+
+ return sym;
+}
+
+
+/* Check block allocation: */
+
+C_regparm C_word C_fcall C_permanentp(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && !C_in_stackp(x) && !C_in_heapp(x));
+}
+
+
+C_regparm int C_in_stackp(C_word x)
+{
+ C_word *ptr = (C_word *)(C_uword)x;
+
+#if C_STACK_GROWS_DOWNWARD
+ return ptr >= C_stack_pointer_test && ptr <= stack_bottom;
+#else
+ return ptr < C_stack_pointer_test && ptr >= stack_bottom;
+#endif
+}
+
+
+C_regparm int C_fcall C_in_heapp(C_word x)
+{
+ C_byte *ptr = (C_byte *)(C_uword)x;
+ return (ptr >= fromspace_start && ptr < C_fromspace_limit) ||
+ (ptr >= tospace_start && ptr < tospace_limit);
+}
+
+
+C_regparm int C_fcall C_in_fromspacep(C_word x)
+{
+ C_byte *ptr = (C_byte *)(C_uword)x;
+ return (ptr >= fromspace_start && ptr < C_fromspace_limit);
+}
+
+
+/* Cons the rest-aguments together: */
+
+C_regparm C_word C_fcall C_restore_rest(C_word *ptr, int num)
+{
+ C_word x = C_SCHEME_END_OF_LIST;
+ C_SCHEME_BLOCK *node;
+
+ while(num--) {
+ node = (C_SCHEME_BLOCK *)ptr;
+ ptr += 3;
+ node->header = C_PAIR_TYPE | (C_SIZEOF_PAIR - 1);
+ node->data[ 0 ] = C_restore;
+ node->data[ 1 ] = x;
+ x = (C_word)node;
+ }
+
+ return x;
+}
+
+
+C_regparm C_word C_fcall C_restore_rest_vector(C_word *ptr, int num)
+{
+ C_word *p0 = ptr;
+
+ *(ptr++) = C_VECTOR_TYPE | num;
+ ptr += num;
+
+ while(num--) *(--ptr) = C_restore;
+
+ return (C_word)p0;
+}
+
+
+/* Print error messages and exit: */
+
+void C_bad_memory(void)
+{
+ panic(C_text("there is not enough stack-space to run this executable"));
+}
+
+
+void C_bad_memory_2(void)
+{
+ panic(C_text("there is not enough heap-space to run this executable - try using the '-:h...' option"));
+}
+
+
+/* The following two can be thrown out in the next release... */
+
+void C_bad_argc(int c, int n)
+{
+ C_bad_argc_2(c, n, C_SCHEME_FALSE);
+}
+
+
+void C_bad_min_argc(int c, int n)
+{
+ C_bad_min_argc_2(c, n, C_SCHEME_FALSE);
+}
+
+
+void C_bad_argc_2(int c, int n, C_word closure)
+{
+ barf(C_BAD_ARGUMENT_COUNT_ERROR, NULL, C_fix(n - 2), C_fix(c - 2), closure);
+}
+
+
+void C_bad_min_argc_2(int c, int n, C_word closure)
+{
+ barf(C_BAD_MINIMUM_ARGUMENT_COUNT_ERROR, NULL, C_fix(n - 2), C_fix(c - 2), closure);
+}
+
+
+void C_stack_overflow(void)
+{
+ barf(C_STACK_OVERFLOW_ERROR, NULL);
+}
+
+
+void C_unbound_error(C_word sym)
+{
+ barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);
+}
+
+
+void C_no_closure_error(C_word x)
+{
+ barf(C_NOT_A_CLOSURE_ERROR, NULL, x);
+}
+
+
+/* Allocate and initialize record: */
+
+C_regparm C_word C_fcall C_string(C_word **ptr, int len, C_char *str)
+{
+ C_word strblock = (C_word)(*ptr);
+
+ *ptr = (C_word *)((C_word)(*ptr) + sizeof(C_header) + C_align(len));
+ ((C_SCHEME_BLOCK *)strblock)->header = C_STRING_TYPE | len;
+ C_memcpy(C_data_pointer(strblock), str, len);
+ return strblock;
+}
+
+
+C_regparm C_word C_fcall C_static_string(C_word **ptr, int len, C_char *str)
+{
+ C_word *dptr = (C_word *)C_malloc(sizeof(C_header) + C_align(len));
+ C_word strblock;
+
+ if(dptr == NULL)
+ panic(C_text("out of memory - cannot allocate static string"));
+
+ strblock = (C_word)dptr;
+ ((C_SCHEME_BLOCK *)strblock)->header = C_STRING_TYPE | len;
+ C_memcpy(C_data_pointer(strblock), str, len);
+ return strblock;
+}
+
+
+C_regparm C_word C_fcall C_static_lambda_info(C_word **ptr, int len, C_char *str)
+{
+ int dlen = sizeof(C_header) + C_align(len);
+ void *dptr = C_malloc(dlen);
+ C_word strblock;
+
+ if(dptr == NULL)
+ panic(C_text("out of memory - cannot allocate static lambda info"));
+
+ strblock = (C_word)dptr;
+ ((C_SCHEME_BLOCK *)strblock)->header = C_LAMBDA_INFO_TYPE | len;
+ C_memcpy(C_data_pointer(strblock), str, len);
+ return strblock;
+}
+
+
+C_regparm C_word C_fcall C_bytevector(C_word **ptr, int len, C_char *str)
+{
+ C_word strblock = C_string(ptr, len, str);
+
+ C_string_to_bytevector(strblock);
+ return strblock;
+}
+
+
+C_regparm C_word C_fcall C_pbytevector(int len, C_char *str)
+{
+ C_SCHEME_BLOCK *pbv = C_malloc(len + sizeof(C_header));
+
+ if(pbv == NULL) panic(C_text("out of memory - cannot allocate permanent blob"));
+
+ pbv->header = C_BYTEVECTOR_TYPE | len;
+ C_memcpy(pbv->data, str, len);
+ return (C_word)pbv;
+}
+
+
+C_regparm C_word C_fcall C_string_aligned8(C_word **ptr, int len, C_char *str)
+{
+ C_word *p = *ptr,
+ *p0;
+
+#ifndef C_SIXTY_FOUR
+ /* Align on 8-byte boundary: */
+ if(aligned8(p)) ++p;
+#endif
+
+ p0 = p;
+ *ptr = p + 1 + C_bytestowords(len);
+ *(p++) = C_STRING_TYPE | C_8ALIGN_BIT | len;
+ C_memcpy(p, str, len);
+ return (C_word)p0;
+}
+
+
+C_regparm C_word C_fcall C_string2(C_word **ptr, C_char *str)
+{
+ C_word strblock = (C_word)(*ptr);
+ int len;
+
+ if(str == NULL) return C_SCHEME_FALSE;
+
+ len = C_strlen(str);
+ *ptr = (C_word *)((C_word)(*ptr) + sizeof(C_header) + C_align(len));
+ ((C_SCHEME_BLOCK *)strblock)->header = C_STRING_TYPE | len;
+ C_memcpy(((C_SCHEME_BLOCK *)strblock)->data, str, len);
+ return strblock;
+}
+
+
+C_regparm C_word C_fcall C_string2_safe(C_word **ptr, int max, C_char *str)
+{
+ C_word strblock = (C_word)(*ptr);
+ int len;
+
+ if(str == NULL) return C_SCHEME_FALSE;
+
+ len = C_strlen(str);
+
+ if(len >= max) {
+ C_sprintf(buffer, C_text("foreign string result exceeded maximum of %d bytes"), max);
+ panic(buffer);
+ }
+
+ *ptr = (C_word *)((C_word)(*ptr) + sizeof(C_header) + C_align(len));
+ ((C_SCHEME_BLOCK *)strblock)->header = C_STRING_TYPE | len;
+ C_memcpy(((C_SCHEME_BLOCK *)strblock)->data, str, len);
+ return strblock;
+}
+
+
+C_word C_fcall C_closure(C_word **ptr, int cells, C_word proc, ...)
+{
+ va_list va;
+ C_word *p = *ptr,
+ *p0 = p;
+
+ *p = C_CLOSURE_TYPE | cells;
+ *(++p) = proc;
+
+ for(va_start(va, proc); --cells; *(++p) = va_arg(va, C_word));
+
+ va_end(va);
+ *ptr = p + 1;
+ return (C_word)p0;
+}
+
+
+C_regparm C_word C_fcall C_pair(C_word **ptr, C_word car, C_word cdr)
+{
+ C_word *p = *ptr,
+ *p0 = p;
+
+ *(p++) = C_PAIR_TYPE | (C_SIZEOF_PAIR - 1);
+ *(p++) = car;
+ *(p++) = cdr;
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_regparm C_word C_fcall C_h_pair(C_word car, C_word cdr)
+{
+ /* Allocate on heap and check for non-heap slots: */
+ C_word *p = (C_word *)C_fromspace_top,
+ *p0 = p;
+
+ *(p++) = C_PAIR_TYPE | (C_SIZEOF_PAIR - 1);
+
+ if(C_in_stackp(car)) C_mutate(p++, car);
+ else *(p++) = car;
+
+ if(C_in_stackp(cdr)) C_mutate(p++, cdr);
+ else *(p++) = cdr;
+
+ C_fromspace_top = (C_byte *)p;
+ return (C_word)p0;
+}
+
+
+C_regparm C_word C_fcall C_flonum(C_word **ptr, double n)
+{
+ C_word
+ *p = *ptr,
+ *p0;
+
+#ifndef C_SIXTY_FOUR
+#ifndef C_DOUBLE_IS_32_BITS
+ /* Align double on 8-byte boundary: */
+ if(aligned8(p)) ++p;
+#endif
+#endif
+
+ p0 = p;
+ *(p++) = C_FLONUM_TAG;
+ *((double *)p) = n;
+ *ptr = p + sizeof(double) / sizeof(C_word);
+ return (C_word)p0;
+}
+
+
+C_regparm C_word C_fcall C_number(C_word **ptr, double n)
+{
+ C_word
+ *p = *ptr,
+ *p0;
+ double m;
+
+ if(n <= (double)C_MOST_POSITIVE_FIXNUM
+ && n >= (double)C_MOST_NEGATIVE_FIXNUM && modf(n, &m) == 0.0) {
+ return C_fix(n);
+ }
+
+#ifndef C_SIXTY_FOUR
+#ifndef C_DOUBLE_IS_32_BITS
+ /* Align double on 8-byte boundary: */
+ if(aligned8(p)) ++p;
+#endif
+#endif
+
+ p0 = p;
+ *(p++) = C_FLONUM_TAG;
+ *((double *)p) = n;
+ *ptr = p + sizeof(double) / sizeof(C_word);
+ return (C_word)p0;
+}
+
+
+C_regparm C_word C_fcall C_mpointer(C_word **ptr, void *mp)
+{
+ C_word
+ *p = *ptr,
+ *p0 = p;
+
+ *(p++) = C_POINTER_TYPE | 1;
+ *((void **)p) = mp;
+ *ptr = p + 1;
+ return (C_word)p0;
+}
+
+
+C_regparm C_word C_fcall C_mpointer_or_false(C_word **ptr, void *mp)
+{
+ C_word
+ *p = *ptr,
+ *p0 = p;
+
+ if(mp == NULL) return C_SCHEME_FALSE;
+
+ *(p++) = C_POINTER_TYPE | 1;
+ *((void **)p) = mp;
+ *ptr = p + 1;
+ return (C_word)p0;
+}
+
+
+C_regparm C_word C_fcall C_taggedmpointer(C_word **ptr, C_word tag, void *mp)
+{
+ C_word
+ *p = *ptr,
+ *p0 = p;
+
+ *(p++) = C_TAGGED_POINTER_TAG;
+ *((void **)p) = mp;
+ *(++p) = tag;
+ *ptr = p + 1;
+ return (C_word)p0;
+}
+
+
+C_regparm C_word C_fcall C_taggedmpointer_or_false(C_word **ptr, C_word tag, void *mp)
+{
+ C_word
+ *p = *ptr,
+ *p0 = p;
+
+ if(mp == NULL) return C_SCHEME_FALSE;
+
+ *(p++) = C_TAGGED_POINTER_TAG;
+ *((void **)p) = mp;
+ *(++p) = tag;
+ *ptr = p + 1;
+ return (C_word)p0;
+}
+
+
+C_regparm C_word C_fcall C_swigmpointer(C_word **ptr, void *mp, void *sdata)
+{
+ C_word
+ *p = *ptr,
+ *p0 = p;
+
+ *(p++) = C_SWIG_POINTER_TAG;
+ *((void **)p) = mp;
+ *((void **)p + 1) = sdata;
+ *ptr = p + 2;
+ return (C_word)p0;
+}
+
+
+C_word C_vector(C_word **ptr, int n, ...)
+{
+ va_list v;
+ C_word
+ *p = *ptr,
+ *p0 = p;
+
+ *(p++) = C_VECTOR_TYPE | n;
+ va_start(v, n);
+
+ while(n--)
+ *(p++) = va_arg(v, C_word);
+
+ *ptr = p;
+ va_end(v);
+ return (C_word)p0;
+}
+
+
+C_word C_structure(C_word **ptr, int n, ...)
+{
+ va_list v;
+ C_word *p = *ptr,
+ *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | n;
+ va_start(v, n);
+
+ while(n--)
+ *(p++) = va_arg(v, C_word);
+
+ *ptr = p;
+ va_end(v);
+ return (C_word)p0;
+}
+
+
+C_word C_h_vector(int n, ...)
+{
+ /* As C_vector(), but remember slots containing nursery pointers: */
+ va_list v;
+ C_word *p = (C_word *)C_fromspace_top,
+ *p0 = p,
+ x;
+
+ *(p++) = C_VECTOR_TYPE | n;
+ va_start(v, n);
+
+ while(n--) {
+ x = va_arg(v, C_word);
+
+ if(C_in_stackp(x)) C_mutate(p++, x);
+ else *(p++) = x;
+ }
+
+ C_fromspace_top = (C_byte *)p;
+ va_end(v);
+ return (C_word)p0;
+}
+
+
+C_word C_h_structure(int n, ...)
+{
+ /* As C_structure(), but remember slots containing nursery pointers: */
+ va_list v;
+ C_word *p = (C_word *)C_fromspace_top,
+ *p0 = p,
+ x;
+
+ *(p++) = C_STRUCTURE_TYPE | n;
+ va_start(v, n);
+
+ while(n--) {
+ x = va_arg(v, C_word);
+
+ if(C_in_stackp(x)) C_mutate(p++, x);
+ else *(p++) = x;
+ }
+
+ C_fromspace_top = (C_byte *)p;
+ va_end(v);
+ return (C_word)p0;
+}
+
+
+C_regparm C_word C_fcall C_mutate(C_word *slot, C_word val)
+{
+ int mssize;
+
+ if(!C_immediatep(val)) {
+#ifdef C_GC_HOOKS
+ if(C_gc_mutation_hook != NULL && C_gc_mutation_hook(slot, val)) return val;
+#endif
+
+ if(mutation_stack_top >= mutation_stack_limit) {
+ assert(mutation_stack_top == mutation_stack_limit);
+ mssize = mutation_stack_top - mutation_stack_bottom;
+ mutation_stack_bottom =
+ (C_word **)realloc(mutation_stack_bottom,
+ (mssize + MUTATION_STACK_GROWTH) * sizeof(C_word *));
+
+ if(mutation_stack_bottom == NULL)
+ panic(C_text("out of memory - cannot re-allocate mutation stack"));
+
+ mutation_stack_limit = mutation_stack_bottom + mssize + MUTATION_STACK_GROWTH;
+ mutation_stack_top = mutation_stack_bottom + mssize;
+ }
+
+ *(mutation_stack_top++) = slot;
+ ++mutation_count;
+ }
+
+ return *slot = val;
+}
+
+
+/* Initiate garbage collection: */
+
+
+void C_save_and_reclaim(void *trampoline, void *proc, int n, ...)
+{
+ va_list v;
+
+ va_start(v, n);
+
+ while(n--) C_save(va_arg(v, C_word));
+
+ va_end(v);
+ C_reclaim(trampoline, proc);
+}
+
+
+C_regparm void C_fcall C_reclaim(void *trampoline, void *proc)
+{
+ int i, j, n, fcount, weakn;
+ C_uword count, bytes;
+ C_word *p, **msp, bucket, last, item, container;
+ C_header h;
+ C_byte *tmp, *start;
+ LF_LIST *lfn;
+ C_SCHEME_BLOCK *bp;
+ C_GC_ROOT *gcrp;
+ WEAK_TABLE_ENTRY *wep;
+ long tgc;
+ C_SYMBOL_TABLE *stp;
+ volatile int finalizers_checked;
+ FINALIZER_NODE *flist;
+ TRACE_INFO *tinfo;
+
+ /* assert(C_timer_interrupt_counter >= 0); */
+
+ if(interrupt_reason && C_interrupts_enabled)
+ handle_interrupt(trampoline, proc);
+
+ /* Note: the mode argument will always be GC_MINOR or GC_REALLOC. */
+ if(C_pre_gc_hook != NULL) C_pre_gc_hook(GC_MINOR);
+
+ finalizers_checked = 0;
+ C_restart_trampoline = (TRAMPOLINE)trampoline;
+ C_restart_address = proc;
+ heap_scan_top = (C_byte *)C_align((C_uword)C_fromspace_top);
+ gc_mode = GC_MINOR;
+
+ /* Entry point for second-level GC (on explicit request or because of full fromspace): */
+ if(C_setjmp(gc_restart) || (start = C_fromspace_top) >= C_fromspace_limit) {
+ if(gc_bell) C_putchar(7);
+
+ tgc = cpu_milliseconds();
+
+ if(gc_mode == GC_REALLOC) {
+ C_rereclaim2(percentage(heap_size, C_heap_growth), 0);
+ gc_mode = GC_MAJOR;
+ goto never_mind_edsgar;
+ }
+
+ heap_scan_top = (C_byte *)C_align((C_uword)tospace_top);
+ gc_mode = GC_MAJOR;
+
+ /* Mark items in forwarding table: */
+ for(p = forwarding_table; *p != 0; p += 2) {
+ last = p[ 1 ];
+ mark(&p[ 1 ]);
+ C_block_header(p[ 0 ]) = C_block_header(last);
+ }
+
+ /* Mark literal frames: */
+ for(lfn = lf_list; lfn != NULL; lfn = lfn->next)
+ for(i = 0; i < lfn->count; mark(&lfn->lf[ i++ ]));
+
+ /* Mark symbol tables: */
+ for(stp = symbol_table_list; stp != NULL; stp = stp->next)
+ for(i = 0; i < stp->size; mark(&stp->table[ i++ ]));
+
+ /* Mark collectibles: */
+ for(msp = collectibles; msp < collectibles_top; ++msp)
+ if(*msp != NULL) mark(*msp);
+
+ /* mark normal GC roots: */
+ for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {
+ if(!gcrp->finalizable) mark(&gcrp->value);
+ }
+
+ mark_system_globals();
+ }
+ else {
+ /* Mark mutated slots: */
+ for(msp = mutation_stack_bottom; msp < mutation_stack_top; mark(*(msp++)));
+ }
+
+ /* Clear the mutated slot stack: */
+ mutation_stack_top = mutation_stack_bottom;
+
+ /* Mark live values: */
+ for(p = C_temporary_stack; p < C_temporary_stack_bottom; mark(p++));
+
+ /* Mark trace-buffer: */
+ for(tinfo = trace_buffer; tinfo < trace_buffer_limit; ++tinfo) {
+ mark(&tinfo->cooked1);
+ mark(&tinfo->cooked2);
+ mark(&tinfo->thread);
+ }
+
+ rescan:
+ /* Mark nested values in already moved (marked) blocks in breadth-first manner: */
+ while(heap_scan_top < (gc_mode == GC_MINOR ? C_fromspace_top : tospace_top)) {
+ bp = (C_SCHEME_BLOCK *)heap_scan_top;
+
+ if(*((C_word *)bp) == ALIGNMENT_HOLE_MARKER)
+ bp = (C_SCHEME_BLOCK *)((C_word *)bp + 1);
+
+ n = C_header_size(bp);
+ h = bp->header;
+ bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
+ p = bp->data;
+
+ if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {
+ if(h & C_SPECIALBLOCK_BIT) {
+ --n;
+ ++p;
+ }
+
+ while(n--) mark(p++);
+ }
+
+ heap_scan_top = (C_byte *)bp + C_align(bytes) + sizeof(C_word);
+ }
+
+ if(gc_mode == GC_MINOR) {
+ count = (C_uword)C_fromspace_top - (C_uword)start;
+ ++gc_count_1;
+ update_locative_table(GC_MINOR);
+ }
+ else {
+ if(!finalizers_checked) {
+ /* Mark finalizer list and remember pointers to non-forwarded items: */
+ last = C_block_item(pending_finalizers_symbol, 0);
+
+ if(!C_immediatep(last) && (j = C_unfix(C_block_item(last, 0))) != 0) {
+ /* still finalizers pending: just mark table items... */
+ if(gc_report_flag)
+ C_printf(C_text("[GC] %d finalized item(s) still pending\n"), j);
+
+ j = fcount = 0;
+
+ for(flist = finalizer_list; flist != NULL; flist = flist->next) {
+ mark(&flist->item);
+ mark(&flist->finalizer);
+ ++fcount;
+ }
+
+ /* mark finalizable GC roots: */
+ for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {
+ if(gcrp->finalizable) mark(&gcrp->value);
+ }
+
+ if(gc_report_flag && fcount > 0)
+ C_printf(C_text("[GC] %d finalizer value(s) marked\n"), fcount);
+ }
+ else {
+ j = fcount = 0;
+
+ for(flist = finalizer_list; flist != NULL; flist = flist->next) {
+ if(j < C_max_pending_finalizers) {
+ if(!is_fptr(C_block_header(flist->item)))
+ pending_finalizer_indices[ j++ ] = flist;
+ }
+
+ mark(&flist->item);
+ mark(&flist->finalizer);
+ }
+
+ /* mark finalizable GC roots: */
+ for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next) {
+ if(gcrp->finalizable) mark(&gcrp->value);
+ }
+ }
+
+ pending_finalizer_count = j;
+ finalizers_checked = 1;
+
+ if(pending_finalizer_count > 0 && gc_report_flag)
+ C_printf(C_text("[GC] finalizers pending for rescan:\t %d (%d live)\n"),
+ pending_finalizer_count, live_finalizer_count);
+
+ goto rescan;
+ }
+ else {
+ /* Copy finalized items with remembered indices into `##sys#pending-finalizers'
+ (and release finalizer node): */
+ if(pending_finalizer_count > 0) {
+ if(gc_report_flag) C_printf(C_text("[GC] queueing %d finalizers\n"), pending_finalizer_count);
+
+ last = C_block_item(pending_finalizers_symbol, 0);
+ assert(C_u_i_car(last) == C_fix(0));
+ C_set_block_item(last, 0, C_fix(pending_finalizer_count));
+
+ for(i = 0; i < pending_finalizer_count; ++i) {
+ flist = pending_finalizer_indices[ i ];
+ C_set_block_item(last, 1 + i * 2, flist->item);
+ C_set_block_item(last, 2 + i * 2, flist->finalizer);
+
+ if(flist->previous != NULL) flist->previous->next = flist->next;
+ else finalizer_list = flist->next;
+
+ if(flist->next != NULL) flist->next->previous = flist->previous;
+
+ flist->next = finalizer_free_list;
+ flist->previous = NULL;
+ finalizer_free_list = flist;
+ --live_finalizer_count;
+ }
+ }
+ }
+
+ update_locative_table(gc_mode);
+ count = (C_uword)tospace_top - (C_uword)tospace_start;
+
+ /*** isn't gc_mode always GC_MAJOR here? */
+ if(gc_mode == GC_MAJOR &&
+ count < percentage(percentage(heap_size, C_heap_shrinkage), DEFAULT_HEAP_SHRINKAGE_USED) &&
+ heap_size > MINIMAL_HEAP_SIZE && !C_heap_size_is_fixed)
+ C_rereclaim2(percentage(heap_size, C_heap_shrinkage), 0);
+ else {
+ C_fromspace_top = tospace_top;
+ tmp = fromspace_start;
+ fromspace_start = tospace_start;
+ tospace_start = tospace_top = tmp;
+ tmp = C_fromspace_limit;
+ C_fromspace_limit = tospace_limit;
+ tospace_limit = tmp;
+ }
+
+ never_mind_edsgar:
+ ++gc_count_2;
+
+ if(C_enable_gcweak) {
+ /* Check entries in weak item table and recover items ref'd only
+ * once and which are unbound symbols: */
+ weakn = 0;
+ wep = weak_item_table;
+
+ for(i = 0; i < WEAK_TABLE_SIZE; ++i, ++wep)
+ if(wep->item != 0) {
+ if((wep->container & WEAK_COUNTER_MAX) == 0 && is_fptr((item = C_block_header(wep->item)))) {
+ item = fptr_to_ptr(item);
+ container = wep->container & ~WEAK_COUNTER_MASK;
+
+ if(C_header_bits(item) == C_SYMBOL_TYPE && C_u_i_car(item) == C_SCHEME_UNBOUND) {
+ ++weakn;
+#ifdef PARANOIA
+ item = C_u_i_cdr(item);
+ C_fprintf(C_stderr, C_text("[recovered: %.*s]\n"), (int)C_header_size(item), (char *)C_data_pointer(item));
+#endif
+ C_set_block_item(container, 0, C_SCHEME_UNDEFINED);
+ }
+ }
+
+ wep->item = wep->container = 0;
+ }
+
+ /* Remove empty buckets in symbol table: */
+ for(stp = symbol_table_list; stp != NULL; stp = stp->next) {
+ for(i = 0; i < stp->size; ++i) {
+ last = 0;
+
+ for(bucket = stp->table[ i ]; bucket != C_SCHEME_END_OF_LIST; bucket = C_u_i_cdr(bucket))
+ if(C_u_i_car(bucket) == C_SCHEME_UNDEFINED) {
+ if(last) C_set_block_item(last, 1, C_u_i_cdr(bucket));
+ else stp->table[ i ] = C_u_i_cdr(bucket);
+ }
+ else last = bucket;
+ }
+ }
+ }
+ }
+
+ if(gc_mode == GC_MAJOR) {
+ tgc = cpu_milliseconds() - tgc;
+ timer_start_gc_ms += tgc;
+ timer_accumulated_gc_ms += tgc;
+ }
+
+ /* Display GC report:
+ Note: stubbornly writes to stdout - there is no provision for other output-ports */
+ if(gc_report_flag == 1 || (gc_report_flag && gc_mode == GC_MAJOR)) {
+ C_printf(C_text("[GC] level %d\tgcs(minor) %d\tgcs(major) %d\n"),
+ gc_mode, gc_count_1, gc_count_2);
+ i = (C_uword)C_stack_pointer;
+
+#if C_STACK_GROWS_DOWNWARD
+ C_printf(C_text("[GC] stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),
+ (C_uword)C_stack_limit, (C_uword)i, (C_uword)C_stack_limit + stack_size);
+#else
+ C_printf(C_text("[GC] stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),
+ (C_uword)C_stack_limit - stack_size, (C_uword)i, (C_uword)C_stack_limit);
+#endif
+
+ if(gc_mode == GC_MINOR) printf(C_text("\t" UWORD_FORMAT_STRING), count);
+
+ C_printf(C_text("\n[GC] from\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),
+ (C_uword)fromspace_start, (C_uword)C_fromspace_top, (C_uword)C_fromspace_limit);
+
+ if(gc_mode == GC_MAJOR) printf(C_text("\t" UWORD_FORMAT_STRING), count);
+
+ C_printf(C_text("\n[GC] to\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING" \n"),
+ (C_uword)tospace_start, (C_uword)tospace_top,
+ (C_uword)tospace_limit);
+
+ if(gc_mode == GC_MAJOR && C_enable_gcweak && weakn)
+ C_printf(C_text("[GC] %d recoverable weakly held items found\n"), weakn);
+
+ C_printf(C_text("[GC] %d locatives (from %d)\n"), locative_table_count, locative_table_size);
+ }
+
+ if(gc_mode == GC_MAJOR) gc_count_1 = 0;
+
+ if(C_post_gc_hook != NULL) C_post_gc_hook(gc_mode, tgc);
+
+ /* Jump from the Empire State Building... */
+ C_longjmp(C_restart, 1);
+}
+
+
+C_regparm void C_fcall mark_system_globals(void)
+{
+ mark(&interrupt_hook_symbol);
+ mark(&error_hook_symbol);
+ mark(&callback_continuation_stack_symbol);
+ mark(&pending_finalizers_symbol);
+ mark(&invalid_procedure_call_hook_symbol);
+ mark(&unbound_variable_value_hook_symbol);
+ mark(&last_invalid_procedure_symbol);
+ mark(&identity_unbound_value_symbol);
+ mark(¤t_thread_symbol);
+ mark(&apply_hook_symbol);
+ mark(&last_applied_procedure_symbol);
+}
+
+
+C_regparm void C_fcall mark(C_word *x)
+{
+ C_word val, item;
+ C_uword n, bytes;
+ C_header h;
+ C_SCHEME_BLOCK *p, *p2;
+ WEAK_TABLE_ENTRY *wep;
+
+ val = *x;
+
+ if(C_immediatep(val)) return;
+
+ p = (C_SCHEME_BLOCK *)val;
+
+ /* not in stack and not in heap? */
+ if (
+#if C_STACK_GROWS_DOWNWARD
+ p < (C_SCHEME_BLOCK *)C_stack_pointer || p >= (C_SCHEME_BLOCK *)stack_bottom
+#else
+ p >= (C_SCHEME_BLOCK *)C_stack_pointer || p < (C_SCHEME_BLOCK *)stack_bottom
+#endif
+ )
+ if((p < (C_SCHEME_BLOCK *)fromspace_start || p >= (C_SCHEME_BLOCK *)C_fromspace_limit) &&
+ (p < (C_SCHEME_BLOCK *)tospace_start || p >= (C_SCHEME_BLOCK *)tospace_limit) ) {
+#ifdef C_GC_HOOKS
+ if(C_gc_trace_hook != NULL)
+ C_gc_trace_hook(x, gc_mode);
+#endif
+
+ return;
+ }
+
+ h = p->header;
+
+ if(gc_mode == GC_MINOR) {
+ if(is_fptr(h)) {
+ *x = val = fptr_to_ptr(h);
+ return;
+ }
+
+ if((C_uword)val >= (C_uword)fromspace_start && (C_uword)val < (C_uword)C_fromspace_top) return;
+
+ p2 = (C_SCHEME_BLOCK *)C_align((C_uword)C_fromspace_top);
+
+#ifndef C_SIXTY_FOUR
+ if((h & C_8ALIGN_BIT) && aligned8(p2) && (C_byte *)p2 < C_fromspace_limit) {
+ *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;
+ p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);
+ }
+#endif
+
+ n = C_header_size(p);
+ bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
+
+ if(((C_byte *)p2 + bytes + sizeof(C_word)) > C_fromspace_limit)
+ C_longjmp(gc_restart, 1);
+
+ C_fromspace_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);
+
+ scavenge:
+ *x = (C_word)p2;
+ p2->header = h;
+ p->header = ptr_to_fptr((C_uword)p2);
+ C_memcpy(p2->data, p->data, bytes);
+ }
+ else {
+ /* Increase counter if weakly held item: */
+ if(C_enable_gcweak && (wep = lookup_weak_table_entry(val, 0)) != NULL) {
+ if((wep->container & WEAK_COUNTER_MAX) == 0) ++wep->container;
+ }
+
+ if(is_fptr(h)) {
+ val = fptr_to_ptr(h);
+
+ if((C_uword)val >= (C_uword)tospace_start && (C_uword)val < (C_uword)tospace_top) {
+ *x = val;
+ return;
+ }
+
+ /* Link points into fromspace: fetch new pointer + header and copy... */
+ p = (C_SCHEME_BLOCK *)val;
+ h = p->header;
+
+ if(is_fptr(h)) {
+ /* Link points into fromspace and into a link which points into from- or tospace: */
+ val = fptr_to_ptr(h);
+
+ if((C_uword)val >= (C_uword)tospace_start && (C_uword)val < (C_uword)tospace_top) {
+ *x = val;
+ return;
+ }
+
+ p = (C_SCHEME_BLOCK *)val;
+ h = p->header;
+ }
+ }
+
+ p2 = (C_SCHEME_BLOCK *)C_align((C_uword)tospace_top);
+
+#ifndef C_SIXTY_FOUR
+ if((h & C_8ALIGN_BIT) && aligned8(p2) && (C_byte *)p2 < tospace_limit) {
+ *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;
+ p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);
+ }
+#endif
+
+ if(C_enable_gcweak && (h & C_HEADER_TYPE_BITS) == C_BUCKET_TYPE) {
+ item = C_u_i_car(val);
+
+ /* Lookup item in weak item table or add entry: */
+ if((wep = lookup_weak_table_entry(item, (C_word)p2)) != NULL) {
+ /* If item is already forwarded, then set count to 2: */
+ if(is_fptr(C_block_header(item))) wep->container |= 2;
+ }
+ }
+
+ n = C_header_size(p);
+ bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
+
+ if(((C_byte *)p2 + bytes + sizeof(C_word)) > tospace_limit) {
+ if(C_heap_size_is_fixed)
+ panic(C_text("out of memory - heap full"));
+
+ gc_mode = GC_REALLOC;
+ C_longjmp(gc_restart, 1);
+ }
+
+ tospace_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);
+ goto scavenge;
+ }
+}
+
+
+/* Do a major GC into a freshly allocated heap: */
+
+C_regparm void C_fcall C_rereclaim(long size)
+{
+ C_rereclaim2(size < 0 ? -size : size, size < 0);
+}
+
+
+C_regparm void C_fcall C_rereclaim2(C_uword size, int double_plus)
+{
+ int i, j;
+ C_uword count, n, bytes;
+ C_word *p, **msp, item, last;
+ C_header h;
+ C_byte *tmp, *start;
+ LF_LIST *lfn;
+ C_SCHEME_BLOCK *bp;
+ WEAK_TABLE_ENTRY *wep;
+ C_GC_ROOT *gcrp;
+ C_SYMBOL_TABLE *stp;
+ FINALIZER_NODE *flist;
+ TRACE_INFO *tinfo;
+ C_byte *new_heapspace;
+ size_t new_heapspace_size;
+
+ if(C_pre_gc_hook != NULL) C_pre_gc_hook(GC_REALLOC);
+
+ if(double_plus) size = heap_size * 2 + size;
+
+ if(size < MINIMAL_HEAP_SIZE) size = MINIMAL_HEAP_SIZE;
+
+ if(size > C_maximal_heap_size) size = C_maximal_heap_size;
+
+ if(size == heap_size) return;
+
+ if(debug_mode)
+ C_printf(C_text("[debug] resizing heap dynamically from " UWORD_COUNT_FORMAT_STRING "k to " UWORD_COUNT_FORMAT_STRING "k ...\n"),
+ (C_uword)heap_size / 1000, size / 1000);
+
+ if(gc_report_flag) {
+ C_printf(C_text("(old) fromspace: \tstart=%08lx, \tlimit=%08lx\n"), (long)fromspace_start, (long)C_fromspace_limit);
+ C_printf(C_text("(old) tospace: \tstart=%08lx, \tlimit=%08lx\n"), (long)tospace_start, (long)tospace_limit);
+ }
+
+ heap_size = size;
+ size /= 2;
+
+ if ((new_heapspace = heap_alloc (size, &new_tospace_start)) == NULL)
+ panic(C_text("out of memory - cannot allocate heap segment"));
+ new_heapspace_size = size;
+
+ new_tospace_top = new_tospace_start;
+ new_tospace_limit = new_tospace_start + size;
+ heap_scan_top = new_tospace_top;
+
+ /* Mark items in forwarding table: */
+ for(p = forwarding_table; *p != 0; p += 2) {
+ last = p[ 1 ];
+ remark(&p[ 1 ]);
+ C_block_header(p[ 0 ]) = C_block_header(last);
+ }
+
+ /* Mark literal frames: */
+ for(lfn = lf_list; lfn != NULL; lfn = lfn->next)
+ for(i = 0; i < lfn->count; remark(&lfn->lf[ i++ ]));
+
+ /* Mark symbol table: */
+ for(stp = symbol_table_list; stp != NULL; stp = stp->next)
+ for(i = 0; i < stp->size; remark(&stp->table[ i++ ]));
+
+ /* Mark collectibles: */
+ for(msp = collectibles; msp < collectibles_top; ++msp)
+ if(*msp != NULL) remark(*msp);
+
+ for(gcrp = gc_root_list; gcrp != NULL; gcrp = gcrp->next)
+ remark(&gcrp->value);
+
+ remark_system_globals();
+
+ /* Clear the mutated slot stack: */
+ mutation_stack_top = mutation_stack_bottom;
+
+ /* Mark live values: */
+ for(p = C_temporary_stack; p < C_temporary_stack_bottom; remark(p++));
+
+ /* Mark locative table: */
+ for(i = 0; i < locative_table_count; ++i)
+ remark(&locative_table[ i ]);
+
+ /* Mark finalizer table: */
+ for(flist = finalizer_list; flist != NULL; flist = flist->next) {
+ remark(&flist->item);
+ remark(&flist->finalizer);
+ }
+
+ /* Mark weakly held items: */
+ if(C_enable_gcweak) {
+ wep = weak_item_table;
+
+ for(i = 0; i < WEAK_TABLE_SIZE; ++i, ++wep)
+ if(wep->item != 0) remark(&wep->item);
+ }
+
+ /* Mark trace-buffer: */
+ for(tinfo = trace_buffer; tinfo < trace_buffer_limit; ++tinfo) {
+ remark(&tinfo->cooked1);
+ remark(&tinfo->cooked2);
+ remark(&tinfo->thread);
+ }
+
+ update_locative_table(GC_REALLOC);
+
+ /* Mark nested values in already moved (marked) blocks in breadth-first manner: */
+ while(heap_scan_top < new_tospace_top) {
+ bp = (C_SCHEME_BLOCK *)heap_scan_top;
+
+ if(*((C_word *)bp) == ALIGNMENT_HOLE_MARKER)
+ bp = (C_SCHEME_BLOCK *)((C_word *)bp + 1);
+
+ n = C_header_size(bp);
+ h = bp->header;
+ assert(!is_fptr(h));
+ bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
+ p = bp->data;
+
+ if(n > 0 && (h & C_BYTEBLOCK_BIT) == 0) {
+ if(h & C_SPECIALBLOCK_BIT) {
+ --n;
+ ++p;
+ }
+
+ while(n--) remark(p++);
+ }
+
+ heap_scan_top = (C_byte *)bp + C_align(bytes) + sizeof(C_word);
+ }
+
+ heap_free (heapspace1, heapspace1_size);
+ heap_free (heapspace2, heapspace1_size);
+
+ if ((heapspace2 = heap_alloc (size, &tospace_start)) == NULL)
+ panic(C_text("out ot memory - cannot allocate heap segment"));
+ heapspace2_size = size;
+
+ heapspace1 = new_heapspace;
+ heapspace1_size = new_heapspace_size;
+ tospace_limit = tospace_start + size;
+ tospace_top = tospace_start;
+ fromspace_start = new_tospace_start;
+ C_fromspace_top = new_tospace_top;
+ C_fromspace_limit = new_tospace_limit;
+
+ if(gc_report_flag) {
+ C_printf(C_text("[GC] resized heap to %d bytes\n"), heap_size);
+ C_printf(C_text("(new) fromspace: \tstart=%08lx, \tlimit=%08lx\n"), (long)fromspace_start, (long)C_fromspace_limit);
+ C_printf(C_text("(new) tospace: \tstart=%08lx, \tlimit=%08lx\n"), (long)tospace_start, (long)tospace_limit);
+ }
+
+ if(C_post_gc_hook != NULL) C_post_gc_hook(GC_REALLOC, 0);
+}
+
+
+C_regparm void C_fcall remark_system_globals(void)
+{
+ remark(&interrupt_hook_symbol);
+ remark(&error_hook_symbol);
+ remark(&callback_continuation_stack_symbol);
+ remark(&pending_finalizers_symbol);
+ remark(&invalid_procedure_call_hook_symbol);
+ remark(&unbound_variable_value_hook_symbol);
+ remark(&last_invalid_procedure_symbol);
+ remark(&identity_unbound_value_symbol);
+ remark(¤t_thread_symbol);
+ remark(&apply_hook_symbol);
+ remark(&last_applied_procedure_symbol);
+}
+
+
+C_regparm void C_fcall remark(C_word *x)
+{
+ C_word val, item;
+ C_uword n, bytes;
+ C_header h;
+ C_SCHEME_BLOCK *p, *p2;
+ WEAK_TABLE_ENTRY *wep;
+
+ val = *x;
+
+ if(C_immediatep(val)) return;
+
+ p = (C_SCHEME_BLOCK *)val;
+
+ /* not in stack and not in heap? */
+ if(
+#if C_STACK_GROWS_DOWNWARD
+ p < (C_SCHEME_BLOCK *)C_stack_pointer || p >= (C_SCHEME_BLOCK *)stack_bottom
+#else
+ p >= (C_SCHEME_BLOCK *)C_stack_pointer || p < (C_SCHEME_BLOCK *)stack_bottom
+#endif
+ )
+ if((p < (C_SCHEME_BLOCK *)fromspace_start || p >= (C_SCHEME_BLOCK *)C_fromspace_limit) &&
+ (p < (C_SCHEME_BLOCK *)tospace_start || p >= (C_SCHEME_BLOCK *)tospace_limit) &&
+ (p < (C_SCHEME_BLOCK *)new_tospace_start || p >= (C_SCHEME_BLOCK *)new_tospace_limit) ) {
+#ifdef C_GC_HOOKS
+ if(C_gc_trace_hook != NULL)
+ C_gc_trace_hook(x, gc_mode);
+#endif
+
+ return;
+ }
+
+ h = p->header;
+
+ if(is_fptr(h)) {
+ val = fptr_to_ptr(h);
+
+ if((C_uword)val >= (C_uword)new_tospace_start && (C_uword)val < (C_uword)new_tospace_top) {
+ *x = val;
+ return;
+ }
+
+ /* Link points into nursery, fromspace or the old tospace:
+ * fetch new pointer + header and copy... */
+ p = (C_SCHEME_BLOCK *)val;
+ h = p->header;
+ n = 1;
+
+ while(is_fptr(h)) {
+ /* Link points into fromspace or old tospace and into a link which
+ * points into tospace or new-tospace: */
+ val = fptr_to_ptr(h);
+
+ if((C_uword)val >= (C_uword)new_tospace_start && (C_uword)val < (C_uword)new_tospace_top) {
+ *x = val;
+ return;
+ }
+
+ p = (C_SCHEME_BLOCK *)val;
+ h = p->header;
+
+ if(++n > 3)
+ panic(C_text("forwarding chain during re-reclamation is longer than 3. somethings fishy."));
+ }
+ }
+
+ p2 = (C_SCHEME_BLOCK *)C_align((C_uword)new_tospace_top);
+
+#ifndef C_SIXTY_FOUR
+ if((h & C_8ALIGN_BIT) && aligned8(p2) && (C_byte *)p2 < new_tospace_limit) {
+ *((C_word *)p2) = ALIGNMENT_HOLE_MARKER;
+ p2 = (C_SCHEME_BLOCK *)((C_word *)p2 + 1);
+ }
+#endif
+
+ n = C_header_size(p);
+ bytes = (h & C_BYTEBLOCK_BIT) ? n : n * sizeof(C_word);
+
+ if(((C_byte *)p2 + bytes + sizeof(C_word)) > new_tospace_limit) {
+ panic(C_text("out of memory - heap full while resizing"));
+ }
+
+ new_tospace_top = (C_byte *)p2 + C_align(bytes) + sizeof(C_word);
+ *x = (C_word)p2;
+ p2->header = h;
+ assert(!is_fptr(h));
+ p->header = ptr_to_fptr((C_word)p2);
+ C_memcpy(p2->data, p->data, bytes);
+}
+
+
+C_regparm void C_fcall update_locative_table(int mode)
+{
+ int i, hi = 0, invalidated = 0;
+ C_header h;
+ C_word loc, obj, obj2, offset, loc2, ptr;
+ C_uword ptr2;
+
+ for(i = 0; i < locative_table_count; ++i) {
+ loc = locative_table[ i ];
+ /* C_printf("%d: %08lx %d/%d\n", i, loc, C_in_stackp(loc), C_in_heapp(loc)); */
+
+ if(loc != C_SCHEME_UNDEFINED) {
+ h = C_block_header(loc);
+
+ switch(mode) {
+ case GC_MINOR:
+ if(is_fptr(h)) /* forwarded? update l-table entry */
+ loc = locative_table[ i ] = fptr_to_ptr(h);
+ /* otherwise it must have been GC'd (since this is a minor one) */
+ else if(C_in_stackp(loc)) {
+ locative_table[ i ] = C_SCHEME_UNDEFINED;
+ C_set_block_item(loc, 0, 0);
+ ++invalidated;
+ break;
+ }
+
+ /* forwarded. fix up ptr and check pointed-at object for being forwarded... */
+ ptr = C_block_item(loc, 0);
+ offset = C_unfix(C_block_item(loc, 1));
+ obj = ptr - offset;
+ h = C_block_header(obj);
+
+ if(is_fptr(h)) { /* pointed-at object forwarded? update */
+ C_set_block_item(loc, 0, (C_uword)fptr_to_ptr(h) + offset);
+ hi = i + 1;
+ }
+ else if(C_in_stackp(obj)) { /* pointed-at object GC'd, locative is invalid */
+ locative_table[ i ] = C_SCHEME_UNDEFINED;
+ C_set_block_item(loc, 0, 0);
+ }
+ else hi = i + 1;
+
+ break;
+
+ case GC_MAJOR:
+ if(is_fptr(h)) /* forwarded? update l-table entry */
+ loc = locative_table[ i ] = fptr_to_ptr(h);
+ else { /* otherwise, throw away */
+ locative_table[ i ] = C_SCHEME_UNDEFINED;
+ C_set_block_item(loc, 0, 0);
+ ++invalidated;
+ break;
+ }
+
+ h = C_block_header(loc);
+
+ if(is_fptr(h)) /* new instance is forwarded itself? update again */
+ loc = locative_table[ i ] = fptr_to_ptr(h);
+
+ ptr = C_block_item(loc, 0); /* fix up ptr */
+ offset = C_unfix(C_block_item(loc, 1));
+ obj = ptr - offset;
+ h = C_block_header(obj);
+
+ if(is_fptr(h)) { /* pointed-at object has been forwarded? */
+ ptr2 = (C_uword)fptr_to_ptr(h);
+ h = C_block_header(ptr2);
+
+ if(is_fptr(h)) { /* secondary forwarding check for pointed-at object */
+ ptr2 = (C_uword)fptr_to_ptr(h) + offset;
+ C_set_block_item(loc, 0, ptr2);
+ }
+ else C_set_block_item(loc, 0, ptr2 + offset); /* everything's fine, fixup pointer */
+
+ hi = i + 1;
+ }
+ else {
+ locative_table[ i ] = C_SCHEME_UNDEFINED; /* pointed-at object is dead */
+ C_set_block_item(loc, 0, 0);
+ ++invalidated;
+ }
+
+ break;
+
+ case GC_REALLOC:
+ ptr = C_block_item(loc, 0); /* just update ptr's pointed-at objects */
+ offset = C_unfix(C_block_item(loc, 1));
+ obj = ptr - offset;
+ remark(&obj);
+ C_set_block_item(loc, 0, obj + offset);
+ break;
+ }
+ }
+ }
+
+ if(gc_report_flag && invalidated > 0)
+ C_printf(C_text("[GC] locative-table entries reclaimed: %d\n"), invalidated);
+
+ if(mode != GC_REALLOC) locative_table_count = hi;
+}
+
+
+C_regparm WEAK_TABLE_ENTRY *C_fcall lookup_weak_table_entry(C_word item, C_word container)
+{
+ int key = (C_uword)item >> 2,
+ disp = 0,
+ n;
+ WEAK_TABLE_ENTRY *wep;
+
+ for(n = 0; n < WEAK_HASH_ITERATIONS; ++n) {
+ key = (key + disp) % WEAK_TABLE_SIZE;
+ wep = &weak_item_table[ key ];
+
+ if(wep->item == 0) {
+ if(container != 0) {
+ /* Add fresh entry: */
+ wep->item = item;
+ wep->container = container;
+ return wep;
+ }
+
+ return NULL;
+ }
+ else if(wep->item == item) return wep;
+ else disp += WEAK_HASH_DISPLACEMENT;
+ }
+
+ return NULL;
+}
+
+
+void handle_interrupt(void *trampoline, void *proc)
+{
+ C_word *p, x, n;
+ int i;
+ long c;
+
+ /* Build vector with context information: */
+ n = C_temporary_stack_bottom - C_temporary_stack;
+ /* 19 <=> 2 headers + trampoline + proc + 1 extra slot + 9 for interning + 5 for string */
+ p = C_alloc(19 + n);
+ x = (C_word)p;
+ *(p++) = C_VECTOR_TYPE | C_BYTEBLOCK_BIT | (2 * sizeof(C_word));
+ *(p++) = (C_word)trampoline;
+ *(p++) = (C_word)proc;
+ C_save(x);
+ x = (C_word)p;
+ *(p++) = C_VECTOR_TYPE | (n + 1);
+ *(p++) = C_restore;
+ C_memcpy(p, C_temporary_stack, n * sizeof(C_word));
+
+ /* Restore state to the one at the time of the interrupt: */
+ C_temporary_stack = C_temporary_stack_bottom;
+ i = interrupt_reason;
+ interrupt_reason = 0;
+ C_stack_limit = saved_stack_limit;
+
+ /* Invoke high-level interrupt handler: */
+ C_save(C_fix(i));
+ C_save(x);
+ x = C_block_item(interrupt_hook_symbol, 0);
+
+ if(C_immediatep(x))
+ panic(C_text("`##sys#interrupt-hook' is not defined"));
+
+ c = cpu_milliseconds() - interrupt_time;
+ last_interrupt_latency = c;
+ C_timer_interrupt_counter = C_initial_timer_interrupt_period; /* just in case */
+ /* <- no continuation is passed: "##sys#interrupt-hook" may not return! */
+ C_do_apply(2, x, C_SCHEME_UNDEFINED);
+}
+
+
+C_regparm C_word C_fcall C_retrieve(C_word sym)
+{
+ C_word val = C_block_item(sym, 0);
+
+ if(val == C_SCHEME_UNBOUND)
+ return C_get_unbound_variable_value_hook(sym);
+
+ return val;
+}
+
+
+C_word get_unbound_variable_value(C_word sym)
+{
+ C_word x = C_block_item(unbound_variable_value_hook_symbol, 0);
+
+ if(x == identity_unbound_value_symbol) return sym;
+ else if(x == C_SCHEME_FALSE)
+ barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);
+
+ return C_block_item(x, 0);
+}
+
+
+C_regparm C_word C_fcall C_retrieve2(C_word val, char *name)
+{
+ C_word *p;
+ int len;
+
+ if(val == C_SCHEME_UNBOUND) {
+ len = C_strlen(name);
+ /* this is ok: we won't return from `C_retrieve2'
+ * (or the value isn't needed). */
+ p = C_alloc(C_SIZEOF_STRING(len));
+ return get_unbound_variable_value(C_string2(&p, name));
+ }
+
+ return val;
+}
+
+
+#ifndef C_UNSAFE_RUNTIME
+static C_word resolve_procedure(C_word closure, C_char *where)
+{
+ C_word s;
+
+ if(C_immediatep(closure) || C_header_bits(closure) != C_CLOSURE_TYPE) {
+ s = C_block_item(invalid_procedure_call_hook_symbol, 0);
+
+ if(s == C_SCHEME_FALSE)
+ barf(C_NOT_A_CLOSURE_ERROR, where, closure);
+
+ C_mutate(&C_block_item(last_invalid_procedure_symbol, 0), closure);
+ closure = s;
+ }
+
+ return closure;
+}
+#endif
+
+
+C_regparm void *C_fcall C_retrieve_proc(C_word closure)
+{
+ closure = resolve_procedure(closure, NULL);
+
+#ifndef C_NO_APPLY_HOOK
+ if(C_block_item(apply_hook_symbol, 0) != C_SCHEME_FALSE) {
+ C_mutate(&C_block_item(last_applied_procedure_symbol, 0), closure);
+ return (void *)C_block_item(C_block_item(apply_hook_symbol, 0), 0);
+ }
+#endif
+
+ return (void *)C_block_item(closure, 0);
+}
+
+
+C_regparm void *C_fcall C_retrieve_symbol_proc(C_word sym)
+{
+ C_word val = C_block_item(sym, 0);
+ C_word closure;
+
+ if(val == C_SCHEME_UNBOUND)
+ val = C_get_unbound_variable_value_hook(sym);
+
+ closure = resolve_procedure(val, NULL);
+
+#ifndef C_NO_APPLY_HOOK
+ if(C_block_item(apply_hook_symbol, 0) != C_SCHEME_FALSE) {
+ C_mutate(&C_block_item(last_applied_procedure_symbol, 0), closure);
+ return (void *)C_block_item(C_block_item(apply_hook_symbol, 0), 0);
+ }
+#endif
+
+ return (void *)C_block_item(closure, 0);
+}
+
+
+C_regparm void *C_fcall C_retrieve2_symbol_proc(C_word val, char *name)
+{
+ C_word closure;
+ C_word *p;
+ int len;
+
+ if(val == C_SCHEME_UNBOUND) {
+ len = C_strlen(name);
+ /* this is ok: we won't return from `C_retrieve2' (or the value isn't needed). */
+ p = C_alloc(C_SIZEOF_STRING(len));
+ val = get_unbound_variable_value(C_string2(&p, name));
+ }
+
+ closure = resolve_procedure(val, NULL);
+
+#ifndef C_NO_APPLY_HOOK
+ if(C_block_item(apply_hook_symbol, 0) != C_SCHEME_FALSE) {
+ C_mutate(&C_block_item(last_applied_procedure_symbol, 0), closure);
+ return (void *)C_block_item(C_block_item(apply_hook_symbol, 0), 0);
+ }
+#endif
+
+ return (void *)C_block_item(closure, 0);
+}
+
+
+C_regparm void C_fcall C_trace(C_char *name)
+{
+ if(show_trace) {
+ C_fputs(name, C_stderr);
+ C_fputc('\n', C_stderr);
+ }
+
+ if(trace_buffer_top >= trace_buffer_limit) {
+ trace_buffer_top = trace_buffer;
+ trace_buffer_full = 1;
+ }
+
+ trace_buffer_top->raw = name;
+ trace_buffer_top->cooked1 = C_SCHEME_FALSE;
+ trace_buffer_top->cooked2 = C_SCHEME_FALSE;
+ trace_buffer_top->thread = C_block_item(current_thread_symbol, 0);
+ ++trace_buffer_top;
+}
+
+
+/* DEPRECATED: throw out at some stage: */
+C_regparm C_word C_fcall C_emit_trace_info(C_word x, C_word y, C_word t)
+{
+ if(trace_buffer_top >= trace_buffer_limit) {
+ trace_buffer_top = trace_buffer;
+ trace_buffer_full = 1;
+ }
+
+ trace_buffer_top->raw = "<eval>";
+ trace_buffer_top->cooked1 = x;
+ trace_buffer_top->cooked2 = y;
+ trace_buffer_top->thread = t;
+ ++trace_buffer_top;
+ return x;
+}
+
+
+C_regparm C_word C_fcall C_emit_trace_info2(char *raw, C_word x, C_word y, C_word t)
+{
+ if(trace_buffer_top >= trace_buffer_limit) {
+ trace_buffer_top = trace_buffer;
+ trace_buffer_full = 1;
+ }
+
+ trace_buffer_top->raw = raw;
+ trace_buffer_top->cooked1 = x;
+ trace_buffer_top->cooked2 = y;
+ trace_buffer_top->thread = t;
+ ++trace_buffer_top;
+ return x;
+}
+
+
+C_char *C_dump_trace(int start)
+{
+ TRACE_INFO *ptr;
+ C_char *result;
+ int i;
+
+ if((result = (char *)C_malloc(STRING_BUFFER_SIZE)) == NULL)
+ horror(C_text("out of memory - cannot allocate trace-dump buffer"));
+
+ *result = '\0';
+
+ if(trace_buffer_top > trace_buffer || trace_buffer_full) {
+ if(trace_buffer_full) {
+ i = C_trace_buffer_size;
+ C_strcat(result, C_text("...more...\n"));
+ }
+ else i = trace_buffer_top - trace_buffer;
+
+ ptr = trace_buffer_full ? trace_buffer_top : trace_buffer;
+ ptr += start;
+ i -= start;
+
+ for(;i--; ++ptr) {
+ if(ptr >= trace_buffer_limit) ptr = trace_buffer;
+
+ if(C_strlen(result) > STRING_BUFFER_SIZE - 32) {
+ if((result = C_realloc(result, C_strlen(result) * 2)) == NULL)
+ horror(C_text("out of memory - cannot reallocate trace-dump buffer"));
+ }
+
+ C_strcat(result, ptr->raw);
+
+ if(i > 0) C_strcat(result, "\n");
+ else C_strcat(result, " \t<--\n");
+ }
+ }
+
+ return result;
+}
+
+
+C_regparm void C_fcall C_clear_trace_buffer(void)
+{
+ int i;
+
+ if(trace_buffer == NULL) {
+ trace_buffer = (TRACE_INFO *)C_malloc(sizeof(TRACE_INFO) * C_trace_buffer_size);
+
+ if(trace_buffer == NULL)
+ panic(C_text("out of memory - cannot allocate trace-buffer"));
+ }
+
+ trace_buffer_top = trace_buffer;
+ trace_buffer_limit = trace_buffer + C_trace_buffer_size;
+ trace_buffer_full = 0;
+
+ for(i = 0; i < C_trace_buffer_size; ++i) {
+ trace_buffer[ i ].cooked1 = C_SCHEME_FALSE;
+ trace_buffer[ i ].cooked2 = C_SCHEME_FALSE;
+ trace_buffer[ i ].thread = C_SCHEME_FALSE;
+ }
+}
+
+
+C_word C_fetch_trace(C_word starti, C_word buffer)
+{
+ TRACE_INFO *ptr;
+ int i, p = 0, start = C_unfix(starti);
+
+ if(trace_buffer_top > trace_buffer || trace_buffer_full) {
+ if(trace_buffer_full) i = C_trace_buffer_size;
+ else i = trace_buffer_top - trace_buffer;
+
+ ptr = trace_buffer_full ? trace_buffer_top : trace_buffer;
+ ptr += start;
+ i -= start;
+
+ if(C_header_size(buffer) < i * 4)
+ panic(C_text("destination buffer too small for call-chain"));
+
+ for(;i--; ++ptr) {
+ if(ptr >= trace_buffer_limit) ptr = trace_buffer;
+
+ /* outside-pointer, will be ignored by GC */
+ C_mutate(&C_block_item(buffer, p++), (C_word)ptr->raw);
+ C_mutate(&C_block_item(buffer, p++), ptr->cooked1);
+ C_mutate(&C_block_item(buffer, p++), ptr->cooked2);
+ C_mutate(&C_block_item(buffer, p++), ptr->thread);
+ }
+ }
+
+ return C_fix(p);
+}
+
+
+C_regparm C_word C_fcall C_hash_string(C_word str)
+{
+ unsigned C_word key = 0;
+ int len = C_header_size(str);
+ C_byte *ptr = C_data_pointer(str);
+// *(ptr++) means you run off the edge.
+ while(len--) key = (key << 4) + (*ptr++);
+
+ return C_fix(key & C_MOST_POSITIVE_FIXNUM);
+}
+
+
+C_regparm C_word C_fcall C_hash_string_ci(C_word str)
+{
+ unsigned C_word key = 0;
+ int len = C_header_size(str);
+ C_byte *ptr = C_data_pointer(str);
+
+ while(len--) key = (key << 4) + C_tolower(*ptr++);
+
+ return C_fix(key & C_MOST_POSITIVE_FIXNUM);
+}
+
+
+C_regparm void C_fcall C_toplevel_entry(C_char *name)
+{
+ if(debug_mode) {
+ C_printf(C_text("[debug] entering toplevel %s...\n"), name);
+ C_fflush(stdout);
+ }
+}
+
+
+C_word C_halt(C_word msg)
+{
+ C_char *dmp = msg != C_SCHEME_FALSE ? C_dump_trace(0) : NULL;
+
+#ifdef C_MICROSOFT_WINDOWS
+ if(msg != C_SCHEME_FALSE) {
+ int n = C_header_size(msg);
+
+ if (n >= sizeof(buffer))
+ n = sizeof(buffer) - 1;
+ C_strncpy(buffer, (C_char *)C_data_pointer(msg), n);
+ buffer[ n ] = '\0';
+ }
+ else C_strcpy(buffer, C_text("(aborted)"));
+
+ C_strcat(buffer, C_text("\n\n"));
+
+ if(dmp != NULL) C_strcat(buffer, dmp);
+
+ MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK);
+#else
+ if(msg != C_SCHEME_FALSE) {
+ C_fwrite(C_data_pointer(msg), C_header_size(msg), sizeof(C_char), C_stderr);
+ C_fputc('\n', C_stderr);
+ }
+
+ if(dmp != NULL) C_fprintf(stderr, C_text("\n%s"), dmp);
+#endif
+
+ C_exit(EX_SOFTWARE);
+ return 0;
+}
+
+
+C_word C_message(C_word msg)
+{
+#ifdef C_MICROSOFT_WINDOWS
+ int n = C_header_size(msg);
+
+ if (n >= sizeof(buffer))
+ n = sizeof(buffer) - 1;
+ C_strncpy(buffer, (C_char *)((C_SCHEME_BLOCK *)msg)->data, n);
+ buffer[ n ] = '\0';
+ MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK);
+#else
+ C_fwrite(((C_SCHEME_BLOCK *)msg)->data, C_header_size(msg), sizeof(C_char), stdout);
+ C_putchar('\n');
+#endif
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_equalp(C_word x, C_word y)
+{
+ C_header header;
+ C_word bits, n, i;
+
+ C_stack_check;
+
+ loop:
+ if(x == y) return 1;
+
+ if(C_immediatep(x) || C_immediatep(y)) return 0;
+
+ if((header = C_block_header(x)) != C_block_header(y)) return 0;
+ else if((bits = header & C_HEADER_BITS_MASK) & C_BYTEBLOCK_BIT) {
+ if(header == C_FLONUM_TAG && C_block_header(y) == C_FLONUM_TAG)
+ return C_flonum_magnitude(x) == C_flonum_magnitude(y);
+ else return !C_memcmp(C_data_pointer(x), C_data_pointer(y), header & C_HEADER_SIZE_MASK);
+ }
+ else if(header == C_SYMBOL_TAG) return 0;
+ else {
+ i = 0;
+ n = header & C_HEADER_SIZE_MASK;
+
+ if(bits & C_SPECIALBLOCK_BIT) {
+ if(C_u_i_car(x) != C_u_i_car(y)) return 0;
+ else ++i;
+
+ if(n == 1) return 1;
+ }
+
+ if(--n < 0) return 1;
+
+ while(i < n)
+ if(!C_equalp(C_block_item(x, i), C_block_item(y, i))) return 0;
+ else ++i;
+
+ x = C_block_item(x, i);
+ y = C_block_item(y, i);
+ goto loop;
+ }
+
+ return 1;
+}
+
+
+C_regparm C_word C_fcall C_set_gc_report(C_word flag)
+{
+ if(flag == C_SCHEME_FALSE) gc_report_flag = 0;
+ else if(flag == C_SCHEME_TRUE) gc_report_flag = 2;
+ else gc_report_flag = 1;
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_start_timer(void)
+{
+ timer_start_mutation_count = mutation_count;
+ timer_start_gc_count_1 = gc_count_1;
+ timer_start_gc_count_2 = gc_count_2;
+ timer_start_fromspace_top = C_fromspace_top;
+ timer_start_ms = cpu_milliseconds();
+ timer_start_gc_ms = 0;
+ return C_SCHEME_UNDEFINED;
+}
+
+
+void C_ccall C_stop_timer(C_word c, C_word closure, C_word k)
+{
+ long t0 = cpu_milliseconds() - timer_start_ms;
+ int gc2 = gc_count_2 - timer_start_gc_count_2,
+ gc1 = gc2 ? gc_count_1 : (gc_count_1 - timer_start_gc_count_1),
+ mutations = mutation_count - timer_start_mutation_count,
+ from = gc2 ? ((C_uword)C_fromspace_top - (C_uword)fromspace_start)
+ : ((C_uword)C_fromspace_top - (C_uword)timer_start_fromspace_top);
+ C_word
+ ab[ WORDS_PER_FLONUM * 2 + 7 ], /* 2 flonums, 1 vector of 6 elements */
+ *a = ab,
+ elapsed = C_flonum(&a, (double)t0 / 1000.0),
+ gc_time = C_flonum(&a, (double)timer_start_gc_ms / 1000.0),
+ info;
+
+ info = C_vector(&a, 6, elapsed, gc_time, C_fix(mutations), C_fix(gc1), C_fix(gc2), C_fix(from));
+ C_kontinue(k, info);
+}
+
+
+C_word C_exit_runtime(C_word code)
+{
+ exit(C_unfix(code));
+ return 0; /* to please the compiler... */
+}
+
+
+C_regparm C_word C_fcall C_set_print_precision(C_word n)
+{
+ flonum_print_precision = C_unfix(n);
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_get_print_precision(void)
+{
+ return C_fix(flonum_print_precision);
+}
+
+
+C_regparm C_word C_fcall C_display_flonum(C_word port, C_word n)
+{
+ C_FILEPTR fp = C_port_file(port);
+
+#ifdef HAVE_GCVT
+ C_fprintf(fp, C_text("%s"), C_gcvt(C_flonum_magnitude(n), flonum_print_precision, buffer));
+#else
+ C_fprintf(fp, C_text("%.*g"), flonum_print_precision, C_flonum_magnitude(n));
+#endif
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_read_char(C_word port)
+{
+ int c = C_getc(C_port_file(port));
+
+ return c == EOF ? C_SCHEME_END_OF_FILE : C_make_character(c);
+}
+
+
+C_regparm C_word C_fcall C_peek_char(C_word port)
+{
+ C_FILEPTR fp = C_port_file(port);
+ int c = C_getc(fp);
+
+ C_ungetc(c, fp);
+ return c == EOF ? C_SCHEME_END_OF_FILE : C_make_character(c);
+}
+
+
+C_regparm C_word C_fcall C_execute_shell_command(C_word string)
+{
+ int n = C_header_size(string);
+ char *buf = buffer;
+
+ /* Windows doc says to flush all output streams before calling system.
+ Probably a good idea for all platforms. */
+ (void)fflush(NULL);
+
+ if(n >= STRING_BUFFER_SIZE) {
+ if((buf = (char *)C_malloc(n + 1)) == NULL)
+ barf(C_OUT_OF_MEMORY_ERROR, "system");
+ }
+
+ C_memcpy(buf, ((C_SCHEME_BLOCK *)string)->data, n);
+ buf[ n ] = '\0';
+
+ n = C_system(buf);
+
+ if(buf != buffer) C_free(buf);
+
+ return C_fix(n);
+}
+
+
+C_regparm C_word C_fcall C_string_to_pbytevector(C_word s)
+{
+ return C_pbytevector(C_header_size(s), C_data_pointer(s));
+}
+
+
+C_regparm C_word C_fcall C_char_ready_p(C_word port)
+{
+#if !defined(C_NONUNIX)
+ fd_set fs;
+ struct timeval to;
+ int fd = C_fileno(C_port_file(port));
+
+ FD_ZERO(&fs);
+ FD_SET(fd, &fs);
+ to.tv_sec = to.tv_usec = 0;
+ return C_mk_bool(C_select(fd + 1, &fs, NULL, NULL, &to) == 1);
+#else
+ return C_SCHEME_TRUE;
+#endif
+}
+
+
+C_regparm C_word C_fcall C_flush_output(C_word port)
+{
+ C_fflush(C_port_file(port));
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_fudge(C_word fudge_factor)
+{
+ int i, j;
+ long tgc;
+
+ switch(fudge_factor) {
+ case C_fix(1): return C_SCHEME_END_OF_FILE;
+ case C_fix(2):
+ /* can be considered broken (overflows into negatives), but is useful for randomize */
+ return C_fix(C_MOST_POSITIVE_FIXNUM & time(NULL));
+
+ case C_fix(3):
+#ifdef C_SIXTY_FOUR
+ return C_SCHEME_TRUE;
+#else
+ return C_SCHEME_FALSE;
+#endif
+
+ case C_fix(4):
+#ifdef C_GENERIC_CONSOLE
+ return C_SCHEME_TRUE;
+#else
+ return C_SCHEME_FALSE;
+#endif
+
+ case C_fix(5):
+#ifdef C_GENERIC_CONSOLE
+ return C_fix(0);
+#elif defined(C_WINDOWS_GUI)
+ return C_fix(1);
+#else
+ return C_SCHEME_FALSE;
+#endif
+
+ case C_fix(6):
+ return C_fix(C_MOST_POSITIVE_FIXNUM & cpu_milliseconds());
+
+ case C_fix(7):
+ return C_fix(sizeof(C_word));
+
+ case C_fix(8):
+ return C_fix(C_wordsperdouble(1));
+
+ case C_fix(9):
+ return C_fix(last_interrupt_latency);
+
+ case C_fix(10):
+ return C_fix(CLOCKS_PER_SEC);
+
+ case C_fix(11):
+#if defined(C_NONUNIX) || defined(__CYGWIN__)
+ return C_SCHEME_FALSE;
+#else
+ return C_SCHEME_TRUE;
+#endif
+
+ case C_fix(12):
+ return C_mk_bool(fake_tty_flag);
+
+ case C_fix(13):
+ return C_mk_bool(debug_mode);
+
+ case C_fix(14):
+ return C_mk_bool(C_interrupts_enabled);
+
+ case C_fix(15):
+ return C_mk_bool(C_enable_gcweak);
+
+ case C_fix(16):
+ return C_fix(C_MOST_POSITIVE_FIXNUM & milliseconds());
+
+ case C_fix(17):
+ return(C_mk_bool(C_heap_size_is_fixed));
+
+ case C_fix(18):
+ return(C_fix(C_STACK_GROWS_DOWNWARD));
+
+ case C_fix(19):
+ for(i = j = 0; i < locative_table_count; ++i)
+ if(locative_table[ i ] != C_SCHEME_UNDEFINED) ++j;
+ return C_fix(j);
+
+ case C_fix(20):
+#ifdef C_UNSAFE_RUNTIME
+ return C_SCHEME_TRUE;
+#else
+ return C_SCHEME_FALSE;
+#endif
+
+ case C_fix(21):
+ return C_fix(C_MOST_POSITIVE_FIXNUM);
+
+ /* 22 */
+
+ case C_fix(23):
+ return C_fix(C_startup_time_seconds);
+
+ case C_fix(24):
+#ifdef NO_DLOAD2
+ return C_SCHEME_FALSE;
+#else
+ return C_SCHEME_TRUE;
+#endif
+
+ case C_fix(25):
+ return C_mk_bool(C_enable_repl);
+
+ case C_fix(26):
+ return C_fix(live_finalizer_count);
+
+ case C_fix(27):
+ return C_fix(allocated_finalizer_count);
+
+ case C_fix(28):
+#ifdef C_ENABLE_PTABLES
+ return C_SCHEME_TRUE;
+#else
+ return C_SCHEME_FALSE;
+#endif
+
+ case C_fix(29):
+ return C_fix(C_trace_buffer_size);
+
+ case C_fix(30):
+#ifdef _MSC_VER
+ return C_fix(_MSC_VER);
+#else
+ return C_SCHEME_FALSE;
+#endif
+
+ case C_fix(31):
+ tgc = timer_accumulated_gc_ms;
+ timer_accumulated_gc_ms = 0;
+ return C_fix(tgc);
+
+ case C_fix(32):
+#ifdef C_GC_HOOKS
+ return C_SCHEME_TRUE;
+#else
+ return C_SCHEME_FALSE;
+#endif
+
+ case C_fix(33):
+ return C_SCHEME_TRUE;
+
+ case C_fix(34):
+#ifdef C_HACKED_APPLY
+ return C_fix(TEMPORARY_STACK_SIZE);
+#else
+ return C_fix(126);
+#endif
+
+ case C_fix(35):
+#ifndef C_NO_APPLY_HOOK
+ return C_SCHEME_TRUE;
+#else
+ return C_SCHEME_FALSE;
+#endif
+
+ case C_fix(36):
+ debug_mode = !debug_mode;
+ return C_mk_bool(debug_mode);
+
+ /* 37 */
+
+ case C_fix(38):
+#ifdef C_SVN_REVISION
+ return C_fix(C_SVN_REVISION);
+#else
+ return C_fix(0);
+#endif
+
+ case C_fix(39):
+#if defined(C_CROSS_CHICKEN) && C_CROSS_CHICKEN
+ return C_SCHEME_TRUE;
+#else
+ return C_SCHEME_FALSE;
+#endif
+
+ case C_fix(40):
+#if defined(C_HACKED_APPLY)
+ return C_SCHEME_TRUE;
+#else
+ return C_SCHEME_FALSE;
+#endif
+
+ case C_fix(41):
+ return C_fix(C_MAJOR_VERSION);
+
+ case C_fix(42):
+#ifdef C_BINARY_VERSION
+ return C_fix(C_BINARY_VERSION);
+#else
+ return C_SCHEME_FALSE;
+#endif
+
+ default: return C_SCHEME_UNDEFINED;
+ }
+}
+
+
+C_regparm void C_fcall C_paranoid_check_for_interrupt(void)
+{
+ if(--C_timer_interrupt_counter <= 0)
+ C_raise_interrupt(C_TIMER_INTERRUPT_NUMBER);
+}
+
+
+C_regparm void C_fcall C_raise_interrupt(int reason)
+{
+ if(C_interrupts_enabled) {
+ saved_stack_limit = C_stack_limit;
+
+#if C_STACK_GROWS_DOWNWARD
+ C_stack_limit = C_stack_pointer + 1000;
+#else
+ C_stack_limit = C_stack_pointer - 1000;
+#endif
+
+ interrupt_reason = reason;
+ interrupt_time = cpu_milliseconds();
+ }
+}
+
+
+C_regparm C_word C_fcall C_set_initial_timer_interrupt_period(C_word n)
+{
+ C_initial_timer_interrupt_period = C_unfix(n);
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_enable_interrupts(void)
+{
+ C_timer_interrupt_counter = C_initial_timer_interrupt_period;
+ /* assert(C_timer_interrupt_counter > 0); */
+ C_interrupts_enabled = 1;
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_disable_interrupts(void)
+{
+ C_interrupts_enabled = 0;
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_establish_signal_handler(C_word signum, C_word reason)
+{
+ int sig = C_unfix(signum);
+
+ if(reason == C_SCHEME_FALSE) C_signal(sig, SIG_IGN);
+ else {
+ signal_mapping_table[ sig ] = C_unfix(reason);
+ C_signal(sig, global_signal_handler);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_flonum_in_fixnum_range_p(C_word n)
+{
+ double f = C_flonum_magnitude(n);
+
+ return C_mk_bool(f <= (double)C_MOST_POSITIVE_FIXNUM && f >= (double)C_MOST_NEGATIVE_FIXNUM);
+}
+
+
+C_regparm C_word C_fcall C_double_to_number(C_word n)
+{
+ double m, f = C_flonum_magnitude(n);
+
+ if(f <= (double)C_MOST_POSITIVE_FIXNUM
+ && f >= (double)C_MOST_NEGATIVE_FIXNUM && modf(f, &m) == 0.0)
+ return C_fix(f);
+ else return n;
+}
+
+
+C_regparm C_word C_fcall C_fits_in_int_p(C_word x)
+{
+ double n, m;
+
+ if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
+
+ n = C_flonum_magnitude(x);
+ return C_mk_bool(modf(n, &m) == 0.0 && n >= C_WORD_MIN && n <= C_WORD_MAX);
+}
+
+
+C_regparm C_word C_fcall C_fits_in_unsigned_int_p(C_word x)
+{
+ double n, m;
+
+ if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
+
+ n = C_flonum_magnitude(x);
+ return C_mk_bool(modf(n, &m) == 0.0 && n >= 0 && n <= C_UWORD_MAX);
+}
+
+
+/* Copy blocks into collected or static memory: */
+
+C_regparm C_word C_fcall C_copy_block(C_word from, C_word to)
+{
+ int n = C_header_size(from);
+ long bytes;
+
+ if(C_header_bits(from) & C_BYTEBLOCK_BIT) {
+ bytes = n;
+ C_memcpy((C_SCHEME_BLOCK *)to, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));
+ }
+ else {
+ bytes = C_wordstobytes(n);
+ C_memcpy((C_SCHEME_BLOCK *)to, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));
+ }
+
+ return to;
+}
+
+
+C_regparm C_word C_fcall C_evict_block(C_word from, C_word ptr)
+{
+ int n = C_header_size(from);
+ long bytes;
+ C_word *p = (C_word *)C_pointer_address(ptr);
+
+ if(C_header_bits(from) & C_BYTEBLOCK_BIT) bytes = n;
+ else bytes = C_wordstobytes(n);
+
+ C_memcpy(p, (C_SCHEME_BLOCK *)from, bytes + sizeof(C_header));
+ return (C_word)p;
+}
+
+
+/* Conversion routines: */
+
+C_regparm double C_fcall C_c_double(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return (double)C_unfix(x);
+ else return C_flonum_magnitude(x);
+}
+
+
+C_regparm C_word C_fcall C_num_to_int(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_unfix(x);
+ else return (int)C_flonum_magnitude(x);
+}
+
+
+C_regparm C_s64 C_fcall C_num_to_int64(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return (C_s64)C_unfix(x);
+ else return (C_s64)C_flonum_magnitude(x);
+}
+
+
+C_regparm C_uword C_fcall C_num_to_unsigned_int(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_unfix(x);
+ else return (unsigned int)C_flonum_magnitude(x);
+}
+
+
+C_regparm C_word C_fcall C_int_to_num(C_word **ptr, C_word n)
+{
+ if(C_fitsinfixnump(n)) return C_fix(n);
+ else return C_flonum(ptr, (double)n);
+}
+
+
+C_regparm C_word C_fcall C_unsigned_int_to_num(C_word **ptr, C_uword n)
+{
+ if(C_ufitsinfixnump(n)) return C_fix(n);
+ else return C_flonum(ptr, (double)n);
+}
+
+
+C_regparm C_word C_fcall C_long_to_num(C_word **ptr, long n)
+{
+ if(C_fitsinfixnump(n)) return C_fix(n);
+ else return C_flonum(ptr, (double)n);
+}
+
+
+C_regparm C_word C_fcall C_unsigned_long_to_num(C_word **ptr, unsigned long n)
+{
+ if(C_ufitsinfixnump(n)) return C_fix(n);
+ else return C_flonum(ptr, (double)n);
+}
+
+
+C_regparm C_word C_fcall C_flonum_in_int_range_p(C_word n)
+{
+ double m = C_flonum_magnitude(n);
+
+ return C_mk_bool(m >= C_WORD_MIN && m <= C_WORD_MAX);
+}
+
+
+C_regparm C_word C_fcall C_flonum_in_uint_range_p(C_word n)
+{
+ double m = C_flonum_magnitude(n);
+
+ return C_mk_bool(m >= 0 && m <= C_UWORD_MAX);
+}
+
+
+C_regparm char *C_fcall C_string_or_null(C_word x)
+{
+ return C_truep(x) ? C_c_string(x) : NULL;
+}
+
+
+C_regparm void *C_fcall C_data_pointer_or_null(C_word x)
+{
+ return C_truep(x) ? C_data_pointer(x) : NULL;
+}
+
+
+C_regparm void *C_fcall C_srfi_4_vector_or_null(C_word x)
+{
+ return C_truep(x) ? C_data_pointer(C_block_item(x, 1)) : NULL;
+}
+
+
+C_regparm void *C_fcall C_c_pointer_or_null(C_word x)
+{
+ return C_truep(x) ? (void *)C_block_item(x, 0) : NULL;
+}
+
+
+C_regparm void *C_fcall C_scheme_or_c_pointer(C_word x)
+{
+ return C_anypointerp(x) ? (void *)C_block_item(x, 0) : C_data_pointer(x);
+}
+
+
+C_regparm long C_fcall C_num_to_long(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_unfix(x);
+ else return (long)C_flonum_magnitude(x);
+}
+
+
+C_regparm unsigned long C_fcall C_num_to_unsigned_long(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_unfix(x);
+ else return (unsigned long)C_flonum_magnitude(x);
+}
+
+
+/* Inline versions of some standard procedures: */
+
+C_regparm C_word C_fcall C_i_listp(C_word x)
+{
+ C_word fast = x, slow = x;
+
+ while(fast != C_SCHEME_END_OF_LIST)
+ if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) {
+ fast = C_u_i_cdr(fast);
+
+ if(fast == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;
+ else if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) {
+ fast = C_u_i_cdr(fast);
+ slow = C_u_i_cdr(slow);
+
+ if(fast == slow) return C_SCHEME_FALSE;
+ }
+ else return C_SCHEME_FALSE;
+ }
+ else return C_SCHEME_FALSE;
+
+ return C_SCHEME_TRUE;
+}
+
+
+C_regparm C_word C_fcall C_i_string_equal_p(C_word x, C_word y)
+{
+ C_word n;
+
+ if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", x);
+
+ if(C_immediatep(y) || C_header_bits(y) != C_STRING_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "string=?", y);
+
+ n = C_header_size(x);
+
+ return C_mk_bool(n == C_header_size(y)
+ && !C_memcmp((char *)C_data_pointer(x), (char *)C_data_pointer(y), n));
+}
+
+
+C_regparm C_word C_fcall C_u_i_string_equal_p(C_word x, C_word y)
+{
+ C_word n;
+
+ n = C_header_size(x);
+ return C_mk_bool(n == C_header_size(y)
+ && !C_memcmp((char *)C_data_pointer(x), (char *)C_data_pointer(y), n));
+}
+
+
+C_regparm C_word C_fcall C_i_string_ci_equal_p(C_word x, C_word y)
+{
+ C_word n;
+ char *p1, *p2;
+
+ if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", x);
+
+ if(C_immediatep(y) || C_header_bits(y) != C_STRING_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ci=?", y);
+
+ n = C_header_size(x);
+
+ if(n != C_header_size(y)) return C_SCHEME_FALSE;
+
+ p1 = (char *)C_data_pointer(x);
+ p2 = (char *)C_data_pointer(y);
+
+ while(n--)
+ if(C_tolower(*(p1++)) != C_tolower(*(p2++))) return C_SCHEME_FALSE;
+
+ return C_SCHEME_TRUE;
+}
+
+
+C_regparm C_word C_fcall C_i_eqvp(C_word x, C_word y)
+{
+ return
+ C_mk_bool(x == y ||
+ (!C_immediatep(x) && !C_immediatep(y) &&
+ C_block_header(x) == C_FLONUM_TAG && C_block_header(y) == C_FLONUM_TAG &&
+ C_flonum_magnitude(x) == C_flonum_magnitude(y) ) );
+}
+
+
+C_regparm C_word C_fcall C_i_symbolp(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_SYMBOL_TAG);
+}
+
+
+C_regparm C_word C_fcall C_i_pairp(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_PAIR_TAG);
+}
+
+
+C_regparm C_word C_fcall C_i_stringp(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_STRING_TYPE);
+}
+
+
+C_regparm C_word C_fcall C_i_locativep(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_LOCATIVE_TAG);
+}
+
+
+C_regparm C_word C_fcall C_i_vectorp(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_VECTOR_TYPE);
+}
+
+
+C_regparm C_word C_fcall C_i_portp(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_PORT_TYPE);
+}
+
+
+C_regparm C_word C_fcall C_i_closurep(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && C_header_bits(x) == C_CLOSURE_TYPE);
+}
+
+
+C_regparm C_word C_fcall C_i_numberp(C_word x)
+{
+ return C_mk_bool((x & C_FIXNUM_BIT)
+ || (!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG));
+}
+
+
+C_regparm C_word C_fcall C_i_rationalp(C_word x)
+{
+ if((x & C_FIXNUM_BIT) != 0) return C_SCHEME_TRUE;
+
+ if((!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG)) {
+ double n = C_flonum_magnitude(x);
+
+ if(!C_isinf(n) && !C_isnan(n)) return C_SCHEME_TRUE;
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
+C_regparm C_word C_fcall C_i_integerp(C_word x)
+{
+ double dummy;
+
+ return C_mk_bool((x & C_FIXNUM_BIT) ||
+ ((!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) &&
+ modf(C_flonum_magnitude(x), &dummy) == 0.0 ) );
+}
+
+
+C_regparm C_word C_fcall C_i_flonump(C_word x)
+{
+ return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG);
+}
+
+
+C_regparm C_word C_fcall C_i_finitep(C_word x)
+{
+ if((x & C_FIXNUM_BIT) != 0) return C_SCHEME_TRUE;
+ else return C_mk_bool(!C_isinf(C_flonum_magnitude(x)));
+}
+
+
+C_regparm C_word C_fcall C_i_fixnum_min(C_word x, C_word y)
+{
+ return ((C_word)x < (C_word)y) ? x : y;
+}
+
+
+C_regparm C_word C_fcall C_i_fixnum_max(C_word x, C_word y)
+{
+ return ((C_word)x > (C_word)y) ? x : y;
+}
+
+
+C_regparm C_word C_fcall C_i_flonum_min(C_word x, C_word y)
+{
+ double
+ xf = C_flonum_magnitude(x),
+ yf = C_flonum_magnitude(y);
+
+ return xf < yf ? x : y;
+}
+
+
+C_regparm C_word C_fcall C_i_flonum_max(C_word x, C_word y)
+{
+ double
+ xf = C_flonum_magnitude(x),
+ yf = C_flonum_magnitude(y);
+
+ return xf > yf ? x : y;
+}
+
+
+#if !defined(__GNUC__) && !defined(__INTEL_COMPILER)
+
+C_word *C_a_i(C_word **a, int n)
+{
+ C_word *p = *a;
+
+ *a += n;
+ return p;
+}
+
+#endif
+
+
+C_word C_a_i_list(C_word **a, int c, ...)
+{
+ va_list v;
+ C_word x, last, current,
+ first = C_SCHEME_END_OF_LIST;
+
+ va_start(v, c);
+
+ for(last = C_SCHEME_UNDEFINED; c--; last = current) {
+ x = va_arg(v, C_word);
+ current = C_pair(a, x, C_SCHEME_END_OF_LIST);
+
+ if(last != C_SCHEME_UNDEFINED)
+ C_set_block_item(last, 1, current);
+ else first = current;
+ }
+
+ va_end(v);
+ return first;
+}
+
+
+C_word C_h_list(int c, ...)
+{
+ /* Similar to C_a_i_list(), but put slots with nursery data into mutation stack: */
+ va_list v;
+ C_word x, last, current,
+ first = C_SCHEME_END_OF_LIST;
+
+ va_start(v, c);
+
+ for(last = C_SCHEME_UNDEFINED; c--; last = current) {
+ x = va_arg(v, C_word);
+ current = C_pair(C_heaptop, x, C_SCHEME_END_OF_LIST);
+
+ if(C_in_stackp(x))
+ C_mutate(&C_u_i_car(current), x);
+
+ if(last != C_SCHEME_UNDEFINED)
+ C_set_block_item(last, 1, current);
+ else first = current;
+ }
+
+ va_end(v);
+ return first;
+}
+
+
+C_word C_a_i_string(C_word **a, int c, ...)
+{
+ va_list v;
+ C_word x, s = (C_word)(*a);
+ char *p;
+
+ *a = (C_word *)((C_word)(*a) + sizeof(C_header) + C_align(c));
+ ((C_SCHEME_BLOCK *)s)->header = C_STRING_TYPE | c;
+ p = (char *)C_data_pointer(s);
+ va_start(v, c);
+
+ while(c--) {
+ x = va_arg(v, C_word);
+
+ if((x & C_IMMEDIATE_TYPE_BITS) == C_CHARACTER_BITS)
+ *(p++) = C_character_code(x);
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "string", x);
+ }
+
+ return s;
+}
+
+
+C_word C_a_i_record(C_word **ptr, int n, ...)
+{
+ va_list v;
+ C_word *p = *ptr,
+ *p0 = p;
+
+ *(p++) = C_STRUCTURE_TYPE | n;
+ va_start(v, n);
+
+ while(n--)
+ *(p++) = va_arg(v, C_word);
+
+ *ptr = p;
+ va_end(v);
+ return (C_word)p0;
+}
+
+
+C_word C_a_i_port(C_word **ptr, int n)
+{
+ C_word
+ *p = *ptr,
+ *p0 = p;
+ int i;
+
+ *(p++) = C_PORT_TYPE | (C_SIZEOF_PORT - 1);
+ *(p++) = (C_word)NULL;
+
+ for(i = 0; i < C_SIZEOF_PORT - 2; ++i)
+ *(p++) = C_SCHEME_FALSE;
+
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+C_regparm C_word C_fcall C_a_i_bytevector(C_word **ptr, int c, C_word num)
+{
+ C_word *p = *ptr,
+ *p0;
+ int n = C_unfix(num);
+
+#ifndef C_SIXTY_FOUR
+ /* Align on 8-byte boundary: */
+ if(aligned8(p)) ++p;
+#endif
+
+ p0 = p;
+ *(p++) = C_BYTEVECTOR_TYPE | C_wordstobytes(n);
+ *ptr = p + n;
+ return (C_word)p0;
+}
+
+
+C_word C_fcall C_a_i_smart_mpointer(C_word **ptr, int c, C_word x)
+{
+ C_word
+ *p = *ptr,
+ *p0 = p;
+ void *mp;
+
+ if(C_immediatep(x)) mp = NULL;
+ else if((C_header_bits(x) && C_SPECIALBLOCK_BIT) != 0) mp = C_pointer_address(x);
+ else mp = C_data_pointer(x);
+
+ *(p++) = C_POINTER_TYPE | 1;
+ *((void **)p) = mp;
+ *ptr = p + 1;
+ return (C_word)p0;
+}
+
+
+C_regparm C_word C_fcall C_i_exactp(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
+
+ if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "exact?", x);
+
+ return C_SCHEME_FALSE;
+}
+
+
+C_regparm C_word C_fcall C_u_i_exactp(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_SCHEME_TRUE;
+
+ return C_SCHEME_FALSE;
+}
+
+
+C_regparm C_word C_fcall C_i_inexactp(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_SCHEME_FALSE;
+
+ if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "inexact?", x);
+
+ return C_SCHEME_TRUE;
+}
+
+
+C_regparm C_word C_fcall C_u_i_inexactp(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_SCHEME_FALSE;
+
+ return C_SCHEME_TRUE;
+}
+
+
+C_regparm C_word C_fcall C_i_zerop(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_mk_bool(x == C_fix(0));
+
+ if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "zero?", x);
+
+ return C_mk_bool(C_flonum_magnitude(x) == 0.0);
+}
+
+
+C_regparm C_word C_fcall C_u_i_zerop(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_mk_bool(x == C_fix(0));
+
+ return C_mk_bool(C_flonum_magnitude(x) == 0.0);
+}
+
+
+C_regparm C_word C_fcall C_i_positivep(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) > 0);
+
+ if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "positive?", x);
+
+ return C_mk_bool(C_flonum_magnitude(x) > 0.0);
+}
+
+
+C_regparm C_word C_fcall C_u_i_positivep(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) > 0);
+
+ return C_mk_bool(C_flonum_magnitude(x) > 0.0);
+}
+
+
+C_regparm C_word C_fcall C_i_negativep(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) < 0);
+
+ if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "negative?", x);
+
+ return C_mk_bool(C_flonum_magnitude(x) < 0.0);
+}
+
+
+C_regparm C_word C_fcall C_u_i_negativep(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_mk_bool(C_unfix(x) < 0);
+
+ return C_mk_bool(C_flonum_magnitude(x) < 0.0);
+}
+
+
+C_regparm C_word C_fcall C_i_evenp(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_mk_nbool(x & 0x02);
+
+ if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "even?", x);
+
+ return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) == 0.0);
+}
+
+
+C_regparm C_word C_fcall C_u_i_evenp(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_mk_nbool(x & 0x02);
+
+ return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) == 0.0);
+}
+
+
+C_regparm C_word C_fcall C_i_oddp(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_mk_bool(x & 0x02);
+
+ if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "odd?", x);
+
+ return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) != 0.0);
+}
+
+
+C_regparm C_word C_fcall C_u_i_oddp(C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_mk_bool(x & 0x02);
+
+ return C_mk_bool(fmod(C_flonum_magnitude(x), 2.0) != 0.0);
+}
+
+
+C_regparm C_word C_fcall C_i_car(C_word x)
+{
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "car", x);
+
+ return C_u_i_car(x);
+}
+
+
+C_regparm C_word C_fcall C_i_cdr(C_word x)
+{
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdr", x);
+
+ return C_u_i_cdr(x);
+}
+
+
+C_regparm C_word C_fcall C_i_cadr(C_word x)
+{
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
+ bad:
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadr", x);
+ }
+
+ x = C_u_i_cdr(x);
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
+
+ return C_u_i_car(x);
+}
+
+
+C_regparm C_word C_fcall C_i_cddr(C_word x)
+{
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
+ bad:
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddr", x);
+ }
+
+ x = C_u_i_cdr(x);
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
+
+ return C_u_i_cdr(x);
+}
+
+
+C_regparm C_word C_fcall C_i_caddr(C_word x)
+{
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
+ bad:
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "caddr", x);
+ }
+
+ x = C_u_i_cdr(x);
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
+ x = C_u_i_cdr(x);
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
+
+ return C_u_i_car(x);
+}
+
+
+C_regparm C_word C_fcall C_i_cdddr(C_word x)
+{
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
+ bad:
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdddr", x);
+ }
+
+ x = C_u_i_cdr(x);
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
+ x = C_u_i_cdr(x);
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
+
+ return C_u_i_cdr(x);
+}
+
+
+C_regparm C_word C_fcall C_i_cadddr(C_word x)
+{
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
+ bad:
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "cadddr", x);
+ }
+
+ x = C_u_i_cdr(x);
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
+ x = C_u_i_cdr(x);
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
+ x = C_u_i_cdr(x);
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
+
+ return C_u_i_car(x);
+}
+
+
+C_regparm C_word C_fcall C_i_cddddr(C_word x)
+{
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
+ bad:
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "cddddr", x);
+ }
+
+ x = C_u_i_cdr(x);
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
+ x = C_u_i_cdr(x);
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
+ x = C_u_i_cdr(x);
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) goto bad;
+
+ return C_u_i_cdr(x);
+}
+
+
+C_regparm C_word C_fcall C_i_list_tail(C_word lst, C_word i)
+{
+ C_word lst0 = lst;
+ int n;
+
+ if(i & C_FIXNUM_BIT) n = C_unfix(i);
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "list-tail", i);
+
+ while(n--) {
+ if(C_immediatep(lst) || C_block_header(lst) != C_PAIR_TAG)
+ barf(C_OUT_OF_RANGE_ERROR, "list-tail", lst0, i);
+
+ lst = C_u_i_cdr(lst);
+ }
+
+ return lst;
+}
+
+
+C_regparm C_word C_fcall C_i_vector_ref(C_word v, C_word i)
+{
+ int j;
+
+ if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= C_header_size(v)) barf(C_OUT_OF_RANGE_ERROR, "vector-ref", v, i);
+
+ return C_block_item(v, j);
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-ref", i);
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_block_ref(C_word x, C_word i)
+{
+ int j;
+
+ if(C_immediatep(x) || (C_header_bits(x) & C_BYTEBLOCK_BIT) != 0)
+ barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, "##sys#block-ref", x);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= C_header_size(x)) barf(C_OUT_OF_RANGE_ERROR, "##sys#block-ref", x, i);
+
+ return C_block_item(x, j);
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "##sys#block-ref", i);
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_string_set(C_word s, C_word i, C_word c)
+{
+ int j;
+
+ if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", s);
+
+ if(!C_immediatep(c) || (c & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", c);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= C_header_size(s)) barf(C_OUT_OF_RANGE_ERROR, "string-set!", s, i);
+
+ return C_setsubchar(s, i, c);
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", i);
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_string_ref(C_word s, C_word i)
+{
+ int j;
+
+ if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", s);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= C_header_size(s)) barf(C_OUT_OF_RANGE_ERROR, "string-ref", s, i);
+
+ return C_subchar(s, i);
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-ref", i);
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_vector_length(C_word v)
+{
+ if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-length", v);
+
+ return C_fix(C_header_size(v));
+}
+
+
+C_regparm C_word C_fcall C_i_string_length(C_word s)
+{
+ if(C_immediatep(s) || C_header_bits(s) != C_STRING_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-length", s);
+
+ return C_fix(C_header_size(s));
+}
+
+
+C_regparm C_word C_fcall C_i_length(C_word lst)
+{
+ C_word fast = lst, slow = lst;
+ int n = 0;
+
+ while(slow != C_SCHEME_END_OF_LIST) {
+ if(fast != C_SCHEME_END_OF_LIST) {
+ if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) {
+ fast = C_u_i_cdr(fast);
+
+ if(fast != C_SCHEME_END_OF_LIST) {
+ if(!C_immediatep(fast) && C_block_header(fast) == C_PAIR_TAG) {
+ fast = C_u_i_cdr(fast);
+ }
+ else barf(C_NOT_A_PROPER_LIST_ERROR, "length", lst);
+ }
+
+ if(fast == slow)
+ barf(C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR, "length", lst);
+ }
+ }
+
+ if(C_immediatep(slow) || C_block_header(lst) != C_PAIR_TAG)
+ barf(C_NOT_A_PROPER_LIST_ERROR, "length", lst);
+
+ slow = C_u_i_cdr(slow);
+ ++n;
+ }
+
+ return C_fix(n);
+}
+
+
+C_regparm C_word C_fcall C_u_i_length(C_word lst)
+{
+ int n = 0;
+
+ while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
+ lst = C_u_i_cdr(lst);
+ ++n;
+ }
+
+ return C_fix(n);
+}
+
+
+C_regparm C_word C_fcall C_i_inexact_to_exact(C_word n)
+{
+ double m;
+ C_word r;
+
+ if(n & C_FIXNUM_BIT) return n;
+ else if(C_immediatep(n) || C_block_header(n) != C_FLONUM_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "inexact->exact", n);
+
+ if(modf(C_flonum_magnitude(n), &m) == 0.0) {
+ r = (C_word)m;
+
+ if(r == m && C_fitsinfixnump(r))
+ return C_fix(r);
+ }
+
+ barf(C_CANT_REPRESENT_INEXACT_ERROR, "inexact->exact", n);
+ return 0;
+}
+
+
+C_regparm C_word C_fcall C_i_set_car(C_word x, C_word val)
+{
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-car!", x);
+
+ C_mutate(&C_u_i_car(x), val);
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_set_cdr(C_word x, C_word val)
+{
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-cdr!", x);
+
+ C_mutate(&C_u_i_cdr(x), val);
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_vector_set(C_word v, C_word i, C_word x)
+{
+ int j;
+
+ if(C_immediatep(v) || C_header_bits(v) != C_VECTOR_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", v);
+
+ if(i & C_FIXNUM_BIT) {
+ j = C_unfix(i);
+
+ if(j < 0 || j >= C_header_size(v)) barf(C_OUT_OF_RANGE_ERROR, "vector-set!", v, i);
+
+ C_mutate(&C_block_item(v, j), x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "vector-set!", i);
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_a_i_abs(C_word **a, int c, C_word x)
+{
+ if(x & C_FIXNUM_BIT) return C_fix(labs(C_unfix(x)));
+
+ if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "abs", x);
+
+ return C_flonum(a, fabs(C_flonum_magnitude(x)));
+}
+
+
+C_regparm C_word C_fcall C_a_i_flonum_plus(C_word **a, int c, C_word n1, C_word n2)
+{
+ return C_flonum(a, C_flonum_magnitude(n1) + C_flonum_magnitude(n2));
+}
+
+
+C_regparm C_word C_fcall C_a_i_flonum_difference(C_word **a, int c, C_word n1, C_word n2)
+{
+ return C_flonum(a, C_flonum_magnitude(n1) - C_flonum_magnitude(n2));
+}
+
+
+C_regparm C_word C_fcall C_a_i_flonum_times(C_word **a, int c, C_word n1, C_word n2)
+{
+ return C_flonum(a, C_flonum_magnitude(n1) * C_flonum_magnitude(n2));
+}
+
+
+C_regparm C_word C_fcall C_a_i_flonum_quotient(C_word **a, int c, C_word n1, C_word n2)
+{
+ return C_flonum(a, C_flonum_magnitude(n1) / C_flonum_magnitude(n2));
+}
+
+
+C_regparm C_word C_fcall C_a_i_flonum_negate(C_word **a, int c, C_word n)
+{
+ return C_flonum(a, -C_flonum_magnitude(n));
+}
+
+
+C_regparm C_word C_fcall C_a_i_bitwise_and(C_word **a, int c, C_word n1, C_word n2)
+{
+ double f1, f2;
+ C_uword nn1, nn2;
+
+ C_check_uint(n1, f1, nn1, "bitwise-and");
+ C_check_uint(n2, f2, nn2, "bitwise-and");
+ nn1 = C_limit_fixnum(nn1 & nn2);
+
+ if(C_ufitsinfixnump(nn1)) return C_fix(nn1);
+ else return C_flonum(a, nn1);
+}
+
+
+C_regparm C_word C_fcall C_a_i_bitwise_ior(C_word **a, int c, C_word n1, C_word n2)
+{
+ double f1, f2;
+ C_uword nn1, nn2;
+
+ C_check_uint(n1, f1, nn1, "bitwise-ior");
+ C_check_uint(n2, f2, nn2, "bitwise-ior");
+ nn1 = C_limit_fixnum(nn1 | nn2);
+
+ if(C_ufitsinfixnump(nn1)) return C_fix(nn1);
+ else return C_flonum(a, nn1);
+}
+
+
+C_regparm C_word C_fcall C_a_i_bitwise_xor(C_word **a, int c, C_word n1, C_word n2)
+{
+ double f1, f2;
+ C_uword nn1, nn2;
+
+ C_check_uint(n1, f1, nn1, "bitwise-xor");
+ C_check_uint(n2, f2, nn2, "bitwise-xor");
+ nn1 = C_limit_fixnum(nn1 ^ nn2);
+
+ if(C_ufitsinfixnump(nn1)) return C_fix(nn1);
+ else return C_flonum(a, nn1);
+}
+
+
+C_regparm C_word C_fcall C_i_bit_setp(C_word n, C_word i)
+{
+ double f1;
+ C_uword nn1;
+ int index;
+
+ if((i & C_FIXNUM_BIT) == 0)
+ barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "bit-set?", i);
+
+ index = C_unfix(i);
+
+ if(index < 0 || index >= C_WORD_SIZE)
+ barf(C_OUT_OF_RANGE_ERROR, "bit-set?", n, i);
+
+ C_check_uint(n, f1, nn1, "bit-set?");
+ return C_mk_bool((nn1 & (1 << index)) != 0);
+}
+
+
+C_regparm C_word C_fcall C_a_i_bitwise_not(C_word **a, int c, C_word n)
+{
+ double f;
+ C_uword nn;
+
+ C_check_uint(n, f, nn, "bitwise-not");
+ nn = C_limit_fixnum(~nn);
+
+ if(C_ufitsinfixnump(nn)) return C_fix(nn);
+ else return C_flonum(a, nn);
+}
+
+
+C_regparm C_word C_fcall C_a_i_arithmetic_shift(C_word **a, int c, C_word n1, C_word n2)
+{
+ C_word nn;
+ C_uword unn;
+ C_word s;
+ int sgn = 1;
+
+ if((n1 & C_FIXNUM_BIT) != 0) {
+ nn = C_unfix(n1);
+
+ if((sgn = nn < 0 ? -1 : 1) >= 0) unn = nn;
+ }
+ else if(C_immediatep(n1) || C_block_header(n1) != C_FLONUM_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "arithmetic-shift", n1);
+ else {
+ double m, f;
+
+ f = C_flonum_magnitude(n1);
+
+ if(modf(f, &m) != 0.0)
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "arithmetic-shift", n1);
+
+ if(f < C_WORD_MIN || f > C_UWORD_MAX)
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "arithmetic-shift", n1);
+ else if(f < 0) {
+ if(f > C_WORD_MAX)
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, "arithmetic-shift", n1);
+ else {
+ sgn = -1;
+ nn = (C_word)f;
+ }
+ }
+ else if(f > C_WORD_MAX) unn = (C_uword)f;
+ else {
+ nn = (C_word)f;
+ sgn = -1;
+ }
+ }
+
+ if((n2 & C_FIXNUM_BIT) != 0) s = C_unfix(n2);
+ else barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, "arithmetic-shift", n2);
+
+ if(sgn < 0) {
+ if(s < 0) nn >>= -s;
+ else nn <<= s;
+
+ if(C_fitsinfixnump(nn)) return C_fix(nn);
+ else return C_flonum(a, nn);
+ }
+ else {
+ if(s < 0) unn >>= -s;
+ else unn <<= s;
+
+ if(C_ufitsinfixnump(unn)) return C_fix(unn);
+ else return C_flonum(a, unn);
+ }
+}
+
+
+C_regparm C_word C_fcall C_a_i_exp(C_word **a, int c, C_word n)
+{
+ double f;
+
+ C_check_real(n, "exp", f);
+ return C_flonum(a, exp(f));
+}
+
+
+C_regparm C_word C_fcall C_a_i_log(C_word **a, int c, C_word n)
+{
+ double f;
+
+ C_check_real(n, "log", f);
+ return C_flonum(a, log(f));
+}
+
+
+C_regparm C_word C_fcall C_a_i_sin(C_word **a, int c, C_word n)
+{
+ double f;
+
+ C_check_real(n, "sin", f);
+ return C_flonum(a, sin(f));
+}
+
+
+C_regparm C_word C_fcall C_a_i_cos(C_word **a, int c, C_word n)
+{
+ double f;
+
+ C_check_real(n, "cos", f);
+ return C_flonum(a, cos(f));
+}
+
+
+C_regparm C_word C_fcall C_a_i_tan(C_word **a, int c, C_word n)
+{
+ double f;
+
+ C_check_real(n, "tan", f);
+ return C_flonum(a, tan(f));
+}
+
+
+C_regparm C_word C_fcall C_a_i_asin(C_word **a, int c, C_word n)
+{
+ double f;
+
+ C_check_real(n, "asin", f);
+ return C_flonum(a, asin(f));
+}
+
+
+C_regparm C_word C_fcall C_a_i_acos(C_word **a, int c, C_word n)
+{
+ double f;
+
+ C_check_real(n, "acos", f);
+ return C_flonum(a, acos(f));
+}
+
+
+C_regparm C_word C_fcall C_a_i_atan(C_word **a, int c, C_word n)
+{
+ double f;
+
+ C_check_real(n, "atan", f);
+ return C_flonum(a, atan(f));
+}
+
+
+C_regparm C_word C_fcall C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2)
+{
+ double f1, f2;
+
+ C_check_real(n1, "atan", f1);
+ C_check_real(n2, "atan", f2);
+ return C_flonum(a, atan2(f1, f2));
+}
+
+
+C_regparm C_word C_fcall C_a_i_sqrt(C_word **a, int c, C_word n)
+{
+ double f;
+
+ C_check_real(n, "sqrt", f);
+ return C_flonum(a, sqrt(f));
+}
+
+
+C_regparm C_word C_fcall C_i_fixnum_arithmetic_shift(C_word n, C_word c)
+{
+ if(C_unfix(c) < 0) return C_fixnum_shift_right(n, C_u_fixnum_negate(c));
+ else return C_fixnum_shift_left(n, c);
+}
+
+
+C_regparm C_word C_fcall C_i_assq(C_word x, C_word lst)
+{
+ C_word a;
+
+ while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
+ a = C_u_i_car(lst);
+
+ if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) {
+ if(C_u_i_car(a) == x) return a;
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assq", a);
+
+ lst = C_u_i_cdr(lst);
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
+C_regparm C_word C_fcall C_u_i_assq(C_word x, C_word lst)
+{
+ C_word a;
+
+ while(!C_immediatep(lst)) {
+ a = C_u_i_car(lst);
+
+ if(C_u_i_car(a) == x) return a;
+ else lst = C_u_i_cdr(lst);
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
+C_regparm C_word C_fcall C_i_assv(C_word x, C_word lst)
+{
+ C_word a;
+
+ while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
+ a = C_u_i_car(lst);
+
+ if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) {
+ if(C_truep(C_i_eqvp(C_u_i_car(a), x))) return a;
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assv", a);
+
+ lst = C_u_i_cdr(lst);
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
+C_regparm C_word C_fcall C_i_assoc(C_word x, C_word lst)
+{
+ C_word a;
+
+ while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
+ a = C_u_i_car(lst);
+
+ if(!C_immediatep(a) && C_block_header(a) == C_PAIR_TAG) {
+ if(C_equalp(C_u_i_car(a), x)) return a;
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assoc", a);
+
+ lst = C_u_i_cdr(lst);
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
+C_regparm C_word C_fcall C_i_memq(C_word x, C_word lst)
+{
+ while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
+ if(C_u_i_car(lst) == x) return lst;
+ else lst = C_u_i_cdr(lst);
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
+C_regparm C_word C_fcall C_u_i_memq(C_word x, C_word lst)
+{
+ while(!C_immediatep(lst)) {
+ if(C_u_i_car(lst) == x) return lst;
+ else lst = C_u_i_cdr(lst);
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
+C_regparm C_word C_fcall C_i_memv(C_word x, C_word lst)
+{
+ while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
+ if(C_truep(C_i_eqvp(C_u_i_car(lst), x))) return lst;
+ else lst = C_u_i_cdr(lst);
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
+C_regparm C_word C_fcall C_i_member(C_word x, C_word lst)
+{
+ while(!C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG) {
+ if(C_equalp(C_u_i_car(lst), x)) return lst;
+ else lst = C_u_i_cdr(lst);
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
+/* Inline routines for extended bindings: */
+
+C_regparm C_word C_fcall C_i_check_closure_2(C_word x, C_word loc)
+{
+ if(C_immediatep(x) || (C_header_bits(x) != C_CLOSURE_TYPE)) {
+ error_location = loc;
+ barf(C_BAD_ARGUMENT_TYPE_NO_CLOSURE_ERROR, NULL, x);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_check_exact_2(C_word x, C_word loc)
+{
+ if((x & C_FIXNUM_BIT) == 0) {
+ error_location = loc;
+ barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_check_inexact_2(C_word x, C_word loc)
+{
+ if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG) {
+ error_location = loc;
+ barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, NULL, x);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_check_char_2(C_word x, C_word loc)
+{
+ if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS) {
+ error_location = loc;
+ barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_check_number_2(C_word x, C_word loc)
+{
+ if((x & C_FIXNUM_BIT) == 0 && (C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)) {
+ error_location = loc;
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, NULL, x);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_check_string_2(C_word x, C_word loc)
+{
+ if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE) {
+ error_location = loc;
+ barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_check_bytevector_2(C_word x, C_word loc)
+{
+ if(C_immediatep(x) || C_header_bits(x) != C_BYTEVECTOR_TYPE) {
+ error_location = loc;
+ barf(C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR, NULL, x);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_check_vector_2(C_word x, C_word loc)
+{
+ if(C_immediatep(x) || C_header_bits(x) != C_VECTOR_TYPE) {
+ error_location = loc;
+ barf(C_BAD_ARGUMENT_TYPE_NO_VECTOR_ERROR, NULL, x);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_check_structure_2(C_word x, C_word st, C_word loc)
+{
+ if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_u_i_car(x) != st) {
+ error_location = loc;
+ barf(C_BAD_ARGUMENT_TYPE_BAD_STRUCT_ERROR, NULL, x, st);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_check_pair_2(C_word x, C_word loc)
+{
+ if(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG) {
+ error_location = loc;
+ barf(C_BAD_ARGUMENT_TYPE_NO_PAIR_ERROR, NULL, x);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_check_symbol_2(C_word x, C_word loc)
+{
+ if(C_immediatep(x) || C_block_header(x) != C_SYMBOL_TAG) {
+ error_location = loc;
+ barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_check_list_2(C_word x, C_word loc)
+{
+ if(x != C_SCHEME_END_OF_LIST && (C_immediatep(x) || C_block_header(x) != C_PAIR_TAG)) {
+ error_location = loc;
+ barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, NULL, x);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_foreign_char_argumentp(C_word x)
+{
+ if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)
+ barf(C_BAD_ARGUMENT_TYPE_NO_CHAR_ERROR, NULL, x);
+
+ return x;
+}
+
+
+C_regparm C_word C_fcall C_i_foreign_fixnum_argumentp(C_word x)
+{
+ if((x & C_FIXNUM_BIT) == 0)
+ barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);
+
+ return x;
+}
+
+
+C_regparm C_word C_fcall C_i_foreign_flonum_argumentp(C_word x)
+{
+ if((x & C_FIXNUM_BIT) != 0) return x;
+
+ if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR, NULL, x);
+
+ return x;
+}
+
+
+C_regparm C_word C_fcall C_i_foreign_block_argumentp(C_word x)
+{
+ if(C_immediatep(x))
+ barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, NULL, x);
+
+ return x;
+}
+
+
+C_regparm C_word C_fcall C_i_foreign_number_vector_argumentp(C_word t, C_word x)
+{
+ if(C_immediatep(x) || C_header_bits(x) != C_STRUCTURE_TYPE || C_block_item(x, 0) != t)
+ barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_VECTOR_ERROR, NULL, x, t);
+
+ return x;
+}
+
+
+C_regparm C_word C_fcall C_i_foreign_string_argumentp(C_word x)
+{
+ if(C_immediatep(x) || C_header_bits(x) != C_STRING_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, NULL, x);
+
+ return x;
+}
+
+
+C_regparm C_word C_fcall C_i_foreign_symbol_argumentp(C_word x)
+{
+ if(C_immediatep(x) || C_header_bits(x) != C_SYMBOL_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_NO_SYMBOL_ERROR, NULL, x);
+
+ return x;
+}
+
+
+C_regparm C_word C_fcall C_i_foreign_pointer_argumentp(C_word x)
+{
+ if(C_immediatep(x) ||
+ (C_header_bits(x) != C_SWIG_POINTER_TYPE &&
+ (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0) )
+ barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);
+
+ return x;
+}
+
+
+C_regparm C_word C_fcall C_i_foreign_scheme_or_c_pointer_argumentp(C_word x)
+{
+ if(C_immediatep(x) ||
+ (C_header_bits(x) != C_SWIG_POINTER_TYPE &&
+ (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0) )
+ barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);
+
+ return x;
+}
+
+
+C_regparm C_word C_fcall C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t)
+{
+ if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0
+ || (t != C_SCHEME_FALSE && !C_equalp(C_block_item(x, 1), t)))
+ barf(C_BAD_ARGUMENT_TYPE_NO_TAGGED_POINTER_ERROR, NULL, x, t);
+
+ return x;
+}
+
+
+C_regparm C_word C_fcall C_i_foreign_integer_argumentp(C_word x)
+{
+ double m;
+
+ if((x & C_FIXNUM_BIT) != 0) return x;
+
+ if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ m = C_flonum_magnitude(x);
+
+ if(m >= C_WORD_MIN && m <= C_WORD_MAX) return x;
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, NULL, x);
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_foreign_unsigned_integer_argumentp(C_word x)
+{
+ double m;
+
+ if((x & C_FIXNUM_BIT) != 0) return x;
+
+ if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ m = C_flonum_magnitude(x);
+
+ if(m >= 0 && m <= C_UWORD_MAX) return x;
+ }
+
+ barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_not_pair_p_2(C_word x)
+{
+ return C_mk_bool(C_immediatep(x) || C_block_header(x) != C_PAIR_TAG);
+}
+
+
+C_regparm C_word C_fcall C_i_null_list_p(C_word x)
+{
+ if(x == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;
+ else if(!C_immediatep(x) && C_block_header(x) == C_PAIR_TAG) return C_SCHEME_FALSE;
+ else {
+ barf(C_BAD_ARGUMENT_TYPE_NO_LIST_ERROR, "null-list?", x);
+ return C_SCHEME_FALSE;
+ }
+}
+
+
+C_regparm C_word C_fcall C_i_string_null_p(C_word x)
+{
+ if(!C_immediatep(x) && C_header_bits(x) == C_STRING_TYPE)
+ return C_zero_length_p(x);
+ else {
+ barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, "string-null?", x);
+ return C_SCHEME_FALSE;
+ }
+}
+
+
+C_regparm C_word C_fcall C_i_null_pointerp(C_word x)
+{
+ if(!C_immediatep(x) && (C_header_bits(x) & C_SPECIALBLOCK_BIT) != 0)
+ return C_null_pointerp(x);
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "null-pointer?", x);
+ return C_SCHEME_FALSE;
+}
+
+
+/* Primitives: */
+
+void C_ccall C_apply(C_word c, C_word closure, C_word k, C_word fn, ...)
+{
+ va_list v;
+ int i, n = c - 3;
+ C_word x, skip, fn2;
+#ifdef C_HACKED_APPLY
+ C_word *buf = C_temporary_stack_limit;
+ void *proc;
+#endif
+
+#ifndef C_UNSAFE_RUNTIME
+ if(c < 4) C_bad_min_argc(c, 4);
+#endif
+
+ fn2 = resolve_procedure(fn, "apply");
+
+ va_start(v, fn);
+
+ for(i = n; i > 1; --i) {
+ x = va_arg(v, C_word);
+#ifdef C_HACKED_APPLY
+ *(buf++) = x;
+#else
+ C_save(x);
+#endif
+ }
+
+ x = va_arg(v, C_word);
+
+#ifndef C_UNSAFE_RUNTIME
+ if(x != C_SCHEME_END_OF_LIST && (C_immediatep(x) || C_block_header(x) != C_PAIR_TAG))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", x);
+#endif
+
+ for(skip = x; !C_immediatep(skip) && C_block_header(skip) == C_PAIR_TAG; skip = C_u_i_cdr(skip)) {
+ x = C_u_i_car(skip);
+
+#ifdef C_HACKED_APPLY
+# ifndef C_UNSAFE_RUNTIME
+ if(buf >= C_temporary_stack_bottom) barf(C_TOO_MANY_PARAMETERS_ERROR, "apply");
+# endif
+
+ *(buf++) = x;
+#else
+ C_save(x);
+
+# ifndef C_UNSAFE_RUNTIME
+ if(C_temporary_stack < C_temporary_stack_limit)
+ barf(C_TOO_MANY_PARAMETERS_ERROR, "apply");
+# endif
+#endif
+ ++n;
+ }
+
+ va_end(v);
+ --n;
+
+#ifdef C_HACKED_APPLY
+ /* 3 additional args + 1 slot for stack-pointer + two for stack-alignment to 16 bytes */
+ buf = alloca((n + 6) * sizeof(C_word));
+# ifdef __x86_64__
+ buf = (void *)C_align16((C_uword)buf);
+# endif
+ buf[ 0 ] = n + 2;
+ buf[ 1 ] = fn2;
+ buf[ 2 ] = k;
+ C_memcpy(&buf[ 3 ], C_temporary_stack_limit, n * sizeof(C_word));
+ proc = (void *)C_block_item(fn2, 0);
+# ifdef _MSC_VER
+ __asm {
+ mov eax, proc
+ mov esp, buf
+ call eax
+ }
+# elif defined(__GNUC__)
+ C_do_apply_hack(proc, buf, n + 3);
+# endif
+#endif
+
+ C_do_apply(n, fn2, k);
+}
+
+
+void C_ccall C_do_apply(C_word n, C_word fn, C_word k)
+{
+ void *pr = (void *)C_block_item(fn, 0);
+ C_word *ptr = C_temporary_stack = C_temporary_stack_bottom;
+
+/* PTR_O_p<P>_<B>(o): list of COUNT = ((2 ** P) * B) '*(ptr-I)' arguments,
+ * with offset I in range [o, o+COUNT-1].
+ */
+#define PTR_O_p0_0(o)
+#define PTR_O_p1_0(o)
+#define PTR_O_p2_0(o)
+#define PTR_O_p3_0(o)
+#define PTR_O_p4_0(o)
+#define PTR_O_p5_0(o)
+#define PTR_O_p6_0(o)
+#define PTR_O_p7_0(o)
+#define PTR_O_p0_1(o) , *(ptr-(o))
+#define PTR_O_p1_1(o) , *(ptr-(o)), *(ptr-(o+1))
+#define PTR_O_p2_1(o) PTR_O_p1_1(o) PTR_O_p1_1(o+2)
+#define PTR_O_p3_1(o) PTR_O_p2_1(o) PTR_O_p2_1(o+4)
+#define PTR_O_p4_1(o) PTR_O_p3_1(o) PTR_O_p3_1(o+8)
+#define PTR_O_p5_1(o) PTR_O_p4_1(o) PTR_O_p4_1(o+16)
+#define PTR_O_p6_1(o) PTR_O_p5_1(o) PTR_O_p5_1(o+32)
+#define PTR_O_p7_1(o) PTR_O_p6_1(o) PTR_O_p6_1(o+64)
+
+/* CASE_C_PROC_p0 (n0, p6,p5,p4,p3,p2,p1,p0):
+ * let's note <N> = <n0> - 2; the macro inserts:
+ * case <N>: ((C_cproc<n0>)pr) (<n0>, fn, k, <rest>);
+ * where <rest> is: *(ptr-1), ..., *(ptr-<N>)
+ * (<rest> is empty for <n0> == 2).
+ * We must have: n0 = SUM (i = 7 to 0, p<i> * (1 << i)).
+ * CASE_C_PROC_p<N+1> (...):
+ * like CASE_C_PROC_p<N>, but with doubled output...
+ */
+#define CASE_C_PROC_p0(n0, p6,p5,p4,p3,p2,p1,p0) \
+ case (n0-2): ((C_proc##n0)pr)(n0, fn, k \
+PTR_O_p6_##p6(((n0-2)&0x80)+1)\
+PTR_O_p5_##p5(((n0-2)&0xC0)+1)\
+PTR_O_p4_##p4(((n0-2)&0xE0)+1)\
+PTR_O_p3_##p3(((n0-2)&0xF0)+1)\
+PTR_O_p2_##p2(((n0-2)&0xF8)+1)\
+PTR_O_p1_##p1(((n0-2)&0xFC)+1)\
+PTR_O_p0_##p0(((n0-2)&0xFE)+1));
+#define CASE_C_PROC_p1( n0,n1, p6,p5,p4,p3,p2,p1) \
+ CASE_C_PROC_p0 (n0, p6,p5,p4,p3,p2,p1,0) \
+ CASE_C_PROC_p0 (n1, p6,p5,p4,p3,p2,p1,1)
+#define CASE_C_PROC_p2( n0,n1,n2,n3, p6,p5,p4,p3,p2) \
+ CASE_C_PROC_p1 (n0,n1, p6,p5,p4,p3,p2,0) \
+ CASE_C_PROC_p1 (n2,n3, p6,p5,p4,p3,p2,1)
+#define CASE_C_PROC_p3( n0,n1,n2,n3,n4,n5,n6,n7, p6,p5,p4,p3) \
+ CASE_C_PROC_p2 (n0,n1,n2,n3, p6,p5,p4,p3,0) \
+ CASE_C_PROC_p2 (n4,n5,n6,n7, p6,p5,p4,p3,1)
+
+ switch(n) {
+ CASE_C_PROC_p3 (2,3,4,5,6,7,8,9, 0,0,0,0)
+ CASE_C_PROC_p3 (10,11,12,13,14,15,16,17, 0,0,0,1)
+ CASE_C_PROC_p3 (18,19,20,21,22,23,24,25, 0,0,1,0)
+ CASE_C_PROC_p3 (26,27,28,29,30,31,32,33, 0,0,1,1)
+ CASE_C_PROC_p3 (34,35,36,37,38,39,40,41, 0,1,0,0)
+ CASE_C_PROC_p3 (42,43,44,45,46,47,48,49, 0,1,0,1)
+ CASE_C_PROC_p3 (50,51,52,53,54,55,56,57, 0,1,1,0)
+ CASE_C_PROC_p3 (58,59,60,61,62,63,64,65, 0,1,1,1)
+ CASE_C_PROC_p0 (66, 1,0,0,0,0,0,0)
+ CASE_C_PROC_p0 (67, 1,0,0,0,0,0,1)
+ CASE_C_PROC_p1 (68,69, 1,0,0,0,0,1)
+ CASE_C_PROC_p2 (70,71,72,73, 1,0,0,0,1)
+ CASE_C_PROC_p3 (74,75,76,77,78,79,80,81, 1,0,0,1)
+ CASE_C_PROC_p3 (82,83,84,85,86,87,88,89, 1,0,1,0)
+ CASE_C_PROC_p3 (90,91,92,93,94,95,96,97, 1,0,1,1)
+ CASE_C_PROC_p3 (98,99,100,101,102,103,104,105, 1,1,0,0)
+ CASE_C_PROC_p3 (106,107,108,109,110,111,112,113, 1,1,0,1)
+ CASE_C_PROC_p3 (114,115,116,117,118,119,120,121, 1,1,1,0)
+ CASE_C_PROC_p2 (122,123,124,125, 1,1,1,1,0)
+ CASE_C_PROC_p1 (126,127, 1,1,1,1,1,0)
+ CASE_C_PROC_p0 (128, 1,1,1,1,1,1,0)
+ default: barf(C_TOO_MANY_PARAMETERS_ERROR, "apply");
+ }
+}
+
+
+void C_ccall C_call_cc(C_word c, C_word closure, C_word k, C_word cont)
+{
+ C_word *a = C_alloc(3),
+ wrapper;
+ void *pr = (void *)C_u_i_car(cont);
+
+ if(C_immediatep(cont) || C_header_bits(cont) != C_CLOSURE_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-current-continuation", cont);
+
+ /* Check for values-continuation: */
+ if(C_u_i_car(k) == (C_word)values_continuation)
+ wrapper = C_closure(&a, 2, (C_word)call_cc_values_wrapper, k);
+ else wrapper = C_closure(&a, 2, (C_word)call_cc_wrapper, k);
+
+ ((C_proc3)pr)(3, cont, k, wrapper);
+}
+
+
+void C_ccall call_cc_wrapper(C_word c, C_word closure, C_word k, C_word result)
+{
+ C_word cont = C_u_i_cdr(closure);
+
+ if(c != 3) C_bad_argc(c, 3);
+
+ C_kontinue(cont, result);
+}
+
+
+void C_ccall call_cc_values_wrapper(C_word c, C_word closure, C_word k, ...)
+{
+ va_list v;
+ C_word cont = C_u_i_cdr(closure),
+ x1;
+ int n = c;
+
+ va_start(v, k);
+
+ if(c > 2) {
+ x1 = va_arg(v, C_word);
+ --n;
+
+ while(--c > 2) C_save(va_arg(v, C_word));
+ }
+ else x1 = C_SCHEME_UNBOUND;
+
+ va_end(v);
+ C_do_apply(n - 2, cont, x1);
+}
+
+
+void C_ccall C_continuation_graft(C_word c, C_word self, C_word k, C_word kk, C_word proc)
+{
+ ((C_proc2)C_retrieve_proc(proc))(2, proc, C_block_item(kk, 1));
+}
+
+
+void C_ccall C_values(C_word c, C_word closure, C_word k, ...)
+{
+ va_list v;
+ C_word n = c;
+
+ if(c < 2) C_bad_min_argc(c, 2);
+
+ va_start(v, k);
+
+ /* Check continuation whether it receives multiple values: */
+ if(C_block_item(k, 0) == (C_word)values_continuation) {
+ while(c-- > 2)
+ C_save(va_arg(v, C_word));
+
+ va_end(v);
+ C_do_apply(n - 2, k, C_SCHEME_UNBOUND); /* unbound value marks direct invocation */
+ }
+
+ if(c != 3) {
+#ifdef RELAX_MULTIVAL_CHECK
+ if(c == 2) n = C_SCHEME_UNDEFINED;
+ else n = va_arg(v, C_word);
+#else
+ barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);
+#endif
+ }
+ else n = va_arg(v, C_word);
+
+ va_end(v);
+ C_kontinue(k, n);
+}
+
+
+void C_ccall C_apply_values(C_word c, C_word closure, C_word k, C_word lst)
+{
+ C_word n;
+
+#ifndef C_UNSAFE_RUNTIME
+ if(c != 3) C_bad_argc(c, 3);
+#endif
+
+ /* Check continuation wether it receives multiple values: */
+ if(C_block_item(k, 0) == (C_word)values_continuation) {
+ for(n = 0; !C_immediatep(lst) && C_block_header(lst) == C_PAIR_TAG; ++n) {
+ C_save(C_u_i_car(lst));
+ lst = C_u_i_cdr(lst);
+ }
+
+ C_do_apply(n, k, C_SCHEME_UNBOUND); /* unbound value marks direct invocation */
+ }
+
+ if(C_immediatep(lst) || (C_block_header(lst) == C_PAIR_TAG && C_u_i_cdr(lst) == C_SCHEME_END_OF_LIST)) {
+#ifdef RELAX_MULTIVAL_CHECK
+ if(C_immediatep(lst)) n = C_SCHEME_UNDEFINED;
+ else n = C_u_i_car(lst);
+#else
+ barf(C_CONTINUATION_CANT_RECEIVE_VALUES_ERROR, "values", k);
+#endif
+ }
+ else n = C_u_i_car(lst);
+
+ C_kontinue(k, n);
+}
+
+
+void C_ccall C_call_with_values(C_word c, C_word closure, C_word k, C_word thunk, C_word kont)
+{
+ C_word *a = C_alloc(4),
+ kk;
+
+#ifndef C_UNSAFE_RUNTIME
+ if(c != 4) C_bad_argc(c, 4);
+
+ if(C_immediatep(thunk) || C_header_bits(thunk) != C_CLOSURE_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", thunk);
+
+ if(C_immediatep(kont) || C_header_bits(kont) != C_CLOSURE_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "call-with-values", kont);
+#endif
+
+ kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);
+ C_do_apply(0, thunk, kk);
+}
+
+
+void C_ccall C_u_call_with_values(C_word c, C_word closure, C_word k, C_word thunk, C_word kont)
+{
+ C_word *a = C_alloc(4),
+ kk;
+
+ kk = C_closure(&a, 3, (C_word)values_continuation, kont, k);
+ C_do_apply(0, thunk, kk);
+}
+
+
+void C_ccall values_continuation(C_word c, C_word closure, C_word arg0, ...)
+{
+ C_word kont = C_u_i_cdr(closure),
+ k = C_block_item(closure, 2),
+ n = c,
+ *ptr;
+ va_list v;
+
+ if(arg0 == C_SCHEME_UNBOUND) { /* This continuation was called by 'values'... */
+ va_start(v, arg0);
+
+ for(; c-- > 2; C_save(va_arg(v, C_word)));
+
+ va_end(v);
+ }
+ else { /* This continuation was captured and called explicity... */
+ ++n;
+ c -= 1;
+
+ /* move temporary-stack contents upwards one slot: */
+ for(ptr = C_temporary_stack - c; --c; ++ptr) *ptr = ptr[ 1 ];
+
+ C_save(arg0);
+ }
+
+ C_do_apply(n - 2, kont, k);
+}
+
+
+void C_ccall C_times(C_word c, C_word closure, C_word k, ...)
+{
+ va_list v;
+ C_word x;
+ C_word iresult = 1;
+ int fflag = 0;
+ double fresult = 1;
+
+ va_start(v, k);
+ c -= 2;
+
+ while(c--) {
+ x = va_arg(v, C_word);
+
+ if(x & C_FIXNUM_BIT) {
+ fresult *= C_unfix(x);
+
+ if(!fflag) iresult *= C_unfix(x);
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ fresult *= C_flonum_magnitude(x);
+
+ if(!fflag) fflag = 1;
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", x);
+ }
+
+ va_end(v);
+ x = C_fix(iresult);
+
+ if(fflag || (double)C_unfix(x) != fresult) {
+ C_temporary_flonum = fresult;
+ C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+ }
+
+ C_kontinue(k, x);
+}
+
+
+C_regparm C_word C_fcall C_2_times(C_word **ptr, C_word x, C_word y)
+{
+ C_word iresult;
+ double fresult;
+ int fflag = 0;
+
+ if(x & C_FIXNUM_BIT) {
+ if(y & C_FIXNUM_BIT) {
+ iresult = C_unfix(x) * C_unfix(y);
+ fresult = (double)C_unfix(x) * (double)C_unfix(y);
+ }
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG) {
+ fresult = C_unfix(x) * C_flonum_magnitude(y);
+ fflag = 1;
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", y);
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ fflag = 1;
+
+ if(y & C_FIXNUM_BIT) fresult = C_flonum_magnitude(x) * C_unfix(y);
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
+ fresult = C_flonum_magnitude(x) * C_flonum_magnitude(y);
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", y);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "*", x);
+
+ iresult = C_fix(iresult);
+
+ if(fflag || (double)C_unfix(iresult) != fresult) return C_flonum(ptr, fresult);
+
+ return iresult;
+}
+
+
+void C_ccall C_plus(C_word c, C_word closure, C_word k, ...)
+{
+ va_list v;
+ C_word x;
+ C_word iresult = 0;
+ int fflag = 0;
+ double fresult = 0;
+
+ va_start(v, k);
+ c -= 2;
+
+ while(c--) {
+ x = va_arg(v, C_word);
+
+ if(x & C_FIXNUM_BIT) {
+ fresult += C_unfix(x);
+
+ if(!fflag) iresult += C_unfix(x);
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ fresult += C_flonum_magnitude(x);
+
+ if(!fflag) fflag = 1;
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", x);
+ }
+
+ va_end(v);
+ x = C_fix(iresult);
+
+ if(fflag || (double)C_unfix(x) != fresult) {
+ C_temporary_flonum = fresult;
+ C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+ }
+
+ C_kontinue(k, x);
+}
+
+
+C_regparm C_word C_fcall C_2_plus(C_word **ptr, C_word x, C_word y)
+{
+ C_word iresult;
+ double fresult;
+ int fflag = 0;
+
+ if(x & C_FIXNUM_BIT) {
+ if(y & C_FIXNUM_BIT) {
+ iresult = C_unfix(x) + C_unfix(y);
+ fresult = (double)C_unfix(x) + (double)C_unfix(y);
+ }
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG) {
+ fresult = C_unfix(x) + C_flonum_magnitude(y);
+ fflag = 1;
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", y);
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ fflag = 1;
+
+ if(y & C_FIXNUM_BIT) fresult = C_flonum_magnitude(x) + C_unfix(y);
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
+ fresult = C_flonum_magnitude(x) + C_flonum_magnitude(y);
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", y);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "+", x);
+
+ iresult = C_fix(iresult);
+
+ if(fflag || (double)C_unfix(iresult) != fresult) return C_flonum(ptr, fresult);
+
+ return iresult;
+}
+
+
+void cons_flonum_trampoline(void *dummy)
+{
+ C_word k = C_restore,
+ *a = C_alloc(WORDS_PER_FLONUM);
+
+ C_kontinue(k, C_flonum(&a, C_temporary_flonum));
+}
+
+
+void C_ccall C_minus(C_word c, C_word closure, C_word k, C_word n1, ...)
+{
+ va_list v;
+ C_word iresult;
+ int fflag;
+ double fresult;
+
+ if(c < 3) C_bad_min_argc(c, 3);
+
+ if(n1 & C_FIXNUM_BIT) {
+ fresult = iresult = C_unfix(n1);
+ fflag = 0;
+ }
+ else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG) {
+ fresult = C_flonum_magnitude(n1);
+ fflag = 1;
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", n1);
+
+ if(c == 3) {
+ if(fflag) fresult = -fresult;
+ else fresult = iresult = -iresult;
+
+ goto cont;
+ }
+
+ va_start(v, n1);
+ c -= 3;
+
+ while(c--) {
+ n1 = va_arg(v, C_word);
+
+ if(n1 & C_FIXNUM_BIT) {
+ fresult -= C_unfix(n1);
+
+ if(!fflag) iresult -= C_unfix(n1);
+ }
+ else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG) {
+ fresult -= C_flonum_magnitude(n1);
+
+ if(!fflag) fflag = 1;
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", n1);
+ }
+
+ va_end(v);
+
+ cont:
+ n1 = C_fix(iresult);
+
+ if(fflag || (double)C_unfix(n1) != fresult) {
+ C_temporary_flonum = fresult;
+ C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+ }
+
+ C_kontinue(k, n1);
+}
+
+
+C_regparm C_word C_fcall C_2_minus(C_word **ptr, C_word x, C_word y)
+{
+ C_word iresult;
+ double fresult;
+ int fflag = 0;
+
+ if(x & C_FIXNUM_BIT) {
+ if(y & C_FIXNUM_BIT) {
+ iresult = C_unfix(x) - C_unfix(y);
+ fresult = (double)C_unfix(x) - (double)C_unfix(y);
+ }
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG) {
+ fresult = C_unfix(x) - C_flonum_magnitude(y);
+ fflag = 1;
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", y);
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ fflag = 1;
+
+ if(y & C_FIXNUM_BIT) fresult = C_flonum_magnitude(x) - C_unfix(y);
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
+ fresult = C_flonum_magnitude(x) - C_flonum_magnitude(y);
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", y);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "-", x);
+
+ iresult = C_fix(iresult);
+
+ if(fflag || (double)C_unfix(iresult) != fresult) return C_flonum(ptr, fresult);
+
+ return iresult;
+}
+
+
+void C_ccall C_divide(C_word c, C_word closure, C_word k, C_word n1, ...)
+{
+ va_list v;
+ C_word n2;
+ C_word iresult;
+ int fflag;
+ double fresult, f2;
+
+ if(c < 3) C_bad_min_argc(c, 3);
+
+ if(n1 & C_FIXNUM_BIT) {
+ iresult = C_unfix(n1);
+ fflag = 0;
+ }
+ else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG) {
+ fresult = C_flonum_magnitude(n1);
+ fflag = 1;
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "/", n1);
+
+ if(c == 3) {
+ if(fflag) {
+ if(fresult == 0) barf(C_DIVISION_BY_ZERO_ERROR, "/");
+
+ fresult = 1.0 / fresult;
+ }
+ else {
+ if(iresult == 0) barf(C_DIVISION_BY_ZERO_ERROR, "/");
+
+ fresult = 1.0 / (double)iresult;
+ fflag = 1;
+ }
+
+ goto cont;
+ }
+
+ va_start(v, n1);
+ c -= 3;
+
+ while(c--) {
+ n1 = va_arg(v, C_word);
+
+ if(n1 & C_FIXNUM_BIT) {
+ if(fflag) {
+ if((n1 = C_unfix(n1)) == 0)
+ barf(C_DIVISION_BY_ZERO_ERROR, "/");
+
+ fresult /= n1;
+ }
+ else {
+ if((n2 = C_unfix(n1)) == 0)
+ barf(C_DIVISION_BY_ZERO_ERROR, "/");
+
+ if((fresult = (double)iresult / (double)n2) != (iresult /= n2))
+ fflag = 1;
+ }
+ }
+ else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG) {
+ if(fflag) {
+ if((f2 = C_flonum_magnitude(n1)) == 0)
+ barf(C_DIVISION_BY_ZERO_ERROR, "/");
+
+ fresult /= f2;
+ }
+ else {
+ fflag = 1;
+
+ if((f2 = C_flonum_magnitude(n1)) == 0)
+ barf(C_DIVISION_BY_ZERO_ERROR, "/");
+
+ fresult = (double)iresult / f2;
+ }
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "/", n1);
+ }
+
+ va_end(v);
+
+ cont:
+ if(fflag) {
+ C_temporary_flonum = fresult;
+ C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+ }
+ else n1 = C_fix(iresult);
+
+ C_kontinue(k, n1);
+}
+
+
+C_regparm C_word C_fcall C_2_divide(C_word **ptr, C_word x, C_word y)
+{
+ C_word iresult;
+ double fresult;
+ int fflag = 0;
+
+ if(x & C_FIXNUM_BIT) {
+ if(y & C_FIXNUM_BIT) {
+ if((iresult = C_unfix(y)) == 0) barf(C_DIVISION_BY_ZERO_ERROR, "/");
+
+ fresult = (double)C_unfix(x) / (double)iresult;
+ iresult = C_unfix(x) / iresult;
+ }
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG) {
+ if((fresult = C_flonum_magnitude(y)) == 0.0)
+ barf(C_DIVISION_BY_ZERO_ERROR, "/");
+
+ fresult = (double)C_unfix(x) / fresult;
+ fflag = 1;
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "/", y);
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ fflag = 1;
+
+ if(y & C_FIXNUM_BIT) {
+ fresult = C_flonum_magnitude(x);
+
+ if((iresult = C_unfix(y)) == 0) barf(C_DIVISION_BY_ZERO_ERROR, "/");
+
+ fresult = fresult / (double)iresult;
+ }
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG) {
+ if((fresult = C_flonum_magnitude(y)) == 0.0) barf(C_DIVISION_BY_ZERO_ERROR, "/");
+
+ fresult = C_flonum_magnitude(x) / fresult;
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "/", y);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "/", x);
+
+ iresult = C_fix(iresult);
+
+ if(fflag || (double)C_unfix(iresult) != fresult) return C_flonum(ptr, fresult);
+
+ return iresult;
+}
+
+
+void C_ccall C_nequalp(C_word c, C_word closure, C_word k, ...)
+{
+ C_word x, i2, f, fflag, ilast;
+ double flast, f2;
+ va_list v;
+
+ c -= 2;
+ f = 1;
+ va_start(v, k);
+
+ if(c == 0) goto cont;
+
+ x = va_arg(v, C_word);
+
+ if(x & C_FIXNUM_BIT) {
+ fflag = 0;
+ ilast = C_unfix(x);
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ fflag = 1;
+ flast = C_flonum_magnitude(x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "=", x);
+
+ while(--c) {
+ x = va_arg(v, C_word);
+
+ if(x & C_FIXNUM_BIT) {
+ if(fflag) {
+ f = flast == (f2 = (double)C_unfix(x));
+ flast = f2;
+ }
+ else {
+ f = ilast == (i2 = C_unfix(x));
+ ilast = i2;
+ }
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ if(fflag) {
+ f = flast == (f2 = C_flonum_magnitude(x));
+ flast = f2;
+ }
+ else {
+ f = (double)ilast == (f2 = C_flonum_magnitude(x));
+ flast = f2;
+ fflag = 1;
+ }
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "=", x);
+
+ if(!f) break;
+ }
+
+ cont:
+ va_end(v);
+ C_kontinue(k, C_mk_bool(f));
+}
+
+
+C_regparm C_word C_fcall C_i_nequalp(C_word x, C_word y)
+{
+ if(x & C_FIXNUM_BIT) {
+ if(y & C_FIXNUM_BIT) return C_mk_bool(x == y);
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
+ return C_mk_bool((double)C_unfix(x) == C_flonum_magnitude(y));
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "=", y);
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ if(y & C_FIXNUM_BIT) return C_mk_bool(C_flonum_magnitude(x) == (double)C_unfix(y));
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
+ return C_mk_bool(C_flonum_magnitude(x) == C_flonum_magnitude(y));
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "=", y);
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
+void C_ccall C_greaterp(C_word c, C_word closure, C_word k, ...)
+{
+ C_word x, i2, f, fflag, ilast;
+ double flast, f2;
+ va_list v;
+
+ c -= 2;
+ f = 1;
+ va_start(v, k);
+
+ if(c == 0) goto cont;
+
+ x = va_arg(v, C_word);
+
+ if(x & C_FIXNUM_BIT) {
+ fflag = 0;
+ ilast = C_unfix(x);
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ fflag = 1;
+ flast = C_flonum_magnitude(x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, ">", x);
+
+ while(--c) {
+ x = va_arg(v, C_word);
+
+ if(x & C_FIXNUM_BIT) {
+ if(fflag) {
+ f = flast > (f2 = (double)C_unfix(x));
+ flast = f2;
+ }
+ else {
+ f = ilast > (i2 = C_unfix(x));
+ ilast = i2;
+ }
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ if(fflag) {
+ f = flast > (f2 = C_flonum_magnitude(x));
+ flast = f2;
+ }
+ else {
+ f = (double)ilast > (f2 = C_flonum_magnitude(x));
+ flast = f2;
+ fflag = 1;
+ }
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, ">", x);
+
+ if(!f) break;
+ }
+
+ cont:
+ va_end(v);
+ C_kontinue(k, C_mk_bool(f));
+}
+
+
+C_regparm C_word C_fcall C_i_greaterp(C_word x, C_word y)
+{
+ if(x & C_FIXNUM_BIT) {
+ if(y & C_FIXNUM_BIT) return C_mk_bool(x > y);
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
+ return C_mk_bool((double)C_unfix(x) > C_flonum_magnitude(y));
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, ">", y);
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ if(y & C_FIXNUM_BIT) return C_mk_bool(C_flonum_magnitude(x) > (double)C_unfix(y));
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
+ return C_mk_bool(C_flonum_magnitude(x) > C_flonum_magnitude(y));
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, ">", y);
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
+void C_ccall C_lessp(C_word c, C_word closure, C_word k, ...)
+{
+ C_word x, i2, f, fflag, ilast;
+ double flast, f2;
+ va_list v;
+
+ c -= 2;
+ f = 1;
+ va_start(v, k);
+
+ if(c == 0) goto cont;
+
+ x = va_arg(v, C_word);
+
+ if(x &C_FIXNUM_BIT) {
+ fflag = 0;
+ ilast = C_unfix(x);
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ fflag = 1;
+ flast = C_flonum_magnitude(x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "<", x);
+
+ while(--c) {
+ x = va_arg(v, C_word);
+
+ if(x &C_FIXNUM_BIT) {
+ if(fflag) {
+ f = flast < (f2 = (double)C_unfix(x));
+ flast = f2;
+ }
+ else {
+ f = ilast < (i2 = C_unfix(x));
+ ilast = i2;
+ }
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ if(fflag) {
+ f = flast < (f2 = C_flonum_magnitude(x));
+ flast = f2;
+ }
+ else {
+ f = (double)ilast < (f2 = C_flonum_magnitude(x));
+ flast = f2;
+ fflag = 1;
+ }
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "<", x);
+
+ if(!f) break;
+ }
+
+ cont:
+ va_end(v);
+ C_kontinue(k, C_mk_bool(f));
+}
+
+
+C_regparm C_word C_fcall C_i_lessp(C_word x, C_word y)
+{
+ if(x & C_FIXNUM_BIT) {
+ if(y & C_FIXNUM_BIT) return C_mk_bool(x < y);
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
+ return C_mk_bool((double)C_unfix(x) < C_flonum_magnitude(y));
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "<", y);
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ if(y & C_FIXNUM_BIT) return C_mk_bool(C_flonum_magnitude(x) < (double)C_unfix(y));
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
+ return C_mk_bool(C_flonum_magnitude(x) < C_flonum_magnitude(y));
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "<", y);
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
+void C_ccall C_greater_or_equal_p(C_word c, C_word closure, C_word k, ...)
+{
+ C_word x, i2, f, fflag, ilast;
+ double flast, f2;
+ va_list v;
+
+ c -= 2;
+ f = 1;
+ va_start(v, k);
+
+ if(c == 0) goto cont;
+
+ x = va_arg(v, C_word);
+
+ if(x &C_FIXNUM_BIT) {
+ fflag = 0;
+ ilast = C_unfix(x);
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ fflag = 1;
+ flast = C_flonum_magnitude(x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, ">=", x);
+
+ while(--c) {
+ x = va_arg(v, C_word);
+
+ if(x &C_FIXNUM_BIT) {
+ if(fflag) {
+ f = flast >= (f2 = (double)C_unfix(x));
+ flast = f2;
+ }
+ else {
+ f = ilast >= (i2 = C_unfix(x));
+ ilast = i2;
+ }
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ if(fflag) {
+ f = flast >= (f2 = C_flonum_magnitude(x));
+ flast = f2;
+ }
+ else {
+ f = (double)ilast >= (f2 = C_flonum_magnitude(x));
+ flast = f2;
+ fflag = 1;
+ }
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, ">=", x);
+
+ if(!f) break;
+ }
+
+ cont:
+ va_end(v);
+ C_kontinue(k, C_mk_bool(f));
+}
+
+
+C_regparm C_word C_fcall C_i_greater_or_equalp(C_word x, C_word y)
+{
+ if(x & C_FIXNUM_BIT) {
+ if(y & C_FIXNUM_BIT) return C_mk_bool(x >= y);
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
+ return C_mk_bool((double)C_unfix(x) >= C_flonum_magnitude(y));
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, ">=", y);
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ if(y & C_FIXNUM_BIT) return C_mk_bool(C_flonum_magnitude(x) >= (double)C_unfix(y));
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
+ return C_mk_bool(C_flonum_magnitude(x) >= C_flonum_magnitude(y));
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, ">=", y);
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
+void C_ccall C_less_or_equal_p(C_word c, C_word closure, C_word k, ...)
+{
+ C_word x, i2, f, fflag, ilast;
+ double flast, f2;
+ va_list v;
+
+ c -= 2;
+ f = 1;
+ va_start(v, k);
+
+ if(c == 0) goto cont;
+
+ x = va_arg(v, C_word);
+
+ if(x &C_FIXNUM_BIT) {
+ fflag = 0;
+ ilast = C_unfix(x);
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ fflag = 1;
+ flast = C_flonum_magnitude(x);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "<=", x);
+
+ while(--c) {
+ x = va_arg(v, C_word);
+
+ if(x &C_FIXNUM_BIT) {
+ if(fflag) {
+ f = flast <= (f2 = (double)C_unfix(x));
+ flast = f2;
+ }
+ else {
+ f = ilast <= (i2 = C_unfix(x));
+ ilast = i2;
+ }
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ if(fflag) {
+ f = flast <= (f2 = C_flonum_magnitude(x));
+ flast = f2;
+ }
+ else {
+ f = (double)ilast <= (f2 = C_flonum_magnitude(x));
+ flast = f2;
+ fflag = 1;
+ }
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "<=", x);
+
+ if(!f) break;
+ }
+
+ cont:
+ va_end(v);
+ C_kontinue(k, C_mk_bool(f));
+}
+
+
+C_regparm C_word C_fcall C_i_less_or_equalp(C_word x, C_word y)
+{
+ if(x & C_FIXNUM_BIT) {
+ if(y & C_FIXNUM_BIT) return C_mk_bool(x <= y);
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
+ return C_mk_bool((double)C_unfix(x) <= C_flonum_magnitude(y));
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "<=", y);
+ }
+ else if(!C_immediatep(x) && C_block_header(x) == C_FLONUM_TAG) {
+ if(y & C_FIXNUM_BIT) return C_mk_bool(C_flonum_magnitude(x) <= (double)C_unfix(y));
+ else if(!C_immediatep(y) && C_block_header(y) == C_FLONUM_TAG)
+ return C_mk_bool(C_flonum_magnitude(x) <= C_flonum_magnitude(y));
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "<=", y);
+ }
+
+ return C_SCHEME_FALSE;
+}
+
+
+void C_ccall C_expt(C_word c, C_word closure, C_word k, C_word n1, C_word n2)
+{
+ double m1, m2;
+ C_word r;
+
+ if(c != 4) C_bad_argc(c, 4);
+
+ if(n1 & C_FIXNUM_BIT) m1 = C_unfix(n1);
+ else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG)
+ m1 = C_flonum_magnitude(n1);
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "expt", n1);
+
+ if(n2 & C_FIXNUM_BIT) m2 = C_unfix(n2);
+ else if(!C_immediatep(n2) && C_block_header(n2) == C_FLONUM_TAG)
+ m2 = C_flonum_magnitude(n2);
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "expt", n2);
+
+ m1 = pow(m1, m2);
+ r = (C_word)m1;
+
+ if(r == m1 && (n1 & C_FIXNUM_BIT) && (n2 & C_FIXNUM_BIT) && modf(m1, &m2) == 0.0 && C_fitsinfixnump(r))
+ C_kontinue(k, C_fix(r));
+
+ C_temporary_flonum = m1;
+ C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+}
+
+
+void C_ccall C_gc(C_word c, C_word closure, C_word k, ...)
+{
+ int f;
+ C_word arg;
+ long size = 0;
+ va_list v;
+
+ va_start(v, k);
+
+ if(c == 3) {
+ arg = va_arg(v, C_word);
+ f = C_truep(arg);
+ }
+ else if(c != 2) C_bad_min_argc(c, 2);
+ else f = 1;
+
+ C_save(k);
+ va_end(v);
+
+ if(c == 3) {
+ if((arg & C_FIXNUM_BIT) != 0) size = C_unfix(arg);
+ else if(arg == C_SCHEME_END_OF_LIST) size = percentage(heap_size, C_heap_growth);
+ }
+
+ if(size && !C_heap_size_is_fixed) {
+ C_rereclaim2(size, 0);
+ gc_2(NULL);
+ }
+ else if(f) C_fromspace_top = C_fromspace_limit;
+
+ C_reclaim(gc_2, NULL);
+}
+
+
+void gc_2(void *dummy)
+{
+ C_word k = C_restore;
+
+ C_kontinue(k, C_fix((C_uword)C_fromspace_limit - (C_uword)C_fromspace_top));
+}
+
+
+void C_ccall C_open_file_port(C_word c, C_word closure, C_word k, C_word port, C_word channel, C_word mode)
+{
+ C_FILEPTR fp = (C_FILEPTR)NULL;
+ C_char fmode[ 4 ];
+ C_word n;
+ char *buf;
+
+ switch(channel) {
+ case C_fix(0): fp = C_stdin; break;
+ case C_fix(1): fp = C_stdout; break;
+ case C_fix(2): fp = C_stderr; break;
+ default:
+ n = C_header_size(channel);
+ buf = buffer;
+
+ if(n >= STRING_BUFFER_SIZE) {
+ if((buf = (char *)C_malloc(n + 1)) == NULL)
+ barf(C_OUT_OF_MEMORY_ERROR, "open");
+ }
+
+ C_strncpy(buf, C_c_string(channel), n);
+ buf[ n ] = '\0';
+ n = C_header_size(mode);
+ if (n >= sizeof(fmode)) n = sizeof(fmode) - 1;
+ C_strncpy(fmode, C_c_string(mode), n);
+ fmode[ n ] = '\0';
+ fp = C_fopen(buf, fmode);
+
+ if(buf != buffer) C_free(buf);
+ }
+
+ C_set_block_item(port, 0, (C_word)fp);
+ C_kontinue(k, C_mk_bool(fp != NULL));
+}
+
+
+void C_ccall C_allocate_vector(C_word c, C_word closure, C_word k, C_word size, C_word bvecf, C_word init, C_word align8)
+{
+ C_uword bytes, n = C_unfix(size);
+
+ if(c != 6) C_bad_argc(c, 6);
+
+ if(n > C_HEADER_SIZE_MASK)
+ barf(C_OUT_OF_RANGE_ERROR, NULL, size, C_fix(C_HEADER_SIZE_MASK));
+
+ if(!C_truep(bvecf)) bytes = C_wordstobytes(n) + sizeof(C_word);
+ else bytes = n + sizeof(C_word);
+
+ if(C_truep(align8)) bytes += sizeof(C_word);
+
+ C_save(k);
+ C_save(size);
+ C_save(init);
+ C_save(bvecf);
+ C_save(align8);
+ C_save(C_fix(bytes));
+
+ if(!C_demand(C_bytestowords(bytes))) {
+ /* Allocate on heap: */
+ if((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size * 2))
+ C_fromspace_top = C_fromspace_limit; /* trigger major GC */
+
+ C_save(C_SCHEME_TRUE);
+ C_reclaim(allocate_vector_2, NULL);
+ }
+
+ C_save(C_SCHEME_FALSE);
+ allocate_vector_2(NULL);
+}
+
+
+void allocate_vector_2(void *dummy)
+{
+ C_word mode = C_restore;
+ int bytes = C_unfix(C_restore);
+ C_word align8 = C_restore,
+ bvecf = C_restore,
+ init = C_restore;
+ C_word size = C_unfix(C_restore);
+ C_word k = C_restore,
+ *v0, v;
+
+ if(C_truep(mode)) {
+ while((C_uword)(C_fromspace_limit - C_fromspace_top) < (bytes + stack_size)) {
+ if(C_heap_size_is_fixed)
+ panic(C_text("out of memory - cannot allocate vector (heap resizing disabled)"));
+
+ C_save(init);
+ C_save(k);
+ C_rereclaim2(percentage(heap_size, C_heap_growth) + (C_uword)bytes, 0);
+ k = C_restore;
+ init = C_restore;
+ }
+
+ v0 = (C_word *)C_align((C_word)C_fromspace_top);
+ C_fromspace_top += C_align(bytes);
+ }
+ else v0 = C_alloc(C_bytestowords(bytes));
+
+#ifndef C_SIXTY_FOUR
+ if(C_truep(align8) && aligned8(v0)) ++v0;
+#endif
+
+ v = (C_word)v0;
+
+ if(!C_truep(bvecf)) {
+ *(v0++) = C_VECTOR_TYPE | size | (C_truep(align8) ? C_8ALIGN_BIT : 0);
+
+ while(size--) *(v0++) = init;
+ }
+ else {
+ *(v0++) = C_STRING_TYPE | size;
+
+ if(C_truep(init))
+ C_memset(v0, C_character_code(init), size);
+ }
+
+ C_kontinue(k, v);
+}
+
+
+void C_ccall C_string_to_symbol(C_word c, C_word closure, C_word k, C_word string)
+{
+ int len, key;
+ C_word s, *a = C_alloc(6); /* 6 <=> 1 bucket (pair) + 1 symbol */
+ C_char *name;
+
+ if(c != 3) C_bad_argc(c, 3);
+
+ if(C_immediatep(string) || C_header_bits(string) != C_STRING_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "string->symbol", string);
+
+ len = C_header_size(string);
+ name = (C_char *)C_data_pointer(string);
+ key = hash_string(len, name, symbol_table->size);
+
+ if(!C_truep(s = lookup(key, len, name, symbol_table)))
+ s = add_symbol(&a, key, string, symbol_table);
+
+ C_kontinue(k, s);
+}
+
+
+void C_ccall C_flonum_fraction(C_word c, C_word closure, C_word k, C_word n)
+{
+ double i, fn = C_flonum_magnitude(n);
+
+ C_temporary_flonum = modf(fn, &i);
+ C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+}
+
+
+void C_ccall C_exact_to_inexact(C_word c, C_word closure, C_word k, C_word n)
+{
+ if(c != 3) C_bad_argc(c, 3);
+
+ if(n & C_FIXNUM_BIT) {
+ C_temporary_flonum = (double)C_unfix(n);
+ C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+ }
+ else if(C_immediatep(n) || C_block_header(n) != C_FLONUM_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "exact->inexact", n);
+
+ C_kontinue(k, n);
+}
+
+
+void C_ccall C_flonum_floor(C_word c, C_word closure, C_word k, C_word n)
+{
+ C_temporary_flonum = floor(C_flonum_magnitude(n));
+ C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+}
+
+
+void C_ccall C_flonum_ceiling(C_word c, C_word closure, C_word k, C_word n)
+{
+ C_temporary_flonum = ceil(C_flonum_magnitude(n));
+ C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+}
+
+
+void C_ccall C_flonum_truncate(C_word c, C_word closure, C_word k, C_word n)
+{
+ modf(C_flonum_magnitude(n), &C_temporary_flonum);
+ C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+}
+
+
+void C_ccall C_flonum_round(C_word c, C_word closure, C_word k, C_word n)
+{
+ double fn, i, f, i2;
+
+ fn = C_flonum_magnitude(n);
+ if(fn < 0.0) {
+ f = modf(-fn, &i);
+ if(f < 0.5 || (f == 0.5 && modf(i * 0.5, &i2) == 0.0))
+ C_temporary_flonum = -i;
+ else
+ C_temporary_flonum = -(i + 1.0);
+ }
+ else if(fn == 0.0/* || fn == -0.0*/)
+ C_temporary_flonum = fn;
+ else {
+ f = modf(fn, &i);
+ if(f < 0.5 || (f == 0.5 && modf(i * 0.5, &i2) == 0.0))
+ C_temporary_flonum = i;
+ else
+ C_temporary_flonum = i + 1.0;
+ }
+
+ C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+}
+
+
+void C_ccall C_quotient(C_word c, C_word closure, C_word k, C_word n1, C_word n2)
+{
+ double f1, f2;
+ C_word result;
+
+ if(c != 4) C_bad_argc(c, 4);
+
+ if(n1 &C_FIXNUM_BIT) {
+ if(n2 &C_FIXNUM_BIT) {
+ if((n2 = C_unfix(n2)) == 0)
+ barf(C_DIVISION_BY_ZERO_ERROR, "quotient");
+
+ result = C_fix(C_unfix(n1) / n2);
+ C_kontinue(k, result);
+ }
+ else if(!C_immediatep(n2) && C_block_header(n2) == C_FLONUM_TAG) {
+ f1 = (double)C_unfix(n1);
+ f2 = C_flonum_magnitude(n2);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "quotient", n2);
+ }
+ else if(!C_immediatep(n1) && C_block_header(n1) == C_FLONUM_TAG) {
+ f1 = C_flonum_magnitude(n1);
+
+ if(n2 &C_FIXNUM_BIT)
+ f2 = (double)C_unfix(n2);
+ else if(!C_immediatep(n2) && C_block_header(n2) == C_FLONUM_TAG)
+ f2 = C_flonum_magnitude(n2);
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "quotient", n2);
+ }
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "quotient", n1);
+
+ if(f2 == 0)
+ barf(C_DIVISION_BY_ZERO_ERROR, "quotient");
+
+ modf(f1 / f2, &C_temporary_flonum);
+ C_cons_flonum(2, C_SCHEME_UNDEFINED, k);
+}
+
+
+void C_ccall C_cons_flonum(C_word c, C_word closure, C_word k)
+{
+ C_word *a = C_alloc(WORDS_PER_FLONUM);
+
+ C_kontinue(k, C_flonum(&a, C_temporary_flonum));
+}
+
+
+void C_ccall C_string_to_number(C_word c, C_word closure, C_word k, C_word str, ...)
+{
+ int radix, radixpf = 0, sharpf = 0, ratp = 0, exactf, exactpf = 0, periodf = 0;
+ C_word n1, n, *a = C_alloc(WORDS_PER_FLONUM);
+ C_char *sptr, *eptr;
+ double fn1, fn;
+ va_list v;
+
+ if(c == 3) radix = 10; /* default radix is 10 */
+ else if(c == 4) {
+ va_start(v, str);
+ radix = va_arg(v, C_word);
+ va_end(v);
+
+ if(radix & C_FIXNUM_BIT) radix = C_unfix(radix);
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "string->number", radix);
+ }
+ else C_bad_argc(c, 3);
+
+ if(C_immediatep(str) || C_header_bits(str) != C_STRING_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "string->number", str);
+
+ if((n = C_header_size(str)) == 0) {
+ fail:
+ n = C_SCHEME_FALSE;
+ goto fini;
+ }
+
+ if(n >= STRING_BUFFER_SIZE - 1) goto fail;
+
+ C_memcpy(sptr = buffer, C_c_string(str), n > (STRING_BUFFER_SIZE - 1) ? STRING_BUFFER_SIZE : n);
+ buffer[ n ] = '\0';
+
+ while(*sptr == '#') {
+ switch(*(++sptr)) {
+ case 'b': if(radixpf) goto fail; else { radix = 2; radixpf = 1; } break;
+ case 'o': if(radixpf) goto fail; else { radix = 8; radixpf = 1; } break;
+ case 'd': if(radixpf) goto fail; else { radix = 10; radixpf = 1; } break;
+ case 'x': if(radixpf) goto fail; else { radix = 16; radixpf = 1; } break;
+ case 'e': if(exactpf) goto fail; else { exactf = 1; exactpf = 1; } break;
+ case 'i': if(exactpf) goto fail; else { exactf = 0; exactpf = 1; } break;
+ default: --sptr;
+ }
+
+ ++sptr;
+ }
+
+ /* check for embedded '#'s and double '.'s: */
+ for(eptr = sptr; *eptr != '\0'; ++eptr) {
+ switch(*eptr) {
+ case '.':
+ if(periodf) goto fail;
+
+ periodf = 1;
+ break;
+
+ case '#':
+ if(eptr[ 1 ] == '\0' || C_strchr("#.0123456789", eptr[ 1 ]) != NULL) {
+ sharpf = 1;
+ *eptr = '0';
+ }
+ else goto fail;
+
+ break;
+ }
+ }
+
+ /* check for rational representation: */
+ if((eptr = C_strchr(sptr, '/')) != NULL) {
+ if (eptr == sptr) {
+ n = C_SCHEME_FALSE;
+ goto fini;
+ }
+ *eptr = '\0';
+ ratp = 1;
+
+ switch(convert_string_to_number(sptr, radix, &n1, &fn1)) {
+ case 0:
+ n = C_SCHEME_FALSE;
+ goto fini;
+
+ case 1:
+ fn1 = (double)n1;
+ break;
+
+ /* case 2: nop */
+ }
+
+ sptr = eptr + 1;
+ }
+
+ /* convert number and return result: */
+ switch(convert_string_to_number(sptr, radix, &n, &fn)) {
+ case 0:
+ n = C_SCHEME_FALSE;
+ break;
+
+ case 1:
+ if(sharpf || ratp || (exactpf && !exactf)) {
+ n = C_flonum(&a, ratp ? fn1 / (double)n : (double)n);
+
+ if(exactpf && exactf) n = C_i_inexact_to_exact(n);
+ }
+ else n = C_fix(n);
+
+ break;
+
+ case 2:
+ n = C_flonum(&a, ratp ? fn1 / fn : fn);
+
+ if(exactpf && exactf) n = C_i_inexact_to_exact(n);
+
+ break;
+ }
+
+ fini:
+ C_kontinue(k, n);
+}
+
+
+C_regparm C_word C_fcall convert_string_to_number(C_char *str, int radix, C_word *fix, double *flo)
+{
+ unsigned long ln;
+ C_word n;
+ C_char *eptr, *eptr2;
+ double fn;
+#if defined(__CYGWIN__) || defined(__MINGW32__) || defined(__OpenBSD__)
+ int len = C_strlen(str);
+
+ if(len >= 4) {
+ if(!C_strncmp(str, "+nan.0", len)) {
+ *flo = 0.0/0.0;
+ return 2;
+ }
+ else if(!C_strncmp(str, "-nan.0", len)) {
+ *flo = -0.0/0.0;
+ return 2;
+ }
+ else if(!C_strncmp(str, "+inf.0", len)) {
+ *flo = 1.0/0.0;
+ return 2;
+ }
+ else if(!C_strncmp(str, "-inf.0", len)) {
+ *flo = -1.0/0.0;
+ return 2;
+ }
+ }
+#endif
+
+ if(C_strpbrk(str, "xX\0") != NULL) return 0;
+
+ errno = 0;
+ n = C_strtol(str, &eptr, radix);
+
+ if(((n == LONG_MAX || n == LONG_MIN) && errno == ERANGE) || *eptr != '\0') {
+ if(radix != 10) {
+ errno = 0;
+ ln = C_strtoul(str, &eptr, radix);
+
+ if((ln == 0 && errno == EINVAL) || (ln == ULONG_MAX && errno == ERANGE) ||
+ *eptr != '\0')
+ return 0;
+
+ *flo = (double)ln;
+ return 2;
+ }
+
+ errno = 0;
+ fn = C_strtod(str, &eptr2);
+
+ if(fn == HUGE_VAL && errno == ERANGE) return 0;
+ else if(eptr2 == str) return 0;
+ else if(*eptr2 == '\0' || (eptr != eptr2 && !C_strncmp(eptr2, ".0", C_strlen(eptr2)))) {
+ *flo = fn;
+ return 2;
+ }
+
+ return 0;
+ }
+ else if((n & C_INT_SIGN_BIT) != ((n << 1) & C_INT_SIGN_BIT)) { /* doesn't fit into fixnum? */
+ if(*eptr == '\0' || !C_strncmp(eptr, ".0", C_strlen(eptr))) {
+ *flo = (double)n;
+ return 2;
+ }
+ else return 0;
+ }
+ else {
+ *fix = n;
+ return 1;
+ }
+}
+
+
+static char *to_binary(C_uword num)
+{
+ char *p;
+
+ buffer[ 65 ] = '\0';
+ p = buffer + 65;
+
+ do {
+ *(--p) = (num & 1) ? '1' : '0';
+ num /= 2;
+ } while(num);
+
+ return p;
+}
+
+
+void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num, ...)
+{
+ C_word radix, *a;
+ C_char *p;
+ double f;
+ va_list v;
+
+ if(c == 3) radix = 10;
+ else if(c == 4) {
+ va_start(v, num);
+ radix = va_arg(v, C_word);
+ va_end(v);
+
+ if(radix & C_FIXNUM_BIT) radix = C_unfix(radix);
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "number->string", radix);
+ }
+ else C_bad_argc(c, 3);
+
+ if(num & C_FIXNUM_BIT) {
+ num = C_unfix(num);
+
+ switch(radix) {
+ case 2:
+ p = to_binary(num);
+ break;
+
+#ifdef C_SIXTY_FOUR
+ case 8: C_sprintf(p = buffer, C_text("%lo"), num); break;
+ case 10: C_sprintf(p = buffer, C_text("%ld"), num); break;
+ case 16: C_sprintf(p = buffer, C_text("%lx"), num); break;
+#else
+ case 8: C_sprintf(p = buffer, C_text("%o"), num); break;
+ case 10: C_sprintf(p = buffer, C_text("%d"), num); break;
+ case 16: C_sprintf(p = buffer, C_text("%x"), num); break;
+#endif
+ default: barf(C_BAD_ARGUMENT_TYPE_ERROR, "number->string", C_fix(radix));
+ }
+ }
+ else if(!C_immediatep(num) && C_block_header(num) == C_FLONUM_TAG) {
+ f = C_flonum_magnitude(num);
+
+ if(C_fits_in_unsigned_int_p(num) == C_SCHEME_TRUE) {
+ switch(radix) {
+ case 2:
+ p = to_binary((unsigned int)f);
+ goto fini;
+
+ case 8:
+ C_sprintf(p = buffer, "%o", (unsigned int)f);
+ goto fini;
+
+ case 16:
+ C_sprintf(p = buffer, "%x", (unsigned int)f);
+ goto fini;
+ }
+ }
+
+#if defined(__CYGWIN__) || defined(__MINGW32__)
+ if(C_isnan(f)) {
+ C_strcpy(p = buffer, "+nan.0");
+ goto fini;
+ }
+ else if(C_isinf(f)) {
+ C_sprintf(p = buffer, "%cinf.0", f > 0 ? '+' : '-');
+ goto fini;
+ }
+#endif
+
+#ifdef HAVE_GCVT
+ C_gcvt(f, flonum_print_precision, buffer);
+#else
+ C_sprintf(buffer, C_text("%.*g"), flonum_print_precision, f);
+#endif
+
+ if((p = C_strpbrk(buffer, C_text(".eE"))) == NULL) {
+ if(*buffer == 'i' || *buffer == 'n') { /* inf or nan */
+ C_memmove(buffer + 1, buffer, C_strlen(buffer) + 1);
+ *buffer = '+';
+ }
+ else if(buffer[ 1 ] != 'i') C_strcat(buffer, C_text(".0")); /* negative infinity? */
+ }
+
+ p = buffer;
+ }
+ else
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "number->string", num);
+
+ fini:
+ radix = C_strlen(p);
+ a = C_alloc((C_bytestowords(radix) + 1));
+ radix = C_string(&a, radix, p);
+ C_kontinue(k, radix);
+}
+
+
+void C_ccall C_get_argv(C_word c, C_word closure, C_word k)
+{
+ int i, cells;
+
+ if(c != 2) C_bad_argc(c, 2);
+
+ i = C_main_argc;
+ cells = 0;
+
+ while(i--)
+ cells += 7 + C_align(C_strlen(C_main_argv[ i ]));
+
+ C_save(k);
+ C_save(C_fix(cells));
+
+ if(!C_demand(cells)) C_reclaim(get_argv_2, NULL);
+
+ get_argv_2(NULL);
+}
+
+
+void get_argv_2(void *dummy)
+{
+ int cells = C_unfix(C_restore),
+ i = C_main_argc;
+ C_word k = C_restore,
+ *a = C_alloc(cells),
+ list, str;
+
+ for(list = C_SCHEME_END_OF_LIST; i--; list = C_pair(&a, str, list))
+ str = C_string2(&a, C_main_argv[ i ]);
+
+ C_kontinue(k, list);
+}
+
+
+void C_ccall C_make_structure(C_word c, C_word closure, C_word k, C_word type, ...)
+{
+ va_list v;
+ int i;
+
+ va_start(v, type);
+
+ for(i = c - 3; i--; C_save(va_arg(v, C_word)));
+
+ va_end(v);
+ C_save(type);
+ C_save(k);
+
+ if(!C_demand(c - 1))
+ C_reclaim(make_structure_2, NULL);
+
+ make_structure_2(NULL);
+}
+
+
+void make_structure_2(void *dummy)
+{
+ C_word k = C_restore,
+ type = C_restore,
+ size = C_rest_count(0),
+ *a = C_alloc(size + 2),
+ *s = a,
+ s0 = (C_word)s;
+
+ *(s++) = C_STRUCTURE_TYPE | (size + 1);
+ *(s++) = type;
+ s += size;
+
+ while(size--)
+ *(--s) = C_restore;
+
+ C_kontinue(k, s0);
+}
+
+
+void C_ccall C_make_symbol(C_word c, C_word closure, C_word k, C_word name)
+{
+ C_word ab[ C_SIZEOF_SYMBOL ], *a = ab,
+ s0 = (C_word)a;
+
+ *(a++) = C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1);
+ *(a++) = C_SCHEME_UNBOUND;
+ *(a++) = name;
+ *a = C_SCHEME_END_OF_LIST;
+ C_kontinue(k, s0);
+}
+
+
+void C_ccall C_make_pointer(C_word c, C_word closure, C_word k)
+{
+ C_word ab[ 2 ], *a = ab,
+ p;
+
+ p = C_mpointer(&a, NULL);
+ C_kontinue(k, p);
+}
+
+
+void C_ccall C_make_tagged_pointer(C_word c, C_word closure, C_word k, C_word tag)
+{
+ C_word ab[ 3 ], *a = ab,
+ p;
+
+ p = C_taggedmpointer(&a, tag, NULL);
+ C_kontinue(k, p);
+}
+
+
+void C_ccall C_ensure_heap_reserve(C_word c, C_word closure, C_word k, C_word n)
+{
+ C_save(k);
+
+ if(!C_demand(C_bytestowords(C_unfix(n))))
+ C_reclaim(generic_trampoline, NULL);
+
+ generic_trampoline(NULL);
+}
+
+
+void generic_trampoline(void *dummy)
+{
+ C_word k = C_restore;
+
+ C_kontinue(k, C_SCHEME_UNDEFINED);
+}
+
+
+void C_ccall C_return_to_host(C_word c, C_word closure, C_word k)
+{
+ return_to_host = 1;
+ C_save(k);
+ C_reclaim(generic_trampoline, NULL);
+}
+
+
+void C_ccall C_file_info(C_word c, C_word closure, C_word k, C_word name)
+{
+ C_save(k);
+ C_save(name);
+
+ if(!C_demand(FILE_INFO_SIZE + 1 + C_SIZEOF_FLONUM * 3)) C_reclaim(file_info_2, NULL);
+
+ file_info_2(NULL);
+}
+
+
+void file_info_2(void *dummy)
+{
+ C_word name = C_restore,
+ k = C_restore,
+ *a = C_alloc(FILE_INFO_SIZE + 1 + C_SIZEOF_FLONUM * 3),
+ v = C_SCHEME_FALSE,
+ t, f1, f2, f3;
+ int len = C_header_size(name);
+ char *buffer2;
+
+#ifdef _MSC_VER
+ struct _stat buf;
+#else
+ struct stat buf;
+#endif
+
+ buffer2 = buffer;
+ if(len >= sizeof(buffer)) {
+ if((buffer2 = (char *)C_malloc(len + 1)) == NULL)
+ barf(C_OUT_OF_MEMORY_ERROR, "stat");
+ }
+ C_strncpy(buffer2, C_c_string(name), len);
+ buffer2[ len ] = '\0';
+
+#ifdef _MSC_VER
+ if(_stat(buffer2, &buf) != 0) v = C_SCHEME_FALSE;
+#else
+ if(stat(buffer2, &buf) != 0) v = C_SCHEME_FALSE;
+#endif
+ else {
+ switch(buf.st_mode & S_IFMT) {
+ case S_IFDIR: t = 1; break;
+#if !defined(_MSC_VER)
+ case S_IFIFO: t = 3; break;
+# if !defined(__MINGW32__)
+ case S_IFSOCK: t = 4; break;
+# endif
+#endif
+ default: t = 0;
+ }
+
+ f1 = C_flonum(&a, buf.st_atime);
+ f2 = C_flonum(&a, buf.st_ctime);
+ f3 = C_flonum(&a, buf.st_mtime);
+ v = C_vector(&a, FILE_INFO_SIZE, f1, f2, f3,
+ C_fix(buf.st_size), C_fix(t), C_fix(buf.st_mode), C_fix(buf.st_uid) );
+ }
+
+ if (buffer2 != buffer)
+ free(buffer2);
+
+ C_kontinue(k, v);
+}
+
+
+/* The following code was contributed by Sergey Khorev: */
+#if defined(_MSC_VER) && !defined(_DLL)
+/* we're using static C runtime
+ * each module has its own environment block
+ * use WinAPI to have consistent look to environment */
+
+# define ENV_SIZE 32767
+static char *envbuf;
+static char *C_getenv(const char *var)
+{
+ envbuf = (char *)malloc(ENV_SIZE);
+ if(!envbuf)
+ return NULL;
+ if(!GetEnvironmentVariable(var, envbuf, ENV_SIZE))
+ {
+ free(envbuf);
+ return NULL;
+ }
+ else
+ return envbuf;
+}
+
+
+static void C_free_envbuf()
+{
+ free(envbuf);
+}
+#else
+# define C_getenv(v) getenv(v)
+# define C_free_envbuf() {}
+#endif
+
+
+void C_ccall C_get_environment_variable(C_word c, C_word closure, C_word k, C_word name)
+{
+ int len;
+
+ if(c != 3) C_bad_argc(c, 3);
+
+ if(C_immediatep(name) || C_header_bits(name) != C_STRING_TYPE)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "getenv", name);
+
+ if((len = C_header_size(name)) >= STRING_BUFFER_SIZE)
+ C_kontinue(k, C_SCHEME_FALSE);
+
+ strncpy(buffer, C_c_string(name), len);
+ buffer[ len ] = '\0';
+
+ if((save_string = C_getenv(buffer)) == NULL)
+ C_kontinue(k, C_SCHEME_FALSE);
+
+ C_save(k);
+
+ len = C_strlen(save_string);
+ if(!C_demand(1 + C_bytestowords(len + 1)))
+ C_reclaim(get_environment_variable_2, NULL);
+
+ get_environment_variable_2(NULL);
+}
+
+
+void get_environment_variable_2(void *dummy)
+{
+ int len = C_strlen(save_string);
+ C_word k = C_restore,
+ *a = C_alloc(1 + C_bytestowords(len + 1)),
+ str = C_string(&a, len, save_string);
+
+ C_free_envbuf();
+ C_kontinue(k, str);
+}
+
+
+void C_ccall C_get_symbol_table_info(C_word c, C_word closure, C_word k)
+{
+ double d1, d2;
+ int n = 0, total;
+ C_SYMBOL_TABLE *stp;
+ C_word x, y,
+ ab[ WORDS_PER_FLONUM * 2 + 5 ], /* 2 flonums + 1 vector of 4 elements */
+ *a = ab;
+
+ for(stp = symbol_table_list; stp != NULL; stp = stp->next)
+ ++n;
+
+ d1 = compute_symbol_table_load(&d2, &total);
+ x = C_flonum(&a, d1);
+ y = C_flonum(&a, d2);
+ C_kontinue(k, C_vector(&a, 4, x, y, C_fix(total), C_fix(n)));
+}
+
+
+void C_ccall C_get_memory_info(C_word c, C_word closure, C_word k)
+{
+ C_word ab[ 3 ], *a = ab;
+
+ C_kontinue(k, C_vector(&a, 2, C_fix(heap_size), C_fix(stack_size)));
+}
+
+
+void C_ccall C_context_switch(C_word c, C_word closure, C_word k, C_word state)
+{
+ C_word n = C_header_size(state) - 1,
+ adrs = C_block_item(state, 0);
+ TRAMPOLINE trampoline;
+
+ C_temporary_stack = C_temporary_stack_bottom - n;
+ C_memcpy(C_temporary_stack, (C_word *)state + 2, n * sizeof(C_word));
+ trampoline = (TRAMPOLINE)C_u_i_car(adrs);
+ trampoline((void *)C_u_i_cdr(adrs));
+}
+
+
+void C_ccall C_peek_signed_integer(C_word c, C_word closure, C_word k, C_word v, C_word index)
+{
+ C_word x = C_block_item(v, C_unfix(index));
+
+ if((x & C_INT_SIGN_BIT) != ((x << 1) & C_INT_SIGN_BIT)) {
+ C_save(k);
+ C_temporary_flonum = (double)x;
+ cons_flonum_trampoline(NULL);
+ }
+
+ C_kontinue(k, C_fix(x));
+}
+
+
+void C_ccall C_peek_unsigned_integer(C_word c, C_word closure, C_word k, C_word v, C_word index)
+{
+ C_word x = C_block_item(v, C_unfix(index));
+
+ if((x & C_INT_SIGN_BIT) || ((x << 1) & C_INT_SIGN_BIT)) {
+ C_save(k);
+ C_temporary_flonum = (double)(C_uword)x;
+ cons_flonum_trampoline(NULL);
+ }
+
+ C_kontinue(k, C_fix(x));
+}
+
+
+void C_ccall C_decode_seconds(C_word c, C_word closure, C_word k, C_word secs, C_word mode)
+{
+ time_t tsecs;
+ struct tm *tmt;
+ C_word ab[ 11 ], *a = ab,
+ info;
+
+ tsecs = (time_t)((secs & C_FIXNUM_BIT) != 0 ? C_unfix(secs) : C_flonum_magnitude(secs));
+
+ if(mode == C_SCHEME_FALSE) tmt = C_localtime(&tsecs);
+ else tmt = C_gmtime(&tsecs);
+
+ if(tmt == NULL)
+ C_kontinue(k, C_SCHEME_FALSE);
+
+ info = C_vector(&a, 10, C_fix(tmt->tm_sec), C_fix(tmt->tm_min), C_fix(tmt->tm_hour),
+ C_fix(tmt->tm_mday), C_fix(tmt->tm_mon), C_fix(tmt->tm_year),
+ C_fix(tmt->tm_wday), C_fix(tmt->tm_yday),
+ tmt->tm_isdst > 0 ? C_SCHEME_TRUE : C_SCHEME_FALSE,
+#ifdef C_MACOSX
+ /* negative for west of UTC, but we want positive */
+ C_fix(-tmt->tm_gmtoff)
+#elif defined(__CYGWIN__) || defined(__MINGW32__) || defined(_WIN32) || defined(__WINNT__)
+ C_fix(_timezone)
+#else
+ C_fix(timezone)
+#endif
+ );
+ C_kontinue(k, info);
+}
+
+
+void C_ccall C_machine_byte_order(C_word c, C_word closure, C_word k)
+{
+ char *str;
+ C_word *a, s;
+
+ if(c != 2) C_bad_argc(c, 2);
+
+#if defined(C_MACHINE_BYTE_ORDER)
+ str = C_MACHINE_BYTE_ORDER;
+#else
+ C_cblock
+ static C_word one_two_three = 123;
+ str = (*((C_char *)&one_two_three) != 123) ? "big-endian" : "little-endian";
+ C_cblockend
+#endif
+
+ a = C_alloc(2 + C_bytestowords(strlen(str)));
+ s = C_string2(&a, str);
+
+ C_kontinue(k, s);
+}
+
+
+void C_ccall C_machine_type(C_word c, C_word closure, C_word k)
+{
+ C_word *a, s;
+
+ if(c != 2) C_bad_argc(c, 2);
+
+ a = C_alloc(2 + C_bytestowords(strlen(C_MACHINE_TYPE)));
+ s = C_string2(&a, C_MACHINE_TYPE);
+
+ C_kontinue(k, s);
+}
+
+
+void C_ccall C_software_type(C_word c, C_word closure, C_word k)
+{
+ C_word *a, s;
+
+ if(c != 2) C_bad_argc(c, 2);
+
+ a = C_alloc(2 + C_bytestowords(strlen(C_SOFTWARE_TYPE)));
+ s = C_string2(&a, C_SOFTWARE_TYPE);
+
+ C_kontinue(k, s);
+}
+
+
+void C_ccall C_build_platform(C_word c, C_word closure, C_word k)
+{
+ C_word *a, s;
+
+ if(c != 2) C_bad_argc(c, 2);
+
+ a = C_alloc(2 + C_bytestowords(strlen(C_BUILD_PLATFORM)));
+ s = C_string2(&a, C_BUILD_PLATFORM);
+
+ C_kontinue(k, s);
+}
+
+
+/* By Sergey Khorev: */
+void C_ccall C_c_runtime(C_word c, C_word closure, C_word k)
+{
+ C_word *a, s;
+
+ if(c != 2) C_bad_argc(c, 2);
+
+ a = C_alloc(2 + C_bytestowords(strlen(C_RUNTIME_VERSION)));
+ s = C_string2(&a, C_RUNTIME_VERSION);
+
+ C_kontinue(k, s);
+}
+
+
+void C_ccall C_software_version(C_word c, C_word closure, C_word k)
+{
+ C_word *a, s;
+
+ if(c != 2) C_bad_argc(c, 2);
+
+ a = C_alloc(2 + C_bytestowords(strlen(C_SOFTWARE_VERSION)));
+ s = C_string2(&a, C_SOFTWARE_VERSION);
+
+ C_kontinue(k, s);
+}
+
+
+/* Register finalizer: */
+
+void C_ccall C_register_finalizer(C_word c, C_word closure, C_word k, C_word x, C_word proc)
+{
+ if(C_immediatep(x)) C_kontinue(k, x);
+
+ C_do_register_finalizer(x, proc);
+ C_kontinue(k, x);
+}
+
+
+void C_ccall C_do_register_finalizer(C_word x, C_word proc)
+{
+ C_word *ptr;
+ int n, i;
+ FINALIZER_NODE *flist;
+
+ if(finalizer_free_list == NULL) {
+ if((flist = (FINALIZER_NODE *)C_malloc(sizeof(FINALIZER_NODE))) == NULL)
+ panic(C_text("out of memory - cannot allocate finalizer node"));
+
+ ++allocated_finalizer_count;
+ }
+ else {
+ flist = finalizer_free_list;
+ finalizer_free_list = flist->next;
+ }
+
+ if(finalizer_list != NULL) finalizer_list->previous = flist;
+
+ flist->previous = NULL;
+ flist->next = finalizer_list;
+ finalizer_list = flist;
+
+ if(C_in_stackp(x)) C_mutate(&flist->item, x);
+ else flist->item = x;
+
+ if(C_in_stackp(proc)) C_mutate(&flist->finalizer, proc);
+ else flist->finalizer = proc;
+
+ ++live_finalizer_count;
+}
+
+
+int C_do_unregister_finalizer(C_word x)
+{
+ int n;
+ FINALIZER_NODE *flist;
+
+ for(flist = finalizer_list; flist != NULL; flist = flist->next) {
+ if(flist->item == x) {
+ if(flist->previous == NULL) finalizer_list = flist->next;
+ else flist->previous->next = flist->next;
+
+ return 1;
+ }
+ }
+
+ return 0;
+}
+
+
+/* Dynamic loading of shared objects: */
+
+void C_ccall C_dlopen_flags(C_word c, C_word closure, C_word k)
+{
+#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)
+ C_word flgs = C_h_list(2, (dlopen_flags & RTLD_NOW) ? C_SCHEME_TRUE : C_SCHEME_FALSE,
+ (dlopen_flags & RTLD_GLOBAL) ? C_SCHEME_TRUE : C_SCHEME_FALSE);
+ C_kontinue(k, flgs);
+#else
+ C_kontinue(k, C_SCHEME_FALSE);
+#endif
+}
+
+void C_ccall C_set_dlopen_flags(C_word c, C_word closure, C_word k, C_word now, C_word global)
+{
+#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)
+ dlopen_flags = (C_truep(now) ? RTLD_NOW : RTLD_LAZY) | (C_truep(global) ? RTLD_GLOBAL : RTLD_LOCAL);
+#endif
+ C_kontinue(k, C_SCHEME_UNDEFINED);
+}
+
+
+void C_ccall C_dload(C_word c, C_word closure, C_word k, C_word name, C_word entry, C_word reloadable)
+{
+#if !defined(NO_DLOAD2)
+ /* Force minor GC: otherwise the lf may contain pointers to stack-data
+ (stack allocated interned symbols, for example) */
+ C_save_and_reclaim(dload_2, NULL, 4, k, name, entry, reloadable);
+#endif
+
+ C_kontinue(k, C_SCHEME_FALSE);
+}
+
+
+#ifdef DLOAD_2_DEFINED
+# undef DLOAD_2_DEFINED
+#endif
+
+#if !defined(NO_DLOAD2) && !defined(DLOAD_2_DEFINED)
+# define DLOAD_2_DEFINED
+void dload_2(void *dummy)
+{
+ void *handle;
+ int ok;
+ void *p = NULL;
+ void *p2;
+ C_word
+ reloadable = C_restore,
+ entry = C_restore,
+ name = C_restore,
+ k = C_restore;
+ C_char *topname = (C_char *)C_data_pointer(entry);
+ C_char *mname = (C_char *)C_data_pointer(name);
+
+ if(C_truep(reloadable) && (reload_lf = find_lf_list_node(mname)) != NULL) {
+ if(0 != C_dynamic_library_close(reload_lf->module_handle))
+ panic(C_text("Unable to unload previously loaded compiled code"));
+ }
+ else reload_lf = NULL;
+
+ if((handle = C_dynamic_library_open(mname)) != NULL) {
+ if ((p = C_dynamic_library_procedure(handle, topname)) != NULL) {
+ /* check whether dloaded code is not a library unit
+ * and matches current safety setting: */
+ p2 = C_dynamic_library_procedure(handle, C_text("C_dynamic_and_unsafe"));
+
+#ifdef C_UNSAFE_RUNTIME
+ ok = p2 != NULL; /* unsafe runtime, unsafe code */
+#else
+ ok = p2 == NULL; /* safe runtime, safe code */
+#endif
+
+ /* unsafe marker not found and this is not a library unit? */
+ if(!ok && !C_strcmp(topname, "C_toplevel"))
+#ifdef C_UNSAFE_RUNTIME
+ barf(C_RUNTIME_UNSAFE_DLOAD_SAFE_ERROR, NULL);
+#else
+ barf(C_RUNTIME_SAFE_DLOAD_UNSAFE_ERROR, NULL);
+#endif
+
+ current_module_name = C_strdup(mname);
+ current_module_handle = handle;
+
+ if(debug_mode) {
+ if(reload_lf != NULL)
+ C_printf(C_text("[debug] reloading compiled module `%s' (previous handle was " UWORD_FORMAT_STRING ", new is "
+ UWORD_FORMAT_STRING ")\n"), current_module_name, (C_uword)reload_lf->module_handle,
+ (C_uword)current_module_handle);
+ else
+ C_printf(C_text("[debug] loading compiled module `%s' (handle is " UWORD_FORMAT_STRING ")\n"),
+ current_module_name, (C_uword)current_module_handle);
+ }
+
+ ((C_proc2)p)(2, C_SCHEME_UNDEFINED, k); /* doesn't return */
+ }
+ else
+ C_dynamic_library_close(handle);
+ }
+
+ C_kontinue(k, C_SCHEME_FALSE);
+}
+#endif
+
+
+C_word C_ccall C_dunload(C_word name)
+{
+ LF_LIST *np = find_lf_list_node(C_c_string(name));
+ if(NULL != np && 0 == C_dynamic_library_close(np->module_handle)) {
+ C_unregister_lf(np);
+ return C_SCHEME_TRUE;
+ }
+ return C_SCHEME_FALSE;
+}
+
+
+/* Dynamic Library Access from C */
+
+C_regparm void * C_fcall
+C_dynamic_library_open(C_char *name)
+{
+#ifndef NO_DLOAD2
+
+# if defined(__hpux__) && defined(HAVE_DL_H)
+
+ shl_t handle = shl_load(name, BIND_IMMEDIATE | DYNAMIC_PATH, 0L);
+ if(NULL != handle) return (void *)handle;
+ C_dlerror = (char *)C_strerror(errno);
+
+# elif defined(HAVE_DLFCN_H)
+
+ void *handle = C_dlopen(name, dlopen_flags);
+ if(NULL != handle) return handle;
+ C_dlerror = (char *)dlerror();
+
+# elif defined(HAVE_LOADLIBRARY)
+
+ HMODULE handle;
+
+ /* cannot use LoadLibrary on non-DLLs, so we use extension checking */
+ int len = strlen(name);
+ /* FIXME - probably should use _stricmp since Windows native */
+ if( (len >= 5 && C_strncasecmp(".dll", name+len-4, 4))
+ && (len >= 4 && C_strncasecmp(".so", name+len-3, 3))) {
+ static char not_dll_msg[] = "unsuitable pathname extension - not a .DLL or .SO";
+ C_dlerror = not_dll_msg;
+ return NULL;
+ }
+
+ handle = LoadLibrary(name);
+ if(NULL != handle) return (void *)handle;
+ C_dlerror = (char *)C_strerror(errno);
+
+# endif
+
+#endif
+
+ return NULL;
+}
+
+
+static C_char *
+make_underscore_symstr(C_char *sym)
+{
+ /* if we're out-of-memory don't report it here */
+ char *usym = (C_char *)C_malloc(C_strlen(sym) + 2);
+ if(NULL != usym) {
+ C_strcpy(usym, C_text("_"));
+ C_strcat(usym, sym);
+ }
+ return usym;
+}
+
+
+C_regparm void * C_fcall
+C_dynamic_library_procedure(void *handle, C_char *name)
+{
+ void *ptr = C_dynamic_library_procedure_exact(handle, name);
+
+#ifndef C_MICROSOFT_WINDOWS
+ if(NULL == ptr) {
+ char *tmp = make_underscore_symstr(name);
+ if(NULL != tmp) {
+ ptr = C_dynamic_library_procedure_exact(handle, tmp);
+ C_free(tmp);
+ }
+ }
+#endif
+
+ return ptr;
+}
+
+
+C_regparm void * C_fcall
+C_dynamic_library_procedure_exact(void *handle, C_char *name)
+{
+#ifndef NO_DLOAD2
+
+# if defined(__hpux__) && defined(HAVE_DL_H)
+
+ shl_t shl_handle = (shl_t)handle;
+ void *ptr;
+ if(0 == shl_findsym(&shl_handle, name, TYPE_PROCEDURE, &ptr)) return ptr;
+ C_dlerror = (char *)C_strerror(errno);
+
+# elif defined(HAVE_DLFCN_H)
+
+ void *ptr = C_dlsym(handle, name);
+ if(NULL != ptr) return ptr;
+ C_dlerror = (char *)dlerror();
+
+# elif defined(HAVE_GETPROCADDRESS)
+
+ FARPROC ptr = GetProcAddress((HMODULE)handle, name);
+ if(NULL != ptr) return (void *)ptr;
+ C_dlerror = (char *)C_strerror(errno);
+
+# endif
+
+#endif
+
+ return NULL;
+}
+
+
+C_regparm void * C_fcall
+C_dynamic_library_variable(void *handle, C_char *name)
+{
+ void *ptr = C_dynamic_library_variable_exact(handle, name);
+
+#ifndef C_MICROSOFT_WINDOWS
+ if(NULL == ptr) {
+ char *tmp = make_underscore_symstr(name);
+ if(NULL != tmp) {
+ ptr = C_dynamic_library_variable_exact(handle, tmp);
+ C_free(tmp);
+ }
+ }
+#endif
+
+ return ptr;
+}
+
+
+C_regparm void * C_fcall
+C_dynamic_library_variable_exact(void *handle, C_char *name)
+{
+#ifndef NO_DLOAD2
+
+# if defined(__hpux__) && defined(HAVE_DL_H)
+
+ shl_t shl_handle = (shl_t)handle;
+ void *p;
+ if(0 == shl_findsym(&shl_handle, name, TYPE_DATA, &p)) return p;
+ C_dlerror = (char *)C_strerror(errno);
+
+# elif defined(HAVE_DLFCN_H)
+
+ void *p = C_dlsym(handle, name);
+ if(NULL != p) return p;
+ C_dlerror = (char *)dlerror();
+
+# elif defined(HAVE_GETPROCADDRESS)
+
+ /* Not Supported */
+
+# endif
+
+#endif
+
+ return NULL;
+}
+
+
+C_regparm int C_fcall
+C_dynamic_library_close(void *handle)
+{
+#ifndef NO_DLOAD2
+
+# if defined(__hpux__) && defined(HAVE_DL_H)
+
+ if(0 != shl_unload((shl_t)handle)) return -1;
+ C_dlerror = (char *)C_strerror(errno);
+
+# elif defined(HAVE_DLFCN_H)
+
+ if(0 != C_dlclose(handle)) return -1;
+ C_dlerror = (char *)dlerror();
+
+# elif defined(HAVE_LOADLIBRARY)
+
+ if(0 == FreeLibrary((HMODULE)handle)) return -1;
+ C_dlerror = (char *)C_strerror(errno);
+
+# endif
+
+#endif
+
+ return 0;
+}
+
+
+/* Dynamic Library Access from Scheme */
+
+void C_ccall
+C_dynamic_library_load(C_word c, C_word closure, C_word k, C_word name)
+{
+ C_word succ = C_SCHEME_FALSE;
+ C_char *pname;
+
+ if(c != 3) C_bad_argc(c, 3);
+
+ pname = checked_string_argument("##sys#dynamic-library-load", name); /* only free'ed on err */
+
+ if(NULL == find_lf_list_node(pname)) {
+ void *handle = C_dynamic_library_open(pname);
+ if(NULL != handle) {
+ LF_LIST *node = make_lf_list_node(NULL, 0, NULL, pname, handle);
+ if(NULL != node) {
+ link_lf_list_node(node);
+ succ = C_SCHEME_TRUE;
+ }
+ else {
+ C_free(pname);
+ C_dynamic_library_close(handle);
+ }
+ }
+ else
+ C_free(pname);
+ }
+ /* loading a loaded library is not an error & we don't bump the dload refcnt */
+ else succ = C_SCHEME_TRUE;
+
+ C_kontinue(k, succ);
+}
+
+
+void C_ccall
+C_dynamic_library_symbol(C_word c, C_word closure, C_word k, C_word mname, C_word sname, C_word isprcsym)
+{
+ C_word mptr = C_SCHEME_FALSE;
+ C_char *pmname, *psname;
+ LF_LIST *node;
+
+ if(c != 5) C_bad_argc(c, 5);
+
+ pmname = checked_string_argument("##sys#dynamic-library-symbol", mname);
+ psname = checked_string_argument("##sys#dynamic-library-symbol", sname);
+
+ node = find_lf_list_node(pmname);
+ if(NULL != node) {
+ /* note that this cannot fail out-of-line - so tmp strs will be free'ed */
+ void *ptr = C_truep(isprcsym)
+ ? C_dynamic_library_procedure(node->module_handle, psname)
+ : C_dynamic_library_variable(node->module_handle, psname);
+ mptr = C_mpointer_or_false(C_heaptop, ptr);
+ }
+
+ if(psname) C_free(psname);
+ if(pmname) C_free(pmname);
+
+ C_kontinue(k, mptr);
+}
+
+
+void C_ccall
+C_dynamic_library_unload(C_word c, C_word closure, C_word k, C_word name)
+{
+ C_word succ = C_SCHEME_FALSE;
+ C_char *pname;
+ LF_LIST *node;
+
+ if(c != 3) C_bad_argc(c, 3);
+
+ pname = checked_string_argument("##sys#dynamic-library-unload", name);
+
+ node = find_lf_list_node(pname);
+ if(NULL != node) {
+ /* note that this cannot fail out-of-line - so tmp str will be free'ed */
+ int ret = C_dynamic_library_close(node->module_handle);
+ destroy_lf_list_node(node);
+ if(0 == ret) succ = C_SCHEME_TRUE;
+ }
+ /* unloading an non-loaded library is not an error */
+ else succ = C_SCHEME_TRUE;
+
+ if(pname) C_free(pname);
+
+ C_kontinue(k, succ);
+}
+
+void C_ccall C_become(C_word c, C_word closure, C_word k, C_word table)
+{
+ C_word tp, x, old, new, i, *p;
+
+ i = forwarding_table_size;
+ p = forwarding_table;
+
+ for(tp = table; tp != C_SCHEME_END_OF_LIST; tp = C_u_i_cdr(tp)) {
+ x = C_u_i_car(tp);
+ old = C_u_i_car(x);
+ new = C_u_i_cdr(x);
+
+ if(i == 0) {
+ if((forwarding_table = (C_word *)realloc(forwarding_table, (forwarding_table_size + 1) * 4 * sizeof(C_word))) == NULL)
+ panic(C_text("out of memory - cannot re-allocate forwarding table"));
+
+ i = forwarding_table_size;
+ p = forwarding_table + forwarding_table_size * 2;
+ forwarding_table_size *= 2;
+ }
+
+ *(p++) = old;
+ *(p++) = new;
+ --i;
+ }
+
+ *p = 0;
+ C_fromspace_top = C_fromspace_limit;
+ C_save_and_reclaim(become_2, NULL, 1, k);
+}
+
+
+void become_2(void *dummy)
+{
+ C_word k = C_restore;
+ *forwarding_table = 0;
+ C_kontinue(k, C_SCHEME_UNDEFINED);
+}
+
+
+void C_ccall C_cpu_time(C_word c, C_word closure, C_word k)
+{
+ C_word u, s = 0;
+
+#if defined(C_NONUNIX) || defined(__CYGWIN__)
+ if(CLOCKS_PER_SEC == 1000) u = clock();
+ else u = ((double)clock() / (double)CLOCKS_PER_SEC) * 1000;
+#else
+ struct rusage ru;
+
+ if(C_getrusage(RUSAGE_SELF, &ru) == -1) u = 0;
+ else {
+ u = ru.ru_utime.tv_sec * 1000 + ru.ru_utime.tv_usec / 1000;
+ s = ru.ru_stime.tv_sec * 1000 + ru.ru_stime.tv_usec / 1000;
+ }
+#endif
+
+ C_values(4, C_SCHEME_UNDEFINED, k, C_fix(u & C_MOST_POSITIVE_FIXNUM), C_fix(s & C_MOST_POSITIVE_FIXNUM));
+}
+
+
+C_regparm C_word C_fcall C_a_i_make_locative(C_word **a, int c, C_word type, C_word object, C_word index, C_word weak)
+{
+ C_word *loc = *a;
+ int offset, i, in = C_unfix(index);
+ *a = loc + C_SIZEOF_LOCATIVE;
+
+ loc[ 0 ] = C_LOCATIVE_TAG;
+
+ switch(C_unfix(type)) {
+ case C_SLOT_LOCATIVE: in *= sizeof(C_word); break;
+ case C_U16_LOCATIVE:
+ case C_S16_LOCATIVE: in *= 2; break;
+ case C_U32_LOCATIVE:
+ case C_F32_LOCATIVE:
+ case C_S32_LOCATIVE: in *= 4; break;
+ case C_F64_LOCATIVE: in *= 8; break;
+ }
+
+ offset = in + sizeof(C_header);
+ loc[ 1 ] = object + offset;
+ loc[ 2 ] = C_fix(offset);
+ loc[ 3 ] = type;
+ loc[ 4 ] = C_truep(weak) ? C_SCHEME_FALSE : object;
+
+ for(i = 0; i < locative_table_count; ++i)
+ if(locative_table[ i ] == C_SCHEME_UNDEFINED) {
+ locative_table[ i ] = (C_word)loc;
+ return (C_word)loc;
+ }
+
+ if(locative_table_count >= locative_table_size) {
+ if(debug_mode == 2)
+ C_printf(C_text("[debug] resizing locative table from %d to %d (count is %d)\n"),
+ locative_table_size, locative_table_size * 2, locative_table_count);
+
+ locative_table = (C_word *)C_realloc(locative_table, locative_table_size * 2 * sizeof(C_word));
+
+ if(locative_table == NULL)
+ panic(C_text("out of memory - cannot resize locative table"));
+
+ locative_table_size *= 2;
+ }
+
+ locative_table[ locative_table_count++ ] = (C_word)loc;
+
+ return (C_word)loc;
+}
+
+
+void C_ccall C_locative_ref(C_word c, C_word closure, C_word k, C_word loc)
+{
+ C_word *ptr, val;
+
+ if(c != 3) C_bad_argc(c, 3);
+
+ if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", loc);
+
+ ptr = (C_word *)C_block_item(loc, 0);
+
+ if(ptr == NULL) barf(C_LOST_LOCATIVE_ERROR, "locative-ref", loc);
+
+ switch(C_unfix(C_block_item(loc, 2))) {
+ case C_SLOT_LOCATIVE: C_kontinue(k, *ptr);
+ case C_CHAR_LOCATIVE: C_kontinue(k, C_make_character(*((char *)ptr)));
+ case C_U8_LOCATIVE: C_kontinue(k, C_fix(*((unsigned char *)ptr)));
+ case C_S8_LOCATIVE: C_kontinue(k, C_fix(*((char *)ptr)));
+ case C_U16_LOCATIVE: C_kontinue(k, C_fix(*((unsigned short *)ptr)));
+ case C_S16_LOCATIVE: C_kontinue(k, C_fix(*((short *)ptr)));
+ case C_U32_LOCATIVE: C_peek_unsigned_integer(0, 0, k, (C_word)(ptr - 1), 0);
+ case C_S32_LOCATIVE: C_peek_signed_integer(0, 0, k, (C_word)(ptr - 1), 0);
+ case C_F32_LOCATIVE: C_temporary_flonum = *((float *)ptr); C_cons_flonum(0, 0, k);
+ case C_F64_LOCATIVE: C_temporary_flonum = *((double *)ptr); C_cons_flonum(0, 0, k);
+ default: panic(C_text("bad locative type"));
+ }
+}
+
+
+C_regparm C_word C_fcall C_i_locative_set(C_word loc, C_word x)
+{
+ C_word *ptr, val;
+
+ if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", loc);
+
+ ptr = (C_word *)C_block_item(loc, 0);
+
+ if(ptr == NULL)
+ barf(C_LOST_LOCATIVE_ERROR, "locative-set!", loc);
+
+ switch(C_unfix(C_block_item(loc, 2))) {
+ case C_SLOT_LOCATIVE: C_mutate(ptr, x); break;
+
+ case C_CHAR_LOCATIVE:
+ if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
+
+ *((char *)ptr) = C_character_code(x);
+ break;
+
+ case C_U8_LOCATIVE:
+ if((x & C_FIXNUM_BIT) == 0)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
+
+ *((unsigned char *)ptr) = C_unfix(x);
+ break;
+
+ case C_S8_LOCATIVE:
+ if((x & C_FIXNUM_BIT) == 0)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
+
+ *((char *)ptr) = C_unfix(x);
+ break;
+
+ case C_U16_LOCATIVE:
+ if((x & C_FIXNUM_BIT) == 0)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
+
+ *((unsigned short *)ptr) = C_unfix(x);
+ break;
+
+ case C_S16_LOCATIVE:
+ if((x & C_FIXNUM_BIT) == 0)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
+
+ *((short *)ptr) = C_unfix(x);
+ break;
+
+ case C_U32_LOCATIVE:
+ if((x & C_FIXNUM_BIT) == 0 && (C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
+
+ *((C_u32 *)ptr) = C_num_to_unsigned_int(x);
+ break;
+
+ case C_S32_LOCATIVE:
+ if((x & C_FIXNUM_BIT) == 0 && (C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
+
+ *((C_s32 *)ptr) = C_num_to_int(x);
+ break;
+
+ case C_F32_LOCATIVE:
+ if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
+
+ *((float *)ptr) = C_flonum_magnitude(x);
+ break;
+
+ case C_F64_LOCATIVE:
+ if(C_immediatep(x) || C_block_header(x) != C_FLONUM_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
+
+ *((double *)ptr) = C_flonum_magnitude(x);
+ break;
+
+ default: panic(C_text("bad locative type"));
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_fcall C_i_locative_to_object(C_word loc)
+{
+ C_word *ptr;
+
+ if(C_immediatep(loc) || C_block_header(loc) != C_LOCATIVE_TAG)
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative->object", loc);
+
+ ptr = (C_word *)C_u_i_car(loc);
+
+ if(ptr == NULL) return C_SCHEME_FALSE;
+ else return (C_word)ptr - C_unfix(C_u_i_cdr(loc));
+}
+
+
+/* GC protection of user-variables: */
+
+C_regparm void C_fcall C_gc_protect(C_word **addr, int n)
+{
+ int k;
+
+ if(collectibles_top + n >= collectibles_limit) {
+ k = collectibles_limit - collectibles;
+ collectibles = (C_word **)C_realloc(collectibles, sizeof(C_word *) * k * 2);
+
+ if(collectibles == NULL)
+ panic(C_text("out of memory - cannot allocate GC protection vector"));
+
+ collectibles_top = collectibles + k;
+ collectibles_limit = collectibles + k * 2;
+ }
+
+ C_memcpy(collectibles_top, addr, n * sizeof(C_word *));
+ collectibles_top += n;
+}
+
+
+C_regparm void C_fcall C_gc_unprotect(int n)
+{
+ collectibles_top -= n;
+}
+
+
+/* Map procedure-ptr to id or id to ptr: */
+
+C_char *C_lookup_procedure_id(void *ptr)
+{
+ LF_LIST *lfl;
+ C_PTABLE_ENTRY *pt;
+
+ for(lfl = lf_list; lfl != NULL; lfl = lfl->next) {
+ pt = lfl->ptable;
+
+ if(pt != NULL) {
+ while(pt->id != NULL) {
+ if(pt->ptr == ptr) return pt->id;
+ else ++pt;
+ }
+ }
+ }
+
+ return NULL;
+}
+
+
+void *C_lookup_procedure_ptr(C_char *id)
+{
+ LF_LIST *lfl;
+ C_PTABLE_ENTRY *pt;
+
+ for(lfl = lf_list; lfl != NULL; lfl = lfl->next) {
+ pt = lfl->ptable;
+
+ if(pt != NULL) {
+ while(pt->id != NULL) {
+ if(!C_strcmp(id, pt->id)) return pt->ptr;
+ else ++pt;
+ }
+ }
+ }
+
+ return NULL;
+}
+
+
+void C_ccall C_copy_closure(C_word c, C_word closure, C_word k, C_word proc)
+{
+ int n = C_header_size(proc);
+
+ if(!C_demand(n + 1)) C_save_and_reclaim(copy_closure_2, NULL, 2, proc, k);
+ else {
+ C_save(proc);
+ C_save(k);
+ copy_closure_2(NULL);
+ }
+}
+
+
+static void copy_closure_2(void *dummy)
+{
+ C_word
+ k = C_restore,
+ proc = C_restore;
+ int cells = C_header_size(proc);
+ C_word
+ *ptr = C_alloc(cells + 1),
+ *p = ptr;
+
+ *(p++) = C_CLOSURE_TYPE | cells;
+ C_memcpy_slots(p, C_data_pointer(proc), cells);
+ C_kontinue(k, (C_word)ptr);
+}
+
+
+/* Creating black holes: */
+
+void C_call_with_cthulhu(C_word c, C_word self, C_word k, C_word proc)
+{
+ C_word *a = C_alloc(3);
+
+ k = C_closure(&a, 1, (C_word)termination_continuation);
+ C_apply(4, C_SCHEME_UNDEFINED, k, proc, C_SCHEME_END_OF_LIST);
+}
+
+
+/* fixnum arithmetic with overflow detection (from "Hacker's Delight" by Hank Warren)
+ These routines return #f if the operation failed due to overflow.
+ */
+
+C_regparm C_word C_fcall C_i_o_fixnum_plus(C_word n1, C_word n2)
+{
+ C_word x1, x2, s;
+
+ if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;
+
+ x1 = C_unfix(n1);
+ x2 = C_unfix(n2);
+ s = x1 + x2;
+
+ if((((s ^ x1) & (s ^ x2)) >> 30) != 0) return C_SCHEME_FALSE;
+ else return C_fix(s);
+}
+
+
+C_regparm C_word C_fcall C_i_o_fixnum_difference(C_word n1, C_word n2)
+{
+ C_word x1, x2, s;
+
+ if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;
+
+ x1 = C_unfix(n1);
+ x2 = C_unfix(n2);
+ s = x1 - x2;
+
+ if((((s ^ x1) & ~(s ^ x2)) >> 30) != 0) return C_SCHEME_FALSE;
+ else return C_fix(s);
+}
+
+
+C_regparm C_word C_fcall C_i_o_fixnum_and(C_word n1, C_word n2)
+{
+ C_uword x1, x2, r;
+
+ if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;
+
+ x1 = C_unfix(n1);
+ x2 = C_unfix(n2);
+ r = x1 & x2;
+
+ if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;
+ else return C_fix(r);
+}
+
+
+C_regparm C_word C_fcall C_i_o_fixnum_ior(C_word n1, C_word n2)
+{
+ C_uword x1, x2, r;
+
+ if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;
+
+ x1 = C_unfix(n1);
+ x2 = C_unfix(n2);
+ r = x1 | x2;
+
+ if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;
+ else return C_fix(r);
+}
+
+
+C_regparm C_word C_fcall C_i_o_fixnum_xor(C_word n1, C_word n2)
+{
+ C_uword x1, x2, r;
+
+ if((n1 & C_FIXNUM_BIT) == 0 || (n2 & C_FIXNUM_BIT) == 0) return C_SCHEME_FALSE;
+
+ x1 = C_unfix(n1);
+ x2 = C_unfix(n2);
+ r = x1 ^ x2;
+
+ if(((r & C_INT_SIGN_BIT) >> 1) != (r & C_INT_TOP_BIT)) return C_SCHEME_FALSE;
+ else return C_fix(r);
+}
+
+
+/* decoding of literals in compressed format */
+
+static C_regparm C_uword C_fcall decode_size(C_char **str)
+{
+ C_uchar **ustr = (C_uchar **)str;
+ C_uword size = (*((*ustr)++) & 0xff) << 16; /* always big endian */
+
+ size |= (*((*ustr)++) & 0xff) << 8;
+ size |= (*((*ustr)++) & 0xff);
+ return size;
+}
+
+
+static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
+ C_word *dest)
+{
+ unsigned long bits = *((*str)++) & 0xff;
+ C_word *data, *dptr, val;
+ C_uword size;
+ int maybe_fixnum = 0;
+
+ /* vvv this can be taken out at a later stage (once it works reliably) vvv */
+ if(bits != 0xfe)
+ panic(C_text("invalid encoded literal format"));
+
+ bits = *((*str)++) & 0xff;
+ /* ^^^ */
+
+#ifdef C_SIXTY_FOUR
+ bits <<= 24 + 32;
+#else
+ bits <<= 24;
+#endif
+
+ if(bits == C_HEADER_BITS_MASK) { /* special/immediate */
+ switch(0xff & *((*str)++)) {
+ case C_BOOLEAN_BITS:
+ return C_mk_bool(*((*str)++));
+
+ case C_CHARACTER_BITS:
+ return C_make_character(decode_size(str));
+
+ case C_SCHEME_END_OF_LIST:
+ case C_SCHEME_UNDEFINED:
+ case C_SCHEME_END_OF_FILE:
+ return (C_word)(*(*str - 1));
+
+ case C_FIXNUM_BIT:
+ val = *((*str)++) << 24; /* always big endian */
+ val |= (*((*str)++) & 0xff) << 16;
+ val |= (*((*str)++) & 0xff) << 8;
+ val |= (*((*str)++) & 0xff);
+ return C_fix(val);
+
+#ifdef C_SIXTY_FOUR
+ case (C_FLONUM_TYPE >> (24 + 32)) & 0xff:
+#else
+ case (C_FLONUM_TYPE >> 24) & 0xff:
+#endif
+ maybe_fixnum = 1;
+ bits = C_FLONUM_TYPE;
+ break;
+
+ default:
+ panic(C_text("invalid encoded special literal"));
+ }
+ }
+
+#ifndef C_SIXTY_FOUR
+ if((bits & C_8ALIGN_BIT) != 0) {
+ /* Align _data_ on 8-byte boundary: */
+ if(aligned8(*ptr)) ++(*ptr);
+ }
+#endif
+
+ val = (C_word)(*ptr);
+
+ if(bits == C_FLONUM_TYPE) {
+ if(maybe_fixnum) {
+ long ln;
+
+ errno = 0;
+ ln = strtol(*str, str, 10);
+
+ if(((ln == LONG_MAX || ln == LONG_MIN) && errno == ERANGE) || **str != '\0')
+ val = C_number(ptr, C_strtod(*str, str));
+ else val = C_fix(ln);
+ }
+ else val = C_flonum(ptr, C_strtod(*str, str));
+
+ ++(*str); /* skip terminating '\0' */
+ return val;
+ }
+
+ if((bits & C_SPECIALBLOCK_BIT) != 0)
+ panic(C_text("literals with special bit cannot be decoded"));
+
+ size = decode_size(str);
+
+ switch(bits) {
+ case C_STRING_TYPE:
+ /* strings are always allocated statically */
+ val = C_static_string(ptr, size, *str);
+ *str += size;
+ break;
+
+ case C_SYMBOL_TYPE:
+ if(dest == NULL)
+ panic(C_text("invalid literal symbol destination"));
+
+ val = C_h_intern(dest, size, *str);
+ *str += size;
+ break;
+
+ case C_LAMBDA_INFO_TYPE:
+ /* lambda infos are always allocated statically */
+ val = C_static_lambda_info(ptr, size, *str);
+ *str += size;
+ break;
+
+ default:
+ *((*ptr)++) = C_make_header(bits, size);
+ data = *ptr;
+
+ if((bits & C_BYTEBLOCK_BIT) != 0) {
+ C_memcpy(data, *str, size);
+ size = C_align(size);
+ *str += size;
+ *ptr = (C_word *)C_align((C_word)(*ptr) + size);
+ }
+ else {
+ C_word *dptr = *ptr;
+ *ptr += size;
+
+ while(size--) {
+ *dptr = decode_literal2(ptr, str, dptr);
+ ++dptr;
+ }
+ }
+ }
+
+ return val;
+}
+
+
+C_regparm C_word C_fcall C_decode_literal(C_word **ptr, C_char *str)
+{
+ return decode_literal2(ptr, &str, NULL);
+}
diff --git a/scheduler.scm b/scheduler.scm
new file mode 100644
index 00000000..69f1a603
--- /dev/null
+++ b/scheduler.scm
@@ -0,0 +1,533 @@
+; scheduler.scm - Basic scheduler for multithreading
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (fixnum)
+ (unit scheduler)
+ (disable-interrupts)
+ (usual-integrations)
+ (disable-warning var)
+ (hide ##sys#ready-queue-head ##sys#ready-queue-tail ##sys#timeout-list
+ ##sys#update-thread-state-buffer ##sys#restore-thread-state-buffer
+ ##sys#remove-from-ready-queue ##sys#unblock-threads-for-i/o ##sys#force-primordial
+ ##sys#fdset-input-set ##sys#fdset-output-set ##sys#fdset-clear
+ ##sys#fdset-select-timeout ##sys#fdset-restore
+ ##sys#clear-i/o-state-for-thread!)
+ (not inline ##sys#interrupt-hook)
+ (foreign-declare #<<EOF
+#ifdef HAVE_ERRNO_H
+# include <errno.h>
+# define C_signal_interrupted_p C_mk_bool(errno == EINTR)
+#else
+# define C_signal_interrupted_p C_SCHEME_FALSE
+#endif
+
+#ifdef _WIN32
+# if _MSC_VER > 1300
+# include <winsock2.h>
+# include <ws2tcpip.h>
+# else
+# include <winsock.h>
+# endif
+/* Beware: winsock2.h must come BEFORE windows.h */
+# define C_msleep(n) (Sleep(C_unfix(n)), C_SCHEME_TRUE)
+#else
+# include <unistd.h>
+# include <sys/types.h>
+# include <sys/time.h>
+# include <time.h>
+static C_word C_msleep(C_word ms);
+C_word C_msleep(C_word ms) {
+#ifdef __CYGWIN__
+ if(usleep(C_unfix(ms) * 1000) == -1) return C_SCHEME_FALSE;
+#else
+ struct timespec ts;
+ unsigned long mss = C_unfix(ms);
+ ts.tv_sec = mss / 1000;
+ ts.tv_nsec = (mss % 1000) * 1000000;
+
+ if(nanosleep(&ts, NULL) == -1) return C_SCHEME_FALSE;
+#endif
+ return C_SCHEME_TRUE;
+}
+#endif
+static fd_set C_fdset_input, C_fdset_output, C_fdset_input_2, C_fdset_output_2;
+#define C_fd_test_input(fd) C_mk_bool(FD_ISSET(C_unfix(fd), &C_fdset_input))
+#define C_fd_test_output(fd) C_mk_bool(FD_ISSET(C_unfix(fd), &C_fdset_output))
+EOF
+) )
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare (unsafe)) ] )
+
+
+(define-syntax dbg
+ (syntax-rules ()
+ ((_ . _) #f)))
+
+
+(define (##sys#schedule)
+ (define (switch thread)
+ (dbg "switching to " thread)
+ (set! ##sys#current-thread thread)
+ (##sys#setslot thread 3 'running)
+ (##sys#restore-thread-state-buffer thread)
+ (##core#inline "C_set_initial_timer_interrupt_period" (##sys#slot thread 9))
+ ((##sys#slot thread 1)) )
+ (let* ([ct ##sys#current-thread]
+ [eintr #f]
+ [cts (##sys#slot ct 3)] )
+ (dbg "scheduling, current: " ct ", ready: " ##sys#ready-queue-head)
+ (##sys#update-thread-state-buffer ct)
+ ;; Put current thread on ready-queue:
+ (when (or (eq? cts 'running) (eq? cts 'ready)) ; should ct really be 'ready? - normally not.
+ (##sys#setislot ct 13 #f) ; clear timeout-unblock flag
+ (##sys#add-to-ready-queue ct) )
+ (let loop1 ()
+ ;; Unblock threads waiting for timeout:
+ (unless (null? ##sys#timeout-list)
+ (let ([now (##sys#fudge 16)])
+ (dbg "timeout (" now ") list: " ##sys#timeout-list)
+ (let loop ([lst ##sys#timeout-list])
+ (if (null? lst)
+ (set! ##sys#timeout-list '())
+ (let* ([tmo1 (caar lst)]
+ [tto (cdar lst)]
+ [tmo2 (##sys#slot tto 4)] )
+ (dbg " " tto " -> " tmo2)
+ (if (eq? tmo1 tmo2)
+ (if (>= now tmo1)
+ (begin
+ (##sys#setislot tto 13 #t) ; mark as being unblocked by timeout
+ (##sys#clear-i/o-state-for-thread! tto)
+ ;;(pp `(CLEARED: ,tto ,@##sys#fd-list) ##sys#standard-error) ;***
+ (##sys#thread-basic-unblock! tto)
+ (loop (cdr lst)) )
+ (begin
+ (set! ##sys#timeout-list lst)
+ ;; If there are no threads blocking on a select call (fd-list)
+ ;; but there are threads in the timeout list then sleep for
+ ;; the number of milliseconds of next thread to wake up.
+ (when (and (null? ##sys#ready-queue-head)
+ (null? ##sys#fd-list)
+ (pair? ##sys#timeout-list))
+ (let ([tmo1 (caar ##sys#timeout-list)])
+ (set! eintr
+ (and (not (##core#inline "C_msleep" (fxmax 0 (- tmo1 now))))
+ (foreign-value "C_signal_interrupted_p" bool) ) ) ) ) ) )
+ (loop (cdr lst)) ) ) ) ) ) )
+ ;; Unblock threads blocked by I/O:
+ (if eintr
+ (##sys#force-primordial)
+ (begin
+ (unless (null? ##sys#fd-list)
+ (##sys#unblock-threads-for-i/o) ) ) )
+ ;; Fetch and activate next ready thread:
+ (let loop2 ()
+ (let ([nt (##sys#remove-from-ready-queue)])
+ (cond [(not nt)
+ (if (and (null? ##sys#timeout-list) (null? ##sys#fd-list))
+ (##sys#signal-hook #:runtime-error "deadlock")
+ (loop1) ) ]
+ [(eq? (##sys#slot nt 3) 'ready) (switch nt)]
+ [else (loop2)] ) ) ) ) ) )
+
+(define (##sys#force-primordial)
+ (dbg "primordial thread forced due to interrupt")
+ (##sys#thread-unblock! ##sys#primordial-thread) )
+
+(define ##sys#ready-queue-head '())
+(define ##sys#ready-queue-tail '())
+
+(define (##sys#ready-queue) ##sys#ready-queue-head)
+
+(define (##sys#add-to-ready-queue thread)
+ (##sys#setslot thread 3 'ready)
+ (let ((new-pair (cons thread '())))
+ (cond ((eq? '() ##sys#ready-queue-head)
+ (set! ##sys#ready-queue-head new-pair))
+ (else (set-cdr! ##sys#ready-queue-tail new-pair)) )
+ (set! ##sys#ready-queue-tail new-pair) ) )
+
+(define (##sys#remove-from-ready-queue)
+ (let ((first-pair ##sys#ready-queue-head))
+ (and (not (null? first-pair))
+ (let ((first-cdr (cdr first-pair)))
+ (set! ##sys#ready-queue-head first-cdr)
+ (when (eq? '() first-cdr) (set! ##sys#ready-queue-tail '()))
+ (car first-pair) ) ) ) )
+
+(define (##sys#update-thread-state-buffer thread)
+ (let ([buf (##sys#slot thread 5)])
+ (##sys#setslot buf 0 ##sys#dynamic-winds)
+ (##sys#setslot buf 1 ##sys#standard-input)
+ (##sys#setslot buf 2 ##sys#standard-output)
+ (##sys#setslot buf 3 ##sys#standard-error)
+ (##sys#setslot buf 4 ##sys#current-exception-handler)
+ (##sys#setslot buf 5 ##sys#current-parameter-vector) ) )
+
+(define (##sys#restore-thread-state-buffer thread)
+ (let ([buf (##sys#slot thread 5)])
+ (set! ##sys#dynamic-winds (##sys#slot buf 0))
+ (set! ##sys#standard-input (##sys#slot buf 1))
+ (set! ##sys#standard-output (##sys#slot buf 2))
+ (set! ##sys#standard-error (##sys#slot buf 3))
+ (set! ##sys#current-exception-handler (##sys#slot buf 4))
+ (set! ##sys#current-parameter-vector (##sys#slot buf 5)) ) )
+
+(set! ##sys#interrupt-hook
+ (let ([oldhook ##sys#interrupt-hook])
+ (lambda (reason state)
+ (when (fx= reason 255) ; C_TIMER_INTERRUPT_NUMBER
+ (let ([ct ##sys#current-thread])
+ (##sys#setslot ct 1 (lambda () (oldhook reason state)))
+ (##sys#schedule) ) ) ; expected not to return!
+ (oldhook reason state) ) ) )
+
+(define ##sys#timeout-list '())
+
+(define (##sys#remove-from-timeout-list t)
+ (let loop ((l ##sys#timeout-list) (prev #f))
+ (if (null? l)
+ l
+ (let ((h (##sys#slot l 0))
+ (r (##sys#slot l 1)))
+ (if (eq? (##sys#slot h 1) t)
+ (if prev
+ (set-cdr! prev r)
+ (set! ##sys#timeout-list r))
+ (loop r l))))))
+
+(define (##sys#thread-block-for-timeout! t tm)
+ (dbg t " blocks for " tm)
+ ;; This should really use a balanced tree:
+ (let loop ([tl ##sys#timeout-list] [prev #f])
+ (if (or (null? tl) (< tm (caar tl)))
+ (if prev
+ (set-cdr! prev (cons (cons tm t) tl))
+ (set! ##sys#timeout-list (cons (cons tm t) tl)) )
+ (loop (cdr tl) tl) ) )
+ (##sys#setslot t 3 'blocked)
+ (##sys#setislot t 13 #f)
+ (##sys#setislot t 4 tm) )
+
+(define (##sys#thread-block-for-termination! t t2)
+ (dbg t " blocks for " t2)
+ (let ([state (##sys#slot t2 3)])
+ (unless (or (eq? state 'dead) (eq? state 'terminated))
+ (##sys#setslot t2 12 (cons t (##sys#slot t2 12)))
+ (##sys#setslot t 3 'blocked)
+ (##sys#setislot t 13 #f)
+ (##sys#setslot t 11 t2) ) ) )
+
+(define (##sys#thread-kill! t s)
+ (dbg "killing: " t " -> " s ", recipients: " (##sys#slot t 12))
+ (##sys#abandon-mutexes t)
+ (##sys#setslot t 3 s)
+ (##sys#setislot t 4 #f)
+ (##sys#setislot t 11 #f)
+ (##sys#setislot t 8 '())
+ (##sys#remove-from-timeout-list t)
+ (let ([rs (##sys#slot t 12)])
+ (unless (null? rs)
+ (for-each
+ (lambda (t2)
+ (dbg " checking: " t2 " (" (##sys#slot t2 3) ") -> " (##sys#slot t2 11))
+ (when (eq? (##sys#slot t2 11) t)
+ (##sys#thread-basic-unblock! t2) ) )
+ rs) ) )
+ (##sys#setislot t 12 '()) )
+
+(define (##sys#thread-basic-unblock! t)
+ (dbg "unblocking: " t)
+ (##sys#setislot t 11 #f)
+ (##sys#setislot t 4 #f)
+ (##sys#add-to-ready-queue t) )
+
+(define ##sys#default-exception-handler
+ (let ([print-error-message print-error-message]
+ [display display]
+ [print-call-chain print-call-chain]
+ [open-output-string open-output-string]
+ [get-output-string get-output-string] )
+ (lambda (arg)
+ (let ([ct ##sys#current-thread])
+ (dbg "exception: " ct " -> " (if (##sys#structure? arg 'condition) (##sys#slot arg 2) arg))
+ (cond [(foreign-value "C_abort_on_thread_exceptions" bool)
+ (let* ([pt ##sys#primordial-thread]
+ [ptx (##sys#slot pt 1)] )
+ (##sys#setslot
+ pt 1
+ (lambda ()
+ (##sys#signal arg)
+ (ptx) ) )
+ (##sys#thread-unblock! pt) ) ]
+ [##sys#warnings-enabled
+ (let ([o (open-output-string)])
+ (display "Warning (" o)
+ (display ct o)
+ (display "): " o)
+ (print-error-message arg ##sys#standard-error (get-output-string o))
+ (print-call-chain ##sys#standard-error 0 ct) ) ] )
+ (##sys#setslot ct 7 arg)
+ (##sys#thread-kill! ct 'terminated)
+ (##sys#schedule) ) ) ) )
+
+
+;;; `select()'-based blocking:
+
+(define ##sys#fd-list '())
+
+(define ##sys#fdset-select-timeout
+ (foreign-lambda* int ([bool to] [unsigned-long tm])
+ "struct timeval timeout;"
+ "timeout.tv_sec = tm / 1000;"
+ "timeout.tv_usec = (tm % 1000) * 1000;"
+ "C_fdset_input_2 = C_fdset_input;"
+ "C_fdset_output_2 = C_fdset_output;"
+ "return(select(FD_SETSIZE, &C_fdset_input, &C_fdset_output, NULL, to ? &timeout : NULL));") )
+
+(define ##sys#fdset-restore
+ (foreign-lambda* void ()
+ "C_fdset_input = C_fdset_input_2;"
+ "C_fdset_output = C_fdset_output_2;") )
+
+((foreign-lambda* void ()
+ "FD_ZERO(&C_fdset_input);"
+ "FD_ZERO(&C_fdset_output);") )
+
+(define ##sys#fdset-input-set
+ (foreign-lambda* void ([int fd])
+ "FD_SET(fd, &C_fdset_input);" ) )
+
+(define ##sys#fdset-output-set
+ (foreign-lambda* void ([int fd])
+ "FD_SET(fd, &C_fdset_output);" ) )
+
+(define ##sys#fdset-clear
+ (foreign-lambda* void ([int fd])
+ "FD_CLR(fd, &C_fdset_input_2);"
+ "FD_CLR(fd, &C_fdset_output_2);") )
+
+(define (##sys#thread-block-for-i/o! t fd i/o)
+ (dbg t " blocks for I/O " fd)
+ (let loop ([lst ##sys#fd-list])
+ (if (null? lst)
+ (set! ##sys#fd-list (cons (list fd t) ##sys#fd-list))
+ (let ([a (car lst)])
+ (if (fx= fd (car a))
+ (##sys#setslot a 1 (cons t (cdr a)))
+ (loop (cdr lst)) ) ) ) )
+ (case i/o
+ ((#t #:input) (##sys#fdset-input-set fd))
+ ((#f #:output) (##sys#fdset-output-set fd))
+ ((#:all)
+ (##sys#fdset-input-set fd)
+ (##sys#fdset-output-set fd) ) )
+ (##sys#setslot t 3 'blocked)
+ (##sys#setislot t 13 #f)
+ (##sys#setslot t 11 (cons fd i/o)) )
+
+(define (##sys#unblock-threads-for-i/o)
+ (dbg "fd-list: " ##sys#fd-list)
+ (let* ([to? (pair? ##sys#timeout-list)]
+ [rq? (pair? ##sys#ready-queue-head)]
+ [n (##sys#fdset-select-timeout ; we use FD_SETSIZE, but really should use max fd
+ (or rq? to?)
+ (if (and to? (not rq?)) ; no thread was unblocked by timeout, so wait
+ (let* ([tmo1 (caar ##sys#timeout-list)]
+ [now (##sys#fudge 16)])
+ (fxmax 0 (- tmo1 now)) )
+ 0) ) ] ) ; otherwise immediate timeout.
+ (dbg n " fds ready")
+ (cond [(eq? -1 n)
+ (##sys#force-primordial)]
+ [(fx> n 0)
+ (set! ##sys#fd-list
+ (let loop ([n n] [lst ##sys#fd-list])
+ (if (or (zero? n) (null? lst))
+ lst
+ (let* ([a (car lst)]
+ [fd (car a)]
+ [inf (##core#inline "C_fd_test_input" fd)]
+ [outf (##core#inline "C_fd_test_output" fd)] )
+ (dbg "fd " fd " ready: input=" inf ", output=" outf)
+ (if (or inf outf)
+ (let loop2 ([threads (cdr a)])
+ (if (null? threads)
+ (begin
+ (##sys#fdset-clear fd)
+ (loop (sub1 n) (cdr lst)) )
+ (let* ([t (car threads)]
+ [p (##sys#slot t 11)] )
+ (when (and (pair? p)
+ (eq? fd (car p))
+ (not (##sys#slot t 13) ) ) ; not unblocked by timeout
+ (##sys#thread-basic-unblock! t) )
+ (loop2 (cdr threads)) ) ) )
+ (cons a (loop n (cdr lst))) ) ) ) ) ) ] )
+ (##sys#fdset-restore) ) )
+
+
+;;; Clear I/O state for unblocked thread
+
+(define (##sys#clear-i/o-state-for-thread! t)
+ (when (pair? (##sys#slot t 11))
+ (let ((fd (##sys#slot (##sys#slot t 11) 0)))
+ (set! ##sys#fd-list
+ (let loop ([lst ##sys#fd-list])
+ (if (null? lst)
+ '()
+ (let* ([a (##sys#slot lst 0)]
+ [fd2 (##sys#slot a 0)] )
+ (if (eq? fd fd2)
+ (let ((ts (##sys#delq t (##sys#slot a 1)))) ; remove from fd-list entry
+ (cond ((null? ts)
+ ;;(pp `(CLEAR FD: ,fd ,t) ##sys#standard-error)
+ (##sys#fdset-clear fd) ; no more threads waiting for this fd
+ (##sys#fdset-restore)
+ (##sys#slot lst 1) )
+ (else
+ (##sys#setslot a 1 ts) ; fd-list entry is list with t removed
+ lst) ) )
+ (cons a (loop (##sys#slot lst 1)))))))))))
+
+
+;;; Get list of all threads that are ready or waiting for timeout or waiting for I/O:
+;
+; (contributed by Joerg Wittenberger)
+
+(define (##sys#all-threads #!optional
+ (cns (lambda (queue arg val init)
+ (cons val init)))
+ (init '()))
+ (let loop ((l ##sys#ready-queue-head) (i init))
+ (if (pair? l)
+ (loop (cdr l) (cns 'ready #f (car l) i))
+ (let loop ((l ##sys#fd-list) (i i))
+ (if (pair? l)
+ (loop (cdr l)
+ (let ((fd (caar l)))
+ (let loop ((l (cdar l)))
+ (if (null? l) i
+ (cns 'i/o fd (car l) (loop (cdr l)))))))
+ (let loop ((l ##sys#timeout-list) (i i))
+ (if (pair? l)
+ (loop (cdr l) (cns 'timeout (caar l) (cdar l) i))
+ i)))))))
+
+
+;;; Remove all waiting threads from the relevant queues with the exception of the current thread:
+
+(define (##sys#fetch-and-clear-threads)
+ (let ([all (vector ##sys#ready-queue-head ##sys#ready-queue-tail ##sys#fd-list ##sys#timeout-list)])
+ (set! ##sys#ready-queue-head '())
+ (set! ##sys#ready-queue-tail '())
+ (set! ##sys#fd-list '())
+ (set! ##sys#timeout-list '())
+ all) )
+
+
+;;; Restore list of waiting threads:
+
+(define (##sys#restore-threads vec)
+ (set! ##sys#ready-queue-head (##sys#slot vec 0))
+ (set! ##sys#ready-queue-tail (##sys#slot vec 1))
+ (set! ##sys#fd-list (##sys#slot vec 2))
+ (set! ##sys#timeout-list (##sys#slot vec 3)) )
+
+
+;;; Unblock thread cleanly:
+
+(define (##sys#thread-unblock! t)
+ (when (eq? 'blocked (##sys#slot t 3))
+ (##sys#remove-from-timeout-list t)
+ (set! ##sys#fd-list
+ (let loop ([fdl ##sys#fd-list])
+ (if (null? fdl)
+ '()
+ (let ([a (##sys#slot fdl 0)])
+ (cons
+ (cons (##sys#slot a 0)
+ (##sys#delq t (##sys#slot a 1)) )
+ (loop (##sys#slot fdl 1)) ) ) ) ) )
+ (##sys#setislot t 12 '())
+ (##sys#thread-basic-unblock! t) ) )
+
+
+;;; Multithreaded breakpoints
+
+(define (##sys#break-entry name args)
+ (when (or (not ##sys#break-in-thread) (eq? ##sys#break-in-thread ##sys#current-thread))
+ (##sys#call-with-current-continuation
+ (lambda (k)
+ (let* ((pk (if (eq? ##sys#current-thread ##sys#primordial-thread)
+ '()
+ (list '(exn . thread) ##sys#current-thread
+ '(exn . primordial-continuation)
+ (lambda _ ((##sys#slot ##sys#primordial-thread 1))))))
+ (exn (##sys#make-structure
+ 'condition
+ '(exn breakpoint)
+ (append
+ (list '(exn . message) "*** breakpoint ***"
+ '(exn . arguments) (cons name args)
+ '(exn . location) name
+ '(exn . continuation) k)
+ pk) ) ) )
+ (set! ##sys#last-breakpoint exn)
+ (cond ((eq? ##sys#current-thread ##sys#primordial-thread)
+ (##sys#signal exn) )
+ (else
+ (##sys#setslot ##sys#current-thread 3 'suspended)
+ (##sys#setslot ##sys#current-thread 1 (lambda () (k (##core#undefined))))
+ (let ([old (##sys#slot ##sys#primordial-thread 1)])
+ (##sys#setslot
+ ##sys#primordial-thread 1
+ (lambda ()
+ (##sys#signal exn)
+ (old) ) )
+ (##sys#thread-unblock! ##sys#primordial-thread)
+ (##sys#schedule) ) ) ) ) ) ) ) )
+
+(define (##sys#break-resume exn)
+ ;; assumes current-thread is primordial
+ (let* ((props (##sys#slot exn 2))
+ (a (member '(exn . continuation) props))
+ (t (member '(exn . thread) props))
+ (pk (or (member '(exn . primordial-continuation) props) a)))
+ (when t
+ (let ((t (cadr t)))
+ (if a
+ (##sys#setslot t 1 (lambda () ((cadr a) (##core#undefined))))
+ (##sys#signal-hook #:type-error "condition has no continuation" exn) )
+ (##sys#add-to-ready-queue t) ) )
+ (if pk
+ ((cadr pk) (##core#undefined))
+ (##sys#signal-hook #:type-error "condition has no continuation" exn) ) ) )
diff --git a/scheme-complete.el b/scheme-complete.el
new file mode 100644
index 00000000..24814fab
--- /dev/null
+++ b/scheme-complete.el
@@ -0,0 +1,4412 @@
+;;; scheme-complete.el -*- Emacs-Lisp -*-
+
+;;; Smart tab completion for Emacs
+
+;;; This code is written by Alex Shinn and placed in the Public
+;;; Domain. All warranties are disclaimed.
+
+;;; This file provides a single function, `scheme-smart-complete',
+;;; which you can use for intelligent, context-sensitive completion
+;;; for any Scheme implementation. To use it just load this file and
+;;; bind that function to a key in your preferred mode:
+;;;
+;;; (autoload 'scheme-smart-complete "scheme-complete" nil t)
+;;; (eval-after-load 'scheme
+;;; '(define-key scheme-mode-map "\e\t" 'scheme-smart-complete))
+;;;
+;;; Alternately, you may want to just bind TAB to the
+;;; `scheme-complete-or-indent' function, which indents at the start
+;;; of a line and otherwise performs the smart completion:
+;;;
+;;; (eval-after-load 'scheme
+;;; '(define-key scheme-mode-map "\t" 'scheme-complete-or-indent))
+;;;
+;;; Note: the completion uses a somewhat less common style than
+;;; typically found in other modes. The first tab will complete the
+;;; longest prefix common to all possible completions. The second
+;;; tab will show a list of those completions. Subsequent tabs will
+;;; scroll that list. You can't use the mouse to select from the
+;;; list - when you see what you want, just type the next one or
+;;; more characters in the symbol you want and hit tab again to
+;;; continue completing it. Any key typed will bury the completion
+;;; list. This ensures you can achieve a completion with the
+;;; minimal number of keystrokes without the completions window
+;;; lingering and taking up space.
+;;;
+;;; If you use eldoc-mode (included in Emacs), you can also get live
+;;; scheme documentation with:
+;;;
+;;; (autoload 'scheme-get-current-symbol-info "scheme-complete" nil t)
+;;; (add-hook 'scheme-mode-hook
+;;; (lambda ()
+;;; (make-local-variable 'eldoc-documentation-function)
+;;; (setq eldoc-documentation-function 'scheme-get-current-symbol-info)
+;;; (eldoc-mode)))
+;;;
+;;; You can enable slightly smarter indentation with
+;;;
+;;; (setq lisp-indent-function 'scheme-smart-indent-function)
+;;;
+;;; which basically ignores the scheme-indent-function property for
+;;; locally overridden symbols (e.g. if you use the (let loop () ...)
+;;; idiom it won't use the special loop indentation inside).
+;;;
+;;; There's a single custom variable, `scheme-default-implementation',
+;;; which you can use to specify your preferred implementation when we
+;;; can't infer it from the source code.
+;;;
+;;; That's all there is to it.
+
+;;; History:
+;;; 0.8.6: 2009/05/03 - fixing support for chicken 4 w/ unbalanced parens
+;;; 0.8.5: 2009/04/30 - full support for chicken 4, fixed bug in caching
+;;; 0.8.4: 2008/12/26 - numerous small bugfixes (Merry Christmas!)
+;;; 0.8.3: 2008/10/06 - smart indent, inferring types from imported modules,
+;;; optionally caching exports, chicken 4 support
+;;; 0.8.2: 2008/07/04 - both TAB and M-TAB scroll results (thanks Peter Bex),
+;;; better MATCH handling, fixed SRFI-55, other bugfixes
+;;; 0.8.1: 2008/04/17 - great renaming, everthing starts with `scheme-'
+;;; also, don't scan imported modules multiple times
+;;; 0.8: 2008/02/08 - several parsing bugfixes on unclosed parenthesis
+;;; (thanks to Kazushi NODA)
+;;; filename completion works properly on absolute paths
+;;; eldoc works properly on dotted lambdas
+;;; 0.7: 2008/01/18 - handles higher-order types (for apply, map, etc.)
+;;; smarter string completion (hostname, username, etc.)
+;;; smarter type inference, various bugfixes
+;;; 0.6: 2008/01/06 - more bugfixes (merry christmas)
+;;; 0.5: 2008/01/03 - handling internal defines, records, smarter
+;;; parsing
+;;; 0.4: 2007/11/14 - silly bugfix plus better repo env support
+;;; for searching chicken and gauche modules
+;;; 0.3: 2007/11/13 - bugfixes, better inference, smart strings
+;;; 0.2: 2007/10/15 - basic type inference
+;;; 0.1: 2007/09/11 - initial release
+;;;
+;;; What is this talk of 'release'? Klingons do not make software
+;;; 'releases'. Our software 'escapes' leaving a bloody trail of
+;;; designers and quality assurance people in its wake.
+
+(require 'cl)
+
+;; this is just to eliminate some warnings when compiling - this file
+;; should be loaded after 'scheme
+(eval-when (compile)
+ (require 'scheme))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; info
+;;
+;; identifier type [doc-string no-type-display?]
+;;
+;; types:
+;;
+;; pair, number, symbol, etc.
+;; (lambda (param-types) [return-type])
+;; (syntax (param-types) [return-type])
+;; (set name values ...)
+;; (flags name values ...)
+;; (list type)
+;; (string expander)
+;; (special type function [outer-function])
+
+(defvar *scheme-r5rs-info*
+ '((define (syntax (identifier value) undefined) "define a new variable")
+ (set! (syntax (identifier value) undefined) "set the value of a variable")
+ (let (syntax (vars body \.\.\.)) "bind new local variables in parallel")
+ (let* (syntax (vars body \.\.\.)) "bind new local variables sequentially")
+ (letrec (syntax (vars body \.\.\.)) "bind new local variables recursively")
+ (lambda (syntax (params body \.\.\.)) "procedure syntax")
+ (if (syntax (cond then else)) "conditional evaluation")
+ (cond (syntax (clause \.\.\.)) "try each clause until one succeeds")
+ (case (syntax (expr clause \.\.\.)) "look for EXPR among literal lists")
+ (delay (syntax (expr)) "create a promise to evaluate EXPR")
+ (and (syntax (expr \.\.\.)) "evaluate EXPRs while true, return last")
+ (or (syntax (expr \.\.\.)) "return the first true EXPR")
+ (begin (syntax (expr \.\.\.)) "evaluate each EXPR in turn and return the last")
+ (do (syntax (vars finish body \.\.\.)) "simple iterator")
+ (quote (syntax (expr)) "represent EXPR literally without evaluating it")
+ (quasiquote (syntax (expr)) "quote literals allowing escapes")
+ (unquote (syntax (expr)) "escape an expression inside quasiquote")
+ (unquote-splicing (syntax (expr)) "escape and splice a list expression inside quasiquote")
+ (define-syntax (syntax (identifier body \.\.\.) undefined) "create a macro")
+ (let-syntax (syntax (syntaxes body \.\.\.)) "a local macro")
+ (letrec-syntax (syntax (syntaxes body \.\.\.)) "a local macro")
+ (syntax-rules (syntax (literals clauses \.\.\.) undefined) "simple macro language")
+ (eqv? (lambda (obj1 obj2) bool) "returns #t if OBJ1 and OBJ2 are the same object")
+ (eq? (lambda (obj1 obj2) bool) "finer grained version of EQV?")
+ (equal? (lambda (obj1 obj2) bool) "recursive equivalence")
+ (not (lambda (obj) bool) "returns #t iff OBJ is false")
+ (boolean? (lambda (obj) bool) "returns #t iff OBJ is #t or #f")
+ (number? (lambda (obj) bool) "returns #t iff OBJ is a number")
+ (complex? (lambda (obj) bool) "returns #t iff OBJ is a complex number")
+ (real? (lambda (obj) bool) "returns #t iff OBJ is a real number")
+ (rational? (lambda (obj) bool) "returns #t iff OBJ is a rational number")
+ (integer? (lambda (obj) bool) "returns #t iff OBJ is an integer")
+ (exact? (lambda (z) bool) "returns #t iff Z is exact")
+ (inexact? (lambda (z) bool) "returns #t iff Z is inexact")
+ (= (lambda (z1 z2 \.\.\.) bool) "returns #t iff the arguments are all equal")
+ (< (lambda (x1 x2 \.\.\.) bool) "returns #t iff the arguments are monotonically increasing")
+ (> (lambda (x1 x2 \.\.\.) bool) "returns #t iff the arguments are monotonically decreasing")
+ (<= (lambda (x1 x2 \.\.\.) bool) "returns #t iff the arguments are monotonically nondecreasing")
+ (>= (lambda (x1 x2 \.\.\.) bool) "returns #t iff the arguments are monotonically nonincreasing")
+ (zero? (lambda (z) bool))
+ (positive? (lambda (x1) bool))
+ (negative? (lambda (x1) bool))
+ (odd? (lambda (n) bool))
+ (even? (lambda (n) bool))
+ (max (lambda (x1 x2 \.\.\.) x3) "returns the maximum of the arguments")
+ (min (lambda (x1 x2 \.\.\.) x3) "returns the minimum of the arguments")
+ (+ (lambda (z1 \.\.\.) z))
+ (* (lambda (z1 \.\.\.) z))
+ (- (lambda (z1 \.\.\.) z))
+ (/ (lambda (z1 \.\.\.) z))
+ (abs (lambda (x1) x2) "returns the absolute value of X")
+ (quotient (lambda (n1 n2) n) "integer division")
+ (remainder (lambda (n1 n2) n) "same sign as N1")
+ (modulo (lambda (n1 n2) n) "same sign as N2")
+ (gcd (lambda (n1 \.\.\.) n) "greatest common divisor")
+ (lcm (lambda (n2 \.\.\.) n) "least common multiple")
+ (numerator (lambda (rational) n))
+ (denominator (lambda (rational) n))
+ (floor (lambda (x1) n) "largest integer not larger than X")
+ (ceiling (lambda (x1) n) "smallest integer not smaller than X")
+ (truncate (lambda (x1) n) "drop fractional part")
+ (round (lambda (x1) n) "round to even (banker's rounding)")
+ (rationalize (lambda (x1 y) n) "rational number differing from X by at most Y")
+ (exp (lambda (z) z) "e^Z")
+ (log (lambda (z) z) "natural logarithm of Z")
+ (sin (lambda (z) z) "sine function")
+ (cos (lambda (z) z) "cosine function")
+ (tan (lambda (z) z) "tangent function")
+ (asin (lambda (z) z) "arcsine function")
+ (acos (lambda (z) z) "arccosine function")
+ (atan (lambda (z) z) "arctangent function")
+ (sqrt (lambda (z) z) "principal square root of Z")
+ (expt (lambda (z1 z2) z) "returns Z1 raised to the Z2 power")
+ (make-rectangular (lambda (x1 x2) z) "create a complex number")
+ (make-polar (lambda (x1 x2) z) "create a complex number")
+ (real-part (lambda (z) x1))
+ (imag-part (lambda (z) x1))
+ (magnitude (lambda (z) x1))
+ (angle (lambda (z) x1))
+ (exact->inexact (lambda (z) z))
+ (inexact->exact (lambda (z) z))
+ (number->string (lambda (z :optional radix) str))
+ (string->number (lambda (str :optional radix) z))
+ (pair? (lambda (obj) bool) "returns #t iff OBJ is a pair")
+ (cons (lambda (obj1 obj2) pair) "create a newly allocated pair")
+ (car (lambda (pair) obj))
+ (cdr (lambda (pair) obj))
+ (set-car! (lambda (pair obj) undefined))
+ (set-cdr! (lambda (pair obj) undefined))
+ (caar (lambda (pair) obj))
+ (cadr (lambda (pair) obj))
+ (cdar (lambda (pair) obj))
+ (cddr (lambda (pair) obj))
+ (caaar (lambda (pair) obj))
+ (caadr (lambda (pair) obj))
+ (cadar (lambda (pair) obj))
+ (caddr (lambda (pair) obj))
+ (cdaar (lambda (pair) obj))
+ (cdadr (lambda (pair) obj))
+ (cddar (lambda (pair) obj))
+ (cdddr (lambda (pair) obj))
+ (caaaar (lambda (pair) obj))
+ (caaadr (lambda (pair) obj))
+ (caadar (lambda (pair) obj))
+ (caaddr (lambda (pair) obj))
+ (cadaar (lambda (pair) obj))
+ (cadadr (lambda (pair) obj))
+ (caddar (lambda (pair) obj))
+ (cadddr (lambda (pair) obj))
+ (cdaaar (lambda (pair) obj))
+ (cdaadr (lambda (pair) obj))
+ (cdadar (lambda (pair) obj))
+ (cdaddr (lambda (pair) obj))
+ (cddaar (lambda (pair) obj))
+ (cddadr (lambda (pair) obj))
+ (cdddar (lambda (pair) obj))
+ (cddddr (lambda (pair) obj))
+ (null? (lambda (obj) bool) "returns #t iff OBJ is the empty list")
+ (list? (lambda (obj) bool) "returns #t iff OBJ is a proper list")
+ (list (lambda (obj \.\.\.) list) "returns a newly allocated list")
+ (length (lambda (list) n))
+ (append (lambda (list \.\.\.) list) "concatenates the list arguments")
+ (reverse (lambda (list) list))
+ (list-tail (lambda (list k) list) "returns the Kth cdr of LIST")
+ (list-ref (lambda (list k) obj) "returns the Kth element of LIST")
+ (memq (lambda (obj list)) "the sublist of LIST whose car is eq? to OBJ")
+ (memv (lambda (obj list)) "the sublist of LIST whose car is eqv? to OBJ")
+ (member (lambda (obj list)) "the sublist of LIST whose car is equal? to OBJ")
+ (assq (lambda (obj list)) "the element of LIST whose car is eq? to OBJ")
+ (assv (lambda (obj list)) "the element of LIST whose car is eqv? to OBJ")
+ (assoc (lambda (obj list)) "the element of LIST whose car is equal? to OBJ")
+ (symbol? (lambda (obj) bool) "returns #t iff OBJ is a symbol")
+ (symbol->string (lambda (symbol) str))
+ (string->symbol (lambda (str) symbol))
+ (char? (lambda (obj) bool) "returns #t iff OBJ is a character")
+ (char=? (lambda (ch1 ch2) bool))
+ (char<? (lambda (ch1 ch2) bool))
+ (char>? (lambda (ch1 ch2) bool))
+ (char<=? (lambda (ch1 ch2) bool))
+ (char>=? (lambda (ch1 ch2) bool))
+ (char-ci=? (lambda (ch1 ch2) bool))
+ (char-ci<? (lambda (ch1 ch2) bool))
+ (char-ci>? (lambda (ch1 ch2) bool))
+ (char-ci<=? (lambda (ch1 ch2) bool))
+ (char-ci>=? (lambda (ch1 ch2) bool))
+ (char-alphabetic? (lambda (ch) bool))
+ (char-numeric? (lambda (ch) bool))
+ (char-whitespace? (lambda (ch) bool))
+ (char-upper-case? (lambda (ch) bool))
+ (char-lower-case? (lambda (ch) bool))
+ (char->integer (lambda (ch) int))
+ (integer->char (lambda (int) ch))
+ (char-upcase (lambda (ch) ch))
+ (char-downcase (lambda (ch) ch))
+ (string? (lambda (obj) bool) "returns #t iff OBJ is a string")
+ (make-string (lambda (k :optional ch) str) "a new string of length k")
+ (string (lambda (ch \.\.\.) str) "a new string made of the char arguments")
+ (string-length (lambda (str) n) "the number of characters in STR")
+ (string-ref (lambda (str i) ch) "the Ith character of STR")
+ (string-set! (lambda (str i ch) undefined) "set the Ith character of STR to CH")
+ (string=? (lambda (str1 str2) bool))
+ (string-ci=? (lambda (str1 str2) bool))
+ (string<? (lambda (str1 str2) bool))
+ (string>? (lambda (str1 str2) bool))
+ (string<=? (lambda (str1 str2) bool))
+ (string>=? (lambda (str1 str2) bool))
+ (string-ci<? (lambda (str1 str2) bool))
+ (string-ci>? (lambda (str1 str2) bool))
+ (string-ci<=? (lambda (str1 str2) bool))
+ (string-ci>=? (lambda (str1 str2) bool))
+ (substring (lambda (str start end) str))
+ (string-append (lambda (str \.\.\.) str) "concatenate the string arguments")
+ (string->list (lambda (str) list))
+ (list->string (lambda (list) str))
+ (string-copy (lambda (str) str))
+ (string-fill! (lambda (str ch) undefined) "set every char in STR to CH")
+ (vector? (lambda (obj) bool) "returns #t iff OBJ is a vector")
+ (make-vector (lambda (len :optional fill) vec) "a new vector of K elements")
+ (vector (lambda (obj \.\.\.) vec))
+ (vector-length (lambda (vec) n) "the number of elements in VEC")
+ (vector-ref (lambda (vec i) obj) "the Ith element of VEC")
+ (vector-set! (lambda (vec i obj) undefined) "set the Ith element of VEC to OBJ")
+ (vector->list (lambda (vec) list))
+ (list->vector (lambda (list) vec))
+ (vector-fill! (lambda (vec obj) undefined) "set every element in VEC to OBJ")
+ (procedure? (lambda (obj) bool) "returns #t iff OBJ is a procedure")
+ (apply (lambda ((lambda obj a) obj \.\.\.) a) "procedure application")
+ (map (lambda ((lambda (obj1 . obj2) a) list \.\.\.) (list a)) "a new list of PROC applied to every element of LIST")
+ (for-each (lambda ((lambda obj a) obj \.\.\.) undefined) "apply PROC to each element of LIST in order")
+ (force (lambda (promise) obj) "force the delayed value of PROMISE")
+ (call-with-current-continuation (lambda (proc) obj) "goto on steroids")
+ (values (lambda (obj \.\.\.)) "send multiple values to the calling continuation")
+ (call-with-values (lambda (producer consumer) obj))
+ (dynamic-wind (lambda (before-thunk thunk after-thunk) obj))
+ (scheme-report-environment (lambda (int) env) "INT should be 5")
+ (null-environment (lambda (int) env) "INT should be 5")
+ (call-with-input-file (lambda (path proc) input-port))
+ (call-with-output-file (lambda (path proc) output-port))
+ (input-port? (lambda (obj) bool) "returns #t iff OBJ is an input port")
+ (output-port? (lambda (obj) bool) "returns #t iff OBJ is an output port")
+ (current-input-port (lambda () input-port) "the default input for read procedures")
+ (current-output-port (lambda () output-port) "the default output for write procedures")
+ (with-input-from-file (lambda (path thunk) obj))
+ (with-output-to-file (lambda (path thunk) obj))
+ (open-input-file (lambda (path) input-port))
+ (open-output-file (lambda (path) output-port))
+ (close-input-port (lambda (input-port)))
+ (close-output-port (lambda (output-port)))
+ (read (lambda (:optional input-port) obj) "read a datum")
+ (read-char (lambda (:optional input-port) ch) "read a single character")
+ (peek-char (lambda (:optional input-port) ch))
+ (eof-object? (lambda (obj) bool) "returns #t iff OBJ is the end-of-file object")
+ (char-ready? (lambda (:optional input-port) bool))
+ (write (lambda (object :optional output-port) undefined) "write a datum")
+ (display (lambda (object :optional output-port) undefined) "display")
+ (newline (lambda (:optional output-port) undefined) "send a linefeed")
+ (write-char (lambda (char :optional output-port) undefined) "write a single character")
+ (load (lambda (filename) undefined) "evaluate expressions from a file")
+ (eval (lambda (expr env)))
+ ))
+
+(defvar *scheme-srfi-info*
+ [
+ ;; SRFI 0
+ ("Feature-based conditional expansion construct"
+ (cond-expand (syntax (clause \.\.\.))))
+
+ ;; SRFI 1
+ ("List Library"
+ (xcons (lambda (object object) pair))
+ (cons* (lambda (object \.\.\.) pair))
+ (make-list (lambda (integer :optional object) list))
+ (list-tabulate (lambda (integer procedure) list))
+ (list-copy (lambda (list) list))
+ (circular-list (lambda (object \.\.\.) list))
+ (iota (lambda (integer :optional integer integer) list))
+ (proper-list? (lambda (object) bool))
+ (circular-list? (lambda (object) bool))
+ (dotted-list? (lambda (object) bool))
+ (not-pair? (lambda (object) bool))
+ (null-list? (lambda (object) bool))
+ (list= (lambda (procedure list \.\.\.) bool))
+ (first (lambda (pair)))
+ (second (lambda (pair)))
+ (third (lambda (pair)))
+ (fourth (lambda (pair)))
+ (fifth (lambda (pair)))
+ (sixth (lambda (pair)))
+ (seventh (lambda (pair)))
+ (eighth (lambda (pair)))
+ (ninth (lambda (pair)))
+ (tenth (lambda (pair)))
+ (car+cdr (lambda (pair)))
+ (take (lambda (pair integer) list))
+ (drop (lambda (pair integer) list))
+ (take-right (lambda (pair integer) list))
+ (drop-right (lambda (pair integer) list))
+ (take! (lambda (pair integer) list))
+ (drop-right! (lambda (pair integer) list))
+ (split-at (lambda (pair integer) list))
+ (split-at! (lambda (pair integer) list))
+ (last (lambda (pair) obj))
+ (last-pair (lambda (pair) pair))
+ (length+ (lambda (object) n))
+ (concatenate (lambda (list) list))
+ (append! (lambda (list \.\.\.) list))
+ (concatenate! (lambda (list) list))
+ (reverse! (lambda (list) list))
+ (append-reverse (lambda (list list) list))
+ (append-reverse! (lambda (list list) list))
+ (zip (lambda (list \.\.\.) list))
+ (unzip1 (lambda (list) list))
+ (unzip2 (lambda (list) list))
+ (unzip3 (lambda (list) list))
+ (unzip4 (lambda (list) list))
+ (unzip5 (lambda (list) list))
+ (count (lambda ((lambda (obj1 . obj2)) list \.\.\.) n))
+ (fold (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
+ (unfold (lambda (procedure procedure procedure object :optional procedure) obj))
+ (pair-fold (lambda ((lambda obj a) object list \.\.\.) a))
+ (reduce (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
+ (fold-right (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
+ (unfold-right (lambda (procedure procedure procedure object :optional object) obj))
+ (pair-fold-right (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
+ (reduce-right (lambda ((lambda (obj1 obj2 . obj3) a) object list \.\.\.) a))
+ (append-map (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
+ (append-map! (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
+ (map! (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
+ (pair-for-each (lambda ((lambda (obj1 . obj2)) list \.\.\.) undefined))
+ (filter-map (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
+ (map-in-order (lambda ((lambda (obj1 . obj2)) list \.\.\.) list))
+ (filter (lambda ((lambda (obj1 . obj2)) list) list))
+ (partition (lambda ((lambda (obj) bool) list) list))
+ (remove (lambda ((lambda (obj1) bool) list) list))
+ (filter! (lambda ((lambda (obj1) bool) list) list))
+ (partition! (lambda ((lambda (obj1) bool) list) list))
+ (remove! (lambda ((lambda (obj1) bool) list) list))
+ (find (lambda ((lambda (obj1) bool) list) obj))
+ (find-tail (lambda ((lambda (obj1) bool) list) obj))
+ (any (lambda ((lambda (obj1 . obj2) a) list \.\.\.) a))
+ (every (lambda ((lambda (obj1 . obj2) a) list \.\.\.) a))
+ (list-index (lambda ((lambda (obj1 . obj2)) list \.\.\.) (or bool integer)))
+ (take-while (lambda ((lambda (obj)) list) list))
+ (drop-while (lambda ((lambda (obj)) list) list))
+ (take-while! (lambda ((lambda (obj)) list) list))
+ (span (lambda ((lambda (obj)) list) list))
+ (break (lambda ((lambda (obj)) list) list))
+ (span! (lambda ((lambda (obj)) list) list))
+ (break! (lambda ((lambda (obj)) list) list))
+ (delete (lambda (object list :optional procedure) list))
+ (delete-duplicates (lambda (list :optional procedure) list))
+ (delete! (lambda (obj list :optional procedure) list))
+ (delete-duplicates! (lambda (list :optional procedure) list))
+ (alist-cons (lambda (obj1 obj2 alist) alist))
+ (alist-copy (lambda (alist) alist))
+ (alist-delete (lambda (obj alist) alist))
+ (alist-delete! (lambda (obj alist) alist))
+ (lset<= (lambda (procedure list \.\.\.) bool))
+ (lset= (lambda (procedure list \.\.\.) bool))
+ (lset-adjoin (lambda (procedure list object \.\.\.) list))
+ (lset-union (lambda (procedure list \.\.\.) list))
+ (lset-union! (lambda (procedure list \.\.\.) list))
+ (lset-intersection (lambda (procedure list \.\.\.) list))
+ (lset-intersection! (lambda (procedure list \.\.\.) list))
+ (lset-difference (lambda (procedure list \.\.\.) list))
+ (lset-difference! (lambda (procedure list \.\.\.) list))
+ (lset-xor (lambda (procedure list \.\.\.) list))
+ (lset-xor! (lambda (procedure list \.\.\.) list))
+ (lset-diff+intersection (lambda (procedure list \.\.\.) list))
+ (lset-diff+intersection! (lambda (procedure list \.\.\.) list))
+
+ )
+
+ ;; SRFI 2
+ ("AND-LET*: an AND with local bindings, a guarded LET* special form"
+ (and-let* (syntax (bindings body \.\.\.))))
+
+ ()
+
+ ;; SRFI 4
+ ("Homogeneous numeric vector datatypes"
+
+ (u8vector? (lambda (obj) bool))
+ (make-u8vector (lambda (size integer) u8vector))
+ (u8vector (lambda (integer \.\.\.) u8vector))
+ (u8vector-length (lambda (u8vector) n))
+ (u8vector-ref (lambda (u8vector i) int))
+ (u8vector-set! (lambda (u8vector i u8value) undefined))
+ (u8vector->list (lambda (u8vector) list))
+ (list->u8vector (lambda (list) u8vector))
+
+ (s8vector? (lambda (obj) bool))
+ (make-s8vector (lambda (size integer) s8vector))
+ (s8vector (lambda (integer \.\.\.) s8vector))
+ (s8vector-length (lambda (s8vector) n))
+ (s8vector-ref (lambda (s8vector i) int))
+ (s8vector-set! (lambda (s8vector i s8value) undefined))
+ (s8vector->list (lambda (s8vector) list))
+ (list->s8vector (lambda (list) s8vector))
+
+ (u16vector? (lambda (obj) bool))
+ (make-u16vector (lambda (size integer) u16vector))
+ (u16vector (lambda (integer \.\.\.)))
+ (u16vector-length (lambda (u16vector) n))
+ (u16vector-ref (lambda (u16vector i) int))
+ (u16vector-set! (lambda (u16vector i u16value) undefined))
+ (u16vector->list (lambda (u16vector) list))
+ (list->u16vector (lambda (list) u16vector))
+
+ (s16vector? (lambda (obj) bool))
+ (make-s16vector (lambda (size integer) s16vector))
+ (s16vector (lambda (integer \.\.\.) s16vector))
+ (s16vector-length (lambda (s16vector) n))
+ (s16vector-ref (lambda (s16vector i) int))
+ (s16vector-set! (lambda (s16vector i s16value) undefined))
+ (s16vector->list (lambda (s16vector) list))
+ (list->s16vector (lambda (list) s16vector))
+
+ (u32vector? (lambda (obj) bool))
+ (make-u32vector (lambda (size integer) u32vector))
+ (u32vector (lambda (integer \.\.\.) u32vector))
+ (u32vector-length (lambda (u32vector) n))
+ (u32vector-ref (lambda (u32vector i) int))
+ (u32vector-set! (lambda (u32vector i u32value) undefined))
+ (u32vector->list (lambda (u32vector) list))
+ (list->u32vector (lambda (list) u32vector))
+
+ (s32vector? (lambda (obj) bool))
+ (make-s32vector (lambda (size integer) s32vector))
+ (s32vector (lambda (integer \.\.\.) s32vector))
+ (s32vector-length (lambda (s32vector) n))
+ (s32vector-ref (lambda (s32vector i) int))
+ (s32vector-set! (lambda (s32vector i s32value) undefined))
+ (s32vector->list (lambda (s32vector) list))
+ (list->s32vector (lambda (list) s32vector))
+
+ (u64vector? (lambda (obj) bool))
+ (make-u64vector (lambda (size integer) u64vector))
+ (u64vector (lambda (integer \.\.\.) u64vector))
+ (u64vector-length (lambda (u64vector) n))
+ (u64vector-ref (lambda (u64vector i) int))
+ (u64vector-set! (lambda (u64vector i u64value) undefined))
+ (u64vector->list (lambda (u64vector) list))
+ (list->u64vector (lambda (list) u64vector))
+
+ (s64vector? (lambda (obj) bool))
+ (make-s64vector (lambda (size integer) s64vector))
+ (s64vector (lambda (integer \.\.\.) s64vector))
+ (s64vector-length (lambda (s64vector) n))
+ (s64vector-ref (lambda (s64vector i) int))
+ (s64vector-set! (lambda (s64vector i s64value) undefined))
+ (s64vector->list (lambda (s64vector) list))
+ (list->s64vector (lambda (list) s64vector))
+
+ (f32vector? (lambda (obj) bool))
+ (make-f32vector (lambda (size integer) f32vector))
+ (f32vector (lambda (number \.\.\.) f32vector))
+ (f32vector-length (lambda (f32vector) n))
+ (f32vector-ref (lambda (f32vector i) int))
+ (f32vector-set! (lambda (f32vector i f32value) undefined))
+ (f32vector->list (lambda (f32vector) list))
+ (list->f32vector (lambda (list) f32vector))
+
+ (f64vector? (lambda (obj) bool))
+ (make-f64vector (lambda (size integer) f64vector))
+ (f64vector (lambda (number \.\.\.) f64vector))
+ (f64vector-length (lambda (f64vector) n))
+ (f64vector-ref (lambda (f64vector i) int))
+ (f64vector-set! (lambda (f64vector i f64value) undefined))
+ (f64vector->list (lambda (f64vector) list))
+ (list->f64vector (lambda (list) f64vector))
+ )
+
+ ;; SRFI 5
+ ("A compatible let form with signatures and rest arguments"
+ (let (syntax (bindings body \.\.\.))))
+
+ ;; SRFI 6
+ ("Basic String Ports"
+ (open-input-string (lambda (str) input-port))
+ (open-output-string (lambda () output-port))
+ (get-output-string (lambda (output-port) str)))
+
+ ;; SRFI 7
+ ("Feature-based program configuration language"
+ (program (syntax (clause \.\.\.)))
+ (feature-cond (syntax (clause))))
+
+ ;; SRFI 8
+ ("receive: Binding to multiple values"
+ (receive (syntax (identifiers producer body \.\.\.))))
+
+ ;; SRFI 9
+ ("Defining Record Types"
+ (define-record-type (syntax (name constructor-name pred-name fields \.\.\.))))
+
+ ;; SRFI 10
+ ("Sharp-Comma External Form"
+ (define-reader-ctor (syntax (name proc) undefined)))
+
+ ;; SRFI 11
+ ("Syntax for receiving multiple values"
+ (let-values (syntax (bindings body \.\.\.)))
+ (let-values* (syntax (bindings body \.\.\.))))
+
+ ()
+
+ ;; SRFI 13
+ ("String Library"
+ (string-map (lambda (proc str :optional start end) str))
+ (string-map! (lambda (proc str :optional start end) undefined))
+ (string-fold (lambda (kons knil str :optional start end) obj))
+ (string-fold-right (lambda (kons knil str :optional start end) obj))
+ (string-unfold (lambda (p f g seed :optional base make-final) str))
+ (string-unfold-right (lambda (p f g seed :optional base make-final) str))
+ (string-tabulate (lambda (proc len) str))
+ (string-for-each (lambda (proc str :optional start end) undefined))
+ (string-for-each-index (lambda (proc str :optional start end) undefined))
+ (string-every (lambda (pred str :optional start end) obj))
+ (string-any (lambda (pred str :optional start end) obj))
+ (string-hash (lambda (str :optional bound start end) int))
+ (string-hash-ci (lambda (str :optional bound start end) int))
+ (string-compare (lambda (string1 string2 lt-proc eq-proc gt-proc :optional start end) obj))
+ (string-compare-ci (lambda (string1 string2 lt-proc eq-proc gt-proc :optional start end) obj))
+ (string= (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
+ (string<> (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
+ (string< (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
+ (string> (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
+ (string<= (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
+ (string>= (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
+ (string-ci= (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
+ (string-ci<> (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
+ (string-ci< (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
+ (string-ci> (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
+ (string-ci<= (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
+ (string-ci>= (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
+ (string-titlecase (lambda (string :optional start end) str))
+ (string-upcase (lambda (string :optional start end) str))
+ (string-downcase (lambda (string :optional start end) str))
+ (string-titlecase! (lambda (string :optional start end) undefined))
+ (string-upcase! (lambda (string :optional start end) undefined))
+ (string-downcase! (lambda (string :optional start end) undefined))
+ (string-take (lambda (string nchars) str))
+ (string-drop (lambda (string nchars) str))
+ (string-take-right (lambda (string nchars) str))
+ (string-drop-right (lambda (string nchars) str))
+ (string-pad (lambda (string k :optional char start end) str))
+ (string-pad-right (lambda (string k :optional char start end) str))
+ (string-trim (lambda (string :optional char/char-set/pred start end) str))
+ (string-trim-right (lambda (string :optional char/char-set/pred start end) str))
+ (string-trim-both (lambda (string :optional char/char-set/pred start end) str))
+ (string-filter (lambda (char/char-set/pred string :optional start end) str))
+ (string-delete (lambda (char/char-set/pred string :optional start end) str))
+ (string-index (lambda (string char/char-set/pred :optional start end) (or integer bool)))
+ (string-index-right (lambda (string char/char-set/pred :optional end start) (or integer bool)))
+ (string-skip (lambda (string char/char-set/pred :optional start end) (or integer bool)))
+ (string-skip-right (lambda (string char/char-set/pred :optional end start) (or integer bool)))
+ (string-count (lambda (string char/char-set/pred :optional start end) n))
+ (string-prefix-length (lambda (string1 string2 :optional start1 end1 start2 end2) n))
+ (string-suffix-length (lambda (string1 string2 :optional start1 end1 start2 end2) n))
+ (string-prefix-length-ci (lambda (string1 string2 :optional start1 end1 start2 end2) n))
+ (string-suffix-length-ci (lambda (string1 string2 :optional start1 end1 start2 end2) n))
+ (string-prefix? (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
+ (string-suffix? (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
+ (string-prefix-ci? (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
+ (string-suffix-ci? (lambda (string1 string2 :optional start1 end1 start2 end2) bool))
+ (string-contains (lambda (string pattern :optional s-start s-end p-start p-end) obj))
+ (string-contains-ci (lambda (string pattern :optional s-start s-end p-start p-end) obj))
+ (string-fill! (lambda (string char :optional start end) undefined))
+ (string-copy! (lambda (to tstart from :optional fstart fend) undefined))
+ (string-copy (lambda (str :optional start end) str))
+ (substring/shared (lambda (str start :optional end) str))
+ (string-reverse (lambda (str :optional start end) str))
+ (string-reverse! (lambda (str :optional start end) undefined))
+ (reverse-list->string (lambda (char-list) str))
+ (string->list (lambda (str :optional start end) list))
+ (string-concatenate (lambda (string-list) str))
+ (string-concatenate/shared (lambda (string-list) str))
+ (string-append/shared (lambda (str \.\.\.) str))
+ (string-concatenate-reverse (lambda (string-list :optional final-string end) str))
+ (string-concatenate-reverse/shared (lambda (string-list :optional final-string end) str))
+ (xsubstring (lambda (str from :optional to start end) str))
+ (string-xcopy! (lambda (target tstart str from :optional to start end) undefined))
+ (string-null? (lambda (str) bool))
+ (string-join (lambda (string-list :optional delim grammar) str))
+ (string-tokenize (lambda (string :optional token-chars start end) str))
+ (string-replace (lambda (str1 str2 start1 end1 :optional start2 end2) str))
+ (string-kmp-partial-search (lambda (pat rv str i :optional c= p-start s-start s-end) n))
+ (make-kmp-restart-vector (lambda (str :optional c= start end) vec))
+ (kmp-step (lambda (pat rv c i c= p-start) n))
+ )
+
+ ;; SRFI 14
+ ("Character-Set Library"
+ (char-set? (lambda (cset) bool))
+ (char-set= (lambda (cset \.\.\.) bool))
+ (char-set<= (lambda (cset \.\.\.) bool))
+ (char-set-hash (lambda (cset :optional int) int))
+ (char-set-cursor (lambda (cset) cursor))
+ (char-set-ref (lambda (cset cursor) ch))
+ (char-set-cursor-next (lambda (cset cursor) int))
+ (end-of-char-set? (lambda (cursor) bool))
+ (char-set-fold (lambda (proc obj cset) obj))
+ (char-set-unfold (lambda (proc proc proc obj :optional obj) cset))
+ (char-set-unfold! (lambda (proc proc proc obj obj) cset))
+ (char-set-for-each (lambda (proc cset) undefined))
+ (char-set-map (lambda (proc cset) cset))
+ (char-set-copy (lambda (cset) cset))
+ (char-set (lambda (ch \.\.\.) cset))
+ (list->char-set (lambda (list :optional obj) cset))
+ (list->char-set! (lambda (list cset) cset))
+ (string->char-set (lambda (str :optional cset) cset))
+ (string->char-set! (lambda (str cset) cset))
+ (ucs-range->char-set (lambda (int int :optional bool cset) cset))
+ (ucs-range->char-set! (lambda (int int bool cset) cset))
+ (char-set-filter (lambda (proc cset :optional base-cset) cset))
+ (char-set-filter! (lambda (proc cset base-cset) cset))
+ (->char-set (lambda (obj) cset))
+ (char-set-size (lambda (cset) n))
+ (char-set-count (lambda (proc cset) n))
+ (char-set-contains? (lambda (cset ch) bool))
+ (char-set-every (lambda (proc cset) obj))
+ (char-set-any (lambda (proc cset) obj))
+ (char-set-adjoin (lambda (cset ch \.\.\.) cset))
+ (char-set-delete (lambda (cset ch \.\.\.) cset))
+ (char-set-adjoin! (lambda (cset ch \.\.\.) cset))
+ (char-set-delete! (lambda (cset ch \.\.\.) cset))
+ (char-set->list (lambda (cset) list))
+ (char-set->string (lambda (cset) str))
+ (char-set-complement (lambda (cset) cset))
+ (char-set-union (lambda (cset \.\.\.) cset))
+ (char-set-intersection (lambda (cset \.\.\.) cset))
+ (char-set-xor (lambda (cset \.\.\.) cset))
+ (char-set-difference (lambda (cset \.\.\.) cset))
+ (char-set-diff+intersection (lambda (cset \.\.\.) cset))
+ (char-set-complement! (lambda (cset) cset))
+ (char-set-union! (lambda (cset \.\.\.) cset))
+ (char-set-intersection! (lambda (cset \.\.\.) cset))
+ (char-set-xor! (lambda (cset \.\.\.) cset))
+ (char-set-difference! (lambda (cset \.\.\.) cset))
+ (char-set-diff+intersection! (lambda (cset \.\.\.) cset))
+ (char-set:lower-case char-set)
+ (char-set:upper-case char-set)
+ (char-set:letter char-set)
+ (char-set:digit char-set)
+ (char-set:letter+digit char-set)
+ (char-set:graphic char-set)
+ (char-set:printing char-set)
+ (char-set:whitespace char-set)
+ (char-set:blank char-set)
+ (char-set:iso-control char-set)
+ (char-set:punctuation char-set)
+ (char-set:symbol char-set)
+ (char-set:hex-digit char-set)
+ (char-set:ascii char-set)
+ (char-set:empty char-set)
+ (char-set:full char-set)
+ )
+
+ ()
+
+ ;; SRFI 16
+ ("Syntax for procedures of variable arity"
+ (case-lambda (syntax (clauses \.\.\.) procedure)))
+
+ ;; SRFI 17
+ ("Generalized set!"
+ (set! (syntax (what value) undefined)))
+
+ ;; SRFI 18
+ ("Multithreading support"
+ (current-thread (lambda () thread))
+ (thread? (lambda (obj) bool))
+ (make-thread (lambda (thunk :optional name) thread))
+ (thread-name (lambda (thread) name))
+ (thread-specific (lambda (thread)))
+ (thread-specific-set! (lambda (thread obj)))
+ (thread-base-priority (lambda (thread)))
+ (thread-base-priority-set! (lambda (thread number)))
+ (thread-priority-boost (lambda (thread)))
+ (thread-priority-boost-set! (lambda (thread number)))
+ (thread-quantum (lambda (thread)))
+ (thread-quantum-set! (lambda (thread number)))
+ (thread-start! (lambda (thread)))
+ (thread-yield! (lambda ()))
+ (thread-sleep! (lambda (number)))
+ (thread-terminate! (lambda (thread)))
+ (thread-join! (lambda (thread :optional timeout timeout-val)))
+ (mutex? (lambda (obj) bool))
+ (make-mutex (lambda (:optional name) mutex))
+ (mutex-name (lambda (mutex) name))
+ (mutex-specific (lambda (mutex)))
+ (mutex-specific-set! (lambda (mutex obj)))
+ (mutex-state (lambda (mutex)))
+ (mutex-lock! (lambda (mutex :optional timeout thread)))
+ (mutex-unlock! (lambda (mutex :optional condition-variable timeout)))
+ (condition-variable? (lambda (obj) bool))
+ (make-condition-variable (lambda (:optional name) condition-variable))
+ (condition-variable-name (lambda (condition-variable) name))
+ (condition-variable-specific (lambda (condition-variable)))
+ (condition-variable-specific-set! (lambda (condition-variable obj)))
+ (condition-variable-signal! (lambda (condition-variable)))
+ (condition-variable-broadcast! (lambda (condition-variable)))
+ (current-time (lambda () time))
+ (time? (lambda (obj) bool))
+ (time->seconds (lambda (time) x1))
+ (seconds->time (lambda (x1) time))
+ (current-exception-handler (lambda () handler))
+ (with-exception-handler (lambda (handler thunk)))
+ (raise (lambda (obj)))
+ (join-timeout-exception? (lambda (obj) bool))
+ (abandoned-mutex-exception? (lambda (obj) bool))
+ (terminated-thread-exception? (lambda (obj) bool))
+ (uncaught-exception? (lambda (obj) bool))
+ (uncaught-exception-reason (lambda (exc) obj))
+ )
+
+ ;; SRFI 19
+ ("Time Data Types and Procedures"
+ (current-date (lambda (:optional tz-offset)) date)
+ (current-julian-day (lambda ()) jdn)
+ (current-modified-julian-day (lambda ()) mjdn)
+ (current-time (lambda (:optional time-type)) time)
+ (time-resolution (lambda (:optional time-type)) nanoseconds)
+ (make-time (lambda (type nanosecond second)))
+ (time? (lambda (obj)))
+ (time-type (lambda (time)))
+ (time-nanosecond (lambda (time)))
+ (time-second (lambda (time)))
+ (set-time-type! (lambda (time)))
+ (set-time-nanosecond! (lambda (time)))
+ (set-time-second! (lambda (time)))
+ (copy-time (lambda (time)))
+ (time<=? (lambda (time1 time2)))
+ (time<? (lambda (time1 time2)))
+ (time=? (lambda (time1 time2)))
+ (time>=? (lambda (time1 time2)))
+ (time>? (lambda (time1 time2)))
+ (time-difference (lambda (time1 time2)))
+ (time-difference! (lambda (time1 time2)))
+ (add-duration (lambda (time duration)))
+ (add-duration! (lambda (time duration)))
+ (subtract-duration (lambda (time duration)))
+ (subtract-duration! (lambda (time duration)))
+ (make-date (lambda (nanosecond second minute hour day month year zone-offset)))
+ (date? (lambda (obj)))
+ (date-nanosecond (lambda (date)))
+ (date-second (lambda (date)))
+ (date-minute (lambda (date)))
+ (date-hour (lambda (date)))
+ (date-day (lambda (date)))
+ (date-month (lambda (date)))
+ (date-year (lambda (date)))
+ (date-zone-offset (lambda (date)))
+ (date-year-day (lambda (date)))
+ (date-week-day (lambda (date)))
+ (date-week-number (lambda (date)))
+ (date->julian-day (lambda (date)))
+ (date->modified-julian-day (lambda (date)))
+ (date->time-monotonic (lambda (date)))
+ (date->time-tai (lambda (date)))
+ (date->time-utc (lambda (date)))
+ (julian-day->date (lambda (date)))
+ (julian-day->time-monotonic (lambda (date)))
+ (julian-day->time-tai (lambda (date)))
+ (julian-day->time-utc (lambda (date)))
+ (modified-julian-day->date (lambda (date)))
+ (modified-julian-day->time-monotonic (lambda (date)))
+ (modified-julian-day->time-tai (lambda (date)))
+ (modified-julian-day->time-utc (lambda (date)))
+ (time-monotonic->date (lambda (date)))
+ (time-monotonic->julian-day (lambda (date)))
+ (time-monotonic->modified-julian-day (lambda (date)))
+ (time-monotonic->time-monotonic (lambda (date)))
+ (time-monotonic->time-tai (lambda (date)))
+ (time-monotonic->time-tai! (lambda (date)))
+ (time-monotonic->time-utc (lambda (date)))
+ (time-monotonic->time-utc! (lambda (date)))
+ (time-tai->date (lambda (date)))
+ (time-tai->julian-day (lambda (date)))
+ (time-tai->modified-julian-day (lambda (date)))
+ (time-tai->time-monotonic (lambda (date)))
+ (time-tai->time-monotonic! (lambda (date)))
+ (time-tai->time-utc (lambda (date)))
+ (time-tai->time-utc! (lambda (date)))
+ (time-utc->date (lambda (date)))
+ (time-utc->julian-day (lambda (date)))
+ (time-utc->modified-julian-day (lambda (date)))
+ (time-utc->time-monotonic (lambda (date)))
+ (time-utc->time-monotonic! (lambda (date)))
+ (time-utc->time-tai (lambda (date)))
+ (time-utc->time-tai! (lambda (date)))
+ (date->string (lambda (date :optional format-string)))
+ (string->date (lambda (input-string template-string)))
+ )
+
+ ()
+
+ ;; SRFI 21
+ ("Real-time multithreading support"
+ srfi-18) ; same as srfi-18
+
+ ;; SRFI 22
+ ("Running Scheme Scripts on Unix"
+ )
+
+ ;; SRFI 23
+ ("Error reporting mechanism"
+ (error (lambda (reason-string arg \.\.\.))))
+
+ ()
+
+ ;; SRFI 25
+ ("Multi-dimensional Array Primitives"
+ (array? (lambda (obj)))
+ (make-array (lambda (shape :optional init)))
+ (shape (lambda (bound \.\.\.)))
+ (array (lambda (shape obj \.\.\.)))
+ (array-rank (lambda (array)))
+ (array-start (lambda (array)))
+ (array-end (lambda (array)))
+ (array-shape (lambda (array)))
+ (array-ref (lambda (array i \.\.\.)))
+ (array-set! (lambda (array obj \.\.\.) undefined))
+ (share-array (lambda (array shape proc)))
+ )
+
+ ;; SRFI 26
+ ("Notation for Specializing Parameters without Currying"
+ (cut (syntax (obj \.\.\.)))
+ (cute (lambda (obj \.\.\.))))
+
+ ;; SRFI 27
+ ("Sources of Random Bits"
+ (random-integer (lambda (n)))
+ (random-real (lambda ()))
+ (default-random-source (lambda ()))
+ (make-random-source (lambda ()))
+ (random-source? (lambda (obj)))
+ (random-source-state-ref (lambda (random-source)))
+ (random-source-state-set! (lambda (random-source state)))
+ (random-source-randomize! (lambda (random-source)))
+ (random-source-pseudo-randomize! (lambda (random-source i j)))
+ (random-source-make-integers (lambda (random-source)))
+ (random-source-make-reals (lambda (random-source)))
+ )
+
+ ;; SRFI 28
+ ("Basic Format Strings"
+ (format (lambda (port-or-boolean format-string arg \.\.\.))))
+
+ ;; SRFI 29
+ ("Localization"
+ (current-language (lambda (:optional symbol)))
+ (current-country (lambda (:optional symbol)))
+ (current-locale-details (lambda (:optional list)))
+ (declare-bundle! (lambda (bundle-name association-list)))
+ (store-bundle (lambda (bundle-name)))
+ (load-bundle! (lambda (bundle-name)))
+ (localized-template (lambda (package-name message-template-name)))
+ )
+
+ ;; SRFI 30
+ ("Nested Multi-line Comments"
+ )
+
+ ;; SRFI 31
+ ("A special form for recursive evaluation"
+ (rec (syntax (name body \.\.\.) procedure)))
+
+ ()
+
+ ()
+
+ ;; SRFI 34
+ ("Exception Handling for Programs"
+ (guard (syntax (clauses \.\.\.)))
+ (raise (lambda (obj)))
+ )
+
+ ;; SRFI 35
+ ("Conditions"
+ (make-condition-type (lambda (id parent field-name-list)))
+ (condition-type? (lambda (obj)))
+ (make-condition (lambda (condition-type)))
+ (condition? (lambda (obj)))
+ (condition-has-type? (lambda (condition condition-type)))
+ (condition-ref (lambda (condition field-name)))
+ (make-compound-condition (lambda (condition \.\.\.)))
+ (extract-condition (lambda (condition condition-type)))
+ (define-condition-type (syntax (name parent pred-name fields \.\.\.)))
+ (condition (syntax (type-field-binding \.\.\.)))
+ )
+
+ ;; SRFI 36
+ ("I/O Conditions"
+ (&error condition)
+ (&i/o-error condition)
+ (&i/o-port-error condition)
+ (&i/o-read-error condition)
+ (&i/o-write-error condition)
+ (&i/o-closed-error condition)
+ (&i/o-filename-error condition)
+ (&i/o-malformed-filename-error condition)
+ (&i/o-file-protection-error condition)
+ (&i/o-file-is-read-only-error condition)
+ (&i/o-file-already-exists-error condition)
+ (&i/o-no-such-file-error condition)
+ )
+
+ ;; SRFI 37
+ ("args-fold: a program argument processor"
+ (args-fold
+ (arg-list option-list unrecognized-option-proc operand-proc seed \.\.\.))
+ (option-processor (lambda (option name arg seeds \.\.\.)))
+ (operand-processor (lambda (operand seeds \.\.\.)))
+ (option (lambda (name-list required-arg? optional-arg? option-proc)))
+ (option-names (lambda (option)))
+ (option-required-arg? (lambda (option)))
+ (option-optional-arg? (lambda (option)))
+ (option-processor (lambda (option)))
+ )
+
+ ;; SRFI 38
+ ("External Representation for Data With Shared Structure"
+ (write-with-shared-structure (lambda (obj :optional port optarg)))
+ (read-with-shared-structure (lambda (:optional port)))
+ )
+
+ ;; SRFI 39
+ ("Parameter objects"
+ (make-parameter (lambda (init-value :optional converter)))
+ (parameterize (syntax (bindings body \.\.\.))))
+
+ ;; SRFI 40
+ ("A Library of Streams"
+ (stream-null stream)
+ (stream-cons (syntax (obj stream)))
+ (stream? (lambda (obj)))
+ (stream-null? (lambda (obj)))
+ (stream-pair? (lambda (obj)))
+ (stream-car (lambda (stream)))
+ (stream-cdr (lambda (stream)))
+ (stream-delay (syntax (expr)))
+ (stream (lambda (obj \.\.\.)))
+ (stream-unfoldn (lambda (generator-proc seed n)))
+ (stream-map (lambda (proc stream \.\.\.)))
+ (stream-for-each (lambda (proc stream \.\.\.) undefined))
+ (stream-filter (lambda (pred stream)))
+ )
+
+ ()
+
+ ;; SRFI 42
+ ("Eager Comprehensions"
+ (list-ec (syntax))
+ (append-ec (syntax))
+ (sum-ec (syntax))
+ (min-ec (syntax))
+ (max-ec (syntax))
+ (any?-ec (syntax))
+ (every?-ec (syntax))
+ (first-ec (syntax))
+ (do-ec (syntax))
+ (fold-ec (syntax))
+ (fold3-ec (syntax))
+ (:list (syntax () undefined))
+ (:string (syntax () undefined))
+ (:vector (syntax () undefined))
+ (:integers (syntax () undefined))
+ (:range (syntax () undefined))
+ (:real-range (syntax () undefined))
+ (:char-range (syntax () undefined))
+ (:port (syntax () undefined))
+ (:do (syntax () undefined))
+ (:let (syntax () undefined))
+ (:parallel (syntax () undefined))
+ (:while (syntax () undefined))
+ (:until (syntax () undefined))
+ )
+
+ ;; SRFI 43
+ ("Vector Library"
+ (vector-unfold (f length initial-seed \.\.\.))
+ (vector-unfold-right (lambda (f length initial-seed \.\.\.)))
+ (vector-tabulate (lambda (f size)))
+ (vector-copy (lambda (vec :optional start end fill)))
+ (vector-reverse-copy (lambda (vec :optional start end)))
+ (vector-append (lambda (vec \.\.\.)))
+ (vector-concatenate (lambda (vector-list)))
+ (vector-empty? (lambda (obj)))
+ (vector= (lambda (eq-proc vec \.\.\.)))
+ (vector-fold (lambda (kons knil vec \.\.\.)))
+ (vector-fold-right (lambda (kons knil vec \.\.\.)))
+ (vector-map (lambda (f vec \.\.\.)))
+ (vector-map! (lambda (f vec \.\.\.)))
+ (vector-for-each (lambda (f vec \.\.\.) undefined))
+ (vector-count (lambda (pred vec \.\.\.)))
+ (vector-index (lambda (pred vec \.\.\.)))
+ (vector-index-right (lambda (pred vec \.\.\.)))
+ (vector-skip (lambda (pred vec \.\.\.)))
+ (vector-skip-right (lambda (pred vec \.\.\.)))
+ (vector-binary-search (lambda (vec value cmp-proc)))
+ (vector-any (lambda (pred vec \.\.\.)))
+ (vector-every (lambda (pred vec \.\.\.)))
+ (vector-swap! (lambda (vec i j) undefined))
+ (vector-reverse! (lambda (vec :optional start end) undefined))
+ (vector-copy! (lambda (target-vec t-start source-vec :optional start end) undefined))
+ (vector-reverse-copy! (lambda (target-vec t-start source-vec :optional start end) undefined))
+ (reverse-vector-to-list (lambda (vec :optional start end)))
+ (reverse-list-to-vector (lambda (list)))
+ )
+
+ ;; SRFI 44
+ ("Collections"
+ )
+
+ ;; SRFI 45
+ ("Primitives for expressing iterative lazy algorithms"
+ (delay (syntax (expr)))
+ (lazy (syntax (expr)))
+ (force (lambda (promise)))
+ (eager (lambda (promise)))
+ )
+
+ ;; SRFI 46
+ ("Basic Syntax-rules Extensions"
+ (syntax-rules (syntax () undefined)))
+
+ ;; SRFI 47
+ ("Array"
+ (make-array (lambda (prototype k \.\.\.)))
+ (ac64 (lambda (:optional z)))
+ (ac32 (lambda (:optional z)))
+ (ar64 (lambda (:optional x1)))
+ (ar32 (lambda (:optional x1)))
+ (as64 (lambda (:optional n)))
+ (as32 (lambda (:optional n)))
+ (as16 (lambda (:optional n)))
+ (as8 (lambda (:optional n)))
+ (au64 (lambda (:optional n)))
+ (au32 (lambda (:optional n)))
+ (au16 (lambda (:optional n)))
+ (au8 (lambda (:optional n)))
+ (at1 (lambda (:optional bool)))
+ (make-shared-array (lambda (array mapper k \.\.\.)))
+ (array-rank (lambda (obj)))
+ (array-dimensions (lambda (array)))
+ (array-in-bounds? (lambda (array k \.\.\.)))
+ (array-ref (lambda (array k \.\.\.)))
+ (array-set! (lambda (array obj k \.\.\.)))
+ )
+
+ ;; SRFI 48
+ ("Intermediate Format Strings"
+ (format (lambda (port-or-boolean format-string arg \.\.\.))))
+
+ ;; SRFI 49
+ ("Indentation-sensitive syntax"
+ )
+
+ ()
+
+ ;; SRFI 51
+ ("Handling rest list"
+ (rest-values (lambda (caller rest-list :optional args-number-limit default)))
+ (arg-and (syntax))
+ (arg-ands (syntax))
+ (err-and (syntax))
+ (err-ands (syntax))
+ (arg-or (syntax))
+ (arg-ors (syntax))
+ (err-or (syntax))
+ (err-ors (syntax))
+ )
+
+ ()
+
+ ()
+
+ ;; SRFI 54
+ ("Formatting"
+ (cat (lambda (obj \.\.\.))))
+
+ ;; SRFI 55
+ ("require-extension"
+ (require-extension (syntax)))
+
+ ()
+
+ ;; SRFI 57
+ ("Records"
+ (define-record-type (syntax))
+ (define-record-scheme (syntax))
+ (record-update (syntax))
+ (record-update! (syntax))
+ (record-compose (syntax)))
+
+ ;; SRFI 58
+ ("Array Notation"
+ )
+
+ ;; SRFI 59
+ ("Vicinity"
+ (program-vicinity (lambda ()))
+ (library-vicinity (lambda ()))
+ (implementation-vicinity (lambda ()))
+ (user-vicinity (lambda ()))
+ (home-vicinity (lambda ()))
+ (in-vicinity (lambda (vicinity filename)))
+ (sub-vicinity (lambda (vicinity name)))
+ (make-vicinity (lambda (dirname)))
+ (path-vicinity (lambda (path)))
+ (vicinity:suffix? (lambda (ch)))
+ )
+
+ ;; SRFI 60
+ ("Integers as Bits"
+ (bitwise-and (lambda (n \.\.\.) int))
+ (bitwise-ior (lambda (n \.\.\.) int))
+ (bitwise-xor (lambda (n \.\.\.) int))
+ (bitwise-not (lambda (n) int))
+ (bitwise-if (lambda (mask n m) int))
+ (any-bits-set? (lambda (n m) bool))
+ (bit-count (lambda (n) int))
+ (integer-length (lambda (n) int))
+ (first-bit-set (lambda (n) int))
+ (bit-set? (lambda (i n) bool))
+ (copy-bit (lambda (index n bool) int))
+ (bit-field (lambda (n start end) int))
+ (copy-bit-field (lambda (to-int from-int start end) int))
+ (arithmetic-shift (lambda (n count) int))
+ (rotate-bit-field (lambda (n count start end) int))
+ (reverse-bit-field (lambda (n start end) int))
+ (integer->list (lambda (k :optional len) list))
+ (list->integer (lambda (list) int))
+ )
+
+ ;; SRFI 61
+ ("A more general cond clause"
+ (cond (syntax)))
+
+ ;; SRFI 62
+ ("S-expression comments"
+ )
+
+ ;; SRFI 63
+ ("Homogeneous and Heterogeneous Arrays"
+ )
+
+ ;; SRFI 64
+ ("A Scheme API for test suites"
+ (test-assert (syntax))
+ (test-eqv (syntax))
+ (test-equal (syntax))
+ (test-eq (syntax))
+ (test-approximate (syntax))
+ (test-error (syntax))
+ (test-read-eval-string (lambda (string)))
+ (test-begin (syntax (suite-name :optional count)))
+ (test-end (syntax (suite-name)))
+ (test-group (syntax (suite-name decl-or-expr \.\.\.)))
+ (test-group-with-cleanup (syntax (suite-name decl-or-expr \.\.\.)))
+ (test-match-name (lambda (name)))
+ (test-match-nth (lambda (n :optional count)))
+ (test-match-any (lambda (specifier \.\.\.)))
+ (test-match-all (lambda (specifier \.\.\.)))
+ (test-skip (syntax (specifier)))
+ (test-expect-fail (syntax (specifier)))
+ (test-runner? (lambda (obj)))
+ (test-runner-current (lambda (:optional runner)))
+ (test-runner-get (lambda ()))
+ (test-runner-simple (lambda ()))
+ (test-runner-null (lambda ()))
+ (test-runner-create (lambda ()))
+ (test-runner-factory (lambda (:optional factory)))
+ (test-apply (syntax (runner specifier \.\.\.)))
+ (test-with-runner (syntax (runner decl-or-expr \.\.\.)))
+ (test-result-kind (lambda (:optional runner)))
+ (test-passed? (lambda (:optional runner)))
+ (test-result-ref (lambda (runner prop-name (:optional default))))
+ (test-result-set! (lambda (runner prop-name value)))
+ (test-result-remove (lambda (runner prop-name)))
+ (test-result-clear (lambda (runner)))
+ (test-result-alist (lambda (runner)))
+ (test-runner-on-test-begin (lambda (runner :optional proc)))
+ (test-runner-on-test-begin! (lambda (runner :optional proc)))
+ (test-runner-on-test-end (lambda (runner :optional proc)))
+ (test-runner-on-test-end! (lambda (runner :optional proc)))
+ (test-runner-on-group-begin (lambda (runner :optional proc)))
+ (test-runner-on-group-begin! (lambda (runner :optional proc)))
+ (test-runner-on-group-end (lambda (runner :optional proc)))
+ (test-runner-on-group-end! (lambda (runner :optional proc)))
+ (test-runner-on-bad-count (lambda (runner :optional proc)))
+ (test-runner-on-bad-count! (lambda (runner :optional proc)))
+ (test-runner-on-bad-end-name (lambda (runner :optional proc)))
+ (test-runner-on-bad-end-name! (lambda (runner :optional proc)))
+ (test-runner-on-final (lambda (runner :optional proc)))
+ (test-runner-on-final! (lambda (runner :optional proc)))
+ (test-runner-pass-count (lambda (runner)))
+ (test-runner-fail-count (lambda (runner)))
+ (test-runner-xpass-count (lambda (runner)))
+ (test-runner-skip-count (lambda (runner)))
+ (test-runner-test-name (lambda (runner)))
+ (test-runner-group-path (lambda (runner)))
+ (test-runner-group-stack (lambda (runner)))
+ (test-runner-aux-value (lambda (runner)))
+ (test-runner-aux-value! (lambda (runner)))
+ (test-runner-reset (lambda (runner)))
+ )
+
+ ()
+
+ ;; SRFI 66
+ ("Octet Vectors"
+ (make-u8vector (lambda (len n)))
+ (u8vector (lambda (n \.\.\.)))
+ (u8vector->list (lambda (u8vector)))
+ (list->u8vector (lambda (octet-list)))
+ (u8vector-length u8vector)
+ (u8vector-ref (lambda (u8vector k)))
+ (u8vector-set! (lambda (u8vector k n)))
+ (u8vector=? (lambda (u8vector-1 u8vector-2)))
+ (u8vector-compare (lambda (u8vector-1 u8vector-2)))
+ (u8vector-copy! (lambda (source source-start target target-start n)))
+ (u8vector-copy (lambda (u8vector)))
+ )
+
+ ;; SRFI 67
+ ("Compare Procedures"
+ )
+
+ ()
+
+ ;; SRFI 69
+ ("Basic hash tables"
+ (alist->hash-table (lambda (alist) hash-table))
+ (hash (lambda (obj :optional n) int))
+ (hash-by-identity (lambda (obj :optional n) int))
+ (hash-table->alist (lambda (hash-table) alist))
+ (hash-table-copy (lambda (hash-table) hash-table))
+ (hash-table-delete! (lambda (hash-table key) undefined))
+ (hash-table-equivalence-function (lambda (hash-table) pred))
+ (hash-table-exists? (lambda (hash-table key) bool))
+ (hash-table-fold (lambda (hash-table f init-value)))
+ (hash-table-hash-function (lambda (hash-table) f))
+ (hash-table-keys (lambda (hash-table) list))
+ (hash-table-merge! (lambda (hash-table1 hash-table2) undefined))
+ (hash-table-ref (lambda (hash-table key :optional thunk)))
+ (hash-table-ref/default (lambda (hash-table key default)))
+ (hash-table-remove! (lambda (hash-table proc) undefined))
+ (hash-table-set! (lambda (hash-table key value) undefined))
+ (hash-table-size (lambda (hash-table) n))
+ (hash-table-update! (lambda (hash-table key proc :optional thunk) undefined))
+ (hash-table-update!/default (lambda (hash-table key proc default) undefined))
+ (hash-table-values (lambda (hash-table) list))
+ (hash-table-walk (lambda (hash-table proc) undefined))
+ (hash-table? (lambda (obj) bool))
+ (make-hash-table (lambda (:optional eq-fn hash-fn) hash-table))
+ (string-ci-hash (lambda (str :optional n) n))
+ (string-hash (lambda (str1 :optional n) n))
+ )
+
+ ;; SRFI 70
+ ("Numbers"
+ )
+
+ ;; SRFI 71
+ ("LET-syntax for multiple values"
+ )
+
+ ;; SRFI 72
+ ("Simple hygienic macros"
+ )
+
+ ()
+
+ ;; SRFI 74
+ ("Octet-Addressed Binary Blocks"
+ )
+
+ ])
+
+(defvar *scheme-chicken-modules*
+ '((extras
+ (->string (lambda (obj) str))
+ (alist->hash-table (lambda (alist) hash-table))
+ (alist-ref (lambda (alist key :optional eq-fn default)))
+ (alist-update! (lambda (key value alist :optional eq-fn) undefined))
+ (atom? (lambda (obj) bool))
+ (binary-search (lambda (vec proc)))
+ (butlast (lambda (list) list) "drops the last element of list")
+ (call-with-input-string (lambda (string proc)))
+ (call-with-output-string (lambda (proc) str))
+ (chop (lambda (list k) list))
+ (complement (lambda (f) f2))
+ (compose (lambda (f1 f2 \.\.\.) f))
+ (compress (lambda (boolean-list list)))
+ (conc (lambda (obj \.\.\.)))
+ (conjoin (lambda (pred \.\.\.) pred))
+ (constantly (lambda (obj \.\.\.) f))
+ (disjoin (lambda (pred \.\.\.) pred))
+ (each (lambda (proc \.\.\.) proc))
+ (flatten (lambda (list1 \.\.\.) list))
+ (flip (lambda (proc) proc))
+ (format (lambda (format-string arg \.\.\.)))
+ (fprintf (lambda (port format-string arg \.\.\.)))
+ (hash (lambda (obj :optional n) int))
+ (hash-by-identity (lambda (obj :optional n) int))
+ (hash-table->alist (lambda (hash-table) alist))
+ (hash-table-copy (lambda (hash-table) hash-table))
+ (hash-table-delete! (lambda (hash-table key) undefined))
+ (hash-table-equivalence-function (lambda (hash-table) pred))
+ (hash-table-exists? (lambda (hash-table key) bool))
+ (hash-table-fold (lambda (hash-table f init-value)))
+ (hash-table-hash-function (lambda (hash-table) f))
+ (hash-table-keys (lambda (hash-table) list))
+ (hash-table-merge! (lambda (hash-table1 hash-table2) undefined))
+ (hash-table-ref (lambda (hash-table key :optional thunk)))
+ (hash-table-ref/default (lambda (hash-table key default)))
+ (hash-table-remove! (lambda (hash-table proc) undefined))
+ (hash-table-set! (lambda (hash-table key value) undefined))
+ (hash-table-size (lambda (hash-table) n))
+ (hash-table-update! (lambda (hash-table key proc :optional thunk) undefined))
+ (hash-table-update!/default (lambda (hash-table key proc default) undefined))
+ (hash-table-values (lambda (hash-table) list))
+ (hash-table-walk (lambda (hash-table proc) undefined))
+ (hash-table? (lambda (obj) bool))
+ (identity (lambda (obj)))
+ (intersperse (lambda (list obj) list))
+ (join (lambda (list-of-lists :optional list) list))
+ (list->queue (lambda (list) queue))
+ (list-of (lambda (pred)))
+ (make-hash-table (lambda (:optional eq-fn hash-fn size) hash-table))
+ (make-input-port (lambda (read-proc ready?-pred close-proc :optional peek-proc) input-port))
+ (make-output-port (lambda (write-proc close-proc :optional flush-proc) output-port))
+ (make-queue (lambda () queue))
+ (merge (lambda (list1 list2 less-fn) list))
+ (merge! (lambda (list1 list2 less-fn) list))
+ (noop (lambda (obj \.\.\.) undefined))
+ (pp (lambda (obj :optional output-port) undefined))
+ (pretty-print (lambda (obj :optional output-port) undefined))
+ (pretty-print-width (lambda (:optional new-width) n))
+ (printf (lambda (format-string arg \.\.\.) undefined))
+ (project (lambda (n) proc))
+ (queue->list (lambda (queue) list))
+ (queue-add! (lambda (queue obj) undefined))
+ (queue-empty? (lambda (queue) bool))
+ (queue-first (lambda (queue)))
+ (queue-last (lambda (queue)))
+ (queue-push-back! (lambda (queue obj) undefined))
+ (queue-push-back-list! (lambda (queue list) undefined))
+ (queue-remove! (lambda (queue) undefined))
+ (queue? (lambda (obj) bool))
+ (random (lambda (n) n))
+ (randomize (lambda (:optional x1) undefined))
+ (rassoc (lambda (key list :optional eq-fn)))
+ (read-file (lambda (:optional file-or-port reader-fn max-count) str))
+ (read-line (lambda (:optional port limit) str))
+ (read-lines (lambda (:optional port max) list))
+ (read-string (lambda (:optional n port) str))
+ (read-string! (lambda (n dest :optional port start) n))
+ (read-token (lambda (predicate :optional port) str))
+ (shuffle (lambda (list) list))
+ (sort (lambda ((or list vector) less-fn) (or list vector)))
+ (sort! (lambda ((or list vector) less-fn) (or list vector)))
+ (sorted? (lambda ((or list vector) less-fn) bool))
+ (sprintf (lambda (format-string arg \.\.\.) str))
+ (string-chomp (lambda (str :optional suffix-str) str))
+ (string-chop (lambda (str length) list))
+ (string-ci-hash (lambda (str :optional n) n))
+ (string-compare3 (lambda (str1 str2) n))
+ (string-compare3-ci (lambda (str1 str2) n))
+ (string-hash (lambda (str1 :optional n) n))
+ (string-intersperse (lambda (list :optional seperator-string) str))
+ (string-split (lambda (str :optional delimiter-str keep-empty?) list))
+ (string-translate (lambda (str from-str :optional to-str) str))
+ (string-translate* (lambda (str list) str))
+ (substring-ci=? (lambda (str1 str2 :optional start1 start2 length) str))
+ (substring-index (lambda (which-str where-str :optional start) i))
+ (substring-index-ci (lambda (which-str where-str :optional start) i))
+ (substring=? (lambda (str1 str2 :optional start1 start2 length) bool))
+ (tail? (lambda (obj list) bool))
+ (with-error-output-to-port (lambda (output-port thunk)))
+ (with-input-from-port (lambda (port thunk)))
+ (with-input-from-string (lambda (str thunk)))
+ (with-output-to-port (lambda (port thunk)))
+ (with-output-to-string (lambda (thunk) str))
+ (write-line (lambda (str :optional port) undefined))
+ (write-string (lambda (str :optional num port) undefined))
+ )
+ (lolevel
+ (address->pointer (lambda (n) ptr))
+ (align-to-word (lambda (ptr-or-int) ptr))
+ (allocate (lambda (size) block))
+ (block-ref (lambda (block index) int))
+ (block-set! (lambda (block index obj) undefined))
+ (byte-vector (lambda (n \.\.\.) byte-vector))
+ (byte-vector->list (lambda (byte-vector) list))
+ (byte-vector->string (lambda (byte-vector) string))
+ (byte-vector-fill! (lambda (byte-vector n) undefined))
+ (byte-vector-length (lambda (byte-vector) n))
+ (byte-vector-ref (lambda (byte-vector i) int))
+ (byte-vector-set! (lambda (byte-vector i n) undefined))
+ (byte-vector? (lambda (obj) bool))
+ (extend-procedure (lambda (proc x1) proc))
+ (extended-procedure? (lambda (proc) bool))
+ (free (lambda (pointer) undefined))
+ (global-bound? (lambda (sym) bool))
+ (global-make-unbound! (lambda (sym) undefined))
+ (global-ref (lambda (sym)))
+ (global-set! (lambda (sym val) undefined))
+ (list->byte-vector (lambda (list) byte-vector))
+ (locative->object (lambda (locative) obj))
+ (locative-ref (lambda (locative)))
+ (locative-set! (lambda (locative val) undefined))
+ (locative? (lambda (obj) bool))
+ (make-byte-vector (lambda (size :optional init-n) byte-vector))
+ (make-locative (lambda (obj :optional index) locative))
+ (make-record-instance (lambda (sym arg \.\.\.)))
+ (make-static-byte-vector (lambda (size :optional init-n)))
+ (make-weak-locative (lambda (obj :optional index) locative))
+ (move-memory! (lambda (from to :optional bytes from-offset to-offset) undefined))
+ (mutate-procedure (lambda (proc proc) proc))
+ (null-pointer (lambda () pointer))
+ (null-pointer? (lambda (pointer) bool))
+ (number-of-bytes (lambda (block) int))
+ (number-of-slots (lambda (block) int))
+ (object->pointer (lambda (obj) ptr))
+ (object-become! (lambda (alist) undefined))
+ (object-copy (lambda (obj)))
+ (object-evict (lambda (obj :optional allocator-proc)))
+ (object-evict-to-location (lambda (obj ptr :optional limit)))
+ (object-evicted? (lambda (obj) bool))
+ (object-release (lambda (obj :optional releaser-proc)))
+ (object-size (lambda (obj) int))
+ (object-unevict (lambda (obj :optional full)))
+ (pointer->address (lambda (ptr) n))
+ (pointer->object (lambda (ptr)))
+ (pointer-f32-ref (lambda (ptr) real))
+ (pointer-f32-set! (lambda (ptr x1) undefined))
+ (pointer-f64-ref (lambda (ptr) real))
+ (pointer-f64-set! (lambda (ptr x1) undefined))
+ (pointer-offset (lambda (ptr n) n))
+ (pointer-s16-ref (lambda (ptr) int))
+ (pointer-s16-set! (lambda (ptr n) undefined))
+ (pointer-s32-ref (lambda (ptr) int))
+ (pointer-s32-set! (lambda (ptr n) undefined))
+ (pointer-s8-ref (lambda (ptr) int))
+ (pointer-s8-set! (lambda (ptr n) undefined))
+ (pointer-tag (lambda (ptr) tag))
+ (pointer-u16-ref (lambda (ptr) int))
+ (pointer-u16-set! (lambda (ptr n) undefined))
+ (pointer-u32-ref (lambda (ptr) int))
+ (pointer-u32-set! (lambda (ptr n) undefined))
+ (pointer-u8-ref (lambda (ptr) int))
+ (pointer-u8-set! (lambda (ptr n) undefined))
+ (pointer=? (lambda (ptr1 ptr2) bool))
+ (pointer? (lambda (obj) bool))
+ (procedure-data (lambda (proc)))
+ (record->vector (lambda (block) vector))
+ (record-instance? (lambda (obj) bool))
+ (set-invalid-procedure-call-handler! (lambda (proc) undefined))
+ (set-procedure-data! (lambda (proc obj) undefined))
+ (static-byte-vector->pointer (lambda (byte-vector) pointer))
+ (string->byte-vector (lambda (str) byte-vector))
+ (tag-pointer (lambda (ptr tag)))
+ (tagged-pointer? (lambda (obj tag) bool))
+ (unbound-variable-value (lambda (:optional value)))
+ )
+ (posix
+ (_exit (lambda (:optional n) undefined))
+ (call-with-input-pipe (lambda (cmdline-string proc :optional mode)))
+ (call-with-output-pipe (lambda (cmdline-string proc :optional mode)))
+ (change-directory (lambda (dir)))
+ (change-file-mode (lambda (filename mode)))
+ (change-file-owner (lambda (filename user-n group-n)))
+ (close-input-pipe (lambda (input-port)))
+ (close-output-pipe (lambda (output-port)))
+ (create-directory (lambda (filename)))
+ (create-fifo (lambda (filename :optional mode)))
+ (create-pipe (lambda ()))
+ (create-session (lambda ()))
+ (create-symbolic-link (lambda (old-filename new-filename)))
+ (current-directory (lambda (:optional new-dir)))
+ (current-effective-group-id (lambda () int))
+ (current-effective-user-id (lambda () int))
+ (current-environment (lambda ()))
+ (current-group-id (lambda ()))
+ (current-process-id (lambda ()))
+ (current-user-id (lambda ()))
+ (delete-directory (lambda (dir)))
+ (directory (lambda (:optional dir show-dotfiles?) list))
+ (directory? (lambda (filename) bool))
+ (duplicate-fileno (lambda (old-n :optional new-n)))
+;; (errno/acces integer)
+;; (errno/again integer)
+;; (errno/badf integer)
+;; (errno/busy integer)
+;; (errno/child integer)
+;; (errno/exist integer)
+;; (errno/fault integer)
+;; (errno/intr integer)
+;; (errno/inval integer)
+;; (errno/io integer)
+;; (errno/isdir integer)
+;; (errno/mfile integer)
+;; (errno/noent integer)
+;; (errno/noexec integer)
+;; (errno/nomem integer)
+;; (errno/nospc integer)
+;; (errno/notdir integer)
+;; (errno/perm integer)
+;; (errno/pipe integer)
+;; (errno/rofs integer)
+;; (errno/spipe integer)
+;; (errno/srch integer)
+;; (errno/wouldblock integer)
+ (fifo? (lambda (filename) bool))
+ (file-access-time (lambda (filename) real))
+ (file-change-time (lambda (filename) real))
+ (file-close (lambda (fileno)))
+ (file-execute-access? (lambda (filename) bool))
+ (file-link (lambda (old-filename new-filename)))
+ (file-lock (lambda (port :optional start len)))
+ (file-lock/blocking (lambda (port :optional start len)))
+ (file-mkstemp (lambda (template-filename)))
+ (file-modification-time (lambda (filename) real))
+ (file-open (lambda (filename (flags open-mode open/binary open/excl open/fsync open/noctty open/nonblock open/rdonly open/rdwr open/read open/sync open/text) :optional mode) fileno))
+ (file-owner (lambda (filename)))
+ (file-permissions (lambda (filename) int))
+ (file-position (lambda (port-or-fileno) int))
+ (file-read (lambda (fileno size :optional buffer-string)))
+ (file-read-access? (lambda (filename) bool))
+ (file-select (lambda (read-fd-list write-fd-list :optional timeout)))
+ (file-size (lambda (filename) int))
+ (file-stat (lambda (filename :optional follow-link?)))
+ (file-test-lock (lambda (port :optional start len)))
+ (file-truncate (lambda (filename-or-fileno offset)))
+ (file-unlock (lambda (lock)))
+ (file-write (lambda (fileno buffer-string :optional size)))
+ (file-write-access? (lambda (filename)))
+ (fileno/stderr integer)
+ (fileno/stdin integer)
+ (fileno/stdout integer)
+ (find-files (lambda (dir pred :optional action-proc identity limit)))
+ (get-groups (lambda ()))
+ (get-host-name (lambda ()))
+ (glob (lambda (pattern1 \.\.\.)))
+ (group-information (lambda (group-name-or-n)))
+ (initialize-groups (lambda (user-name base-group-n)))
+ (local-time->seconds (lambda (vector)))
+ (local-timezone-abbreviation (lambda ()))
+ (map-file-to-memory (lambda (address len protection flag fileno :optional offset)))
+ (memory-mapped-file-pointer (lambda (mmap)))
+ (memory-mapped-file? (lambda (obj)))
+ (open-input-file* (lambda (fileno :optional (flags open-mode open/binary open/excl open/fsync open/noctty open/nonblock open/rdonly open/rdwr open/read open/sync open/text))))
+ (open-input-pipe (lambda (cmdline-string :optional mode)))
+ (open-output-file* (lambda (fileno :optional (flags open-mode open/append open/binary open/creat open/excl open/fsync open/noctty open/nonblock open/rdwr open/sync open/text open/trunc open/write open/wronly))))
+ (open-output-pipe (lambda (cmdline-string :optional mode)))
+;; (open/append integer)
+;; (open/binary integer)
+;; (open/creat integer)
+;; (open/excl integer)
+;; (open/fsync integer)
+;; (open/noctty integer)
+;; (open/nonblock integer)
+;; (open/rdonly integer)
+;; (open/rdwr integer)
+;; (open/read integer)
+;; (open/sync integer)
+;; (open/text integer)
+;; (open/trunc integer)
+;; (open/write integer)
+;; (open/wronly integer)
+ (parent-process-id (lambda ()))
+;; (perm/irgrp integer)
+;; (perm/iroth integer)
+;; (perm/irusr integer)
+;; (perm/irwxg integer)
+;; (perm/irwxo integer)
+;; (perm/irwxu integer)
+;; (perm/isgid integer)
+;; (perm/isuid integer)
+;; (perm/isvtx integer)
+;; (perm/iwgrp integer)
+;; (perm/iwoth integer)
+;; (perm/iwusr integer)
+;; (perm/ixgrp integer)
+;; (perm/ixoth integer)
+;; (perm/ixusr integer)
+;; (pipe/buf integer)
+ (port->fileno (lambda (port)))
+ (process (lambda (cmdline-string :optional arg-list env-list)))
+ (process-execute (lambda (filename :optional arg-list env-list)))
+ (process-fork (lambda (:optional thunk)))
+ (process-group-id (lambda ()))
+ (process-run (lambda (filename :optional list)))
+ (process-signal (lambda (pid :optional signal)))
+ (process-wait (lambda (:optional pid nohang?)))
+ (read-symbolic-link (lambda (filename) filename))
+ (regular-file? (lambda (filename)))
+ (seconds->local-time (lambda (seconds)))
+ (seconds->string (lambda (seconds)))
+ (seconds->utc-time (lambda (seconds)))
+ (set-alarm! (lambda (seconds)))
+ (set-buffering-mode! (lambda (port mode :optional buf-size)))
+ (set-file-position! (lambda (port-or-fileno pos :optional whence)))
+ (set-group-id! (lambda (n)))
+ (set-groups! (lambda (group-n-list)))
+ (set-process-group-id! (lambda (process-n n)))
+ (set-root-directory! (lambda (dir)) "chroot")
+ (set-signal-handler! (lambda (sig-n proc)))
+ (set-signal-mask! (lambda (sig-n-list)))
+ (set-user-id! (lambda (n)))
+ (setenv (lambda (name value-string)))
+;; (signal/abrt integer)
+;; (signal/alrm integer)
+;; (signal/chld integer)
+;; (signal/cont integer)
+;; (signal/fpe integer)
+;; (signal/hup integer)
+;; (signal/ill integer)
+;; (signal/int integer)
+;; (signal/io integer)
+;; (signal/kill integer)
+;; (signal/pipe integer)
+;; (signal/prof integer)
+;; (signal/quit integer)
+;; (signal/segv integer)
+;; (signal/stop integer)
+;; (signal/term integer)
+;; (signal/trap integer)
+;; (signal/tstp integer)
+;; (signal/urg integer)
+;; (signal/usr1 integer)
+;; (signal/usr2 integer)
+;; (signal/vtalrm integer)
+;; (signal/winch integer)
+;; (signal/xcpu integer)
+;; (signal/xfsz integer)
+ (sleep (lambda (seconds)))
+ (symbolic-link? (lambda (filename)))
+ (system-information (lambda ()))
+ (terminal-name (lambda (port)))
+ (terminal-port? (lambda (port)))
+ (time->string (lambda (vector)))
+ (unmap-file-from-memory (lambda (mmap :optional len)))
+ (unsetenv (lambda (name) undefined))
+ (user-information (lambda ((or integer (string scheme-complete-user-name))) list))
+ (utc-time->seconds (lambda (vector)))
+ (with-input-from-pipe (lambda (cmdline-string thunk :optional mode)))
+ (with-output-to-pipe (lambda (cmdline-string thunk :optional mode)))
+ )
+ (regex
+ (glob->regexp (lambda (pattern)))
+ (glob? (lambda (obj)))
+ (grep (lambda (pattern list) list))
+ (regexp (lambda (pattern ignore-case? ignore-space? utf-8?)))
+ (regexp-escape (lambda (str) str))
+ (regexp? (lambda (obj) bool))
+ (string-match (lambda (pattern str :optional start)))
+ (string-match-positions (lambda (pattern str :optional start)))
+ (string-search (lambda (pattern str :optional start)))
+ (string-search-positions (lambda (pattern str :optional start)))
+ (string-split-fields (lambda (pattern str :optional mode start)))
+ (string-substitute (lambda (pattern subst str :optional mode)))
+ (string-substitute* (lambda (str subst-list :optional mode)))
+ )
+ (tcp
+ (tcp-abandon-port (lambda (port)))
+ (tcp-accept (lambda (listener)))
+ (tcp-accept-ready? (lambda (listener)))
+ (tcp-addresses (lambda (port)))
+ (tcp-buffer-size (lambda (:optional new-size)))
+ (tcp-close (lambda (listener)))
+ (tcp-connect (lambda ((string scheme-complete-host-name) :optional (string scheme-complete-port-name))))
+ (tcp-listen (lambda (tcp-port-n :optional backlog-n host-string)))
+ (tcp-listener-fileno (lambda (listener)))
+ (tcp-listener-port (lambda (listener)))
+ (tcp-listener? (lambda (obj)))
+ (tcp-port-numbers (lambda (port)))
+ )
+ (utils
+ (absolute-pathname? (lambda (pathname)))
+ (create-temporary-file (lambda (:optional ext-str)))
+ (decompose-pathname (lambda (pathname)))
+ (delete-file* (lambda (filename)))
+ (for-each-argv-line (lambda (proc) undefined))
+ (for-each-line (lambda (proc :optional input-port) undefined))
+ (make-absolute-pathname (lambda (dir filename :optional ext-str)))
+ (make-pathname (lambda (dir filename :optional ext-str)))
+ (pathname-directory (lambda (pathname)))
+ (pathname-extension (lambda (pathname)))
+ (pathname-file (lambda (pathname)))
+ (pathname-replace-directory (lambda (pathname dir)))
+ (pathname-replace-extension (lambda (pathname ext-str)))
+ (pathname-replace-file (lambda (pathname filename)))
+ (pathname-strip-directory (lambda (pathname)))
+ (pathname-strip-extension (lambda (pathname)))
+ (port-for-each (lambda (read-fn thunk) undefined))
+ (port-map (lambda (read-fn thunk)))
+ (read-all (lambda (:optional file-or-port)))
+ (shift! (lambda (list :optional default)))
+ (system* (lambda (format-string arg1 \.\.\.)))
+ (unshift! (lambda (obj pair)))
+ )
+ ))
+
+;; another big table - consider moving to a separate file
+(defvar *scheme-implementation-exports*
+ '((chicken
+ (abort (lambda (obj) undefined))
+ (add1 (lambda (z) z))
+ (andmap (lambda (pred list) bool))
+ (any? (lambda (obj) bool))
+ (argc+argv (lambda () (values n ptr)))
+ (argv (lambda () list))
+ (bit-set? (lambda (n index) bool))
+ (bitwise-and (lambda (n \.\.\.) n))
+ (bitwise-ior (lambda (n \.\.\.) n))
+ (bitwise-not (lambda (n \.\.\.) n))
+ (bitwise-xor (lambda (n \.\.\.) n))
+ (blob->string (lambda (blob) string))
+ (blob-size (lambda (blob) n))
+ (blob? (lambda (obj) bool))
+ (breakpoint (lambda (:optional name)))
+ (build-platform (lambda () symbol))
+ (c-runtime (lambda () symbol))
+ (call/cc (lambda (proc)))
+ (case-sensitive (lambda (:optional on?)))
+ (chicken-home (lambda () string))
+ (chicken-version (lambda () string))
+ (command-line-arguments (lambda () list))
+ (cond-expand (syntax))
+ (condition-predicate (lambda (kind) pred))
+ (condition-property-accessor (lambda (kind prop :optional err?) proc))
+ (condition? (lambda (obj) bool))
+ (continuation-capture (lambda (proc)))
+ (continuation-graft (lambda (continuation thunk)))
+ (continuation-return (lambda (continuation vals\.\.\.)))
+ (continuation? (lambda (obj) bool))
+ (copy-read-table (lambda (read-table) read-table))
+ (cpu-time (lambda () (values n n)))
+ (current-error-port (lambda () output-port))
+ (current-exception-handler (lambda () proc))
+ (current-gc-milliseconds (lambda () n))
+ (current-milliseconds (lambda () n))
+ (current-read-table (lambda () read-table))
+ (current-seconds (lambda () x1))
+ (define-reader-ctor (lambda (sym proc) undefined))
+ (delete-file (lambda (filename) undefined))
+ (disable-interrupts (lambda () undefined))
+ (dynamic-load-libraries (lambda () list))
+ (dynamic-wind (lambda (before-thunk thunk after-thunk)))
+ (enable-interrupts (lambda () undefined))
+ (enable-warnings (lambda () undefined))
+ (errno (lambda () n))
+ (error (lambda (error-string args \.\.\.) undefined))
+ (eval-handler (lambda () proc))
+ (exit (lambda (:optional n) undefined))
+ (exit-handler (lambda () proc))
+ (extension-info (lambda (proc)))
+ (extension-information (lambda (proc)))
+ (feature? (lambda (sym) bool))
+ (features (lambda () list))
+ (file-exists? (lambda (filename) bool))
+ (finite? (lambda (z) bool))
+ (fixnum? (lambda (obj) bool))
+ (flonum? (lambda (obj) bool))
+ (flush-output (lambda (:optional port) undefined))
+ (force (lambda (promise)))
+ (force-finalizers (lambda (f args \.\.\.)))
+ (fp* (lambda (x1 x2) x3))
+ (fp+ (lambda (x1 x2) x3))
+ (fp- (lambda (x1 x2) x3))
+ (fp/ (lambda (x1 x2) x3))
+ (fp< (lambda (x1 x2) x3))
+ (fp<= (lambda (x1 x2) x3))
+ (fp= (lambda (x1 x2) x3))
+ (fp> (lambda (x1 x2) x3))
+ (fp>= (lambda (x1 x2) x3))
+ (fpmax (lambda (x1 x2) x3))
+ (fpmin (lambda (x1 x2) x3))
+ (fpneg (lambda (x1 x2) x3))
+ (fx* (lambda (n1 n2) n))
+ (fx+ (lambda (n1 n2) n))
+ (fx- (lambda (n1 n2) n))
+ (fx/ (lambda (n1 n2) n))
+ (fx< (lambda (n1 n2) n))
+ (fx<= (lambda (n1 n2) n))
+ (fx= (lambda (n1 n2) n))
+ (fx> (lambda (n1 n2) n))
+ (fx>= (lambda (n1 n2) n))
+ (fxand (lambda (n1 n2) n))
+ (fxior (lambda (n1 n2) n))
+ (fxmax (lambda (n1 n2) n))
+ (fxmin (lambda (n1 n2) n))
+ (fxmod (lambda (n1 n2) n))
+ (fxneg (lambda (n1 n2) n))
+ (fxnot (lambda (n1 n2) n))
+ (fxshl (lambda (n1 n2) n))
+ (fxshr (lambda (n1 n2) n))
+ (fxxor (lambda (n1 n2) n))
+ (gc (lambda () n))
+ (gensym (lambda (:optional name) sym))
+ (get-call-chain (lambda (:optional n) list))
+ (get-keyword (lambda (sym list :optional default)))
+ (get-line-number (lambda (sexp) n))
+ (get-output-string (lambda (string-output-port) string))
+ (getenv (lambda (name) string))
+ (getter-with-setter (lambda (get-proc set-proc) proc))
+ (implicit-exit-handler (lambda (:optional proc) proc))
+ (invalid-procedure-call-handler (lambda (:optional proc) proc))
+ (keyword->string (lambda (sym) string))
+ (keyword-style (lambda (:optional sym) sym))
+ (keyword? (lambda (obj) bool))
+ (load-library (lambda (sym) undefined))
+ (load-noisily (lambda (string) undefined))
+ (load-relative (lambda (string) undefined))
+ (load-verbose (lambda (:optional bool) bool))
+ (machine-byte-order (lambda () sym))
+ (machine-type (lambda () sym))
+ (macro? (lambda (obj) bool))
+ (macroexpand (lambda (sexp) sexp))
+ (macroexpand-1 (lambda (sexp) sexp))
+ (make-blob (lambda (size) blob))
+ (make-composite-condition (lambda (condition \.\.\.) condition))
+ (make-parameter (lambda (val) proc))
+ (make-property-condition (lambda (kind \.\.\.) condition))
+ (match-error-control (lambda (:optional proc) proc))
+ (match-error-procedure (lambda (:optional proc) proc))
+ (memory-statistics (lambda () vector))
+ (on-exit (lambda (thunk) undefined))
+ (open-input-string (lambda (string) string-input-port))
+ (open-output-string (lambda () string-output-port))
+ (ormap (lambda (pred list \.\.\.) bool))
+ (port-name (lambda (:optional port) name))
+ (port-position (lambda (:optional port) n))
+ (port? (lambda (obj) bool))
+ (print (lambda (obj \.\.\.) undefined))
+ (print* (lambda (obj \.\.\.) undefined))
+ (print-backtrace (lambda (:optional n) undefined))
+ (print-call-chain (lambda (:optional n) undefined))
+ (print-error-message (lambda (err args \.\.\.) undefined))
+ (procedure-information (lambda (proc)))
+ (program-name (lambda (:optional name) name))
+ (provide (lambda (name)))
+ (provided? (lambda (name) bool))
+ (rational? (lambda (obj) bool))
+ (read-byte (lambda (:optional input-port) n))
+ (register-feature! (lambda (name) undefined))
+ (rename-file (lambda (old-name new-name) undefined))
+ (repl (lambda () undefined))
+ (repository-path (lambda (:optional dirname) dirname))
+ (require (lambda (sym \.\.\.) undefined))
+ (reset (lambda () undefined))
+ (reset-handler (lambda (:optional proc) proc))
+ (return-to-host (lambda () undefined))
+ (reverse-list->string (lambda (list) string))
+ (set-dynamic-load-mode! (lambda (obj) undefined))
+ (set-extension-specifier! (lambda (name proc) undefined))
+ (set-finalizer! (lambda (obj proc) undefined))
+ (set-gc-report! (lambda (bool) undefined))
+ (set-parameterized-read-syntax! (lambda (ch proc) undefined))
+ (set-port-name! (lambda (port name) undefined))
+ (set-read-syntax! (lambda (ch proc) undefined))
+ (set-sharp-read-syntax! (lambda (ch proc) undefined))
+ (setter (lambda (proc) proc))
+ (signal (lambda (n) undefined))
+ (signum (lambda (x1) x2))
+ (singlestep (lambda (thunk)))
+ (software-type (lambda () sym))
+ (software-version (lambda () sym))
+ (string->blob (lambda (string) blob))
+ (string->keyword (lambda (string) sym))
+ (string->uninterned-symbol (lambda (string) sym))
+ (string-copy (lambda (string) string))
+ (sub1 (lambda (z1) z2))
+ (syntax-error (lambda (args \.\.\.) undefined))
+ (system (lambda (str) n))
+ (test-feature? (lambda (obj) bool))
+ (undefine-macro! (lambda (sym) undefined))
+ (unregister-feature! (lambda (sym) undefined))
+ (use (special symbol scheme-chicken-available-modules)
+ "import extensions into top-level namespace")
+ (vector-copy! (lambda (from-vector to-vector :optional start) undefined))
+ (vector-resize (lambda (vec n :optional init)))
+ (void (lambda () undefined))
+ (warning (lambda (msg-str args \.\.\.) undefined))
+ (with-exception-handler (lambda (handler thunk)))
+ (write-byte (lambda (n :optional output-port) undefined))
+ )
+ (gauche
+ (E2BIG integer)
+ (EACCES integer)
+ (EADDRINUSE integer)
+ (EADDRNOTAVAIL integer)
+ (EADV integer)
+ (EAFNOSUPPORT integer)
+ (EAGAIN integer)
+ (EALREADY integer)
+ (EBADE integer)
+ (EBADF integer)
+ (EBADFD integer)
+ (EBADMSG integer)
+ (EBADR integer)
+ (EBADRQC integer)
+ (EBADSLT integer)
+ (EBFONT integer)
+ (EBUSY integer)
+ (ECANCELED integer)
+ (ECHILD integer)
+ (ECHRNG integer)
+ (ECOMM integer)
+ (ECONNABORTED integer)
+ (ECONNREFUSED integer)
+ (ECONNRESET integer)
+ (EDEADLK integer)
+ (EDEADLOCK integer)
+ (EDESTADDRREQ integer)
+ (EDOM integer)
+ (EDOTDOT integer)
+ (EDQUOT integer)
+ (EEXIST integer)
+ (EFAULT integer)
+ (EFBIG integer)
+ (EHOSTDOWN integer)
+ (EHOSTUNREACH integer)
+ (EIDRM integer)
+ (EILSEQ integer)
+ (EINPROGRESS integer)
+ (EINTR integer)
+ (EINVAL integer)
+ (EIO integer)
+ (EISCONN integer)
+ (EISDIR integer)
+ (EISNAM integer)
+ (EKEYEXPIRED integer)
+ (EKEYREJECTED integer)
+ (EKEYREVOKED integer)
+ (EL2HLT integer)
+ (EL2NSYNC integer)
+ (EL3HLT integer)
+ (EL3RST integer)
+ (ELIBACC integer)
+ (ELIBBAD integer)
+ (ELIBEXEC integer)
+ (ELIBMAX integer)
+ (ELIBSCN integer)
+ (ELNRNG integer)
+ (ELOOP integer)
+ (EMEDIUMTYPE integer)
+ (EMFILE integer)
+ (EMLINK integer)
+ (EMSGSIZE integer)
+ (EMULTIHOP integer)
+ (ENAMETOOLONG integer)
+ (ENAVAIL integer)
+ (ENETDOWN integer)
+ (ENETRESET integer)
+ (ENETUNREACH integer)
+ (ENFILE integer)
+ (ENOANO integer)
+ (ENOBUFS integer)
+ (ENOCSI integer)
+ (ENODATA integer)
+ (ENODEV integer)
+ (ENOENT integer)
+ (ENOEXEC integer)
+ (ENOKEY integer)
+ (ENOLCK integer)
+ (ENOLINK integer)
+ (ENOMEDIUM integer)
+ (ENOMEM integer)
+ (ENOMSG integer)
+ (ENONET integer)
+ (ENOPKG integer)
+ (ENOPROTOOPT integer)
+ (ENOSPC integer)
+ (ENOSR integer)
+ (ENOSTR integer)
+ (ENOSYS integer)
+ (ENOTBLK integer)
+ (ENOTCONN integer)
+ (ENOTDIR integer)
+ (ENOTEMPTY integer)
+ (ENOTNAM integer)
+ (ENOTSOCK integer)
+ (ENOTTY integer)
+ (ENOTUNIQ integer)
+ (ENXIO integer)
+ (EOPNOTSUPP integer)
+ (EOVERFLOW integer)
+ (EPERM integer)
+ (EPFNOSUPPORT integer)
+ (EPIPE integer)
+ (EPROTO integer)
+ (EPROTONOSUPPORT integer)
+ (EPROTOTYPE integer)
+ (ERANGE integer)
+ (EREMCHG integer)
+ (EREMOTE integer)
+ (EREMOTEIO integer)
+ (ERESTART integer)
+ (EROFS integer)
+ (ESHUTDOWN integer)
+ (ESOCKTNOSUPPORT integer)
+ (ESPIPE integer)
+ (ESRCH integer)
+ (ESRMNT integer)
+ (ESTALE integer)
+ (ESTRPIPE integer)
+ (ETIME integer)
+ (ETIMEDOUT integer)
+ (ETOOMANYREFS integer)
+ (ETXTBSY integer)
+ (EUCLEAN integer)
+ (EUNATCH integer)
+ (EUSERS integer)
+ (EWOULDBLOCK integer)
+ (EXDEV integer)
+ (EXFULL integer)
+ (F_OK integer)
+ (LC_ALL integer)
+ (LC_COLLATE integer)
+ (LC_CTYPE integer)
+ (LC_MONETARY integer)
+ (LC_NUMERIC integer)
+ (LC_TIME integer)
+ (RAND_MAX integer)
+ (R_OK integer)
+ (SEEK_CUR integer)
+ (SEEK_END integer)
+ (SEEK_SET integer)
+ (SIGABRT integer)
+ (SIGALRM integer)
+ (SIGBUS integer)
+ (SIGCHLD integer)
+ (SIGCONT integer)
+ (SIGFPE integer)
+ (SIGHUP integer)
+ (SIGILL integer)
+ (SIGINT integer)
+ (SIGIO integer)
+ (SIGIOT integer)
+ (SIGKILL integer)
+ (SIGPIPE integer)
+ (SIGPOLL integer)
+ (SIGPROF integer)
+ (SIGPWR integer)
+ (SIGQUIT integer)
+ (SIGSEGV integer)
+ (SIGSTKFLT integer)
+ (SIGSTOP integer)
+ (SIGTERM integer)
+ (SIGTRAP integer)
+ (SIGTSTP integer)
+ (SIGTTIN integer)
+ (SIGTTOU integer)
+ (SIGURG integer)
+ (SIGUSR1 integer)
+ (SIGUSR2 integer)
+ (SIGVTALRM integer)
+ (SIGWINCH integer)
+ (SIGXCPU integer)
+ (SIGXFSZ integer)
+ (SIG_BLOCK integer)
+ (SIG_SETMASK integer)
+ (SIG_UNBLOCK integer)
+ (W_OK integer)
+ (X_OK integer)
+ (acons (lambda (key value alist) alist))
+ (acosh (lambda (z) z))
+ (add-load-path (lambda (path) undefined))
+ (add-method! (lambda (generic method) undefined))
+ (all-modules (lambda () list))
+ (allocate-instance (lambda (class list)))
+ (and-let* (syntax))
+ (any (lambda (pred list)))
+ (any$ (lambda (pred) proc))
+ (any-pred (lambda (pred \.\.\.) pred))
+ (append! (lambda (list \.\.\.) list))
+ (apply$ (lambda (proc) proc))
+ (apply-generic (lambda (generic list)))
+ (apply-method (lambda (method list)))
+ (apply-methods (lambda (generic list list)))
+ (arity (lambda (proc) n))
+ (arity-at-least-value (lambda (n)))
+ (arity-at-least? (lambda (proc) bool))
+ (ash (lambda (n i) n))
+ (asinh (lambda (z) z))
+ (assoc$ (lambda (obj) proc))
+ (atanh (lambda (z) z))
+ (autoload (syntax))
+ (begin0 (syntax))
+ (bignum? (lambda (obj) bool))
+ (bit-field (lambda (n start end) n))
+ (byte-ready? (lambda (:optional input-port) bool))
+ (call-with-input-string (lambda (str proc)))
+ (call-with-output-string (lambda (proc) str))
+ (call-with-string-io (lambda (str proc) str))
+ (case-lambda (syntax))
+ (change-class (lambda (obj new-class)))
+ (change-object-class (lambda (obj orig-class new-class)))
+ (char->ucs (lambda (ch) int))
+ (char-set (lambda (ch \.\.\.) char-set))
+ (char-set-contains? (lambda (char-set ch) bool))
+ (char-set-copy (lambda (char-set) char-set))
+ (char-set? (lambda (obj) bool))
+ (check-arg (syntax))
+ (circular-list? (lambda (obj) bool))
+ (clamp (lambda (x1 :optional min-x max-x) x2))
+ (class-direct-methods (lambda (class) list))
+ (class-direct-slots (lambda (class) list))
+ (class-direct-subclasses (lambda (class) list))
+ (class-direct-supers (lambda (class) list))
+ (class-name (lambda (class) sym))
+ (class-of (lambda (obj) class))
+ (class-precedence-list (lambda (class) list))
+ (class-slot-accessor (lambda (class id) proc))
+ (class-slot-bound? (lambda (class id) bool))
+ (class-slot-definition (lambda (class id)))
+ (class-slot-ref (lambda (class slot)))
+ (class-slot-set! (lambda (class slot val) undefined))
+ (class-slots (lambda (class) list))
+ (closure-code (lambda (proc)))
+ (closure? (lambda (obj) bool))
+ (compare (lambda (obj1 obj2) n))
+ (complement (lambda (proc) proc))
+ (compose (lambda (proc \.\.\.) proc))
+ (compute-applicable-methods (lambda (generic list)))
+ (compute-cpl (lambda (generic list)))
+ (compute-get-n-set (lambda (class slot)))
+ (compute-slot-accessor (lambda (class slot)))
+ (compute-slots (lambda (class)))
+ (cond-expand (syntax))
+ (condition (syntax))
+ (condition-has-type? (lambda (condition obj)))
+ (condition-ref (lambda (condition id)))
+ (condition-type? (lambda (obj) bool))
+ (condition? (lambda (obj) bool))
+ (copy-bit (lambda (index n i) n))
+ (copy-bit-field (lambda (n start end from) n))
+ (copy-port (lambda (from-port to-port :optional unit-sym) undefined))
+ (cosh (lambda (z) z))
+ (count$ (lambda (pred) proc))
+ (current-class-of (lambda (obj) class))
+ (current-error-port (lambda () output-port))
+ (current-exception-handler (lambda () handler))
+ (current-load-history (lambda () list))
+ (current-load-next (lambda () list))
+ (current-load-port (lambda () port))
+ (current-module (lambda () env))
+ (current-thread (lambda () thread))
+ (current-time (lambda () time))
+ (cut (syntax))
+ (cute (lambda (args \.\.\.) proc))
+ (debug-print (lambda (obj)))
+ (debug-print-width (lambda () int))
+ (debug-source-info (lambda (obj)))
+ (dec! (syntax))
+ (decode-float (lambda (x1) vector))
+ (define-class (syntax))
+ (define-condition-type (syntax))
+ (define-constant (syntax))
+ (define-generic (syntax))
+ (define-in-module (syntax))
+ (define-inline (syntax))
+ (define-macro (syntax))
+ (define-method (syntax))
+ (define-module (syntax))
+ (define-reader-ctor (lambda (sym proc) undefined))
+ (define-values (syntax))
+ (delete$ (lambda (obj) proc))
+ (delete-keyword (lambda (id list) list))
+ (delete-keyword! (lambda (id list) list))
+ (delete-method! (lambda (generic method) undefined))
+ (digit->integer (lambda (ch) n))
+ (disasm (lambda (proc) undefined))
+ (dolist (syntax))
+ (dotimes (syntax))
+ (dotted-list? (lambda (obj) bool))
+ (dynamic-load (lambda (file)))
+ (eager (lambda (obj)))
+ (eq-hash (lambda (obj)))
+ (eqv-hash (lambda (obj)))
+ (error (lambda (msg-string args \.\.\.)))
+ (errorf (lambda (fmt-string args \.\.\.)))
+ (eval-when (syntax))
+ (every$ (lambda (pred) pred))
+ (every-pred (lambda (pred \.\.\.) pred))
+ (exit (lambda (:optional n) undefined))
+ (export (syntax))
+ (export-all (syntax))
+ (export-if-defined (syntax))
+ (extend (syntax))
+ (extract-condition (lambda (condition type)))
+ (file-exists? (lambda (filename) bool))
+ (file-is-directory? (lambda (filename) bool))
+ (file-is-regular? (lambda (filename) bool))
+ (filter$ (lambda (pred) proc))
+ (find (lambda (pred list)))
+ (find$ (lambda (pred) proc))
+ (find-module (lambda (id) env))
+ (find-tail$ (lambda (pred) proc))
+ (fixnum? (lambda (obj) bool))
+ (flonum? (lambda (obj) bool))
+ (fluid-let (syntax))
+ (flush (lambda (:optional output-port) undefined))
+ (flush-all-ports (lambda () undefined))
+ (fmod (lambda (x1 x2) x3))
+ (fold (lambda (proc init list)))
+ (fold$ (lambda (proc :optional init) proc))
+ (fold-right (lambda (proc init list)))
+ (fold-right$ (lambda (proc :optional init)))
+ (for-each$ (lambda (proc) (lambda (ls) undefined)))
+ (foreign-pointer-attribute-get (lambda (ptr attr)))
+ (foreign-pointer-attribute-set (lambda (ptr attr val)))
+ (foreign-pointer-attributes (lambda (ptr) list))
+ (format (lambda (fmt-string arg \.\.\.)))
+ (format/ss (lambda (fmt-string arg \.\.\.)))
+ (frexp (lambda (x1) x2))
+ (gauche-architecture (lambda () string))
+ (gauche-architecture-directory (lambda () string))
+ (gauche-character-encoding (lambda () symbol))
+ (gauche-dso-suffix (lambda () string))
+ (gauche-library-directory (lambda () string))
+ (gauche-site-architecture-directory (lambda () string))
+ (gauche-site-library-directory (lambda () string))
+ (gauche-version (lambda () string))
+ (gc (lambda () undefined))
+ (gc-stat (lambda () list))
+ (gensym (lambda (:optional name) symbol))
+ (get-keyword (lambda (id list :optional default)))
+ (get-keyword* (syntax))
+ (get-optional (syntax))
+ (get-output-string (lambda (string-output-port) string))
+ (get-remaining-input-string (lambda (port) string))
+ (get-signal-handler (lambda (n) proc))
+ (get-signal-handler-mask (lambda (n) n))
+ (get-signal-handlers (lambda () list))
+ (get-signal-pending-limit (lambda () n))
+ (getter-with-setter (lambda (get-proc set-proc) proc))
+ (global-variable-bound? (lambda (sym) bool))
+ (global-variable-ref (lambda (sym)))
+ (guard (syntax))
+ (has-setter? (lambda (proc) bool))
+ (hash (lambda (obj)))
+ (hash-table (lambda (id pair \.\.\.) hash-table))
+ (hash-table-delete! (lambda (hash-table key) undefined))
+ (hash-table-exists? (lambda (hash-table key) bool))
+ (hash-table-fold (lambda (hash-table proc init)))
+ (hash-table-for-each (lambda (hash-table proc) undefined))
+ (hash-table-get (lambda (hash-table key :optional default)))
+ (hash-table-keys (lambda (hash-table) list))
+ (hash-table-map (lambda (hash-table proc) list))
+ (hash-table-num-entries (lambda (hash-table) n))
+ (hash-table-pop! (lambda (hash-table key :optional default)))
+ (hash-table-push! (lambda (hash-table key value) undefined))
+ (hash-table-put! (lambda (hash-table key value) undefined))
+ (hash-table-stat (lambda (hash-table) list))
+ (hash-table-type (lambda (hash-table) id))
+ (hash-table-update! (lambda (hash-table key proc :optional default) undefined))
+ (hash-table-values (lambda (hash-table) list))
+ (hash-table? (lambda (obj) bool))
+ (identifier->symbol (lambda (obj) sym))
+ (identifier? (lambda (obj) bool))
+ (identity (lambda (obj)))
+ (import (syntax))
+ (inc! (syntax))
+ (inexact-/ (lambda (x1 x2) x3))
+ (initialize (lambda (obj)))
+ (instance-slot-ref (lambda (obj id)))
+ (instance-slot-set (lambda (obj id value)))
+ (integer->digit (lambda (n) ch))
+ (integer-length (lambda (n) n))
+ (is-a? (lambda (obj class) bool))
+ (keyword->string (lambda (id) string))
+ (keyword? (lambda (obj) bool))
+ (last-pair (lambda (pair) pair))
+ (lazy (syntax))
+ (ldexp (lambda (x1 n) x2))
+ (let-keywords* (syntax))
+ (let-optionals* (syntax))
+ (let/cc (syntax))
+ (let1 (syntax))
+ (library-exists? (lambda (filename) bool))
+ (library-fold (lambda (string proc init)))
+ (library-for-each (lambda (string proc) undefined))
+ (library-has-module? (lambda (filename id) bool))
+ (library-map (lambda (string proc) list))
+ (list* (lambda (obj \.\.\.) list))
+ (list-copy (lambda (list) list))
+ (logand (lambda (n \.\.\.) n))
+ (logbit? (lambda (index n) bool))
+ (logcount (lambda (n) n))
+ (logior (lambda (n \.\.\.) n))
+ (lognot (lambda (n) n))
+ (logtest (lambda (n \.\.\.) bool))
+ (logxor (lambda (n \.\.\.) n))
+ (macroexpand (lambda (obj)))
+ (macroexpand-1 (lambda (obj)))
+ (make (lambda (class args \.\.\.)))
+ (make-byte-string (lambda (n :optional int) byte-string))
+ (make-compound-condition (lambda (condition \.\.\.) condition))
+ (make-condition (lambda (condition-type field+value \.\.\.) condition))
+ (make-condition-type (lambda (id condition-type list) condition-type))
+ (make-hash-table (lambda (:optional id) hash-table))
+ (make-keyword (lambda (string) sym))
+ (make-list (lambda (n :optional init) list))
+ (make-module (lambda (id :optional if-exists-proc) env))
+ (make-weak-vector (lambda (n) vector))
+ (map$ (lambda (proc) proc))
+ (member$ (lambda (obj) proc))
+ (merge (lambda (list1 list2 proc) list))
+ (merge! (lambda (list1 list2 proc) list))
+ (method-more-specific? (lambda (method1 method2 list) bool))
+ (min&max (lambda (x1 \.\.\.) (values x2 x3)))
+ (modf (lambda (x1) x2))
+ (module-exports (lambda (env) list))
+ (module-imports (lambda (env) list))
+ (module-name (lambda (env) sym))
+ (module-name->path (lambda (sym) string))
+ (module-parents (lambda (env) list))
+ (module-precedence-list (lambda (env) list))
+ (module-table (lambda (env) hash-table))
+ (module? (lambda (obj) bool))
+ (null-list? (lambda (obj) bool))
+ (object-* (lambda (z \.\.\.) z))
+ (object-+ (lambda (z \.\.\.) z))
+ (object-- (lambda (z \.\.\.) z))
+ (object-/ (lambda (z \.\.\.) z))
+ (object-apply (lambda (proc arg \.\.\.)))
+ (object-compare (lambda (obj1 obj2) n))
+ (object-equal? (lambda (obj1 obj2) bool))
+ (object-hash (lambda (obj) n))
+ (open-coding-aware-port (lambda (input-port) input-port))
+ (open-input-buffered-port (lambda ()))
+ (open-input-fd-port (lambda (fileno) input-port))
+ (open-input-string (lambda (str) input-port))
+ (open-output-buffered-port (lambda ()))
+ (open-output-fd-port (lambda (fileno) output-port))
+ (open-output-string (lambda () string-output-port))
+ (pa$ (lambda (proc arg \.\.\.) proc))
+ (partition$ (lambda (pred) proc))
+ (path->module-name (lambda (str) sym))
+ (peek-byte (lambda (:optional input-port) n))
+ (pop! (syntax (list)))
+ (port->byte-string (lambda (input-port) byte-string))
+ (port->list (lambda (proc input-port) list))
+ (port->sexp-list (lambda (port) list))
+ (port->string (lambda (port) string))
+ (port->string-list (lambda (port) list))
+ (port-buffering (lambda (port) sym))
+ (port-closed? (lambda (port) bool))
+ (port-current-line (lambda (port) n))
+ (port-file-number (lambda (port) n))
+ (port-fold (lambda (proc init port)))
+ (port-fold-right (lambda (proc init port)))
+ (port-for-each (lambda (proc read-proc) undefined))
+ (port-map (lambda (proc read-proc)))
+ (port-name (lambda (port) name))
+ (port-position-prefix (lambda ()))
+ (port-seek (lambda (port offset (set int SEEK_SET SEEK_CUR SEEK_END))))
+ (port-tell (lambda (port) n))
+ (port-type (lambda (port) sym))
+ (print (lambda (obj \.\.\.)))
+ (procedure-arity-includes? (lambda (proc n) bool))
+ (procedure-info (lambda (proc)))
+ (profiler-reset (lambda () undefined))
+ (profiler-show (lambda () undefined))
+ (profiler-show-load-stats (lambda () undefined))
+ (profiler-start (lambda () undefined))
+ (profiler-stop (lambda () undefined))
+ (program (syntax))
+ (promise-kind (lambda ()))
+ (promise? (lambda (obj) bool))
+ (proper-list? (lambda (obj) bool))
+ (provide (lambda (str) undefined))
+ (provided? (lambda (str) bool))
+ (push! (syntax))
+ (quotient&remainder (lambda (n1 n2) (values n1 n2)))
+ (raise (lambda (exn) undefined))
+ (read-block (lambda (n :optional input-port) string))
+ (read-byte (lambda (:optional input-port) n))
+ (read-eval-print-loop (lambda () undefined))
+ (read-from-string (lambda (str)))
+ (read-line (lambda (:optional input-port) str))
+ (read-list (lambda (ch :optional input-port)))
+ (read-reference-has-value? (lambda ()))
+ (read-reference-value (lambda ()))
+ (read-reference? (lambda ()))
+ (read-with-shared-structure (lambda (:optional input-port)))
+ (read/ss (lambda (:optional input-port)))
+ (rec (syntax))
+ (receive (syntax))
+ (redefine-class! (lambda ()))
+ (reduce$ (lambda (proc :optional default) proc))
+ (reduce-right$ (lambda (proc :optional default) proc))
+ (ref (lambda (obj key \.\.\.)))
+ (ref* (lambda (obj key \.\.\.)))
+ (regexp->string (lambda (regexp) string))
+ (regexp-case-fold? (lambda (regexp) bool))
+ (regexp-compile (lambda (str) regexp))
+ (regexp-optimize (lambda (str) str))
+ (regexp-parse (lambda (str) list))
+ (regexp-quote (lambda (str) str))
+ (regexp-replace (lambda (regexp string subst) string))
+ (regexp-replace* (lambda (string regexp subst \.\.\.) string))
+ (regexp-replace-all (lambda (regexp string subst) string))
+ (regexp-replace-all* (lambda (string regexp subst \.\.\.)))
+ (regexp? (lambda (obj) bool))
+ (regmatch? (lambda (obj) bool))
+ (remove$ (lambda (pred) proc))
+ (report-error (lambda ()))
+ (require (syntax))
+ (require-extension (syntax))
+ (reverse! (lambda (list) list))
+ (rxmatch (lambda (regexp string) regmatch))
+ (rxmatch-after (lambda (regmatch :optional i) str))
+ (rxmatch-before (lambda (regmatch :optional i) str))
+ (rxmatch-case (syntax))
+ (rxmatch-cond (syntax))
+ (rxmatch-end (lambda (regmatch :optional i) n))
+ (rxmatch-if (syntax))
+ (rxmatch-let (syntax))
+ (rxmatch-num-matches (lambda (regmatch) i))
+ (rxmatch-start (lambda (regmatch :optional i) n))
+ (rxmatch-substring (lambda (regmatch :optional i) str))
+ (seconds->time (lambda (x1) time))
+ (select-module (syntax))
+ (set!-values (syntax))
+ (set-signal-handler! (lambda (signals handler) undefined))
+ (set-signal-pending-limit (lambda (n) undefined))
+ (setter (lambda (proc) proc))
+ (sinh (lambda (z) z))
+ (slot-bound-using-accessor? (lambda (proc obj id) bool))
+ (slot-bound-using-class? (lambda (class obj id) bool))
+ (slot-bound? (lambda (obj id) bool))
+ (slot-definition-accessor (lambda ()))
+ (slot-definition-allocation (lambda ()))
+ (slot-definition-getter (lambda ()))
+ (slot-definition-name (lambda ()))
+ (slot-definition-option (lambda ()))
+ (slot-definition-options (lambda ()))
+ (slot-definition-setter (lambda ()))
+ (slot-exists-using-class? (lambda (class obj id) bool))
+ (slot-exists? (lambda (obj id) bool))
+ (slot-initialize-using-accessor! (lambda ()))
+ (slot-missing (lambda (class obj id)))
+ (slot-push! (lambda (obj id value) undefined))
+ (slot-ref (lambda (obj id)))
+ (slot-ref-using-accessor (lambda (proc obj id)))
+ (slot-ref-using-class (lambda (class obj id)))
+ (slot-set! (lambda (obj id value) undefined))
+ (slot-set-using-accessor! (lambda (proc obj id value) undefined))
+ (slot-set-using-class! (lambda (class obj id value) undefined))
+ (slot-unbound (lambda (class obj id)))
+ (sort (lambda (seq :optional proc)))
+ (sort! (lambda (seq :optional proc)))
+ (sort-applicable-methods (lambda ()))
+ (sorted? (lambda (seq :optional proc)))
+ (split-at (lambda (list i) (values list list)))
+ (stable-sort (lambda (seq :optional proc)))
+ (stable-sort! (lambda (seq :optional proc)))
+ (standard-error-port (lambda () output-port))
+ (standard-input-port (lambda () input-port))
+ (standard-output-port (lambda () output-port))
+ (string->regexp (lambda (str) regexp))
+ (string-byte-ref (lambda (str i) n))
+ (string-byte-set! (lambda (str i n) undefined))
+ (string-complete->incomplete (lambda (str) str))
+ (string-immutable? (lambda (str) bool))
+ (string-incomplete->complete (lambda (str) str))
+ (string-incomplete->complete! (lambda (str) str))
+ (string-incomplete? (lambda (str) bool))
+ (string-interpolate (lambda (str) list))
+ (string-join (lambda (list :optional delim-str (set grammar infix strict-infix prefix suffix))))
+;; deprecated
+;; (string-pointer-byte-index (lambda ()))
+;; (string-pointer-copy (lambda ()))
+;; (string-pointer-index (lambda ()))
+;; (string-pointer-next! (lambda ()))
+;; (string-pointer-prev! (lambda ()))
+;; (string-pointer-ref (lambda ()))
+;; (string-pointer-set! (lambda ()))
+;; (string-pointer-substring (lambda ()))
+;; (string-pointer? (lambda ()))
+ (string-scan (lambda (string item :optional (set return index before after before* after* both))))
+ (string-size (lambda (str) n))
+ (string-split (lambda (str splitter) list))
+ (string-substitute! (lambda ()))
+ (subr? (lambda (obj) bool))
+ (supported-character-encoding? (lambda (id) bool))
+ (supported-character-encodings (lambda () list))
+ (symbol-bound? (lambda (id) bool))
+ (syntax-error (syntax))
+ (syntax-errorf (syntax))
+ (sys-abort (lambda () undefined))
+ (sys-access (lambda (filename (flags amode R_OK W_OK X_OK F_OK))))
+ (sys-alarm (lambda (x1) x2))
+ (sys-asctime (lambda (time) str))
+ (sys-basename (lambda (filename) str))
+ (sys-chdir (lambda (dirname)))
+ (sys-chmod (lambda (filename n)))
+ (sys-chown (lambda (filename uid gid)))
+ (sys-close (lambda (fileno)))
+ (sys-crypt (lambda (key-str salt-str) str))
+ (sys-ctermid (lambda () string))
+ (sys-ctime (lambda (time) string))
+ (sys-difftime (lambda (time1 time2) x1))
+ (sys-dirname (lambda (filename) string))
+ (sys-exec (lambda (command-string list) n))
+ (sys-exit (lambda (n) undefined))
+ (sys-fchmod (lambda (port-or-fileno n)))
+ (sys-fdset-max-fd (lambda (fdset)))
+ (sys-fdset-ref (lambda (fdset port-or-fileno)))
+ (sys-fdset-set! (lambda (fdset port-or-fileno)))
+ (sys-fork (lambda () n))
+ (sys-fork-and-exec (lambda (command-string list) n))
+ (sys-fstat (lambda (port-or-fileno) sys-stat))
+ (sys-ftruncate (lambda (port-or-fileno n)))
+ (sys-getcwd (lambda () string))
+ (sys-getdomainname (lambda () string))
+ (sys-getegid (lambda () gid))
+ (sys-getenv (lambda (name) string))
+ (sys-geteuid (lambda () uid))
+ (sys-getgid (lambda () gid))
+ (sys-getgrgid (lambda () gid))
+ (sys-getgrnam (lambda (name)))
+ (sys-getgroups (lambda () list))
+ (sys-gethostname (lambda () string))
+ (sys-getloadavg (lambda () list))
+ (sys-getlogin (lambda () string))
+ (sys-getpgid (lambda () gid))
+ (sys-getpgrp (lambda () gid))
+ (sys-getpid (lambda () pid))
+ (sys-getppid (lambda () pid))
+ (sys-getpwnam (lambda (name)))
+ (sys-getpwuid (lambda () uid))
+ (sys-gettimeofday (lambda () (values x1 x2)))
+ (sys-getuid (lambda () uid))
+ (sys-gid->group-name (lambda (gid) name))
+ (sys-glob (lambda (string) list))
+ (sys-gmtime (lambda (time) string))
+ (sys-group-name->gid (lambda (name) gid))
+ (sys-isatty (lambda (port-or-fileno) bool))
+ (sys-kill (lambda (pid)))
+ (sys-lchown (lambda (filename uid gid)))
+ (sys-link (lambda (old-filename new-filename)))
+ (sys-localeconv (lambda () alist))
+ (sys-localtime (lambda (time) string))
+ (sys-lstat (lambda (filename) sys-stat))
+ (sys-mkdir (lambda (dirname)))
+ (sys-mkfifo (lambda (filename)))
+ (sys-mkstemp (lambda (filename)))
+ (sys-mktime (lambda (time) x1))
+ (sys-nanosleep (lambda (x1)))
+ (sys-normalize-pathname (lambda (filename) string))
+ (sys-pause (lambda (x1)))
+ (sys-pipe (lambda (:optional buffering) (values input-port output-port)))
+ (sys-putenv (lambda (name string)))
+ (sys-random (lambda () n))
+ (sys-readdir (lambda (dirname) list))
+ (sys-readlink (lambda (filename) string))
+ (sys-realpath (lambda (filename) string))
+ (sys-remove (lambda (filename)))
+ (sys-rename (lambda (old-filename new-filename)))
+ (sys-rmdir (lambda (dirname)))
+ (sys-select (lambda (read-filenos write-filenos execpt-filenos :optional timeout-x)))
+ (sys-select! (lambda (read-filenos write-filenos execpt-filenos :optional timeout-x)))
+ (sys-setenv (lambda (name string)))
+ (sys-setgid (lambda (gid)))
+ (sys-setlocale (lambda (locale-string)))
+ (sys-setpgid (lambda (gid)))
+ (sys-setsid (lambda ()))
+ (sys-setuid (lambda (uid)))
+ (sys-sigmask (lambda ((set how SIG_SETMASK SIG_BLOCK SIG_UNBLOCK) sigset)))
+ (sys-signal-name (lambda (n)))
+ (sys-sigset (lambda (n \.\.\.) sigset))
+ (sys-sigset-add! (lambda (sigset n)))
+ (sys-sigset-delete! (lambda (sigset n)))
+ (sys-sigset-empty! (lambda (sigset)))
+ (sys-sigset-fill! (lambda (sigset)))
+ (sys-sigsuspend (lambda (sigset)))
+ (sys-sigwait (lambda (sigset)))
+ (sys-sleep (lambda (x1)))
+ (sys-srandom (lambda (n)))
+ (sys-stat (lambda (filename)))
+;; deprecated
+;; (sys-stat->atime (lambda ()))
+;; (sys-stat->ctime (lambda ()))
+;; (sys-stat->dev (lambda ()))
+;; (sys-stat->file-type (lambda ()))
+;; (sys-stat->gid (lambda ()))
+;; (sys-stat->ino (lambda ()))
+;; (sys-stat->mode (lambda ()))
+;; (sys-stat->mtime (lambda ()))
+;; (sys-stat->nlink (lambda ()))
+;; (sys-stat->rdev (lambda ()))
+;; (sys-stat->size (lambda ()))
+;; (sys-stat->type (lambda ()))
+;; (sys-stat->uid (lambda ()))
+ (sys-strerror (lambda (errno) string))
+ (sys-strftime (lambda (format-string time)))
+ (sys-symlink (lambda (old-filename new-filename)))
+ (sys-system (lambda (command) n))
+ (sys-time (lambda () n))
+ (sys-times (lambda () list))
+;; (sys-tm->alist (lambda ()))
+ (sys-tmpnam (lambda () string))
+ (sys-truncate (lambda (filename n)))
+ (sys-ttyname (lambda (port-or-fileno) string))
+ (sys-uid->user-name (lambda (uid) name))
+ (sys-umask (lambda () n))
+ (sys-uname (lambda () string))
+ (sys-unlink (lambda (filename)))
+ (sys-unsetenv (lambda (name)))
+ (sys-user-name->uid (lambda (name) uid))
+ (sys-utime (lambda (filename)))
+ (sys-wait (lambda ()))
+ (sys-wait-exit-status (lambda (n) n))
+ (sys-wait-exited? (lambda (n) bool))
+ (sys-wait-signaled? (lambda (n) bool))
+ (sys-wait-stopped? (lambda (n) bool))
+ (sys-wait-stopsig (lambda (n) n))
+ (sys-wait-termsig (lambda (n) n))
+ (sys-waitpid (lambda (pid)))
+ (tanh (lambda (z) z))
+ (time (syntax))
+ (time->seconds (lambda (time) x1))
+ (time? (lambda (obj) bool))
+ (toplevel-closure? (lambda (obj) bool))
+ (touch-instance! (lambda ()))
+ (ucs->char (lambda (n) ch))
+ (undefined (lambda () undefined))
+ (undefined? (lambda (obj) bool))
+ (unless (syntax))
+ (until (syntax))
+ (unwrap-syntax (lambda (obj)))
+ (update! (syntax))
+ (update-direct-method! (lambda ()))
+ (update-direct-subclass! (lambda ()))
+ (use (special symbol scheme-gauche-available-modules))
+ (use-version (syntax))
+ (values-ref (syntax))
+ (vector-copy (lambda (vector :optional start end fill) vector))
+ (vm-dump (lambda () undefined))
+ (vm-get-stack-trace (lambda () undefined))
+ (vm-get-stack-trace-lite (lambda () undefined))
+ (vm-set-default-exception-handler (lambda (handler) undefined))
+ (warn (lambda (message-str args) undefined))
+ (weak-vector-length (lambda (vector) n))
+ (weak-vector-ref (lambda (vector i)))
+ (weak-vector-set! (lambda (vector i value) undefined))
+ (when (syntax))
+ (while (syntax))
+ (with-error-handler (lambda (handler thunk)))
+ (with-error-to-port (lambda (port thunk)))
+ (with-exception-handler (lambda (handler thunk)))
+ (with-input-from-port (lambda (port thunk)))
+ (with-input-from-string (lambda (string thunk)))
+ (with-module (syntax))
+ (with-output-to-port (lambda (port thunk)))
+ (with-output-to-string (lambda (thunk) string))
+ (with-port-locking (lambda (port thunk)))
+ (with-ports (lambda (input-port output-port error-port thunk)))
+ (with-signal-handlers (syntax))
+ (with-string-io (lambda (string thunk) string))
+ (write* (lambda (obj :optional output-port) undefined))
+ (write-byte (lambda (n :optional output-port) undefined))
+ (write-limited (lambda (obj :optional output-port)))
+ (write-object (lambda (obj output-port)))
+ (write-to-string (lambda (obj) string))
+ (write-with-shared-structure (lambda (obj :optional output-port)))
+ (write/ss (lambda (obj :optional output-port)))
+ (x->integer (lambda (obj) integer))
+ (x->number (lambda (obj) number))
+ (x->string (lambda (obj) string))
+ )))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; special lookups (XXXX add more impls, try to abstract better)
+
+(defvar *scheme-chicken-base-repo*
+ (or (getenv "CHICKEN_REPOSITORY")
+ (let ((dir
+ (car (remove-if-not #'file-directory-p
+ '("/usr/lib/chicken"
+ "/usr/local/lib/chicken"
+ "/opt/lib/chicken"
+ "/opt/local/lib/chicken"
+ )))))
+ (and dir
+ (car (reverse (sort (directory-files dir t "^[0-9]+$")
+ #'string-lessp)))))
+ (and (fboundp 'shell-command-to-string)
+ (let* ((res (shell-command-to-string
+ "csi -e '(print (repository-path))'"))
+ (res (substring res 0 (- (length res) 1))))
+ (and res (file-directory-p res) res)))
+ "/usr/local/lib/chicken"))
+
+(defvar *scheme-chicken-repo-dirs*
+ (remove-if-not
+ #'(lambda (x) (and (stringp x) (not (equal x ""))))
+ (let ((home (getenv "CHICKEN_HOME")))
+ (if (and home (not (equal home "")))
+ (let ((res (split-string home ";"))) ;
+ (if (member *scheme-chicken-base-repo* res)
+ res
+ (cons *scheme-chicken-repo-dirs* res)))
+ (list *scheme-chicken-base-repo*)))))
+
+(defun scheme-chicken-available-modules (&optional sym)
+ (append
+ (mapcar #'symbol-name (mapcar #'car *scheme-chicken-modules*))
+ (mapcar
+ #'file-name-sans-extension
+ (directory-files "." nil ".*\\.scm$" t))
+ (scheme-append-map
+ #'(lambda (dir)
+ (mapcar
+ #'file-name-sans-extension
+ (directory-files dir nil ".*\\.\\(so\\|scm\\)$" t)))
+ *scheme-chicken-repo-dirs*)))
+
+(defvar *scheme-gauche-repo-path*
+ (or (car (remove-if-not #'file-directory-p
+ '("/usr/share/gauche"
+ "/usr/local/share/gauche"
+ "/opt/share/gauche"
+ "/opt/local/share/gauche")))
+ (and (fboundp 'shell-command-to-string)
+ (let* ((res (shell-command-to-string "gauche-config --syslibdir"))
+ (res (substring res 0 (- (length res) 1))))
+ (and res (file-directory-p res)
+ (let* ((dir (file-name-directory res))
+ (dir2 (file-name-directory
+ (substring dir 0 (- (length dir) 1)))))
+ (substring dir2 0 (- (length dir2) 1))))))
+ "/usr/local/share/gauche"))
+
+(defvar *scheme-gauche-site-repo-path*
+ (concat *scheme-gauche-repo-path* "/site/lib"))
+
+(defun scheme-gauche-available-modules (&optional sym)
+ (let ((version-dir
+ (concat
+ (car (directory-files *scheme-gauche-repo-path* t "^[0-9]"))
+ "/lib"))
+ (site-dir *scheme-gauche-site-repo-path*)
+ (other-dirs
+ (remove-if-not
+ #'(lambda (d) (and (not (equal d "")) (file-directory-p d)))
+ (split-string (or (getenv "GAUCHE_LOAD_PATH") "") ":"))))
+ (mapcar
+ #'(lambda (f) (subst-char-in-string ?/ ?. f))
+ (mapcar
+ #'file-name-sans-extension
+ (scheme-append-map
+ #'(lambda (dir)
+ (let ((len (length dir)))
+ (mapcar #'(lambda (f) (substring f (+ 1 len)))
+ (scheme-directory-tree-files dir t "\\.scm"))))
+ (cons version-dir (cons site-dir other-dirs)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; utilities
+
+(defun scheme-append-map (proc init-ls)
+ (if (null init-ls)
+ '()
+ (let* ((ls (reverse init-ls))
+ (res (funcall proc (pop ls))))
+ (while (consp ls)
+ (setq res (append (funcall proc (pop ls)) res)))
+ res)))
+
+(defun scheme-flatten (ls)
+ (cond
+ ((consp ls) (cons (car ls) (scheme-flatten (cdr ls))))
+ ((null ls) '())
+ (t (list ls))))
+
+(defun scheme-in-string-p ()
+ (let ((orig (point)))
+ (save-excursion
+ (goto-char (point-min))
+ (let ((parses (parse-partial-sexp (point) orig)))
+ (nth 3 parses)))))
+
+(defun scheme-beginning-of-sexp ()
+ (let ((syn (char-syntax (char-before (point)))))
+ (if (or (eq syn ?\()
+ (and (eq syn ?\") (scheme-in-string-p)))
+ (forward-char -1)
+ (forward-sexp -1))))
+
+(defun scheme-find-file-in-path (file path)
+ (car (remove-if-not
+ #'(lambda (dir) (file-exists-p (concat dir "/" file)))
+ path)))
+
+;; visit a file and kill the buffer only if it wasn't already open
+(defmacro scheme-with-find-file (path-expr &rest body)
+ (let ((path (gensym "path"))
+ (buf (gensym "buf"))
+ (res (gensym "res")))
+ `(save-window-excursion
+ (let* ((,path (file-truename ,path-expr))
+ (,buf (find-if
+ #'(lambda (x)
+ (let ((buf-file (buffer-file-name x)))
+ (and buf-file
+ (equal ,path (file-truename buf-file)))))
+ (buffer-list))))
+ (if ,buf
+ (switch-to-buffer ,buf)
+ (switch-to-buffer (find-file-noselect ,path t)))
+ (let ((,res (save-excursion ,@body)))
+ (unless ,buf (kill-buffer (current-buffer)))
+ ,res)))))
+
+(defun scheme-directory-tree-files (init-dir &optional full match)
+ (let ((res '())
+ (stack (list init-dir)))
+ (while (consp stack)
+ (let* ((dir (pop stack))
+ (files (cddr (directory-files dir full))))
+ (setq res (append (if match
+ (remove-if-not
+ #'(lambda (f) (string-match match f))
+ files)
+ files)
+ res))
+ (setq stack
+ (append
+ (remove-if-not 'file-directory-p
+ (if full
+ files
+ (mapcar #'(lambda (f) (concat dir "/" f))
+ files)))
+ stack))))
+ res))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; sexp manipulation
+
+;; returns current argument position within sexp
+(defun scheme-beginning-of-current-sexp-operator ()
+ (let ((pos 0))
+ (skip-syntax-backward "w_")
+ (while (and (not (bobp)) (not (eq ?\( (char-before))))
+ (scheme-beginning-of-sexp)
+ (incf pos))
+ pos))
+
+(defun scheme-beginning-of-next-sexp ()
+ (forward-sexp 2)
+ (backward-sexp 1))
+
+(defun scheme-beginning-of-string ()
+ (interactive)
+ (search-backward "\"" nil t)
+ (while (and (> (point) (point-min)) (eq ?\\ (char-before)))
+ (search-backward "\"" nil t)))
+
+;; for the enclosing sexp, returns a cons of the leading symbol (if
+;; any) and the current position within the sexp (starting at 0)
+;; (defun scheme-enclosing-sexp-prefix ()
+;; (save-excursion
+;; (let ((pos (scheme-beginning-of-current-sexp-operator)))
+;; (cons (scheme-symbol-at-point) pos))))
+
+(defun scheme-enclosing-2-sexp-prefixes ()
+ (save-excursion
+ (let* ((pos1 (scheme-beginning-of-current-sexp-operator))
+ (sym1 (scheme-symbol-at-point)))
+ (backward-char)
+ (or
+ (ignore-errors
+ (let ((pos2 (scheme-beginning-of-current-sexp-operator)))
+ (list sym1 pos1 (scheme-symbol-at-point) pos2)))
+ (list sym1 pos1 nil 0)))))
+
+;; sexp-at-point is always fragile, both because the user can input
+;; incomplete sexps and because some scheme sexps are not valid elisp
+;; sexps. this is one of the few places we use it, so we're careful
+;; to wrap it in ignore-errors.
+(defun scheme-nth-sexp-at-point (n)
+ (ignore-errors
+ (save-excursion
+ (forward-sexp (+ n 1))
+ (let ((end (point)))
+ (forward-sexp -1)
+ (car (read-from-string (buffer-substring (point) end)))))))
+
+(defun scheme-symbol-at-point ()
+ (save-excursion
+ (skip-syntax-backward "w_")
+ (let ((start (point)))
+ (skip-syntax-forward "w_")
+ (and (< start (point))
+ (intern (buffer-substring start (point)))))))
+
+(defun scheme-goto-next-top-level ()
+ (let ((here (point)))
+ (or (ignore-errors (end-of-defun) (end-of-defun)
+ (beginning-of-defun)
+ (< here (point)))
+ (progn (forward-char)
+ (and (re-search-forward "^(" nil t)
+ (progn (backward-char 1) t)))
+ (goto-char (point-max)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; variable extraction
+
+(defun scheme-sexp-type-at-point (&optional env)
+ (case (char-syntax (char-after))
+ ((?\()
+ (forward-char 1)
+ (if (eq ?w (char-syntax (char-after)))
+ (let ((op (scheme-symbol-at-point)))
+ (cond
+ ((eq op 'lambda)
+ (let ((params
+ (scheme-nth-sexp-at-point 1)))
+ `(lambda ,params)))
+ (t
+ (let ((spec (scheme-env-lookup env op)))
+ (and spec
+ (consp (cadr spec))
+ (eq 'lambda (caadr spec))
+ (cddadr spec)
+ (car (cddadr spec)))))))
+ nil))
+ ((?\")
+ 'string)
+ ((?\w)
+ (if (string-match "[0-9]" (string (char-after)))
+ 'number
+ nil))
+ (t
+ nil)))
+
+(defun scheme-let-vars-at-point (&optional env)
+ (let ((end (or (ignore-errors
+ (save-excursion (forward-sexp) (point)))
+ (point-min)))
+ (vars '()))
+ (forward-char 1)
+ (while (< (point) end)
+ (when (eq ?\( (char-after))
+ (save-excursion
+ (forward-char 1)
+ (if (eq ?w (char-syntax (char-after)))
+ (let* ((sym (scheme-symbol-at-point))
+ (type (ignore-errors
+ (scheme-beginning-of-next-sexp)
+ (scheme-sexp-type-at-point env))))
+ (push (if type (list sym type) (list sym)) vars)))))
+ (unless (ignore-errors (let ((here (point)))
+ (scheme-beginning-of-next-sexp)
+ (> (point) here)))
+ (goto-char end)))
+ (reverse vars)))
+
+(defun scheme-extract-match-clause-vars (x)
+ (cond
+ ((null x) '())
+ ((symbolp x)
+ (if (memq x '(_ ___ \.\.\.))
+ '()
+ (list (list x))))
+ ((consp x)
+ (case (car x)
+ ((or not)
+ (scheme-extract-match-clause-vars (cdr x)))
+ ((and)
+ (if (and (consp (cdr x))
+ (consp (cddr x))
+ (symbolp (cadr x))
+ (consp (caddr x))
+ (not (memq (caaddr x)
+ '(= $ @ ? and or not quote quasiquote get! set!))))
+ (cons (list (cadr x) (if (listp (caddr x)) 'list 'pair))
+ (scheme-extract-match-clause-vars (cddr x)))
+ (scheme-extract-match-clause-vars (cddr x))))
+ ((= $ @)
+ (if (consp (cdr x)) (scheme-extract-match-clause-vars (cddr x)) '()))
+ ((\? ? ) ; XXXX this is a hack, the lone ? gets read as a char (space)
+ (if (and (consp (cdr x))
+ (consp (cddr x))
+ (symbolp (cadr x))
+ (symbolp (caddr x)))
+ (cons (list (caddr x) (scheme-predicate->type (cadr x)))
+ (scheme-extract-match-clause-vars (cdddr x)))
+ (scheme-extract-match-clause-vars (cddr x))))
+ ((get! set!)
+ (if (consp (cdr x)) (scheme-extract-match-clause-vars (cadr x)) '()))
+ ((quote) '())
+ ((quasiquote) '()) ; XXXX
+ (t
+ (union (scheme-extract-match-clause-vars (car x))
+ (scheme-extract-match-clause-vars (cdr x))))))
+ ((vectorp x)
+ (scheme-extract-match-clause-vars (concatenate 'list x)))
+ (t
+ '())))
+
+;; call this from the first opening paren of the match clauses
+(defun scheme-extract-match-vars (&optional pos limit)
+ (let ((match-vars '())
+ (limit (or limit
+ (save-excursion
+ (or
+ (ignore-errors (end-of-defun) (point))
+ (point-max))))))
+ (save-excursion
+ (while (< (point) limit)
+ (let* ((end (ignore-errors (forward-sexp) (point)))
+ (start (and end (progn (backward-sexp) (point)))))
+ (cond
+ ((and pos start end (or (< pos start) (> pos end)))
+ (goto-char (if end (+ end 1) limit)))
+ (t
+ (forward-char 1)
+ (let* ((pat (scheme-nth-sexp-at-point 0))
+ (new-vars (ignore-errors
+ (scheme-extract-match-clause-vars pat))))
+ (setq match-vars (append new-vars match-vars)))
+ (goto-char (if (or pos (not end)) limit (+ end 1)))))))
+ match-vars)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; You can set the *scheme-default-implementation* to your preferred
+;; implementation, for when we can't figure out the file from
+;; heuristics. Alternately, in any given buffer, just
+;;
+;; (setq *scheme-current-implementation* whatever)
+
+(defgroup scheme-complete nil
+ "Smart tab completion"
+ :group 'scheme)
+
+(defcustom scheme-default-implementation nil
+ "Default scheme implementation to provide completion for
+when scheme-complete can't infer the current implementation."
+ :type 'symbol
+ :group 'scheme-complete)
+
+(defcustom scheme-complete-smart-indent-p t
+ "Toggles using `scheme-smart-indent' for `scheme-complete-or-indent'."
+ :type 'boolean
+ :group 'scheme-complete)
+
+(defcustom scheme-complete-cache-p t
+ "Toggles caching of module/load export information."
+ :type 'boolean
+ :group 'scheme-complete)
+
+;; (defcustom scheme-complete-learn-syntax-p nil
+;; "Toggles parsing of syntax-rules macros for completion info."
+;; :type 'boolean
+;; :group 'scheme-complete)
+
+(defvar *scheme-interleave-definitions-p* nil)
+
+(defvar *scheme-complete-module-cache* '())
+
+(defvar *scheme-current-implementation* nil)
+(make-variable-buffer-local '*scheme-current-implementation*)
+
+;; most implementations use their name as the script name
+(defvar *scheme-interpreter-alist*
+ '(("csi" . chicken)
+ ("gosh" . gauche)
+ ("gsi" . gambit)
+ ("mred" . mzscheme)
+ ))
+
+(defvar *scheme-imported-modules* '())
+
+(defun scheme-current-implementation ()
+ (unless *scheme-current-implementation*
+ (setq *scheme-current-implementation*
+ (save-excursion
+ (goto-char (point-min))
+ (or
+ (and (looking-at "#! *\\([^ \t\n]+\\)")
+ (let ((script (file-name-nondirectory (match-string 1))))
+ (cdr (assoc script *scheme-interpreter-alist*))))
+ (cond
+ ((re-search-forward "(define-module +\\(.\\)" nil t)
+ (if (equal "(" (match-string 1))
+ 'guile
+ 'gauche))
+ ((re-search-forward "(\\(?:use\\|require-library\\) " nil t)
+ 'chicken)
+ ((re-search-forward
+ "#\\(?:lang\\|reader\\)" nil t)
+ 'mzscheme)
+ ((re-search-forward "(module\\s-" nil t)
+ (if (looking-at "\\s-*\\sw") 'chicken 'mzscheme)))))))
+ (or *scheme-current-implementation*
+ scheme-default-implementation))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun scheme-current-local-vars (&optional env)
+ (let ((vars '())
+ (limit (save-excursion (beginning-of-defun) (+ (point) 1)))
+ (start (point))
+ (scan-internal))
+ (save-excursion
+ (while (> (point) limit)
+ (or (ignore-errors
+ (progn
+ (skip-chars-backward " \t\n" limit)
+ (scheme-beginning-of-sexp)
+ t))
+ (goto-char limit))
+ (when (and (> (point) (point-min))
+ (eq ?\( (char-syntax (char-before (point))))
+ (eq ?w (char-syntax (char-after (point)))))
+ (setq scan-internal t)
+ (let ((sym (scheme-symbol-at-point)))
+ (case sym
+ ((lambda)
+ (setq vars
+ (append
+ (mapcar #'list
+ (scheme-flatten (scheme-nth-sexp-at-point 1)))
+ vars)))
+ ((match match-let match-let*)
+ (setq vars
+ (append
+ (ignore-errors
+ (save-excursion
+ (let ((limit (save-excursion
+ (cond
+ ((eq sym 'match)
+ (backward-char 1)
+ (forward-sexp 1))
+ (t
+ (forward-sexp 2)))
+ (point))))
+ (forward-sexp 2)
+ (if (eq sym 'match)
+ (forward-sexp 1))
+ (backward-sexp 1)
+ (if (not (eq sym 'match))
+ (forward-char 1))
+ (scheme-extract-match-vars
+ (and (or (eq sym 'match) (< start limit)) start)
+ limit))))
+ vars)))
+ ((let let* letrec letrec* let-syntax letrec-syntax and-let* do)
+ (or
+ (ignore-errors
+ (save-excursion
+ (scheme-beginning-of-next-sexp)
+ (if (and (eq sym 'let)
+ (eq ?w (char-syntax (char-after (point)))))
+ ;; named let
+ (let* ((sym (scheme-symbol-at-point))
+ (args (progn
+ (scheme-beginning-of-next-sexp)
+ (scheme-let-vars-at-point env))))
+ (setq vars (cons `(,sym (lambda ,(mapcar #'car args)))
+ (append args vars))))
+ (setq vars (append (scheme-let-vars-at-point env) vars)))
+ t))
+ (goto-char limit)))
+ ((let-values let*-values)
+ (setq vars
+ (append (mapcar
+ #'list
+ (scheme-append-map
+ #'scheme-flatten
+ (remove-if-not #'consp
+ (scheme-nth-sexp-at-point 1))))
+ vars)))
+ ((receive defun defmacro)
+ (setq vars
+ (append (mapcar #'list
+ (scheme-flatten
+ (scheme-nth-sexp-at-point 1)))
+ vars)))
+ (t
+ (if (string-match "^define\\(-.*\\)?" (symbol-name sym))
+ (let ((defs (save-excursion
+ (backward-char)
+ (scheme-extract-definitions))))
+ (setq vars
+ (append (scheme-append-map
+ #'(lambda (x)
+ (and (consp (cdr x))
+ (consp (cadr x))
+ (eq 'lambda (caadr x))
+ (mapcar #'list
+ (scheme-flatten
+ (cadadr x)))))
+ defs)
+ defs
+ vars)))
+ (setq scan-internal nil))))
+ ;; check for internal defines
+ (when scan-internal
+ (ignore-errors
+ (save-excursion
+ (forward-sexp
+ (+ 1 (if (numberp scan-internal) scan-internal 2)))
+ (backward-sexp)
+ (if (< (point) start)
+ (setq vars (append (scheme-current-definitions) vars))
+ ))))))))
+ (reverse vars)))
+
+(defun scheme-extract-import-module-imports (sexp)
+ (case (and (consp sexp) (car sexp))
+ ((prefix prefix-in)
+ (let* ((ids (scheme-extract-import-module-imports (cadr sexp)))
+ (prefix0 (caddr sexp))
+ (prefix (if (symbolp prefix0) (symbol-name prefix0) prefix0)))
+ (mapcar #'(lambda (x)
+ (cons (intern (concat prefix (symbol-name (car x))))
+ (cdr x)))
+ ids)))
+ ((prefix-all-except)
+ (let ((prefix
+ (if (symbolp (cadr sexp)) (symbol-name (cadr sexp)) (cadr sexp)))
+ (exceptions (cddr sexp)))
+ (mapcar #'(lambda (x)
+ (if (memq (car x) exceptions)
+ x
+ (cons (intern (concat prefix (symbol-name (car x))))
+ (cdr x))))
+ (scheme-extract-import-module-imports (caddr sexp)))))
+ ((for for-syntax for-template for-label for-meta)
+ (scheme-extract-import-module-imports (cadr sexp)))
+ ((rename rename-in)
+ (let ((renames (cddr sexp)))
+ (mapcar #'(lambda (x)
+ (cons (or (cadr (assq (car x) renames)) (car x)) (cdr x)))
+ (scheme-extract-import-module-imports (cadr sexp)))))
+ ((except except-in)
+ (remove-if #'(lambda (x) (memq (car x) (cddr sexp)))
+ (scheme-extract-import-module-imports (cadr sexp))))
+ ((only only-in)
+ (remove-if-not
+ #'(lambda (x) (memq (car x) (cddr sexp)))
+ (scheme-extract-import-module-imports (cadr sexp))))
+ ((import import-for-syntax require)
+ (scheme-append-map #'scheme-extract-import-module-imports (cdr sexp)))
+ ((library)
+ (if (and (stringp (cadr sexp)) (file-exists-p (cadr sexp)))
+ (scheme-module-exports (intern (cadr sexp)))))
+ ((lib)
+ (if (and (equal "srfi" (caddr sexp))
+ (stringp (cadr sexp))
+ (string-match "^[0-9]+\\." (cadr sexp)))
+ (scheme-module-exports
+ (intern (file-name-sans-extension (concat "srfi-" (cadr sexp)))))
+ (scheme-module-exports
+ (intern (apply 'concat (append (cddr sexp) (list (cadr sexp))))))))
+ (t
+ (scheme-module-exports sexp))))
+
+(defun scheme-extract-sexp-imports (sexp)
+ (case (and (consp sexp) (car sexp))
+ ((begin define-module)
+ (scheme-append-map #'scheme-extract-sexp-imports (cdr sexp)))
+ ((cond-expand)
+ (scheme-append-map #'scheme-extract-sexp-imports
+ (scheme-append-map #'cdr (cdr sexp))))
+ ((use require-extension)
+ (scheme-append-map #'scheme-module-exports (cdr sexp)))
+ ((import)
+ (scheme-append-map #'scheme-extract-import-module-imports (cdr sexp)))
+ ((autoload)
+ (unless (member (cadr sexp) *scheme-imported-modules*)
+ (push (cadr sexp) *scheme-imported-modules*)
+ (mapcar #'(lambda (x) (cons (if (consp x) (car x) x) '((lambda obj))))
+ (cddr sexp))))
+ ((load)
+ (unless (member (cadr sexp) *scheme-imported-modules*)
+ (push (cadr sexp) *scheme-imported-modules*)
+ (and (stringp (cadr sexp))
+ (file-exists-p (cadr sexp))
+ (scheme-with-find-file (cadr sexp)
+ (scheme-current-globals)))))
+ ((library module)
+ (scheme-append-map #'scheme-extract-import-module-imports
+ (remove-if #'(lambda (x)
+ (memq (car x) '(import require)))
+ (cdr sexp))))
+ ))
+
+(defun scheme-module-symbol-p (sym)
+ (memq sym '(use require require-extension begin cond-expand
+ module library define-module autoload load import)))
+
+(defun scheme-skip-shebang ()
+ ;; skip shebang if present
+ (if (looking-at "#!")
+ ;; guile skips until a closing !#
+ (if (eq 'guile (scheme-current-implementation))
+ (re-search-forward "!#" nil t)
+ (next-line))))
+
+(defun scheme-current-imports ()
+ (let ((imports '())
+ (*scheme-imported-modules* '()))
+ (save-excursion
+ (goto-char (point-min))
+ (scheme-skip-shebang)
+ ;; scan for module forms
+ (while (not (eobp))
+ (if (ignore-errors (forward-sexp) t)
+ (let ((end (point))
+ (inside-p nil))
+ (backward-sexp)
+ (when (eq ?\( (char-after))
+ (forward-char)
+ (when (not (eq ?\( (char-after)))
+ (let ((sym (scheme-symbol-at-point)))
+ (cond
+ ((memq sym '(module library))
+ (forward-sexp 3)
+ (setq inside-p t))
+ ((scheme-module-symbol-p sym)
+ (backward-char)
+ (ignore-errors
+ (setq imports
+ (append (scheme-extract-sexp-imports
+ (scheme-nth-sexp-at-point 0))
+ imports))))))))
+ (unless inside-p (goto-char end)))
+ ;; if an incomplete sexp is found, try to recover at the
+ ;; next line beginning with an open paren
+ (scheme-goto-next-top-level))))
+ imports))
+
+;; we should be just inside the opening paren of an expression
+(defun scheme-name-of-define ()
+ (save-excursion
+ (scheme-beginning-of-next-sexp)
+ (if (eq ?\( (char-syntax (char-after)))
+ (forward-char))
+ (and (memq (char-syntax (char-after)) '(?\w ?\_))
+ (scheme-symbol-at-point))))
+
+(defun scheme-type-of-define ()
+ (save-excursion
+ (scheme-beginning-of-next-sexp)
+ (cond
+ ((eq ?\( (char-syntax (char-after)))
+ `(lambda ,(cdr (scheme-nth-sexp-at-point 0))))
+ (t
+ (ignore-errors (scheme-beginning-of-next-sexp)
+ (scheme-sexp-type-at-point))))))
+
+;; we should be at the opening paren of an expression
+(defun scheme-extract-definitions (&optional env)
+ (save-excursion
+ (let ((sym (ignore-errors (and (eq ?\( (char-syntax (char-after)))
+ (progn (forward-char)
+ (scheme-symbol-at-point))))))
+ (case sym
+ ((define-syntax define-compiled-syntax defmacro define-macro)
+ (list (list (scheme-name-of-define) '(syntax))))
+ ((define define-inline define-constant define-primitive defun)
+ (let ((name (scheme-name-of-define))
+ (type (scheme-type-of-define)))
+ (list (if type (list name type) (list name)))))
+ ((defvar define-class)
+ (list (list (scheme-name-of-define) 'non-procedure)))
+ ((define-record)
+ (backward-char)
+ (ignore-errors
+ (let* ((sexp (scheme-nth-sexp-at-point 0))
+ (name (symbol-name (cadr sexp))))
+ `((,(intern (concat name "?")) (lambda (obj) boolean))
+ (,(intern (concat "make-" name)) (lambda ,(cddr sexp) ))
+ ,@(scheme-append-map
+ #'(lambda (x)
+ `((,(intern (concat name "-" (symbol-name x)))
+ (lambda (non-procedure)))
+ (,(intern (concat name "-" (symbol-name x) "-set!"))
+ (lambda (non-procedure val) undefined))))
+ (cddr sexp))))))
+ ((define-record-type)
+ (backward-char)
+ (ignore-errors
+ (let ((sexp (scheme-nth-sexp-at-point 0)))
+ `((,(caaddr sexp) (lambda ,(cdaddr sexp)))
+ (,(cadddr sexp) (lambda (obj)))
+ ,@(scheme-append-map
+ #'(lambda (x)
+ (if (consp x)
+ (if (consp (cddr x))
+ `((,(cadr x) (lambda (non-procedure)))
+ (,(caddr x)
+ (lambda (non-procedure val) undefined)))
+ `((,(cadr x) (lambda (non-procedure)))))))
+ (cddddr sexp))))))
+ ((begin progn)
+ (forward-sexp)
+ (scheme-current-definitions))
+ (t
+ '())))))
+
+;; a little more liberal than -definitions, we try to scan to a new
+;; top-level form (i.e. a line beginning with an open paren) if
+;; there's an error during normal sexp movement
+(defun scheme-current-globals ()
+ (let ((here (point))
+ (globals '())
+ (end (point-max)))
+ (save-excursion
+ (goto-char (point-min))
+ (or (ignore-errors (end-of-defun) (backward-sexp) t)
+ (and (re-search-forward "^(" nil t) (progn (backward-char) t))
+ (goto-char (point-max)))
+ (while (< (point) end)
+ (cond
+ ((and (< (point) here) (looking-at "(\\(module\\|library\\)\\s-"))
+ (let ((module-end (ignore-errors
+ (save-excursion (forward-sexp) (point)))))
+ (cond
+ ((or (not module-end) (< here module-end)) ; inside the module
+ (setq globals '())
+ (when module-end
+ (setq end module-end))
+ (forward-word 1)
+ (forward-sexp 2)
+ (scheme-beginning-of-next-sexp))
+ (t ;; not inside the module, skip it altogether
+ (forward-sexp 1)
+ (scheme-goto-next-top-level)))))
+ (t
+ (setq globals
+ (append (ignore-errors (scheme-extract-definitions)) globals))
+ (or (and (progn (forward-char) (re-search-forward "^(" nil t))
+ (progn (backward-char) t))
+ (scheme-goto-next-top-level))))))
+ globals))
+
+;; for internal defines, etc.
+(defun scheme-current-definitions (&optional enclosing-end)
+ (let ((defs '())
+ (end (or enclosing-end (point-max))))
+ (save-excursion
+ (while (< (point) end)
+ (let ((here (point))
+ (new-defs (scheme-extract-definitions)))
+ (cond
+ (new-defs
+ (setq defs (append new-defs defs))
+ (or (ignore-errors (scheme-beginning-of-next-sexp)
+ (> (point) here))
+ (goto-char end)))
+ ;; non-definition form, maybe stop scanning
+ ((not *scheme-interleave-definitions-p*)
+ (goto-char end))))))
+ defs))
+
+(defun scheme-current-exports ()
+ (let ((res '()))
+ (save-excursion
+ (goto-char (point-min))
+ (or (ignore-errors (end-of-defun) (beginning-of-defun) t)
+ (re-search-forward "^(" nil t)
+ (goto-char (point-max)))
+ (while (not (eobp))
+ (when (and (eq ?\( (char-syntax (char-after)))
+ (eq ?w (char-syntax (char-after (1+ (point))))))
+ (let ((sym (save-excursion (forward-char) (scheme-symbol-at-point))))
+ (case sym
+ ((declare define-module)
+ (let ((decls (scheme-nth-sexp-at-point 0)))
+ (cond
+ ((and (listp decls) (assq 'export decls))
+ (setq res (nconc (cdr (assq 'export decls)) res)))
+ ((and (listp decls) (assq 'export-all decls))
+ (goto-char (point-max))))))
+ ((export provide)
+ (unless (and (eq 'provide sym)
+ (eq 'chicken (scheme-current-implementation)))
+ (setq res (nconc (cdr (scheme-nth-sexp-at-point 0)) res))))
+ ((export-all)
+ (goto-char (point-max)))
+ ((extend)
+ (let ((parents (cdr (scheme-nth-sexp-at-point 0))))
+ (setq res (nconc (mapcar #'car
+ (scheme-append-map
+ #'scheme-module-exports
+ parents))
+ res))))
+ ((module)
+ (forward-char)
+ (forward-sexp)
+ (let ((x (scheme-nth-sexp-at-point 0)))
+ (cond
+ ((eq '* x)
+ (goto-char (point-max)))
+ ((listp x)
+ (setq res
+ (nconc (remove-if-not #'symbolp (cdr x)) res))))))
+ )))
+ (scheme-goto-next-top-level)))
+ res))
+
+(defun scheme-srfi-exports (i)
+ (and (integerp i)
+ (>= i 0)
+ (< i (length *scheme-srfi-info*))
+ (let ((info (cdr (aref *scheme-srfi-info* i))))
+ (if (and (consp info) (null (cdr info)) (symbolp (car info)))
+ (scheme-module-exports (car info))
+ info))))
+
+(defvar scheme-module-exports-function nil)
+
+(defvar *scheme-module-exports-functions*
+ '((chicken . scheme-module-exports/chicken)
+ (gauche . scheme-module-exports/gauche)
+ (mzscheme . scheme-module-exports/mzscheme)))
+
+(defun scheme-module-exports (mod)
+ (unless (member mod *scheme-imported-modules*)
+ (push mod *scheme-imported-modules*)
+ (cond
+ ((and (consp mod) (eq 'srfi (car mod)))
+ (scheme-append-map #'scheme-srfi-exports (cdr mod)))
+ ((and (symbolp mod) (string-match "^srfi-" (symbol-name mod)))
+ (scheme-srfi-exports
+ (string-to-number (substring (symbol-name mod) 5))))
+ (t
+ (let ((cached (assq mod *scheme-complete-module-cache*)))
+ ;; remove stale caches
+ (when (and cached
+ (stringp (cadr cached))
+ (ignore-errors
+ (let ((mtime (nth 5 (file-attributes (cadr cached))))
+ (ptime (caddr cached)))
+ (or (> (car mtime) (car ptime))
+ (and (= (car mtime) (car ptime))
+ (> (cadr mtime) (cadr ptime)))))))
+ (setq *scheme-complete-module-cache*
+ (assq-delete-all mod *scheme-complete-module-cache*))
+ (setq cached nil))
+ (if cached
+ (cadddr cached)
+ ;; (re)compute module exports
+ (let ((export-fun
+ (or scheme-module-exports-function
+ (cdr (assq (scheme-current-implementation)
+ *scheme-module-exports-functions*)))))
+ (when export-fun
+ (let ((res (funcall export-fun mod)))
+ (when res
+ (when (and scheme-complete-cache-p (car res))
+ (push (list mod
+ (car res)
+ (nth 5 (file-attributes (car res)))
+ (cadr res))
+ *scheme-complete-module-cache*))
+ (cadr res)))))))))))
+
+(defun scheme-module-exports/chicken (mod)
+ (let ((predefined (assq mod *scheme-chicken-modules*)))
+ (if predefined
+ (list nil (cdr predefined))
+ (let* ((mod-str (symbol-name mod))
+ (export-file
+ (concat *scheme-chicken-base-repo* "/" mod-str ".exports"))
+ (setup-file
+ (concat *scheme-chicken-base-repo* "/" mod-str ".setup-info"))
+ ;; look for the source in the current directory
+ (source-file (concat mod-str ".scm"))
+ ;; try the chicken 4 modules db
+ (modules-db (concat *scheme-chicken-base-repo* "/modules.db")))
+ (cond
+ ((eq mod 'scheme)
+ (list nil *scheme-r5rs-info*))
+ ((file-exists-p source-file)
+ (list source-file
+ (scheme-with-find-file source-file
+ (let ((env (scheme-current-globals))
+ (exports (scheme-current-exports)))
+ (if (consp exports)
+ (remove-if-not #'(lambda (x) (memq (car x) exports)) env)
+ env)))))
+ ((file-exists-p export-file)
+ (list export-file
+ (mapcar #'(lambda (x) (cons (intern x) '((lambda obj))))
+ (scheme-file->lines export-file))))
+ (t
+ (let ((setup-file-exports
+ (and (file-exists-p setup-file)
+ (scheme-with-find-file setup-file
+ (let* ((alist (scheme-nth-sexp-at-point 0))
+ (cell (assq 'exports alist)))
+ (cdr cell))))))
+ (cond
+ (setup-file-exports
+ (list setup-file
+ (mapcar #'(lambda (x) (cons (intern x) '((lambda obj))))
+ setup-file-exports)))
+ ((file-exists-p modules-db)
+ (list modules-db
+ (mapcar
+ #'(lambda (x)
+ (cons (intern (car (split-string (substring x 1))))
+ '((lambda ()))))
+ (remove-if-not
+ #'(lambda (x) (string-match (concat " " mod-str ")") x))
+ (scheme-file->lines modules-db))))))))
+ )))))
+
+(defun scheme-module-exports/gauche (mod)
+ (let* ((file (concat (subst-char-in-string ?. ?/ (symbol-name mod)) ".scm"))
+ (dir
+ (scheme-find-file-in-path
+ file
+ (cons
+ (concat *scheme-gauche-site-repo-path* "/site/lib")
+ (mapcar
+ #'(lambda (x) (concat x "/lib"))
+ (reverse
+ (directory-files *scheme-gauche-repo-path* t "^[0-9]")))))))
+ (when dir
+ (list
+ (concat dir "/" file)
+ (scheme-with-find-file (concat dir "/" file)
+ (let ((env (scheme-current-globals))
+ (exports (scheme-current-exports)))
+ (if (consp exports)
+ (remove-if-not #'(lambda (x) (memq (car x) exports)) env)
+ env)))))))
+
+(defun scheme-module-exports/mzscheme (mod)
+ (let ((dir (scheme-find-file-in-path
+ (symbol-name mod)
+ '("."
+ "/usr/local/lib/plt/collects"
+ "/usr/local/lib/plt/collects/mzlib"))))
+ (when dir
+ ;; XXXX parse, don't use regexps
+ (list
+ (concat dir "/" (symbol-name mod))
+ (scheme-with-find-file (concat dir "/" (symbol-name mod))
+ (when (re-search-forward "(provide" nil t)
+ (backward-sexp)
+ (backward-char)
+ (mapcar #'list (cdr (ignore-errors (scheme-nth-sexp-at-point 0))))
+ ))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; This is rather complicated because we want to auto-generate
+;; docstring summaries from the type information, which means
+;; inferring various types from common names. The benefit is that you
+;; don't have to input the same information twice, and can often
+;; cut&paste&munge procedure descriptions from the original
+;; documentation.
+
+(defun scheme-translate-type (type)
+ (if (not (symbolp type))
+ type
+ (case type
+ ((pred proc thunk handler dispatch producer consumer f fn g kons)
+ 'procedure)
+ ((num) 'number)
+ ((z) 'complex)
+ ((x1 x2 x3 y timeout seconds nanoseconds) 'real)
+ ((i j k n m int index size count len length bound nchars start end
+ pid uid gid fd fileno errno)
+ 'integer)
+ ((ch) 'char)
+ ((str name pattern) 'string)
+ ((file path pathname) 'filename)
+ ((dir dirname) 'directory)
+ ((sym id identifier) 'symbol)
+ ((ls lis lst alist lists) 'list)
+ ((vec) 'vector)
+ ((exc excn err error) 'exception)
+ ((ptr) 'pointer)
+ ((bool) 'boolean)
+ ((env) 'environment)
+ ((char string boolean number complex real integer procedure char-set
+ port input-port output-port pair list vector array stream hash-table
+ thread mutex condition-variable time exception date duration locative
+ random-source state condition condition-type queue pointer
+ u8vector s8vector u16vector s16vector u32vector s32vector
+ u64vector s64vector f32vector f64vector undefined symbol
+ block filename directory mmap listener environment non-procedure
+ read-table continuation blob generic method class regexp regmatch
+ sys-stat fdset)
+ type)
+ ((parent seed option mode) 'non-procedure)
+ (t
+ (let* ((str (symbol-name type))
+ (i (string-match "-?[0-9]+$" str)))
+ (if i
+ (scheme-translate-type (intern (substring str 0 i)))
+ (let ((i (string-match "-\\([^-]+\\)$" str)))
+ (if i
+ (scheme-translate-type (intern (substring str (+ i 1))))
+ (if (string-match "\\?$" str)
+ 'boolean
+ 'object)))))))))
+
+(defun scheme-lookup-type (spec pos)
+ (let ((i 1)
+ (type nil))
+ (while (and (consp spec) (<= i pos))
+ (cond
+ ((eq :optional (car spec))
+ (if (and (= i pos) (consp (cdr spec)))
+ (setq type (cadr spec)))
+ (setq i (+ pos 1)))
+ ((= i pos)
+ (setq type (car spec))
+ (setq spec nil))
+ ((and (consp (cdr spec)) (eq '\.\.\. (cadr spec)))
+ (setq type (car spec))
+ (setq spec nil)))
+ (setq spec (cdr spec))
+ (incf i))
+ (if type
+ (setq type (scheme-translate-type type)))
+ type))
+
+(defun scheme-predicate->type (pred)
+ (case pred
+ ((even? odd?) 'integer)
+ ((char-upper-case? char-lower-case?
+ char-alphabetic? char-numeric? char-whitespace?)
+ 'char)
+ (t
+ ;; catch all the `type?' predicates with pattern matching
+ ;; ... we could be smarter if the env was passed
+ (let ((str (symbol-name pred)))
+ (if (string-match "\\?$" str)
+ (scheme-translate-type
+ (intern (substring str 0 (- (length str) 1))))
+ 'object)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; completion
+
+(eval-when (compile load eval)
+ (unless (fboundp 'event-matches-key-specifier-p)
+ (defalias 'event-matches-key-specifier-p 'eq)))
+
+(unless (fboundp 'read-event)
+ (defun read-event ()
+ (aref (read-key-sequence nil) 0)))
+
+(unless (fboundp 'event-basic-type)
+ (defalias 'event-basic-type 'event-key))
+
+(defun scheme-string-prefix-p (pref str)
+ (let ((p-len (length pref))
+ (s-len (length str)))
+ (and (<= p-len s-len)
+ (equal pref (substring str 0 p-len)))))
+
+(defun scheme-do-completion (str coll &optional strs pred)
+ (let* ((coll (mapcar #'(lambda (x)
+ (cond
+ ((symbolp x) (list (symbol-name x)))
+ ((stringp x) (list x))
+ (t x)))
+ coll))
+ (completion1 (try-completion str coll pred))
+ (completion2 (and strs (try-completion str strs pred)))
+ (completion (if (and completion2
+ (or (not completion1)
+ (< (length completion2)
+ (length completion1))))
+ completion2
+ completion1)))
+ (cond
+ ((eq completion t))
+ ((not completion)
+ (message "Can't find completion for \"%s\"" str)
+ (ding))
+ ((not (string= str completion))
+ (let ((prefix-p (scheme-string-prefix-p completion completion1)))
+ (unless prefix-p
+ (save-excursion
+ (backward-char (length str))
+ (insert "\"")))
+ (insert (substring completion (length str)))
+ (unless prefix-p
+ (insert "\"")
+ (backward-char))))
+ (t
+ (let ((win-config (current-window-configuration))
+ (done nil))
+ (message "Hit space to flush")
+ (with-output-to-temp-buffer "*Completions*"
+ (display-completion-list
+ (sort
+ (all-completions str (append strs coll) pred)
+ 'string-lessp)))
+ (while (not done)
+ (let* ((orig-event
+ (with-current-buffer (get-buffer "*Completions*")
+ (read-event)))
+ (event (event-basic-type orig-event)))
+ (cond
+ ((or (event-matches-key-specifier-p event 'tab)
+ (event-matches-key-specifier-p event 9))
+ (save-selected-window
+ (select-window (get-buffer-window "*Completions*"))
+ (if (pos-visible-in-window-p (point-max))
+ (goto-char (point-min))
+ (scroll-up))))
+ (t
+ (set-window-configuration win-config)
+ (if (or (event-matches-key-specifier-p event 'space)
+ (event-matches-key-specifier-p event 32))
+ (bury-buffer (get-buffer "*Completions*"))
+ (setq unread-command-events (list orig-event)))
+ (setq done t))))))
+ ))))
+
+(defun scheme-env-lookup (env sym)
+ (let ((spec nil)
+ (ls env))
+ (while (and ls (not spec))
+ (setq spec (assq sym (pop ls))))
+ spec))
+
+(defun scheme-inside-module-p ()
+ (save-excursion
+ (ignore-errors
+ (let ((here (point))
+ res)
+ (goto-char (point-min))
+ (while (< (point) here)
+ (if (not (re-search-forward "^(\\(?:module\\|library\\)\\s-"))
+ (goto-char (point-max))
+ (beginning-of-line)
+ (let ((mod-point (point)))
+ (if (ignore-errors (forward-sexp) t)
+ (if (and (<= mod-point here) (<= here (point)))
+ (setq res t))
+ (setq res (<= mod-point here))
+ (goto-char (point-max))))))
+ res))))
+
+(defun scheme-current-env ()
+ (let ((in-mod-p (scheme-inside-module-p)))
+ ;; r5rs
+ (let ((env (if in-mod-p (list) (list *scheme-r5rs-info*))))
+ ;; base language
+ (let ((base (cdr (assq (scheme-current-implementation)
+ *scheme-implementation-exports*))))
+ (if (and base (not in-mod-p)) (push base env)))
+ ;; imports
+ (let ((imports (ignore-errors (scheme-current-imports))))
+ (if imports (push imports env)))
+ ;; top-level defs
+ (let ((top (ignore-errors (scheme-current-globals))))
+ (if top (push top env)))
+ ;; current local vars
+ (let ((locals (ignore-errors (scheme-current-local-vars env))))
+ (if locals (push locals env)))
+ env)))
+
+(defun scheme-env-filter (pred env)
+ (mapcar #'car
+ (apply #'concatenate
+ 'list
+ (mapcar #'(lambda (e) (remove-if-not pred e))
+ env))))
+
+;; checking return values:
+;; a should be capable of returning instances of b
+(defun scheme-type-match-p (a b)
+ (let ((a1 (scheme-translate-type a))
+ (b1 (scheme-translate-type b)))
+ (and (not (eq a1 'undefined)) ; check a *does* return something
+ (or (eq a1 b1) ; and they're the same
+ (eq a1 'object) ; ... or a can return anything
+ (eq b1 'object) ; ... or b can receive anything
+ (if (symbolp a1)
+ (if (symbolp b1)
+ (case a1 ; ... or the types overlap
+ ((number complex real rational integer)
+ (memq b1 '(number complex real rational integer)))
+ ((port input-port output-port)
+ (memq b1 '(port input-port output-port)))
+ ((pair list)
+ (memq b1 '(pair list)))
+ ((non-procedure)
+ (not (eq 'procedure b1))))
+ (and
+ (consp b1)
+ (if (eq 'or (car b1))
+ ;; type unions
+ (find-if
+ #'(lambda (x)
+ (scheme-type-match-p
+ a1 (scheme-translate-type x)))
+ (cdr b1))
+ (let ((b2 (scheme-translate-special-type b1)))
+ (and (not (equal b1 b2))
+ (scheme-type-match-p a1 b2))))))
+ (and (consp a1)
+ (case (car a1)
+ ((or)
+ ;; type unions
+ (find-if
+ #'(lambda (x)
+ (scheme-type-match-p (scheme-translate-type x) b1))
+ (cdr a1)))
+ ((lambda)
+ ;; procedures
+ (or (eq 'procedure b1)
+ (and (consp b1)
+ (eq 'lambda (car b1))
+ (scheme-param-list-match-p (cadr a1)
+ (cadr b1)))))
+ (t
+ ;; other special types
+ (let ((a2 (scheme-translate-special-type a1))
+ (b2 (scheme-translate-special-type b1)))
+ (and (or (not (equal a1 a2)) (not (equal b1 b2)))
+ (scheme-type-match-p a2 b2)))))))))))
+
+(defun scheme-param-list-match-p (p1 p2)
+ (or (and (symbolp p1) (not (null p1)))
+ (and (symbolp p2) (not (null p2)))
+ (and (null p1) (null p2))
+ (and (consp p1) (consp p2)
+ (scheme-param-list-match-p (cdr p1) (cdr p2)))))
+
+(defun scheme-translate-special-type (x)
+ (if (not (consp x))
+ x
+ (case (car x)
+ ((list string) (car x))
+ ((set special) (cadr x))
+ ((flags) 'integer)
+ (t x))))
+
+(defun scheme-nth* (n ls)
+ (while (and (consp ls) (> n 0))
+ (setq n (- n 1)
+ ls (cdr ls)))
+ (and (consp ls) (car ls)))
+
+(defun scheme-file->lines (file)
+ (and (file-readable-p file)
+ (scheme-with-find-file file
+ (goto-char (point-min))
+ (let ((res '()))
+ (while (not (eobp))
+ (let ((start (point)))
+ (forward-line)
+ (push (buffer-substring-no-properties start (- (point) 1))
+ res)))
+ (reverse res)))))
+
+(defun scheme-passwd-file-names (file &optional pat)
+ (delete
+ nil
+ (mapcar
+ #'(lambda (line)
+ (and (not (string-match "^[ ]*#" line))
+ (or (not pat) (string-match pat line))
+ (string-match "^\\([^:]*\\):" line)
+ (match-string 1 line)))
+ (scheme-file->lines file))))
+
+(defun scheme-host-file-names (file)
+ (scheme-append-map
+ #'(lambda (line)
+ (let ((i (string-match "#" line)))
+ (if i (setq line (substring line 0 i))))
+ (cdr (split-string line)))
+ (scheme-file->lines file)))
+
+(defun scheme-ssh-known-hosts-file-names (file)
+ (scheme-append-map
+ #'(lambda (line)
+ (split-string (car (split-string line)) ","))
+ (scheme-file->lines file)))
+
+(defun scheme-ssh-config-file-names (file)
+ (scheme-append-map
+ #'(lambda (line)
+ (and (string-match "^ *Host" line)
+ (cdr (split-string line))))
+ (scheme-file->lines file)))
+
+(defun scheme-complete-user-name (trans sym)
+ (if (string-match "apple" (emacs-version))
+ (append (scheme-passwd-file-names "/etc/passwd" "^[^_].*")
+ (delete "Shared" (directory-files "/Users" nil "^[^.].*")))
+ (scheme-passwd-file-names "/etc/passwd")))
+
+(defun scheme-complete-host-name (trans sym)
+ (append (scheme-host-file-names "/etc/hosts")
+ (scheme-ssh-known-hosts-file-names "~/.ssh/known_hosts")
+ (scheme-ssh-config-file-names "~/.ssh/config")))
+
+;; my /etc/services is 14k lines, so we try to optimize this
+(defun scheme-complete-port-name (trans sym)
+ (and (file-readable-p "/etc/services")
+ (scheme-with-find-file "/etc/services"
+ (goto-char (point-min))
+ (let ((rx (concat "^\\(" (regexp-quote (if (symbolp sym)
+ (symbol-name sym)
+ sym))
+ "[^ ]*\\)"))
+ (res '()))
+ (while (not (eobp))
+ (if (not (re-search-forward rx nil t))
+ (goto-char (point-max))
+ (let ((str (match-string-no-properties 1)))
+ (if (not (equal str (car res)))
+ (push str res)))
+ (forward-char 1)))
+ res))))
+
+(defun scheme-complete-file-name (trans sym)
+ (let* ((file (file-name-nondirectory sym))
+ (dir (file-name-directory sym))
+ (res (file-name-all-completions file (or dir "."))))
+ (if dir
+ (mapcar #'(lambda (f) (concat dir f)) res)
+ res)))
+
+(defun scheme-complete-directory-name (trans sym)
+ (let* ((file (file-name-nondirectory sym))
+ (dir (file-name-directory sym))
+ (res (file-name-all-completions file (or dir ".")))
+ (res2 (if dir (mapcar #'(lambda (f) (concat dir f)) res) res)))
+ (remove-if-not #'file-directory-p res2)))
+
+(defun scheme-string-completer (type)
+ (case type
+ ((filename)
+ '(scheme-complete-file-name file-name-nondirectory))
+ ((directory)
+ '(scheme-complete-directory-name file-name-nondirectory))
+ (t
+ (cond
+ ((and (consp type) (eq 'string (car type)))
+ (cadr type))
+ ((and (consp type) (eq 'or (car type)))
+ (car (delete nil (mapcar #'scheme-string-completer (cdr type)))))))))
+
+(defun scheme-apply-string-completer (cmpl sym)
+ (let ((func (if (consp cmpl) (car cmpl) cmpl))
+ (trans (and (consp cmpl) (cadr cmpl))))
+ (funcall func trans sym)))
+
+(defun scheme-smart-complete (&optional arg)
+ (interactive "P")
+ (let* ((end (point))
+ (start (save-excursion (skip-syntax-backward "w_") (point)))
+ (sym (buffer-substring-no-properties start end))
+ (in-str-p (scheme-in-string-p))
+ (x (save-excursion
+ (if in-str-p (scheme-beginning-of-string))
+ (scheme-enclosing-2-sexp-prefixes)))
+ (inner-proc (car x))
+ (inner-pos (cadr x))
+ (outer-proc (caddr x))
+ (outer-pos (cadddr x))
+ (env (save-excursion
+ (if in-str-p (scheme-beginning-of-string))
+ (scheme-current-env)))
+ (outer-spec (scheme-env-lookup env outer-proc))
+ (outer-type (scheme-translate-type (cadr outer-spec)))
+ (inner-spec (scheme-env-lookup env inner-proc))
+ (inner-type (scheme-translate-type (cadr inner-spec))))
+ (cond
+ ;; return all env symbols when a prefix arg is given
+ (arg
+ (scheme-do-completion sym (scheme-env-filter #'(lambda (x) t) env)))
+ ;; for now just do file-name completion in strings
+ (in-str-p
+ (let* ((param-type
+ (and (consp inner-type)
+ (eq 'lambda (car inner-type))
+ (scheme-lookup-type (cadr inner-type) inner-pos)))
+ (completer (or (scheme-string-completer param-type)
+ '(scheme-complete-file-name
+ file-name-nondirectory))))
+ (scheme-do-completion
+ ;;(if (consp completer) (funcall (cadr completer) sym) sym)
+ sym
+ (scheme-apply-string-completer completer sym))))
+ ;; outer special
+ ((and (consp outer-type)
+ (eq 'special (car outer-type))
+ (cadddr outer-type))
+ (scheme-do-completion sym (funcall (cadddr outer-type) sym)))
+ ;; inner special
+ ((and (consp inner-type)
+ (eq 'special (car inner-type))
+ (caddr inner-type))
+ (scheme-do-completion sym (funcall (caddr inner-type) sym)))
+ ;; completing inner procedure, complete procedures with a
+ ;; matching return type
+ ((and (consp outer-type)
+ (eq 'lambda (car outer-type))
+ (not (zerop outer-pos))
+ (scheme-nth* (- outer-pos 1) (cadr outer-type))
+ (or (zerop inner-pos)
+ (and (>= 1 inner-pos)
+ (consp inner-type)
+ (eq 'lambda (car inner-type))
+ (let ((param-type
+ (scheme-lookup-type (cadr inner-type) inner-pos)))
+ (and (consp param-type)
+ (eq 'lambda (car param-type))
+ (eq (caddr inner-type) (caddr param-type)))))))
+ (let ((want-type (scheme-lookup-type (cadr outer-type) outer-pos)))
+ (scheme-do-completion
+ sym
+ (scheme-env-filter
+ #'(lambda (x)
+ (let ((type (cadr x)))
+ (or (memq type '(procedure object nil))
+ (and (consp type)
+ (or (and (eq 'syntax (car type))
+ (not (eq 'undefined (caddr type))))
+ (and (eq 'lambda (car type))
+ (scheme-type-match-p (caddr type)
+ want-type)))))))
+ env))))
+ ;; completing a normal parameter
+ ((and inner-proc
+ (not (zerop inner-pos))
+ (consp inner-type)
+ (eq 'lambda (car inner-type)))
+ (let* ((param-type (scheme-lookup-type (cadr inner-type) inner-pos))
+ (set-or-flags
+ (or (and (consp param-type)
+ (case (car param-type)
+ ((set) (cddr param-type))
+ ((flags) (cdr param-type))))
+ ;; handle nested arithmetic functions inside a flags
+ ;; parameter
+ (and (not (zerop outer-pos))
+ (consp outer-type)
+ (eq 'lambda (car outer-type))
+ (let ((outer-param-type
+ (scheme-lookup-type (cadr outer-type)
+ outer-pos)))
+ (and (consp outer-param-type)
+ (eq 'flags (car outer-param-type))
+ (memq (scheme-translate-type param-type)
+ '(number complex real rational integer))
+ (memq (scheme-translate-type (caddr inner-type))
+ '(number complex real rational integer))
+ (cdr outer-param-type))))))
+ (base-type (if set-or-flags
+ (if (and (consp param-type)
+ (eq 'set (car param-type)))
+ (scheme-translate-type (cadr param-type))
+ 'integer)
+ param-type))
+ (base-completions
+ (scheme-env-filter
+ #'(lambda (x)
+ (scheme-type-match-p (cadr x) base-type))
+ env))
+ (str-completions
+ (let ((completer (scheme-string-completer base-type)))
+ (and
+ completer
+ (scheme-apply-string-completer completer sym)))))
+ (scheme-do-completion
+ sym
+ (append set-or-flags base-completions)
+ str-completions)))
+ ;; completing a function
+ ((zerop inner-pos)
+ (scheme-do-completion
+ sym
+ (scheme-env-filter
+ #'(lambda (x)
+ (or (null (cdr x))
+ (memq (cadr x) '(procedure object nil))
+ (and (consp (cadr x))
+ (memq (caadr x) '(lambda syntax)))))
+ env)))
+ ;; complete everything
+ (t
+ (scheme-do-completion sym (scheme-env-filter #'(lambda (x) t) env)) ))))
+
+(defun scheme-complete-or-indent (&optional arg)
+ (interactive "P")
+ (let* ((end (point))
+ (func
+ (save-excursion
+ (beginning-of-line)
+ (if (re-search-forward "\\S-" end t)
+ 'scheme-smart-complete
+ 'lisp-indent-line))))
+ (funcall func arg)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; optional indentation handling
+
+(defvar calculate-lisp-indent-last-sexp)
+
+;; Copied from scheme-indent-function, but ignore
+;; scheme-indent-function property for local variables.
+(defun scheme-smart-indent-function (indent-point state)
+ (let ((normal-indent (current-column)))
+ (goto-char (1+ (elt state 1)))
+ (parse-partial-sexp (point) calculate-lisp-indent-last-sexp 0 t)
+ (if (and (elt state 2)
+ (not (looking-at "\\sw\\|\\s_")))
+ ;; car of form doesn't seem to be a symbol
+ (progn
+ (if (not (> (save-excursion (forward-line 1) (point))
+ calculate-lisp-indent-last-sexp))
+ (progn (goto-char calculate-lisp-indent-last-sexp)
+ (beginning-of-line)
+ (parse-partial-sexp (point)
+ calculate-lisp-indent-last-sexp 0 t)))
+ ;; Indent under the list or under the first sexp on the same
+ ;; line as calculate-lisp-indent-last-sexp. Note that first
+ ;; thing on that line has to be complete sexp since we are
+ ;; inside the innermost containing sexp.
+ (backward-prefix-chars)
+ (current-column))
+ (let* ((function (buffer-substring (point)
+ (progn (forward-sexp 1) (point))))
+ (function-sym (intern-soft function))
+ (method (and (not (assq function-sym (scheme-current-local-vars)))
+ (get function-sym 'scheme-indent-function))))
+ (cond ((or (eq method 'defun)
+ (and (null method)
+ (> (length function) 3)
+ (string-match "\\`def" function)))
+ (lisp-indent-defform state indent-point))
+ ((integerp method)
+ (lisp-indent-specform method state
+ indent-point normal-indent))
+ (method
+ (funcall method state indent-point normal-indent)))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; optional eldoc function
+
+(defun scheme-translate-dot-to-optional (ls)
+ (let ((res '()))
+ (while (consp ls)
+ (setq res (cons (car ls) res))
+ (setq ls (cdr ls)))
+ (if (not (null ls))
+ (setq res (cons ls (cons :optional res))))
+ (reverse res)))
+
+(defun scheme-optional-in-brackets (ls)
+ ;; put optional arguments inside brackets (via a vector)
+ (if (memq :optional ls)
+ (let ((res '()))
+ (while (and (consp ls) (not (eq :optional (car ls))))
+ (push (pop ls) res))
+ (reverse (cons (apply #'vector (cdr ls)) res)))
+ ls))
+
+(defun scheme-base-type (x)
+ (if (not (consp x))
+ x
+ (case (car x)
+ ((string list) (car x))
+ ((set) (or (cadr x) (car x)))
+ ((flags) 'integer)
+ ((lambda) 'procedure)
+ ((syntax) 'syntax)
+ (t x))))
+
+(defun scheme-sexp-to-string (sexp)
+ (with-output-to-string (princ sexp)))
+
+(defun scheme-get-current-symbol-info ()
+ (let* ((sym (eldoc-current-symbol))
+ (fnsym0 (eldoc-fnsym-in-current-sexp))
+ (fnsym (if (consp fnsym0) (car fnsym0) fnsym0))
+ (env (save-excursion
+ (if (scheme-in-string-p) (scheme-beginning-of-string))
+ (scheme-current-env)))
+ (spec (or (and sym (scheme-env-lookup env sym))
+ (and fnsym (scheme-env-lookup env fnsym)))))
+ (and (consp spec)
+ (consp (cdr spec))
+ (let ((type (cadr spec)))
+ (concat
+ (cond
+ ((nth 3 spec)
+ "")
+ ((and (consp type)
+ (memq (car type) '(syntax lambda)))
+ (concat
+ (if (eq (car type) 'syntax)
+ "syntax: "
+ "")
+ (scheme-sexp-to-string
+ (cons (car spec)
+ (scheme-optional-in-brackets
+ (mapcar #'scheme-base-type
+ (scheme-translate-dot-to-optional
+ (cadr type))))))
+ (if (and (consp (cddr type))
+ (not (memq (caddr type) '(obj object))))
+ (concat " => " (scheme-sexp-to-string (caddr type)))
+ "")))
+ ((and (consp type) (eq (car type) 'special))
+ (scheme-sexp-to-string (car spec)))
+ (t
+ (scheme-sexp-to-string type)))
+ (if (and (not (nth 3 spec)) (nth 4 spec)) " - " "")
+ (or (nth 4 spec) ""))))))
+
+(provide 'scheme-complete)
+
+;; Local Variables:
+;; eval: (put 'scheme-with-find-file 'lisp-indent-hook 1)
+;; End:
+
diff --git a/scheme.import.scm b/scheme.import.scm
new file mode 100644
index 00000000..040f983a
--- /dev/null
+++ b/scheme.import.scm
@@ -0,0 +1,58 @@
+;;;; scheme.import.scm - import library for "scheme" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'scheme
+ '(not boolean? eq? eqv? equal? pair?
+ cons car cdr caar cadr cdar cddr caaar caadr cadar caddr cdaar cdadr
+ cddar cdddr caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr cdaaar
+ cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr!
+ null? list? list length list-tail list-ref append reverse memq memv
+ member assq assv assoc symbol? symbol->string string->symbol number?
+ integer? exact? real? complex? inexact? rational? zero? odd? even?
+ positive? negative? max min + - * / = > < >= <= quotient remainder
+ modulo gcd lcm abs floor ceiling truncate round exact->inexact
+ inexact->exact exp log expt sqrt sin cos tan asin acos atan
+ number->string string->number char? char=? char>? char<? char>=?
+ char<=? char-ci=? char-ci<? char-ci>? char-ci>=? char-ci<=?
+ char-alphabetic? char-whitespace? char-numeric? char-upper-case?
+ char-lower-case? char-upcase char-downcase char->integer integer->char
+ string? string=? string>? string<? string>=? string<=? string-ci=?
+ string-ci<? string-ci>? string-ci>=? string-ci<=? make-string
+ string-length string-ref string-set! string-append string-copy
+ string->list list->string substring string-fill! vector? make-vector
+ vector-ref vector-set! string vector vector-length vector->list
+ list->vector vector-fill! procedure? map for-each apply force
+ call-with-current-continuation input-port? output-port?
+ current-input-port current-output-port call-with-input-file
+ call-with-output-file open-input-file open-output-file
+ close-input-port close-output-port load read eof-object? read-char
+ peek-char write display write-char newline with-input-from-file
+ with-output-to-file dynamic-wind values call-with-values eval
+ char-ready? imag-part real-part magnitude numerator denominator
+ scheme-report-environment null-environment interaction-environment
+ else)
+ ##sys#default-macro-environment)
diff --git a/scripts/README b/scripts/README
new file mode 100644
index 00000000..09c6e87e
--- /dev/null
+++ b/scripts/README
@@ -0,0 +1,44 @@
+README for scripts/
+===================
+
+
+This directory contains a couple of things that might be useful:
+
+ scheme
+
+ A wrapper sh(1) script that allows automatic compilation of Scheme
+ scripts. If you precede a Scheme file with a header line like this
+
+ #!/usr/bin/env scheme
+
+ then a compiled version of the code will be stored in $HOME/.cache
+ and executed, instead of the original source file.
+
+ tools.scm
+
+ Helper functions for some of the scripts here.
+
+ test-dist.sh
+
+ Takes a platform-designator and the path to a tarball and unpacks,
+ builds and tests the chicken distribution contained therein.
+
+ wiki2html.scm
+
+ A simple svnwiki -> HTML translator used for the manual. Needs
+ `htmlprag' and `matchable' eggs installed.
+
+ make-egg-index.scm
+
+ Creates an egg index HTML page from a local working copy of a
+ `release/<number>' egg tree.
+
+ makedist.scm
+
+ Creates a distribution tarball from a chicken svn checkout.
+
+ henrietta.scm
+ henrietta.cgi
+
+ A CGI script and sub-program that serves eggs from a local tree
+ or via svn over HTTP.
diff --git a/scripts/chicken-scheme b/scripts/chicken-scheme
new file mode 100755
index 00000000..892c0093
--- /dev/null
+++ b/scripts/chicken-scheme
@@ -0,0 +1,44 @@
+#!/bin/bash
+### usage: chicken-scheme FILENAME
+#
+# variables:
+#
+# CHICKEN_AUTOCOMPILE_DEBUG
+
+
+dbgoption=
+cache=$HOME/.chicken-scheme.cache
+uname=`uname`
+wd=`pwd`
+
+if test -n "$CHICKEN_AUTOCOMPILE_DEBUG"; then
+ set -x
+ dbgoption="-v2"
+fi
+
+if test "$#" == 0; then
+ exec csi
+else
+ prg="$1"
+fi
+
+if test $uname = "Darwin"; then
+ prgh=`md5 -q $prg`
+else
+ prgh=`md5sum $prg | sed -n -e 's/\([^[:space:]]*\).*/\1/p'`
+fi
+
+if test \! -d $cache; then
+ mkdir -p $cache
+fi
+
+if test "$prg" -nt "$cache/$prgh"; then
+ csc $dbgoption "$prg" -o "$cache/$prgh"
+fi
+
+if test -x "$cache/$prgh"; then
+ shift
+ exec "$cache/$prgh" "$@"
+else
+ echo "can not run $1"
+fi
diff --git a/scripts/dpkg-eggs.scm b/scripts/dpkg-eggs.scm
new file mode 100644
index 00000000..a0b9da1e
--- /dev/null
+++ b/scripts/dpkg-eggs.scm
@@ -0,0 +1,151 @@
+;;
+;; Given a directory tree with egg directories, build Debian packages
+;; for all eggs that have a debian subdirectory.
+;;
+;; Usage: dpkg-eggs --eggdir=DIR --output-dir=DIR
+;;
+
+(require-extension srfi-1)
+(require-extension srfi-13)
+(require-extension posix)
+(require-extension regex)
+(require-extension utils)
+(require-extension args)
+
+(include "tools.scm")
+
+(define s+ string-append)
+
+(define opts
+ `(
+ ,(args:make-option (extension-path) (required: "DIR")
+ (s+ "path to stream-wiki extensions"))
+ ,(args:make-option (wiki-dir) (required: "DIR")
+ (s+ "use wiki documentation in directory DIR"))
+ ,(args:make-option (egg-dir) (required: "DIR")
+ (s+ "operate on eggs in directory DIR"))
+ ,(args:make-option (output-dir) (required: "DIR")
+ (s+ "place Debian packages in directory DIR (will be created if it does not exist)"))
+ ,(args:make-option (verbose) #:none
+ (s+ "enable verbose mode")
+ (set! *verbose* #t))
+ ,(args:make-option (exclude) (required: "EGGS")
+ (s+ "a comma separated list of eggs to exclude from building"))
+ ,(args:make-option (h help) #:none "Print help"
+ (usage))
+
+ ))
+
+
+;; Use args:usage to generate a formatted list of options (from OPTS),
+;; suitable for embedding into help text.
+(define (usage)
+ (print "Usage: " (car (argv)) " options... [list of eggs to be built] ")
+ (newline)
+ (print "The following options are recognized: ")
+ (newline)
+ (print (parameterize ((args:indent 5)) (args:usage opts)))
+ (exit 1))
+
+
+;; Process arguments and collate options and arguments into OPTIONS
+;; alist, and operands (filenames) into OPERANDS. You can handle
+;; options as they are processed, or afterwards.
+(define args (command-line-arguments))
+(set!-values (options operands) (args:parse args opts))
+
+(define dirsep (string ##sys#pathname-directory-separator))
+
+(define (read-subdirs path)
+ (find-files path directory? cons (list) 0))
+
+;; Compare versions of the format x.x...
+(define (version< v1 v2)
+ (let ((v1 (string-split v1 "."))
+ (v2 (string-split v2 ".")))
+ (every (lambda (s1 s2)
+ (let ((n1 (string->number s1))
+ (n2 (string->number s2)))
+ (cond ((and n1 n2) (<= n1 n2))
+ (else (string<= s1 s2)))))
+ v1 v2)))
+
+;; Find the latest release in a given egg directory
+(define (find-latest-release path)
+ (let ((tags (s+ path dirsep "tags")))
+ (cond ((file-exists? tags)
+ (let ((lst (filter-map (lambda (x) (and (not (string=? (pathname-strip-directory x) ".svn")) x))
+ (read-subdirs tags)))
+ (cmp (lambda (x y) (version< (pathname-strip-directory x) (pathname-strip-directory y)))))
+ (if (pair? lst) (car (reverse (sort lst cmp))) path)))
+ (else path))))
+
+;; Find the debian subdirectory in a given egg directory
+(define (find-debian-subdir path . rest)
+ (let-optionals rest ((release (find-latest-release path)))
+ (cond ((file-exists? (s+ path dirsep "trunk" dirsep "debian")) => identity)
+ ((file-exists? (s+ release dirsep "debian")) => identity)
+ (else #f))))
+
+;; Find wiki documentation for given egg
+(define (find-wiki-doc name wikidir)
+ (cond ((file-exists? (s+ wikidir dirsep name)) => identity)
+ (else #f)))
+
+(define (build-deb eggdir wiki-dir output-dir ext-path path)
+ (let* ((name (pathname-strip-directory path))
+ (release (find-latest-release path))
+ (debdir (find-debian-subdir path release)))
+ (if debdir
+ (let ((start (cwd))
+ (build-dir (s+ output-dir dirsep name))
+ (doc (cond ((file-exists? (s+ release dirsep name ".html")) => identity)
+ ((and wiki-dir (file-exists? (s+ wiki-dir dirsep name))) => identity)
+ (else #f))))
+ (message "Release directory is ~a" release)
+ (message "debian subdirectory found in ~a" path)
+ (run (rm -rf ,build-dir))
+ (run (cp -R ,release ,build-dir))
+ (run (cp -R ,debdir ,build-dir))
+ (if (and doc (not (string-suffix? ".html" doc)))
+ (let ((html-path (s+ "html/" name ".html")))
+ (run (csi -s ,(cond ((file-exists? (s+ start "/makehtml.scm")) => identity)
+ (else 'makehtml.scm))
+ ,(s+ "--extension-path=" ext-path)
+ ,(s+ "--wikipath=" wiki-dir)
+ ,(s+ "--only=" name)))
+ (run (cp ,html-path ,build-dir))))
+ (cd build-dir)
+ (run (chmod a+rx debian/rules))
+ (run (,(s+ "EGG_TREE=\"" eggdir "\"") dpkg-buildpackage -us -uc))
+ (cd start))
+ (message "No debian subdirectory found in ~a" path))))
+
+(define (main options operands)
+ (let ((opt_wikidir (alist-ref 'wiki-dir options))
+ (opt_eggdir (alist-ref 'egg-dir options))
+ (opt_extpath (alist-ref 'extension-path options))
+ (opt_exclude ((lambda (x) (and x (string-split x ","))) (alist-ref 'exclude options)))
+ (opt_output-dir (alist-ref 'output-dir options)))
+ (if (not (and opt_eggdir opt_output-dir))
+ (begin
+ (error-message "Both egg directory and output directory must be specified!")
+ (usage)))
+ (message "Egg directory tree: ~a" opt_eggdir)
+ (message "Output directory tree: ~a" opt_output-dir)
+ ;; make sure target dir exists
+ (if (not (file-exists? opt_output-dir))
+ (begin
+ (message "Creating directory ~a" opt_output-dir)
+ (create-directory opt_output-dir)))
+ (let ((eggdirs (filter-map
+ (lambda (x) (and (not (member (pathname-strip-directory x) opt_exclude)) x))
+ (or (and (pair? operands) (map (lambda (x) (s+ opt_eggdir dirsep (->string x))) operands))
+ (read-subdirs opt_eggdir)))))
+ (if (null? eggdirs)
+ (message "No egg directories found in ~a" opt_eggdir)
+ (message "Found egg directories: ~a" eggdirs))
+ (for-each (lambda (x) (build-deb opt_eggdir opt_wikidir opt_output-dir opt_extpath x))
+ eggdirs))))
+
+(main options operands)
diff --git a/scripts/guess-platform.sh b/scripts/guess-platform.sh
new file mode 100644
index 00000000..a81236d7
--- /dev/null
+++ b/scripts/guess-platform.sh
@@ -0,0 +1,21 @@
+#!/bin/sh
+### guess-platform.sh - guess correct setting for PLATFORM
+
+
+if test "$MSYSTEM" == MINGW32; then
+ echo mingw-msys
+ exit
+fi
+
+case `uname` in
+ *Linux*)
+ echo "linux";;
+ *BSD*)
+ echo "bsd";;
+ Darwin)
+ echo "macosx";;
+ *)
+ echo "cannot figure out correct PLATFORM"
+ exit 1;;
+ # missing: solaris, cygwin
+esac
diff --git a/scripts/henrietta.cgi b/scripts/henrietta.cgi
new file mode 100644
index 00000000..cfef0e85
--- /dev/null
+++ b/scripts/henrietta.cgi
@@ -0,0 +1,10 @@
+#!/bin/sh
+
+export HENRIETTA=/home/chicken/henrietta
+export EGG_REPOSITORY=https://localhost/svn/chicken-eggs/release/4
+export LOGFILE=/home/chicken/henrietta.log
+export USERNAME=anonymous
+export PASSWORD=
+
+exec "$HENRIETTA" -l "$EGG_REPOSITORY" -t svn -username "$USERNAME" \
+ -password "$PASSWORD" 2>>"$LOGFILE"
diff --git a/scripts/henrietta.scm b/scripts/henrietta.scm
new file mode 100644
index 00000000..b3a6fe81
--- /dev/null
+++ b/scripts/henrietta.scm
@@ -0,0 +1,205 @@
+;;;; henrietta.scm - Server program (CGI) for serving eggs from a repository over HTTP
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+; used environment variables:
+;
+; QUERY_STRING
+; REMOTE_ADDR (optional)
+
+; URL arguments:
+;
+; version=<version>
+; name=<name>
+; tests
+; list
+
+
+(require-library setup-download regex extras utils ports srfi-1 posix)
+
+
+(module main ()
+
+ (import scheme chicken regex extras utils ports srfi-1 posix)
+ (import setup-api setup-download)
+
+ (define *default-transport* 'svn)
+ (define *default-location* (current-directory))
+ (define *username* #f)
+ (define *password* #f)
+ (define *tests* #f)
+
+ (define (headers)
+ (print "Connection: close\r\nContent-type: text/plain\r\n\r\n"))
+
+ (define (fail msg . args)
+ (pp `(error ,msg ,@args))
+ (cleanup)
+ (exit 0))
+
+ (define (cleanup)
+ (and-let* ((tmpdir (temporary-directory)))
+ (fprintf (current-error-port) "removing temporary directory `~a'~%" tmpdir)
+ (remove-directory tmpdir)))
+
+ (define test-file?
+ (let ((rx (regexp "(\\./)?tests(/.*)?")))
+ (lambda (path) (string-match rx path))))
+
+ (define (retrieve name version)
+ (let ((dir (handle-exceptions ex
+ (fail ((condition-property-accessor 'exn 'message) ex)
+ ((condition-property-accessor 'exn 'arguments) ex))
+ (retrieve-extension
+ name *default-transport* *default-location*
+ version: version
+ quiet: #t
+ destination: #f
+ tests: *tests*
+ username: *username*
+ password: *password*))))
+ (unless dir
+ (fail "no such extension or version" name version))
+ (let walk ((dir dir) (prefix "."))
+ (let ((files (directory dir)))
+ (for-each
+ (lambda (f)
+ (when (or *tests* (not (test-file? f)))
+ (let ((ff (string-append dir "/" f))
+ (pf (string-append prefix "/" f)))
+ (cond ((directory? ff)
+ (print "\n#|--------------------|# \"" pf "/\" 0")
+ (walk ff pf))
+ (else
+ (print "\n#|--------------------|# \"" pf "\" " (file-size ff))
+ (display (read-all ff)))))))
+ files)))
+ (print "\n#!eof") ) )
+
+ (define (listing)
+ (let ((dir (handle-exceptions ex
+ (fail ((condition-property-accessor 'exn 'message) ex)
+ ((condition-property-accessor 'exn 'arguments) ex))
+ (list-extensions
+ *default-transport* *default-location*
+ quiet: #t
+ username: *username*
+ password: *password*))))
+ (if dir
+ (display dir)
+ (fail "unable to retrieve extension-list"))))
+
+ (define query-string-rx (regexp "[^?]+\\?(.+)"))
+ (define query-arg-rx (regexp "^&?(\\w+)=([^&]+)"))
+
+ (define (service)
+ (let ((qs (getenv "QUERY_STRING"))
+ (ra (getenv "REMOTE_ADDR")))
+ (fprintf (current-error-port) "~%========== serving request from ~a: ~s~%"
+ (or ra "<unknown>") qs)
+ (unless qs
+ (error "no QUERY_STRING set"))
+ (let ((m (string-match query-string-rx qs))
+ (egg #f)
+ (version #f))
+ (let loop ((qs (if m (cadr m) qs)))
+ (let* ((m (string-search-positions query-arg-rx qs))
+ (ms (and m (apply substring qs (cadr m))))
+ (rest (and m (substring qs (cadar m)))))
+ (cond ((not m)
+ (headers) ; from here on use `fail'
+ (cond (egg
+ (retrieve egg version)
+ (cleanup) )
+ (else (fail "no extension name specified") ) ))
+ ((string=? ms "version")
+ (set! version (apply substring qs (caddr m)))
+ (loop rest))
+ ((string=? ms "name")
+ (set! egg (apply substring qs (caddr m)))
+ (loop rest))
+ ((string=? ms "tests")
+ (set! *tests* #t)
+ (loop rest))
+ ((string=? ms "list")
+ (headers)
+ (listing))
+ (else
+ (warning "unrecognized query option" ms)
+ (loop rest))))))))
+
+
+ (define (usage code)
+ (print #<#EOF
+usage: henrietta [OPTION ...]
+
+ -h -help show this message
+ -l -location LOCATION install from given location (default: current directory)
+ -t -transport TRANSPORT use given transport instead of default (#{*default-transport*})
+ -username USER set username for transports that require this
+ -password PASS set password for transports that require this
+EOF
+);|
+ (exit code))
+
+ (define *short-options* '(#\h #\l #\t))
+
+ (define (main args)
+ (let loop ((args args))
+ (if (null? args)
+ (service)
+ (let ((arg (car args)))
+ (cond ((or (string=? arg "-help")
+ (string=? arg "-h")
+ (string=? arg "--help"))
+ (usage 0))
+ ((or (string=? arg "-l") (string=? arg "-location"))
+ (unless (pair? (cdr args)) (usage 1))
+ (set! *default-location* (cadr args))
+ (loop (cddr args)))
+ ((or (string=? arg "-t") (string=? arg "-transport"))
+ (unless (pair? (cdr args)) (usage 1))
+ (set! *default-transport* (string->symbol (cadr args)))
+ (loop (cddr args)))
+ ((string=? "-username" arg)
+ (unless (pair? (cdr args)) (usage 1))
+ (set! *username* (cadr args))
+ (loop (cddr args)))
+ ((string=? "-password" arg)
+ (unless (pair? (cdr args)) (usage 1))
+ (set! *password* (cadr args))
+ (loop (cddr args)))
+ ((and (positive? (string-length arg))
+ (char=? #\- (string-ref arg 0)))
+ (if (> (string-length arg) 2)
+ (let ((sos (string->list (substring arg 1))))
+ (if (null? (lset-intersection eq? *short-options* sos))
+ (loop (append (map (cut string #\- <>) sos) (cdr args)))
+ (usage 1)))
+ (usage 1)))
+ (else (loop (cdr args))))))))
+
+ (main (command-line-arguments))
+
+)
diff --git a/scripts/import-to-index b/scripts/import-to-index
new file mode 100755
index 00000000..934bbaaf
--- /dev/null
+++ b/scripts/import-to-index
@@ -0,0 +1,45 @@
+#!/bin/sh
+#| import-to-index - convert import-library to documentation-index -*- Scheme -*-
+exec csi -s "$0" "$@"
+|#
+
+(define (usage code)
+ (print "usage: import-to-index [-p PREFIX] [-s SUFFIX] [-l LINK] IMPORTLIB ...")
+ (exit code))
+
+(define (main args)
+ (let ((prefix "")
+ (suffix "")
+ (link #f))
+ (let loop ((args args) (libs '()))
+ (cond ((null? args)
+ (for-each
+ (lambda (lib)
+ ;; those slot accesses are naturally highly implementation dependent
+ (let* ((mod (##sys#find-module (string->symbol lib)))
+ (exports (map car (append (##sys#slot mod 10) (##sys#slot mod 11)))))
+ (define (make-name s)
+ (or link (conc prefix s suffix)))
+ (print "; " lib)
+ (for-each
+ (lambda (s)
+ (if (symbol? s)
+ (pp (cons s (make-name s)))
+ (pp (cons (car s) (make-name (car s))))))
+ exports)))
+ (reverse libs)))
+ ((string=? "-p" (car args))
+ (set! prefix (cadr args))
+ (loop (cddr args) libs))
+ ((string=? "-s" (car args))
+ (set! suffix (cadr args))
+ (loop (cddr args) libs))
+ ((string=? "-l" (car args))
+ (set! link (cadr args))
+ (loop (cddr args) libs))
+ (else
+ (let ((lib (car args)))
+ (eval `(import ,(string->symbol lib)))
+ (loop (cdr args) (cons lib libs))))))))
+
+(main (command-line-arguments))
diff --git a/scripts/make-egg-index.scm b/scripts/make-egg-index.scm
new file mode 100644
index 00000000..055b987e
--- /dev/null
+++ b/scripts/make-egg-index.scm
@@ -0,0 +1,264 @@
+;;;; make-egg-index.scm - create index page for extension release directory
+
+(load-relative "tools.scm")
+
+(use setup-download matchable sxml-transforms data-structures regex)
+
+(import irregex)
+
+(define *help* #f)
+(define *major-version* (##sys#fudge 41))
+
+(define +link-regexp+
+ (irregex '(: #\[ #\[ (submatch (* (~ #\] #\|))) #\] #\])))
+
+(define +categories+
+ '((lang-exts "Language extensions")
+ (graphics "Graphics")
+ (debugging "Debugging tools")
+ (logic "Logic programming")
+ (net "Networking")
+ (io "Input/Output")
+ (db "Databases")
+ (os "OS interface")
+ (ffi "Interfacing to other languages")
+ (web "Web programming")
+ (xml "XML processing")
+ (doc-tools "Documentation tools")
+ (egg-tools "Egg tools")
+ (math "Mathematical libraries")
+ (oop "Object-oriented programming")
+ (data "Algorithms and data-structures")
+ (parsing "Data formats and parsing")
+ (tools "Tools")
+ (sound "Sound")
+ (testing "Unit-testing")
+ (crypt "Cryptography")
+ (ui "User interface toolkits")
+ (code-generation "Code generation")
+ (macros "Macros and meta-syntax")
+ (misc "Miscellaneous")
+ (hell "Concurrency and parallelism")
+ (uncategorized "Uncategorized")
+ (obsolete "Unsupported or redundant") ) )
+
+(define (d fstr . args)
+ (fprintf (current-error-port) "~?~%" fstr args))
+
+(define (usage code)
+ (print "make-egg-index.scm [--help] [--major-version=MAJOR] [DIR]")
+ (exit code))
+
+(define (sxml->html doc)
+ (SRV:send-reply
+ (pre-post-order
+ doc
+ ;; LITERAL tag contents are used as raw HTML.
+ `((literal *preorder* . ,(lambda (tag . body) (map ->string body)))
+ ,@universal-conversion-rules))))
+
+(define (make-egg-index dir)
+ (let ((title (sprintf "Eggs Unlimited (release branch ~a)" *major-version*))
+ (eggs (gather-egg-information dir)))
+ (sxml->html
+ `((literal "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n")
+ (literal "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Transitional//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd\">")
+ (html
+ ,(header title)
+ (body
+ ,(titlebar title)
+ ,(sidebar)
+ ,(content (prelude title)
+ (emit-egg-information eggs))
+ ,(trailer)))))))
+
+(define (wiki-link path desc)
+ `(a (@ (href "http://chicken.wiki.br/" ,path))
+ ,desc))
+
+(define (sidebar)
+ `(div (@ (id "toc-links"))
+ (div (@ (id "toc"))
+ (p ,(wiki-link "" "Home") (br)
+ ,(wiki-link "manual/index" "Manual") (br)
+ ,(wiki-link "eggs" "Eggs") (br)
+ ,(wiki-link "users" "Users") (br)
+ ))))
+
+(define (content . body)
+ `(div (@ (id "content-box"))
+ (div (@ (class "content"))
+ ,body)))
+
+(define (header title)
+ `(head
+;; (style (@ (type "text/css"))
+;; ,+stylesheet+)
+ (link (@ (rel "stylesheet")
+ (type "text/css")
+ (href "http://chicken.wiki.br/common-css")))
+ (title ,title)))
+
+(define (titlebar title)
+ `(div (@ (id "header"))
+ (h1 (a (@ (href "http://chicken.wiki.br/eggs"))
+ ,title))))
+
+(define (prelude title)
+ `((p (img (@
+ (style "float: right;")
+ (src "http://www.call-with-current-continuation.org/eggs/3/egg.jpg"))))
+ (p (b "Last updated: " ,(seconds->string (current-seconds))))
+ (p "A library of extensions for the Chicken Scheme system.")
+ (h2 "Installation")
+ (p "Just enter")
+ (pre " chicken-install EXTENSIONNAME\n")
+ (p "This will download anything needed to compile and install the library. "
+ "If your " (i "extension repository") " is placed at a location for which "
+ "you don't have write permissions, then run " (tt "chicken-install")
+ " with the " (tt "-sudo") " option or run it as root (not recommended).")
+ (p "You can obtain the repository location by running")
+ (pre " csi -p \"(repository-path)\"\n")
+ (p "If you only want to download the extension and install it later, pass the "
+ (tt "-retrieve") " option to " (tt "chicken-install") ":")
+ (pre " chicken-install -retrieve EXTENSIONNAME\n")
+ (p "By default the archive will be unpacked into a temporary directory (named "
+ (tt "EXTENSIONNAME.egg-dir") ") and the directory will be removed if the "
+ "installation completed successfully. To keep the extracted files add "
+ (tt "-keep") " to the options passed to " (tt "chicken-install") ".")
+ (p "For more information, enter")
+ (pre " chicken-install -help\n")
+ (p "If you would like to access the subversion repository, see the "
+ (a (@ (href "http://chicken.wiki.br/eggs tutorial"))
+ "Egg tutorial") ".")
+ (p "If you are looking for 3rd party libraries used by one of the extensions, "
+ "check out the CHICKEN "
+ (a (@ (href "http://www.call-with-current-continuation.org/tarballs/") )
+ "tarball repository") ".")
+ (h2 "List of available eggs")
+ (a (@ (name "category-list")))
+ (h3 "Categories")
+ ,(category-link-list)
+ ))
+
+;; information on empty categories not available yet; link all possible categories
+(define (category-link-list)
+ `(ul (@ (style "list-style-type: none; padding-left: 2em;"))
+ ,@(map
+ (match-lambda
+ ((cat catname)
+ `(li (a (@ (href "#" ,cat))
+ ,catname))))
+ +categories+)))
+
+(define (trailer)
+ `(div (@ (id "credits"))
+ (p "Generated with Chicken " ,(chicken-version))))
+
+(define (emit-egg-information eggs)
+ (append-map
+ (match-lambda
+ ((cat catname)
+ (let ((eggs (append-map
+ make-egg-entry
+ (sort
+ (filter (lambda (info)
+ (and (eq? cat (cadr (or (assq 'category (cdr info))
+ '(#f uncategorized))))
+ (not (assq 'hidden (cdr info)))))
+ eggs)
+ (lambda (e1 e2)
+ (string<? (symbol->string (car e1)) (symbol->string (car e2))))))))
+ (if (null? eggs)
+ '()
+ (begin
+ (d "category: ~a" catname)
+ `((a (@ (name ,cat)))
+ (h3 (a (@ (href "#category-list"))
+ ,catname))
+ (table
+ (tr (th "Name") (th "Description") (th "License") (th "author") (th "maintainer") (th "version"))
+ ,@eggs)))))))
+ +categories+))
+
+(define (make-egg-entry egg)
+ (call/cc
+ (lambda (return)
+ (define (prop name def pred)
+ (cond ((assq name (cdr egg)) => (o (cut check pred <> name) cadr))
+ (else def)))
+ (define (check pred x p)
+ (cond ((pred x) x)
+ (else
+ (warning "extension has .meta entry of incorrect type and will not be listed" (car egg) p x)
+ (return '()))))
+ (d " ~a ~a" (car egg) (prop 'version "HEAD" any?))
+ `((tr (td (a (@ (href ,(sprintf "http://chicken.wiki.br/eggref/~a/~a" *major-version* (car egg))))
+ ,(symbol->string (car egg))))
+ (td ,(prop 'synopsis "unknown" string?))
+ (td ,(prop 'license "unknown" name?))
+ (td ,(linkify-names (prop 'author "unknown" name?)))
+ (td ,(linkify-names (prop 'maintainer "" name?)))
+ (td ,(prop 'version "" version?)))))))
+
+;; Names are either raw HTML, or [[user name]] denoting a wiki link.
+(define (linkify-names str)
+ ;; Call MATCHED on (sub)matches and DID-NOT-MATCH on non-matches in STR,
+ ;; and collect into a list.
+ (define (transform irx str matched did-not-match)
+ ;; IRREGEX-FOLD is exported for SVN trunk >= r14283, delete this if
+ ;; installed Chicken is new enough.
+ (define (irregex-fold irx kons knil str . o)
+ (let* ((irx (irregex irx))
+ (finish (if (pair? o) (car o) (lambda (i acc) acc)))
+ (start (if (and (pair? o) (pair? (cdr o))) (cadr o) 0))
+ (end (if (and (pair? o) (pair? (cdr o)) (pair? (cddr o)))
+ (caddr o)
+ (string-length str))))
+ (let lp ((i start) (acc knil))
+ (if (>= i end)
+ (finish i acc)
+ (let ((m (irregex-search irx str i end)))
+ (if (not m)
+ (finish i acc)
+ (let* ((end (irregex-match-end m 0))
+ (acc (kons i m acc)))
+ (lp end acc))))))))
+ (let ((irregex-match-start-index irregex-match-start)) ;; upcoming API change in irregex 0.7
+ (irregex-fold irx
+ (lambda (i m s)
+ (cons (matched (irregex-match-substring m 1))
+ (cons (did-not-match
+ (substring str i (irregex-match-start-index m 0)))
+ s)))
+ '()
+ str
+ (lambda (i s)
+ (reverse (cons (did-not-match (substring str i))
+ s))))))
+ (transform
+ +link-regexp+
+ str
+ (lambda (name) ;; wiki username
+ `(a (@ (href ,(string-append "http://chicken.wiki.br/users/"
+ (string-substitute " " "-" name 'global))))
+ ,name))
+ (lambda (x) ;; raw HTML chunk
+ `(literal ,x))))
+
+(define name?
+ (disjoin string? symbol?))
+
+(define version?
+ (disjoin string? number?))
+
+(define (main args)
+ (when *help* (usage 0))
+ (match args
+ ((dir)
+ (make-egg-index dir))
+ (() (make-egg-index "."))
+ (_ (usage 1))))
+
+(main (simple-args (command-line-arguments)))
+
diff --git a/scripts/make-egg-rss-feed.scm b/scripts/make-egg-rss-feed.scm
new file mode 100644
index 00000000..4ecde7bc
--- /dev/null
+++ b/scripts/make-egg-rss-feed.scm
@@ -0,0 +1,114 @@
+;;;; make-egg-rss-feed.scm - create RSS 2.0 feed for extension release directory
+
+(load-relative "tools.scm")
+
+;; uses sxml-transforms since htmlprag idiotically attempts to be clever
+;; about empty elements (i.e. "link").
+
+(use setup-download matchable sxml-transforms data-structures regex srfi-1)
+
+(import irregex)
+
+(define *help* #f)
+(define *major-version* (##sys#fudge 41))
+
+(define +categories+
+ '((lang-exts "Language extensions")
+ (graphics "Graphics")
+ (debugging "Debugging tools")
+ (logic "Logic programming")
+ (net "Networking")
+ (io "Input/Output")
+ (db "Databases")
+ (os "OS interface")
+ (ffi "Interfacing to other languages")
+ (web "Web programing")
+ (xml "XML processing")
+ (doc-tools "Documentation tools")
+ (egg-tools "Egg tools")
+ (math "Mathematical libraries")
+ (oop "Object-oriented programming")
+ (data "Algorithms and data-structures")
+ (parsing "Data formats and parsing")
+ (tools "Tools")
+ (sound "Sound")
+ (testing "Unit-testing")
+ (crypt "Cryptography")
+ (ui "User interface toolkits")
+ (code-generation "Code generation")
+ (macros "Macros and meta-syntax")
+ (misc "Miscellaneous")
+ (hell "Concurrency and parallelism")
+ (uncategorized "Not categorized")
+ (obsolete "Unsupported or redundant") ) )
+
+(define (d fstr . args)
+ (fprintf (current-error-port) "~?~%" fstr args))
+
+(define (usage code)
+ (print "make-egg-rss-feed.scm [--help] [--major-version=MAJOR] [DIR]")
+ (exit code))
+
+(define (make-egg-rss-feed dir)
+ (let ((title (sprintf "Eggs Unlimited (release branch ~a)" *major-version*))
+ (eggs (gather-egg-information dir)))
+ (display "<?xml version='1.0'?>\n")
+ (SXML->HTML
+ `(rss
+ (@ (version "2.0"))
+ (channel
+ ,@(channel title)
+ ,@(items eggs))))))
+
+(define (channel title)
+ (let ((date (seconds->string (current-seconds))))
+ `((title ,title)
+ (link "http://galinha.ucpel.tche.br/chicken-projects/egg-rss-feed-4.xml")
+ (description "RSS feed for publishing latest CHICKEN extensions")
+ (language "en-us")
+ (copyright "(c)2009 The CHICKEN Team")
+ (pubDate ,date)
+ (lastBuildDate ,date))))
+
+(define (items eggs)
+ (map
+ (lambda (egg)
+ (call/cc
+ (lambda (return)
+ (define (prop name def pred)
+ (cond ((assq name (cdr egg)) => (o (cut check pred <> name) cadr))
+ (else def)))
+ (define (check pred x p)
+ (cond ((pred x) x)
+ (else
+ (warning "extension has .meta entry of incorrect type and will not be listed" (car egg) p x)
+ (return '()))))
+ (d " ~a ~a" (car egg) (prop 'version "HEAD" any?))
+ `(item
+ (title ,(sprintf "~a ~a (~a)"
+ (car egg)
+ (prop 'version "" version?)
+ (let* ((c1 (prop 'category 'uncategorized name?))
+ (c (assq c1 +categories+)))
+ (if c (cadr c) (sprintf "unknown category: ~a" c1)))))
+ (guid (@ (isPermaLink "false")) ,(symbol->string (car egg)))
+ (link ,(sprintf "http://chicken.wiki.br/eggref/~a/~a" *major-version* (car egg)))
+ (description ,(prop 'synopsis "unknown" string?))
+ (author ,(prop 'author "unknown" name?))))))
+ eggs))
+
+(define name?
+ (disjoin string? symbol?))
+
+(define version?
+ (disjoin string? number?))
+
+(define (main args)
+ (when *help* (usage 0))
+ (match args
+ ((dir)
+ (make-egg-rss-feed dir))
+ (() (make-egg-rss-feed "."))
+ (_ (usage 1))))
+
+(main (simple-args (command-line-arguments)))
diff --git a/scripts/make-eggdoc.scm b/scripts/make-eggdoc.scm
new file mode 100644
index 00000000..a8e9d416
--- /dev/null
+++ b/scripts/make-eggdoc.scm
@@ -0,0 +1,57 @@
+;;;; make-eggdoc.scm - create HTML files for eggs that use eggdoc.
+
+(include "tools.scm")
+
+(use setup-download matchable data-structures regex)
+
+(import foreign)
+
+(define csi (foreign-value "C_CSI_PROGRAM" c-string))
+
+(define *help* #f)
+(define *docroot* ".")
+
+(define *major-version* (##sys#fudge 41))
+
+(define (d fstr . args)
+ (fprintf (current-error-port) "~?~%" fstr args))
+
+(define (usage code)
+ (print "make-eggdoc.scm [--help] [--major-version=MAJOR] [DIR]")
+ (exit code))
+
+
+(define (make-eggdoc dir)
+ (let ((title (sprintf "Eggs Unlimited (release branch ~a)" *major-version*))
+ (eggs (gather-egg-information dir)))
+
+ (for-each
+ (lambda (egg)
+ (let ((meta (cdr egg)))
+ (cond
+ ((assq 'eggdoc meta) =>
+ (lambda (edoc)
+ (let ((eggname (->string (car egg))))
+ (d "creating HTML from eggdoc file ~a" (cadr edoc))
+ (let* ((egg-dir (locate-egg/local eggname dir))
+ (eggref-dir (sprintf "~s/eggref/~a" *docroot* *major-version* ))
+ (cmd (sprintf "~a -s ~a > ~a"
+ csi
+ (make-pathname egg-dir (->string (cadr edoc)))
+ (make-pathname eggref-dir eggname "html"))))
+ (d "~s" cmd)
+ (system* cmd) )))))))
+ eggs)
+
+ ))
+
+(define (main args)
+ (when *help* (usage 0))
+ (print "args = " args)
+ (match args
+ ((dir) (make-eggdoc dir))
+ (() (make-eggdoc "."))
+ (_ (usage 1))))
+
+(main (simple-args (command-line-arguments)))
+
diff --git a/scripts/makedist.scm b/scripts/makedist.scm
new file mode 100644
index 00000000..a6100b27
--- /dev/null
+++ b/scripts/makedist.scm
@@ -0,0 +1,77 @@
+;;;; makedist.scm - Make distribution tarballs
+
+
+(define *release* #f)
+
+(load-relative "tools.scm")
+
+(set! *verbose* #t)
+
+(define BUILDVERSION (with-input-from-file "buildversion" read))
+
+(define *platform*
+ (let ((sv (symbol->string (software-version))))
+ (cond ((string-match ".*bsd" sv) "bsd")
+ (else
+ (case (build-platform)
+ ((mingw32)
+ (if (string=? (getenv "MSYSTEM") "MINGW32")
+ "mingw-msys"
+ "mingw32"))
+ ((msvc) "msvc")
+ (else sv))))))
+
+(define *make* "make")
+
+(define (release full?)
+ (let* ((files (read-lines "distribution/manifest"))
+ (distname (conc "chicken-" BUILDVERSION))
+ (distfiles (map (cut prefix distname <>) files))
+ (tgz (conc distname ".tar.gz")))
+ (run (rm -fr ,distname ,tgz))
+ (create-directory distname)
+ (for-each
+ (lambda (d)
+ (let ((d (path distname d)))
+ (unless (file-exists? d)
+ (print "creating " d)
+ (create-directory d))))
+ (delete-duplicates (filter-map prefix files) string=?))
+ (let ((missing '()))
+ (for-each
+ (lambda (f)
+ (if (-e f)
+ (run (cp -p ,(qs f) ,(qs (path distname f))))
+ (set! f (cons f missing))))
+ files)
+ (unless (null? missing)
+ (warning "files missing" missing) ) )
+ (run (tar cfz ,(conc distname ".tar.gz") ,distname))
+ (run (rm -fr ,distname)) ) )
+
+(define (make-html)
+ (unless (file-exists? "html")
+ (create-directory "html"))
+ (run (,(or (get-environment-variable "CSI")
+ (let ((this (car (argv))))
+ (if (string=? "csi" (pathname-file this))
+ this
+ "csi")) )
+ -s scripts/wiki2html.scm
+ --outdir=html
+ ,@(map (o qs (cut make-pathname "manual" <>))
+ (directory "manual")))))
+
+(define *makeargs*
+ (simple-args
+ (command-line-arguments)
+ (lambda _
+ (print "usage: makedist [--release] [--make=PROGRAM] [--platform=PLATFORM] MAKEOPTION ...")
+ (exit 1))) )
+
+(run (,*make* -f ,(conc "Makefile." *platform*) distfiles ,@*makeargs*))
+
+(make-html)
+(run (cp misc/manual.css html))
+
+(release *release*)
diff --git a/scripts/scheme b/scripts/scheme
new file mode 100755
index 00000000..66740fab
--- /dev/null
+++ b/scripts/scheme
@@ -0,0 +1,44 @@
+#!/bin/bash
+### usage: scheme FILENAME
+#
+# variables:
+#
+# AUTOCOMPILE_DEBUG
+
+
+dbgoption=
+cache=$HOME/.schemecache
+uname=`uname`
+wd=`pwd`
+
+if test -n "$AUTOCOMPILE_DEBUG"; then
+ set -x
+ dbgoption="-v2"
+fi
+
+if test "$#" == 0; then
+ exec csi
+else
+ prg="$1"
+fi
+
+if test $uname = "Darwin"; then
+ prgh=`md5 -q $prg`
+else
+ prgh=`md5sum $prg | sed -n -e 's/\([^[:space:]]*\).*/\1/p'`
+fi
+
+if test \! -d $cache; then
+ mkdir -p $cache
+fi
+
+if test "$prg" -nt "$cache/$prgh"; then
+ csc $dbgoption "$prg" -o "$cache/$prgh"
+fi
+
+if test -x "$cache/$prgh"; then
+ shift
+ exec "$cache/$prgh" "$@"
+else
+ echo "can not run $1"
+fi
diff --git a/scripts/setversion b/scripts/setversion
new file mode 100644
index 00000000..af580cde
--- /dev/null
+++ b/scripts/setversion
@@ -0,0 +1,62 @@
+#!/bin/sh
+#| setversion - Bump version-number -*- Scheme -*-
+exec csi -s "$0" "$@"
+|#
+
+(use srfi-1 utils posix)
+
+(define buildversion (->string (car (read-file "buildversion"))))
+(define buildbinaryversion (car (read-file "buildbinaryversion")))
+
+(define files '("README" "manual/The User's Manual"))
+
+(define-syntax rx
+ (syntax-rules ()
+ ((_ r) (force (delay (regexp r))))))
+
+(define (patch which rx subst)
+ (cond ((and (list? which) (= 2 (length which)))
+ (let ((from (car which))
+ (to (cadr which)))
+ (print "patching " from " ...")
+ (with-output-to-file to
+ (lambda ()
+ (with-input-from-file from
+ (lambda ()
+ (let loop ()
+ (let ((ln (read-line)))
+ (unless (eof-object? ln)
+ (write-line (string-substitute rx subst ln #t))
+ (loop) ) ) ) )
+ binary:) )
+ binary:)))
+ (else
+ (let ((tmp (create-temporary-file)))
+ (patch (list which tmp) rx subst)
+ (system* "mv ~S ~S" tmp which) ) ) ) )
+
+(define (parse-version v)
+ (string-match (rx "(\\d+)\\.(\\d+)\\.(\\d+)(.*)") v) )
+
+(define (main args)
+ (cond ((member "-set" args) =>
+ (lambda (a) (set! buildversion (cadr a))) )
+ ((not (member "-noinc" args))
+ (let* ((v (parse-version buildversion))
+ (maj (cadr v))
+ (min (caddr v))
+ (pl (cadddr v))
+ (huh (car (cddddr v))))
+ (set! buildversion (conc maj "." min "." (add1 (string->number pl)) huh)) ) ) )
+ (with-output-to-file "buildversion" (cut display buildversion) binary:)
+ (with-output-to-file "version.scm"
+ (lambda ()
+ (write `(define-constant +build-version+ ,buildversion))
+ (newline) )
+ binary:)
+ (system* "cat version.scm")
+ (let ([vstr (sprintf "version ~A" buildversion)])
+ (for-each (cut patch <> (rx "version [0-9][-.0-9a-zA-Z]+") vstr) files) )
+ 0)
+
+(main (command-line-arguments))
diff --git a/scripts/test-dist.sh b/scripts/test-dist.sh
new file mode 100644
index 00000000..6ba17364
--- /dev/null
+++ b/scripts/test-dist.sh
@@ -0,0 +1,89 @@
+#!/bin/sh
+### test-dist.sh - test distribution tarball
+#
+# usage: test-dist.sh [-bootstrap] PLATFORM [TARBALL]
+
+set -e
+
+pwdopts=
+bootstrap=
+
+if test "$1" = "-bootstrap"; then
+ bootstrap=1
+ shift
+fi
+
+case $# in
+ 1|2) ;;
+ *)
+ echo "usage: test-dist.sh [-bootstrap] PLATFORM [TARBALL]"
+ exit 1;;
+esac
+
+platform="$1"
+tarball="$2"
+makeprg=gmake
+
+# use gmake, if available
+if test -z `which gmake`; then
+ makeprg=make
+fi
+
+# need Windows-style drive letter on mingw/msys
+if test -n "$MSYSTEM"; then
+ pwdopts=-W
+fi
+
+# bootstrap, if desired
+prefix=`pwd $pwdopts`/tmp-test-dist
+
+if test \! -x "$prefix/bin/csi"; then
+ echo "no csi at ${prefix} - please build and install chicken first"
+ exit 1
+fi
+
+for ext in htmlprag matchable; do
+ if test `$prefix/bin/csi -p "(extension-information '${ext})"` = "#f"; then
+ $prefix/bin/chicken-install $ext
+ fi
+done
+
+if test -n "$bootstrap"; then
+ $makeprg PLATFORM=$platform PREFIX=$prefix DEBUGBUILD=1 bootstrap
+ $makeprg PLATFORM=$platform PREFIX=$prefix DEBUGBUILD=1 CHICKEN=./chicken-boot confclean all install
+fi
+
+# if no tarball given, create one
+if test -z "$tarball"; then
+ $prefix/bin/csi -s scripts/makedist.scm --make=$makeprg --platform=$platform
+ tarball=chicken-`cat buildversion`.tar.gz
+fi
+
+# prepare testing directory
+if test -d tmp-test-dist; then
+ rm -fr tmp-test-dist/*
+fi
+
+mkdir -p tmp-test-dist
+cp "$tarball" tmp-test-dist
+
+# unpack and enter
+cd tmp-test-dist
+tar xvfz "$tarball"
+cd `basename "$tarball" .tar.gz`
+
+# build #1
+$makeprg PLATFORM=$platform PREFIX=$prefix DEBUGBUILD=1 all install
+# check #1
+$makeprg PLATFORM=$platform PREFIX=$prefix DEBUGBUILD=1 check
+# build once again with freshly built compiler
+touch *.scm
+$makeprg PLATFORM=$platform PREFIX=$prefix DEBUGBUILD=1 CHICKEN=$prefix/bin/chicken all install
+# and check...
+$makeprg PLATFORM=$platform PREFIX=$prefix DEBUGBUILD=1 check
+
+# Install a few eggs
+$prefix/bin/chicken-install -test prometheus
+$prefix/bin/chicken-install opengl
+
+echo "looks good."
diff --git a/scripts/tools.scm b/scripts/tools.scm
new file mode 100644
index 00000000..3d07dc29
--- /dev/null
+++ b/scripts/tools.scm
@@ -0,0 +1,462 @@
+;;;; tools.scm
+
+
+(use (srfi 1) posix utils files)
+
+
+(define *verbose* (##sys#fudge 13))
+(define *dependencies* (make-hash-table string=?))
+(define *variables* (make-hash-table string=?))
+(define *actions* (make-hash-table string=?))
+(define *pseudo-targets* '())
+(define *sleep-delay* 2)
+
+(define *windows-shell*
+ (memq (build-platform) '(mingw32 msvc)))
+
+
+;;; Verbosity and output
+
+(define *tty*
+ (and (##sys#tty-port? (current-output-port))
+ (not (equal? (getenv "EMACS") "t"))
+ (not (equal? (getenv "TERM") "dumb"))))
+
+(define *tty-width*
+ (or (and *tty*
+ (not *windows-shell*)
+ (with-input-from-pipe "stty size 2>/dev/null"
+ (lambda () (read) (read))))
+ 72))
+
+(define *info-message-escape* (if *tty* "\x1b[0m\x1b[2m" ""))
+(define *target-message-escape* (if *tty* "\x1b[0m\x1b[32m" ""))
+(define *error-message-escape* (if *tty* "\x1b[0m\x1b[31m" ""))
+(define *command-message-escape* (if *tty* "\x1b[0m\x1b[33m" ""))
+(define *reset-escape* (if *tty* "\x1b[0m" ""))
+
+(define (format-message msg #!optional (nl #t))
+ (if (or *verbose* (not *tty*))
+ ((if nl print print*) msg)
+ (for-each
+ (lambda (ln)
+ (printf "\r\x1b[K~a~!"
+ (if (>= (string-length ln) (sub1 *tty-width*))
+ (string-append
+ (substring ln 0 (- *tty-width* 5))
+ "...")
+ ln) ) )
+ (string-split msg "\n")) ) )
+
+(define (message fstr . args)
+ (when *verbose*
+ (format-message (sprintf "~a* ~?~a " *info-message-escape* fstr args *reset-escape*)) ) )
+
+(define (message* fstr . args)
+ (when *verbose*
+ (format-message (sprintf "~a* ~?~a " *info-message-escape* fstr args *reset-escape*) #f) ) )
+
+(define (target-message fstr . args)
+ (format-message (sprintf "~a~?~a " *target-message-escape* fstr args *reset-escape*)))
+
+(define (command-message fstr . args)
+ (when *verbose*
+ (format-message (sprintf "~a ~?~a " *command-message-escape* fstr args *reset-escape*))) )
+
+(define (error-message fstr . args)
+ (sprintf "~%~a~?~a~%" *error-message-escape* fstr args *reset-escape*))
+
+(define (quit fstr . args)
+ (display (apply error-message fstr args) (current-error-port))
+ (reset) )
+
+(define (cleanup-output)
+ (when (and (not *verbose*) *tty*)
+ (printf "\r\x1b[0m\x1b[K~!") ) )
+
+
+;;; make-code stolen from PLT
+
+(define (find-matching-line str spec)
+ (let ([match? (lambda (s) (string=? s str))])
+ (let loop ([lines spec])
+ (cond
+ [(null? lines) #f]
+ [else (let* ([line (car lines)]
+ [names (if (string? (car line))
+ (list (car line))
+ (car line))])
+ (if (any match? names)
+ line
+ (loop (cdr lines))))]))))
+
+(define (form-error s p) (quit "~a: ~s" s p))
+(define (line-error s p n) (quit "~a: ~s in line ~a" s p))
+
+(define (check-spec spec)
+ (and (or (list? spec) (form-error "specification is not a list" spec))
+ (or (pair? spec) (form-error "specification is an empty list" spec))
+ (every
+ (lambda (line)
+ (and (or (and (list? line) (<= 2 (length line) 3))
+ (form-error "list is not a list with 2 or 3 parts" line))
+ (or (or (string? (car line))
+ (and (list? (car line))
+ (every string? (car line))))
+ (form-error "line does not start with a string or list of strings" line))
+ (let ([name (car line)])
+ (or (list? (cadr line))
+ (line-error "second part of line is not a list" (cadr line) name)
+ (every (lambda (dep)
+ (or (string? dep)
+ (form-error "dependency item is not a string" dep)))
+ (cadr line)))
+ (or (null? (cddr line))
+ (procedure? (caddr line))
+ (line-error "command part of line is not a thunk" (caddr line) name)))))
+ spec)))
+
+(define (check-argv argv)
+ (or (string? argv)
+ (and (vector? argv)
+ (every string? (vector->list argv)))
+ (error "argument is not a string or string vector" argv)))
+
+(define (make/proc/helper spec argv)
+ (check-spec spec)
+ (check-argv argv)
+ (letrec ([made '()]
+ [exn? (condition-predicate 'exn)]
+ [exn-message (condition-property-accessor 'exn 'message)]
+ [make-file
+ (lambda (s indent)
+ (let ([line (find-matching-line s spec)]
+ [date (and (not (member s *pseudo-targets*))
+ (file-exists? s)
+ (file-modification-time s))])
+ (if line
+ (let ([deps (cadr line)])
+ (for-each (let ([new-indent (string-append " " indent)])
+ (lambda (d) (make-file d new-indent)))
+ deps)
+ (let ([reason
+ (or (not date)
+ (any (lambda (dep)
+ (unless (file-exists? dep)
+ (quit "dependancy ~a was not made~%" dep))
+ (and (> (file-modification-time dep) date)
+ dep))
+ deps))])
+ (when reason
+ (let ([l (cddr line)])
+ (unless (null? l)
+ (set! made (cons s made))
+ ((car l)))))))
+ (when (not date)
+ (quit "don't know how to make ~a" s)))))])
+ (cond
+ [(string? argv) (make-file argv "")]
+ [(equal? argv '#()) (make-file (caar spec) "")]
+ [else (for-each (lambda (f) (make-file f "")) (vector->list argv))]) ) )
+
+(define make/proc
+ (case-lambda
+ [(spec) (make/proc/helper spec '#())]
+ [(spec argv) (make/proc/helper spec argv)]))
+
+
+;;; Run subcommands
+
+(define (execute exps)
+ (for-each
+ (lambda (exp)
+ (let ((cmd (string-intersperse (map ->string (flatten exps)))))
+ (command-message "~A" cmd)
+ (let ((s (system cmd)))
+ (unless (zero? s)
+ (quit (sprintf "invocation of command failed with non-zero exit-status ~a: ~a~%" s cmd) s) ) ) ) )
+ exps) )
+
+(define-syntax run
+ (syntax-rules ()
+ ((_ exp ...)
+ (execute (list `exp ...)))))
+
+
+;;; String and path helper functions
+
+(define (prefix dir . files)
+ (if (null? files)
+ (pathname-directory dir)
+ (let ((files2 (map (cut make-pathname dir <>) (normalize files))))
+ (if (or (pair? (cdr files)) (pair? (car files)))
+ files2
+ (car files2) ) ) ) )
+
+(define (suffix suf . files)
+ (if (null? files)
+ (pathname-extension suf)
+ (let ((files2 (map (cut pathname-replace-extension <> suf) (normalize files))))
+ (if (or (pair? (cdr files)) (pair? (car files)))
+ files2
+ (car files2) ) ) ) )
+
+(define (normalize fs)
+ (delete-duplicates
+ (map ->string
+ (if (pair? fs)
+ (flatten fs)
+ (list fs) ) )
+ equal?) )
+
+(define path make-pathname)
+
+
+;;; "Stateful" build interface
+
+(define (build-clear)
+ (set! *dependencies* (make-hash-table string=?))
+ (set! *actions* (make-hash-table string=?))
+ (set! *variables* (make-hash-table string=?)) )
+
+(define (depends target . deps)
+ (let ((deps (normalize deps)))
+ (hash-table-update!
+ *dependencies* target
+ (lambda (old) (lset-union string=? old deps))
+ (lambda () deps) ) ) )
+
+(define actions
+ (let ((doaction
+ (lambda (name target proc)
+ (hash-table-update! *dependencies* target identity (constantly '()))
+ (hash-table-set!
+ *actions* target
+ (lambda ()
+ (target-message "~a\t~a" name target)
+ (proc) ) ) ) ) )
+ (case-lambda
+ ((target proc) (doaction "build " target proc))
+ ((name target proc) (doaction name target proc)) ) ) )
+
+(define (notfile . targets)
+ (set! *pseudo-targets* (lset-union string=? *pseudo-targets* targets)))
+
+(define (clean-on-error t thunk)
+ (handle-exceptions ex
+ (begin
+ (when (file-exists? t)
+ (message "deleting ~a" t)
+ (delete-file t) )
+ (abort ex) )
+ (thunk) ) )
+
+(define (build #!optional
+ (targets "all")
+ #!key
+ continuous
+ (verbose *verbose*) )
+ (fluid-let ((*verbose* verbose))
+ (let* ((deps (hash-table->alist *dependencies*))
+ (wdeps (delete-duplicates (append-map cdr deps) string=?))
+ (targets (list->vector (normalize targets)) )
+ (ftable (and continuous (make-hash-table string=?))))
+ (when continuous
+ (for-each
+ (lambda (dep)
+ (when (file-exists? dep)
+ (hash-table-set! ftable dep (file-modification-time dep))))
+ wdeps))
+ (let loop ()
+ (make/proc
+ (map (lambda (dep)
+ (let ((target (car dep))
+ (deps (cdr dep)))
+ (list target deps
+ (eval
+ `(lambda ()
+ (clean-on-error
+ ',target
+ (lambda ()
+ ((hash-table-ref/default *actions* ',target noop)))))))))
+ deps)
+ targets)
+ (when continuous
+ (watch-dependencies wdeps ftable)
+ (loop)))
+ (cleanup-output))))
+
+(define (build-dump #!optional (port (current-output-port)))
+ (with-output-to-port port
+ (lambda ()
+ (message "dependencies:")
+ (for-each show-dependencies (hash-table-keys *dependencies*))
+ (when (positive? (hash-table-size *variables*))
+ (message "variables:")
+ (hash-table-walk
+ *variables*
+ (lambda (v x)
+ (message " ~s:" v)
+ (for-each
+ (lambda (p)
+ (message " ~a\t-> ~s~%" (car p) (cadr p)))
+ x))) ) ) ) )
+
+(define (show-dependencies target)
+ (let ((i ""))
+ (let loop ((t target))
+ (message "~a~a ~a" i t (if (member t *pseudo-targets*) "(p)" ""))
+ (fluid-let ((i (string-append i " ")))
+ (for-each loop (hash-table-ref/default *dependencies* t '())) ) ) ) )
+
+
+;;; Command line processing
+
+(define (build* . args)
+ (let ((continuous #f)
+ (targets '())
+ (debug #f) )
+ (let-values (((procs arglists) (partition procedure? args)))
+ (let loop ((args (if (null? arglists)
+ (command-line-arguments)
+ (concatenate arglists))) )
+ (cond ((null? args)
+ (when debug (build-dump))
+ (for-each (lambda (p) (p)) procs)
+ (build
+ (if (null? targets) "all" (reverse targets))
+ verbose: *verbose*
+ continuous: continuous) )
+ (else
+ (let ((x (car args)))
+ (cond ((and (> (string-length x) 0) (char=? #\- (string-ref x 0)))
+ (cond ((string=? "-v" x)
+ (set! *verbose* #t) )
+ ((member x '("-h" "-help" "--help"))
+ (usage 0) )
+ ((string=? "-c" x)
+ (set! continuous #t) )
+ ((string=? "-d" x)
+ (set! debug #t) )
+ (else (usage 1)) )
+ (loop (cdr args)) )
+ ((string-match "([-_A-Za-z0-9]+)=(.*)" x) =>
+ (lambda (m)
+ (let* ((sym (string->symbol (cadr m))))
+ (if (##sys#symbol-has-toplevel-binding? sym)
+ (let ((val (##sys#slot sym 0)))
+ (if (or (boolean? val) (string? val) (symbol? val) (eq? (void) val))
+ (##sys#setslot sym 0 (caddr m))
+ (quit "variable `~a' already has a suspicious value" sym) ) )
+ (##sys#setslot sym 0 (caddr m)) )
+ (loop (cdr args)) ) ) )
+ (else
+ (set! targets (cons x targets))
+ (loop (cdr args))))))))) ) )
+
+(define (usage code)
+ (print "usage: " (car (argv)) " [ -v | -c | -d | TARGET | VARIABLE=VALUE ] ...")
+ (exit code) )
+
+
+;;; Check dependencies for changes
+
+(define (watch-dependencies deps tab)
+ (let loop ((f #f))
+ (sleep *sleep-delay*)
+ (cond ((any (lambda (dep)
+ (and-let* (((file-exists? dep))
+ (ft (file-modification-time dep))
+ ((> ft (hash-table-ref/default tab dep 0))))
+ (hash-table-set! tab dep ft)
+ (message "~a changed" dep)
+ #t) )
+ deps))
+ (f (loop #t))
+ (else
+ (message "waiting for changes ...")
+ (loop #t)))))
+
+
+;;; Other useful procedures
+
+(define -e file-exists?)
+(define -d (conjoin file-exists? directory?))
+(define -x (conjoin file-exists? file-execute-access?))
+
+(define cwd current-directory)
+(define (cd #!optional d) (if d (current-directory d) (getenv "HOME")))
+
+(define (with-cwd dir thunk)
+ (if (or (not dir) (equal? "." dir))
+ (thunk)
+ (let ((old #f))
+ (dynamic-wind
+ (lambda () (set! old (current-directory)))
+ (lambda ()
+ (command-message "cd ~a" dir)
+ (change-directory dir)
+ (thunk) )
+ (lambda ()
+ (change-directory old)
+ (command-message "cd ~a" old) ) ) ) ) )
+
+(define (try-run code #!optional (msg "trying to compile and run some C code") (flags "") (cc "cc"))
+ (let ((tmp (create-temporary-file "c")))
+ (with-output-to-file tmp (lambda () (display code)))
+ (message* "~a ..." msg)
+ (let ((r (zero? (system (sprintf "~a ~a ~a 2>/dev/null && ./a.out" cc tmp flags)))))
+ (delete-file* tmp)
+ (message (if r "ok" "failed"))
+ r) ) )
+
+(define (true? x)
+ (and x (not (member x '("no" "false" "off" "0" "")))))
+
+(define (simple-args #!optional (args (command-line-arguments)) (error error))
+ (define (assign var val)
+ (##sys#setslot
+ (string->symbol (string-append "*" var "*"))
+ 0
+ (if (string? val)
+ (or (string->number val) val)
+ val)))
+ (let loop ((args args) (vals '()))
+ (cond ((null? args) (reverse vals))
+ ((string-match "(-{1,2})([-_A-Za-z0-9]+)(=)?\\s*(.+)?" (car args))
+ =>
+ (lambda (m)
+ (let*-values (((next) (cdr args))
+ ((var val)
+ (cond ((equal? "=" (fourth m))
+ (let ((opt (third m))
+ (val (fifth m)))
+ (cond (val (values opt val))
+ (else
+ (when (null? next)
+ (error "missing argument for option" (car args)) )
+ (let ((x (car next)))
+ (set! next (cdr next))
+ (values opt x))))) )
+ ((string? (second m)) (values (third m) #t))
+ (else (values #f #f)) ) ) )
+ (cond (var
+ (assign var val)
+ (loop next vals) )
+ (else (loop next (cons (car args) vals)))))))
+ (else (loop (cdr args) (cons (car args) vals))))))
+
+(define (yes-or-no? str . default)
+ (let ((def (optional default #f)))
+ (let loop ()
+ (printf "~%~A (yes/no) " str)
+ (when def (printf "[~A] " def))
+ (flush-output)
+ (let ((ln (read-line)))
+ (cond ((eof-object? ln) (set! ln "abort"))
+ ((and def (string=? "" ln)) (set! ln def)) )
+ (cond ((string-ci=? "yes" ln) #t)
+ ((string-ci=? "no" ln) #f)
+ (else
+ (printf "~%Please enter \"yes\" or \"no\".~%")
+ (loop) ) ) ) ) ) )
diff --git a/scripts/wiki2html.scm b/scripts/wiki2html.scm
new file mode 100644
index 00000000..d521cbf3
--- /dev/null
+++ b/scripts/wiki2html.scm
@@ -0,0 +1,296 @@
+;;;; wiki2html.scm - quick-and-dirty svnwiki->HTML conversion
+
+
+(load-relative "tools.scm")
+
+(use regex srfi-1 extras utils srfi-13 posix)
+(use htmlprag matchable)
+
+
+;;; inline elements
+
+(define +code+ '(: #\{ #\{ (submatch (*? any)) #\} #\}))
+(define +bold+ '(: (= 3 #\') (submatch (* (~ #\'))) (= 3 #\')))
+(define +italic+ '(: (= 2 #\') (submatch (* (~ #\'))) (= 2 #\')))
+(define +html-tag+ '(: #\< (submatch (* (~ #\>))) #\>))
+(define +enscript-tag+ '(: "<enscript" (* (~ #\>)) #\>))
+
+(define +link+
+ '(: #\[ #\[ (submatch (* (~ #\] #\|))) (? #\| (submatch (* (~ #\])))) #\] #\]))
+
+(define +image-link+
+ '(: #\[ #\[ (* space) "image:" (* space)
+ (submatch (* (~ #\] #\|))) (? #\| (submatch (* (~ #\])))) #\] #\]))
+
+(define +inline-element+
+ `(or ,+code+ ,+image-link+ ,+link+ ,+html-tag+ ,+bold+ ,+italic+))
+
+(define +http-url+ '(: (* space) "http://" (* any)))
+(define +end-enscript-tag+ '(: "</enscript>"))
+
+
+;;; Block elements
+
+(define +header+ '(: (submatch (>= 2 #\=)) (* space) (submatch (* any))))
+(define +pre+ '(: (>= 1 space) (submatch (* any))))
+
+(define +d-list+
+ '(: (* space) #\; (submatch (*? any)) #\space #\: #\space (submatch (* any))))
+
+(define +d-head+ '(: (* space) #\; (submatch (* any))))
+(define +u-list+ '(: (* space) (submatch (>= 1 #\*)) (* space) (submatch (* any))))
+(define +o-list+ '(: (* space) (submatch (>= 1 #\*)) #\# (* space) (submatch (* any))))
+(define +hr+ '(: (* space) (submatch (>= 3 #\-)) (* space)))
+
+(define +block-element+
+ `(or ,+pre+
+ ,+header+
+ ,+d-list+
+ ,+d-head+
+ ,+u-list+
+ ,+o-list+
+ ,+enscript-tag+
+ ,+hr+))
+
+
+;;; Global state
+
+(define *tags* '())
+(define *open* '())
+(define *manual-pages* '())
+(define *list-continuation* #f)
+
+(define (push-tag tag out)
+ ;(fprintf (current-error-port) "start: tag: ~a, open: ~a~%" tag *open*)
+ (unless (and (pair? *open*) (equal? tag (car *open*)))
+ (when (pair? *open*)
+ (cond ((not (pair? tag)) (pop-tag out))
+ ((pair? (car *open*))
+ ;(fprintf (current-error-port) "tag: ~a, open: ~a~%" tag *open*)
+ (when (< (cdr tag) (cdar *open*))
+ (do ((n (cdar *open*) (sub1 n)))
+ ((= (cdr tag) n))
+ (pop-tag out))))))
+ (unless (and (pair? *open*) (equal? tag (car *open*)))
+ (fprintf out "<~a>~%" (if (pair? tag) (car tag) tag))
+ (set! *list-continuation* #f)
+ ;(fprintf (current-error-port) "PUSH: ~a~%" tag)
+ (set! *open* (cons tag *open*)))))
+
+(define (pop-tag out)
+ (let ((tag (car *open*)))
+ ;(fprintf (current-error-port) "POP: ~a~%" *open*)
+ (fprintf out "</~a>~%" (if (pair? tag) (car tag) tag))
+ (set! *open* (cdr *open*))))
+
+(define (pop-all out)
+ (when (pair? *open*)
+ (pop-tag out)
+ (pop-all out)))
+
+
+;;; Helper syntax
+
+(define-syntax rx
+ (syntax-rules ()
+ ((_ rx) (force (delay (regexp rx))))))
+
+
+;;; Conversion entry point
+
+(define (wiki->html #!optional (in (current-input-port)) (out (current-output-port)))
+ (call/cc
+ (lambda (return)
+ (let loop ()
+ (let ((ln (read-line in)))
+ (cond ((eof-object? ln) (return #f))
+ ((not (string-match (rx +block-element+) ln))
+ (cond ((string-null? ln)
+ (display "<br />\n" out)
+ (set! *list-continuation* #f))
+ (else
+ (pop-all out)
+ (fprintf out "~a~%" (inline ln)))))
+ ((string-match (rx +enscript-tag+) ln) =>
+ (lambda (m)
+ (pop-all out)
+ (fprintf out "<pre>~a~%" (substring ln (string-length (car m))))
+ (copy-until-match (rx +end-enscript-tag+) in out) ;XXX doesn't parse rest of line
+ (display "</pre>" out)))
+ ((string-match (rx +header+) ln) =>
+ (lambda (m)
+ (pop-all out)
+ (let ((n (sub1 (string-length (second m))))
+ (name (inline (third m))))
+ (fprintf out "<a name='~a' /><h~a>~a</h~a>~%"
+ name n name n))))
+ ((string-match (rx +pre+) ln) =>
+ (lambda (m)
+ (cond (*list-continuation*
+ (fprintf out "~a~%" (inline (second m))))
+ (else
+ (push-tag 'pre out)
+ (fprintf out "~a~%" (clean (car m)))))))
+ ((string-match (rx +hr+) ln) =>
+ (lambda (m)
+ (fprintf out "<hr />~%")))
+ ((string-match (rx +d-list+) ln) =>
+ (lambda (m)
+ (push-tag 'dl out)
+ (set! *list-continuation* #t)
+ (fprintf out "<dt>~a</dt><dd>~a</dd>~%"
+ (inline (second m)) (inline (or (third m) "")))))
+ ((string-match (rx +d-head+) ln) =>
+ (lambda (m)
+ (push-tag 'dl out)
+ (set! *list-continuation* #t)
+ (fprintf out "<dt>~a</dt>~%" (inline (second m)))))
+ ((string-match (rx +u-list+) ln) =>
+ (lambda (m)
+ (push-tag `(ul . ,(string-length (second m))) out)
+ (set! *list-continuation* #t)
+ (fprintf out "<li>~a~%" (inline (third m)))))
+ ((string-match (rx +o-list+) ln) =>
+ (lambda (m)
+ (push-tag `(ol . ,(string-length (second m))) out)
+ (set! *list-continuation* #t)
+ (fprintf out "<li>~a~%" (inline (third m)))))
+ (else (error "unknown block match" m))´)
+ (loop))))))
+
+
+;;; Substitute inline elements
+
+(define (inline str)
+ (or (and-let* ((m (string-search-positions (rx +inline-element+) str)))
+ (string-append
+ (clean (substring str 0 (caar m)))
+ (let ((rest (substring str (caar m))))
+ (define (continue m)
+ (inline (substring rest (string-length (first m)))))
+ (cond ((string-search (rx `(: bos ,+code+)) rest) =>
+ (lambda (m)
+ (string-append
+ "<tt>" (clean (second m)) "</tt>"
+ (continue m))))
+ ((string-search (rx `(: bos ,+html-tag+)) rest) =>
+ (lambda (m)
+ (string-append
+ (first m)
+ (continue m))))
+ ((string-search (rx `(: bos ,+image-link+)) rest) =>
+ (lambda (m)
+ (string-append
+ "<img src='" (clean (second m)) "' />"
+ (continue m))))
+ ((string-search (rx `(: bos ,+link+)) rest) =>
+ (lambda (m)
+ (let ((m1 (string-trim-both (second m))))
+ (string-append
+ (cond ((or (string=? "toc:" m1)
+ (string-search (rx '(: bos (* space) "tags:")) m1) )
+ "")
+ ((find (cut string-ci=? <> m1) *manual-pages*)
+ (string-append
+ "<a href='" (clean m1) ".html'>" (inline m1) "</a>"))
+ (else
+ (string-append
+ "<a href='"
+ (clean
+ (let ((href (second m)))
+ (if (string-match (rx +http-url+) href)
+ href
+ (string-append "http://chicken.wiki.br/" href))))
+ "'>"
+ (clean (or (third m) (second m)))
+ "</a>")))
+ (continue m)))))
+ ((string-search (rx `(: bos ,+bold+)) rest) =>
+ (lambda (m)
+ (string-append
+ "<b>" (inline (second m)) "</b>"
+ (continue m))))
+ ((string-search (rx `(: bos ,+italic+)) rest) =>
+ (lambda (m)
+ (string-append
+ "<i>" (inline (second m)) "</i>"
+ (continue m))))
+ (else (error "unknown inline match" m rest))))))
+ str))
+
+(define (convert name)
+ (let ((sxml (html->sxml (open-input-string (with-output-to-string wiki->html)))))
+ (define (walk n)
+ (match n
+ (('*PI* . _) "")
+ (('enscript strs ...)
+ `(pre ,@(match strs
+ ((('@ . _) . strs) strs)
+ (_ strs))))
+ (('procedure strs ...)
+ `(pre "\n [procedure] " ,@strs))
+ (('scheme strs ...)
+ `(pre "\n" ,@strs))
+ (('nowiki content ...)
+ `(div ,content))
+ (((? symbol? tag) ('@ attr ...) . body)
+ `(,tag (@ ,@attr) ,@(map walk body)))
+ (((? symbol? tag) . body)
+ `(,tag ,@(map walk body)))
+ (_ n)))
+ (display
+ (shtml->html
+ (let ((sxml (wrap name (walk `(body ,@(cdr sxml))))))
+ ;(pp sxml (current-error-port))
+ sxml)))))
+
+(define (wrap name body)
+ `(html (head (title ,(string-append "The CHICKEN User's Manual - " name))
+ (style (@ (type "text/css"))
+ "@import url('manual.css');\n"))
+ ,body))
+
+
+;;; Normalize text
+
+(define (clean str)
+ (string-translate* str '(("<" . "<") ("&" . "&") ("'" . "'") ("\"" . """))))
+
+
+;;; Read until rx matches
+
+(define (copy-until-match rx in out)
+ (let loop ()
+ (let ((ln (read-line in)))
+ (cond ((string-match rx ln) =>
+ (lambda (m)
+ (substring ln (string-length (car m))) ) )
+ (else
+ (display (clean ln) out)
+ (newline out)
+ (loop))))))
+
+
+;;; Run it
+
+(define *outdir* ".")
+
+(define (main args)
+ (let loop ((args args))
+ (match args
+ (()
+ (print "usage: wiki2html [--outdir=DIRECTORY] PAGEFILE ...")
+ (exit 1))
+ ((files ...)
+ (let ((dirs (delete-duplicates (map pathname-directory files) string=?)))
+ (set! *manual-pages* (map pathname-strip-directory (append-map directory dirs)))
+ (for-each
+ (lambda (file)
+ (print file)
+ (with-input-from-file file
+ (lambda ()
+ (with-output-to-file (pathname-replace-directory (string-append file ".html") *outdir*)
+ (cut convert (pathname-file file))))))
+ files))))))
+
+(main (simple-args))
diff --git a/scripts/xhere b/scripts/xhere
new file mode 100755
index 00000000..761efe26
--- /dev/null
+++ b/scripts/xhere
@@ -0,0 +1,5 @@
+#!/bin/sh
+prg=$1
+here="`pwd`"
+shift
+LD_LIBRARY_PATH=$here DYLD_LIBRARY_PATH=$here PATH=.:$PATH exec ./$prg "$@"
diff --git a/scrutinizer.scm b/scrutinizer.scm
new file mode 100644
index 00000000..f611e3fa
--- /dev/null
+++ b/scrutinizer.scm
@@ -0,0 +1,628 @@
+;;;; scrutinizer.scm - The CHICKEN Scheme compiler (local flow analysis)
+;
+; Copyright (c) 2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare (unit scrutinizer))
+
+
+(include "compiler-namespace")
+(include "tweaks")
+
+
+(define (d fstr . args)
+ (when (##sys#fudge 13)
+ (printf "[debug] ~?~%" fstr args)) )
+
+(define-syntax d (syntax-rules () ((_ . _) (void))))
+
+
+;;; Walk node tree, keeping type and binding information
+;
+; result specifiers:
+;
+; SPEC = * | (VAL1 ...)
+; VAL = (or VAL1 ...)
+; | (struct NAME)
+; | (procedure (VAL1 ... [#!optional VALOPT1 ...] [#!rest [VAL | values]]) . RESULTS)
+; | BASIC
+; | deprecated
+; BASIC = * | string | symbol | char | number | boolean | list | pair |
+; procedure | vector | null | eof | undefined | port |
+; blob | noreturn | pointer | locative | fixnum | float
+; RESULTS = *
+; | (VAL1 ...)
+
+; global symbol properties:
+;
+; ##core#type -> <typespec>
+; ##core#declared-type -> <bool>
+
+(define-constant +fragment-max-length+ 5)
+(define-constant +fragment-max-depth+ 3)
+
+(define (scrutinize node db)
+ (define (constant-result lit)
+ (cond ((string? lit) 'string)
+ ((symbol? lit) 'symbol)
+ ((fixnum? lit) 'fixnum)
+ ((flonum? lit) 'float)
+ ((number? lit) 'number) ; in case...
+ ((boolean? lit) 'boolean)
+ ((list? lit) 'list)
+ ((pair? lit) 'pair)
+ ((eof-object? lit) 'eof)
+ ((vector? lit) 'vector)
+ ((and (not (##sys#immediate? lit)) ##sys#generic-structure? lit)
+ `(struct ,(##sys#slot lit 0)))
+ ((null? lit) 'null)
+ ((char? lit) 'char)
+ (else '*)))
+ (define (global-result id loc)
+ (cond ((##sys#get id '##core#type) =>
+ (lambda (a)
+ (cond #;((and (get db id 'assigned) ; remove assigned global from type db
+ (not (##sys#get id '##core#declared-type)))
+ (##sys#put! id '##core#type #f)
+ '*)
+ ((eq? a 'deprecated)
+ (report
+ loc
+ (sprintf "use of deprecated toplevel identifier `~a'" id) )
+ '*)
+ (else (list a)))))
+ (else '*)))
+ (define (variable-result id e loc)
+ (cond ((and (get db id 'assigned)
+ (not (##sys#get id '##core#declared-type)) )
+ '*)
+ ((assq id e) =>
+ (lambda (a)
+ (cond ((eq? 'undefined (cdr a))
+ (report
+ loc
+ (sprintf "access to variable `~a' which has an undefined value"
+ (real-name id db)))
+ '*)
+ (else (list (cdr a))))))
+ (else (global-result id loc))))
+ (define (always-true1 t)
+ (cond ((and (pair? t) (eq? 'or (car t)))
+ (every always-true1 (cdr t)))
+ ((memq t '(* boolean undefined noreturn)) #f)
+ (else #t)))
+ (define (always-true t loc x)
+ (let ((f (always-true1 t)))
+ (when f
+ (report
+ loc
+ (sprintf
+ "expected value of type boolean in conditional but were given a value of\ntype `~a' which is always true:~%~%~a"
+ t
+ (pp-fragment x))))
+ f))
+ (define (typename t)
+ (case t
+ ((*) "anything")
+ ((char) "character")
+ (else
+ (cond ((symbol? t) (symbol->string t))
+ ((pair? t)
+ (case (car t)
+ ((procedure)
+ (if (or (string? (cadr t)) (symbol? (cadr t)))
+ (->string (cadr t))
+ (sprintf "a procedure with ~a returning ~a"
+ (argument-string (cadr t))
+ (result-string (cddr t)))))
+ ((or)
+ (string-intersperse
+ (map typename (cdr t))
+ " OR "))
+ ((struct)
+ (sprintf "a structure of type ~a" (cadr t)))
+ (else (bomb "invalid type: ~a" t))))
+ (else (bomb "invalid type: ~a" t))))))
+ (define (argument-string args)
+ (let ((len (length args))
+ (m (multiples len)))
+ (if (zero? len)
+ "zero arguments"
+ (sprintf
+ "~a argument~a of type~a ~a"
+ len m m
+ (map typename args)))))
+ (define (result-string results)
+ (if (eq? '* results)
+ "an unknown number of values"
+ (let ((len (length results))
+ (m (multiples len)))
+ (if (zero? len)
+ "zero values"
+ (sprintf
+ "~a value~a of type~a ~a"
+ len m m
+ (map typename results))))))
+ (define (simplify t)
+ (let ((t2 (simplify1 t)))
+ (d "simplify: ~a -> ~a" t t2)
+ t2))
+ (define (simplify1 t)
+ (call/cc
+ (lambda (return)
+ (if (pair? t)
+ (case (car t)
+ ((or)
+ (cond ((= 2 (length t)) (simplify (second t)))
+ ((every procedure-type? (cdr t))
+ (if (any (cut eq? 'procedure <>) (cdr t))
+ 'procedure
+ (reduce
+ (lambda (t pt)
+ (let* ((name1 (and (named? t) (cadr t)))
+ (atypes1 (if name1 (third t) (second t)))
+ (rtypes1 (if name1 (cdddr t) (cddr t)))
+ (name2 (and (named? pt) (cadr pt)))
+ (atypes2 (if name2 (third pt) (second pt)))
+ (rtypes2 (if name2 (cdddr pt) (cddr pt))))
+ (append
+ '(procedure)
+ (if (and name1 name2 (eq? name1 name2)) (list name1) '())
+ (list (merge-argument-types atypes1 atypes2))
+ (merge-result-types rtypes1 rtypes2))))
+ #f
+ (cdr t))))
+ (else
+ (let* ((ts (append-map
+ (lambda (t)
+ (let ((t (simplify t)))
+ (cond ((and (pair? t) (eq? 'or (car t)))
+ (cdr t))
+ ;((eq? t 'noreturn) '())
+ ((eq? t 'undefined) (return 'undefined))
+ (else (list t)))))
+ (cdr t)))
+ (ts2 (let loop ((ts ts) (done '()))
+ (cond ((null? ts) (reverse done))
+ ((eq? '* (car ts)) (return '*))
+ ((any (cut type<=? (car ts) <>) (cdr ts))
+ (loop (cdr ts) done))
+ ((any (cut type<=? (car ts) <>) done)
+ (loop (cdr ts) done))
+ (else (loop (cdr ts) (cons (car ts) done)))))))
+ (cond ((equal? ts2 (cdr t)) t)
+ (else
+ (d " or-simplify: ~a" ts2)
+ (simplify `(or ,@(if (any (cut eq? <> '*) ts2) '(*) ts2)))))))) )
+ ((procedure)
+ (let* ((name (and (named? t) (cadr t)))
+ (rtypes (if name (cdddr t) (cddr t))))
+ (append
+ '(procedure)
+ (if name (list name) '())
+ (list (map simplify (if name (third t) (second t))))
+ (if (eq? '* rtypes)
+ '*
+ (map simplify rtypes)))))
+ (else t))
+ t))))
+ (define (named? t)
+ (and (pair? t)
+ (eq? 'procedure (car t))
+ (not (or (null? (cadr t)) (pair? (cadr t))))))
+ (define (rest-type r)
+ (cond ((null? r) '*)
+ ((eq? 'values (car r)) '*)
+ (else (car r))))
+ (define (merge-argument-types ts1 ts2)
+ (cond ((null? ts1)
+ (cond ((null? ts2) '())
+ ((memq (car ts2) '(#!rest #!optional)) ts2)
+ (else '(#!rest))))
+ ((eq? '#!rest (car ts1))
+ (cond ((and (pair? ts2) (eq? '#!rest (car ts2)))
+ `(#!rest
+ ,(simplify
+ `(or ,(rest-type (cdr ts1))
+ ,(rest-type (cdr ts2))))))
+ (else '(#!rest)))) ;XXX giving up
+ ((eq? '#!optional (car ts1))
+ (cond ((and (pair? ts2) (eq? '#!optional (car ts2)))
+ `(#!optional
+ ,(simplify `(or ,(cadr ts1) ,(cadr ts2)))
+ ,@(merge-argument-types (cddr ts1) (cddr ts2))))
+ (else '(#!rest)))) ;XXX
+ (else (cons (simplify `(or ,(car ts1) ,(car ts2)))
+ (merge-argument-types (cdr ts1) (cdr ts2))))))
+ (define (merge-result-types ts1 ts2) ;XXX possibly overly conservative
+ (cond ((null? ts1) ts2)
+ ((null? ts2) ts1)
+ ((or (atom? ts1) (atom? ts2)) '*)
+ (else (cons (simplify `(or ,(car ts1) ,(car ts2)))
+ (merge-result-types (cdr ts1) (cdr ts2))))))
+ (define (match t1 t2)
+ (let ((m (match1 t1 t2)))
+ (d "match ~a <-> ~a -> ~a" t1 t2 m)
+ m))
+ (define (match1 t1 t2)
+ (cond ((eq? t1 t2))
+ ((eq? t1 '*))
+ ((eq? t2 '*))
+ ((eq? t1 'noreturn))
+ ((eq? t2 'noreturn))
+ ((and (eq? t1 'number) (memq t2 '(number fixnum float))))
+ ((and (eq? t2 'number) (memq t1 '(number fixnum float))))
+ ((eq? 'procedure t1) (and (pair? t2) (eq? 'procedure (car t2))))
+ ((eq? 'procedure t2) (and (pair? t1) (eq? 'procedure (car t1))))
+ ((and (pair? t1) (eq? 'or (car t1))) (any (cut match <> t2) (cdr t1)))
+ ((and (pair? t2) (eq? 'or (car t2))) (any (cut match t1 <>) (cdr t2)))
+ ((memq t1 '(pair list)) (memq t2 '(pair list)))
+ ((memq t1 '(null list)) (memq t2 '(null list)))
+ ((and (pair? t1) (pair? t2) (eq? (car t1) (car t2)))
+ (case (car t1)
+ ((procedure)
+ (let ((args1 (if (named? t1) (third t1) (second t1)))
+ (args2 (if (named? t2) (third t2) (second t2)))
+ (results1 (if (named? t1) (cdddr t1) (cddr t1)))
+ (results2 (if (named? t2) (cdddr t2) (cddr t2))) )
+ (and (match-args args1 args2)
+ (match-results results1 results2))))
+ ((struct) (equal? t1 t2))
+ (else #f) ) )
+ (else #f)))
+ (define (match-args args1 args2)
+ (d "match-args: ~s <-> ~s" args1 args2)
+ (define (match-rest rtype args opt) ;XXX currently ignores `opt'
+ (let-values (((head tail) (break (cut eq? '#!rest <>) args)))
+ (and (every (cut match rtype <>) head) ; match required args
+ (match rtype (if (pair? tail) (rest-type (cdr tail)) '*)))))
+ (define (optargs a)
+ (memq a '(#!rest #!optional)))
+ (let loop ((args1 args1) (args2 args2) (opt1 #f) (opt2 #f))
+ (d " args ~a ~a ~a ~a" args1 args2 opt1 opt2)
+ (cond ((null? args1)
+ (or opt2
+ (null? args2)
+ (optargs (car args2))))
+ ((null? args2)
+ (or opt1
+ (optargs (car args1))))
+ ((eq? '#!optional (car args1))
+ (loop (cdr args1) args2 #t opt2))
+ ((eq? '#!optional (car args2))
+ (loop args1 (cdr args2) opt1 #t))
+ ((eq? '#!rest (car args1))
+ (match-rest (rest-type (cdr args1)) args2 opt2))
+ ((eq? '#!rest (car args2))
+ (match-rest (rest-type (cdr args2)) args1 opt1))
+ ((match (car args1) (car args2)) (loop (cdr args1) (cdr args2) opt1 opt2))
+ (else #f))))
+ (define (match-results results1 results2)
+ (cond ((null? results1) (atom? results2))
+ ((eq? '* results1))
+ ((eq? '* results2))
+ ((null? results2) #f)
+ ((match (car results1) (car results2))
+ (match-results (cdr results1) (cdr results2)))
+ (else #f)))
+ (define (type<=? t1 t2)
+ (or (eq? t1 t2)
+ (memq t2 '(* undefined))
+ (case t2
+ ((list) (memq t1 '(null pair)))
+ ((procedure) (and (pair? t1) (eq? 'procedure (car t1))))
+ ((number) (memq t1 '(fixnum float)))
+ (else
+ (and (pair? t1) (pair? t2)
+ (case (car t1)
+ ((or) (every (cut type<=? <> t2) (cdr t1)))
+ ((procedure)
+ (let ((args1 (if (pair? (cadr t1)) (cadr t1) (caddr t1)))
+ (args2 (if (pair? (cadr t2)) (cadr t2) (caddr t2)))
+ (res1 (if (pair? (cadr t1)) (cddr t1) (cdddr t1)))
+ (res2 (if (pair? (cadr t2)) (cddr t2) (cdddr t2))) )
+ (let loop1 ((args1 args1)
+ (args2 args2)
+ (m1 0)
+ (m2 0))
+ (cond ((null? args1)
+ (and (or (null? args2) (> m2 0))
+ (let loop2 ((res1 res1) (res2 res2))
+ (cond ((eq? '* res2) #t)
+ ((null? res2) (null? res1))
+ ((eq? '* res1) #f)
+ ((type<=? (car res1) (car res2))
+ (loop2 (cdr res1) (cdr res2)))
+ (else #f)))))
+ ((null? args2) #f)
+ ((eq? (car args1) '#!optional)
+ (loop1 (cdr args1) args2 1 m2))
+ ((eq? (car args2) '#!optional)
+ (loop1 args1 (cdr args2) m1 1))
+ ((eq? (car args1) '#!rest)
+ (loop1 (cdr args1) args2 2 m2))
+ ((eq? (car args2) '#!rest)
+ (loop1 args1 (cdr args2) m1 2))
+ ((type<=? (car args1) (car args2))
+ (loop1 (cdr args1) (cdr args2) m1 m2))
+ (else #f)))))))))))
+ (define (multiples n)
+ (if (= n 1) "" "s"))
+ (define (single what tv loc)
+ (if (eq? '* tv)
+ '*
+ (let ((n (length tv)))
+ (cond ((= 1 n) (car tv))
+ ((zero? n)
+ (report
+ loc
+ (sprintf "expected ~a a single result, but were given zero results" what))
+ 'undefined)
+ (else
+ (report
+ loc
+ (sprintf "expected ~a a single result, but were given ~a result~a"
+ what n (multiples n)))
+ (first tv))))))
+ (define (report loc desc)
+ (compiler-warning
+ 'scrutiny
+ "~a~a"
+ (location-name loc) desc))
+ (define (location-name loc)
+ (define (lname loc1)
+ (if loc1
+ (sprintf "procedure `~a'" (real-name loc1))
+ "unknown procedure"))
+ (cond ((null? loc) "at toplevel:\n ")
+ ((null? (cdr loc))
+ (sprintf "in toplevel ~a:\n " (lname (car loc))))
+ (else
+ (let rec ((loc loc))
+ (if (null? (cdr loc))
+ (location-name loc)
+ (sprintf "in local ~a,\n ~a" (lname (car loc)) (rec (cdr loc))))))))
+ (define add-loc cons)
+ (define (fragment x)
+ (let ((x (build-expression-tree x)))
+ (let walk ((x x) (d 0))
+ (cond ((atom? x) x)
+ ((>= d +fragment-max-depth+) '...)
+ ((list? x)
+ (map (cute walk <> (add1 d)) (take x (min +fragment-max-length+ (length x)))))
+ (else x)))))
+ (define (pp-fragment x)
+ (string-chomp
+ (with-output-to-string
+ (lambda ()
+ (pp (fragment x))))))
+ (define (call-result args e loc x params)
+ (define (pname)
+ (sprintf
+ "in procedure call to `~s'~a"
+ (fragment x)
+ (if (and (pair? params) (pair? (cdr params)))
+ (let ((n (source-info->line (cadr params))))
+ (if (number? n)
+ (sprintf " (line ~a)" n)
+ ""))
+ "")))
+ (d "call-result: ~a (~a)" args loc)
+ (let* ((ptype (car args))
+ (nargs (length (cdr args)))
+ (xptype `(procedure ,(make-list nargs '*) *)))
+ (when (and (not (procedure-type? ptype))
+ (not (match xptype ptype)))
+ (report
+ loc
+ (sprintf
+ "expected ~a a value of type `~a', but were given a value of type `~a'"
+ (pname)
+ xptype
+ ptype)))
+ (let-values (((atypes values-rest) (procedure-argument-types ptype (length (cdr args)))))
+ (d " argument-types: ~a (~a)" atypes values-rest)
+ (unless (= (length atypes) nargs)
+ (let ((alen (length atypes)))
+ (report
+ loc
+ (sprintf
+ "expected ~a ~a argument~a, but where given ~a argument~a"
+ (pname) alen (multiples alen)
+ nargs (multiples nargs)))))
+ (do ((args (cdr args) (cdr args))
+ (atypes atypes (cdr atypes))
+ (i 1 (add1 i)))
+ ((or (null? args) (null? atypes)))
+ (unless (match (car atypes) (car args))
+ (report
+ loc
+ (sprintf
+ "expected argument #~a of type `~a' ~a, but where given an argument of type `~a'"
+ i (car atypes) (pname) (car args)))))
+ (let ((r (procedure-result-types ptype values-rest (cdr args))))
+ (d " result-types: ~a" r)
+ r))))
+ (define (procedure-type? t)
+ (or (eq? 'procedure t)
+ (and (pair? t)
+ (or (eq? 'procedure (car t))
+ (and (eq? 'or (car t))
+ (every procedure-type? (cdr t)))))))
+ (define (procedure-argument-types t n)
+ (cond ((or (memq t '(* procedure))
+ (not-pair? t) )
+ (values (make-list n '*) #f))
+ ((eq? 'procedure (car t))
+ (let* ((vf #f)
+ (llist
+ (let loop ((at (if (or (string? (second t)) (symbol? (second t)))
+ (third t)
+ (second t)))
+ (m n)
+ (opt #f))
+ (cond ((null? at) '())
+ ((eq? '#!optional (car at))
+ (loop (cdr at) m #t) )
+ ((eq? '#!rest (car at))
+ (set! vf (and (pair? (cdr at)) (eq? 'values (cadr at))))
+ (make-list m (rest-type (cdr at))))
+ ((and opt (<= m 0)) '())
+ (else (cons (car at) (loop (cdr at) (sub1 m) opt)))))))
+ (values llist vf)))
+ (else (bomb "not a procedure type" t))))
+ (define (procedure-result-types t values-rest? args)
+ (cond (values-rest? args)
+ ((or (memq t '(* procedure))
+ (not-pair? t) )
+ '*)
+ ((eq? 'procedure (car t))
+ (call/cc
+ (lambda (return)
+ (let loop ((rt (if (or (string? (second t)) (symbol? (second t)))
+ (cdddr t)
+ (cddr t))))
+ (cond ((null? rt) '())
+ ((eq? '* rt) (return '*))
+ (else (cons (car rt) (loop (cdr rt)))))))))
+ (else (bomb "not a procedure type: ~a" t))))
+ (define (noreturn-type? t)
+ (or (eq? 'noreturn t)
+ (and (pair? t)
+ (eq? 'or (car t))
+ (any noreturn-type? (cdr t)))))
+ (define (walk n e loc dest) ; returns result specifier
+ (let ((subs (node-subexpressions n))
+ (params (node-parameters n))
+ (class (node-class n)) )
+ (d "walk: ~a ~a (loc: ~a, dest: ~a)" class params loc dest)
+ (let ((results
+ (case class
+ ((quote) (list (constant-result (first params))))
+ ((##core#undefined) '(*))
+ ((##core#proc) '(procedure))
+ ((##core#global-ref) (global-result (first params) loc))
+ ((##core#variable) (variable-result (first params) e loc))
+ ((if) (let ((rt (single "in conditional" (walk (first subs) e loc dest) loc)))
+ (always-true rt loc n)
+ (let ((r1 (walk (second subs) e loc dest))
+ (r2 (walk (third subs) e loc dest)))
+ (cond ((and (not (eq? r1 '*))
+ (not (eq? '* r2)) )
+ (when (and (not (any noreturn-type? r1))
+ (not (any noreturn-type? r2))
+ (not (= (length r1) (length r2))))
+ (report
+ loc
+ (sprintf
+ "branches in conditional expression differ in the number of results:~%~%~a"
+ (pp-fragment n))))
+ (map (lambda (t1 t2) (simplify `(or ,t1 ,t2)))
+ r1 r2))
+ (else '*)))))
+ ((let)
+ (let loop ((vars params) (body subs) (e2 '()))
+ (if (null? vars)
+ (walk (car body) (append e2 e) loc dest)
+ (let ((t (single
+ (sprintf "in `let' binding of `~a'" (real-name (car vars)))
+ (walk (car body) e loc (car vars)) loc)))
+ (loop (cdr vars) (cdr body) (alist-cons (car vars) t e2))))))
+ ((##core#lambda lambda)
+ (decompose-lambda-list
+ (first params)
+ (lambda (vars argc rest)
+ (let* ((name (if dest (list dest) '()))
+ (args (append (make-list argc '*) (if rest '(#!rest) '())))
+ (e2 (append (map (lambda (v) (cons v '*))
+ (if rest (butlast vars) vars))
+ e))
+ (r (walk (first subs)
+ (if rest (alist-cons rest 'list e2) e2)
+ (add-loc dest loc)
+ #f)))
+ (list
+ (append
+ '(procedure)
+ name
+ (list args)
+ r))))))
+ ((set! ##core#set!)
+ (let* ((var (first params))
+ (type (##sys#get var '##core#type))
+ (rt (single
+ (sprintf "in assignment to `~a'" var)
+ (walk (first subs) e loc var)
+ loc))
+ (b (assq var e)) )
+ (when (and type (not b)
+ (not (eq? type 'deprecated))
+ (not (match type rt)))
+ (report
+ loc
+ (sprintf
+ "assignment of value of type `~a' to toplevel variable `~a' does not match declared type `~a'"
+ rt var type)))
+ (when (and b (eq? 'undefined (cdr b)))
+ (set-cdr! b rt))
+ '(undefined)))
+ ((##core#primitive ##core#inline_ref) '*)
+ ((##core#call)
+ (let* ((f (fragment n))
+ (args (map (lambda (n i)
+ (single
+ (sprintf
+ "in ~a of procedure call `~s'"
+ (if (zero? i)
+ "operator position"
+ (sprintf "argument #~a" i))
+ f)
+ (walk n e loc #f) loc))
+ subs (iota (length subs)))))
+ (call-result args e loc (first subs) params)))
+ ((##core#switch ##core#cond)
+ (bomb "unexpected node class: ~a" class))
+ (else
+ (for-each (lambda (n) (walk n e loc #f)) subs)
+ '*))))
+ (d " -> ~a" results)
+ results)))
+ (walk (first (node-subexpressions node)) '() '() #f))
+
+(define (load-type-database name #!optional (path (repository-path)))
+ (and-let* ((dbfile (file-exists? (make-pathname path name))))
+ (when verbose-mode
+ (printf "loading type database ~a ...~%" dbfile))
+ (for-each
+ (lambda (e)
+ (let* ((name (car e))
+ (old (##sys#get name '##core#type))
+ (new (cadr e)))
+ (when (and old (not (equal? old new)))
+ (compiler-warning
+ 'scrutiny
+ "type-definition `~a' for toplevel binding `~a' conflicts with previously loaded type `~a'"
+ name new old))
+ (##sys#put! name '##core#type new)))
+ (read-file dbfile))))
diff --git a/setup-api.scm b/setup-api.scm
new file mode 100644
index 00000000..15dd945d
--- /dev/null
+++ b/setup-api.scm
@@ -0,0 +1,792 @@
+;;;; setup-api.scm - build + installation API for eggs
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(require-library srfi-1 regex utils posix srfi-13 extras ports data-structures files)
+
+; This code is partially quite messy and the API is not overly consistent,
+; mainly because it has grown "organically" while the old chicken-setup program
+; evolved. The code was extracted and put into this module, without much
+; cleaning up. Nevertheless, it should work.
+;
+; *windows-shell* and, to a lesser extent, 'sudo' processing knowledge is
+; scattered in the code.
+
+(module setup-api
+
+ (move-file
+ (run execute)
+ compile
+ standard-extension
+ make make/proc
+ host-extension
+ install-extension install-program install-script
+ setup-verbose-mode setup-install-mode
+ setup-verbose-flag setup-install-flag ; DEPRECATED
+ installation-prefix chicken-prefix
+ find-library find-header
+ program-path remove-file*
+ patch yes-or-no? abort-setup
+ setup-root-directory create-directory/parents
+ test-compile try-compile copy-file run-verbose
+ required-chicken-version required-extension-version cross-chicken
+ sudo-install keep-intermediates
+ version>=?
+ extension-name-and-version
+ extension-name
+ extension-version
+ create-temporary-directory
+ remove-directory
+ remove-extension
+ read-info
+ shellpath)
+
+ (import scheme chicken foreign
+ regex utils posix ports extras data-structures
+ srfi-1 srfi-13 files)
+
+;;; Constants, variables and parameters
+
+(define-constant setup-file-extension "setup-info")
+
+(define *installed-executables*
+ `(("chicken" . ,(foreign-value "C_CHICKEN_PROGRAM" c-string))
+ ("csc" . ,(foreign-value "C_CSC_PROGRAM" c-string))
+ ("csi" . ,(foreign-value "C_CSI_PROGRAM" c-string))
+ ("chicken-bug" . ,(foreign-value "C_CHICKEN_BUG_PROGRAM" c-string))))
+
+(define *cc* (foreign-value "C_TARGET_CC" c-string))
+(define *cxx* (foreign-value "C_TARGET_CXX" c-string))
+(define *target-cflags* (foreign-value "C_TARGET_CFLAGS" c-string))
+(define *target-libs* (foreign-value "C_TARGET_MORE_LIBS" c-string))
+(define *target-lib-home* (foreign-value "C_TARGET_LIB_HOME" c-string))
+(define *sudo* #f)
+(define *windows-shell* (foreign-value "C_WINDOWS_SHELL" bool))
+
+(define *windows*
+ (and (eq? (software-type) 'windows)
+ (build-platform) ) )
+
+(register-feature! 'chicken-setup)
+
+(define host-extension (make-parameter #f))
+
+(define *chicken-bin-path*
+ (or (and-let* ((p (get-environment-variable "CHICKEN_PREFIX")))
+ (make-pathname p "bin") )
+ (foreign-value "C_INSTALL_BIN_HOME" c-string) ) )
+
+(define *doc-path*
+ (or (and-let* ((p (get-environment-variable "CHICKEN_PREFIX")))
+ (make-pathname p "share/chicken/doc") )
+ (make-pathname
+ (foreign-value "C_INSTALL_SHARE_HOME" c-string)
+ "doc")))
+
+(define chicken-prefix
+ (or (get-environment-variable "CHICKEN_PREFIX")
+ (let ((m (string-match "(.*)/bin/?" *chicken-bin-path*)))
+ (if m
+ (cadr m)
+ "/usr/local") ) ) )
+
+(define (shellpath str)
+ (qs (normalize-pathname str)))
+
+(define (cross-chicken) (##sys#fudge 39)) ; DEPRECATED
+
+(define *csc-options* '())
+(define *base-directory* (current-directory))
+
+(define setup-root-directory (make-parameter *base-directory*))
+(define setup-verbose-mode (make-parameter #f))
+(define setup-install-mode (make-parameter #t))
+(define setup-verbose-flag setup-verbose-mode) ; DEPRECATED
+(define setup-install-flag setup-install-mode) ; DEPRECATED
+(define program-path (make-parameter *chicken-bin-path*))
+(define keep-intermediates (make-parameter #f))
+
+; Setup shell commands
+
+(define *copy-command*)
+(define *remove-command*)
+(define *move-command*)
+(define *chmod-command*)
+(define *ranlib-command*)
+(define *mkdir-command*)
+
+(define (windows-user-install-setup)
+ (set! *copy-command* 'copy)
+ (set! *remove-command* "del /Q /S")
+ (set! *move-command* 'move)
+ (set! *chmod-command* "chmod")
+ (set! *ranlib-command* "ranlib") )
+
+(define (unix-user-install-setup)
+ (set! *copy-command* "cp -r")
+ (set! *remove-command* "rm -fr")
+ (set! *move-command* 'mv)
+ (set! *chmod-command* "chmod")
+ (set! *ranlib-command* "ranlib")
+ (set! *mkdir-command* "mkdir") )
+
+(define (windows-sudo-install-setup)
+ (set! *sudo* #f)
+ (print "Warning: cannot install as superuser with Windows") )
+
+(define (unix-sudo-install-setup)
+ (set! *copy-command* "sudo cp -r")
+ (set! *remove-command* "sudo rm -fr")
+ (set! *move-command* "sudo mv")
+ (set! *chmod-command* "sudo chmod")
+ (set! *ranlib-command* "sudo ranlib")
+ (set! *mkdir-command* "sudo mkdir") )
+
+(define (user-install-setup)
+ (set! *sudo* #f)
+ (if *windows-shell*
+ (windows-user-install-setup)
+ (unix-user-install-setup) ) )
+
+(define (sudo-install-setup)
+ (set! *sudo* #t)
+ (if *windows-shell*
+ (windows-sudo-install-setup)
+ (unix-sudo-install-setup) ) )
+
+(define (sudo-install . args)
+ (cond ((null? args) *sudo*)
+ ((car args) (sudo-install-setup))
+ (else (user-install-setup)) ) )
+
+(define abort-setup (make-parameter exit))
+
+(define (yes-or-no? str #!key default (abort (abort-setup)))
+ (let loop ()
+ (printf "~%~A (yes/no/abort) " str)
+ (when default (printf "[~A] " default))
+ (flush-output)
+ (let ((ln (read-line)))
+ (cond ((eof-object? ln) (set! ln "abort"))
+ ((and default (string=? "" ln)) (set! ln default)) )
+ (cond ((string-ci=? "yes" ln) #t)
+ ((string-ci=? "no" ln) #f)
+ ((string-ci=? "abort" ln) (abort))
+ (else
+ (printf "~%Please enter \"yes\", \"no\" or \"abort\".~%")
+ (loop) ) ) ) ) )
+
+(define (patch which rx subst)
+ (when (setup-verbose-mode) (printf "patching ~A ...~%" which))
+ (if (list? which)
+ (with-output-to-file (cadr which)
+ (lambda ()
+ (with-input-from-file (car which)
+ (lambda ()
+ (let loop ()
+ (let ((ln (read-line)))
+ (unless (eof-object? ln)
+ (write-line (string-substitute rx subst ln #t))
+ (loop) ) ) ) ) ) ) )
+ (let ((tmp (create-temporary-file)))
+ (patch (list tmp tmp) rx subst)
+ ($system
+ (sprintf "~A ~A ~A" *move-command* (shellpath tmp)
+ (shellpath which))))))
+
+(define run-verbose (make-parameter #t))
+
+(define (fixpath prg)
+ (cond ((string=? prg "csc")
+ (string-intersperse
+ (cons* (shellpath
+ (make-pathname
+ *chicken-bin-path*
+ (cdr (assoc prg *installed-executables*))))
+ "-feature" "compiling-extension" "-setup-mode"
+ (if (keep-intermediates) "-k" "")
+ (if (host-extension) "-host" "")
+ *csc-options*)
+ " ") )
+ ((assoc prg *installed-executables*) =>
+ (lambda (a) (shellpath (make-pathname *chicken-bin-path* (cdr a)))))
+ (else prg) ) )
+
+(define (fixmaketarget file)
+ (if (and (equal? "so" (pathname-extension file))
+ (not (string=? "so" ##sys#load-dynamic-extension)) )
+ (pathname-replace-extension file ##sys#load-dynamic-extension)
+ file) )
+
+(define (execute explist)
+ (define (smooth lst)
+ (let ((slst (map ->string lst)))
+ (string-intersperse (cons (fixpath (car slst)) (cdr slst)) " ") ) )
+ (for-each
+ (lambda (cmd)
+ (when (run-verbose) (printf " ~A~%~!" cmd))
+ ($system cmd))
+ (map smooth explist) ) )
+
+(define-syntax run
+ (syntax-rules ()
+ ((_ exp ...)
+ (execute (list `exp ...)))))
+
+(define-syntax compile
+ (syntax-rules ()
+ ((_ exp ...)
+ (run (csc exp ...)))))
+
+
+;;; "make" functionality
+
+(define (make:find-matching-line str spec)
+ (let ((match? (lambda (s) (string=? s str))))
+ (let loop ((lines spec))
+ (cond
+ ((null? lines) #f)
+ (else (let* ((line (car lines))
+ (names (if (string? (car line))
+ (list (car line))
+ (car line))))
+ (if (any match? names)
+ line
+ (loop (cdr lines)))))))))
+
+(define (make:form-error s p) (error (sprintf "~a: ~s" s p)))
+(define (make:line-error s p n) (error (sprintf "~a: ~s for line: ~a" s p n)))
+
+(define (make:check-spec spec)
+ (and (or (list? spec) (make:form-error "specification is not a list" spec))
+ (or (pair? spec) (make:form-error "specification is an empty list" spec))
+ (every
+ (lambda (line)
+ (and (or (and (list? line) (<= 2 (length line) 3))
+ (make:form-error "list is not a list with 2 or 3 parts" line))
+ (or (or (string? (car line))
+ (and (list? (car line))
+ (every string? (car line))))
+ (make:form-error "line does not start with a string or list of strings" line))
+ (let ((name (car line)))
+ (or (list? (cadr line))
+ (make:line-error "second part of line is not a list" (cadr line) name)
+ (every (lambda (dep)
+ (or (string? dep)
+ (make:form-error "dependency item is not a string" dep)))
+ (cadr line)))
+ (or (null? (cddr line))
+ (procedure? (caddr line))
+ (make:line-error "command part of line is not a thunk" (caddr line) name)))))
+ spec)))
+
+(define (make:check-argv argv)
+ (or (string? argv)
+ (every string? argv)
+ (error "argument is not a string or string list" argv)))
+
+(define (make:make/proc/helper spec argv)
+ (when (vector? argv) (set! argv (vector->list argv)))
+ (make:check-spec spec)
+ (make:check-argv argv)
+ (letrec ((made '())
+ (exn? (condition-predicate 'exn))
+ (exn-message (condition-property-accessor 'exn 'message))
+ (make-file
+ (lambda (s indent)
+ (let* ((line (make:find-matching-line s spec))
+ (s2 (fixmaketarget s))
+ (date (and (file-exists? s2)
+ (file-modification-time s2))))
+ (when (setup-verbose-mode)
+ (printf "make: ~achecking ~a~%" indent s2))
+ (if line
+ (let ((deps (cadr line)))
+ (for-each (let ((new-indent (string-append " " indent)))
+ (lambda (d) (make-file d new-indent)))
+ deps)
+ (let ((reason
+ (or (not date)
+ (any (lambda (dep)
+ (let ((dep2 (fixmaketarget dep)))
+ (unless (file-exists? dep2)
+ (error (sprintf "dependancy ~a was not made~%" dep2)))
+ (and (> (file-modification-time dep2) date)
+ dep2)) )
+ deps))))
+ (when reason
+ (let ((l (cddr line)))
+ (unless (null? l)
+ (set! made (cons s made))
+ (when (setup-verbose-mode)
+ (printf "make: ~amaking ~a~a~%"
+ indent
+ s2
+ (cond
+ ((not date)
+ (string-append " because " s2 " does not exist"))
+ ((string? reason)
+ (string-append " because " reason " changed"))
+ (else
+ (string-append (sprintf " just because (reason: ~a date: ~a)"
+ reason date)))) ) )
+ (handle-exceptions exn
+ (begin
+ (printf "make: Failed to make ~a: ~a~%"
+ (car line)
+ (if (exn? exn)
+ (exn-message exn)
+ exn))
+ (signal exn) )
+ ((car l))))))))
+ (unless date
+ (error (sprintf "don't know how to make ~a" s2))))))))
+ (cond
+ ((string? argv) (make-file argv ""))
+ ((null? argv) (make-file (caar spec) ""))
+ (else (for-each (lambda (f) (make-file f "")) argv)))
+ (when (setup-verbose-mode)
+ (for-each (lambda (item)
+ (printf "make: made ~a~%" item))
+ (reverse made)))) )
+
+(define make/proc
+ (case-lambda
+ ((spec) (make:make/proc/helper spec '()))
+ ((spec argv)
+ (make:make/proc/helper
+ spec
+ (if (vector? argv)
+ (vector->list argv)
+ argv) ) ) ) )
+
+(define-syntax make
+ (lambda (form r c)
+ (##sys#check-syntax 'make form '(_ _ . #(_ 0 1)))
+ (let ((spec (cadr form))
+ (%list (r 'list))
+ (%lambda (r 'lambda)))
+ (let ((form-error (lambda (s . p) (apply error s spec p))))
+ (and (or (list? spec) (form-error "illegal specification (not a sequence)"))
+ (or (pair? spec) (form-error "empty specification"))
+ (every
+ (lambda (line)
+ (and (or (and (list? line) (>= (length line) 2))
+ (form-error "clause does not have at least 2 parts" line))
+ (let ((name (car line)))
+ (or (list? (cadr line))
+ (make:line-error "second part of clause is not a sequence" (cadr line) name)))))
+ spec))
+ `(,(r 'make/proc)
+ (list ,@(map (lambda (line)
+ `(,%list ,(car line)
+ (,%list ,@(cadr line))
+ ,@(let ((l (cddr line)))
+ (if (null? l)
+ '()
+ `((,%lambda () ,@l))))))
+ spec))
+ ,@(if (null? (cddr form))
+ '('())
+ (cddr form)))))))
+
+
+;;; Processing setup scripts
+
+(define (make-setup-info-pathname fn #!optional (rpath (repository-path)))
+ (make-pathname rpath fn setup-file-extension) )
+
+(define installation-prefix
+ (make-parameter (or (get-environment-variable "CHICKEN_INSTALL_PREFIX") #f)))
+
+(define create-directory/parents
+ (let ()
+ (define (verb dir)
+ (when (setup-verbose-mode) (printf " creating directory `~a'~%~!" dir)) )
+ (if *windows*
+ (lambda (dir)
+ (verb dir)
+ (create-directory dir #t) )
+ (lambda (dir)
+ (verb dir)
+ (run (,*mkdir-command* -p ,(shellpath dir)) ) ) ) ) )
+
+(define (write-info id files info)
+ (let ((info `((files ,@files)
+ ,@info)) )
+ (when (setup-verbose-mode) (printf "writing info ~A -> ~S ...~%" id info))
+ (let* ((sid (->string id))
+ (setup-file (make-setup-info-pathname sid (repo-path #t))))
+ (cond (*sudo*
+ (let ((tmp (create-temporary-file)))
+ (with-output-to-file tmp (cut pp info))
+ (run (,*move-command* ,(shellpath tmp) ,(shellpath setup-file)))))
+ (else (with-output-to-file setup-file (cut pp info))))
+ (unless *windows-shell* (run (,*chmod-command* a+r ,(shellpath setup-file)))))))
+
+(define (copy-file from to #!optional (err #t) (prefix (installation-prefix)))
+ ;;XXX the prefix handling is completely bogus
+ (let ((from (if (pair? from) (car from) from))
+ (to (let ((to-path (if (pair? from) (make-pathname to (cadr from)) to)))
+ (if (and prefix (not (string-prefix? prefix to-path)))
+ (make-pathname prefix to-path)
+ to-path))))
+ (ensure-directory to)
+ (cond ((or (glob? from) (file-exists? from))
+ (begin
+ (run (,*copy-command* ,(shellpath from) ,(shellpath to)))
+ to))
+ (err (error "file does not exist" from))
+ (else (warning "file does not exist" from)))))
+
+(define (move-file from to)
+ (let ((from (if (pair? from) (car from) from))
+ (to (if (pair? from) (make-pathname to (cadr from)) to)))
+ (ensure-directory to)
+ (run (,*move-command* ,(shellpath from) ,(shellpath to)) ) ) )
+
+(define (remove-file* dir)
+ (run (,*remove-command* ,(shellpath dir)) ) )
+
+(define (make-dest-pathname path file)
+ (if (list? file)
+ (make-dest-pathname path (cadr file))
+ (if (absolute-pathname? file)
+ file
+ (make-pathname path file) ) ) )
+
+(define (check-filelist flist)
+ (map (lambda (f)
+ (cond ((string? f) f)
+ ((and (list? f) (every string? f)) f)
+ ((and (pair? f) (list (car f) (cdr f))))
+ (else (error "invalid file-specification" f)) ) )
+ flist) )
+
+(define (translate-extension f #!optional default)
+ (pathname-replace-extension f
+ (let ((ext (pathname-extension f)))
+ (cond ((not ext) default)
+ ((equal? "so" ext) ##sys#load-dynamic-extension)
+ ((equal? "a" ext) (if *windows-shell* "lib" "a"))
+ (else ext)))))
+
+
+;;; Convenience function
+
+(define (standard-extension name version)
+ (let* ((sname (->string name))
+ (fname (make-pathname #f sname "scm"))
+ (iname (make-pathname #f sname "import.scm")))
+ (compile -s -O2 -d1 ,fname -j ,name)
+ (compile -c -O2 -d1 ,fname -j ,name -unit ,name)
+ (compile -s -O2 -d0 ,iname)
+ (install-extension
+ name
+ (list fname (make-pathname #f sname "setup"))
+ `((version ,version)
+ (static ,(make-pathname #f fname "o"))))))
+
+
+;;; Installation
+
+(define (install-extension id files #!optional (info '()))
+ (when (setup-install-mode)
+ (let* ((files (check-filelist (if (list? files) files (list files))))
+ (rpath (repo-path))
+ (rpathd (repo-path #t))
+ (dests (map (lambda (f)
+ (let ((from (if (pair? f) (car f) f))
+ (to (make-dest-pathname rpathd f)) )
+ (when (and (not *windows*)
+ (equal? "so" (pathname-extension to)))
+ (run (,*remove-command* ,(shellpath to)) ))
+ (copy-file from to)
+ (unless *windows-shell*
+ (run (,*chmod-command* a+r ,(shellpath to))))
+ (and-let* ((static (assq 'static info)))
+ (when (and (eq? (software-version) 'macosx)
+ (equal? (cadr static) from)
+ (equal? (pathname-extension to) "a"))
+ (run (,*ranlib-command* ,(shellpath to)) ) ))
+ (make-dest-pathname rpath f)))
+ files) )
+ (pre (installation-prefix))
+ (docpath (if pre
+ (ensure-directory (make-pathname pre "share/chicken/doc"))
+ *doc-path*)))
+ (and-let* ((docs (assq 'documentation info)))
+ (print "\n* Installing documentation files in " docpath ":")
+ (for-each
+ (lambda (f)
+ (copy-file f (make-pathname docpath f) #f) )
+ (cdr docs))
+ (newline))
+ (and-let* ((exs (assq 'examples info)))
+ (print "\n* Installing example files in " docpath ":")
+ (for-each
+ (lambda (f)
+ (let ((destf (make-pathname docpath f)))
+ (copy-file f destf #f)
+ (unless *windows-shell*
+ (run (,*chmod-command* a+rx ,destf)) ) ))
+ (cdr exs))
+ (newline))
+ (write-info id dests info) ) ) )
+
+(define (install-program id files #!optional (info '()))
+ (define (exify f)
+ (translate-extension
+ f
+ (if *windows-shell* "exe" #f) ) )
+ (when (setup-install-mode)
+ (let* ((files (check-filelist (if (list? files) files (list files))))
+ (ppath ((lambda (pre)
+ (if pre
+ (ensure-directory (make-pathname pre "bin"))
+ (program-path)))
+ (installation-prefix)))
+ (files (if *windows*
+ (map (lambda (f)
+ (if (list? f)
+ (list (exify (car f)) (exify (cadr f)))
+ (exify f) ) )
+ files)
+ files) )
+ (dests (map (lambda (f)
+ (let ((from (if (pair? f) (car f) f))
+ (to (make-dest-pathname ppath f)) )
+ (copy-file from to)
+ (unless *windows-shell*
+ (run (,*chmod-command* a+r ,(shellpath to))))
+ to) )
+ files) ) )
+ (write-info id dests info) ) ) )
+
+(define (install-script id files #!optional (info '()))
+ (when (setup-install-mode)
+ (let* ((files (check-filelist (if (list? files) files (list files))))
+ (ppath ((lambda (pre)
+ (if pre
+ (ensure-directory (make-pathname pre "bin"))
+ (program-path)))
+ (installation-prefix)))
+ (pfiles (map (lambda (f)
+ (let ((from (if (pair? f) (car f) f))
+ (to (make-dest-pathname ppath f)) )
+ (copy-file from to)
+ (unless *windows-shell*
+ (run (,*chmod-command* a+r ,(shellpath to))))
+ to) )
+ files) ) )
+ (unless *windows-shell*
+ (run (,*chmod-command* a+rx ,(string-intersperse pfiles " "))) )
+ (write-info id pfiles info) ) ) )
+
+
+;;; More helper stuff
+
+(define (repo-path #!optional ddir?)
+ (let ((p (if (and ddir? (installation-prefix))
+ (make-pathname
+ (installation-prefix)
+ (sprintf "lib/chicken/~a" (##sys#fudge 42)))
+ (repository-path))) )
+ (ensure-directory p)
+ p) )
+
+(define (ensure-directory path)
+ (and-let* ((dir (pathname-directory path)))
+ (if (file-exists? dir)
+ (unless (directory? dir)
+ (error "cannot create directory: a file with the same name already exists") )
+ (begin
+ (create-directory/parents dir)
+ (unless *windows-shell*
+ (run (,*chmod-command* a+x ,(shellpath dir)))))))
+ path)
+
+(define (try-compile code #!key c++ (cc (if c++ *cxx* *cc*)) (cflags "") (ldflags "")
+ (verb (setup-verbose-mode)) (compile-only #f))
+ (let* ((fname (create-temporary-file "c"))
+ (oname (pathname-replace-extension fname "o"))
+ (r (begin
+ (with-output-to-file fname (cut display code))
+ (system
+ (let ((cmd (conc
+ cc " "
+ (if compile-only "-c" "") " "
+ cflags " " *target-cflags* " "
+ fname " "
+ (if compile-only
+ ""
+ (conc "-L" *target-lib-home* " " ldflags " " *target-libs*) )
+ " >/dev/null "
+ (if verb "" "2>&1") ) ) )
+ (when verb (print cmd " ..."))
+ cmd) ) ) ) )
+ (when verb (print (if (zero? r) "succeeded." "failed.")))
+ ($system (sprintf "~A ~A" *remove-command* (shellpath fname)))
+ (zero? r) ) )
+
+(define (required-chicken-version v)
+ (when (version>=? v (chicken-version) )
+ (error (sprintf "CHICKEN version ~a or higher is required" v)) ) )
+
+(define (upgrade-message ext msg)
+ (error
+ (sprintf
+ "the required extension `~s' ~a - please run~%~% chicken-install ~a~%~%and repeat the current installation operation."
+ ext msg ext) ) )
+
+(define (required-extension-version . args)
+ (let loop ((args args))
+ (cond ((null? args) #f)
+ ((and (list? args) (>= (length args) 2))
+ (let* ((ext (car args))
+ (version (cadr args))
+ (more (cddr args))
+ (info (extension-information ext)))
+ (if info
+ (let ((ver (and (assq 'version info) (cadr (assq 'version info)))))
+ (cond ((not ver) (upgrade-message ext "has no associated version information"))
+ ((and (version>=? version ver) (not (string=? (->string version) (->string ver))))
+ (upgrade-message
+ ext
+ (sprintf "is older than ~a, which is what this extension requires"
+ version) ) )
+ (else (loop more)) ) )
+ (upgrade-message ext "is not installed") ) ) )
+ (else
+ (error 'required-extension-information "bad argument format" args)) ) ) )
+
+(define test-compile try-compile)
+
+(define (find-library name proc)
+ (test-compile
+ (sprintf "#ifdef __cplusplus~%extern \"C\"~%#endif~%char ~a();~%int main() { ~a(); return 0; }~%" proc proc)
+ ldflags: (conc "-l" name) ) )
+
+(define (find-header name)
+ (test-compile
+ (sprintf "#include <~a>\nint main() { return 0; }\n" name)
+ compile-only: #t) )
+
+(define (version>=? v1 v2)
+ (define (version->list v)
+ (map (lambda (x) (or (string->number x) x))
+ (string-split-fields "[-\\._]" (->string v) #:infix)))
+ (let loop ((p1 (version->list v1))
+ (p2 (version->list v2)))
+ (cond ((null? p1) (null? p2))
+ ((null? p2))
+ ((number? (car p1))
+ (and (number? (car p2))
+ (or (> (car p1) (car p2))
+ (and (= (car p1) (car p2))
+ (loop (cdr p1) (cdr p2))))))
+ ((number? (car p2)))
+ ((string>? (car p1) (car p2)))
+ (else
+ (and (string=? (car p1) (car p2))
+ (loop (cdr p1) (cdr p2)))))))
+
+(define extension-name-and-version
+ (make-parameter '("" "")
+ (lambda (x)
+ (cond [(or (not x) (null? x))
+ '("" "") ]
+ [(and (list? x) (= 2 (length x)))
+ (let ([nam (car x)]
+ [ver (cadr x)]
+ [ensure-string (lambda (x) (if (or (not x) (null? x)) "" (->string x)))])
+ (list (ensure-string nam) (ensure-string ver)) ) ]
+ [else
+ (warning "invalid extension-name-and-version" x)
+ (extension-name-and-version) ] ) ) ) )
+
+(define (extension-name)
+ (car (extension-name-and-version)) )
+
+(define (extension-version #!optional defver)
+ (let ([ver (cadr (extension-name-and-version))])
+ (if (string-null? ver)
+ (and defver (->string defver))
+ ver ) ) )
+
+(define (read-info egg)
+ (with-input-from-file
+ (make-pathname (repository-path) egg ".setup-info")
+ read))
+
+(define (create-temporary-directory)
+ (let ((dir (or (get-environment-variable "TMPDIR")
+ (get-environment-variable "TEMP")
+ (get-environment-variable "TMP")
+ "/tmp")))
+ (let loop ()
+ (let* ((n (##sys#fudge 16)) ; current milliseconds
+ (pn (make-pathname dir (string-append "chicken-install-" (number->string n 16)) "tmp")))
+ (cond ((file-exists? pn) (loop))
+ (else (create-directory pn) pn))))))
+
+(define (remove-directory dir #!optional (strict #t))
+ (cond ((not (file-exists? dir))
+ (if strict
+ (error 'remove-directory "cannot remove - directory not found" dir)
+ #f))
+ (*sudo*
+ ($system (sprintf "sudo rm -fr ~a" (shellpath dir))))
+ (else
+ (let walk ((dir dir))
+ (let ((files (directory dir #t)))
+ (for-each
+ (lambda (f)
+ (unless (or (string=? "." f) (string=? ".." f))
+ (let ((p (make-pathname dir f)))
+ (if (directory? p)
+ (walk p)
+ (delete-file p)))))
+ files)
+ (delete-directory dir)))) ))
+
+(define (remove-extension egg)
+ (and-let* ((files (assq 'files (read-info egg))))
+ (for-each remove-file* (cdr files)))
+ (remove-file* (make-pathname (repository-path) egg "setup-info")))
+
+(define ($system str)
+ (let ((r (system
+ (if *windows-shell*
+ (string-append "\"" str "\"") ; double quotes, yes - thanks to Matthew Flatt
+ str))))
+ (unless (zero? r)
+ (error "shell command failed with nonzero exit status" r str))))
+
+;;; Module Setup
+
+; User setup by default
+(user-install-setup)
+)
diff --git a/setup-download.scm b/setup-download.scm
new file mode 100644
index 00000000..38c8fb64
--- /dev/null
+++ b/setup-download.scm
@@ -0,0 +1,305 @@
+;;;; setup-download.scm
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(require-library extras regex posix utils setup-api srfi-1 data-structures tcp srfi-13
+ files)
+
+
+(module setup-download (retrieve-extension
+ locate-egg/local
+ locate-egg/svn
+ locate-egg/http
+ gather-egg-information
+ list-extensions
+ temporary-directory)
+
+ (import scheme chicken)
+ (import extras regex posix utils srfi-1 data-structures tcp srfi-13 files setup-api)
+
+ (define-constant +default-tcp-connect-timeout+ 10000) ; 10 seconds
+ (define-constant +default-tcp-read/write-timeout+ 20000) ; 20 seconds
+
+ (tcp-connect-timeout +default-tcp-connect-timeout+)
+ (tcp-read-timeout +default-tcp-read/write-timeout+)
+ (tcp-write-timeout +default-tcp-read/write-timeout+)
+
+ (define *quiet* #f)
+
+ (define *chicken-install-user-agent* (conc "chicken-install " (chicken-version)))
+
+ (define (d fstr . args)
+ (let ([port (if *quiet* (current-error-port) (current-output-port))])
+ (apply fprintf port fstr args)
+ (flush-output port) ) )
+
+ (define temporary-directory (make-parameter #f))
+
+ (define (get-temporary-directory)
+ (or (temporary-directory)
+ (let ([dir (create-temporary-directory)])
+ (temporary-directory dir)
+ dir ) ) )
+
+ (define (existing-version egg version vs)
+ (if version
+ (if (member version vs)
+ version
+ (error "version not found" egg version) )
+ (let ([vs (sort vs version>=?)])
+ (and (pair? vs)
+ (car vs) ) ) ) )
+
+ (define (when-no-such-version-warning egg version)
+ (when version (warning "extension has no such version - using default" egg version)) )
+
+ (define (list-eggs/local dir)
+ (string-concatenate (map (cut string-append <> "\n") (directory dir))) )
+
+ (define (locate-egg/local egg dir #!optional version destination)
+ (let* ([eggdir (make-pathname dir egg)]
+ [tagdir (make-pathname eggdir "tags")]
+ [tagver (and (file-exists? tagdir) (directory? tagdir)
+ (existing-version egg version (directory tagdir)) ) ] )
+ (if tagver
+ (values (make-pathname tagdir tagver) tagver)
+ (let ([trunkdir (make-pathname eggdir "trunk")])
+ (when-no-such-version-warning egg version)
+ (if (and (file-exists? trunkdir) (directory? trunkdir))
+ (values trunkdir "trunk")
+ (values eggdir "") ) ) ) ) )
+
+ (define (gather-egg-information dir)
+ (let ((ls (directory dir)))
+ (filter-map
+ (lambda (egg)
+ (let-values (((loc version) (locate-egg/local egg dir)))
+ (let ((meta (make-pathname loc egg "meta")))
+ (and (file-exists? meta)
+ (call/cc
+ (lambda (return)
+ (cons (string->symbol egg)
+ (cons (list 'version version)
+ (handle-exceptions ex
+ (begin
+ (warning "extension has syntactically invalid .meta file" egg)
+ (return #f))
+ (with-input-from-file meta read))))))))))
+ ls)))
+
+ (define (make-svn-ls-cmd uarg parg pnam #!key recursive?)
+ (conc "svn ls " uarg #\space parg (if recursive? " -R " " ") (qs pnam)) )
+
+ (define (make-svn-export-cmd uarg parg dir tmpdir)
+ (conc "svn export " uarg #\space parg #\space #\" dir #\" #\space #\" tmpdir #\"
+ (if *quiet* " 1>&2" "")) )
+
+ (define (list-eggs/svn repo #!optional username password)
+ (let ([uarg (if username (string-append "--username='" username "'") "")]
+ [parg (if password (string-append "--password='" password "'") "")])
+ (let ([cmd (make-svn-ls-cmd uarg parg repo)])
+ (d "listing extension directory ...~% ~a~%" cmd)
+ (string-concatenate
+ (map (lambda (s) (string-append (string-chomp s "/") "\n"))
+ (with-input-from-pipe cmd read-lines))) ) ) )
+
+ (define (locate-egg/svn egg repo #!optional version destination username password)
+ (let* ([uarg (if username (string-append "--username='" username "'") "")]
+ [parg (if password (string-append "--password='" password "'") "")]
+ [cmd (make-svn-ls-cmd uarg parg (make-pathname repo egg) recursive?: #t)])
+ (d "checking available versions ...~% ~a~%" cmd)
+ (let* ([files (with-input-from-pipe cmd read-lines)]
+ [tagver (existing-version
+ egg version
+ (filter-map
+ (lambda (f) (and-let* ((m (string-search "^tags/([^/]+)/" f))) (cadr m)))
+ files))])
+ (let-values ([(filedir ver)
+ (if tagver
+ (values (string-append "tags/" tagver) tagver)
+ (begin
+ (when-no-such-version-warning egg version)
+ (if (member "trunk/" files)
+ (values "trunk" "trunk")
+ (values "" "") ) ) ) ] )
+ (let* ([tmpdir (make-pathname (or destination (get-temporary-directory)) egg)]
+ [cmd (make-svn-export-cmd uarg parg (conc repo #\/ egg #\/ filedir) tmpdir)])
+ (d " ~a~%" cmd)
+ (if (zero? (system cmd))
+ (values tmpdir ver)
+ (values #f "") ) ) ) ) ) )
+
+ (define (deconstruct-url url)
+ (let ([m (string-match "(http://)?([^/:]+)(:([^:/]+))?(/.+)" url)])
+ (values
+ (if m (caddr m) url)
+ (if (and m (cadddr m))
+ (or (string->number (list-ref m 4))
+ (error "not a valid port" (list-ref m 4)))
+ 80)
+ (if m (list-ref m 5) "/")) ) )
+
+ (define (locate-egg/http egg url #!optional version destination tests)
+ (let ([tmpdir (or destination (get-temporary-directory))])
+ (let-values ([(host port locn) (deconstruct-url url)])
+ (let ([locn (string-append
+ locn
+ "?name=" egg
+ (if version (string-append "&version=" version) "")
+ (if tests "&tests=yes" ""))]
+ [eggdir (make-pathname tmpdir egg) ] )
+ (unless (file-exists? eggdir) (create-directory eggdir))
+ (http-fetch host port locn eggdir)
+ ; If we get here then version of egg exists
+ (values eggdir (or version "")) ) ) ) )
+
+ (define (network-failure msg . args)
+ (signal
+ (make-composite-condition
+ (make-property-condition
+ 'exn
+ 'message "invalid response from server"
+ 'arguments args)
+ (make-property-condition 'http-fetch))) )
+
+ (define (make-HTTP-GET/1.1 location user-agent host
+ #!key
+ (port 80)
+ (connection "close")
+ (accept "*")
+ (content-length 0))
+ (conc
+ "GET " location " HTTP/1.1" "\r\n"
+ "Connection: " connection "\r\n"
+ "User-Agent: " user-agent "\r\n"
+ "Accept: " accept "\r\n"
+ "Host: " host #\: port "\r\n"
+ "Content-length: " content-length "\r\n"
+ "\r\n") )
+
+ (define (match-http-response rsp)
+ (and (string? rsp)
+ (string-match "HTTP/[0-9.]+\\s+([0-9]+)\\s+.*" rsp)) )
+
+ (define (response-match-code? mrsp code)
+ (and mrsp (string=? (number->string code) (cadr mrsp))) )
+
+ (define (match-chunked-transfer-encoding ln)
+ (string-match "[Tt]ransfer-[Ee]ncoding:\\s*chunked.*" ln) )
+
+ (define (http-fetch host port locn dest)
+ (d "connecting to host ~s, port ~a ...~%" host port)
+ (let-values ([(in out) (tcp-connect host port)])
+ (d "requesting ~s ...~%" locn)
+ (display
+ (make-HTTP-GET/1.1 locn *chicken-install-user-agent* host port: port accept: "*/*")
+ out)
+ (flush-output out)
+ (d "reading response ...~%")
+ (let ([chunked #f])
+ (let* ([h1 (read-line in)]
+ [response-match (match-http-response h1)])
+ (d "~a~%" h1)
+ ;;*** handle redirects here
+ (unless (response-match-code? response-match 200)
+ (network-failure "invalid response from server" h1) )
+ (let loop ()
+ (let ([ln (read-line in)])
+ (unless (string-null? ln)
+ (when (match-chunked-transfer-encoding ln) (set! chunked #t))
+ (d "~a~%" ln)
+ (loop) ) ) ) )
+ (when chunked
+ (d "reading chunks ...~%")
+ (let ([data (read-chunks in)])
+ (close-input-port in)
+ (set! in (open-input-string data))) ) )
+ (d "reading files ...~%")
+ (let get-files ([files '()])
+ (let ([name (read in)])
+ (cond [(and (pair? name) (eq? 'error (car name)))
+ (throw-server-error (cadr name) (cddr name))]
+ [(or (eof-object? name) (not name))
+ (close-input-port in)
+ (close-output-port out)
+ (reverse files) ]
+ [(not (string? name))
+ (error "invalid file name - possibly corrupt transmission" name) ]
+ [(string-suffix? "/" name)
+ (read in) ; skip size
+ (d " ~a~%" name)
+ (create-directory (make-pathname dest name))
+ (get-files files) ]
+ [else
+ (d " ~a~%" name)
+ (let* ([size (read in)]
+ [_ (read-line in)]
+ [data (read-string size in)] )
+ (with-output-to-file (make-pathname dest name) (cut display data) ) )
+ (get-files (cons name files)) ] ) ) ) ) )
+
+ (define (throw-server-error msg args)
+ (abort
+ (make-composite-condition
+ (make-property-condition
+ 'exn
+ 'message (string-append "[Server] " msg)
+ 'arguments args)
+ (make-property-condition 'setup-download-error))))
+
+ (define (read-chunks in)
+ (let get-chunks ([data '()])
+ (let ([size (string->number (read-line in) 16)])
+ (if (zero? size)
+ (string-concatenate-reverse data)
+ (let ([chunk (read-string size in)])
+ (read-line in)
+ (get-chunks (cons chunk data)) ) ) ) ) )
+
+ (define (retrieve-extension name transport location
+ #!key version quiet destination username password tests)
+ (fluid-let ([*quiet* quiet])
+ (case transport
+ [(local)
+ (when destination (warning "destination for transport `local' ignored"))
+ (locate-egg/local name location version destination) ]
+ [(svn)
+ (locate-egg/svn name location version destination username password) ]
+ [(http)
+ (locate-egg/http name location version destination tests) ]
+ [else
+ (error "cannot retrieve extension unsupported transport" transport) ] ) ) )
+
+ (define (list-extensions transport location #!key quiet username password)
+ (fluid-let ([*quiet* quiet])
+ (case transport
+ [(local)
+ (list-eggs/local location) ]
+ [(svn)
+ (list-eggs/svn location username password) ]
+ [else
+ (error "cannot list extensions - unsupported transport" transport) ] ) ) )
+
+) ;module setup-download
diff --git a/setup.defaults b/setup.defaults
new file mode 100644
index 00000000..cfcecd11
--- /dev/null
+++ b/setup.defaults
@@ -0,0 +1,8 @@
+;;;; setup.defaults - defaults for chicken-install -*- Scheme -*-
+
+((location "http://chicken.kitten-technologies.co.uk/henrietta.cgi")
+ (transport http))
+
+((location "http://galinha.ucpel.tche.br/cgi-bin/henrietta")
+ (transport http))
+
diff --git a/site/chicken.html b/site/chicken.html
new file mode 100644
index 00000000..4be6afb5
--- /dev/null
+++ b/site/chicken.html
@@ -0,0 +1,10 @@
+<!doctype html public "-//w3c//dtd html 4.0 transitional//en">
+<html>
+<head>
+<meta
+ http-equiv="refresh"
+ content="2;url=http://www.call-with-current-continuation.org/index.html">
+</head>
+<body>
+</body>
+</html>
diff --git a/site/chicken.png b/site/chicken.png
new file mode 100644
index 00000000..2b55a150
Binary files /dev/null and b/site/chicken.png differ
diff --git a/site/chicken4-low.png b/site/chicken4-low.png
new file mode 100644
index 00000000..17cadc69
Binary files /dev/null and b/site/chicken4-low.png differ
diff --git a/site/eggs/index.html b/site/eggs/index.html
new file mode 100644
index 00000000..da0013aa
--- /dev/null
+++ b/site/eggs/index.html
@@ -0,0 +1,3 @@
+<html><head><meta http-equiv="Refresh"
+content="1; URL=http://chicken.wiki.br/Eggs%20Unlimited">
+</head><body></body></html>
diff --git a/site/index.html b/site/index.html
new file mode 100644
index 00000000..baccb2c1
--- /dev/null
+++ b/site/index.html
@@ -0,0 +1,198 @@
+<html>
+<head>
+<title>call-with-current-continuation.org</title><style type="text/css"> <!--
+ CODE {
+ color: #666666;
+ }
+
+ DT.definition {
+ background: #eee;
+ color: black;
+ padding: 0.2em 1em 0.2em 0.7em;
+ margin-left: 0.2em;
+ border: 1px solid #bbc;
+ font-family: "Andale Mono", monospace;
+ }
+ DD {
+ margin-top: 0.8em;
+ margin-bottom: 0.8em;
+ }
+ DIV.subsection {
+ border-top: 1px solid #448;
+ padding-left: 1em;
+ }
+ DIV.section {
+ margin-bottom: 1.5em;
+ }
+ a:link {
+ color: #336;
+ }
+ a:visited { color: #666; }
+ a:active { color: #966; }
+ a:hover { color: #669; }
+ body { margin: 0; padding: 0; background: #fff; color: #000; font: 9pt "Lucida Grande", "Verdana", sans-serif; }
+ H2 {
+ background: #336;
+ color: #fff;
+ padding-top: 0.5em;
+ padding-bottom: 0.5em;
+ padding-left: 16px;
+ margin: 0 0 1em 0;
+ }
+ TT {
+ font-family: "Andale Mono", monospace;
+ /* font-size: 1.2em; */
+ }
+ H3 {
+ color: #113;
+ margin-bottom: 0.5em;
+ }
+ DIV#eggheader {
+ text-align: center;
+ float: right;
+ margin-right: 2em;
+ }
+ DIV#header IMG {
+ /* display: block; margin-left: auto; margin-right: auto; */
+ /* float: right; */
+ border: none; /* firefox */
+ }
+ DIV#footer {
+ background: #bbd;
+ padding: 0.7em ;
+ border-top: 1px solid #cce;
+ }
+ DIV#footer hr {
+ display: none;
+ }
+ DIV#footer a {
+ float: left;
+ }
+ DIV#revision-history {
+ float: right;
+ }
+
+ DIV#body {
+ margin: 1em 1em 1em 16px;
+ }
+
+ DIV#examples PRE {
+ background: #eef;
+ padding: 0.1em;
+ border: 1px solid #aac;
+ }
+ PRE#license, DIV#examples PRE {
+ padding: 0.5em;
+ }
+ DIV#examples PRE {
+ /* font-size: 85%; */
+ }
+ PRE { font-family: "Andale Mono", monospace; }
+ TABLE {
+ background: #eef;
+ padding: 0.2em;
+ border: 1px solid #aac;
+ width: 100%;
+ }
+ TABLE.symbol-table TD.symbol {
+ width: 15em;
+ font-family: "Andale Mono", monospace;
+ /* font-size: 1.2em; */
+ }
+ P.block { text-align: left; }
+ H3 { margin: 2em; }
+ TH {
+ border-bottom: 1px solid black;
+ } --></style>
+</head>
+<body>
+<h2>call-with-current-continuation.org</h2>
+
+<center>
+<img src="chicken4-low.png">
+<div style="width: 70%; margin: 3em;">
+
+<p class="block" style="margin: 3em;">
+CHICKEN is a compiler for the <a href="http://schemers.org/">Scheme</a> programming language.
+CHICKEN produces portable, efficient C, supports almost all of the
+<a href="http://schemers.org/Documents/Standards/R5RS/HTML/">R5RS</a>
+Scheme language standard, and includes many enhancements and
+extensions. CHICKEN runs on Linux, MacOS X, Windows, and many Unix flavours.
+</p>
+
+<h3>FEATURES</h3>
+<p class="block"><ul style="text-align: left;">
+<li>Includes a full-featured interactive interpreter as well as an optimizing batch compiler
+<li>Usable for interpreted scripts or compiled standalone executables with either dynamic or static linkage
+<li>Full support for tail recursion, first-class continuations and hygienic macros
+<li>Highly portable and known to run on many platforms, including x86,
+x86-64, IA-64, PowerPC, SPARC and UltraSPARC, Alpha, MIPS, ARM and
+S/390
+<li>Distributed free for use and modification under the terms of the BSD License
+<li>Transparent support for dynamically loadable compiled code and linkage to C
+<li>An easy to use foreign function interface for accessing C and C++ libraries from Scheme code
+<li>Lightweight user-level threads based on first-class continuations
+<li>Provides high- and low-level hygienic macros, including <tt>syntax-rules</tt>
+<li>Includes a powerful module system that integrates hygienic macros and separate compilation
+<li>Execution profiling, debugging, backtrace and single-stepping support
+<li>A POSIX interface that covers environment and filesystem access,
+pipes, processes, signals, locks, sockets, and low-level and
+memory-mapped I/O
+<li>Perl compatible regular expressions, including support for SRE syntax (Structured Regular Expressions)
+<li>Support for interpreted or compiled shell scripts under Unix and Windows
+<li>Support for a large number of <a href="http://srfi.schemers.org/">Scheme Requests For Implementation</a> (SRFIs)
+<li>Many libraries and extensions are available
+at <a href="http://chicken.wiki.br/chicken-projects/egg-index-4.html">"Eggs Unlimited"</a>
+</ul>
+</p>
+
+<h3>DOWNLOAD</h3>
+<p>
+Get the tarball for the most recent release (4.1.0) here:
+<a href="http://www.call-with-current-continuation.org/chicken-4.1.0.tar.gz">
+chicken-4.1.0.tar.gz</a>
+
+</p>
+
+<h3>DOCUMENTATION</h3>
+<p>
+Browse the <a href="http://chicken.wiki.br/man/4/The User's Manual">User's manual</a> at the CHICKEN
+<a href="http://chicken.wiki.br/">wiki</a>
+</p>
+
+<h3>MAILING LIST</h3>
+<p class="block">
+The <a href="http://mail.nongnu.org/mailman/listinfo/chicken-users">CHICKEN Users</a>
+mailing list is a medium-volume but fast-response list for discussing all
+things related to CHICKEN. You can send a message to the list by addressing
+it to <a href="mailto:chicken-users@nongnu.org"><tt>chicken-users@nongnu.org</tt></a>.
+</p>
+If you are interested in the development of CHICKEN,
+check out <a href="http://mail.nongnu.org/mailman/listinfo/chicken-hackers">CHICKEN Hackers</a>.
+
+<h3>DEVELOPMENT</h3>
+<p class="block">
+The current CHICKEN development version can be accessed through the
+<a href="http://subversion.tigris.org">Subversion</a> revision control system, like this:<br>
+<pre>
+$ svn co <a href="https://galinha.ucpel.tche.br/svn/chicken-eggs/chicken/trunk">https://galinha.ucpel.tche.br/svn/chicken-eggs/chicken/trunk</a>
+</pre>
+(username: <tt>anonymous</tt>, password: <none>)
+<p>
+The CHICKEN bug tracking system is located <a href="http://www.irp.oist.jp/trac/chicken/"/>here.</a></p>
+</p>
+</p>
+
+<h3>CONTACT</h3>
+<p class="block">
+If you have any questions, suggestions or insults regarding CHICKEN,
+don't hesitate to join the <tt>chicken-users</tt> mailing list. Bug reports
+should be directed to <a href="mailto:chicken-janitors@nongnu.org">chicken-janitors@nongnu.org</a>,
+preferrably using the <tt>chicken-bug(1)</tt> tool.
+</p>
+</table>
+</div>
+
+</center>
+</body>
+</html>
diff --git a/site/tarballs/index.html b/site/tarballs/index.html
new file mode 100644
index 00000000..5689ef9f
--- /dev/null
+++ b/site/tarballs/index.html
@@ -0,0 +1,153 @@
+<html>
+<head>
+<title>call-with-current-continuation.org - tarballs</title><style type="text/css"> <!--
+ CODE {
+ color: #666666;
+ }
+
+ DT.definition {
+ background: #eee;
+ color: black;
+ padding: 0.2em 1em 0.2em 0.7em;
+ margin-left: 0.2em;
+ border: 1px solid #bbc;
+ font-family: "Andale Mono", monospace;
+ }
+ DD {
+ margin-top: 0.8em;
+ margin-bottom: 0.8em;
+ }
+ DIV.subsection {
+ border-top: 1px solid #448;
+ padding-left: 1em;
+ }
+ DIV.section {
+ margin-bottom: 1.5em;
+ }
+ a:link {
+ color: #336;
+ }
+ a:visited { color: #666; }
+ a:active { color: #966; }
+ a:hover { color: #669; }
+ body { margin: 0; padding: 0; background: #fff; color: #000; font: 9pt "Lucida Grande", "Verdana", sans-serif; }
+ H2 {
+ background: #336;
+ color: #fff;
+ padding-top: 0.5em;
+ padding-bottom: 0.5em;
+ padding-left: 16px;
+ margin: 0 0 1em 0;
+ }
+ TT {
+ font-family: "Andale Mono", monospace;
+ /* font-size: 1.2em; */
+ }
+ H3 {
+ color: #113;
+ margin-bottom: 0.5em;
+ }
+ DIV#eggheader {
+ text-align: center;
+ float: right;
+ margin-right: 2em;
+ }
+ DIV#header IMG {
+ /* display: block; margin-left: auto; margin-right: auto; */
+ /* float: right; */
+ border: none; /* firefox */
+ }
+ DIV#footer {
+ background: #bbd;
+ padding: 0.7em ;
+ border-top: 1px solid #cce;
+ }
+ DIV#footer hr {
+ display: none;
+ }
+ DIV#footer a {
+ float: left;
+ }
+ DIV#revision-history {
+ float: right;
+ }
+
+ DIV#body {
+ margin: 1em 1em 1em 16px;
+ }
+
+ DIV#examples PRE {
+ background: #eef;
+ padding: 0.1em;
+ border: 1px solid #aac;
+ }
+ PRE#license, DIV#examples PRE {
+ padding: 0.5em;
+ }
+ DIV#examples PRE {
+ /* font-size: 85%; */
+ }
+ PRE { font-family: "Andale Mono", monospace; }
+ TABLE {
+ background: #eef;
+ padding: 0.2em;
+ border: 1px solid #aac;
+ width: 100%;
+ }
+ TABLE.symbol-table TD.symbol {
+ width: 15em;
+ font-family: "Andale Mono", monospace;
+ /* font-size: 1.2em; */
+ }
+ P.block { text-align: left; }
+ H3 { margin: 2em; }
+ TH {
+ border-bottom: 1px solid black;
+ } --></style>
+</head>
+<body>
+<h2>call-with-current-continuation.org</h2>
+
+<div style="width: 70%; margin: 3em;">
+
+<p>This is the tarball mirror for the <a href="../index.html">CHICKEN</a> Scheme implementation.
+The following files are currently available:</p>
+
+<p><a href="AquaTerm1.0.1.dmg">AquaTerm1.0.1.dmg</a>
+<p><a href="SDL-1.2.11.tar.gz">SDL-1.2.11.tar.gz</a>
+<p><a href="SDL_gfx-2.0.13.tar.gz">SDL_gfx-2.0.13.tar.gz</a>
+<p><a href="SDL_image-1.2.5.tar.gz">SDL_image-1.2.5.tar.gz</a>
+<p><a href="SDL_net-1.2.6.tar.gz">SDL_net-1.2.6.tar.gz</a>
+<p><a href="SDL_ttf-2.0.8.tar.gz">SDL_ttf-2.0.8.tar.gz</a>
+<p><a href="UnxUtils.zip">UnxUtils.zip</a>: Windows binaries of common UNIX utilities
+<p><a href="cairo-1.2.6.tar.gz">cairo-1.2.6.tar.gz</a>
+<p><a href="cmake-2.4.5.tar.gz">cmake-2.4.5.tar.gz</a>
+<p><a href="cmake-2.4.5-win32-x86.exe">cmake-2.4.5-win32-x86.exe</a>
+<p><a href="darcs-1.0.8-static-linux-i386.gz">darcs-1.0.8-static-linux-i386.gz</a>
+<p><a href="darcsdir-w32-1.0.7.zip">darcsdir-w32-1.0.7.zip</a>
+<p><a href="enscript-1.6.1.tar.gz">enscript-1.6.1.tar.gz</a>
+<p><a href="fcgi-2.4.0.tar.gzf">cgi-2.4.0.tar.gz</a>
+<p><a href="g2-0.72.tar.gz">g2-0.72.tar.gz</a>
+<p><a href="gdbm-1.8.3.tar.gz">gdbm-1.8.3.tar.gz</a>
+<p><a href="gmp-4.2.1.tar.gz">gmp-4.2.1.tar.gz</a>
+<p><a href="htmldoc-1.9.x-r1521.tar.gz">htmldoc-1.9.x-r1521.tar.gz</a>
+<p><a href="hyperestraier-1.4.9.tar.gz">hyperestraier-1.4.9.tar.gz</a>
+<p><a href="imlib2-1.3.0.tar.gz">imlib2-1.3.0.tar.gz</a>
+<p><a href="libffi-3.tgz">libffi-3.tgz</a>
+<p><a href="libpcap-0.9.5.tar.gz">libpcap-0.9.5.tar.gz</a>
+<p><a href="libxmi-1.2.tar.gz">libxmi-1.2.tar.gz</a>
+<p><a href="libsx-2.04.tar.bz2">libsx-2.04.tar.bz2</a>
+<p><a href="mapm-4.9.2.tar.gz">mapm-4.9.2.tar.gz</a>
+<p><a href="metakit-2.4.9.6.tar.gz">metakit-2.4.9.6.tar.gz</a>
+<p><a href="openal-0.0.8.tar.gz">openal-0.0.8.tar.gz</a>
+<p><a href="pcre-6.3.tar.gz">pcre-6.3.tar.gz</a>
+<p><a href="q-7.5.tar.gz">q-7.5.tar.gz</a>
+<p><a href="readline-5.2.tar.gz">readline-5.2.tar.gz</a>
+<p><a href="sqlite-3.3.8.tar.gz">sqlite-3.3.8.tar.gz</a>
+<p><a href="uuid-1.5.1.tar.gz">uuid-1.5.1.tar.gz</a>
+<p><a href="xosd-2.2.12.tar.gz">xosd-2.2.12.tar.gz</a>
+<p><a href="fltk-1.1.7-source.tar.gz">fltk-1.1.7-source.tar.gz</a>
+
+</div>
+</body>
+</html>
diff --git a/srfi-1.import.scm b/srfi-1.import.scm
new file mode 100644
index 00000000..2febc9f7
--- /dev/null
+++ b/srfi-1.import.scm
@@ -0,0 +1,132 @@
+;;;; srfi-1.import.scm - import library for "srfi-1" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'srfi-1
+ '(alist-cons
+ alist-copy
+ alist-delete
+ alist-delete!
+ any
+ append!
+ append-map
+ append-map!
+ append-reverse
+ append-reverse!
+ assoc
+ break
+ break!
+ car+cdr
+ circular-list
+ circular-list?
+ concatenate
+ concatenate!
+ cons*
+ count
+ delete
+ delete!
+ delete-duplicates
+ delete-duplicates!
+ dotted-list?
+ drop
+ drop-right
+ drop-right!
+ drop-while
+ eighth
+ every
+ fifth
+ filter
+ filter!
+ filter-map
+ find
+ find-tail
+ first
+ fold
+ fold-right
+ fourth
+ iota
+ last
+ last-pair
+ length+
+ list-copy
+ list-index
+ list-tabulate
+ list=
+ lset-adjoin
+ lset-diff+intersection
+ lset-diff+intersection!
+ lset-difference
+ lset-difference!
+ lset-intersection
+ lset-intersection!
+ lset-union
+ lset-union!
+ lset-xor
+ lset-xor!
+ lset<=
+ lset=
+ make-list
+ map
+ map!
+ map-in-order
+ member
+ ninth
+ not-pair?
+ null-list?
+ pair-fold
+ pair-fold-right
+ pair-for-each
+ partition
+ partition!
+ proper-list?
+ reduce
+ reduce-right
+ remove
+ remove!
+ reverse!
+ second
+ seventh
+ sixth
+ span
+ span!
+ split-at
+ split-at!
+ take
+ take!
+ take-right
+ take-while
+ take-while!
+ tenth
+ third
+ unfold
+ unfold-right
+ unzip1
+ unzip2
+ unzip3
+ unzip4
+ unzip5
+ xcons
+ zip))
diff --git a/srfi-1.scm b/srfi-1.scm
new file mode 100644
index 00000000..579b49e2
--- /dev/null
+++ b/srfi-1.scm
@@ -0,0 +1,1643 @@
+;;;; srfi-1.scm - Shivers' reference implementation of SRFI-1
+
+
+; Some things to make it work with CHICKEN: (flw)
+;
+
+(declare
+ (unit srfi-1)
+ (disable-interrupts)
+ (disable-warning redef)
+ (hide ##srfi1#cars+cdrs/no-test ##srfi1#cdrs ##srfi1#cars+ ##srfi1#really-append-map ##srfi1#cars+cdrs+
+ ##srfi1#cars+cdrs ##srfi1#lset2<=)
+ (extended-bindings)
+ (standard-bindings not boolean? apply call-with-current-continuation eq? eqv? equal? pair? cons car cdr caar cadr
+ cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar
+ cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr!
+ null? list list? length zero? * - error + / - > < >= <= current-output-port current-input-port
+ write-char newline write display append symbol->string char? char->integer
+ integer->char eof-object? vector-length string-length string-ref string-set! vector-ref
+ vector-set! char=? char<? char>? char>=? char<=? gcd lcm reverse symbol? string->symbol
+ number? complex? real? integer? rational? odd? even? positive? negative? exact? inexact?
+ max min quotient remainder modulo floor ceiling truncate round exact->inexact inexact->exact
+ exp log sin expt sqrt cos tan asin acos atan number->string string->number char-ci=?
+ char-ci<? char-ci>? char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric?
+ char-lower-case? char-upper-case? char-upcase char-downcase string? string=? string>? string<?
+ string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=?
+ string-append string->list list->string vector? vector->list list->vector string read
+ read-char substring string-fill! vector-fill! make-string make-vector open-input-file
+ open-output-file call-with-input-file call-with-output-file close-input-port close-output-port
+ port? values call-with-values vector procedure? memq memv assq assv) )
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ (no-procedure-checks-for-usual-bindings)
+ (bound-to-procedure
+ every any partition! reduce lset-difference! append! pair-fold lset-diff+intersection! fold
+ lset-difference filter! filter delete span! span find-tail find delete! pair-for-each car+cdr
+ reduce-right last-pair drop)
+ (no-bound-checks) ) ] )
+
+(include "unsafe-declarations.scm")
+
+(register-feature! 'srfi-1)
+
+
+;;; SRFI-1 list-processing library -*- Scheme -*-
+;;; Reference implementation
+;;;
+;;; Copyright (c) 1998, 1999 by Olin Shivers. You may do as you please with
+;;; this code as long as you do not remove this copyright notice or
+;;; hold me liable for its use. Please send bug reports to shivers@ai.mit.edu.
+;;; -Olin
+
+;;; This is a library of list- and pair-processing functions. I wrote it after
+;;; carefully considering the functions provided by the libraries found in
+;;; R4RS/R5RS Scheme, MIT Scheme, Gambit, RScheme, MzScheme, slib, Common
+;;; Lisp, Bigloo, guile, T, APL and the SML standard basis. It is a pretty
+;;; rich toolkit, providing a superset of the functionality found in any of
+;;; the various Schemes I considered.
+
+;;; This implementation is intended as a portable reference implementation
+;;; for SRFI-1. See the porting notes below for more information.
+
+;;; Exported:
+;;; xcons tree-copy make-list list-tabulate cons* list-copy
+;;; proper-list? circular-list? dotted-list? not-pair? null-list? list=
+;;; circular-list length+
+;;; iota
+;;; first second third fourth fifth sixth seventh eighth ninth tenth
+;;; car+cdr
+;;; take drop
+;;; take-right drop-right
+;;; take! drop-right!
+;;; split-at split-at!
+;;; last last-pair
+;;; zip unzip1 unzip2 unzip3 unzip4 unzip5
+;;; count
+;;; append! append-reverse append-reverse! concatenate concatenate!
+;;; unfold fold pair-fold reduce
+;;; unfold-right fold-right pair-fold-right reduce-right
+;;; append-map append-map! map! pair-for-each filter-map map-in-order
+;;; filter partition remove
+;;; filter! partition! remove!
+;;; find find-tail any every list-index
+;;; take-while drop-while take-while!
+;;; span break span! break!
+
+;;; In principle, the following R4RS list- and pair-processing procedures
+;;; are also part of this package's exports, although they are not defined
+;;; in this file:
+;;; Primitives: cons pair? null? car cdr set-car! set-cdr!
+;;; Non-primitives: list length append reverse cadr ... cddddr list-ref
+;;; memq memv assq assv
+;;; (The non-primitives are defined in this file, but commented out.)
+;;;
+;;; These R4RS procedures have extended definitions in SRFI-1 and are defined
+;;; in this file:
+;;; map for-each member assoc
+;;;
+;;; The remaining two R4RS list-processing procedures are not included:
+;;; list-tail (use drop)
+;;; list? (use proper-list?)
+
+
+;;; A note on recursion and iteration/reversal:
+;;; Many iterative list-processing algorithms naturally compute the elements
+;;; of the answer list in the wrong order (left-to-right or head-to-tail) from
+;;; the order needed to cons them into the proper answer (right-to-left, or
+;;; tail-then-head). One style or idiom of programming these algorithms, then,
+;;; loops, consing up the elements in reverse order, then destructively
+;;; reverses the list at the end of the loop. I do not do this. The natural
+;;; and efficient way to code these algorithms is recursively. This trades off
+;;; intermediate temporary list structure for intermediate temporary stack
+;;; structure. In a stack-based system, this improves cache locality and
+;;; lightens the load on the GC system. Don't stand on your head to iterate!
+;;; Recurse, where natural. Multiple-value returns make this even more
+;;; convenient, when the recursion/iteration has multiple state values.
+
+;;; Porting:
+;;; This is carefully tuned code; do not modify casually.
+;;; - It is careful to share storage when possible;
+;;; - Side-effecting code tries not to perform redundant writes.
+;;;
+;;; That said, a port of this library to a specific Scheme system might wish
+;;; to tune this code to exploit particulars of the implementation.
+;;; The single most important compiler-specific optimisation you could make
+;;; to this library would be to add rewrite rules or transforms to:
+;;; - transform applications of n-ary procedures (e.g. LIST=, CONS*, APPEND,
+;;; LSET-UNION) into multiple applications of a primitive two-argument
+;;; variant.
+;;; - transform applications of the mapping functions (MAP, FOR-EACH, FOLD,
+;;; ANY, EVERY) into open-coded loops. The killer here is that these
+;;; functions are n-ary. Handling the general case is quite inefficient,
+;;; requiring many intermediate data structures to be allocated and
+;;; discarded.
+;;; - transform applications of procedures that take optional arguments
+;;; into calls to variants that do not take optional arguments. This
+;;; eliminates unnecessary consing and parsing of the rest parameter.
+;;;
+;;; These transforms would provide BIG speedups. In particular, the n-ary
+;;; mapping functions are particularly slow and cons-intensive, and are good
+;;; candidates for tuning. I have coded fast paths for the single-list cases,
+;;; but what you really want to do is exploit the fact that the compiler
+;;; usually knows how many arguments are being passed to a particular
+;;; application of these functions -- they are usually explicitly called, not
+;;; passed around as higher-order values. If you can arrange to have your
+;;; compiler produce custom code or custom linkages based on the number of
+;;; arguments in the call, you can speed these functions up a *lot*. But this
+;;; kind of compiler technology no longer exists in the Scheme world as far as
+;;; I can see.
+;;;
+;;; Note that this code is, of course, dependent upon standard bindings for
+;;; the R5RS procedures -- i.e., it assumes that the variable CAR is bound
+;;; to the procedure that takes the car of a list. If your Scheme
+;;; implementation allows user code to alter the bindings of these procedures
+;;; in a manner that would be visible to these definitions, then there might
+;;; be trouble. You could consider horrible kludgery along the lines of
+;;; (define fact
+;;; (let ((= =) (- -) (* *))
+;;; (letrec ((real-fact (lambda (n)
+;;; (if (= n 0) 1 (* n (real-fact (- n 1)))))))
+;;; real-fact)))
+;;; Or you could consider shifting to a reasonable Scheme system that, say,
+;;; has a module system protecting code from this kind of lossage.
+;;;
+;;; This code does a fair amount of run-time argument checking. If your
+;;; Scheme system has a sophisticated compiler that can eliminate redundant
+;;; error checks, this is no problem. However, if not, these checks incur
+;;; some performance overhead -- and, in a safe Scheme implementation, they
+;;; are in some sense redundant: if we don't check to see that the PROC
+;;; parameter is a procedure, we'll find out anyway three lines later when
+;;; we try to call the value. It's pretty easy to rip all this argument
+;;; checking code out if it's inappropriate for your implementation -- just
+;;; nuke every call to CHECK-ARG.
+;;;
+;;; On the other hand, if you *do* have a sophisticated compiler that will
+;;; actually perform soft-typing and eliminate redundant checks (Rice's systems
+;;; being the only possible candidate of which I'm aware), leaving these checks
+;;; in can *help*, since their presence can be elided in redundant cases,
+;;; and in cases where they are needed, performing the checks early, at
+;;; procedure entry, can "lift" a check out of a loop.
+;;;
+;;; Finally, I have only checked the properties that can portably be checked
+;;; with R5RS Scheme -- and this is not complete. You may wish to alter
+;;; the CHECK-ARG parameter checks to perform extra, implementation-specific
+;;; checks, such as procedure arity for higher-order values.
+;;;
+;;; The code has only these non-R4RS dependencies:
+;;; A few calls to an ERROR procedure;
+;;; Uses of the R5RS multiple-value procedure VALUES and the m-v binding
+;;; RECEIVE macro (which isn't R5RS, but is a trivial macro).
+;;; Many calls to a parameter-checking procedure check-arg:
+;;; (define (check-arg pred val caller)
+;;; (let lp ((val val))
+;;; (if (pred val) val (lp (error "Bad argument" val pred caller)))))
+;;; A few uses of the LET-OPTIONAL and :OPTIONAL macros for parsing
+;;; optional arguments.
+;;;
+;;; Most of these procedures use the NULL-LIST? test to trigger the
+;;; base case in the inner loop or recursion. The NULL-LIST? function
+;;; is defined to be a careful one -- it raises an error if passed a
+;;; non-nil, non-pair value. The spec allows an implementation to use
+;;; a less-careful implementation that simply defines NULL-LIST? to
+;;; be NOT-PAIR?. This would speed up the inner loops of these procedures
+;;; at the expense of having them silently accept dotted lists.
+
+;;; A note on dotted lists:
+;;; I, personally, take the view that the only consistent view of lists
+;;; in Scheme is the view that *everything* is a list -- values such as
+;;; 3 or "foo" or 'bar are simply empty dotted lists. This is due to the
+;;; fact that Scheme actually has no true list type. It has a pair type,
+;;; and there is an *interpretation* of the trees built using this type
+;;; as lists.
+;;;
+;;; I lobbied to have these list-processing procedures hew to this
+;;; view, and accept any value as a list argument. I was overwhelmingly
+;;; overruled during the SRFI discussion phase. So I am inserting this
+;;; text in the reference lib and the SRFI spec as a sort of "minority
+;;; opinion" dissent.
+;;;
+;;; Many of the procedures in this library can be trivially redefined
+;;; to handle dotted lists, just by changing the NULL-LIST? base-case
+;;; check to NOT-PAIR?, meaning that any non-pair value is taken to be
+;;; an empty list. For most of these procedures, that's all that is
+;;; required.
+;;;
+;;; However, we have to do a little more work for some procedures that
+;;; *produce* lists from other lists. Were we to extend these procedures to
+;;; accept dotted lists, we would have to define how they terminate the lists
+;;; produced as results when passed a dotted list. I designed a coherent set
+;;; of termination rules for these cases; this was posted to the SRFI-1
+;;; discussion list. I additionally wrote an earlier version of this library
+;;; that implemented that spec. It has been discarded during later phases of
+;;; the definition and implementation of this library.
+;;;
+;;; The argument *against* defining these procedures to work on dotted
+;;; lists is that dotted lists are the rare, odd case, and that by
+;;; arranging for the procedures to handle them, we lose error checking
+;;; in the cases where a dotted list is passed by accident -- e.g., when
+;;; the programmer swaps a two arguments to a list-processing function,
+;;; one being a scalar and one being a list. For example,
+;;; (member '(1 3 5 7 9) 7)
+;;; This would quietly return #f if we extended MEMBER to accept dotted
+;;; lists.
+;;;
+;;; The SRFI discussion record contains more discussion on this topic.
+
+
+;;; Constructors
+;;;;;;;;;;;;;;;;
+
+;;; Occasionally useful as a value to be passed to a fold or other
+;;; higher-order procedure.
+(define (xcons d a) (cons a d))
+
+;;;; Recursively copy every cons.
+;(define (tree-copy x)
+; (let recur ((x x))
+; (if (not (pair? x)) x
+; (cons (recur (car x)) (recur (cdr x))))))
+
+;;; Make a list of length LEN.
+
+(define (make-list len . maybe-elt)
+; (check-arg (lambda (n) (and (integer? n) (>= n 0))) len make-list)
+ (##sys#check-exact len 'make-list)
+ (let ((elt (cond ((null? maybe-elt) #f) ; Default value
+ ((null? (cdr maybe-elt)) (car maybe-elt))
+ (else (##sys#error 'make-list "Too many arguments to MAKE-LIST"
+ (cons len maybe-elt))))))
+ (do ((i len (fx- i 1))
+ (ans '() (cons elt ans)))
+ ((fx<= i 0) ans))))
+
+
+;(define (list . ans) ans) ; R4RS
+
+
+;;; Make a list of length LEN. Elt i is (PROC i) for 0 <= i < LEN.
+
+(define (list-tabulate len proc)
+; (check-arg (lambda (n) (and (integer? n) (>= n 0))) len list-tabulate)
+; (check-arg procedure? proc list-tabulate)
+ (##sys#check-exact len 'list-tabulate)
+ (do ((i (fx- len 1) (fx- i 1))
+ (ans '() (cons (proc i) ans)))
+ ((fx< i 0) ans)))
+
+;;; (cons* a1 a2 ... an) = (cons a1 (cons a2 (cons ... an)))
+;;; (cons* a1) = a1 (cons* a1 a2 ...) = (cons a1 (cons* a2 ...))
+;;;
+;;; (cons first (unfold not-pair? car cdr rest values))
+
+(define (cons* first . rest)
+ (let recur ((x first) (rest rest))
+ (if (pair? rest)
+ (cons x (recur (car rest) (cdr rest)))
+ x)))
+
+;;; (unfold not-pair? car cdr lis values)
+
+(define (list-copy lis)
+ (let recur ((lis lis))
+ (if (pair? lis)
+ (cons (car lis) (recur (cdr lis)))
+ lis)))
+
+;;; IOTA count [start step] (start start+step ... start+(count-1)*step)
+
+(define (iota count . maybe-start+step)
+; (check-arg integer? count iota)
+ (##sys#check-number count 'iota)
+ (if (< count 0) (##sys#error 'iota "Negative step count" iota count))
+ (let-optionals maybe-start+step ((start 0) ; Olin, I'm tired of fixing your stupid bugs - why didn't
+ (step 1) ) ; you use your own macros, then?
+ (##sys#check-number start 'iota)
+ (##sys#check-number step 'iota)
+; (check-arg number? start iota)
+; (check-arg number? step iota)
+ (let ((last-val (+ start (* (- count 1) step))))
+ (do ((count count (- count 1))
+ (val last-val (- val step))
+ (ans '() (cons val ans)))
+ ((<= count 0) ans)))))
+
+;;; I thought these were lovely, but the public at large did not share my
+;;; enthusiasm...
+;;; :IOTA to (0 ... to-1)
+;;; :IOTA from to (from ... to-1)
+;;; :IOTA from to step (from from+step ...)
+
+;;; IOTA: to (1 ... to)
+;;; IOTA: from to (from+1 ... to)
+;;; IOTA: from to step (from+step from+2step ...)
+
+;(define (##srfi1#parse-iota-args arg1 rest-args proc)
+; (let ((check (lambda (n) (check-arg integer? n proc))))
+; (check arg1)
+; (if (pair? rest-args)
+; (let ((arg2 (check (car rest-args)))
+; (rest (cdr rest-args)))
+; (if (pair? rest)
+; (let ((arg3 (check (car rest)))
+; (rest (cdr rest)))
+; (if (pair? rest) (error "Too many parameters" proc arg1 rest-args)
+; (values arg1 arg2 arg3)))
+; (values arg1 arg2 1)))
+; (values 0 arg1 1))))
+;
+;(define (iota: arg1 . rest-args)
+; (receive (from to step) (##srfi1#parse-iota-args arg1 rest-args iota:)
+; (let* ((numsteps (floor (/ (- to from) step)))
+; (last-val (+ from (* step numsteps))))
+; (if (< numsteps 0) (error "Negative step count" iota: from to step))
+; (do ((steps-left numsteps (- steps-left 1))
+; (val last-val (- val step))
+; (ans '() (cons val ans)))
+; ((<= steps-left 0) ans)))))
+;
+;
+;(define (:iota arg1 . rest-args)
+; (receive (from to step) (##srfi1#parse-iota-args arg1 rest-args :iota)
+; (let* ((numsteps (ceiling (/ (- to from) step)))
+; (last-val (+ from (* step (- numsteps 1)))))
+; (if (< numsteps 0) (error "Negative step count" :iota from to step))
+; (do ((steps-left numsteps (- steps-left 1))
+; (val last-val (- val step))
+; (ans '() (cons val ans)))
+; ((<= steps-left 0) ans)))))
+
+
+
+(define (circular-list val1 . vals)
+ (let ((ans (cons val1 vals)))
+ (set-cdr! (last-pair ans) ans)
+ ans))
+
+;;; <proper-list> ::= () ; Empty proper list
+;;; | (cons <x> <proper-list>) ; Proper-list pair
+;;; Note that this definition rules out circular lists -- and this
+;;; function is required to detect this case and return false.
+
+(define proper-list? list?)
+
+#;(define (proper-list? x)
+ (let lp ((x x) (lag x))
+ (if (pair? x)
+ (let ((x (cdr x)))
+ (if (pair? x)
+ (let ((x (cdr x))
+ (lag (cdr lag)))
+ (and (not (eq? x lag)) (lp x lag)))
+ (null? x)))
+ (null? x))))
+
+
+;;; A dotted list is a finite list (possibly of length 0) terminated
+;;; by a non-nil value. Any non-cons, non-nil value (e.g., "foo" or 5)
+;;; is a dotted list of length 0.
+;;;
+;;; <dotted-list> ::= <non-nil,non-pair> ; Empty dotted list
+;;; | (cons <x> <dotted-list>) ; Proper-list pair
+
+(define (dotted-list? x)
+ (let lp ((x x) (lag x))
+ (if (pair? x)
+ (let ((x (cdr x)))
+ (if (pair? x)
+ (let ((x (cdr x))
+ (lag (cdr lag)))
+ (and (not (eq? x lag)) (lp x lag)))
+ (not (null? x))))
+ (not (null? x)))))
+
+(define (circular-list? x)
+ (let lp ((x x) (lag x))
+ (and (pair? x)
+ (let ((x (cdr x)))
+ (and (pair? x)
+ (let ((x (cdr x))
+ (lag (cdr lag)))
+ (or (eq? x lag) (lp x lag))))))))
+
+(define (not-pair? x) (##core#inline "C_i_not_pair_p" x))
+
+;;; This is a legal definition which is fast and sloppy:
+;;; (define null-list? not-pair?)
+;;; but we'll provide a more careful one:
+(define (null-list? l) (##core#inline "C_i_null_list_p" l))
+
+(define (list= = . lists)
+ (or (null? lists) ; special case
+ (let lp1 ((list-a (car lists)) (others (cdr lists)))
+ (or (null? others)
+ (let ((list-b (car others))
+ (others (cdr others)))
+ (if (eq? list-a list-b) ; EQ? => LIST=
+ (lp1 list-b others)
+ (let lp2 ((la list-a) (lb list-b))
+ (if (null-list? la)
+ (and (null-list? lb)
+ (lp1 list-b others))
+ (and (not (null-list? lb))
+ (= (car la) (car lb))
+ (lp2 (cdr la) (cdr lb)))))))))))
+
+
+
+;;; R4RS, so commented out.
+;(define (length x) ; LENGTH may diverge or
+; (let lp ((x x) (len 0)) ; raise an error if X is
+; (if (pair? x) ; a circular list. This version
+; (lp (cdr x) (+ len 1)) ; diverges.
+; len)))
+
+(define (length+ x) ; Returns #f if X is circular.
+ (let lp ((x x) (lag x) (len 0))
+ (if (pair? x)
+ (let ((x (cdr x))
+ (len (fx+ len 1)))
+ (if (pair? x)
+ (let ((x (cdr x))
+ (lag (cdr lag))
+ (len (fx+ len 1)))
+ (and (not (eq? x lag)) (lp x lag len)))
+ len))
+ len)))
+
+(define (zip list1 . more-lists) (apply map list list1 more-lists))
+
+
+;;; Selectors
+;;;;;;;;;;;;;
+
+;;; R4RS non-primitives:
+;(define (caar x) (car (car x)))
+;(define (cadr x) (car (cdr x)))
+;(define (cdar x) (cdr (car x)))
+;(define (cddr x) (cdr (cdr x)))
+;
+;(define (caaar x) (caar (car x)))
+;(define (caadr x) (caar (cdr x)))
+;(define (cadar x) (cadr (car x)))
+;(define (caddr x) (cadr (cdr x)))
+;(define (cdaar x) (cdar (car x)))
+;(define (cdadr x) (cdar (cdr x)))
+;(define (cddar x) (cddr (car x)))
+;(define (cdddr x) (cddr (cdr x)))
+;
+;(define (caaaar x) (caaar (car x)))
+;(define (caaadr x) (caaar (cdr x)))
+;(define (caadar x) (caadr (car x)))
+;(define (caaddr x) (caadr (cdr x)))
+;(define (cadaar x) (cadar (car x)))
+;(define (cadadr x) (cadar (cdr x)))
+;(define (caddar x) (caddr (car x)))
+;(define (cadddr x) (caddr (cdr x)))
+;(define (cdaaar x) (cdaar (car x)))
+;(define (cdaadr x) (cdaar (cdr x)))
+;(define (cdadar x) (cdadr (car x)))
+;(define (cdaddr x) (cdadr (cdr x)))
+;(define (cddaar x) (cddar (car x)))
+;(define (cddadr x) (cddar (cdr x)))
+;(define (cdddar x) (cdddr (car x)))
+;(define (cddddr x) (cdddr (cdr x)))
+
+
+(define first car)
+(define second cadr)
+(define third caddr)
+(define fourth cadddr)
+(define (fifth x) (car (cddddr x)))
+(define (sixth x) (cadr (cddddr x)))
+(define (seventh x) (caddr (cddddr x)))
+(define (eighth x) (cadddr (cddddr x)))
+(define (ninth x) (car (cddddr (cddddr x))))
+(define (tenth x) (cadr (cddddr (cddddr x))))
+
+(define (car+cdr pair)
+ (##sys#check-pair pair 'car+cdr)
+ (values (##sys#slot pair 0) (##sys#slot pair 1)) )
+
+;;; take & drop
+
+(define (take lis k)
+ (##sys#check-exact k 'take)
+; (check-arg integer? k take)
+ (let recur ((lis lis) (k k))
+ (if (eq? 0 k) '()
+ (cons (car lis)
+ (recur (cdr lis) (fx- k 1))))))
+
+(define (drop lis k)
+ (##sys#check-exact k 'drop)
+; (check-arg integer? k drop)
+ (let iter ((lis lis) (k k))
+ (if (eq? 0 k) lis (iter (cdr lis) (fx- k 1)))))
+
+(define (take! lis k)
+ (##sys#check-exact k 'take!)
+; (check-arg integer? k take!)
+ (if (eq? 0 k) '()
+ (begin (set-cdr! (drop lis (fx- k 1)) '())
+ lis)))
+
+;;; TAKE-RIGHT and DROP-RIGHT work by getting two pointers into the list,
+;;; off by K, then chasing down the list until the lead pointer falls off
+;;; the end.
+
+(define (take-right lis k)
+; (check-arg integer? k take-right)
+ (let lp ((lag lis) (lead (drop lis k)))
+ (if (pair? lead)
+ (lp (cdr lag) (cdr lead))
+ lag)))
+
+(define (drop-right lis k)
+; (check-arg integer? k drop-right)
+ (let recur ((lag lis) (lead (drop lis k)))
+ (if (pair? lead)
+ (cons (car lag) (recur (cdr lag) (cdr lead)))
+ '())))
+
+;;; In this function, LEAD is actually K+1 ahead of LAG. This lets
+;;; us stop LAG one step early, in time to smash its cdr to ().
+(define (drop-right! lis k)
+; (check-arg integer? k drop-right!)
+ (let ((lead (drop lis k)))
+ (if (pair? lead)
+
+ (let lp ((lag lis) (lead (cdr lead))) ; Standard case
+ (if (pair? lead)
+ (lp (cdr lag) (cdr lead))
+ (begin (set-cdr! lag '())
+ lis)))
+
+ '()))) ; Special case dropping everything -- no cons to side-effect.
+
+;(define (list-ref lis i) (car (drop lis i))) ; R4RS
+
+;;; These use the APL convention, whereby negative indices mean
+;;; "from the right." I liked them, but they didn't win over the
+;;; SRFI reviewers.
+;;; K >= 0: Take and drop K elts from the front of the list.
+;;; K <= 0: Take and drop -K elts from the end of the list.
+
+;(define (take lis k)
+; (check-arg integer? k take)
+; (if (negative? k)
+; (list-tail lis (+ k (length lis)))
+; (let recur ((lis lis) (k k))
+; (if (zero? k) '()
+; (cons (car lis)
+; (recur (cdr lis) (- k 1)))))))
+;
+;(define (drop lis k)
+; (check-arg integer? k drop)
+; (if (negative? k)
+; (let recur ((lis lis) (nelts (+ k (length lis))))
+; (if (zero? nelts) '()
+; (cons (car lis)
+; (recur (cdr lis) (- nelts 1)))))
+; (list-tail lis k)))
+;
+;
+;(define (take! lis k)
+; (check-arg integer? k take!)
+; (cond ((zero? k) '())
+; ((positive? k)
+; (set-cdr! (list-tail lis (- k 1)) '())
+; lis)
+; (else (list-tail lis (+ k (length lis))))))
+;
+;(define (drop! lis k)
+; (check-arg integer? k drop!)
+; (if (negative? k)
+; (let ((nelts (+ k (length lis))))
+; (if (zero? nelts) '()
+; (begin (set-cdr! (list-tail lis (- nelts 1)) '())
+; lis)))
+; (list-tail lis k)))
+
+(define (split-at x k)
+ (##sys#check-exact k 'split-at)
+; (check-arg integer? k split-at)
+ (let recur ((lis x) (k k))
+ (if (eq? 0 k) (values '() lis)
+ (receive (prefix suffix) (recur (cdr lis) (fx- k 1))
+ (values (cons (car lis) prefix) suffix)))))
+
+(define (split-at! x k)
+ (##sys#check-exact k 'split-at!)
+; (check-arg integer? k split-at!)
+ (if (eq? 0 k) (values '() x)
+ (let* ((prev (drop x (fx- k 1)))
+ (suffix (cdr prev)))
+ (set-cdr! prev '())
+ (values x suffix))))
+
+
+(define (last lis) (car (last-pair lis)))
+
+(define (last-pair lis)
+; (check-arg pair? lis last-pair)
+ (let lp ((lis lis))
+ (let ((tail (cdr lis)))
+ (if (pair? tail) (lp tail) lis))))
+
+
+;;; Unzippers -- 1 through 5
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (unzip1 lis) (map car lis))
+
+(define (unzip2 lis)
+ (let recur ((lis lis))
+ (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle
+ (let ((elt (car lis))) ; dotted lists.
+ (receive (a b) (recur (cdr lis))
+ (values (cons (car elt) a)
+ (cons (cadr elt) b)))))))
+
+(define (unzip3 lis)
+ (let recur ((lis lis))
+ (if (null-list? lis) (values lis lis lis)
+ (let ((elt (car lis)))
+ (receive (a b c) (recur (cdr lis))
+ (values (cons (car elt) a)
+ (cons (cadr elt) b)
+ (cons (caddr elt) c)))))))
+
+(define (unzip4 lis)
+ (let recur ((lis lis))
+ (if (null-list? lis) (values lis lis lis lis)
+ (let ((elt (car lis)))
+ (receive (a b c d) (recur (cdr lis))
+ (values (cons (car elt) a)
+ (cons (cadr elt) b)
+ (cons (caddr elt) c)
+ (cons (cadddr elt) d)))))))
+
+(define (unzip5 lis)
+ (let recur ((lis lis))
+ (if (null-list? lis) (values lis lis lis lis lis)
+ (let ((elt (car lis)))
+ (receive (a b c d e) (recur (cdr lis))
+ (values (cons (car elt) a)
+ (cons (cadr elt) b)
+ (cons (caddr elt) c)
+ (cons (cadddr elt) d)
+ (cons (car (cddddr elt)) e)))))))
+
+
+;;; append! append-reverse append-reverse! concatenate concatenate!
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (append! . lists)
+ ;; First, scan through lists looking for a non-empty one.
+ (let lp ((lists lists) (prev '()))
+ (if (not (pair? lists)) prev
+ (let ((first (car lists))
+ (rest (cdr lists)))
+ (if (not (pair? first)) (lp rest first)
+
+ ;; Now, do the splicing.
+ (let lp2 ((tail-cons (last-pair first))
+ (rest rest))
+ (if (pair? rest)
+ (let ((next (car rest))
+ (rest (cdr rest)))
+ (set-cdr! tail-cons next)
+ (lp2 (if (pair? next) (last-pair next) tail-cons)
+ rest))
+ first)))))))
+
+;;; APPEND is R4RS.
+;(define (append . lists)
+; (if (pair? lists)
+; (let recur ((list1 (car lists)) (lists (cdr lists)))
+; (if (pair? lists)
+; (let ((tail (recur (car lists) (cdr lists))))
+; (fold-right cons tail list1)) ; Append LIST1 & TAIL.
+; list1))
+; '()))
+
+;(define (append-reverse rev-head tail) (fold cons tail rev-head))
+
+;(define (append-reverse! rev-head tail)
+; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair)
+; tail
+; rev-head))
+
+;;; Hand-inline the FOLD and PAIR-FOLD ops for speed.
+
+(define (append-reverse rev-head tail)
+ (let lp ((rev-head rev-head) (tail tail))
+ (if (null-list? rev-head) tail
+ (lp (cdr rev-head) (cons (car rev-head) tail)))))
+
+(define (append-reverse! rev-head tail)
+ (let lp ((rev-head rev-head) (tail tail))
+ (if (null-list? rev-head) tail
+ (let ((next-rev (cdr rev-head)))
+ (set-cdr! rev-head tail)
+ (lp next-rev rev-head)))))
+
+
+(define (concatenate lists) (reduce-right append '() lists))
+(define (concatenate! lists) (reduce-right append! '() lists))
+
+;;; Fold/map internal utilities
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; These little internal utilities are used by the general
+;;; fold & mapper funs for the n-ary cases . It'd be nice if they got inlined.
+;;; One the other hand, the n-ary cases are painfully inefficient as it is.
+;;; An aggressive implementation should simply re-write these functions
+;;; for raw efficiency; I have written them for as much clarity, portability,
+;;; and simplicity as can be achieved.
+;;;
+;;; I use the dreaded call/cc to do local aborts. A good compiler could
+;;; handle this with extreme efficiency. An implementation that provides
+;;; a one-shot, non-persistent continuation grabber could help the compiler
+;;; out by using that in place of the call/cc's in these routines.
+;;;
+;;; These functions have funky definitions that are precisely tuned to
+;;; the needs of the fold/map procs -- for example, to minimize the number
+;;; of times the argument lists need to be examined.
+
+;;; Return (map cdr lists).
+;;; However, if any element of LISTS is empty, just abort and return '().
+(define (##srfi1#cdrs lists)
+ (##sys#call-with-current-continuation
+ (lambda (abort)
+ (let recur ((lists lists))
+ (if (pair? lists)
+ (let ((lis (car lists)))
+ (if (null-list? lis) (abort '())
+ (cons (cdr lis) (recur (cdr lists)))))
+ '())))))
+
+(define (##srfi1#cars+ lists last-elt) ; (append! (##sys#map car lists) (list last-elt))
+ (let recur ((lists lists))
+ (if (pair? lists) (cons (caar lists) (recur (cdr lists))) (list last-elt))))
+
+;;; LISTS is a (not very long) non-empty list of lists.
+;;; Return two lists: the cars & the cdrs of the lists.
+;;; However, if any of the lists is empty, just abort and return [() ()].
+
+(define (##srfi1#cars+cdrs lists)
+ (##sys#call-with-current-continuation
+ (lambda (abort)
+ (let recur ((lists lists))
+ (if (pair? lists)
+ (receive (list other-lists) (car+cdr lists)
+ (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
+ (receive (a d) (car+cdr list)
+ (receive (cars cdrs) (recur other-lists)
+ (values (cons a cars) (cons d cdrs))))))
+ (values '() '()))))))
+
+;;; Like ##srfi1#CARS+CDRS, but we pass in a final elt tacked onto the end of the
+;;; cars list. What a hack.
+(define (##srfi1#cars+cdrs+ lists cars-final)
+ (##sys#call-with-current-continuation
+ (lambda (abort)
+ (let recur ((lists lists))
+ (if (pair? lists)
+ (receive (list other-lists) (car+cdr lists)
+ (if (null-list? list) (abort '() '()) ; LIST is empty -- bail out
+ (receive (a d) (car+cdr list)
+ (receive (cars cdrs) (recur other-lists)
+ (values (cons a cars) (cons d cdrs))))))
+ (values (list cars-final) '()))))))
+
+;;; Like ##srfi1#CARS+CDRS, but blow up if any list is empty.
+(define (##srfi1#cars+cdrs/no-test lists)
+ (let recur ((lists lists))
+ (if (pair? lists)
+ (receive (list other-lists) (car+cdr lists)
+ (receive (a d) (car+cdr list)
+ (receive (cars cdrs) (recur other-lists)
+ (values (cons a cars) (cons d cdrs)))))
+ (values '() '()))))
+
+
+;;; count
+;;;;;;;;;
+(define (count pred list1 . lists)
+; (check-arg procedure? pred count)
+ (if (pair? lists)
+
+ ;; N-ary case
+ (let lp ((list1 list1) (lists lists) (i 0))
+ (if (null-list? list1) i
+ (receive (as ds) (##srfi1#cars+cdrs lists)
+ (if (null? as) i
+ (lp (cdr list1) ds
+ (if (apply pred (car list1) as) (fx+ i 1) i))))))
+
+ ;; Fast path
+ (let lp ((lis list1) (i 0))
+ (if (null-list? lis) i
+ (lp (cdr lis) (if (pred (car lis)) (fx+ i 1) i))))))
+
+
+;;; fold/unfold
+;;;;;;;;;;;;;;;
+
+(define (unfold-right p f g seed . maybe-tail)
+; (check-arg procedure? p unfold-right)
+; (check-arg procedure? f unfold-right)
+; (check-arg procedure? g unfold-right)
+ (let lp ((seed seed) (ans (optional maybe-tail '())))
+ (if (p seed) ans
+ (lp (g seed)
+ (cons (f seed) ans)))))
+
+
+(define (unfold p f g seed . maybe-tail-gen)
+; (check-arg procedure? p unfold)
+; (check-arg procedure? f unfold)
+; (check-arg procedure? g unfold)
+ (if (pair? maybe-tail-gen)
+
+ (let ((tail-gen (car maybe-tail-gen)))
+ (if (pair? (cdr maybe-tail-gen))
+ (apply error "Too many arguments" unfold p f g seed maybe-tail-gen)
+
+ (let recur ((seed seed))
+ (if (p seed) (tail-gen seed)
+ (cons (f seed) (recur (g seed)))))))
+
+ (let recur ((seed seed))
+ (if (p seed) '()
+ (cons (f seed) (recur (g seed)))))))
+
+
+(define (fold kons knil lis1 . lists)
+; (check-arg procedure? kons fold)
+ (if (pair? lists)
+ (let lp ((lists (cons lis1 lists)) (ans knil)) ; N-ary case
+ (receive (cars+ans cdrs) (##srfi1#cars+cdrs+ lists ans)
+ (if (null? cars+ans) ans ; Done.
+ (lp cdrs (apply kons cars+ans)))))
+
+ (let lp ((lis lis1) (ans knil)) ; Fast path
+ (if (null-list? lis) ans
+ (lp (cdr lis) (kons (car lis) ans))))))
+
+
+(define (fold-right kons knil lis1 . lists)
+; (check-arg procedure? kons fold-right)
+ (if (pair? lists)
+ (let recur ((lists (cons lis1 lists))) ; N-ary case
+ (let ((cdrs (##srfi1#cdrs lists)))
+ (if (null? cdrs) knil
+ (apply kons (##srfi1#cars+ lists (recur cdrs))))))
+
+ (let recur ((lis lis1)) ; Fast path
+ (if (null-list? lis) knil
+ (let ((head (car lis)))
+ (kons head (recur (cdr lis))))))))
+
+
+(define (pair-fold-right f zero lis1 . lists)
+; (check-arg procedure? f pair-fold-right)
+ (if (pair? lists)
+ (let recur ((lists (cons lis1 lists))) ; N-ary case
+ (let ((cdrs (##srfi1#cdrs lists)))
+ (if (null? cdrs) zero
+ (apply f (append! lists (list (recur cdrs)))))))
+
+ (let recur ((lis lis1)) ; Fast path
+ (if (null-list? lis) zero (f lis (recur (cdr lis)))))))
+
+(define (pair-fold f zero lis1 . lists)
+; (check-arg procedure? f pair-fold)
+ (if (pair? lists)
+ (let lp ((lists (cons lis1 lists)) (ans zero)) ; N-ary case
+ (let ((tails (##srfi1#cdrs lists)))
+ (if (null? tails) ans
+ (lp tails (apply f (append! lists (list ans)))))))
+
+ (let lp ((lis lis1) (ans zero))
+ (if (null-list? lis) ans
+ (let ((tail (cdr lis))) ; Grab the cdr now,
+ (lp tail (f lis ans))))))) ; in case F SET-CDR!s LIS.
+
+
+;;; REDUCE and REDUCE-RIGHT only use RIDENTITY in the empty-list case.
+;;; These cannot meaningfully be n-ary.
+
+(define (reduce f ridentity lis)
+; (check-arg procedure? f reduce)
+ (if (null-list? lis) ridentity
+ (fold f (car lis) (cdr lis))))
+
+(define (reduce-right f ridentity lis)
+; (check-arg procedure? f reduce-right)
+ (if (null-list? lis) ridentity
+ (let recur ((head (car lis)) (lis (cdr lis)))
+ (if (pair? lis)
+ (f head (recur (car lis) (cdr lis)))
+ head))))
+
+
+
+;;; Mappers: append-map append-map! pair-for-each map! filter-map map-in-order
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (append-map f lis1 . lists)
+ (##srfi1#really-append-map append-map append f lis1 lists))
+(define (append-map! f lis1 . lists)
+ (##srfi1#really-append-map append-map! append! f lis1 lists))
+
+(define (##srfi1#really-append-map who appender f lis1 lists)
+; (check-arg procedure? f who)
+ (if (pair? lists)
+ (receive (cars cdrs) (##srfi1#cars+cdrs (cons lis1 lists))
+ (if (null? cars) '()
+ (let recur ((cars cars) (cdrs cdrs))
+ (let ((vals (apply f cars)))
+ (receive (cars2 cdrs2) (##srfi1#cars+cdrs cdrs)
+ (if (null? cars2) vals
+ (appender vals (recur cars2 cdrs2))))))))
+
+ ;; Fast path
+ (if (null-list? lis1) '()
+ (let recur ((elt (car lis1)) (rest (cdr lis1)))
+ (let ((vals (f elt)))
+ (if (null-list? rest) vals
+ (appender vals (recur (car rest) (cdr rest)))))))))
+
+
+(define (pair-for-each proc lis1 . lists)
+; (check-arg procedure? proc pair-for-each)
+ (if (pair? lists)
+
+ (let lp ((lists (cons lis1 lists)))
+ (let ((tails (##srfi1#cdrs lists)))
+ (if (pair? tails)
+ (begin (apply proc lists)
+ (lp tails)))))
+
+ ;; Fast path.
+ (let lp ((lis lis1))
+ (if (not (null-list? lis))
+ (let ((tail (cdr lis))) ; Grab the cdr now,
+ (proc lis) ; in case PROC SET-CDR!s LIS.
+ (lp tail))))))
+
+;;; We stop when LIS1 runs out, not when any list runs out.
+(define (map! f lis1 . lists)
+; (check-arg procedure? f map!)
+ (if (pair? lists)
+ (let lp ((lis1 lis1) (lists lists))
+ (if (not (null-list? lis1))
+ (receive (heads tails) (##srfi1#cars+cdrs/no-test lists)
+ (set-car! lis1 (apply f (car lis1) heads))
+ (lp (cdr lis1) tails))))
+
+ ;; Fast path.
+ (pair-for-each (lambda (pair) (set-car! pair (f (car pair)))) lis1))
+ lis1)
+
+
+;;; Map F across L, and save up all the non-false results.
+(define (filter-map f lis1 . lists)
+; (check-arg procedure? f filter-map)
+ (if (pair? lists)
+ (let recur ((lists (cons lis1 lists)))
+ (receive (cars cdrs) (##srfi1#cars+cdrs lists)
+ (if (pair? cars)
+ (cond ((apply f cars) => (lambda (x) (cons x (recur cdrs))))
+ (else (recur cdrs))) ; Tail call in this arm.
+ '())))
+
+ ;; Fast path.
+ (let recur ((lis lis1))
+ (if (null-list? lis) lis
+ (let ((tail (recur (cdr lis))))
+ (cond ((f (car lis)) => (lambda (x) (cons x tail)))
+ (else tail)))))))
+
+
+;;; Map F across lists, guaranteeing to go left-to-right.
+;;; NOTE: Some implementations of R5RS MAP are compliant with this spec;
+;;; in which case this procedure may simply be defined as a synonym for MAP.
+
+(define (map-in-order f lis1 . lists)
+; (check-arg procedure? f map-in-order)
+ (if (pair? lists)
+ (let recur ((lists (cons lis1 lists)))
+ (receive (cars cdrs) (##srfi1#cars+cdrs lists)
+ (if (pair? cars)
+ (let ((x (apply f cars))) ; Do head first,
+ (cons x (recur cdrs))) ; then tail.
+ '())))
+
+ ;; Fast path.
+ (let recur ((lis lis1))
+ (if (null-list? lis) lis
+ (let ((tail (cdr lis))
+ (x (f (car lis)))) ; Do head first,
+ (cons x (recur tail))))))) ; then tail.
+
+
+;;; We extend MAP to handle arguments of unequal length.
+(define map map-in-order)
+
+
+;;; filter, remove, partition
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; FILTER, REMOVE, PARTITION and their destructive counterparts do not
+;;; disorder the elements of their argument.
+
+;; This FILTER shares the longest tail of L that has no deleted elements.
+;; If Scheme had multi-continuation calls, they could be made more efficient.
+
+(define (filter pred lis) ; Sleazing with EQ? makes this
+; (check-arg procedure? pred filter) ; one faster.
+ (let recur ((lis lis))
+ (if (null-list? lis) lis ; Use NOT-PAIR? to handle dotted lists.
+ (let ((head (car lis))
+ (tail (cdr lis)))
+ (if (pred head)
+ (let ((new-tail (recur tail))) ; Replicate the RECUR call so
+ (if (eq? tail new-tail) lis
+ (cons head new-tail)))
+ (recur tail)))))) ; this one can be a tail call.
+
+
+;;; Another version that shares longest tail.
+;(define (filter pred lis)
+; (receive (ans no-del?)
+; ;; (recur l) returns L with (pred x) values filtered.
+; ;; It also returns a flag NO-DEL? if the returned value
+; ;; is EQ? to L, i.e. if it didn't have to delete anything.
+; (let recur ((l l))
+; (if (null-list? l) (values l #t)
+; (let ((x (car l))
+; (tl (cdr l)))
+; (if (pred x)
+; (receive (ans no-del?) (recur tl)
+; (if no-del?
+; (values l #t)
+; (values (cons x ans) #f)))
+; (receive (ans no-del?) (recur tl) ; Delete X.
+; (values ans #f))))))
+; ans))
+
+
+
+;(define (filter! pred lis) ; Things are much simpler
+; (let recur ((lis lis)) ; if you are willing to
+; (if (pair? lis) ; push N stack frames & do N
+; (cond ((pred (car lis)) ; SET-CDR! writes, where N is
+; (set-cdr! lis (recur (cdr lis))); the length of the answer.
+; lis)
+; (else (recur (cdr lis))))
+; lis)))
+
+
+;;; This implementation of FILTER!
+;;; - doesn't cons, and uses no stack;
+;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are
+;;; usually expensive on modern machines, and can be extremely expensive on
+;;; modern Schemes (e.g., ones that have generational GC's).
+;;; It just zips down contiguous runs of in and out elts in LIS doing the
+;;; minimal number of SET-CDR!s to splice the tail of one run of ins to the
+;;; beginning of the next.
+
+(define (filter! pred lis)
+; (check-arg procedure? pred filter!)
+ (let lp ((ans lis))
+ (cond ((null-list? ans) ans) ; Scan looking for
+ ((not (pred (car ans))) (lp (cdr ans))) ; first cons of result.
+
+ ;; ANS is the eventual answer.
+ ;; SCAN-IN: (CDR PREV) = LIS and (CAR PREV) satisfies PRED.
+ ;; Scan over a contiguous segment of the list that
+ ;; satisfies PRED.
+ ;; SCAN-OUT: (CAR PREV) satisfies PRED. Scan over a contiguous
+ ;; segment of the list that *doesn't* satisfy PRED.
+ ;; When the segment ends, patch in a link from PREV
+ ;; to the start of the next good segment, and jump to
+ ;; SCAN-IN.
+ (else (letrec ((scan-in (lambda (prev lis)
+ (if (pair? lis)
+ (if (pred (car lis))
+ (scan-in lis (cdr lis))
+ (scan-out prev (cdr lis))))))
+ (scan-out (lambda (prev lis)
+ (let lp ((lis lis))
+ (if (pair? lis)
+ (if (pred (car lis))
+ (begin (set-cdr! prev lis)
+ (scan-in lis (cdr lis)))
+ (lp (cdr lis)))
+ (set-cdr! prev lis))))))
+ (scan-in ans (cdr ans))
+ ans)))))
+
+
+
+;;; Answers share common tail with LIS where possible;
+;;; the technique is slightly subtle.
+
+(define (partition pred lis)
+; (check-arg procedure? pred partition)
+ (let recur ((lis lis))
+ (if (null-list? lis) (values lis lis) ; Use NOT-PAIR? to handle dotted lists.
+ (let ((elt (car lis))
+ (tail (cdr lis)))
+ (receive (in out) (recur tail)
+ (if (pred elt)
+ (values (if (pair? out) (cons elt in) lis) out)
+ (values in (if (pair? in) (cons elt out) lis))))))))
+
+
+
+;(define (partition! pred lis) ; Things are much simpler
+; (let recur ((lis lis)) ; if you are willing to
+; (if (null-list? lis) (values lis lis) ; push N stack frames & do N
+; (let ((elt (car lis))) ; SET-CDR! writes, where N is
+; (receive (in out) (recur (cdr lis)) ; the length of LIS.
+; (cond ((pred elt)
+; (set-cdr! lis in)
+; (values lis out))
+; (else (set-cdr! lis out)
+; (values in lis))))))))
+
+
+;;; This implementation of PARTITION!
+;;; - doesn't cons, and uses no stack;
+;;; - is careful not to do redundant SET-CDR! writes, as writes to memory are
+;;; usually expensive on modern machines, and can be extremely expensive on
+;;; modern Schemes (e.g., ones that have generational GC's).
+;;; It just zips down contiguous runs of in and out elts in LIS doing the
+;;; minimal number of SET-CDR!s to splice these runs together into the result
+;;; lists.
+
+(define (partition! pred lis)
+; (check-arg procedure? pred partition!)
+ (if (null-list? lis) (values lis lis)
+
+ ;; This pair of loops zips down contiguous in & out runs of the
+ ;; list, splicing the runs together. The invariants are
+ ;; SCAN-IN: (cdr in-prev) = LIS.
+ ;; SCAN-OUT: (cdr out-prev) = LIS.
+ (letrec ((scan-in (lambda (in-prev out-prev lis)
+ (let lp ((in-prev in-prev) (lis lis))
+ (if (pair? lis)
+ (if (pred (car lis))
+ (lp lis (cdr lis))
+ (begin (set-cdr! out-prev lis)
+ (scan-out in-prev lis (cdr lis))))
+ (set-cdr! out-prev lis))))) ; Done.
+
+ (scan-out (lambda (in-prev out-prev lis)
+ (let lp ((out-prev out-prev) (lis lis))
+ (if (pair? lis)
+ (if (pred (car lis))
+ (begin (set-cdr! in-prev lis)
+ (scan-in lis out-prev (cdr lis)))
+ (lp lis (cdr lis)))
+ (set-cdr! in-prev lis)))))) ; Done.
+
+ ;; Crank up the scan&splice loops.
+ (if (pred (car lis))
+ ;; LIS begins in-list. Search for out-list's first pair.
+ (let lp ((prev-l lis) (l (cdr lis)))
+ (cond ((not (pair? l)) (values lis l))
+ ((pred (car l)) (lp l (cdr l)))
+ (else (scan-out prev-l l (cdr l))
+ (values lis l)))) ; Done.
+
+ ;; LIS begins out-list. Search for in-list's first pair.
+ (let lp ((prev-l lis) (l (cdr lis)))
+ (cond ((not (pair? l)) (values l lis))
+ ((pred (car l))
+ (scan-in l prev-l (cdr l))
+ (values l lis)) ; Done.
+ (else (lp l (cdr l)))))))))
+
+
+;;; Inline us, please.
+(define (remove pred l) (filter (lambda (x) (not (pred x))) l))
+(define (remove! pred l) (filter! (lambda (x) (not (pred x))) l))
+
+
+
+;;; Here's the taxonomy for the DELETE/ASSOC/MEMBER functions.
+;;; (I don't actually think these are the world's most important
+;;; functions -- the procedural FILTER/REMOVE/FIND/FIND-TAIL variants
+;;; are far more general.)
+;;;
+;;; Function Action
+;;; ---------------------------------------------------------------------------
+;;; remove pred lis Delete by general predicate
+;;; delete x lis [=] Delete by element comparison
+;;;
+;;; find pred lis Search by general predicate
+;;; find-tail pred lis Search by general predicate
+;;; member x lis [=] Search by element comparison
+;;;
+;;; assoc key lis [=] Search alist by key comparison
+;;; alist-delete key alist [=] Alist-delete by key comparison
+
+(define (delete x lis . maybe-=)
+ (let ((= (optional maybe-= equal?)))
+ (filter (lambda (y) (not (= x y))) lis)))
+
+(define (delete! x lis . maybe-=)
+ (let ((= (optional maybe-= equal?)))
+ (filter! (lambda (y) (not (= x y))) lis)))
+
+;;; Extended from R4RS to take an optional comparison argument.
+(define (member x lis . maybe-=)
+ (let ((= (optional maybe-= equal?)))
+ (find-tail (lambda (y) (= x y)) lis)))
+
+;;; R4RS, hence we don't bother to define.
+;;; The MEMBER and then FIND-TAIL call should definitely
+;;; be inlined for MEMQ & MEMV.
+;(define (memq x lis) (member x lis eq?))
+;(define (memv x lis) (member x lis eqv?))
+
+
+;;; right-duplicate deletion
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; delete-duplicates delete-duplicates!
+;;;
+;;; Beware -- these are N^2 algorithms. To efficiently remove duplicates
+;;; in long lists, sort the list to bring duplicates together, then use a
+;;; linear-time algorithm to kill the dups. Or use an algorithm based on
+;;; element-marking. The former gives you O(n lg n), the latter is linear.
+
+(define (delete-duplicates lis . maybe-=)
+ (let ((elt= (optional maybe-= equal?)))
+; (check-arg procedure? elt= delete-duplicates)
+ (let recur ((lis lis))
+ (if (null-list? lis) lis
+ (let* ((x (car lis))
+ (tail (cdr lis))
+ (new-tail (recur (delete x tail elt=))))
+ (if (eq? tail new-tail) lis (cons x new-tail)))))))
+
+(define (delete-duplicates! lis . maybe-=)
+ (let ((elt= (optional maybe-= equal?)))
+; (check-arg procedure? elt= delete-duplicates!)
+ (let recur ((lis lis))
+ (if (null-list? lis) lis
+ (let* ((x (car lis))
+ (tail (cdr lis))
+ (new-tail (recur (delete! x tail elt=))))
+ (if (eq? tail new-tail) lis (cons x new-tail)))))))
+
+
+;;; alist stuff
+;;;;;;;;;;;;;;;
+
+;;; Extended from R4RS to take an optional comparison argument.
+(define (assoc x lis . maybe-=)
+ (let ((= (optional maybe-= equal?)))
+ (find (lambda (entry) (= x (car entry))) lis)))
+
+(define (alist-cons key datum alist) (cons (cons key datum) alist))
+
+(define (alist-copy alist)
+ (##sys#map (lambda (elt) (cons (car elt) (cdr elt)))
+ alist))
+
+(define (alist-delete key alist . maybe-=)
+ (let ((= (optional maybe-= equal?)))
+ (filter (lambda (elt) (not (= key (car elt)))) alist)))
+
+(define (alist-delete! key alist . maybe-=)
+ (let ((= (optional maybe-= equal?)))
+ (filter! (lambda (elt) (not (= key (car elt)))) alist)))
+
+
+;;; find find-tail take-while drop-while span break any every list-index
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (find pred list)
+ (cond ((find-tail pred list) => car)
+ (else #f)))
+
+(define (find-tail pred list)
+; (check-arg procedure? pred find-tail)
+ (let lp ((list list))
+ (and (not (null-list? list))
+ (if (pred (car list)) list
+ (lp (cdr list))))))
+
+(define (take-while pred lis)
+; (check-arg procedure? pred take-while)
+ (let recur ((lis lis))
+ (if (null-list? lis) '()
+ (let ((x (car lis)))
+ (if (pred x)
+ (cons x (recur (cdr lis)))
+ '())))))
+
+(define (drop-while pred lis)
+; (check-arg procedure? pred drop-while)
+ (let lp ((lis lis))
+ (if (null-list? lis) '()
+ (if (pred (car lis))
+ (lp (cdr lis))
+ lis))))
+
+(define (take-while! pred lis)
+; (check-arg procedure? pred take-while!)
+ (if (or (null-list? lis) (not (pred (car lis)))) '()
+ (begin (let lp ((prev lis) (rest (cdr lis)))
+ (if (pair? rest)
+ (let ((x (car rest)))
+ (if (pred x) (lp rest (cdr rest))
+ (set-cdr! prev '())))))
+ lis)))
+
+(define (span pred lis)
+; (check-arg procedure? pred span)
+ (let recur ((lis lis))
+ (if (null-list? lis) (values '() '())
+ (let ((x (car lis)))
+ (if (pred x)
+ (receive (prefix suffix) (recur (cdr lis))
+ (values (cons x prefix) suffix))
+ (values '() lis))))))
+
+(define (span! pred lis)
+; (check-arg procedure? pred span!)
+ (if (or (null-list? lis) (not (pred (car lis)))) (values '() lis)
+ (let ((suffix (let lp ((prev lis) (rest (cdr lis)))
+ (if (null-list? rest) rest
+ (let ((x (car rest)))
+ (if (pred x) (lp rest (cdr rest))
+ (begin (set-cdr! prev '())
+ rest)))))))
+ (values lis suffix))))
+
+
+(define (break pred lis) (span (lambda (x) (not (pred x))) lis))
+(define (break! pred lis) (span! (lambda (x) (not (pred x))) lis))
+
+(define (any pred lis1 . lists)
+; (check-arg procedure? pred any)
+ (if (pair? lists)
+
+ ;; N-ary case
+ (receive (heads tails) (##srfi1#cars+cdrs (cons lis1 lists))
+ (and (pair? heads)
+ (let lp ((heads heads) (tails tails))
+ (receive (next-heads next-tails) (##srfi1#cars+cdrs tails)
+ (if (pair? next-heads)
+ (or (apply pred heads) (lp next-heads next-tails))
+ (apply pred heads)))))) ; Last PRED app is tail call.
+
+ ;; Fast path
+ (and (not (null-list? lis1))
+ (let lp ((head (car lis1)) (tail (cdr lis1)))
+ (if (null-list? tail)
+ (pred head) ; Last PRED app is tail call.
+ (or (pred head) (lp (car tail) (cdr tail))))))))
+
+
+;(define (every pred list) ; Simple definition.
+; (let lp ((list list)) ; Doesn't return the last PRED value.
+; (or (not (pair? list))
+; (and (pred (car list))
+; (lp (cdr list))))))
+
+(define (every pred lis1 . lists)
+; (check-arg procedure? pred every)
+ (if (pair? lists)
+
+ ;; N-ary case
+ (receive (heads tails) (##srfi1#cars+cdrs (cons lis1 lists))
+ (or (not (pair? heads))
+ (let lp ((heads heads) (tails tails))
+ (receive (next-heads next-tails) (##srfi1#cars+cdrs tails)
+ (if (pair? next-heads)
+ (and (apply pred heads) (lp next-heads next-tails))
+ (apply pred heads)))))) ; Last PRED app is tail call.
+
+ ;; Fast path
+ (or (null-list? lis1)
+ (let lp ((head (car lis1)) (tail (cdr lis1)))
+ (if (null-list? tail)
+ (pred head) ; Last PRED app is tail call.
+ (and (pred head) (lp (car tail) (cdr tail))))))))
+
+(define (list-index pred lis1 . lists)
+; (check-arg procedure? pred list-index)
+ (if (pair? lists)
+
+ ;; N-ary case
+ (let lp ((lists (cons lis1 lists)) (n 0))
+ (receive (heads tails) (##srfi1#cars+cdrs lists)
+ (and (pair? heads)
+ (if (apply pred heads) n
+ (lp tails (fx+ n 1))))))
+
+ ;; Fast path
+ (let lp ((lis lis1) (n 0))
+ (and (not (null-list? lis))
+ (if (pred (car lis)) n (lp (cdr lis) (fx+ n 1)))))))
+
+;;; Reverse
+;;;;;;;;;;;
+
+;R4RS, so not defined here.
+;(define (reverse lis) (fold cons '() lis))
+
+;(define (reverse! lis)
+; (pair-fold (lambda (pair tail) (set-cdr! pair tail) pair) '() lis))
+
+(define (reverse! lis)
+ (let lp ((lis lis) (ans '()))
+ (if (null-list? lis) ans
+ (let ((tail (cdr lis)))
+ (set-cdr! lis ans)
+ (lp tail lis)))))
+
+;;; Lists-as-sets
+;;;;;;;;;;;;;;;;;
+
+;;; This is carefully tuned code; do not modify casually.
+;;; - It is careful to share storage when possible;
+;;; - Side-effecting code tries not to perform redundant writes.
+;;; - It tries to avoid linear-time scans in special cases where constant-time
+;;; computations can be performed.
+;;; - It relies on similar properties from the other list-lib procs it calls.
+;;; For example, it uses the fact that the implementations of MEMBER and
+;;; FILTER in this source code share longest common tails between args
+;;; and results to get structure sharing in the lset procedures.
+
+(define (##srfi1#lset2<= = lis1 lis2) (every (lambda (x) (member x lis2 =)) lis1))
+
+(define (lset<= = . lists)
+; (check-arg procedure? = lset<=)
+ (or (not (pair? lists)) ; 0-ary case
+ (let lp ((s1 (car lists)) (rest (cdr lists)))
+ (or (not (pair? rest))
+ (let ((s2 (car rest)) (rest (cdr rest)))
+ (and (or (eq? s2 s1) ; Fast path
+ (##srfi1#lset2<= = s1 s2)) ; Real test
+ (lp s2 rest)))))))
+
+(define (lset= = . lists)
+; (check-arg procedure? = lset=)
+ (or (not (pair? lists)) ; 0-ary case
+ (let lp ((s1 (car lists)) (rest (cdr lists)))
+ (or (not (pair? rest))
+ (let ((s2 (car rest))
+ (rest (cdr rest)))
+ (and (or (eq? s1 s2) ; Fast path
+ (and (##srfi1#lset2<= = s1 s2) (##srfi1#lset2<= = s2 s1))) ; Real test
+ (lp s2 rest)))))))
+
+
+(define (lset-adjoin = lis . elts)
+; (check-arg procedure? = lset-adjoin)
+ (fold (lambda (elt ans) (if (member elt ans =) ans (cons elt ans)))
+ lis elts))
+
+
+(define (lset-union = . lists)
+; (check-arg procedure? = lset-union)
+ (reduce (lambda (lis ans) ; Compute ANS + LIS.
+ (cond ((null? lis) ans) ; Don't copy any lists
+ ((null? ans) lis) ; if we don't have to.
+ ((eq? lis ans) ans)
+ (else
+ (fold (lambda (elt ans) (if (any (lambda (x) (= x elt)) ans)
+ ans
+ (cons elt ans)))
+ ans lis))))
+ '() lists))
+
+(define (lset-union! = . lists)
+; (check-arg procedure? = lset-union!)
+ (reduce (lambda (lis ans) ; Splice new elts of LIS onto the front of ANS.
+ (cond ((null? lis) ans) ; Don't copy any lists
+ ((null? ans) lis) ; if we don't have to.
+ ((eq? lis ans) ans)
+ (else
+ (pair-fold (lambda (pair ans)
+ (let ((elt (car pair)))
+ (if (any (lambda (x) (= x elt)) ans)
+ ans
+ (begin (set-cdr! pair ans) pair))))
+ ans lis))))
+ '() lists))
+
+
+(define (lset-intersection = lis1 . lists)
+; (check-arg procedure? = lset-intersection)
+ (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
+ (cond ((any null-list? lists) '()) ; Short cut
+ ((null? lists) lis1) ; Short cut
+ (else (filter (lambda (x)
+ (every (lambda (lis) (member x lis =)) lists))
+ lis1)))))
+
+(define (lset-intersection! = lis1 . lists)
+; (check-arg procedure? = lset-intersection!)
+ (let ((lists (delete lis1 lists eq?))) ; Throw out any LIS1 vals.
+ (cond ((any null-list? lists) '()) ; Short cut
+ ((null? lists) lis1) ; Short cut
+ (else (filter! (lambda (x)
+ (every (lambda (lis) (member x lis =)) lists))
+ lis1)))))
+
+
+(define (lset-difference = lis1 . lists)
+; (check-arg procedure? = lset-difference)
+ (let ((lists (filter pair? lists))) ; Throw out empty lists.
+ (cond ((null? lists) lis1) ; Short cut
+ ((memq lis1 lists) '()) ; Short cut
+ (else (filter (lambda (x)
+ (every (lambda (lis) (not (member x lis =)))
+ lists))
+ lis1)))))
+
+(define (lset-difference! = lis1 . lists)
+; (check-arg procedure? = lset-difference!)
+ (let ((lists (filter pair? lists))) ; Throw out empty lists.
+ (cond ((null? lists) lis1) ; Short cut
+ ((memq lis1 lists) '()) ; Short cut
+ (else (filter! (lambda (x)
+ (every (lambda (lis) (not (member x lis =)))
+ lists))
+ lis1)))))
+
+
+(define (lset-xor = . lists)
+; (check-arg procedure? = lset-xor)
+ (reduce (lambda (b a) ; Compute A xor B:
+ ;; Note that this code relies on the constant-time
+ ;; short-cuts provided by LSET-DIFF+INTERSECTION,
+ ;; LSET-DIFFERENCE & APPEND to provide constant-time short
+ ;; cuts for the cases A = (), B = (), and A eq? B. It takes
+ ;; a careful case analysis to see it, but it's carefully
+ ;; built in.
+
+ ;; Compute a-b and a^b, then compute b-(a^b) and
+ ;; cons it onto the front of a-b.
+ (receive (a-b a-int-b) (lset-diff+intersection = a b)
+ (cond ((null? a-b) (lset-difference = b a))
+ ((null? a-int-b) (append b a))
+ (else (fold (lambda (xb ans)
+ (if (member xb a-int-b =) ans (cons xb ans)))
+ a-b
+ b)))))
+ '() lists))
+
+
+(define (lset-xor! = . lists)
+; (check-arg procedure? = lset-xor!)
+ (reduce (lambda (b a) ; Compute A xor B:
+ ;; Note that this code relies on the constant-time
+ ;; short-cuts provided by LSET-DIFF+INTERSECTION,
+ ;; LSET-DIFFERENCE & APPEND to provide constant-time short
+ ;; cuts for the cases A = (), B = (), and A eq? B. It takes
+ ;; a careful case analysis to see it, but it's carefully
+ ;; built in.
+
+ ;; Compute a-b and a^b, then compute b-(a^b) and
+ ;; cons it onto the front of a-b.
+ (receive (a-b a-int-b) (lset-diff+intersection! = a b)
+ (cond ((null? a-b) (lset-difference! = b a))
+ ((null? a-int-b) (append! b a))
+ (else (pair-fold (lambda (b-pair ans)
+ (if (member (car b-pair) a-int-b =) ans
+ (begin (set-cdr! b-pair ans) b-pair)))
+ a-b
+ b)))))
+ '() lists))
+
+
+(define (lset-diff+intersection = lis1 . lists)
+; (check-arg procedure? = lset-diff+intersection)
+ (cond ((every null-list? lists) (values lis1 '())) ; Short cut
+ ((memq lis1 lists) (values '() lis1)) ; Short cut
+ (else (partition (lambda (elt)
+ (not (any (lambda (lis) (member elt lis =))
+ lists)))
+ lis1))))
+
+(define (lset-diff+intersection! = lis1 . lists)
+; (check-arg procedure? = lset-diff+intersection!)
+ (cond ((every null-list? lists) (values lis1 '())) ; Short cut
+ ((memq lis1 lists) (values '() lis1)) ; Short cut
+ (else (partition! (lambda (elt)
+ (not (any (lambda (lis) (member elt lis =))
+ lists)))
+ lis1))))
diff --git a/srfi-13.import.scm b/srfi-13.import.scm
new file mode 100644
index 00000000..979d22ee
--- /dev/null
+++ b/srfi-13.import.scm
@@ -0,0 +1,130 @@
+;;;; srfi-13.import.scm - import library for "srfi-13" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'srfi-13
+ '(check-substring-spec
+ kmp-step
+ make-kmp-restart-vector
+ string->list
+ string-any
+ string-append/shared
+ string-ci<
+ string-ci<=
+ string-ci<>
+ string-ci=
+ string-ci>
+ string-ci>=
+ string-compare
+ string-compare-ci
+ string-concatenate
+ string-concatenate-reverse
+ string-concatenate-reverse/shared
+ string-concatenate/shared
+ string-contains
+ string-contains-ci
+ string-copy
+ string-copy!
+ string-count
+ string-delete
+ string-downcase
+ string-downcase!
+ string-drop
+ string-drop-right
+ string-every
+ string-fill!
+ string-filter
+ string-fold
+ string-fold-right
+ string-for-each
+ string-for-each-index
+ string-index
+ string-index-right
+ string-join
+ string-kmp-partial-search
+ string-map
+ string-map!
+ string-null?
+ string-pad
+ string-pad-right
+ string-parse-final-start+end
+ string-parse-start+end
+ string-prefix-ci?
+ string-prefix-length
+ string-prefix-length-ci
+ string-prefix?
+ string-replace
+ string-reverse
+ string-reverse!
+ string-skip
+ string-skip-right
+ string-suffix-ci?
+ string-suffix-length
+ string-suffix-length-ci
+ string-suffix?
+ string-tabulate
+ string-take
+ string-take-right
+ string-titlecase
+ string-titlecase!
+ string-tokenize
+ string-trim
+ string-trim-both
+ string-trim-right
+ string-unfold
+ string-unfold-right
+ string-upcase
+ string-upcase!
+ string-xcopy!
+ string<
+ string<=
+ string<>
+ string=
+ string>
+ string>=
+ substring-spec-ok?
+ substring/shared
+ xsubstring)
+ `((let-string-start+end
+ ()
+ ,(##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'let-string-start+end form '(_ _ _ _ _ . _))
+ (let ((s-e-r (cadr form))
+ (proc (caddr form))
+ (s-exp (cadddr form))
+ (args-exp (car (cddddr form)))
+ (body (cdr (cddddr form)))
+ (%receive (r 'receive))
+ (%string-parse-start+end (r 'string-parse-start+end))
+ (%string-parse-final-start+end (r 'string-parse-final-start+end)))
+ (if (pair? (cddr s-e-r))
+ `(,%receive (,(caddr s-e-r) ,(car s-e-r) ,(cadr s-e-r))
+ (,%string-parse-start+end ,proc ,s-exp ,args-exp)
+ ,@body)
+ `(,%receive ,s-e-r
+ (,%string-parse-final-start+end ,proc ,s-exp ,args-exp)
+ ,@body) ) ))))))
diff --git a/srfi-13.scm b/srfi-13.scm
new file mode 100644
index 00000000..14c12337
--- /dev/null
+++ b/srfi-13.scm
@@ -0,0 +1,2082 @@
+;;;; srfi-13.scm - Shivers' reference implementation of SRFI-13
+
+
+(declare
+ (unit srfi-13)
+ (uses srfi-14)
+ (fixnum)
+ (disable-warning redef)
+ (hide %string-prefix? %string-hash %finish-string-concatenate-reverse %string-suffix-length %string-prefix-length
+ %string-map %string-copy! %string-compare %substring/shared %string-suffix? %multispan-repcopy!
+ %string-prefix-length-ci %string-suffix-length-ci %string-prefix-ci? %string-suffix-ci?
+ ##srfi13#traverse
+ %string-titlecase! %string-map! %string-compare-ci ##srfi13#string-fill!)
+ (standard-bindings not boolean? apply call-with-current-continuation eq? eqv? equal? pair? cons car cdr caar cadr
+ cdar cddr caaar caadr cadar caddr cdaar cdadr cddar cdddr caaaar caaadr caadar caaddr cadaar
+ cadadr caddar cadddr cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr set-car! set-cdr!
+ null? list list? length zero? * - error + / - > < >= <= current-output-port current-input-port
+ write-char newline write display append symbol->string char? char->integer
+ integer->char eof-object? vector-length string-length string-ref string-set! vector-ref
+ vector-set! char=? char<? char>? char>=? char<=? gcd lcm reverse symbol? string->symbol
+ number? complex? real? integer? rational? odd? even? positive? negative? exact? inexact?
+ max min quotient remainder modulo floor ceiling truncate round exact->inexact inexact->exact
+ exp log sin expt sqrt cos tan asin acos atan number->string string->number char-ci=?
+ char-ci<? char-ci>? char-ci>=? char-ci<=? char-alphabetic? char-whitespace? char-numeric?
+ char-lower-case? char-upper-case? char-upcase char-downcase string? string=? string>? string<?
+ string>=? string<=? string-ci=? string-ci<? string-ci>? string-ci<=? string-ci>=?
+ string-append list->string vector? vector->list list->vector string read map for-each
+ read-char substring vector-fill! make-string make-vector open-input-file
+ open-output-file call-with-input-file call-with-output-file close-input-port close-output-port
+ port? values call-with-values vector procedure? memq memv assq assv member assoc)
+ (extended-bindings)
+ (disable-interrupts) )
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ (no-procedure-checks-for-usual-bindings)
+ (bound-to-procedure
+ string-concatenate check-substring-spec ##srfi13#string-fill! string-parse-final-start+end
+ ##sys#substring string-index-right string-skip-right substring/shared
+ string-concatenate/shared make-kmp-restart-vector string-ci= string= char-set?
+ char-set-contains? string-fold char-set string-skip string-index string-downcase! char->int
+ string-parse-start+end substring-spec-ok?)
+ (no-bound-checks) ) ] )
+
+(include "unsafe-declarations.scm")
+
+(register-feature! 'srfi-13)
+
+
+(define-inline (char-cased? c) (char-alphabetic? c))
+(define-inline (char-titlecase c) (char-upcase c))
+
+
+;;; SRFI 13 string library reference implementation -*- Scheme -*-
+;;; Olin Shivers 5/2000
+;;;
+;;; Copyright (c) 1988-1994 Massachusetts Institute of Technology.
+;;; Copyright (c) 1998, 1999, 2000 Olin Shivers. All rights reserved.
+;;; The details of the copyrights appear at the end of the file. Short
+;;; summary: BSD-style open source.
+
+;;; Exports:
+;;; string-map string-map!
+;;; string-fold string-unfold
+;;; string-fold-right string-unfold-right
+;;; string-tabulate string-for-each string-for-each-index
+;;; string-every string-any
+;;; string-hash string-hash-ci
+;;; string-compare string-compare-ci
+;;; string= string< string> string<= string>= string<>
+;;; string-ci= string-ci< string-ci> string-ci<= string-ci>= string-ci<>
+;;; string-downcase string-upcase string-titlecase
+;;; string-downcase! string-upcase! string-titlecase!
+;;; string-take string-take-right
+;;; string-drop string-drop-right
+;;; string-pad string-pad-right
+;;; string-trim string-trim-right string-trim-both
+;;; string-filter string-delete
+;;; string-index string-index-right
+;;; string-skip string-skip-right
+;;; string-count
+;;; string-prefix-length string-prefix-length-ci
+;;; string-suffix-length string-suffix-length-ci
+;;; string-prefix? string-prefix-ci?
+;;; string-suffix? string-suffix-ci?
+;;; string-contains string-contains-ci
+;;; string-copy! substring/shared
+;;; string-reverse string-reverse! reverse-list->string
+;;; string-concatenate string-concatenate/shared string-concatenate-reverse
+;;; string-append/shared
+;;; xsubstring string-xcopy!
+;;; string-null?
+;;; string-join
+;;; string-tokenize
+;;; string-replace
+;;;
+;;; R5RS extended:
+;;; string->list string-copy string-fill!
+;;;
+;;; R5RS re-exports:
+;;; string? make-string string-length string-ref string-set!
+;;;
+;;; R5RS re-exports (also defined here but commented-out):
+;;; string string-append list->string
+;;;
+;;; Low-level routines:
+;;; make-kmp-restart-vector string-kmp-partial-search kmp-step
+;;; string-parse-start+end
+;;; string-parse-final-start+end
+;;; let-string-start+end
+;;; check-substring-spec
+;;; substring-spec-ok?
+
+;;; Imports
+;;; This is a fairly large library. While it was written for portability, you
+;;; must be aware of its dependencies in order to run it in a given scheme
+;;; implementation. Here is a complete list of the dependencies it has and the
+;;; assumptions it makes beyond stock R5RS Scheme:
+;;;
+;;; This code has the following non-R5RS dependencies:
+;;; - (RECEIVE (var ...) mv-exp body ...) multiple-value binding macro;
+;;;
+;;; - Various imports from the char-set library for the routines that can
+;;; take char-set arguments;
+;;;
+;;; - An n-ary ERROR procedure;
+;;;
+;;; - BITWISE-AND for the hash functions;
+;;;
+;;; - A simple CHECK-ARG procedure for checking parameter values; it is
+;;; (lambda (pred val proc)
+;;; (if (pred val) val (error "Bad arg" val pred proc)))
+;;;
+;;; - :OPTIONAL and LET-OPTIONALS* macros for parsing, defaulting &
+;;; type-checking optional parameters from a rest argument;
+;;;
+;;; - CHAR-CASED? and CHAR-TITLECASE for the STRING-TITLECASE &
+;;; STRING-TITLECASE! procedures. The former returns true iff a character is
+;;; one that has case distinctions; in ASCII it returns true on a-z and A-Z.
+;;; CHAR-TITLECASE is analagous to CHAR-UPCASE and CHAR-DOWNCASE. In ASCII &
+;;; Latin-1, it is the same as CHAR-UPCASE.
+;;;
+;;; The code depends upon a small set of core string primitives from R5RS:
+;;; MAKE-STRING STRING-REF STRING-SET! STRING? STRING-LENGTH SUBSTRING
+;;; (Actually, SUBSTRING is not a primitive, but we assume that an
+;;; implementation's native version is probably faster than one we could
+;;; define, so we import it from R5RS.)
+;;;
+;;; The code depends upon a small set of R5RS character primitives:
+;;; char? char=? char-ci=? char<? char-ci<?
+;;; char-upcase char-downcase
+;;; char->integer (for the hash functions)
+;;;
+;;; We assume the following:
+;;; - CHAR-DOWNCASE o CHAR-UPCASE = CHAR-DOWNCASE
+;;; - CHAR-CI=? is equivalent to
+;;; (lambda (c1 c2) (char=? (char-downcase (char-upcase c1))
+;;; (char-downcase (char-upcase c2))))
+;;; - CHAR-UPCASE, CHAR-DOWNCASE and CHAR-TITLECASE are locale-insensitive
+;;; and consistent with Unicode's 1-1 char-mapping spec.
+;;; These things are typically true, but if not, you would need to modify
+;;; the case-mapping and case-insensitive routines.
+
+;;; Enough introductory blather. On to the source code. (But see the end of
+;;; the file for further notes on porting & performance tuning.)
+
+
+;;; Support for START/END substring specs
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-syntax let-string-start+end2
+ (syntax-rules ()
+ ((_ (s-e1 s-e2 s-e3 s-e4) proc s1 s2 args . body)
+ (let ((procv proc))
+ (let-string-start+end
+ (s-e1 s-e2 rest) procv s1 args
+ (let-string-start+end
+ (s-e3 s-e4) procv s2 rest
+ . body) ) ) ) ) )
+
+(define-syntax let-string-start+end
+ (lambda (form r c)
+ (##sys#check-syntax 'let-string-start+end form '(_ _ _ _ _ . _))
+ (let ((s-e-r (cadr form))
+ (proc (caddr form))
+ (s-exp (cadddr form))
+ (args-exp (car (cddddr form)))
+ (body (cdr (cddddr form)))
+ (%receive (r 'receive))
+ (%string-parse-start+end (r 'string-parse-start+end))
+ (%string-parse-final-start+end (r 'string-parse-final-start+end)))
+ (if (pair? (cddr s-e-r))
+ `(,%receive (,(caddr s-e-r) ,(car s-e-r) ,(cadr s-e-r))
+ (,%string-parse-start+end ,proc ,s-exp ,args-exp)
+ ,@body)
+ `(,%receive ,s-e-r
+ (,%string-parse-final-start+end ,proc ,s-exp ,args-exp)
+ ,@body) ) )))
+
+
+;;; Returns three values: rest start end
+
+(define (string-parse-start+end proc s args)
+ (##sys#check-string s 'string-parse-start+end)
+ (let ((slen (string-length s)))
+ (if (pair? args)
+
+ (let ((start (car args))
+ (args (cdr args)))
+; (if (and (integer? start) (exact? start) (>= start 0))
+ (if (and (fixnum? start) (>= start 0))
+ (receive (end args)
+ (if (pair? args)
+ (let ((end (car args))
+ (args (cdr args)))
+; (if (and (integer? end) (exact? end) (<= end slen))
+ (if (and (fixnum? end) (<= end slen))
+ (values end args)
+ (##sys#error 'string-parse-start+end "Illegal substring END spec" proc end s)))
+ (values slen args))
+ (if (<= start end) (values args start end)
+ (##sys#error 'string-parse-start+end "Illegal substring START/END spec"
+ proc start end s)))
+ (##sys#error 'string-parse-start+end "Illegal substring START spec" proc start s)))
+
+ (values '() 0 slen))))
+
+(define (string-parse-final-start+end proc s args)
+ (receive (rest start end) (string-parse-start+end proc s args)
+ (if (pair? rest) (##sys#error 'string-parse-final-start+end "Extra arguments to procedure" proc rest)
+ (values start end))))
+
+(define (substring-spec-ok? s start end)
+ (and (string? s)
+; (integer? start)
+; (exact? start)
+; (integer? end)
+; (exact? end)
+ (fixnum? start)
+ (fixnum? end)
+ (<= 0 start)
+ (<= start end)
+ (<= end (string-length s))))
+
+(define (check-substring-spec proc s start end)
+ (if (not (substring-spec-ok? s start end))
+ (##sys#error 'check-substring-spec "Illegal substring spec." proc s start end)))
+
+
+;;; Defined by R5RS, so commented out here.
+;(define (string . chars)
+; (let* ((len (length chars))
+; (ans (make-string len)))
+; (do ((i 0 (+ i 1))
+; (chars chars (cdr chars)))
+; ((>= i len))
+; (string-set! ans i (car chars)))
+; ans))
+;
+;(define (string . chars) (string-unfold null? car cdr chars))
+
+
+
+;;; substring/shared S START [END]
+;;; string-copy S [START END]
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;;; All this goop is just arg parsing & checking surrounding a call to the
+;;; actual primitive, %SUBSTRING/SHARED.
+
+(define (substring/shared s start . maybe-end)
+; (check-arg string? s substring/shared)
+ (let ((slen (string-length s)))
+; (check-arg (lambda (start) (and (integer? start) (exact? start) (<= 0 start)))
+; start substring/shared)
+ (let ([n (optional maybe-end slen)])
+ (##sys#check-exact n 'substring/shared)
+ (check-substring-spec 'substring/shared s start n)
+ (%substring/shared s start n) ) ) )
+#|
+ (%substring/shared s start
+ (:optional maybe-end slen
+ (lambda (end) (and (integer? end)
+ (exact? end)
+ (<= start end)
+ (<= end slen)))))))
+|#
+
+;;; Split out so that other routines in this library can avoid arg-parsing
+;;; overhead for END parameter.
+(define (%substring/shared s start end)
+ (if (and (zero? start) (= end (string-length s))) s
+ (##sys#substring s start end)))
+
+(define (string-copy s . maybe-start+end)
+ (let-string-start+end (start end) string-copy s maybe-start+end
+ (##sys#substring s start end)))
+
+;This library uses the R5RS SUBSTRING, but doesn't export it.
+;Here is a definition, just for completeness.
+;(define (substring s start end)
+; (check-substring-spec substring s start end)
+; (let* ((slen (- end start))
+; (ans (make-string slen)))
+; (do ((i 0 (+ i 1))
+; (j start (+ j 1)))
+; ((>= i slen) ans)
+; (string-set! ans i (string-ref s j)))))
+
+;;; Basic iterators and other higher-order abstractions
+;;; (string-map proc s [start end])
+;;; (string-map! proc s [start end])
+;;; (string-fold kons knil s [start end])
+;;; (string-fold-right kons knil s [start end])
+;;; (string-unfold p f g seed [base make-final])
+;;; (string-unfold-right p f g seed [base make-final])
+;;; (string-for-each proc s [start end])
+;;; (string-for-each-index proc s [start end])
+;;; (string-every char-set/char/pred s [start end])
+;;; (string-any char-set/char/pred s [start end])
+;;; (string-tabulate len proc)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; You want compiler support for high-level transforms on fold and unfold ops.
+;;; You'd at least like a lot of inlining for clients of these procedures.
+;;; Don't hold your breath.
+
+;;; Shut up, Olin (flw)
+
+(define (string-map proc s . maybe-start+end)
+; (check-arg procedure? proc string-map)
+ (let-string-start+end (start end) string-map s maybe-start+end
+ (%string-map proc s start end)))
+
+(define (%string-map proc s start end) ; Internal utility
+ (let* ((len (- end start))
+ (ans (make-string len)))
+ (do ((i 0 (+ i 1))
+ (j start (+ j 1)))
+ ((>= i len))
+ (string-set! ans i (proc (string-ref s j))))
+ ans))
+
+(define (string-map! proc s . maybe-start+end)
+; (check-arg procedure? proc string-map!)
+ (let-string-start+end (start end) string-map! s maybe-start+end
+ (%string-map! proc s start end)))
+
+(define (%string-map! proc s start end)
+ (do ((i start (+ i 1)))
+ ((>= i end) s)
+ (string-set! s i (proc (string-ref s i)))))
+
+(define (string-fold kons knil s . maybe-start+end)
+; (check-arg procedure? kons string-fold)
+ (let-string-start+end (start end) string-fold s maybe-start+end
+ (let lp ((v knil) (i start))
+ (if (< i end) (lp (kons (string-ref s i) v) (+ i 1))
+ v))))
+
+(define (string-fold-right kons knil s . maybe-start+end)
+; (check-arg procedure? kons string-fold-right)
+ (let-string-start+end (start end) string-fold-right s maybe-start+end
+ (let lp ((v knil) (i (- end 1)))
+ (if (>= i start) (lp (kons (string-ref s i) v) (- i 1))
+ v))))
+
+;;; (string-unfold p f g seed [base make-final])
+;;; This is the fundamental constructor for strings.
+;;; - G is used to generate a series of "seed" values from the initial seed:
+;;; SEED, (G SEED), (G^2 SEED), (G^3 SEED), ...
+;;; - P tells us when to stop -- when it returns true when applied to one
+;;; of these seed values.
+;;; - F maps each seed value to the corresponding character
+;;; in the result string. These chars are assembled into the
+;;; string in a left-to-right order.
+;;; - BASE is the optional initial/leftmost portion of the constructed string;
+;;; it defaults to the empty string "".
+;;; - MAKE-FINAL is applied to the terminal seed value (on which P returns
+;;; true) to produce the final/rightmost portion of the constructed string.
+;;; It defaults to (LAMBDA (X) "").
+;;;
+;;; In other words, the following (simple, inefficient) definition holds:
+;;; (define (string-unfold p f g seed base make-final)
+;;; (string-append base
+;;; (let recur ((seed seed))
+;;; (if (p seed) (make-final seed)
+;;; (string-append (string (f seed))
+;;; (recur (g seed)))))))
+;;;
+;;; STRING-UNFOLD is a fairly powerful constructor -- you can use it to
+;;; reverse a string, copy a string, convert a list to a string, read
+;;; a port into a string, and so forth. Examples:
+;;; (port->string port) =
+;;; (string-unfold (compose eof-object? peek-char)
+;;; read-char values port)
+;;;
+;;; (list->string lis) = (string-unfold null? car cdr lis)
+;;;
+;;; (tabulate-string f size) = (string-unfold (lambda (i) (= i size)) f add1 0)
+
+;;; A problem with the following simple formulation is that it pushes one
+;;; stack frame for every char in the result string -- an issue if you are
+;;; using it to read a 100kchar string. So we don't use it -- but I include
+;;; it to give a clear, straightforward description of what the function
+;;; does.
+
+;(define (string-unfold p f g seed base make-final)
+; (let ((ans (let recur ((seed seed) (i (string-length base)))
+; (if (p seed)
+; (let* ((final (make-final seed))
+; (ans (make-string (+ i (string-length final)))))
+; (string-copy! ans i final)
+; ans)
+;
+; (let* ((c (f seed))
+; (s (recur (g seed) (+ i 1))))
+; (string-set! s i c)
+; s)))))
+; (string-copy! ans 0 base)
+; ans))
+
+;;; The strategy is to allocate a series of chunks into which we stash the
+;;; chars as we generate them. Chunk size goes up in powers of two starting
+;;; with 40 and levelling out at 4k, i.e.
+;;; 40 40 80 160 320 640 1280 2560 4096 4096 4096 4096 4096...
+;;; This should work pretty well for short strings, 1-line (80 char) strings,
+;;; and longer ones. When done, we allocate an answer string and copy the
+;;; chars over from the chunk buffers.
+
+(define (string-unfold p f g seed . base+make-final)
+; (check-arg procedure? p string-unfold)
+; (check-arg procedure? f string-unfold)
+; (check-arg procedure? g string-unfold)
+ (let-optionals* base+make-final
+ ((base "") ; (string? base))
+ (make-final (lambda (x) ""))) ;(procedure? make-final)))
+ (let lp ((chunks '()) ; Previously filled chunks
+ (nchars 0) ; Number of chars in CHUNKS
+ (chunk (make-string 40)) ; Current chunk into which we write
+ (chunk-len 40)
+ (i 0) ; Number of chars written into CHUNK
+ (seed seed))
+ (let lp2 ((i i) (seed seed))
+ (if (not (p seed))
+ (let ((c (f seed))
+ (seed (g seed)))
+ (if (< i chunk-len)
+ (begin (string-set! chunk i c)
+ (lp2 (+ i 1) seed))
+
+ (let* ((nchars2 (+ chunk-len nchars))
+ (chunk-len2 (min 4096 nchars2))
+ (new-chunk (make-string chunk-len2)))
+ (string-set! new-chunk 0 c)
+ (lp (cons chunk chunks) (+ nchars chunk-len)
+ new-chunk chunk-len2 1 seed))))
+
+ ;; We're done. Make the answer string & install the bits.
+ (let* ((final (make-final seed))
+ (flen (string-length final))
+ (base-len (string-length base))
+ (j (+ base-len nchars i))
+ (ans (make-string (+ j flen))))
+ (%string-copy! ans j final 0 flen) ; Install FINAL.
+ (let ((j (- j i)))
+ (%string-copy! ans j chunk 0 i) ; Install CHUNK[0,I).
+ (let lp ((j j) (chunks chunks)) ; Install CHUNKS.
+ (if (pair? chunks)
+ (let* ((chunk (car chunks))
+ (chunks (cdr chunks))
+ (chunk-len (string-length chunk))
+ (j (- j chunk-len)))
+ (%string-copy! ans j chunk 0 chunk-len)
+ (lp j chunks)))))
+ (%string-copy! ans 0 base 0 base-len) ; Install BASE.
+ ans))))))
+
+(define (string-unfold-right p f g seed . base+make-final)
+ (let-optionals* base+make-final
+ ((base ""); (string? base))
+ (make-final (lambda (x) ""))); (procedure? make-final)))
+ (let lp ((chunks '()) ; Previously filled chunks
+ (nchars 0) ; Number of chars in CHUNKS
+ (chunk (make-string 40)) ; Current chunk into which we write
+ (chunk-len 40)
+ (i 40) ; Number of chars available in CHUNK
+ (seed seed))
+ (let lp2 ((i i) (seed seed)) ; Fill up CHUNK from right
+ (if (not (p seed)) ; to left.
+ (let ((c (f seed))
+ (seed (g seed)))
+ (if (> i 0)
+ (let ((i (- i 1)))
+ (string-set! chunk i c)
+ (lp2 i seed))
+
+ (let* ((nchars2 (+ chunk-len nchars))
+ (chunk-len2 (min 4096 nchars2))
+ (new-chunk (make-string chunk-len2))
+ (i (- chunk-len2 1)))
+ (string-set! new-chunk i c)
+ (lp (cons chunk chunks) (+ nchars chunk-len)
+ new-chunk chunk-len2 i seed))))
+
+ ;; We're done. Make the answer string & install the bits.
+ (let* ((final (make-final seed))
+ (flen (string-length final))
+ (base-len (string-length base))
+ (chunk-used (- chunk-len i))
+ (j (+ base-len nchars chunk-used))
+ (ans (make-string (+ j flen))))
+ (%string-copy! ans 0 final 0 flen) ; Install FINAL.
+ (%string-copy! ans flen chunk i chunk-len); Install CHUNK[I,).
+ (let lp ((j (+ flen chunk-used)) ; Install CHUNKS.
+ (chunks chunks))
+ (if (pair? chunks)
+ (let* ((chunk (car chunks))
+ (chunks (cdr chunks))
+ (chunk-len (string-length chunk)))
+ (%string-copy! ans j chunk 0 chunk-len)
+ (lp (+ j chunk-len) chunks))
+ (%string-copy! ans j base 0 base-len))); Install BASE.
+ ans))))))
+
+
+(define (string-for-each proc s . maybe-start+end)
+; (check-arg procedure? proc string-for-each)
+ (let-string-start+end (start end) string-for-each s maybe-start+end
+ (let lp ((i start))
+ (if (< i end)
+ (begin (proc (string-ref s i))
+ (lp (+ i 1)))))))
+
+(define (string-for-each-index proc s . maybe-start+end)
+; (check-arg procedure? proc string-for-each-index)
+ (let-string-start+end (start end) string-for-each-index s maybe-start+end
+ (let lp ((i start))
+ (if (< i end) (begin (proc i) (lp (+ i 1)))))))
+
+(define (string-every criteria s . maybe-start+end)
+ (let-string-start+end (start end) string-every s maybe-start+end
+ (cond ((char? criteria)
+ (let lp ((i start))
+ (or (>= i end)
+ (and (char=? criteria (string-ref s i))
+ (lp (+ i 1))))))
+
+ ((char-set? criteria)
+ (let lp ((i start))
+ (or (>= i end)
+ (and (char-set-contains? criteria (string-ref s i))
+ (lp (+ i 1))))))
+
+ ((procedure? criteria) ; Slightly funky loop so that
+ (or (= start end) ; final (PRED S[END-1]) call
+ (let lp ((i start)) ; is a tail call.
+ (let ((c (string-ref s i))
+ (i1 (+ i 1)))
+ (if (= i1 end) (criteria c) ; Tail call.
+ (and (criteria c) (lp i1)))))))
+
+ (else (##sys#error 'string-every "Second param is neither char-set, char, or predicate procedure."
+ string-every criteria)))))
+
+
+(define (string-any criteria s . maybe-start+end)
+ (let-string-start+end (start end) string-any s maybe-start+end
+ (cond ((char? criteria)
+ (let lp ((i start))
+ (and (< i end)
+ (or (char=? criteria (string-ref s i))
+ (lp (+ i 1))))))
+
+ ((char-set? criteria)
+ (let lp ((i start))
+ (and (< i end)
+ (or (char-set-contains? criteria (string-ref s i))
+ (lp (+ i 1))))))
+
+ ((procedure? criteria) ; Slightly funky loop so that
+ (and (< start end) ; final (PRED S[END-1]) call
+ (let lp ((i start)) ; is a tail call.
+ (let ((c (string-ref s i))
+ (i1 (+ i 1)))
+ (if (= i1 end) (criteria c) ; Tail call
+ (or (criteria c) (lp i1)))))))
+
+ (else (##sys#error 'string-any "Second param is neither char-set, char, or predicate procedure."
+ string-any criteria)))))
+
+
+(define (string-tabulate proc len)
+; (check-arg procedure? proc string-tabulate)
+; (check-arg (lambda (val) (and (integer? val) (exact? val) (<= 0 val)))
+; len string-tabulate)
+ (##sys#check-exact len 'string-tabulate)
+ (let ((s (make-string len)))
+ (do ((i (- len 1) (- i 1)))
+ ((< i 0))
+ (string-set! s i (proc i)))
+ s))
+
+
+
+;;; string-prefix-length[-ci] s1 s2 [start1 end1 start2 end2]
+;;; string-suffix-length[-ci] s1 s2 [start1 end1 start2 end2]
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Find the length of the common prefix/suffix.
+;;; It is not required that the two substrings passed be of equal length.
+;;; This was microcode in MIT Scheme -- a very tightly bummed primitive.
+;;; %STRING-PREFIX-LENGTH is the core routine of all string-comparisons,
+;;; so should be as tense as possible.
+
+(define (%string-prefix-length s1 start1 end1 s2 start2 end2)
+ (let* ((delta (min (- end1 start1) (- end2 start2)))
+ (end1 (+ start1 delta)))
+
+ (if (and (eq? s1 s2) (= start1 start2)) ; EQ fast path
+ delta
+
+ (let lp ((i start1) (j start2)) ; Regular path
+ (if (or (>= i end1)
+ (not (char=? (string-ref s1 i)
+ (string-ref s2 j))))
+ (- i start1)
+ (lp (+ i 1) (+ j 1)))))))
+
+(define (%string-suffix-length s1 start1 end1 s2 start2 end2)
+ (let* ((delta (min (- end1 start1) (- end2 start2)))
+ (start1 (- end1 delta)))
+
+ (if (and (eq? s1 s2) (= end1 end2)) ; EQ fast path
+ delta
+
+ (let lp ((i (- end1 1)) (j (- end2 1))) ; Regular path
+ (if (or (< i start1)
+ (not (char=? (string-ref s1 i)
+ (string-ref s2 j))))
+ (- (- end1 i) 1)
+ (lp (- i 1) (- j 1)))))))
+
+(define (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)
+ (let* ((delta (min (- end1 start1) (- end2 start2)))
+ (end1 (+ start1 delta)))
+
+ (if (and (eq? s1 s2) (= start1 start2)) ; EQ fast path
+ delta
+
+ (let lp ((i start1) (j start2)) ; Regular path
+ (if (or (>= i end1)
+ (not (char-ci=? (string-ref s1 i)
+ (string-ref s2 j))))
+ (- i start1)
+ (lp (+ i 1) (+ j 1)))))))
+
+(define (%string-suffix-length-ci s1 start1 end1 s2 start2 end2)
+ (let* ((delta (min (- end1 start1) (- end2 start2)))
+ (start1 (- end1 delta)))
+
+ (if (and (eq? s1 s2) (= end1 end2)) ; EQ fast path
+ delta
+
+ (let lp ((i (- end1 1)) (j (- end2 1))) ; Regular path
+ (if (or (< i start1)
+ (not (char-ci=? (string-ref s1 i)
+ (string-ref s2 j))))
+ (- (- end1 i) 1)
+ (lp (- i 1) (- j 1)))))))
+
+
+(define (string-prefix-length s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-prefix-length s1 s2 maybe-starts+ends
+ (%string-prefix-length s1 start1 end1 s2 start2 end2)))
+
+(define (string-suffix-length s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-suffix-length s1 s2 maybe-starts+ends
+ (%string-suffix-length s1 start1 end1 s2 start2 end2)))
+
+(define (string-prefix-length-ci s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-prefix-length-ci s1 s2 maybe-starts+ends
+ (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)))
+
+(define (string-suffix-length-ci s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-suffix-length-ci s1 s2 maybe-starts+ends
+ (%string-suffix-length-ci s1 start1 end1 s2 start2 end2)))
+
+
+;;; string-prefix? s1 s2 [start1 end1 start2 end2]
+;;; string-suffix? s1 s2 [start1 end1 start2 end2]
+;;; string-prefix-ci? s1 s2 [start1 end1 start2 end2]
+;;; string-suffix-ci? s1 s2 [start1 end1 start2 end2]
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; These are all simple derivatives of the previous counting funs.
+
+(define (string-prefix? s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-prefix? s1 s2 maybe-starts+ends
+ (%string-prefix? s1 start1 end1 s2 start2 end2)))
+
+(define (string-suffix? s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-suffix? s1 s2 maybe-starts+ends
+ (%string-suffix? s1 start1 end1 s2 start2 end2)))
+
+(define (string-prefix-ci? s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-prefix-ci? s1 s2 maybe-starts+ends
+ (%string-prefix-ci? s1 start1 end1 s2 start2 end2)))
+
+(define (string-suffix-ci? s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-suffix-ci? s1 s2 maybe-starts+ends
+ (%string-suffix-ci? s1 start1 end1 s2 start2 end2)))
+
+
+;;; Here are the internal routines that do the real work.
+
+(define (%string-prefix? s1 start1 end1 s2 start2 end2)
+ (let ((len1 (- end1 start1)))
+ (and (<= len1 (- end2 start2)) ; Quick check
+ (= (%string-prefix-length s1 start1 end1
+ s2 start2 end2)
+ len1))))
+
+(define (%string-suffix? s1 start1 end1 s2 start2 end2)
+ (let ((len1 (- end1 start1)))
+ (and (<= len1 (- end2 start2)) ; Quick check
+ (= len1 (%string-suffix-length s1 start1 end1
+ s2 start2 end2)))))
+
+(define (%string-prefix-ci? s1 start1 end1 s2 start2 end2)
+ (let ((len1 (- end1 start1)))
+ (and (<= len1 (- end2 start2)) ; Quick check
+ (= len1 (%string-prefix-length-ci s1 start1 end1
+ s2 start2 end2)))))
+
+(define (%string-suffix-ci? s1 start1 end1 s2 start2 end2)
+ (let ((len1 (- end1 start1)))
+ (and (<= len1 (- end2 start2)) ; Quick check
+ (= len1 (%string-suffix-length-ci s1 start1 end1
+ s2 start2 end2)))))
+
+
+;;; string-compare s1 s2 proc< proc= proc> [start1 end1 start2 end2]
+;;; string-compare-ci s1 s2 proc< proc= proc> [start1 end1 start2 end2]
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Primitive string-comparison functions.
+;;; Continuation order is different from MIT Scheme.
+;;; Continuations are applied to s1's mismatch index;
+;;; in the case of equality, this is END1.
+
+(define (%string-compare s1 start1 end1 s2 start2 end2
+ proc< proc= proc>)
+ (let ((size1 (- end1 start1))
+ (size2 (- end2 start2)))
+ (let ((match (%string-prefix-length s1 start1 end1 s2 start2 end2)))
+ (if (= match size1)
+ ((if (= match size2) proc= proc<) end1)
+ ((if (= match size2)
+ proc>
+ (if (char<? (string-ref s1 (+ start1 match))
+ (string-ref s2 (+ start2 match)))
+ proc< proc>))
+ (+ match start1))))))
+
+(define (%string-compare-ci s1 start1 end1 s2 start2 end2
+ proc< proc= proc>)
+ (let ((size1 (- end1 start1))
+ (size2 (- end2 start2)))
+ (let ((match (%string-prefix-length-ci s1 start1 end1 s2 start2 end2)))
+ (if (= match size1)
+ ((if (= match size2) proc= proc<) end1)
+ ((if (= match size2) proc>
+ (if (char-ci<? (string-ref s1 (+ start1 match))
+ (string-ref s2 (+ start2 match)))
+ proc< proc>))
+ (+ start1 match))))))
+
+(define (string-compare s1 s2 proc< proc= proc> . maybe-starts+ends)
+; (check-arg procedure? proc< string-compare)
+; (check-arg procedure? proc= string-compare)
+; (check-arg procedure? proc> string-compare)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-compare s1 s2 maybe-starts+ends
+ (%string-compare s1 start1 end1 s2 start2 end2 proc< proc= proc>)))
+
+(define (string-compare-ci s1 s2 proc< proc= proc> . maybe-starts+ends)
+; (check-arg procedure? proc< string-compare-ci)
+; (check-arg procedure? proc= string-compare-ci)
+; (check-arg procedure? proc> string-compare-ci)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-compare-ci s1 s2 maybe-starts+ends
+ (%string-compare-ci s1 start1 end1 s2 start2 end2 proc< proc= proc>)))
+
+
+
+;;; string= string<> string-ci= string-ci<>
+;;; string< string> string-ci< string-ci>
+;;; string<= string>= string-ci<= string-ci>=
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Simple definitions in terms of the previous comparison funs.
+;;; I sure hope the %STRING-COMPARE calls get integrated.
+
+(define (string= s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string= s1 s2 maybe-starts+ends
+ (and (= (- end1 start1) (- end2 start2)) ; Quick filter
+ (or (and (eq? s1 s2) (= start1 start2)) ; Fast path
+ (%string-compare s1 start1 end1 s2 start2 end2 ; Real test
+ (lambda (i) #f)
+ values
+ (lambda (i) #f))))))
+
+(define (string<> s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string<> s1 s2 maybe-starts+ends
+ (or (not (= (- end1 start1) (- end2 start2))) ; Fast path
+ (and (not (and (eq? s1 s2) (= start1 start2))) ; Quick filter
+ (%string-compare s1 start1 end1 s2 start2 end2 ; Real test
+ values
+ (lambda (i) #f)
+ values)))))
+
+(define (string< s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string< s1 s2 maybe-starts+ends
+ (if (and (eq? s1 s2) (= start1 start2)) ; Fast path
+ (< end1 end2)
+
+ (%string-compare s1 start1 end1 s2 start2 end2 ; Real test
+ values
+ (lambda (i) #f)
+ (lambda (i) #f)))))
+
+(define (string> s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string> s1 s2 maybe-starts+ends
+ (if (and (eq? s1 s2) (= start1 start2)) ; Fast path
+ (> end1 end2)
+
+ (%string-compare s1 start1 end1 s2 start2 end2 ; Real test
+ (lambda (i) #f)
+ (lambda (i) #f)
+ values))))
+
+(define (string<= s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string<= s1 s2 maybe-starts+ends
+ (if (and (eq? s1 s2) (= start1 start2)) ; Fast path
+ (<= end1 end2)
+
+ (%string-compare s1 start1 end1 s2 start2 end2 ; Real test
+ values
+ values
+ (lambda (i) #f)))))
+
+(define (string>= s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string>= s1 s2 maybe-starts+ends
+ (if (and (eq? s1 s2) (= start1 start2)) ; Fast path
+ (>= end1 end2)
+
+ (%string-compare s1 start1 end1 s2 start2 end2 ; Real test
+ (lambda (i) #f)
+ values
+ values))))
+
+(define (string-ci= s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-ci= s1 s2 maybe-starts+ends
+ (and (= (- end1 start1) (- end2 start2)) ; Quick filter
+ (or (and (eq? s1 s2) (= start1 start2)) ; Fast path
+ (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test
+ (lambda (i) #f)
+ values
+ (lambda (i) #f))))))
+
+(define (string-ci<> s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-ci<> s1 s2 maybe-starts+ends
+ (or (not (= (- end1 start1) (- end2 start2))) ; Fast path
+ (and (not (and (eq? s1 s2) (= start1 start2))) ; Quick filter
+ (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test
+ values
+ (lambda (i) #f)
+ values)))))
+
+(define (string-ci< s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-ci< s1 s2 maybe-starts+ends
+ (if (and (eq? s1 s2) (= start1 start2)) ; Fast path
+ (< end1 end2)
+
+ (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test
+ values
+ (lambda (i) #f)
+ (lambda (i) #f)))))
+
+(define (string-ci> s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-ci> s1 s2 maybe-starts+ends
+ (if (and (eq? s1 s2) (= start1 start2)) ; Fast path
+ (> end1 end2)
+
+ (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test
+ (lambda (i) #f)
+ (lambda (i) #f)
+ values))))
+
+(define (string-ci<= s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-ci<= s1 s2 maybe-starts+ends
+ (if (and (eq? s1 s2) (= start1 start2)) ; Fast path
+ (<= end1 end2)
+
+ (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test
+ values
+ values
+ (lambda (i) #f)))))
+
+(define (string-ci>= s1 s2 . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-ci>= s1 s2 maybe-starts+ends
+ (if (and (eq? s1 s2) (= start1 start2)) ; Fast path
+ (>= end1 end2)
+
+ (%string-compare-ci s1 start1 end1 s2 start2 end2 ; Real test
+ (lambda (i) #f)
+ values
+ values))))
+
+
+;;; Hash
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Compute (c + 37 c + 37^2 c + ...) modulo BOUND.
+;;; If you keep BOUND small enough, the intermediate calculations will
+;;; always be fixnums. How small is dependent on the underlying Scheme system;
+;;; we use a default BOUND of 2^22 = 4194304, which should hack it in
+;;; Schemes that give you at least 29 signed bits for fixnums. The core
+;;; calculation that you don't want to overflow is, worst case,
+;;; (+ 65535 (* 37 (- bound 1)))
+;;; where 65535 is the max character code. Choose the default BOUND to be the
+;;; biggest power of two that won't cause this expression to fixnum overflow,
+;;; and everything will be copacetic.
+
+(define (%string-hash s char->int bound start end)
+ (let ((iref (lambda (s i) (char->int (string-ref s i))))
+ ;; Compute a 111...1 mask that will cover BOUND-1:
+ (mask (let lp ((i #x10000)) ; Let's skip first 16 iterations, eh?
+ (if (>= i bound) (- i 1) (lp (+ i i))))))
+ (let lp ((i start) (ans 0))
+ (if (>= i end) (modulo ans bound)
+ (lp (+ i 1) (fxand mask (+ (* 37 ans) (iref s i))))))))
+
+(define (string-hash s . maybe-bound+start+end)
+ (let-optionals* maybe-bound+start+end ((bound 4194304); (and (integer? bound)
+ ; (exact? bound)
+ ; (<= 0 bound)))
+ rest)
+ (if (zero? bound) (set! bound 4194304))
+ (##sys#check-exact bound 'string-hash)
+ (let-string-start+end (start end) string-hash s rest
+ (%string-hash s char->integer bound start end))))
+
+(define (string-hash-ci s . maybe-bound+start+end)
+ (let-optionals* maybe-bound+start+end ((bound 4194304) ;(and (integer? bound)
+ ; (exact? bound)
+ ; (<= 0 bound)))
+ rest)
+ (if (zero? bound) (set! bound 4194304))
+ (##sys#check-exact bound 'string-hash-ci)
+ (let-string-start+end (start end) string-hash-ci s rest
+ (%string-hash s (lambda (c) (char->integer (char-downcase c)))
+ bound start end))))
+
+;;; Case hacking
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; string-upcase s [start end]
+;;; string-upcase! s [start end]
+;;; string-downcase s [start end]
+;;; string-downcase! s [start end]
+;;;
+;;; string-titlecase s [start end]
+;;; string-titlecase! s [start end]
+;;; Capitalize every contiguous alpha sequence: capitalise
+;;; first char, lowercase rest.
+
+(define (string-upcase s . maybe-start+end)
+ (let-string-start+end (start end) string-upcase s maybe-start+end
+ (%string-map char-upcase s start end)))
+
+(define (string-upcase! s . maybe-start+end)
+ (let-string-start+end (start end) string-upcase! s maybe-start+end
+ (%string-map! char-upcase s start end)))
+
+(define (string-downcase s . maybe-start+end)
+ (let-string-start+end (start end) string-downcase s maybe-start+end
+ (%string-map char-downcase s start end)))
+
+(define (string-downcase! s . maybe-start+end)
+ (let-string-start+end (start end) string-downcase! s maybe-start+end
+ (%string-map! char-downcase s start end)))
+
+(define (%string-titlecase! s start end)
+ (let lp ((i start))
+ (cond ((string-index s char-cased? i end) =>
+ (lambda (i)
+ (string-set! s i (char-titlecase (string-ref s i)))
+ (let ((i1 (+ i 1)))
+ (cond ((string-skip s char-cased? i1 end) =>
+ (lambda (j)
+ (string-downcase! s i1 j)
+ (lp (+ j 1))))
+ (else (string-downcase! s i1 end)))))))))
+
+(define (string-titlecase! s . maybe-start+end)
+ (let-string-start+end (start end) string-titlecase! s maybe-start+end
+ (%string-titlecase! s start end)))
+
+(define (string-titlecase s . maybe-start+end)
+ (let-string-start+end (start end) string-titlecase! s maybe-start+end
+ (let ((ans (##sys#substring s start end)))
+ (%string-titlecase! ans 0 (- end start))
+ ans)))
+
+
+;;; Cutting & pasting strings
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; string-take string nchars
+;;; string-drop string nchars
+;;;
+;;; string-take-right string nchars
+;;; string-drop-right string nchars
+;;;
+;;; string-pad string k [char start end]
+;;; string-pad-right string k [char start end]
+;;;
+;;; string-trim string [char/char-set/pred start end]
+;;; string-trim-right string [char/char-set/pred start end]
+;;; string-trim-both string [char/char-set/pred start end]
+;;;
+;;; These trimmers invert the char-set meaning from MIT Scheme -- you
+;;; say what you want to trim.
+
+(define (string-take s n)
+; (check-arg string? s string-take)
+; (check-arg (lambda (val) (and (integer? n) (exact? n)
+; (<= 0 n (string-length s))))
+; n string-take)
+ (##sys#check-string s 'string-take)
+ (##sys#check-range n 0 (fx+ 1 (##sys#size s)) 'string-take)
+ (%substring/shared s 0 n))
+
+(define (string-take-right s n)
+; (check-arg string? s string-take-right)
+ (##sys#check-string s 'string-take-right)
+ (##sys#check-range n 0 (fx+ 1 (##sys#size s)) 'string-take-right)
+ (let ((len (##sys#size s)))
+; (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
+; n string-take-right)
+ (%substring/shared s (- len n) len)))
+
+(define (string-drop s n)
+; (check-arg string? s string-drop)
+ (##sys#check-string s 'string-drop)
+ (##sys#check-range n 0 (fx+ 1 (##sys#size s)) 'string-drop)
+ (let ((len (##sys#size s)))
+; (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
+; n string-drop)
+ (%substring/shared s n len)))
+
+(define (string-drop-right s n)
+; (check-arg string? s string-drop-right)
+ (##sys#check-string s 'string-drop-right)
+ (##sys#check-range n 0 (fx+ 1 (##sys#size s)) 'string-drop-right)
+ (let ((len (##sys#size s)))
+; (check-arg (lambda (val) (and (integer? n) (exact? n) (<= 0 n len)))
+; n string-drop-right)
+ (%substring/shared s 0 (- len n))))
+
+
+(define (string-trim s . criteria+start+end)
+ (let-optionals* criteria+start+end ((criteria char-set:whitespace) rest)
+ (let-string-start+end (start end) string-trim s rest
+ (cond ((string-skip s criteria start end) =>
+ (lambda (i) (%substring/shared s i end)))
+ (else "")))))
+
+(define (string-trim-right s . criteria+start+end)
+ (let-optionals* criteria+start+end ((criteria char-set:whitespace) rest)
+ (let-string-start+end (start end) string-trim-right s rest
+ (cond ((string-skip-right s criteria start end) =>
+ (lambda (i) (%substring/shared s 0 (+ 1 i))))
+ (else "")))))
+
+(define (string-trim-both s . criteria+start+end)
+ (let-optionals* criteria+start+end ((criteria char-set:whitespace) rest)
+ (let-string-start+end (start end) string-trim-both s rest
+ (cond ((string-skip s criteria start end) =>
+ (lambda (i)
+ (%substring/shared s i (+ 1 (string-skip-right s criteria i end)))))
+ (else "")))))
+
+
+(define (string-pad-right s n . char+start+end)
+ (##sys#check-exact n 'string-pad-right)
+ (let-optionals* char+start+end ((char #\space) rest) ; (char? char)) rest)
+ (let-string-start+end (start end) string-pad-right s rest
+ (let ((len (- end start)))
+ (if (<= n len)
+ (%substring/shared s start (+ start n))
+ (let ((ans (make-string n char)))
+ (%string-copy! ans 0 s start end)
+ ans))))))
+
+(define (string-pad s n . char+start+end)
+ (##sys#check-exact n 'string-pad)
+ (let-optionals* char+start+end ((char #\space) rest) ; (char? char)) rest)
+ (let-string-start+end (start end) string-pad s rest
+ (let ((len (- end start)))
+ (if (<= n len)
+ (%substring/shared s (- end n) end)
+ (let ((ans (make-string n char)))
+ (%string-copy! ans (- n len) s start end)
+ ans))))))
+
+
+
+;;; Filtering strings
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; string-delete char/char-set/pred string [start end]
+;;; string-filter char/char-set/pred string [start end]
+;;;
+;;; If the criteria is a char or char-set, we scan the string twice with
+;;; string-fold -- once to determine the length of the result string,
+;;; and once to do the filtered copy.
+;;; If the criteria is a predicate, we don't do this double-scan strategy,
+;;; because the predicate might have side-effects or be very expensive to
+;;; compute. So we preallocate a temp buffer pessimistically, and only do
+;;; one scan over S. This is likely to be faster and more space-efficient
+;;; than consing a list.
+
+(define (string-delete criteria s . maybe-start+end)
+ (let-string-start+end (start end) string-delete s maybe-start+end
+ (if (procedure? criteria)
+ (let* ((slen (- end start))
+ (temp (make-string slen))
+ (ans-len (string-fold (lambda (c i)
+ (if (criteria c) i
+ (begin (string-set! temp i c)
+ (+ i 1))))
+ 0 s start end)))
+ (if (= ans-len slen) temp (##sys#substring temp 0 ans-len)))
+
+ (let* ((cset (cond ((char-set? criteria) criteria)
+ ((char? criteria) (char-set criteria))
+ (else (##sys#error 'string-delete "string-delete criteria not predicate, char or char-set" criteria))))
+ (len (string-fold (lambda (c i) (if (char-set-contains? cset c)
+ i
+ (+ i 1)))
+ 0 s start end))
+ (ans (make-string len)))
+ (string-fold (lambda (c i) (if (char-set-contains? cset c)
+ i
+ (begin (string-set! ans i c)
+ (+ i 1))))
+ 0 s start end)
+ ans))))
+
+(define (string-filter criteria s . maybe-start+end)
+ (let-string-start+end (start end) string-filter s maybe-start+end
+ (if (procedure? criteria)
+ (let* ((slen (- end start))
+ (temp (make-string slen))
+ (ans-len (string-fold (lambda (c i)
+ (if (criteria c)
+ (begin (string-set! temp i c)
+ (+ i 1))
+ i))
+ 0 s start end)))
+ (if (= ans-len slen) temp (##sys#substring temp 0 ans-len)))
+
+ (let* ((cset (cond ((char-set? criteria) criteria)
+ ((char? criteria) (char-set criteria))
+ (else (##sys#error 'string-filter "string-delete criteria not predicate, char or char-set" criteria))))
+
+ (len (string-fold (lambda (c i) (if (char-set-contains? cset c)
+ (+ i 1)
+ i))
+ 0 s start end))
+ (ans (make-string len)))
+ (string-fold (lambda (c i) (if (char-set-contains? cset c)
+ (begin (string-set! ans i c)
+ (+ i 1))
+ i))
+ 0 s start end)
+ ans))))
+
+
+;;; String search
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; string-index string char/char-set/pred [start end]
+;;; string-index-right string char/char-set/pred [start end]
+;;; string-skip string char/char-set/pred [start end]
+;;; string-skip-right string char/char-set/pred [start end]
+;;; string-count char/char-set/pred string [start end]
+;;; There's a lot of replicated code here for efficiency.
+;;; For example, the char/char-set/pred discrimination has
+;;; been lifted above the inner loop of each proc.
+
+(define (string-index str criteria . maybe-start+end)
+ (let-string-start+end (start end) string-index str maybe-start+end
+ (cond ((char? criteria)
+ (let lp ((i start))
+ (and (< i end)
+ (if (char=? criteria (string-ref str i)) i
+ (lp (+ i 1))))))
+ ((char-set? criteria)
+ (let lp ((i start))
+ (and (< i end)
+ (if (char-set-contains? criteria (string-ref str i)) i
+ (lp (+ i 1))))))
+ ((procedure? criteria)
+ (let lp ((i start))
+ (and (< i end)
+ (if (criteria (string-ref str i)) i
+ (lp (+ i 1))))))
+ (else (##sys#error 'string-index "Second param is neither char-set, char, or predicate procedure."
+ string-index criteria)))))
+
+(define (string-index-right str criteria . maybe-start+end)
+ (let-string-start+end (start end) string-index-right str maybe-start+end
+ (cond ((char? criteria)
+ (let lp ((i (- end 1)))
+ (and (>= i 0)
+ (if (char=? criteria (string-ref str i)) i
+ (lp (- i 1))))))
+ ((char-set? criteria)
+ (let lp ((i (- end 1)))
+ (and (>= i 0)
+ (if (char-set-contains? criteria (string-ref str i)) i
+ (lp (- i 1))))))
+ ((procedure? criteria)
+ (let lp ((i (- end 1)))
+ (and (>= i 0)
+ (if (criteria (string-ref str i)) i
+ (lp (- i 1))))))
+ (else (##sys#error 'string-index-right "Second param is neither char-set, char, or predicate procedure."
+ string-index-right criteria)))))
+
+(define (string-skip str criteria . maybe-start+end)
+ (let-string-start+end (start end) string-skip str maybe-start+end
+ (cond ((char? criteria)
+ (let lp ((i start))
+ (and (< i end)
+ (if (char=? criteria (string-ref str i))
+ (lp (+ i 1))
+ i))))
+ ((char-set? criteria)
+ (let lp ((i start))
+ (and (< i end)
+ (if (char-set-contains? criteria (string-ref str i))
+ (lp (+ i 1))
+ i))))
+ ((procedure? criteria)
+ (let lp ((i start))
+ (and (< i end)
+ (if (criteria (string-ref str i)) (lp (+ i 1))
+ i))))
+ (else (##sys#error 'string-skip "Second param is neither char-set, char, or predicate procedure."
+ string-skip criteria)))))
+
+(define (string-skip-right str criteria . maybe-start+end)
+ (let-string-start+end (start end) string-skip-right str maybe-start+end
+ (cond ((char? criteria)
+ (let lp ((i (- end 1)))
+ (and (>= i 0)
+ (if (char=? criteria (string-ref str i))
+ (lp (- i 1))
+ i))))
+ ((char-set? criteria)
+ (let lp ((i (- end 1)))
+ (and (>= i 0)
+ (if (char-set-contains? criteria (string-ref str i))
+ (lp (- i 1))
+ i))))
+ ((procedure? criteria)
+ (let lp ((i (- end 1)))
+ (and (>= i 0)
+ (if (criteria (string-ref str i)) (lp (- i 1))
+ i))))
+ (else (##sys#error 'string-skip-right "CRITERIA param is neither char-set or char."
+ string-skip-right criteria)))))
+
+
+; [felix] Boooh! original code had "s" and "criteria" in the wrong order:
+
+(define (string-count s criteria . maybe-start+end)
+ (let-string-start+end (start end) string-count s maybe-start+end
+ (cond ((char? criteria)
+ (do ((i start (+ i 1))
+ (count 0 (if (char=? criteria (string-ref s i))
+ (+ count 1)
+ count)))
+ ((>= i end) count)))
+
+ ((char-set? criteria)
+ (do ((i start (+ i 1))
+ (count 0 (if (char-set-contains? criteria (string-ref s i))
+ (+ count 1)
+ count)))
+ ((>= i end) count)))
+
+ ((procedure? criteria)
+ (do ((i start (+ i 1))
+ (count 0 (if (criteria (string-ref s i)) (+ count 1) count)))
+ ((>= i end) count)))
+
+ (else (##sys#error 'string-count "CRITERIA param is neither char-set or char."
+ string-count criteria)))))
+
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; string-fill! string char [start end]
+;;;
+;;; string-copy! to tstart from [fstart fend]
+;;; Guaranteed to work, even if s1 eq s2.
+
+(define (string-fill! s char . maybe-start+end)
+; (check-arg char? char string-fill!)
+ (let-string-start+end (start end) string-fill! s maybe-start+end
+ (do ((i (- end 1) (- i 1)))
+ ((< i start))
+ (string-set! s i char))))
+
+(define (string-copy! to tstart from . maybe-fstart+fend)
+ (let-string-start+end (fstart fend) string-copy! from maybe-fstart+fend
+; (check-arg integer? tstart string-copy!)
+ (##sys#check-exact tstart 'string-copy!)
+ (check-substring-spec string-copy! to tstart (+ tstart (- fend fstart)))
+ (%string-copy! to tstart from fstart fend)))
+
+;;; Library-internal routine
+(define (%string-copy! to tstart from fstart fend)
+ (##core#inline "C_substring_copy" from to fstart fend tstart))
+
+
+;;; Returns starting-position in STRING or #f if not true.
+;;; This implementation is slow & simple. It is useful as a "spec" or for
+;;; comparison testing with fancier implementations.
+;;; See below for fast KMP version.
+
+(define (string-contains string substring . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-contains string substring maybe-starts+ends
+ (let* ((len (fx- end2 start2))
+ (i-bound (fx- end1 len)))
+ (let lp ((i start1))
+ (and (fx<= i i-bound)
+ (if (string= string substring i (fx+ i len) start2 end2)
+ i
+ (lp (fx+ i 1))))))))
+
+(define (string-contains-ci string substring . maybe-starts+ends)
+ (let-string-start+end2 (start1 end1 start2 end2)
+ string-contains string substring maybe-starts+ends
+ (let* ((len (fx- end2 start2))
+ (i-bound (fx- end1 len)))
+ (let lp ((i start1))
+ (and (fx<= i i-bound)
+ (if (string-ci= string substring i (fx+ i len) start2 end2)
+ i
+ (lp (fx+ i 1))))))))
+
+
+;;; Searching for an occurrence of a substring
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+; this is completely broken and was probably never tested. Thanks, Olin! (flw)
+
+
+;;; Knuth-Morris-Pratt string searching
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; See
+;;; "Fast pattern matching in strings"
+;;; SIAM J. Computing 6(2):323-350 1977
+;;; D. E. Knuth, J. H. Morris and V. R. Pratt
+;;; also described in
+;;; "Pattern matching in strings"
+;;; Alfred V. Aho
+;;; Formal Language Theory - Perspectives and Open Problems
+;;; Ronald V. Brook (editor)
+;;; This algorithm is O(m + n) where m and n are the
+;;; lengths of the pattern and string respectively
+
+
+;;; (make-kmp-restart-vector pattern [c= start end]) -> integer-vector
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Compute the KMP restart vector RV for string PATTERN. If
+;;; we have matched chars 0..i-1 of PATTERN against a search string S, and
+;;; PATTERN[i] doesn't match S[k], then reset i := RV[i], and try again to
+;;; match S[k]. If RV[i] = -1, then punt S[k] completely, and move on to
+;;; S[k+1] and PATTERN[0] -- no possible match of PAT[0..i] contains S[k].
+;;;
+;;; In other words, if you have matched the first i chars of PATTERN, but
+;;; the i+1'th char doesn't match, RV[i] tells you what the next-longest
+;;; prefix of PATTERN is that you have matched.
+;;;
+;;; - C= (default CHAR=?) is used to compare characters for equality.
+;;; Pass in CHAR-CI=? for case-folded string search.
+;;;
+;;; - START & END restrict the pattern to the indicated substring; the
+;;; returned vector will be of length END - START. The numbers stored
+;;; in the vector will be values in the range [0,END-START) -- that is,
+;;; they are valid indices into the restart vector; you have to add START
+;;; to them to use them as indices into PATTERN.
+;;;
+;;; I've split this out as a separate function in case other constant-string
+;;; searchers might want to use it.
+;;;
+;;; E.g.:
+;;; a b d a b x
+;;; #(-1 0 0 -1 1 2)
+
+(define (make-kmp-restart-vector pattern . maybe-c=+start+end)
+ (let-optionals* maybe-c=+start+end
+ ((c= char=?) rest) ; (procedure? c=))
+ (receive (rest2 start end) (string-parse-start+end make-kmp-restart-vector pattern rest)
+ (let* ((rvlen (- end start))
+ (rv (make-vector rvlen -1)))
+ (if (> rvlen 0)
+ (let ((rvlen-1 (- rvlen 1))
+ (c0 (string-ref pattern start)))
+
+ ;; Here's the main loop. We have set rv[0] ... rv[i].
+ ;; K = I + START -- it is the corresponding index into PATTERN.
+ (let lp1 ((i 0) (j -1) (k start))
+ (if (< i rvlen-1)
+
+ (let ((ck (string-ref pattern k)))
+ ;; lp2 invariant:
+ ;; pat[(k-j) .. k-1] matches pat[start .. start+j-1]
+ ;; or j = -1.
+ (let lp2 ((j j))
+
+ (cond ((= j -1)
+ (let ((i1 (+ i 1)))
+ (vector-set! rv i1 (if (c= ck c0) -1 0))
+ (lp1 i1 0 (+ k 1))))
+
+ ;; pat[(k-j) .. k] matches pat[start..start+j].
+ ((c= ck (string-ref pattern (+ j start)))
+ (let* ((i1 (+ 1 i))
+ (j1 (+ 1 j)))
+ (vector-set! rv i1 j1)
+ (lp1 i1 j1 (+ k 1))))
+
+ (else (lp2 (vector-ref rv j))))))))))
+ rv))))
+
+
+;;; We've matched I chars from PAT. C is the next char from the search string.
+;;; Return the new I after handling C.
+;;;
+;;; The pattern is (VECTOR-LENGTH RV) chars long, beginning at index PAT-START
+;;; in PAT (PAT-START is usually 0). The I chars of the pattern we've matched
+;;; are
+;;; PAT[PAT-START .. PAT-START + I].
+;;;
+;;; It's *not* an oversight that there is no friendly error checking or
+;;; defaulting of arguments. This is a low-level, inner-loop procedure
+;;; that we want integrated/inlined into the point of call.
+
+(define (kmp-step pat rv c i c= p-start)
+ (let lp ((i i))
+ (if (c= c (string-ref pat (+ i p-start))) ; Match =>
+ (+ i 1) ; Done.
+ (let ((i (vector-ref rv i))) ; Back up in PAT.
+ (if (= i -1) 0 ; Can't back up further.
+ (lp i)))))) ; Keep trying for match.
+
+;;; Zip through S[start,end), looking for a match of PAT. Assume we've
+;;; already matched the first I chars of PAT when we commence at S[start].
+;;; - <0: If we find a match *ending* at index J, return -J.
+;;; - >=0: If we get to the end of the S[start,end) span without finding
+;;; a complete match, return the number of chars from PAT we'd matched
+;;; when we ran off the end.
+;;;
+;;; This is useful for searching *across* buffers -- that is, when your
+;;; input comes in chunks of text. We hand-integrate the KMP-STEP loop
+;;; for speed.
+
+(define (string-kmp-partial-search pat rv s i . c=+p-start+s-start+s-end)
+; (check-arg vector? rv string-kmp-partial-search)
+ (let-optionals* c=+p-start+s-start+s-end
+ ((c= char=?) ; (procedure? c=))
+ (p-start 0) rest) ; (and (integer? p-start) (exact? p-start) (<= 0 p-start)))
+ (receive (rest2 s-start s-end) (string-parse-start+end string-kmp-partial-search s rest)
+ ;; Enough prelude. Here's the actual code.
+ (let ((patlen (vector-length rv)))
+ (let lp ((si s-start) ; An index into S.
+ (vi i)) ; An index into RV.
+ (cond ((= vi patlen) (- si)) ; Win.
+ ((= si s-end) vi) ; Ran off the end.
+ (else ; Match s[si] & loop.
+ (let ((c (string-ref s si)))
+ (lp (+ si 1)
+ (let lp2 ((vi vi)) ; This is just KMP-STEP.
+ (if (c= c (string-ref pat (+ vi p-start)))
+ (+ vi 1)
+ (let ((vi (vector-ref rv vi)))
+ (if (= vi -1) 0
+ (lp2 vi))))))))))))) )
+
+
+;;; Misc
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; (string-null? s)
+;;; (string-reverse s [start end])
+;;; (string-reverse! s [start end])
+;;; (reverse-list->string clist)
+;;; (string->list s [start end])
+
+(define (string-null? s) (##core#inline "C_i_string_null_p" s))
+
+(define (string-reverse s . maybe-start+end)
+ (let-string-start+end (start end) string-reverse s maybe-start+end
+ (let* ((len (- end start))
+ (ans (make-string len)))
+ (do ((i start (+ i 1))
+ (j (- len 1) (- j 1)))
+ ((< j 0))
+ (string-set! ans j (string-ref s i)))
+ ans)))
+
+(define (string-reverse! s . maybe-start+end)
+ (let-string-start+end (start end) string-reverse! s maybe-start+end
+ (do ((i (- end 1) (- i 1))
+ (j start (+ j 1)))
+ ((<= i j))
+ (let ((ci (string-ref s i)))
+ (string-set! s i (string-ref s j))
+ (string-set! s j ci)))))
+
+
+#| this is already available in library.scm:
+
+(define (reverse-list->string clist)
+ (let* ((len (length clist))
+ (s (make-string len)))
+ (do ((i (- len 1) (- i 1)) (clist clist (cdr clist)))
+ ((not (pair? clist)))
+ (string-set! s i (car clist)))
+ s))
+|#
+
+
+;(define (string->list s . maybe-start+end)
+; (apply string-fold-right cons '() s maybe-start+end))
+
+(define (string->list s . maybe-start+end)
+ (let-string-start+end (start end) string->list s maybe-start+end
+ (do ((i (- end 1) (- i 1))
+ (ans '() (cons (string-ref s i) ans)))
+ ((< i start) ans))))
+
+;;; Defined by R5RS, so commented out here.
+;(define (list->string lis) (string-unfold null? car cdr lis))
+
+
+;;; string-concatenate string-list -> string
+;;; string-concatenate/shared string-list -> string
+;;; string-append/shared s ... -> string
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; STRING-APPEND/SHARED has license to return a string that shares storage
+;;; with any of its arguments. In particular, if there is only one non-empty
+;;; string amongst its parameters, it is permitted to return that string as
+;;; its result. STRING-APPEND, by contrast, always allocates new storage.
+;;;
+;;; STRING-CONCATENATE & STRING-CONCATENATE/SHARED are passed a list of
+;;; strings, which they concatenate into a result string. STRING-CONCATENATE
+;;; always allocates a fresh string; STRING-CONCATENATE/SHARED may (or may
+;;; not) return a result that shares storage with any of its arguments. In
+;;; particular, if it is applied to a singleton list, it is permitted to
+;;; return the car of that list as its value.
+
+(define (string-append/shared . strings) (string-concatenate/shared strings))
+
+(define (string-concatenate/shared strings)
+ (let lp ((strings strings) (nchars 0) (first #f))
+ (cond ((pair? strings) ; Scan the args, add up total
+ (let* ((string (car strings)) ; length, remember 1st
+ (tail (cdr strings)) ; non-empty string.
+ (slen (string-length string)))
+ (if (zero? slen)
+ (lp tail nchars first)
+ (lp tail (+ nchars slen) (or first strings)))))
+
+ ((zero? nchars) "")
+
+ ;; Just one non-empty string! Return it.
+ ((= nchars (string-length (car first))) (car first))
+
+ (else (let ((ans (make-string nchars)))
+ (let lp ((strings first) (i 0))
+ (if (pair? strings)
+ (let* ((s (car strings))
+ (slen (string-length s)))
+ (%string-copy! ans i s 0 slen)
+ (lp (cdr strings) (+ i slen)))))
+ ans)))))
+
+
+; Alas, Scheme 48's APPLY blows up if you have many, many arguments.
+;(define (string-concatenate strings) (apply string-append strings))
+
+;;; Here it is written out. I avoid using REDUCE to add up string lengths
+;;; to avoid non-R5RS dependencies.
+(define (string-concatenate strings)
+ (let* ((total (do ((strings strings (cdr strings))
+ (i 0 (+ i (string-length (car strings)))))
+ ((not (pair? strings)) i)))
+ (ans (make-string total)))
+ (let lp ((i 0) (strings strings))
+ (if (pair? strings)
+ (let* ((s (car strings))
+ (slen (string-length s)))
+ (%string-copy! ans i s 0 slen)
+ (lp (+ i slen) (cdr strings)))))
+ ans))
+
+
+;;; Defined by R5RS, so commented out here.
+;(define (string-append . strings) (string-concatenate strings))
+
+;;; string-concatenate-reverse string-list [final-string end] -> string
+;;; string-concatenate-reverse/shared string-list [final-string end] -> string
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Return
+;;; (string-concatenate
+;;; (reverse
+;;; (cons (substring final-string 0 end) string-list)))
+
+(define (string-concatenate-reverse string-list . maybe-final+end)
+ (let-optionals* maybe-final+end ((final ""); (string? final))
+ (end (string-length final)) )
+; (and (integer? end)
+; (exact? end)
+; (<= 0 end (string-length final)))))
+ (##sys#check-exact end 'string-concatenate-reverse)
+ (let ((len (let lp ((sum 0) (lis string-list))
+ (if (pair? lis)
+ (lp (+ sum (string-length (car lis))) (cdr lis))
+ sum))))
+
+ (%finish-string-concatenate-reverse len string-list final end))))
+
+(define (string-concatenate-reverse/shared string-list . maybe-final+end)
+ (let-optionals* maybe-final+end ((final ""); (string? final))
+ (end (string-length final)))
+; (and (integer? end)
+; (exact? end)
+; (<= 0 end (string-length final)))))
+ (##sys#check-exact end 'string-concatenate-reverse/shared)
+ ;; Add up the lengths of all the strings in STRING-LIST; also get a
+ ;; pointer NZLIST into STRING-LIST showing where the first non-zero-length
+ ;; string starts.
+ (let lp ((len 0) (nzlist #f) (lis string-list))
+ (if (pair? lis)
+ (let ((slen (string-length (car lis))))
+ (lp (+ len slen)
+ (if (or nzlist (zero? slen)) nzlist lis)
+ (cdr lis)))
+
+ (cond ((zero? len) (substring/shared final 0 end))
+
+ ;; LEN > 0, so NZLIST is non-empty.
+
+ ((and (zero? end) (= len (string-length (car nzlist))))
+ (car nzlist))
+
+ (else (%finish-string-concatenate-reverse len nzlist final end)))))))
+
+(define (%finish-string-concatenate-reverse len string-list final end)
+ (let ((ans (make-string (+ end len))))
+ (%string-copy! ans len final 0 end)
+ (let lp ((i len) (lis string-list))
+ (if (pair? lis)
+ (let* ((s (car lis))
+ (lis (cdr lis))
+ (slen (string-length s))
+ (i (- i slen)))
+ (%string-copy! ans i s 0 slen)
+ (lp i lis))))
+ ans))
+
+
+
+
+;;; string-replace s1 s2 start1 end1 [start2 end2] -> string
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Replace S1[START1,END1) with S2[START2,END2).
+
+(define (string-replace s1 s2 start1 end1 . maybe-start+end)
+ (check-substring-spec string-replace s1 start1 end1)
+ (let-string-start+end (start2 end2) string-replace s2 maybe-start+end
+ (let* ((slen1 (string-length s1))
+ (sublen2 (- end2 start2))
+ (alen (+ (- slen1 (- end1 start1)) sublen2))
+ (ans (make-string alen)))
+ (%string-copy! ans 0 s1 0 start1)
+ (%string-copy! ans start1 s2 start2 end2)
+ (%string-copy! ans (+ start1 sublen2) s1 end1 slen1)
+ ans)))
+
+
+;;; string-tokenize s [token-set start end] -> list
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Break S up into a list of token strings, where a token is a maximal
+;;; non-empty contiguous sequence of chars belonging to TOKEN-SET.
+;;; (string-tokenize "hello, world") => ("hello," "world")
+
+(define (string-tokenize s . token-chars+start+end)
+ (let-optionals* token-chars+start+end
+ ((token-chars char-set:graphic) rest) ; (char-set? token-chars)) rest)
+ (let-string-start+end (start end) string-tokenize s rest
+ (let lp ((i end) (ans '()))
+ (cond ((and (< start i) (string-index-right s token-chars start i)) =>
+ (lambda (tend-1)
+ (let ((tend (+ 1 tend-1)))
+ (cond ((string-skip-right s token-chars start tend-1) =>
+ (lambda (tstart-1)
+ (lp tstart-1
+ (cons (##sys#substring s (+ 1 tstart-1) tend)
+ ans))))
+ (else (cons (##sys#substring s start tend) ans))))))
+ (else ans))))))
+
+
+;;; xsubstring s from [to start end] -> string
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; S is a string; START and END are optional arguments that demarcate
+;;; a substring of S, defaulting to 0 and the length of S (e.g., the whole
+;;; string). Replicate this substring up and down index space, in both the
+;; positive and negative directions. For example, if S = "abcdefg", START=3,
+;;; and END=6, then we have the conceptual bidirectionally-infinite string
+;;; ... d e f d e f d e f d e f d e f d e f d e f ...
+;;; ... -9 -8 -7 -6 -5 -4 -3 -2 -1 0 1 2 3 4 5 6 7 8 9 ...
+;;; XSUBSTRING returns the substring of this string beginning at index FROM,
+;;; and ending at TO (which defaults to FROM+(END-START)).
+;;;
+;;; You can use XSUBSTRING in many ways:
+;;; - To rotate a string left: (xsubstring "abcdef" 2) => "cdefab"
+;;; - To rotate a string right: (xsubstring "abcdef" -2) => "efabcd"
+;;; - To replicate a string: (xsubstring "abc" 0 7) => "abcabca"
+;;;
+;;; Note that
+;;; - The FROM/TO indices give a half-open range -- the characters from
+;;; index FROM up to, but not including index TO.
+;;; - The FROM/TO indices are not in terms of the index space for string S.
+;;; They are in terms of the replicated index space of the substring
+;;; defined by S, START, and END.
+;;;
+;;; It is an error if START=END -- although this is allowed by special
+;;; dispensation when FROM=TO.
+
+(define (xsubstring s from . maybe-to+start+end)
+; (check-arg (lambda (val) (and (integer? val) (exact? val)))
+; from xsubstring)
+ (##sys#check-exact from 'xsubstring)
+ (receive (to start end)
+ (if (pair? maybe-to+start+end)
+ (let-string-start+end (start end) xsubstring s (cdr maybe-to+start+end)
+ (let ((to (car maybe-to+start+end)))
+; (check-arg (lambda (val) (and (integer? val)
+; (exact? val)
+; (<= from val)))
+; to xsubstring)
+ (##sys#check-exact to 'xsubstring)
+ (values to start end)))
+; (let ((slen (string-length (check-arg string? s xsubstring))))
+ (let ((slen (string-length s)))
+ (values (+ from slen) 0 slen)))
+ (let ((slen (- end start))
+ (anslen (- to from)))
+ (cond ((zero? anslen) "")
+ ((zero? slen) (##sys#error 'xsubstring "Cannot replicate empty (sub)string"
+ xsubstring s from to start end))
+
+ ((= 1 slen) ; Fast path for 1-char replication.
+ (make-string anslen (string-ref s start)))
+
+ ;; Selected text falls entirely within one span.
+ ((= (floor (/ from slen)) (floor (/ to slen)))
+ (##sys#substring s (+ start (modulo from slen))
+ (+ start (modulo to slen))))
+
+ ;; Selected text requires multiple spans.
+ (else (let ((ans (make-string anslen)))
+ (%multispan-repcopy! ans 0 s from to start end)
+ ans))))))
+
+
+;;; string-xcopy! target tstart s sfrom [sto start end] -> unspecific
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Exactly the same as xsubstring, but the extracted text is written
+;;; into the string TARGET starting at index TSTART.
+;;; This operation is not defined if (EQ? TARGET S) -- you cannot copy
+;;; a string on top of itself.
+
+(define ##srfi13#string-fill! string-fill!) ; or we use std-binding.
+
+(define (string-xcopy! target tstart s sfrom . maybe-sto+start+end)
+; (check-arg (lambda (val) (and (integer? val) (exact? val)))
+; sfrom string-xcopy!)
+ (##sys#check-exact sfrom 'string-xcopy!)
+ (receive (sto start end)
+ (if (pair? maybe-sto+start+end)
+ (let-string-start+end (start end) string-xcopy! s (cdr maybe-sto+start+end)
+ (let ((sto (car maybe-sto+start+end)))
+; (check-arg (lambda (val) (and (integer? val) (exact? val)))
+; sto string-xcopy!)
+ (##sys#check-exact sto 'string-xcopy!)
+ (values sto start end)))
+ (let ((slen (string-length s)))
+ (values (+ sfrom slen) 0 slen)))
+
+ (let* ((tocopy (- sto sfrom))
+ (tend (+ tstart tocopy))
+ (slen (- end start)))
+ (check-substring-spec string-xcopy! target tstart tend)
+ (cond ((zero? tocopy))
+ ((zero? slen) (##sys#error 'string-xcopy! "Cannot replicate empty (sub)string"
+ string-xcopy!
+ target tstart s sfrom sto start end))
+
+ ((= 1 slen) ; Fast path for 1-char replication.
+ (##srfi13#string-fill! target (string-ref s start) tstart tend))
+
+ ;; Selected text falls entirely within one span.
+ ((= (floor (/ sfrom slen)) (floor (/ sto slen)))
+ (%string-copy! target tstart s
+ (+ start (modulo sfrom slen))
+ (+ start (modulo sto slen))))
+
+ ;; Multi-span copy.
+ (else (%multispan-repcopy! target tstart s sfrom sto start end))))))
+
+;;; This is the core copying loop for XSUBSTRING and STRING-XCOPY!
+;;; Internal -- not exported, no careful arg checking.
+(define (%multispan-repcopy! target tstart s sfrom sto start end)
+ (let* ((slen (- end start))
+ (i0 (+ start (modulo sfrom slen)))
+ (total-chars (- sto sfrom)))
+
+ ;; Copy the partial span @ the beginning
+ (%string-copy! target tstart s i0 end)
+
+ (let* ((ncopied (- end i0)) ; We've copied this many.
+ (nleft (- total-chars ncopied)) ; # chars left to copy.
+ (nspans (quotient nleft slen))) ; # whole spans to copy
+
+ ;; Copy the whole spans in the middle.
+ (do ((i (+ tstart ncopied) (+ i slen)) ; Current target index.
+ (nspans nspans (- nspans 1))) ; # spans to copy
+ ((zero? nspans)
+ ;; Copy the partial-span @ the end & we're done.
+ (%string-copy! target i s start (+ start (- total-chars (- i tstart)))))
+
+ (%string-copy! target i s start end))))); Copy a whole span.
+
+
+
+;;; (string-join string-list [delimiter grammar]) => string
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Paste strings together using the delimiter string.
+;;;
+;;; (join-strings '("foo" "bar" "baz") ":") => "foo:bar:baz"
+;;;
+;;; DELIMITER defaults to a single space " "
+;;; GRAMMAR is one of the symbols {prefix, infix, strict-infix, suffix}
+;;; and defaults to 'infix.
+;;;
+;;; I could rewrite this more efficiently -- precompute the length of the
+;;; answer string, then allocate & fill it in iteratively. Using
+;;; STRING-CONCATENATE is less efficient.
+
+(define (string-join strings . delim+grammar)
+ (let-optionals* delim+grammar ((delim " ") ; (string? delim))
+ (grammar 'infix))
+ (let ((buildit (lambda (lis final)
+ (let recur ((lis lis))
+ (if (pair? lis)
+ (cons delim (cons (car lis) (recur (cdr lis))))
+ final)))))
+
+ (cond ((pair? strings)
+ (string-concatenate
+ (case grammar
+
+ ((infix strict-infix)
+ (cons (car strings) (buildit (cdr strings) '())))
+
+ ((prefix) (buildit strings '()))
+
+ ((suffix)
+ (cons (car strings) (buildit (cdr strings) (list delim))))
+
+ (else (##sys#error 'string-join "Illegal join grammar"
+ grammar string-join)))))
+
+ ((not (null? strings))
+ (##sys#error 'string-join "STRINGS parameter not list." strings string-join))
+
+ ;; STRINGS is ()
+
+ ((eq? grammar 'strict-infix)
+ (##sys#error 'string-join "Empty list cannot be joined with STRICT-INFIX grammar."
+ string-join))
+
+ (else ""))))) ; Special-cased for infix grammar.
+
+
+;;; Porting & performance-tuning notes
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; See the section at the beginning of this file on external dependencies.
+;;;
+;;; The biggest issue with respect to porting is the LET-OPTIONALS* macro.
+;;; There are many, many optional arguments in this library; the complexity
+;;; of parsing, defaulting & type-testing these parameters is handled with the
+;;; aid of this macro. There are about 15 uses of LET-OPTIONALS*. You can
+;;; rewrite the uses, port the hairy macro definition (which is implemented
+;;; using a Clinger-Rees low-level explicit-renaming macro system), or port
+;;; the simple, high-level definition, which is less efficient.
+;;;
+;;; There is a fair amount of argument checking. This is, strictly speaking,
+;;; unnecessary -- the actual body of the procedures will blow up if, say, a
+;;; START/END index is improper. However, the error message will not be as
+;;; good as if the error were caught at the "higher level." Also, a very, very
+;;; smart Scheme compiler may be able to exploit having the type checks done
+;;; early, so that the actual body of the procedures can assume proper values.
+;;; This isn't likely; this kind of compiler technology isn't common any
+;;; longer.
+;;;
+;;; The overhead of optional-argument parsing is irritating. The optional
+;;; arguments must be consed into a rest list on entry, and then parsed out.
+;;; Function call should be a matter of a few register moves and a jump; it
+;;; should not involve heap allocation! Your Scheme system may have a superior
+;;; non-R5RS optional-argument system that can eliminate this overhead. If so,
+;;; then this is a prime candidate for optimising these procedures,
+;;; *especially* the many optional START/END index parameters.
+;;;
+;;; Note that optional arguments are also a barrier to procedure integration.
+;;; If your Scheme system permits you to specify alternate entry points
+;;; for a call when the number of optional arguments is known in a manner
+;;; that enables inlining/integration, this can provide performance
+;;; improvements.
+;;;
+;;; There is enough *explicit* error checking that *all* string-index
+;;; operations should *never* produce a bounds error. Period. Feel like
+;;; living dangerously? *Big* performance win to be had by replacing
+;;; STRING-REF's and STRING-SET!'s with unsafe equivalents in the loops.
+;;; Similarly, fixnum-specific operators can speed up the arithmetic done on
+;;; the index values in the inner loops. The only arguments that are not
+;;; completely error checked are
+;;; - string lists (complete checking requires time proportional to the
+;;; length of the list)
+;;; - procedure arguments, such as char->char maps & predicates.
+;;; There is no way to check the range & domain of procedures in Scheme.
+;;; Procedures that take these parameters cannot fully check their
+;;; arguments. But all other types to all other procedures are fully
+;;; checked.
+;;;
+;;; This does open up the alternate possibility of simply *removing* these
+;;; checks, and letting the safe primitives raise the errors. On a dumb
+;;; Scheme system, this would provide speed (by eliminating the redundant
+;;; error checks) at the cost of error-message clarity.
+;;;
+;;; See the comments preceding the hash function code for notes on tuning
+;;; the default bound so that the code never overflows your implementation's
+;;; fixnum size into bignum calculation.
+;;;
+;;; In an interpreted Scheme, some of these procedures, or the internal
+;;; routines with % prefixes, are excellent candidates for being rewritten
+;;; in C. Consider STRING-HASH, %STRING-COMPARE, the
+;;; %STRING-{SUF,PRE}FIX-LENGTH routines, STRING-COPY!, STRING-INDEX &
+;;; STRING-SKIP (char-set & char cases), SUBSTRING and SUBSTRING/SHARED,
+;;; %KMP-SEARCH, and %MULTISPAN-REPCOPY!.
+;;;
+;;; It would also be nice to have the ability to mark some of these
+;;; routines as candidates for inlining/integration.
+;;;
+;;; All the %-prefixed routines in this source code are written
+;;; to be called internally to this library. They do *not* perform
+;;; friendly error checks on the inputs; they assume everything is
+;;; proper. They also do not take optional arguments. These two properties
+;;; save calling overhead and enable procedure integration -- but they
+;;; are not appropriate for exported routines.
+
+
+;;; Copyright details
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The prefix/suffix and comparison routines in this code had (extremely
+;;; distant) origins in MIT Scheme's string lib, and was substantially
+;;; reworked by Olin Shivers (shivers@ai.mit.edu) 9/98. As such, it is
+;;; covered by MIT Scheme's open source copyright. See below for details.
+;;;
+;;; The KMP string-search code was influenced by implementations written
+;;; by Stephen Bevan, Brian Dehneyer and Will Fitzgerald. However, this
+;;; version was written from scratch by myself.
+
+;;; I guessed that much. (flw)
+
+;;;
+;;; The remainder of this code was written from scratch by myself for scsh.
+;;; The scsh copyright is a BSD-style open source copyright. See below for
+;;; details.
+;;; -Olin Shivers
+
+;;; MIT Scheme copyright terms
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; This material was developed by the Scheme project at the Massachusetts
+;;; Institute of Technology, Department of Electrical Engineering and
+;;; Computer Science. Permission to copy and modify this software, to
+;;; redistribute either the original software or a modified version, and
+;;; to use this software for any purpose is granted, subject to the
+;;; following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright notice
+;;; in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions that
+;;; they make, so that these may be included in future releases; and (b)
+;;; to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the usual
+;;; standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation of
+;;; this software will be error-free, and MIT is under no obligation to
+;;; provide any services, by way of maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this material,
+;;; there shall be no use of the name of the Massachusetts Institute of
+;;; Technology nor of any adaptation thereof in any advertising,
+;;; promotional, or sales literature without prior written consent from
+;;; MIT in each case.
+
+;;; Scsh copyright terms
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; 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 authors may not be used to endorse or promote products
+;;; derived from this software without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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/srfi-14.import.scm b/srfi-14.import.scm
new file mode 100644
index 00000000..66237871
--- /dev/null
+++ b/srfi-14.import.scm
@@ -0,0 +1,94 @@
+;;;; srfi-14.import.scm - import library for "srfi-14" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'srfi-14
+ '(->char-set
+ char-set
+ char-set->list
+ char-set->string
+ char-set-adjoin
+ char-set-adjoin!
+ char-set-any
+ char-set-complement
+ char-set-complement!
+ char-set-contains?
+ char-set-copy
+ char-set-count
+ char-set-cursor
+ char-set-cursor-next
+ char-set-delete
+ char-set-delete!
+ char-set-diff+intersection
+ char-set-diff+intersection!
+ char-set-difference
+ char-set-difference!
+ char-set-every
+ char-set-filter
+ char-set-filter!
+ char-set-fold
+ char-set-for-each
+ char-set-hash
+ char-set-intersection
+ char-set-intersection!
+ char-set-map
+ char-set-ref
+ char-set-size
+ char-set-unfold
+ char-set-unfold!
+ char-set-union
+ char-set-union!
+ char-set-xor
+ char-set-xor!
+ char-set:ascii
+ char-set:blank
+ char-set:digit
+ char-set:empty
+ char-set:full
+ char-set:graphic
+ char-set:hex-digit
+ char-set:iso-control
+ char-set:letter
+ char-set:letter+digit
+ char-set:lower-case
+ char-set:printing
+ char-set:punctuation
+ char-set:s
+ char-set:symbol
+ char-set:title-case
+ char-set:upper-case
+ char-set:whitespace
+ char-set<=
+ char-set=
+ char-set?
+ end-of-char-set?
+ list->char-set
+ list->char-set!
+ make-char-set
+ string->char-set
+ string->char-set!
+ ucs-range->char-set
+ ucs-range->char-set!))
diff --git a/srfi-14.scm b/srfi-14.scm
new file mode 100644
index 00000000..f394288e
--- /dev/null
+++ b/srfi-14.scm
@@ -0,0 +1,844 @@
+;;;; srfi-14.scm - Shivers' reference implementation of SRFI-14
+
+
+(declare
+ (unit srfi-14)
+ (fixnum)
+ (disable-interrupts)
+ (standard-bindings)
+ (extended-bindings)
+ (hide %char-set:s/check %string-iter %char-set-diff+intersection! %char->latin1 %latin1->char
+ %ucs-range->char-set! %string->char-set! %list->char-set! %set-char-set! %char-set-unfold!
+ %char-set-algebra %char-set-cursor-next %char-set-filter! %set-char-set c0 c1 %string-copy
+ %default-base) )
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ (no-procedure-checks-for-usual-bindings)
+ (bound-to-procedure
+ char-set char-set-complement ucs-range->char-set! ucs-range->char-set char-set-union
+ char-set-adjoin string->char-set list->char-set string-copy make-char-set char-set-copy
+ char-set? char-set-size char-set:s)
+ (no-bound-checks) ) ] )
+
+(include "unsafe-declarations.scm")
+
+(register-feature! 'srfi-14)
+
+
+(define (%latin1->char n) (integer->char n))
+(define (%char->latin1 c) (char->integer c))
+
+
+;;; SRFI-14 character-sets library -*- Scheme -*-
+;;;
+;;; - Ported from MIT Scheme runtime by Brian D. Carlstrom.
+;;; - Massively rehacked & extended by Olin Shivers 6/98.
+;;; - Massively redesigned and rehacked 5/2000 during SRFI process.
+;;; At this point, the code bears the following relationship to the
+;;; MIT Scheme code: "This is my grandfather's axe. My father replaced
+;;; the head, and I have replaced the handle." Nonetheless, we preserve
+;;; the MIT Scheme copyright:
+;;; Copyright (c) 1988-1995 Massachusetts Institute of Technology
+;;; The MIT Scheme license is a "free software" license. See the end of
+;;; this file for the tedious details.
+
+;;; Exports:
+;;; char-set? char-set= char-set<=
+;;; char-set-hash
+;;; char-set-cursor char-set-ref char-set-cursor-next end-of-char-set?
+;;; char-set-fold char-set-unfold char-set-unfold!
+;;; char-set-for-each char-set-map
+;;; char-set-copy
+;;;
+;;; char-set list->char-set string->char-set
+;;; char-set! list->char-set! string->char-set!
+;;;
+;;; filterchar-set ucs-range->char-set ->char-set
+;;; filterchar-set! ucs-range->char-set!
+;;;
+;;; char-set->list char-set->string
+;;;
+;;; char-set-size char-set-count char-set-contains?
+;;; char-set-every char-set-any
+;;;
+;;; char-set-adjoin char-set-delete
+;;; char-set-adjoin! char-set-delete!
+;;;
+;;; char-set-complement char-set-union char-set-intersection char-set-difference
+;;; char-set-complement! char-set-union! char-set-intersection! char-set-difference!
+;;;
+;;; char-set-difference char-set-xor char-set-diff+intersection
+;;; char-set-difference! char-set-xor! char-set-diff+intersection!
+;;;
+;;; 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 char-set:ascii
+;;; char-set:empty char-set:full
+
+;;; Imports
+;;; This code has the following non-R5RS dependencies:
+;;; - ERROR
+;;; - %LATIN1->CHAR %CHAR->LATIN1
+;;; - LET-OPTIONALS* and :OPTIONAL macros for parsing, checking & defaulting
+;;; optional arguments from rest lists.
+;;; - BITWISE-AND for CHAR-SET-HASH
+;;; - The SRFI-19 DEFINE-RECORD-TYPE record macro
+;;; - A simple CHECK-ARG procedure:
+;;; (lambda (pred val caller) (if (not (pred val)) (error val caller)))
+
+;;; This is simple code, not great code. Char sets are represented as 256-char
+;;; strings. If char I is ASCII/Latin-1 0, then it isn't in the set; if char I
+;;; is ASCII/Latin-1 1, then it is in the set.
+;;; - Should be rewritten to use bit strings or byte vecs.
+;;; - Is Latin-1 specific. Would certainly have to be rewritten for Unicode.
+
+;;; See the end of the file for porting and performance-tuning notes.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (make-char-set s) (##sys#make-structure 'char-set s))
+(define (char-set:s cs) (##sys#slot cs 1))
+(define (char-set? x) (##sys#structure? x 'char-set))
+
+#|
+(define-record-type :char-set
+ (make-char-set s)
+ char-set?
+ (s char-set:s))
+|#
+
+
+(define (%string-copy s) (substring s 0 (string-length s)))
+
+;;; Parse, type-check & default a final optional BASE-CS parameter from
+;;; a rest argument. Return a *fresh copy* of the underlying string.
+;;; The default is the empty set. The PROC argument is to help us
+;;; generate informative error exceptions.
+
+(define (%default-base maybe-base proc)
+ (if (pair? maybe-base)
+ (let ((bcs (car maybe-base))
+ (tail (cdr maybe-base)))
+ (if (null? tail)
+ (if (char-set? bcs) (%string-copy (char-set:s bcs))
+ (##sys#error "BASE-CS parameter not a char-set" proc bcs))
+ (##sys#error "Expected final base char set -- too many parameters"
+ proc maybe-base)))
+ (make-string 256 (%latin1->char 0))))
+
+;;; If CS is really a char-set, do CHAR-SET:S, otw report an error msg on
+;;; behalf of our caller, PROC. This procedure exists basically to provide
+;;; explicit error-checking & reporting.
+
+(define (%char-set:s/check cs proc)
+ (let lp ((cs cs))
+ (if (char-set? cs) (char-set:s cs)
+ (lp (##sys#error proc "Not a char-set" cs)))))
+
+
+
+;;; These internal functions hide a lot of the dependency on the
+;;; underlying string representation of char sets. They should be
+;;; inlined if possible.
+
+(define-inline (si=0? s i) (zero? (%char->latin1 (string-ref s i))))
+(define-inline (si=1? s i) (not (si=0? s i)))
+(define-inline (si s i) (%char->latin1 (string-ref s i)))
+(define-inline (%set0! s i) (string-set! s i c0))
+(define-inline (%set1! s i) (string-set! s i c1))
+
+(define c0 (%latin1->char 0))
+(define c1 (%latin1->char 1))
+
+;;; These do various "s[i] := s[i] op val" operations -- see
+;;; %CHAR-SET-ALGEBRA. They are used to implement the various
+;;; set-algebra procedures.
+(define-inline (setv! s i v) (string-set! s i (%latin1->char v))) ; SET to a Value.
+(define-inline (%not! s i v) (setv! s i (- 1 v)))
+(define-inline (%and! s i v) (if (zero? v) (%set0! s i)))
+(define-inline (%or! s i v) (if (not (zero? v)) (%set1! s i)))
+(define-inline (%minus! s i v) (if (not (zero? v)) (%set0! s i)))
+(define-inline (%xor! s i v) (if (not (zero? v)) (setv! s i (- 1 (si s i)))))
+
+(define (char-set-copy cs)
+ (make-char-set (%string-copy (%char-set:s/check cs 'char-set-copy))))
+
+(define char-set=
+ (lambda rest
+ (or (null? rest)
+ (let* ((cs1 (car rest))
+ (rest (cdr rest))
+ (s1 (%char-set:s/check cs1 'char-set=)))
+ (let lp ((rest rest))
+ (or (not (pair? rest))
+ (and (string=? s1 (%char-set:s/check (car rest) 'char-set=))
+ (lp (cdr rest)))))))))
+
+(define char-set<=
+ (lambda rest
+ (or (null? rest)
+ (let ((cs1 (car rest))
+ (rest (cdr rest)))
+ (let lp ((s1 (%char-set:s/check cs1 'char-set<=)) (rest rest))
+ (or (not (pair? rest))
+ (let ((s2 (%char-set:s/check (car rest) 'char-set<=))
+ (rest (cdr rest)))
+ (if (eq? s1 s2) (lp s2 rest) ; Fast path
+ (let lp2 ((i 255)) ; Real test
+ (if (< i 0) (lp s2 rest)
+ (and (<= (si s1 i) (si s2 i))
+ (lp2 (- i 1))))))))))) ))
+
+;;; Hash
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Compute (c + 37 c + 37^2 c + ...) modulo BOUND.
+;;; If you keep BOUND small enough, the intermediate calculations will
+;;; always be fixnums. How small is dependent on the underlying Scheme system;
+;;; we use a default BOUND of 2^22 = 4194304, which should hack it in
+;;; Schemes that give you at least 29 signed bits for fixnums. The core
+;;; calculation that you don't want to overflow is, worst case,
+;;; (+ 65535 (* 37 (- bound 1)))
+;;; where 65535 is the max character code. Choose the default BOUND to be the
+;;; biggest power of two that won't cause this expression to fixnum overflow,
+;;; and everything will be copacetic.
+
+(define (char-set-hash cs . maybe-bound)
+ (let ((bound (optional maybe-bound 4194304)))
+ (if (zero? bound) (set! bound 4194304))
+ (##sys#check-exact bound 'char-set-hash)
+ (let* ((s (%char-set:s/check cs 'char-set-hash))
+ ;; Compute a 111...1 mask that will cover BOUND-1:
+ (mask (let lp ((i #x10000)) ; Let's skip first 16 iterations, eh?
+ (if (>= i bound) (- i 1) (lp (+ i i))))))
+ (let lp ((i 255) (ans 0))
+ (if (< i 0) (modulo ans bound)
+ (lp (- i 1)
+ (if (si=0? s i) ans
+ (fxand mask (+ (* 37 ans) i)))))))) )
+
+
+(define (char-set-contains? cs char)
+ (##sys#check-char char 'char-set-contains?)
+ (si=1? (%char-set:s/check cs 'char-set-contains?)
+; (%char->latin1 (check-arg char? char char-set-contains?))))
+ (%char->latin1 char) ) )
+
+(define (char-set-size cs)
+ (let ((s (%char-set:s/check cs 'char-set-size)))
+ (let lp ((i 255) (size 0))
+ (if (< i 0) size
+ (lp (- i 1) (+ size (si s i)))))))
+
+(define (char-set-count pred cset)
+; (check-arg procedure? pred char-set-count)
+ (let ((s (%char-set:s/check cset 'char-set-count)))
+ (let lp ((i 255) (count 0))
+ (if (< i 0) count
+ (lp (- i 1)
+ (if (and (si=1? s i) (pred (%latin1->char i)))
+ (+ count 1)
+ count))))))
+
+
+;;; -- Adjoin & delete
+
+(define (%set-char-set set proc cs chars)
+ (let ((s (%string-copy (%char-set:s/check cs proc))))
+ (for-each (lambda (c) (set s (%char->latin1 c)))
+ chars)
+ (make-char-set s)))
+
+(define (%set-char-set! set proc cs chars)
+ (let ((s (%char-set:s/check cs proc)))
+ (for-each (lambda (c) (set s (%char->latin1 c)))
+ chars))
+ cs)
+
+(define (char-set-adjoin cs . chars)
+ (%set-char-set %set1! 'char-set-adjoin cs chars))
+(define (char-set-adjoin! cs . chars)
+ (%set-char-set! %set1! 'char-set-adjoin! cs chars))
+(define (char-set-delete cs . chars)
+ (%set-char-set %set0! 'char-set-delete cs chars))
+(define (char-set-delete! cs . chars)
+ (%set-char-set! %set0! 'char-set-delete! cs chars))
+
+
+;;; Cursors
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Simple implementation. A cursors is an integer index into the
+;;; mark vector, and -1 for the end-of-char-set cursor.
+;;;
+;;; If we represented char sets as a bit set, we could do the following
+;;; trick to pick the lowest bit out of the set:
+;;; (count-bits (xor (- cset 1) cset))
+;;; (But first mask out the bits already scanned by the cursor first.)
+
+(define (char-set-cursor cset)
+ (%char-set-cursor-next cset 256 'char-set-cursor))
+
+(define (end-of-char-set? cursor) (< cursor 0))
+
+(define (char-set-ref cset cursor) (%latin1->char cursor))
+
+(define (char-set-cursor-next cset cursor)
+ (##sys#check-exact cursor 'char-set-cursor-next)
+; (check-arg (lambda (i) (and (integer? i) (exact? i) (<= 0 i 255))) cursor
+; char-set-cursor-next)
+ (%char-set-cursor-next cset cursor 'char-set-cursor-next))
+
+(define (%char-set-cursor-next cset cursor proc) ; Internal
+ (let ((s (%char-set:s/check cset proc)))
+ (let lp ((cur cursor))
+ (let ((cur (- cur 1)))
+ (if (or (< cur 0) (si=1? s cur)) cur
+ (lp cur))))))
+
+
+;;; -- for-each map fold unfold every any
+
+(define (char-set-for-each proc cs)
+; (check-arg procedure? proc char-set-for-each)
+ (let ((s (%char-set:s/check cs 'char-set-for-each)))
+ (let lp ((i 255))
+ (cond ((>= i 0)
+ (if (si=1? s i) (proc (%latin1->char i)))
+ (lp (- i 1)))))))
+
+(define (char-set-map proc cs)
+; (check-arg procedure? proc char-set-map)
+ (let ((s (%char-set:s/check cs 'char-set-map))
+ (ans (make-string 256 c0)))
+ (let lp ((i 255))
+ (cond ((>= i 0)
+ (if (si=1? s i)
+ (%set1! ans (%char->latin1 (proc (%latin1->char i)))))
+ (lp (- i 1)))))
+ (make-char-set ans)))
+
+(define (char-set-fold kons knil cs)
+; (check-arg procedure? kons char-set-fold)
+ (let ((s (%char-set:s/check cs 'char-set-fold)))
+ (let lp ((i 255) (ans knil))
+ (if (< i 0) ans
+ (lp (- i 1)
+ (if (si=0? s i) ans
+ (kons (%latin1->char i) ans)))))))
+
+(define (char-set-every pred cs)
+; (check-arg procedure? pred char-set-every)
+ (let ((s (%char-set:s/check cs 'char-set-every)))
+ (let lp ((i 255))
+ (or (< i 0)
+ (and (or (si=0? s i) (pred (%latin1->char i)))
+ (lp (- i 1)))))))
+
+(define (char-set-any pred cs)
+; (check-arg procedure? pred char-set-any)
+ (let ((s (%char-set:s/check cs 'char-set-any)))
+ (let lp ((i 255))
+ (and (>= i 0)
+ (or (and (si=1? s i) (pred (%latin1->char i)))
+ (lp (- i 1)))))))
+
+
+(define (%char-set-unfold! proc p f g s seed)
+; (check-arg procedure? p proc)
+; (check-arg procedure? f proc)
+; (check-arg procedure? g proc)
+ (let lp ((seed seed))
+ (cond ((not (p seed)) ; P says we are done.
+ (%set1! s (%char->latin1 (f seed))) ; Add (F SEED) to set.
+ (lp (g seed)))))) ; Loop on (G SEED).
+
+(define (char-set-unfold p f g seed . maybe-base)
+ (let ((bs (%default-base maybe-base char-set-unfold)))
+ (%char-set-unfold! char-set-unfold p f g bs seed)
+ (make-char-set bs)))
+
+(define (char-set-unfold! p f g seed base-cset)
+ (%char-set-unfold! char-set-unfold! p f g
+ (%char-set:s/check base-cset 'char-set-unfold!)
+ seed)
+ base-cset)
+
+
+
+;;; list <--> char-set
+
+(define (%list->char-set! chars s)
+ (for-each (lambda (char) (%set1! s (%char->latin1 char)))
+ chars))
+
+(define (char-set . chars)
+ (let ((s (make-string 256 c0)))
+ (%list->char-set! chars s)
+ (make-char-set s)))
+
+(define (list->char-set chars . maybe-base)
+ (let ((bs (%default-base maybe-base list->char-set)))
+ (%list->char-set! chars bs)
+ (make-char-set bs)))
+
+(define (list->char-set! chars base-cs)
+ (%list->char-set! chars (%char-set:s/check base-cs 'list->char-set!))
+ base-cs)
+
+
+(define (char-set->list cs)
+ (let ((s (%char-set:s/check cs 'char-set->list)))
+ (let lp ((i 255) (ans '()))
+ (if (< i 0) ans
+ (lp (- i 1)
+ (if (si=0? s i) ans
+ (cons (%latin1->char i) ans)))))))
+
+
+
+;;; string <--> char-set
+
+(define (%string->char-set! str bs proc)
+ (##sys#check-string str proc)
+; (check-arg string? str proc)
+ (do ((i (- (string-length str) 1) (- i 1)))
+ ((< i 0))
+ (%set1! bs (%char->latin1 (string-ref str i)))))
+
+(define (string->char-set str . maybe-base)
+ (let ((bs (%default-base maybe-base string->char-set)))
+ (%string->char-set! str bs 'string->char-set)
+ (make-char-set bs)))
+
+(define (string->char-set! str base-cs)
+ (%string->char-set! str (%char-set:s/check base-cs 'string->char-set!)
+ 'string->char-set!)
+ base-cs)
+
+
+(define (char-set->string cs)
+ (let* ((s (%char-set:s/check cs 'char-set->string))
+ (ans (make-string (char-set-size cs))))
+ (let lp ((i 255) (j 0))
+ (if (< i 0) ans
+ (let ((j (if (si=0? s i) j
+ (begin (string-set! ans j (%latin1->char i))
+ (+ j 1)))))
+ (lp (- i 1) j))))))
+
+
+;;; -- UCS-range -> char-set
+
+(define (%ucs-range->char-set! lower upper error? bs proc)
+ (##sys#check-exact lower proc)
+ (##sys#check-exact upper proc)
+; (check-arg (lambda (x) (and (integer? x) (exact? x) (<= 0 x))) lower proc)
+; (check-arg (lambda (x) (and (integer? x) (exact? x) (<= lower x))) upper proc)
+
+ (if (and (< lower upper) (< 256 upper) error?)
+ (##sys#error "Requested UCS range contains unavailable characters -- this implementation only supports Latin-1"
+ proc lower upper))
+
+ (let lp ((i (- (min upper 256) 1)))
+ (cond ((<= lower i) (%set1! bs i) (lp (- i 1))))))
+
+(define (ucs-range->char-set lower upper . rest)
+ (let-optionals* rest ((error? #f) rest)
+ (let ((bs (%default-base rest ucs-range->char-set)))
+ (%ucs-range->char-set! lower upper error? bs 'ucs-range->char-set)
+ (make-char-set bs))))
+
+(define (ucs-range->char-set! lower upper error? base-cs)
+ (%ucs-range->char-set! lower upper error?
+ (%char-set:s/check base-cs 'ucs-range->char-set!)
+ 'ucs-range->char-set)
+ base-cs)
+
+
+;;; -- predicate -> char-set
+
+(define (%char-set-filter! pred ds bs proc)
+; (check-arg procedure? pred proc)
+ (let lp ((i 255))
+ (cond ((>= i 0)
+ (if (and (si=1? ds i) (pred (%latin1->char i)))
+ (%set1! bs i))
+ (lp (- i 1))))))
+
+(define (char-set-filter predicate domain . maybe-base)
+ (let ((bs (%default-base maybe-base char-set-filter)))
+ (%char-set-filter! predicate
+ (%char-set:s/check domain 'char-set-filter!)
+ bs
+ char-set-filter)
+ (make-char-set bs)))
+
+(define (char-set-filter! predicate domain base-cs)
+ (%char-set-filter! predicate
+ (%char-set:s/check domain 'char-set-filter!)
+ (%char-set:s/check base-cs 'char-set-filter!)
+ char-set-filter!)
+ base-cs)
+
+
+;;; {string, char, char-set, char predicate} -> char-set
+
+(define (->char-set x)
+ (cond ((char-set? x) x)
+ ((string? x) (string->char-set x))
+ ((char? x) (char-set x))
+ (else (##sys#error '->char-set "Not a charset, string or char." x))))
+
+
+
+;;; Set algebra
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; The exported ! procs are "linear update" -- allowed, but not required, to
+;;; side-effect their first argument when computing their result. In other
+;;; words, you must use them as if they were completely functional, just like
+;;; their non-! counterparts, and you must additionally ensure that their
+;;; first arguments are "dead" at the point of call. In return, we promise a
+;;; more efficient result, plus allowing you to always assume char-sets are
+;;; unchangeable values.
+
+;;; Apply P to each index and its char code in S: (P I VAL).
+;;; Used by the set-algebra ops.
+
+(define (%string-iter p s)
+ (let lp ((i (- (string-length s) 1)))
+ (cond ((>= i 0)
+ (p i (%char->latin1 (string-ref s i)))
+ (lp (- i 1))))))
+
+;;; String S represents some initial char-set. (OP s i val) does some
+;;; kind of s[i] := s[i] op val update. Do
+;;; S := S OP CSETi
+;;; for all the char-sets in the list CSETS. The n-ary set-algebra ops
+;;; all use this internal proc.
+
+(define (%char-set-algebra s csets op proc)
+ (for-each (lambda (cset)
+ (let ((s2 (%char-set:s/check cset proc)))
+ (let lp ((i 255))
+ (cond ((>= i 0)
+ (op s i (si s2 i))
+ (lp (- i 1)))))))
+ csets))
+
+
+;;; -- Invert
+
+(define (char-set-complement cs)
+ (let ((s (%char-set:s/check cs 'char-set-complement))
+ (ans (make-string 256)))
+ (%string-iter (lambda (i v) (%not! ans i v)) s)
+ (make-char-set ans)))
+
+(define (char-set-complement! cset)
+ (let ((s (%char-set:s/check cset 'char-set-complement!)))
+ (%string-iter (lambda (i v) (%not! s i v)) s))
+ cset)
+
+
+;;; -- Union
+
+(define (char-set-union! cset1 . csets)
+ (%char-set-algebra (%char-set:s/check cset1 'char-set-union!)
+ csets %or! 'char-set-union!)
+ cset1)
+
+(define (char-set-union . csets)
+ (if (pair? csets)
+ (let ((s (%string-copy (%char-set:s/check (car csets) 'char-set-union))))
+ (%char-set-algebra s (cdr csets) %or! 'char-set-union)
+ (make-char-set s))
+ (char-set-copy char-set:empty)))
+
+
+;;; -- Intersection
+
+(define (char-set-intersection! cset1 . csets)
+ (%char-set-algebra (%char-set:s/check cset1 'char-set-intersection!)
+ csets %and! 'char-set-intersection!)
+ cset1)
+
+(define (char-set-intersection . csets)
+ (if (pair? csets)
+ (let ((s (%string-copy (%char-set:s/check (car csets) 'char-set-intersection))))
+ (%char-set-algebra s (cdr csets) %and! 'char-set-intersection)
+ (make-char-set s))
+ (char-set-copy char-set:full)))
+
+
+;;; -- Difference
+
+(define (char-set-difference! cset1 . csets)
+ (%char-set-algebra (%char-set:s/check cset1 'char-set-difference!)
+ csets %minus! 'char-set-difference!)
+ cset1)
+
+(define (char-set-difference cs1 . csets)
+ (if (pair? csets)
+ (let ((s (%string-copy (%char-set:s/check cs1 'char-set-difference))))
+ (%char-set-algebra s csets %minus! 'char-set-difference)
+ (make-char-set s))
+ (char-set-copy cs1)))
+
+
+;;; -- Xor
+
+(define (char-set-xor! cset1 . csets)
+ (%char-set-algebra (%char-set:s/check cset1 'char-set-xor!)
+ csets %xor! 'char-set-xor!)
+ cset1)
+
+(define (char-set-xor . csets)
+ (if (pair? csets)
+ (let ((s (%string-copy (%char-set:s/check (car csets) 'char-set-xor))))
+ (%char-set-algebra s (cdr csets) %xor! 'char-set-xor)
+ (make-char-set s))
+ (char-set-copy char-set:empty)))
+
+
+;;; -- Difference & intersection
+
+(define (%char-set-diff+intersection! diff int csets proc)
+ (for-each (lambda (cs)
+ (%string-iter (lambda (i v)
+ (if (not (zero? v))
+ (cond ((si=1? diff i)
+ (%set0! diff i)
+ (%set1! int i)))))
+ (%char-set:s/check cs proc)))
+ csets))
+
+(define (char-set-diff+intersection! cs1 cs2 . csets)
+ (let ((s1 (%char-set:s/check cs1 'char-set-diff+intersection!))
+ (s2 (%char-set:s/check cs2 'char-set-diff+intersection!)))
+ (%string-iter (lambda (i v) (if (zero? v)
+ (%set0! s2 i)
+ (if (si=1? s2 i) (%set0! s1 i))))
+ s1)
+ (%char-set-diff+intersection! s1 s2 csets 'char-set-diff+intersection!))
+ (values cs1 cs2))
+
+(define (char-set-diff+intersection cs1 . csets)
+ (let ((diff (string-copy (%char-set:s/check cs1 'char-set-diff+intersection)))
+ (int (make-string 256 c0)))
+ (%char-set-diff+intersection! diff int csets 'char-set-diff+intersection)
+ (values (make-char-set diff) (make-char-set int))))
+
+
+;;;; System character sets
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; These definitions are for Latin-1.
+;;;
+;;; If your Scheme implementation allows you to mark the underlying strings
+;;; as immutable, you should do so -- it would be very, very bad if a client's
+;;; buggy code corrupted these constants.
+
+(define char-set:empty (char-set))
+(define char-set:full (char-set-complement char-set:empty))
+
+(define char-set:lower-case
+ (let* ((a-z (ucs-range->char-set #x61 #x7B))
+ (latin1 (ucs-range->char-set! #xdf #xf7 #t a-z))
+ (latin2 (ucs-range->char-set! #xf8 #x100 #t latin1)))
+ (char-set-adjoin! latin2 (%latin1->char #xb5))))
+
+(define char-set:upper-case
+ (let ((A-Z (ucs-range->char-set #x41 #x5B)))
+ ;; Add in the Latin-1 upper-case chars.
+ (ucs-range->char-set! #xd8 #xdf #t
+ (ucs-range->char-set! #xc0 #xd7 #t A-Z))))
+
+(define char-set:title-case char-set:empty)
+
+(define char-set:letter
+ (let ((u/l (char-set-union char-set:upper-case char-set:lower-case)))
+ (char-set-adjoin! u/l
+ (%latin1->char #xaa) ; FEMININE ORDINAL INDICATOR
+ (%latin1->char #xba)))) ; MASCULINE ORDINAL INDICATOR
+
+(define char-set:digit (string->char-set "0123456789"))
+(define char-set:hex-digit (string->char-set "0123456789abcdefABCDEF"))
+
+(define char-set:letter+digit
+ (char-set-union char-set:letter char-set:digit))
+
+(define char-set:punctuation
+ (let ((ascii (string->char-set "!\"#%&'()*,-./:;?@[\\]_{}"))
+ (latin-1-chars (map %latin1->char '(#xA1 ; INVERTED EXCLAMATION MARK
+ #xAB ; LEFT-POINTING DOUBLE ANGLE QUOTATION MARK
+ #xAD ; SOFT HYPHEN
+ #xB7 ; MIDDLE DOT
+ #xBB ; RIGHT-POINTING DOUBLE ANGLE QUOTATION MARK
+ #xBF)))) ; INVERTED QUESTION MARK
+ (list->char-set! latin-1-chars ascii)))
+
+(define char-set:symbol
+ (let ((ascii (string->char-set "$+<=>^`|~"))
+ (latin-1-chars (map %latin1->char '(#x00A2 ; CENT SIGN
+ #x00A3 ; POUND SIGN
+ #x00A4 ; CURRENCY SIGN
+ #x00A5 ; YEN SIGN
+ #x00A6 ; BROKEN BAR
+ #x00A7 ; SECTION SIGN
+ #x00A8 ; DIAERESIS
+ #x00A9 ; COPYRIGHT SIGN
+ #x00AC ; NOT SIGN
+ #x00AE ; REGISTERED SIGN
+ #x00AF ; MACRON
+ #x00B0 ; DEGREE SIGN
+ #x00B1 ; PLUS-MINUS SIGN
+ #x00B4 ; ACUTE ACCENT
+ #x00B6 ; PILCROW SIGN
+ #x00B8 ; CEDILLA
+ #x00D7 ; MULTIPLICATION SIGN
+ #x00F7)))) ; DIVISION SIGN
+ (list->char-set! latin-1-chars ascii)))
+
+
+(define char-set:graphic
+ (char-set-union char-set:letter+digit char-set:punctuation char-set:symbol))
+
+(define char-set:whitespace
+ (list->char-set (map %latin1->char '(#x09 ; HORIZONTAL TABULATION
+ #x0A ; LINE FEED
+ #x0B ; VERTICAL TABULATION
+ #x0C ; FORM FEED
+ #x0D ; CARRIAGE RETURN
+ #x20 ; SPACE
+ #xA0))))
+
+(define char-set:printing (char-set-union char-set:whitespace char-set:graphic)) ; NO-BREAK SPACE
+
+(define char-set:blank
+ (list->char-set (map %latin1->char '(#x09 ; HORIZONTAL TABULATION
+ #x20 ; SPACE
+ #xA0)))) ; NO-BREAK SPACE
+
+
+(define char-set:iso-control
+ (ucs-range->char-set! #x7F #xA0 #t (ucs-range->char-set 0 32)))
+
+(define char-set:ascii (ucs-range->char-set 0 128))
+
+
+;;; Porting & performance-tuning notes
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; See the section at the beginning of this file on external dependencies.
+;;;
+;;; First and foremost, rewrite this code to use bit vectors of some sort.
+;;; This will give big speedup and memory savings.
+;;;
+;;; - LET-OPTIONALS* macro.
+;;; This is only used once. You can rewrite the use, port the hairy macro
+;;; definition (which is implemented using a Clinger-Rees low-level
+;;; explicit-renaming macro system), or port the simple, high-level
+;;; definition, which is less efficient.
+;;;
+;;; - :OPTIONAL macro
+;;; Very simply defined using an R5RS high-level macro.
+;;;
+;;; Implementations that can arrange for the base char sets to be immutable
+;;; should do so. (E.g., Scheme 48 allows one to mark a string as immutable,
+;;; which can be used to protect the underlying strings.) It would be very,
+;;; very bad if a client's buggy code corrupted these constants.
+;;;
+;;; There is a fair amount of argument checking. This is, strictly speaking,
+;;; unnecessary -- the actual body of the procedures will blow up if an
+;;; illegal value is passed in. However, the error message will not be as good
+;;; as if the error were caught at the "higher level." Also, a very, very
+;;; smart Scheme compiler may be able to exploit having the type checks done
+;;; early, so that the actual body of the procedures can assume proper values.
+;;; This isn't likely; this kind of compiler technology isn't common any
+;;; longer.
+;;;
+;;; The overhead of optional-argument parsing is irritating. The optional
+;;; arguments must be consed into a rest list on entry, and then parsed out.
+;;; Function call should be a matter of a few register moves and a jump; it
+;;; should not involve heap allocation! Your Scheme system may have a superior
+;;; non-R5RS optional-argument system that can eliminate this overhead. If so,
+;;; then this is a prime candidate for optimising these procedures,
+;;; *especially* the many optional BASE-CS parameters.
+;;;
+;;; Note that optional arguments are also a barrier to procedure integration.
+;;; If your Scheme system permits you to specify alternate entry points
+;;; for a call when the number of optional arguments is known in a manner
+;;; that enables inlining/integration, this can provide performance
+;;; improvements.
+;;;
+;;; There is enough *explicit* error checking that *all* internal operations
+;;; should *never* produce a type or index-range error. Period. Feel like
+;;; living dangerously? *Big* performance win to be had by replacing string
+;;; and record-field accessors and setters with unsafe equivalents in the
+;;; code. Similarly, fixnum-specific operators can speed up the arithmetic
+;;; done on the index values in the inner loops. The only arguments that are
+;;; not completely error checked are
+;;; - string lists (complete checking requires time proportional to the
+;;; length of the list)
+;;; - procedure arguments, such as char->char maps & predicates.
+;;; There is no way to check the range & domain of procedures in Scheme.
+;;; Procedures that take these parameters cannot fully check their
+;;; arguments. But all other types to all other procedures are fully
+;;; checked.
+;;;
+;;; This does open up the alternate possibility of simply *removing* these
+;;; checks, and letting the safe primitives raise the errors. On a dumb
+;;; Scheme system, this would provide speed (by eliminating the redundant
+;;; error checks) at the cost of error-message clarity.
+;;;
+;;; In an interpreted Scheme, some of these procedures, or the internal
+;;; routines with % prefixes, are excellent candidates for being rewritten
+;;; in C.
+;;;
+;;; It would also be nice to have the ability to mark some of these
+;;; routines as candidates for inlining/integration.
+;;;
+;;; See the comments preceding the hash function code for notes on tuning
+;;; the default bound so that the code never overflows your implementation's
+;;; fixnum size into bignum calculation.
+;;;
+;;; All the %-prefixed routines in this source code are written
+;;; to be called internally to this library. They do *not* perform
+;;; friendly error checks on the inputs; they assume everything is
+;;; proper. They also do not take optional arguments. These two properties
+;;; save calling overhead and enable procedure integration -- but they
+;;; are not appropriate for exported routines.
+
+;;; Copyright notice
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Copyright (c) 1988-1995 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the Massachusetts
+;;; Institute of Technology, Department of Electrical Engineering and
+;;; Computer Science. Permission to copy and modify this software, to
+;;; redistribute either the original software or a modified version, and
+;;; to use this software for any purpose is granted, subject to the
+;;; following restrictions and understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright notice
+;;; in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a) to
+;;; return to the MIT Scheme project any improvements or extensions that
+;;; they make, so that these may be included in future releases; and (b)
+;;; to inform MIT of noteworthy uses of this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with the usual
+;;; standards of acknowledging credit in academic research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the operation of
+;;; this software will be error-free, and MIT is under no obligation to
+;;; provide any services, by way of maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this material,
+;;; there shall be no use of the name of the Massachusetts Institute of
+;;; Technology nor of any adaptation thereof in any advertising,
+;;; promotional, or sales literature without prior written consent from
+;;; MIT in each case.
diff --git a/srfi-18.import.scm b/srfi-18.import.scm
new file mode 100644
index 00000000..a5a74a52
--- /dev/null
+++ b/srfi-18.import.scm
@@ -0,0 +1,74 @@
+;;;; srfi-18.import.scm - import library for "srfi-18" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'srfi-18
+ '(abandoned-mutex-exception?
+ condition-variable-broadcast!
+ condition-variable-signal!
+ condition-variable-specific
+ condition-variable-specific-set!
+ condition-variable?
+ current-thread
+ current-time
+ join-timeout-exception?
+ make-condition-variable
+ make-mutex
+ make-thread
+ milliseconds->time
+ mutex-lock!
+ mutex-name
+ mutex-specific
+ mutex-specific-set!
+ mutex-state
+ mutex-unlock!
+ mutex?
+ raise
+ seconds->time
+ srfi-18:current-time
+ srfi-18:time?
+ terminated-thread-exception?
+ thread-join!
+ thread-name
+ thread-quantum
+ thread-quantum-set!
+ thread-resume!
+ thread-signal!
+ thread-sleep!
+ thread-specific
+ thread-specific-set!
+ thread-start!
+ thread-state
+ thread-suspend!
+ thread-terminate!
+ thread-wait-for-i/o!
+ thread-yield!
+ thread?
+ time->milliseconds
+ time->seconds
+ time?
+ uncaught-exception-reason
+ uncaught-exception?))
diff --git a/srfi-18.scm b/srfi-18.scm
new file mode 100644
index 00000000..77084324
--- /dev/null
+++ b/srfi-18.scm
@@ -0,0 +1,485 @@
+;;;; srfi-18.scm - Simple thread unit - felix
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit srfi-18)
+ (uses scheduler)
+ (disable-warning redef)
+ (disable-interrupts)
+ (usual-integrations)
+ (hide ##sys#compute-time-limit) )
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ (no-bound-checks)
+ (no-procedure-checks-for-usual-bindings)
+ (bound-to-procedure
+ ##sys#thread-yield!
+ condition-property-accessor ##sys#tty-port? ##sys#thread-block-for-i/o thread-yield! ##sys#thread-unblock!
+ ##sys#thread-basic-unblock! gensym ##sys#thread-block-for-timeout! ##sys#thread-kill!
+ ##sys#thread-block-for-termination! make-thread ##sys#exact->inexact ##sys#flonum-fraction truncate
+ ##sys#add-to-ready-queue
+ ##sys#schedule ##sys#make-thread
+ ##sys#check-number ##sys#error ##sys#signal-hook ##sys#signal
+ ##sys#current-exception-handler ##sys#abandon-mutexes ##sys#check-structure ##sys#structure? ##sys#make-mutex
+ ##sys#delq ##sys#compute-time-limit ##sys#fudge) ) ] )
+
+(include "unsafe-declarations.scm")
+
+(register-feature! 'srfi-18)
+
+(define-syntax dbg
+ (syntax-rules ()
+ ((_ . _) #f)))
+
+
+;;; Helper routines:
+
+(define ##sys#compute-time-limit
+ (let ([truncate truncate])
+ (lambda (tm)
+ (and tm
+ (cond [(##sys#structure? tm 'time) (##sys#slot tm 1)]
+ [(number? tm) (fx+ (##sys#fudge 16) (inexact->exact (truncate (* tm 1000))))]
+ [else (##sys#signal-hook #:type-error "invalid timeout argument" tm)] ) ) ) ) )
+
+
+;;; Time objects:
+
+(declare
+ (foreign-declare #<<EOF
+static C_TLS long C_ms;
+#define C_get_seconds C_seconds(&C_ms)
+EOF
+) )
+
+(define-foreign-variable C_get_seconds double)
+(define-foreign-variable C_startup_time_seconds double)
+(define-foreign-variable C_ms long)
+
+(define (current-time)
+ (let* ([s C_get_seconds]
+ [ss C_startup_time_seconds]
+ [ms C_ms] )
+ (##sys#make-structure
+ 'time
+ (inexact->exact (truncate (+ (* (- s ss) 1000) C_ms)))
+ s
+ C_ms) ) )
+
+(define srfi-18:current-time current-time)
+
+(define (time->seconds tm)
+ (##sys#check-structure tm 'time 'time->seconds)
+ (+ (##sys#slot tm 2) (/ (##sys#slot tm 3) 1000)) )
+
+(define (time->milliseconds tm)
+ (##sys#check-structure tm 'time 'time->milliseconds)
+ (+ (inexact->exact (* (- (##sys#slot tm 2) C_startup_time_seconds) 1000))
+ (##sys#slot tm 3) ) )
+
+(define (seconds->time n)
+ (##sys#check-number n 'seconds->time)
+ (let* ([n2 (max 0 (- n C_startup_time_seconds))] ; seconds since startup
+ [ms (truncate (* 1000 (##sys#flonum-fraction (##sys#exact->inexact n))))] ; milliseconds
+ [n3 (inexact->exact (truncate (+ (* n2 1000) ms)))] ) ; milliseconds since startup
+ (##sys#make-structure 'time n3 (truncate n) (inexact->exact ms)) ) )
+
+(define (milliseconds->time nms)
+ (##sys#check-exact nms 'milliseconds->time)
+ (let ((s (+ C_startup_time_seconds (/ nms 1000))))
+ (##sys#make-structure 'time nms s 0) ) )
+
+(define (time? x) (##sys#structure? x 'time))
+
+(define srfi-18:time? time?)
+
+
+;;; Exception handling:
+
+(define raise ##sys#signal)
+
+(define (join-timeout-exception? x)
+ (and (##sys#structure? x 'condition)
+ (memq 'join-timeout-exception (##sys#slot x 1)) ) )
+
+(define (abandoned-mutex-exception? x)
+ (and (##sys#structure? x 'condition)
+ (memq 'abandoned-mutex-exception (##sys#slot x 1)) ) )
+
+(define (terminated-thread-exception? x)
+ (and (##sys#structure? x 'condition)
+ (memq 'terminated-thread-exception (##sys#slot x 1)) ) )
+
+(define (uncaught-exception? x)
+ (and (##sys#structure? x 'condition)
+ (memq 'uncaught-exception (##sys#slot x 1)) ) )
+
+(define uncaught-exception-reason
+ (condition-property-accessor 'uncaught-exception 'reason) )
+
+
+;;; Threads:
+
+(define make-thread
+ (let ((gensym gensym))
+ (lambda (thunk . name)
+ (let ((thread
+ (##sys#make-thread
+ #f
+ 'created
+ (if (pair? name) (##sys#slot name 0) (gensym 'thread))
+ (##sys#slot ##sys#current-thread 9) ) ) )
+ (##sys#setslot
+ thread 1
+ (lambda ()
+ (##sys#call-with-values
+ thunk
+ (lambda results
+ (##sys#setslot thread 2 results)
+ (##sys#thread-kill! thread 'dead)
+ (##sys#schedule) ) ) ) )
+ thread) ) ) )
+
+(define (thread? x) (##sys#structure? x 'thread))
+(define (current-thread) ##sys#current-thread)
+
+(define (thread-state thread)
+ (##sys#check-structure thread 'thread 'thread-state)
+ (##sys#slot thread 3) )
+
+(define (thread-specific thread)
+ (##sys#check-structure thread 'thread 'thread-specific)
+ (##sys#slot thread 10) )
+
+(define (thread-specific-set! thread x)
+ (##sys#check-structure thread 'thread 'thread-specific-set!)
+ (##sys#setslot thread 10 x) )
+
+(define (thread-quantum thread)
+ (##sys#check-structure thread 'thread 'thread-quantum)
+ (##sys#slot thread 9) )
+
+(define (thread-quantum-set! thread q)
+ (##sys#check-structure thread 'thread 'thread-quantum-set!)
+ (##sys#check-exact q 'thread-quantum-set!)
+ (##sys#setislot thread 9 (fxmax q 10)) )
+
+(define (thread-name x)
+ (##sys#check-structure x 'thread 'thread-name)
+ (##sys#slot x 6) )
+
+(define thread-start!
+ (let ([make-thread make-thread])
+ (lambda (thread)
+ (if (procedure? thread)
+ (set! thread (make-thread thread))
+ (##sys#check-structure thread 'thread 'thread-start!) )
+ (unless (eq? 'created (##sys#slot thread 3))
+ (##sys#error 'thread-start! "thread cannot be started a second time" thread) )
+ (##sys#setslot thread 3 'ready)
+ (##sys#add-to-ready-queue thread)
+ thread) ) )
+
+(define thread-yield! ##sys#thread-yield!) ;In library.scm
+
+(define thread-join!
+ (lambda (thread . timeout)
+ (##sys#check-structure thread 'thread 'thread-join!)
+ (let* ((limit (and (pair? timeout) (##sys#compute-time-limit (##sys#slot timeout 0))))
+ (rest (and (pair? timeout) (##sys#slot timeout 1)))
+ (tosupplied (and rest (pair? rest)))
+ (toval (and tosupplied (##sys#slot rest 0))) )
+ (##sys#call-with-current-continuation
+ (lambda (return)
+ (let ([ct ##sys#current-thread])
+ (when limit (##sys#thread-block-for-timeout! ct limit))
+ (##sys#setslot
+ ct 1
+ (lambda ()
+ (case (##sys#slot thread 3)
+ [(dead)
+ (unless (##sys#slot ct 13) ; not unblocked by timeout
+ (##sys#remove-from-timeout-list ct))
+ (apply return (##sys#slot thread 2))]
+ [(terminated)
+ (return
+ (##sys#signal
+ (##sys#make-structure
+ 'condition '(uncaught-exception)
+ (list '(uncaught-exception . reason) (##sys#slot thread 7)) ) ) ) ]
+ [else
+ (return
+ (if tosupplied
+ toval
+ (##sys#signal
+ (##sys#make-structure 'condition '(join-timeout-exception) '())) ) ) ] ) ) )
+ (##sys#thread-block-for-termination! ct thread)
+ (##sys#schedule) ) ) ) ) ) )
+
+(define (thread-terminate! thread)
+ (##sys#check-structure thread 'thread 'thread-terminate!)
+ (when (eq? thread ##sys#primordial-thread)
+ ((##sys#exit-handler)) )
+ (##sys#setslot thread 2 (list (##core#undefined)))
+ (##sys#setslot thread 7 (##sys#make-structure 'condition '(terminated-thread-exception) '()))
+ (##sys#thread-kill! thread 'terminated)
+ (when (eq? thread ##sys#current-thread) (##sys#schedule)) )
+
+(define (thread-suspend! thread)
+ (##sys#check-structure thread 'thread 'thread-suspend!)
+ (##sys#setslot thread 3 'suspended)
+ (when (eq? thread ##sys#current-thread)
+ (##sys#call-with-current-continuation
+ (lambda (return)
+ (##sys#setslot thread 1 (lambda () (return (##core#undefined))))
+ (##sys#schedule) ) ) ) )
+
+(define (thread-resume! thread)
+ (##sys#check-structure thread 'thread 'thread-resume!)
+ (when (eq? (##sys#slot thread 3) 'suspended)
+ (##sys#setslot thread 3 'ready)
+ (##sys#add-to-ready-queue thread) ) )
+
+(define (thread-sleep! tm)
+ (define (sleep limit loc)
+ (##sys#call-with-current-continuation
+ (lambda (return)
+ (let ((ct ##sys#current-thread))
+ (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
+ (##sys#thread-block-for-timeout! ct limit)
+ (##sys#schedule) ) ) ) )
+ (unless tm (##sys#signal-hook #:type-error 'thread-sleep! "invalid timeout argument" tm))
+ (sleep (##sys#compute-time-limit tm) 'thread-sleep!) )
+
+
+;;; Mutexes:
+
+(define (mutex? x) (##sys#structure? x 'mutex))
+
+(define make-mutex
+ (let ((gensym gensym))
+ (lambda id
+ (let* ((id (if (pair? id) (car id) (gensym 'mutex)))
+ (m (##sys#make-mutex id ##sys#current-thread)) )
+ m) ) ) )
+
+(define (mutex-name x)
+ (##sys#check-structure x 'mutex 'mutex-name)
+ (##sys#slot x 1) )
+
+(define (mutex-specific mutex)
+ (##sys#check-structure mutex 'mutex 'mutex-specific)
+ (##sys#slot mutex 6) )
+
+(define (mutex-specific-set! mutex x)
+ (##sys#check-structure mutex 'mutex 'mutex-specific-set!)
+ (##sys#setslot mutex 6 x) )
+
+(define (mutex-state mutex)
+ (##sys#check-structure mutex 'mutex 'mutex-state)
+ (cond [(##sys#slot mutex 5) (or (##sys#slot mutex 2) 'not-owned)]
+ [(##sys#slot mutex 4) 'abandoned]
+ [else 'not-abandoned] ) )
+
+(define mutex-lock!
+ (lambda (mutex . ms-and-t)
+ (##sys#check-structure mutex 'mutex 'mutex-lock!)
+ (let* ([limitsup (pair? ms-and-t)]
+ [limit (and limitsup (##sys#compute-time-limit (car ms-and-t)))]
+ [threadsup (fx> (length ms-and-t) 1)]
+ [thread (and threadsup (cadr ms-and-t))]
+ [abd (##sys#slot mutex 4)] )
+ (when thread (##sys#check-structure thread 'thread 'mutex-lock!))
+ (##sys#call-with-current-continuation
+ (lambda (return)
+ (let ([ct ##sys#current-thread])
+ (define (switch)
+ (##sys#setslot mutex 3 (##sys#append (##sys#slot mutex 3) (list ct)))
+ (##sys#schedule) )
+ (define (check)
+ (when abd
+ (return (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) '()))) ) )
+ (dbg ct ": locking " mutex)
+ (cond [(not (##sys#slot mutex 5))
+ (if (and threadsup (not thread))
+ (begin
+ (##sys#setislot mutex 2 #f)
+ (##sys#setislot mutex 5 #t) )
+ (let* ([t (or thread ct)]
+ [ts (##sys#slot t 3)] )
+ (if (or (eq? 'terminated ts) (eq? 'dead ts))
+ (##sys#setislot mutex 4 #t)
+ (begin
+ (##sys#setislot mutex 5 #t)
+ (##sys#setslot t 8 (cons mutex (##sys#slot t 8)))
+ (##sys#setslot mutex 2 t) ) ) ) )
+ (check)
+ (return #t) ]
+ [limit
+ (check)
+ (##sys#setslot
+ ct 1
+ (lambda ()
+ (##sys#setslot mutex 3 (##sys#delq ct (##sys#slot mutex 3)))
+ (unless (##sys#slot ct 13) ; not unblocked by timeout
+ (##sys#remove-from-timeout-list ct))
+ (##sys#setslot ct 8 (cons mutex (##sys#slot ct 8)))
+ (##sys#setslot mutex 2 thread)
+ (return #f) ))
+ (##sys#thread-block-for-timeout! ct limit)
+ (switch) ]
+ [else
+ (##sys#setslot ct 3 'sleeping)
+ (##sys#setslot ct 1 (lambda () (return #t)))
+ (switch) ] ) ) ) ) ) ) )
+
+(define mutex-unlock!
+ (lambda (mutex . cvar-and-to)
+ (##sys#check-structure mutex 'mutex 'mutex-unlock!)
+ (let ([ct ##sys#current-thread]
+ [cvar (and (pair? cvar-and-to) (car cvar-and-to))]
+ [timeout (and (fx> (length cvar-and-to) 1) (cadr cvar-and-to))] )
+ (dbg ct ": unlocking " mutex)
+ (when cvar (##sys#check-structure cvar 'condition-variable 'mutex-unlock!))
+ (##sys#call-with-current-continuation
+ (lambda (return)
+ (let ([waiting (##sys#slot mutex 3)]
+ [limit (and timeout (##sys#compute-time-limit timeout))]
+ [result #t] )
+ (##sys#setislot mutex 4 #f)
+ (##sys#setislot mutex 5 #f)
+ (##sys#setslot ct 8 (##sys#delq mutex (##sys#slot ct 8)))
+ (##sys#setslot ct 1 (lambda () (return result)))
+ (when cvar
+ (##sys#setslot cvar 2 (##sys#append (##sys#slot cvar 2) (##sys#list ct)))
+ (cond [limit
+ (##sys#setslot
+ ct 1
+ (lambda ()
+ (##sys#setslot cvar 2 (##sys#delq ct (##sys#slot cvar 2)))
+ (unless (##sys#slot ct 13) ; not unblocked by timeout
+ (##sys#remove-from-timeout-list ct))
+ (return #f) ) )
+ (##sys#thread-block-for-timeout! ct limit) ]
+ [else
+ (##sys#setslot ct 3 'sleeping)] ) )
+ (unless (null? waiting)
+ (let* ([wt (##sys#slot waiting 0)]
+ [wts (##sys#slot wt 3)] )
+ (##sys#setslot mutex 3 (##sys#slot waiting 1))
+ (##sys#setislot mutex 5 #t)
+ (when (or (eq? wts 'blocked) (eq? wts 'sleeping))
+ (##sys#setslot mutex 2 wt)
+ (##sys#setslot wt 8 (cons mutex (##sys#slot wt 8)))
+ (when (eq? wts 'sleeping) (##sys#add-to-ready-queue wt) ) ) ) )
+ (##sys#schedule) ) ) ) ) ) )
+
+
+;;; Condition variables:
+
+(define make-condition-variable
+ (let ([gensym gensym])
+ (lambda name
+ (##sys#make-structure
+ 'condition-variable
+ (if (pair? name) ; #1 name
+ (car name)
+ (gensym 'condition-variable) )
+ '() ; #2 list of waiting threads
+ (##core#undefined) ) ) ) ) ; #3 specific
+
+(define (condition-variable? x)
+ (##sys#structure? x 'condition-variable) )
+
+(define (condition-variable-specific cv)
+ (##sys#check-structure cv 'condition-variable 'condition-variable-specific)
+ (##sys#slot cv 3) )
+
+(define (condition-variable-specific-set! cv x)
+ (##sys#check-structure cv 'condition-variable 'condition-variable-specific-set!)
+ (##sys#setslot cv 3 x) )
+
+(define (condition-variable-signal! cvar)
+ (##sys#check-structure cvar 'condition-variable 'condition-variable-signal!)
+ (dbg "signalling " cvar)
+ (let ([ts (##sys#slot cvar 2)])
+ (unless (null? ts)
+ (let* ([t0 (##sys#slot ts 0)]
+ [t0s (##sys#slot t0 3)] )
+ (##sys#setslot cvar 2 (##sys#slot ts 1))
+ (when (or (eq? t0s 'blocked) (eq? t0s 'sleeping))
+ (##sys#thread-basic-unblock! t0) ) ) ) ) )
+
+(define (condition-variable-broadcast! cvar)
+ (##sys#check-structure cvar 'condition-variable 'condition-variable-broadcast!)
+ (dbg "broadcasting " cvar)
+ (##sys#for-each
+ (lambda (ti)
+ (let ([tis (##sys#slot ti 3)])
+ (when (or (eq? tis 'blocked) (eq? tis 'sleeping))
+ (##sys#thread-basic-unblock! ti) ) ) )
+ (##sys#slot cvar 2) )
+ (##sys#setislot cvar 2 '()) )
+
+
+;;; Change continuation of thread to signal an exception:
+
+(define (thread-signal! thread exn)
+ (##sys#check-structure thread 'thread 'thread-signal!)
+ (if (eq? thread ##sys#current-thread)
+ (##sys#signal exn)
+ (let ([old (##sys#slot thread 1)])
+ (##sys#setslot
+ thread 1
+ (lambda ()
+ (##sys#signal exn)
+ (old) ) )
+ (##sys#thread-unblock! thread) ) ) )
+
+
+;;; Don't block in the repl: (by Chris Double)
+
+(unless (eq? (build-platform) 'msvc)
+ (set! ##sys#read-prompt-hook
+ (let ([old ##sys#read-prompt-hook]
+ [thread-yield! thread-yield!] )
+ (lambda ()
+ (when (or (##sys#fudge 12) (##sys#tty-port? ##sys#standard-input))
+ (old)
+ (##sys#thread-block-for-i/o! ##sys#current-thread 0 #t)
+ (thread-yield!)))) ) )
+
+
+;;; Waiting for I/O on file-descriptor
+
+(define (thread-wait-for-i/o! fd #!optional (mode #:all))
+ (##sys#check-exact fd 'thread-wait-for-i/o!)
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd mode)
+ (thread-yield!) )
diff --git a/srfi-4.import.scm b/srfi-4.import.scm
new file mode 100644
index 00000000..18194ecd
--- /dev/null
+++ b/srfi-4.import.scm
@@ -0,0 +1,144 @@
+;;;; srfi-4.import.scm - import library for "srfi-4" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'srfi-4
+ '(blob->f32vector
+ blob->f32vector/shared
+ blob->f64vector
+ blob->f64vector/shared
+ blob->s16vector
+ blob->s16vector/shared
+ blob->s32vector
+ blob->s32vector/shared
+ blob->s8vector
+ blob->s8vector/shared
+ blob->u16vector
+ blob->u16vector/shared
+ blob->u32vector
+ blob->u32vector/shared
+ blob->u8vector
+ blob->u8vector/shared
+ f32vector
+ f32vector->blob
+ f32vector->blob/shared
+ f32vector->byte-vector
+ f32vector->list
+ f32vector-length
+ f32vector-ref
+ f32vector-set!
+ f32vector?
+ f64vector
+ f64vector->blob
+ f64vector->blob/shared
+ f64vector->byte-vector
+ f64vector->list
+ f64vector-length
+ f64vector-ref
+ f64vector-set!
+ f64vector?
+ list->f32vector
+ list->f64vector
+ list->s16vector
+ list->s32vector
+ list->s8vector
+ list->u16vector
+ list->u32vector
+ list->u8vector
+ make-f32vector
+ make-f64vector
+ make-s16vector
+ make-s32vector
+ make-s8vector
+ make-u16vector
+ make-u32vector
+ make-u8vector
+ read-u8vector
+ read-u8vector!
+ release-number-vector
+ s16vector
+ s16vector->blob
+ s16vector->blob/shared
+ s16vector->byte-vector
+ s16vector->list
+ s16vector-length
+ s16vector-ref
+ s16vector-set!
+ s16vector?
+ s32vector
+ s32vector->blob
+ s32vector->blob/shared
+ s32vector->byte-vector
+ s32vector->list
+ s32vector-length
+ s32vector-ref
+ s32vector-set!
+ s32vector?
+ s8vector
+ s8vector->blob
+ s8vector->blob/shared
+ s8vector->byte-vector
+ s8vector->list
+ s8vector-length
+ s8vector-ref
+ s8vector-set!
+ s8vector?
+ subf32vector
+ subf64vector
+ subs16vector
+ subs32vector
+ subs8vector
+ subu16vector
+ subu32vector
+ subu8vector
+ u16vector
+ u16vector->blob
+ u16vector->blob/shared
+ u16vector->byte-vector
+ u16vector->list
+ u16vector-length
+ u16vector-ref
+ u16vector-set!
+ u16vector?
+ u32vector
+ u32vector->blob
+ u32vector->blob/shared
+ u32vector->byte-vector
+ u32vector->list
+ u32vector-length
+ u32vector-ref
+ u32vector-set!
+ u32vector?
+ u8vector
+ u8vector->blob
+ u8vector->blob/shared
+ u8vector->byte-vector
+ u8vector->list
+ u8vector-length
+ u8vector-ref
+ u8vector-set!
+ u8vector?
+ write-u8vector))
diff --git a/srfi-4.scm b/srfi-4.scm
new file mode 100644
index 00000000..f6bdc0db
--- /dev/null
+++ b/srfi-4.scm
@@ -0,0 +1,671 @@
+;;;; srfi-4.scm - Homogeneous numeric vectors
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit srfi-4)
+ (disable-interrupts)
+ (disable-warning redef)
+ (usual-integrations)
+ (hide ##sys#u8vector-set! ##sys#s8vector-set! ##sys#u16vector-set! ##sys#s16vector-set!
+ ##sys#u32vector-set! ##sys#s32vector-set! ##sys#f32vector-set! ##sys#f64vector-set!
+ ##sys#u8vector-ref ##sys#s8vector-ref ##sys#u16vector-ref ##sys#s16vector-ref subvector
+ ##sys#u32vector-ref ##sys#s32vector-ref ##sys#f32vector-ref ##sys#f64vector-ref)
+ (not inline ##sys#user-print-hook ##sys#number-hash-hook)
+ (foreign-declare #<<EOF
+#define C_u8peek(b, i) C_fix(((unsigned char *)C_data_pointer(b))[ C_unfix(i) ])
+#define C_s8peek(b, i) C_fix(((char *)C_data_pointer(b))[ C_unfix(i) ])
+#define C_u16peek(b, i) C_fix(((unsigned short *)C_data_pointer(b))[ C_unfix(i) ])
+#define C_s16peek(b, i) C_fix(((short *)C_data_pointer(b))[ C_unfix(i) ])
+#ifdef C_SIXTY_FOUR
+# define C_a_u32peek(ptr, d, b, i) C_fix(((C_u32 *)C_data_pointer(b))[ C_unfix(i) ])
+# define C_a_s32peek(ptr, d, b, i) C_fix(((C_s32 *)C_data_pointer(b))[ C_unfix(i) ])
+#else
+# define C_a_u32peek(ptr, d, b, i) C_unsigned_int_to_num(ptr, ((C_u32 *)C_data_pointer(b))[ C_unfix(i) ])
+# define C_a_s32peek(ptr, d, b, i) C_int_to_num(ptr, ((C_s32 *)C_data_pointer(b))[ C_unfix(i) ])
+#endif
+#define C_f32peek(b, i) (C_temporary_flonum = ((float *)C_data_pointer(b))[ C_unfix(i) ], C_SCHEME_UNDEFINED)
+#define C_f64peek(b, i) (C_temporary_flonum = ((double *)C_data_pointer(b))[ C_unfix(i) ], C_SCHEME_UNDEFINED)
+#define C_u8poke(b, i, x) ((((unsigned char *)C_data_pointer(b))[ C_unfix(i) ] = C_unfix(x)), C_SCHEME_UNDEFINED)
+#define C_s8poke(b, i, x) ((((char *)C_data_pointer(b))[ C_unfix(i) ] = C_unfix(x)), C_SCHEME_UNDEFINED)
+#define C_u16poke(b, i, x) ((((unsigned short *)C_data_pointer(b))[ C_unfix(i) ] = C_unfix(x)), C_SCHEME_UNDEFINED)
+#define C_s16poke(b, i, x) ((((short *)C_data_pointer(b))[ C_unfix(i) ] = C_unfix(x)), C_SCHEME_UNDEFINED)
+#define C_u32poke(b, i, x) ((((C_u32 *)C_data_pointer(b))[ C_unfix(i) ] = C_num_to_unsigned_int(x)), C_SCHEME_UNDEFINED)
+#define C_s32poke(b, i, x) ((((C_s32 *)C_data_pointer(b))[ C_unfix(i) ] = C_num_to_int(x)), C_SCHEME_UNDEFINED)
+#define C_f32poke(b, i, x) ((((float *)C_data_pointer(b))[ C_unfix(i) ] = C_flonum_magnitude(x)), C_SCHEME_UNDEFINED)
+#define C_f64poke(b, i, x) ((((double *)C_data_pointer(b))[ C_unfix(i) ] = C_flonum_magnitude(x)), C_SCHEME_UNDEFINED)
+#define C_copy_subvector(to, from, start_to, start_from, bytes) \
+ (C_memcpy((C_char *)C_data_pointer(to) + C_unfix(start_to), (C_char *)C_data_pointer(from) + C_unfix(start_from), C_unfix(bytes)), \
+ C_SCHEME_UNDEFINED)
+EOF
+) )
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ (no-bound-checks)
+ (no-procedure-checks-for-usual-bindings)
+ (bound-to-procedure
+ ##sys#check-exact ##sys#u8vector-ref ##sys#u8vector-set! ##sys#s8vector-ref ##sys#s8vector-set!
+ ##sys#u16vector-ref ##sys#u16vector-set!
+ ##sys#s16vector-ref ##sys#s16vector-set! ##sys#u32vector-ref ##sys#u32vector-set! ##sys#s32vector-ref
+ ##sys#s32vector-set! read list->f64vector list->s32vector list->u32vector list->u16vector list-s8vector
+ list->u8vector set-finalizer!
+ ##sys#f32vector-ref ##sys#f32vector-set! ##sys#f64vector-ref ##sys#f64vector-set! ##sys#check-exact-interval
+ ##sys#check-inexact-interval ##sys#check-number ##sys#check-structure ##sys#cons-flonum ##sys#check-list
+ ##sys#check-range ##sys#error ##sys#signal-hook
+ ##sys#error-not-a-proper-list ##sys#print ##sys#allocate-vector) ) ] )
+
+(include "unsafe-declarations.scm")
+
+
+;;; Helper routines:
+
+(define ##sys#check-exact-interval
+ (lambda (n from to loc)
+ (##sys#check-exact n loc)
+ (if (or (##core#inline "C_fixnum_lessp" n from)
+ (##core#inline "C_fixnum_greaterp" n to) )
+ (##sys#error loc "numeric value is not in expected range" n from to) ) ) )
+
+(define ##sys#check-inexact-interval
+ (lambda (n from to loc)
+ (##sys#check-number n loc)
+ (if (or (< n from) (> n to))
+ (##sys#error "numeric value is not in expected range" n from to) ) ) )
+
+
+;;; Primitive accessors:
+
+(define (##sys#u8vector-ref v i) (##core#inline "C_u8peek" (##core#inline "C_slot" v 1) i))
+(define (##sys#s8vector-ref v i) (##core#inline "C_s8peek" (##core#inline "C_slot" v 1) i))
+(define (##sys#u16vector-ref v i) (##core#inline "C_u16peek" (##core#inline "C_slot" v 1) i))
+(define (##sys#s16vector-ref v i) (##core#inline "C_s16peek" (##core#inline "C_slot" v 1) i))
+(define (##sys#u32vector-ref v i) (##core#inline_allocate ("C_a_u32peek" 4) (##core#inline "C_slot" v 1) i))
+(define (##sys#s32vector-ref v i) (##core#inline_allocate ("C_a_s32peek" 4) (##core#inline "C_slot" v 1) i))
+
+(define (##sys#f32vector-ref v i)
+ (##core#inline "C_f32peek" (##core#inline "C_slot" v 1) i)
+ (##sys#cons-flonum) )
+
+(define (##sys#f64vector-ref v i)
+ (##core#inline "C_f64peek" (##core#inline "C_slot" v 1) i)
+ (##sys#cons-flonum) )
+
+(define (##sys#u8vector-set! v i x) (##core#inline "C_u8poke" (##core#inline "C_slot" v 1) i x))
+(define (##sys#s8vector-set! v i x) (##core#inline "C_s8poke" (##core#inline "C_slot" v 1) i x))
+(define (##sys#u16vector-set! v i x) (##core#inline "C_u16poke" (##core#inline "C_slot" v 1) i x))
+(define (##sys#s16vector-set! v i x) (##core#inline "C_s16poke" (##core#inline "C_slot" v 1) i x))
+(define (##sys#u32vector-set! v i x) (##core#inline "C_u32poke" (##core#inline "C_slot" v 1) i x))
+(define (##sys#s32vector-set! v i x) (##core#inline "C_s32poke" (##core#inline "C_slot" v 1) i x))
+(define (##sys#f32vector-set! v i x) (##core#inline "C_f32poke" (##core#inline "C_slot" v 1) i x))
+(define (##sys#f64vector-set! v i x) (##core#inline "C_f64poke" (##core#inline "C_slot" v 1) i x))
+
+
+;;; Get vector length:
+
+(let ()
+
+ (define (len tag shift loc)
+ (lambda (v)
+ (##sys#check-structure v tag loc)
+ (let ((bytes (##core#inline "C_block_size" (##core#inline "C_slot" v 1))))
+ (if shift
+ (##core#inline "C_fixnum_shift_right" bytes shift)
+ bytes) ) ) )
+
+ (set! u8vector-length (len 'u8vector #f 'u8vector-length))
+ (set! s8vector-length (len 's8vector #f 's8vector-length))
+ (set! u16vector-length (len 'u16vector 1 'u16vector-length))
+ (set! s16vector-length (len 's16vector 1 's16vector-length))
+ (set! u32vector-length (len 'u32vector 2 'u32vector-length))
+ (set! s32vector-length (len 's32vector 2 's32vector-length))
+ (set! f32vector-length (len 'f32vector 2 'f32vector-length))
+ (set! f64vector-length (len 'f64vector 3 'f64vector-length)) )
+
+
+;;; Safe accessors:
+
+(let ()
+
+ (define (get length acc loc)
+ (lambda (v i)
+ (let ((len (length v)))
+ (##sys#check-range i 0 len loc)
+ (acc v i) ) ) )
+
+ (define (set length upd loc)
+ (lambda (v i x)
+ (let ((len (length v)))
+ (##sys#check-exact x loc)
+ (##sys#check-range i 0 len loc)
+ (upd v i x) ) ) )
+
+ (define (setu length upd loc)
+ (lambda (v i x)
+ (let ((len (length v)))
+ (##sys#check-exact x loc)
+ (if (fx< x 0)
+ (##sys#error loc "argument may not be negative" x) )
+ (##sys#check-range i 0 len loc)
+ (upd v i x) ) ) )
+
+ (define (setw length upd loc)
+ (lambda (v i x)
+ (let ((len (length v)))
+ (if (not (##sys#fits-in-int? x))
+ (##sys#error loc "argument exceeds integer range" x) )
+ (##sys#check-range i 0 len loc)
+ (upd v i x) ) ) )
+
+ (define (setuw length upd loc)
+ (lambda (v i x)
+ (let ((len (length v)))
+ (cond ((negative? x)
+ (##sys#error loc "argument may not be negative" x) )
+ ((not (##sys#fits-in-unsigned-int? x))
+ (##sys#error loc "argument exceeds integer range" x) ) )
+ (##sys#check-range i 0 len loc)
+ (upd v i x) ) ) )
+
+ (define (setf length upd loc)
+ (lambda (v i x)
+ (let ((len (length v)))
+ (##sys#check-number x loc)
+ (##sys#check-range i 0 len loc)
+ (upd v i (if (##core#inline "C_blockp" x)
+ x
+ (exact->inexact x) ) ) ) ) )
+
+ (set! u8vector-set! (setu u8vector-length ##sys#u8vector-set! 'u8vector-set!))
+ (set! s8vector-set! (set s8vector-length ##sys#s8vector-set! 's8vector-set!))
+ (set! u16vector-set! (setu u16vector-length ##sys#u16vector-set! 'u16vector-set!))
+ (set! s16vector-set! (set s16vector-length ##sys#s16vector-set! 's16vector-set!))
+ (set! u32vector-set! (setuw u32vector-length ##sys#u32vector-set! 'u32vector-set!))
+ (set! s32vector-set! (setw s32vector-length ##sys#s32vector-set! 's32vector-set!))
+ (set! f32vector-set! (setf f32vector-length ##sys#f32vector-set! 'f32vector-set!))
+ (set! f64vector-set! (setf f64vector-length ##sys#f64vector-set! 'f64vector-set!))
+
+ (set! u8vector-ref
+ (getter-with-setter (get u8vector-length ##sys#u8vector-ref 'u8vector-ref)
+ u8vector-set!) )
+ (set! s8vector-ref
+ (getter-with-setter (get s8vector-length ##sys#s8vector-ref 's8vector-ref)
+ s8vector-set!) )
+ (set! u16vector-ref
+ (getter-with-setter (get u16vector-length ##sys#u16vector-ref 'u16vector-ref)
+ u16vector-set!) )
+ (set! s16vector-ref
+ (getter-with-setter (get s16vector-length ##sys#s16vector-ref 's16vector-ref)
+ s16vector-set!) )
+ (set! u32vector-ref
+ (getter-with-setter
+ (get u32vector-length ##sys#u32vector-ref 'u32vector-ref)
+ u32vector-set!) )
+ (set! s32vector-ref
+ (getter-with-setter
+ (get s32vector-length ##sys#s32vector-ref 's32vector-ref)
+ s32vector-set!) )
+ (set! f32vector-ref
+ (getter-with-setter
+ (get f32vector-length ##sys#f32vector-ref 'f32vector-ref)
+ f32vector-set!) )
+ (set! f64vector-ref
+ (getter-with-setter
+ (get f64vector-length ##sys#f64vector-ref 'f64vector-ref)
+ f64vector-set!) ) )
+
+
+
+;;; Basic constructors:
+
+(let* ([ext-alloc
+ (foreign-lambda* scheme-object ([int bytes])
+ "C_word *buf = (C_word *)C_malloc(bytes + sizeof(C_header));"
+ "if(buf == NULL) return(C_SCHEME_FALSE);"
+ "C_block_header(buf) = C_make_header(C_BYTEVECTOR_TYPE, bytes);"
+ "return(buf);") ]
+ [ext-free
+ (foreign-lambda* void ([scheme-object bv])
+ "C_free((void *)C_block_item(bv, 1));") ]
+ [set-finalizer! set-finalizer!]
+ [alloc
+ (lambda (loc len ext?)
+ (if ext?
+ (let ([bv (ext-alloc len)])
+ (or bv
+ (##sys#error loc "not enough memory - cannot allocate external number vector" len)) )
+ (let ([bv (##sys#allocate-vector len #t #f #t)]) ; this could be made better...
+ (##core#inline "C_string_to_bytevector" bv)
+ bv) ) ) ] )
+
+ (set! release-number-vector
+ (lambda (v)
+ (if (and (##sys#generic-structure? v)
+ (memq (##sys#slot v 0) '(u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector)) )
+ (ext-free v)
+ (##sys#error 'release-number-vector "bad argument type - not a number vector" v)) ) )
+
+ (set! make-u8vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin? #t))
+ (##sys#check-exact len 'make-u8vector)
+ (let ((v (##sys#make-structure 'u8vector (alloc 'make-u8vector len ext?))))
+ (when (and ext? fin?) (set-finalizer! v ext-free))
+ (if (not init)
+ v
+ (begin
+ (##sys#check-exact-interval init 0 #xff 'make-u8vector)
+ (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
+ ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
+ (##sys#u8vector-set! v i init) ) ) ) ) ) )
+
+ (set! make-s8vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin #t))
+ (##sys#check-exact len 'make-s8vector)
+ (let ((v (##sys#make-structure 's8vector (alloc 'make-s8vector len ext?))))
+ (when (and ext? fin?) (set-finalizer! v ext-free))
+ (if (not init)
+ v
+ (begin
+ (##sys#check-exact-interval init -128 127 'make-s8vector)
+ (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
+ ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
+ (##sys#s8vector-set! v i init) ) ) ) ) ) )
+
+ (set! make-u16vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin #t))
+ (##sys#check-exact len 'make-u16vector)
+ (let ((v (##sys#make-structure 'u16vector (alloc 'make-u16vector (##core#inline "C_fixnum_shift_left" len 1) ext?))))
+ (when (and ext? fin?) (set-finalizer! v ext-free))
+ (if (not init)
+ v
+ (begin
+ (##sys#check-exact-interval init 0 #xffff 'make-u16vector)
+ (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
+ ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
+ (##sys#u16vector-set! v i init) ) ) ) ) ) )
+
+ (set! make-s16vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin #t))
+ (##sys#check-exact len 'make-s16vector)
+ (let ((v (##sys#make-structure 's16vector (alloc 'make-s16vector (##core#inline "C_fixnum_shift_left" len 1) ext?))))
+ (when (and ext? fin?) (set-finalizer! v ext-free))
+ (if (not init)
+ v
+ (begin
+ (##sys#check-exact-interval init -32768 32767 'make-s16vector)
+ (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
+ ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
+ (##sys#s16vector-set! v i init) ) ) ) ) ) )
+
+ (set! make-u32vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin #t))
+ (##sys#check-exact len 'make-u32vector)
+ (let ((v (##sys#make-structure 'u32vector (alloc 'make-u32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
+ (when (and ext? fin?) (set-finalizer! v ext-free))
+ (if (not init)
+ v
+ (begin
+ (##sys#check-exact init 'make-u32vector)
+ (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
+ ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
+ (##sys#u32vector-set! v i init) ) ) ) ) ) )
+
+ (set! make-s32vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin #t))
+ (##sys#check-exact len 'make-s32vector)
+ (let ((v (##sys#make-structure 's32vector (alloc 'make-s32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
+ (when (and ext? fin?) (set-finalizer! v ext-free))
+ (if (not init)
+ v
+ (begin
+ (##sys#check-exact init 'make-s32vector)
+ (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
+ ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
+ (##sys#s32vector-set! v i init) ) ) ) ) ) )
+
+ (set! make-f32vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin #t))
+ (##sys#check-exact len 'make-f32vector)
+ (let ((v (##sys#make-structure 'f32vector (alloc 'make-f32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
+ (when (and ext? fin?) (set-finalizer! v ext-free))
+ (if (not init)
+ v
+ (begin
+ (##sys#check-number init 'make-f32vector)
+ (unless (##core#inline "C_blockp" init)
+ (set! init (exact->inexact init)) )
+ (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
+ ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
+ (##sys#f32vector-set! v i init) ) ) ) ) ) )
+
+ (set! make-f64vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin #t))
+ (##sys#check-exact len 'make-f64vector)
+ (let ((v (##sys#make-structure 'f64vector (alloc 'make-f64vector (##core#inline "C_fixnum_shift_left" len 3) ext?))))
+ (when (and ext? fin?) (set-finalizer! v ext-free))
+ (if (not init)
+ v
+ (begin
+ (##sys#check-number init 'make-f64vector)
+ (unless (##core#inline "C_blockp" init)
+ (set! init (exact->inexact init)) )
+ (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
+ ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
+ (##sys#f64vector-set! v i init) ) ) ) ) ) ) )
+
+
+;;; Creating vectors from a list:
+
+(let ()
+
+ (define (init make set loc)
+ (lambda (lst)
+ (##sys#check-list lst loc)
+ (let* ((n (length lst))
+ (v (make n)) )
+ (do ((p lst (##core#inline "C_slot" p 1))
+ (i 0 (##core#inline "C_fixnum_plus" i 1)) )
+ ((##core#inline "C_eqp" p '()) v)
+ (if (and (##core#inline "C_blockp" p) (##core#inline "C_pairp" p))
+ (set v i (##core#inline "C_slot" p 0))
+ (##sys#error-not-a-proper-list lst) ) ) ) ) )
+
+ (set! list->u8vector (init make-u8vector u8vector-set! 'list->u8vector))
+ (set! list->s8vector (init make-s8vector s8vector-set! 'list->s8vector))
+ (set! list->u16vector (init make-u16vector u16vector-set! 'list->u16vector))
+ (set! list->s16vector (init make-s16vector s16vector-set! 'list->s16vector))
+ (set! list->u32vector (init make-u32vector u32vector-set! 'list->u32vector))
+ (set! list->s32vector (init make-s32vector s32vector-set! 'list->s32vector))
+ (set! list->f32vector (init make-f32vector f32vector-set! 'list->f32vector))
+ (set! list->f64vector (init make-f64vector f64vector-set! 'list->f64vector)) )
+
+
+;;; More constructors:
+
+(define u8vector
+ (let ((list->u8vector list->u8vector))
+ (lambda xs (list->u8vector xs)) ) )
+
+(define s8vector
+ (let ((list->s8vector list->s8vector))
+ (lambda xs (list->s8vector xs)) ) )
+
+(define u16vector
+ (let ((list->u16vector list->u16vector))
+ (lambda xs (list->u16vector xs)) ) )
+
+(define s16vector
+ (let ((list->s16vector list->s16vector))
+ (lambda xs (list->s16vector xs)) ) )
+
+(define u32vector
+ (let ((list->u32vector list->u32vector))
+ (lambda xs (list->u32vector xs)) ) )
+
+(define s32vector
+ (let ((list->s32vector list->s32vector))
+ (lambda xs (list->s32vector xs)) ) )
+
+(define f32vector
+ (let ((list->f32vector list->f32vector))
+ (lambda xs (list->f32vector xs)) ) )
+
+(define f64vector
+ (let ((list->f64vector list->f64vector))
+ (lambda xs (list->f64vector xs)) ) )
+
+
+;;; Creating lists from a vector:
+
+(let ()
+
+ (define (init tag length ref)
+ (lambda (v)
+ (let ((len (length v)))
+ (let loop ((i 0))
+ (if (fx>= i len)
+ '()
+ (cons (ref v i)
+ (loop (fx+ i 1)) ) ) ) ) ) )
+
+ (set! u8vector->list (init 'u8vector u8vector-length ##sys#u8vector-ref))
+ (set! s8vector->list (init 's8vector s8vector-length ##sys#s8vector-ref))
+ (set! u16vector->list (init 'u16vector u16vector-length ##sys#u16vector-ref))
+ (set! s16vector->list (init 's16vector s16vector-length ##sys#s16vector-ref))
+ (set! u32vector->list (init 'u32vector u32vector-length ##sys#u32vector-ref))
+ (set! s32vector->list (init 's32vector s32vector-length ##sys#s32vector-ref))
+ (set! f32vector->list (init 'f32vector f32vector-length ##sys#f32vector-ref))
+ (set! f64vector->list (init 'f64vector f64vector-length ##sys#f64vector-ref)) )
+
+
+;;; Predicates:
+
+(define (u8vector? x) (##sys#structure? x 'u8vector))
+(define (s8vector? x) (##sys#structure? x 's8vector))
+(define (u16vector? x) (##sys#structure? x 'u16vector))
+(define (s16vector? x) (##sys#structure? x 's16vector))
+(define (u32vector? x) (##sys#structure? x 'u32vector))
+(define (s32vector? x) (##sys#structure? x 's32vector))
+(define (f32vector? x) (##sys#structure? x 'f32vector))
+(define (f64vector? x) (##sys#structure? x 'f64vector))
+
+
+;;; Accessing the packed bytevector:
+
+(let ()
+
+ (define (pack tag loc)
+ (lambda (v)
+ (##sys#check-structure v tag loc)
+ (##sys#slot v 1) ) )
+
+ (define (pack-copy tag loc)
+ (lambda (v)
+ (##sys#check-structure v tag loc)
+ (let* ((old (##sys#slot v 1))
+ (new (##sys#make-blob (##sys#size old))))
+ (##core#inline "C_copy_block" old new) ) ) )
+
+ (define (unpack tag sz loc)
+ (lambda (str)
+ (##sys#check-byte-vector str loc)
+ (let ([len (##sys#size str)])
+ (if (or (eq? #t sz)
+ (eq? 0 (##core#inline "C_fixnum_modulo" len sz)))
+ (##sys#make-structure tag str)
+ (##sys#error loc "blob does not have correct size for packing" tag len sz) ) ) ) )
+
+ (define (unpack-copy tag sz loc)
+ (lambda (str)
+ (##sys#check-byte-vector str loc)
+ (let* ((len (##sys#size str))
+ (new (##sys#make-blob len)))
+ (if (or (eq? #t sz)
+ (eq? 0 (##core#inline "C_fixnum_modulo" len sz)))
+ (##sys#make-structure
+ tag
+ (##core#inline "C_copy_block" str new) )
+ (##sys#error loc "blob does not have correct size for packing" tag len sz) ) ) ) )
+
+ (set! u8vector->blob/shared (pack 'u8vector 'u8vector->blob/shared))
+ (set! s8vector->blob/shared (pack 's8vector 's8vector->blob/shared))
+ (set! u16vector->blob/shared (pack 'u16vector 'u16vector->blob/shared))
+ (set! s16vector->blob/shared (pack 's16vector 's16vector->blob/shared))
+ (set! u32vector->blob/shared (pack 'u32vector 'u32vector->blob/shared))
+ (set! s32vector->blob/shared (pack 's32vector 's32vector->blob/shared))
+ (set! f32vector->blob/shared (pack 'f32vector 'f32vector->blob/shared))
+ (set! f64vector->blob/shared (pack 'f64vector 'f64vector->blob/shared))
+
+ (set! u8vector->blob (pack-copy 'u8vector 'u8vector->blob))
+ (set! s8vector->blob (pack-copy 's8vector 's8vector->blob))
+ (set! u16vector->blob (pack-copy 'u16vector 'u16vector->blob))
+ (set! s16vector->blob (pack-copy 's16vector 's16vector->blob))
+ (set! u32vector->blob (pack-copy 'u32vector 'u32vector->blob))
+ (set! s32vector->blob (pack-copy 's32vector 's32vector->blob))
+ (set! f32vector->blob (pack-copy 'f32vector 'f32vector->blob))
+ (set! f64vector->blob (pack-copy 'f64vector 'f64vector->blob))
+
+ (set! blob->u8vector/shared (unpack 'u8vector #t 'blob->u8vector/shared))
+ (set! blob->s8vector/shared (unpack 's8vector #t 'blob->s8vector/shared))
+ (set! blob->u16vector/shared (unpack 'u16vector 2 'blob->u16vector/shared))
+ (set! blob->s16vector/shared (unpack 's16vector 2 'blob->s16vector/shared))
+ (set! blob->u32vector/shared (unpack 'u32vector 4 'blob->u32vector/shared))
+ (set! blob->s32vector/shared (unpack 's32vector 4 'blob->s32vector/shared))
+ (set! blob->f32vector/shared (unpack 'f32vector 4 'blob->f32vector/shared))
+ (set! blob->f64vector/shared (unpack 'f64vector 8 'blob->f64vector/shared))
+
+ (set! blob->u8vector (unpack-copy 'u8vector #t 'blob->u8vector))
+ (set! blob->s8vector (unpack-copy 's8vector #t 'blob->s8vector))
+ (set! blob->u16vector (unpack-copy 'u16vector 2 'blob->u16vector))
+ (set! blob->s16vector (unpack-copy 's16vector 2 'blob->s16vector))
+ (set! blob->u32vector (unpack-copy 'u32vector 4 'blob->u32vector))
+ (set! blob->s32vector (unpack-copy 's32vector 4 'blob->s32vector))
+ (set! blob->f32vector (unpack-copy 'f32vector 4 'blob->f32vector))
+ (set! blob->f64vector (unpack-copy 'f64vector 8 'blob->f64vector)) )
+
+
+;;; Read syntax:
+
+(set! ##sys#user-read-hook
+ (let ([old-hook ##sys#user-read-hook]
+ [read read]
+ [consers (list 'u8 list->u8vector
+ 's8 list->s8vector
+ 'u16 list->u16vector
+ 's16 list->s16vector
+ 'u32 list->u32vector
+ 's32 list->s32vector
+ 'f32 list->f32vector
+ 'f64 list->f64vector) ] )
+ (lambda (char port)
+ (if (memq char '(#\u #\s #\f #\U #\S #\F))
+ (let* ([x (read port)]
+ [tag (and (symbol? x) x)] )
+ (cond [(or (eq? tag 'f) (eq? tag 'F)) #f]
+ [(memq tag consers) => (lambda (c) ((##sys#slot (##sys#slot c 1) 0) (read port)))]
+ [else (##sys#read-error port "illegal bytevector syntax" tag)] ) )
+ (old-hook char port) ) ) ) )
+
+
+;;; Printing:
+
+(set! ##sys#user-print-hook
+ (let ((old-hook ##sys#user-print-hook))
+ (lambda (x readable port)
+ (let ((tag (assq (##core#inline "C_slot" x 0)
+ `((u8vector u8 ,u8vector->list)
+ (s8vector s8 ,s8vector->list)
+ (u16vector u16 ,u16vector->list)
+ (s16vector s16 ,s16vector->list)
+ (u32vector u32 ,u32vector->list)
+ (s32vector s32 ,s32vector->list)
+ (f32vector f32 ,f32vector->list)
+ (f64vector f64 ,f64vector->list) ) ) ) )
+ (cond (tag
+ (##sys#print #\# #f port)
+ (##sys#print (cadr tag) #f port)
+ (##sys#print ((caddr tag) x) #t port) )
+ (else (old-hook x readable port)) ) ) ) ) )
+
+
+;;; Subvectors:
+
+(define (subvector v t es from to loc)
+ (##sys#check-structure v t loc)
+ (let* ([bv (##sys#slot v 1)]
+ [len (##sys#size bv)]
+ [ilen (##core#inline "C_fixnum_divide" len es)] )
+ (##sys#check-range from 0 (fx+ ilen 1) loc)
+ (##sys#check-range to 0 (fx+ ilen 1) loc)
+ (let* ([size2 (fx* es (fx- to from))]
+ [bv2 (##sys#allocate-vector size2 #t #f #t)] )
+ (##core#inline "C_string_to_bytevector" bv2)
+ (let ([v (##sys#make-structure t bv2)])
+ (##core#inline "C_copy_subvector" bv2 bv 0 (fx* from es) size2)
+ v) ) ) )
+
+(define (subu8vector v from to) (subvector v 'u8vector 1 from to 'subu8vector))
+(define (subu16vector v from to) (subvector v 'u16vector 2 from to 'subu16vector))
+(define (subu32vector v from to) (subvector v 'u32vector 4 from to 'subu32vector))
+(define (subs8vector v from to) (subvector v 's8vector 1 from to 'subs8vector))
+(define (subs16vector v from to) (subvector v 's16vector 2 from to 'subs16vector))
+(define (subs32vector v from to) (subvector v 's32vector 4 from to 'subs32vector))
+(define (subf32vector v from to) (subvector v 'f32vector 4 from to 'subf32vector))
+(define (subf64vector v from to) (subvector v 'f64vector 8 from to 'subf64vector))
+
+(define (write-u8vector v #!optional (port ##sys#standard-output) (from 0) (to (u8vector-length v)))
+ (##sys#check-structure v 'u8vector 'write-u8vector)
+ (##sys#check-port port 'write-u8vector)
+ (let ((buf (##sys#slot v 1)))
+ (do ((i from (fx+ i 1)))
+ ((fx>= i to))
+ (##sys#write-char-0 (integer->char (##core#inline "C_u8peek" buf i)) port) ) ) )
+
+(define (read-u8vector! n dest #!optional (port ##sys#standard-input) (start 0))
+ (##sys#check-port port 'read-u8vector!)
+ (##sys#check-exact start 'read-u8vector!)
+ (##sys#check-structure dest 'u8vector 'read-u8vector!)
+ (let ((dest (##sys#slot dest 1)))
+ (when n
+ (##sys#check-exact n 'read-u8vector!)
+ (when (fx> (fx+ start n) (##sys#size dest))
+ (set! n (fx- (##sys#size dest) start))))
+ (##sys#read-string! n dest port start) ) )
+
+(define read-u8vector
+ (let ((open-output-string open-output-string)
+ (get-output-string get-output-string) )
+ (define (wrap str n)
+ (##sys#make-structure
+ 'u8vector
+ (let ((str2 (##sys#allocate-vector n #t #f #t)))
+ (##core#inline "C_string_to_bytevector" str2)
+ (##core#inline "C_substring_copy" str str2 0 n 0)
+ str2) ) )
+ (lambda (#!optional n (p ##sys#standard-input))
+ (##sys#check-port p 'read-u8vector)
+ (cond (n (##sys#check-exact n 'read-u8vector)
+ (let* ((str (##sys#allocate-vector n #t #f #t))
+ (n2 (##sys#read-string! n str p 0)) )
+ (##core#inline "C_string_to_bytevector" str)
+ (if (eq? n n2)
+ (##sys#make-structure 'u8vector str)
+ (wrap str n2) ) ) )
+ (else
+ (let ([str (open-output-string)])
+ (let loop ()
+ (let ([c (##sys#read-char-0 p)])
+ (if (eof-object? c)
+ (let* ((s (get-output-string str))
+ (n (##sys#size s)) )
+ (wrap s n) )
+ (begin
+ (##sys#write-char/port c str)
+ (loop)))))))))))
+
+(register-feature! 'srfi-4)
diff --git a/srfi-69.import.scm b/srfi-69.import.scm
new file mode 100644
index 00000000..f56a610e
--- /dev/null
+++ b/srfi-69.import.scm
@@ -0,0 +1,71 @@
+;;;; srfi-69.import.scm - import library for "srfi-69" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'srfi-69
+ '(alist->hash-table
+ eq?-hash
+ equal?-hash
+ eqv?-hash
+ hash
+ hash-by-identity
+ hash-table->alist
+ hash-table-clear!
+ hash-table-copy
+ hash-table-delete!
+ hash-table-equivalence-function
+ hash-table-exists?
+ hash-table-fold
+ hash-table-for-each
+ hash-table-has-initial?
+ hash-table-hash-function
+ hash-table-initial
+ hash-table-keys
+ hash-table-map
+ hash-table-max-load
+ hash-table-merge
+ hash-table-merge!
+ hash-table-min-load
+ hash-table-ref
+ hash-table-ref/default
+ hash-table-remove!
+ hash-table-set!
+ hash-table-size
+ hash-table-update!
+ hash-table-update!/default
+ hash-table-values
+ hash-table-walk
+ hash-table-weak-keys
+ hash-table-weak-values
+ hash-table?
+ keyword-hash
+ make-hash-table
+ number-hash
+ object-uid-hash
+ string-hash-ci
+ string-ci-hash
+ string-hash
+ symbol-hash))
diff --git a/srfi-69.scm b/srfi-69.scm
new file mode 100644
index 00000000..36ed0fbb
--- /dev/null
+++ b/srfi-69.scm
@@ -0,0 +1,1089 @@
+;;; srfi-69.scm - Optional non-standard extensions
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+(declare
+ (unit srfi-69)
+ (usual-integrations)
+ (disable-warning redef) ) ; hash-table-ref is an extended binding!
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ (no-bound-checks)
+ (no-procedure-checks-for-usual-bindings) ) ] )
+
+(declare
+ (bound-to-procedure
+ ##sys#signal-hook
+ ##sys#peek-fixnum
+ ##sys#make-structure
+ ##sys#size
+ ##sys#slot ##sys#setslot
+ *equal?-hash )
+ (hide
+ *eq?-hash *eqv?-hash *equal?-hash
+ *make-hash-table
+ *hash-table-copy *hash-table-merge! *hash-table-update!/default
+ *hash-table-for-each *hash-table-fold
+ hash-table-canonical-length hash-table-rehash! hash-table-check-resize! ) )
+
+(cond-expand
+ [unsafe]
+ [else
+ (declare
+ (bound-to-procedure
+ ##sys#check-string ##sys#check-symbol
+ ##sys#check-exact ##sy#check-inexact
+ ##sys#check-closure ##sys#check-structure ) ) ] )
+
+(include "unsafe-declarations.scm")
+
+(register-feature! 'srfi-69)
+
+
+;;; Naming Conventions:
+
+;; %foo - inline primitive
+;; %%foo - local inline (no such thing but at least it looks different)
+;; $foo - local macro
+;; *foo - local unchecked variant of a checked procedure
+;; ##sys#foo - public, but undocumented, un-checked procedure
+;; foo - public checked procedure
+;;
+
+
+;;; Core Inlines:
+
+(define-inline (%fix wrd)
+ (##core#inline "C_fix" wrd) )
+
+(define-inline (%block? obj)
+ (##core#inline "C_blockp" obj) )
+
+(define-inline (%immediate? obj)
+ (not (##core#inline "C_blockp" obj)) )
+
+(define-inline (%special? obj)
+ (##core#inline "C_specialp" obj) )
+
+(define-inline (%port? obj)
+ (##core#inline "C_portp" obj) )
+
+(define-inline (%byte-block? obj)
+ (##core#inline "C_byteblockp" obj) )
+
+(define-inline (%string-hash str)
+ (##core#inline "C_hash_string" str) )
+
+(define-inline (%string-ci-hash str)
+ (##core#inline "C_hash_string_ci" str) )
+
+(define-inline (%subbyte bytvec i)
+ (##core#inline "C_subbyte" bytvec i) )
+
+
+;;; Generation of hash-values:
+
+;; All '%foo-hash' return a fixnum, not necessarily positive. The "overflow" of
+;; a, supposedly, unsigned hash value into negative is not checked during
+;; intermediate computation.
+;;
+;; The body of '*eq?-hash' is duplicated in '*eqv?-hash' and the body of '*eqv?-hash'
+;; is duplicated in '*equal?-hash' to save on procedure calls.
+
+;; Fixed hash-values:
+
+(define-constant other-hash-value 99)
+(define-constant true-hash-value 256)
+(define-constant false-hash-value 257)
+(define-constant null-hash-value 258)
+(define-constant eof-hash-value 259)
+(define-constant input-port-hash-value 260)
+(define-constant output-port-hash-value 261)
+(define-constant unknown-immediate-hash-value 262)
+
+(define-constant hash-default-bound 536870912)
+
+;; Force Hash to Bounded Fixnum:
+
+(define-inline (%fxabs fxn)
+ (if (fx< fxn 0) (fxneg fxn) fxn ) )
+
+(define-inline (%hash/limit hsh lim)
+ (fxmod (fxand (foreign-value "C_MOST_POSITIVE_FIXNUM" int)
+ (%fxabs hsh))
+ lim) )
+
+;; Number Hash:
+
+(define-constant flonum-magic 331804471)
+
+(define-syntax $flonum-hash
+ (lambda (form r c)
+ (let ( (flo (cadr form))
+ (_%subbyte (r '%subbyte))
+ (_flonum-magic (r 'flonum-magic))
+ (_fx+ (r 'fx+))
+ (_fx* (r 'fx*))
+ (_fxshl (r 'fxshl)) )
+ `(,_fx* ,_flonum-magic
+ ,(let loop ( (idx (fx- (##sys#size 1.0) 1)) )
+ (if (fx= 0 idx)
+ `(,_%subbyte ,flo 0)
+ `(,_fx+ (,_%subbyte ,flo ,idx)
+ (,_fxshl ,(loop (fx- idx 1)) 1)) ) ) ) ) ) )
+
+(define (##sys#number-hash-hook obj)
+ (*equal?-hash obj) )
+
+(define-inline (%non-fixnum-number-hash obj)
+ (cond [(flonum? obj) ($flonum-hash obj)]
+ [else (%fix (##sys#number-hash-hook obj))] ) )
+
+(define-inline (%number-hash obj)
+ (cond [(fixnum? obj) obj]
+ [else (%non-fixnum-number-hash obj)] ) )
+
+(define (number-hash obj #!optional (bound hash-default-bound))
+ (unless (number? obj)
+ (##sys#signal-hook #:type 'number-hash "invalid number" obj) )
+ (##sys#check-exact bound 'number-hash)
+ (%hash/limit (%number-hash obj) bound) )
+
+;; Object UID Hash:
+
+#; ;NOT YET (no weak-reference)
+(define-inline (%object-uid-hash obj)
+ (%uid-hash (##sys#object->uid obj)) )
+
+(define-inline (%object-uid-hash obj)
+ (*equal?-hash obj) )
+
+(define (object-uid-hash obj #!optional (bound hash-default-bound))
+ (##sys#check-exact bound 'object-uid-hash)
+ (%hash/limit (%object-uid-hash obj) bound) )
+
+;; Symbol Hash:
+
+#; ;NOT YET (no unique-symbol-hash)
+(define-inline (%symbol-hash obj)
+ (##sys#slot obj INDEX-OF-UNIQUE-HASH-VALUE-COMPUTED-DURING-SYMBOL-CREATION) )
+
+(define-inline (%symbol-hash obj)
+ (%string-hash (##sys#slot obj 1)) )
+
+(define (symbol-hash obj #!optional (bound hash-default-bound))
+ (##sys#check-symbol obj 'symbol-hash)
+ (##sys#check-exact bound 'symbol-hash)
+ (%hash/limit (%symbol-hash obj) bound) )
+
+;; Keyword Hash:
+
+(define (##sys#check-keyword x . y)
+ (unless (keyword? x)
+ (##sys#signal-hook #:type-error
+ (and (not (null? y)) (car y))
+ "bad argument type - not a keyword" x) ) )
+
+#; ;NOT YET (no unique-keyword-hash)
+(define-inline (%keyword-hash obj)
+ (##sys#slot obj INDEX-OF-UNIQUE-HASH-VALUE-COMPUTED-DURING-KEYWORD-CREATION) )
+
+(define-inline (%keyword-hash obj)
+ (%string-hash (##sys#slot obj 1)) )
+
+(define (keyword-hash obj #!optional (bound hash-default-bound))
+ (##sys#check-keyword obj 'keyword-hash)
+ (##sys#check-exact bound 'keyword-hash)
+ (%hash/limit (%keyword-hash obj) bound) )
+
+;; Eq Hash:
+
+(define-inline (%eq?-hash-object? obj)
+ (or (%immediate? obj)
+ (symbol? obj)
+ #; ;NOT YET (no keyword vs. symbol issue)
+ (keyword? obj) ) )
+
+(define (*eq?-hash obj)
+ (cond [(fixnum? obj) obj]
+ [(char? obj) (char->integer obj)]
+ [(eq? obj #t) true-hash-value]
+ [(eq? obj #f) false-hash-value]
+ [(null? obj) null-hash-value]
+ [(eof-object? obj) eof-hash-value]
+ [(symbol? obj) (%symbol-hash obj)]
+ #; ;NOT YET (no keyword vs. symbol issue)
+ [(keyword? obj) (%keyword-hash obj)]
+ [(%immediate? obj) unknown-immediate-hash-value]
+ [else (%object-uid-hash obj) ] ) )
+
+(define (eq?-hash obj #!optional (bound hash-default-bound))
+ (##sys#check-exact bound 'eq?-hash)
+ (%hash/limit (*eq?-hash obj) bound) )
+
+(define hash-by-identity eq?-hash)
+
+;; Eqv Hash:
+
+(define-inline (%eqv?-hash-object? obj)
+ (or (%eq?-hash-object? obj)
+ (number? obj) ) )
+
+(define (*eqv?-hash obj)
+ (cond [(fixnum? obj) obj]
+ [(char? obj) (char->integer obj)]
+ [(eq? obj #t) true-hash-value]
+ [(eq? obj #f) false-hash-value]
+ [(null? obj) null-hash-value]
+ [(eof-object? obj) eof-hash-value]
+ [(symbol? obj) (%symbol-hash obj)]
+ #; ;NOT YET (no keyword vs. symbol issue)
+ [(keyword? obj) (%keyword-hash obj)]
+ [(number? obj) (%non-fixnum-number-hash obj)]
+ [(%immediate? obj) unknown-immediate-hash-value]
+ [else (%object-uid-hash obj) ] ) )
+
+(define (eqv?-hash obj #!optional (bound hash-default-bound))
+ (##sys#check-exact bound 'eqv?-hash)
+ (%hash/limit (*eqv?-hash obj) bound) )
+
+;; Equal Hash:
+
+;XXX Be nice if these were parameters
+(define-constant recursive-hash-max-depth 4)
+(define-constant recursive-hash-max-length 4)
+
+;; NOTE - These refer to identifiers available only within the body of '*equal?-hash'.
+
+(define-inline (%%list-hash obj)
+ (fx+ (length obj)
+ (recursive-atomic-hash (##sys#slot obj 0) depth)) )
+
+(define-inline (%%pair-hash obj)
+ (fx+ (fxshl (recursive-atomic-hash (##sys#slot obj 0) depth) 16)
+ (recursive-atomic-hash (##sys#slot obj 1) depth)) )
+
+(define-inline (%%port-hash obj)
+ (fx+ (fxshl (##sys#peek-fixnum obj 0) 4) ; Little extra "identity"
+ (if (input-port? obj)
+ input-port-hash-value
+ output-port-hash-value)) )
+
+(define-inline (%%special-vector-hash obj)
+ (vector-hash obj (##sys#peek-fixnum obj 0) depth 1) )
+
+(define-inline (%%regular-vector-hash obj)
+ (vector-hash obj 0 depth 0) )
+
+(define (*equal?-hash obj)
+
+ ; Recurse into some portion of the vector's slots
+ (define (vector-hash obj seed depth start)
+ (let ([len (##sys#size obj)])
+ (let loop ([hsh (fx+ len seed)]
+ [i start]
+ [len (fx- (fxmin recursive-hash-max-length len) start)] )
+ (if (fx= len 0)
+ hsh
+ (loop (fx+ hsh
+ (fx+ (fxshl hsh 4)
+ (recursive-hash (##sys#slot obj i) (fx+ depth 1))))
+ (fx+ i 1)
+ (fx- len 1) ) ) ) ) )
+
+ ; Don't recurse into structured objects
+ (define (recursive-atomic-hash obj depth)
+ (if (or (%eqv?-hash-object? obj)
+ (%byte-block? obj))
+ (recursive-hash obj (fx+ depth 1))
+ other-hash-value ) )
+
+ ; Recurse into structured objects
+ (define (recursive-hash obj depth)
+ (cond [(fx>= depth recursive-hash-max-depth)
+ other-hash-value]
+ [(fixnum? obj) obj]
+ [(char? obj) (char->integer obj)]
+ [(eq? obj #t) true-hash-value]
+ [(eq? obj #f) false-hash-value]
+ [(null? obj) null-hash-value]
+ [(eof-object? obj) eof-hash-value]
+ [(symbol? obj) (%symbol-hash obj)]
+ #; ;NOT YET (no keyword vs. symbol issue)
+ [(keyword? obj) (%keyword-hash obj)]
+ [(number? obj) (%non-fixnum-number-hash obj)]
+ [(%immediate? obj) unknown-immediate-hash-value]
+ [(%byte-block? obj) (%string-hash obj)]
+ [(list? obj) (%%list-hash obj)]
+ [(pair? obj) (%%pair-hash obj)]
+ [(%port? obj) (%%port-hash obj)]
+ [(%special? obj) (%%special-vector-hash obj)]
+ [else (%%regular-vector-hash obj)] ) )
+
+ ;
+ (recursive-hash obj 0) )
+
+(define (equal?-hash obj #!optional (bound hash-default-bound))
+ (##sys#check-exact bound 'hash)
+ (%hash/limit (*equal?-hash obj) bound) )
+
+(define hash equal?-hash)
+
+;; String Hash:
+
+(define (string-hash str #!optional (bound hash-default-bound) . start+end)
+ (##sys#check-string str 'string-hash)
+ (##sys#check-exact bound 'string-hash)
+ (let ((str (if (pair? start+end)
+ (let-optionals start+end ((start 0)
+ (end (##sys#size str)))
+ (##sys#check-range start 0 (##sys#size str) 'string-hash)
+ (##sys#check-range end 0 (##sys#size str) 'string-hash)
+ (##sys#substring str start end) )
+ str) ) )
+ (%hash/limit (%string-hash str) bound) ) )
+
+(define (string-ci-hash str #!optional (bound hash-default-bound) . start+end)
+ (##sys#check-string str 'string-ci-hash)
+ (##sys#check-exact bound 'string-ci-hash)
+ (let ((str (if (pair? start+end)
+ (let-optionals start+end ((start 0)
+ (end (##sys#size str)))
+ (##sys#check-range start 0 (##sys#size str) 'string-hash-ci)
+ (##sys#check-range end 0 (##sys#size str) 'string-hash-ci)
+ (##sys#substring str start end) )
+ str) ) )
+ (%hash/limit (%string-ci-hash str) bound) ) )
+
+(define string-hash-ci string-ci-hash)
+
+
+;;; Hash-Tables:
+
+; Predefined sizes for the hash tables:
+;
+; Starts with 307; each element is the smallest prime that is at least twice in
+; magnitude as the previous element in the list.
+;
+; The last number is an exception: it is the largest 32-bit fixnum we can represent.
+
+(define-constant hash-table-prime-lengths
+ '(307 617
+ 1237 2477 4957 9923
+ 19853 39709 79423
+ 158849 317701 635413
+ 1270849 2541701 5083423
+ 10166857 20333759 40667527 81335063 162670129
+ 325340273 650680571
+ ;
+ 1073741823))
+
+(define-constant hash-table-default-length 307)
+(define-constant hash-table-max-length 1073741823)
+(define-constant hash-table-new-length-factor 2)
+
+(define-constant hash-table-default-min-load 0.5)
+(define-constant hash-table-default-max-load 0.8)
+
+;; Restrict hash-table length to tabled lengths:
+
+(define (hash-table-canonical-length tab req)
+ (let loop ([tab tab])
+ (let ([cur (##sys#slot tab 0)]
+ [nxt (##sys#slot tab 1)])
+ (if (or (fx>= cur req)
+ (null? nxt))
+ cur
+ (loop nxt) ) ) ) )
+
+;; "Raw" make-hash-table:
+
+(define *make-hash-table
+ (let ([make-vector make-vector])
+ (lambda (test hash len min-load max-load weak-keys weak-values initial
+ #!optional (vec (make-vector len '())))
+ (##sys#make-structure 'hash-table
+ vec 0 test hash min-load max-load #f #f initial) ) ) )
+
+;; SRFI-69 & SRFI-90'ish.
+;;
+;; Argument list is the pattern
+;;
+;; (make-hash-table #!optional test hash size
+;; #!key test hash size initial min-load max-load weak-keys weak-values)
+;;
+;; where a keyword argument takes precedence over the corresponding optional
+;; argument. Keyword arguments MUST come after optional & required
+;; arugments.
+;;
+;; Wish DSSSL (extended) argument list processing Did-What-I-Want (DWIW).
+
+(define make-hash-table
+ (let ([core-eq? eq?]
+ [core-eqv? eqv?]
+ [core-equal? equal?]
+ [core-string=? string=?]
+ [core-string-ci=? string-ci=?]
+ [core= =] )
+ (lambda arguments0
+ (let ([arguments arguments0]
+ [test equal?]
+ [hash #f]
+ [size hash-table-default-length]
+ [initial #f]
+ [min-load hash-table-default-min-load]
+ [max-load hash-table-default-max-load]
+ [weak-keys #f]
+ [weak-values #f])
+ (let ([hash-for-test
+ (lambda ()
+ (cond [(or (eq? core-eq? test)
+ (eq? eq? test)) eq?-hash]
+ [(or (eq? core-eqv? test)
+ (eq? eqv? test)) eqv?-hash]
+ [(or (eq? core-equal? test)
+ (eq? equal? test)) equal?-hash]
+ [(or (eq? core-string=? test)
+ (eq? string=? test)) string-hash]
+ [(or (eq? core-string-ci=? test)
+ (eq? string-ci=? test)) string-hash-ci]
+ [(or (eq? core= test)
+ (eq? = test)) number-hash]
+ [else #f] ) ) ] )
+ ; Process optional arguments
+ (unless (null? arguments)
+ (let ([arg (car arguments)])
+ (unless (keyword? arg)
+ (##sys#check-closure arg 'make-hash-table)
+ (set! test arg)
+ (set! arguments (cdr arguments)) ) ) )
+ (unless (null? arguments)
+ (let ([arg (car arguments)])
+ (unless (keyword? arg)
+ (##sys#check-closure arg 'make-hash-table)
+ (set! hash arg)
+ (set! arguments (cdr arguments)) ) ) )
+ (unless (null? arguments)
+ (let ([arg (car arguments)])
+ (unless (keyword? arg)
+ (##sys#check-exact arg 'make-hash-table)
+ (unless (fx< 0 arg)
+ (error 'make-hash-table "invalid size" arg) )
+ (set! size (fxmin hash-table-max-size arg))
+ (set! arguments (cdr arguments)) ) ) )
+ ; Process keyword arguments
+ (let loop ([args arguments])
+ (unless (null? args)
+ (let ([arg (car args)])
+ (let ([invarg-err
+ (lambda (msg)
+ (error 'make-hash-table msg arg arguments0))])
+ (if (keyword? arg)
+ (let* ([nxt (cdr args)]
+ [val (if (pair? nxt)
+ (car nxt)
+ (invarg-err "missing keyword value"))])
+ (case arg
+ [(#:test)
+ (##sys#check-closure val 'make-hash-table)
+ (set! test val)]
+ [(#:hash)
+ (##sys#check-closure val 'make-hash-table)
+ (set! hash val)]
+ [(#:size)
+ (##sys#check-exact val 'make-hash-table)
+ (unless (fx< 0 val)
+ (error 'make-hash-table "invalid size" val) )
+ (set! size (fxmin hash-table-max-size val))]
+ [(#:initial)
+ (set! initial (lambda () val))]
+ [(#:min-load)
+ (##sys#check-inexact val 'make-hash-table)
+ (unless (and (fp< 0.0 val) (fp< val 1.0))
+ (error 'make-hash-table "invalid min-load" val) )
+ (set! min-load val)]
+ [(#:max-load)
+ (##sys#check-inexact val 'make-hash-table)
+ (unless (and (fp< 0.0 val) (fp< val 1.0))
+ (error 'make-hash-table "invalid max-load" val) )
+ (set! max-load val)]
+ [(#:weak-keys)
+ (set! weak-keys (and val #t))]
+ [(#:weak-values)
+ (set! weak-values (and val #t))]
+ [else
+ (invarg-err "unknown keyword")])
+ (loop (cdr nxt)) )
+ (invarg-err "missing keyword") ) ) ) ) )
+ ; Load must be a proper interval
+ (when (fp< max-load min-load)
+ (error 'make-hash-table "min-load greater than max-load" min-load max-load) )
+ ; Force canonical hash-table vector length
+ (set! size (hash-table-canonical-length hash-table-prime-lengths size))
+ ; Decide on a hash function when not supplied
+ (unless hash
+ (let ([func (hash-for-test)])
+ (if func
+ (set! hash func)
+ (begin
+ (warning 'make-hash-table "user test without user hash")
+ (set! hash equal?-hash) ) ) ) )
+ ; Done
+ (*make-hash-table test hash size min-load max-load weak-keys weak-values initial) ) ) ) ) )
+
+;; Hash-Table Predicate:
+
+(define (hash-table? obj)
+ (##sys#structure? obj 'hash-table) )
+
+;; Hash-Table Properties:
+
+(define (hash-table-size ht)
+ (##sys#check-structure ht 'hash-table 'hash-table-size)
+ (##sys#slot ht 2) )
+
+(define (hash-table-equivalence-function ht)
+ (##sys#check-structure ht 'hash-table 'hash-table-equivalence-function)
+ (##sys#slot ht 3) )
+
+(define (hash-table-hash-function ht)
+ (##sys#check-structure ht 'hash-table 'hash-table-hash-function)
+ (##sys#slot ht 4) )
+
+(define (hash-table-min-load ht)
+ (##sys#check-structure ht 'hash-table 'hash-table-min-load)
+ (##sys#slot ht 5) )
+
+(define (hash-table-max-load ht)
+ (##sys#check-structure ht 'hash-table 'hash-table-max-load)
+ (##sys#slot ht 6) )
+
+(define (hash-table-weak-keys ht)
+ (##sys#check-structure ht 'hash-table 'hash-table-weak-keys)
+ (##sys#slot ht 7) )
+
+(define (hash-table-weak-values ht)
+ (##sys#check-structure ht 'hash-table 'hash-table-weak-values)
+ (##sys#slot ht 8) )
+
+(define (hash-table-has-initial? ht)
+ (##sys#check-structure ht 'hash-table 'hash-table-has-initial?)
+ (and (##sys#slot ht 9)
+ #t ) )
+
+(define (hash-table-initial ht)
+ (##sys#check-structure ht 'hash-table 'hash-table-initial)
+ (and-let* ([thunk (##sys#slot ht 9)])
+ (thunk) ) )
+
+;; hash-table-rehash!:
+
+(define (hash-table-rehash! vec1 vec2 hash)
+ (let ([len1 (##sys#size vec1)]
+ [len2 (##sys#size vec2)] )
+ (do ([i 0 (fx+ i 1)])
+ [(fx>= i len1)]
+ (let loop ([bucket (##sys#slot vec1 i)])
+ (unless (null? bucket)
+ (let* ([pare (##sys#slot bucket 0)]
+ [key (##sys#slot pare 0)]
+ [hshidx (hash key len2)] )
+ (##sys#setslot vec2 hshidx
+ (cons (cons key (##sys#slot pare 1)) (##sys#slot vec2 hshidx)))
+ (loop (##sys#slot bucket 1)) ) ) ) ) ) )
+
+;; hash-table-resize!:
+
+(define (hash-table-resize! ht vec len)
+ (let* ([deslen (fxmin hash-table-max-length (fx* len hash-table-new-length-factor))]
+ [newlen (hash-table-canonical-length hash-table-prime-lengths deslen)]
+ [vec2 (make-vector newlen '())] )
+ (hash-table-rehash! vec vec2 (##sys#slot ht 4))
+ (##sys#setslot ht 1 vec2) ) )
+
+;; hash-table-check-resize!:
+
+(define-inline (hash-table-check-resize! ht newsiz)
+ (let ([vec (##sys#slot ht 1)]
+ [min-load (##sys#slot ht 5)]
+ [max-load (##sys#slot ht 6)] )
+ (let ([len (##sys#size vec)] )
+ (let ([min-load-len (inexact->exact (floor (* len min-load)))]
+ [max-load-len (inexact->exact (floor (* len max-load)))] )
+ (if (and (fx< len hash-table-max-length)
+ (fx<= min-load-len newsiz) (fx<= newsiz max-load-len))
+ (hash-table-resize! ht vec len) ) ) ) ) )
+
+;; hash-table-copy:
+
+(define *hash-table-copy
+ (let ([make-vector make-vector])
+ (lambda (ht)
+ (let* ([vec1 (##sys#slot ht 1)]
+ [len (##sys#size vec1)]
+ [vec2 (make-vector len '())] )
+ (do ([i 0 (fx+ i 1)])
+ [(fx>= i len)
+ (*make-hash-table
+ (##sys#slot ht 3) (##sys#slot ht 4)
+ (##sys#slot ht 2)
+ (##sys#slot ht 5) (##sys#slot ht 6)
+ (##sys#slot ht 7) (##sys#slot ht 8)
+ (##sys#slot ht 9)
+ vec2)]
+ (##sys#setslot vec2 i
+ (let copy-loop ([bucket (##sys#slot vec1 i)])
+ (if (null? bucket)
+ '()
+ (let ([pare (##sys#slot bucket 0)])
+ (cons (cons (##sys#slot pare 0) (##sys#slot pare 1))
+ (copy-loop (##sys#slot bucket 1))))))) ) ) ) ) )
+
+(define (hash-table-copy ht)
+ (##sys#check-structure ht 'hash-table 'hash-table-copy)
+ (*hash-table-copy ht) )
+
+;; hash-table-update!:
+;;
+;; This one was suggested by Sven Hartrumpf (and subsequently added in SRFI-69).
+;; Modified for ht props min & max load.
+
+(define hash-table-update!
+ (let ([core-eq? eq?] )
+ (lambda (ht key
+ #!optional (func identity)
+ (thunk
+ (let ([thunk (##sys#slot ht 9)])
+ (or thunk
+ (lambda ()
+ (##sys#signal-hook #:access-error
+ 'hash-table-update!
+ "hash-table does not contain key" key ht))))))
+ (##sys#check-structure ht 'hash-table 'hash-table-update!)
+ (##sys#check-closure func 'hash-table-update!)
+ (##sys#check-closure thunk 'hash-table-update!)
+ (let ([newsiz (fx+ (##sys#slot ht 2) 1)] )
+ (hash-table-check-resize! ht newsiz)
+ (let ([hash (##sys#slot ht 4)]
+ [test (##sys#slot ht 3)]
+ [vec (##sys#slot ht 1)] )
+ (let* ([len (##sys#size vec)]
+ [hshidx (hash key len)]
+ [bucket0 (##sys#slot vec hshidx)] )
+ (if (eq? core-eq? test)
+ ; Fast path (eq? is rewritten by the compiler):
+ (let loop ([bucket bucket0])
+ (if (null? bucket)
+ (let ([val (func (thunk))])
+ (##sys#setslot vec hshidx (cons (cons key val) bucket0))
+ (##sys#setislot ht 2 newsiz)
+ val )
+ (let ([pare (##sys#slot bucket 0)])
+ (if (eq? key (##sys#slot pare 0))
+ (let ([val (func (##sys#slot pare 1))])
+ (##sys#setslot pare 1 val)
+ val)
+ (loop (##sys#slot bucket 1)) ) ) ) )
+ ; Slow path
+ (let loop ([bucket bucket0])
+ (if (null? bucket)
+ (let ([val (func (thunk))])
+ (##sys#setslot vec hshidx (cons (cons key val) bucket0))
+ (##sys#setislot ht 2 newsiz)
+ val )
+ (let ([pare (##sys#slot bucket 0)])
+ (if (test key (##sys#slot pare 0))
+ (let ([val (func (##sys#slot pare 1))])
+ (##sys#setslot pare 1 val)
+ val )
+ (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) ) )
+
+(define *hash-table-update!/default
+ (let ([core-eq? eq?] )
+ (lambda (ht key func def)
+ (let ([newsiz (fx+ (##sys#slot ht 2) 1)] )
+ (hash-table-check-resize! ht newsiz)
+ (let ([hash (##sys#slot ht 4)]
+ [test (##sys#slot ht 3)]
+ [vec (##sys#slot ht 1)] )
+ (let* ([len (##sys#size vec)]
+ [hshidx (hash key len)]
+ [bucket0 (##sys#slot vec hshidx)] )
+ (if (eq? core-eq? test)
+ ; Fast path (eq? is rewritten by the compiler):
+ (let loop ([bucket bucket0])
+ (if (null? bucket)
+ (let ([val (func def)])
+ (##sys#setslot vec hshidx (cons (cons key val) bucket0))
+ (##sys#setislot ht 2 newsiz)
+ val )
+ (let ([pare (##sys#slot bucket 0)])
+ (if (eq? key (##sys#slot pare 0))
+ (let ([val (func (##sys#slot pare 1))])
+ (##sys#setslot pare 1 val)
+ val)
+ (loop (##sys#slot bucket 1)) ) ) ) )
+ ; Slow path
+ (let loop ([bucket bucket0])
+ (if (null? bucket)
+ (let ([val (func def)])
+ (##sys#setslot vec hshidx (cons (cons key val) bucket0))
+ (##sys#setislot ht 2 newsiz)
+ val )
+ (let ([pare (##sys#slot bucket 0)])
+ (if (test key (##sys#slot pare 0))
+ (let ([val (func (##sys#slot pare 1))])
+ (##sys#setslot pare 1 val)
+ val )
+ (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) ) )
+
+(define (hash-table-update!/default ht key func def)
+ (##sys#check-structure ht 'hash-table 'hash-table-update!/default)
+ (##sys#check-closure func 'hash-table-update!/default)
+ (*hash-table-update!/default ht key func def) )
+
+(define hash-table-set!
+ (let ([core-eq? eq?] )
+ (lambda (ht key val)
+ (##sys#check-structure ht 'hash-table 'hash-table-set!)
+ (let ([newsiz (fx+ (##sys#slot ht 2) 1)] )
+ (hash-table-check-resize! ht newsiz)
+ (let ([hash (##sys#slot ht 4)]
+ [test (##sys#slot ht 3)]
+ [vec (##sys#slot ht 1)] )
+ (let* ([len (##sys#size vec)]
+ [hshidx (hash key len)]
+ [bucket0 (##sys#slot vec hshidx)] )
+ (if (eq? core-eq? test)
+ ; Fast path (eq? is rewritten by the compiler):
+ (let loop ([bucket bucket0])
+ (if (null? bucket)
+ (begin
+ (##sys#setslot vec hshidx (cons (cons key val) bucket0))
+ (##sys#setislot ht 2 newsiz) )
+ (let ([pare (##sys#slot bucket 0)])
+ (if (eq? key (##sys#slot pare 0))
+ (##sys#setslot pare 1 val)
+ (loop (##sys#slot bucket 1)) ) ) ) )
+ ; Slow path
+ (let loop ([bucket bucket0])
+ (if (null? bucket)
+ (begin
+ (##sys#setslot vec hshidx (cons (cons key val) bucket0))
+ (##sys#setislot ht 2 newsiz) )
+ (let ([pare (##sys#slot bucket 0)])
+ (if (test key (##sys#slot pare 0))
+ (##sys#setslot pare 1 val)
+ (loop (##sys#slot bucket 1)) ) ) ) ) )
+ (void) ) ) ) ) ) )
+
+;; Hash-Table Reference:
+
+(define hash-table-ref
+ (getter-with-setter
+ (let ([core-eq? eq?])
+ (lambda (ht key #!optional (def (lambda ()
+ (##sys#signal-hook #:access-error
+ 'hash-table-ref
+ "hash-table does not contain key" key ht))))
+ (##sys#check-structure ht 'hash-table 'hash-table-ref)
+ (##sys#check-closure def 'hash-table-ref)
+ (let ([vec (##sys#slot ht 1)]
+ [test (##sys#slot ht 3)] )
+ (let* ([hash (##sys#slot ht 4)]
+ [hshidx (hash key (##sys#size vec))] )
+ (if (eq? core-eq? test)
+ ; Fast path (eq? is rewritten by the compiler):
+ (let loop ([bucket (##sys#slot vec hshidx)])
+ (if (null? bucket)
+ (def)
+ (let ([pare (##sys#slot bucket 0)])
+ (if (eq? key (##sys#slot pare 0))
+ (##sys#slot pare 1)
+ (loop (##sys#slot bucket 1)) ) ) ) )
+ ; Slow path
+ (let loop ([bucket (##sys#slot vec hshidx)])
+ (if (null? bucket)
+ (def)
+ (let ([pare (##sys#slot bucket 0)])
+ (if (test key (##sys#slot pare 0))
+ (##sys#slot pare 1)
+ (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) )
+ hash-table-set!) )
+
+(define hash-table-ref/default
+ (let ([core-eq? eq?])
+ (lambda (ht key def)
+ (##sys#check-structure ht 'hash-table 'hash-table-ref/default)
+ (let ([vec (##sys#slot ht 1)]
+ [test (##sys#slot ht 3)] )
+ (let* ([hash (##sys#slot ht 4)]
+ [hshidx (hash key (##sys#size vec))] )
+ (if (eq? core-eq? test)
+ ; Fast path (eq? is rewritten by the compiler):
+ (let loop ([bucket (##sys#slot vec hshidx)])
+ (if (null? bucket)
+ def
+ (let ([pare (##sys#slot bucket 0)])
+ (if (eq? key (##sys#slot pare 0))
+ (##sys#slot pare 1)
+ (loop (##sys#slot bucket 1)) ) ) ) )
+ ; Slow path
+ (let loop ([bucket (##sys#slot vec hshidx)])
+ (if (null? bucket)
+ def
+ (let ([pare (##sys#slot bucket 0)])
+ (if (test key (##sys#slot pare 0))
+ (##sys#slot pare 1)
+ (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) )
+
+(define hash-table-exists?
+ (let ([core-eq? eq?])
+ (lambda (ht key)
+ (##sys#check-structure ht 'hash-table 'hash-table-exists?)
+ (let ([vec (##sys#slot ht 1)]
+ [test (##sys#slot ht 3)] )
+ (let* ([hash (##sys#slot ht 4)]
+ [hshidx (hash key (##sys#size vec))] )
+ (if (eq? core-eq? test)
+ ; Fast path (eq? is rewritten by the compiler):
+ (let loop ([bucket (##sys#slot vec hshidx)])
+ (and (not (null? bucket))
+ (let ([pare (##sys#slot bucket 0)])
+ (or (eq? key (##sys#slot pare 0))
+ (loop (##sys#slot bucket 1)) ) ) ) )
+ ; Slow path
+ (let loop ([bucket (##sys#slot vec hshidx)])
+ (and (not (null? bucket))
+ (let ([pare (##sys#slot bucket 0)])
+ (or (test key (##sys#slot pare 0))
+ (loop (##sys#slot bucket 1)) ) ) ) ) ) ) ) ) ) )
+
+;; hash-table-delete!:
+
+(define hash-table-delete!
+ (let ([core-eq? eq?])
+ (lambda (ht key)
+ (##sys#check-structure ht 'hash-table 'hash-table-delete!)
+ (let* ([vec (##sys#slot ht 1)]
+ [len (##sys#size vec)]
+ [hash (##sys#slot ht 4)]
+ [hshidx (hash key len)] )
+ (let ([test (##sys#slot ht 3)]
+ [newsiz (fx- (##sys#slot ht 2) 1)]
+ [bucket0 (##sys#slot vec hshidx)] )
+ (if (eq? core-eq? test)
+ ; Fast path (eq? is rewritten by the compiler):
+ (let loop ([prev #f] [bucket bucket0])
+ (and (not (null? bucket))
+ (let ([pare (##sys#slot bucket 0)]
+ [nxt (##sys#slot bucket 1)])
+ (if (eq? key (##sys#slot pare 0))
+ (begin
+ (if prev
+ (##sys#setslot prev 1 nxt)
+ (##sys#setslot vec hshidx nxt) )
+ (##sys#setislot ht 2 newsiz)
+ #t )
+ (loop bucket nxt) ) ) ) )
+ ; Slow path
+ (let loop ([prev #f] [bucket bucket0])
+ (and (not (null? bucket))
+ (let ([pare (##sys#slot bucket 0)]
+ [nxt (##sys#slot bucket 1)])
+ (if (test key (##sys#slot pare 0))
+ (begin
+ (if prev
+ (##sys#setslot prev 1 nxt)
+ (##sys#setslot vec hshidx nxt) )
+ (##sys#setislot ht 2 newsiz)
+ #t )
+ (loop bucket nxt) ) ) ) ) ) ) ) ) ) )
+
+;; hash-table-remove!:
+
+(define (hash-table-remove! ht func)
+ (##sys#check-structure ht 'hash-table 'hash-table-remove!)
+ (##sys#check-closure func 'hash-table-remove!)
+ (let* ([vec (##sys#slot ht 1)]
+ [len (##sys#size vec)] )
+ (let ([siz (##sys#slot ht 2)])
+ (do ([i 0 (fx+ i 1)])
+ [(fx>= i len) (##sys#setislot ht 2 siz)]
+ (let loop ([prev #f] [bucket (##sys#slot vec i)])
+ (and (not (null? bucket))
+ (let ([pare (##sys#slot bucket 0)]
+ [nxt (##sys#slot bucket 1)])
+ (if (func (##sys#slot pare 0) (##sys#slot pare 1))
+ (begin
+ (if prev
+ (##sys#setslot prev 1 nxt)
+ (##sys#setslot vec i nxt) )
+ (set! siz (fx- siz 1))
+ #t )
+ (loop bucket nxt ) ) ) ) ) ) ) ) )
+
+;; hash-table-clear!:
+
+(define (hash-table-clear! ht)
+ (##sys#check-structure ht 'hash-table 'hash-table-clear!)
+ (vector-fill! (##sys#slot ht 1) '())
+ (##sys#setislot ht 2 0) )
+
+;; Hash Table Merge:
+
+(define (*hash-table-merge! ht1 ht2)
+ (let* ([vec (##sys#slot ht2 1)]
+ [len (##sys#size vec)] )
+ (do ([i 0 (fx+ i 1)])
+ [(fx>= i len) ht1]
+ (do ([lst (##sys#slot vec i) (##sys#slot lst 1)])
+ [(null? lst)]
+ (let ([b (##sys#slot lst 0)])
+ (*hash-table-update!/default ht1 (##sys#slot b 0) identity (##sys#slot b 1)) ) ) ) ) )
+
+(define (hash-table-merge! ht1 ht2)
+ (##sys#check-structure ht1 'hash-table 'hash-table-merge!)
+ (##sys#check-structure ht2 'hash-table 'hash-table-merge!)
+ (*hash-table-merge! ht1 ht2) )
+
+(define (hash-table-merge ht1 ht2)
+ (##sys#check-structure ht1 'hash-table 'hash-table-merge)
+ (##sys#check-structure ht2 'hash-table 'hash-table-merge)
+ (*hash-table-merge! (*hash-table-copy ht1) ht2) )
+
+;; Hash-Table <-> Association-List:
+
+(define (hash-table->alist ht)
+ (##sys#check-structure ht 'hash-table 'hash-table->alist)
+ (let* ([vec (##sys#slot ht 1)]
+ [len (##sys#size vec)] )
+ (let loop ([i 0] [lst '()])
+ (if (fx>= i len)
+ lst
+ (let loop2 ([bucket (##sys#slot vec i)]
+ [lst lst])
+ (if (null? bucket)
+ (loop (fx+ i 1) lst)
+ (loop2 (##sys#slot bucket 1)
+ (let ([x (##sys#slot bucket 0)])
+ (cons (cons (##sys#slot x 0) (##sys#slot x 1)) lst) ) ) ) ) ) ) ) )
+
+(define alist->hash-table
+ (let ([make-hash-table make-hash-table])
+ (lambda (alist . rest)
+ (##sys#check-list alist 'alist->hash-table)
+ (let ([ht (apply make-hash-table rest)])
+ (for-each
+ (lambda (x)
+ (##sys#check-pair x 'alist->hash-table)
+ (*hash-table-update!/default ht (##sys#slot x 0) identity (##sys#slot x 1)) )
+ alist)
+ ht ) ) ) )
+
+;; Hash-Table Keys & Values:
+
+(define (hash-table-keys ht)
+ (##sys#check-structure ht 'hash-table 'hash-table-keys)
+ (let* ([vec (##sys#slot ht 1)]
+ [len (##sys#size vec)] )
+ (let loop ([i 0] [lst '()])
+ (if (fx>= i len)
+ lst
+ (let loop2 ([bucket (##sys#slot vec i)]
+ [lst lst])
+ (if (null? bucket)
+ (loop (fx+ i 1) lst)
+ (loop2 (##sys#slot bucket 1)
+ (let ([x (##sys#slot bucket 0)])
+ (cons (##sys#slot x 0) lst) ) ) ) ) ) ) ) )
+
+(define (hash-table-values ht)
+ (##sys#check-structure ht 'hash-table 'hash-table-values)
+ (let* ([vec (##sys#slot ht 1)]
+ [len (##sys#size vec)] )
+ (let loop ([i 0] [lst '()])
+ (if (fx>= i len)
+ lst
+ (let loop2 ([bucket (##sys#slot vec i)]
+ [lst lst])
+ (if (null? bucket)
+ (loop (fx+ i 1) lst)
+ (loop2 (##sys#slot bucket 1)
+ (let ([x (##sys#slot bucket 0)])
+ (cons (##sys#slot x 1) lst) ) ) ) ) ) ) ) )
+
+;; Mapping Over Hash-Table Keys & Values:
+;;
+;; hash-table-for-each:
+;; hash-table-walk:
+;; hash-table-fold:
+;; hash-table-map:
+
+(define (*hash-table-for-each ht proc)
+ (let* ([vec (##sys#slot ht 1)]
+ [len (##sys#size vec)] )
+ (do ([i 0 (fx+ i 1)] )
+ [(fx>= i len)]
+ (##sys#for-each (lambda (bucket)
+ (proc (##sys#slot bucket 0) (##sys#slot bucket 1)) )
+ (##sys#slot vec i)) ) ) )
+
+(define (*hash-table-fold ht func init)
+ (let* ([vec (##sys#slot ht 1)]
+ [len (##sys#size vec)] )
+ (let loop ([i 0] [acc init])
+ (if (fx>= i len)
+ acc
+ (let fold2 ([bucket (##sys#slot vec i)]
+ [acc acc])
+ (if (null? bucket)
+ (loop (fx+ i 1) acc)
+ (let ([pare (##sys#slot bucket 0)])
+ (fold2 (##sys#slot bucket 1)
+ (func (##sys#slot pare 0) (##sys#slot pare 1) acc) ) ) ) ) ) ) ) )
+
+(define (hash-table-fold ht func init)
+ (##sys#check-structure ht 'hash-table 'hash-table-fold)
+ (##sys#check-closure func 'hash-table-fold)
+ (*hash-table-fold ht func init) )
+
+(define (hash-table-for-each ht proc)
+ (##sys#check-structure ht 'hash-table 'hash-table-for-each)
+ (##sys#check-closure proc 'hash-table-for-each)
+ (*hash-table-for-each ht proc) )
+
+(define (hash-table-walk ht proc)
+ (##sys#check-structure ht 'hash-table 'hash-table-walk)
+ (##sys#check-closure proc 'hash-table-walk)
+ (*hash-table-for-each ht proc) )
+
+(define (hash-table-map ht func)
+ (##sys#check-structure ht 'hash-table 'hash-table-map)
+ (##sys#check-closure func 'hash-table-map)
+ (*hash-table-fold ht (lambda (k v a) (cons (func k v) a)) '()) )
diff --git a/stub.scm b/stub.scm
new file mode 100644
index 00000000..a1f8a041
--- /dev/null
+++ b/stub.scm
@@ -0,0 +1,33 @@
+;;;; stub.scm
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit default_stub)
+ (uses library eval data-structures ports extras)
+ (not safe) )
+
+(let loop () (return-to-host) (loop))
diff --git a/support.scm b/support.scm
new file mode 100644
index 00000000..8cac05bd
--- /dev/null
+++ b/support.scm
@@ -0,0 +1,1483 @@
+;;;; support.scm - Miscellaneous support code for the CHICKEN compiler
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit support))
+
+
+(include "compiler-namespace")
+(include "tweaks")
+(include "banner")
+
+(declare
+ (not inline compiler-cleanup-hook ##sys#user-read-hook) )
+
+
+;;; Debugging and error-handling stuff:
+
+(define (compiler-cleanup-hook) #f)
+
+(define debugging-chicken '())
+(define disabled-warnings '()) ; usage type load var const syntax redef use call ffi
+
+(define (bomb . msg-and-args)
+ (if (pair? msg-and-args)
+ (apply error (string-append "[internal compiler error] " (car msg-and-args)) (cdr msg-and-args))
+ (error "[internal compiler error]") ) )
+
+(define (debugging mode msg . args)
+ (and (memq mode debugging-chicken)
+ (begin
+ (printf "~a" msg)
+ (if (pair? args)
+ (begin
+ (display ": ")
+ (for-each (lambda (x) (printf "~s " (force x))) args) ) )
+ (newline)
+ (flush-output)
+ #t) ) )
+
+(define (compiler-warning class msg . args)
+ (when (and ##sys#warnings-enabled (not (memq class disabled-warnings)))
+ (let ((out (current-error-port)))
+ (apply fprintf out (string-append "\nWarning: " msg) args)
+ (newline out) ) ) )
+
+(define (quit msg . args)
+ (let ([out (current-error-port)])
+ (apply fprintf out (string-append "\nError: " msg) args)
+ (newline out)
+ (exit 1) ) )
+
+(set! ##sys#syntax-error-hook
+ (lambda (msg . args)
+ (let ((out (current-error-port))
+ (loc (and (symbol? msg)
+ (let ((loc msg))
+ (set! msg (car args))
+ (set! args (cdr args))
+ loc))))
+ (if loc
+ (fprintf out "Syntax error (~a): ~a~%~%" loc msg)
+ (fprintf out "Syntax error: ~a~%~%" msg) )
+ (for-each (cut fprintf out "\t~s~%" <>) args)
+ (print-call-chain out 0 ##sys#current-thread "\n\tExpansion history:\n")
+ (exit 70) ) ) )
+
+(set! syntax-error ##sys#syntax-error-hook)
+
+(define (emit-syntax-trace-info info cntr)
+ (##core#inline "C_emit_syntax_trace_info" info cntr ##sys#current-thread) )
+
+(define (map-llist proc llist)
+ (let loop ([llist llist])
+ (cond [(null? llist) '()]
+ [(symbol? llist) (proc llist)]
+ [else (cons (proc (car llist)) (loop (cdr llist)))] ) ) )
+
+(define (check-signature var args llist)
+ (define (err)
+ (quit "Arguments to inlined call of `~A' do not match parameter-list ~A"
+ (real-name var)
+ (map-llist real-name (cdr llist)) ) )
+ (let loop ([as args] [ll llist])
+ (cond [(null? ll) (unless (null? as) (err))]
+ [(symbol? ll)]
+ [(null? as) (err)]
+ [else (loop (cdr as) (cdr ll))] ) ) )
+
+
+;;; Generic utility routines:
+
+(define (posq x lst)
+ (let loop ([lst lst] [i 0])
+ (cond [(null? lst) #f]
+ [(eq? x (car lst)) i]
+ [else (loop (cdr lst) (add1 i))] ) ) )
+
+(define (stringify x)
+ (cond ((string? x) x)
+ ((symbol? x) (symbol->string x))
+ (else (sprintf "~a" x)) ) )
+
+(define (symbolify x)
+ (cond ((symbol? x) x)
+ ((string? x) (string->symbol x))
+ (else (string->symbol (sprintf "~a" x))) ) )
+
+(define (build-lambda-list vars argc rest)
+ (let loop ((vars vars) (n argc))
+ (cond ((or (zero? n) (null? vars)) (or rest '()))
+ (else (cons (car vars) (loop (cdr vars) (sub1 n)))) ) ) )
+
+(define string->c-identifier ##sys#string->c-identifier)
+
+(define (c-ify-string str)
+ (list->string
+ (cons
+ #\"
+ (let loop ((chars (string->list str)))
+ (if (null? chars)
+ '(#\")
+ (let* ((c (car chars))
+ (code (char->integer c)) )
+ (if (or (< code 32) (>= code 127) (memq c '(#\" #\' #\\ #\?)))
+ (append '(#\\)
+ (cond ((< code 8) '(#\0 #\0))
+ ((< code 64) '(#\0))
+ (else '()) )
+ (string->list (number->string code 8))
+ (loop (cdr chars)) )
+ (cons c (loop (cdr chars))) ) ) ) ) ) ) )
+
+(define (valid-c-identifier? name)
+ (let ([str (string->list (->string name))])
+ (and (pair? str)
+ (let ([c0 (car str)])
+ (and (or (char-alphabetic? c0) (char=? #\_ c0))
+ (any (lambda (c) (or (char-alphabetic? c) (char-numeric? c) (char=? #\_ c)))
+ (cdr str) ) ) ) ) ) )
+
+(eval-when (load)
+ (define words (foreign-lambda int "C_bytestowords" int))
+ (define words->bytes (foreign-lambda int "C_wordstobytes" int)) )
+
+(eval-when (eval)
+ (define (words n)
+ (let ([wordsize (##sys#fudge 7)])
+ (+ (quotient n wordsize) (if (zero? (modulo n wordsize)) 0 1)) ) )
+ (define (words->bytes n)
+ (* n (##sys#fudge 7)) ) )
+
+(define (check-and-open-input-file fname . line)
+ (cond [(string=? fname "-") (current-input-port)]
+ [(file-exists? fname) (open-input-file fname)]
+ [(or (null? line) (not (car line))) (quit "Can not open file ~s" fname)]
+ [else (quit "Can not open file ~s in line ~s" fname (car line))] ) )
+
+(define (close-checked-input-file port fname)
+ (unless (string=? fname "-") (close-input-port port)) )
+
+(define (fold-inner proc lst)
+ (if (null? (cdr lst))
+ lst
+ (let fold ((xs (reverse lst)))
+ (apply
+ proc
+ (if (null? (cddr xs))
+ (list (cadr xs) (car xs))
+ (list (fold (cdr xs)) (car xs)) ) ) ) ) )
+
+(define (follow-without-loop seed proc abort)
+ (let loop ([x seed] [done '()])
+ (if (member x done)
+ (abort)
+ (proc x (lambda (x2) (loop x2 (cons x done)))) ) ) )
+
+(define (sort-symbols lst)
+ (sort lst (lambda (s1 s2) (string<? (symbol->string s1) (symbol->string s2)))))
+
+
+;;; Predicates on expressions and literals:
+
+(define (constant? x)
+ (or (number? x)
+ (char? x)
+ (string? x)
+ (boolean? x)
+ (eof-object? x)
+ (and (pair? x) (eq? 'quote (car x))) ) )
+
+(define (collapsable-literal? x)
+ (or (boolean? x)
+ (char? x)
+ (eof-object? x)
+ (number? x)
+ (symbol? x) ) )
+
+(define (immediate? x)
+ (or (and (fixnum? x) (not (big-fixnum? x))) ; 64-bit fixnums would result in platform-dependent .c files
+ (eq? (##core#undefined) x)
+ (null? x)
+ (eof-object? x)
+ (char? x)
+ (boolean? x) ) )
+
+(define (basic-literal? x)
+ (or (null? x)
+ (symbol? x)
+ (constant? x)
+ (and (vector? x) (every basic-literal? (vector->list x)))
+ (and (pair? x)
+ (basic-literal? (car x))
+ (basic-literal? (cdr x)) ) ) )
+
+
+;;; Expression manipulation:
+
+(define (canonicalize-begin-body body)
+ (let loop ((xs body))
+ (cond ((null? xs) '(##core#undefined))
+ ((null? (cdr xs)) (car xs))
+ ((let ([h (car xs)])
+ (or (equal? h '(##core#undefined))
+ (constant? h)
+ (equal? h '(##sys#void)) ) )
+ (loop (cdr xs)) )
+ (else `(let ((,(gensym 't) ,(car xs)))
+ ,(loop (cdr xs))) ) ) ) )
+
+(define string->expr
+ (let ([exn? (condition-predicate 'exn)]
+ [exn-msg (condition-property-accessor 'exn 'message)] )
+ (lambda (str)
+ (handle-exceptions ex
+ (quit "cannot parse expression: ~s [~a]~%"
+ str
+ (if (exn? ex)
+ (exn-msg ex)
+ (->string ex) ) )
+ (let ([xs (with-input-from-string str (lambda () (unfold eof-object? values (lambda (x) (read)) (read))))])
+ (cond [(null? xs) '(##core#undefined)]
+ [(null? (cdr xs)) (car xs)]
+ [else `(begin ,@xs)] ) ) ) ) ) )
+
+(define decompose-lambda-list ##sys#decompose-lambda-list)
+
+(define (process-lambda-documentation id doc proc)
+ proc) ; Hook this
+
+(define (llist-length llist)
+ (##core#inline "C_u_i_length" llist))
+
+
+;;; Profiling instrumentation:
+
+(define (expand-profile-lambda name llist body)
+ (let ([index profile-lambda-index]
+ [args (gensym)] )
+ (set! profile-lambda-list (alist-cons index name profile-lambda-list))
+ (set! profile-lambda-index (add1 index))
+ `(lambda ,args
+ (##sys#dynamic-wind
+ (lambda () (##sys#profile-entry ',index ,profile-info-vector-name))
+ (lambda () (apply (lambda ,llist ,body) ,args))
+ (lambda () (##sys#profile-exit ',index ,profile-info-vector-name)) ) ) ) )
+
+
+;;; Database operations:
+;
+; - 'get' and 'put' shadow the routines in the extras-unit, we use low-level
+; symbol-keyed hash-tables here.
+; - does currently nothing after the first invocation, but we leave it
+; this way to have the option to add default entries for each new db.
+
+(define initialize-analysis-database
+ (let ((initial #t))
+ (lambda ()
+ (when initial
+ (for-each
+ (lambda (s)
+ (mark-variable s '##compiler#intrinsic 'standard)
+ (when (memq s foldable-bindings)
+ (mark-variable s '##compiler#foldable #t)))
+ standard-bindings)
+ (for-each
+ (lambda (s)
+ (mark-variable s '##compiler#intrinsic 'extended)
+ (when (memq s foldable-bindings)
+ (mark-variable s '##compiler#foldable #t)))
+ extended-bindings)
+ (for-each
+ (lambda (s)
+ (mark-variable s '##compiler#intrinsic 'internal))
+ internal-bindings))
+ (set! initial #f))))
+
+(define (get db key prop)
+ (let ((plist (##sys#hash-table-ref db key)))
+ (and plist
+ (let ([a (assq prop plist)])
+ (and a (##sys#slot a 1)) ) ) ) )
+
+(define (get-all db key . props)
+ (let ((plist (##sys#hash-table-ref db key)))
+ (if plist
+ (filter-map (lambda (prop) (assq prop plist)) props)
+ '() ) ) )
+
+(define (put! db key prop val)
+ (let ([plist (##sys#hash-table-ref db key)])
+ (if plist
+ (let ([a (assq prop plist)])
+ (cond [a (##sys#setslot a 1 val)]
+ [val (##sys#setslot plist 1 (alist-cons prop val (##sys#slot plist 1)))] ) )
+ (when val (##sys#hash-table-set! db key (list (cons prop val)))) ) ) )
+
+(define (collect! db key prop val)
+ (let ((plist (##sys#hash-table-ref db key)))
+ (if plist
+ (let ([a (assq prop plist)])
+ (cond [a (##sys#setslot a 1 (cons val (##sys#slot a 1)))]
+ [else (##sys#setslot plist 1 (alist-cons prop (list val) (##sys#slot plist 1)))] ) )
+ (##sys#hash-table-set! db key (list (list prop val)))) ) )
+
+(define (count! db key prop . val)
+ (let ([plist (##sys#hash-table-ref db key)]
+ [n (if (pair? val) (car val) 1)] )
+ (if plist
+ (let ([a (assq prop plist)])
+ (cond [a (##sys#setslot a 1 (+ (##sys#slot a 1) n))]
+ [else (##sys#setslot plist 1 (alist-cons prop n (##sys#slot plist 1)))] ) )
+ (##sys#hash-table-set! db key (list (cons prop val)))) ) )
+
+(define (get-list db key prop) ; returns '() if not set
+ (let ((x (get db key prop)))
+ (or x '())))
+
+
+;;; Line-number database management:
+
+(define (get-line exp)
+ (get ##sys#line-number-database (car exp) exp) )
+
+(define (get-line-2 exp)
+ (let* ((name (car exp))
+ (lst (##sys#hash-table-ref ##sys#line-number-database name)) )
+ (cond ((and lst (assq exp (cdr lst)))
+ => (lambda (a) (values (car lst) (cdr a))) )
+ (else (values name #f)) ) ) )
+
+(define (find-lambda-container id cid db)
+ (let loop ([id id])
+ (or (eq? id cid)
+ (let ([c (get db id 'contained-in)])
+ (and c (loop c)) ) ) ) )
+
+(define (display-line-number-database)
+ (##sys#hash-table-for-each
+ (lambda (key val)
+ (when val (printf "~S ~S~%" key (map cdr val))) )
+ ##sys#line-number-database) )
+
+
+;;; Display analysis database:
+
+(define display-analysis-database
+ (let ((names '((captured . cpt) (assigned . set) (boxed . box) (global . glo) (assigned-locally . stl)
+ (contractable . con) (standard-binding . stb) (simple . sim) (inlinable . inl)
+ (collapsable . col) (removable . rem) (constant . con)
+ (inline-target . ilt) (inline-transient . itr)
+ (undefined . und) (replacing . rpg) (unused . uud) (extended-binding . xtb) (inline-export . ilx)
+ (customizable . cst) (has-unused-parameters . hup) (boxed-rest . bxr) ) )
+ (omit #f))
+ (lambda (db)
+ (unless omit
+ (set! omit
+ (append default-standard-bindings
+ default-extended-bindings
+ internal-bindings) ) )
+ (##sys#hash-table-for-each
+ (lambda (sym plist)
+ (let ([val #f]
+ (lval #f)
+ [pval #f]
+ [csites '()]
+ [refs '()] )
+ (unless (memq sym omit)
+ (write sym)
+ (let loop ((es plist))
+ (if (pair? es)
+ (begin
+ (case (caar es)
+ ((captured assigned boxed global contractable standard-binding assigned-locally
+ collapsable removable undefined replacing unused simple inlinable inline-export
+ has-unused-parameters extended-binding customizable constant boxed-rest hidden-refs)
+ (printf "\t~a" (cdr (assq (caar es) names))) )
+ ((unknown)
+ (set! val 'unknown) )
+ ((value)
+ (unless (eq? val 'unknown) (set! val (cdar es))) )
+ ((local-value)
+ (unless (eq? val 'unknown) (set! lval (cdar es))) )
+ ((potential-value)
+ (set! pval (cdar es)) )
+ ((replacable home contains contained-in use-expr closure-size rest-parameter
+ o-r/access-count captured-variables explicit-rest)
+ (printf "\t~a=~s" (caar es) (cdar es)) )
+ ((references)
+ (set! refs (cdar es)) )
+ ((call-sites)
+ (set! csites (cdar es)) )
+ (else (bomb "Illegal property" (car es))) )
+ (loop (cdr es)) ) ) )
+ (cond [(and val (not (eq? val 'unknown)))
+ (printf "\tval=~s" (cons (node-class val) (node-parameters val))) ]
+ [(and lval (not (eq? val 'unknown)))
+ (printf "\tlval=~s" (cons (node-class lval) (node-parameters lval))) ]
+ [(and pval (not (eq? val 'unknown)))
+ (printf "\tpval=~s" (cons (node-class pval) (node-parameters pval)))] )
+ (when (pair? refs) (printf "\trefs=~s" (length refs)))
+ (when (pair? csites) (printf "\tcss=~s" (length csites)))
+ (newline) ) ) )
+ db) ) ) )
+
+
+;;; Node creation and -manipulation:
+
+;; Note: much of this stuff will be overridden by the inline-definitions in "tweaks.scm".
+
+(define-record-type node
+ (make-node class parameters subexpressions)
+ node?
+ (class node-class node-class-set!) ; symbol
+ (parameters node-parameters node-parameters-set!) ; (value...)
+ (subexpressions node-subexpressions node-subexpressions-set!)) ; (node...)
+
+(define (make-node c p s)
+ (##sys#make-structure 'node c p s) ) ; this kludge is for allowing the inlined `make-node'
+
+(define (varnode var) (make-node '##core#variable (list var) '()))
+(define (qnode const) (make-node 'quote (list const) '()))
+
+(define (build-node-graph exp)
+ (let ([count 0])
+ (define (walk x)
+ (cond ((symbol? x) (varnode x))
+ ((not-pair? x) (bomb "bad expression" x))
+ ((symbol? (car x))
+ (case (car x)
+ ((##core#global-ref) (make-node '##core#global-ref (list (cadr x)) '()))
+ ((if ##core#undefined) (make-node (car x) '() (map walk (cdr x))))
+ ((quote)
+ (let ((c (cadr x)))
+ (qnode (if (and (number? c)
+ (eq? 'fixnum number-type)
+ (not (integer? c)) )
+ (begin
+ (compiler-warning
+ 'type
+ "literal '~s' is out of range - will be truncated to integer" c)
+ (inexact->exact (truncate c)) )
+ c) ) ) )
+ ((let)
+ (let ([bs (cadr x)]
+ [body (caddr x)] )
+ (if (null? bs)
+ (walk body)
+ (make-node 'let (unzip1 bs)
+ (append (map (lambda (b) (walk (cadr b))) (cadr x))
+ (list (walk body)) ) ) ) ) )
+ ((lambda ##core#lambda)
+ (make-node 'lambda (list (cadr x)) (list (walk (caddr x)))))
+ ((##core#primitive)
+ (let ([arg (cadr x)])
+ (make-node
+ (car x)
+ (list (if (and (pair? arg) (eq? 'quote (car arg))) (cadr arg) arg))
+ (map walk (cddr x)) ) ) )
+ ((##core#inline ##core#callunit)
+ (make-node (car x) (list (cadr x)) (map walk (cddr x))) )
+ ((##core#proc)
+ (make-node '##core#proc (list (cadr x) #t) '()) )
+ ((set! ##core#set!)
+ (make-node
+ 'set! (list (cadr x))
+ (map walk (cddr x))))
+ ((##core#foreign-callback-wrapper)
+ (let ([name (cadr (second x))])
+ (make-node
+ '##core#foreign-callback-wrapper
+ (list name (cadr (third x)) (cadr (fourth x)) (cadr (fifth x)))
+ (list (walk (sixth x))) ) ) )
+ ((##core#inline_allocate ##core#inline_ref ##core#inline_update
+ ##core#inline_loc_ref ##core#inline_loc_update)
+ (make-node (first x) (second x) (map walk (cddr x))) )
+ ((##core#app)
+ (make-node '##core#call '(#t) (map walk (cdr x))) )
+ (else
+ (receive (name ln) (get-line-2 x)
+ (make-node
+ '##core#call
+ (list (cond [(variable-mark name '##compiler#always-bound-to-procedure)
+ (set! count (add1 count))
+ #t]
+ [else #f] )
+ (if ln
+ (let ([rn (real-name name)])
+ (list source-filename ln (or rn (##sys#symbol->qualified-string name))) )
+ (##sys#symbol->qualified-string name) ) )
+ (map walk x) ) ) ) ) )
+ (else (make-node '##core#call '(#f) (map walk x))) ) )
+ (let ([exp2 (walk exp)])
+ (debugging 'o "eliminated procedure checks" count)
+ exp2) ) )
+
+(define (build-expression-tree node)
+ (let walk ((n node))
+ (let ((subs (node-subexpressions n))
+ (params (node-parameters n))
+ (class (node-class n)) )
+ (case class
+ ((if ##core#box ##core#cond) (cons class (map walk subs)))
+ ((##core#closure)
+ `(##core#closure ,params ,@(map walk subs)) )
+ ((##core#variable ##core#global-ref) (car params))
+ ((quote) `(quote ,(car params)))
+ ((let)
+ `(let ,(map list params (map walk (butlast subs)))
+ ,(walk (last subs)) ) )
+ ((##core#lambda)
+ (list (if (second params)
+ 'lambda
+ '##core#lambda)
+ (third params)
+ (walk (car subs)) ) )
+ ((##core#call) (map walk subs))
+ ((##core#callunit) (cons* '##core#callunit (car params) (map walk subs)))
+ ((##core#undefined) (list class))
+ ((##core#bind)
+ (let loop ((n (car params)) (vals subs) (bindings '()))
+ (if (zero? n)
+ `(##core#bind ,(reverse bindings) ,(walk (car vals)))
+ (loop (- n 1) (cdr vals) (cons (walk (car vals)) bindings)) ) ) )
+ ((##core#unbox ##core#ref ##core#update ##core#update_i)
+ (cons* class (walk (car subs)) params (map walk (cdr subs))) )
+ (else (cons class (append params (map walk subs)))) ) ) ) )
+
+(define (fold-boolean proc lst)
+ (let fold ([vars lst])
+ (if (null? (cddr vars))
+ (apply proc vars)
+ (make-node
+ '##core#inline '("C_and")
+ (list (proc (first vars) (second vars))
+ (fold (cdr vars)) ) ) ) ) )
+
+(define (inline-lambda-bindings llist args body copy? db)
+ (decompose-lambda-list
+ llist
+ (lambda (vars argc rest)
+ (receive (largs rargs) (split-at args argc)
+ (let* ([rlist (if copy? (map gensym vars) vars)]
+ [body (if copy?
+ (copy-node-tree-and-rename body vars rlist db)
+ body) ] )
+ (fold-right
+ (lambda (var val body) (make-node 'let (list var) (list val body)) )
+ (if rest
+ (make-node
+ 'let (list (last rlist))
+ (list (if (null? rargs)
+ (qnode '())
+ (make-node '##core#inline_allocate (list "C_a_i_list" (* 3 (length rargs))) rargs) )
+ body) )
+ body)
+ (take rlist argc)
+ largs) ) ) ) ) )
+
+(define (copy-node-tree-and-rename node vars aliases db)
+ (let ([rlist (map cons vars aliases)])
+ (define (rename v rl) (alist-ref v rl eq? v))
+ (define (walk n rl)
+ (let ([subs (node-subexpressions n)]
+ [params (node-parameters n)]
+ [class (node-class n)] )
+ (case class
+ [(##core#variable) (varnode (rename (first params) rl))]
+ [(set!)
+ (make-node
+ 'set! (list (rename (first params) rl))
+ (list (walk (first subs) rl)) ) ]
+ [(let)
+ (let* ((v (first params))
+ (val1 (walk (first subs) rl))
+ (a (gensym v))
+ (rl2 (alist-cons v a rl)) )
+ (make-node
+ 'let (list a)
+ (list val1 (walk (second subs) rl2)))) ]
+ [(##core#lambda)
+ (decompose-lambda-list
+ (third params)
+ (lambda (vars argc rest)
+ (let* ((as (map (lambda (v)
+ (let ((a (gensym v)))
+ (put! db v 'inline-transient #t)
+ a))
+ vars) )
+ (rl2 (append (map cons vars as) rl)) )
+ (make-node
+ '##core#lambda
+ (list (gensym 'f) (second params) ; new function-id
+ (build-lambda-list as argc (and rest (rename rest rl2)))
+ (fourth params) )
+ (map (cut walk <> rl2) subs) ) ) ) ) ]
+ [else (make-node class (tree-copy params) (map (cut walk <> rl) subs))] ) ) )
+ (walk node rlist) ) )
+
+(define (tree-copy t)
+ (let rec ([t t])
+ (if (pair? t)
+ (cons (rec (car t)) (rec (cdr t)))
+ t) ) )
+
+(define (copy-node! from to)
+ (node-class-set! to (node-class from))
+ (node-parameters-set! to (node-parameters from))
+ (node-subexpressions-set! to (node-subexpressions from))
+ to)
+
+(define (node->sexpr n)
+ (let walk ((n n))
+ `(,(node-class n)
+ ,(node-parameters n)
+ ,@(map walk (node-subexpressions n)))))
+
+(define (sexpr->node x)
+ (let walk ((x x))
+ (make-node (car x) (cadr x) (map walk (cddr x)))))
+
+(define (emit-global-inline-file filename db)
+ (let ((lst '()))
+ (with-output-to-file filename
+ (lambda ()
+ (print "; GENERATED BY CHICKEN " (chicken-version) " FROM "
+ source-filename "\n")
+ (##sys#hash-table-for-each
+ (lambda (sym plist)
+ (when (variable-visible? sym)
+ (and-let* ((val (assq 'local-value plist))
+ ((not (node? (variable-mark sym '##compiler#inline-global))))
+ ((let ((val (assq 'value plist)))
+ (or (not val)
+ (not (eq? 'unknown (cdr val))))))
+ ((assq 'inlinable plist))
+ (lparams (node-parameters (cdr val)))
+ ;;((get db (first lparams) 'simple))
+ ((not (get db sym 'hidden-refs)))
+ ((case (variable-mark sym '##compiler#inline)
+ ((yes) #t)
+ ((no) #f)
+ (else
+ (< (fourth lparams) inline-max-size) ) ) ) )
+ (set! lst (cons sym lst))
+ (pp (list sym (node->sexpr (cdr val))))
+ (newline))))
+ db)
+ (print "; END OF FILE")))
+ (when (and (pair? lst)
+ (debugging 'i "the following procedures can be globally inlined:"))
+ (for-each (cut print " " <>) (sort-symbols lst)))))
+
+(define (load-inline-file fname)
+ (with-input-from-file fname
+ (lambda ()
+ (let loop ()
+ (let ((x (read)))
+ (unless (eof-object? x)
+ (mark-variable
+ (car x)
+ '##compiler#inline-global
+ (sexpr->node (cadr x)))
+ (loop)))))))
+
+
+;;; Match node-structure with pattern:
+
+(define (match-node node pat vars)
+ (let ((env '()))
+
+ (define (resolve v x)
+ (cond ((assq v env) => (lambda (a) (equal? x (cdr a))))
+ ((memq v vars)
+ (set! env (alist-cons v x env))
+ #t)
+ (else (eq? v x)) ) )
+
+ (define (match1 x p)
+ (cond ((not-pair? p) (resolve p x))
+ ((not-pair? x) #f)
+ ((match1 (car x) (car p)) (match1 (cdr x) (cdr p)))
+ (else #f) ) )
+
+ (define (matchn n p)
+ (if (not-pair? p)
+ (resolve p n)
+ (and (eq? (node-class n) (first p))
+ (match1 (node-parameters n) (second p))
+ (let loop ((ns (node-subexpressions n))
+ (ps (cddr p)) )
+ (cond ((null? ps) (null? ns))
+ ((not-pair? ps) (resolve ps ns))
+ ((null? ns) #f)
+ (else (and (matchn (car ns) (car ps))
+ (loop (cdr ns) (cdr ps)) ) ) ) ) ) ) )
+
+ (let ((r (matchn node pat)))
+ (and r
+ (begin
+ (debugging 'a "matched" (node-class node) (node-parameters node) pat)
+ env) ) ) ) )
+
+
+;;; Test nodes for certain properties:
+
+(define (expression-has-side-effects? node db)
+ (let walk ([n node])
+ (let ([subs (node-subexpressions n)])
+ (case (node-class n)
+ [(##core#variable quote ##core#undefined ##core#proc ##core#global-ref) #f]
+ [(##core#lambda)
+ (let ([id (first (node-parameters n))])
+ (find (lambda (fs) (eq? id (foreign-callback-stub-id fs))) foreign-callback-stubs) ) ]
+ [(if let) (any walk subs)]
+ [else #t] ) ) ) )
+
+(define (simple-lambda-node? node)
+ (let* ([params (node-parameters node)]
+ [llist (third params)]
+ [k (and (pair? llist) (first llist))] ) ; leaf-routine has no continuation argument
+ (and k
+ (second params)
+ (let rec ([n node])
+ (case (node-class n)
+ [(##core#call)
+ (let* ([subs (node-subexpressions n)]
+ [f (first subs)] )
+ (and (eq? '##core#variable (node-class f))
+ (eq? k (first (node-parameters f)))
+ (every rec (cdr subs)) ) ) ]
+ [(##core#callunit) #f]
+ [else (every rec (node-subexpressions n))] ) ) ) ) )
+
+
+;;; Some safety checks and database dumping:
+
+(define (dump-undefined-globals db)
+ (##sys#hash-table-for-each
+ (lambda (sym plist)
+ (when (and (not (keyword? sym))
+ (assq 'global plist)
+ (not (assq 'assigned plist)) )
+ (write sym)
+ (newline) ) )
+ db) )
+
+(define (dump-defined-globals db)
+ (##sys#hash-table-for-each
+ (lambda (sym plist)
+ (when (and (not (keyword? sym))
+ (assq 'global plist)
+ (assq 'assigned plist))
+ (write sym)
+ (newline) ) )
+ db) )
+
+(define (dump-global-refs db)
+ (##sys#hash-table-for-each
+ (lambda (sym plist)
+ (when (and (not (keyword? sym)) (assq 'global plist))
+ (let ((a (assq 'references plist)))
+ (write (list sym (if a (length (cdr a)) 0)))
+ (newline) ) ) )
+ db) )
+
+
+;;; change hook function to hide non-exported module bindings
+
+(set! ##sys#toplevel-definition-hook
+ (lambda (sym mod exp val)
+ (when (and (not val) (not exp))
+ (debugging 'o "hiding nonexported module bindings" sym)
+ (hide-variable sym))))
+
+
+;;; Compute general statistics from analysis database:
+;
+; - Returns:
+;
+; current-program-size
+; original-program-size
+; number of known variables
+; number of known procedures
+; number of global variables
+; number of known call-sites
+; number of database entries
+; average bucket load
+
+(define (compute-database-statistics db)
+ (let ((nprocs 0)
+ (nvars 0)
+ (nglobs 0)
+ (entries 0)
+ (nsites 0) )
+ (##sys#hash-table-for-each
+ (lambda (sym plist)
+ (for-each
+ (lambda (prop)
+ (set! entries (+ entries 1))
+ (case (car prop)
+ ((global) (set! nglobs (+ nglobs 1)))
+ ((value)
+ (set! nvars (+ nvars 1))
+ (if (eq? '##core#lambda (node-class (cdr prop)))
+ (set! nprocs (+ nprocs 1)) ) )
+ ((call-sites) (set! nsites (+ nsites (length (cdr prop))))) ) )
+ plist) )
+ db)
+ (values current-program-size
+ original-program-size
+ nvars
+ nprocs
+ nglobs
+ nsites
+ entries) ) )
+
+(define (print-program-statistics db)
+ (receive
+ (size osize kvars kprocs globs sites entries) (compute-database-statistics db)
+ (when (debugging 's "program statistics:")
+ (printf "; program size: \t~s \toriginal program size: \t~s\n" size osize)
+ (printf "; variables with known values: \t~s\n" kvars)
+ (printf "; known procedures: \t~s\n" kprocs)
+ (printf "; global variables: \t~s\n" globs)
+ (printf "; known call sites: \t~s\n" sites)
+ (printf "; database entries: \t~s\n" entries) ) ) )
+
+
+;;; Pretty-print expressions:
+
+(define (pprint-expressions-to-file exps filename)
+ (let ([port (if filename (open-output-file filename) (current-output-port))])
+ (with-output-to-port port
+ (lambda ()
+ (for-each
+ (lambda (x)
+ (pretty-print x)
+ (newline) )
+ exps) ) )
+ (when filename (close-output-port port)) ) )
+
+
+;;; Create foreign type checking expression:
+
+(define foreign-type-check
+ (let ([tmap '((nonnull-u8vector . u8vector) (nonnull-u16vector . u16vector)
+ (nonnull-s8vector . s8vector) (nonnull-s16vector . s16vector)
+ (nonnull-u32vector . u32vector) (nonnull-s32vector . s32vector)
+ (nonnull-f32vector . f32vector) (nonnull-f64vector . f64vector) ) ] )
+ (lambda (param type)
+ (follow-without-loop
+ type
+ (lambda (t next)
+ (let repeat ([t t])
+ (case t
+ [(char unsigned-char) (if unsafe param `(##sys#foreign-char-argument ,param))]
+ [(int unsigned-int short unsigned-short byte unsigned-byte int32 unsigned-int32)
+ (if unsafe param `(##sys#foreign-fixnum-argument ,param))]
+ [(float double number) (if unsafe param `(##sys#foreign-flonum-argument ,param))]
+ [(pointer byte-vector blob scheme-pointer) ; pointer and byte-vector are DEPRECATED
+ (let ([tmp (gensym)])
+ `(let ([,tmp ,param])
+ (if ,tmp
+ ,(if unsafe
+ tmp
+ `(##sys#foreign-block-argument ,tmp) )
+ '#f) ) ) ]
+ [(nonnull-pointer nonnull-scheme-pointer nonnull-blob nonnull-byte-vector) ; nonnull-pointer and nonnull-byte-vector are DEPRECATED
+ (if unsafe
+ param
+ `(##sys#foreign-block-argument ,param) ) ]
+ [(u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector)
+ (let ([tmp (gensym)])
+ `(let ([,tmp ,param])
+ (if ,tmp
+ ,(if unsafe
+ tmp
+ `(##sys#foreign-number-vector-argument ',t ,tmp) )
+ '#f) ) ) ]
+ [(nonnull-u8vector nonnull-u16vector nonnull-s8vector nonnull-s16vector nonnull-u32vector nonnull-s32vector
+ nonnull-f32vector nonnull-f64vector)
+ (if unsafe
+ param
+ `(##sys#foreign-number-vector-argument
+ ',(##sys#slot (assq t tmap) 1)
+ ,param) ) ]
+ [(integer long integer32) (if unsafe param `(##sys#foreign-integer-argument ,param))]
+ [(unsigned-integer unsigned-integer32 unsigned-long)
+ (if unsafe
+ param
+ `(##sys#foreign-unsigned-integer-argument ,param) ) ]
+ [(c-pointer c-string-list c-string-list*)
+ (let ([tmp (gensym)])
+ `(let ([,tmp ,param])
+ (if ,tmp
+ (##sys#foreign-pointer-argument ,tmp)
+ '#f) ) ) ]
+ [(nonnull-c-pointer)
+ `(##sys#foreign-pointer-argument ,param) ]
+ [(c-string c-string* unsigned-c-string unsigned-c-string*)
+ (let ([tmp (gensym)])
+ `(let ([,tmp ,param])
+ (if ,tmp
+ ,(if unsafe
+ `(##sys#make-c-string ,tmp)
+ `(##sys#make-c-string (##sys#foreign-string-argument ,tmp)) )
+ '#f) ) ) ]
+ [(nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*)
+ (if unsafe
+ `(##sys#make-c-string ,param)
+ `(##sys#make-c-string (##sys#foreign-string-argument ,param)) ) ]
+ [(symbol)
+ (if unsafe
+ `(##sys#make-c-string (##sys#symbol->string ,param))
+ `(##sys#make-c-string (##sys#foreign-string-argument (##sys#symbol->string ,param))) ) ]
+ [else
+ (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
+ => (lambda (t)
+ (next (if (vector? t) (vector-ref t 0) t)) ) ]
+ [(pair? t)
+ (case (car t)
+ [(ref pointer function c-pointer)
+ (let ([tmp (gensym)])
+ `(let ([,tmp ,param])
+ (if ,tmp
+ (##sys#foreign-pointer-argument ,tmp)
+ '#f) ) ) ]
+ [(instance instance-ref)
+ (let ([tmp (gensym)])
+ `(let ([,tmp ,param])
+ (if ,tmp
+ (slot-ref ,param 'this)
+ '#f) ) ) ]
+ [(nonnull-instance)
+ `(slot-ref ,param 'this) ]
+ [(const) (repeat (cadr t))]
+ [(enum)
+ (if unsafe param `(##sys#foreign-integer-argument ,param))]
+ [(nonnull-pointer nonnull-c-pointer)
+ `(##sys#foreign-pointer-argument ,param) ]
+ [else param] ) ]
+ [else param] ) ] ) ) )
+ (lambda () (quit "foreign type `~S' refers to itself" type)) ) ) ) )
+
+
+;;; Compute foreign-type conversions:
+
+(define (foreign-type-convert-result r t)
+ (or (and-let* ([(symbol? t)]
+ [ft (##sys#hash-table-ref foreign-type-table t)]
+ [(vector? ft)] )
+ (list (vector-ref ft 2) r) )
+ r) )
+
+(define (foreign-type-convert-argument a t)
+ (or (and-let* ([(symbol? t)]
+ [ft (##sys#hash-table-ref foreign-type-table t)]
+ [(vector? ft)] )
+ (list (vector-ref ft 1) a) )
+ a) )
+
+(define (final-foreign-type t0)
+ (follow-without-loop
+ t0
+ (lambda (t next)
+ (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
+ => (lambda (t2)
+ (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
+ [else t] ) )
+ (lambda () (quit "foreign type `~S' refers to itself" t0)) ) )
+
+
+;;; Compute foreign result size:
+
+(define (estimate-foreign-result-size type)
+ (follow-without-loop
+ type
+ (lambda (t next)
+ (case t
+ ((char int short bool void unsigned-short scheme-object unsigned-char unsigned-int byte unsigned-byte
+ int32 unsigned-int32)
+ 0)
+ ((c-string nonnull-c-string c-pointer nonnull-c-pointer symbol c-string* nonnull-c-string*
+ unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
+ c-string-list c-string-list*)
+ (words->bytes 3) )
+ ((unsigned-integer long integer unsigned-long integer32 unsigned-integer32)
+ (words->bytes 4) )
+ ((float double number integer64)
+ (words->bytes 4) ) ; possibly 8-byte aligned 64-bit double
+ (else
+ (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
+ => (lambda (t2)
+ (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
+ [(pair? t)
+ (case (car t)
+ [(ref nonnull-pointer pointer c-pointer nonnull-c-pointer function instance instance-ref nonnull-instance)
+ (words->bytes 3) ]
+ [else 0] ) ]
+ [else 0] ) ) ) )
+ (lambda () (quit "foreign type `~S' refers to itself" type)) ) )
+
+(define (estimate-foreign-result-location-size type)
+ (define (err t)
+ (quit "cannot compute size of location for foreign type `~S'" t) )
+ (follow-without-loop
+ type
+ (lambda (t next)
+ (case t
+ ((char int short bool unsigned-short unsigned-char unsigned-int long unsigned-long byte unsigned-byte
+ c-pointer pointer nonnull-c-pointer unsigned-integer integer float c-string symbol
+ scheme-pointer nonnull-scheme-pointer int32 unsigned-int32 integer32 unsigned-integer32
+ unsigned-c-string unsigned-c-string* nonnull-unsigned-c-string*
+ nonnull-c-string c-string* nonnull-c-string* c-string-list c-string-list*) ; pointer and nonnull-pointer are DEPRECATED
+ (words->bytes 1) )
+ ((double number)
+ (words->bytes 2) )
+ (else
+ (cond [(and (symbol? t) (##sys#hash-table-ref foreign-type-table t))
+ => (lambda (t2)
+ (next (if (vector? t2) (vector-ref t2 0) t2)) ) ]
+ [(pair? t)
+ (case (car t)
+ [(ref nonnull-pointer pointer c-pointer nonnull-c-pointer function) (words->bytes 1)]
+ [else (err t)] ) ]
+ [else (err t)] ) ) ) )
+ (lambda () (quit "foreign type `~S' refers to itself" type)) ) )
+
+
+;;; Convert result value, if a string:
+
+(define (finish-foreign-result type body)
+ (case type
+ [(c-string unsigned-c-string) `(##sys#peek-c-string ,body '0)]
+ [(nonnull-c-string) `(##sys#peek-nonnull-c-string ,body '0)]
+ [(c-string* unsigned-c-string*) `(##sys#peek-and-free-c-string ,body '0)]
+ [(nonnull-c-string* nonnull-unsigned-c-string*) `(##sys#peek-and-free-nonnull-c-string ,body '0)]
+ [(symbol) `(##sys#intern-symbol (##sys#peek-c-string ,body '0))]
+ [(c-string-list) `(##sys#peek-c-string-list ,body '#f)]
+ [(c-string-list*) `(##sys#peek-and-free-c-string-list ,body '#f)]
+ [else
+ (cond
+ [(and (list? type) (= 3 (length type))
+ (memq (car type) '(instance instance-ref)))
+ `(##tinyclos#make-instance-from-pointer ,body ,(caddr type)) ] ;XXX eggified, needs better treatment...
+ [(and (list? type) (= 3 (length type)) (eq? 'nonnull-instance (car type)))
+ `(make ,(caddr type) 'this ,body) ]
+ [else body] ) ] ) )
+
+
+;;; Scan expression-node for variable usage:
+
+(define (scan-used-variables node vars)
+ (let ([used '()])
+ (let walk ([n node])
+ (let ([subs (node-subexpressions n)])
+ (case (node-class n)
+ [(##core#variable set!)
+ (let ([var (first (node-parameters n))])
+ (when (and (memq var vars) (not (memq var used)))
+ (set! used (cons var used)) )
+ (for-each walk subs) ) ]
+ [(quote ##core#undefined ##core#primitive) #f]
+ [else (for-each walk subs)] ) ) )
+ used) )
+
+
+;;; Scan expression-node for free variables (that are not in env):
+
+(define (scan-free-variables node)
+ (let ((vars '())
+ (hvars '()))
+
+ (define (walk n e)
+ (let ([subs (node-subexpressions n)]
+ [params (node-parameters n)] )
+ (case (node-class n)
+ ((quote ##core#undefined ##core#primitive ##core#proc ##core#inline_ref) #f)
+ ((##core#variable)
+ (let ((var (first params)))
+ (unless (memq var e)
+ (set! vars (lset-adjoin eq? vars var))
+ (unless (variable-visible? var)
+ (set! hvars (lset-adjoin eq? hvars var))))))
+ ((set!)
+ (let ((var (first params)))
+ (unless (memq var e) (set! vars (lset-adjoin eq? vars var)))
+ (walk (car subs) e) ) )
+ ((let)
+ (walk (first subs) e)
+ (walk (second subs) (append params e)) )
+ ((##core#lambda)
+ (decompose-lambda-list
+ (third params)
+ (lambda (vars argc rest)
+ (walk (first subs) (append vars e)) ) ) )
+ (else (walkeach subs e)) ) ) )
+
+ (define (walkeach ns e)
+ (for-each (lambda (n) (walk n e)) ns) )
+
+ (walk node '())
+ (values vars hvars) ) )
+
+
+;;; Some pathname operations:
+
+(define (chop-separator str)
+ (let ([len (sub1 (string-length str))])
+ (if (and (> len 0)
+ (memq (string-ref str len) '(#\\ #\/)))
+ (substring str 0 len)
+ str) ) )
+
+(define (chop-extension str)
+ (let ([len (sub1 (string-length str))])
+ (let loop ([i len])
+ (cond [(zero? i) str]
+ [(char=? #\. (string-ref str i)) (substring str 0 i)]
+ [else (loop (sub1 i))] ) ) ) )
+
+
+;;; Print version/usage information:
+
+(define (print-version #!optional b)
+ (when b (print* +banner+))
+ (print (chicken-version #t)) )
+
+(define (print-usage)
+ (print-version)
+ (newline)
+ (display #<<EOF
+Usage: chicken FILENAME OPTION ...
+
+ `chicken' is the CHICKEN compiler.
+
+ FILENAME should be a complete source file name with extension, or "-" for
+ standard input. OPTION may be one of the following:
+
+ General options:
+
+ -help display this text and exit
+ -version display compiler version and exit
+ -release print release number and exit
+ -verbose display information on compilation progress
+
+ File and pathname options:
+
+ -output-file FILENAME specifies output-filename, default is 'out.c'
+ -include-path PATHNAME specifies alternative path for included files
+ -to-stdout write compiled file to stdout instead of file
+
+ Language options:
+
+ -feature SYMBOL register feature identifier
+
+ Syntax related options:
+
+ -case-insensitive don't preserve case of read symbols
+ -keyword-style STYLE allow alternative keyword syntax
+ (prefix, suffix or none)
+ -no-parentheses-synonyms disables list delimiter synonyms
+ -no-symbol-escape disables support for escaped symbols
+ -r5rs-syntax disables the Chicken extensions to
+ R5RS syntax
+ -compile-syntax macros are made available at run-time
+ -emit-import-library MODULE write compile-time module information into
+ separate file
+ -emit-all-import-libraries emit import-libraries for all defined modules
+ -no-compiler-syntax disable expansion of compiler-macros
+
+ Translation options:
+
+ -explicit-use do not use units 'library' and 'eval' by
+ default
+ -check-syntax stop compilation after macro-expansion
+ -analyze-only stop compilation after first analysis pass
+
+ Debugging options:
+
+ -no-warnings disable warnings
+ -disable-warning CLASS disable specific class of warnings
+ -debug-level NUMBER set level of available debugging information
+ -no-trace disable tracing information
+ -profile executable emits profiling information
+ -profile-name FILENAME name of the generated profile information file
+ -accumulate-profile executable emits profiling information in
+ append mode
+ -no-lambda-info omit additional procedure-information
+ -scrutinize perform local flow analysis
+ -types FILENAME load additional type database
+
+ Optimization options:
+
+ -optimize-level NUMBER enable certain sets of optimization options
+ -optimize-leaf-routines enable leaf routine optimization
+ -lambda-lift enable lambda-lifting
+ -no-usual-integrations standard procedures may be redefined
+ -unsafe disable all safety checks
+ -local assume globals are only modified in current
+ file
+ -block enable block-compilation
+ -disable-interrupts disable interrupts in compiled code
+ -fixnum-arithmetic assume all numbers are fixnums
+ -benchmark-mode equivalent to 'block -optimize-level 4
+ -debug-level 0 -fixnum-arithmetic -lambda-lift
+ -inline -disable-interrupts'
+ -disable-stack-overflow-checks disables detection of stack-overflows
+ -inline enable inlining
+ -inline-limit set inlining threshold
+ -inline-global enable cross-module inlining
+ -emit-inline-file FILENAME generate file with globally inlinable
+ procedures (implies -inline -local)
+ -consult-inline-file FILENAME explicitly load inline file
+ -no-argc-checks disable argument count checks
+ -no-bound-checks disable bound variable checks
+ -no-procedure-checks disable procedure call checks
+ -no-procedure-checks-for-usual-bindings
+ disable procedure call checks only for usual
+ bindings
+
+ Configuration options:
+
+ -unit NAME compile file as a library unit
+ -uses NAME declare library unit as used.
+ -heap-size NUMBER specifies heap-size of compiled executable
+ -heap-initial-size NUMBER specifies heap-size at startup time
+ -heap-growth PERCENTAGE specifies growth-rate of expanding heap
+ -heap-shrinkage PERCENTAGE specifies shrink-rate of contracting heap
+ -nursery NUMBER -stack-size NUMBER
+ specifies nursery size of compiled executable
+ -extend FILENAME load file before compilation commences
+ -prelude EXPRESSION add expression to front of source file
+ -postlude EXPRESSION add expression to end of source file
+ -prologue FILENAME include file before main source file
+ -epilogue FILENAME include file after main source file
+ -dynamic compile as dynamically loadable code
+ -require-extension NAME require and import extension NAME
+ -static-extension NAME import extension NAME but link statically
+ (if available)
+
+ Obscure options:
+
+ -debug MODES display debugging output for the given modes
+ -unsafe-libraries marks the generated file as being linked with
+ the unsafe runtime system
+ -raw do not generate implicit init- and exit code
+ -emit-external-prototypes-first
+ emit prototypes for callbacks before foreign
+ declarations
+ -ignore-repository do not refer to repository for extensions
+ -setup-mode prefer the current directory when locating extensions
+
+EOF
+) )
+
+
+;;; Special block-variable literal type:
+
+(define-record-type block-variable-literal
+ (make-block-variable-literal name)
+ block-variable-literal?
+ (name block-variable-literal-name)) ; symbol
+
+
+;;; Generation of random names:
+
+(define (make-random-name . prefix)
+ (string->symbol
+ (sprintf "~A-~A~A"
+ (optional prefix (gensym))
+ (current-seconds)
+ (random 1000) ) ) )
+
+
+;;; Register/lookup real names:
+;
+; - The real-name-table contains the following mappings:
+;
+; <variable-alias> -> <variable>
+; <lambda-id> -> <variable> or <variable-alias>
+
+(define (set-real-name! name rname)
+ (##sys#hash-table-set! real-name-table name rname) )
+
+(define (real-name var . db)
+ (define (resolve n)
+ (let ([n2 (##sys#hash-table-ref real-name-table n)])
+ (if n2
+ (or (##sys#hash-table-ref real-name-table n2)
+ n2)
+ n) ) )
+ (let ([rn (resolve var)])
+ (cond [(not rn) (##sys#symbol->qualified-string var)]
+ [(pair? db)
+ (let ([db (car db)])
+ (let loop ([prev (##sys#symbol->qualified-string rn)]
+ [container (get db var 'contained-in)] )
+ (if container
+ (let ([rc (resolve container)])
+ (if (eq? rc container)
+ prev
+ (loop (sprintf "~A in ~A" prev rc)
+ (get db container 'contained-in) ) ) )
+ prev) ) ) ]
+ [else (##sys#symbol->qualified-string rn)] ) ) )
+
+(define (real-name2 var db)
+ (and-let* ([rn (##sys#hash-table-ref real-name-table var)])
+ (real-name rn db) ) )
+
+(define (display-real-name-table)
+ (##sys#hash-table-for-each
+ (lambda (key val)
+ (printf "~S\t~S~%" key val) )
+ real-name-table) )
+
+(define (source-info->string info)
+ (if (list? info)
+ (let ((file (car info))
+ (ln (cadr info))
+ (name (caddr info)))
+ (let ((lns (->string ln)))
+ (conc file ": " lns (make-string (max 0 (- 4 (string-length lns))) #\space) " " name) ) )
+ (and info (->string info))) )
+
+(define (source-info->line info)
+ (if (list? info)
+ (cadr info)
+ (and info (->string info))) )
+
+
+;;; We need this for constant folding:
+
+(define (string-null? x)
+ (##core#inline "C_i_string_null_p" s))
+
+
+;;; Dump node structure:
+
+(define (dump-nodes n)
+ (let loop ([i 0] [n n])
+ (let ([class (node-class n)]
+ [params (node-parameters n)]
+ [subs (node-subexpressions n)]
+ [ind (make-string i #\space)]
+ [i2 (+ i 2)] )
+ (printf "~%~A<~A ~S" ind class params)
+ (for-each (cut loop i2 <>) subs)
+ (let ([len (##sys#size n)])
+ (when (fx> len 4)
+ (printf "[~S" (##sys#slot n 4))
+ (do ([i 5 (fx+ i 1)])
+ ((fx>= i len))
+ (printf " ~S" (##sys#slot n i)) )
+ (write-char #\]) ) )
+ (write-char #\>) ) )
+ (newline) )
+
+
+;;; "#> ... <#" syntax:
+
+(set! ##sys#user-read-hook
+ (let ([old-hook ##sys#user-read-hook])
+ (lambda (char port)
+ (if (char=? #\> char)
+ (let* ((_ (read-char port)) ; swallow #\>
+ (text (scan-sharp-greater-string port)))
+ `(declare (foreign-declare ,text)) )
+ (old-hook char port) ) ) ) )
+
+(define (scan-sharp-greater-string port)
+ (let ([out (open-output-string)])
+ (let loop ()
+ (let ([c (read-char port)])
+ (cond [(eof-object? c) (quit "unexpected end of `#> ... <#' sequence")]
+ [(char=? c #\newline)
+ (newline out)
+ (loop) ]
+ [(char=? c #\<)
+ (let ([c (read-char port)])
+ (if (eqv? #\# c)
+ (get-output-string out)
+ (begin
+ (write-char #\< out)
+ (write-char c out)
+ (loop) ) ) ) ]
+ [else
+ (write-char c out)
+ (loop) ] ) ) ) ) )
+
+
+;;; 64-bit fixnum?
+
+(define (big-fixnum? x)
+ (and (fixnum? x)
+ (##sys#fudge 3) ; 64 bit?
+ (or (fx> x 1073741823)
+ (fx< x -1073741824) ) ) )
+
+
+;;; symbol visibility and other global variable properties
+
+(define (hide-variable sym)
+ (mark-variable sym '##compiler#visibility 'hidden))
+
+(define (export-variable sym)
+ (mark-variable sym '##compiler#visibility 'exported))
+
+(define (variable-visible? sym)
+ (let ((p (##sys#get sym '##compiler#visibility)))
+ (case p
+ ((hidden) #f)
+ ((exported) #t)
+ (else (not block-compilation)))))
+
+(define (mark-variable var mark #!optional (val #t))
+ (##sys#put! var mark val) )
+
+(define (variable-mark var mark)
+ (##sys#get var mark) )
+
+(define intrinsic? (cut variable-mark <> '##compiler#intrinsic))
+(define foldable? (cut variable-mark <> '##compiler#foldable))
+
+
+;;; Load support files
+
+(define (load-identifier-database name)
+ (and-let* ((rp (repository-path))
+ (dbfile (file-exists? (make-pathname rp name))))
+ (when verbose-mode
+ (printf "loading identifier database ~a ...~%" dbfile))
+ (for-each
+ (lambda (e)
+ (##sys#put!
+ (car e) '##core#db
+ (append (or (##sys#get (car e) '##core#db) '()) (list (cdr e))) ))
+ (read-file dbfile))))
diff --git a/svnrevision.sh b/svnrevision.sh
new file mode 100644
index 00000000..8f68f842
--- /dev/null
+++ b/svnrevision.sh
@@ -0,0 +1,51 @@
+#!/bin/sh
+# svnrevision.sh - figure out SVN revision and update buildsvnrevision file, if needed
+#
+# Copyright (c) 2007, Felix L. Winkelmann
+# Copyright (c) 2008-2009, The Chicken Team
+# All rights reserved.
+#
+# Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+# conditions are met:
+#
+# Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+# disclaimer.
+# 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.
+# Neither the name of the author nor the names of its contributors may be used to endorse or promote
+# products derived from this software without specific prior written permission.
+#
+# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+# OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+# AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+# CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+# SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+# POSSIBILITY OF SUCH DAMAGE.
+
+
+LANG="C"
+
+if test -d ".svn" ;
+then
+ if test -x "`which svn`" ;
+ then
+ rev="`svn info | sed -n -e 's/Revision: \([0-9]*\)/\1/p'`"
+ else
+ rev="`cat .svn/entries | sed -n -e '4 s/^\([0-9]*\)$/\1/p'`"
+ fi
+else
+ rev="0"
+fi
+
+if test -e "buildsvnrevision" ;
+then
+ if test "`cat buildsvnrevision`" \!= "${rev}" ;
+ then
+ echo "${rev}" > buildsvnrevision
+ fi
+else
+ echo "${rev}" > buildsvnrevision
+fi
diff --git a/synrules.scm b/synrules.scm
new file mode 100644
index 00000000..492a65ae
--- /dev/null
+++ b/synrules.scm
@@ -0,0 +1,332 @@
+;; Copyright (c) 1993-2001 by Richard Kelsey and Jonathan Rees.
+;; 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 authors may not be used to endorse or promote products
+;; derived from this software without specific prior written permission.
+
+;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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.
+
+; The syntax-rules macro (new in R5RS)
+
+;;; [Hacked slightly by Taylor R. Campbell to make it work in his
+;;; macro expander `riaxpander'.]
+
+;; [Hacked even more by Felix L. Winkelmann to make it work in his
+;; Hi-Lo expander]
+
+; Example:
+;
+; (define-syntax or
+; (syntax-rules ()
+; ((or) #f)
+; ((or e) e)
+; ((or e1 e ...) (let ((temp e1))
+; (if temp temp (or e ...))))))
+
+
+(##sys#extend-macro-environment
+ 'syntax-rules
+ '()
+ (##sys#er-transformer
+ (lambda (exp r c)
+ (##sys#check-syntax 'syntax-rules exp '#(_ 2))
+ (let ((subkeywords (cadr exp))
+ (rules (cddr exp))
+ (ellipsis '...))
+ (when (symbol? subkeywords)
+ (##sys#check-syntax 'syntax-rules exp '(_ _ list . #(_ 0)))
+ (set! ellipsis subkeywords)
+ (set! subkeywords (car rules))
+ (set! rules (cdr rules)))
+ (##sys#process-syntax-rules ellipsis rules subkeywords r c)))))
+
+
+(define (##sys#process-syntax-rules ellipsis rules subkeywords r c)
+
+ (define %append '##sys#append)
+ (define %apply '##sys#apply)
+ (define %and (r 'and))
+ (define %car '##sys#car)
+ (define %cdr '##sys#cdr)
+ (define %vector? '##sys#vector?)
+ (define %vector-length '##sys#vector-length)
+ (define %vector-ref '##sys#vector-ref)
+ (define %vector->list '##sys#vector->list)
+ (define %list->vector '##sys#list->vector)
+ (define %>= '##sys#>=)
+ (define %= '##sys#=)
+ (define %+ '##sys#+)
+ (define %i (r 'i))
+ (define %compare (r 'compare))
+ (define %cond (r 'cond))
+ (define %cons '##sys#cons)
+ (define %else (r 'else))
+ (define %eq? '##sys#eq?)
+ (define %equal? '##sys#equal?)
+ (define %input (r 'input))
+ (define %l (r 'l))
+ (define %lambda (r 'lambda))
+ (define %let (r 'let))
+ (define %let* (r 'let*))
+ (define %list? '##sys#list?)
+ (define %list (r 'list))
+ (define %loop (r 'loop))
+ (define %map1 '##sys#map)
+ (define %map '##sys#map-n)
+ (define %null? '##sys#null?)
+ (define %or (r 'or))
+ (define %pair? '##sys#pair?)
+ (define %quote (r 'quote))
+ (define %rename (r 'rename))
+ (define %tail (r 'tail))
+ (define %temp (r 'temp))
+ (define %syntax-error '##sys#syntax-error-hook)
+ (define %ellipsis (r ellipsis))
+
+ (define (ellipsis? x)
+ (c x %ellipsis))
+
+ (define (make-transformer rules)
+ `(,%lambda (,%input ,%rename ,%compare)
+ (,%let ((,%tail (,%cdr ,%input)))
+ (,%cond ,@(map process-rule rules)
+ (,%else
+ (##sys#syntax-rules-mismatch ,%input))))))
+
+ (define (process-rule rule)
+ (if (and (pair? rule)
+ (pair? (cdr rule))
+ (null? (cddr rule)))
+ (let ((pattern (cdar rule))
+ (template (cadr rule)))
+ `((,%and ,@(process-match %tail pattern))
+ (,%let* ,(process-pattern pattern
+ %tail
+ (lambda (x) x))
+ ,(process-template template
+ 0
+ (meta-variables pattern 0 '())))))
+ (##sys#syntax-error-hook "ill-formed syntax rule" rule)))
+
+ ;; Generate code to test whether input expression matches pattern
+
+ (define (process-match input pattern)
+ (cond ((symbol? pattern)
+ (if (memq pattern subkeywords)
+ `((,%compare ,input (,%rename (syntax ,pattern))))
+ `()))
+ ((segment-pattern? pattern)
+ (process-segment-match input (car pattern)))
+ ((pair? pattern)
+ `((,%let ((,%temp ,input))
+ (,%and (,%pair? ,%temp)
+ ,@(process-match `(,%car ,%temp) (car pattern))
+ ,@(process-match `(,%cdr ,%temp) (cdr pattern))))))
+ ((vector? pattern)
+ (process-vector-match input pattern))
+ ((or (null? pattern) (boolean? pattern) (char? pattern))
+ `((,%eq? ,input ',pattern)))
+ (else
+ `((,%equal? ,input ',pattern)))))
+
+ (define (process-segment-match input pattern)
+ (let ((conjuncts (process-match `(,%car ,%l) pattern)))
+ (if (null? conjuncts)
+ `((,%list? ,input)) ;+++
+ `((,%let ,%loop ((,%l ,input))
+ (,%or (,%null? ,%l)
+ (,%and (,%pair? ,%l)
+ ,@conjuncts
+ (,%loop (,%cdr ,%l)))))))))
+
+ (define (process-vector-match input pattern)
+ (let* ((len (vector-length pattern))
+ (segment? (and (>= len 2)
+ (ellipsis? (vector-ref pattern (- len 1))))))
+ `((,%let ((,%temp ,input))
+ (,%and (,%vector? ,%temp)
+ ,(if segment?
+ `(,%>= (,%vector-length ,%temp) ,(- len 2))
+ `(,%= (,%vector-length ,%temp) ,len))
+ ,@(let lp ((i 0))
+ (cond
+ ((>= i len)
+ '())
+ ((and (= i (- len 2)) segment?)
+ `((,%let ,%loop ((,%i ,i))
+ (,%or (,%>= ,%i ,len)
+ (,%and ,@(process-match
+ `(,%vector-ref ,%temp ,%i)
+ (vector-ref pattern (- len 2)))
+ (,%loop (,%+ ,%i 1)))))))
+ (else
+ (append (process-match `(,%vector-ref ,%temp ,i)
+ (vector-ref pattern i))
+ (lp (+ i 1)))))))))))
+
+ ;; Generate code to take apart the input expression
+ ;; This is pretty bad, but it seems to work (can't say why).
+
+ (define (process-pattern pattern path mapit)
+ (cond ((symbol? pattern)
+ (if (memq pattern subkeywords)
+ '()
+ (list (list pattern (mapit path)))))
+ ((segment-pattern? pattern)
+ (process-pattern (car pattern)
+ %temp
+ (lambda (x) ;temp is free in x
+ (mapit (if (eq? %temp x)
+ path ;+++
+ `(,%map1 (,%lambda (,%temp) ,x)
+ ,path))))))
+ ((pair? pattern)
+ (append (process-pattern (car pattern) `(,%car ,path) mapit)
+ (process-pattern (cdr pattern) `(,%cdr ,path) mapit)))
+ ((vector? pattern)
+ (let* ((len (vector-length pattern))
+ (segment? (and (>= len 2)
+ (ellipsis? (vector-ref pattern (- len 1))))))
+ (if segment?
+ (process-pattern (vector->list pattern)
+ `(,%vector->list ,path)
+ mapit)
+ (let lp ((i 0))
+ (cond
+ ((>= i len)
+ '())
+ (else
+ (append (process-pattern (vector-ref pattern i)
+ `(,%vector-ref ,path ,i)
+ mapit)
+ (lp (+ i 1)))))))))
+ (else '())))
+
+ ;; Generate code to compose the output expression according to template
+
+ (define (process-template template dim env)
+ (cond ((symbol? template)
+ (let ((probe (assq template env)))
+ (if probe
+ (if (<= (cdr probe) dim)
+ template
+ (##sys#syntax-error-hook "template dimension error (too few ellipses?)"
+ template))
+ `(,%rename (syntax ,template)))))
+ ((segment-template? template)
+ (let* ((depth (segment-depth template))
+ (seg-dim (+ dim depth))
+ (vars
+ (free-meta-variables (car template) seg-dim env '())))
+ (if (null? vars)
+ (##sys#syntax-error-hook "too many ellipses" template)
+ (let* ((x (process-template (car template)
+ seg-dim
+ env))
+ (gen (if (and (pair? vars)
+ (null? (cdr vars))
+ (symbol? x)
+ (eq? x (car vars)))
+ x ;+++
+ `(,%map (,%lambda ,vars ,x)
+ ,@vars)))
+ (gen (do ((d depth (- d 1))
+ (gen gen `(,%apply ,%append ,gen)))
+ ((= d 1)
+ gen))))
+ (if (null? (segment-tail template))
+ gen ;+++
+ `(,%append ,gen ,(process-template (segment-tail template)
+ dim env)))))))
+ ((pair? template)
+ `(,%cons ,(process-template (car template) dim env)
+ ,(process-template (cdr template) dim env)))
+ ((vector? template)
+ `(,%list->vector
+ ,(process-template (vector->list template) dim env)))
+ (else
+ `(,%quote ,template))))
+
+ ;; Return an association list of (var . dim)
+
+ (define (meta-variables pattern dim vars)
+ (cond ((symbol? pattern)
+ (if (memq pattern subkeywords)
+ vars
+ (cons (cons pattern dim) vars)))
+ ((segment-pattern? pattern)
+ (meta-variables (car pattern) (+ dim 1) vars))
+ ((pair? pattern)
+ (meta-variables (car pattern) dim
+ (meta-variables (cdr pattern) dim vars)))
+ ((vector? pattern)
+ (meta-variables (vector->list pattern) dim vars))
+ (else vars)))
+
+ ;; Return a list of meta-variables of given higher dim
+
+ (define (free-meta-variables template dim env free)
+ (cond ((symbol? template)
+ (if (and (not (memq template free))
+ (let ((probe (assq template env)))
+ (and probe (>= (cdr probe) dim))))
+ (cons template free)
+ free))
+ ((segment-template? template)
+ (free-meta-variables (car template)
+ dim env
+ (free-meta-variables (cddr template)
+ dim env free)))
+ ((pair? template)
+ (free-meta-variables (car template)
+ dim env
+ (free-meta-variables (cdr template)
+ dim env free)))
+ ((vector? template)
+ (free-meta-variables (vector->list template) dim env free))
+ (else free)))
+
+ (define (segment-pattern? pattern)
+ (and (segment-template? pattern)
+ (or (null? (cddr pattern))
+ (##sys#syntax-error-hook "segment matching not implemented" pattern))))
+
+ (define (segment-template? pattern)
+ (and (pair? pattern)
+ (pair? (cdr pattern))
+ (ellipsis? (cadr pattern))))
+
+ ;; Count the number of `...'s in PATTERN.
+
+ (define (segment-depth pattern)
+ (if (segment-template? pattern)
+ (+ 1 (segment-depth (cdr pattern)))
+ 0))
+
+ ;; Get whatever is after the `...'s in PATTERN.
+
+ (define (segment-tail pattern)
+ (let loop ((pattern (cdr pattern)))
+ (if (and (pair? pattern)
+ (ellipsis? (car pattern)))
+ (loop (cdr pattern))
+ pattern)))
+
+ (make-transformer rules))
diff --git a/tcp.import.scm b/tcp.import.scm
new file mode 100644
index 00000000..60fde47a
--- /dev/null
+++ b/tcp.import.scm
@@ -0,0 +1,44 @@
+;;;; tcp.import.scm - import library for "tcp" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'tcp
+ '(tcp-abandon-port
+ tcp-accept
+ tcp-accept-ready?
+ tcp-accept-timeout
+ tcp-addresses
+ tcp-buffer-size
+ tcp-close
+ tcp-connect
+ tcp-connect-timeout
+ tcp-listen
+ tcp-listener-fileno
+ tcp-listener-port
+ tcp-listener?
+ tcp-port-numbers
+ tcp-read-timeout
+ tcp-write-timeout))
diff --git a/tcp.scm b/tcp.scm
new file mode 100644
index 00000000..72087ef5
--- /dev/null
+++ b/tcp.scm
@@ -0,0 +1,650 @@
+;;;; tcp.scm - Networking stuff
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit tcp)
+ (uses extras scheduler)
+ (usual-integrations)
+ (fixnum-arithmetic)
+ (no-bound-checks)
+ (export tcp-close tcp-listen tcp-connect tcp-accept tcp-accept-ready? ##sys#tcp-port->fileno tcp-listener? tcp-addresses
+ tcp-abandon-port tcp-listener-port tcp-listener-fileno tcp-port-numbers tcp-buffer-size
+ tcp-read-timeout tcp-write-timeout tcp-accept-timeout tcp-connect-timeout)
+ (no-procedure-checks-for-usual-bindings)
+ (bound-to-procedure
+ ##net#socket ##net#bind ##net#connect ##net#listen ##net#accept make-parameter ##sys#string-append ##sys#tcp-port->fileno
+ ##sys#check-port ##sys#port-data ##sys#thread-block-for-i/o! make-string make-input-port make-output-port ##sys#substring
+ substring ##sys#make-c-string ##sys#schedule ##sys#set-port-data!
+ ##net#close ##net#recv ##net#send ##net#select ##net#select-write ##net#gethostaddr ##net#io-ports ##sys#update-errno
+ ##sys#error ##sys#signal-hook ##net#getservbyname ##net#parse-host ##net#fresh-addr
+ ##net#bind-socket ##net#shutdown)
+ (foreign-declare #<<EOF
+#include <errno.h>
+#ifdef _WIN32
+# if _MSC_VER > 1300
+# include <winsock2.h>
+# include <ws2tcpip.h>
+# else
+# include <winsock.h>
+# endif
+/* Beware: winsock2.h must come BEFORE windows.h */
+# define socklen_t int
+static WSADATA wsa;
+# define fcntl(a, b, c) 0
+# define EWOULDBLOCK 0
+# define EINPROGRESS 0
+# define typecorrect_getsockopt(socket, level, optname, optval, optlen) \
+ getsockopt(socket, level, optname, (char *)optval, optlen)
+#else
+# include <fcntl.h>
+# include <sys/types.h>
+# include <sys/socket.h>
+# include <sys/time.h>
+# include <netinet/in.h>
+# include <unistd.h>
+# include <netdb.h>
+# include <signal.h>
+# define closesocket close
+# define INVALID_SOCKET -1
+# define typecorrect_getsockopt getsockopt
+#endif
+
+#ifndef SD_RECEIVE
+# define SD_RECEIVE 0
+# define SD_SEND 1
+#endif
+
+#ifdef ECOS
+#include <sys/sockio.h>
+#endif
+
+static char addr_buffer[ 20 ];
+EOF
+) )
+
+(include "unsafe-declarations.scm")
+
+(register-feature! 'tcp)
+
+(define-foreign-variable errno int "errno")
+(define-foreign-variable strerror c-string "strerror(errno)")
+
+(define-foreign-type sockaddr* (pointer "struct sockaddr"))
+(define-foreign-type sockaddr_in* (pointer "struct sockaddr_in"))
+
+(define-foreign-variable _af_inet int "AF_INET")
+(define-foreign-variable _sock_stream int "SOCK_STREAM")
+(define-foreign-variable _sock_dgram int "SOCK_DGRAM")
+(define-foreign-variable _sockaddr_size int "sizeof(struct sockaddr)")
+(define-foreign-variable _sockaddr_in_size int "sizeof(struct sockaddr_in)")
+(define-foreign-variable _sd_receive int "SD_RECEIVE")
+(define-foreign-variable _sd_send int "SD_SEND")
+(define-foreign-variable _ipproto_tcp int "IPPROTO_TCP")
+(define-foreign-variable _invalid_socket int "INVALID_SOCKET")
+(define-foreign-variable _ewouldblock int "EWOULDBLOCK")
+(define-foreign-variable _einprogress int "EINPROGRESS")
+
+(define ##net#socket (foreign-lambda int "socket" int int int))
+(define ##net#bind (foreign-lambda int "bind" int scheme-pointer int))
+(define ##net#listen (foreign-lambda int "listen" int int))
+(define ##net#accept (foreign-lambda int "accept" int c-pointer c-pointer))
+(define ##net#close (foreign-lambda int "closesocket" int))
+(define ##net#recv (foreign-lambda int "recv" int scheme-pointer int int))
+(define ##net#shutdown (foreign-lambda int "shutdown" int int))
+(define ##net#connect (foreign-lambda int "connect" int scheme-pointer int))
+
+(define ##net#send
+ (foreign-lambda* int ((int s) (scheme-pointer msg) (int offset) (int len) (int flags))
+ "return(send(s, (char *)msg+offset, len, flags));"))
+
+(define ##net#make-nonblocking
+ (foreign-lambda* bool ((int fd))
+ "int val = fcntl(fd, F_GETFL, 0);"
+ "if(val == -1) return(0);"
+ "return(fcntl(fd, F_SETFL, val | O_NONBLOCK) != -1);") )
+
+(define ##net#getsockname
+ (foreign-lambda* c-string ((int s))
+ "struct sockaddr_in sa;"
+ "unsigned char *ptr;"
+ "int len = sizeof(struct sockaddr_in);"
+ "if(getsockname(s, (struct sockaddr *)&sa, (socklen_t *)&len) != 0) return(NULL);"
+ "ptr = (unsigned char *)&sa.sin_addr;"
+ "sprintf(addr_buffer, \"%d.%d.%d.%d\", ptr[ 0 ], ptr[ 1 ], ptr[ 2 ], ptr[ 3 ]);"
+ "return(addr_buffer);") )
+
+(define ##net#getsockport
+ (foreign-lambda* int ((int s))
+ "struct sockaddr_in sa;"
+ "int len = sizeof(struct sockaddr_in);"
+ "if(getsockname(s, (struct sockaddr *)&sa, (socklen_t *)(&len)) != 0) return(-1);"
+ "else return(ntohs(sa.sin_port));") )
+
+(define ##net#getpeerport
+ (foreign-lambda* int ((int s))
+ "struct sockaddr_in sa;"
+ "int len = sizeof(struct sockaddr_in);"
+ "if(getpeername(s, (struct sockaddr *)&sa, (socklen_t *)(&len)) != 0) return(-1);"
+ "else return(ntohs(sa.sin_port));") )
+
+(define ##net#getpeername
+ (foreign-lambda* c-string ((int s))
+ "struct sockaddr_in sa;"
+ "unsigned char *ptr;"
+ "unsigned int len = sizeof(struct sockaddr_in);"
+ "if(getpeername(s, (struct sockaddr *)&sa, ((unsigned int *)&len)) != 0) return(NULL);"
+ "ptr = (unsigned char *)&sa.sin_addr;"
+ "sprintf(addr_buffer, \"%d.%d.%d.%d\", ptr[ 0 ], ptr[ 1 ], ptr[ 2 ], ptr[ 3 ]);"
+ "return(addr_buffer);") )
+
+(define ##net#startup
+ (foreign-lambda* bool () #<<EOF
+#ifdef _WIN32
+ return(WSAStartup(MAKEWORD(1, 1), &wsa) == 0);
+#else
+ signal(SIGPIPE, SIG_IGN);
+ return(1);
+#endif
+EOF
+) )
+
+(unless (##net#startup)
+ (##sys#signal-hook #:network-error "cannot initialize Winsock") )
+
+(define ##net#getservbyname
+ (foreign-lambda* int ((c-string serv) (c-string proto))
+ "struct servent *se;
+ if((se = getservbyname(serv, proto)) == NULL) return(0);
+ else return(ntohs(se->s_port));") )
+
+(define ##net#select
+ (foreign-lambda* int ((int fd))
+ "fd_set in;
+ struct timeval tm;
+ int rv;
+ FD_ZERO(&in);
+ FD_SET(fd, &in);
+ tm.tv_sec = tm.tv_usec = 0;
+ rv = select(fd + 1, &in, NULL, NULL, &tm);
+ if(rv > 0) { rv = FD_ISSET(fd, &in) ? 1 : 0; }
+ return(rv);") )
+
+(define ##net#select-write
+ (foreign-lambda* int ((int fd))
+ "fd_set out;
+ struct timeval tm;
+ int rv;
+ FD_ZERO(&out);
+ FD_SET(fd, &out);
+ tm.tv_sec = tm.tv_usec = 0;
+ rv = select(fd + 1, NULL, &out, NULL, &tm);
+ if(rv > 0) { rv = FD_ISSET(fd, &out) ? 1 : 0; }
+ return(rv);") )
+
+(define ##net#gethostaddr
+ (foreign-lambda* bool ((scheme-pointer saddr) (c-string host) (unsigned-short port))
+ "struct hostent *he = gethostbyname(host);"
+ "struct sockaddr_in *addr = (struct sockaddr_in *)saddr;"
+ "if(he == NULL) return(0);"
+ "memset(addr, 0, sizeof(struct sockaddr_in));"
+ "addr->sin_family = AF_INET;"
+ "addr->sin_port = htons((short)port);"
+ "addr->sin_addr = *((struct in_addr *)he->h_addr);"
+ "return(1);") )
+
+(define (yield)
+ (##sys#call-with-current-continuation
+ (lambda (return)
+ (let ((ct ##sys#current-thread))
+ (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
+ (##sys#schedule) ) ) ) )
+
+(define ##net#parse-host
+ (let ((substring substring))
+ (lambda (host proto)
+ (let ((len (##sys#size host)))
+ (let loop ((i 0))
+ (if (fx>= i len)
+ (values host #f)
+ (let ((c (##core#inline "C_subchar" host i)))
+ (if (char=? c #\:)
+ (values
+ (substring host (add1 i) len)
+ (let* ((s (substring host 0 i))
+ (p (##net#getservbyname s proto)) )
+ (when (eq? 0 p)
+ (##sys#update-errno)
+ (##sys#signal-hook
+ #:network-error 'tcp-connect (##sys#string-append "cannot compute port from service - " strerror)
+ s) )
+ p) )
+ (loop (fx+ i 1)) ) ) ) ) ) ) ) )
+
+(define ##net#fresh-addr
+ (foreign-lambda* void ((scheme-pointer saddr) (unsigned-short port))
+ "struct sockaddr_in *addr = (struct sockaddr_in *)saddr;"
+ "memset(addr, 0, sizeof(struct sockaddr_in));"
+ "addr->sin_family = AF_INET;"
+ "addr->sin_port = htons(port);"
+ "addr->sin_addr.s_addr = htonl(INADDR_ANY);") )
+
+(define (##net#bind-socket port style host)
+ (##sys#check-exact port)
+ (cond-expand
+ (unsafe)
+ (else
+ (when (or (fx< port 0) (fx>= port 65535))
+ (##sys#signal-hook #:domain-error 'tcp-listen "invalid port number" port) ) ) )
+ (let ((s (##net#socket _af_inet style 0)))
+ (when (eq? _invalid_socket s)
+ (##sys#update-errno)
+ (##sys#error "cannot create socket") )
+ ;; PLT makes this an optional arg to tcp-listen. Should we as well?
+ (when (eq? -1 ((foreign-lambda* int ((int socket))
+ "int yes = 1;
+ return(setsockopt(socket, SOL_SOCKET, SO_REUSEADDR, (const char *)&yes, sizeof(int)));")
+ s) )
+ (##sys#update-errno)
+ (##sys#signal-hook #:network-error 'tcp-listen (##sys#string-append "error while setting up socket - " strerror) s) )
+ (let ((addr (make-string _sockaddr_in_size)))
+ (if host
+ (unless (##net#gethostaddr addr host port)
+ (##sys#signal-hook #:network-error 'tcp-listen "getting listener host IP failed - " host port) )
+ (##net#fresh-addr addr port) )
+ (let ((b (##net#bind s addr _sockaddr_in_size)))
+ (when (eq? -1 b)
+ (##sys#update-errno)
+ (##sys#signal-hook #:network-error 'tcp-listen (##sys#string-append "cannot bind to socket - " strerror) s port) )
+ (values s addr) ) ) ) )
+
+(define-constant default-backlog 10)
+
+(define (tcp-listen port . more)
+ (let-optionals more ((w default-backlog) (host #f))
+ (let-values (((s addr) (##net#bind-socket port _sock_stream host)))
+ (##sys#check-exact w)
+ (let ((l (##net#listen s w)))
+ (when (eq? -1 l)
+ (##sys#update-errno)
+ (##sys#signal-hook #:network-error 'tcp-listen (##sys#string-append "cannot listen on socket - " strerror) s port) )
+ (##sys#make-structure 'tcp-listener s) ) ) ) )
+
+(define (tcp-listener? x)
+ (and (##core#inline "C_blockp" x)
+ (##sys#structure? x 'tcp-listener) ) )
+
+(define (tcp-close tcpl)
+ (##sys#check-structure tcpl 'tcp-listener)
+ (let ((s (##sys#slot tcpl 1)))
+ (when (fx= -1 (##net#close s))
+ (##sys#update-errno)
+ (##sys#signal-hook #:network-error 'tcp-close (##sys#string-append "cannot close TCP socket - " strerror) tcpl) ) ) )
+
+(define-constant +input-buffer-size+ 1024)
+(define-constant +output-chunk-size+ 8192)
+
+(define tcp-buffer-size (make-parameter #f))
+(define tcp-read-timeout)
+(define tcp-write-timeout)
+(define tcp-connect-timeout)
+(define tcp-accept-timeout)
+
+(let ()
+ (define ((check loc) x)
+ (when x (##sys#check-exact x loc))
+ x)
+ (define minute (* 60 1000))
+ (set! tcp-read-timeout (make-parameter minute (check 'tcp-read-timeout)))
+ (set! tcp-write-timeout (make-parameter minute (check 'tcp-write-timeout)))
+ (set! tcp-connect-timeout (make-parameter #f (check 'tcp-connect-timeout)))
+ (set! tcp-accept-timeout (make-parameter #f (check 'tcp-accept-timeout))) )
+
+(define ##net#io-ports
+ (let ((make-input-port make-input-port)
+ (make-output-port make-output-port)
+ (tbs tcp-buffer-size)
+ (make-string make-string) )
+ (lambda (fd)
+ (unless (##net#make-nonblocking fd)
+ (##sys#update-errno)
+ (##sys#signal-hook #:network-error (##sys#string-append "cannot create TCP ports - " strerror)) )
+ (let* ((buf (make-string +input-buffer-size+))
+ (data (vector fd #f #f buf 0))
+ (buflen 0)
+ (bufindex 0)
+ (iclosed #f)
+ (oclosed #f)
+ (outbufsize (tbs))
+ (outbuf (and outbufsize (fx> outbufsize 0) ""))
+ (tmr (tcp-read-timeout))
+ (tmw (tcp-write-timeout))
+ (read-input
+ (lambda ()
+ (let loop ()
+ (let ((n (##net#recv fd buf +input-buffer-size+ 0)))
+ (cond ((eq? -1 n)
+ (cond ((eq? errno _ewouldblock)
+ (when tmr
+ (##sys#thread-block-for-timeout!
+ ##sys#current-thread
+ (fx+ (##sys#fudge 16) tmr) ) )
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
+ (yield)
+ (when (##sys#slot ##sys#current-thread 13)
+ (##sys#signal-hook
+ #:network-error
+ "read operation timed out" fd) )
+ (loop) )
+ (else
+ (##sys#update-errno)
+ (##sys#signal-hook
+ #:network-error
+ (##sys#string-append "cannot read from socket - " strerror)
+ fd) ) ) )
+ (else
+ (set! buflen n)
+ (##sys#setislot data 4 n)
+ (set! bufindex 0) ) ) ) ) ) )
+ (in
+ (make-input-port
+ (lambda ()
+ (when (fx>= bufindex buflen)
+ (read-input))
+ (if (fx>= bufindex buflen)
+ #!eof
+ (let ((c (##core#inline "C_subchar" buf bufindex)))
+ (set! bufindex (fx+ bufindex 1))
+ c) ) )
+ (lambda ()
+ (or (fx< bufindex buflen)
+ (let ((f (##net#select fd)))
+ (when (eq? f -1)
+ (##sys#update-errno)
+ (##sys#signal-hook
+ #:network-error
+ (##sys#string-append "cannot check socket for input - " strerror)
+ fd) )
+ (eq? f 1) ) ) )
+ (lambda ()
+ (unless iclosed
+ (set! iclosed #t)
+ (unless (##sys#slot data 1) (##net#shutdown fd _sd_receive))
+ (when (and oclosed (eq? -1 (##net#close fd)))
+ (##sys#update-errno)
+ (##sys#signal-hook
+ #:network-error
+ (##sys#string-append "cannot close socket input port - " strerror)
+ fd) ) ) )
+ #f
+ (lambda (p n dest start) ; read-string!
+ (let loop ((n n) (m 0) (start start))
+ (cond ((eq? n 0) m)
+ ((fx< bufindex buflen)
+ (let* ((rest (fx- buflen bufindex))
+ (n2 (if (fx< n rest) n rest)))
+ (##core#inline "C_substring_copy" buf dest bufindex (fx+ bufindex n2) start)
+ (set! bufindex (fx+ bufindex n2))
+ (loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) )
+ (else
+ (read-input)
+ (if (eq? buflen 0)
+ m
+ (loop n m start) ) ) ) ) )
+ (lambda (p limit) ; read-line
+ (let loop ((str #f)
+ (limit (or limit (##sys#fudge 21))))
+ (cond ((fx< bufindex buflen)
+ (##sys#scan-buffer-line
+ buf
+ (fxmin buflen limit)
+ bufindex
+ (lambda (pos2 next)
+ (let* ((len (fx- pos2 bufindex))
+ (dest (##sys#make-string len)))
+ (##core#inline "C_substring_copy" buf dest bufindex pos2 0)
+ (set! bufindex next)
+ (cond ((eq? pos2 limit) ; no line-terminator, hit limit
+ (if str (##sys#string-append str dest) dest))
+ ((eq? pos2 next) ; no line-terminator, hit buflen
+ (read-input)
+ (if (fx>= bufindex buflen)
+ (or str "")
+ (loop (if str (##sys#string-append str dest) dest)
+ (fx- limit len)) ) )
+ (else
+ (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
+ (if str (##sys#string-append str dest) dest)) ) ) ) ) )
+ (else
+ (read-input)
+ (if (fx< bufindex buflen)
+ (loop str limit)
+ #!eof) ) ) ) ) ) )
+ (output
+ (lambda (s)
+ (let loop ((len (##sys#size s))
+ (offset 0))
+ (let* ((count (fxmin +output-chunk-size+ len))
+ (n (##net#send fd s offset count 0)) )
+ (cond ((eq? -1 n)
+ (cond ((eq? errno _ewouldblock)
+ (when tmw
+ (##sys#thread-block-for-timeout!
+ ##sys#current-thread
+ (fx+ (##sys#fudge 16) tmw) ) )
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
+ (yield)
+ (when (##sys#slot ##sys#current-thread 13)
+ (##sys#signal-hook
+ #:network-error
+ "write operation timed out" fd) )
+ (loop len offset) )
+ (else
+ (##sys#update-errno)
+ (##sys#signal-hook
+ #:network-error
+ (##sys#string-append "cannot write to socket - " strerror)
+ fd) ) ) )
+ ((fx< n len)
+ (loop (fx- len n) (fx+ offset n)) ) ) ) ) ) )
+ (out
+ (make-output-port
+ (if outbuf
+ (lambda (s)
+ (set! outbuf (##sys#string-append outbuf s))
+ (when (fx>= (##sys#size outbuf) outbufsize)
+ (output outbuf)
+ (set! outbuf "") ) )
+ (lambda (s)
+ (when (fx> (##sys#size s) 0)
+ (output s)) ) )
+ (lambda ()
+ (unless oclosed
+ (set! oclosed #t)
+ (when (and outbuf (fx> (##sys#size outbuf) 0))
+ (output outbuf)
+ (set! outbuf "") )
+ (unless (##sys#slot data 2) (##net#shutdown fd _sd_send))
+ (when (and iclosed (eq? -1 (##net#close fd)))
+ (##sys#update-errno)
+ (##sys#signal-hook
+ #:network-error (##sys#string-append "cannot close socket output port - " strerror) fd) ) ) )
+ (and outbuf
+ (lambda ()
+ (when (fx> (##sys#size outbuf) 0)
+ (output outbuf)
+ (set! outbuf "") ) ) ) ) ) )
+ (##sys#setslot in 3 "(tcp)")
+ (##sys#setslot out 3 "(tcp)")
+ (##sys#setslot in 7 'socket)
+ (##sys#setslot out 7 'socket)
+ (##sys#set-port-data! in data)
+ (##sys#set-port-data! out data)
+ (values in out) ) ) ) )
+
+(define (tcp-accept tcpl)
+ (##sys#check-structure tcpl 'tcp-listener)
+ (let ((fd (##sys#slot tcpl 1))
+ (tma (tcp-accept-timeout)))
+ (let loop ()
+ (if (eq? 1 (##net#select fd))
+ (let ((fd (##net#accept fd #f #f)))
+ (when (eq? -1 fd)
+ (##sys#update-errno)
+ (##sys#signal-hook
+ #:network-error 'tcp-accept (##sys#string-append "could not accept from listener - " strerror)
+ tcpl) )
+ (##net#io-ports fd) )
+ (begin
+ (when tma
+ (##sys#thread-block-for-timeout!
+ ##sys#current-thread
+ (fx+ (##sys#fudge 16) tma) ) )
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
+ (yield)
+ (when (##sys#slot ##sys#current-thread 13)
+ (##sys#signal-hook
+ #:network-error
+ 'tcp-accept
+ "accept operation timed out" fd) )
+ (loop) ) ) ) ) )
+
+(define (tcp-accept-ready? tcpl)
+ (##sys#check-structure tcpl 'tcp-listener 'tcp-accept-ready?)
+ (let ((f (##net#select (##sys#slot tcpl 1))))
+ (when (eq? -1 f)
+ (##sys#update-errno)
+ (##sys#signal-hook
+ #:network-error 'tcp-accept-ready? (##sys#string-append "cannot check socket for input - " strerror)
+ tcpl) )
+ (eq? 1 f) ) )
+
+(define get-socket-error
+ (foreign-lambda* int ((int socket))
+ "int err, optlen;"
+ "optlen = sizeof(err);"
+ "if (typecorrect_getsockopt(socket, SOL_SOCKET, SO_ERROR, &err, (socklen_t *)&optlen) == -1)"
+ "return(-1);"
+ "return(err);"))
+
+(define general-strerror (foreign-lambda c-string "strerror" int))
+
+(define (tcp-connect host . more)
+ (let ((port (optional more #f))
+ (tmc (tcp-connect-timeout)))
+ (##sys#check-string host)
+ (unless port
+ (set!-values (host port) (##net#parse-host host "tcp"))
+ (unless port (##sys#signal-hook #:network-error 'tcp-connect "no port specified" host)) )
+ (##sys#check-exact port)
+ (let ((addr (make-string _sockaddr_in_size))
+ (s (##net#socket _af_inet _sock_stream 0)) )
+ (define (fail)
+ (##net#close s)
+ (##sys#update-errno)
+ (##sys#signal-hook
+ #:network-error 'tcp-connect (##sys#string-append "cannot connect to socket - " strerror)
+ host port) )
+ (when (eq? -1 s)
+ (##sys#update-errno)
+ (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "cannot create socket - " strerror) host port) )
+ (unless (##net#gethostaddr addr host port)
+ (##sys#signal-hook #:network-error 'tcp-connect "cannot find host address" host) )
+ (unless (##net#make-nonblocking s)
+ (##sys#update-errno)
+ (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "fcntl() failed - " strerror)) )
+ (when (eq? -1 (##net#connect s addr _sockaddr_in_size))
+ (if (eq? errno _einprogress)
+ (let loop ()
+ (let ((f (##net#select-write s)))
+ (when (eq? f -1) (fail))
+ (unless (eq? f 1)
+ (when tmc
+ (##sys#thread-block-for-timeout!
+ ##sys#current-thread
+ (fx+ (##sys#fudge 16) tmc) ) )
+ (##sys#thread-block-for-i/o! ##sys#current-thread s #:all)
+ (yield)
+ (when (##sys#slot ##sys#current-thread 13)
+ (##sys#signal-hook
+ #:network-error
+ 'tcp-connect
+ "connect operation timed out" s) )
+ (loop) ) ) )
+ (fail) ) )
+ (let ((err (get-socket-error s)))
+ (cond ((= err -1)
+ (##net#close s)
+ (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "getsockopt() failed - " strerror)))
+ ((> err 0)
+ (##net#close s)
+ (##sys#signal-hook #:network-error 'tcp-connect (##sys#string-append "cannot create socket - " (general-strerror err))))))
+ (##net#io-ports s) ) ) )
+
+(define (##sys#tcp-port->fileno p)
+ (let ((data (##sys#port-data p)))
+ (if (vector? data) ; a meagre test, but better than nothing
+ (##sys#slot data 0)
+ (error '##sys#tcp-port->fileno "argument does not appear to be a TCP port" p))))
+
+(define (tcp-addresses p)
+ (##sys#check-port p 'tcp-addresses)
+ (let ((fd (##sys#tcp-port->fileno p)))
+ (values
+ (or (##net#getsockname fd)
+ (##sys#signal-hook #:network-error 'tcp-addresses (##sys#string-append "cannot compute local address - " strerror) p) )
+ (or (##net#getpeername fd)
+ (##sys#signal-hook #:network-error 'tcp-addresses (##sys#string-append "cannot compute remote address - " strerror) p) ) ) ) )
+
+(define (tcp-port-numbers p)
+ (##sys#check-port p 'tcp-port-numbers)
+ (let ((fd (##sys#tcp-port->fileno p)))
+ (values
+ (or (##net#getsockport fd)
+ (##sys#signal-hook #:network-error 'tcp-port-numbers (##sys#string-append "cannot compute local port - " strerror) p) )
+ (or (##net#getpeerport fd)
+ (##sys#signal-hook #:network-error 'tcp-port-numbers (##sys#string-append "cannot compute remote port - " strerror) p) ) ) ) )
+
+(define (tcp-listener-port tcpl)
+ (##sys#check-structure tcpl 'tcp-listener 'tcp-listener-port)
+ (let* ((fd (##sys#slot tcpl 1))
+ (port (##net#getsockport fd)) )
+ (when (eq? -1 port)
+ (##sys#signal-hook
+ #:network-error 'tcp-listener-port (##sys#string-append "cannot obtain listener port - " strerror)
+ tcpl fd) )
+ port) )
+
+(define (tcp-abandon-port p)
+ (##sys#check-port p 'tcp-abandon-port)
+ (##sys#setislot
+ (##sys#port-data p)
+ (if (##sys#slot p 1) 2 1)
+ #t) )
+
+(define (tcp-listener-fileno l)
+ (##sys#check-structure l 'tcp-listener 'tcp-listener-fileno)
+ (##sys#slot l 1) )
diff --git a/tests/apply-test.scm b/tests/apply-test.scm
new file mode 100644
index 00000000..d05356ba
--- /dev/null
+++ b/tests/apply-test.scm
@@ -0,0 +1,14 @@
+(require-extension srfi-1)
+
+(define manyargs (feature? 'manyargs))
+
+(when manyargs (print "many arguments supported."))
+
+(define (foo . args)
+ (when (pair? args)
+ (assert (= (length args) (last args)))))
+
+(let ((max (if manyargs 500 100)))
+ (do ((i 0 (add1 i)))
+ ((>= i max))
+ (apply foo (iota i 1))))
diff --git a/tests/bootstrap.sh b/tests/bootstrap.sh
new file mode 100644
index 00000000..84019965
--- /dev/null
+++ b/tests/bootstrap.sh
@@ -0,0 +1,20 @@
+# bootstrap.sh
+
+set -e
+
+echo "======================================== bootstrapping ..."
+darcs dist
+rm -fr /tmp/chicken
+cp chicken.tar.gz /tmp
+pushd /tmp
+tar xfz chicken.tar.gz
+cd chicken
+sh autogen.sh
+./configure --disable-shared --prefix=`pwd`/chicken-install
+installed_chicken=`which chicken`
+make BOOTSTRAP_PATH=`dirname $installed_chicken`
+touch *.scm
+make
+rm -fr /tmp/chicken
+
+echo "======================================== done."
diff --git a/tests/compiler-syntax-tests.scm b/tests/compiler-syntax-tests.scm
new file mode 100644
index 00000000..36d15b70
--- /dev/null
+++ b/tests/compiler-syntax-tests.scm
@@ -0,0 +1,31 @@
+(define (foo) 1)
+
+(assert (= 1 (foo)))
+
+(define-compiler-syntax foo
+ (syntax-rules ()
+ ((_ x) 2) ) )
+
+(assert (= 2 (foo 42)))
+(assert (= 1 (foo)))
+
+(let-compiler-syntax ((foo (syntax-rules () ((_ x) 3))))
+ (assert (= 3 (foo 42))))
+
+(assert (= 2 (foo 42)))
+
+(module m1 (bar)
+ (import (prefix scheme s:) chicken)
+ (define-compiler-syntax s:+
+ (syntax-rules ()
+ ((_ x y) (s:- x y))))
+ (define-compiler-syntax bar
+ (syntax-rules ()
+ ((_ x y) "oink!")))
+ (s:define (bar x) (s:+ x 1)) )
+
+(module m2 ()
+ (import scheme chicken (prefix m1 m-))
+ (print (m-bar 10))
+ (print (m-bar 10 23))
+ (print (+ 4 3)))
diff --git a/tests/compiler-tests-2.scm b/tests/compiler-tests-2.scm
new file mode 100644
index 00000000..cd4a567b
--- /dev/null
+++ b/tests/compiler-tests-2.scm
@@ -0,0 +1,52 @@
+;;; compiler-tests-2.scm - tests for particular compiler optimizations
+
+
+;;; rev. 12113 - lambda-lifting breakage, because lambda-bound variables
+; were incorrectly marked as global (analysis didn't walk
+; "lambda" nodes correctly, due t incorrect assumption
+; that "lambda" doesn't occur. Major stupidity.
+; Test case by Joerg Wittenberger
+
+(define (plus1 a)
+ (define (plus b)
+ (+ a b))
+ (plus 1))
+
+(assert (= 2 (plus1 1)))
+
+(define (len lst)
+ (define (len n)
+ (if (pair? lst)
+ (begin
+ (set! lst (cdr lst))
+ (len (+ n 1)))
+ n))
+ (len 0))
+
+(assert (= 3 (len '(1 2 3))))
+
+
+;;; compiler-syntax for map/for-each must be careful when the
+; operator may have side-effects (currently only lambda exprs and symbols
+; are allowed)
+
+(let ((x #f))
+ (define (f1 x) (print* x " "))
+ (map f1 '(1 2 3))
+ (newline)
+ (map (begin (assert (not x))
+ (set! x #t)
+ f1)
+ '(1 2 3))
+ (map (lambda (x) (print* ":" x)) '(1 2 3))
+ (newline))
+
+(let ((x #f))
+ (define (f1 x) (print* x " "))
+ (let-syntax ((f1 (syntax-rules ()
+ ((_ y)
+ (begin
+ (assert (not x))
+ (set! x #t)
+ f1)))))
+ (for-each f1 '(1 2 3))))
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
new file mode 100644
index 00000000..79de1eb3
--- /dev/null
+++ b/tests/compiler-tests.scm
@@ -0,0 +1,85 @@
+;;;; compiler-tests.scm
+
+
+(module foo (bar)
+ (import scheme chicken)
+ (declare (hide bar))
+ (define (bar x) (+ x 1)))
+
+(assert (not (##sys#symbol-has-toplevel-binding? 'foo#bar)))
+
+
+;;; rev. 12104 (reported by Joerg Wittenberger)
+;
+; - canonicalization of assignment to location didn't walk expansion recursively
+
+(define test-location
+ (let-location
+ ((again bool #f))
+ (lambda ()
+ ((foreign-lambda*
+ int
+ (((c-pointer bool) again))
+ "*again=1; return(1);")
+ (location again))
+ again)))
+
+(print (test-location))
+
+
+;;; rev. 12188 (reported by Jörg Wittenberger)
+;
+; - generated init-assignment refers to alias, but alias isn't seen later)
+
+(module
+ x
+ (bar)
+ (import scheme chicken foreign)
+
+ (define (bar n)
+ (let-location
+ ((off integer 0))
+ (lambda () ((foreign-lambda*
+ void
+ (((c-pointer integer) i))
+ "(*i)++;")
+ (location off)) off)))
+)
+
+(import x)
+(bar 42)
+
+;;; rev. 14574 (reported by Peter Bex)
+;
+; - type specifiers in foreign-lambda in macros are incorrectly renamed
+; - variable names and type specifiers in foreign-lambda* and
+; foreign-primitive in macros are incorrectly renamed
+
+(let-syntax ((strlen-macro
+ (syntax-rules ()
+ ((strlen-macro arg)
+ (print ((foreign-lambda int strlen c-string) arg)))))
+ (strlen-macro*
+ (syntax-rules ()
+ ((strlen-macro* arg)
+ (print ((foreign-lambda* int ((c-string str))
+ "C_return(strlen(str));") arg)))))
+ (strlen-safe-macro
+ (syntax-rules ()
+ ((strlen-safe-macro arg)
+ (print ((foreign-safe-lambda int strlen c-string) arg)))))
+ (strlen-safe-macro*
+ (syntax-rules ()
+ ((strlen-safe-macro* arg)
+ (print ((foreign-safe-lambda* int ((c-string str))
+ "C_return(strlen(str));") arg)))))
+ (strlen-primitive-macro
+ (syntax-rules ()
+ ((strlen-primitive-macro* arg)
+ (print ((foreign-primitive int ((c-string str))
+ "C_return(strlen(str));") arg))))))
+ (strlen-macro "hello, world")
+ (strlen-macro* "hello, world")
+ (strlen-safe-macro "hello, world")
+ (strlen-safe-macro* "hello, world")
+ (strlen-primitive-macro "hello, world"))
diff --git a/tests/dirty-macros.scm b/tests/dirty-macros.scm
new file mode 100644
index 00000000..80fd6556
--- /dev/null
+++ b/tests/dirty-macros.scm
@@ -0,0 +1,1136 @@
+; How to write dirty R5RS macros
+; http://groups.google.com/groups?selm=87oflzcdwt.fsf%40radish.petrofsky.org
+; How to write seemingly unhygienic macros using syntax-rules
+; Date: 2001-11-19 01:23:33 PST
+;
+; $Id: dirty-macros.scm,v 1.10 2003/08/16 02:13:32 oleg Exp oleg $
+
+; Extract a colored identifier from a form
+; extract? SYMB BODY CONT-T CONT-F
+; BODY is a form that may contain an occurence of an identifier that
+; refers to the same binding occurrence as SYMB, perhaps with a different
+; color. CONT-T and CONT-F are forms of the shape (K-HEAD K-IDL . K-ARGS)
+; where K-IDL are K-ARGS are lists.
+; If the extract? macro finds the identifier in question, it expands into
+; CONT-T, to be more precise, into
+; (K-HEAD (extr-id . K-IDL) . K-ARGS)
+; where extr-id is the extracted colored identifier. If the identifier
+; SYMB does not occur in BODY at all, the extract macro expands into CONT-F,
+; to be more precise,
+; (K-HEAD (SYMB . K-IDL) . K-ARGS)
+
+(define-syntax m-symbol?
+ (syntax-rules ()
+ ((_ maybe-symbol kt kf)
+ (letrec-syntax
+ ((ok
+ (syntax-rules ()
+ ((_) kt)))
+ (test
+ (syntax-rules ()
+ ((_ maybe-symbol) (ok))
+ ((_ x) kf))))
+ (test abracadabra)))))
+
+(define-syntax m-symb-equal?
+ (syntax-rules ()
+ ((_ symb b kt kf)
+ (let-syntax
+ ((symb (syntax-rules ()
+ ((_) kf)))
+ (ok (syntax-rules ()
+ ((_) kt))))
+ (let-syntax
+ ((test (syntax-rules ()
+ ((_ b) (symb))
+ ((_ x) kf))))
+ (test ok))))))
+
+(define-syntax extract?
+ (syntax-rules ()
+ ((_ symb body _cont-t _cont-f)
+ (letrec-syntax
+ ((lp
+ (syntax-rules (symb)
+ ((_ d symb stack (cont-head symb-l . cont-args) cont-f)
+ (cont-head (d . symb-l) . cont-args)) ; symb has occurred
+ ((_ d (x . y) stack . rest) ; if body is a composite form,
+ (lp x x (y . stack) . rest)) ; look inside
+ ((_ d1 d2 () cont-t (cont-head symb-l . cont-args))
+ (cont-head (symb . symb-l) . cont-args)) ; symb does not occur
+ ((_ d1 d2 (x . y) . rest)
+ (lp x x y . rest)))))
+ (lp body body () _cont-t _cont-f)))))
+
+; (define-syntax extract?
+; (syntax-rules ()
+; ((_ symb body _cont-t _cont-f)
+; (letrec-syntax
+; ((tr
+; (syntax-rules ()
+; ((_ d (x . y) tail . rest) ; if body is a composite form,
+; (tr x x (y . tail) . rest)) ; look inside
+; ((_ x y () (cont-head symb-l . cont-args)
+; (cont-headf symb-lf . cont-argsf))
+; (m-symb-equal? symb y
+; (cont-head (x . symb-l) . cont-args) ; symb has occurred
+; (cont-headf (symb . symb-lf) . cont-argsf)));symb does not occur
+; ((_ d1 d2 (x . y) (cont-head symb-l . cont-args) cont-f)
+; (m-symb-equal? symb d2
+; (cont-head (d1 . symb-l) . cont-args) ; symb has occurred
+; (tr x x y (cont-head symb-l . cont-args) cont-f))))))
+; (tr body body () _cont-t _cont-f)))))
+
+; Extract a colored identifier from a form
+; extract SYMB BODY CONT
+; BODY is a form that may contain an occurence of an identifier that
+; refers to the same binding occurrence as SYMB, perhaps with a different
+; color. CONT is a form of the shape (K-HEAD K-IDL . K-ARGS)
+; where K-IDL are K-ARGS are S-expressions representing lists or the
+; empty list.
+; The extract macro expands into
+; (K-HEAD (extr-id . K-IDL) . K-ARGS)
+; where extr-id is the extracted colored identifier. If symbol SYMB does
+; not occur in BODY at all, extr-id is identical to SYMB.
+
+
+(define-syntax extract
+ (syntax-rules ()
+ ((_ symb body cont)
+ (extract? symb body cont cont))))
+
+; Extract several colored identifiers from a form
+; extract* SYMB-L BODY CONT
+; where SYMB-L is the list of symbols to extract, and BODY and CONT
+; has the same meaning as in extract, see above.
+;
+; The extract* macro expands into
+; (K-HEAD (extr-id-l . K-IDL) . K-ARGS)
+; where extr-id-l is the list of extracted colored identifiers. The extraction
+; itself is performed by the macro extract.
+
+(define-syntax extract*
+ (syntax-rules ()
+ ((_ (symb) body cont) ; only one symbol: use extract to do the job
+ (extract symb body cont))
+ ((_ _symbs _body _cont)
+ (letrec-syntax
+ ((ex-aux ; extract symbol-by-symbol
+ (syntax-rules ()
+ ((_ found-symbs () body cont)
+ (reverse () found-symbs cont))
+ ((_ found-symbs (symb . symb-others) body cont)
+ (extract symb body
+ (ex-aux found-symbs symb-others body cont)))
+ ))
+ (reverse ; reverse the list of extracted symbols
+ (syntax-rules () ; to match the order of SYMB-L
+ ((_ res () (cont-head () . cont-args))
+ (cont-head res . cont-args))
+ ((_ res (x . tail) cont)
+ (reverse (x . res) tail cont)))))
+ (ex-aux () _symbs _body _cont)))))
+
+; Writing weakly referentially opaque macros
+
+; A binding-capturing macro with an explicit specification
+; of the captured variable
+(define-syntax m1-i
+ (syntax-rules ()
+ ((_ i val body) (let ((i val)) body))))
+
+(display
+ (m1-i i 10 (* 1 i)))
+(newline) ;==> 10
+
+; A dirty macro m1 that extracts i from its argument and expands
+; into an invocation of m1-i:
+
+(define-syntax m1-dirty-v1
+ (syntax-rules ()
+ ((_ _val _body)
+ (let-syntax
+ ((cont
+ (syntax-rules ()
+ ((_ (symb) val body) (let ((symb val)) body) ))))
+ (extract i _body (cont () _val _body))))))
+
+(display
+ (m1-dirty-v1 10 (* 1 i))
+)
+(newline)
+
+(display
+ (m1-dirty-v1 10
+ (m1-dirty-v1 20 (* 1 i)))
+)
+(newline)
+
+
+; A macro that re-defines itself in its expansion
+; m1-dirty-v2 val body
+; expands into
+; (let ((i val)) body)
+; and also re-defines itself in the scope of body.
+
+(define-syntax m1-dirty-v2
+ (syntax-rules ()
+ ((_ _val _body)
+ (letrec-syntax
+ ((doit ; it's the continuation from extract*
+ (syntax-rules () ; myself-symb i-symb are colored ids extracted
+ ((_ (myself-symb i-symb) val body) ; from the 'body'
+ (let ((i-symb val)) ; first bind the symbol i
+ (letrec-syntax ; now re-define oneself
+ ((myself-symb
+ (syntax-rules ()
+ ((_ val__ body__)
+ (extract* (myself-symb i-symb) body__
+ (doit () val__ body__))))))
+ body))))))
+ (extract* (m1-dirty-v2 i) _body
+ (doit () _val _body))))))
+
+(display "m1-dirty-v2")
+(newline)
+(display
+ (m1-dirty-v2 10 (* 1 i))
+)
+(newline)
+; => 10
+
+(display
+ (m1-dirty-v2 10
+ (m1-dirty-v2 20
+ (m1-dirty-v2 30 (* 1 i))))
+)
+(newline)
+
+(display
+ (let ((i 1))
+ (m1-dirty-v2 10 (* 1 i)))
+)
+(newline)
+; => 1
+
+; A self-perpetuating smearing let
+; (mylet ((var init)) body)
+; expands into
+; (let ((var init)) body')
+; where body' is body wrapped into redefinitions of mylet
+; and a macro m1-dirty-v3
+
+; This macro is closed (no free variables)
+(define-syntax dirty-m-gen
+ (syntax-rules ()
+ ((_ name let-name _symb_ _body_)
+ (let-syntax
+ ((name
+ (syntax-rules ()
+ ((_ _val _body)
+ (let-syntax
+ ((cont
+ (syntax-rules ()
+ ((_ (symb) val body) (let ((symb val)) body) ))))
+ (extract _symb_ _body (cont () _val _body)))))))
+ _body_))))
+
+; (define-syntax mylet
+; (syntax-rules ()
+; ((_ ((_var _init)) _body)
+; (letrec-syntax
+; ((doit ; it's the continuation from extract*
+; (syntax-rules () ; myself-symb etc. are extr. colored ids extracted
+; ((_ (myself-symb dirty-m-symb i-symb) ((var init)) body)
+; (let ((var init)) ; first do the binding
+; (letrec-syntax ; now re-define oneself
+; ((myself-symb
+; (syntax-rules ()
+; ((_ ((var__ init__)) body__)
+; (extract* (myself-symb dirty-m-symb i-symb)
+; (var__ body__)
+; (doit () ((var__ init__)) body__))))))
+; (dirty-m-gen ; re-generate the dirty macro
+; dirty-m-symb myself-symb i-symb
+; body)))))))
+; (extract* (mylet m1-dirty-v3 i) (_var _body)
+; (doit () ((_var _init)) _body))))))
+
+; (letrec-syntax
+; ((ex
+; (syntax-rules ()
+; ((_ (mylet-symb mm-symb foo-symb) ((var init)) body)
+; (let ((var init))
+; (make-mm mm-symb foo-symb
+; (letrec-syntax
+; ((mylet-symb
+; (syntax-rules ()
+; ((_ ((var_ init_)) body_)
+; (extract* (mylet-symb mm-symb foo-symb) (var_ body_)
+; (ex () ((var_ init_)) body_))))))
+; body)))
+; ))))
+; (extract* (mylet mm foo) (_var _body)
+; (ex () ((_var _init)) _body))))))
+
+; (display "m1-dirty-v3")
+; (newline)
+; (display
+; (mylet ((i 1))
+; (m1-dirty-v3 10 (* 1 i)))
+; )
+; (newline)
+
+; (display
+; (mylet ((i 1))
+; (mylet ((i 10))
+; (m1-dirty-v3 20 (* 1 i))))
+; )
+; (newline)
+
+; (display
+; (mylet ((i 1))
+; (m1-dirty-v3 10
+; (m1-dirty-v3 20 (* 1 i))))
+; )
+; (newline)
+
+
+; A macro that generates a dirty macro:
+; m1-dirty BODY
+; expands into a definition of a macro
+; NAME BODY
+; which in turn expands into (let ((SYMB 10)) BODY)
+; such that the binding captures any free occurences of SYMB in BODY.
+
+; (define-syntax m1-dirty
+; (syntax-rules ()
+; ((_ _symb _body)
+; (let-syntax
+; ((doit
+; (syntax-rules ()
+; ((_ (symb) val body)
+; (let ((symb val)) body)))))
+; (extract _symb _body (doit () 10 _body))))))
+
+; Macro: make-mm NAME SYMB BODY
+; In the scope of BODY, define a macro NAME that expands into a symbol SYMB
+
+(define-syntax make-mm
+ (syntax-rules ()
+ ((_ name symb body)
+ (let-syntax
+ ((name
+ (syntax-rules ()
+ ((_) symb))))
+ body))))
+
+; (define-syntax mylet
+; (syntax-rules (foo)
+; ((_ ((var init)) body)
+; (extract foo (var)
+; (make-mm-in ((var init)) body)))))
+
+; (mylet ((var init)) body)
+; expands into
+; (let ((var init)) body')
+; where body' is the body wrapped in the re-definitions of mylet and macro mm.
+
+(define-syntax mylet
+ (syntax-rules ()
+ ((_ ((_var _init)) _body)
+ (letrec-syntax
+ ((doit ; The continuation from extract*
+ (syntax-rules () ; mylet-symb, etc. are extracted from body
+ ((_ (mylet-symb mm-symb foo-symb) ((var init)) body)
+ (let ((var init)) ; bind the 'var' first
+ (make-mm mm-symb foo-symb ; now re-generate the macro mm
+ (letrec-syntax
+ ((mylet-symb ; and re-define myself
+ (syntax-rules ()
+ ((_ ((var_ init_)) body_)
+ (extract* (mylet-symb mm-symb foo-symb) (var_ body_)
+ (doit () ((var_ init_)) body_))))))
+ body)))
+ ))))
+ (extract* (mylet mm foo) (_var _body)
+ (doit () ((_var _init)) _body))))))
+
+(display "mylet")
+(newline)
+(define foo 1)
+(display
+ (mylet ((x 1)) (list (mm) x))
+)
+(newline)
+
+(display
+ (mylet ((foo 2)) (list (mm) foo))
+)
+(newline)
+
+; ;(let ((foo 3)) (mylet ((foo 4)) (list foo (mm))))
+;(mylet ((foo 2)) (mylet ((foo 3)) (list foo (mm))))
+
+(display
+ (mylet ((foo 3)) (mylet ((foo 4)) (mylet ((foo 5)) (list foo (mm)))))
+)
+(newline)
+
+(display
+ (mylet ((foo 3))
+ (mylet ((thunk (lambda () (mm))))
+ (mylet ((foo 4)) (list foo (mm) (thunk)))))
+)
+(newline)
+
+; The following are definitions of let, let* and letrec, straight out of R5RS.
+; The only difference is that the definitions use custom-bound
+; let, let*, letrec and lambda identifiers, which we explicitly pass
+; to the macros in the first argument.
+
+(define-syntax glet ; let, straight out of R5RS
+ (syntax-rules ()
+ ((_ (let let* letrec lambda) ((name val) ...) body1 body2 ...)
+ ((lambda (name ...) body1 body2 ...) val ...))
+ ((_ (let let* letrec lambda) tag ((name val) ...) body1 body2 ...)
+ ((letrec ((tag
+ (lambda (name ...) body1 body2 ...))) tag) val ...))))
+
+(define-syntax glet* ; let*, straight out of R5RS
+ (syntax-rules ()
+ ((_ mynames () body1 body2 ...)
+ (let () body1 body2 ...))
+ ((_ (let let* letrec lambda)
+ ((name1 val1) (name2 val2) ...) body1 body2 ...)
+ (let ((name1 val1)) (let* ((name2 val2) ...) body1 body2 ...)))))
+
+; A shorter implementations of letrec, see
+; "Re: Widespread bug (arguably) in letrec when an initializer returns twice"
+; comp.lang.scheme, 2001-05-21 10:30:34 PST and 2001-05-21 14:56:49 PST
+; http://groups.google.com/groups?selm=7eb8ac3e.0105210930.21542605%40posting.google.com
+; http://groups.google.com/groups?selm=87ae468j7x.fsf%40app.dial.idiom.com
+
+(define-syntax gletrec
+ (syntax-rules ()
+ ((_ (mlet let* letrec lambda) ((var init) ...) . body)
+ (mlet ((var 'undefined) ...)
+ (let ((temp (list init ...))) ; the native let will do fine here
+ (begin (begin (set! var (car temp)) (set! temp (cdr temp))) ...
+ (let () . body)))))))
+
+; This macro defiles its body
+; It re-defines all the let-forms and the lambda, and defines
+; a non-hygienic macro 'mm'. Whenever any binding is introduced,
+; the let-forms, the lambdas and 'mm' are redefined.
+; The redefined lambda acts as if it were infected by a virus, which
+; keeps spreading within lambda's body to infect other lambda's there.
+
+(define-syntax defile
+ (syntax-rules ()
+ ((_ dbody)
+ (letrec-syntax
+ ((do-defile
+ (syntax-rules () ; all the shadowed symbols
+ ((_ (let-symb let*-symb letrec-symb lambda-symb mm-symb foo-symb)
+ body-to-defile)
+ (letrec-syntax
+ ((let-symb ; R5RS definition of let
+ (syntax-rules ()
+ ((_ . args)
+ (glet (let-symb let*-symb letrec-symb lambda-symb)
+ . args))))
+
+ (let*-symb ; Redefinition of let*
+ (syntax-rules ()
+ ((_ . args)
+ (glet* (let-symb let*-symb letrec-symb lambda-symb)
+ . args))))
+
+ (letrec-symb ; Redefinition of letrec
+ (syntax-rules ()
+ ((_ . args)
+ (gletrec (let-symb let*-symb letrec-symb lambda-symb)
+ . args))))
+
+ (lambda-symb ; re-defined, infected lambda
+ (syntax-rules ()
+ ((_ _vars _body)
+ (letrec-syntax
+ ((doit
+ (syntax-rules ()
+ ((_ (mylet-symb mylet*-symb myletrec-symb
+ mylambda-symb mymm-symb
+ myfoo-symb) vars body)
+ (lambda-native vars
+ (make-mm mymm-symb myfoo-symb
+ (do-defile ; proliferate in the body
+ (mylet-symb mylet*-symb myletrec-symb
+ mylambda-symb
+ mymm-symb myfoo-symb)
+ body))))))
+ (proliferate
+ (syntax-rules ()
+ ((_ dummy __vars __body)
+ (extract* (let-symb let*-symb
+ letrec-symb lambda-symb
+ mm-symb foo-symb)
+ (__vars __body)
+ (doit () __vars __body)))))
+ (stop-infection
+ (syntax-rules ()
+ ((_ dummy __vars __body)
+ (lambda-native __vars __body))))
+ )
+ (extract? mm-symb _vars
+ ; true-continuation
+ (stop-infection () _vars _body)
+ ; false-cont
+ (proliferate () _vars _body))
+ ))))
+
+ (lambda-native ; capture the native lambda
+ (syntax-rules ()
+ ((_ . args) (lambda . args))))
+ )
+
+ body-to-defile)))))
+
+ (extract* (let let* letrec lambda mm foo) dbody
+ (do-defile () dbody))
+ ))))
+
+
+;(mylet ((foo 2)) (mylet ((x 3)) (mylet ((foo 4)) (list (mm) foo))))
+(display "defile")
+(display "now.\n" (current-error-port))
+(newline)
+(defile
+ (display
+ (let ((foo 2)) (list (mm) foo))
+ )
+)
+(newline)
+; ==> (2 2)
+
+(defile
+ (display
+ (let ((foo 2)) (let ((foo 3)) (let ((foo 4)) (list (mm) foo))))
+ )
+)
+(newline)
+; ==> (4 4)
+
+(defile
+ (display
+ (let ((foo 2))
+ (let ((foo 3) (bar (list (mm) foo)))
+ (list foo (mm) bar)))
+ )
+)
+(newline)
+; ==> (3 3 (2 2))
+
+(defile
+ (display
+ (let ((foo 2))
+ (list
+ ((letrec ((bar (lambda () (list foo (mm))))
+ (foo 3))
+ bar))
+ foo (mm)))))
+(newline)
+;==> ((3 3) 2 2)
+
+(defile
+ (display
+ (let ((foo 2))
+ (let foo ((flag #t) (lst (list foo (mm))))
+ (if flag ((mm) #f (list lst lst)) lst)))))
+(newline)
+; ==> ((2 2) (2 2))
+
+(defile
+ (display
+ (let* ((foo 2)
+ (i 3)
+ (foo 4)
+ (ft (lambda () (mm))) ; will capture binding of foo to 4
+ (foo 5)
+ (ft1 (lambda (foo) (mm))) ; will capture the arg of ft1
+ (foo 6))
+ (list foo (mm) (ft) (ft1 7) '(mm))))
+ )
+(newline)
+; ==> (6 6 4 7 (mm))
+
+; the use of (mm) (separately-defined macro) is equivalent to the use of variable foo --
+; (define-macro (mm) foo) -- dirty macro
+
+
+; Re-defining the global let
+
+(define-syntax dlet
+ (syntax-rules ()
+ ((_ new-let-symb . args)
+ ; just renaming of new-let-symbol with 'let'
+ (let-syntax
+ ((ren
+ (syntax-rules ()
+ ((_ list) (defile (let . args))))))
+ (ren let1)))))
+
+
+(display "dlet")
+(newline)
+(display
+ (dlet list ((foo 2)) (list (mm) foo))
+ )
+
+; (define-syntax old-let
+; (syntax-rules ()
+; ((_ . args) (let . args))))
+; (define-syntax old-let*
+; (syntax-rules ()
+; ((_ . args) (let* . args))))
+; (define-syntax old-letrec
+; (syntax-rules ()
+; ((_ . args) (letrec . args))))
+; (define-syntax old-lambda
+; (syntax-rules ()
+; ((_ . args) (lambda . args))))
+
+; (define-syntax let
+; (syntax-rules ()
+; ((_ . args) (defile1 (glet (old-let old-let* old-letrec lambda) . args)))))
+; ; (define-syntax let
+; ; (syntax-rules ()
+; ; ((_ . args) (defile1 (old-let . args)))))
+
+
+; (define-syntax defile1
+; (syntax-rules ()
+; ((_ dbody)
+; (letrec-syntax
+; ((do-defile
+; (syntax-rules () ; all the shadowed symbols
+; ((_ (let-symb let*-symb letrec-symb lambda-symb mm-symb foo-symb)
+; body-to-defile)
+; (letrec-syntax
+; ((let-symb ; R5RS definition of let
+; (syntax-rules ()
+; ((_ . args)
+; (glet (let-symb let*-symb letrec-symb lambda-symb)
+; . args))))
+
+; (let*-symb ; Redefinition of let*
+; (syntax-rules ()
+; ((_ . args)
+; (glet* (let-symb let*-symb letrec-symb lambda-symb)
+; . args))))
+
+; (letrec-symb ; Redefinition of letrec
+; (syntax-rules ()
+; ((_ . args)
+; (gletrec (let-symb let*-symb letrec-symb lambda-symb)
+; . args))))
+
+; (lambda-symb ; re-defined, infected lambda
+; (syntax-rules ()
+; ((_ _vars _body)
+; (letrec-syntax
+; ((doit
+; (syntax-rules ()
+; ((_ (mylet-symb mylet*-symb myletrec-symb
+; mylambda-symb mymm-symb
+; myfoo-symb) vars body)
+; (lambda-native vars
+; (make-mm mymm-symb myfoo-symb
+; (do-defile ; proliferate in the body
+; (mylet-symb mylet*-symb myletrec-symb
+; mylambda-symb
+; mymm-symb myfoo-symb)
+; body)))))))
+; (extract* (let-symb let*-symb letrec-symb lambda-symb
+; mm-symb foo-symb)
+; (_vars _body)
+; (doit () _vars _body))))))
+
+; (lambda-native ; capture the native lambda
+; (syntax-rules ()
+; ((_ . args) (lambda . args))))
+; )
+
+; body-to-defile)))))
+
+; (extract* (let let* letrec lambda mm foo) dbody
+; (do-defile () dbody))
+; ))))
+
+; ; (define-syntax let
+; ; (syntax-rules ()
+; ; ((_ . args) (dlet let . args))))
+
+
+
+; ; (define-syntax alet
+; ; (syntax-rules ()
+; ; ((_ . args)
+; ; (let-syntax
+; ; ((doit
+; ; (syntax-rules ()
+; ; ((_ (let-symb) body) (defile1 let-symb (blet . body))))))
+; ; (extract* (blet) args (doit () args))))))
+
+
+; (display "corrupted-let")
+; (newline)
+; (display
+; (let ((foo 2)) (list (mm) foo))
+; )
+
+; (newline)
+; (display
+; (let ((foo 2)) (let ((foo 3)) (let ((foo 4)) (list (mm) foo))))
+; )
+; (newline)
+; ; ==> (4 4)
+
+; (display
+; (let ((foo 2))
+; (let ((foo 3) (bar (list (mm) foo)))
+; (list foo (mm) bar)))
+; )
+; (newline)
+; ; ==> (3 3 (2 2))
+
+; (display
+; (let ((foo 2))
+; (list
+; ((letrec ((bar (lambda () (list foo (mm))))
+; (foo 3))
+; bar))
+; foo (mm))))
+; (newline)
+; ;==> ((3 3) 2 2)
+
+; (display
+; (let ((foo 2))
+; (let foo ((flag #t) (lst (list foo (mm))))
+; (if flag ((mm) #f (list lst lst)) lst))))
+; (newline)
+; ; ==> ((2 2) (2 2))
+
+; (display
+; (let ()
+; (let* ((foo 2)
+; (i 3)
+; (foo 4)
+; (ft (lambda () (mm))) ; will capture binding of foo to 4
+; (foo 5)
+; (ft1 (lambda (foo) (mm))) ; will capture the arg of ft1
+; (foo 6))
+; (list foo (mm) (ft) (ft1 7) '(mm))))
+; )
+; (newline)
+; ; ==> (6 6 4 7 (mm))
+
+
+(define-syntax defile-what
+ (syntax-rules ()
+ ((_ dirty-macro-name dirty-macro-name-gen captured-symbol dbody)
+ (letrec-syntax
+ ((do-defile
+ (syntax-rules () ; all the shadowed symbols
+ ((_ (let-symb let*-symb letrec-symb lambda-symb mm-symb foo-symb)
+ body-to-defile)
+ (letrec-syntax
+ ((let-symb ; R5RS definition of let
+ (syntax-rules ()
+ ((_ . args)
+ (glet (let-symb let*-symb letrec-symb lambda-symb)
+ . args))))
+
+ (let*-symb ; Redefinition of let*
+ (syntax-rules ()
+ ((_ . args)
+ (glet* (let-symb let*-symb letrec-symb lambda-symb)
+ . args))))
+
+ (letrec-symb ; Redefinition of letrec
+ (syntax-rules ()
+ ((_ . args)
+ (gletrec (let-symb let*-symb letrec-symb lambda-symb)
+ . args))))
+ (lambda-symb ; re-defined, infected lambda
+ (syntax-rules ()
+ ((_ _vars _body)
+ (letrec-syntax
+ ((doit
+ (syntax-rules ()
+ ((_ (mylet-symb mylet*-symb myletrec-symb
+ mylambda-symb mymm-symb
+ myfoo-symb) vars body)
+ (lambda-native vars
+ (dirty-macro-name-gen mymm-symb myfoo-symb
+ (do-defile ; proliferate in the body
+ (mylet-symb mylet*-symb myletrec-symb
+ mylambda-symb
+ mymm-symb myfoo-symb)
+ body))))))
+ (proliferate
+ (syntax-rules ()
+ ((_ dummy __vars __body)
+ (extract* (let-symb let*-symb
+ letrec-symb lambda-symb
+ mm-symb foo-symb)
+ (__vars __body)
+ (doit () __vars __body)))))
+ (stop-infection
+ (syntax-rules ()
+ ((_ dummy __vars __body)
+ (lambda-native __vars __body))))
+ )
+ (extract? mm-symb _vars
+ ; true-continuation
+ (stop-infection () _vars _body)
+ ; false-cont
+ (proliferate () _vars _body))
+ ))))
+
+; (lambda-symb ; re-defined, infected lambda
+; (syntax-rules ()
+; ((_ _vars _body)
+; (letrec-syntax
+; ((doit
+; (syntax-rules ()
+; ((_ (mylet-symb mylet*-symb myletrec-symb
+; mylambda-symb mymm-symb
+; myfoo-symb) vars body)
+; (lambda-native vars
+; (dirty-macro-name-gen mymm-symb myfoo-symb
+; (do-defile ; proliferate in the body
+; (mylet-symb mylet*-symb myletrec-symb
+; mylambda-symb
+; mymm-symb myfoo-symb)
+; body)))))))
+; (extract* (let-symb let*-symb letrec-symb lambda-symb
+; mm-symb foo-symb)
+; (_vars _body)
+; (doit () _vars _body))))))
+
+ (lambda-native ; capture the native lambda
+ (syntax-rules ()
+ ((_ . args) (lambda . args))))
+ )
+
+ body-to-defile)))))
+
+ (extract* (let let* letrec lambda dirty-macro-name captured-symbol) dbody
+ (do-defile () dbody))
+ ))))
+
+
+(define-syntax let-defiled-syntax
+ (syntax-rules ()
+ ((_ var-to-capture ((dm-name dm-body)) body)
+ (let-syntax
+ ((dm-generator
+ (syntax-rules ()
+ ((_ dmg-name var-to-capture dmg-outer-body)
+ (let-syntax
+ ((dmg-name dm-body))
+ dmg-outer-body)))))
+ (defile-what
+ dm-name dm-generator var-to-capture body)
+ ))))
+
+(display "defile-what") (newline)
+(display
+ (let-defiled-syntax
+ bar ((mbar (syntax-rules () ((_ val) (+ bar val)))))
+ (let ((bar 1)) (let ((bar 2)) (mbar 2))))
+)
+(newline)
+
+(display "defile-what") (newline)
+(display
+ (let-defiled-syntax
+ quux ((mquux (syntax-rules () ((_ val) (+ quux quux val)))))
+ (let* ((bar 1) (quux 0) (quux 2)
+ (lquux (lambda (x) (mquux x)))
+ (quux 3)
+ (lcquux (lambda (quux) (mquux quux)))) ; will tripple its arg
+ (list (+ quux quux) (mquux 0) (lquux 2) (lcquux 5)))))
+(newline)
+; ==> (6 6 6 15)
+
+; testing shadowing
+(display "test shadowing") (newline)
+(display
+ (let-defiled-syntax
+ quux ((mquux (syntax-rules () ((_ val) (+ quux quux val)))))
+ (let* ((bar 1) (quux 0) (quux 2)
+ (lquux (lambda (x) (mquux x)))
+ (mquux (lambda (val) 0))
+ (lcquux (lambda (quux) (mquux quux)))) ; will tripple its arg
+ (list (+ quux quux) (mquux 0) (lquux 2) (lcquux 5)))))
+(newline)
+; ==> (4 0 6 0)
+(display
+ (let-syntax
+ ((mquux (syntax-rules () ((_ val) (+ quux quux val)))))
+ (let ((mquux (lambda (val) 0)))
+ (let* ((bar 1) (quux 0) (quux 2)
+ (lquux (lambda (x) (mquux x)))
+ (lcquux (lambda (quux) (mquux quux)))) ; will tripple its arg
+ (list (+ quux quux) (mquux 0) (lquux 2) (lcquux 5))))))
+(newline)
+; ==> (4 0 0 0)
+
+(display
+ (let-defiled-syntax
+ quux ((mquux (syntax-rules () ((_ val) (+ quux quux val)))))
+ (let-syntax ((mquux (syntax-rules () ((_ val) 0))))
+ (let* ((bar 1) (quux 0) (quux 2)
+ (lquux (lambda (x) (mquux x)))
+ (lcquux (lambda (quux) (mquux quux)))) ; will tripple its arg
+ (list (+ quux quux) (mquux 0) (lquux 2) (lcquux 5))))))
+; ==> (4 0 0 0)
+
+(display
+ (defile
+ (let-syntax
+ ((test2
+ (syntax-rules (mm)
+ ((_ mm) 'okay)
+ ((_ x) 'wrong))))
+ (list
+ (test2 mm)
+ (let ((foo 3)) (test2 mm))))))
+(newline)
+
+; extracting on a different sort of criteria
+
+; extract2 MARKER BODY CONT
+; Search the body for the occurrence of the form (SYMB MARKER . REST)
+; where SYMB is a symbol. MARKER is a string, boolean, or number.
+; For simplicity, we don't check that SYMB
+; is a symbol, but we could: see a macro m-symbol?.
+; CONT is a list (K-HEAD () . K-REST)
+; If we found such a form, expand into
+; (K-HEAD SYMB . K-REST)
+; If we didn't find what we searched for, expand into
+; (K-HEAD nai . K-REST)
+
+
+(define-syntax extract2
+ (syntax-rules ()
+ ((_ _marker _body _cont)
+ (letrec-syntax
+ ((lp
+ (syntax-rules ()
+ ((_ (symb _marker . rest) stack (cont-head () . cont-args))
+ (cont-head symb . cont-args)) ; found
+ ((_ (x . y) stack cont) ; if body is a composite form,
+ (lp x (y . stack) cont)) ; look inside
+ ((_ d () (cont-head () . cont-args))
+ (cont-head nai . cont-args)) ; symb does not occur
+ ((_ d (x . y) cont)
+ (lp x y cont)))))
+ (lp _body () _cont)))))
+
+
+(define-syntax loop
+ (syntax-rules ()
+ ((_ . exps)
+ (let-syntax
+ ((cont
+ (syntax-rules ()
+ ((_ ident exps_)
+ (call-with-current-continuation
+ (lambda (k)
+ (let ((ident (lambda (dummy value) (k value))))
+ (let f ()
+ (begin 'prevent-empty-begin . exps_)
+ (f)))))))))
+ (extract2 "this one" exps (cont () exps))))))
+
+
+(display "loop") (newline)
+(display (loop (break "this one" 'foo)))
+(newline)
+; ==> foo
+
+(display "nested loop") (newline)
+(display
+ (loop
+ (loop
+ (break "this one" 'foo))
+ (break "this one" 'bar)))
+; ==> bar
+(newline)
+
+(display "loop: shadowing") (newline)
+(display
+ (let ((break (lambda (dummy x) x)))
+ (loop (break "this one" 'foo))
+ (break "this one" 'bar)))
+(newline)
+
+; Petrofsky:
+; There are problems with writing extensions to loop. Suppose we want
+; to write loop-while, which adds a test that is checked once each time
+; around the loop, and still binds an exit procedure. We might think it
+; could be written like this:
+
+(define-syntax loop-while
+ (syntax-rules ()
+ ((_ test exp ...)
+ (loop
+ (if (not test) (break "this one" #f))
+ exp ...))))
+
+(display "loop-while") (newline)
+(display
+ (let ((n 0))
+ (loop-while (< n 5)
+ (set! n (+ n 1)))
+ n))
+; ==> 5
+(newline)
+
+(display
+ (loop
+ (let ((n 0))
+ (loop-while (< n 5)
+ (set! n (+ n 1))
+ (if (= n 2)
+ (break "this one" 'foo)))
+ (break "this one" 'bar))))
+(newline)
+
+
+; (define-syntax make-lambda
+; (syntax-rules ()
+; ((_ . args) (lambda . args))))
+
+; (define-syntax make-lambda
+; (syntax-rules ()
+; ((_ bindings body ...)
+; (let () (define (proc . bindings) body ...)
+; proc))))
+
+(define-syntax make-lambda
+ (syntax-rules ()
+ ((_ bindings body ...)
+ (let-syntax () (define (proc . bindings) body ...)
+ proc))))
+
+(define-syntax lambda
+ (syntax-rules ()
+ ((_ bindings body1 body2 ...)
+ (make-lambda bindings
+ (display "OK") (newline)
+ (begin body1 body2 ...)))))
+
+(display "lambda-test") (newline)
+(let ((p (lambda (x y z) (list x y z))))
+ (display (p 1 2 3)))
+(newline)
+
+(define-syntax mm
+ (syntax-rules ()
+ ((_ dummy) foo)
+ ((_ dummy k) (k foo))))
+
+(define-syntax make-mm
+ (syntax-rules ()
+ ((_ mm foo bodies)
+ (let-syntax
+ ((mm
+ (syntax-rules ()
+ ((_ dummy) foo)
+ ((_ dummy (kh () . kargs)) (kh foo . kargs)))))
+ . bodies))))
+
+(define-syntax recolor
+ (syntax-rules ()
+ ((_ from to bodies . rest)
+ (let-syntax
+ ((ren
+ (syntax-rules ()
+ ((_ from) bodies))))
+ (ren to)))))
+
+(define-syntax nai
+ (syntax-rules ()
+ ((_ dummy (kh () . kargs)) (kh nai . kargs))))
+
+(define-syntax lambda
+ (syntax-rules ()
+ ((_ bindings . bodies)
+ (letrec-syntax
+ ((test
+ (syntax-rules ()
+ ((_ symb exp _kt _kf)
+ (letrec-syntax
+ ((loop
+ (syntax-rules (symb)
+ ((_ d () kt kf) kf)
+ ((_ (s . r1) (symb . r2) (kh () . kargs) kf)
+ (kh s . kargs))
+ ((_ d (x . rest) kt kf) (loop rest rest kt kf)))))
+ (loop exp exp _kt _kf)))))
+ (doit
+ (syntax-rules ()
+ ((_ foo orig-foo bindings_ bodies_)
+ (extract2 "mm" bodies_
+ (cont () foo orig-foo bindings_ bodies_)))))
+ (cont
+ (syntax-rules ()
+ ((_ mm bindings_ bodies_)
+ (mm dummy (cont2 () mm bindings_ bodies_)))))
+ (cont2
+ (syntax-rules ()
+ ((_ xxx foo mm bindings_ bodies_)
+ (test foo bindings_
+ (cont3 () mm bindings_ bodies_)
+ (make-lambda bindings_ bodies_)))))
+ (cont3
+ (syntax-rules ()
+ ((_ foo mm bindings_ bodies_)
+ (make-lambda bindings_
+ (make-mm mm foo
+ bodies_))))))
+ (extract2 "mm" bodies
+ (cont () bindings bodies))))))
+
+
+; (define-syntax let
+; (syntax-rules ()
+; ((_ ((v i)) . bodies)
+; ((lambda (v) . bodies) i))))
+
+(define-syntax let*
+ (syntax-rules ()
+ ((_ () . bodies) (begin . bodies))
+ ((_ ((v i) . rest) . bodies)
+ ((lambda (v) (let* rest . bodies)) i))))
+; ((_ . args) (glet* (let let* letrec lambda) . args))))
+
+;(display (let* ((foo 2)) (list foo (mm "mm"))))
+
+; (display
+; (let* ((foo 2)
+; (i 3)
+; (foo 4)
+; (ft (lambda () (mm "mm"))) ; will capture binding of foo to 4
+; (foo 5)
+; (ft1 (lambda (foo) (mm "mm"))) ; will capture the arg of ft1
+; (foo 6))
+; (list foo (mm "mm") (ft) (ft1 7) '(mm "mm"))))
+(newline)
+; ==> (6 6 4 7 (mm))
+
+
diff --git a/tests/ec-tests.scm b/tests/ec-tests.scm
new file mode 100644
index 00000000..1ab7f68d
--- /dev/null
+++ b/tests/ec-tests.scm
@@ -0,0 +1,652 @@
+; <PLAINTEXT>
+; Examples for Eager Comprehensions in [outer..inner|expr]-Convention
+; ===================================================================
+;
+; sebastian.egner@philips.com, Eindhoven, The Netherlands, 26-Dec-2007.
+; Scheme R5RS (incl. macros), SRFI-23 (error).
+;
+; Running the examples in Scheme48 (version 1.1):
+; ,open srfi-23
+; ,load ec.scm
+; (define my-open-output-file open-output-file)
+; (define my-call-with-input-file call-with-input-file)
+; ,load examples.scm
+;
+; Running the examples in PLT/DrScheme (version 317):
+; (load "ec.scm")
+; (define (my-open-output-file filename)
+; (open-output-file filename 'replace 'text) )
+; (define (my-call-with-input-file filename thunk)
+; (call-with-input-file filename thunk 'text) )
+; (load "examples.scm")
+;
+; Running the examples in SCM (version 5d7):
+; (require 'macro) (require 'record)
+; (load "ec.scm")
+; (define my-open-output-file open-output-file)
+; (define my-call-with-input-file call-with-input-file)
+; (load "examples.scm")
+
+(import ec)
+
+
+(define my-open-output-file open-output-file)
+(define my-call-with-input-file call-with-input-file)
+
+
+; Tools for checking results
+; ==========================
+
+(define (my-equal? x y)
+ (cond
+ ((or (boolean? x)
+ (null? x)
+ (symbol? x)
+ (char? x)
+ (input-port? x)
+ (output-port? x) )
+ (eqv? x y) )
+ ((string? x)
+ (and (string? y) (string=? x y)) )
+ ((vector? x)
+ (and (vector? y)
+ (my-equal? (vector->list x) (vector->list y)) ))
+ ((pair? x)
+ (and (pair? y)
+ (my-equal? (car x) (car y))
+ (my-equal? (cdr x) (cdr y)) ))
+ ((real? x)
+ (and (real? y)
+ (eqv? (exact? x) (exact? y))
+ (if (exact? x)
+ (= x y)
+ (< (abs (- x y)) (/ 1 (expt 10 6))) ))) ; will do here
+ (else
+ (error "unrecognized type" x) )))
+
+(define my-check-correct 0)
+(define my-check-wrong 0)
+
+(define-syntax my-check
+ (syntax-rules (=>)
+ ((my-check ec => desired-result)
+ (begin
+ (newline)
+ (write (quote ec))
+ (newline)
+ (let ((actual-result ec))
+ (display " => ")
+ (write actual-result)
+ (if (my-equal? actual-result desired-result)
+ (begin
+ (display " ; correct")
+ (set! my-check-correct (+ my-check-correct 1)) )
+ (begin
+ (display " ; *** wrong ***, desired result:")
+ (newline)
+ (display " => ")
+ (write desired-result)
+ (set! my-check-wrong (+ my-check-wrong 1)) ))
+ (newline) )))))
+
+
+; ==========================================================================
+; do-ec
+; ==========================================================================
+
+(my-check
+ (let ((x 0)) (do-ec (set! x (+ x 1))) x)
+ => 1)
+
+(my-check
+ (let ((x 0)) (do-ec (:range i 10) (set! x (+ x 1))) x)
+ => 10)
+
+(my-check
+ (let ((x 0)) (do-ec (:range n 10) (:range k n) (set! x (+ x 1))) x)
+ => 45)
+
+
+; ==========================================================================
+; list-ec and basic qualifiers
+; ==========================================================================
+
+(my-check (list-ec 1) => '(1))
+
+(my-check (list-ec (:range i 4) i) => '(0 1 2 3))
+
+(my-check (list-ec (:range n 3) (:range k (+ n 1)) (list n k))
+ => '((0 0) (1 0) (1 1) (2 0) (2 1) (2 2)) )
+
+(my-check
+ (list-ec (:range n 5) (if (even? n)) (:range k (+ n 1)) (list n k))
+ => '((0 0) (2 0) (2 1) (2 2) (4 0) (4 1) (4 2) (4 3) (4 4)) )
+
+(my-check
+ (list-ec (:range n 5) (not (even? n)) (:range k (+ n 1)) (list n k))
+ => '((1 0) (1 1) (3 0) (3 1) (3 2) (3 3)) )
+
+(my-check
+ (list-ec (:range n 5)
+ (and (even? n) (> n 2))
+ (:range k (+ n 1))
+ (list n k) )
+ => '((4 0) (4 1) (4 2) (4 3) (4 4)) )
+
+(my-check
+ (list-ec (:range n 5)
+ (or (even? n) (> n 3))
+ (:range k (+ n 1))
+ (list n k) )
+ => '((0 0) (2 0) (2 1) (2 2) (4 0) (4 1) (4 2) (4 3) (4 4)) )
+
+(my-check
+ (let ((x 0)) (list-ec (:range n 10) (begin (set! x (+ x 1))) n) x)
+ => 10 )
+
+(my-check
+ (list-ec (nested (:range n 3) (:range k n)) k)
+ => '(0 0 1) )
+
+
+; ==========================================================================
+; Other comprehensions
+; ==========================================================================
+
+(my-check (append-ec '(a b)) => '(a b))
+(my-check (append-ec (:range i 0) '(a b)) => '())
+(my-check (append-ec (:range i 1) '(a b)) => '(a b))
+(my-check (append-ec (:range i 2) '(a b)) => '(a b a b))
+
+(my-check (string-ec #\a) => (string #\a))
+(my-check (string-ec (:range i 0) #\a) => "")
+(my-check (string-ec (:range i 1) #\a) => "a")
+(my-check (string-ec (:range i 2) #\a) => "aa")
+
+(my-check (string-append-ec "ab") => "ab")
+(my-check (string-append-ec (:range i 0) "ab") => "")
+(my-check (string-append-ec (:range i 1) "ab") => "ab")
+(my-check (string-append-ec (:range i 2) "ab") => "abab")
+
+(my-check (vector-ec 1) => (vector 1))
+(my-check (vector-ec (:range i 0) i) => (vector))
+(my-check (vector-ec (:range i 1) i) => (vector 0))
+(my-check (vector-ec (:range i 2) i) => (vector 0 1))
+
+(my-check (vector-of-length-ec 1 1) => (vector 1))
+(my-check (vector-of-length-ec 0 (:range i 0) i) => (vector))
+(my-check (vector-of-length-ec 1 (:range i 1) i) => (vector 0))
+(my-check (vector-of-length-ec 2 (:range i 2) i) => (vector 0 1))
+
+(my-check (sum-ec 1) => 1)
+(my-check (sum-ec (:range i 0) i) => 0)
+(my-check (sum-ec (:range i 1) i) => 0)
+(my-check (sum-ec (:range i 2) i) => 1)
+(my-check (sum-ec (:range i 3) i) => 3)
+
+(my-check (product-ec 1) => 1)
+(my-check (product-ec (:range i 1 0) i) => 1)
+(my-check (product-ec (:range i 1 1) i) => 1)
+(my-check (product-ec (:range i 1 2) i) => 1)
+(my-check (product-ec (:range i 1 3) i) => 2)
+(my-check (product-ec (:range i 1 4) i) => 6)
+
+(my-check (min-ec 1) => 1)
+(my-check (min-ec (:range i 1) i) => 0)
+(my-check (min-ec (:range i 2) i) => 0)
+
+(my-check (max-ec 1) => 1)
+(my-check (max-ec (:range i 1) i) => 0)
+(my-check (max-ec (:range i 2) i) => 1)
+
+(my-check (first-ec #f 1) => 1)
+(my-check (first-ec #f (:range i 0) i) => #f)
+(my-check (first-ec #f (:range i 1) i) => 0)
+(my-check (first-ec #f (:range i 2) i) => 0)
+
+(my-check
+ (let ((last-i -1))
+ (first-ec #f (:range i 10) (begin (set! last-i i)) i)
+ last-i )
+ => 0 )
+
+(my-check (last-ec #f 1) => 1)
+(my-check (last-ec #f (:range i 0) i) => #f)
+(my-check (last-ec #f (:range i 1) i) => 0)
+(my-check (last-ec #f (:range i 2) i) => 1)
+
+(my-check (any?-ec #f) => #f)
+(my-check (any?-ec #t) => #t)
+(my-check (any?-ec (:range i 2 2) (even? i)) => #f)
+(my-check (any?-ec (:range i 2 3) (even? i)) => #t)
+
+(my-check (every?-ec #f) => #f)
+(my-check (every?-ec #t) => #t)
+(my-check (every?-ec (:range i 2 2) (even? i)) => #t)
+(my-check (every?-ec (:range i 2 3) (even? i)) => #t)
+(my-check (every?-ec (:range i 2 4) (even? i)) => #f)
+
+(my-check
+ (let ((sum-sqr (lambda (x result) (+ result (* x x)))))
+ (fold-ec 0 (:range i 10) i sum-sqr) )
+ => 285 )
+
+(my-check
+ (let ((minus-1 (lambda (x) (- x 1)))
+ (sum-sqr (lambda (x result) (+ result (* x x)))))
+ (fold3-ec (error "wrong") (:range i 10) i minus-1 sum-sqr) )
+ => 284 )
+
+(my-check
+ (fold3-ec 'infinity (:range i 0) i min min)
+ => 'infinity )
+
+
+; ==========================================================================
+; Typed generators
+; ==========================================================================
+
+(my-check (list-ec (:list x '()) x) => '())
+(my-check (list-ec (:list x '(1)) x) => '(1))
+(my-check (list-ec (:list x '(1 2 3)) x) => '(1 2 3))
+(my-check (list-ec (:list x '(1) '(2)) x) => '(1 2))
+(my-check (list-ec (:list x '(1) '(2) '(3)) x) => '(1 2 3))
+
+(my-check (list-ec (:string c "") c) => '())
+(my-check (list-ec (:string c "1") c) => '(#\1))
+(my-check (list-ec (:string c "123") c) => '(#\1 #\2 #\3))
+(my-check (list-ec (:string c "1" "2") c) => '(#\1 #\2))
+(my-check (list-ec (:string c "1" "2" "3") c) => '(#\1 #\2 #\3))
+
+(my-check (list-ec (:vector x (vector)) x) => '())
+(my-check (list-ec (:vector x (vector 1)) x) => '(1))
+(my-check (list-ec (:vector x (vector 1 2 3)) x) => '(1 2 3))
+(my-check (list-ec (:vector x (vector 1) (vector 2)) x) => '(1 2))
+(my-check
+ (list-ec (:vector x (vector 1) (vector 2) (vector 3)) x)
+ => '(1 2 3))
+
+(my-check (list-ec (:range x -2) x) => '())
+(my-check (list-ec (:range x -1) x) => '())
+(my-check (list-ec (:range x 0) x) => '())
+(my-check (list-ec (:range x 1) x) => '(0))
+(my-check (list-ec (:range x 2) x) => '(0 1))
+
+(my-check (list-ec (:range x 0 3) x) => '(0 1 2))
+(my-check (list-ec (:range x 1 3) x) => '(1 2))
+(my-check (list-ec (:range x -2 -1) x) => '(-2))
+(my-check (list-ec (:range x -2 -2) x) => '())
+
+(my-check (list-ec (:range x 1 5 2) x) => '(1 3))
+(my-check (list-ec (:range x 1 6 2) x) => '(1 3 5))
+(my-check (list-ec (:range x 5 1 -2) x) => '(5 3))
+(my-check (list-ec (:range x 6 1 -2) x) => '(6 4 2))
+
+(my-check (list-ec (:real-range x 0.0 3.0) x) => '(0. 1. 2.))
+(my-check (list-ec (:real-range x 0 3.0) x) => '(0. 1. 2.))
+(my-check (list-ec (:real-range x 0 3 1.0) x) => '(0. 1. 2.))
+
+(my-check
+ (string-ec (:char-range c #\a #\z) c)
+ => "abcdefghijklmnopqrstuvwxyz" )
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (my-call-with-input-file "tmp1"
+ (lambda (port) (list-ec (:port x port read) x)) ))
+ => (list-ec (:range n 10) n) )
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (my-call-with-input-file "tmp1"
+ (lambda (port) (list-ec (:port x port) x)) ))
+ => (list-ec (:range n 10) n) )
+
+
+; ==========================================================================
+; The special generators :do :let :parallel :while :until
+; ==========================================================================
+
+(my-check (list-ec (:do ((i 0)) (< i 4) ((+ i 1))) i) => '(0 1 2 3))
+
+(my-check
+ (list-ec
+ (:do (let ((x 'x)))
+ ((i 0))
+ (< i 4)
+ (let ((j (- 10 i))))
+ #t
+ ((+ i 1)) )
+ j )
+ => '(10 9 8 7) )
+
+(my-check (list-ec (:let x 1) x) => '(1))
+(my-check (list-ec (:let x 1) (:let y (+ x 1)) y) => '(2))
+(my-check (list-ec (:let x 1) (:let x (+ x 1)) x) => '(2))
+
+(my-check
+ (list-ec (:parallel (:range i 1 10) (:list x '(a b c))) (list i x))
+ => '((1 a) (2 b) (3 c)) )
+
+(my-check
+ (list-ec (:while (:range i 1 10) (< i 5)) i)
+ => '(1 2 3 4) )
+
+(my-check
+ (list-ec (:until (:range i 1 10) (>= i 5)) i)
+ => '(1 2 3 4 5) )
+
+; with generator that might use inner bindings
+
+(my-check
+ (list-ec (:while (:list i '(1 2 3 4 5 6 7 8 9)) (< i 5)) i)
+ => '(1 2 3 4) )
+; Was broken in original reference implementation as pointed
+; out by sunnan@handgranat.org on 24-Apr-2005 comp.lang.scheme.
+; Refer to http://groups-beta.google.com/group/comp.lang.scheme/
+; browse_thread/thread/f5333220eaeeed66/75926634cf31c038#75926634cf31c038
+
+(my-check
+ (list-ec (:until (:list i '(1 2 3 4 5 6 7 8 9)) (>= i 5)) i)
+ => '(1 2 3 4 5) )
+
+(my-check
+ (list-ec (:while (:vector x (index i) '#(1 2 3 4 5))
+ (< x 10))
+ x)
+ => '(1 2 3 4 5))
+; Was broken in reference implementation, even after fix for the
+; bug reported by Sunnan, as reported by Jens-Axel Soegaard on
+; 4-Jun-2007.
+
+; combine :while/:until and :parallel
+
+(my-check
+ (list-ec (:while (:parallel (:range i 1 10)
+ (:list j '(1 2 3 4 5 6 7 8 9)))
+ (< i 5))
+ (list i j))
+ => '((1 1) (2 2) (3 3) (4 4)))
+
+(my-check
+ (list-ec (:until (:parallel (:range i 1 10)
+ (:list j '(1 2 3 4 5 6 7 8 9)))
+ (>= i 5))
+ (list i j))
+ => '((1 1) (2 2) (3 3) (4 4) (5 5)))
+
+; check that :while/:until really stop the generator
+
+(my-check
+ (let ((n 0))
+ (do-ec (:while (:range i 1 10) (begin (set! n (+ n 1)) (< i 5)))
+ (if #f #f))
+ n)
+ => 5)
+
+(my-check
+ (let ((n 0))
+ (do-ec (:until (:range i 1 10) (begin (set! n (+ n 1)) (>= i 5)))
+ (if #f #f))
+ n)
+ => 5)
+
+(my-check
+ (let ((n 0))
+ (do-ec (:while (:parallel (:range i 1 10)
+ (:do () (begin (set! n (+ n 1)) #t) ()))
+ (< i 5))
+ (if #f #f))
+ n)
+ => 5)
+
+(my-check
+ (let ((n 0))
+ (do-ec (:until (:parallel (:range i 1 10)
+ (:do () (begin (set! n (+ n 1)) #t) ()))
+ (>= i 5))
+ (if #f #f))
+ n)
+ => 5)
+
+; ==========================================================================
+; The dispatching generator
+; ==========================================================================
+
+(my-check (list-ec (: c '(a b)) c) => '(a b))
+(my-check (list-ec (: c '(a b) '(c d)) c) => '(a b c d))
+
+(my-check (list-ec (: c "ab") c) => '(#\a #\b))
+(my-check (list-ec (: c "ab" "cd") c) => '(#\a #\b #\c #\d))
+
+(my-check (list-ec (: c (vector 'a 'b)) c) => '(a b))
+(my-check (list-ec (: c (vector 'a 'b) (vector 'c)) c) => '(a b c))
+
+(my-check (list-ec (: i 0) i) => '())
+(my-check (list-ec (: i 1) i) => '(0))
+(my-check (list-ec (: i 10) i) => '(0 1 2 3 4 5 6 7 8 9))
+(my-check (list-ec (: i 1 2) i) => '(1))
+(my-check (list-ec (: i 1 2 3) i) => '(1))
+(my-check (list-ec (: i 1 9 3) i) => '(1 4 7))
+
+(my-check (list-ec (: i 0.0 1.0 0.2) i) => '(0. 0.2 0.4 0.6 0.8))
+
+(my-check (list-ec (: c #\a #\c) c) => '(#\a #\b #\c))
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (my-call-with-input-file "tmp1"
+ (lambda (port) (list-ec (: x port read) x)) ))
+ => (list-ec (:range n 10) n) )
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (my-call-with-input-file "tmp1"
+ (lambda (port) (list-ec (: x port) x)) ))
+ => (list-ec (:range n 10) n) )
+
+
+; ==========================================================================
+; With index variable
+; ==========================================================================
+
+(my-check (list-ec (:list c (index i) '(a b)) (list c i)) => '((a 0) (b 1)))
+(my-check (list-ec (:string c (index i) "a") (list c i)) => '((#\a 0)))
+(my-check (list-ec (:vector c (index i) (vector 'a)) (list c i)) => '((a 0)))
+
+(my-check
+ (list-ec (:range i (index j) 0 -3 -1) (list i j))
+ => '((0 0) (-1 1) (-2 2)) )
+
+(my-check
+ (list-ec (:real-range i (index j) 0 1 0.2) (list i j))
+ => '((0. 0) (0.2 1) (0.4 2) (0.6 3) (0.8 4)) )
+
+(my-check
+ (list-ec (:char-range c (index i) #\a #\c) (list c i))
+ => '((#\a 0) (#\b 1) (#\c 2)) )
+
+(my-check
+ (list-ec (: x (index i) '(a b c d)) (list x i))
+ => '((a 0) (b 1) (c 2) (d 3)) )
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (my-call-with-input-file "tmp1"
+ (lambda (port) (list-ec (: x (index i) port) (list x i))) ))
+ => '((0 0) (1 1) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9)) )
+
+
+; ==========================================================================
+; The examples from the SRFI document
+; ==========================================================================
+
+; from Abstract
+
+(my-check (list-ec (: i 5) (* i i)) => '(0 1 4 9 16))
+
+(my-check
+ (list-ec (: n 1 4) (: i n) (list n i))
+ => '((1 0) (2 0) (2 1) (3 0) (3 1) (3 2)) )
+
+; from Generators
+
+(my-check
+ (list-ec (: x (index i) "abc") (list x i))
+ => '((#\a 0) (#\b 1) (#\c 2)) )
+
+(my-check
+ (list-ec (:string c (index i) "a" "b") (cons c i))
+ => '((#\a . 0) (#\b . 1)) )
+
+
+; ==========================================================================
+; Little Shop of Horrors
+; ==========================================================================
+
+(my-check (list-ec (:range x 5) (:range x x) x) => '(0 0 1 0 1 2 0 1 2 3))
+
+(my-check (list-ec (:list x '(2 "23" (4))) (: y x) y) => '(0 1 #\2 #\3 4))
+
+(my-check
+ (list-ec (:parallel (:integers x)
+ (:do ((i 10)) (< x i) ((- i 1))))
+ (list x i))
+ => '((0 10) (1 9) (2 8) (3 7) (4 6)) )
+
+
+; ==========================================================================
+; Less artificial examples
+; ==========================================================================
+
+(define (factorial n) ; n * (n-1) * .. * 1 for n >= 0
+ (product-ec (:range k 2 (+ n 1)) k) )
+
+(my-check (factorial 0) => 1)
+(my-check (factorial 1) => 1)
+(my-check (factorial 3) => 6)
+(my-check (factorial 5) => 120)
+
+
+(define (eratosthenes n) ; primes in {2..n-1} for n >= 1
+ (let ((p? (make-string n #\1)))
+ (do-ec (:range k 2 n)
+ (if (char=? (string-ref p? k) #\1))
+ (:range i (* 2 k) n k)
+ (string-set! p? i #\0) )
+ (list-ec (:range k 2 n) (if (char=? (string-ref p? k) #\1)) k) ))
+
+(my-check
+ (eratosthenes 50)
+ => '(2 3 5 7 11 13 17 19 23 29 31 37 41 43 47) )
+
+(my-check
+ (length (eratosthenes 100000))
+ => 9592 ) ; we expect 10^5/ln(10^5)
+
+
+(define (pythagoras n) ; a, b, c s.t. 1 <= a <= b <= c <= n, a^2 + b^2 = c^2
+ (list-ec
+ (:let sqr-n (* n n))
+ (:range a 1 (+ n 1))
+; (begin (display a) (display " "))
+ (:let sqr-a (* a a))
+ (:range b a (+ n 1))
+ (:let sqr-c (+ sqr-a (* b b)))
+ (if (<= sqr-c sqr-n))
+ (:range c b (+ n 1))
+ (if (= (* c c) sqr-c))
+ (list a b c) ))
+
+(my-check
+ (pythagoras 15)
+ => '((3 4 5) (5 12 13) (6 8 10) (9 12 15)) )
+
+(my-check
+ (length (pythagoras 200))
+ => 127 )
+
+
+(define (qsort xs) ; stable
+ (if (null? xs)
+ '()
+ (let ((pivot (car xs)) (xrest (cdr xs)))
+ (append
+ (qsort (list-ec (:list x xrest) (if (< x pivot)) x))
+ (list pivot)
+ (qsort (list-ec (:list x xrest) (if (>= x pivot)) x)) ))))
+
+(my-check
+ (qsort '(1 5 4 2 4 5 3 2 1 3))
+ => '(1 1 2 2 3 3 4 4 5 5) )
+
+
+(define (pi-BBP m) ; approx. of pi within 16^-m (Bailey-Borwein-Plouffe)
+ (sum-ec
+ (:range n 0 (+ m 1))
+ (:let n8 (* 8 n))
+ (* (- (/ 4 (+ n8 1))
+ (+ (/ 2 (+ n8 4))
+ (/ 1 (+ n8 5))
+ (/ 1 (+ n8 6))))
+ (/ 1 (expt 16 n)) )))
+
+(my-check
+ (pi-BBP 5)
+ => (/ 40413742330349316707 12864093722915635200) )
+
+
+(define (read-line port) ; next line (incl. #\newline) of port
+ (let ((line
+ (string-ec
+ (:until (:port c port read-char)
+ (char=? c #\newline) )
+ c )))
+ (if (string=? line "")
+ (read-char port) ; eof-object
+ line )))
+
+(define (read-lines filename) ; list of all lines
+ (my-call-with-input-file
+ filename
+ (lambda (port)
+ (list-ec (:port line port read-line) line) )))
+
+(my-check
+ (begin
+ (let ((f (my-open-output-file "tmp1")))
+ (do-ec (:range n 10) (begin (write n f) (newline f)))
+ (close-output-port f))
+ (read-lines "tmp1") )
+ => (list-ec (:char-range c #\0 #\9) (string c #\newline)) )
+
+
+; ==========================================================================
+; Summary
+; ==========================================================================
+
+(begin
+ (newline)
+ (newline)
+ (display "correct examples : ")
+ (display my-check-correct)
+ (newline)
+ (display "wrong examples : ")
+ (display my-check-wrong)
+ (newline)
+ (newline) )
diff --git a/tests/ec.scm b/tests/ec.scm
new file mode 100644
index 00000000..96297b4e
--- /dev/null
+++ b/tests/ec.scm
@@ -0,0 +1,1073 @@
+(module ec (do-ec do-ec:do :do :let :parallel
+ :parallel-1 :while :while-1 :while-2
+ :until :until-1 :list :string
+ (:vector ec-:vector-filter)
+ :integers :range
+ :real-range :char-range :port :dispatched
+ :generator-proc dispatch-union
+ make-initial-:-dispatch
+ (: :-dispatch)
+ :-dispatch-ref :-dispatch-set!
+ fold3-ec fold-ec list-ec append-ec
+ string-ec string-append-ec vector-ec
+ vector-of-length-ec sum-ec product-ec
+ min-ec max-ec last-ec first-ec
+ ec-guarded-do-ec any?-ec every?-ec)
+
+(import scheme chicken)
+
+; <PLAINTEXT>
+; Eager Comprehensions in [outer..inner|expr]-Convention
+; ======================================================
+;
+; sebastian.egner@philips.com, Eindhoven, The Netherlands, 26-Dec-2007
+; Scheme R5RS (incl. macros), SRFI-23 (error).
+;
+; Loading the implementation into Scheme48 0.57:
+; ,open srfi-23
+; ,load ec.scm
+;
+; Loading the implementation into PLT/DrScheme 317:
+; ; File > Open ... "ec.scm", click Execute
+;
+; Loading the implementation into SCM 5d7:
+; (require 'macro) (require 'record)
+; (load "ec.scm")
+;
+; Implementation comments:
+; * All local (not exported) identifiers are named ec-<something>.
+; * This implementation focuses on portability, performance,
+; readability, and simplicity roughly in this order. Design
+; decisions related to performance are taken for Scheme48.
+; * Alternative implementations, Comments and Warnings are
+; mentioned after the definition with a heading.
+
+
+; ==========================================================================
+; The fundamental comprehension do-ec
+; ==========================================================================
+;
+; All eager comprehensions are reduced into do-ec and
+; all generators are reduced to :do.
+;
+; We use the following short names for syntactic variables
+; q - qualifier
+; cc - current continuation, thing to call at the end;
+; the CPS is (m (cc ...) arg ...) -> (cc ... expr ...)
+; cmd - an expression being evaluated for its side-effects
+; expr - an expression
+; gen - a generator of an eager comprehension
+; ob - outer binding
+; oc - outer command
+; lb - loop binding
+; ne1? - not-end1? (before the payload)
+; ib - inner binding
+; ic - inner command
+; ne2? - not-end2? (after the payload)
+; ls - loop step
+; etc - more arguments of mixed type
+
+
+; (do-ec q ... cmd)
+; handles nested, if/not/and/or, begin, :let, and calls generator
+; macros in CPS to transform them into fully decorated :do.
+; The code generation for a :do is delegated to do-ec:do.
+
+(define-syntax do-ec
+ (syntax-rules (nested if not and or begin :do let)
+
+ ; explicit nesting -> implicit nesting
+ ((do-ec (nested q ...) etc ...)
+ (do-ec q ... etc ...) )
+
+ ; implicit nesting -> fold do-ec
+ ((do-ec q1 q2 etc1 etc ...)
+ (do-ec q1 (do-ec q2 etc1 etc ...)) )
+
+ ; no qualifiers at all -> evaluate cmd once
+ ((do-ec cmd)
+ (begin cmd (if #f #f)) )
+
+; now (do-ec q cmd) remains
+
+ ; filter -> make conditional
+ ((do-ec (if test) cmd)
+ (if test (do-ec cmd)) )
+ ((do-ec (not test) cmd)
+ (if (not test) (do-ec cmd)) )
+ ((do-ec (and test ...) cmd)
+ (if (and test ...) (do-ec cmd)) )
+ ((do-ec (or test ...) cmd)
+ (if (or test ...) (do-ec cmd)) )
+
+ ; begin -> make a sequence
+ ((do-ec (begin etc ...) cmd)
+ (begin etc ... (do-ec cmd)) )
+
+ ; fully decorated :do-generator -> delegate to do-ec:do
+ ((do-ec (:do olet lbs ne1? ilet ne2? lss) cmd)
+ (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss)) )
+
+; anything else -> call generator-macro in CPS; reentry at (*)
+
+ ((do-ec (g arg1 arg ...) cmd)
+ (g (do-ec:do cmd) arg1 arg ...) )))
+
+
+; (do-ec:do cmd (:do olet lbs ne1? ilet ne2? lss))
+; generates code for a single fully decorated :do-generator
+; with cmd as payload, taking care of special cases.
+
+(define-syntax do-ec:do
+ (syntax-rules (:do let)
+
+ ; reentry point (*) -> generate code
+ ((do-ec:do cmd
+ (:do (let obs oc ...)
+ lbs
+ ne1?
+ (let ibs ic ...)
+ ne2?
+ (ls ...) ))
+ (ec-simplify
+ (let obs
+ oc ...
+ (let loop lbs
+ (ec-simplify
+ (if ne1?
+ (ec-simplify
+ (let ibs
+ ic ...
+ cmd
+ (ec-simplify
+ (if ne2?
+ (loop ls ...) )))))))))) ))
+
+
+; (ec-simplify <expression>)
+; generates potentially more efficient code for <expression>.
+; The macro handles if, (begin <command>*), and (let () <command>*)
+; and takes care of special cases.
+
+(define-syntax ec-simplify
+ (syntax-rules (if not let begin)
+
+; one- and two-sided if
+
+ ; literal <test>
+ ((ec-simplify (if #t consequent))
+ consequent )
+ ((ec-simplify (if #f consequent))
+ (if #f #f) )
+ ((ec-simplify (if #t consequent alternate))
+ consequent )
+ ((ec-simplify (if #f consequent alternate))
+ alternate )
+
+ ; (not (not <test>))
+ ((ec-simplify (if (not (not test)) consequent))
+ (ec-simplify (if test consequent)) )
+ ((ec-simplify (if (not (not test)) consequent alternate))
+ (ec-simplify (if test consequent alternate)) )
+
+; (let () <command>*)
+
+ ; empty <binding spec>*
+ ((ec-simplify (let () command ...))
+ (ec-simplify (begin command ...)) )
+
+; begin
+
+ ; flatten use helper (ec-simplify 1 done to-do)
+ ((ec-simplify (begin command ...))
+ (ec-simplify 1 () (command ...)) )
+ ((ec-simplify 1 done ((begin to-do1 ...) to-do2 ...))
+ (ec-simplify 1 done (to-do1 ... to-do2 ...)) )
+ ((ec-simplify 1 (done ...) (to-do1 to-do ...))
+ (ec-simplify 1 (done ... to-do1) (to-do ...)) )
+
+ ; exit helper
+ ((ec-simplify 1 () ())
+ (if #f #f) )
+ ((ec-simplify 1 (command) ())
+ command )
+ ((ec-simplify 1 (command1 command ...) ())
+ (begin command1 command ...) )
+
+; anything else
+
+ ((ec-simplify expression)
+ expression )))
+
+
+; ==========================================================================
+; The special generators :do, :let, :parallel, :while, and :until
+; ==========================================================================
+
+(define-syntax :do
+ (syntax-rules ()
+
+ ; full decorated -> continue with cc, reentry at (*)
+ ((:do (cc ...) olet lbs ne1? ilet ne2? lss)
+ (cc ... (:do olet lbs ne1? ilet ne2? lss)) )
+
+ ; short form -> fill in default values
+ ((:do cc lbs ne1? lss)
+ (:do cc (let ()) lbs ne1? (let ()) #t lss) )))
+
+
+(define-syntax :let
+ (syntax-rules (index)
+ ((:let cc var (index i) expression)
+ (:do cc (let ((var expression) (i 0))) () #t (let ()) #f ()) )
+ ((:let cc var expression)
+ (:do cc (let ((var expression))) () #t (let ()) #f ()) )))
+
+
+(define-syntax :parallel
+ (syntax-rules (:do)
+ ((:parallel cc)
+ cc )
+ ((:parallel cc (g arg1 arg ...) gen ...)
+ (g (:parallel-1 cc (gen ...)) arg1 arg ...) )))
+
+; (:parallel-1 cc (to-do ...) result [ next ] )
+; iterates over to-do by converting the first generator into
+; the :do-generator next and merging next into result.
+
+(define-syntax :parallel-1 ; used as
+ (syntax-rules (:do let)
+
+ ; process next element of to-do, reentry at (**)
+ ((:parallel-1 cc ((g arg1 arg ...) gen ...) result)
+ (g (:parallel-1 cc (gen ...) result) arg1 arg ...) )
+
+ ; reentry point (**) -> merge next into result
+ ((:parallel-1
+ cc
+ gens
+ (:do (let (ob1 ...) oc1 ...)
+ (lb1 ...)
+ ne1?1
+ (let (ib1 ...) ic1 ...)
+ ne2?1
+ (ls1 ...) )
+ (:do (let (ob2 ...) oc2 ...)
+ (lb2 ...)
+ ne1?2
+ (let (ib2 ...) ic2 ...)
+ ne2?2
+ (ls2 ...) ))
+ (:parallel-1
+ cc
+ gens
+ (:do (let (ob1 ... ob2 ...) oc1 ... oc2 ...)
+ (lb1 ... lb2 ...)
+ (and ne1?1 ne1?2)
+ (let (ib1 ... ib2 ...) ic1 ... ic2 ...)
+ (and ne2?1 ne2?2)
+ (ls1 ... ls2 ...) )))
+
+ ; no more gens -> continue with cc, reentry at (*)
+ ((:parallel-1 (cc ...) () result)
+ (cc ... result) )))
+
+(define-syntax :while
+ (syntax-rules ()
+ ((:while cc (g arg1 arg ...) test)
+ (g (:while-1 cc test) arg1 arg ...) )))
+
+; (:while-1 cc test (:do ...))
+; modifies the fully decorated :do-generator such that it
+; runs while test is a true value.
+; The original implementation just replaced ne1? by
+; (and ne1? test) as follows:
+;
+; (define-syntax :while-1
+; (syntax-rules (:do)
+; ((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss))
+; (:do cc olet lbs (and ne1? test) ilet ne2? lss) )))
+;
+; Bug #1:
+; Unfortunately, this code is wrong because ne1? may depend
+; in the inner bindings introduced in ilet, but ne1? is evaluated
+; outside of the inner bindings. (Refer to the specification of
+; :do to see the structure.)
+; The problem manifests itself (as sunnan@handgranat.org
+; observed, 25-Apr-2005) when the :list-generator is modified:
+;
+; (do-ec (:while (:list x '(1 2)) (= x 1)) (display x)).
+;
+; In order to generate proper code, we introduce temporary
+; variables saving the values of the inner bindings. The inner
+; bindings are executed in a new ne1?, which also evaluates ne1?
+; outside the scope of the inner bindings, then the inner commands
+; are executed (possibly changing the variables), and then the
+; values of the inner bindings are saved and (and ne1? test) is
+; returned. In the new ilet, the inner variables are bound and
+; initialized and their values are restored. So we construct:
+;
+; (let (ob .. (ib-tmp #f) ...)
+; oc ...
+; (let loop (lb ...)
+; (if (let (ne1?-value ne1?)
+; (let ((ib-var ib-rhs) ...)
+; ic ...
+; (set! ib-tmp ib-var) ...)
+; (and ne1?-value test))
+; (let ((ib-var ib-tmp) ...)
+; /payload/
+; (if ne2?
+; (loop ls ...) )))))
+;
+; Bug #2:
+; Unfortunately, the above expansion is still incorrect (as Jens-Axel
+; Soegaard pointed out, 4-Jun-2007) because ib-rhs are evaluated even
+; if ne1?-value is #f, indicating that the loop has ended.
+; The problem manifests itself in the following example:
+;
+; (do-ec (:while (:list x '(1)) #t) (display x))
+;
+; Which iterates :list beyond exhausting the list '(1).
+;
+; For the fix, we follow Jens-Axel's approach of guarding the evaluation
+; of ib-rhs with a check on ne1?-value.
+
+(define-syntax :while-1
+ (syntax-rules (:do let)
+ ((:while-1 cc test (:do olet lbs ne1? ilet ne2? lss))
+ (:while-2 cc test () () () (:do olet lbs ne1? ilet ne2? lss)))))
+
+(define-syntax :while-2
+ (syntax-rules (:do let)
+ ((:while-2 cc
+ test
+ (ib-let ...)
+ (ib-save ...)
+ (ib-restore ...)
+ (:do olet
+ lbs
+ ne1?
+ (let ((ib-var ib-rhs) ib ...) ic ...)
+ ne2?
+ lss))
+ (:while-2 cc
+ test
+ (ib-let ... (ib-tmp #f))
+ (ib-save ... (ib-var ib-rhs))
+ (ib-restore ... (ib-var ib-tmp))
+ (:do olet
+ lbs
+ ne1?
+ (let (ib ...) ic ... (set! ib-tmp ib-var))
+ ne2?
+ lss)))
+ ((:while-2 cc
+ test
+ (ib-let ...)
+ (ib-save ...)
+ (ib-restore ...)
+ (:do (let (ob ...) oc ...) lbs ne1? (let () ic ...) ne2? lss))
+ (:do cc
+ (let (ob ... ib-let ...) oc ...)
+ lbs
+ (let ((ne1?-value ne1?))
+ (and ne1?-value
+ (let (ib-save ...)
+ ic ...
+ test)))
+ (let (ib-restore ...))
+ ne2?
+ lss))))
+
+
+(define-syntax :until
+ (syntax-rules ()
+ ((:until cc (g arg1 arg ...) test)
+ (g (:until-1 cc test) arg1 arg ...) )))
+
+(define-syntax :until-1
+ (syntax-rules (:do)
+ ((:until-1 cc test (:do olet lbs ne1? ilet ne2? lss))
+ (:do cc olet lbs ne1? ilet (and ne2? (not test)) lss) )))
+
+
+; ==========================================================================
+; The typed generators :list :string :vector etc.
+; ==========================================================================
+
+(define-syntax :list
+ (syntax-rules (index)
+ ((:list cc var (index i) arg ...)
+ (:parallel cc (:list var arg ...) (:integers i)) )
+ ((:list cc var arg1 arg2 arg ...)
+ (:list cc var (append arg1 arg2 arg ...)) )
+ ((:list cc var arg)
+ (:do cc
+ (let ())
+ ((t arg))
+ (not (null? t))
+ (let ((var (car t))))
+ #t
+ ((cdr t)) ))))
+
+
+(define-syntax :string
+ (syntax-rules (index)
+ ((:string cc var (index i) arg)
+ (:do cc
+ (let ((str arg) (len 0))
+ (set! len (string-length str)))
+ ((i 0))
+ (< i len)
+ (let ((var (string-ref str i))))
+ #t
+ ((+ i 1)) ))
+ ((:string cc var (index i) arg1 arg2 arg ...)
+ (:string cc var (index i) (string-append arg1 arg2 arg ...)) )
+ ((:string cc var arg1 arg ...)
+ (:string cc var (index i) arg1 arg ...) )))
+
+; Alternative: An implementation in the style of :vector can also
+; be used for :string. However, it is less interesting as the
+; overhead of string-append is much less than for 'vector-append'.
+
+
+(define-syntax :vector
+ (syntax-rules (index)
+ ((:vector cc var arg)
+ (:vector cc var (index i) arg) )
+ ((:vector cc var (index i) arg)
+ (:do cc
+ (let ((vec arg) (len 0))
+ (set! len (vector-length vec)))
+ ((i 0))
+ (< i len)
+ (let ((var (vector-ref vec i))))
+ #t
+ ((+ i 1)) ))
+
+ ((:vector cc var (index i) arg1 arg2 arg ...)
+ (:parallel cc (:vector cc var arg1 arg2 arg ...) (:integers i)) )
+ ((:vector cc var arg1 arg2 arg ...)
+ (:do cc
+ (let ((vec #f)
+ (len 0)
+ (vecs (ec-:vector-filter (list arg1 arg2 arg ...))) ))
+ ((k 0))
+ (if (< k len)
+ #t
+ (if (null? vecs)
+ #f
+ (begin (set! vec (car vecs))
+ (set! vecs (cdr vecs))
+ (set! len (vector-length vec))
+ (set! k 0)
+ #t )))
+ (let ((var (vector-ref vec k))))
+ #t
+ ((+ k 1)) ))))
+
+(define (ec-:vector-filter vecs)
+ (if (null? vecs)
+ '()
+ (if (zero? (vector-length (car vecs)))
+ (ec-:vector-filter (cdr vecs))
+ (cons (car vecs) (ec-:vector-filter (cdr vecs))) )))
+
+; Alternative: A simpler implementation for :vector uses vector->list
+; append and :list in the multi-argument case. Please refer to the
+; 'design.scm' for more details.
+
+
+(define-syntax :integers
+ (syntax-rules (index)
+ ((:integers cc var (index i))
+ (:do cc ((var 0) (i 0)) #t ((+ var 1) (+ i 1))) )
+ ((:integers cc var)
+ (:do cc ((var 0)) #t ((+ var 1))) )))
+
+
+(define-syntax :range
+ (syntax-rules (index)
+
+ ; handle index variable and add optional args
+ ((:range cc var (index i) arg1 arg ...)
+ (:parallel cc (:range var arg1 arg ...) (:integers i)) )
+ ((:range cc var arg1)
+ (:range cc var 0 arg1 1) )
+ ((:range cc var arg1 arg2)
+ (:range cc var arg1 arg2 1) )
+
+; special cases (partially evaluated by hand from general case)
+
+ ((:range cc var 0 arg2 1)
+ (:do cc
+ (let ((b arg2))
+ (if (not (and (integer? b) (exact? b)))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" 0 b 1 )))
+ ((var 0))
+ (< var b)
+ (let ())
+ #t
+ ((+ var 1)) ))
+
+ ((:range cc var 0 arg2 -1)
+ (:do cc
+ (let ((b arg2))
+ (if (not (and (integer? b) (exact? b)))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" 0 b 1 )))
+ ((var 0))
+ (> var b)
+ (let ())
+ #t
+ ((- var 1)) ))
+
+ ((:range cc var arg1 arg2 1)
+ (:do cc
+ (let ((a arg1) (b arg2))
+ (if (not (and (integer? a) (exact? a)
+ (integer? b) (exact? b) ))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" a b 1 )) )
+ ((var a))
+ (< var b)
+ (let ())
+ #t
+ ((+ var 1)) ))
+
+ ((:range cc var arg1 arg2 -1)
+ (:do cc
+ (let ((a arg1) (b arg2) (s -1) (stop 0))
+ (if (not (and (integer? a) (exact? a)
+ (integer? b) (exact? b) ))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" a b -1 )) )
+ ((var a))
+ (> var b)
+ (let ())
+ #t
+ ((- var 1)) ))
+
+; the general case
+
+ ((:range cc var arg1 arg2 arg3)
+ (:do cc
+ (let ((a arg1) (b arg2) (s arg3) (stop 0))
+ (if (not (and (integer? a) (exact? a)
+ (integer? b) (exact? b)
+ (integer? s) (exact? s) ))
+ (error
+ "arguments of :range are not exact integer "
+ "(use :real-range?)" a b s ))
+ (if (zero? s)
+ (error "step size must not be zero in :range") )
+ (set! stop (+ a (* (max 0 (ceiling (/ (- b a) s))) s))) )
+ ((var a))
+ (not (= var stop))
+ (let ())
+ #t
+ ((+ var s)) ))))
+
+; Comment: The macro :range inserts some code to make sure the values
+; are exact integers. This overhead has proven very helpful for
+; saving users from themselves.
+
+
+(define-syntax :real-range
+ (syntax-rules (index)
+
+ ; add optional args and index variable
+ ((:real-range cc var arg1)
+ (:real-range cc var (index i) 0 arg1 1) )
+ ((:real-range cc var (index i) arg1)
+ (:real-range cc var (index i) 0 arg1 1) )
+ ((:real-range cc var arg1 arg2)
+ (:real-range cc var (index i) arg1 arg2 1) )
+ ((:real-range cc var (index i) arg1 arg2)
+ (:real-range cc var (index i) arg1 arg2 1) )
+ ((:real-range cc var arg1 arg2 arg3)
+ (:real-range cc var (index i) arg1 arg2 arg3) )
+
+ ; the fully qualified case
+ ((:real-range cc var (index i) arg1 arg2 arg3)
+ (:do cc
+ (let ((a arg1) (b arg2) (s arg3) (istop 0))
+ (if (not (and (real? a) (real? b) (real? s)))
+ (error "arguments of :real-range are not real" a b s) )
+ (if (and (exact? a) (or (not (exact? b)) (not (exact? s))))
+ (set! a (exact->inexact a)) )
+ (set! istop (/ (- b a) s)) )
+ ((i 0))
+ (< i istop)
+ (let ((var (+ a (* s i)))))
+ #t
+ ((+ i 1)) ))))
+
+; Comment: The macro :real-range adapts the exactness of the start
+; value in case any of the other values is inexact. This is a
+; precaution to avoid (list-ec (: x 0 3.0) x) => '(0 1.0 2.0).
+
+
+(define-syntax :char-range
+ (syntax-rules (index)
+ ((:char-range cc var (index i) arg1 arg2)
+ (:parallel cc (:char-range var arg1 arg2) (:integers i)) )
+ ((:char-range cc var arg1 arg2)
+ (:do cc
+ (let ((imax (char->integer arg2))))
+ ((i (char->integer arg1)))
+ (<= i imax)
+ (let ((var (integer->char i))))
+ #t
+ ((+ i 1)) ))))
+
+; Warning: There is no R5RS-way to implement the :char-range generator
+; because the integers obtained by char->integer are not necessarily
+; consecutive. We simply assume this anyhow for illustration.
+
+
+(define-syntax :port
+ (syntax-rules (index)
+ ((:port cc var (index i) arg1 arg ...)
+ (:parallel cc (:port var arg1 arg ...) (:integers i)) )
+ ((:port cc var arg)
+ (:port cc var arg read) )
+ ((:port cc var arg1 arg2)
+ (:do cc
+ (let ((port arg1) (read-proc arg2)))
+ ((var (read-proc port)))
+ (not (eof-object? var))
+ (let ())
+ #t
+ ((read-proc port)) ))))
+
+
+; ==========================================================================
+; The typed generator :dispatched and utilities for constructing dispatchers
+; ==========================================================================
+
+(define-syntax :dispatched
+ (syntax-rules (index)
+ ((:dispatched cc var (index i) dispatch arg1 arg ...)
+ (:parallel cc
+ (:integers i)
+ (:dispatched var dispatch arg1 arg ...) ))
+ ((:dispatched cc var dispatch arg1 arg ...)
+ (:do cc
+ (let ((d dispatch)
+ (args (list arg1 arg ...))
+ (g #f)
+ (empty (list #f)) )
+ (set! g (d args))
+ (if (not (procedure? g))
+ (error "unrecognized arguments in dispatching"
+ args
+ (d '()) )))
+ ((var (g empty)))
+ (not (eq? var empty))
+ (let ())
+ #t
+ ((g empty)) ))))
+
+; Comment: The unique object empty is created as a newly allocated
+; non-empty list. It is compared using eq? which distinguishes
+; the object from any other object, according to R5RS 6.1.
+
+
+(define-syntax :generator-proc
+ (syntax-rules (:do let)
+
+ ; call g with a variable, reentry at (**)
+ ((:generator-proc (g arg ...))
+ (g (:generator-proc var) var arg ...) )
+
+ ; reentry point (**) -> make the code from a single :do
+ ((:generator-proc
+ var
+ (:do (let obs oc ...)
+ ((lv li) ...)
+ ne1?
+ (let ((i v) ...) ic ...)
+ ne2?
+ (ls ...)) )
+ (ec-simplify
+ (let obs
+ oc ...
+ (let ((lv li) ... (ne2 #t))
+ (ec-simplify
+ (let ((i #f) ...) ; v not yet valid
+ (lambda (empty)
+ (if (and ne1? ne2)
+ (ec-simplify
+ (begin
+ (set! i v) ...
+ ic ...
+ (let ((value var))
+ (ec-simplify
+ (if ne2?
+ (ec-simplify
+ (begin (set! lv ls) ...) )
+ (set! ne2 #f) ))
+ value )))
+ empty ))))))))
+
+ ; silence warnings of some macro expanders
+ ((:generator-proc var)
+ (error "illegal macro call") )))
+
+
+(define (dispatch-union d1 d2)
+ (lambda (args)
+ (let ((g1 (d1 args)) (g2 (d2 args)))
+ (if g1
+ (if g2
+ (if (null? args)
+ (append (if (list? g1) g1 (list g1))
+ (if (list? g2) g2 (list g2)) )
+ (error "dispatching conflict" args (d1 '()) (d2 '())) )
+ g1 )
+ (if g2 g2 #f) ))))
+
+
+; ==========================================================================
+; The dispatching generator :
+; ==========================================================================
+
+(define (make-initial-:-dispatch)
+ (lambda (args)
+ (case (length args)
+ ((0) 'SRFI42)
+ ((1) (let ((a1 (car args)))
+ (cond
+ ((list? a1)
+ (:generator-proc (:list a1)) )
+ ((string? a1)
+ (:generator-proc (:string a1)) )
+ ((vector? a1)
+ (:generator-proc (:vector a1)) )
+ ((and (integer? a1) (exact? a1))
+ (:generator-proc (:range a1)) )
+ ((real? a1)
+ (:generator-proc (:real-range a1)) )
+ ((input-port? a1)
+ (:generator-proc (:port a1)) )
+ (else
+ #f ))))
+ ((2) (let ((a1 (car args)) (a2 (cadr args)))
+ (cond
+ ((and (list? a1) (list? a2))
+ (:generator-proc (:list a1 a2)) )
+ ((and (string? a1) (string? a1))
+ (:generator-proc (:string a1 a2)) )
+ ((and (vector? a1) (vector? a2))
+ (:generator-proc (:vector a1 a2)) )
+ ((and (integer? a1) (exact? a1) (integer? a2) (exact? a2))
+ (:generator-proc (:range a1 a2)) )
+ ((and (real? a1) (real? a2))
+ (:generator-proc (:real-range a1 a2)) )
+ ((and (char? a1) (char? a2))
+ (:generator-proc (:char-range a1 a2)) )
+ ((and (input-port? a1) (procedure? a2))
+ (:generator-proc (:port a1 a2)) )
+ (else
+ #f ))))
+ ((3) (let ((a1 (car args)) (a2 (cadr args)) (a3 (caddr args)))
+ (cond
+ ((and (list? a1) (list? a2) (list? a3))
+ (:generator-proc (:list a1 a2 a3)) )
+ ((and (string? a1) (string? a1) (string? a3))
+ (:generator-proc (:string a1 a2 a3)) )
+ ((and (vector? a1) (vector? a2) (vector? a3))
+ (:generator-proc (:vector a1 a2 a3)) )
+ ((and (integer? a1) (exact? a1)
+ (integer? a2) (exact? a2)
+ (integer? a3) (exact? a3))
+ (:generator-proc (:range a1 a2 a3)) )
+ ((and (real? a1) (real? a2) (real? a3))
+ (:generator-proc (:real-range a1 a2 a3)) )
+ (else
+ #f ))))
+ (else
+ (letrec ((every?
+ (lambda (pred args)
+ (if (null? args)
+ #t
+ (and (pred (car args))
+ (every? pred (cdr args)) )))))
+ (cond
+ ((every? list? args)
+ (:generator-proc (:list (apply append args))) )
+ ((every? string? args)
+ (:generator-proc (:string (apply string-append args))) )
+ ((every? vector? args)
+ (:generator-proc (:list (apply append (map vector->list args)))) )
+ (else
+ #f )))))))
+
+(define :-dispatch
+ (make-initial-:-dispatch) )
+
+(define (:-dispatch-ref)
+ :-dispatch )
+
+(define (:-dispatch-set! dispatch)
+ (if (not (procedure? dispatch))
+ (error "not a procedure" dispatch) )
+ (set! :-dispatch dispatch) )
+
+(define-syntax :
+ (syntax-rules (index)
+ ((: cc var (index i) arg1 arg ...)
+ (:dispatched cc var (index i) :-dispatch arg1 arg ...) )
+ ((: cc var arg1 arg ...)
+ (:dispatched cc var :-dispatch arg1 arg ...) )))
+
+
+; ==========================================================================
+; The utility comprehensions fold-ec, fold3-ec
+; ==========================================================================
+
+(define-syntax fold3-ec
+ (syntax-rules (nested)
+ ((fold3-ec x0 (nested q1 ...) q etc1 etc2 etc3 etc ...)
+ (fold3-ec x0 (nested q1 ... q) etc1 etc2 etc3 etc ...) )
+ ((fold3-ec x0 q1 q2 etc1 etc2 etc3 etc ...)
+ (fold3-ec x0 (nested q1 q2) etc1 etc2 etc3 etc ...) )
+ ((fold3-ec x0 expression f1 f2)
+ (fold3-ec x0 (nested) expression f1 f2) )
+
+ ((fold3-ec x0 qualifier expression f1 f2)
+ (let ((result #f) (empty #t))
+ (do-ec qualifier
+ (let ((value expression)) ; don't duplicate
+ (if empty
+ (begin (set! result (f1 value))
+ (set! empty #f) )
+ (set! result (f2 value result)) )))
+ (if empty x0 result) ))))
+
+
+(define-syntax fold-ec
+ (syntax-rules (nested)
+ ((fold-ec x0 (nested q1 ...) q etc1 etc2 etc ...)
+ (fold-ec x0 (nested q1 ... q) etc1 etc2 etc ...) )
+ ((fold-ec x0 q1 q2 etc1 etc2 etc ...)
+ (fold-ec x0 (nested q1 q2) etc1 etc2 etc ...) )
+ ((fold-ec x0 expression f2)
+ (fold-ec x0 (nested) expression f2) )
+
+ ((fold-ec x0 qualifier expression f2)
+ (let ((result x0))
+ (do-ec qualifier (set! result (f2 expression result)))
+ result ))))
+
+
+; ==========================================================================
+; The comprehensions list-ec string-ec vector-ec etc.
+; ==========================================================================
+
+(define-syntax list-ec
+ (syntax-rules ()
+ ((list-ec etc1 etc ...)
+ (reverse (fold-ec '() etc1 etc ... cons)) )))
+
+; Alternative: Reverse can safely be replaced by reverse! if you have it.
+;
+; Alternative: It is possible to construct the result in the correct order
+; using set-cdr! to add at the tail. This removes the overhead of copying
+; at the end, at the cost of more book-keeping.
+
+
+(define-syntax append-ec
+ (syntax-rules ()
+ ((append-ec etc1 etc ...)
+ (apply append (list-ec etc1 etc ...)) )))
+
+(define-syntax string-ec
+ (syntax-rules ()
+ ((string-ec etc1 etc ...)
+ (list->string (list-ec etc1 etc ...)) )))
+
+; Alternative: For very long strings, the intermediate list may be a
+; problem. A more space-aware implementation collect the characters
+; in an intermediate list and when this list becomes too large it is
+; converted into an intermediate string. At the end, the intermediate
+; strings are concatenated with string-append.
+
+
+(define-syntax string-append-ec
+ (syntax-rules ()
+ ((string-append-ec etc1 etc ...)
+ (apply string-append (list-ec etc1 etc ...)) )))
+
+(define-syntax vector-ec
+ (syntax-rules ()
+ ((vector-ec etc1 etc ...)
+ (list->vector (list-ec etc1 etc ...)) )))
+
+; Comment: A similar approach as for string-ec can be used for vector-ec.
+; However, the space overhead for the intermediate list is much lower
+; than for string-ec and as there is no vector-append, the intermediate
+; vectors must be copied explicitly.
+
+(define-syntax vector-of-length-ec
+ (syntax-rules (nested)
+ ((vector-of-length-ec k (nested q1 ...) q etc1 etc ...)
+ (vector-of-length-ec k (nested q1 ... q) etc1 etc ...) )
+ ((vector-of-length-ec k q1 q2 etc1 etc ...)
+ (vector-of-length-ec k (nested q1 q2) etc1 etc ...) )
+ ((vector-of-length-ec k expression)
+ (vector-of-length-ec k (nested) expression) )
+
+ ((vector-of-length-ec k qualifier expression)
+ (let ((len k))
+ (let ((vec (make-vector len))
+ (i 0) )
+ (do-ec qualifier
+ (if (< i len)
+ (begin (vector-set! vec i expression)
+ (set! i (+ i 1)) )
+ (error "vector is too short for the comprehension") ))
+ (if (= i len)
+ vec
+ (error "vector is too long for the comprehension") ))))))
+
+
+(define-syntax sum-ec
+ (syntax-rules ()
+ ((sum-ec etc1 etc ...)
+ (fold-ec (+) etc1 etc ... +) )))
+
+(define-syntax product-ec
+ (syntax-rules ()
+ ((product-ec etc1 etc ...)
+ (fold-ec (*) etc1 etc ... *) )))
+
+(define-syntax min-ec
+ (syntax-rules ()
+ ((min-ec etc1 etc ...)
+ (fold3-ec (min) etc1 etc ... min min) )))
+
+(define-syntax max-ec
+ (syntax-rules ()
+ ((max-ec etc1 etc ...)
+ (fold3-ec (max) etc1 etc ... max max) )))
+
+(define-syntax last-ec
+ (syntax-rules (nested)
+ ((last-ec default (nested q1 ...) q etc1 etc ...)
+ (last-ec default (nested q1 ... q) etc1 etc ...) )
+ ((last-ec default q1 q2 etc1 etc ...)
+ (last-ec default (nested q1 q2) etc1 etc ...) )
+ ((last-ec default expression)
+ (last-ec default (nested) expression) )
+
+ ((last-ec default qualifier expression)
+ (let ((result default))
+ (do-ec qualifier (set! result expression))
+ result ))))
+
+
+; ==========================================================================
+; The fundamental early-stopping comprehension first-ec
+; ==========================================================================
+
+(define-syntax first-ec
+ (syntax-rules (nested)
+ ((first-ec default (nested q1 ...) q etc1 etc ...)
+ (first-ec default (nested q1 ... q) etc1 etc ...) )
+ ((first-ec default q1 q2 etc1 etc ...)
+ (first-ec default (nested q1 q2) etc1 etc ...) )
+ ((first-ec default expression)
+ (first-ec default (nested) expression) )
+
+ ((first-ec default qualifier expression)
+ (let ((result default) (stop #f))
+ (ec-guarded-do-ec
+ stop
+ (nested qualifier)
+ (begin (set! result expression)
+ (set! stop #t) ))
+ result ))))
+
+; (ec-guarded-do-ec stop (nested q ...) cmd)
+; constructs (do-ec q ... cmd) where the generators gen in q ... are
+; replaced by (:until gen stop).
+
+(define-syntax ec-guarded-do-ec
+ (syntax-rules (nested if not and or begin)
+
+ ((ec-guarded-do-ec stop (nested (nested q1 ...) q2 ...) cmd)
+ (ec-guarded-do-ec stop (nested q1 ... q2 ...) cmd) )
+
+ ((ec-guarded-do-ec stop (nested (if test) q ...) cmd)
+ (if test (ec-guarded-do-ec stop (nested q ...) cmd)) )
+ ((ec-guarded-do-ec stop (nested (not test) q ...) cmd)
+ (if (not test) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+ ((ec-guarded-do-ec stop (nested (and test ...) q ...) cmd)
+ (if (and test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+ ((ec-guarded-do-ec stop (nested (or test ...) q ...) cmd)
+ (if (or test ...) (ec-guarded-do-ec stop (nested q ...) cmd)) )
+
+ ((ec-guarded-do-ec stop (nested (begin etc ...) q ...) cmd)
+ (begin etc ... (ec-guarded-do-ec stop (nested q ...) cmd)) )
+
+ ((ec-guarded-do-ec stop (nested gen q ...) cmd)
+ (do-ec
+ (:until gen stop)
+ (ec-guarded-do-ec stop (nested q ...) cmd) ))
+
+ ((ec-guarded-do-ec stop (nested) cmd)
+ (do-ec cmd) )))
+
+; Alternative: Instead of modifying the generator with :until, it is
+; possible to use call-with-current-continuation:
+;
+; (define-synatx first-ec
+; ...same as above...
+; ((first-ec default qualifier expression)
+; (call-with-current-continuation
+; (lambda (cc)
+; (do-ec qualifier (cc expression))
+; default ))) ))
+;
+; This is much simpler but not necessarily as efficient.
+
+
+; ==========================================================================
+; The early-stopping comprehensions any?-ec every?-ec
+; ==========================================================================
+
+(define-syntax any?-ec
+ (syntax-rules (nested)
+ ((any?-ec (nested q1 ...) q etc1 etc ...)
+ (any?-ec (nested q1 ... q) etc1 etc ...) )
+ ((any?-ec q1 q2 etc1 etc ...)
+ (any?-ec (nested q1 q2) etc1 etc ...) )
+ ((any?-ec expression)
+ (any?-ec (nested) expression) )
+
+ ((any?-ec qualifier expression)
+ (first-ec #f qualifier (if expression) #t) )))
+
+(define-syntax every?-ec
+ (syntax-rules (nested)
+ ((every?-ec (nested q1 ...) q etc1 etc ...)
+ (every?-ec (nested q1 ... q) etc1 etc ...) )
+ ((every?-ec q1 q2 etc1 etc ...)
+ (every?-ec (nested q1 q2) etc1 etc ...) )
+ ((every?-ec expression)
+ (every?-ec (nested) expression) )
+
+ ((every?-ec qualifier expression)
+ (first-ec #t qualifier (if (not expression)) #f) )))
+
+
+)
diff --git a/tests/embedded1.c b/tests/embedded1.c
new file mode 100644
index 00000000..6ef6d688
--- /dev/null
+++ b/tests/embedded1.c
@@ -0,0 +1,10 @@
+#include <stdio.h>
+#include <stdlib.h>
+#include <chicken.h>
+
+int main()
+{
+ CHICKEN_run((void*)CHICKEN_default_toplevel);
+
+ return 0;
+}
diff --git a/tests/embedded2.scm b/tests/embedded2.scm
new file mode 100644
index 00000000..c5629da8
--- /dev/null
+++ b/tests/embedded2.scm
@@ -0,0 +1,29 @@
+(use extras)
+
+#>
+#include <assert.h>
+
+int main()
+{
+ static char buffer[ 4096 ];
+
+ void C_toplevel(C_word x, C_word y, C_word z);
+
+ CHICKEN_run((void*)C_toplevel);
+ assert(CHICKEN_eval_string_to_string("(oink (make-vector 10 'ok))",
+ buffer, sizeof(buffer)));
+ printf("--> %s\n", buffer);
+ return 0;
+}
+<#
+
+
+(##sys#fudge 36)
+(gc)
+(print "starting...")
+
+(define (oink x)
+ (pp x)
+ (vector-length x))
+
+(return-to-host)
diff --git a/tests/feeley-dynwind.scm b/tests/feeley-dynwind.scm
new file mode 100644
index 00000000..fd103ec9
--- /dev/null
+++ b/tests/feeley-dynwind.scm
@@ -0,0 +1,71 @@
+;;; by Marc Feeley
+;
+; This fails. Currently to heavy stuff to debug
+
+(use srfi-18)
+
+(define (dw tag thunk)
+ (dynamic-wind
+ (lambda () (pp (list 'before tag (current-thread))))
+ thunk
+ (lambda () (pp (list 'after tag (current-thread))))))
+
+(define c1 #f)
+(define c2 #f)
+(define c3 #f)
+(define c4 #f)
+
+(define (f)
+ (call/cc
+ (lambda (k1)
+ (set! c1 k1)
+ (dw 111
+ (lambda ()
+ (call/cc
+ (lambda (k2)
+ (set! c2 k2)
+ (dw 222
+ (lambda ()
+ (call/cc
+ (lambda (k3)
+ (set! c3 k3)
+ (dw 333
+ (lambda ()
+ (call/cc
+ (lambda (k4)
+ (set! c4 k4)
+; (xxx) ;; error
+ (pp 'inner)))))))))))))))
+ (pp (list 'done (current-thread))))
+
+(thread-join!
+ (thread-start!
+ (make-thread (lambda () (f)))))
+
+(thread-join!
+ (thread-start!
+ (make-thread (lambda () (c4 'dummy)))))
+
+(thread-join!
+ (thread-start!
+ (make-thread (lambda () (c1 'dummy)))))
+
+
+;; expected result:
+
+;; (before 111 #<thread #2>)
+;; (before 222 #<thread #2>)
+;; (before 333 #<thread #2>)
+;; inner
+;; (after 333 #<thread #2>)
+;; (after 222 #<thread #2>)
+;; (after 111 #<thread #2>)
+;; (done #<thread #2>)
+;; (before 111 #<thread #3>)
+;; (before 222 #<thread #3>)
+;; (before 333 #<thread #3>)
+;; (after 333 #<thread #3>)
+;; (after 222 #<thread #3>)
+;; (after 111 #<thread #3>)
+;; (done #<thread #3>)
+;; (done #<thread #4>)
diff --git a/tests/fixnum-tests.scm b/tests/fixnum-tests.scm
new file mode 100644
index 00000000..faf18b6d
--- /dev/null
+++ b/tests/fixnum-tests.scm
@@ -0,0 +1,12 @@
+(define (fxo+ x y) (##core#inline "C_i_o_fixnum_plus" x y))
+(define (fxo- x y) (##core#inline "C_i_o_fixnum_difference" x y))
+
+(assert (= 4 (fxo+ 2 2)))
+(assert (= -26 (fxo+ 74 -100)))
+(assert (= 1073741823 (fxo+ #x3ffffffe 1)))
+(assert (not (fxo+ #x3fffffff 1)))
+(assert (= 4 (fxo- 6 2)))
+(assert (= -4 (fxo- 1000 1004)))
+(assert (= 2004 (fxo- 1000 -1004)))
+(assert (= -1073741824 (fxo- (- #x3fffffff) 1)))
+(assert (not (fxo- (- #x3fffffff) 2)))
diff --git a/tests/hash-table-tests.scm b/tests/hash-table-tests.scm
new file mode 100644
index 00000000..8f0f62be
--- /dev/null
+++ b/tests/hash-table-tests.scm
@@ -0,0 +1,146 @@
+;;;; hash-table-tests.scm
+
+(require-extension srfi-69)
+
+(print "SRFI 69 procedures")
+(assert (eq? hash equal?-hash))
+(assert (eq? hash-by-identity eq?-hash))
+
+;; Re-use variable
+(define ht)
+
+(print "HT - No Parameters")
+(set! ht (make-hash-table))
+(assert (hash-table? ht))
+(assert (eq? equal? (hash-table-equivalence-function ht)))
+(assert (eq? equal?-hash (hash-table-hash-function ht)))
+(assert (not (hash-table-has-initial? ht)))
+
+(print "HT - Test Parameter")
+(set! ht (make-hash-table eq?))
+(assert (hash-table? ht))
+(assert (eq? eq? (hash-table-equivalence-function ht)))
+(assert (eq? eq?-hash (hash-table-hash-function ht)))
+(assert (not (hash-table-has-initial? ht)))
+
+(print "HT - Number Test Parameter")
+(set! ht (make-hash-table =))
+(assert (hash-table? ht))
+(assert (eq? = (hash-table-equivalence-function ht)))
+(assert (eq? number-hash (hash-table-hash-function ht)))
+(assert (not (hash-table-has-initial? ht)))
+
+(print "HT - All Optional Parameters")
+(set! ht (make-hash-table eqv? eqv?-hash 23))
+(assert (hash-table? ht))
+(assert (not (hash-table-has-initial? ht)))
+
+(print "HT - All Parameters")
+(set! ht (make-hash-table eqv? eqv?-hash 23
+ #:test equal? #:hash equal?-hash
+ #:initial 'foo
+ #:size 500
+ #:min-load 0.45 #:max-load 0.85
+ #:weak-keys #t #:weak-values #t))
+(assert (hash-table? ht))
+(assert (not (hash-table-weak-keys ht)))
+(assert (not (hash-table-weak-values ht)))
+(assert (eq? equal? (hash-table-equivalence-function ht)))
+(assert (eq? equal?-hash (hash-table-hash-function ht)))
+(assert (hash-table-has-initial? ht))
+(assert (eq? (hash-table-initial ht) 'foo))
+
+(print "HT - Insert with setter")
+(set! (hash-table-ref ht 23.0) 'bar)
+(assert (eq? (hash-table-ref ht 23.0) 'bar))
+
+(print "HT - Insert with update!")
+(hash-table-update! ht 'baz)
+(assert (eq? (hash-table-ref ht 'baz) 'foo))
+(assert (= (hash-table-size ht) 2))
+
+(print "HT - A-List")
+(let ([alist (hash-table->alist ht)])
+ (assert (list? alist))
+ (assert (= (length alist) 2))
+ (assert (eq? (alist-ref 23.0 alist) 'bar))
+ (assert (eq? (alist-ref 'baz alist) 'foo)) )
+
+(print "HT - set! overwrites")
+(hash-table-set! ht 23.0 'foo-bar)
+(assert (eq? (hash-table-ref ht 23.0) 'foo-bar))
+
+(print "HT - Delete")
+(assert (hash-table-delete! ht 23.0))
+(assert (not (hash-table-exists? ht 23.0)))
+(assert (= (hash-table-size ht) 1))
+
+(print "HT - Remove")
+(assert (hash-table-remove! ht (lambda (k v) (eq? k 'baz))))
+(assert (not (hash-table-exists? ht 'baz)))
+(assert (= (hash-table-size ht) 0))
+
+(print "HT - Make from A-List")
+(set! ht (alist->hash-table '(("abc" . #t) ("cbs" . #t) ("cnn" . #f))))
+(assert (hash-table? ht))
+(assert (= (hash-table-size ht) 3))
+
+(print "HT - Merge!")
+(let ([ht2 (make-hash-table)])
+ (set! (hash-table-ref ht2 23.0) 'bar)
+ (set! (hash-table-ref ht2 'baz) 'foo)
+ (let ([ht3 (hash-table-merge! ht2 ht)])
+ (assert (eq? ht3 ht2))
+ (assert (not (eq? ht3 ht)))
+ (let ([alist (hash-table->alist ht3)])
+ (assert (list? alist))
+ (assert (= (length alist) 5))
+ (assert (eq? (alist-ref "abc" alist equal?) #t))
+ (assert (eq? (alist-ref "cbs" alist equal?) #t))
+ (assert (eq? (alist-ref "cnn" alist equal?) #f))
+ (assert (eq? (alist-ref 23.0 alist) 'bar))
+ (assert (eq? (alist-ref 'baz alist) 'foo)) ) ) )
+
+(print "HT - Merge")
+(let ([ht2 (make-hash-table)])
+ (set! (hash-table-ref ht2 23.0) 'bar)
+ (set! (hash-table-ref ht2 'baz) 'foo)
+ (let ([ht3 (hash-table-merge ht2 ht)])
+ (assert (not (eq? ht3 ht2)))
+ (assert (not (eq? ht3 ht)))
+ (let ([alist (hash-table->alist ht3)])
+ (assert (list? alist))
+ (assert (= (length alist) 5))
+ (assert (eq? (alist-ref "abc" alist equal?) #t))
+ (assert (eq? (alist-ref "cbs" alist equal?) #t))
+ (assert (eq? (alist-ref "cnn" alist equal?) #f))
+ (assert (eq? (alist-ref 23.0 alist) 'bar))
+ (assert (eq? (alist-ref 'baz alist) 'foo)) ) ) )
+
+(print "HT - Map")
+(let ([alist (hash-table-map ht (lambda (k v) (cons k v)))])
+ (assert (list? alist))
+ (assert (= (length alist) 3)) )
+
+(print "HT - Fold")
+(let ([alist (hash-table-fold ht (lambda (k v a) (cons (cons k v) a)) '())])
+ (assert (list? alist))
+ (assert (= (length alist) 3)) )
+
+;; Stress Test
+
+(set! ht (make-hash-table))
+
+(define-constant stress-size 100000)
+
+(print "HT - Stress Insert " stress-size " Fixnum Key Items")
+(time
+ (do ([i 0 (fx+ i 1)])
+ [(fx= i stress-size)]
+ (set! (hash-table-ref ht i) i) ) )
+
+(print "HT - Stress Retrieve " stress-size " Fixnum Key Items")
+(time
+ (do ([i 0 (fx+ i 1)])
+ [(fx= i stress-size)]
+ (assert (fx= i (hash-table-ref ht i))) ) )
diff --git a/tests/import-library-test1.scm b/tests/import-library-test1.scm
new file mode 100644
index 00000000..f0c51381
--- /dev/null
+++ b/tests/import-library-test1.scm
@@ -0,0 +1,9 @@
+(module foo (foo xcase)
+ (import (rename scheme (case xcase)))
+ (define-syntax foo
+ (syntax-rules ()
+ ((_) (bar))))
+ (define-syntax bar
+ (syntax-rules ()
+ ((_) (list 123)))))
+
diff --git a/tests/import-library-test2.scm b/tests/import-library-test2.scm
new file mode 100644
index 00000000..e0c3b2b0
--- /dev/null
+++ b/tests/import-library-test2.scm
@@ -0,0 +1,9 @@
+(require-library import-library-test1)
+
+(module bar (xcase)
+ (import scheme chicken extras foo)
+ (assert (equal? '(123) (foo)))
+ (assert (= 2 (xcase 1 ((1) 2)))))
+
+(import bar)
+(assert (= 2 (xcase 1 ((1) 2))))
diff --git a/tests/inlining-tests.scm b/tests/inlining-tests.scm
new file mode 100644
index 00000000..7080d476
--- /dev/null
+++ b/tests/inlining-tests.scm
@@ -0,0 +1,27 @@
+;;;; inlining-tests.scm - test inlining
+
+
+;;; SVN rev. 15495: local assignment did not mark lexical as "captured"
+
+(define (foo n)
+ (let ((r #f))
+ (for-each
+ (lambda (m)
+ (case m
+ ((abc) (set! r #t))
+ ((def) (set! r 'ok))
+ ((xyz) (set! r 'yo))))
+ n)
+ r))
+
+(assert (eq? #t (foo '(abc))))
+
+
+;;; SVN rev. 15511: multiple assignments didn't make global variable unknown for local inlining
+
+(define (bar)
+ (set! foo (lambda () 1)))
+
+(define (foo) 0)
+(bar)
+(assert (= 1 (foo)))
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
new file mode 100644
index 00000000..9055fe44
--- /dev/null
+++ b/tests/library-tests.scm
@@ -0,0 +1,14 @@
+(assert (= -4.0 (round -4.3)))
+(assert (= 4.0 (round 3.5)))
+(assert (= 4 (round (string->number "7/2"))))
+(assert (= 7 (round 7)))
+(assert (zero? (round -0.5))) ; is actually -0.0
+(assert (zero? (round -0.3)))
+(assert (= -1 (round -0.6)))
+(assert (zero? (round 0.5)))
+(assert (zero? (round 0.3)))
+(assert (= 1.0 (round 0.6)))
+(assert (rational? 1))
+(assert (rational? 1.0))
+(assert (not (rational? +inf.)))
+(assert (not (rational? 'foo)))
diff --git a/tests/locative-stress-test.scm b/tests/locative-stress-test.scm
new file mode 100644
index 00000000..baae4857
--- /dev/null
+++ b/tests/locative-stress-test.scm
@@ -0,0 +1,50 @@
+;;; locative-stress-test.scm - by Kon Lovett
+
+(declare (usual-integrations))
+
+;(set-gc-report! #t)
+
+(require-extension srfi-1)
+#>
+long *ptrs[10];
+
+//#define check(n) ptrs[n] = o##n; if(!C_in_stackp((C_word)o##n) && !C_in_fromspacep((C_word)o##n)) C_dbg_hook(0);
+#define check(n)
+
+long fill_10(long i, long *o0, long *o1, long *o2, long *o3, long *o4,
+ long *o5, long *o6, long *o7, long *o8, long *o9)
+{
+ check(0)
+ check(1)
+ check(2)
+ check(3)
+ check(4)
+ check(5)
+ check(6)
+ check(7)
+ check(8)
+ check(9)
+ *o0=*o1=*o2=*o3=*o4=*o5=*o6=*o7=*o8=*o9=i;
+ return i;
+}
+<#
+
+(define fill-10!
+ (foreign-lambda long "fill_10" long
+ (c-pointer long) (c-pointer long) (c-pointer long)
+ (c-pointer long) (c-pointer long) (c-pointer long)
+ (c-pointer long) (c-pointer long) (c-pointer long)
+ (c-pointer long)))
+
+(let* ((el 1)
+ (expected (make-list 10 el)))
+ (let loop
+ ((i (string->number (optional (command-line-arguments) "100000"))))
+ (unless (eq? i 0)
+ (let-location ((o0 long) (o1 long) (o2 long) (o3 long) (o4 long)
+ (o5 long) (o6 long) (o7 long) (o8 long) (o9 long))
+ (fill-10! el #$o0 #$o1 #$o2 #$o3 #$o4 #$o5 #$o6 #$o7 #$o8 #$o9)
+ (let ((result (list o0 o1 o2 o3 o4 o5 o6 o7 o8 o9)))
+ (if (not (equal? result expected))
+ (error "strange values: " result)
+ (loop (fx- i 1))))))))
diff --git a/tests/lolevel-tests.scm b/tests/lolevel-tests.scm
new file mode 100644
index 00000000..96d93574
--- /dev/null
+++ b/tests/lolevel-tests.scm
@@ -0,0 +1,289 @@
+;;;; Unit lolevel testing
+
+(require-extension lolevel)
+
+; move-memory!
+
+; object-copy
+
+; allocate
+
+(define some-chunk (allocate 23))
+
+(assert some-chunk)
+
+; free
+
+(free some-chunk)
+
+(define some-chunk (allocate 23))
+
+; pointer?
+
+(assert (pointer? some-chunk))
+
+; pointer-like?
+
+(assert (pointer-like? some-chunk))
+
+(assert (pointer-like? allocate))
+
+; address->pointer
+
+; pointer->address
+
+; null-pointer
+
+; null-pointer?
+
+(assert (null-pointer? (null-pointer)))
+(assert (null-pointer? (address->pointer #x0)))
+
+; object->pointer
+
+; pointer->object
+
+; pointer=?
+
+(assert (pointer=? some-chunk (address->pointer (pointer->address some-chunk))))
+
+; pointer-offset
+
+(assert (pointer=? (address->pointer #x9) (pointer-offset (address->pointer #x5) #x4)))
+
+; align-to-word
+
+; pointer-u8-set!
+
+; pointer-s8-set!
+
+; pointer-u16-set!
+
+; pointer-s16-set!
+
+; pointer-u32-set!
+
+; pointer-s32-set!
+
+; pointer-f32-set!
+
+; pointer-f64-set!
+
+; pointer-u8-ref
+
+(set! (pointer-u8-ref some-chunk) 255)
+
+(assert (= 255 (pointer-u8-ref some-chunk)))
+
+; pointer-s8-ref
+
+(set! (pointer-s8-ref some-chunk) -1)
+
+(assert (= -1 (pointer-s8-ref some-chunk)))
+
+; pointer-u16-ref
+
+; pointer-s16-ref
+
+; pointer-u32-ref
+
+; pointer-s32-ref
+
+; pointer-f32-ref
+
+; pointer-f64-ref
+
+; tag-pointer
+
+(define some-unique-tag '#(vector foo bar))
+
+(define some-tagged-pointer (tag-pointer some-chunk some-unique-tag))
+
+(assert some-tagged-pointer)
+
+; tagged-pointer?
+
+(assert (tagged-pointer? some-tagged-pointer))
+
+(assert (tagged-pointer? some-tagged-pointer some-unique-tag))
+
+; pointer-tag
+
+(assert (eq? some-unique-tag (pointer-tag some-tagged-pointer)))
+
+; make-locative
+
+; make-weak-locative
+
+; locative-set!
+
+; locative-ref
+
+; locative->object
+
+; locative?
+
+; extend-procedure
+
+(define (foo a b) (list a b))
+
+(define unique-proc-data-1 '(23 'skidoo))
+
+(define new-foo (extend-procedure foo unique-proc-data-1))
+
+(assert (not (eq? foo new-foo)))
+
+(define foo new-foo)
+
+; extended-procedure?
+
+(assert (extended-procedure? foo))
+
+; procedure-data
+
+(assert (eq? unique-proc-data-1 (procedure-data foo)))
+
+; set-procedure-data!
+
+(define unique-proc-data-2 '(23 'skidoo))
+
+(assert (eq? foo (set-procedure-data! foo unique-proc-data-2)))
+
+(assert (eq? unique-proc-data-2 (procedure-data foo)))
+
+; block-set!
+
+(define some-block (vector 1 2 3 4))
+
+(block-set! some-block 2 5)
+
+; block-ref
+
+(assert (= 5 (block-ref some-block 2)))
+
+; number-of-slots
+
+(assert (= 4 (number-of-slots some-block)))
+
+; number-of-bytes
+
+(assert (= 4 (number-of-bytes "abcd")))
+
+(assert (= (if (##sys#fudge 3) 8 4) (number-of-bytes '#(1))))
+
+; make-record-instance
+
+(define some-record (make-record-instance 'test 'a 1))
+
+(assert some-record)
+
+; record-instance?
+
+(assert (record-instance? some-record))
+
+(assert (record-instance? some-record 'test))
+
+; record-instance-type
+
+(assert (eq? 'test (record-instance-type some-record)))
+
+; record-instance-length
+
+(assert (= 2 (record-instance-length some-record)))
+
+; record-instance-slot-set!
+
+; record-instance-slot
+
+(assert (eq? 1 (record-instance-slot some-record 1)))
+
+(record-instance-slot-set! some-record 1 'b)
+
+(assert (eq? 'b (record-instance-slot some-record 1)))
+
+; record->vector
+
+(assert (equal? '#(test a b) (record->vector some-record)))
+
+; object-evict
+; object-evicted?
+; object-size
+; object-release
+
+(define tstvec (vector #f))
+(let ((sz (object-size tstvec)))
+ (assert (and (integer? sz) (positive? sz))) )
+(define ev-tstvec (object-evict tstvec))
+(assert (not (eq? tstvec ev-tstvec)))
+(assert (object-evicted? ev-tstvec))
+(object-release ev-tstvec)
+
+; object-evict-to-location
+
+; object-unevict
+
+; global-ref
+
+(assert (pointer? (global-ref 'some-chunk)))
+
+; global-set!
+
+(global-set! 'some-chunk 34)
+
+(assert (not (pointer? (global-ref 'some-chunk))))
+
+(assert (atom? (global-ref 'some-chunk)))
+
+; global-bound?
+
+(assert (global-bound? 'some-chunk))
+
+; global-make-unbound!
+
+(global-make-unbound! 'some-chunk)
+
+(assert (not (global-bound? 'some-chunk)))
+
+; object-become!
+
+(define some-foo '#(1 2 3))
+
+(define some-bar '(1 2 3))
+
+(object-become! (list (cons some-foo '(1 2 3)) (cons some-bar '#(1 2 3))))
+
+(assert (pair? some-foo))
+
+(assert (vector? some-bar))
+
+; mutate-procedure
+
+(assert (equal? '(1 2) (foo 1 2)))
+
+(define new-foo (mutate-procedure foo (lambda (new) (lambda args (cons 'hello (apply new args))))))
+
+(assert (not (eq? foo new-foo)))
+
+(assert (equal? '(hello 1 2) (foo 1 2)))
+
+; set-invalid-procedure-call-handler!
+
+(set-invalid-procedure-call-handler!
+ (lambda (proc args)
+ (cond [(string? proc) (apply string-ref proc args)]
+ [(vector? proc) (apply vector-ref proc args)]
+ [else
+ (error 'lolevel-test:invalid-procedure-call-handler
+ "bad argument type - not a procedure" proc args)])))
+
+(assert (char=? #\b ("abc" 1)))
+
+(assert (char=? #\b ('#(#\a #\b #\c) 1)))
+
+; unbound-variable-value
+
+(unbound-variable-value '23skidoo)
+
+(assert (eq? '23skidoo skidoo))
+
+(unbound-variable-value)
diff --git a/tests/loopy-loop.scm b/tests/loopy-loop.scm
new file mode 100644
index 00000000..59e53643
--- /dev/null
+++ b/tests/loopy-loop.scm
@@ -0,0 +1,548 @@
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Adapted from http://okmij.org/ftp/Scheme/keyword-arg-macro.txt
+;; Currently fails in Gauche.
+;; A more commented version is available at
+;; http://mumble.net/~campbell/scheme/syn-param.scm
+
+(define-syntax let-keyword-form
+ (syntax-rules ()
+ ((let-keyword-form
+ ((labeled-arg-macro-name
+ (positional-form-name (arg-name . arg-default) ...)))
+ . body)
+ (letrec-syntax
+ ((labeled-arg-macro-name
+ (syntax-rules ()
+ ((labeled-arg-macro-name . keyword-val-pairs)
+ (letrec-syntax
+ ((find
+ (syntax-rules (<- arg-name ...)
+ ((find kvp k-args (arg-name . default) arg-name <- val
+ . others) ; found arg-name among keyword-val-pairs
+ (next kvp val . k-args)) ...
+ ((find kvp k-args key arg-no-match-name <- val . others)
+ (find kvp k-args key . others))
+ ((find kvp k-args (arg-name default)) ; default must be here
+ (next kvp default . k-args)) ...
+ ))
+ (next ; pack the continuation to find
+ (syntax-rules ()
+ ((next kvp val vals key . keys)
+ (find kvp ((val . vals) . keys) key . kvp))
+ ((next kvp val vals) ; processed all arg-descriptors
+ (rev-apply (val) vals))))
+ (match-positionals
+ (syntax-rules (<-)
+ ((match-positionals () res . rest)
+ (rev-apply () res))
+ ((match-positionals args (val . vals) name <- value . rest)
+ (next (name <- value . rest) val vals . args))
+ ((match-positionals args (val . vals))
+ (next () val vals . args))
+ ((match-positionals (arg1 . args) res pos-arg . rest)
+ (match-positionals args (pos-arg . res) . rest))))
+ (rev-apply
+ (syntax-rules ()
+ ((rev-apply form (x . xs))
+ (rev-apply (x . form) xs))
+ ((rev-apply form ()) form))))
+ (match-positionals ((arg-name . arg-default) ...)
+ (positional-form-name)
+ . keyword-val-pairs)
+ )))))
+ . body))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define-syntax loop
+ (syntax-rules ()
+ ;; unnamed, implicit recursion
+ ((loop (vars ...) body ...)
+ (%loop tmp-loop () () () () () (vars ...) body ... (tmp-loop)))
+ ;; named, explicit recursion
+ ((loop name (vars ...) body ...)
+ (%loop name () () () () () (vars ...) body ...))))
+
+;; Main LOOP macro. Separate the variables from the iterator and
+;; parameters, then walk through each parameter expanding the
+;; bindings, and build the final form.
+
+(define-syntax %loop
+ (syntax-rules (=> <-)
+ ;; automatic iteration
+ ((_ name l v c r f ((var1 <- iterator source ...) rest ...) . body)
+ (iterator ((var1) (source ...)) %loop-next name l v c r f (rest ...) . body))
+ ((_ name l v c r f ((var1 var2 <- iterator source ...) rest ...) . body)
+ (iterator ((var1 var2) (source ...)) %loop-next name l v c r f (rest ...) . body))
+ ((_ name l v c r f ((var1 var2 var3 <- iterator source ...) rest ...) . body)
+ (iterator ((var1 var2 var3) (source ...)) %loop-next name l v c r f (rest ...) . body))
+ ((_ name l v c r f ((var1 var2 var3 var4 <- iterator source ...) rest ...) . body)
+ (iterator ((var1 var2 var3 var4) (source ...)) %loop-next name l v c r f (rest ...) . body))
+ ;; do equivalents, with optional guards
+ ((_ name l (vars ...) (checks ...) r f ((var init step guard) rest ...) . body)
+ (%loop name l (vars ... (var init step)) (checks ... (guard var)) r f (rest ...) . body))
+ ((_ name l (vars ...) c r f ((var init step) rest ...) . body)
+ (%loop name l (vars ... (var init step)) c r f (rest ...) . body))
+ ((_ name l (vars ...) c r f ((var init) rest ...) . body)
+ (%loop name l (vars ... (var init var)) c r f (rest ...) . body))
+ ;; specify a default done?
+ ((_ name l v c r f ())
+ (%loop name l v c r f () (#f #f)))
+ ((_ name l v c r f () () . body)
+ (%loop name l v c r f () (#f #f) . body))
+ ;; final expansion
+ ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
+ => result
+ . body)
+ (let* (lets ...)
+ (letrec ((tmp (lambda (var ...)
+ (if (or checks ...)
+ (let-keyword-form ((name (tmp (var step) ...)))
+ (match-let (finals ...)
+ result))
+ (match-let (refs ...)
+ (let-keyword-form ((name (tmp (var step) ...)))
+ (if #f #f)
+ . body))))))
+ (tmp init ...))))
+ ;; unspecified return value case
+ ((_ name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
+ . body)
+ (%loop name (lets ...) ((var init step) ...) (checks ...) (refs ...) (finals ...) ()
+ => (if #f #f) . body))
+ ))
+
+(define-syntax %loop-next
+ (syntax-rules ()
+ ((_ (new-lets ...) (new-vars ...) (new-checks ...) (new-refs ...) (new-finals ...)
+ name (lets ...) (vars ...) (checks ...) (refs ...) (finals ...)
+ . rest)
+ (%loop name (lets ... new-lets ...) (vars ... new-vars ...)
+ (checks ... new-checks ...) (refs ... new-refs ...)
+ (finals ... new-finals ...)
+ . rest))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Iterators
+
+;; Each gets passed two lists, those items left of the <- and those to
+;; the right, followed by a NEXT and REST continuation.
+
+;; Should finish with
+;;
+;; (next (outer-vars ...) (cursor-vars ...) (done?-tests ...)
+;; (loop-vars ...) (final-vars ...) . rest)
+;;
+;; OUTER-VARS: bound once outside the loop in a LET*
+;; CURSOR-VARS: DO-style bindings of the form (name init update)
+;; DONE?-TESTS: possibly empty list of forms that terminate the loop on #t
+;; LOOP-VARS: inner variables, updated in parallel after the cursors
+;; FINAL-VARS: final variables, bound only in the => result
+
+(define-syntax in-list ; called just "IN" in ITER
+ (syntax-rules ()
+ ((in-list ((var) source) next . rest)
+ (in-list ((var cursor) source) next . rest))
+ ((in-list ((var cursor) source) next . rest)
+ (in-list ((var cursor succ) source) next . rest))
+ ((in-list ((var cursor succ) (source)) next . rest)
+ (in-list ((var cursor succ) (source cdr)) next . rest))
+ ((in-list ((var cursor succ) (source step)) next . rest)
+ (in-list ((var cursor succ) (source step null?)) next . rest))
+ ((in-list ((var cursor succ) (source step done?)) next . rest)
+ (next () ; outer let bindings
+ ((cursor source succ)) ; iterator, init, step
+ ((done? cursor)) ; finish tests for iterator vars
+ ((var (car cursor)) ; step variables and values
+ (succ (step cursor)))
+ () ; final result bindings
+ . rest))))
+
+;; Iterator from Taylor R. Campbell. If you know the number of lists
+;; ahead of time it's much more efficient to iterate over each one
+;; separately.
+(define-syntax in-lists
+ (syntax-rules ()
+ ((in-lists ((elts) lol) next . rest)
+ (in-lists ((elts pairs) lol) next . rest))
+ ((in-lists ((elts pairs) lol) next . rest)
+ (in-lists ((elts pairs succ) lol) next . rest))
+ ((in-lists ((elts pairs succ) (lol)) next . rest)
+ (in-lists ((elts pairs succ) (lol cdr)) next . rest))
+ ((in-lists ((elts pairs succ) (lol)) next . rest)
+ (in-lists ((elts pairs succ) (lol cdr)) next . rest))
+ ((in-lists ((elts pairs succ) (lol step)) next . rest)
+ (in-lists ((elts pairs succ) (lol step null?)) next . rest))
+ ((in-lists ((elts pairs succ) (lol step done?)) next . rest)
+ (next ()
+ ((pairs lol succ))
+ ((let lp ((ls pairs)) ; yes, an in-lined ANY
+ (and (pair? ls) (or (done? (car ls)) (lp (cdr ls))))))
+ ((elts (map car pairs))
+ (succ (map step pairs)))
+ ()
+ . rest))
+ ))
+
+(define-syntax define-in-indexed
+ (syntax-rules ()
+ ((define-in-indexed in-type in-type-reverse length ref)
+ (begin
+ (define-syntax in-type
+ (syntax-rules ()
+ ((in-type ls next . rest)
+ (%in-indexed >= + 0 (length tmp) ref tmp ls next . rest))))
+ (define-syntax in-type-reverse
+ (syntax-rules ()
+ ((in-type-reverse ls next . rest)
+ (%in-indexed < - (- (length tmp) 1) 0 ref tmp ls next . rest))))
+ ))))
+
+(define-in-indexed in-string in-string-reverse string-length string-ref)
+(define-in-indexed in-vector in-vector-reverse vector-length vector-ref)
+(define-in-indexed in-u8vector in-u8vector-reverse u8vector-length u8vector-ref)
+(define-in-indexed in-s8vector in-s8vector-reverse s8vector-length s8vector-ref)
+(define-in-indexed in-u16vector in-u16vector-reverse u16vector-length u16vector-ref)
+(define-in-indexed in-s16vector in-s16vector-reverse s16vector-length s16vector-ref)
+(define-in-indexed in-u32vector in-u32vector-reverse u32vector-length u32vector-ref)
+(define-in-indexed in-s32vector in-s32vector-reverse s32vector-length s32vector-ref)
+(define-in-indexed in-f32vector in-f32vector-reverse f32vector-length f32vector-ref)
+(define-in-indexed in-f64vector in-f64vector-reverse f64vector-length f64vector-ref)
+
+;; helper for the above string and vector iterators
+(define-syntax %in-indexed
+ (syntax-rules ()
+ ;; cmp inc start end ref
+ ((%in-indexed ge + s e r tmp-vec ((var) (vec ...)) next . rest)
+ (%in-indexed ge + s e r tmp-vec ((var vec-index) (vec ...)) next . rest))
+ ((%in-indexed ge + s e r tmp-vec ((var index) (vec)) next . rest)
+ (%in-indexed ge + s e r tmp-vec ((var index) (vec s e 1)) next . rest))
+ ((%in-indexed ge + s e r tmp-vec ((var index) (vec from)) next . rest)
+ (%in-indexed ge + s e r tmp-vec ((var index) (vec from e 1)) next . rest))
+ ((%in-indexed ge + s e r tmp-vec ((var index) (vec from to)) next . rest)
+ (%in-indexed ge + s e r tmp-vec ((var index) (vec from to 1)) next . rest))
+ ((%in-indexed ge + s e r tmp-vec ((var index) (vec from to step)) next . rest)
+ (next ((tmp-vec vec) (end to))
+ ((index from (+ index step)))
+ ((ge index end))
+ ((var (r tmp-vec index)))
+ ()
+ . rest))
+ ))
+
+(define-syntax in-port
+ (syntax-rules ()
+ ((in-port ((var) source) next . rest)
+ (in-port ((var p) source) next . rest))
+ ((in-port ((var p) ()) next . rest)
+ (in-port ((var p) ((current-input-port))) next . rest))
+ ((in-port ((var p) (port)) next . rest)
+ (in-port ((var p) (port read-char)) next . rest))
+ ((in-port ((var p) (port read-char)) next . rest)
+ (in-port ((var p) (port read-char eof-object?)) next . rest))
+ ((in-port ((var p) (port reader eof?)) next . rest)
+ (next ((p port) (r reader) (e? eof?))
+ ((var (r p) (r p)))
+ ((e? var))
+ ()
+ ()
+ . rest))))
+
+(define-syntax in-file
+ (syntax-rules ()
+ ((in-file ((var) source) next . rest)
+ (in-file ((var p) source) next . rest))
+ ((in-file ((var p) (file)) next . rest)
+ (in-file ((var p) (file read-char)) next . rest))
+ ((in-file ((var p) (file reader)) next . rest)
+ (in-file ((var p) (file reader eof-object?)) next . rest))
+ ((in-file ((var p) (file reader eof?)) next . rest)
+ (next ((p (open-input-file file)) (r reader) (e? eof?))
+ ((var (r p) (r p)))
+ ((e? var))
+ ()
+ ((dummy (close-input-port p)))
+ . rest))))
+
+;; XXXX Consider a keyword approach such as Taylor uses.
+
+(define-syntax in-range
+ (syntax-rules ()
+ ((in-range ((var) ()) next . rest)
+ (next () ((var 0 (+ var 1))) () () . rest))
+ ((in-range ((var) (to)) next . rest)
+ (next () ((var 0 to)) () () . rest))
+ ((in-range ((var) (from to)) next . rest)
+ (in-range ((var) (from to 1)) next . rest))
+ ((in-range ((var) (from to step)) next . rest)
+ (next ((tmp-to to))
+ ((var from (+ var step)))
+ ((>= var tmp-to))
+ ()
+ ()
+ . rest))))
+
+(define-syntax in-range-reverse
+ (syntax-rules ()
+ ((in-range ((var) ()) next . rest)
+ (next () ((var 0 (- var 1))) () () . rest))
+ ((in-range ((var) (to)) next . rest)
+ (next () ((var 0 to)) () () . rest))
+ ((in-range ((var) (from to)) next . rest)
+ (in-range ((var) (from to 1)) next . rest))
+ ((in-range ((var) (from to step)) next . rest)
+ (next ((tmp-to to))
+ ((var from (- var step)))
+ ((<= var tmp-to))
+ ()
+ ()
+ . rest))))
+
+;; XXXX A generalized accumulator, possibly not worth the effort.
+
+(define-syntax collecting
+ (syntax-rules ()
+ ((collecting ((var) source) next . rest)
+ (collecting ((var cursor) source) next . rest))
+ ((collecting ((var cursor) (source)) next . rest)
+ (collecting ((var cursor) (source cons)) next . rest))
+ ((collecting ((var cursor) (source kons)) next . rest)
+ (collecting ((var cursor) (source kons reverse)) next . rest))
+ ((collecting ((var cursor) (source kons final)) next . rest)
+ (next ((tmp-kons kons))
+ ((cursor '() (tmp-kons source cursor)))
+ ()
+ ()
+ ((var (final cursor)))
+ . rest))))
+
+;; XXXX should these be loop variables or body variables?
+
+(define-syntax in-random
+ (syntax-rules ()
+ ((in-random ((var) ()) next . rest) ; XXXX consider in-random-real
+ (next ((MAX_RAND (+ (expt 2 29) (- (expt 2 29) 1))))
+ ((var (/ (random MAX_RAND) MAX_RAND)
+ (/ (random MAX_RAND) MAX_RAND)))
+ ()
+ ()
+ . rest))
+ ((in-random ((var) (n)) next . rest)
+ (next ((tmp-n n))
+ ((var (random tmp-n) (random tmp-n)))
+ ()
+ ()
+ ()
+ . rest))
+ ((in-random ((var) (n lo)) next . rest)
+ (next ((tmp-n n) (tmp-lo lo))
+ ((var (+ tmp-lo (random tmp-n))
+ (+ tmp-lo (random tmp-n))))
+ ()
+ ()
+ ()
+ . rest))
+ ))
+
+;; takes either a list or vector
+
+(define-syntax in-random-element
+ (syntax-rules ()
+ ((in-random-element ((var) (source)) next . rest)
+ (next ((tmp-source source)
+ (tmp-vec (if (pair? tmp-source)
+ (list->vector tmp-source)
+ tmp-source))
+ (tmp-len (vector-length tmp-vec)))
+ ((var (vector-ref tmp-vec (random tmp-len))
+ (vector-ref tmp-vec (random tmp-len))))
+ ()
+ ()
+ ()
+ . rest))))
+
+;; XXXX document this and explain what the hell it's doing :)
+(define-syntax in-permutations
+ (syntax-rules ()
+ ((in-permutations ((var) source) next . rest)
+ (in-permutations ((var p) source) next . rest))
+ ((in-permutations ((var p) (set)) next . rest)
+ (in-permutations ((var p) (set #f)) next . rest))
+ ((in-permutations ((var p) (set len)) next . rest)
+ (next
+ ((tmp-set set))
+ ((p
+ (let ((tmp-len (or len (length tmp-set))))
+ (let lp ((i 0) (ls tmp-set) (res '()))
+ (if (= i tmp-len)
+ res
+ (lp (+ i 1) (cdr ls) (cons (cons ls '()) res)))))
+ (and (pair? p)
+ (let lp ((ls p) (count 0))
+ (if (pair? (cdaar ls))
+ (let lp2 ((i count)
+ (ls2 (append (reverse (cdar ls))
+ (cons (caaar ls) (cddaar ls))))
+ (res (cons (cons (cdaar ls)
+ (cons (caaar ls) (cdar ls)))
+ (cdr ls))))
+ (if (zero? i)
+ res
+ (lp2 (- i 1) (cdr ls2) (cons (cons ls2 '()) res))))
+ (and (pair? (cdr ls)) (lp (cdr ls) (+ count 1))))))))
+ ((not p))
+ ((var
+ (let lp ((ls p) (res '()))
+ (if (null? ls) res (lp (cdr ls) (cons (caaar ls) res))))))
+ ()
+ . rest))
+ ))
+
+(define-syntax in-combinations
+ (syntax-rules ()
+ ((in-combinations ((var) x) next . rest)
+ (in-combinations ((var p) x) next . rest))
+ ;; all 2^len combinations
+ ((in-combinations ((var p) (set)) next . rest)
+ (next
+ ((tmp-vec (list->vector set))
+ (tmp-len (vector-length tmp-vec))
+ (tmp-limit (expt 2 tmp-len)))
+ ((p 0 (+ p 1)))
+ ((>= p tmp-limit))
+ ((var
+ (let lp ((p p) (i 0) (res '()))
+ (cond
+ ((zero? p) (reverse res))
+ ((odd? p)
+ (lp (arithmetic-shift p -1)
+ (+ i 1)
+ (cons (vector-ref tmp-vec i) res)))
+ (else (lp (arithmetic-shift p -1) (+ i 1) res))))))
+ ()
+ . rest))
+ ;; all C(n,k) combinations of length k
+ ((in-combinations ((var p) (set len)) next . rest)
+ (next
+ ((tmp-len len))
+ ((p
+ (let lp ((i 0) (ls set) (res '()))
+ (if (= i tmp-len)
+ res
+ (lp (+ i 1) (cdr ls) (cons ls res))))
+ (and (pair? p)
+ (if (and (pair? (car p)) (pair? (cdar p)))
+ (cons (cdar p) (cdr p))
+ (let lp ((ls (cdr p)) (count 1))
+ (and (pair? ls)
+ (if (> (length (cdar ls)) count)
+ (let lp2 ((i count)
+ (ls2 (cddar ls))
+ (res (cons (cdar ls) (cdr ls))))
+ (if (zero? i)
+ res
+ (lp2 (- i 1) (cdr ls2) (cons ls2 res))))
+ (lp (cdr ls) (+ count 1)))))))))
+ ((not p))
+ ((var
+ (let lp ((ls p) (res '()))
+ (if (null? ls) res (lp (cdr ls) (cons (caar ls) res))))))
+ ()
+ . rest))
+ ))
+
+(define-syntax in-cartesian-product
+ (syntax-rules ()
+ ((in-cartesian-product ((var) (lol-src)) next . rest)
+ (in-cartesian-product ((var p) (lol-src)) next . rest))
+ ;; all NxMx... joins
+ ((in-cartesian-product ((var x) (lol-src)) next . rest)
+ (next
+ ((lol lol-src))
+ ((x (and (pair? lol)
+ (cons (reverse lol) (reverse (cdr lol))))
+ (let lp ((p (car x)) (ls (cdr x)) (rev '()))
+ (cond
+ ((pair? (cdar p))
+ (cons (append (reverse rev)
+ (cons (cdar p) (cdr p)))
+ (cdr x)))
+ ((pair? (cdr p))
+ (lp (cdr p) (cdr ls) (cons (car ls) rev)))
+ (else
+ #f)))))
+ ((not x))
+ ((var (let lp ((ls (car x)) (res '()))
+ (if (null? ls) res (lp (cdr ls) (cons (caar ls) res))))))
+ ()
+ . rest))
+ ))
+
+;; Chicken-specific implementation using internal knowledge of the
+;; vector+alist representation. The ##sys#slot form will cause most
+;; other implementations to choke, so comment this out if needed.
+
+(define-syntax in-hash-table
+ (syntax-rules ()
+ ((in-hash-table ((key val) (table)) next . rest)
+ (next ((tmp-vec (##sys#slot table 1))
+ (end (vector-length tmp-vec))
+ (next-pair-bucket
+ (lambda (start)
+ (let lp ((i start))
+ (and (< i end)
+ (let ((x (vector-ref tmp-vec i)))
+ (if (pair? x)
+ i
+ (lp (+ i 1))))))))
+ (first-bucket (next-pair-bucket 0)))
+ ((bucket first-bucket
+ (if (and (pair? cell) (pair? (cdr cell)))
+ bucket
+ (next-pair-bucket (+ bucket 1))))
+ (cell (and first-bucket (vector-ref tmp-vec first-bucket))
+ (if (and (pair? cell) (pair? (cdr cell)))
+ (cdr cell)
+ (let ((i (next-pair-bucket (+ bucket 1))))
+ (and i (vector-ref tmp-vec i))))))
+ ((not bucket))
+ ((key (caar cell))
+ (val (cdar cell)))
+ ()
+ . rest))
+ ))
+
+;; Portable R5RS + SRFI-69 version.
+
+;; (define-syntax in-hash-table
+;; (syntax-rules ()
+;; ((in-hash-table ((key val) (table)) next . rest)
+;; (next ((tmp-table table)
+;; (start-cursor
+;; (call-with-current-continuation
+;; (lambda (return)
+;; (hash-table-walk
+;; table
+;; (lambda (k v)
+;; (call-with-current-continuation
+;; (lambda (inside)
+;; (return
+;; (lambda (sym)
+;; (cond
+;; ((eq? sym 'key) k)
+;; ((eq? sym 'value) v)
+;; ((eq? sym 'next) (inside #t))
+;; ((eq? sym 'end?) #f))))))))
+;; (lambda (sym)
+;; (if (eq? sym 'end?)
+;; #t
+;; (error "past end of hash table")))))))
+;; ((tmp-cursor start-cursor (tmp-cursor 'next)))
+;; ((tmp-cursor 'end?))
+;; ((key (tmp-cursor 'key))
+;; (val (tmp-cursor 'value)))
+;; ()
+;; . rest))
+;; ))
+
diff --git a/tests/loopy-test.scm b/tests/loopy-test.scm
new file mode 100644
index 00000000..86d450b2
--- /dev/null
+++ b/tests/loopy-test.scm
@@ -0,0 +1,201 @@
+(load-relative "loopy-loop.scm")
+(load-relative "matchable.scm")
+
+(require-extension srfi-69)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; SRFI-64 subset + test-approx=
+
+(define *pass* 0)
+(define *fail* 0)
+(define *start* 0)
+
+(define (run-test name thunk expect eq pass-msg fail-msg)
+ (let ((result (thunk)))
+ (cond
+ ((eq expect result)
+ (set! *pass* (+ *pass* 1))
+ (format-result pass-msg name expect result))
+ (else
+ (set! *fail* (+ *fail* 1))
+ (format-result fail-msg name expect result)))))
+
+(define (format-result ls name expect result)
+ (let lp ((ls ls))
+ (cond
+ ((null? ls) (newline))
+ ((eq? (car ls) 'expect) (display expect) (lp (cdr ls)))
+ ((eq? (car ls) 'result) (display result) (lp (cdr ls)))
+ ((eq? (car ls) 'name) (if name (begin (display #\space) (display name))) (lp (cdr ls)))
+ (else (display (car ls)) (lp (cdr ls))))))
+
+(define (test-begin . o)
+ (set! *pass* 0)
+ (set! *fail* 0)
+ (set! *start* (current-milliseconds)))
+
+(define (format-float n prec)
+ (let* ((str (number->string n))
+ (len (string-length str)))
+ (let lp ((i (- len 1)))
+ (cond
+ ((negative? i)
+ (string-append str "." (make-string prec #\0)))
+ ((eqv? #\. (string-ref str i))
+ (let ((diff (+ 1 (- prec (- len i)))))
+ (cond
+ ((positive? diff)
+ (string-append str (make-string diff #\0)))
+ ((negative? diff)
+ (substring str 0 (+ i prec 1)))
+ (else
+ str))))
+ (else
+ (lp (- i 1)))))))
+
+(define (format-percent num denom)
+ (let ((x (if (zero? denom) num (exact->inexact (/ num denom)))))
+ (format-float (* 100 x) 2)))
+
+(define (test-end . o)
+ (let ((end (current-milliseconds))
+ (total (+ *pass* *fail*)))
+ (printf " ~A tests completed in ~A seconds\n"
+ total (format-float (exact->inexact (/ (- end *start*) 1000)) 3))
+ (printf " ~A (~A%) tests passed\n"
+ *pass* (format-percent *pass* total))
+ (printf " ~A (~A%) tests failed\n"
+ *fail* (format-percent *fail* total))))
+
+(define-syntax test-assert
+ (syntax-rules ()
+ ((_ x opt)
+ (run-assert x (lambda () opt)))
+ ((_ x ) (run-assert 'x (lambda () x)))))
+
+(define (run-equal name thunk expect eq)
+ (run-test name thunk expect eq
+ '("(PASS)" name)
+ '("(FAIL)" name ": expected " expect " but got " result)))
+
+(define-syntax test-equal
+ (syntax-rules ()
+ ((_ x y opt)
+ (run-equal x (lambda () y) opt equal?))
+ ((_ x y) (run-equal 'x (lambda () x) y equal?))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; run tests
+
+(test-begin "loop")
+
+(test-equal
+ "stepping"
+ (loop lp ((i 0 (+ i 1)) (res '() (cons i res)))
+ (if (= i 3)
+ (reverse res)
+ (lp)))
+ '(0 1 2))
+
+(test-equal
+ "basic in-list"
+ (let ((res '()))
+ (loop ((x <- in-list '(a b c)))
+ (set! res (cons x res)))
+ res)
+ '(c b a))
+
+(test-equal
+ "in-list with result"
+ (loop ((x <- in-list '(a b c))
+ (res '() (cons x res)))
+ => res)
+ '(c b a))
+
+(test-equal
+ "in-list with collecting"
+ (loop ((x <- in-list '(a b c)) (res <- collecting x)) => res)
+ '(a b c))
+
+(test-equal
+ "uneven length in-list's"
+ (loop ((x <- in-list '(a b c))
+ (y <- in-list '(1 2 3 4))
+ (res <- collecting (cons x y)))
+ => res)
+ '((a . 1) (b . 2) (c . 3)))
+
+(test-equal
+ "in-lists"
+ (loop ((ls <- in-lists '((a b c) (1 2 3)))
+ (res <- collecting ls))
+ => res)
+ '((a 1) (b 2) (c 3)))
+
+(define (flatten ls)
+ (reverse
+ (loop lp ((x ls <- in-list ls) (res '()))
+ => res
+ (if (pair? x)
+ (lp res <- (lp ls <- x))
+ (lp res <- (cons x res))))))
+
+(test-equal
+ "flatten (recursion test)"
+ (flatten '(1 (2) (3 (4 (5)) 6) 7))
+ '(1 2 3 4 5 6 7))
+
+(test-equal
+ "in-string"
+ (loop ((c <- in-string "hello") (res <- collecting c)) => res)
+ '(#\h #\e #\l #\l #\o))
+
+(test-equal
+ "in-string with start"
+ (loop ((c <- in-string "hello" 3) (res <- collecting c)) => res)
+ '(#\l #\o))
+
+(test-equal
+ "in-string with start and end"
+ (loop ((c <- in-string "hello" 0 4) (res <- collecting c)) => res)
+ '(#\h #\e #\l #\l))
+
+(test-equal
+ "in-string with start, end and step"
+ (loop ((c <- in-string "hello" 1 4 2) (res <- collecting c)) => res)
+ '(#\e #\l))
+
+(test-equal
+ "in-string-reverse"
+ (loop ((c <- in-string-reverse "hello") (res <- collecting c)) => res)
+ '(#\o #\l #\l #\e #\h))
+
+(test-equal
+ "in-vector"
+ (loop ((x <- in-vector '#(1 2 3)) (res <- collecting x)) => res)
+ '(1 2 3))
+
+(test-equal
+ "in-permutations"
+ (loop ((p <- in-permutations '(a b c)) (res <- collecting p)) => res)
+ '((a b c) (a c b) (b a c) (b c a) (c a b) (c b a)))
+
+(test-equal
+ "in-permutations with length"
+ (loop ((p <- in-permutations '(a b c) 2) (res <- collecting p)) => res)
+ '((a b) (a c) (b a) (b c) (c a) (c b)))
+
+(test-equal
+ "in-combinations"
+ (loop ((p <- in-combinations '(a b c) 2) (res <- collecting p)) => res)
+ '((a b) (a c) (b c)))
+
+(test-equal
+ "in-hash-table"
+ (loop ((k v <- in-hash-table (alist->hash-table '((a . 1))))
+ (res <- collecting (cons k v)))
+ => res)
+ '((a . 1)))
+
+(test-end "loop")
+
diff --git a/tests/match-test.scm b/tests/match-test.scm
new file mode 100644
index 00000000..d3dd2437
--- /dev/null
+++ b/tests/match-test.scm
@@ -0,0 +1,118 @@
+(load-relative "test.scm")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; run tests
+
+(test-begin "match")
+
+(test-equal "any" (match 'any (_ 'ok)) 'ok)
+(test-equal "symbol" (match 'ok (x x)) 'ok)
+(test-equal "number" (match 28 (28 'ok)) 'ok)
+(test-equal "string" (match "good" ("bad" 'fail) ("good" 'ok)) 'ok)
+(test-equal "literal symbol" (match 'good ('bad 'fail) ('good 'ok)) 'ok)
+(test-equal "null" (match '() (() 'ok)) 'ok)
+(test-equal "pair" (match '(ok) ((x) x)) 'ok)
+(test-equal "vector" (match '#(ok) (#(x) x)) 'ok)
+(test-equal "any doubled" (match '(1 2) ((_ _) 'ok)) 'ok)
+(test-equal "and empty" (match '(o k) ((and) 'ok)) 'ok)
+(test-equal "and single" (match 'ok ((and x) x)) 'ok)
+(test-equal "and double" (match 'ok ((and (? symbol?) y) 'ok)) 'ok)
+(test-equal "or empty" (match '(o k) ((or) 'fail) (else 'ok)) 'ok)
+(test-equal "or single" (match 'ok ((or x) 'ok)) 'ok)
+(test-equal "or double" (match 'ok ((or (? symbol? y) y) y)) 'ok)
+(test-equal "not" (match 28 ((not (a . b)) 'ok)) 'ok)
+(test-equal "pred" (match 28 ((? number?) 'ok)) 'ok)
+(test-equal "named pred" (match 28 ((? number? x) (+ x 1))) 29)
+
+(test-equal "duplicate symbols pass" (match '(ok . ok) ((x . x) x)) 'ok)
+(test-equal "duplicate symbols fail" (match '(ok . bad) ((x . x) 'bad) (else 'ok)) 'ok)
+(test-equal "duplicate symbols samth" (match '(ok . ok) ((x . 'bad) x) (('ok . x) x)) 'ok)
+
+(test-equal "ellipses"
+ (match '((a . 1) (b . 2) (c . 3))
+ (((x . y) ___) (list x y)))
+ '((a b c) (1 2 3)))
+
+(test-equal "real ellipses"
+ (match '((a . 1) (b . 2) (c . 3))
+ (((x . y) ...) (list x y)))
+ '((a b c) (1 2 3)))
+
+(test-equal "vector ellipses"
+ (match '#(1 2 3 (a . 1) (b . 2) (c . 3))
+ (#(a b c (hd . tl) ...) (list a b c hd tl)))
+ '(1 2 3 (a b c) (1 2 3)))
+
+(test-equal "pred ellipses"
+ (match '(1 2 3)
+ (((? odd? n) ___) n)
+ (((? number? n) ___) n))
+ '(1 2 3))
+
+(test-equal "failure continuation"
+ (match '(1 2)
+ ((a . b) (=> next) (if (even? a) 'fail (next)))
+ ((a . b) 'ok))
+ 'ok)
+
+(test-equal "let"
+ (match-let ((x 'ok) (y '(o k)))
+ y)
+ '(o k))
+
+(test-equal "let*"
+ (match-let* ((x 'f) (y 'o) ((z w) (list y x)))
+ (list x y z w))
+ '(f o o f))
+
+(test-equal "getter car"
+ (match '(1 . 2) (((get! a) . b) (list (a) b)))
+ '(1 2))
+
+(test-equal "getter cdr"
+ (match '(1 . 2) ((a . (get! b)) (list a (b))))
+ '(1 2))
+
+(test-equal "getter vector"
+ (match '#(1 2 3) (#((get! a) b c) (list (a) b c)))
+ '(1 2 3))
+
+(test-equal "setter car"
+ (let ((x '(1 . 2)))
+ (match x (((set! a) . b) (a 3)))
+ x)
+ '(3 . 2))
+
+(test-equal "setter cdr"
+ (let ((x '(1 . 2)))
+ (match x ((a . (set! b)) (b 3)))
+ x)
+ '(1 . 3))
+
+(test-equal "setter vector"
+ (let ((x '#(1 2 3)))
+ (match x (#(a (set! b) c) (b 0)))
+ x)
+ '#(1 0 3))
+
+(test-equal "single tail"
+ (match '((a . 1) (b . 2) (c . 3))
+ (((x . y) ... last) (list x y last)))
+ '((a b) (1 2) (c . 3)))
+
+(test-equal "single tail 2"
+ (match '((a . 1) (b . 2) 3)
+ (((x . y) ... last) (list x y last)))
+ '((a b) (1 2) 3))
+
+(test-equal "multiple tail"
+ (match '((a . 1) (b . 2) (c . 3) (d . 4) (e . 5))
+ (((x . y) ... u v w) (list x y u v w)))
+ '((a b) (1 2) (c . 3) (d . 4) (e . 5)))
+
+(test-equal "Riastradh quasiquote"
+ (match '(1 2 3) (`(1 ,b ,c) (list b c)))
+ '(2 3))
+
+(test-end "match")
+
diff --git a/tests/matchable.scm b/tests/matchable.scm
new file mode 100644
index 00000000..b870d110
--- /dev/null
+++ b/tests/matchable.scm
@@ -0,0 +1,551 @@
+;;;; matchable.scm -- portable hygienic pattern matcher
+;;
+;; This code is written by Alex Shinn and placed in the
+;; Public Domain. All warranties are disclaimed.
+
+;; Written in fully portable SYNTAX-RULES, with a few non-portable
+;; bits at the end of the file conditioned out with COND-EXPAND.
+
+;; This is a simple generative pattern matcher - each pattern is
+;; expanded into the required tests, calling a failure continuation if
+;; the tests pass. This makes the logic easy to follow and extend,
+;; but produces sub-optimal code in cases where you have many similar
+;; clauses due to repeating the same tests. Nonetheless a smart
+;; compiler should be able to remove the redundant tests. For
+;; MATCH-LET and DESTRUCTURING-BIND type uses there is no performance
+;; hit.
+
+;; 2008/03/20 - fixing bug where (a ...) matched non-lists
+;; 2008/03/15 - removing redundant check in vector patterns
+;; 2007/09/04 - fixing quasiquote patterns
+;; 2007/07/21 - allowing ellipse patterns in non-final list positions
+;; 2007/04/10 - fixing potential hygiene issue in match-check-ellipse
+;; (thanks to Taylor Campbell)
+;; 2007/04/08 - clean up, commenting
+;; 2006/12/24 - bugfixes
+;; 2006/12/01 - non-linear patterns, shared variables in OR, get!/set!
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; This is always passed a message, yet won't match the message, and
+;; thus always results in a compile-time error.
+
+(define-syntax match-syntax-error
+ (syntax-rules ()
+ ((_)
+ (match-syntax-error "invalid match-syntax-error usage"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; The basic interface. MATCH just performs some basic syntax
+;; validation, binds the match expression to a temporary variable, and
+;; passes it on to MATCH-NEXT.
+
+(define-syntax match
+ (syntax-rules ()
+ ((match)
+ (match-syntax-error "missing match expression"))
+ ((match atom)
+ (match-syntax-error "missing match clause"))
+ ((match (app ...) (pat . body) ...)
+ (let ((v (app ...)))
+ (match-next v (app ...) (set! (app ...)) (pat . body) ...)))
+ ((match #(vec ...) (pat . body) ...)
+ (let ((v #(vec ...)))
+ (match-next v v (set! v) (pat . body) ...)))
+ ((match atom (pat . body) ...)
+ (match-next atom atom (set! atom) (pat . body) ...))
+ ))
+
+;; MATCH-NEXT passes each clause to MATCH-ONE in turn with its failure
+;; thunk, which is expanded by recursing MATCH-NEXT on the remaining
+;; clauses.
+
+(define-syntax match-next
+ (syntax-rules (=>)
+ ;; no more clauses, the match failed
+ ((match-next v g s)
+ (error 'match "no matching pattern"))
+ ;; named failure continuation
+ ((match-next v g s (pat (=> failure) . body) . rest)
+ (let ((failure (lambda () (match-next v g s . rest))))
+ ;; match-one analyzes the pattern for us
+ (match-one v pat g s (match-drop-ids (begin . body)) (failure) ())))
+ ;; anonymous failure continuation, give it a dummy name
+ ((match-next v g s (pat . body) . rest)
+ (match-next v g s (pat (=> failure) . body) . rest))))
+
+;; MATCH-ONE first checks for ellipse patterns, otherwise passes on to
+;; MATCH-TWO.
+
+(define-syntax match-one
+ (syntax-rules ()
+ ;; If it's a list of two values, check to see if the second one is
+ ;; an ellipse and handle accordingly, otherwise go to MATCH-TWO.
+ ((match-one v (p q . r) g s sk fk i)
+ (match-check-ellipse
+ q
+ (match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ())
+ (match-two v (p q . r) g s sk fk i)))
+ ;; Otherwise, go directly to MATCH-TWO.
+ ((match-one . x)
+ (match-two . x))))
+
+;; This is the guts of the pattern matcher. We are passed a lot of
+;; information in the form:
+;;
+;; (match-two var pattern getter setter success-k fail-k (ids ...))
+;;
+;; where VAR is the symbol name of the current variable we are
+;; matching, PATTERN is the current pattern, getter and setter are the
+;; corresponding accessors (e.g. CAR and SET-CAR! of the pair holding
+;; VAR), SUCCESS-K is the success continuation, FAIL-K is the failure
+;; continuation (which is just a thunk call and is thus safe to expand
+;; multiple times) and IDS are the list of identifiers bound in the
+;; pattern so far.
+
+(define-syntax match-two
+ (syntax-rules (_ ___ quote quasiquote ? $ = and or not set! get!)
+ ((match-two v () g s (sk ...) fk i)
+ (if (null? v) (sk ... i) fk))
+ ((match-two v (quote p) g s (sk ...) fk i)
+ (if (equal? v 'p) (sk ... i) fk))
+ ((match-two v (quasiquote p) g s sk fk i)
+ (match-quasiquote v p g s sk fk i))
+ ((match-two v (and) g s (sk ...) fk i) (sk ... i))
+ ((match-two v (and p q ...) g s sk fk i)
+ (match-one v p g s (match-one v (and q ...) g s sk fk) fk i))
+ ((match-two v (or) g s sk fk i) fk)
+ ((match-two v (or p) g s sk fk i)
+ (match-one v p g s sk fk i))
+ ((match-two v (or p ...) g s sk fk i)
+ (match-extract-vars (or p ...)
+ (match-gen-or v (p ...) g s sk fk i)
+ i
+ ()))
+ ((match-two v (not p) g s (sk ...) fk i)
+ (match-one v p g s (match-drop-ids fk) (sk ... i) i))
+ ((match-two v (get! getter) g s (sk ...) fk i)
+ (let ((getter (lambda () g))) (sk ... i)))
+ ((match-two v (set! setter) g (s ...) (sk ...) fk i)
+ (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
+ ((match-two v (? pred p ...) g s sk fk i)
+ (if (pred v) (match-one v (and p ...) g s sk fk i) fk))
+ ((match-two v (= proc p) g s sk fk i)
+ (let ((w (proc v)))
+ (match-one w p g s sk fk i)))
+ ((match-two v (p ___ . r) g s sk fk i)
+ (match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ()))
+ ((match-two v (p) g s sk fk i)
+ (if (and (pair? v) (null? (cdr v)))
+ (let ((w (car v)))
+ (match-one w p (car v) (set-car! v) sk fk i))
+ fk))
+ ((match-two v (p . q) g s sk fk i)
+ (if (pair? v)
+ (let ((w (car v)) (x (cdr v)))
+ (match-one w p (car v) (set-car! v)
+ (match-one x q (cdr v) (set-cdr! v) sk fk)
+ fk
+ i))
+ fk))
+ ((match-two v #(p ...) g s sk fk i)
+ (match-vector v 0 () (p ...) sk fk i))
+ ((match-two v _ g s (sk ...) fk i) (sk ... i))
+ ;; Not a pair or vector or special literal, test to see if it's a
+ ;; new symbol, in which case we just bind it, or if it's an
+ ;; already bound symbol or some other literal, in which case we
+ ;; compare it with EQUAL?.
+ ((match-two v x g s (sk ...) fk (id ...))
+ (let-syntax
+ ((new-sym?
+ (syntax-rules (id ...)
+ ((new-sym? x sk2 fk2) sk2)
+ ((new-sym? y sk2 fk2) fk2))))
+ (new-sym? abracadabra ; thanks Oleg
+ (let ((x v)) (sk ... (id ... x)))
+ (if (equal? v x) (sk ... (id ...)) fk))))
+ ))
+
+;; QUASIQUOTE patterns
+
+(define-syntax match-quasiquote
+ (syntax-rules (unquote unquote-splicing quasiquote)
+ ((_ v (unquote p) g s sk fk i)
+ (match-one v p g s sk fk i))
+ ((_ v ((unquote-splicing p) . rest) g s sk fk i)
+ (if (pair? v)
+ (match-one v
+ (p . tmp)
+ (match-quasiquote tmp rest g s sk fk)
+ fk
+ i)
+ fk))
+ ((_ v (quasiquote p) g s sk fk i . depth)
+ (match-quasiquote v p g s sk fk i #f . depth))
+ ((_ v (unquote p) g s sk fk i x . depth)
+ (match-quasiquote v p g s sk fk i . depth))
+ ((_ v (unquote-splicing p) g s sk fk i x . depth)
+ (match-quasiquote v p g s sk fk i . depth))
+ ((_ v (p . q) g s sk fk i . depth)
+ (if (pair? v)
+ (let ((w (car v)) (x (cdr v)))
+ (match-quasiquote
+ w p g s
+ (match-quasiquote-step x q g s sk fk depth)
+ fk i . depth))
+ fk))
+ ((_ v #(elt ...) g s sk fk i . depth)
+ (if (vector? v)
+ (let ((ls (vector->list v)))
+ (match-quasiquote ls (elt ...) g s sk fk i . depth))
+ fk))
+ ((_ v x g s sk fk i . depth)
+ (match-one v 'x g s sk fk i))))
+
+(define-syntax match-quasiquote-step
+ (syntax-rules ()
+ ((match-quasiquote-step x q g s sk fk depth i)
+ (match-quasiquote x q g s sk fk i . depth))
+ ))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Utilities
+
+;; A CPS utility that takes two values and just expands into the
+;; first.
+(define-syntax match-drop-ids
+ (syntax-rules ()
+ ((_ expr ids ...) expr)))
+
+;; Generating OR clauses just involves binding the success
+;; continuation into a thunk which takes the identifiers common to
+;; each OR clause, and trying each clause, calling the thunk as soon
+;; as we succeed.
+
+(define-syntax match-gen-or
+ (syntax-rules ()
+ ((_ v p g s (sk ...) fk (i ...) ((id id-ls) ...))
+ (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
+ (match-gen-or-step
+ v p g s (match-drop-ids (sk2 id ...)) fk (i ...))))))
+
+(define-syntax match-gen-or-step
+ (syntax-rules ()
+ ((_ v () g s sk fk i)
+ ;; no OR clauses, call the failure continuation
+ fk)
+ ((_ v (p) g s sk fk i)
+ ;; last (or only) OR clause, just expand normally
+ (match-one v p g s sk fk i))
+ ((_ v (p . q) g s sk fk i)
+ ;; match one and try the remaining on failure
+ (match-one v p g s sk (match-gen-or-step v q g s sk fk i) i))
+ ))
+
+;; We match a pattern (p ...) by matching the pattern p in a loop on
+;; each element of the variable, accumulating the bound ids into lists
+
+;; Look at the body - it's just a named let loop, matching each
+;; element in turn to the same pattern. This illustrates the
+;; simplicity of this generative-style pattern matching. It would be
+;; just as easy to implement a tree searching pattern.
+
+(define-syntax match-gen-ellipses
+ (syntax-rules ()
+ ((_ v p () g s (sk ...) fk i ((id id-ls) ...))
+ (match-check-identifier p
+ (let ((p v))
+ (if (list? p)
+ (sk ... i)
+ fk))
+ (let loop ((ls v) (id-ls '()) ...)
+ (cond
+ ((null? ls)
+ (let ((id (reverse id-ls)) ...) (sk ... i)))
+ ((pair? ls)
+ (let ((w (car ls)))
+ (match-one w p (car ls) (set-car! ls)
+ (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
+ fk i)))
+ (else
+ fk)))))
+ ((_ v p (r ...) g s (sk ...) fk i ((id id-ls) ...))
+ (match-verify-no-ellipses
+ (r ...)
+ (let* ((tail-len (length '(r ...)))
+ (ls v)
+ (len (length ls)))
+ (if (< len tail-len)
+ fk
+ (let loop ((ls ls) (n len) (id-ls '()) ...)
+ (cond
+ ((= n tail-len)
+ (let ((id (reverse id-ls)) ...)
+ (match-one ls (r ...) #f #f (sk ... i) fk i)))
+ ((pair? ls)
+ (let ((w (car ls)))
+ (match-one w p (car ls) (set-car! ls)
+ (match-drop-ids
+ (loop (cdr ls) (- n 1) (cons id id-ls) ...))
+ fk
+ i)))
+ (else
+ fk)))))))
+ ))
+
+(define-syntax match-verify-no-ellipses
+ (syntax-rules ()
+ ((_ (x . y) sk)
+ (match-check-ellipse
+ x
+ (match-syntax-error
+ "multiple ellipse patterns not allowed at same level")
+ (match-verify-no-ellipses y sk)))
+ ((_ x sk) sk)
+ ))
+
+;; Vector patterns are just more of the same, with the slight
+;; exception that we pass around the current vector index being
+;; matched.
+
+(define-syntax match-vector
+ (syntax-rules (___)
+ ((_ v n pats (p q) sk fk i)
+ (match-check-ellipse q
+ (match-vector-ellipses v n pats p sk fk i)
+ (match-vector-two v n pats (p q) sk fk i)))
+ ((_ v n pats (p ___) sk fk i)
+ (match-vector-ellipses v n pats p sk fk i))
+ ((_ . x)
+ (match-vector-two . x))))
+
+;; Check the exact vector length, then check each element in turn.
+
+(define-syntax match-vector-two
+ (syntax-rules ()
+ ((_ v n ((pat index) ...) () sk fk i)
+ (if (vector? v)
+ (let ((len (vector-length v)))
+ (if (= len n)
+ (match-vector-step v ((pat index) ...) sk fk i)
+ fk))
+ fk))
+ ((_ v n (pats ...) (p . q) sk fk i)
+ (match-vector v (+ n 1) (pats ... (p n)) q sk fk i))
+ ))
+
+(define-syntax match-vector-step
+ (syntax-rules ()
+ ((_ v () (sk ...) fk i) (sk ... i))
+ ((_ v ((pat index) . rest) sk fk i)
+ (let ((w (vector-ref v index)))
+ (match-one w pat (vector-ref v index) (vector-set! v index)
+ (match-vector-step v rest sk fk)
+ fk i)))))
+
+;; With a vector ellipse pattern we first check to see if the vector
+;; length is at least the required length.
+
+(define-syntax match-vector-ellipses
+ (syntax-rules ()
+ ((_ v n ((pat index) ...) p sk fk i)
+ (if (vector? v)
+ (let ((len (vector-length v)))
+ (if (>= len n)
+ (match-vector-step v ((pat index) ...)
+ (match-vector-tail v p n len sk fk)
+ fk i)
+ fk))
+ fk))))
+
+(define-syntax match-vector-tail
+ (syntax-rules ()
+ ((_ v p n len sk fk i)
+ (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
+
+(define-syntax match-vector-tail-two
+ (syntax-rules ()
+ ((_ v p n len (sk ...) fk i ((id id-ls) ...))
+ (let loop ((j n) (id-ls '()) ...)
+ (if (>= j len)
+ (let ((id (reverse id-ls)) ...) (sk ... i))
+ (let ((w (vector-ref v j)))
+ (match-one w p (vector-ref v j) (vetor-set! v j)
+ (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
+ fk i)))))))
+
+;; Extract all identifiers in a pattern. A little more complicated
+;; than just looking for symbols, we need to ignore special keywords
+;; and not pattern forms (such as the predicate expression in ?
+;; patterns).
+;;
+;; (match-extract-vars pattern continuation (ids ...) (new-vars ...))
+
+(define-syntax match-extract-vars
+ (syntax-rules (_ ___ ? $ = quote quasiquote and or not get! set!)
+ ((match-extract-vars (? pred . p) k i v)
+ (match-extract-vars p k i v))
+ ((match-extract-vars ($ rec . p) k i v)
+ (match-extract-vars p k i v))
+ ((match-extract-vars (= proc p) k i v)
+ (match-extract-vars p k i v))
+ ((match-extract-vars (quote x) (k ...) i v)
+ (k ... v))
+ ((match-extract-vars (quasiquote x) k i v)
+ (match-extract-quasiquote-vars x k i v (#t)))
+ ((match-extract-vars (and . p) k i v)
+ (match-extract-vars p k i v))
+ ((match-extract-vars (or . p) k i v)
+ (match-extract-vars p k i v))
+ ((match-extract-vars (not . p) k i v)
+ (match-extract-vars p k i v))
+ ;; A non-keyword pair, expand the CAR with a continuation to
+ ;; expand the CDR.
+ ((match-extract-vars (p q . r) k i v)
+ (match-check-ellipse
+ q
+ (match-extract-vars (p . r) k i v)
+ (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
+ ((match-extract-vars (p . q) k i v)
+ (match-extract-vars p (match-extract-vars-step q k i v) i ()))
+ ((match-extract-vars #(p ...) k i v)
+ (match-extract-vars (p ...) k i v))
+ ((match-extract-vars _ (k ...) i v) (k ... v))
+ ((match-extract-vars ___ (k ...) i v) (k ... v))
+ ;; This is the main part, the only place where we might add a new
+ ;; var if it's an unbound symbol.
+ ((match-extract-vars p (k ...) (i ...) v)
+ (let-syntax
+ ((new-sym?
+ (syntax-rules (i ...)
+ ((new-sym? p sk fk) sk)
+ ((new-sym? x sk fk) fk))))
+ (new-sym? random-sym-to-match
+ (k ... ((p p-ls) . v))
+ (k ... v))))
+ ))
+
+;; Stepper used in the above so it can expand the CAR and CDR
+;; separately.
+
+(define-syntax match-extract-vars-step
+ (syntax-rules ()
+ ((_ p k i v ((v2 v2-ls) ...))
+ (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))
+ ))
+
+(define-syntax match-extract-quasiquote-vars
+ (syntax-rules (quasiquote unquote unquote-splicing)
+ ((match-extract-quasiquote-vars (quasiquote x) k i v d)
+ (match-extract-quasiquote-vars x k i v (#t . d)))
+ ((match-extract-quasiquote-vars (unquote-splicing x) k i v d)
+ (match-extract-quasiquote-vars (unquote x) k i v d))
+ ((match-extract-quasiquote-vars (unquote x) k i v (#t))
+ (match-extract-vars x k i v))
+ ((match-extract-quasiquote-vars (unquote x) k i v (#t . d))
+ (match-extract-quasiquote-vars x k i v d))
+ ((match-extract-quasiquote-vars (x . y) k i v (#t . d))
+ (match-extract-quasiquote-vars
+ x
+ (match-extract-quasiquote-vars-step y k i v d) i ()))
+ ((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
+ (match-extract-quasiquote-vars (x ...) k i v d))
+ ((match-extract-quasiquote-vars x (k ...) i v (#t . d))
+ (k ... v))
+ ))
+
+(define-syntax match-extract-quasiquote-vars-step
+ (syntax-rules ()
+ ((_ x k i v d ((v2 v2-ls) ...))
+ (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))
+ ))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Gimme some sugar baby.
+
+(define-syntax match-lambda
+ (syntax-rules ()
+ ((_ clause ...) (lambda (expr) (match expr clause ...)))))
+
+(define-syntax match-lambda*
+ (syntax-rules ()
+ ((_ clause ...) (lambda expr (match expr clause ...)))))
+
+(define-syntax match-let
+ (syntax-rules ()
+ ((_ (vars ...) . body)
+ (match-let/helper let () () (vars ...) . body))
+ ((_ loop . rest)
+ (match-named-let loop () . rest))))
+
+(define-syntax match-letrec
+ (syntax-rules ()
+ ((_ vars . body) (match-let/helper letrec () () vars . body))))
+
+(define-syntax match-let/helper
+ (syntax-rules ()
+ ((_ let ((var expr) ...) () () . body)
+ (let ((var expr) ...) . body))
+ ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
+ (let ((var expr) ...)
+ (match-let* ((pat tmp) ...)
+ . body)))
+ ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
+ (match-let/helper
+ let (v ... (tmp expr)) (p ... ((a . b) tmp)) rest . body))
+ ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
+ (match-let/helper
+ let (v ... (tmp expr)) (p ... (#(a ...) tmp)) rest . body))
+ ((_ let (v ...) (p ...) ((a expr) . rest) . body)
+ (match-let/helper let (v ... (a expr)) (p ...) rest . body))
+ ))
+
+(define-syntax match-named-let
+ (syntax-rules ()
+ ((_ loop ((pat expr var) ...) () . body)
+ (let loop ((var expr) ...)
+ (match-let ((pat var) ...)
+ . body)))
+ ((_ loop (v ...) ((pat expr) . rest) . body)
+ (match-named-let loop (v ... (pat expr tmp)) rest . body))))
+
+(define-syntax match-let*
+ (syntax-rules ()
+ ((_ () . body)
+ (begin . body))
+ ((_ ((pat expr) . rest) . body)
+ (match expr (pat (match-let* rest . body))))))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Not quite portable bits.
+
+;; Matching ellipses `...' is tricky. A strict interpretation of R5RS
+;; would suggest that `...' in the literals list would treat it as a
+;; literal in pattern, however no SYNTAX-RULES implementation I'm
+;; aware of currently supports this. SRFI-46 support would makes this
+;; easy, but SRFI-46 also is widely unsupported.
+
+;; In the meantime we conditionally implement this in whatever
+;; low-level macro system is available, defaulting to an
+;; implementation which doesn't support `...' and requires the user to
+;; match with `___'.
+
+(define-syntax match-check-ellipse
+ (syntax-rules ___ (...)
+ ((_ ... sk fk) sk)
+ ((_ x sk fk) fk)))
+
+(define-syntax match-check-identifier
+ (syntax-rules ()
+ ((_ (x . y) sk fk) fk)
+ ((_ #(x ...) sk fk) fk)
+ ((_ x sk fk)
+ (let-syntax
+ ((sym?
+ (syntax-rules ()
+ ((sym? x sk2 fk2) sk2)
+ ((sym? y sk2 fk2) fk2))))
+ (sym? abracadabra sk fk))) ))
diff --git a/tests/meta-syntax-test.scm b/tests/meta-syntax-test.scm
new file mode 100755
index 00000000..4ce32f11
--- /dev/null
+++ b/tests/meta-syntax-test.scm
@@ -0,0 +1,11 @@
+;;; currently disabled, need to compile matchable properly
+
+(module foo (bar)
+ (import scheme chicken)
+ (import-for-syntax matchable)
+ (begin-for-syntax
+ (define (baz x)
+ (match x
+ ((_ y) (list y)))))
+ (define-syntax (bar x r c)
+ `(,(r 'print) (,(r 'list) (baz (list 1 ,(cadr x)))))))
diff --git a/tests/module-tests-compiled.scm b/tests/module-tests-compiled.scm
new file mode 100644
index 00000000..66031acb
--- /dev/null
+++ b/tests/module-tests-compiled.scm
@@ -0,0 +1,43 @@
+;;;; module-tests-compiled.scm
+
+
+(include "test.scm")
+
+(test-begin "modules/compiled")
+
+
+;; inlines where walked twice (once for extracting mutable constants)
+;; and then when expanded, this caused inline function names to be
+;; aliased/renamed twice - also, aliasing in syntax-defs could make
+;; inline func unrecognizable for canonicalizer.
+
+(module m1 (f1)
+ (import scheme chicken)
+ (define-inline (bar x) (cons x '(foo)))
+ (define-syntax s1
+ (syntax-rules ()
+ ((_ x) (list (bar x)))))
+ (define (f1 x) (s1 x)))
+
+(import m1)
+(test-equal "inline in syntax" (f1 'ok) '((ok foo)))
+
+
+;; here, the identical names of alias/real id pairs in primitive
+;; modules with prefix applied would cause the second to be marked
+;; ##core#aliase'd. That would avoid renaming of the newly defined
+;; vector-fill!.
+
+(module m2 (vector-fill!)
+ (import (except scheme vector-fill!)
+ (prefix (only scheme vector-fill!) %))
+ (define (vector-fill! x v)
+ (%vector-fill! v x)
+ v))
+
+(import m2)
+(define v (vector 1 2 3))
+(test-equal "unmarked primitive exports" (vector-fill! 99 v) '#(99 99 99))
+
+
+(test-end "modules")
diff --git a/tests/module-tests.scm b/tests/module-tests.scm
new file mode 100644
index 00000000..7372423d
--- /dev/null
+++ b/tests/module-tests.scm
@@ -0,0 +1,159 @@
+;;;; module-tests.scm
+
+
+(cond-expand
+ (compiling
+ (include "test.scm") )
+ (else
+ (load-relative "test.scm")))
+
+(test-begin "modules")
+
+(test-equal "internal/variable"
+(module foo (abc def)
+ (import scheme)
+ (define (abc x) (+ x 33))
+ (define-syntax def
+ (syntax-rules ()
+ ((_ x) (+ 99 (abc x)))))
+ (abc 1))
+34)
+
+(test-error "external/unimported variable (fail)" (abc 2))
+(test-error "external/unimported syntax (fail)" (def 3))
+
+(import foo)
+
+(test-equal "external/imported variable" (abc 4) 37)
+(test-equal "external/imported syntax" (def 5) 137)
+
+(module bar (x y)
+ (import (prefix scheme s:))
+ (s:define (x y) (s:* y 2))
+ (s:define y 1))
+
+(import (prefix (only (except (rename bar (x z)) y) z) "bar-"))
+(test-equal "modified import" (bar-z 10) 20)
+(test-error "hidden import" y)
+
+(module baz ((x s:list))
+ (import (prefix scheme s:))
+ (define-syntax x
+ (syntax-rules ()
+ ((_ x) (s:list x)))))
+
+(import baz)
+(test-equal "prefixed import and reexport" (x 1) '(1))
+
+(module m1 ((bar gna))
+ (import scheme)
+ (define (gna x) (list 'gna x))
+ (define-syntax bar
+ (syntax-rules ()
+ ((_ x) (baz x))))
+ (define-syntax baz
+ (syntax-rules ()
+ ((_ x) (gna 'x)))))
+
+(module m2 (run)
+ (import scheme chicken m1)
+ (define-syntax baz
+ (syntax-rules ()
+ ((_ x) (list 'goo 'x))))
+ (define (gna x) (print "ok."))
+ (define (run) (gna 9) (bar 99)))
+
+(import (only m2 run))
+(test-equal "indirect imports" (run) '(gna 99))
+
+(module m1 ((s1 f1))
+ (import scheme chicken)
+ (define (f1) (print "f1") 'f1)
+ (define-syntax s1
+ (syntax-rules ()
+ ((_) (f1)))))
+
+(module m2 (s2)
+ (import scheme m1)
+ (define-syntax s2
+ (syntax-rules ()
+ ((_) (s1)))))
+
+(module m3 (s3)
+ (import scheme m2)
+ (define-syntax s3
+ (syntax-rules ()
+ ((_) (s2)))))
+
+(import m3)
+(test-equal "chained indirect imports" (s3) 'f1)
+
+(module literal-compare-test (s1)
+ (import scheme)
+ (define-syntax s1
+ (syntax-rules (and)
+ ((_ (and x)) (list x))))
+)
+
+(import literal-compare-test)
+(test-equal "literal compare and export" (s1 (and 100)) '(100))
+
+(module y (y1)
+ (import scheme)
+ (define y1 10))
+
+(module x (magnitude)
+ (import (except scheme magnitude) y)
+ (define magnitude y1))
+
+(test-equal "redefinition of indirect import" (procedure? magnitude) #t)
+
+(import x)
+(test-equal "redefinition of indirect import (II)" magnitude 10)
+
+(module m10 (m10x m10y)
+ (import scheme)
+ (define m10x 99)
+ (define-syntax m10y
+ (syntax-rules ()
+ ((_ x) (list 'x)))))
+
+(module m11 (m10x m10y)
+ (import m10))
+
+(import m11)
+(test-equal "value reexport" m10x 99)
+(test-equal "syntax reexport" (m10y 3) '(3))
+
+;; found by Jim Ursetto;
+
+(module m12 (begin0)
+ (import scheme)
+ (define-syntax begin0
+ (syntax-rules ()
+ ((_ e0 e1 ...)
+ (##sys#call-with-values
+ (lambda () e0)
+ (lambda var
+ (begin
+ e1 ...
+ (apply ##sys#values var))))))))
+
+(test-equal "primitive indirect value-binding reexport"
+ (module m13 ()
+ (import m12) ; note absence of "scheme"
+ (begin0 1 2 3))
+ 1)
+
+(module m14 (test-extlambda)
+ (import chicken scheme)
+ (define (test-extlambda string #!optional whatever)
+ string))
+
+(import m14)
+
+(test-equal "extended lambda list uses expansion environment"
+ "some text"
+ (test-extlambda "some text"))
+
+(test-end "modules")
diff --git a/tests/path-tests.scm b/tests/path-tests.scm
new file mode 100644
index 00000000..ebeb835c
--- /dev/null
+++ b/tests/path-tests.scm
@@ -0,0 +1,73 @@
+(use files)
+
+(assert (equal? "/" (pathname-directory "/")))
+(assert (equal? "/" (pathname-directory "/abc")))
+(assert (equal? "abc" (pathname-directory "abc/")))
+(assert (equal? "abc" (pathname-directory "abc/def")))
+(assert (equal? "abc" (pathname-directory "abc/def.ghi")))
+(assert (equal? "abc" (pathname-directory "abc/.def.ghi")))
+(assert (equal? "abc" (pathname-directory "abc/.ghi")))
+(assert (equal? "/abc" (pathname-directory "/abc/")))
+(assert (equal? "/abc" (pathname-directory "/abc/def")))
+(assert (equal? "/abc" (pathname-directory "/abc/def.ghi")))
+(assert (equal? "/abc" (pathname-directory "/abc/.def.ghi")))
+(assert (equal? "/abc" (pathname-directory "/abc/.ghi")))
+(assert (equal? "q/abc" (pathname-directory "q/abc/")))
+(assert (equal? "q/abc" (pathname-directory "q/abc/def")))
+(assert (equal? "q/abc" (pathname-directory "q/abc/def.ghi")))
+(assert (equal? "q/abc" (pathname-directory "q/abc/.def.ghi")))
+(assert (equal? "q/abc" (pathname-directory "q/abc/.ghi")))
+
+(define-syntax test
+ (syntax-rules ()
+ ((_ expected exp)
+ (let ((result exp)
+ (expd expected))
+ (unless (equal? result expd)
+ (error "test failed" result expd 'exp))))))
+
+(test "./" (normalize-pathname "" 'unix))
+(test ".\\" (normalize-pathname "" 'windows))
+(test "\\..\\" (normalize-pathname "/../" 'windows))
+(test "\\." (normalize-pathname "/abc/../." 'windows))
+(test "/." (normalize-pathname "/" 'unix))
+(test "/." (normalize-pathname "/./" 'unix))
+(test "/." (normalize-pathname "/." 'unix))
+(test "./" (normalize-pathname "./" 'unix))
+(test "a" (normalize-pathname "a"))
+(test "a/" (normalize-pathname "a/" 'unix))
+(test "a/b" (normalize-pathname "a/b" 'unix))
+(test "a/b" (normalize-pathname "a\\b" 'unix))
+(test "a\\b" (normalize-pathname "a\\b" 'windows))
+(test "a\\b" (normalize-pathname "a/b" 'windows))
+(test "a/b/" (normalize-pathname "a/b/" 'unix))
+(test "a/b/" (normalize-pathname "a/b//" 'unix))
+(test "a/b" (normalize-pathname "a//b" 'unix))
+(test "/a/b" (normalize-pathname "/a//b" 'unix))
+(test "/a/b" (normalize-pathname "///a//b" 'unix))
+(test "c:a\\b" (normalize-pathname "c:a/./b" 'windows))
+(test "c:/a/b" (normalize-pathname "c:/a/./b" 'unix))
+(test "c:a\\b" (normalize-pathname "c:a/./b" 'windows))
+(test "c:b" (normalize-pathname "c:a/../b" 'windows))
+(test "c:\\b" (normalize-pathname "c:\\a\\..\\b" 'windows))
+(test "a/b" (normalize-pathname "a/./././b" 'unix))
+(test "a/b" (normalize-pathname "a/b/c/d/../.." 'unix))
+(test "a/b/" (normalize-pathname "a/b/c/d/../../" 'unix))
+
+(define home (get-environment-variable "HOME"))
+
+(test (string-append home "/foo") (normalize-pathname "~/foo" 'unix))
+(test "c:~/foo" (normalize-pathname "c:~/foo" 'unix))
+(test (string-append home "\\foo") (normalize-pathname "c:~\\foo" 'windows))
+
+(assert (directory-null? "/.//"))
+(assert (directory-null? ""))
+(assert (not (directory-null? "//foo//")))
+
+(test '(#f "/" (".")) (receive (decompose-directory "/.//")))
+(test '(#f "\\" (".")) (receive (decompose-directory (normalize-pathname "/.//" 'windows))))
+(test '(#f "/" #f) (receive (decompose-directory "///\\///")))
+(test '(#f "/" ("foo")) (receive (decompose-directory "//foo//")))
+(test '(#f "/" ("foo" "bar")) (receive (decompose-directory "//foo//bar")))
+(test '(#f #f (" " "foo" "bar")) (receive (decompose-directory " //foo//bar")))
+(test '(#f #f ("foo" "bar")) (receive (decompose-directory "foo//bar/")))
diff --git a/tests/port-tests.scm b/tests/port-tests.scm
new file mode 100644
index 00000000..4b99cf73
--- /dev/null
+++ b/tests/port-tests.scm
@@ -0,0 +1,35 @@
+(require-extension srfi-1)
+
+(define *text* #<<EOF
+this is a test
+<foof> #;33> (let ((in (open-input-string ""))) (close-input-port in)
+ (read-char in)) [09:40]
+<foof> Error: (read-char) port already closed: #<input port "(string)">
+<foof> #;33> (let ((in (open-input-string ""))) (close-input-port in)
+ (read-line in))
+<foof> Error: call of non-procedure: #t
+<foof> ... that's a little odd
+<Bunny351> yuck. [09:44]
+<Bunny351> double yuck. [10:00]
+<sjamaan> yuck squared! [10:01]
+<Bunny351> yuck powered by yuck
+<Bunny351> (to the power of yuck, of course) [10:02]
+<pbusser3> My yuck is bigger than yours!!!
+<foof> yuck!
+<foof> (that's a factorial)
+<sjamaan> heh
+<sjamaan> I think you outyucked us all [10:03]
+<foof> well, for large enough values of yuck, yuck! ~= yuck^yuck [10:04]
+ERC>
+EOF
+)
+
+(define p (open-input-string *text*))
+
+(assert (string=? "this is a test" (read-line p)))
+
+(assert
+ (string=?
+ "<foof> #;33> (let ((in (open-input-string \"\"))) (close-input-port in)"
+ (read-line p)))
+(assert (= 20 (length (read-lines (open-input-string *text*)))))
diff --git a/tests/posix-tests.scm b/tests/posix-tests.scm
new file mode 100644
index 00000000..e069a5af
--- /dev/null
+++ b/tests/posix-tests.scm
@@ -0,0 +1,18 @@
+(use files posix)
+
+(define-constant SOME-POS 123456)
+
+(let ((tnpfilpn (create-temporary-file)))
+ (let ((tmpfilno (file-open tnpfilpn (+ open/rdwr open/creat open/text))))
+ (set-file-position! tmpfilno SOME-POS seek/end)
+ (assert (= SOME-POS (file-position tmpfilno)))
+ (file-close tmpfilno)
+ (delete-file* tnpfilpn) ) )
+
+(let ((tnpfilpn (create-temporary-file)))
+ (let ((tmpfilno (file-open tnpfilpn (+ open/rdwr open/creat open/text))))
+ (let ((port (open-output-file* tmpfilno)))
+ (set-file-position! port SOME-POS seek/end)
+ (assert (= SOME-POS (file-position port)))
+ (close-output-port port)
+ (delete-file* tnpfilpn) ) ) )
diff --git a/tests/r4rstest.out b/tests/r4rstest.out
new file mode 100644
index 00000000..f34b9cc5
--- /dev/null
+++ b/tests/r4rstest.out
@@ -0,0 +1,792 @@
+SECTION(2 1)
+SECTION(3 4)
+ #<procedure>
+ #<procedure>
+ #<procedure>
+ #<procedure>
+ #<procedure>
+ #<procedure>
+ #<procedure>
+ #<procedure>
+ #<procedure>
+(#t #f #f #f #f #f #f #f #f)#t
+(#t #f #f #f #f #f #f #f #f)#f
+(#f #t #f #f #f #f #f #f #f)#\a
+(#f #f #t #f #f #f #f #f #f)()
+(#f #f #f #t #f #f #f #f #f)9739
+(#f #f #f #f #t #f #f #f #f)(test)
+(#f #f #f #f #f #t #f #f #f)#<procedure>
+(#f #f #f #f #f #f #t #f #f)"test"
+(#f #f #f #f #f #f #t #f #f)""
+(#f #f #f #f #f #f #f #t #f)test
+(#f #f #f #f #f #f #f #f #t)#()
+(#f #f #f #f #f #f #f #f #t)#(a b c)
+SECTION(4 1 2)
+(quote (quote a)) ==> (quote a)
+(quote (quote a)) ==> (quote a)
+SECTION(4 1 3)
+(#<procedure> 3 4) ==> 12
+SECTION(4 1 4)
+(#<procedure> 4) ==> 8
+(#<procedure> 7 10) ==> 3
+(#<procedure> 6) ==> 10
+(#<procedure> 3 4 5 6) ==> (3 4 5 6)
+(#<procedure> 3 4 5 6) ==> (5 6)
+SECTION(4 1 5)
+(if yes) ==> yes
+(if no) ==> no
+(if 1) ==> 1
+SECTION(4 1 6)
+(define 3) ==> 3
+(set! 5) ==> 5
+SECTION(4 2 1)
+(cond greater) ==> greater
+(cond equal) ==> equal
+(cond 2) ==> 2
+(case composite) ==> composite
+(case consonant) ==> consonant
+(and #t) ==> #t
+(and #f) ==> #f
+(and (f g)) ==> (f g)
+(and #t) ==> #t
+(or #t) ==> #t
+(or #t) ==> #t
+(or #f) ==> #f
+(or #f) ==> #f
+(or (b c)) ==> (b c)
+SECTION(4 2 2)
+(let 6) ==> 6
+(let 35) ==> 35
+(let* 70) ==> 70
+(letrec #t) ==> #t
+(let 5) ==> 5
+(let 34) ==> 34
+(let 6) ==> 6
+(let 34) ==> 34
+(let* 7) ==> 7
+(let* 34) ==> 34
+(let* 8) ==> 8
+(let* 34) ==> 34
+(letrec 9) ==> 9
+(letrec 34) ==> 34
+(letrec 10) ==> 10
+(letrec 34) ==> 34
+SECTION(4 2 3)
+(begin 6) ==> 6
+SECTION(4 2 4)
+(do #(0 1 2 3 4)) ==> #(0 1 2 3 4)
+(do 25) ==> 25
+(let 1) ==> 1
+(let ((6 1 3) (-5 -2))) ==> ((6 1 3) (-5 -2))
+(let -1) ==> -1
+SECTION(4 2 6)
+(quasiquote (list 3 4)) ==> (list 3 4)
+(quasiquote (list a (quote a))) ==> (list a (quote a))
+(quasiquote (a 3 4 5 6 b)) ==> (a 3 4 5 6 b)
+(quasiquote ((foo 7) . cons)) ==> ((foo 7) . cons)
+(quasiquote #(10 5 2 4 3 8)) ==> #(10 5 2 4 3 8)
+(quasiquote 5) ==> 5
+(quasiquote (a (quasiquote (b (unquote (+ 1 2)) (unquote (foo 4 d)) e)) f)) ==> (a (quasiquote (b (unquote (+ 1 2)) (unquote (foo 4 d)) e)) f)
+(quasiquote (a (quasiquote (b (unquote x) (unquote (quote y)) d)) e)) ==> (a (quasiquote (b (unquote x) (unquote (quote y)) d)) e)
+(quasiquote (list 3 4)) ==> (list 3 4)
+(quasiquote (quasiquote (list (unquote (+ 1 2)) 4))) ==> (quasiquote (list (unquote (+ 1 2)) 4))
+SECTION(5 2 1)
+(define 6) ==> 6
+(define 1) ==> 1
+(#<procedure> 6) ==> (3 6)
+(#<procedure> 6) ==> 9
+SECTION(5 2 2)
+(#<procedure>) ==> 5
+(define 34) ==> 34
+(#<procedure>) ==> 5
+(define 34) ==> 34
+(#<procedure> 88) ==> 88
+(#<procedure> 4) ==> 4
+(define 34) ==> 34
+(internal-define 99) ==> 99
+(internal-define 77) ==> 77
+SECTION(6 1)
+(#<procedure> #t) ==> #f
+(#<procedure> 3) ==> #f
+(#<procedure> (3)) ==> #f
+(#<procedure> #f) ==> #t
+(#<procedure> ()) ==> #f
+(#<procedure> ()) ==> #f
+(#<procedure> nil) ==> #f
+SECTION(6 2)
+(#<procedure> a a) ==> #t
+(#<procedure> a b) ==> #f
+(#<procedure> 2 2) ==> #t
+(#<procedure> () ()) ==> #t
+(#<procedure> 10000 10000) ==> #t
+(#<procedure> (1 . 2) (1 . 2)) ==> #f
+(#<procedure> #<procedure> #<procedure>) ==> #f
+(#<procedure> #f nil) ==> #f
+(#<procedure> #<procedure> #<procedure>) ==> #t
+(#<procedure> #<procedure> #<procedure>) ==> #t
+(#<procedure> #<procedure> #<procedure>) ==> #f
+(#<procedure> #<procedure> #<procedure>) ==> #f
+(#<procedure> a a) ==> #t
+(#<procedure> (a) (a)) ==> #f
+(#<procedure> () ()) ==> #t
+(#<procedure> #<procedure> #<procedure>) ==> #t
+(#<procedure> (a) (a)) ==> #t
+(#<procedure> #() #()) ==> #t
+(#<procedure> #<procedure> #<procedure>) ==> #t
+(#<procedure> a a) ==> #t
+(#<procedure> (a) (a)) ==> #t
+(#<procedure> (a (b) c) (a (b) c)) ==> #t
+(#<procedure> "abc" "abc") ==> #t
+(#<procedure> 2 2) ==> #t
+(#<procedure> #(a a a a a) #(a a a a a)) ==> #t
+SECTION(6 3)
+(dot (a b c d e)) ==> (a b c d e)
+(#<procedure> (a b c)) ==> #t
+(set-cdr! (a . 4)) ==> (a . 4)
+(#<procedure> (a . 4) (a . 4)) ==> #t
+(dot (a b c . d)) ==> (a b c . d)
+(#<procedure> (a . 4)) ==> #f
+(list? #f) ==> #f
+(#<procedure> a ()) ==> (a)
+(#<procedure> (a) (b c d)) ==> ((a) b c d)
+(#<procedure> "a" (b c)) ==> ("a" b c)
+(#<procedure> a 3) ==> (a . 3)
+(#<procedure> (a b) c) ==> ((a b) . c)
+(#<procedure> (a b c)) ==> a
+(#<procedure> ((a) b c d)) ==> (a)
+(#<procedure> (1 . 2)) ==> 1
+(#<procedure> ((a) b c d)) ==> (b c d)
+(#<procedure> (1 . 2)) ==> 2
+(#<procedure> a 7 c) ==> (a 7 c)
+(#<procedure>) ==> ()
+(#<procedure> (a b c)) ==> 3
+(#<procedure> (a (b) (c d e))) ==> 3
+(#<procedure> ()) ==> 0
+(#<procedure> (x) (y)) ==> (x y)
+(#<procedure> (a) (b c d)) ==> (a b c d)
+(#<procedure> (a (b)) ((c))) ==> (a (b) (c))
+(#<procedure>) ==> ()
+(#<procedure> (a b) (c . d)) ==> (a b c . d)
+(#<procedure> () a) ==> a
+(#<procedure> (a b c)) ==> (c b a)
+(#<procedure> (a (b c) d (e (f)))) ==> ((e (f)) d (b c) a)
+(#<procedure> (a b c d) 2) ==> c
+(#<procedure> a (a b c)) ==> (a b c)
+(#<procedure> b (a b c)) ==> (b c)
+(#<procedure> a (b c d)) ==> #f
+(#<procedure> (a) (b (a) c)) ==> #f
+(#<procedure> (a) (b (a) c)) ==> ((a) c)
+(#<procedure> 101 (100 101 102)) ==> (101 102)
+(#<procedure> a ((a 1) (b 2) (c 3))) ==> (a 1)
+(#<procedure> b ((a 1) (b 2) (c 3))) ==> (b 2)
+(#<procedure> d ((a 1) (b 2) (c 3))) ==> #f
+(#<procedure> (a) (((a)) ((b)) ((c)))) ==> #f
+(#<procedure> (a) (((a)) ((b)) ((c)))) ==> ((a))
+(#<procedure> 5 ((2 3) (5 7) (11 13))) ==> (5 7)
+SECTION(6 4)
+(#<procedure> a) ==> #t
+(standard-case #t) ==> #t
+(standard-case #t) ==> #t
+(#<procedure> flying-fish) ==> "flying-fish"
+(#<procedure> martin) ==> "martin"
+(#<procedure> Malvina) ==> "Malvina"
+(standard-case #t) ==> #t
+(string-set! "cb") ==> "cb"
+(#<procedure> ab) ==> "ab"
+(#<procedure> "ab") ==> ab
+(#<procedure> mississippi mississippi) ==> #t
+(string->symbol #f) ==> #f
+(#<procedure> "jollywog") ==> jollywog
+SECTION(6 5 5)
+(#<procedure> 3) ==> #t
+(#<procedure> 3) ==> #t
+(#<procedure> 3) ==> #t
+(#<procedure> 3) ==> #t
+(#<procedure> 3) ==> #t
+(#<procedure> 3) ==> #t
+(#<procedure> 3) ==> #f
+(#<procedure> 22 22 22) ==> #t
+(#<procedure> 22 22) ==> #t
+(#<procedure> 34 34 35) ==> #f
+(#<procedure> 34 35) ==> #f
+(#<procedure> 3 -6246) ==> #t
+(#<procedure> 9 9 -2424) ==> #f
+(#<procedure> 3 -4 -6246) ==> #t
+(#<procedure> 9 9) ==> #t
+(#<procedure> 8 9) ==> #f
+(#<procedure> -1 2 3 4 5 6 7 8) ==> #t
+(#<procedure> -1 2 3 4 4 5 6 7) ==> #f
+(#<procedure> -1 2 3 4 5 6 7 8) ==> #t
+(#<procedure> -1 2 3 4 4 5 6 7) ==> #t
+(#<procedure> 1 3 2) ==> #f
+(#<procedure> 1 3 2) ==> #f
+(#<procedure> 0) ==> #t
+(#<procedure> 1) ==> #f
+(#<procedure> -1) ==> #f
+(#<procedure> -100) ==> #f
+(#<procedure> 4) ==> #t
+(#<procedure> -4) ==> #f
+(#<procedure> 0) ==> #f
+(#<procedure> 4) ==> #f
+(#<procedure> -4) ==> #t
+(#<procedure> 0) ==> #f
+(#<procedure> 3) ==> #t
+(#<procedure> 2) ==> #f
+(#<procedure> -4) ==> #f
+(#<procedure> -1) ==> #t
+(#<procedure> 3) ==> #f
+(#<procedure> 2) ==> #t
+(#<procedure> -4) ==> #t
+(#<procedure> -1) ==> #f
+(#<procedure> 34 5 7 38 6) ==> 38
+(#<procedure> 3 5 5 330 4 -24) ==> -24
+(#<procedure> 3 4) ==> 7
+(#<procedure> 3) ==> 3
+(#<procedure>) ==> 0
+(#<procedure> 4) ==> 4
+(#<procedure>) ==> 1
+(#<procedure> 3 4) ==> -1
+(#<procedure> 3) ==> -3
+(#<procedure> -7) ==> 7
+(#<procedure> 7) ==> 7
+(#<procedure> 0) ==> 0
+(#<procedure> 35 7) ==> 5
+(#<procedure> -35 7) ==> -5
+(#<procedure> 35 -7) ==> -5
+(#<procedure> -35 -7) ==> 5
+(#<procedure> 13 4) ==> 1
+(#<procedure> 13 4) ==> 1
+(#<procedure> -13 4) ==> 3
+(#<procedure> -13 4) ==> -1
+(#<procedure> 13 -4) ==> -3
+(#<procedure> 13 -4) ==> 1
+(#<procedure> -13 -4) ==> -1
+(#<procedure> -13 -4) ==> -1
+(#<procedure> 0 86400) ==> 0
+(#<procedure> 0 -86400) ==> 0
+(#<procedure> 238 9) ==> #t
+(#<procedure> -238 9) ==> #t
+(#<procedure> 238 -9) ==> #t
+(#<procedure> -238 -9) ==> #t
+(#<procedure> 0 4) ==> 4
+(#<procedure> -4 0) ==> 4
+(#<procedure> 32 -36) ==> 4
+(#<procedure>) ==> 0
+(#<procedure> 32 -36) ==> 288
+(#<procedure>) ==> 1
+SECTION(6 5 5)
+(#<procedure> "+#.#") ==> #t
+(#<procedure> "-#.#") ==> #t
+(#<procedure> "#.#") ==> #t
+(#<procedure> "1/0") ==> #t
+(#<procedure> "-1/0") ==> #t
+(#<procedure> "0/0") ==> #t
+(#<procedure> "+1/0i") ==> #t
+(#<procedure> "-1/0i") ==> #t
+(#<procedure> "0/0i") ==> #t
+(#<procedure> "0/0-0/0i") ==> #t
+(#<procedure> "1/0-1/0i") ==> #t
+(#<procedure> "-1/0+1/0i") ==> #t
+(#<procedure> "#i") ==> #t
+(#<procedure> "#e") ==> #t
+(#<procedure> "#") ==> #t
+(#<procedure> "#i0/0") ==> #t
+SECTION(6 5 9)
+(#<procedure> 0) ==> "0"
+(#<procedure> 100) ==> "100"
+(#<procedure> 256 16) ==> "100"
+(#<procedure> "100") ==> 100
+(#<procedure> "100" 16) ==> 256
+(#<procedure> "") ==> #f
+(#<procedure> ".") ==> #f
+(#<procedure> "d") ==> #f
+(#<procedure> "D") ==> #f
+(#<procedure> "i") ==> #f
+(#<procedure> "I") ==> #f
+(#<procedure> "3i") ==> #f
+(#<procedure> "3I") ==> #f
+(#<procedure> "33i") ==> #f
+(#<procedure> "33I") ==> #f
+(#<procedure> "3.3i") ==> #f
+(#<procedure> "3.3I") ==> #f
+(#<procedure> "-") ==> #f
+(#<procedure> "+") ==> #f
+(string->number #t) ==> #t
+(string->number #t) ==> #t
+SECTION(6 6)
+(#<procedure> #\a) ==> #t
+(#<procedure> #\() ==> #t
+(#<procedure> #\space) ==> #t
+(#<procedure> #\newline) ==> #t
+(#<procedure> #\A #\B) ==> #f
+(#<procedure> #\a #\b) ==> #f
+(#<procedure> #\9 #\0) ==> #f
+(#<procedure> #\A #\A) ==> #t
+(#<procedure> #\A #\B) ==> #t
+(#<procedure> #\a #\b) ==> #t
+(#<procedure> #\9 #\0) ==> #f
+(#<procedure> #\A #\A) ==> #f
+(#<procedure> #\A #\B) ==> #f
+(#<procedure> #\a #\b) ==> #f
+(#<procedure> #\9 #\0) ==> #t
+(#<procedure> #\A #\A) ==> #f
+(#<procedure> #\A #\B) ==> #t
+(#<procedure> #\a #\b) ==> #t
+(#<procedure> #\9 #\0) ==> #f
+(#<procedure> #\A #\A) ==> #t
+(#<procedure> #\A #\B) ==> #f
+(#<procedure> #\a #\b) ==> #f
+(#<procedure> #\9 #\0) ==> #t
+(#<procedure> #\A #\A) ==> #t
+(#<procedure> #\A #\B) ==> #f
+(#<procedure> #\a #\B) ==> #f
+(#<procedure> #\A #\b) ==> #f
+(#<procedure> #\a #\b) ==> #f
+(#<procedure> #\9 #\0) ==> #f
+(#<procedure> #\A #\A) ==> #t
+(#<procedure> #\A #\a) ==> #t
+(#<procedure> #\A #\B) ==> #t
+(#<procedure> #\a #\B) ==> #t
+(#<procedure> #\A #\b) ==> #t
+(#<procedure> #\a #\b) ==> #t
+(#<procedure> #\9 #\0) ==> #f
+(#<procedure> #\A #\A) ==> #f
+(#<procedure> #\A #\a) ==> #f
+(#<procedure> #\A #\B) ==> #f
+(#<procedure> #\a #\B) ==> #f
+(#<procedure> #\A #\b) ==> #f
+(#<procedure> #\a #\b) ==> #f
+(#<procedure> #\9 #\0) ==> #t
+(#<procedure> #\A #\A) ==> #f
+(#<procedure> #\A #\a) ==> #f
+(#<procedure> #\A #\B) ==> #t
+(#<procedure> #\a #\B) ==> #t
+(#<procedure> #\A #\b) ==> #t
+(#<procedure> #\a #\b) ==> #t
+(#<procedure> #\9 #\0) ==> #f
+(#<procedure> #\A #\A) ==> #t
+(#<procedure> #\A #\a) ==> #t
+(#<procedure> #\A #\B) ==> #f
+(#<procedure> #\a #\B) ==> #f
+(#<procedure> #\A #\b) ==> #f
+(#<procedure> #\a #\b) ==> #f
+(#<procedure> #\9 #\0) ==> #t
+(#<procedure> #\A #\A) ==> #t
+(#<procedure> #\A #\a) ==> #t
+(#<procedure> #\a) ==> #t
+(#<procedure> #\A) ==> #t
+(#<procedure> #\z) ==> #t
+(#<procedure> #\Z) ==> #t
+(#<procedure> #\0) ==> #f
+(#<procedure> #\9) ==> #f
+(#<procedure> #\space) ==> #f
+(#<procedure> #\;) ==> #f
+(#<procedure> #\a) ==> #f
+(#<procedure> #\A) ==> #f
+(#<procedure> #\z) ==> #f
+(#<procedure> #\Z) ==> #f
+(#<procedure> #\0) ==> #t
+(#<procedure> #\9) ==> #t
+(#<procedure> #\space) ==> #f
+(#<procedure> #\;) ==> #f
+(#<procedure> #\a) ==> #f
+(#<procedure> #\A) ==> #f
+(#<procedure> #\z) ==> #f
+(#<procedure> #\Z) ==> #f
+(#<procedure> #\0) ==> #f
+(#<procedure> #\9) ==> #f
+(#<procedure> #\space) ==> #t
+(#<procedure> #\;) ==> #f
+(#<procedure> #\0) ==> #f
+(#<procedure> #\9) ==> #f
+(#<procedure> #\space) ==> #f
+(#<procedure> #\;) ==> #f
+(#<procedure> #\0) ==> #f
+(#<procedure> #\9) ==> #f
+(#<procedure> #\space) ==> #f
+(#<procedure> #\;) ==> #f
+(#<procedure> 46) ==> #\.
+(#<procedure> 65) ==> #\A
+(#<procedure> 97) ==> #\a
+(#<procedure> #\A) ==> #\A
+(#<procedure> #\a) ==> #\A
+(#<procedure> #\A) ==> #\a
+(#<procedure> #\a) ==> #\a
+SECTION(6 7)
+(#<procedure> "The word \"recursion\\\" has many meanings.") ==> #t
+(string-set! "?**") ==> "?**"
+(#<procedure> #\a #\b #\c) ==> "abc"
+(#<procedure>) ==> ""
+(#<procedure> "abc") ==> 3
+(#<procedure> "abc" 0) ==> #\a
+(#<procedure> "abc" 2) ==> #\c
+(#<procedure> "") ==> 0
+(#<procedure> "ab" 0 0) ==> ""
+(#<procedure> "ab" 1 1) ==> ""
+(#<procedure> "ab" 2 2) ==> ""
+(#<procedure> "ab" 0 1) ==> "a"
+(#<procedure> "ab" 1 2) ==> "b"
+(#<procedure> "ab" 0 2) ==> "ab"
+(#<procedure> "foo" "bar") ==> "foobar"
+(#<procedure> "foo") ==> "foo"
+(#<procedure> "foo" "") ==> "foo"
+(#<procedure> "" "foo") ==> "foo"
+(#<procedure>) ==> ""
+(#<procedure> 0) ==> ""
+(#<procedure> "" "") ==> #t
+(#<procedure> "" "") ==> #f
+(#<procedure> "" "") ==> #f
+(#<procedure> "" "") ==> #t
+(#<procedure> "" "") ==> #t
+(#<procedure> "" "") ==> #t
+(#<procedure> "" "") ==> #f
+(#<procedure> "" "") ==> #f
+(#<procedure> "" "") ==> #t
+(#<procedure> "" "") ==> #t
+(#<procedure> "A" "B") ==> #f
+(#<procedure> "a" "b") ==> #f
+(#<procedure> "9" "0") ==> #f
+(#<procedure> "A" "A") ==> #t
+(#<procedure> "A" "B") ==> #t
+(#<procedure> "a" "b") ==> #t
+(#<procedure> "9" "0") ==> #f
+(#<procedure> "A" "A") ==> #f
+(#<procedure> "A" "B") ==> #f
+(#<procedure> "a" "b") ==> #f
+(#<procedure> "9" "0") ==> #t
+(#<procedure> "A" "A") ==> #f
+(#<procedure> "A" "B") ==> #t
+(#<procedure> "a" "b") ==> #t
+(#<procedure> "9" "0") ==> #f
+(#<procedure> "A" "A") ==> #t
+(#<procedure> "A" "B") ==> #f
+(#<procedure> "a" "b") ==> #f
+(#<procedure> "9" "0") ==> #t
+(#<procedure> "A" "A") ==> #t
+(#<procedure> "A" "B") ==> #f
+(#<procedure> "a" "B") ==> #f
+(#<procedure> "A" "b") ==> #f
+(#<procedure> "a" "b") ==> #f
+(#<procedure> "9" "0") ==> #f
+(#<procedure> "A" "A") ==> #t
+(#<procedure> "A" "a") ==> #t
+(#<procedure> "A" "B") ==> #t
+(#<procedure> "a" "B") ==> #t
+(#<procedure> "A" "b") ==> #t
+(#<procedure> "a" "b") ==> #t
+(#<procedure> "9" "0") ==> #f
+(#<procedure> "A" "A") ==> #f
+(#<procedure> "A" "a") ==> #f
+(#<procedure> "A" "B") ==> #f
+(#<procedure> "a" "B") ==> #f
+(#<procedure> "A" "b") ==> #f
+(#<procedure> "a" "b") ==> #f
+(#<procedure> "9" "0") ==> #t
+(#<procedure> "A" "A") ==> #f
+(#<procedure> "A" "a") ==> #f
+(#<procedure> "A" "B") ==> #t
+(#<procedure> "a" "B") ==> #t
+(#<procedure> "A" "b") ==> #t
+(#<procedure> "a" "b") ==> #t
+(#<procedure> "9" "0") ==> #f
+(#<procedure> "A" "A") ==> #t
+(#<procedure> "A" "a") ==> #t
+(#<procedure> "A" "B") ==> #f
+(#<procedure> "a" "B") ==> #f
+(#<procedure> "A" "b") ==> #f
+(#<procedure> "a" "b") ==> #f
+(#<procedure> "9" "0") ==> #t
+(#<procedure> "A" "A") ==> #t
+(#<procedure> "A" "a") ==> #t
+SECTION(6 8)
+(#<procedure> #(0 (2 2 2 2) "Anna")) ==> #t
+(#<procedure> a b c) ==> #(a b c)
+(#<procedure>) ==> #()
+(#<procedure> #(0 (2 2 2 2) "Anna")) ==> 3
+(#<procedure> #()) ==> 0
+(#<procedure> #(1 1 2 3 5 8 13 21) 5) ==> 8
+(vector-set #(0 ("Sue" "Sue") "Anna")) ==> #(0 ("Sue" "Sue") "Anna")
+(#<procedure> 2 hi) ==> #(hi hi)
+(#<procedure> 0) ==> #()
+(#<procedure> 0 a) ==> #()
+SECTION(6 9)
+(#<procedure> #<procedure>) ==> #t
+(#<procedure> #<procedure>) ==> #t
+(#<procedure> (lambda (x) (* x x))) ==> #f
+(#<procedure> #<procedure>) ==> #t
+(#<procedure> #<procedure> (3 4)) ==> 7
+(#<procedure> #<procedure> (3 4)) ==> 7
+(#<procedure> #<procedure> 10 (3 4)) ==> 17
+(#<procedure> #<procedure> ()) ==> ()
+(#<procedure> 12 75) ==> 30
+(#<procedure> #<procedure> ((a b) (d e) (g h))) ==> (b e h)
+(#<procedure> #<procedure> (1 2 3) (4 5 6)) ==> (5 7 9)
+(#<procedure> #<procedure> (1 2 3)) ==> (1 2 3)
+(#<procedure> #<procedure> (1 2 3)) ==> (1 2 3)
+(#<procedure> #<procedure> (1 2 3)) ==> (-1 -2 -3)
+(for-each #(0 1 4 9 16)) ==> #(0 1 4 9 16)
+(#<procedure> #<procedure>) ==> -3
+(#<procedure> (1 2 3 4)) ==> 4
+(#<procedure> (a b . c)) ==> #f
+(#<procedure> #<procedure> ()) ==> ()
+SECTION(6 10 1)
+(#<procedure> #<input port "(stdin)">) ==> #t
+(#<procedure> #<output port "(stdout)">) ==> #t
+(#<procedure> "r4rstest.scm" #<procedure>) ==> #t
+(#<procedure> #<input port "r4rstest.scm">) ==> #t
+SECTION(6 10 2)
+(#<procedure> #<input port "r4rstest.scm">) ==> #\;
+(#<procedure> #<input port "r4rstest.scm">) ==> #\;
+(#<procedure> #<input port "r4rstest.scm">) ==> (define cur-section (quote ()))
+(#<procedure> #<input port "r4rstest.scm">) ==> #\(
+(#<procedure> #<input port "r4rstest.scm">) ==> (define errs (quote ()))
+SECTION(6 10 3)
+(#<procedure> "tmp1" #<procedure>) ==> #t
+(#<procedure> #<input port "tmp1">) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
+(#<procedure> #!eof) ==> #t
+(#<procedure> #!eof) ==> #t
+(input-port? #t) ==> #t
+(#<procedure> #<input port "tmp1">) ==> #\;
+(#<procedure> #<input port "tmp1">) ==> #\;
+(#<procedure> #<input port "tmp1">) ==> #\;
+(#<procedure> #<input port "tmp1">) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
+(#<procedure> #<input port "tmp1">) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
+(#<procedure> #<output port "tmp2">) ==> #t
+(#<procedure> #<input port "tmp2">) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
+(#<procedure> #!eof) ==> #t
+(#<procedure> #!eof) ==> #t
+(input-port? #t) ==> #t
+(#<procedure> #<input port "tmp2">) ==> #\;
+(#<procedure> #<input port "tmp2">) ==> #\;
+(#<procedure> #<input port "tmp2">) ==> #\;
+(#<procedure> #<input port "tmp2">) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
+(#<procedure> #<input port "tmp2">) ==> (define foo (quote (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))))
+
+Passed all tests
+
+;testing inexact numbers;
+SECTION(6 2)
+(#<procedure> 1 1.0) ==> #f
+(#<procedure> 0 0.0) ==> #f
+SECTION(6 5 5)
+(#<procedure> 3.9) ==> #t
+(max #t) ==> #t
+(#<procedure> 3.9 4) ==> 4.0
+(#<procedure> 4) ==> 4.0
+(#<procedure> 4.0) ==> 4.0
+(#<procedure> 4) ==> 4
+(#<procedure> 4.0) ==> 4
+(#<procedure> -4.5) ==> -4.0
+(#<procedure> -3.5) ==> -4.0
+(#<procedure> -3.9) ==> -4.0
+(#<procedure> 0.0) ==> 0.0
+(#<procedure> 0.25) ==> 0.0
+(#<procedure> 0.8) ==> 1.0
+(#<procedure> 3.5) ==> 4.0
+(#<procedure> 4.5) ==> 4.0
+(#<procedure> 0 0) ==> 1
+(#<procedure> 0 1) ==> 0
+(#<procedure> 1 1) ==> 0.785398163397448
+(#<procedure> "tmp3" #<procedure>) ==> #t
+(#<procedure> #<input port "tmp3">) ==> (define foo (quote (0.25 -3.25)))
+(#<procedure> #!eof) ==> #t
+(#<procedure> #!eof) ==> #t
+(input-port? #t) ==> #t
+(#<procedure> #<input port "tmp3">) ==> #\;
+(#<procedure> #<input port "tmp3">) ==> #\;
+(#<procedure> #<input port "tmp3">) ==> #\;
+(#<procedure> #<input port "tmp3">) ==> (0.25 -3.25)
+(#<procedure> #<input port "tmp3">) ==> (define foo (quote (0.25 -3.25)))
+(pentium-fdiv-bug #t) ==> #t
+
+Passed all tests
+SECTION(6 5 6)
+(float-print-test #t) ==> #t
+Number readback failure for (+ 1.0 (* -100 2.22044604925031e-16))
+0.999999999999978
+Number readback failure for (+ 10.0 (* -100 1.77635683940025e-15))
+9.99999999999982
+Number readback failure for (+ 100.0 (* -100 1.4210854715202e-14))
+99.9999999999986
+Number readback failure for (+ 1e+20 (* -100 16384.0))
+9.99999999999984e+19
+Number readback failure for (+ 1e+50 (* -100 2.07691874341393e+34))
+9.99999999999979e+49
+Number readback failure for (+ 1e+100 (* -100 1.94266889222573e+84))
+9.99999999999981e+99
+Number readback failure for (+ 0.1 (* -100 1.38777878078145e-17))
+0.0999999999999986
+Number readback failure for (+ 0.01 (* -100 1.73472347597681e-18))
+0.00999999999999983
+Number readback failure for (+ 0.001 (* -100 2.16840434497101e-19))
+0.000999999999999978
+Number readback failure for (+ 1e-20 (* -100 1.50463276905253e-36))
+9.99999999999985e-21
+Number readback failure for (+ 1e-50 (* -100 1.18694596821997e-66))
+9.99999999999988e-51
+Number readback failure for (+ 1e-100 (* -100 1.26897091865782e-116))
+9.99999999999987e-101
+(mult-float-print-test #f) ==> #f
+ BUT EXPECTED #t
+Number readback failure for (+ 3.0 (* -100 4.44089209850063e-16))
+2.99999999999996
+Number readback failure for (+ 30.0 (* -100 3.5527136788005e-15))
+29.9999999999996
+Number readback failure for (+ 300.0 (* -100 5.6843418860808e-14))
+299.999999999994
+Number readback failure for (+ 3e+20 (* -100 65536.0))
+2.99999999999993e+20
+Number readback failure for (+ 3e+50 (* -100 4.15383748682786e+34))
+2.99999999999996e+50
+Number readback failure for (+ 3e+100 (* -100 3.88533778445146e+84))
+2.99999999999996e+100
+Number readback failure for (+ 0.3 (* -100 5.55111512312578e-17))
+0.299999999999994
+Number readback failure for (+ 0.03 (* -100 3.46944695195361e-18))
+0.0299999999999997
+Number readback failure for (+ 0.003 (* -100 4.33680868994202e-19))
+0.00299999999999996
+Number readback failure for (+ 3e-20 (* -100 6.01853107621011e-36))
+2.99999999999994e-20
+Number readback failure for (+ 3e-50 (* -100 4.7477838728799e-66))
+2.99999999999995e-50
+Number readback failure for (+ 3e-100 (* -100 5.0758836746313e-116))
+2.99999999999995e-100
+(mult-float-print-test #f) ==> #f
+ BUT EXPECTED #t
+Number readback failure for (+ 7.0 (* -100 8.88178419700125e-16))
+6.99999999999991
+Number readback failure for (+ 70.0 (* -100 1.4210854715202e-14))
+69.9999999999986
+Number readback failure for (+ 700.0 (* -100 1.13686837721616e-13))
+699.999999999989
+Number readback failure for (+ 7e+20 (* -100 131072.0))
+6.99999999999987e+20
+Number readback failure for (+ 7e+50 (* -100 8.30767497365572e+34))
+6.99999999999992e+50
+Number readback failure for (+ 7e+100 (* -100 1.55413511378058e+85))
+6.99999999999984e+100
+Number readback failure for (+ 0.7 (* -99 1.11022302462516e-16))
+0.699999999999989
+Number readback failure for (+ 0.07 (* -100 1.38777878078145e-17))
+0.0699999999999986
+Number readback failure for (+ 0.007 (* -100 8.67361737988404e-19))
+0.00699999999999991
+Number readback failure for (+ 7e-20 (* -99 1.20370621524202e-35))
+6.99999999999988e-20
+Number readback failure for (+ 7e-50 (* -100 9.4955677457598e-66))
+6.9999999999999e-50
+Number readback failure for (+ 7e-100 (* -100 1.01517673492626e-115))
+6.9999999999999e-100
+(mult-float-print-test #f) ==> #f
+ BUT EXPECTED #t
+Number readback failure for (+ 3.14159265358979 (* -100 4.44089209850063e-16))
+3.14159265358975
+Number readback failure for (+ 31.4159265358979 (* -100 3.5527136788005e-15))
+31.4159265358976
+Number readback failure for (+ 314.159265358979 (* -100 5.6843418860808e-14))
+314.159265358974
+Number readback failure for (+ 3.14159265358979e+20 (* -100 65536.0))
+3.14159265358973e+20
+Number readback failure for (+ 3.14159265358979e+50 (* -100 4.15383748682786e+34))
+3.14159265358975e+50
+Number readback failure for (+ 3.14159265358979e+100 (* -100 3.88533778445146e+84))
+3.14159265358975e+100
+Number readback failure for (+ 0.314159265358979 (* -100 5.55111512312578e-17))
+0.314159265358974
+Number readback failure for (+ 0.0314159265358979 (* -100 6.93889390390723e-18))
+0.0314159265358972
+Number readback failure for (+ 0.00314159265358979 (* -99 4.33680868994202e-19))
+0.00314159265358975
+Number readback failure for (+ 3.14159265358979e-20 (* -100 6.01853107621011e-36))
+3.14159265358973e-20
+Number readback failure for (+ 3.14159265358979e-50 (* -100 4.7477838728799e-66))
+3.14159265358975e-50
+Number readback failure for (+ 3.14159265358979e-100 (* -100 5.0758836746313e-116))
+3.14159265358974e-100
+(mult-float-print-test #f) ==> #f
+ BUT EXPECTED #t
+Number readback failure for (+ 2.71828182845905 (* -100 4.44089209850063e-16))
+2.718281828459
+Number readback failure for (+ 27.1828182845905 (* -100 3.5527136788005e-15))
+27.1828182845901
+Number readback failure for (+ 271.828182845905 (* -100 5.6843418860808e-14))
+271.828182845899
+Number readback failure for (+ 2.71828182845905e+20 (* -100 32768.0))
+2.71828182845901e+20
+Number readback failure for (+ 2.71828182845905e+50 (* -100 4.15383748682786e+34))
+2.718281828459e+50
+Number readback failure for (+ 2.71828182845905e+100 (* -100 3.88533778445146e+84))
+2.71828182845901e+100
+Number readback failure for (+ 0.271828182845905 (* -99 5.55111512312578e-17))
+0.271828182845899
+Number readback failure for (+ 0.0271828182845905 (* -100 3.46944695195361e-18))
+0.0271828182845901
+Number readback failure for (+ 0.00271828182845905 (* -100 4.33680868994202e-19))
+0.002718281828459
+Number readback failure for (+ 2.71828182845904e-20 (* -100 6.01853107621011e-36))
+2.71828182845898e-20
+Number readback failure for (+ 2.71828182845905e-50 (* -100 4.7477838728799e-66))
+2.718281828459e-50
+Number readback failure for (+ 2.71828182845905e-100 (* -100 5.0758836746313e-116))
+2.71828182845899e-100
+(mult-float-print-test #f) ==> #f
+ BUT EXPECTED #t
+
+To fully test continuations, Scheme 4, and DELAY/FORCE do:
+(test-cont) (test-sc4) (test-delay)
+
+;testing continuations;
+SECTION(6 9)
+(#<procedure> (a (b (c))) ((a) b c)) ==> #t
+(#<procedure> (a (b (c))) ((a) b c d)) ==> #f
+
+errors were:
+(SECTION (got expected (call)))
+((6 5 6) (#f #t (mult-float-print-test #f)))
+((6 5 6) (#f #t (mult-float-print-test #f)))
+((6 5 6) (#f #t (mult-float-print-test #f)))
+((6 5 6) (#f #t (mult-float-print-test #f)))
+((6 5 6) (#f #t (mult-float-print-test #f)))
+
+
+;testing scheme 4 functions;
+SECTION(6 7)
+(#<procedure> "P l") ==> (#\P #\space #\l)
+(#<procedure> "") ==> ()
+(#<procedure> (#\1 #\\ #\")) ==> "1\\\""
+(#<procedure> ()) ==> ""
+SECTION(6 8)
+(#<procedure> #(dah dah didah)) ==> (dah dah didah)
+(#<procedure> #()) ==> ()
+(#<procedure> (dididit dah)) ==> #(dididit dah)
+(#<procedure> ()) ==> #()
+SECTION(6 10 4)
+(load (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) ==> (#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))
+
+errors were:
+(SECTION (got expected (call)))
+((6 5 6) (#f #t (mult-float-print-test #f)))
+((6 5 6) (#f #t (mult-float-print-test #f)))
+((6 5 6) (#f #t (mult-float-print-test #f)))
+((6 5 6) (#f #t (mult-float-print-test #f)))
+((6 5 6) (#f #t (mult-float-print-test #f)))
+
+
+;testing DELAY and FORCE;
+SECTION(6 9)
+(delay 3) ==> 3
+(delay (3 3)) ==> (3 3)
+(delay 2) ==> 2
+(#<procedure> #<promise>) ==> 6
+(#<procedure> #<promise>) ==> 6
+(force 3) ==> 3
+
+errors were:
+(SECTION (got expected (call)))
+((6 5 6) (#f #t (mult-float-print-test #f)))
+((6 5 6) (#f #t (mult-float-print-test #f)))
+((6 5 6) (#f #t (mult-float-print-test #f)))
+((6 5 6) (#f #t (mult-float-print-test #f)))
+((6 5 6) (#f #t (mult-float-print-test #f)))
+
diff --git a/tests/r4rstest.scm b/tests/r4rstest.scm
new file mode 100644
index 00000000..9952d9da
--- /dev/null
+++ b/tests/r4rstest.scm
@@ -0,0 +1,1235 @@
+;; Copyright (C) 1991, 1992, 1993, 1994, 1995, 2000, 2003 Free Software Foundation, Inc.
+;;
+;; This program is free software; you can redistribute it and/or modify it
+;; under the terms of the GNU General Public License as published by the
+;; Free Software Foundation; either version 2, or (at your option) any
+;; later version.
+;;
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+;;
+;; To receive a copy of the GNU General Public License, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA; or view
+;; http://swissnet.ai.mit.edu/~jaffer/GPL.html
+
+;;;; "r4rstest.scm" Test correctness of scheme implementations.
+;;; Author: Aubrey Jaffer
+
+;;; This includes examples from
+;;; William Clinger and Jonathan Rees, editors.
+;;; Revised^4 Report on the Algorithmic Language Scheme
+;;; and the IEEE specification.
+
+;;; The input tests read this file expecting it to be named "r4rstest.scm".
+;;; Files `tmp1', `tmp2' and `tmp3' will be created in the course of running
+;;; these tests. You may need to delete them in order to run
+;;; "r4rstest.scm" more than once.
+
+;;; There are three optional tests:
+;;; (TEST-CONT) tests multiple returns from call-with-current-continuation
+;;;
+;;; (TEST-SC4) tests procedures required by R4RS but not by IEEE
+;;;
+;;; (TEST-DELAY) tests DELAY and FORCE, which are not required by
+;;; either standard.
+
+;;; If you are testing a R3RS version which does not have `list?' do:
+;;; (define list? #f)
+
+;;; send corrections or additions to agj @ alum.mit.edu
+
+(define cur-section '())(define errs '())
+(define SECTION (lambda args
+ (display "SECTION") (write args) (newline)
+ (set! cur-section args) #t))
+(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs))))
+
+(define test
+ (lambda (expect fun . args)
+ (write (cons fun args))
+ (display " ==> ")
+ ((lambda (res)
+ (write res)
+ (newline)
+ (cond ((not (equal? expect res))
+ (record-error (list res expect (cons fun args)))
+ (display " BUT EXPECTED ")
+ (write expect)
+ (newline)
+ #f)
+ (else #t)))
+ (if (procedure? fun) (apply fun args) (car args)))))
+(define (report-errs)
+ (newline)
+ (if (null? errs) (display "Passed all tests")
+ (begin
+ (display "errors were:")
+ (newline)
+ (display "(SECTION (got expected (call)))")
+ (newline)
+ (for-each (lambda (l) (write l) (newline))
+ errs)))
+ (newline))
+
+(SECTION 2 1);; test that all symbol characters are supported.
+'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.)
+
+(SECTION 3 4)
+(define disjoint-type-functions
+ (list boolean? char? null? number? pair? procedure? string? symbol? vector?))
+(define type-examples
+ (list
+ #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) ))
+(define i 1)
+(for-each (lambda (x) (display (make-string i #\ ))
+ (set! i (+ 3 i))
+ (write x)
+ (newline))
+ disjoint-type-functions)
+(define type-matrix
+ (map (lambda (x)
+ (let ((t (map (lambda (f) (f x)) disjoint-type-functions)))
+ (write t)
+ (write x)
+ (newline)
+ t))
+ type-examples))
+(set! i 0)
+(define j 0)
+(for-each (lambda (x y)
+ (set! j (+ 1 j))
+ (set! i 0)
+ (for-each (lambda (f)
+ (set! i (+ 1 i))
+ (cond ((and (= i j))
+ (cond ((not (f x)) (test #t f x))))
+ ((f x) (test #f f x)))
+ (cond ((and (= i j))
+ (cond ((not (f y)) (test #t f y))))
+ ((f y) (test #f f y))))
+ disjoint-type-functions))
+ (list #t #\a '() 9739 '(test) record-error "test" 'car '#(a b c))
+ (list #f #\newline '() -3252 '(t . t) car "" 'nil '#()))
+(SECTION 4 1 2)
+(test '(quote a) 'quote (quote 'a))
+(test '(quote a) 'quote ''a)
+(SECTION 4 1 3)
+(test 12 (if #f + *) 3 4)
+(SECTION 4 1 4)
+(test 8 (lambda (x) (+ x x)) 4)
+(define reverse-subtract
+ (lambda (x y) (- y x)))
+(test 3 reverse-subtract 7 10)
+(define add4
+ (let ((x 4))
+ (lambda (y) (+ x y))))
+(test 10 add4 6)
+(test '(3 4 5 6) (lambda x x) 3 4 5 6)
+(test '(5 6) (lambda (x y . z) z) 3 4 5 6)
+(SECTION 4 1 5)
+(test 'yes 'if (if (> 3 2) 'yes 'no))
+(test 'no 'if (if (> 2 3) 'yes 'no))
+(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2)))
+(SECTION 4 1 6)
+(define x 2)
+(test 3 'define (+ x 1))
+(set! x 4)
+(test 5 'set! (+ x 1))
+(SECTION 4 2 1)
+(test 'greater 'cond (cond ((> 3 2) 'greater)
+ ((< 3 2) 'less)))
+(test 'equal 'cond (cond ((> 3 3) 'greater)
+ ((< 3 3) 'less)
+ (else 'equal)))
+(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr)
+ (else #f)))
+(test 'composite 'case (case (* 2 3)
+ ((2 3 5 7) 'prime)
+ ((1 4 6 8 9) 'composite)))
+(test 'consonant 'case (case (car '(c d))
+ ((a e i o u) 'vowel)
+ ((w y) 'semivowel)
+ (else 'consonant)))
+(test #t 'and (and (= 2 2) (> 2 1)))
+(test #f 'and (and (= 2 2) (< 2 1)))
+(test '(f g) 'and (and 1 2 'c '(f g)))
+(test #t 'and (and))
+(test #t 'or (or (= 2 2) (> 2 1)))
+(test #t 'or (or (= 2 2) (< 2 1)))
+(test #f 'or (or #f #f #f))
+(test #f 'or (or))
+(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0)))
+(SECTION 4 2 2)
+(test 6 'let (let ((x 2) (y 3)) (* x y)))
+(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x))))
+(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x))))
+(test #t 'letrec (letrec ((even?
+ (lambda (n) (if (zero? n) #t (odd? (- n 1)))))
+ (odd?
+ (lambda (n) (if (zero? n) #f (even? (- n 1))))))
+ (even? 88)))
+(define x 34)
+(test 5 'let (let ((x 3)) (define x 5) x))
+(test 34 'let x)
+(test 6 'let (let () (define x 6) x))
+(test 34 'let x)
+(test 7 'let* (let* ((x 3)) (define x 7) x))
+(test 34 'let* x)
+(test 8 'let* (let* () (define x 8) x))
+(test 34 'let* x)
+(test 9 'letrec (letrec () (define x 9) x))
+(test 34 'letrec x)
+(test 10 'letrec (letrec ((x 3)) (define x 10) x))
+(test 34 'letrec x)
+(define (s x) (if x (let () (set! s x) (set! x s))))
+(SECTION 4 2 3)
+(define x 0)
+(test 6 'begin (begin (set! x (begin (begin 5)))
+ (begin ((begin +) (begin x) (begin (begin 1))))))
+(SECTION 4 2 4)
+(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5))
+ (i 0 (+ i 1)))
+ ((= i 5) vec)
+ (vector-set! vec i i)))
+(test 25 'do (let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum))))
+(test 1 'let (let foo () 1))
+(test '((6 1 3) (-5 -2)) 'let
+ (let loop ((numbers '(3 -2 1 6 -5))
+ (nonneg '())
+ (neg '()))
+ (cond ((null? numbers) (list nonneg neg))
+ ((negative? (car numbers))
+ (loop (cdr numbers)
+ nonneg
+ (cons (car numbers) neg)))
+ (else
+ (loop (cdr numbers)
+ (cons (car numbers) nonneg)
+ neg)))))
+;;From: Allegro Petrofsky <Allegro@Petrofsky.Berkeley.CA.US>
+(test -1 'let (let ((f -)) (let f ((n (f 1))) n)))
+
+(SECTION 4 2 6)
+(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4))
+(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name)))
+(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
+(test '((foo 7) . cons)
+ 'quasiquote
+ `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
+
+;;; sqt is defined here because not all implementations are required to
+;;; support it.
+(define (sqt x)
+ (do ((i 0 (+ i 1)))
+ ((> (* i i) x) (- i 1))))
+
+(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqt 4) ,@(map sqt '(16 9)) 8))
+(test 5 'quasiquote `,(+ 2 3))
+(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+ 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
+(test '(a `(b ,x ,'y d) e) 'quasiquote
+ (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e)))
+(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4)))
+(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4)))
+(SECTION 5 2 1)
+(define add3 (lambda (x) (+ x 3)))
+(test 6 'define (add3 3))
+(define first car)
+(test 1 'define (first '(1 2)))
+(define old-+ +)
+(begin (begin (begin)
+ (begin (begin (begin) (define + (lambda (x y) (list y x)))
+ (begin)))
+ (begin))
+ (begin)
+ (begin (begin (begin) (test '(3 6) add3 6)
+ (begin))))
+(set! + old-+)
+(test 9 add3 6)
+(begin)
+(begin (begin))
+(begin (begin (begin (begin))))
+(SECTION 5 2 2)
+#;(test 45 'define
+ (let ((x 5))
+ (begin (begin (begin)
+ (begin (begin (begin) (define foo (lambda (y) (bar x y)))
+ (begin)))
+ (begin))
+ (begin)
+ (begin)
+ (begin (define bar (lambda (a b) (+ (* a b) a))))
+ (begin))
+ (begin)
+ (begin (foo (+ x 3)))))
+(define x 34)
+(define (foo) (define x 5) x)
+(test 5 foo)
+(test 34 'define x)
+(define foo (lambda () (define x 5) x))
+(test 5 foo)
+(test 34 'define x)
+(define (foo x) ((lambda () (define x 5) x)) x)
+(test 88 foo 88)
+(test 4 foo 4)
+(test 34 'define x)
+(test 99 'internal-define (letrec ((foo (lambda (arg)
+ (or arg (and (procedure? foo)
+ (foo 99))))))
+ (define bar (foo #f))
+ (foo #f)))
+(test 77 'internal-define (letrec ((foo 77)
+ (bar #f)
+ (retfoo (lambda () foo)))
+ (define baz (retfoo))
+ (retfoo)))
+(SECTION 6 1)
+(test #f not #t)
+(test #f not 3)
+(test #f not (list 3))
+(test #t not #f)
+(test #f not '())
+(test #f not (list))
+(test #f not 'nil)
+
+;(test #t boolean? #f)
+;(test #f boolean? 0)
+;(test #f boolean? '())
+(SECTION 6 2)
+(test #t eqv? 'a 'a)
+(test #f eqv? 'a 'b)
+(test #t eqv? 2 2)
+(test #t eqv? '() '())
+(test #t eqv? '10000 '10000)
+(test #f eqv? (cons 1 2)(cons 1 2))
+(test #f eqv? (lambda () 1) (lambda () 2))
+(test #f eqv? #f 'nil)
+(let ((p (lambda (x) x)))
+ (test #t eqv? p p))
+(define gen-counter
+ (lambda ()
+ (let ((n 0))
+ (lambda () (set! n (+ n 1)) n))))
+(let ((g (gen-counter))) (test #t eqv? g g))
+(test #f eqv? (gen-counter) (gen-counter))
+(letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
+ (g (lambda () (if (eqv? f g) 'g 'both))))
+ (test #f eqv? f g))
+
+(test #t eq? 'a 'a)
+(test #f eq? (list 'a) (list 'a))
+(test #t eq? '() '())
+(test #t eq? car car)
+(let ((x '(a))) (test #t eq? x x))
+(let ((x '#())) (test #t eq? x x))
+(let ((x (lambda (x) x))) (test #t eq? x x))
+
+(define test-eq?-eqv?-agreement
+ (lambda (obj1 obj2)
+ (cond ((eq? (eq? obj1 obj2) (eqv? obj1 obj2)))
+ (else
+ (record-error (list #f #t (list 'test-eq?-eqv?-agreement obj1 obj2)))
+ (display "eqv? and eq? disagree about ")
+ (write obj1)
+ (display #\ )
+ (write obj2)
+ (newline)))))
+
+(test-eq?-eqv?-agreement '#f '#f)
+(test-eq?-eqv?-agreement '#t '#t)
+(test-eq?-eqv?-agreement '#t '#f)
+(test-eq?-eqv?-agreement '(a) '(a))
+(test-eq?-eqv?-agreement '(a) '(b))
+(test-eq?-eqv?-agreement car car)
+(test-eq?-eqv?-agreement car cdr)
+(test-eq?-eqv?-agreement (list 'a) (list 'a))
+(test-eq?-eqv?-agreement (list 'a) (list 'b))
+(test-eq?-eqv?-agreement '#(a) '#(a))
+(test-eq?-eqv?-agreement '#(a) '#(b))
+(test-eq?-eqv?-agreement "abc" "abc")
+(test-eq?-eqv?-agreement "abc" "abz")
+
+(test #t equal? 'a 'a)
+(test #t equal? '(a) '(a))
+(test #t equal? '(a (b) c) '(a (b) c))
+(test #t equal? "abc" "abc")
+(test #t equal? 2 2)
+(test #t equal? (make-vector 5 'a) (make-vector 5 'a))
+(SECTION 6 3)
+(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ()))))))
+(define x (list 'a 'b 'c))
+(define y x)
+(and list? (test #t list? y))
+(set-cdr! x 4)
+(test '(a . 4) 'set-cdr! x)
+(test #t eqv? x y)
+(test '(a b c . d) 'dot '(a . (b . (c . d))))
+(and list? (test #f list? y))
+(and list? (let ((x (list 'a))) (set-cdr! x x) (test #f 'list? (list? x))))
+
+;(test #t pair? '(a . b))
+;(test #t pair? '(a . 1))
+;(test #t pair? '(a b c))
+;(test #f pair? '())
+;(test #f pair? '#(a b))
+
+(test '(a) cons 'a '())
+(test '((a) b c d) cons '(a) '(b c d))
+(test '("a" b c) cons "a" '(b c))
+(test '(a . 3) cons 'a 3)
+(test '((a b) . c) cons '(a b) 'c)
+
+(test 'a car '(a b c))
+(test '(a) car '((a) b c d))
+(test 1 car '(1 . 2))
+
+(test '(b c d) cdr '((a) b c d))
+(test 2 cdr '(1 . 2))
+
+(test '(a 7 c) list 'a (+ 3 4) 'c)
+(test '() list)
+
+(test 3 length '(a b c))
+(test 3 length '(a (b) (c d e)))
+(test 0 length '())
+
+(test '(x y) append '(x) '(y))
+(test '(a b c d) append '(a) '(b c d))
+(test '(a (b) (c)) append '(a (b)) '((c)))
+(test '() append)
+(test '(a b c . d) append '(a b) '(c . d))
+(test 'a append '() 'a)
+
+(test '(c b a) reverse '(a b c))
+(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f))))
+
+(test 'c list-ref '(a b c d) 2)
+
+(test '(a b c) memq 'a '(a b c))
+(test '(b c) memq 'b '(a b c))
+(test '#f memq 'a '(b c d))
+(test '#f memq (list 'a) '(b (a) c))
+(test '((a) c) member (list 'a) '(b (a) c))
+(test '(101 102) memv 101 '(100 101 102))
+
+(define e '((a 1) (b 2) (c 3)))
+(test '(a 1) assq 'a e)
+(test '(b 2) assq 'b e)
+(test #f assq 'd e)
+(test #f assq (list 'a) '(((a)) ((b)) ((c))))
+(test '((a)) assoc (list 'a) '(((a)) ((b)) ((c))))
+(test '(5 7) assv 5 '((2 3) (5 7) (11 13)))
+(SECTION 6 4)
+;(test #t symbol? 'foo)
+(test #t symbol? (car '(a b)))
+;(test #f symbol? "bar")
+;(test #t symbol? 'nil)
+;(test #f symbol? '())
+;(test #f symbol? #f)
+;;; But first, what case are symbols in? Determine the standard case:
+(define char-standard-case char-upcase)
+(if (string=? (symbol->string 'A) "a")
+ (set! char-standard-case char-downcase))
+(test #t 'standard-case
+ (string=? (symbol->string 'a) (symbol->string 'A)))
+(test #t 'standard-case
+ (or (string=? (symbol->string 'a) "A")
+ (string=? (symbol->string 'A) "a")))
+(define (str-copy s)
+ (let ((v (make-string (string-length s))))
+ (do ((i (- (string-length v) 1) (- i 1)))
+ ((< i 0) v)
+ (string-set! v i (string-ref s i)))))
+(define (string-standard-case s)
+ (set! s (str-copy s))
+ (do ((i 0 (+ 1 i))
+ (sl (string-length s)))
+ ((>= i sl) s)
+ (string-set! s i (char-standard-case (string-ref s i)))))
+(test (string-standard-case "flying-fish") symbol->string 'flying-fish)
+(test (string-standard-case "martin") symbol->string 'Martin)
+(test "Malvina" symbol->string (string->symbol "Malvina"))
+(test #t 'standard-case (eq? 'a 'A))
+
+(define x (string #\a #\b))
+(define y (string->symbol x))
+(string-set! x 0 #\c)
+(test "cb" 'string-set! x)
+(test "ab" symbol->string y)
+(test y string->symbol "ab")
+
+(test #t eq? 'mISSISSIppi 'mississippi)
+(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt")))
+(test 'JollyWog string->symbol (symbol->string 'JollyWog))
+
+(SECTION 6 5 5)
+(test #t number? 3)
+(test #t complex? 3)
+(test #t real? 3)
+(test #t rational? 3)
+(test #t integer? 3)
+
+(test #t exact? 3)
+(test #f inexact? 3)
+
+(test #t = 22 22 22)
+(test #t = 22 22)
+(test #f = 34 34 35)
+(test #f = 34 35)
+(test #t > 3 -6246)
+(test #f > 9 9 -2424)
+(test #t >= 3 -4 -6246)
+(test #t >= 9 9)
+(test #f >= 8 9)
+(test #t < -1 2 3 4 5 6 7 8)
+(test #f < -1 2 3 4 4 5 6 7)
+(test #t <= -1 2 3 4 5 6 7 8)
+(test #t <= -1 2 3 4 4 5 6 7)
+(test #f < 1 3 2)
+(test #f >= 1 3 2)
+
+(test #t zero? 0)
+(test #f zero? 1)
+(test #f zero? -1)
+(test #f zero? -100)
+(test #t positive? 4)
+(test #f positive? -4)
+(test #f positive? 0)
+(test #f negative? 4)
+(test #t negative? -4)
+(test #f negative? 0)
+(test #t odd? 3)
+(test #f odd? 2)
+(test #f odd? -4)
+(test #t odd? -1)
+(test #f even? 3)
+(test #t even? 2)
+(test #t even? -4)
+(test #f even? -1)
+
+(test 38 max 34 5 7 38 6)
+(test -24 min 3 5 5 330 4 -24)
+
+(test 7 + 3 4)
+(test '3 + 3)
+(test 0 +)
+(test 4 * 4)
+(test 1 *)
+
+(test -1 - 3 4)
+(test -3 - 3)
+(test 7 abs -7)
+(test 7 abs 7)
+(test 0 abs 0)
+
+(test 5 quotient 35 7)
+(test -5 quotient -35 7)
+(test -5 quotient 35 -7)
+(test 5 quotient -35 -7)
+(test 1 modulo 13 4)
+(test 1 remainder 13 4)
+(test 3 modulo -13 4)
+(test -1 remainder -13 4)
+(test -3 modulo 13 -4)
+(test 1 remainder 13 -4)
+(test -1 modulo -13 -4)
+(test -1 remainder -13 -4)
+(test 0 modulo 0 86400)
+(test 0 modulo 0 -86400)
+(define (divtest n1 n2)
+ (= n1 (+ (* n2 (quotient n1 n2))
+ (remainder n1 n2))))
+(test #t divtest 238 9)
+(test #t divtest -238 9)
+(test #t divtest 238 -9)
+(test #t divtest -238 -9)
+
+(test 4 gcd 0 4)
+(test 4 gcd -4 0)
+(test 4 gcd 32 -36)
+(test 0 gcd)
+(test 288 lcm 32 -36)
+(test 1 lcm)
+
+(SECTION 6 5 5)
+;;; Implementations which don't allow division by 0 can have fragile
+;;; string->number.
+(define (test-string->number str)
+ (define ans (string->number str))
+ (cond ((not ans) #t) ((number? ans) #t) (else ans)))
+(for-each (lambda (str) (test #t test-string->number str))
+ '("+#.#" "-#.#" "#.#" "1/0" "-1/0" "0/0"
+ "+1/0i" "-1/0i" "0/0i" "0/0-0/0i" "1/0-1/0i" "-1/0+1/0i"
+ "#i" "#e" "#" "#i0/0"))
+(cond ((number? (string->number "1+1i")) ;More kawa bait
+ (test #t number? (string->number "#i-i"))
+ (test #t number? (string->number "#i+i"))
+ (test #t number? (string->number "#i2+i"))))
+
+;;;;From: fred@sce.carleton.ca (Fred J Kaudel)
+;;; Modified by jaffer.
+(define (test-inexact)
+ (define f3.9 (string->number "3.9"))
+ (define f4.0 (string->number "4.0"))
+ (define f-3.25 (string->number "-3.25"))
+ (define f.25 (string->number ".25"))
+ (define f4.5 (string->number "4.5"))
+ (define f3.5 (string->number "3.5"))
+ (define f0.0 (string->number "0.0"))
+ (define f0.8 (string->number "0.8"))
+ (define f1.0 (string->number "1.0"))
+ (define wto write-test-obj)
+ (define lto load-test-obj)
+ (newline)
+ (display ";testing inexact numbers; ")
+ (newline)
+ (SECTION 6 2)
+ (test #f eqv? 1 f1.0)
+ (test #f eqv? 0 f0.0)
+ (SECTION 6 5 5)
+ (test #t inexact? f3.9)
+ (test #t 'max (inexact? (max f3.9 4)))
+ (test f4.0 max f3.9 4)
+ (test f4.0 exact->inexact 4)
+ (test f4.0 exact->inexact 4.0)
+ (test 4 inexact->exact 4)
+ (test 4 inexact->exact 4.0)
+ (test (- f4.0) round (- f4.5))
+ (test (- f4.0) round (- f3.5))
+ (test (- f4.0) round (- f3.9))
+ (test f0.0 round f0.0)
+ (test f0.0 round f.25)
+ (test f1.0 round f0.8)
+ (test f4.0 round f3.5)
+ (test f4.0 round f4.5)
+ (test 1 expt 0 0)
+ (test 0 expt 0 1)
+ (test (atan 1) atan 1 1)
+ (set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely.
+ (set! load-test-obj (list 'define 'foo (list 'quote write-test-obj)))
+ (test #t call-with-output-file
+ "tmp3"
+ (lambda (test-file)
+ (write-char #\; test-file)
+ (display #\; test-file)
+ (display ";" test-file)
+ (write write-test-obj test-file)
+ (newline test-file)
+ (write load-test-obj test-file)
+ (output-port? test-file)))
+ (check-test-file "tmp3")
+ (set! write-test-obj wto)
+ (set! load-test-obj lto)
+ (let ((x (string->number "4195835.0"))
+ (y (string->number "3145727.0")))
+ (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y)))))
+ (report-errs))
+
+(define (test-inexact-printing)
+ (let ((f0.0 (string->number "0.0"))
+ (f0.5 (string->number "0.5"))
+ (f1.0 (string->number "1.0"))
+ (f2.0 (string->number "2.0")))
+ (define log2
+ (let ((l2 (log 2)))
+ (lambda (x) (/ (log x) l2))))
+
+ (define (slow-frexp x)
+ (if (zero? x)
+ (list f0.0 0)
+ (let* ((l2 (log2 x))
+ (e (floor (log2 x)))
+ (e (if (= l2 e)
+ (inexact->exact e)
+ (+ (inexact->exact e) 1)))
+ (f (/ x (expt 2 e))))
+ (list f e))))
+
+ (define float-precision
+ (let ((mantissa-bits
+ (do ((i 0 (+ i 1))
+ (eps f1.0 (* f0.5 eps)))
+ ((= f1.0 (+ f1.0 eps))
+ i)))
+ (minval
+ (do ((x f1.0 (* f0.5 x)))
+ ((zero? (* f0.5 x)) x))))
+ (lambda (x)
+ (apply (lambda (f e)
+ (let ((eps
+ (cond ((= f1.0 f) (expt f2.0 (+ 1 (- e mantissa-bits))))
+ ((zero? f) minval)
+ (else (expt f2.0 (- e mantissa-bits))))))
+ (if (zero? eps) ;Happens if gradual underflow.
+ minval
+ eps)))
+ (slow-frexp x)))))
+
+ (define (float-print-test x)
+ (define (testit number)
+ (eqv? number (string->number (number->string number))))
+ (let ((eps (float-precision x))
+ (all-ok? #t))
+ (do ((j -100 (+ j 1)))
+ ((or (not all-ok?) (> j 100)) all-ok?)
+ (let* ((xx (+ x (* j eps)))
+ (ok? (testit xx)))
+ (cond ((not ok?)
+ (display "Number readback failure for ")
+ (display `(+ ,x (* ,j ,eps)))
+ (newline)
+ (display xx)
+ (newline)
+ (set! all-ok? #f))
+ ;; (else (display xx) (newline))
+ )))))
+
+ (define (mult-float-print-test x)
+ (let ((res #t))
+ (for-each
+ (lambda (mult)
+ (or (float-print-test (* mult x)) (set! res #f)))
+ (map string->number
+ '("1.0" "10.0" "100.0" "1.0e20" "1.0e50" "1.0e100"
+ "0.1" "0.01" "0.001" "1.0e-20" "1.0e-50" "1.0e-100")))
+ res))
+
+ (SECTION 6 5 6)
+ (test #t 'float-print-test (float-print-test f0.0))
+ (test #t 'mult-float-print-test (mult-float-print-test f1.0))
+ (test #t 'mult-float-print-test (mult-float-print-test
+ (string->number "3.0")))
+ (test #t 'mult-float-print-test (mult-float-print-test
+ (string->number "7.0")))
+ (test #t 'mult-float-print-test (mult-float-print-test
+ (string->number "3.1415926535897931")))
+ (test #t 'mult-float-print-test (mult-float-print-test
+ (string->number "2.7182818284590451")))))
+
+(define (test-bignum)
+ (define tb
+ (lambda (n1 n2)
+ (= n1 (+ (* n2 (quotient n1 n2))
+ (remainder n1 n2)))))
+ (newline)
+ (display ";testing bignums; ")
+ (newline)
+ (SECTION 6 5 7)
+ (test 0 modulo 33333333333333333333 3)
+ (test 0 modulo 33333333333333333333 -3)
+ (test 0 remainder 33333333333333333333 3)
+ (test 0 remainder 33333333333333333333 -3)
+ (test 2 modulo 33333333333333333332 3)
+ (test -1 modulo 33333333333333333332 -3)
+ (test 2 remainder 33333333333333333332 3)
+ (test 2 remainder 33333333333333333332 -3)
+ (test 1 modulo -33333333333333333332 3)
+ (test -2 modulo -33333333333333333332 -3)
+ (test -2 remainder -33333333333333333332 3)
+ (test -2 remainder -33333333333333333332 -3)
+
+ (test 3 modulo 3 33333333333333333333)
+ (test 33333333333333333330 modulo -3 33333333333333333333)
+ (test 3 remainder 3 33333333333333333333)
+ (test -3 remainder -3 33333333333333333333)
+ (test -33333333333333333330 modulo 3 -33333333333333333333)
+ (test -3 modulo -3 -33333333333333333333)
+ (test 3 remainder 3 -33333333333333333333)
+ (test -3 remainder -3 -33333333333333333333)
+
+ (test 0 modulo -2177452800 86400)
+ (test 0 modulo 2177452800 -86400)
+ (test 0 modulo 2177452800 86400)
+ (test 0 modulo -2177452800 -86400)
+ (test 0 modulo 0 -2177452800)
+ (test #t 'remainder (tb 281474976710655325431 65535))
+ (test #t 'remainder (tb 281474976710655325430 65535))
+
+ (SECTION 6 5 8)
+ (test 281474976710655325431 string->number "281474976710655325431")
+ (test "281474976710655325431" number->string 281474976710655325431)
+ (report-errs))
+
+(define (test-numeric-predicates)
+ (let* ((big-ex (expt 2 90))
+ (big-inex (exact->inexact big-ex)))
+ (newline)
+ (display ";testing bignum-inexact comparisons;")
+ (newline)
+ (SECTION 6 5 5)
+ (test #f = (+ big-ex 1) big-inex (- big-ex 1))
+ (test #f = big-inex (+ big-ex 1) (- big-ex 1))
+ (test #t < (- (inexact->exact big-inex) 1)
+ big-inex
+ (+ (inexact->exact big-inex) 1))))
+
+
+(SECTION 6 5 9)
+(test "0" number->string 0)
+(test "100" number->string 100)
+(test "100" number->string 256 16)
+(test 100 string->number "100")
+(test 256 string->number "100" 16)
+(test #f string->number "")
+(test #f string->number ".")
+(test #f string->number "d")
+(test #f string->number "D")
+(test #f string->number "i")
+(test #f string->number "I")
+(test #f string->number "3i")
+(test #f string->number "3I")
+(test #f string->number "33i")
+(test #f string->number "33I")
+(test #f string->number "3.3i")
+(test #f string->number "3.3I")
+(test #f string->number "-")
+(test #f string->number "+")
+(test #t 'string->number (or (not (string->number "80000000" 16))
+ (positive? (string->number "80000000" 16))))
+(test #t 'string->number (or (not (string->number "-80000000" 16))
+ (negative? (string->number "-80000000" 16))))
+
+(SECTION 6 6)
+;(test #t eqv? '#\ #\Space)
+;(test #t eqv? #\space '#\Space)
+(test #t char? #\a)
+(test #t char? #\()
+(test #t char? #\ )
+(test #t char? '#\newline)
+
+(test #f char=? #\A #\B)
+(test #f char=? #\a #\b)
+(test #f char=? #\9 #\0)
+(test #t char=? #\A #\A)
+
+(test #t char<? #\A #\B)
+(test #t char<? #\a #\b)
+(test #f char<? #\9 #\0)
+(test #f char<? #\A #\A)
+
+(test #f char>? #\A #\B)
+(test #f char>? #\a #\b)
+(test #t char>? #\9 #\0)
+(test #f char>? #\A #\A)
+
+(test #t char<=? #\A #\B)
+(test #t char<=? #\a #\b)
+(test #f char<=? #\9 #\0)
+(test #t char<=? #\A #\A)
+
+(test #f char>=? #\A #\B)
+(test #f char>=? #\a #\b)
+(test #t char>=? #\9 #\0)
+(test #t char>=? #\A #\A)
+
+(test #f char-ci=? #\A #\B)
+(test #f char-ci=? #\a #\B)
+(test #f char-ci=? #\A #\b)
+(test #f char-ci=? #\a #\b)
+(test #f char-ci=? #\9 #\0)
+(test #t char-ci=? #\A #\A)
+(test #t char-ci=? #\A #\a)
+
+(test #t char-ci<? #\A #\B)
+(test #t char-ci<? #\a #\B)
+(test #t char-ci<? #\A #\b)
+(test #t char-ci<? #\a #\b)
+(test #f char-ci<? #\9 #\0)
+(test #f char-ci<? #\A #\A)
+(test #f char-ci<? #\A #\a)
+
+(test #f char-ci>? #\A #\B)
+(test #f char-ci>? #\a #\B)
+(test #f char-ci>? #\A #\b)
+(test #f char-ci>? #\a #\b)
+(test #t char-ci>? #\9 #\0)
+(test #f char-ci>? #\A #\A)
+(test #f char-ci>? #\A #\a)
+
+(test #t char-ci<=? #\A #\B)
+(test #t char-ci<=? #\a #\B)
+(test #t char-ci<=? #\A #\b)
+(test #t char-ci<=? #\a #\b)
+(test #f char-ci<=? #\9 #\0)
+(test #t char-ci<=? #\A #\A)
+(test #t char-ci<=? #\A #\a)
+
+(test #f char-ci>=? #\A #\B)
+(test #f char-ci>=? #\a #\B)
+(test #f char-ci>=? #\A #\b)
+(test #f char-ci>=? #\a #\b)
+(test #t char-ci>=? #\9 #\0)
+(test #t char-ci>=? #\A #\A)
+(test #t char-ci>=? #\A #\a)
+
+(test #t char-alphabetic? #\a)
+(test #t char-alphabetic? #\A)
+(test #t char-alphabetic? #\z)
+(test #t char-alphabetic? #\Z)
+(test #f char-alphabetic? #\0)
+(test #f char-alphabetic? #\9)
+(test #f char-alphabetic? #\space)
+(test #f char-alphabetic? #\;)
+
+(test #f char-numeric? #\a)
+(test #f char-numeric? #\A)
+(test #f char-numeric? #\z)
+(test #f char-numeric? #\Z)
+(test #t char-numeric? #\0)
+(test #t char-numeric? #\9)
+(test #f char-numeric? #\space)
+(test #f char-numeric? #\;)
+
+(test #f char-whitespace? #\a)
+(test #f char-whitespace? #\A)
+(test #f char-whitespace? #\z)
+(test #f char-whitespace? #\Z)
+(test #f char-whitespace? #\0)
+(test #f char-whitespace? #\9)
+(test #t char-whitespace? #\space)
+(test #f char-whitespace? #\;)
+
+(test #f char-upper-case? #\0)
+(test #f char-upper-case? #\9)
+(test #f char-upper-case? #\space)
+(test #f char-upper-case? #\;)
+
+(test #f char-lower-case? #\0)
+(test #f char-lower-case? #\9)
+(test #f char-lower-case? #\space)
+(test #f char-lower-case? #\;)
+
+(test #\. integer->char (char->integer #\.))
+(test #\A integer->char (char->integer #\A))
+(test #\a integer->char (char->integer #\a))
+(test #\A char-upcase #\A)
+(test #\A char-upcase #\a)
+(test #\a char-downcase #\A)
+(test #\a char-downcase #\a)
+(SECTION 6 7)
+(test #t string? "The word \"recursion\\\" has many meanings.")
+;(test #t string? "")
+(define f (make-string 3 #\*))
+(test "?**" 'string-set! (begin (string-set! f 0 #\?) f))
+(test "abc" string #\a #\b #\c)
+(test "" string)
+(test 3 string-length "abc")
+(test #\a string-ref "abc" 0)
+(test #\c string-ref "abc" 2)
+(test 0 string-length "")
+(test "" substring "ab" 0 0)
+(test "" substring "ab" 1 1)
+(test "" substring "ab" 2 2)
+(test "a" substring "ab" 0 1)
+(test "b" substring "ab" 1 2)
+(test "ab" substring "ab" 0 2)
+(test "foobar" string-append "foo" "bar")
+(test "foo" string-append "foo")
+(test "foo" string-append "foo" "")
+(test "foo" string-append "" "foo")
+(test "" string-append)
+(test "" make-string 0)
+(test #t string=? "" "")
+(test #f string<? "" "")
+(test #f string>? "" "")
+(test #t string<=? "" "")
+(test #t string>=? "" "")
+(test #t string-ci=? "" "")
+(test #f string-ci<? "" "")
+(test #f string-ci>? "" "")
+(test #t string-ci<=? "" "")
+(test #t string-ci>=? "" "")
+
+(test #f string=? "A" "B")
+(test #f string=? "a" "b")
+(test #f string=? "9" "0")
+(test #t string=? "A" "A")
+
+(test #t string<? "A" "B")
+(test #t string<? "a" "b")
+(test #f string<? "9" "0")
+(test #f string<? "A" "A")
+
+(test #f string>? "A" "B")
+(test #f string>? "a" "b")
+(test #t string>? "9" "0")
+(test #f string>? "A" "A")
+
+(test #t string<=? "A" "B")
+(test #t string<=? "a" "b")
+(test #f string<=? "9" "0")
+(test #t string<=? "A" "A")
+
+(test #f string>=? "A" "B")
+(test #f string>=? "a" "b")
+(test #t string>=? "9" "0")
+(test #t string>=? "A" "A")
+
+(test #f string-ci=? "A" "B")
+(test #f string-ci=? "a" "B")
+(test #f string-ci=? "A" "b")
+(test #f string-ci=? "a" "b")
+(test #f string-ci=? "9" "0")
+(test #t string-ci=? "A" "A")
+(test #t string-ci=? "A" "a")
+
+(test #t string-ci<? "A" "B")
+(test #t string-ci<? "a" "B")
+(test #t string-ci<? "A" "b")
+(test #t string-ci<? "a" "b")
+(test #f string-ci<? "9" "0")
+(test #f string-ci<? "A" "A")
+(test #f string-ci<? "A" "a")
+
+(test #f string-ci>? "A" "B")
+(test #f string-ci>? "a" "B")
+(test #f string-ci>? "A" "b")
+(test #f string-ci>? "a" "b")
+(test #t string-ci>? "9" "0")
+(test #f string-ci>? "A" "A")
+(test #f string-ci>? "A" "a")
+
+(test #t string-ci<=? "A" "B")
+(test #t string-ci<=? "a" "B")
+(test #t string-ci<=? "A" "b")
+(test #t string-ci<=? "a" "b")
+(test #f string-ci<=? "9" "0")
+(test #t string-ci<=? "A" "A")
+(test #t string-ci<=? "A" "a")
+
+(test #f string-ci>=? "A" "B")
+(test #f string-ci>=? "a" "B")
+(test #f string-ci>=? "A" "b")
+(test #f string-ci>=? "a" "b")
+(test #t string-ci>=? "9" "0")
+(test #t string-ci>=? "A" "A")
+(test #t string-ci>=? "A" "a")
+(SECTION 6 8)
+(test #t vector? '#(0 (2 2 2 2) "Anna"))
+;(test #t vector? '#())
+(test '#(a b c) vector 'a 'b 'c)
+(test '#() vector)
+(test 3 vector-length '#(0 (2 2 2 2) "Anna"))
+(test 0 vector-length '#())
+(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5)
+(test '#(0 ("Sue" "Sue") "Anna") 'vector-set
+ (let ((vec (vector 0 '(2 2 2 2) "Anna")))
+ (vector-set! vec 1 '("Sue" "Sue"))
+ vec))
+(test '#(hi hi) make-vector 2 'hi)
+(test '#() make-vector 0)
+(test '#() make-vector 0 'a)
+(SECTION 6 9)
+(test #t procedure? car)
+;(test #f procedure? 'car)
+(test #t procedure? (lambda (x) (* x x)))
+(test #f procedure? '(lambda (x) (* x x)))
+(test #t call-with-current-continuation procedure?)
+(test 7 apply + (list 3 4))
+(test 7 apply (lambda (a b) (+ a b)) (list 3 4))
+(test 17 apply + 10 (list 3 4))
+(test '() apply list '())
+(define compose (lambda (f g) (lambda args (f (apply g args)))))
+(test 30 (compose sqt *) 12 75)
+
+(test '(b e h) map cadr '((a b) (d e) (g h)))
+(test '(5 7 9) map + '(1 2 3) '(4 5 6))
+(test '(1 2 3) map + '(1 2 3))
+(test '(1 2 3) map * '(1 2 3))
+(test '(-1 -2 -3) map - '(1 2 3))
+(test '#(0 1 4 9 16) 'for-each
+ (let ((v (make-vector 5)))
+ (for-each (lambda (i) (vector-set! v i (* i i)))
+ '(0 1 2 3 4))
+ v))
+(test -3 call-with-current-continuation
+ (lambda (exit)
+ (for-each (lambda (x) (if (negative? x) (exit x)))
+ '(54 0 37 -3 245 19))
+ #t))
+(define list-length
+ (lambda (obj)
+ (call-with-current-continuation
+ (lambda (return)
+ (letrec ((r (lambda (obj) (cond ((null? obj) 0)
+ ((pair? obj) (+ (r (cdr obj)) 1))
+ (else (return #f))))))
+ (r obj))))))
+(test 4 list-length '(1 2 3 4))
+(test #f list-length '(a b . c))
+(test '() map cadr '())
+
+;;; This tests full conformance of call-with-current-continuation. It
+;;; is a separate test because some schemes do not support call/cc
+;;; other than escape procedures. I am indebted to
+;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this
+;;; code. The function leaf-eq? compares the leaves of 2 arbitrary
+;;; trees constructed of conses.
+(define (next-leaf-generator obj eot)
+ (letrec ((return #f)
+ (cont (lambda (x)
+ (recur obj)
+ (set! cont (lambda (x) (return eot)))
+ (cont #f)))
+ (recur (lambda (obj)
+ (if (pair? obj)
+ (for-each recur obj)
+ (call-with-current-continuation
+ (lambda (c)
+ (set! cont c)
+ (return obj)))))))
+ (lambda () (call-with-current-continuation
+ (lambda (ret) (set! return ret) (cont #f))))))
+(define (leaf-eq? x y)
+ (let* ((eot (list 'eot))
+ (xf (next-leaf-generator x eot))
+ (yf (next-leaf-generator y eot)))
+ (letrec ((loop (lambda (x y)
+ (cond ((not (eq? x y)) #f)
+ ((eq? eot x) #t)
+ (else (loop (xf) (yf)))))))
+ (loop (xf) (yf)))))
+(define (test-cont)
+ (newline)
+ (display ";testing continuations; ")
+ (newline)
+ (SECTION 6 9)
+ (test #t leaf-eq? '(a (b (c))) '((a) b c))
+ (test #f leaf-eq? '(a (b (c))) '((a) b c d))
+ (report-errs))
+
+;;; Test Optional R4RS DELAY syntax and FORCE procedure
+(define (test-delay)
+ (newline)
+ (display ";testing DELAY and FORCE; ")
+ (newline)
+ (SECTION 6 9)
+ (test 3 'delay (force (delay (+ 1 2))))
+ (test '(3 3) 'delay (let ((p (delay (+ 1 2))))
+ (list (force p) (force p))))
+ (test 2 'delay (letrec ((a-stream
+ (letrec ((next (lambda (n)
+ (cons n (delay (next (+ n 1)))))))
+ (next 0)))
+ (head car)
+ (tail (lambda (stream) (force (cdr stream)))))
+ (head (tail (tail a-stream)))))
+ (letrec ((count 0)
+ (p (delay (begin (set! count (+ count 1))
+ (if (> count x)
+ count
+ (force p)))))
+ (x 5))
+ (test 6 force p)
+ (set! x 10)
+ (test 6 force p))
+ (test 3 'force
+ (letrec ((p (delay (if c 3 (begin (set! c #t) (+ (force p) 1)))))
+ (c #f))
+ (force p)))
+ (report-errs))
+
+(SECTION 6 10 1)
+(test #t input-port? (current-input-port))
+(test #t output-port? (current-output-port))
+(test #t call-with-input-file "r4rstest.scm" input-port?)
+(define this-file (open-input-file "r4rstest.scm"))
+(test #t input-port? this-file)
+(SECTION 6 10 2)
+(test #\; peek-char this-file)
+(test #\; read-char this-file)
+(test '(define cur-section '()) read this-file)
+(test #\( peek-char this-file)
+(test '(define errs '()) read this-file)
+(close-input-port this-file)
+(close-input-port this-file)
+(define (check-test-file name)
+ (define test-file (open-input-file name))
+ (test #t 'input-port?
+ (call-with-input-file
+ name
+ (lambda (test-file)
+ (test load-test-obj read test-file)
+ (test #t eof-object? (peek-char test-file))
+ (test #t eof-object? (read-char test-file))
+ (input-port? test-file))))
+ (test #\; read-char test-file)
+ (test #\; read-char test-file)
+ (test #\; read-char test-file)
+ (test write-test-obj read test-file)
+ (test load-test-obj read test-file)
+ (close-input-port test-file))
+(SECTION 6 10 3)
+(define write-test-obj
+ '(#t #f a () 9739 -3 . #((test) "te \" \" st" "" test #() b c)))
+(define load-test-obj
+ (list 'define 'foo (list 'quote write-test-obj)))
+(test #t call-with-output-file
+ "tmp1"
+ (lambda (test-file)
+ (write-char #\; test-file)
+ (display #\; test-file)
+ (display ";" test-file)
+ (write write-test-obj test-file)
+ (newline test-file)
+ (write load-test-obj test-file)
+ (output-port? test-file)))
+(check-test-file "tmp1")
+
+(define test-file (open-output-file "tmp2"))
+(write-char #\; test-file)
+(display #\; test-file)
+(display ";" test-file)
+(write write-test-obj test-file)
+(newline test-file)
+(write load-test-obj test-file)
+(test #t output-port? test-file)
+(close-output-port test-file)
+(check-test-file "tmp2")
+(define (test-sc4)
+ (newline)
+ (display ";testing scheme 4 functions; ")
+ (newline)
+ (SECTION 6 7)
+ (test '(#\P #\space #\l) string->list "P l")
+ (test '() string->list "")
+ (test "1\\\"" list->string '(#\1 #\\ #\"))
+ (test "" list->string '())
+ (SECTION 6 8)
+ (test '(dah dah didah) vector->list '#(dah dah didah))
+ (test '() vector->list '#())
+ (test '#(dididit dah) list->vector '(dididit dah))
+ (test '#() list->vector '())
+ (SECTION 6 10 4)
+ (load "tmp1")
+ (test write-test-obj 'load foo)
+ (report-errs))
+
+(report-errs)
+(let ((have-inexacts?
+ (and (string->number "0.0") (inexact? (string->number "0.0"))))
+ (have-bignums?
+ (let ((n (string->number "281474976710655325431")))
+ (and n (exact? n)))))
+ (cond (have-inexacts?
+ (test-inexact)
+ (test-inexact-printing)))
+ (if have-bignums? (test-bignum))
+ (if (and have-inexacts? have-bignums?)
+ (test-numeric-predicates)))
+
+(newline)
+(display "To fully test continuations, Scheme 4, and DELAY/FORCE do:")
+(newline)
+(display "(test-cont) (test-sc4) (test-delay)")
+(newline)
+(test-cont)
+(test-sc4)
+(test-delay)
+"last item in file"
diff --git a/tests/r5rs_pitfalls.scm b/tests/r5rs_pitfalls.scm
new file mode 100644
index 00000000..5813dfc2
--- /dev/null
+++ b/tests/r5rs_pitfalls.scm
@@ -0,0 +1,330 @@
+;; r5rs_pitfalls.scm
+;;
+;; This program attempts to test a Scheme implementation's conformance
+;; to various subtle edge-cases and consequences of the R5RS Scheme standard.
+;; Code was collected from public forums, and is hereby placed in the public domain.
+;;
+;;
+(define-syntax should-be
+ (syntax-rules ()
+ ((_ test-id value expression)
+ (let ((return-value expression))
+ (if (not (equal? return-value value))
+ (for-each (lambda (v) (display v))
+ `("Failure: " test-id ", expected '"
+ value "', got '" ,return-value "'." #\newline))
+ (for-each (lambda (v) (display v))
+ '("Passed: " test-id #\newline)))))))
+
+(define call/cc call-with-current-continuation)
+
+;; Section 1: Proper letrec implementation
+
+;;Credits to Al Petrofsky
+;; In thread:
+;; defines in letrec body
+;; http://groups.google.com/groups?selm=87bsoq0wfk.fsf%40app.dial.idiom.com
+(should-be 1.1 0
+ (let ((cont #f))
+ (letrec ((x (call-with-current-continuation (lambda (c) (set! cont c) 0)))
+ (y (call-with-current-continuation (lambda (c) (set! cont c) 0))))
+ (if cont
+ (let ((c cont))
+ (set! cont #f)
+ (set! x 1)
+ (set! y 1)
+ (c 0))
+ (+ x y)))))
+
+;;Credits to Al Petrofsky
+;; In thread:
+;; Widespread bug (arguably) in letrec when an initializer returns twice
+;; http://groups.google.com/groups?selm=87d793aacz.fsf_-_%40app.dial.idiom.com
+(should-be 1.2 #t
+ (letrec ((x (call/cc list)) (y (call/cc list)))
+ (cond ((procedure? x) (x (pair? y)))
+ ((procedure? y) (y (pair? x))))
+ (let ((x (car x)) (y (car y)))
+ (and (call/cc x) (call/cc y) (call/cc x)))))
+
+;;Credits to Alan Bawden
+;; In thread:
+;; LETREC + CALL/CC = SET! even in a limited setting
+;; http://groups.google.com/groups?selm=19890302162742.4.ALAN%40PIGPEN.AI.MIT.EDU
+(should-be 1.3 #t
+ (letrec ((x (call-with-current-continuation
+ (lambda (c)
+ (list #T c)))))
+ (if (car x)
+ ((cadr x) (list #F (lambda () x)))
+ (eq? x ((cadr x))))))
+
+;; Section 2: Proper call/cc and procedure application
+
+;;Credits to Al Petrofsky, (and a wink to Matthias Blume)
+;; In thread:
+;; Widespread bug in handling (call/cc (lambda (c) (0 (c 1)))) => 1
+;; http://groups.google.com/groups?selm=87g00y4b6l.fsf%40radish.petrofsky.org
+(should-be 2.1 1
+ (call/cc (lambda (c) (0 (c 1)))))
+
+;; Section 3: Hygienic macros
+
+;; Eli Barzilay
+;; In thread:
+;; R5RS macros...
+;; http://groups.google.com/groups?selm=skitsdqjq3.fsf%40tulare.cs.cornell.edu
+(should-be 3.1 4
+ (let-syntax ((foo
+ (syntax-rules ()
+ ((_ expr) (+ expr 1)))))
+ (let ((+ *))
+ (foo 3))))
+
+
+;; Al Petrofsky again
+;; In thread:
+;; Buggy use of begin in r5rs cond and case macros.
+;; http://groups.google.com/groups?selm=87bse3bznr.fsf%40radish.petrofsky.org
+(should-be 3.2 2
+ (let-syntax ((foo (syntax-rules ()
+ ((_ var) (define var 1)))))
+ (let ((x 2))
+ (begin (define foo +))
+ (cond (else (foo x)))
+ x)))
+
+;;Al Petrofsky
+;; In thread:
+;; An Advanced syntax-rules Primer for the Mildly Insane
+;; http://groups.google.com/groups?selm=87it8db0um.fsf@radish.petrofsky.org
+
+(should-be 3.3 1
+ (let ((x 1))
+ (let-syntax
+ ((foo (syntax-rules ()
+ ((_ y) (let-syntax
+ ((bar (syntax-rules ()
+ ((_) (let ((x 2)) y)))))
+ (bar))))))
+ (foo x))))
+
+;; Al Petrofsky
+;; Contributed directly
+(should-be 3.4 1
+ (let-syntax ((x (syntax-rules ()))) 1))
+
+;; Setion 4: No identifiers are reserved
+
+;;(Brian M. Moore)
+;; In thread:
+;; shadowing syntatic keywords, bug in MIT Scheme?
+;; http://groups.google.com/groups?selm=6e6n88%248qf%241%40news.cc.ukans.edu
+(should-be 4.1 '(x)
+ ((lambda lambda lambda) 'x))
+
+(should-be 4.2 '(1 2 3)
+ ((lambda (begin) (begin 1 2 3)) (lambda lambda lambda)))
+
+(should-be 4.3 #f
+ (let ((quote -)) (eqv? '1 1)))
+;; Section 5: #f/() distinctness
+
+;; Scott Miller
+(should-be 5.1 #f
+ (eq? #f '()))
+(should-be 5.2 #f
+ (eqv? #f '()))
+(should-be 5.3 #f
+ (equal? #f '()))
+
+;; Section 6: string->symbol case sensitivity
+
+;; Jens Axel S?gaard
+;; In thread:
+;; Symbols in DrScheme - bug?
+;; http://groups.google.com/groups?selm=3be55b4f%240%24358%24edfadb0f%40dspool01.news.tele.dk
+(should-be 6.1 #f
+ (eq? (string->symbol "f") (string->symbol "F")))
+
+;; Section 7: First class continuations
+
+;; Scott Miller
+;; No newsgroup posting associated. The gist of this test and 7.2
+;; is that once captured, a continuation should be unmodified by the
+;; invocation of other continuations. This test determines that this is
+;; the case by capturing a continuation and setting it aside in a temporary
+;; variable while it invokes that and another continuation, trying to
+;; side effect the first continuation. This test case was developed when
+;; testing SISC 1.7's lazy CallFrame unzipping code.
+(define r #f)
+(define a #f)
+(define b #f)
+(define c #f)
+(define i 0)
+(should-be 7.1 28
+ (let ()
+ (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4))))
+ (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7))))))
+ (if (not c)
+ (set! c a))
+ (set! i (+ i 1))
+ (case i
+ ((1) (a 5))
+ ((2) (b 8))
+ ((3) (a 6))
+ ((4) (c 4)))
+ r))
+
+;; Same test, but in reverse order
+(define r #f)
+(define a #f)
+(define b #f)
+(define c #f)
+(define i 0)
+(should-be 7.2 28
+ (let ()
+ (set! r (+ 1 (+ 2 (+ 3 (call/cc (lambda (k) (set! a k) 4))))
+ (+ 5 (+ 6 (call/cc (lambda (k) (set! b k) 7))))))
+ (if (not c)
+ (set! c a))
+ (set! i (+ i 1))
+ (case i
+ ((1) (b 8))
+ ((2) (a 5))
+ ((3) (b 7))
+ ((4) (c 4)))
+ r))
+
+;; Credits to Matthias Radestock
+;; Another test case used to test SISC's lazy CallFrame routines.
+(should-be 7.3 '((-1 4 5 3)
+ (4 -1 5 3)
+ (-1 5 4 3)
+ (5 -1 4 3)
+ (4 5 -1 3)
+ (5 4 -1 3))
+ (let ((k1 #f)
+ (k2 #f)
+ (k3 #f)
+ (state 0))
+ (define (identity x) x)
+ (define (fn)
+ ((identity (if (= state 0)
+ (call/cc (lambda (k) (set! k1 k) +))
+ +))
+ (identity (if (= state 0)
+ (call/cc (lambda (k) (set! k2 k) 1))
+ 1))
+ (identity (if (= state 0)
+ (call/cc (lambda (k) (set! k3 k) 2))
+ 2))))
+ (define (check states)
+ (set! state 0)
+ (let* ((res '())
+ (r (fn)))
+ (set! res (cons r res))
+ (if (null? states)
+ res
+ (begin (set! state (car states))
+ (set! states (cdr states))
+ (case state
+ ((1) (k3 4))
+ ((2) (k2 2))
+ ((3) (k1 -)))))))
+ (map check '((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1)))))
+
+;; Modification of the yin-yang puzzle so that it terminates and produces
+;; a value as a result. (Scott G. Miller)
+(should-be 7.4 '(10 9 8 7 6 5 4 3 2 1 0)
+ (let ((x '())
+ (y 0))
+ (call/cc
+ (lambda (escape)
+ (let* ((yin ((lambda (foo)
+ (set! x (cons y x))
+ (if (= y 10)
+ (escape x)
+ (begin
+ (set! y 0)
+ foo)))
+ (call/cc (lambda (bar) bar))))
+ (yang ((lambda (foo)
+ (set! y (+ y 1))
+ foo)
+ (call/cc (lambda (baz) baz)))))
+ (yin yang))))))
+
+;; Miscellaneous
+
+;;Al Petrofsky
+;; In thread:
+;; R5RS Implementors Pitfalls
+;; http://groups.google.com/groups?selm=871zemtmd4.fsf@app.dial.idiom.com
+(should-be 8.1 -1
+ (let - ((n (- 1))) n))
+
+(should-be 8.2 '(1 2 3 4 1 2 3 4 5)
+ (let ((ls (list 1 2 3 4)))
+ (append ls ls '(5))))
+
+;; This example actually illustrates a bug in R5RS. If a Scheme system
+;; follows the letter of the standard, 1 should be returned, but
+;; the general agreement is that 2 should instead be returned.
+;; The reason is that in R5RS, let-syntax always introduces new scope, thus
+;; in the following test, the let-syntax breaks the definition section
+;; and begins the expression section of the let.
+;;
+;; The general agreement by the implementors in 1998 was that the following
+;; should be possible, but isn't:
+;;
+;; (define ---)
+;; (let-syntax (---)
+;; (define ---)
+;; (define ---))
+;; (define ---)
+;;
+;; Scheme systems based on the Portable syntax-case expander by Dybvig
+;; and Waddell do allow the above, and thus often violate the letter of
+;; R5RS. In such systems, the following will produce a local scope:
+;;
+;; (define ---)
+;; (let-syntax ((a ---))
+;; (let ()
+;; (define ---)
+;; (define ---)))
+;; (define ---)
+;;
+;; Credits to Matthias Radestock and thanks to R. Kent Dybvig for the
+;; explanation and background
+(should-be 8.3 1
+ (let ((x 1))
+ (let-syntax ((foo (syntax-rules () ((_) 2))))
+ (define x (foo))
+ 3)
+ x))
+
+;;Not really an error to fail this (Matthias Radestock)
+;;If this returns (0 1 0), your map isn't call/cc safe, but is probably
+;;tail-recursive. If its (0 0 0), the opposite is true.
+(let ((result
+ (let ()
+ (define executed-k #f)
+ (define cont #f)
+ (define res1 #f)
+ (define res2 #f)
+ (set! res1 (map (lambda (x)
+ (if (= x 0)
+ (call/cc (lambda (k) (set! cont k) 0))
+ 0))
+ '(1 0 2)))
+ (if (not executed-k)
+ (begin (set! executed-k #t)
+ (set! res2 res1)
+ (cont 1)))
+ res2)))
+ (if (equal? result '(0 0 0))
+ (display "Map is call/cc safe, but probably not tail recursive or inefficient.")
+ (display "Map is not call/cc safe, but probably tail recursive and efficient."))
+ (newline))
+
diff --git a/tests/re-tests.txt b/tests/re-tests.txt
new file mode 100644
index 00000000..a73604c6
--- /dev/null
+++ b/tests/re-tests.txt
@@ -0,0 +1,125 @@
+abc abc y & abc
+abc xbc n - -
+abc axc n - -
+abc abx n - -
+abc xabcy y & abc
+abc ababc y & abc
+ab*c abc y & abc
+ab*bc abc y & abc
+ab*bc abbc y & abbc
+ab*bc abbbbc y & abbbbc
+ab+bc abbc y & abbc
+ab+bc abc n - -
+ab+bc abq n - -
+ab+bc abbbbc y & abbbbc
+ab?bc abbc y & abbc
+ab?bc abc y & abc
+ab?bc abbbbc n - -
+ab?c abc y & abc
+^abc$ abc y & abc
+^abc$ abcc n - -
+^abc abcc y & abc
+^abc$ aabc n - -
+abc$ aabc y & abc
+^ abc y &
+$ abc y &
+a.c abc y & abc
+a.c axc y & axc
+a.*c axyzc y & axyzc
+a.*c axyzd n - -
+a[bc]d abc n - -
+a[bc]d abd y & abd
+a[b-d]e abd n - -
+a[b-d]e ace y & ace
+a[b-d] aac y & ac
+a[-b] a- y & a-
+a[b-] a- y & a-
+[k] ab n - -
+a[b-a] - c - -
+a[]b - c - -
+a[ - c - -
+a] a] y & a]
+a[]]b a]b y & a]b
+a[^bc]d aed y & aed
+a[^bc]d abd n - -
+a[^-b]c adc y & adc
+a[^-b]c a-c n - -
+a[^]b]c a]c n - -
+a[^]b]c adc y & adc
+ab|cd abc y & ab
+ab|cd abcd y & ab
+()ef def y &-\1 ef-
+()* - c - -
+*a - c - -
+^* - c - -
+$* - c - -
+(*)b - c - -
+$b b n - -
+a\ - c - -
+a\(b a(b y &-\1 a(b-
+a\(*b ab y & ab
+a\(*b a((b y & a((b
+a\\b a\b y & a\b
+abc) - c - -
+(abc - c - -
+((a)) abc y &-\1-\2 a-a-a
+(a)b(c) abc y &-\1-\2 abc-a-c
+a+b+c aabbabc y & abc
+a** - c - -
+(a*)* - c - -
+(a*)+ - c - -
+(a|)* - c - -
+(a*|b)* - c - -
+(a+|b)* ab y &-\1 ab-b
+(a+|b)+ ab y &-\1 ab-b
+(a+|b)? ab y &-\1 a-a
+[^ab]* cde y & cde
+(^)* - c - -
+(ab|)* - c - -
+)( - c - -
+ abc y &
+abc n - -
+a* y &
+abcd abcd y &-\&-\\& abcd-&-\abcd
+a(bc)d abcd y \1-\\1-\\\1 bc-\1-\bc
+([abc])*d abbbcd y &-\1 abbbcd-c
+([abc])*bcd abcd y &-\1 abcd-a
+a|b|c|d|e e y & e
+(a|b|c|d|e)f ef y &-\1 ef-e
+((a*|b))* - c - -
+abcd*efg abcdefg y & abcdefg
+ab* xabyabbbz y & ab
+ab* xayabbbz y & a
+(ab|cd)e abcde y &-\1 cde-cd
+[abhgefdc]ij hij y & hij
+^(ab|cd)e abcde n x\1y xy
+(abc|)ef abcdef y &-\1 ef-
+(a|b)c*d abcd y &-\1 bcd-b
+(ab|ab*)bc abc y &-\1 abc-a
+a([bc]*)c* abc y &-\1 abc-bc
+a([bc]*)(c*d) abcd y &-\1-\2 abcd-bc-d
+a([bc]+)(c*d) abcd y &-\1-\2 abcd-bc-d
+a([bc]*)(c+d) abcd y &-\1-\2 abcd-b-cd
+a[bcd]*dcdcde adcdcde y & adcdcde
+a[bcd]+dcdcde adcdcde n - -
+(ab|a)b*c abc y &-\1 abc-ab
+((a)(b)c)(d) abcd y \1-\2-\3-\4 abc-a-b-d
+[ -~]* abc y & abc
+[ -~ -~]* abc y & abc
+[ -~ -~ -~]* abc y & abc
+[ -~ -~ -~ -~]* abc y & abc
+[ -~ -~ -~ -~ -~]* abc y & abc
+[ -~ -~ -~ -~ -~ -~]* abc y & abc
+[ -~ -~ -~ -~ -~ -~ -~]* abc y & abc
+[a-zA-Z_][a-zA-Z0-9_]* alpha y & alpha
+^a(bc+|b[eh])g|.h$ abh y &-\1 bh-
+(bc+d$|ef*g.|h?i(j|k)) effgz y &-\1-\2 effgz-effgz-
+(bc+d$|ef*g.|h?i(j|k)) ij y &-\1-\2 ij-ij-j
+(bc+d$|ef*g.|h?i(j|k)) effg n - -
+(bc+d$|ef*g.|h?i(j|k)) bcdd n - -
+(bc+d$|ef*g.|h?i(j|k)) reffgz y &-\1-\2 effgz-effgz-
+(((((((((a))))))))) a y & a
+multiple words of text uh-uh n - -
+multiple words multiple words, yeah y & multiple words
+(.*)c(.*) abcde y &-\1-\2 abcde-ab-de
+\((.*), (.*)\) (a, b) y (\2, \1) (b, a)
diff --git a/tests/reexport-tests.scm b/tests/reexport-tests.scm
new file mode 100644
index 00000000..ef19a63a
--- /dev/null
+++ b/tests/reexport-tests.scm
@@ -0,0 +1,38 @@
+;;;; reexport-tests.scm
+
+
+(module r4rs ()
+ (import scheme chicken)
+ (reexport
+ (except scheme
+ dynamic-wind values call-with-values eval scheme-report-environment
+ null-environment interaction-environment)))
+
+(module m1 ()
+ (import r4rs)
+ (display (+ 3 4))
+ (newline))
+
+(assert
+ (not
+ (handle-exceptions ex #f
+ (eval '(module m2 ()
+ (import r4rs)
+ (values 123))))))
+
+(define-syntax compound-module
+ (syntax-rules ()
+ ((_ name imp ...)
+ (module name ()
+ (import scheme)
+ (reexport imp ...)))))
+
+(compound-module
+ big-chicken
+ chicken ports files extras data-structures)
+
+(require-library extras data-structures)
+
+(module m3 ()
+ (import scheme big-chicken)
+ (pp (string-intersperse '("abc" "def" "ghi") "-")))
diff --git a/tests/runtests.sh b/tests/runtests.sh
new file mode 100644
index 00000000..e260339e
--- /dev/null
+++ b/tests/runtests.sh
@@ -0,0 +1,224 @@
+#!/bin/sh
+# runtests.sh
+
+set -e
+TEST_DIR=`pwd`
+export DYLD_LIBRARY_PATH=${TEST_DIR}/..
+export LD_LIBRARY_PATH=${TEST_DIR}/..
+
+mkdir -p test-repository
+
+# copy files into test-repository (by hand to avoid calling `chicken-install'):
+
+for x in setup-api.so setup-api.import.so setup-download.so \
+ setup-download.import.so chicken.import.so lolevel.import.so \
+ srfi-1.import.so srfi-4.import.so data-structures.import.so \
+ ports.import.so files.import.so posix.import.so \
+ srfi-13.import.so srfi-69.import.so extras.import.so \
+ regex.import.so srfi-14.import.so tcp.import.so \
+ foreign.import.so scheme.import.so srfi-18.import.so \
+ utils.import.so csi.import.so irregex.import.so types.db; do
+ cp ../$x test-repository
+done
+
+"${TEST_DIR}/../chicken-install" -init test-repository export
+CHICKEN_REPOSITORY=${TEST_DIR}/test-repository
+CHICKEN=../chicken
+
+if test -n "$MSYSTEM"; then
+ CHICKEN="..\\chicken.exe"
+fi
+
+compile="../csc -compiler $CHICKEN -v -I.. -L.. -include-path .. -o a.out"
+compile_s="../csc -s -compiler $CHICKEN -v -I.. -L.. -include-path .."
+interpret="../csi -n -include-path .."
+
+echo "======================================== compiler tests ..."
+$compile compiler-tests.scm
+./a.out
+
+echo "======================================== compiler tests (2) ..."
+$compile compiler-tests-2.scm -lambda-lift
+./a.out
+
+echo "======================================== compiler inlining tests ..."
+$compile inlining-tests.scm -optimize-level 3
+./a.out
+
+echo "======================================== scrutiny tests ..."
+$compile scrutiny-tests.scm -scrutinize -analyze-only -ignore-repository -types ../types.db 2>scrutiny.out
+
+if test -n "$MSYSTEM"; then
+ dos2unix scrutiny.out
+fi
+
+# this is sensitive to gensym-names, so make it optional
+if test \! -f scrutiny.expected; then
+ cp scrutiny.out scrutiny.expected
+fi
+
+diff -u scrutiny.out scrutiny.expected || true
+
+echo "======================================== runtime tests ..."
+$interpret -s apply-test.scm
+$compile test-gc-hooks.scm
+./a.out
+
+echo "======================================== library tests ..."
+$interpret -s library-tests.scm
+
+echo "======================================== syntax tests ..."
+$interpret -s syntax-tests.scm
+
+echo "======================================== syntax tests (compiled) ..."
+$compile syntax-tests.scm
+./a.out
+
+echo "======================================== syntax tests (2, compiled) ..."
+$compile syntax-tests-2.scm
+./a.out
+
+#echo "======================================== meta-syntax tests ..."
+#$interpret -bnq meta-syntax-test.scm -e '(import foo)' -e '(bar 1 2)'
+#$compile_s -s meta-syntax-test.scm -j foo
+#$compile_s -s foo.import.scm
+#$interpret -bnq -e '(require-library meta-syntax-test)' -e '(import foo)' -e '(bar 1 2)'
+
+echo "======================================== reexport tests ..."
+$interpret -bnq reexport-tests.scm
+$compile reexport-tests.scm
+./a.out
+
+echo "======================================== compiler syntax tests ..."
+$compile compiler-syntax-tests.scm
+./a.out
+
+echo "======================================== import library tests ..."
+rm -f foo.import.*
+$compile import-library-test1.scm -emit-import-library foo
+$interpret -s import-library-test2.scm
+$compile_s -s foo.import.scm -o foo.import.so
+$interpret -s import-library-test2.scm
+$compile import-library-test2.scm
+./a.out
+
+echo "======================================== syntax tests (matchable) ..."
+$interpret matchable.scm -s match-test.scm
+
+echo "======================================== syntax tests (loopy-loop) ..."
+$interpret -s loopy-test.scm
+
+echo "======================================== syntax tests (r5rs_pitfalls) ..."
+echo "(expect two failures)"
+$interpret -i -s r5rs_pitfalls.scm
+
+echo "======================================== module tests ..."
+$interpret -include-path .. -s module-tests.scm
+
+echo "======================================== module tests (compiled) ..."
+$compile module-tests-compiled.scm
+./a.out
+
+echo "======================================== module tests (chained) ..."
+rm -f m*.import.* test-chained-modules.so
+$interpret -bnq test-chained-modules.scm
+$compile_s test-chained-modules.scm -j m3
+$compile_s m3.import.scm
+$interpret -bn test-chained-modules.so
+$interpret -bn test-chained-modules.so -e '(import m3) (s3)'
+
+echo "======================================== module tests (ec) ..."
+rm -f ec.so ec.import.*
+$interpret -bqn ec.scm ec-tests.scm
+$compile_s ec.scm -emit-import-library ec -o ec.so
+$compile_s ec.import.scm -o ec.import.so
+$interpret -bnq ec.so ec-tests.scm
+# $compile ec-tests.scm
+# ./a.out # takes ages to compile
+
+echo "======================================== hash-table tests ..."
+$interpret -s hash-table-tests.scm
+
+echo "======================================== lolevel tests ..."
+$interpret -s lolevel-tests.scm
+
+echo "======================================== port tests ..."
+$interpret -s port-tests.scm
+
+echo "======================================== fixnum tests ..."
+$compile fixnum-tests.scm
+./a.out
+
+echo "======================================== srfi-18 tests ..."
+$interpret -s srfi-18-tests.scm
+echo "*** Skipping \"feeley-dynwind\" (for now) ***"
+# $interpret -s feeley-dynwind.scm
+
+echo "======================================== path tests ..."
+$interpret -bnq path-tests.scm
+
+echo "======================================== posix tests ..."
+$compile posix-tests.scm
+./a.out
+
+echo "======================================== regular expression tests ..."
+$interpret -bnq test-irregex.scm
+
+echo "======================================== r4rstest ..."
+echo "(expect mult-float-print-test to fail)"
+$interpret -e '(set! ##sys#procedure->string (constantly "#<procedure>"))' \
+ -i -s r4rstest.scm >r4rstest.log
+
+if test -n "$MSYSTEM"; then
+ # the windows runtime library prints flonums differently
+ tail r4rstest.log
+else
+ diff -bu r4rstest.out r4rstest.log || true
+fi
+
+echo "======================================== compiler/nursery stress test ..."
+for s in 100000 120000 200000 250000 300000 350000 400000 450000 500000; do
+ echo " $s"
+ ../chicken ../utils.scm -:s$s -output-file tmp.c -include-path ..
+done
+
+echo "======================================== finalizer tests ..."
+$interpret -s test-finalizers.scm
+
+echo "======================================== finalizer tests (2) ..."
+$compile test-finalizers-2.scm
+./a.out
+
+echo "======================================== locative stress test ..."
+$compile locative-stress-test.scm
+./a.out
+
+echo "======================================== embedding (1) ..."
+$compile embedded1.c
+./a.out
+
+echo "======================================== embedding (2) ..."
+$compile -e embedded2.scm
+./a.out
+
+echo "======================================== regex benchmarks ..."
+
+cd ../benchmarks/regex
+../../csi -bnq -include-path ../.. benchmark.scm
+cd "${TEST_DIR}"
+
+echo "======================================== benchmarks ..."
+cd ../benchmarks
+for x in `ls *.scm`; do
+ case $x in
+ "cscbench.scm");;
+ "plists.scm");;
+ *)
+ echo $x
+ ../csc $x -compiler $CHICKEN -I.. -L.. -O3 -d0
+ ./`basename $x .scm`;;
+ esac
+done
+cd "${TEST_DIR}"
+
+echo "======================================== done."
diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm
new file mode 100644
index 00000000..f3b872b3
--- /dev/null
+++ b/tests/scrutiny-tests.scm
@@ -0,0 +1,40 @@
+;;;; scrutiny-tests.scm
+
+
+(pp (current-environment))
+
+(define (a)
+ (define (b)
+ (define (c)
+ (let ((x (+ 3 4)))
+ (if x 1 2)))))
+
+(define (foo x)
+ (if x
+ (values 1 2)
+ (values 1 2 (+ (+ (+ (+ 3)))))))
+
+(let ((bar +))
+ (bar 3 'a))
+
+(pp)
+
+(print (cpu-time))
+(print (values))
+
+(let ((x 100))
+ (x))
+
+(print (+ 'a 'b))
+
+(set! car 33)
+
+((values 1 2))
+
+; this should *not* signal a warning:
+
+(define (test-values x)
+ (define (fail) (error "failed"))
+ (if x
+ (values 42 43)
+ (fail)))
diff --git a/tests/scrutiny.expected b/tests/scrutiny.expected
new file mode 100644
index 00000000..fa6ab5c8
--- /dev/null
+++ b/tests/scrutiny.expected
@@ -0,0 +1,47 @@
+
+Warning: at toplevel:
+ use of deprecated toplevel identifier `current-environment'
+
+Warning: in local procedure `c',
+ in local procedure `b',
+ in toplevel procedure `a':
+ expected value of type boolean in conditional but were given a value of type `number' which is always true:
+
+(if x3 '1 '2)
+
+Warning: in toplevel procedure `foo':
+ branches in conditional expression differ in the number of results:
+
+(if x5 (values '1 '2) (values '1 '2 (+ ...)))
+
+Warning: at toplevel:
+ expected argument #2 of type `number' in procedure call to `bar6' (line 18), but where given an argument of type `symbol'
+
+Warning: at toplevel:
+ expected in procedure call to `pp' (line 20) 1 argument, but where given 0 arguments
+
+Warning: at toplevel:
+ expected in argument #1 of procedure call `(print (cpu-time))' a single result, but were given 2 results
+
+Warning: at toplevel:
+ expected in argument #1 of procedure call `(print (values))' a single result, but were given zero results
+
+Warning: at toplevel:
+ expected in procedure call to `x7' (line 26) a value of type `(procedure () *)', but were given a value of type `fixnum'
+
+Warning: at toplevel:
+ expected argument #1 of type `number' in procedure call to `+' (line 28), but where given an argument of type `symbol'
+
+Warning: at toplevel:
+ expected argument #2 of type `number' in procedure call to `+' (line 28), but where given an argument of type `symbol'
+
+Warning: at toplevel:
+ assignment of value of type `fixnum' to toplevel variable `car' does not match declared type `(procedure car (pair) *)'
+
+Warning: at toplevel:
+ expected in operator position of procedure call `((values (quote 1) (quote 2)))' a single result, but were given 2 results
+
+Warning: at toplevel:
+ expected in procedure call to `(values (quote 1) (quote 2))' a value of type `(procedure () *)', but were given a value of type `fixnum'
+
+Warning: redefinition of standard binding `car'
diff --git a/tests/srfi-18-tests.scm b/tests/srfi-18-tests.scm
new file mode 100644
index 00000000..de38727c
--- /dev/null
+++ b/tests/srfi-18-tests.scm
@@ -0,0 +1,73 @@
+(require-extension srfi-18)
+
+(cond-expand (dribble
+(define-for-syntax count 0)
+(define-syntax trail
+ (lambda (form r c) ; doesn't bother much with renaming
+ (let ((loc (cadr form))
+ (expr (caddr form)))
+ (set! count (add1 count))
+ `(,(r 'begin)
+ (print "(" ,count ") " ,loc ": " ',expr ": get: " (##sys#slot get-mutex 5) ", put: " (##sys#slot put-mutex 5))
+ (let ((xxx ,expr))
+ (print " (" ,count ") " ,loc ": " ',expr ": get: " (##sys#slot get-mutex 5) ", put: " (##sys#slot put-mutex 5))
+ xxx) ) ))))
+(else (define-syntax trail (syntax-rules () ((_ loc expr) expr)))))
+
+(define (tprint . x)
+ (printf "~a " (current-milliseconds))
+ (apply print x))
+
+(define (make-empty-mailbox)
+ (let ((put-mutex (make-mutex)) ; allow put! operation
+ (get-mutex (make-mutex))
+ (cell #f))
+
+ (define (put! obj)
+ (trail 'put! (mutex-lock! put-mutex #f #f)) ; prevent put! operation
+ (set! cell obj)
+ (trail 'put! (mutex-unlock! get-mutex)) )
+
+ (define (get!)
+ (trail 'get! (mutex-lock! get-mutex #f #f)) ; wait until object in mailbox
+ (let ((result cell))
+ (set! cell #f) ; prevent space leaks
+ (trail 'get! (mutex-unlock! put-mutex)) ; allow put! operation
+ result))
+
+ (trail 'main (mutex-lock! get-mutex #f #f)) ; prevent get! operation
+
+ (lambda (print)
+ (case print
+ ((put!) put!)
+ ((get!) get!)
+ (else (error "unknown message"))))))
+
+(define (mailbox-put! m obj) ((m 'put!) obj))
+(define (mailbox-get! m) ((m 'get!)))
+
+;(tprint 'start)
+
+(define mb (make-empty-mailbox))
+
+(thread-start!
+ (make-thread
+ (lambda ()
+ (let lp ()
+ ;(print "1: get")
+ (let ((x (mailbox-get! mb)))
+ ;(tprint "read: " x)
+ (assert x)
+ (lp))))))
+
+(thread-start!
+ (make-thread
+ (lambda ()
+ (thread-sleep! 1)
+ ;(tprint 'put)
+ ;(print "2: put")
+ (mailbox-put! mb 'test)
+ #;(print "2: endput"))))
+
+(thread-sleep! 3)
+;(tprint 'exit)
diff --git a/tests/syntax-rule-stress-test.scm b/tests/syntax-rule-stress-test.scm
new file mode 100644
index 00000000..49989929
--- /dev/null
+++ b/tests/syntax-rule-stress-test.scm
@@ -0,0 +1,34 @@
+; A stress test of the syntax-rule macro-expander.
+; The following code, when evaluated, prints if number 5 is prime.
+; The code implements the sieve of Eratosthenes, (see the macro ?sieve)
+; The code is generated automatically by the Scheme-to-syntax-rule
+; compiler.
+; See macros.html in this directory for more detail.
+
+(define-syntax ??!apply (syntax-rules (??!lambda) ((_ (??!lambda (bound-var . other-bound-vars) body) oval . other-ovals) (letrec-syntax ((subs (syntax-rules (??! bound-var ??!lambda) ((_ val k (??! bound-var)) (appl k val)) ((_ val k (??!lambda bvars int-body)) (subs-in-lambda val bvars (k bvars) int-body)) ((_ val k (x)) (subs val (recon-pair val k ()) x)) ((_ val k (x . y)) (subs val (subsed-cdr val k x) y)) ((_ val k x) (appl k x)))) (subsed-cdr (syntax-rules () ((_ val k x new-y) (subs val (recon-pair val k new-y) x)))) (recon-pair (syntax-rules () ((_ val k new-y new-x) (appl k (new-x . new-y))))) (subs-in-lambda (syntax-rules (bound-var) ((_ val () kp int-body) (subs val (recon-l kp ()) int-body)) ((_ val (bound-var . obvars) (k bvars) int-body) (appl k (??!lambda bvars int-body))) ((_ val (obvar . obvars) kp int-body) (subs-in-lambda val obvars kp int-body)))) (recon-l (syntax-rules () ((_ (k bvars) () result) (appl k (??!lambda bvars result))))) (appl (syntax-rules () ((_ (a b c d) result) (a b c d result)) ((_ (a b c) result) (a b c result)))) (finish (syntax-rules () ((_ () () exp) exp) ((_ rem-bvars rem-ovals exps) (??!apply (??!lambda rem-bvars exps) . rem-ovals))))) (subs oval (finish other-bound-vars other-ovals) body)))))
+(define-syntax ?car (syntax-rules () ((_ (x . y) k) (??!apply k x))))
+(define-syntax ?cdr (syntax-rules () ((_ (x . y) k) (??!apply k y))))
+(define-syntax ?cons (syntax-rules () ((_ x y k) (??!apply k (x . y)))))
+(define-syntax ?null? (syntax-rules () ((_ () k) (??!apply k #t)) ((_ x k) (??!apply k #f))))
+(define-syntax ?ifnull? (syntax-rules () ((_ () kt kf) (??!apply kt #t)) ((_ x kt kf) (??!apply kf #f))))
+(define-syntax ?pair? (syntax-rules () ((_ (a . b) k) (??!apply k #t)) ((_ not-pair k) (??!apply k #f))))
+(define-syntax ?ifpair? (syntax-rules () ((_ (a . b) kt kf) (??!apply kt #t)) ((_ not-pair kt kf) (??!apply kf #f))))
+(define-syntax ?true? (syntax-rules () ((_ x k) (??!apply k x))))
+(define-syntax ?iftrue? (syntax-rules () ((_ #f kt kf) (??!apply kf #f)) ((_ x kt kf) (??!apply kt #t))))
+(define-syntax ?append (syntax-rules () ((_ (x ...) (y ...) k) (??!apply k (x ... y ...)))))
+(define-syntax ?ifeq? (syntax-rules () ((_ (x . y) b kt kf) (??!apply kf #f)) ((_ () b kt kf) (??!apply kf #f)) ((_ a b _kt _kf) (let-syntax ((aux (syntax-rules (a) ((_ a kt kf) (??!apply kt #t)) ((_ other kt kf) (??!apply kf #f))))) (aux b _kt _kf)))))
+(define-syntax ?ifmemq? (syntax-rules () ((_ a lst kt kf) (?ifpair? lst (??!lambda (_) (?car lst (??!lambda (x) (?ifeq? a (??! x) (??!lambda (_) (??!apply kt #t)) (??!lambda (_) (?cdr lst (??!lambda (tail) (?ifmemq? a (??! tail) kt kf)))))))) (??!lambda (_) (??!apply kf #f))))))
+(define-syntax ?number-zero (syntax-rules () ((_ k) (??!apply k ()))))
+(define-syntax ?number-two (syntax-rules () ((_ k) (??!apply k ((()))))))
+(define-syntax ?incr (syntax-rules () ((_ n k) (??!apply k (n)))))
+(define-syntax ?decr (syntax-rules () ((_ (n) k) (??!apply k n))))
+(define-syntax ?less-than-two? (syntax-rules () ((_ ((n)) k) (??!apply k #f)) ((_ x k) (??!apply k #t))))
+(define-syntax ?ifless-than-two? (syntax-rules () ((_ ((n)) kt kf) (??!apply kf #f)) ((_ x kt kf) (??!apply kt #t))))
+(define-syntax ?number-zero? (syntax-rules () ((_ () k) (??!apply k #t)) ((_ x k) (??!apply k #f))))
+(define-syntax ?ifnumber-zero? (syntax-rules () ((_ () kt kf) (??!apply kt #t)) ((_ x kt kf) (??!apply kf #f))))
+(define-syntax ?iota (syntax-rules () ((_ _?n _?kg1029) (letrec-syntax ((?loop (syntax-rules () ((_ _?currg1031 _?counterg1032 _?kg1030) (?ifless-than-two? _?counterg1032 (??!lambda (g1033) (??!apply _?kg1030 ())) (??!lambda (g1034) (?incr _?currg1031 (??!lambda (g1036) (?decr _?counterg1032 (??!lambda (g1037) (?loop (??! g1036) (??! g1037) (??!lambda (g1035) (?cons _?currg1031 (??! g1035) _?kg1030))))))))))))) (?number-two (??!lambda (g1038) (?loop (??! g1038) _?n _?kg1029)))))))
+(define-syntax ?sieve (syntax-rules () ((_ _?lst _?kg1039) (letrec-syntax ((?choose-pivot (syntax-rules () ((_ _?lstg1041 _?kg1040) (?ifnull? _?lstg1041 (??!lambda (g1042) (??!apply _?kg1040 _?lstg1041)) (??!lambda (g1043) (?car _?lstg1041 (??!lambda (g1057) (?number-zero? (??! g1057) (??!lambda (g1044) (?iftrue? (??! g1044) (??!lambda (g1045) (?car _?lstg1041 (??!lambda (g1046) (?cdr _?lstg1041 (??!lambda (g1048) (?choose-pivot (??! g1048) (??!lambda (g1047) (?cons (??! g1046) (??! g1047) _?kg1040)))))))) (??!lambda (g1049) (?car _?lstg1041 (??!lambda (g1050) (?car _?lstg1041 (??!lambda (g1053) (?car _?lstg1041 (??!lambda (g1056) (?decr (??! g1056) (??!lambda (g1054) (?cdr _?lstg1041 (??!lambda (g1055) (?do-sieve (??! g1053) (??! g1054) (??! g1055) (??!lambda (g1052) (?choose-pivot (??! g1052) (??!lambda (g1051) (?cons (??! g1050) (??! g1051) _?kg1040)))))))))))))))))))))))))) (?do-sieve (syntax-rules () ((_ _?stepg1059 _?currentg1060 _?lstg1061 _?kg1058) (?ifnull? _?lstg1061 (??!lambda (g1062) (??!apply _?kg1058 _?lstg1061)) (??!lambda (g1063) (?ifnumber-zero? _?currentg1060 (??!lambda (g1064) (?number-zero (??!lambda (g1065) (?decr _?stepg1059 (??!lambda (g1067) (?cdr _?lstg1061 (??!lambda (g1068) (?do-sieve _?stepg1059 (??! g1067) (??! g1068) (??!lambda (g1066) (?cons (??! g1065) (??! g1066) _?kg1058)))))))))) (??!lambda (g1069) (?car _?lstg1061 (??!lambda (g1070) (?decr _?currentg1060 (??!lambda (g1072) (?cdr _?lstg1061 (??!lambda (g1073) (?do-sieve _?stepg1059 (??! g1072) (??! g1073) (??!lambda (g1071) (?cons (??! g1070) (??! g1071) _?kg1058))))))))))))))))) (?choose-pivot _?lst _?kg1039)))))
+(define-syntax ?is-prime (syntax-rules () ((_ _?n _?kg1074) (?iota _?n (??!lambda (g1081) (?sieve (??! g1081) (??!lambda (g1080) (?reverse (??! g1080) (??!lambda (g1079) (?car (??! g1079) (??!lambda (g1078) (?number-zero? (??! g1078) (??!lambda (g1075) (?iftrue? (??! g1075) (??!lambda (g1076) (??!apply _?kg1074 composite)) (??!lambda (g1077) (??!apply _?kg1074 prime))))))))))))))))
+(define-syntax ?reverse (syntax-rules () ((_ _?lst _?kg1082) (letrec-syntax ((?loop (syntax-rules () ((_ _?lstg1084 _?accumg1085 _?kg1083) (?ifnull? _?lstg1084 (??!lambda (g1086) (??!apply _?kg1083 _?accumg1085)) (??!lambda (g1087) (?cdr _?lstg1084 (??!lambda (g1088) (?car _?lstg1084 (??!lambda (g1090) (?cons (??! g1090) _?accumg1085 (??!lambda (g1089) (?loop (??! g1088) (??! g1089) _?kg1083))))))))))))) (?loop _?lst () _?kg1082)))))
+(?is-prime (((((()))))) (??!lambda (x) (display (quote (??! x)))))
+(newline)
\ No newline at end of file
diff --git a/tests/syntax-tests-2.scm b/tests/syntax-tests-2.scm
new file mode 100644
index 00000000..7eb2be7d
--- /dev/null
+++ b/tests/syntax-tests-2.scm
@@ -0,0 +1,6 @@
+;;;; syntax-tests-2.scm - tests using extended syntax at runtime
+
+(require-library chicken-syntax)
+
+(eval '(define-record-type x (make x) x? (x get-x)))
+(assert (eq? 'yes (get-x (make 'yes))))
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
new file mode 100644
index 00000000..b36d5fc7
--- /dev/null
+++ b/tests/syntax-tests.scm
@@ -0,0 +1,373 @@
+;;;; mtest.scm - various macro tests
+
+
+(use extras)
+
+
+(define-syntax t
+ (syntax-rules ()
+ ((_ r x)
+ (let ((tmp x))
+ (if (not (equal? r tmp))
+ (error "test failed" r tmp 'x)
+ (pp tmp))))))
+
+(define-syntax f
+ (syntax-rules ()
+ ((_ x)
+ (handle-exceptions ex (void)
+ x
+ (error "test returned, but should have failed" 'x) ))))
+
+(t 3 3)
+
+(f abc)
+
+(f (t 3 4))
+
+;; test syntax-rules
+
+(define-syntax test
+ (syntax-rules ()
+ ((_ x form)
+ (let ((tmp x))
+ (if (number? tmp)
+ form
+ (error "not a number" tmp))))))
+
+(t 100 (test 2 100))
+
+;; some basic contrived testing
+
+(define (fac n)
+ (let-syntax ((m1 (lambda (n r c)
+ (pp `(M1: ,n))
+ (list (r 'sub1) (cadr n)))))
+ (define (sub1 . _) ; ref. transp.? (should not be used here)
+ (error "argh.") )
+ #;(print "fac: " n)
+ (if (test n (zero? n))
+ 1
+ (* n (fac (m1 n))))))
+
+(t 3628800 (fac 10))
+
+;; letrec-syntax
+
+(t 34
+(letrec-syntax ((foo (syntax-rules () ((_ x) (bar x))))
+ (bar (syntax-rules () ((_ x) (+ x 1)))))
+ (foo 33))
+)
+
+;; from r5rs:
+
+(t 45
+(let ((x 5))
+ (define foo (lambda (y) (bar x y)))
+ (define bar (lambda (a b) (+ (* a b) a)))
+ (foo (+ x 3)))
+)
+
+;; an error, according to r5rs - here it treats foo as defining a toplevel binding
+
+#;(let-syntax
+ ((foo (syntax-rules ()
+ ((foo (proc args ...) body ...)
+ (define proc
+ (lambda (args ...)
+ body ...))))))
+ (let ((x 3))
+ (foo (plus x y) (+ x y))
+ (define foo x)
+ (print (plus foo x))))
+
+(t 'now
+(let-syntax ((when (syntax-rules ()
+ ((when test stmt1 stmt2 ...)
+ (if test
+ (begin stmt1
+ stmt2 ...))))))
+ (let ((if #t))
+ (when if (set! if 'now))
+ if))
+)
+
+(t 'outer
+(let ((x 'outer))
+ (let-syntax ((m (syntax-rules () ((m) x))))
+ (let ((x 'inner))
+ (m))))
+)
+
+(t 7
+(letrec-syntax
+ ((my-or (syntax-rules ()
+ ((my-or) #f)
+ ((my-or e) e)
+ ((my-or e1 e2 ...)
+ (let ((temp e1))
+ (if temp
+ temp
+ (my-or e2 ...)))))))
+ (let ((x #f)
+ (y 7)
+ (temp 8)
+ (let odd?)
+ (if even?))
+ (my-or x
+ (let temp)
+ (if y)
+ y)))
+)
+
+(define-syntax kw
+ (syntax-rules (baz)
+ ((_ baz) "baz")
+ ((_ any) "no baz")))
+
+(t "baz" (kw baz))
+(t "no baz" (kw xxx))
+
+(let ((baz 100))
+ (t "no baz" (kw baz)))
+
+(t 'ok
+(let ((=> #f))
+ (cond (#t => 'ok)))
+)
+
+(t '(3 4)
+(let ((foo 3))
+ (let-syntax ((bar (syntax-rules () ((_ x) (list foo x)))))
+ (let ((foo 4))
+ (bar foo))))
+)
+
+;;; alternative ellipsis test
+
+(define-syntax foo
+ (syntax-rules
+ ___ ()
+ ((_ vals ___) (list '... vals ___))))
+
+(t '(... 1 2 3)
+ (foo 1 2 3)
+)
+
+(define-syntax defalias
+ (syntax-rules ___ ()
+ ((_ new old)
+ (define-syntax new
+ (syntax-rules ()
+ ((_ args ...) (old args ...)))))))
+
+(defalias inc add1)
+
+(t 3 (inc 2))
+
+;;;
+
+(define-syntax usetmp
+ (syntax-rules ()
+ ((_ var)
+ (list var))))
+
+(define-syntax withtmp
+ (syntax-rules ()
+ ((_ val exp)
+ (let ((tmp val))
+ (exp tmp)))))
+
+(t '(99)
+ (withtmp 99 usetmp)
+)
+
+(t 7
+(letrec-syntax
+ ((my-or (syntax-rules ()
+ ((my-or) #f)
+ ((my-or e) e)
+ ((my-or e1 e2 ...)
+ (let ((temp e1))
+ (if temp
+ temp
+ (my-or e2 ...)))))))
+ (let ((x #f)
+ (y 7)
+ (temp 8)
+ (let odd?)
+ (if even?))
+ (my-or x
+ (let temp)
+ (if y)
+ y)))
+)
+
+(define-syntax foo
+ (syntax-rules ()
+ ((_ #(a ...)) (list a ...))))
+
+(t '(1 2 3)
+ (foo #(1 2 3))
+)
+
+
+(define-syntax loop
+ (lambda (x r c)
+ (let ((body (cdr x)))
+ `(,(r 'call/cc)
+ (,(r 'lambda) (exit)
+ (,(r 'let) ,(r 'f) () ,@body (,(r 'f))))))))
+
+(let ((n 10))
+ (loop
+ (print* n " ")
+ (set! n (sub1 n))
+ (when (zero? n) (exit #f)))
+ (newline))
+
+(define-syntax while0
+ (syntax-rules ()
+ ((_ t b ...)
+ (loop (if (not t) (exit #f))
+ b ...))))
+
+(f (while0 #f (print "no.")))
+
+(define-syntax while
+ (lambda (x r c)
+ `(,(r 'loop)
+ (,(r 'if) (,(r 'not) ,(cadr x)) (exit #f))
+ ,@(cddr x))))
+
+(let ((n 10))
+ (while (not (zero? n))
+ (print* n " ")
+ (set! n (- n 1)) )
+ (newline))
+
+;;; found by Jim Ursetto
+
+(let ((lambda 0)) (define (foo) 1) (foo))
+
+
+;;; define-macro implementation (only usable in a module-free environment)
+
+(define-syntax define-macro
+ (syntax-rules ()
+ ((_ (name . llist) body ...)
+ (define-syntax name
+ (lambda (x r c)
+ (apply (lambda llist body ...) (strip-syntax (cdr x))))))))
+
+(define-macro (loop . body)
+ (let ((loop (gensym)))
+ `(call/cc
+ (lambda (exit)
+ (let ,loop () ,@body (,loop))))))
+
+(let ((i 1))
+ (loop (when (> i 10) (exit #f))
+ (print* i " ")
+ (set! i (add1 i))))
+(newline)
+
+
+;;;; exported macro would override original name (fixed in rev. 13351)
+
+(module xfoo (xbaz xbar)
+ (import scheme)
+ (define-syntax xbar
+ (syntax-rules ()
+ ((_ 1) (xbaz))
+ ((_) 'xbar)))
+ (define-syntax xbaz
+ (syntax-rules ()
+ ((_ 1) (xbar))
+ ((_) 'xbazz))))
+
+(import xfoo)
+(assert (eq? 'xbar (xbaz 1)))
+(assert (eq? 'xbazz (xbar 1)))
+(assert (eq? 'xbar (xbar)))
+
+
+;;;; ellipsis pattern element wasn't matched - reported by Jim Ursetto (fixed rev. 13582)
+
+(define-syntax foo
+ (syntax-rules ()
+ ((_ (a b) ...)
+ (list '(a b) ...))
+ ((_ a ...)
+ (list '(a) ...))))
+
+(assert (equal? (foo (1 2) (3 4) (5 6)) '((1 2) (3 4) (5 6))))
+(assert (equal? (foo (1 2) (3) (5 6)) '(((1 2)) ((3)) ((5 6))))) ; failed
+(assert (equal? (foo 1) '((1))))
+
+
+;;; incorrect lookup for keyword variables in DSSSL llists
+
+(module broken-keyword-var ()
+ (import scheme chicken)
+ ((lambda (#!key string) (assert (not string))))) ; refered to R5RS `string'
+
+
+;;; compiler didn't resolve expansion into local variable
+;;; (reported by Alex Shinn, #15)
+
+(module unresolve-local (foo)
+ (import scheme)
+ (define (foo)
+ (let ((qux 3))
+ (let-syntax ((bar (syntax-rules () ((bar) qux))))
+ (bar))))
+
+ (display (foo))
+ (newline)
+)
+
+
+;;; incorrect expansion when assigning to something marked '##core#primitive (rev. 14613)
+
+(define x 99)
+
+(module primitive-assign ()
+ (import scheme chicken)
+ (let ((x 100)) (set! x 20) (assert (= x 20)))
+ (set! setter 123))
+
+(assert (= x 99))
+(assert (= 123 setter))
+
+
+;;; prefixed import from `chicken' module with indirect reference to imported syntax
+;;; (reported by Jack Trades)
+
+(module prefixed-self-reference1 (a b c)
+ (import scheme (prefix chicken c:))
+ (c:define-values (a b c) (values 1 2 3)) )
+
+(module prefixed-self-reference2 ()
+ (import scheme (prefix chicken c:))
+ (c:define-values (a b c) (values 1 2 3))
+ (c:print "ok")
+ (c:condition-case
+ (c:abort "ugh")
+ (ex () (c:print "caught"))))
+
+(module prefixed-self-reference3 (a)
+ (import (prefix scheme s.) (prefix chicken c.))
+ (s.define (a x y)
+ (c.condition-case (s.+ x y) ((exn) "not numbers")))
+ )
+
+(module prefixed-self-reference4 (a)
+ (import (prefix scheme s.))
+ (s.define (a x y) (s.and x y)))
+
+
+;;; canonicalization of body captures 'begin (reported by Abdulaziz Ghuloum)
+
+(let ((begin (lambda (x y) (bomb)))) 1 2)
diff --git a/tests/test-chained-modules.scm b/tests/test-chained-modules.scm
new file mode 100644
index 00000000..0e67445f
--- /dev/null
+++ b/tests/test-chained-modules.scm
@@ -0,0 +1,22 @@
+(module m1 ((s1 f1))
+ (import scheme chicken)
+ (define (f1) (print "f1") 'f1)
+ (define-syntax s1
+ (syntax-rules ()
+ ((_) (f1)))))
+
+(module m2 (s2)
+ (import scheme (rename m1 (s1 s1:s1)))
+ (define-syntax s2
+ (syntax-rules ()
+ ((_) (s1:s1)))))
+
+(module m3 (s3)
+ (import scheme m2)
+ (define-syntax s3
+ (syntax-rules ()
+ ((_) (s2)))))
+
+(import m3)
+(s3)
+
diff --git a/tests/test-finalizers-2.scm b/tests/test-finalizers-2.scm
new file mode 100644
index 00000000..1bdc1153
--- /dev/null
+++ b/tests/test-finalizers-2.scm
@@ -0,0 +1,60 @@
+;;;; test-finalizers-2.scm - test finalizers + GC roots
+
+
+(use srfi-1)
+
+(define *n* 1000)
+(define *count* 0)
+
+#>
+static void *
+makef(int f, ___scheme_value x)
+{
+ void *r = f ? CHICKEN_new_finalizable_gc_root() : CHICKEN_new_gc_root();
+
+ CHICKEN_gc_root_set(r, x);
+ return r;
+}
+
+static void
+freef(void *r)
+{
+ CHICKEN_delete_gc_root(r);
+}
+<#
+
+
+(define makef (foreign-lambda c-pointer "makef" bool scheme-object))
+(define freef (foreign-lambda void "freef" c-pointer))
+
+(define ((fin f e) x)
+ (set! *count* (add1 *count*))
+ (assert ((if e even? odd?) (car x)))
+ (when e (freef f)))
+
+(print "creating gc roots")
+
+(let* ((x (list-tabulate *n* list))
+ (fs (circular-list #t #f))
+ (rs (map makef fs x)))
+ (for-each
+ (lambda (x f e)
+ (set-finalizer! x (fin f e)))
+ x rs fs)
+ (print "forcing finalizers")
+ (##sys#force-finalizers)
+ (assert (zero? *count*))
+ (print "dropping data")
+ (set! x #f)
+ (print "forcing finalizables")
+ (##sys#force-finalizers)
+ (print *count*)
+ (assert (= (quotient *n* 2) *count*))
+ (print "releasing non-finalizable gc roots")
+ (for-each
+ (lambda (f e)
+ (unless e (freef f)))
+ rs fs)
+ (print "forcing remaining")
+ (##sys#force-finalizers)
+ (assert (= *n* *count*)))
diff --git a/tests/test-finalizers.scm b/tests/test-finalizers.scm
new file mode 100644
index 00000000..b9eda52d
--- /dev/null
+++ b/tests/test-finalizers.scm
@@ -0,0 +1,50 @@
+;;;; test-finalizers.scm
+
+(define x (list 1 2 3))
+(define y (list 4 5 6))
+(define x-f #f)
+(define y-f #f)
+
+(begin
+ (set-finalizer!
+ x
+ (lambda (o)
+ (format #t "Delete: ~A (y: ~a)~%" o y-f)
+ (set! x-f #t)))
+ #t)
+(begin
+ (set-finalizer!
+ y
+ (let ((p x))
+ (lambda (o)
+ (format #t "Delete: ~A: ~A~%" o p)
+ (set! y-f #t))))
+ #t)
+(gc #t)
+(assert (not x-f))
+
+#|
+
+This ought to work, see patches/finalizer.closures.diff for
+a fix that unfortunately disables finalizers in the interpreter
+(probably due to the different closure representation).
+
+(assert (not y-f))
+(set! x #f)
+(gc #t)
+(assert (not x-f))
+(assert (not y-f))
+(set! y #f)
+(gc #t)
+(assert y-f)
+(assert x-f)
+|#
+
+(define foo-f #f)
+
+(let ((foo (vector 1 2 3)))
+ (set-finalizer! foo (lambda _ (set! foo-f #t)))
+ #t)
+
+(gc #t)
+(assert foo-f)
diff --git a/tests/test-gc-hooks.scm b/tests/test-gc-hooks.scm
new file mode 100644
index 00000000..13e865b3
--- /dev/null
+++ b/tests/test-gc-hooks.scm
@@ -0,0 +1,42 @@
+;;;; test-gc-hooks.scm
+
+#>
+
+static int count = 0;
+
+static void
+gc_start(int mode)
+{
+ printf(">>>>> GC pre hook - mode=%d, count=%d\n", mode, count++);
+}
+
+static void
+gc_end(int mode, long ms)
+{
+ printf("<<<<< GC post hook - mode=%d, count=%d, ms=%ld\n", mode, --count, ms);
+}
+
+<#
+
+(set-gc-report! #t)
+
+(foreign-code #<<EOF
+C_pre_gc_hook = gc_start;
+C_post_gc_hook = gc_end;
+EOF
+)
+
+(print "major gc ...")
+(gc)
+(print "minor gc ...")
+(gc #f)
+(print "alloc ...")
+(make-string 10000000)
+(print "resize ...")
+(##sys#gc '())
+(print "major gc ...")
+(gc)
+(print "minor gc ...")
+(gc #f)
+
+(assert (zero? (foreign-value "count" int)))
diff --git a/tests/test-irregex.scm b/tests/test-irregex.scm
new file mode 100644
index 00000000..12d49adf
--- /dev/null
+++ b/tests/test-irregex.scm
@@ -0,0 +1,93 @@
+;;;: test-irregex.scm
+
+
+(use extras regex)
+
+(include "test.scm")
+
+(import irregex)
+
+(define (subst-matches matches subst)
+ (define (submatch n)
+ (if (vector? matches)
+ (irregex-match-substring matches n)
+ (list-ref matches n)))
+ (and
+ matches
+ (call-with-output-string
+ (lambda (out)
+ (call-with-input-string subst
+ (lambda (in)
+ (let lp ()
+ (let ((c (read-char in)))
+ (cond
+ ((not (eof-object? c))
+ (case c
+ ((#\&)
+ (display (or (submatch 0) "") out))
+ ((#\\)
+ (let ((c (read-char in)))
+ (if (char-numeric? c)
+ (display
+ (or (submatch (string->number (string c))) "")
+ out)
+ (write-char c out))))
+ (else
+ (write-char c out)))
+ (lp)))))))))))
+
+(define (test-re matcher line)
+ (apply
+ (lambda (pattern input result subst output)
+ (let ((name (sprintf "~A ~A ~A" pattern input result)))
+ (cond
+ ((equal? "c" result)
+ (test-error name (matcher pattern input)))
+ ((equal? "n" result)
+ (test-assert name (not (matcher pattern input))))
+ ((equal? "y" result)
+ (test-assert name (matcher pattern input)))
+ (else
+ (test-equal name
+ (subst-matches (matcher pattern input) subst)
+ result)))))
+ (string-split line "\t" #t)))
+
+
+(test-begin)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(for-each
+ (lambda (opts)
+ (test-group (sprintf "irregex - ~S" opts)
+ (with-input-from-file "re-tests.txt"
+ (lambda ()
+ (port-for-each
+ (lambda (line)
+ (test-re (lambda (pat str)
+ (irregex-search (apply irregex pat opts) str))
+ line))
+ read-line)))))
+ '((small) (fast)))
+
+(test-group "regex"
+ (with-input-from-file "re-tests.txt"
+ (lambda ()
+ (port-for-each
+ (lambda (line) (test-re string-search line))
+ read-line))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(test-group "utils"
+ (test-equal "replace"
+ (irregex-replace "[aeiou]" "hello world" "*")
+ "h*llo world")
+ (test-equal "replace/all"
+ (irregex-replace/all "[aeiou]" "hello world" "*")
+ "h*ll* w*rld"))
+
+(test-end)
+(test-exit)
+
diff --git a/tests/test.scm b/tests/test.scm
new file mode 100644
index 00000000..e9b43c14
--- /dev/null
+++ b/tests/test.scm
@@ -0,0 +1,99 @@
+;;;; test.scm - minimal testing framework
+;
+; by Alex Shinn, lifted from match-test by felix
+
+
+(define *pass* 0)
+(define *fail* 0)
+(define *start* 0)
+(define *fail-token* (gensym))
+
+(define (run-test name thunk expect eq pass-msg fail-msg)
+ (let ((result (thunk)))
+ (cond
+ ((eq expect result)
+ (set! *pass* (+ *pass* 1))
+ (format-result pass-msg name expect result))
+ (else
+ (set! *fail* (+ *fail* 1))
+ (format-result fail-msg name expect result)))))
+
+(define (format-result ls name expect result)
+ (let lp ((ls ls))
+ (cond
+ ((null? ls) (newline))
+ ((eq? (car ls) 'expect) (display expect) (lp (cdr ls)))
+ ((eq? (car ls) 'result) (display result) (lp (cdr ls)))
+ ((eq? (car ls) 'name) (if name (begin (display #\space) (display name))) (lp (cdr ls)))
+ (else (display (car ls)) (lp (cdr ls))))))
+
+(define (test-begin . o)
+ (set! *pass* 0)
+ (set! *fail* 0)
+ (set! *start* (current-milliseconds)))
+
+(define (format-float n prec)
+ (let* ((str (number->string n))
+ (len (string-length str)))
+ (let lp ((i (- len 1)))
+ (cond
+ ((negative? i)
+ (string-append str "." (make-string prec #\0)))
+ ((eqv? #\. (string-ref str i))
+ (let ((diff (+ 1 (- prec (- len i)))))
+ (cond
+ ((positive? diff)
+ (string-append str (make-string diff #\0)))
+ ((negative? diff)
+ (substring str 0 (+ i prec 1)))
+ (else
+ str))))
+ (else
+ (lp (- i 1)))))))
+
+(define (format-percent num denom)
+ (let ((x (if (zero? denom) num (exact->inexact (/ num denom)))))
+ (format-float (* 100 x) 2)))
+
+(define (test-end . o)
+ (let ((end (current-milliseconds))
+ (total (+ *pass* *fail*)))
+ (print " " total " tests completed in "
+ (format-float (exact->inexact (/ (- end *start*) 1000)) 3)
+ " seconds")
+ (print " " *pass* " ("
+ (format-percent *pass* total)
+ "%) tests passed")
+ (print " " *fail* " ("
+ (format-percent *fail* total)
+ "%) tests failed")
+ (exit (if (zero? *fail*) 0 1))))
+
+(define (run-equal name thunk expect eq)
+ (run-test name thunk expect eq
+ '("(PASS)" name)
+ '("(FAIL)" name ": expected " expect " but got " result)))
+
+(define-syntax test-equal
+ (syntax-rules ()
+ ((_ name expr value eq) (run-equal name (lambda () expr) value eq))
+ ((_ name expr value) (run-equal name (lambda () expr) value equal?))))
+
+(define-syntax test-error
+ (syntax-rules ()
+ ((_ name expr)
+ (run-equal
+ name
+ (lambda () (handle-exceptions ex *fail-token* expr)) *fail-token* eq?) )
+ ((_ expr) (test-error 'expr expr))))
+
+(define-syntax test-assert
+ (syntax-rules ()
+ ((_ name expr) (run-equal name (lambda () (if expr #t #f)) #t eq?))))
+
+(define-syntax test-group
+ (syntax-rules ()
+ ((_ name body ...)
+ (begin
+ (print "\n" name ":\n")
+ body ...))))
diff --git a/tweaks.scm b/tweaks.scm
new file mode 100644
index 00000000..e59f1208
--- /dev/null
+++ b/tweaks.scm
@@ -0,0 +1,57 @@
+;;;; tweaks.scm - Some inline-routines and declarations
+;
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+;; This file contains some stuff to speed up basic node accessors, and also
+;; contains common declarations.
+
+(cond-expand
+ [compiler-unsafe
+ (declare
+ (fixnum)
+ (disable-interrupts)
+ (no-bound-checks)
+ (no-procedure-checks)
+ (no-argc-checks) ) ]
+ [else
+ (declare
+ (fixnum)
+ (disable-interrupts) ) ] )
+
+
+(define-inline (node? x) (##sys#structure? x 'node))
+(define-inline (make-node c p s) (##sys#make-structure 'node c p s))
+(define-inline (node-class n) (##sys#slot n 1))
+(define-inline (node-parameters n) (##sys#slot n 2))
+(define-inline (node-subexpressions n) (##sys#slot n 3))
+
+(define-inline (intrinsic? sym) (##sys#get sym '##compiler#intrinsic))
+
+(define-inline (mark-variable var mark #!optional (val #t))
+ (##sys#put! var mark val) )
+
+(define-inline (variable-mark var mark)
+ (##sys#get var mark) )
diff --git a/types.db b/types.db
new file mode 100644
index 00000000..0061bf2f
--- /dev/null
+++ b/types.db
@@ -0,0 +1,1384 @@
+;;;; types.db - Type-information for core library functions -*- Scheme -*-
+;
+; Copyright (c 2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+;; scheme
+
+(not (procedure not (*) boolean))
+(boolean? (procedure boolean (*) boolean))
+(eq? (procedure eq? (* *) boolean))
+(eqv? (procedure eqv? (* *) boolean))
+(equal? (procedure equal? (* *) boolean))
+(pair? (procedure pair? (*) boolean))
+(cons (procedure cons (* *) pair))
+(car (procedure car (pair) *))
+(cdr (procedure cdr (pair) *))
+(caar (procedure caar (pair) *))
+(cadr (procedure cadr (pair) *))
+(cdar (procedure cdar (pair) *))
+(cddr (procedure cddr (pair) *))
+(caaar (procedure caaar (pair) *))
+(caadr (procedure caadr (pair) *))
+(cadar (procedure cadar (pair) *))
+(caddr (procedure caddr (pair) *))
+(cdaar (procedure cdaar (pair) *))
+(cdadr (procedure cdadr (pair) *))
+(cddar (procedure cddar (pair) *))
+(cdddr (procedure cdddr (pair) *))
+(caaaar (procedure caaaar (pair) *))
+(caaadr (procedure caaadr (pair) *))
+(caadar (procedure caadar (pair) *))
+(caaddr (procedure caaddr (pair) *))
+(cadaar (procedure cadaar (pair) *))
+(cadadr (procedure cadadr (pair) *))
+(caddar (procedure caddar (pair) *))
+(cadddr (procedure cadddr (pair) *))
+(cdaaar (procedure cdaaar (pair) *))
+(cdaadr (procedure cdaadr (pair) *))
+(cdadar (procedure cdadar (pair) *))
+(cdaddr (procedure cdaddr (pair) *))
+(cddaar (procedure cddaar (pair) *))
+(cddadr (procedure cddadr (pair) *))
+(cdddar (procedure cdddar (pair) *))
+(cddddr (procedure cddddr (pair) *))
+(set-car! (procedure set-car! (pair *) undefined))
+(set-cdr! (procedure set-cdr! (pair *) undefined))
+(null? (procedure null? (*) boolean))
+(list? (procedure list? (*) boolean))
+(list (procedure list (#!rest) list))
+(length (procedure length (list) fixnum))
+(list-tail (procedure list-tail (list fixnum) *))
+(list-ref (procedure list-ref (list fixnum) *))
+(append (procedure append (list #!rest) list))
+(reverse (procedure reverse (list) list))
+(memq (procedure memq (* list) *)) ; result type: (or list boolean) ?
+(memv (procedure memv (* list) *))
+(member (procedure member (* list #!optional (procedure (* *) *)) *))
+(assq (procedure assq (* list) *))
+(assv (procedure assv (* list) *))
+(assoc (procedure assoc (* list #!optional (procedure (* *) *)) *))
+(symbol? (procedure symbol? (*) boolean))
+(symbol->string (procedure symbol->string (symbol) string))
+(string->symbol (procedure string->symbol (string) symbol))
+(number? (procedure number? (*) boolean))
+(integer? (procedure integer? (*) boolean))
+(exact? (procedure exact? (*) boolean))
+(real? (procedure real? (*) boolean))
+(complex? (procedure complex? (*) boolean))
+(inexact? (procedure inexact? (*) boolean))
+(rational? (procedure rational? (*) boolean))
+(zero? (procedure zero? (number) boolean))
+(odd? (procedure odd? (number) boolean))
+(even? (procedure even? (number) boolean))
+(positive? (procedure positive? (number) boolean))
+(negative? (procedure negative? (number) boolean))
+(max (procedure max (#!rest number) number))
+(min (procedure min (#!rest number) number))
+(+ (procedure + (#!rest number) number))
+(- (procedure - (number #!rest number) number))
+(* (procedure * (#!rest number) number))
+(/ (procedure / (number #!rest number) number))
+(= (procedure = (#!rest number) boolean))
+(> (procedure > (#!rest number) boolean))
+(< (procedure < (#!rest number) boolean))
+(>= (procedure >= (#!rest number) boolean))
+(<= (procedure <= (#!rest number) boolean))
+(quotient (procedure quotient (number number) number))
+(remainder (procedure remainder (number number) number))
+(modulo (procedure modulo (number number) number))
+(gcd (procedure gcd (#!rest number) number))
+(lcm (procedure lcm (#!rest number) number))
+(abs (procedure abs (number) number))
+(floor (procedure floor (number) number))
+(ceiling (procedure ceiling (number) number))
+(truncate (procedure truncate (number) number))
+(round (procedure round (number) number))
+(exact->inexact (procedure exact->inexact (number) number))
+(inexact->exact (procedure inexact->exact (number) number))
+(exp (procedure exp (number) float))
+(log (procedure log (number) float))
+(expt (procedure expt (number number) number))
+(sqrt (procedure sqrt (number) float))
+(sin (procedure sin (number) float))
+(cos (procedure cos (number) float))
+(tan (procedure tan (number) float))
+(asin (procedure asin (number) float))
+(acos (procedure acos (number) float))
+(atan (procedure atan (number number) float))
+(number->string (procedure number->string (number #!optional number) string))
+(string->number (procedure string->number (string #!optional number) (or number boolean)))
+(char? (procedure char? (*) boolean))
+(char=? (procedure char=? (char char) boolean))
+(char>? (procedure char>? (char char) boolean))
+(char<? (procedure char<? (char char) boolean))
+(char>=? (procedure char>=? (char char) boolean))
+(char<=? (procedure char<=? (char char) boolean))
+(char-ci=? (procedure char-ci=? (char char) boolean))
+(char-ci<? (procedure char-ci<? (char char) boolean))
+(char-ci>? (procedure char-ci>? (char char) boolean))
+(char-ci>=? (procedure char-ci>=? (char char) boolean))
+(char-ci<=? (procedure char-ci<=? (char char) boolean))
+(char-alphabetic? (procedure char-alphabetic? (char) boolean))
+(char-whitespace? (procedure char-whitespace? (char) boolean))
+(char-numeric? (procedure char-numeric? (char) boolean))
+(char-upper-case? (procedure char-upper-case? (char) boolean))
+(char-lower-case? (procedure char-lower-case? (char) boolean))
+(char-upcase (procedure char-upcase (char) char))
+(char-downcase (procedure char-downcase (char) char))
+(char->integer (procedure char->integer (char) fixnum))
+(integer->char (procedure integer->char (fixnum) char))
+(string? (procedure string? (*) boolean))
+(string=? (procedure string=? (string string) boolean))
+(string>? (procedure string>? (string string) boolean))
+(string<? (procedure string<? (string string) boolean))
+(string>=? (procedure string>=? (string string) boolean))
+(string<=? (procedure string<=? (string string) boolean))
+(string-ci=? (procedure string-ci=? (string string) boolean))
+(string-ci<? (procedure string-ci<? (string string) boolean))
+(string-ci>? (procedure string-ci>? (string string) boolean))
+(string-ci>=? (procedure string-ci>=? (string string) boolean))
+(string-ci<=? (procedure string-ci<=? (string string) boolean))
+(make-string (procedure make-string (fixnum #!optional char) string))
+(string-length (procedure string-length (string) fixnum))
+(string-ref (procedure string-ref (string fixnum) char))
+(string-set! (procedure string-set! (string fixnum char) undefined))
+(string-append (procedure string-append (#!rest string) string))
+;(string-copy (procedure string-copy (string) string)) - we use the more general version from srfi-13
+(string->list (procedure string->list (string) list))
+(list->string (procedure list->string (list) string))
+(substring (procedure substring (string fixnum #!optional fixnum) string))
+(string-fill! (procedure string-fill! (string char) string))
+(vector? (procedure vector? (*) boolean))
+(make-vector (procedure make-vector (fixnum #!optional *) vector))
+(vector-ref (procedure vector-ref (vector fixnum) *))
+(vector-set! (procedure vector-set! (vector fixnum *) undefined))
+(string (procedure string (#!rest char) string))
+(vector (procedure vector (#!rest) vector))
+(vector-length (procedure vector-length (vector) fixnum))
+(vector->list (procedure vector->list (vector) list))
+(list->vector (procedure list->vector (list) vector))
+(vector-fill! (procedure vector-fill! (vector *) vector))
+(procedure? (procedure procedure? (*) boolean))
+(map (procedure map (procedure #!rest list) list))
+(for-each (procedure for-each (procedure #!rest list) undefined))
+(apply (procedure apply (procedure #!rest) . *))
+(force (procedure force (*) *))
+(call-with-current-continuation (procedure call-with-current-continuation (procedure) . *))
+(input-port? (procedure input-port? (*) boolean))
+(output-port? (procedure output-port? (*) boolean))
+(current-input-port (procedure current-input-port (#!optional port) port))
+(current-output-port (procedure current-output-port (#!optional port) port))
+(call-with-input-file (procedure call-with-input-file (string (procedure (port) . *)) . *))
+(call-with-output-file (procedure call-with-output-file (string (procedure (port) . *)) . *))
+(open-input-file (procedure open-input-file (string #!rest symbol) port))
+(open-output-file (procedure open-output-file (string #!rest symbol) port))
+(close-input-port (procedure close-input-port (port) undefined))
+(close-output-port (procedure close-output-port (port) undefined))
+(load (procedure load (string #!optional procedure) undefined))
+(read (procedure read (#!optional port) *))
+(eof-object? (procedure eof-object? (*) boolean))
+(read-char (procedure read-char (#!optional port) *)) ; result (or eof char) ?
+(peek-char (procedure peek-char (#!optional port) *))
+(write (procedure write (* #!optional port) undefined))
+(display (procedure display (* #!optional port) undefined))
+(write-char (procedure write-char (char #!optional port) undefined))
+(newline (procedure newline (#!optional port) undefined))
+(with-input-from-file (procedure with-input-from-file (string procedure #!rest symbol) . *))
+(with-output-to-file (procedure with-output-to-file (string procedure #!rest symbol) . *))
+(dynamic-wind (procedure dynamic-wind (procedure procedure procedure) . *))
+(values (procedure values (#!rest values) . *))
+(call-with-values (procedure call-with-values (procedure procedure) . *))
+(eval (procedure eval (* #!optional *) *))
+(char-ready? (procedure char-ready? (#!optional port) boolean))
+(imag-part (procedure imag-part (number) number))
+(real-part (procedure real-part (number) number))
+(magnitude (procedure magnitude (number) number))
+(numerator (procedure numerator (number) number))
+(denominator (procedure denominator (number) number))
+(scheme-report-environment (procedure scheme-report-environment (#!optional fixnum) *))
+(null-environment (procedure null-environment (#!optional fixnum) *))
+(interaction-environment (procedure interaction-environment () *))
+
+;; chicken
+
+(abort (procedure abort (*) noreturn))
+(add1 (procedure add1 (number) number))
+(argc+argv (procedure argc+argv () fixnum list))
+(argv (procedure argv () list))
+(arithmetic-shift (procedure arithmetic-shift (number number) number))
+(bit-set? (procedure bit-set? (number fixnum) boolean))
+(bitwise-and (procedure bitwise-and (#!rest number) number))
+(bitwise-ior (procedure bitwise-ior (#!rest number) number))
+(bitwise-not (procedure bitwise-not (number) number))
+(bitwise-xor (procedure bitwise-xor (#!rest number) number))
+(blob->string (procedure blob->string (blob) string))
+(blob-size (procedure blob-size (blob) fixnum))
+(blob? (procedure blob? (*) boolean))
+(blob=? (procedure blob=? (blob blob) boolean))
+(breakpoint (procedure breakpoint (#!optional *) . *))
+(build-platform (procedure build-platform () symbol))
+(c-runtime (procedure c-runtime () symbol))
+(call/cc (procedure call/cc (procedure) . *))
+(case-sensitive (procedure case-sensitive (#!optional *) *))
+(char-name (procedure char-name ((or char symbol) #!optional char) *))
+(chicken-home (procedure chicken-home () string))
+(chicken-version (procedure chicken-version (#!optional *) string))
+(command-line-arguments (procedure command-line-arguments (#!optional list) list))
+(condition-predicate (procedure condition-predicate (symbol) (procedure ((struct condition)) boolean)))
+(condition-property-accessor (procedure condition-property-accessor (symbol symbol #!optional *) (procedure ((struct condition)) *)))
+(condition? (procedure condition? (*) boolean))
+(continuation-capture (procedure continuation-capture ((procedure ((struct continuation)) . *)) *))
+(continuation-graft (procedure continuation-graft ((struct continuation) (procedure () . *)) *))
+(continuation-return (procedure continuation-return (procedure #!rest) . *)) ;XXX make return type more specific?
+(continuation? (procedure continuation? (*) boolean))
+(copy-read-table (procedure copy-read-table ((struct read-table)) (struct read-table)))
+(cpu-time (procedure cpu-time () fixnum fixnum))
+(current-error-port (procedure current-error-port (#!optional port) port))
+(current-exception-handler (procedure current-exception-handler () procedure))
+(current-gc-milliseconds (procedure current-gc-milliseconds () fixnum))
+(current-milliseconds (procedure current-milliseconds () fixnum))
+(current-read-table (procedure current-read-table () (struct read-table)))
+(current-seconds (procedure current-seconds () number))
+(define-reader-ctor (procedure define-reader-ctor (symbol procedure) undefined))
+(delete-file (procedure delete-file (string) undefined))
+(enable-warnings (procedure enable-warnings (#!optional *) *))
+(errno (procedure errno () fixnum))
+(error (procedure error (#!rest) noreturn))
+(exit (procedure exit (#!optional fixnum) noreturn))
+(exit-handler (procedure exit-handler (#!optional procedure) procedure))
+(expand (procedure expand (* #!optional *) *))
+(extension-information (procedure extension-information (symbol) *))
+(feature? (procedure feature? (symbol) boolean))
+(features (procedure features () list))
+(file-exists? (procedure file-exists? (string) *))
+(directory-exists? (procedure directory-exists? (string) *))
+(fixnum-bits fixnum)
+(fixnum-precision fixnum)
+(fixnum? (procedure fixnum? (*) boolean))
+(flonum-decimal-precision fixnum)
+(flonum-epsilon float)
+(flonum-maximum-decimal-exponent fixnum)
+(flonum-maximum-exponent fixnum)
+(flonum-minimum-decimal-exponent fixnum)
+(flonum-minimum-exponent fixnum)
+(flonum-precision fixnum)
+(flonum-print-precision (procedure (#!optional fixnum) fixnum))
+(flonum-radix fixnum)
+(flonum? (procedure flonum? (*) boolean))
+(flush-output (procedure flush-output (#!optional port) undefined))
+(force-finalizers (procedure force-finalizers () undefined))
+(fp- (procedure fp- (float float) float))
+(fp* (procedure fp* (float float) float))
+(fp/ (procedure fp/ (float float) float))
+(fp+ (procedure fp+ (float float) float))
+(fp< (procedure fp< (float float) boolean))
+(fp<= (procedure fp<= (float float) boolean))
+(fp= (procedure fp= (float float) boolean))
+(fp> (procedure fp> (float float) boolean))
+(fp>= (procedure fp>= (float float) boolean))
+(fpmax (procedure fpmax (float float) float))
+(fpmin (procedure fpmin (float float) float))
+(fpneg (procedure fpneg (float) float))
+(fx- (procedure fx- (fixnum fixnum) fixnum))
+(fx* (procedure fx* (fixnum fixnum) fixnum))
+(fx/ (procedure fx/ (fixnum fixnum) fixnum))
+(fx+ (procedure fx+ (fixnum fixnum) fixnum))
+(fx< (procedure fx< (fixnum fixnum) boolean))
+(fx<= (procedure fx<= (fixnum fixnum) boolean))
+(fx= (procedure fx= (fixnum fixnum) boolean))
+(fx> (procedure fx> (fixnum fixnum) boolean))
+(fx>= (procedure fx>= (fixnum fixnum) boolean))
+(fxand (procedure fxand (fixnum fixnum) fixnum))
+(fxior (procedure fxior (fixnum fixnum) fixnum))
+(fxmax (procedure fxmax (fixnum fixnum) fixnum))
+(fxmin (procedure fxmin (fixnum fixnum) fixnum))
+(fxmod (procedure fxmod (fixnum fixnum) fixnum))
+(fxneg (procedure fxneg (fixnum) fixnum))
+(fxnot (procedure fxnot (fixnum) fixnum))
+(fxshl (procedure fxshl (fixnum fixnum) fixnum))
+(fxshr (procedure fxshr (fixnum fixnum) fixnum))
+(fxxor (procedure fxxor (fixnum fixnum) fixnum))
+(gc (procedure gc (#!optional *) fixnum))
+(gensym (procedure gensym (#!optional *) symbol))
+(get (procedure get (symbol symbol) *))
+(get-call-chain (procedure get-call-chain (#!optional fixnum *) list))
+(get-condition-property (procedure get-condition-property ((struct condition) symbol symbol #!optional *) *))
+(get-environment-variable (procedure get-environment-variable (string) *))
+(get-keyword (procedure get-keyword (symbol list #!optional *) *))
+(get-output-string (procedure get-output-string (port) string))
+(get-properties (procedure get-properties (symbol list) symbol * list))
+(getenv deprecated)
+(getter-with-setter (procedure getter-with-setter (procedure procedure) procedure))
+(implicit-exit-handler (procedure implicit-exit-handler (#!optional procedure) procedure))
+(keyword->string (procedure keyword->string (symbol) string))
+(keyword-style (procedure keyword-style (#!optional *) *))
+(keyword? (procedure keyword? (*) boolean))
+(load-library (procedure load-library (* string) undefined))
+(load-relative (procedure load-relative (string #!optional procedure) undefined))
+(load-verbose (procedure load-verbose (#!optional *) *))
+(machine-byte-order (procedure machine-byte-order () symbol))
+(machine-type (procedure machine-type () symbol))
+(make-blob (procedure make-blob (fixnum) blob))
+(make-composite-condition (procedure make-composite-condition (#!rest (struct condition)) (struct condition)))
+(make-parameter (procedure make-parameter (* #!optional procedure) procedure))
+(make-property-condition (procedure make-property-condition (symbol #!rest *) (struct condition)))
+(maximum-flonum float)
+(memory-statistics (procedure memory-statistics () vector))
+(minimum-flonum float)
+(most-negative-fixnum fixnum)
+(most-positive-fixnum fixnum)
+(on-exit (procedure on-exit ((procedure () . *)) undefined))
+(open-input-string (procedure open-input-string (string #!rest) port))
+(open-output-string (procedure open-output-string (#!rest) port))
+(parentheses-synonyms (procedure parentheses-synonyms (#!optional *) *))
+(port-name (procedure port-name (#!optional port) *))
+(port-position (procedure port-position (#!optional port) fixnum))
+(port? (procedure port? (*) boolean))
+(print (procedure print (#!rest *) undefined))
+(print-call-chain (procedure print-call-chain (#!optional port fixnum * string) undefined))
+(print-error-message (procedure print-error-message (* #!optional port string) undefined))
+(print* (procedure print* (#!rest) undefined))
+(procedure-information (procedure procedure-information (procedure) *))
+(program-name (procedure program-name (#!optional string) string))
+(promise? (procedure promise? (*) boolean))
+(put! (procedure put! (symbol symbol *) undefined))
+(register-feature! (procedure register-feature! (#!rest symbol) undefined))
+(remprop! (procedure remprop! (symbol symbol) undefined))
+(rename-file (procedure rename-file (string string) undefined))
+(repl (procedure repl () undefined))
+(repl-prompt (procedure repl-prompt (#!optional procedure) procedure))
+(repository-path (procedure repository-path (#!optional *) *))
+(require (procedure require (#!rest *) undefined))
+(reset (procedure reset () undefined))
+(reset-handler (procedure reset-handler (#!optional procedure) procedure))
+(return-to-host (procedure return-to-host () . *))
+(reverse-list->string (procedure reverse-list->string (list) string))
+(set-finalizer! (procedure set-finalizer! (* (procedure (*) . *)) undefined))
+(set-gc-report! (procedure set-gc-report! (*) undefined))
+(set-parameterized-read-syntax! (procedure set-parameterized-read-syntax! (char procedure) undefined))
+(set-port-name! (procedure set-port-name! (port string) undefined))
+(set-read-syntax! (procedure set-read-syntax! (char procedure) undefined))
+(set-sharp-read-syntax! (procedure set-sharp-read-syntax! (char procedure) undefined))
+(setter (procedure setter (procedure) procedure))
+(signal (procedure signal (*) . *))
+(signum (procedure signum (number) number))
+(singlestep (procedure singlestep (procedure) . *))
+(software-type (procedure software-type () symbol))
+(software-version (procedure software-version () symbol))
+(string->blob (procedure string->blob (string) blob))
+(string->keyword (procedure string->keyword (string) symbol))
+(string->uninterned-symbol (procedure string->uninterned-symbol (string) symbol))
+(strip-syntax (procedure strip-syntax (*) *))
+(sub1 (procedure sub1 (number) number))
+(symbol-escape (procedure symbol-escape (#!optional *) *))
+(symbol-plist (procedure symbol-plist (symbol) list))
+(syntax-error (procedure syntax-error (#!rest) noreturn))
+(system (procedure system (string) fixnum))
+(unregister-feature! (procedure unregister-feature! (#!rest symbol) undefined))
+(vector-resize (procedure vector-resize (vector fixnum) vector))
+(void (procedure void () undefined))
+(warning (procedure warning (#!rest) . *))
+(with-exception-handler (procedure with-exception-handler (procedure procedure) . *))
+
+;; data-structures
+
+(->string (procedure ->string (*) string))
+(alist-ref (procedure alist-ref (* list #!optional (procedure (* *) *) *) *))
+(alist-update! (procedure alist-update! (* * list #!optional (procedure (* *) *)) *))
+(always? (procedure always? (#!rest) boolean))
+(any? (procedure any? (*) boolean))
+(atom? (procedure atom? (*) boolean))
+(binary-search (procedure binary-search (vector (procedure (*) *)) *))
+(butlast (procedure butlast (pair) list))
+(chop (procedure chop (list fixnum) list))
+(complement (procedure complement (procedure) procedure))
+(compose (procedure compose (#!rest procedure) procedure))
+(compress (procedure compress (list list) list))
+(conc (procedure conc (#!rest) string))
+(conjoin (procedure conjoin (#!rest (procedure (*) *)) (procedure (*) *)))
+(constantly (procedure constantly (#!rest) . *))
+(disjoin (procedure disjoin (#!rest (procedure (*) *)) (procedure (*) *)))
+(each (procedure each (#!rest procedure) procedure))
+(flatten (procedure flatten (pair) list))
+(flip (procedure flip ((procedure (* *) . *)) procedure))
+(identity (procedure identity (*) *))
+(intersperse (procedure intersperse (list *) list))
+(join (procedure join (list list) list))
+(left-section (procedure left-section (procedure #!rest) procedure))
+(list->queue (procedure list->queue (list) (struct queue)))
+(list-of? (procedure list-of? ((procedure (*) *)) (procedure (list) boolean)))
+(make-queue (procedure make-queue () (struct queue)))
+(merge (procedure merge (list list (procedure (* *) *)) list))
+(merge! (procedure merge! (list list (procedure (* *) *)) list))
+(never? (procedure never? (#!rest) boolean))
+(none? (procedure none? (*) boolean))
+(noop (procedure noop (#!rest) *))
+(o (procedure o (#!rest (procedure (*) *)) (procedure (*) *)))
+(project (procedure project (fixnum) procedure))
+(queue->list (procedure queue->list ((struct queue)) list))
+(queue-add! (procedure queue-add! ((struct queue) *) undefined))
+(queue-empty? (procedure queue-empty? ((struct queue)) boolean))
+(queue-first (procedure queue-first ((struct queue)) *))
+(queue-last (procedure queue-last ((struct queue)) *))
+(queue-push-back! (procedure queue-push-back! ((struct queue) *) undefined))
+(queue-push-back-list! (procedure queue-push-back-list! ((struct queue) list) undefined))
+(queue-remove! (procedure queue-remove! ((struct queue)) undefined))
+(queue? (procedure queue? (*) boolean))
+(rassoc (procedure rassoc (* list #!optional (procedure (* *) *)) *))
+(right-section (procedure right-section (procedure #!rest) procedure))
+(reverse-string-append (procedure reverse-string-append (list) string))
+(shuffle (procedure shuffle (list (procedure (fixnum) fixnum)) list))
+(sort (procedure sort ((or list vector) (procedure (* *) *)) (or list vector)))
+(sort! (procedure sort! ((or list vector) (procedure (* *) *)) (or list vector)))
+(sorted? (procedure sorted? ((or list vector) (procedure (* *) *)) boolean))
+(topological-sort (procedure topological-sort (list (procedure (* *) *)) list))
+(string-chomp (procedure string-chomp (string #!optional string) string))
+(string-chop (procedure string-chop (string fixnum) list))
+(string-compare3 (procedure string-compare3 (string string) fixnum))
+(string-compare3-ci (procedure string-compare3-ci (string string) fixnum))
+(string-intersperse (procedure string-intersperse (list #!optional string) string))
+(string-split (procedure string-split (string #!optional string *) list))
+(string-translate (procedure string-translate (string string #!optional string) string))
+(string-translate* (procedure string-translate* (string list) string))
+(substring-ci=? (procedure substring-ci=? (string string #!optional fixnum fixnum fixnum) boolean))
+(substring-index (procedure substring-index (string string #!optional fixnum) *))
+(substring-index-ci (procedure substring-index-ci (string string #!optional fixnum) *))
+(substring=? (procedure substring=? (string string #!optional fixnum fixnum fixnum) boolean))
+(tail? (procedure tail? (* *) boolean))
+
+;; extras
+
+(format (procedure format (string #!rest) *))
+(fprintf (procedure fprintf (port string #!rest) undefined))
+(pp (procedure pp (* #!optional port) undefined))
+(pretty-print (procedure pretty-print (* #!optional port) undefined))
+(pretty-print-width (procedure pretty-print-width (#!optional *) *))
+(printf (procedure printf (string #!rest) undefined))
+(random (procedure random (number) number))
+(random-seed (procedure random-seed (#!optional number) number))
+(randomize (procedure randomize (#!optional number) undefined))
+(read-byte (procedure read-byte (#!optional port) fixnum))
+(read-file (procedure read-file (#!optional (or port string) (procedure (port) *) fixnum) list))
+(read-line (procedure read-line (#!optional port fixnum) *))
+(read-lines (procedure read-lines (#!optional (or port string) fixnum) list))
+(read-string (procedure read-string (#!optional * port) string))
+(read-string! (procedure read-string! (fixnum string #!optional port fixnum) fixnum))
+(read-token (procedure read-token ((procedure (char) *) #!optional port) string))
+(sprintf (procedure sprintf (string #!rest) string))
+(write-byte (procedure write-byte (fixnum #!optional port) undefined))
+(write-line (procedure write-line (string #!optional port) undefined))
+(write-string (procedure write-string (string #!optional * port) undefined))
+
+;; files
+
+(delete-file* (procedure delete-file* (string) boolean))
+(file-copy (procedure file-copy (string string #!optional * fixnum) undefined))
+(file-move (procedure file-move (string string #!optional * fixnum) undefined))
+(make-pathname (procedure make-pathname (* * #!optional string string) string))
+(directory-null? (procedure directory-null? (string) boolean))
+(make-absolute-pathname (procedure make-absolute-pathname (* * #!optional string string) string))
+(create-temporary-file (procedure create-temporary-file (#!optional string) string))
+(decompose-pathname (procedure decompose-pathname (string) * * *))
+(absolute-pathname? (procedure absolute-pathname? (string) boolean))
+(pathname-directory (procedure pathname-directory (string) *))
+(pathname-extension (procedure pathname-extension (string) *))
+(pathname-file (procedure pathname-file (string) *))
+(pathname-replace-directory (procedure pathname-replace-directory (string string) string))
+(pathname-replace-extension (procedure pathname-replace-extension (string string) string))
+(pathname-replace-file (procedure pathname-replace-file (string string) string))
+(pathname-strip-directory (procedure pathname-strip-directory (string) string))
+(pathname-strip-extension (procedure pathname-strip-extension (string) string))
+(normalize-pathname (procedure normalize-pathname (string) string))
+
+;; irregex
+
+(irregex (procedure irregex (#!rest) *))
+(string->irregex (procedure string->irregex (string #!rest) *))
+(sre->irregex (procedure sre->irregex (#!rest) *))
+(string->sre (procedure string->sre (string #!rest) *))
+(irregex? (procedure irregex? (*) boolean))
+(irregex-match-data? (procedure irregex-match-data? (*) boolean))
+(irregex-new-matches (procedure irregex-new-matches (*) *))
+(irregex-reset-matches! (procedure irregex-reset-matches! (*) *))
+(irregex-match-start (procedure irregex-match-start (* #!optional *) *))
+(irregex-match-end (procedure irregex-match-end (* #!optional *) *))
+(irregex-match-substring (procedure irregex-match-substring (* #!optional *) *))
+(irregex-search (procedure irregex-search (* string #!optional fixnum fixnum) *))
+(irregex-search/matches (procedure irregex-search/matches (* string fixnum fixnum *) *))
+(irregex-match (procedure irregex-match (* string) *))
+(irregex-match-string (procedure irregex-match-string (*) *))
+(irregex-replace (procedure irregex-replace (* string #!rest) *))
+(irregex-replace/all (procedure irregex-replace/all (* string #!rest) *))
+(irregex-dfa (procedure irregex-dfa (*) *))
+(irregex-dfa/search (procedure irregex-dfa/search (*) *))
+(irregex-dfa/extract (procedure irregex-dfa/extract (*) *))
+(irregex-nfa (procedure irregex-nfa (*) *))
+(irregex-flags (procedure irregex-flags (*) *))
+(irregex-submatches (procedure irregex-submatches (*) *))
+(irregex-lengths (procedure irregex-lengths (*) *))
+(irregex-names (procedure irregex-names (*) *))
+
+;; lolevel
+
+(address->pointer (procedure address->pointer (fixnum) pointer))
+(align-to-word (procedure align-to-word (*) *))
+(allocate (procedure allocate (fixnum) pointer))
+(block-ref (procedure block-ref (* fixnum) *))
+(block-set! (procedure block-set! (* fixnum *) *))
+(clear-unbound-variable-value! (procedure clear-unbound-variable-value! () undefined))
+(extend-procedure (procedure extend-procedure (procedure *) procedure))
+(extended-procedure? (procedure extended-procedure? (*) boolean))
+(free (procedure free (pointer) *))
+(global-bound? (procedure global-bound? (symbol) boolean))
+(global-make-unbound! (procedure global-make-unbound! (symbol) symbol))
+(global-ref (procedure global-ref (symbol) *))
+(global-set! (procedure global-set! (symbol *) *))
+(invalid-procedure-call-handler (procedure invalid-procedure-call-handler () procedure))
+(locative->object (procedure locative->object (locative) *))
+(locative-ref (procedure locative-ref (locative) *))
+(locative-set! (procedure locative-set! (locative *) *))
+(locative? (procedure locative? (*) boolean))
+(make-locative (procedure make-locative (* #!optional fixnum) locative))
+(make-record-instance (procedure make-record-instance (* #!rest) *))
+(make-weak-locative (procedure make-weak-locative (* #!optional fixnum) locative))
+(move-memory! (procedure move-memory! (* * #!optional fixnum fixnum fixnum) *))
+(mutate-procedure (procedure mutate-procedure (procedure procedure) procedure))
+(null-pointer (procedure null-pointer () pointer))
+(null-pointer? (procedure null-pointer? (pointer) boolean))
+(number-of-bytes (procedure number-of-bytes (*) fixnum))
+(number-of-slots (procedure number-of-slots (*) fixnum))
+(object->pointer (procedure object->pointer (*) *))
+(object-become! (procedure object-become! (list) *))
+(object-copy (procedure object-copy (*) *))
+(object-evict (procedure object-evict (* #!optional (procedure (fixnum) pointer)) *))
+(object-evict-to-location (procedure object-evict-to-location (* pointer #!optional fixnum) * pointer))
+(object-evicted? (procedure object-evicted? (*) boolean))
+(object-release (procedure object-release (* #!optional (procedure (pointer) *)) *))
+(object-size (procedure object-size (*) fixnum))
+(object-unevict (procedure object-unevict (* #!optional *) *))
+(pointer->address (procedure pointer->address (pointer) number))
+(pointer-like? (procedure pointer-like? (*) boolean))
+(pointer->object (procedure pointer->object (pointer) *))
+(pointer-f32-ref (procedure pointer-f32-ref (pointer) number))
+(pointer-f32-set! (procedure pointer-f32-set! (pointer number) undefined))
+(pointer-f64-ref (procedure pointer-f64-ref (pointer) number))
+(pointer-f64-set! (procedure pointer-f64-set! (pointer number) undefined))
+(pointer-offset (procedure pointer-offset (pointer fixnum) pointer))
+(pointer-s16-ref (procedure pointer-s16-ref (pointer) fixnum))
+(pointer-s16-set! (procedure pointer-s16-set! (pointer fixnum) undefined))
+(pointer-s32-ref (procedure pointer-s32-ref (pointer) number))
+(pointer-s32-set! (procedure pointer-s32-set! (pointer number) undefined))
+(pointer-s8-ref (procedure pointer-s8-ref (pointer) fixnum))
+(pointer-s8-set! (procedure pointer-s8-set! (pointer fixnum) undefined))
+(pointer-tag (procedure pointer-tag (pointer) *))
+(pointer-u16-ref (procedure pointer-u16-ref (pointer) fixnum))
+(pointer-u16-set! (procedure pointer-u16-set! (pointer fixnum) undefined))
+(pointer-u32-ref (procedure pointer-u32-ref (pointer) number))
+(pointer-u32-set! (procedure pointer-u32-set! (pointer number) undefined))
+(pointer-u8-ref (procedure pointer-u8-ref (pointer) fixnum))
+(pointer-u8-set! (procedure pointer-u8-set! (pointer fixnum) undefined))
+(pointer=? (procedure pointer=? (pointer pointer) boolean))
+(pointer? (procedure pointer? (*) boolean))
+(procedure-data (procedure procedure-data (procedure) *))
+(record->vector (procedure record->vector (*) vector))
+(record-instance? (procedure record-instance? (*) boolean))
+(record-instance-length (procedure record-instance-length (*) fixnum))
+(record-instance-slot (procedure record-instance-slot (* fixnum) *))
+(record-instance-slot-set! (procedure record-instance-slot-set! (* fixnum *) undefined))
+(record-instance-type (procedure record-instance-type (*) *))
+(set-invalid-procedure-call-handler! (procedure set-invalid-procedure-call-handler! (procedure) undefined))
+(set-procedure-data! (procedure set-procedure-data! (procedure *) undefined))
+(set-unbound-variable-value! (procedure set-unbound-variable-value! (*) undefined))
+(tag-pointer (procedure tag-pointer (pointer *) pointer))
+(tagged-pointer? (procedure tagged-pointer? (*) boolean))
+(unbound-variable-value (procedure unbound-variable-value (#!optional *) undefined))
+(unbound-variable-given-value (procedure unbound-variable-given-value () *))
+(unbound-variable-signals-error? (procedure unbound-variable-signals-error? () boolean))
+(vector-like? (procedure vector-like? (*) boolean))
+
+;; ports
+
+(call-with-input-string (procedure call-with-input-string (string (procedure (port) . *)) . *))
+(call-with-output-string (procedure call-with-output-string ((procedure (port) . *)) string))
+(make-input-port (procedure make-input-port ((procedure () char) (procedure () *) (procedure () . *) #!optional * * *) port))
+(make-output-port (procedure make-output-port ((procedure (string) . *) (procedure () . *) #!optional (procedure () . *)) port))
+(port-for-each (procedure port-for-each ((procedure (*) *) (procedure () . *)) undefined))
+(port-map (procedure port-map ((procedure (*) *) (procedure () . *)) list))
+(port-fold (procedure port-fold ((procedure (* *) *) * (procedure () *)) *))
+(make-broadcast-port (procedure make-broadcast-port (#!rest port) port))
+(make-concatenated-port (procedure make-concatenated-port (port #!rest port) port))
+(with-error-output-to-port (procedure with-error-output-to-port (port (procedure () . *)) . *))
+(with-input-from-port (procedure with-input-from-port (port (procedure () . *)) . *))
+(with-input-from-string (procedure with-input-from-string (string (procedure () . *)) . *))
+(with-output-to-port (procedure with-output-to-port (port (procedure () . *)) . *))
+(with-output-to-string (procedure with-output-to-string ((procedure () . *)) . *))
+(with-error-output-to-port (procedure with-error-output-to-port (port (procedure () . *)) . *))
+
+;; posix
+
+(_exit (procedure _exit (fixnum) noreturn))
+(call-with-input-pipe (procedure call-with-input-pipe (string (procedure (port) . *) #!optional symbol) . *))
+(call-with-output-pipe (procedure call-with-output-pipe (string (procedure (port) . *) #!optional symbol) . *))
+(canonical-path deprecated)
+(change-directory (procedure change-directory (string) undefined))
+(change-file-mode (procedure change-file-mode (string fixnum) undefined))
+(change-file-owner (procedure change-file-owner (string fixnum fixnum) undefined))
+(close-input-pipe (procedure close-input-pipe (port) fixnum))
+(close-output-pipe (procedure close-output-pipe (port) fixnum))
+(create-directory (procedure create-directory (string #!optional *) undefined))
+(create-fifo (procedure create-fifo (string #!optional fixnum) undefined))
+(create-pipe (procedure create-pipe () fixnum fixnum))
+(create-session (procedure create-session () fixnum))
+(create-symbolic-link (procedure create-symbolic-link (string string) undefined))
+(current-directory (procedure current-directory (#!optional string) string))
+(current-effective-group-id (procedure current-effective-group-id () fixnum))
+(current-effective-user-id (procedure current-effective-user-id () fixnum))
+(current-effective-user-name (procedure current-effective-user-name () string))
+(current-environment deprecated)
+(get-environment-variables (procedure get-environment-variables () list))
+(current-group-id (procedure current-group-id () fixnum))
+(current-process-id (procedure current-process-id () fixnum))
+(current-user-id (procedure current-user-id () fixnum))
+(current-user-name (procedure current-user-name () string))
+(delete-directory (procedure delete-directory (string) undefined))
+(directory (procedure directory (string #!optional *) list))
+(directory? (procedure directory? (string) boolean))
+(duplicate-fileno (procedure duplicate-fileno (fixnum #!optional fixnum) fixnum))
+(errno/2big fixnum)
+(errno/acces fixnum)
+(errno/again fixnum)
+(errno/badf fixnum)
+(errno/busy fixnum)
+(errno/child fixnum)
+(errno/deadlk fixnum)
+(errno/dom fixnum)
+(errno/exist fixnum)
+(errno/fault fixnum)
+(errno/fbig fixnum)
+(errno/ilseq fixnum)
+(errno/intr fixnum)
+(errno/inval fixnum)
+(errno/io fixnum)
+(errno/isdir fixnum)
+(errno/mfile fixnum)
+(errno/mlink fixnum)
+(errno/nametoolong fixnum)
+(errno/nfile fixnum)
+(errno/nodev fixnum)
+(errno/noent fixnum)
+(errno/noexec fixnum)
+(errno/nolck fixnum)
+(errno/nomem fixnum)
+(errno/nospc fixnum)
+(errno/nosys fixnum)
+(errno/notdir fixnum)
+(errno/notempty fixnum)
+(errno/notty fixnum)
+(errno/nxio fixnum)
+(errno/perm fixnum)
+(errno/pipe fixnum)
+(errno/range fixnum)
+(errno/rofs fixnum)
+(errno/spipe fixnum)
+(errno/srch fixnum)
+(errno/wouldblock fixnum)
+(errno/xdev fixnum)
+(fcntl/dupfd fixnum)
+(fcntl/getfd fixnum)
+(fcntl/getfl fixnum)
+(fcntl/setfd fixnum)
+(fcntl/setfl fixnum)
+(fifo? (procedure fifo? (string) boolean))
+(file-access-time (procedure file-access-time (string) number))
+(file-change-time (procedure file-change-time (string) number))
+(file-close (procedure file-close (fixnum) undefined))
+(file-control (procedure file-control (fixnum fixnum #!optional fixnum) fixnum))
+(file-execute-access? (procedure file-execute-access? (string) boolean))
+(file-link (procedure file-link (string string) undefined))
+(file-lock (procedure file-lock (string fixnum #!optional *) (struct lock)))
+(file-lock/blocking (procedure file-lock/blocking (string fixnum #!optional *) (struct lock)))
+(file-mkstemp (procedure file-mkstemp (string) fixnum string))
+(file-modification-time (procedure file-modification-time (string) number))
+(file-open (procedure file-open (string fixnum #!optional fixnum) fixnum))
+(file-owner (procedure file-owner (string) fixnum))
+(file-permissions (procedure file-permissions (string) fixnum))
+(file-position (procedure file-position ((or port fixnum)) fixnum))
+(file-read (procedure file-read (fixnum fixnum #!optional *) list))
+(file-read-access? (procedure file-read-access? (string) boolean))
+(file-select (procedure file-select (list list #!optional fixnum) list list))
+(file-size (procedure file-size (string) fixnum))
+(file-stat (procedure file-stat (string #!optional *) vector))
+(file-test-lock (procedure file-test-lock (port fixnum #!optional *) boolean))
+(file-truncate (procedure file-truncate (string fixnum) undefined))
+(file-unlock (procedure file-unlock ((struct lock)) undefined))
+(file-write (procedure file-write (fixnum * #!optional fixnum) fixnum))
+(file-write-access? (procedure file-write-access? (string) boolean))
+(fileno/stderr fixnum)
+(fileno/stdin fixnum)
+(fileno/stdout fixnum)
+(find-files (procedure find-files (string * #!optional (procedure (string string) *) * fixnum) list))
+(get-groups (procedure get-groups () list))
+(get-host-name (procedure get-host-name () string))
+(glob (procedure glob (#!rest string) list))
+(group-information (procedure group-information (fixnum #!optional *) *))
+(initialize-groups (procedure initialize-groups (fixnum fixnum) undefined))
+(local-time->seconds (procedure local-time->seconds (vector) number))
+(local-timezone-abbreviation (procedure local-timezone-abbreviation () string))
+(map-file-to-memory (procedure map-file-to-memory (* fixnum fixnum fixnum fixnum #!optional fixnum) (struct mmap)))
+(map/anonymous fixnum)
+(map/file fixnum)
+(map/fixed fixnum)
+(map/private fixnum)
+(map/shared fixnum)
+(memory-mapped-file-pointer (procedure memory-mapped-file-pointer ((struct mmap)) pointer))
+(memory-mapped-file? (procedure memory-mapped-file? (*) boolean))
+(open-input-file* (procedure open-input-file* (fixnum #!optional symbol) port))
+(open-input-pipe (procedure open-input-pipe (string #!optional symbol) port))
+(open-output-file* (procedure open-output-file* (fixnum #!optional symbol) port))
+(open-output-pipe (procedure open-output-pipe (string #!optional symbol) port))
+(open/append fixnum)
+(open/binary fixnum)
+(open/creat fixnum)
+(open/excl fixnum)
+(open/fsync fixnum)
+(open/noctty fixnum)
+(open/nonblock fixnum)
+(open/rdonly fixnum)
+(open/rdwr fixnum)
+(open/read fixnum)
+(open/sync fixnum)
+(open/text fixnum)
+(open/trunc fixnum)
+(open/write fixnum)
+(open/wronly fixnum)
+(parent-process-id (procedure parent-process-id () fixnum))
+(perm/irgrp fixnum)
+(perm/iroth fixnum)
+(perm/irusr fixnum)
+(perm/irwxg fixnum)
+(perm/irwxo fixnum)
+(perm/irwxu fixnum)
+(perm/isgid fixnum)
+(perm/isuid fixnum)
+(perm/isvtx fixnum)
+(perm/iwgrp fixnum)
+(perm/iwoth fixnum)
+(perm/iwusr fixnum)
+(perm/ixgrp fixnum)
+(perm/ixoth fixnum)
+(perm/ixusr fixnum)
+(pipe/buf fixnum)
+(port->fileno (procedure port->fileno (port) fixnum))
+(process (procedure process (string #!optional list list) port port fixnum))
+(process* (procedure process* (string #!optional list list) port port fixnum *))
+(process-execute (procedure process-execute (string #!optional list list) noreturn))
+(process-fork (procedure process-fork (#!optional (procedure () . *)) fixnum))
+(process-group-id (procedure process-group-id () fixnum))
+(process-run (procedure process-run (string #!optional list) fixnum))
+(process-signal (procedure process-signal (fixnum #!optional fixnum) undefined))
+(process-wait (procedure process-wait (fixnum #!optional *) fixnum fixnum fixnum))
+(prot/exec fixnum)
+(prot/none fixnum)
+(prot/read fixnum)
+(prot/write fixnum)
+(read-symbolic-link (procedure read-symbolic-link (string) string))
+(regular-file? (procedure regular-file? (string) boolean))
+(seconds->local-time (procedure seconds->local-time (number) vector))
+(seconds->string (procedure seconds->string (number) string))
+(seconds->utc-time (procedure seconds->utc-time (number) vector))
+(seek/cur fixnum)
+(seek/end fixnum)
+(seek/set fixnum)
+(set-alarm! (procedure set-alarm! (number) number))
+(set-buffering-mode! (procedure set-buffering-mode! (port symbol #!optional fixnum) undefined))
+(set-file-position! (procedure set-file-position! ((or port fixnum) fixnum #!optional fixnum) undefined))
+(set-groups! (procedure set-groups! (list) undefined))
+(set-root-directory! (procedure set-root-directory! (string) undefined))
+(set-signal-handler! (procedure set-signal-handler! (fixnum (procedure (fixnum) . *)) undefined))
+(set-signal-mask! (procedure set-signal-mask! (list) undefined))
+(setenv (procedure setenv (string string) undefined))
+(signal-handler (procedure signal-handler (fixnum) (procedure (fixnum) . *)))
+(signal-mask (procedure signal-mask () fixnum))
+(signal-mask! (procedure signal-mask! (fixnum) undefined))
+(signal-masked? (procedure signal-masked? (fixnum) boolean))
+(signal-unmask! (procedure signal-unmask! (fixnum) undefined))
+(signal/abrt fixnum)
+(signal/alrm fixnum)
+(signal/chld fixnum)
+(signal/cont fixnum)
+(signal/fpe fixnum)
+(signal/hup fixnum)
+(signal/ill fixnum)
+(signal/int fixnum)
+(signal/io fixnum)
+(signal/kill fixnum)
+(signal/pipe fixnum)
+(signal/prof fixnum)
+(signal/quit fixnum)
+(signal/segv fixnum)
+(signal/stop fixnum)
+(signal/term fixnum)
+(signal/trap fixnum)
+(signal/tstp fixnum)
+(signal/urg fixnum)
+(signal/usr1 fixnum)
+(signal/usr2 fixnum)
+(signal/vtalrm fixnum)
+(signal/winch fixnum)
+(signal/xcpu fixnum)
+(signal/xfsz fixnum)
+(signals-list list)
+(sleep (procedure sleep (fixnum) fixnum))
+(block-device? (procedure block-device? (string) boolean))
+(stat-block-device? deprecated)
+(character-device? (procedure character-device? (string) boolean))
+(stat-char-device? deprecated)
+(stat-fifo? deprecated)
+(stat-directory? deprecated)
+(fifo? (procedure fifo? (string) boolean))
+(stat-regular? deprecated)
+(stat-socket? deprecated)
+(socket? (procedure socket? (string) boolean))
+(stat-symlink? deprecated)
+(string->time (procedure string->time (string #!optional string) vector))
+(symbolic-link? (procedure symbolic-link? (string) boolean))
+(system-information (procedure system-information () list))
+(terminal-name (procedure terminal-name (port) string))
+(terminal-port? (procedure terminal-port? (port) boolean))
+(terminal-size (procedure terminal-size (port) fixnum fixnum))
+(time->string (procedure time->string (vector #!optional string) string))
+(unmap-file-from-memory (procedure unmap-file-from-memory ((struct mmap) #!optional fixnum) undefined))
+(unsetenv (procedure unsetenv (string) undefined))
+(user-information (procedure user-information (fixnum #!optional *) *))
+(utc-time->seconds (procedure utc-time->seconds (vector) number))
+(with-input-from-pipe (procedure with-input-from-pipe (string (procedure () . *) #!optional symbol) . *))
+(with-output-to-pipe (procedure with-output-to-pipe (string (procedure () . *) #!optional symbol) . *))
+
+;; regex
+
+(glob->regexp (procedure glob->regexp (string) string))
+(glob? (procedure glob? (string) boolean))
+(grep (procedure grep (* list) list))
+(regexp (procedure regexp (* #!optional * * *) (struct regexp)))
+(regexp-escape (procedure regexp-escape (string) string))
+(regexp? (procedure regexp? (*) boolean))
+(string-match (procedure string-match (* string) *))
+(string-match-positions (procedure string-match-positions (* string) *))
+(string-search (procedure string-search (* string #!optional fixnum fixnum) *))
+(string-search-positions (procedure string-search-positions (* string #!optional fixnum fixnum) *))
+(string-split-fields (procedure string-split-fields (* string #!optional * fixnum) list))
+(string-substitute (procedure string-substitute (* string string #!optional *) string))
+(string-substitute* (procedure string-substitute* (string list #!optional *) string))
+
+;; srfi-1
+
+(alist-cons (procedure alist-cons (* * *) list))
+(alist-copy (procedure alist-copy (list) list))
+(alist-delete (procedure alist-delete (* list #!optional (procedure (* *) *)) list))
+(alist-delete! (procedure alist-delete! (* list #!optional (procedure (* *) *)) undefined))
+(any (procedure any ((procedure (* #!rest) *) list #!rest list) *))
+(append! (procedure append! (#!rest list) list))
+(append-map (procedure append-map ((procedure (#!rest) *) list #!rest list) pair))
+(append-map! (procedure append-map! ((procedure (#!rest) *) list #!rest list) pair))
+(append-reverse (procedure append-reverse (list list) list))
+(append-reverse! (procedure append-reverse! (list list) list))
+(break (procedure break ((procedure (*) *) list) list list))
+(break! (procedure break! ((procedure (*) *) list) list list))
+(car+cdr (procedure car+cdr (pair) * *))
+(circular-list (procedure circular-list (#!rest) list))
+(circular-list? (procedure circular-list? (*) boolean))
+(concatenate (procedure concatenate (list) list))
+(concatenate! (procedure concatenate! (list) list))
+(cons* (procedure cons* (* #!rest) pair))
+(count (procedure count ((procedure (*) *) list #!rest list) fixnum))
+(delete (procedure delete (* list #!optional (procedure (* *) *)) list))
+(delete! (procedure delete! (* list #!optional (procedure (* *) *)) list))
+(delete-duplicates (procedure delete-duplicates (list #!optional (procedure (* *) *)) list))
+(delete-duplicates! (procedure delete-duplicates! (list #!optional (procedure (* *) *)) list))
+(dotted-list? (procedure dotted-list? (*) boolean))
+(drop (procedure drop (list fixnum) list))
+(drop-right (procedure drop-right (list fixnum) list))
+(drop-right! (procedure drop-right! (list fixnum) list))
+(drop-while (procedure drop-while ((procedure (*) *) list) list))
+(eighth (procedure eighth (pair) *))
+(every (procedure every ((procedure (* #!rest) *) list #!rest list) *))
+(fifth (procedure fifth (pair) *))
+(filter (procedure filter ((procedure (*) *) list) list))
+(filter! (procedure filter! ((procedure (*) *) list) list))
+(filter-map (procedure filter-map ((procedure (*) *) list #!rest list) list))
+(find (procedure find ((procedure (*) *) list) *))
+(find-tail (procedure find-tail ((procedure (*) *) list) *))
+(first (procedure first (pair) *))
+(fold (procedure fold ((procedure (* #!rest) *) * #!rest list) *))
+(fold-right (procedure fold-right ((procedure (* #!rest) *) * #!rest list) *))
+(fourth (procedure fourth (pair) *))
+(iota (procedure iota (fixnum #!optional fixnum fixnum) list))
+(last (procedure last (pair) *))
+(last-pair (procedure last-pair (pair) *))
+(length+ (procedure length+ (list) *))
+(list-copy (procedure list-copy (list) list))
+(list-index (procedure list-index ((procedure (* #!rest) *) list #!rest list) *))
+(list-tabulate (procedure list-tabulate (fixnum (procedure (fixnum) *)) list))
+(list= (procedure list= (#!rest list) boolean))
+(lset-adjoin (procedure lset-adjoin ((procedure (* *) *) list #!rest) list))
+(lset-diff+intersection (procedure lset-diff+intersection ((procedure (* *) *) list #!rest list) list))
+(lset-diff+intersection! (procedure lset-diff+intersection! ((procedure (* *) *) list #!rest list) list))
+(lset-difference (procedure lset-difference ((procedure (* *) *) list #!rest list) list))
+(lset-difference! (procedure lset-difference! ((procedure (* *) *) list #!rest list) list))
+(lset-intersection (procedure lset-intersection ((procedure (* *) *) list #!rest list) list))
+(lset-intersection! (procedure lset-intersection! ((procedure (* *) *) list #!rest list) list))
+(lset-union (procedure lset-union ((procedure (* *) *) list #!rest list) list))
+(lset-union! (procedure lset-union! ((procedure (* *) *) list #!rest list) list))
+(lset-xor (procedure lset-xor ((procedure (* *) *) list #!rest list) list))
+(lset-xor! (procedure lset-xor! ((procedure (* *) *) list #!rest list) list))
+(lset<= (procedure lset<= ((procedure (* *) *) list #!rest list) boolean))
+(lset= (procedure lset= ((procedure (* *) *) list #!rest list) boolean))
+(make-list (procedure make-list (fixnum #!optional *) list))
+(map! (procedure map! ((procedure (*) *) list #!rest list) list))
+(map-in-order (procedure map-in-order ((procedure (*) *) list #!rest list) list))
+(ninth (procedure ninth (pair) *))
+(not-pair? (procedure not-pair? (*) boolean))
+(null-list? (procedure null-list? (list) boolean))
+(pair-fold (procedure pair-fold (procedure * list #!rest list) *))
+(pair-fold-right (procedure pair-fold-right (procedure * list #!rest list) *))
+(pair-for-each (procedure pair-for-each ((procedure (#!rest) . *) list #!rest list) undefined))
+(partition (procedure partition ((procedure (*) *) list) list list))
+(partition! (procedure partition! ((procedure (*) *) list) list list))
+(proper-list? (procedure proper-list? (*) boolean))
+(reduce (procedure reduce ((procedure (* *) *) * list) *))
+(reduce-right (procedure reduce-right ((procedure (* *) *) * list) *))
+(remove (procedure remove ((procedure (*) *) list) list))
+(remove! (procedure remove! ((procedure (*) *) list) list))
+(reverse! (procedure reverse! (list) list))
+(second (procedure second (pair) *))
+(seventh (procedure seventh (pair) *))
+(sixth (procedure sixth (pair) *))
+(span (procedure span ((procedure (*) *) list) list list))
+(span! (procedure span! ((procedure (*) *) list) list list))
+(split-at (procedure split-at (list fixnum) list list))
+(split-at! (procedure split-at! (list fixnum) list list))
+(take (procedure take (list fixnum) list))
+(take! (procedure take! (list fixnum) list))
+(take-right (procedure take-right (list fixnum) list))
+(take-while (procedure take-while ((procedure (*) *) list) list))
+(take-while! (procedure take-while! ((procedure (*) *) list) list))
+(tenth (procedure tenth (pair) *))
+(third (procedure third (pair) *))
+(unfold (procedure unfold ((procedure (*) *) (procedure (*) *) (procedure (*) *) * #!optional (procedure (*) *)) *))
+(unfold-right (procedure unfold-right ((procedure (*) *) (procedure (*) *) (procedure (*) *) * #!optional (procedure (*) *)) *))
+(unzip1 (procedure unzip1 (list) list))
+(unzip2 (procedure unzip2 (list) list list))
+(unzip3 (procedure unzip3 (list) list list list))
+(unzip4 (procedure unzip4 (list) list list list list))
+(unzip5 (procedure unzip5 (list) list list list list list))
+(xcons (procedure xcons (* *) pair))
+(zip (procedure zip (list #!rest list) list))
+
+;; srfi-13
+
+(check-substring-spec (procedure check-substring-spec (* string fixnum fixnum) undefined))
+(kmp-step (procedure kmp-step (string vector char fixnum (procedure (char char) *) fixnum) fixnum))
+(make-kmp-restart-vector (procedure make-kmp-restart-vector (string #!optional (procedure (* *) *) fixnum fixnum) vector))
+(string->list (procedure string->list (string) list))
+(string-any (procedure string-any (* string #!optional fixnum fixnum) boolean))
+(string-append/shared (procedure string-append/shared (#!rest string) string))
+(string-ci< (procedure string-ci< (string string #!optional fixnum fixnum) boolean))
+(string-ci<= (procedure string-ci<= (string string #!optional fixnum fixnum) boolean))
+(string-ci<> (procedure string-ci<> (string string #!optional fixnum fixnum) boolean))
+(string-ci= (procedure string-ci= (string string #!optional fixnum fixnum) boolean))
+(string-ci> (procedure string-ci> (string string #!optional fixnum fixnum) boolean))
+(string-ci>= (procedure string-ci>= (string string #!optional fixnum fixnum) boolean))
+(string-compare (procedure string-compare (string string (procedure (fixnum) *) (procedure (fixnum) *) (procedure (fixnum) *) #!optional fixnum fixnum fixnum fixnum) *))
+(string-compare-ci (procedure string-compare (string string (procedure (fixnum) *) (procedure (fixnum) *) (procedure (fixnum) *) #!optional fixnum fixnum fixnum fixnum) *))
+(string-concatenate (procedure string-concatenate (list) string))
+(string-concatenate-reverse (procedure string-concatenate-reverse (list) string))
+(string-concatenate-reverse/shared (procedure string-concatenate-reverse/shared (list) string))
+(string-concatenate/shared (procedure string-concatenate/shared (list) string))
+(string-contains (procedure string-contains (string string #!optional fixnum fixnum fixnum fixnum) *))
+(string-contains-ci (procedure string-contains-ci (string string #!optional fixnum fixnum fixnum fixnum) *))
+(string-copy (procedure string-copy (string #!optional fixnum fixnum) string))
+(string-copy! (procedure string-copy! (string fixnum string #!optional fixnum fixnum) undefined))
+(string-count (procedure string-count (string * #!optional fixnum fixnum) fixnum))
+(string-delete (procedure string-delete (* string #!optional fixnum fixnum) string))
+(string-downcase (procedure string-downcase (string #!optional fixnum fixnum) string))
+(string-downcase! (procedure string-downcase! (string #!optional fixnum fixnum) string))
+(string-drop (procedure string-drop (string fixnum) string))
+(string-drop-right (procedure string-drop-right (string fixnum) string))
+(string-every (procedure string-every (* string #!optional fixnum fixnum) boolean))
+(string-fill! (procedure string-fill! (string char) string))
+(string-filter (procedure string-filter (* string #!optional fixnum fixnum) string))
+(string-fold (procedure string-fold ((procedure (char *) *) * string #!optional fixnum fixnum) *))
+(string-fold-right (procedure string-fold-right ((procedure (char *) *) * string #!optional fixnum fixnum) *))
+(string-for-each (procedure string-for-each ((procedure (char) . *) string #!optional fixnum fixnum) undefined))
+(string-for-each-index (procedure string-for-each-index ((procedure (fixnum) . *) string #!optional fixnum fixnum) undefined))
+(string-index (procedure string-index (string * #!optional fixnum fixnum) *))
+(string-index-right (procedure string-index-right (string * #!optional fixnum fixnum) *))
+(string-join (procedure string-join (list #!optional string symbol) string))
+(string-kmp-partial-search (procedure string-kmp-partial-search (string vector string fixnum #!optional (procedure (char char) *) fixnum fixnum fixnum) fixnum))
+(string-map (procedure string-map ((procedure (char) char) string #!optional fixnum fixnum) string))
+(string-map! (procedure string-map! ((procedure (char) char) string #!optional fixnum fixnum) string))
+(string-null? (procedure string-null? (string) boolean))
+(string-pad (procedure string-pad (string fixnum #!optional char fixnum fixnum) string))
+(string-pad-right (procedure string-pad-right (string fixnum #!optional char fixnum fixnum) string))
+(string-parse-final-start+end (procedure string-parse-final-start+end (procedure string #!rest) . *))
+(string-parse-start+end (procedure string-parse-start+end (procedure string #!rest) . *))
+(string-prefix-ci? (procedure string-prefix-ci? (string string #!optional fixnum fixnum fixnum fixnum) boolean))
+(string-prefix-length (procedure string-prefix-length (string string #!optional fixnum fixnum fixnum fixnum) fixnum))
+(string-prefix-length-ci (procedure string-prefix-length-ci (string string #!optional fixnum fixnum fixnum fixnum) fixnum))
+(string-prefix? (procedure string-prefix? (string string #!optional fixnum fixnum fixnum fixnum) boolean))
+(string-replace (procedure string-replace (string string fixnum fixnum #!optional fixnum fixnum) string))
+(string-reverse (procedure string-reverse (string #!optional fixnum fixnum) string))
+(string-reverse! (procedure string-reverse! (string #!optional fixnum fixnum) string))
+(string-skip (procedure string-skip (string * #!optional fixnum fixnum) fixnum))
+(string-skip-right (procedure string-skip-right (string * #!optional fixnum fixnum) fixnum))
+(string-suffix-ci? (procedure string-suffix-ci? (string string #!optional fixnum fixnum fixnum fixnum) boolean))
+(string-suffix-length (procedure string-suffix-length (string string #!optional fixnum fixnum fixnum fixnum) fixnum))
+(string-suffix-length-ci (procedure string-suffix-length-ci (string string #!optional fixnum fixnum fixnum fixnum) fixnum))
+(string-suffix? (procedure string-suffix? (string string #!optional fixnum fixnum fixnum fixnum) boolean))
+(string-tabulate (procedure string-tabulate ((procedure (fixnum) char) fixnum) string))
+(string-take (procedure string-take (string fixnum) string))
+(string-take-right (procedure string-take-right (string fixnum) string))
+(string-titlecase (procedure string-titlecase (string #!optional fixnum fixnum) string))
+(string-titlecase! (procedure string-titlecase! (string #!optional fixnum fixnum) string))
+(string-tokenize (procedure string-tokenize (string #!optional * fixnum fixnum) list))
+(string-trim (procedure string-trim (string #!optional * fixnum fixnum) string))
+(string-trim-both (procedure string-trim-both (string #!optional * fixnum fixnum) string))
+(string-trim-right (procedure string-trim-right (string #!optional * fixnum fixnum) string))
+(string-unfold (procedure string-unfold (procedure procedure procedure * #!optional * procedure) string))
+(string-unfold-right (procedure string-unfold-right (procedure procedure procedure * #!optional * procedure) string))
+(string-upcase (procedure string-upcase (string #!optional fixnum fixnum) string))
+(string-upcase! (procedure string-upcase! (string #!optional fixnum fixnum) string))
+(string-xcopy! (procedure string-xcopy! (string string string fixnum #!optional fixnum fixnum fixnum) string))
+(string< (procedure string< (string string #!optional fixnum fixnum fixnum fixnum) boolean))
+(string<= (procedure string<= (string string #!optional fixnum fixnum fixnum fixnum) boolean))
+(string<> (procedure string<> (string string #!optional fixnum fixnum fixnum fixnum) boolean))
+(string= (procedure string= (string string #!optional fixnum fixnum fixnum fixnum) boolean))
+(string> (procedure string> (string string #!optional fixnum fixnum fixnum fixnum) boolean))
+(string>= (procedure string>= (string string #!optional fixnum fixnum fixnum fixnum) boolean))
+(substring-spec-ok? (procedure substring-spec-ok? (string fixnum fixnum) boolean))
+(substring/shared (procedure substring/shared (string fixnum #!optional fixnum) string))
+(xsubstring (procedure xsubstring (string fixnum #!optional fixnum fixnum fixnum) string))
+
+;; srfi-14
+
+(->char-set (procedure ->char-set (*) (struct char-set)))
+(char-set (procedure char-set (#!rest char) (struct char-set)))
+(char-set->list (procedure char-set->list ((struct char-set)) list))
+(char-set->string (procedure char-set->string ((struct char-set)) string))
+(char-set-adjoin (procedure char-set-adjoin ((struct char-set) #!rest char) (struct char-set)))
+(char-set-adjoin! (procedure char-set-adjoin! ((struct char-set) #!rest char) (struct char-set)))
+(char-set-any (procedure char-set-any ((procedure (char) *) (struct char-set)) *))
+(char-set-complement (procedure char-set-complement ((struct char-set)) (struct char-set)))
+(char-set-complement! (procedure char-set-complement! ((struct char-set)) (struct char-set)))
+(char-set-contains? (procedure char-set-contains? ((struct char-set) char) boolean))
+(char-set-copy (procedure char-set-copy ((struct char-set)) (struct char-set)))
+(char-set-count (procedure char-set-count ((procedure (char) *) (struct char-set)) fixnum))
+(char-set-cursor (procedure char-set-cursor ((struct char-set)) fixnum))
+(char-set-cursor-next (procedure char-set-cursor-next ((struct char-set) fixnum) fixnum))
+(char-set-delete (procedure char-set-delete ((struct char-set) #!rest char) (struct char-set)))
+(char-set-delete! (procedure char-set-delete! ((struct char-set) #!rest char) (struct char-set)))
+(char-set-diff+intersection (procedure char-set-diff+intersection ((struct char-set) #!rest (struct char-set)) (struct char-set) (struct char-set)))
+(char-set-diff+intersection! (procedure char-set-diff+intersection! ((struct char-set) #!rest (struct char-set)) (struct char-set) (struct char-set)))
+(char-set-difference (procedure char-set-difference ((struct char-set) #!rest (struct char-set)) (struct char-set)))
+(char-set-difference! (procedure char-set-difference! ((struct char-set) #!rest (struct char-set)) (struct char-set)))
+(char-set-every (procedure char-set-every ((procedure (char) *) (struct char-set)) boolean))
+(char-set-filter (procedure char-set-filter ((procedure (char) *) (struct char-set) #!optional (struct char-set)) (struct char-set)))
+(char-set-filter! (procedure char-set-filter! ((procedure (char) *) (struct char-set) #!optional (struct char-set)) (struct char-set)))
+(char-set-fold (procedure char-set-fold ((procedure (char *) *) * (struct char-set)) *))
+(char-set-for-each (procedure char-set-for-each ((procedure (char) . *) (struct char-set)) undefined))
+(char-set-hash (procedure char-set-hash ((struct char-set) #!optional number) number))
+(char-set-intersection (procedure char-set-intersection (#!rest (struct char-set)) (struct char-set)))
+(char-set-intersection! (procedure char-set-intersection! (#!rest (struct char-set)) (struct char-set)))
+(char-set-map (procedure char-set-map ((procedure (char) char) (struct char-set)) (struct char-set)))
+(char-set-ref (procedure char-set-ref ((struct char-set) fixnum) char))
+(char-set-size (procedure char-set-size ((struct char-set)) fixnum))
+(char-set-unfold (procedure char-set-unfold (procedure procedure procedure * #!optional (struct char-set)) (struct char-set)))
+(char-set-unfold! (procedure char-set-unfold! (procedure procedure procedure * (struct char-set)) (struct char-set)))
+(char-set-union (procedure char-set-union (#!rest (struct char-set)) (struct char-set)))
+(char-set-union! (procedure char-set-union! (#!rest (struct char-set)) (struct char-set)))
+(char-set-xor (procedure char-set-xor (#!rest (struct char-set)) (struct char-set)))
+(char-set-xor! (procedure char-set-xor! (#!rest (struct char-set)) (struct char-set)))
+(char-set:ascii (struct char-set))
+(char-set:blank (struct char-set))
+(char-set:digit (struct char-set))
+(char-set:empty (struct char-set))
+(char-set:full (struct char-set))
+(char-set:graphic (struct char-set))
+(char-set:hex-digit (struct char-set))
+(char-set:iso-control (struct char-set))
+(char-set:letter (struct char-set))
+(char-set:letter+digit (struct char-set))
+(char-set:lower-case (struct char-set))
+(char-set:printing (struct char-set))
+(char-set:punctuation (struct char-set))
+(char-set:symbol (struct char-set))
+(char-set:title-case (struct char-set))
+(char-set:upper-case (struct char-set))
+(char-set:whitespace (struct char-set))
+(char-set<= (procedure char-set<= (#!rest (struct char-set)) boolean))
+(char-set= (procedure char-set= (#!rest (struct char-set)) boolean))
+(char-set? (procedure char-set? (*) boolean))
+(end-of-char-set? (procedure end-of-char-set? (fixnum) boolean))
+(list->char-set (procedure list->char-set (list #!optional (struct char-set)) (struct char-set)))
+(list->char-set! (procedure list->char-set! (list #!optional (struct char-set)) (struct char-set)))
+(string->char-set (procedure string->char-set (string #!optional (struct char-set)) (struct char-set)))
+(string->char-set! (procedure string->char-set! (string #!optional (struct char-set)) (struct char-set)))
+(ucs-range->char-set (procedure ucs-range->char-set (fixnum fixnum #!optional * (struct char-set)) (struct char-set)))
+(ucs-range->char-set! (procedure ucs-range->char-set! (fixnum fixnum #!optional * (struct char-set)) (struct char-set)))
+
+;; srfi-18
+
+(abandoned-mutex-exception? (procedure abandoned-mutex-exception? (*) boolean))
+(condition-variable-broadcast! (procedure condition-variable-broadcast! ((struct condition-variable)) undefined))
+(condition-variable-signal! (procedure condition-variable-signal! ((struct condition-variable)) undefined))
+(condition-variable-specific (procedure condition-variable-specific ((struct condition-vasriable)) *))
+(condition-variable-specific-set! (procedure condition-variable-specific-set! ((struct condition-variable) *) undefined))
+(condition-variable? (procedure condition-variable? (*) boolean))
+(current-thread (procedure current-thread () (struct thread)))
+(current-time (procedure current-time () number))
+(join-timeout-exception? (procedure join-timeout-exception? (*) boolean))
+(make-condition-variable (procedure make-condition-variable (#!optional *) (struct condition-variable)))
+(make-mutex (procedure make-mutex (#!optional *) (struct mutex)))
+(make-thread (procedure make-thread ((procedure () . *) #!optional *) (struct thread)))
+(milliseconds->time (procedure milliseconds->time (fixnum) (struct time)))
+(mutex-lock! (procedure mutex-lock! ((struct mutex) #!optional * (struct thread)) boolean))
+(mutex-name (procedure mutex-name ((struct mutex)) *))
+(mutex-specific (procedure mutex-specific ((struct mutex)) *))
+(mutex-specific-set! (procedure mutex-specific-set! ((struct mutex) *) undefined))
+(mutex-state (procedure mutex-state ((struct mutex)) symbol))
+(mutex-unlock! (procedure mutex-unlock! ((struct mutex) #!optional (struct condition-variable) *) undefined))
+(mutex? (procedure mutex? (*) boolean))
+(raise (procedure raise (*) noreturn))
+(seconds->time (procedure seconds->time (number) (struct time)))
+(terminated-thread-exception? (procedure terminated-thread-exception? (*) boolean))
+(thread-join! (procedure thread-join! ((struct thread) #!optional *) *))
+(thread-name (procedure thread-name ((struct thread)) *))
+(thread-quantum (procedure thread-quantum ((struct thread)) fixnum))
+(thread-quantum-set! (procedure thread-quantum-set! ((struct thread) fixnum) undefined))
+(thread-resume! (procedure thread-resume! ((struct thread)) undefined))
+(thread-signal! (procedure thread-signal! ((struct thread) *) undefined))
+(thread-sleep! (procedure thread-sleep! (*) undefined))
+(thread-specific (procedure thread-specific ((struct thread)) *))
+(thread-specific-set! (procedure thread-specific-set! ((struct thread) *) undefined))
+(thread-start! (procedure thread-start! ((or (struct thread) (procedure () . *))) (struct thread)))
+(thread-state (procedure thread-state ((struct thread)) symbol))
+(thread-suspend! (procedure thread-suspend! ((struct thread)) undefined))
+(thread-terminate! (procedure thread-terminate! ((struct thread)) undefined))
+(thread-wait-for-i/o! (procedure thread-wait-for-i/o! (fixnum #!optional symbol) undefined))
+(thread-yield! (procedure thread-yield! () undefined))
+(thread? (procedure thread? (*) boolean))
+(time->milliseconds (procedure time->milliseconds ((struct time)) fixnum))
+(time->seconds (procedure time->seconds ((struct time)) number))
+(time? (procedure time? (*) boolean))
+(uncaught-exception-reason (procedure uncaught-exception-reason ((struct condition)) *))
+(uncaught-exception? (procedure uncaught-exception? (*) boolean))
+
+;; srfi-4
+
+(blob->f32vector (procedure blob->f32vector (blob) (struct f32vector)))
+(blob->f32vector/shared (procedure blob->f32vector/shared (blob) (struct f32vector)))
+(blob->f64vector (procedure blob->f64vector (blob) (struct f64vector)))
+(blob->f64vector/shared (procedure blob->f64vector/shared (blob) (struct f64vector)))
+(blob->s16vector (procedure blob->s16vector (blob) (struct s16vector)))
+(blob->s16vector/shared (procedure blob->s16vector/shared (blob) (struct s16vector)))
+(blob->s32vector (procedure blob->s32vector (blob) (strucrt s32vector)))
+(blob->s32vector/shared (procedure blob->s32vector/shared (blob) (struct s32vector)))
+(blob->s8vector (procedure blob->s8vector (blob) (struct u8vector)))
+(blob->s8vector/shared (procedure blob->s8vector/shared (blob) (struct u8vector)))
+(blob->u16vector (procedure blob->u16vector (blob) (struct u16vector)))
+(blob->u16vector/shared (procedure blob->u16vector/shared (blob) (struct u16vector)))
+(blob->u32vector (procedure blob->u32vector (blob) (struct u32vector)))
+(blob->u32vector/shared (procedure blob->u32vector/shared (blob) (struct u32vector)))
+(blob->u8vector (procedure blob->u8vector (blob) (struct u8vector)))
+(blob->u8vector/shared (procedure blob->u8vector/shared (blob) (struct u8vector)))
+(f32vector (procedure f32vector (#!rest number) (struct f32vector)))
+(f32vector->blob (procedure f32vector->blob ((struct f32vector)) blob))
+(f32vector->blob/shared (procedure f32vector->blob/shared ((struct f232vector)) blob))
+(f32vector->list (procedure f32vector->list ((struct f32vector)) list))
+(f32vector-length (procedure f32vector-length ((struct f32vector)) fixnum))
+(f32vector-ref (procedure f32vector-ref ((struct f32vector) fixnum) float))
+(f32vector-set! (procedure f32vector-set! ((struct f32vector) fixnum number) undefined))
+(f32vector? (procedure f32vector? (*) boolean))
+(f64vector (procedure f64vector (#!rest number) (struct f64vector)))
+(f64vector->blob (procedure f64vector->blob ((struct f32vector)) blob))
+(f64vector->blob/shared (procedure f64vector->blob/shared ((struct f64vector)) blob))
+(f64vector->list (procedure f64vector->list ((struct f64vector)) blob))
+(f64vector-length (procedure f64vector-length ((struct f64vector)) fixnum))
+(f64vector-ref (procedure f64vector-ref ((struct f64vector) fixnum) float))
+(f64vector-set! (procedure f64vector-set! ((struct f64vector) fixnum number) undefined))
+(f64vector? (procedure f64vector? (*) boolean))
+(list->f32vector (procedure list->f32vector (list) (struct f32vector)))
+(list->f64vector (procedure list->f64vector (list) (struct f64vector)))
+(list->s16vector (procedure list->s16vector (list) (struct s16vector)))
+(list->s32vector (procedure list->s32vector (list) (struct s32vector)))
+(list->s8vector (procedure list->s8vector (list) (struct s8vector)))
+(list->u16vector (procedure list->u16vector (list) (struct u16vector)))
+(list->u32vector (procedure list->u32vector (list) (struct u32vector)))
+(list->u8vector (procedure list->u8vector (list) (struct u8vector)))
+(make-f32vector (procedure make-f32vector (fixnum #!optional * * *) (struct f32vector)))
+(make-f64vector (procedure make-f64vector (fixnum #!optional * * *) (struct f64vector)))
+(make-s16vector (procedure make-s16vector (fixnum #!optional * * *) (struct s16vector)))
+(make-s32vector (procedure make-s32vector (fixnum #!optional * * *) (struct s32vector)))
+(make-s8vector (procedure make-s8vector (fixnum #!optional * * *) (struct s8vector)))
+(make-u16vector (procedure make-u16vector (fixnum #!optional * * *) (struct u16vector)))
+(make-u32vector (procedure make-u32vector (fixnum #!optional * * *) (struct u32vector)))
+(make-u8vector (procedure make-u8vector (fixnum #!optional * * *) (struct u8vector)))
+(read-u8vector (procedure read-u8vector (#!optional fixnum port) (struct u8vector)))
+(read-u8vector! (procedure read-u8vector! (fixnum (struct u8vector) #!optional port fixnum) (struct u8vector)))
+(release-number-vector (procedure release-number-vector (*) undefined))
+(s16vector (procedure s16vector (#!rest fixnum) (struct s16vector)))
+(s16vector->blob (procedure s16vector->blob ((struct s16vector)) blob))
+(s16vector->blob/shared (procedure s16vector->blob/shared ((struct s16vector)) blob))
+(s16vector->list (procedure s16vector->list ((struct s16vector)) list))
+(s16vector-length (procedure s16vector-length ((struct s16vector)) fixnum))
+(s16vector-ref (procedure s16vector-ref ((struct s16vector) fixnum) fixnum))
+(s16vector-set! (procedure s16vector-set! ((struct s16vewctor) fixnum fixnum) undefined))
+(s16vector? (procedure s16vector? (*) boolean))
+(s32vector (procedure s32vector (#!rest number) (struct s32vector)))
+(s32vector->blob (procedure s32vector->blob ((structs 32vector)) blob))
+(s32vector->blob/shared (procedure s32vector->blob/shared ((struct s32vector)) blob))
+(s32vector->list (procedure s32vector->list ((struct s32vector)) list))
+(s32vector-length (procedure s32vector-length ((struct s32vector)) fixnum))
+(s32vector-ref (procedure s32vector-ref ((struct s32vector) fixnum) number))
+(s32vector-set! (procedure s32vector-set! ((struct s32vector) fixnum number) undefined))
+(s32vector? (procedure s32vector? (*) boolean))
+(s8vector (procedure s8vector (#!rest fixnum) (struct s8vector)))
+(s8vector->blob (procedure s8vector->blob ((struct s8vector)) blob))
+(s8vector->blob/shared (procedure s8vector->blob/shared ((struct s8vector)) blob))
+(s8vector->list (procedure s8vector->list ((struct s8vector)) list))
+(s8vector-length (procedure s8vector-length ((struct s8vector)) fixnum))
+(s8vector-ref (procedure s8vector-ref ((struct s18vector) fixnum) fixnum))
+(s8vector-set! (procedure s8vector-set! ((struct s8vector) fixnum fixnum) undefined))
+(s8vector? (procedure s8vector? (*) boolean))
+(subf32vector (procedure subf32vector ((struct f32vector) fixnum fixnum) (struct f32vector)))
+(subf64vector (procedure subf64vector ((struct f64vector) fixnum fixnum) (struct f64vector)))
+(subs16vector (procedure subs16vector ((struct s16vector) fixnum fixnum) (struct s16vector)))
+(subs32vector (procedure subs32vector ((struct s32vector) fixnum fixnum) (struct s32vector)))
+(subs8vector (procedure subs8vector ((struct s8vector) fixnum fixnum) (struct s8vector)))
+(subu16vector (procedure subu16vector ((struct u16vector) fixnum fixnum) (struct u16vector)))
+(subu32vector (procedure subu32vector ((struct u32vector) fixnum fixnum) (struct u32vector)))
+(subu8vector (procedure subu8vector ((struct u8vector) fixnum fixnum) (struct u8vector)))
+(u16vector (procedure u16vector (#!rest fixnum) (struct u16vector)))
+(u16vector->blob (procedure u16vector->blob ((struct u16vector)) blob))
+(u16vector->blob/shared (procedure u16vector->blob/shared ((struct u16vector)) blob))
+(u16vector->list (procedure u16vector->list ((struct u16vector)) list))
+(u16vector-length (procedure u16vector-length ((struct u16vector)) fixnum))
+(u16vector-ref (procedure u16vector-ref ((struct u16vector) fixnum) fixnum))
+(u16vector-set! (procedure u16vector-set! ((struct u16vector) fixnum fixnum) undefined))
+(u16vector? (procedure u16vector? (*) boolean))
+(u32vector (procedure u32vector (#!rest number) (struct u32vector)))
+(u32vector->blob (procedure u32vector->blob ((struct u32vector)) blob))
+(u32vector->blob/shared (procedure u32vector->blob/shared ((struct u32vector)) blob))
+(u32vector->list (procedure u32vector->list ((struct u32vector)) list))
+(u32vector-length (procedure u32vector-length ((struct u32vector)) fixnum))
+(u32vector-ref (procedure u32vector-ref ((struct u32vector) fixnum) number))
+(u32vector-set! (procedure u32vector-set! ((struct u32vector) fixnum number) undefined))
+(u32vector? (procedure u32vector? (*) boolean))
+(u8vector (procedure u8vector (#!rest fixnum) (struct u8vector)))
+(u8vector->blob (procedure u8vector->blob ((struct u8vector)) blob))
+(u8vector->blob/shared (procedure u8vector->blob/shared ((struct u8vector)) blob))
+(u8vector->list (procedure u8vector->list ((struct u8vector)) list))
+(u8vector-length (procedure u8vector-length ((struct u8vector)) fixnum))
+(u8vector-ref (procedure u8vector-ref ((struct u8vector) fixnum) fixnum))
+(u8vector-set! (procedure u8vector-set! ((struct u8vector) fixnum fixnum) undefined))
+(u8vector? (procedure u8vector? (*) boolean))
+(write-u8vector (procedure write-u8vector ((struct u8vector) #!optional port fixnum fixnum) undefined))
+
+;; srfi-69
+
+(alist->hash-table (procedure alist->hash-table (list #!rest) (struct hash-table)))
+(eq?-hash (procedure eq?-hash (* #!optional fixnum) fixnum))
+(equal?-hash (procedure equal?-hash (* #!optional fixnum) fixnum))
+(eqv?-hash (procedure eqv?-hash (* #!optional fixnum) fixnum))
+(hash (procedure hash (* #!optional fixnum) fixnum))
+(hash-by-identity (procedure hash-by-identity (* #!optional fixnum) fixnum))
+(hash-table->alist (procedure hash-table->alist ((struct hash-table)) list))
+(hash-table-clear! (procedure hash-table-clear! ((struct hash-table)) undefined))
+(hash-table-copy (procedure hash-table-copy ((struct hash-table)) (struct hash-table)))
+(hash-table-delete! (procedure hash-table-delete! ((struct hash-table) *) boolean))
+(hash-table-equivalence-function (procedure hash-table-equivalence-function ((struct hash-table)) (procedure (* *) *)))
+(hash-table-exists? (procedure hash-table-exists? ((struct hash-table) *) boolean))
+(hash-table-fold (procedure hash-table-fold ((struct hash-table) (procedure (* * *) *) *) *))
+(hash-table-for-each (procedure hash-table-for-each ((struct hash-table) (procedure (* *) . *)) undefined))
+(hash-table-has-initial? (procedure hash-table-has-initial? ((struct hash-table)) boolean))
+(hash-table-hash-function (procedure hash-table-hash-function ((struct hash-table)) (procedure (* fixnum) fixnum)))
+(hash-table-initial (procedure hash-table-initial ((struct hash-table)) *))
+(hash-table-keys (procedure hash-table-keys ((struct hash-table)) list))
+(hash-table-map (procedure hash-table-map ((struct hash-table) (procedure (* *) *)) list))
+(hash-table-max-load (procedure hash-table-max-load ((struct hash-table)) fixnum))
+(hash-table-merge (procedure hash-table-merge ((struct hash-table) (struct hash-table)) (struct hash-table)))
+(hash-table-merge! (procedure hash-table-merge! ((struct hash-table) (struct hash-table)) undefined))
+(hash-table-min-load (procedure hash-table-min-load ((struct hash-table)) fixnum))
+(hash-table-ref (procedure hash-table-ref ((struct hash-table) * #!optional (procedure () *)) *))
+(hash-table-ref/default (procedure hash-table-ref/default ((struct hash-table) * *) *))
+(hash-table-remove! (procedure hash-table-remove! ((struct hash-table) (procedure (* *) *)) undefined))
+(hash-table-set! (procedure hash-table-set! ((struct hash-table) * *) undefined))
+(hash-table-size (procedure hash-table-size ((struct hash-table)) fixnum))
+(hash-table-update! (procedure hash-table-update! ((struct hash-table) * #!optional (procedure (*) *) (procedure () *)) *))
+(hash-table-update!/default (procedure hash-table-update!/default ((struct hash-table) * (procedure (*) *) (procedure () *)) *))
+(hash-table-values (procedure hash-table-values ((struct hash-table)) list))
+(hash-table-walk (procedure hash-table-walk ((struct hash-table) (procedure (* *) . *)) undefined))
+(hash-table-weak-keys (procedure hash-table-weak-keys ((struct hash-table)) boolean))
+(hash-table-weak-values (procedure hash-table-weak-values ((struct hash-table)) boolean))
+(hash-table? (procedure hash-table? (*) boolean))
+(keyword-hash (procedure keyword-hash (* #!optional fixnum) fixnum))
+(make-hash-table (procedure make-hash-table (#!rest) (struct hash-table)))
+(number-hash (procedure number-hash (fixnum #!optional fixnum) fixnum))
+(object-uid-hash (procedure object-uid-hash (* #!optional fixnum) fixnum))
+(symbol-hash (procedure symbol-hash (symbol #!optional fixnum) fixnum))
+(string-hash (procedure string-hash (string #!optional fixnum fixnum fixnum) number))
+(string-hash-ci (procedure string-hash-ci (string #!optional fixnum fixnum fixnum) number))
+(string-ci-hash (procedure string-ci-hash (string #!optional fixnum fixnum fixnum) number))
+
+;; tcp
+
+(tcp-abandon-port (procedure tcp-abandon-port (port) undefined))
+(tcp-accept (procedure tcp-accept ((struct tcp-listener)) port port))
+(tcp-accept-ready? (procedure tcp-accept-ready? ((struct tcp-listener)) boolean))
+(tcp-accept-timeout (procedure tcp-accept-timeout (#!optional number) number))
+(tcp-addresses (procedure tcp-addresses (port) string string))
+(tcp-buffer-size (procedure tcp-buffer-size (#!optional fixnum) fixnum))
+(tcp-close (procedure tcp-close ((struct tcp-listener)) undefined))
+(tcp-connect (procedure tcp-connect (string #!optional fixnum) port port))
+(tcp-connect-timeout (procedure tcp-connect-timeout (#!optional number) number))
+(tcp-listen (procedure tcp-listen (fixnum #!optional fixnum *) (struct tcp-listener)))
+(tcp-listener-fileno (procedure tcp-listener-fileno ((struct tcp-listener)) fixnum))
+(tcp-listener-port (procedure tcp-listener-port ((struct tcp-listener)) fixnum))
+(tcp-listener? (procedure tcp-listener? (*) boolean))
+(tcp-port-numbers (procedure tcp-port-numbers (port) fixnum fixnum))
+(tcp-read-timeout (procedure tcp-read-timeout (#!optional number) number))
+(tcp-write-timeout (procedure tcp-write-timeout (#!optional number) number))
+
+;; utils
+
+(for-each-argv-line deprecated)
+(for-each-line deprecated)
+(read-all (procedure read-all (#!optional (or port string)) string))
+(system* (procedure system* (string #!rest) undefined))
+(qs (procedure qs (string) string))
+(compile-file (procedure compile-file (string #!rest) string))
+(compile-file-options (procedure compile-file-options (#!optional list) list))
+
+;; missing: setup-api, setup-download
diff --git a/unsafe-declarations.scm b/unsafe-declarations.scm
new file mode 100644
index 00000000..369d3200
--- /dev/null
+++ b/unsafe-declarations.scm
@@ -0,0 +1,77 @@
+;;;; unsafe-declarations.scm - various settings for libraries compiled in unsafe mode
+;
+; Copyright (c) 2008, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(cond-expand
+ (unsafe
+ (define-syntax ##sys#check-closure
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-inexact
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-range
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-pair
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-blob
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-list
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-symbol
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-string
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-char
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-exact
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-port
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-port-mode
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-port*
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-number
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-special
+ (syntax-rules ()
+ ((_ . _) (##core#undefined))))
+ (define-syntax ##sys#check-byte-vector
+ (syntax-rules ()
+ ((_ . _) '(##core#undefined)) ) ))
+ (else))
diff --git a/utils.import.scm b/utils.import.scm
new file mode 100644
index 00000000..cdd6c031
--- /dev/null
+++ b/utils.import.scm
@@ -0,0 +1,34 @@
+;;;; utils.import.scm - import library for "utils" module
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(##sys#register-primitive-module
+ 'utils
+ '(for-each-argv-line
+ for-each-line
+ read-all
+ system*
+ qs
+ compile-file))
diff --git a/utils.scm b/utils.scm
new file mode 100644
index 00000000..4cb17309
--- /dev/null
+++ b/utils.scm
@@ -0,0 +1,156 @@
+;;;; utils.scm - Utilities for scripting and file stuff
+;
+; Copyright (c) 2008-2009, The Chicken Team
+; Copyright (c) 2000-2007, Felix L. Winkelmann
+; All rights reserved.
+;
+; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
+; conditions are met:
+;
+; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
+; disclaimer.
+; 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.
+; Neither the name of the author nor the names of its contributors may be used to endorse or promote
+; products derived from this software without specific prior written permission.
+;
+; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
+; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
+; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+; POSSIBILITY OF SUCH DAMAGE.
+
+
+(declare
+ (unit utils)
+ (uses extras srfi-13 posix files)
+ (usual-integrations)
+ (fixnum)
+ (hide chop-pds)
+ (disable-interrupts) )
+
+(cond-expand
+ [paranoia]
+ [else
+ (declare
+ (always-bound
+ ##sys#windows-platform)
+ (bound-to-procedure
+ ##sys#check-port port? read-string for-each-line read-line with-input-from-file
+ command-line-arguments
+ string-append
+ system)
+ (no-procedure-checks-for-usual-bindings)
+ (no-bound-checks))] )
+
+(include "unsafe-declarations.scm")
+
+(register-feature! 'utils)
+
+
+;;; Like `system', but allows format-string and bombs on nonzero return code:
+
+(define system*
+ (let ([sprintf sprintf]
+ [system system] )
+ (lambda (fstr . args)
+ (let* ([str (apply sprintf fstr args)]
+ [n (system str)] )
+ (unless (zero? n)
+ (##sys#error "shell invocation failed with non-zero return status" str n) ) ) ) ) )
+
+
+;;; Handy I/O procedures:
+
+(define for-each-line ; DEPRECATED
+ (let ([read-line read-line])
+ (lambda (proc . port)
+ (let ([port (if (pair? port) (car port) ##sys#standard-input)])
+ (##sys#check-port port 'for-each-line)
+ (let loop ()
+ (let ([ln (read-line port)])
+ (unless (eof-object? ln)
+ (proc ln)
+ (loop) ) ) ) ) ) ) )
+
+
+;; This one is from William Annis:
+
+(define (for-each-argv-line thunk) ; DEPRECATED
+ (define (file-iterator file thunk)
+ (if (string=? file "-")
+ (for-each-line thunk)
+ (with-input-from-file file (cut for-each-line thunk) ) ) )
+ (let ((args (command-line-arguments)))
+ (if (null? args)
+ ;; If no arguments, take from stdin,
+ (for-each-line thunk)
+ ;; otherwise, hit each file named in argv.
+ (for-each (lambda (arg) (file-iterator arg thunk)) args))))
+
+
+;;; Read file as string from given filename or port:
+
+(define (read-all . file)
+ (let ([file (optional file ##sys#standard-input)])
+ (if (port? file)
+ (read-string #f file)
+ (with-input-from-file file (cut read-string #f)) ) ) )
+
+
+;;; Quote string for shell
+
+(define (qs str #!optional (platform (build-platform)))
+ (case platform
+ ((mingw32 msvc)
+ (string-append "\"" str "\""))
+ (else
+ (if (zero? (string-length str))
+ "''"
+ (string-concatenate
+ (map (lambda (c)
+ (if (or (char-whitespace? c)
+ (memq c '(#\# #\" #\' #\` #\´ #\~ #\& #\% #\$ #\! #\* #\; #\< #\> #\\
+ #\( #\) #\[ #\] #\{ #\})))
+ (string #\\ c)
+ (string c)))
+ (string->list str)))))))
+
+
+;;; Compile and load file
+
+(define compile-file-options (make-parameter '("-S" "-O2" "-d2")))
+
+(define compile-file
+ (let ((csc (foreign-value "C_CSC_PROGRAM" c-string))
+ (path (foreign-value "C_INSTALL_BIN_HOME" c-string))
+ (load-file load))
+ (lambda (filename #!key (options '()) output-file (load #t))
+ (let ((cscpath (or (file-exists? (make-pathname path csc)) "csc"))
+ (tmpfile (and (not output-file) (create-temporary-file "so")))
+ (crapshell (memq (build-platform) '(mingw32 msvc))))
+ (print "; compiling " filename " ...")
+ (system*
+ "~a~a -s ~a ~a -o ~a~a"
+ (if crapshell "\"" "")
+ (qs cscpath)
+ (string-intersperse (append (compile-file-options) options) " ")
+ (qs filename)
+ (qs (or output-file tmpfile))
+ (if crapshell "\"" ""))
+ (unless output-file
+ (on-exit
+ (lambda ()
+ (handle-exceptions ex #f (delete-file* tmpfile)))))
+ (when load
+ (let ((f (or output-file tmpfile)))
+ (handle-exceptions ex
+ (begin
+ (delete-file* f)
+ (abort ex))
+ (load-file f)
+ f)))))))
diff --git a/version.scm b/version.scm
new file mode 100644
index 00000000..61a7f523
--- /dev/null
+++ b/version.scm
@@ -0,0 +1 @@
+(define-constant +build-version+ "4.2.2")
Trap