~ chicken-core (chicken-5) 860f8d764457b8342dd008a14e9639bfed23e2ed
commit 860f8d764457b8342dd008a14e9639bfed23e2ed
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Dec 3 18:08:07 2024 +0100
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Dec 3 18:08:07 2024 +0100
merged utf+r7rs into temporary master
# Conflicts:
# Makefile.mingw-msys
# NEWS
# README
# batch-driver.scm
# buildversion
# chicken.h
# core.scm
# csi.scm
# data-structures.scm
# egg-compile.scm
# eval.scm
# library.scm
# manual/Acknowledgements
# manual/Extensions to the standard
# manual/Foreign type specifiers
# manual/Module (chicken base)
# manual/Module (chicken foreign)
# manual/Module (chicken platform)
# manual/Module scheme
# manual/Module srfi-4
# manual/The User's Manual
# support.scm
# tests/data-structures-tests.scm
# tests/runtests.bat
# tests/runtests.sh
# types.db
diff --git a/.gitignore b/.gitignore
index 40a78048..202db4f9 100644
--- a/.gitignore
+++ b/.gitignore
@@ -13,7 +13,6 @@
/buildid
/chicken-config.h
/chicken-defaults.h
-/feathers
# Compiled binary executables
@@ -65,6 +64,7 @@
/port.c
/posixunix.c
/profiler.c
+/r7lib.c
/read-syntax.c
/repl.c
/scheduler.c
@@ -78,7 +78,7 @@
# Compiled Scheme modules' imports
/chicken.bitwise.import.scm
-/chicken.blob.import.scm
+/chicken.bytevector.import.scm
/chicken.compiler.batch-driver.import.scm
/chicken.compiler.c-backend.import.scm
/chicken.compiler.c-platform.import.scm
@@ -123,4 +123,13 @@
/chicken.string.import.scm
/chicken.tcp.import.scm
/chicken.time.posix.import.scm
+/chicken.number-vector.import.scm
/srfi-4.import.scm
+/scheme.write.import.scm
+/scheme.time.import.scm
+/scheme.file.import.scm
+/scheme.process-context.import.scm
+
+# Generated manual (from dist)
+
+/manual-html
diff --git a/DEPRECATED b/DEPRECATED
index 716a148b..53697615 100644
--- a/DEPRECATED
+++ b/DEPRECATED
@@ -1,6 +1,10 @@
Deprecated functions and variables
==================================
+6.0.0
+- The foreign type "blob" is obsolete and equivalent to the
+ foreign type "bytevector".
+
5.3.1
- read/source-info from the internal, undocumented module
(chicken compiler support) is deprecated. Instead, use
diff --git a/GNUmakefile b/GNUmakefile
index 6e938d57..c8f59af4 100644
--- a/GNUmakefile
+++ b/GNUmakefile
@@ -9,11 +9,11 @@
# conditions are met:
#
# Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-# disclaimer.
+# 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.
+# 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.
+# 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
@@ -25,19 +25,7 @@
# OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
-# If nothing selected, use default config (this should set PLATFORM)
-ifeq ($(CONFIG)$(PLATFORM),)
-CONFIG=config.make
-endif
-
-ifneq ($(CONFIG),)
-# Avoid loading config when building a boot-chicken
-ifneq ($(MAKECMDGOALS),boot-chicken)
-include $(CONFIG)
-endif
-endif
-
-include Makefile.detect
+include config.make
ifndef PLATFORM
$(info Please select your target platform by running one of the following commands:)
diff --git a/LICENSE b/LICENSE
index 0ddbe10f..368e5e94 100644
--- a/LICENSE
+++ b/LICENSE
@@ -142,6 +142,7 @@ these licenses are only relevant in atypical situations:
tests/slatex.scm
tests/slatex.sty
tests/test.tex:
+
Copyright (c) 1990-2002, Dorai Sitaram.
All rights reserved.
@@ -219,3 +220,29 @@ tests/numbers-test-gauche.scm:
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.
+
+utf.c:
+
+ The character case mapping tables are generated by a script taken"
+ from http://git.suckless.org/ubase/ which is
+
+ MIT/X Consortium Copyright (c) 2012 Connor Lane Smith <cls@lubutu.com>
+ (c) 2015 Laslo Hunhold <dev@frign.de>
+
+ Permission is hereby granted, free of charge, to any person obtaining a
+ copy of this software and associated documentation files (the "Software"),
+ to deal in the Software without restriction, including without limitation
+ the rights to use, copy, modify, merge, publish, distribute, sublicense,
+ and/or sell copies of the Software, and to permit persons to whom the
+ Software is furnished to do so, subject to the following conditions:
+
+ The above copyright notice and this permission notice shall be included in
+ all copies or substantial portions of the Software.
+
+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+ IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+ FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+ THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+ LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+ FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+ DEALINGS IN THE SOFTWARE.
diff --git a/Makefile.cross-linux-mingw b/Makefile.cross-linux-mingw
index d6dcfa21..37f4329e 100644
--- a/Makefile.cross-linux-mingw
+++ b/Makefile.cross-linux-mingw
@@ -8,11 +8,11 @@
# conditions are met:
#
# Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-# disclaimer.
+# 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.
+# 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.
+# 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
@@ -39,7 +39,7 @@ EXE = .exe
# commands
-HOSTSYSTEM ?= mingw32
+HOSTSYSTEM ?= mingw
# options
@@ -57,8 +57,8 @@ C_COMPILER_SHARED_OPTIONS = -DPIC
LINKER_LINK_SHARED_LIBRARY_OPTIONS = -shared
LIBRARIES = -lm -lws2_32
LIBCHICKEN_SO_LINKER_OPTIONS = -Wl,--out-implib,lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX).dll.a
-LIBCHICKEN_SO_LIBRARIES = -lws2_32
-LIBUCHICKEN_SO_LIBRARIES = -lws2_32
+LIBCHICKEN_SO_LIBRARIES = -lws2_32
+LIBUCHICKEN_SO_LIBRARIES = -lws2_32
LIBCHICKEN_IMPORT_LIBRARY = lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX).dll.a
TARGET_C_COMPILER = gcc
TARGET_CXX_COMPILER = g++
diff --git a/Makefile.detect b/Makefile.detect
deleted file mode 100644
index 9694b125..00000000
--- a/Makefile.detect
+++ /dev/null
@@ -1,88 +0,0 @@
-# -*- Makefile -*-
-#
-# Detect the PLATFORM with uname.
-# Based on Chibi Scheme auto-detector
-# Heavily revamped by John Cowan
-# Copyright (c) 2009-2018 Alex Shinn, John Cowan
-# BSD license at <https://github.com/ashinn/chibi-scheme/blob/master/COPYING>
-
-ifndef PLATFORM
-
-# First check is for pure MinGW, which doesn't have uname.
-# In cmd.exe, echo "test" outputs "test", with quotes.
-test:=$(shell echo "test")
-quote:=$(findstring ",$(test))
-
-ifeq ($(quote),")
-PLATFORM=mingw
-else
-
-# Now we can use uname tests
-uname_s:=$(shell uname)
-uname_o:=$(shell uname -o 2>/dev/null)
-
-# Check for specific platforms
-ifeq ($(uname_o),Msys)
-PLATFORM=mingw-msys
-endif
-
-ifeq ($(uname_s),Darwin)
-PLATFORM=macosx
-endif
-
-ifeq ($(uname_s),FreeBSD)
-PLATFORM=bsd
-endif
-
-ifeq ($(uname_s),NetBSD)
-PLATFORM=bsd
-endif
-
-ifeq ($(uname_s),OpenBSD)
-PLATFORM=bsd
-endif
-
-ifeq ($(uname_s),DragonFly)
-PLATFORM=bsd
-endif
-
-ifeq ($(uname_o),Cygwin)
-PLATFORM=cygwin
-endif
-
-ifeq ($(uname_o),Android)
-PLATFORM=android
-endif
-
-ifeq ($(uname_o),GNU/Linux)
-PLATFORM=linux
-endif
-
-ifeq ($(uname_o),Linux)
-PLATFORM=linux
-endif
-
-ifeq ($(uname_s),SunOS)
-PLATFORM=solaris
-endif
-
-ifeq ($(uname_s),Haiku)
-PLATFORM=haiku
-endif
-
-ifeq ($(uname_s),BeOS)
-PLATFORM=haiku
-endif
-
-ifeq ($(uname_s),GNU)
-PLATFORM=hurd
-endif
-
-ifeq ($(uname_s),AIX)
-PLATFORM=aix
-endif
-
-# add more options here
-
-endif # have uname
-endif # undef PLATFORM
diff --git a/Makefile.linux b/Makefile.linux
index a48e252f..c5de9e8e 100644
--- a/Makefile.linux
+++ b/Makefile.linux
@@ -34,7 +34,7 @@ ARCH ?= $(shell sh $(SRCDIR)/config-arch.sh)
C_COMPILER_OPTIONS ?= -fno-strict-aliasing -fwrapv -DHAVE_CHICKEN_CONFIG_H
ifdef DEBUGBUILD
-C_COMPILER_OPTIMIZATION_OPTIONS ?= -g -Wall -Wno-unused
+C_COMPILER_OPTIMIZATION_OPTIONS ?= -g -Wall -Wno-unused -O0 -Wno-cpp
else
ifdef OPTIMIZE_FOR_SPEED
C_COMPILER_OPTIMIZATION_OPTIONS ?= -O3 -fomit-frame-pointer
diff --git a/Makefile.mingw b/Makefile.mingw
index da2849fd..e6698cbe 100644
--- a/Makefile.mingw
+++ b/Makefile.mingw
@@ -1,4 +1,4 @@
-# Makefile.mingw - configuration for MinGW (no MSYS) -*- Makefile -*-
+# Makefile.mingw - configuration for MinGW (MSYS) -*- Makefile -*-
#
# Copyright (c) 2008-2022, The CHICKEN Team
# Copyright (c) 2007, Felix L. Winkelmann
@@ -24,16 +24,13 @@
# 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)
+SRCDIR ?= ./
# platform configuration
DLLSINPATH = 1
ARCH ?= x86
WINDOWS = 1
-WINDOWS_SHELL = 1
-UNAME_SYS = MinGW
# file extensions
@@ -42,7 +39,6 @@ EXE = .exe
# options
-C_COMPILER ?= gcc
C_COMPILER_OPTIONS ?= -fno-strict-aliasing -fwrapv -DHAVE_CHICKEN_CONFIG_H
ifdef DEBUGBUILD
C_COMPILER_OPTIMIZATION_OPTIONS ?= -g -Wall -Wno-unused
@@ -54,15 +50,23 @@ C_COMPILER_OPTIMIZATION_OPTIONS ?= -Os
endif
endif
C_COMPILER_SHARED_OPTIONS = -DPIC
-RC_COMPILER ?= windres
+LINKER_OPTIONS += -Wl,--enable-auto-import
LINKER_LINK_SHARED_LIBRARY_OPTIONS = -shared
LIBRARIES = -lm -lws2_32
-LINKER_OPTIONS += -Wl,--enable-auto-import
LIBCHICKEN_SO_LINKER_OPTIONS = -Wl,--out-implib,lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX).dll.a
-LIBCHICKEN_SO_LIBRARIES = -lm -lws2_32
+LIBCHICKEN_SO_LIBRARIES = -lm -lws2_32
LIBCHICKEN_IMPORT_LIBRARY = lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX).dll.a
-MAKEDIR_COMMAND_OPTIONS =
-GENERATE_DEBUGGER = type $< >$@ & echo wish $(DATADIR)\feathers.tcl %1 %2 %3 %4 %5 %6 %7 %8 %9 >>$@
+
+# Don't use "install" program as it is broken in some Mingw versions and
+# Vista doesn't like it, anyway.
+
+INSTALL_PROGRAM = cp
+INSTALL_PROGRAM_SHARED_LIBRARY_OPTIONS = -r
+INSTALL_PROGRAM_STATIC_LIBRARY_OPTIONS = -r
+INSTALL_PROGRAM_EXECUTABLE_OPTIONS = -r
+INSTALL_PROGRAM_FILE_OPTIONS = -r
+MAKEDIR_COMMAND = mkdir
+MAKEDIR_COMMAND_OPTIONS = -p
# special files
@@ -71,37 +75,38 @@ POSIXFILE = posixwin
# select default and internal settings
-include $(SRCDIR)defaults.make
+include $(SRCDIR)/defaults.make
chicken-config.h: chicken-defaults.h
- echo /* GENERATED */ >$@
- 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 NO_POSIX_POLL 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_DIRECT_H 1 >>$@
- echo #define HAVE_ERRNO_H 1 >>$@
- echo #define HAVE_LOADLIBRARY 1 >>$@
- echo #define HAVE_GETPROCADDRESS 1 >>$@
- echo #define C_STACK_GROWS_DOWNWARD 1 >>$@
+ echo "/* GENERATED */" >$@
+ 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 NO_POSIX_POLL 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_DIRECT_H 1" >>$@
+ echo "#define HAVE_ERRNO_H 1" >>$@
+ echo "#define HAVE_LOADLIBRARY 1" >>$@
+ echo "#define HAVE_GETPROCADDRESS 1" >>$@
+ echo "#define C_WINDOWS_SHELL 1" >>$@
+ echo "#define C_STACK_GROWS_DOWNWARD 1" >>$@
ifdef GCHOOKS
- echo #define C_GC_HOOKS >>$@
+ echo "#define C_GC_HOOKS" >>$@
endif
- echo #define C_USE_STD_FEATURE_MACROS >>$@
- type chicken-defaults.h >>$@
+ echo "#define C_USE_STD_FEATURE_MACROS" >>$@
+ cat chicken-defaults.h >>$@
-include $(SRCDIR)rules.make
+include $(SRCDIR)/rules.make
diff --git a/Makefile.mingw-msys b/Makefile.mingw-msys
deleted file mode 100644
index db4bf2a7..00000000
--- a/Makefile.mingw-msys
+++ /dev/null
@@ -1,114 +0,0 @@
-# Makefile.mingw - configuration for MinGW (MSYS) -*- Makefile -*-
-#
-# Copyright (c) 2008-2022, The CHICKEN Team
-# Copyright (c) 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.
-
-SRCDIR ?= ./
-
-# platform configuration
-
-DLLSINPATH = 1
-ARCH ?= x86
-WINDOWS = 1
-
-# file extensions
-
-SO = .dll
-EXE = .exe
-
-# options
-
-C_COMPILER_OPTIONS ?= -fno-strict-aliasing -fwrapv -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
-LINKER_OPTIONS += -Wl,--enable-auto-import
-LINKER_LINK_SHARED_LIBRARY_OPTIONS = -shared
-LIBRARIES = -lm -lws2_32
-LIBCHICKEN_SO_LINKER_OPTIONS = -Wl,--out-implib,lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX).dll.a
-LIBCHICKEN_SO_LIBRARIES = -lm -lws2_32
-LIBCHICKEN_IMPORT_LIBRARY = lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX).dll.a
-
-# Don't use "install" program as it is broken in some Mingw versions and
-# Vista doesn't like it, anyway.
-
-INSTALL_PROGRAM = cp
-INSTALL_PROGRAM_SHARED_LIBRARY_OPTIONS = -r
-INSTALL_PROGRAM_STATIC_LIBRARY_OPTIONS = -r
-INSTALL_PROGRAM_EXECUTABLE_OPTIONS = -r
-INSTALL_PROGRAM_FILE_OPTIONS = -r
-MAKEDIR_COMMAND = mkdir
-MAKEDIR_COMMAND_OPTIONS = -p
-
-# special files
-
-CHICKEN_CONFIG_H = chicken-config.h
-POSIXFILE = posixwin
-
-# select default and internal settings
-
-include $(SRCDIR)/defaults.make
-
-chicken-config.h: chicken-defaults.h
- echo "/* GENERATED */" >$@.tmp
- echo "#define HAVE_DIRENT_H 1" >>$@.tmp
- echo "#define HAVE_INTTYPES_H 1" >>$@.tmp
- echo "#define HAVE_LIMITS_H 1" >>$@.tmp
- echo "#define HAVE_LONG_LONG 1" >>$@.tmp
- echo "#define HAVE_MEMMOVE 1" >>$@.tmp
- echo "#define HAVE_MEMORY_H 1" >>$@.tmp
- echo "#define NO_POSIX_POLL 1" >>$@.tmp
- echo "#define HAVE_STDINT_H 1" >>$@.tmp
- echo "#define HAVE_STDLIB_H 1" >>$@.tmp
- echo "#define HAVE_STRERROR 1" >>$@.tmp
- echo "#define HAVE_STRINGS_H 1" >>$@.tmp
- echo "#define HAVE_STRING_H 1" >>$@.tmp
- echo "#define HAVE_STRTOLL 1" >>$@.tmp
- echo "#define HAVE_SYS_STAT_H 1" >>$@.tmp
- echo "#define HAVE_SYS_TYPES_H 1" >>$@.tmp
- echo "#define HAVE_UNISTD_H 1" >>$@.tmp
- echo "#define HAVE_UNSIGNED_LONG_LONG 1" >>$@.tmp
- echo "#define STDC_HEADERS 1" >>$@.tmp
- echo "#define HAVE_DIRECT_H 1" >>$@.tmp
- echo "#define HAVE_ERRNO_H 1" >>$@.tmp
- echo "#define HAVE_LOADLIBRARY 1" >>$@.tmp
- echo "#define HAVE_GETPROCADDRESS 1" >>$@.tmp
- echo "#define C_WINDOWS_SHELL 1" >>$@.tmp
- echo "#define C_STACK_GROWS_DOWNWARD 1" >>$@.tmp
-ifdef GCHOOKS
- echo "#define C_GC_HOOKS" >>$@.tmp
-endif
- echo "#define C_USE_STD_FEATURE_MACROS" >>$@.tmp
- cat $@.tmp chicken-defaults.h >$@.tmp2
- rm $@.tmp
- mv $@.tmp2 $@
-
-include $(SRCDIR)/rules.make
diff --git a/NEWS b/NEWS
index 30e16d1b..61df9e40 100644
--- a/NEWS
+++ b/NEWS
@@ -1,3 +1,110 @@
+6.0.0
+
+- Core libraries
+ - All modules specified by the R7RS small language are now available in
+ the core system.
+ - The internal string representation has been converted to UTF-8,
+ making strings fully UNICODE capable.
+ - The (chicken blob) module has been replaced with (chicken bytevector),
+ containing R7RS compatible bytevector operations. Bytevectors are
+ now fully equivalent to SRFI-4 u8vectors.
+ - The read-syntax for blobs (`#${...}') has been removed. Bytevectors
+ can be read using `#u8(...)' or `#u8"..."'.
+ - `open-input-file' and `open-output-file' accept a file encoding,
+ supported are currently UTF-8 (the default) and Latin-1 (ISO-8859-1).
+ - `file-read', `file-write', 'set-pseudo-random-seed!' and `random-bytes'
+ require a bytevector argument and do not accept strings.
+ - File-locking operations in the (chicken file posix) module now use the
+ flock(2) system call, operator over whole files, are thread-safe and
+ use a simpler interface. `file-test-lock' has been removed.
+ - `read-u8vector', `read-u8vector!' and `write-u8vector' have been
+ removed, use the equivalent operations from the (chicken io)
+ module instead.
+ - Added `read-bytevector', `read-bytevector!' and `write-bytevector'
+ to the (chicken io) module.
+ - Removed `set-port-name!', use the SRFI-17 setter for `port-name'
+ instead.
+ - Added `port-encoding' to the (chicken port) module.
+ - Locatives on strings are now indexed by code-point, not byte.
+ - `symbol-escape' now also controls whether symbols are printed in
+ escaped ("|...|") mode or not.
+ - Symbol printing is stricter in deciding when symbols should be escaped
+ or not.
+ - The following primitives have been moved from (chicken base)
+ to R7RS modules:
+ - `exact-integer-sqrt?', `vector-copy!', `make-parameter', `call/cc',
+ `open-input-string', `open-output-string', `get-output-string',
+ `input-port-open?', `output-port-open?', `parameterize' and `port?'
+ moved from the (chicken base) to the (scheme base).
+ - `case-lambda' moved from (chicken base) to (scheme case-lambda).
+ - `features' moved from (chicken platform) to (scheme base).
+ - `write-string' moved from (chicken io) to (scheme base) and its
+ signature changed to the R7RS one.
+ - `define-record-type' moved to (scheme base) and is generative,
+ to be compliant with R7RS.
+ - `syntax-error' has been removed from (chicken syntax) and is now a macro
+ and part of (scheme base).
+ - `record-instance?' and `make-record-instance' accept non-symbolic
+ type specifiers to support generative record types.
+ - The new (chicken number-vector) module now provides a superset of
+ SRFI-4, including 64 and 128-bit complex number vectors, the `srfi-4'
+ module is still available but exports only those procedures as are
+ specified in SRFI-4.
+ - The second (optional) parameter for `load' and `load-relative' may be
+ either an environment or an evaluation procedure.
+ - The module aliases `srfi-0', `srfi-6', `srfi-9', `srfi-11', `srfi-23',
+ `srfi-39' and `srfi-98' have been removed (all of these are covered by
+ R7RS).
+ - The modules `r4rs', `r5rs', `r4rs-null' and `r5rs-null' have been
+ renamed to `(scheme XXX)'.
+ - Hexadecimal escape sequences in strings and extended symbols must be
+ terminated by the `;' character, following R7RS.
+ - The `#ci'/`#cs' read syntaxes have been removed, use `#![no-]fold-case'
+ markers instead.
+ - `include' and `include-relative' accept multiple filenames, `include-ci'
+ has been added.
+ - Added `include-path' to (chicken platform) module.
+ - The platform-identifier "mingw32" has been renamed to "mingw".
+
+- Syntax expander:
+ - `syntax-rules' attempts to better support tail patterns with ellipses (#1736).
+
+- FFI changes:
+ - Strings and symbols passed to foreign code are not copied, they are
+ passed directly, any mutations done by external code will be visible on the
+ Scheme side.
+ - Complex numbers, C structs and unions can now be passed directly as
+ arguments and returned as results when interfacing to C code.
+
+- Tools
+ - The compiler and interpreter option `-r5rs-syntax' has been renamed to
+ `-r7rs-syntax' and does not disable extended symbol syntax ("|...|") anymore.
+ - The "feathers" debugger has been removed from the core and is now available
+ as an egg.
+ - The `set-describer!' procedure has been removed from the `csi' module.
+ - The "csc" program now accepts tool flags (e.g. -compiler, -cc etc) which
+ have paths with spaces in them without requiring the user to double-quote
+ them. As a consequence, it no longer accepts programs with space separated
+ flags for tool arguments (e.g. "csc -cc 'gcc -debug'" etc). If this is
+ desired, write a short shell script which calls the tool with your flags.
+ - `chicken-install' now locks the cache directory during egg-installation.
+ - Added component type `installed-c-object' to egg format.
+ - The `csc-options' and `link-options' configuration clauses in egg
+ specifications now allow `custom-config' forms to produce arbitrary
+ computed compiler and linker options.
+
+- Build system
+ - A "configure" script is now used to prepare the sources for building
+ everything. This simplifies the use of "make", allows more elaborate
+ platform sanity checks and follows conventions.
+ - On Windows the minimal "mingw" build is not supported anymore, a POSIX
+ shell and the basic sete of command-line utilities is now required
+ (formerly the "mingw-msys" build). Chris Wellons "w64devkit" is now
+ the recommended toolchain. The platform identifier "mingw-msys" has been
+ renamed to "mingw".
+ - The system can now be built with "zig cc" as a C compiler/linker
+ replacement.
+
5.4.0
- Security fixes
@@ -14,7 +121,7 @@
- Fix type declarations for `file-select` (reported by Anton Idukov).
- Change `create-temporary-{file,directory}` fallback code on Windows to
use %USERPROFILE%/AppData/Local/Temp if that environment variable is set.
- - Added new thread-safe API for POSIX signals ("make-signal-handler",
+ - Added new thread-safe API for POSIX signals ("make-signal-handler",
"signal-ignore" and "signal-default") and deprecated the existing one.
- Added "make-finalizer" to execute finalizers in a thread-safe
manner.
@@ -525,7 +632,7 @@
`-prefix`.
- Added new "-from-list" option to chicken-install.
- Eggs can now be installed and located in multiple directories,
- using the `CHICKEN_REPOSITORY_PATH` +
+ using the `CHICKEN_REPOSITORY_PATH` +
`CHICKEN_INSTALL_REPOSITORY`
environment variables.
- Static compilation of eggs is now fully supported and static
@@ -1054,7 +1161,7 @@
into the core libraries and shown in the "csi" and "chicken"
version headers
- The default target library name for an installation configured for cross-
- compilation is now "libchicken" and independent on any particular
+ compilation is now "libchicken" and independent on any particular
setting of PROGRAM_PREFIX/PROGRAM_SUFFIX (thanks to Otavio Salvador)
- Compiler
@@ -1090,14 +1197,14 @@
with the compiler option of the same name)
- the optimizations done by the compiler are now listed as a comment
in the generated C file
- - the type-information obtained during flow-analysis ("scrutiny") is
+ - the type-information obtained during flow-analysis ("scrutiny") is
now used for performing type-sensitive optimizations of calls to
most of the core-library procedures
- deprecated the "constant" declaration specifier
- "unboxing" optimization has been completely removed - the implementation
was unreliable and unmaintainable; the "-unboxing" compiler option will
still be accepted but will produce a warning
- - Peter Bex contributed an optimization to the analysis pass that
+ - Peter Bex contributed an optimization to the analysis pass that
greatly reduces compile time for source code containing deeply nested
lexical bindings
- procedures that are known to have the value of a core library procedure
@@ -1119,7 +1226,7 @@
- Core libraries
- Cleaned up the set of available internal SRFI-feature-identifiers
- Fixed bugs in "make-pathname" and "normalize-pathname" (thanks to Jim Ursetto)
- - The reader is now more consistent when parsing symbol- and keyword names
+ - The reader is now more consistent when parsing symbol- and keyword names
that are fully or partially escaped (thanks to Kon Lovett)
- The printer now does a better job at escaping certain single-character
symbol names
@@ -1145,14 +1252,14 @@
- invoking a parameter-procedure with an argument will return the new
value
- added new procedure "quit"
- - port-procedures now check correctly for argument-ports being open
+ - port-procedures now check correctly for argument-ports being open
(thanks to Peter Bex)
- - "repl" accepts an optional evaluator procedure (suggested by John
+ - "repl" accepts an optional evaluator procedure (suggested by John
Cowan)
- added a setter procedure to "signal-handler" ("posix" unit)
- EINTR is properly handled for input routines that may block
waiting for input
- - the implementation of R5RS evaluation environments is now fully
+ - the implementation of R5RS evaluation environments is now fully
standards compliant
- "file-exists?" and "directory-exists?" work now properly for files
> 2GB (EOVERFLOW handling in stat(3) system call)
@@ -1179,7 +1286,7 @@
- a number of bugs in the irregex regular expression engine have been
fixed; it has been updated to upstream release 0.8.3
- "with-input-from-file", "with-output-to-file", "with-input-from-pipe" and
- "with-output-to-pipe" now properly restore the standard input/output
+ "with-output-to-pipe" now properly restore the standard input/output
ports in case the body thunk escapes
- symbols with a single-char print-name where not always properly escaped
when printed readably
@@ -1199,7 +1306,7 @@
- Fixed handling of "-output-file" (it was being ignored)
- "chicken-install"
- Added option "-override", which allows retrieving extension-
- versions from a file - this may be useful to ensure specific
+ versions from a file - this may be useful to ensure specific
versions of a complete set of eggs are installed
- Added option "-keep-installed"/"-x" that only installs explicitly
named extensions given on the command line, if they are not
@@ -1241,7 +1348,7 @@
call rewrites in compiled code
- Syntax expander
- - Fixed a bug that caused imported identifiers to leak into the
+ - Fixed a bug that caused imported identifiers to leak into the
macroexpansion/compile-time environment (reported by Christian Kellermann)
- Fixed a bug in the processing of extended lambda-lists (thanks to Peter Bex)
- Peter Bex fixed a bug that caused bound variables to be incorrectly
@@ -1255,7 +1362,7 @@
- Runtime system
- fixed handling of "inf" and nan" floating-point predicates for Solaris
(thanks to Claude Marinier)
- - support for re-loading of compiled files has now been completely
+ - support for re-loading of compiled files has now been completely
removed
- the maximum length of strings is no longer limited to a 24-bit
number on 64-bit architectures but can be 56 bits.
@@ -1277,9 +1384,9 @@
was broken for Sparc64 systems and has been disabled for this platform
- signal masks were accidentally reset upon GC for some platforms; use
sigsetjmp/siglongjmp on BSD, Linux, MacOS X and Haiku
-
+
- Type system
- - added new type-specifiers "input-port", "output-port", "(list-of T)"
+ - added new type-specifiers "input-port", "output-port", "(list-of T)"
and "(vector-of T)"
- the type-specifiers "(vector T ...)" and "(list T ...)" represent
fixed size lists and vectors now
@@ -1325,7 +1432,7 @@
are applied to generated files and directories which allows
perform differently named installations into the same PREFIX
- increaded binary-compatibility version from 5 to 6, which
- means installed extensions in an existing installations will
+ means installed extensions in an existing installations will
have to be re-installed
- bugfixes in mingw/msys makefiles
- Sven Hartrumpf contributed a bugfix to the internal helper
@@ -1349,7 +1456,7 @@
sequences inside strings (thanks to Mario Domenech Goulart,
thanks to Kon Lovett for pointing out a missing test-file)
- The pretty printer did not escape some control characters correctly
- (reported by Alan Post)
+ (reported by Alan Post)
- control-characters in symbol-names are now properly escaped if
the symbol is printed readably (thanks to Alaric Snell-Pym
for pointing this out)
@@ -1364,7 +1471,7 @@
enhancements
- "library" unit
- Added "condition->list" (thanks to Christian Kellermann)
- - The reader accepts now escaped octal character codes in string
+ - The reader accepts now escaped octal character codes in string
literals
- Read-syntax can return zero values to indicate ignored objects
- R5RS output output routines now always return a "void" result
@@ -1397,14 +1504,14 @@
- "close-input-pipe" did not return the status code of a
terminated process on Windows (reported by Mario Domenech Goulart)
- added `file-creation-mode' (suggested by Mario Domenech Goulart)
- - "setup-api" unit
+ - "setup-api" unit
- `required-extension-version' and `required-chicken-version' have
been deprecated
- "srfi-18" unit
- removed deprecated `milliseconds->time' and `time->milliseconds'
procedures
- `make-mutex' incorrectly created mutexes as initially owned by
- the current threads (thanks to Joerg Wittenberger)
+ the current threads (thanks to Joerg Wittenberger)
- the file-descriptor handling in the scheduler has been simplified
and performs some sanity checks
- deadlock in the scheduler now terminates the process instead of
@@ -1469,7 +1576,7 @@
- Documentation
- Added list of installed files to README
- - Documented remaining "c...r" standard procedures (thanks to
+ - Documented remaining "c...r" standard procedures (thanks to
Juergen Lorenz)
- The manual is now installed in HTML format in
PREFIX/share/chicken/doc, many thanks to Jim Ursetto for
@@ -1485,7 +1592,7 @@
- added missing result-type handling for `unsigned-integer64'
(thanks to Moritz Heidkamp)
- added `foreign-type-size' macro
- - added the new foreign type `size_t' (suggested by Moritz
+ - added the new foreign type `size_t' (suggested by Moritz
Heidkamp)
- added the missing `unsigned-integer64' foreign type (thanks
to Moritz for catching this)
@@ -1614,13 +1721,13 @@
- the evaluation-result history in `csi' can be inspected and
cleared (to reduce memory load) with the toplevel commands
`,h' and `,ch'
-- unit `data-structures': deprecated `left-section' and
+- unit `data-structures': deprecated `left-section' and
`right-section'
-- fixed bug that caused the static syntax-environment of
+- fixed bug that caused the static syntax-environment of
syntax exported by a module to be incomplete
- module `setup-api': Documented the `version>=?' and
`extension-name-and-version' proceedures
-- unit `posix': `utc-time->seconds' is considerably
+- unit `posix': `utc-time->seconds' is considerably
faster on Mac OS X (thanks to Jim Ursetto);
added new procedure `file-type'
- the `time' macro now shows the correct number of minor
@@ -1665,11 +1772,11 @@
- added compiler and interpreter option `-no-feature FEATURENAME' that
disables predefined feature identifiers
- code compiled with interrupts disabled will not emit inline files
- for global inlining since they may execute in a context where
+ for global inlining since they may execute in a context where
interrupts are enabled
-- the `setup.defaults' file that holds download sources for
+- the `setup.defaults' file that holds download sources for
`chicken-install' now allows aliases for locations
-- CHICKEN systems build from cross-compilation now by default
+- CHICKEN systems build from cross-compilation now by default
transparently build and install extensions for both the host
and target parts of the cross-compilation setup; the options
`-host' and `-target' can now be used to selectively build
@@ -1704,7 +1811,7 @@
- fixed some build-system bugs related to installation
- fixed a problem in the C runtime code that prevented it to be compileable
without a configuration header-file
-- the makefile-target to build a bootstrapping `chicken' executable
+- the makefile-target to build a bootstrapping `chicken' executable
performs multi-stage build now
- changed error message when required extension is out of date (thanks to
Mario Goulart)
@@ -1732,10 +1839,10 @@
- strings passed to C runtime functions and which are converted to
0-terminated C strings are now checked for not containing embedded
`\0' characters (thanks to Peter Bex)
-- errors in user-defined record printers are caught and shown in the
+- errors in user-defined record printers are caught and shown in the
output instead of throwing an error to avoid endless recursion when
an error message is printed
-- a feature identifier named `chicken-MAJOR.MINOR' is now defined
+- a feature identifier named `chicken-MAJOR.MINOR' is now defined
to simplify conditionalization of code on the CHICKEN version
- `getter-with-setter' copies the lambda-information (if available) from
the getter to the generated procedure
@@ -1746,7 +1853,7 @@
- split up manual chapter `Modules and macros' into two chapters
(named `Modules' and `Macros', respectively - suggested by
Mario Goulart)
-- the last 5 non-precompiled regular expressions are now internally
+- the last 5 non-precompiled regular expressions are now internally
cached in compiled form, which speeds up repeated matching of
the same uncompiled regular expression dramatically
- added the new procedure `yes-or-no?' to the `utils' library unit
@@ -1758,7 +1865,7 @@
- added `[-]no-procedure-checks-for-toplevel-bindings' compiler
option and declaration
- usage of unimported syntax in modules gives more usable
- error messages; in particular, used but unimported FFI forms are
+ error messages; in particular, used but unimported FFI forms are
now detected
- invalid syntactic forms (mostly `()') encountered by the compiler
or interpreter show the contextual form containing the expression,
@@ -1768,10 +1875,10 @@
- added new option `-feature FEATURE' to `chicken-install' tool
to pass feature-identifiers to invocations of `csc'
- removed deprecated `-host-extension' option from `chicken-install'
-- `chicken-status' in a system built for cross-compilation now
+- `chicken-status' in a system built for cross-compilation now
lists extensions installed in the target prefix, unless the
new `-host' option is given on the command line
-- `chicken-uninstall' in a system built for cross-compilation now
+- `chicken-uninstall' in a system built for cross-compilation now
removes extensions installed in the target prefix, unless the
new `-host' option is given on the command line
- added missing entry for `finite?' to the `chicken' module
@@ -1821,12 +1928,12 @@
- fixed handling of VARDIR in `chicken-install' (thanks to
Davide Puricelli)
- `chicken-install -test' doesn't runs tests for dependencies
-- when a non-else clause follows an else-clause in `cond',
+- when a non-else clause follows an else-clause in `cond',
`case' or `select' a warning (note) is shown in verbose
mode
- removed the deprecated `define-extension' and
`define-compiled-syntax'
-- `chicken-uninstall' now always asks before removing
+- `chicken-uninstall' now always asks before removing
extensions, unless `-force' is given
- improved performance of keyword-argument processing slightly
- `export' outside of a module definition has no effect
@@ -1900,7 +2007,7 @@
`chicken-status' that prevented collapsed command-line
options to be handled correctly.
- disabled runpath-fix for deployed applications for netbsd
- (but resurrected providing a runpath at all, thanks to
+ (but resurrected providing a runpath at all, thanks to
Peter Bex)
- Peter Bex provided documentation for the `C_closure' C API
function
@@ -1954,7 +2061,7 @@
building/installing dependencies
- `chicken-uninstall' takes a glob instead of a regular expression as
argument
-- the rename and compare functions for low-level macro-definitions
+- the rename and compare functions for low-level macro-definitions
accept now arbitrary s-expressions and renames/compares them recursively
- `number->string' handles negative-numbers with bases different from 10
correctly (thanks to Peter Danenberg)
@@ -1998,7 +2105,7 @@
- added `fpinteger?' and `fpabs'
- deprecated `define-compiled-syntax'
- added new floating-point primitives `fpsin', `fpcos', `fptan',
- `fpasin', `fpacos', `fpatan', `fpatan2', `fpexp', `fplog',
+ `fpasin', `fpacos', `fpatan', `fpatan2', `fpexp', `fplog',
`fpexpt' and `fpsqrt'
- heavy cleanup of floating math functions which gives much better performance,
especially for code compiled in unsafe mode
@@ -2036,7 +2143,7 @@
to each matched item (contributed by Tony Sidaway)
- added extension-property `import-only', which makes it possible to
create extensions that have no runtime part
-- the argument to `seconds->string', `seconds->utc-time' and
+- the argument to `seconds->string', `seconds->utc-time' and
`seconds->local-time' is now optional and defaults to the value
of `(current-seconds)' (suggested by Mario Goulart)
- removed read-syntax for `syntax' form
@@ -2045,7 +2152,7 @@
- TCP timeouts throw exception of kind `timeout' to allow
distinguishing between timeouts and other errors
- removed some internal functions that manipulate environments
-- fixed bugs in `standard-extension' (`setup-api' module) and added keyword
+- fixed bugs in `standard-extension' (`setup-api' module) and added keyword
arguments for building static extensions and adding custom properties
- when cross-compiling, `chicken-install(1)' doesn't pass `-setup-mode'
(the host tools should not attempt to load target binaries)
@@ -2120,14 +2227,14 @@
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
+- 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
+- removed texinfo and PDF documentation - this will possible be added back
later
- replaced PCRE regex engine with Alex Shinn's "irregex" regular expression
package
@@ -2148,7 +2255,7 @@
- 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
+- 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
@@ -2157,7 +2264,7 @@
andmap ormap
byte-vector? byte-vector-fill!
make-byte-vector byte-vector
- byte-vector-set! byte-vector-ref
+ byte-vector-set! byte-vector-ref
byte-vector->list list->byte-vector
string->byte-vector byte-vector->string
byte-vector-length
diff --git a/README b/README
index fb41d26d..7b80992c 100644
--- a/README
+++ b/README
@@ -1,11 +1,11 @@
-
- _/_/_/ _/ _/ _/_/_/ _/_/_/ _/ _/ _/_/_/_/ _/ _/
- _/ _/ _/ _/ _/ _/ _/ _/ _/_/ _/
- _/ _/_/_/_/ _/ _/ _/_/ _/_/_/ _/ _/ _/
-_/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
- _/_/_/ _/ _/ _/_/_/ _/_/_/ _/ _/ _/_/_/_/ _/ _/
+
+ _/_/_/ _/ _/ _/_/_/ _/_/_/ _/ _/ _/_/_/_/ _/ _/
+ _/ _/ _/ _/ _/ _/ _/ _/ _/_/ _/
+ _/ _/_/_/_/ _/ _/ _/_/ _/_/_/ _/ _/ _/
+_/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
+ _/_/_/ _/ _/ _/_/_/ _/_/_/ _/ _/ _/_/_/_/ _/ _/
@@ -16,7 +16,7 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
(c) 2008-2022, The CHICKEN Team
(c) 2000-2007, Felix L. Winkelmann
- version 5.4.1
+ version 6.0.0
1. Introduction
@@ -53,48 +53,64 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
2. Installation
Building CHICKEN requires GNU Make. Other "make" derivates are
- not supported. If you are using a Windows system and do not
- have GNU Make, download
- http://www.call-with-current-continuation.org/tarballs/UnxUtils.zip.
- It contains a precompiled set of UNIX utilities, which among
- other useful tools contains "make".
+ not supported.
- 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.
+ Configuration and customization of the build process is done by
+ either using the "configure" script, setting makefile variables
+ on the "make" command line or by editing the platform-specific
+ makefile.
2.1. Building from a release tarball
To build CHICKEN, first extract the archive ("tar xzf
chicken-<version>.tar.gz" on UNIX or use your favorite
extraction program on Windows), then change to the
- chicken-<version> directory and invoke "make" like this:
+ chicken-<version> directory and invoke "configure" like this:
- make PLATFORM=<platform> PREFIX=<destination>
+ ./configure [OPTION ...]
+
+ This will overwrite a configuration file for the subsequent
+ "make" invocation that builds the CHICKEN tools and libraries.
+ Enter "./configure --help" to see the available options.
+ Usually you want to set the installation prefix where the
+ results of the build should be installed:
+
+ ./configure --prefix $HOME/.local
+
+ If not given, the installation prefix defaults to "/usr/local".
+ You can also define the build platform and whether you want to
+ build with debug-information, in addition to other specialized
+ settings. The platform is determined automatically if not
+ specified.
+
+ Once you have configured the system you can start building it
+ by entering
- 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".
+ make
- If you enter "make" without the PLATFORM option, CHICKEN will
- attempt to figure out what platform you are using. If it cannot
- do so, you will see a list of supported platforms. If you are
- cross-building, you must specify PLATFORM; for example,
- PLATFORM=cross-linux-mingw will build CHICKEN on Linux to
- deploy on Windows.
+ Note that GNU make is currently required, so use
+
+ gmake
+
+ On systems that use BSD make.
+
+ The old style invocation of "make" is still supported, where
+ you pass platform and prefix information on the make command
+ line, like this:
+
+ make PLATFORM=<platform> PREFIX=<destination>
+
+ Out-of-directory builds are currently not supported, so you must
+ be in the toplevel source directory to invoke "configure" and
+ "make".
If CHICKEN somehow detects the wrong platform, type
- make PLATFORM=""
+ ./configure --platform=list
- to get a list of available platforms, and re-run "make" using
+ to get a list of available platforms, and re-run "configure" using
the correct platform.
- Note that parallel builds (using the "-j" make(1) option) are
- *not* supported.
-
If you invoke "make" later with different configuration parameters,
it is advisable to run:
@@ -109,6 +125,21 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
generate the compiled C files from the Scheme library sources.
See section 2.1 for platform detection issues.
+ Configuration is the same as when building from the distribution
+ tarball. You may have to use the "--chicken" option to define
+ which "chicken" compiler binary should be used to translate the
+ Scheme source code in the repository:
+
+ ./configure --prefix ... --chicken <install-dir>/bin/chicken
+
+ If you do not want to use the "configure" script, create an empty
+ "config.make", like this:
+
+ touch config.make
+
+ "Config.make" is required by the build process, even if it
+ contains no settings.
+
If you are building in a checkout where you have built other
versions of chicken, you need to make sure that all traces of
the previous build are removed. "make clean" is insufficient,
@@ -124,10 +155,6 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
recommended, if necessary you can install it to a temporary
location in your homedir for example.
- Then, to build you can run:
-
- make CHICKEN=<install-dir>/bin/chicken
-
In some cases, the sources may have diverged enough to
become unbuildable even with the snapshot. Then you'll need
to first build a bootstrapping compiler with the installed
@@ -139,26 +166,18 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
If CHICKEN is built successfully, you can install it on your
system by entering
- make 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.
+ make install
- 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.
+ To install CHICKEN for a particular prefix on a different
+ location, set the "DESTDIR" variable: It designates the
+ directory where the files are installed into.
2.4. Verifying your installation is correct
You can check whether CHICKEN is functioning correctly by
running
- make <vars> check
-
- where <vars> are all the variables you used while building
- CHICKEN.
+ make check
This will run the test scripts, which show a lot of output.
The only thing that matters is the exit status at the end.
@@ -170,40 +189,32 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
2.5. Optional features
You can further enable various optional features by adding
- one or more of the following variables to the "make"
+ one or more of the following variables to the "configure"
invocation:
- DEBUGBUILD=1
+ --debugbuild
Disable optimizations in compiled C code and enable
debug information.
- STATICBUILD=1
+ --staticbuild
Build only static versions of the runtime library, compiler
and interpreter.
- EXTRA_CHICKEN_OPTIONS=...
- Additional options that should be passed to `chicken' when
- building the system.
-
- 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
+ --program-prefix 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=
+ --program-suffix SUFFIX
A suffix to be appended to the names of all generated executables.
- HOSTSYSTEM=
+ --host SYSTEM
A "<machine>-<platform>" name prefix to use for the C compiler 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=
+ --target SYSTEM
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
@@ -214,40 +225,28 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
process and the variables that you should set are provided
in the manual (see the "Cross development" chapter).
- SRCDIR=
+ --srcdir DIRECTORY
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=
+ --vardir DIRECTORY
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.
- CONFIG=
- If you build CHICKEN often, passing all those make variables
- can get annoying. An alternative is to create a configuration
- file defining the required variables and passing
- "CONFIG=<configfile>" to make(1).
- Even simpler is editing the included "config.make"
- and just invoke make(1) without any extra parameters.
-
- C_COMPILER=
- You can select an alternative compiler by setting this variable.
- The default compiler is "gcc". CHICKEN can be built with the
- LLVM version of gcc and with "clang", the LLVM-based C compiler,
- just set C_COMPILER to "llvm-gcc" or "clang".
-
- LINKER=
- Selects the linker to be used for creating executables and
- dynamic libraries from compiled C code. This should normally
- be the same as C_COMPILER.
-
- PROFILE_OBJECTS=
- This variable allows you to profile (parts of) CHICKEN itself.
+ --c-compiler PROGRAM
+ If set, determines the C compiler used to compiler C sources.
+
+ --linker PROGRAM
+ Determines the executable used for linking compiled object files,
+ usually the same as the C compiler executable.
+
+ --profile-object "FILENAME ..."
+ This option allows you to profile (parts of) CHICKEN itself.
Just pass in a whitespace-separated list of objects, without
the .scm-extension. (An "object" here is an individual
.scm-file which gets compiled to a .c-file)
@@ -255,12 +254,26 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
Be warned that this is a highly experimental option and
profiling doesn't work for every component of CHICKEN.
+ The "configure" script respects the "CC" and "CFLAGS" environment
+ variables which allow overriding the C compiler to use and any
+ additional C compiler flags that should be used when compiling
+ the runtime system and C files generated by "chicken".
+
+ The default compiler is "gcc" ("cc" on *BSD systems). CHICKEN
+ can be built with the LLVM version of gcc and with "clang",
+ the LLVM-based C compiler, just set C_COMPILER to "llvm-gcc"
+ or "clang". CHICKEN has also been successfully built with "zig cc",
+ the C frontend of the "Zig" language toolchain.
+
+ Less frequently used settings are available by variables that can
+ be passed on the "make" command line:
+
2.6. Uninstalling CHICKEN
To remove CHICKEN from your file-system, enter (probably as
root):
- make PREFIX=<destination> uninstall
+ make uninstall
(If you gave DESTDIR during installation, you have to pass
the same setting to "make" when uninstalling)
@@ -270,7 +283,7 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
These files will be installed under the prefix given during
build and installation:
- <PREFIX>
+ <PREFIX>
|-- bin
| |-- chicken
| |-- chicken-install
@@ -279,19 +292,17 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
| |-- chicken-uninstall
| |-- libchicken.dll (Windows)
| |-- csc
- | |-- csi
- | |-- feathers.bat (Windows)
- | `-- feathers (Unix)
+ | `-- csi
|-- include
| `-- chicken
| |-- chicken-config.h
| `-- chicken.h
|-- lib
| |-- chicken
- | | `-- 9
+ | | `-- 12
| | |-- chicken.base.import.so
| | |-- chicken.bitwise.import.so
- | | |-- chicken.blob.import.so
+ | | |-- chicken.bytevector.import.so
| | |-- chicken.compiler.user-pass.import.so
| | |-- chicken.condition.import.so
| | |-- chicken.continuation.import.so
@@ -331,25 +342,28 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
| | |-- chicken.tcp.import.so
| | |-- chicken.time.import.so
| | |-- chicken.time.posix.import.so
+ | | |-- scheme.file.import.so
+ | | |-- scheme.process-context.import.so
+ | | |-- scheme.time.import.so
+ | | |-- scheme.write.import.so
| | |-- modules.db
| | |-- srfi-4.import.so
| | `-- types.db
- | |-- libchicken.a
+ | |-- libchicken-static.a
| |-- libchicken.dll.a (Windows)
| |-- libchicken.dylib (Macintosh)
- | |-- libchicken.so -> libchicken.so.11 (Unix)
- | `-- libchicken.so.11 (Unix)
+ | |-- libchicken.so -> libchicken.so.12 (Unix)
+ | `-- libchicken.so.12 (Unix)
`-- share
|-- chicken
| |-- doc
| | |-- LICENSE
| | |-- README
| | |-- DEPRECATED
- | | |-- manual-html
| | |-- chicken.png
- | | `-- *.html
+ | | |-- manual-html
+ | | `-- *.html
| |-- chicken.rc.o (Windows)
- | |-- feathers.tcl
| `-- setup.defaults
`-- man
`-- man1
@@ -359,8 +373,7 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
|-- chicken-uninstall.1
|-- chicken.1
|-- csc.1
- |-- csi.1
- `-- feathers.1
+ `-- csi.1
3. Usage
@@ -384,11 +397,11 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
are also available at:
<http://www.call-with-current-continuation.org/tarballs/>.
-
+
5. Platform issues
- Android:
-
+ Android:
+
- The Android SDK and NDK are required. Make sure you have
set up a project and have a suitable NDK toolchain
available. You will have to override the make(1) variable
@@ -439,26 +452,25 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
Note that this may cause build-problems, if you already have
an existing CHICKEN installation in the /usr/pkg prefix.
- Linux:
+ Linux:
- If you want to build Linux binaries which use the "X32 ABI",
you can pass ARCH=x32 on the Make command line.
- - There have been reports where the library directory
+ - There have been reports where the library directory
"/usr/lib64" could not be found at build-time on a Fedora
12 system. If you build a 64-bit version of CHICKEN and
the library directory is set incorrectly, you can override
it by passing "LIBDIR=/usr/lib64" as an additional
argument when you invoke "make".
- Solaris:
+ Solaris:
- By default, CHICKEN is build with the GNU C compiler (`gcc').
- To use the SunPro C compiler (`cc') instead, pass
-
- C_COMPILER=cc
+ To use the SunPro C compiler (`cc') instead, override the
+ used compiler like this:
- to the "make" invocation.
+ CC=cc ./configure ...
- Older versions of Solaris have a bug in ld.so that causes
trouble with dynamic loading. Patching Solaris fixes the
@@ -473,7 +485,7 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
Mac OS X:
- - The build currently assumes the C toolchain is in the path,
+ - The build currently assumes the C toolchain is in the path,
use the "xcode-select(1)" tool to make them available on the
command line if you haven't already done so.
@@ -511,68 +523,65 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
- On 10.3 and earlier, you must first install `dlcompat'
which can be found at http://distfiles.macports.org/dlcompat/.
+ iOS:
- iOS:
-
- - Make sure the "XCODE_PATH" setting is correct (see
- Makefile.ios), it defaults to "/Applications/Xcode.app".
+ - Make sure the "XCODE_PATH" setting is correct (see
+ Makefile.ios), it defaults to "/Applications/Xcode.app".
- - The paths for the various build tools changed between
- Xcode 4 and 5. The makefile used for iOS builds of CHICKEN
- assume Xcode 5 is used. If you are using Xcode 4, override
- the XCODE_TOOLPATH and C_COMPILER make-variables providing
- the correct paths, see Makefile.ios for suggestions.
+ - The paths for the the various build tools changed between
+ Xcode 4 and 5. The makefile used for iOS builds of CHICKEN
+ assume Xcode 5 is used. If you are using Xcode 4, override
+ the XCODE_TOOLPATH and C_COMPILER make-variables providing
+ the correct paths, see Makefile.ios for suggestions.
- - The iOS build is static (iOS doesn't support dynamic
- loading of executable code). Only the runtime library
- (libchicken.a) is of interest. To use it, integrate
- libchicken.a in your Xcode project and use a normal MacOS
- build to compile your Scheme sources into C files, adding
- them to you project.
+ - The iOS build is static (iOS doesn't support dynamic
+ loading of executable code). Only the runtime library
+ (libchicken.a) is of interest. To use it, integrate
+ libchicken.a in your Xcode project and use a normal MacOS
+ build to compile your Scheme sources into C files, adding
+ them to you project.
- - Core library units must by accessed via "(declare (uses
- ...))" and "(import ...)", "require", "require-library",
- "require-extension" and "use" will not work, due to the
- reasons mentioned above.
+ - Core library units must by accessed via "(declare (uses
+ ...))" and "(import ...)", "require", "require-library",
+ "require-extension" and "use" will not work, due to the
+ reasons mentioned above.
- - As dynamic loading is not supported, eggs can not be used
- as usual, you will have to compile them manually and
- integrate what you need into your project.
+ - As dynamic loading is not supported, eggs can not be used
+ as usual, you will have to compile them manually and
+ integrate what you need into your project.
- - If you want to build for the iPhone Simulator, override
- the ARCH and XCODE_SDK variables accordingly, see also in
- Makefile.ios for suggestions.
+ - If you want to build for the iPhone Simulator, override
+ the ARCH and XCODE_SDK variables accordingly, see also in
+ Makefile.ios for suggestions.
Windows:
- - On Windows, mingw32, <http://mingw.sourceforge.net/> and
+ - On Windows, native builds using the "MingW" toolchain and
Cygwin are supported (Microsoft Visual Studio is *NOT*).
- Makefiles for mingw under MSYS and the Windows shell are
- provided (`Makefile.mingw-msys' and `Makefile.mingw').
+ Makefiles for MingW are provided (`Makefile.MingW').
+ GNU make and a POSIX sh(1) are required to build the system.
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), for example
- "PREFIX=C:/chicken/".
+ - Since there are various distributions of the MingW toolchain
+ we recommend to use "w64devkit" by Chrstopher Wellons:
- - When installing under mingw, with a windows shell
- ("cmd.exe"), pass an absolute pathname (including the
- drive letter) as PREFIX and use forward slashes. If you
- are building the sources from git, use backslashes to
- specify the path to `chicken' (the "CHICKEN" variable).
+ https://github.com/skeeto/w64devkit
- - 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.
+ This toolset is very complete, includes GNU make and a
+ POSIX shell and is the development environment we use to
+ test CHICKEN. Other distributions of MingW may work but
+ are not tested by us.
- - 64-bit Windows is supported, invoke mingw32-make with the
- "ARCH=x86-64" argument (this is currently not detected
- automatically). The build has been tested on Windows 7
- with the SJLJ binary package from "MinGW-builds", which
- can be found here:
+ - When installing under the MingW platform, PREFIX must be an
+ absolute path name (i.e. it must include the drive letter) and
+ must use forward slashes (no backward slashes), for example
+
+ ./configure --prefix C:/chicken/
- http://sourceforge.net/projects/mingwbuilds/
+ - Under MingW, the "csc" compiler driver and "chicken-install"
+ expect the compiler executable and the usual UNIX tools are
+ in the PATH, so make sure to run them inside a shell that
+ provides the necessary stuff.
- Cygwin will not be able to find the chicken shared libraries
until Windows is rebooted.
@@ -645,17 +654,17 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
To build a bootstrapping compiler yourself, get the most
recent development snapshot tarball from
- http://code.call-cc.org, unpack it, build and install it.
+ http://code.call-cc.org, unpack it, build and install everything.
Then change to the directory containing the git code and run:
- make CHICKEN=<path-to-existing-chicken> \
- boot-chicken
+ ./configure --chicken <path-to-existing-chicken>
+ make boot-chicken
- This will produce a statically linked binary with the name
- "chicken-boot[.exe]" that can be given as the value of the
- "CHICKEN" argument when invoking make(1). Note that the path
- to an existing `chicken' binary must be given to use it for
- compiling the Scheme code of the runtime-system and compiler.
+ This will produce a statically linked binary with the name
+ "chicken-boot[.exe]" that can be given as the value of the
+ "--chicken" configuration option. Note that the path to an
+ existing `chicken' binary must be given to use it for
+ compiling the Scheme code of the runtime-system and compiler.
"scripts/bootstrap.sh" automates this process; use this script
if you are unsure how to build from the repository sources. It
@@ -663,7 +672,7 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
builds the boot-chicken that you can use to compile the
development sources. The invocation is:
- scripts/bootstrap.sh ...
+ ./scripts/bootstrap.sh ...
You can add additional parameters if you like to customize the
build, but this should not be necessary. Note that your current
@@ -674,6 +683,11 @@ _/ _/ _/ _/ _/ _/ _/ _/ _/ _/_/
make CHICKEN=./chicken-boot ...
+ or run "configure" again:
+
+ ./configure --chicken ./chicken-boot ...
+ make
+
7. Emacs support
diff --git a/batch-driver.scm b/batch-driver.scm
index 95a41096..3afdb949 100644
--- a/batch-driver.scm
+++ b/batch-driver.scm
@@ -8,11 +8,11 @@
; conditions are met:
;
; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-; disclaimer.
+; 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.
+; 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.
+; 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
@@ -78,7 +78,7 @@
(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 "; known call sites: \t~s\n" sites)
(printf "; database entries: \t~s\n" entries) ) ) )
;;; Initialize analysis database:
@@ -117,11 +117,11 @@
(undefined . und) (replacing . rpg) (unused . uud) (extended-binding . xtb)
(inline-export . ilx) (hidden-refs . hrf)
(value-ref . vvf)
- (customizable . cst) (has-unused-parameters . hup) (boxed-rest . bxr) ) )
+ (customizable . cst) (has-unused-parameters . hup) (boxed-rest . bxr) ) )
(omit #f))
(lambda (db)
(unless omit
- (set! omit
+ (set! omit
(append default-standard-bindings
default-extended-bindings
internal-bindings) ) )
@@ -200,7 +200,7 @@
(let* ((dynamic (memq 'dynamic options))
(unit (memq 'unit options))
(init-forms `((##core#declare
- ,@(append
+ ,@(append
default-declarations
(if emit-debug-info
'((uses debugger-client))
@@ -283,8 +283,8 @@
(define (print-expr mode dbgmode xs)
(when (print-header mode dbgmode)
- (for-each
- (lambda (x)
+ (for-each
+ (lambda (x)
(pretty-print x)
(newline))
xs) ) )
@@ -298,12 +298,12 @@
((char-whitespace? (string-ref str (sub1 back)))
(loop front (sub1 back)))
(else (substring str front back)))))
-
+
(define (string->extension-name str)
(let ((str (string-trim str)))
(if (and (positive? (string-length str))
(char=? #\( (string-ref str 0)))
- (handle-exceptions ex
+ (handle-exceptions ex
(##sys#error "invalid import specification" str)
(with-input-from-string str read))
(string->symbol str))))
@@ -329,7 +329,7 @@
(define (end-time pass)
(when time-breakdown
- (printf "milliseconds needed for ~a: \t~s~%"
+ (printf "milliseconds needed for ~a: \t~s~%"
pass
(inexact->exact (round (- (cputime) time0)) ) )))
@@ -370,7 +370,7 @@
(set! dumpnodes (memq '|D| debugging-chicken))
(set! import-libraries
(map (lambda (il)
- (cons (string->symbol il)
+ (cons (string->symbol il)
(string-append il ".import.scm")))
(collect-options 'emit-import-library)))
(when (and (memq 'emit-all-import-libraries options)
@@ -400,12 +400,12 @@
(when (memq 'strict-types options)
(set! strict-variable-types #t)
(set! enable-specialization #t))
- (when (memq 'no-warnings options)
+ (when (memq 'no-warnings options)
(dribble "Warnings are disabled")
- (set! ##sys#warnings-enabled #f)
+ (set! ##sys#warnings-enabled #f)
(set! do-scrutinize #f)) ; saves some processing time
(when (memq 'optimize-leaf-routines options) (set! optimize-leaf-routines #t))
- (when (memq 'unsafe options)
+ (when (memq 'unsafe options)
(set! unsafe #t) )
(when (memq 'setup-mode options)
(set! ##sys#setup-mode #t))
@@ -426,7 +426,7 @@
(and-let* ((tfile (memq 'emit-types-file options)))
(set! types-output-file (option-arg tfile)))
(and-let* ([inlimit (memq 'inline-limit options)])
- (set! inline-max-size
+ (set! inline-max-size
(let ([arg (option-arg inlimit)])
(or (string->number arg)
(quit-compiling
@@ -437,7 +437,7 @@
(or (string->number arg)
(quit-compiling
"invalid argument to `-unroll-limit' option: `~A'" arg) ) ) ) )
- (when (memq 'case-insensitive options)
+ (when (memq 'case-insensitive options)
(dribble "Identifiers and symbols are case insensitive")
(register-feature! 'case-insensitive)
(case-sensitive #f) )
@@ -451,15 +451,11 @@
(when (memq 'no-parentheses-synonyms options)
(dribble "Disabled support for parentheses synonyms")
(parentheses-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")
+ (when (memq 'r7rs-syntax options)
+ (dribble "Disabled the CHICKEN extensions to R7RS syntax")
(case-sensitive #f)
(keyword-style #:none)
- (parentheses-synonyms #f)
- (symbol-escape #f) )
+ (parentheses-synonyms #f))
(set! ##sys#read-error-with-line-number #t)
(set! ##sys#include-pathnames
(append (map chop-separator (collect-options 'include-path))
@@ -477,12 +473,12 @@
(when (memq 'no-procedure-checks-for-toplevel-bindings options)
(set! no-global-procedure-checks #t) )
(when (memq 'no-procedure-checks-for-usual-bindings options)
- (for-each
+ (for-each
(lambda (v)
(mark-variable v '##compiler#always-bound-to-procedure)
(mark-variable v '##compiler#always-bound) )
default-standard-bindings)
- (for-each
+ (for-each
(lambda (v)
(mark-variable v '##compiler#always-bound-to-procedure)
(mark-variable v '##compiler#always-bound) )
@@ -490,10 +486,10 @@
(when (memq 'p debugging-chicken) (load-verbose #t))
;; Handle feature options:
- (for-each
+ (for-each
register-feature!
(append-map (cut string-split <> ", ") (collect-options 'feature)))
- (for-each
+ (for-each
unregister-feature!
(append-map (cut string-split <> ",") (collect-options 'no-feature)))
@@ -578,7 +574,7 @@
((or (memq 'help options) (memq '-help options) (memq 'h options) (memq '-h options))
(print-usage))
((memq 'release options)
- (display (chicken-version))
+ (display (chicken-version))
(newline) )
((not filename)
(print-version #t)
@@ -598,8 +594,8 @@
;; 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
+ [postlude (collect-options 'postlude)]
+ [files (append
(collect-options 'prologue)
(list filename)
(collect-options 'epilogue) ) ] )
@@ -621,7 +617,7 @@
(let loop ()
(let ((x (chicken.syntax#read-with-source-info in))) ; OBSOLETE - after bootstrapping we can get rid of this explicit namespacing
- (cond ((eof-object? x)
+ (cond ((eof-object? x)
(close-checked-input-file in f) )
(else
(set! forms (cons x forms))
@@ -676,7 +672,7 @@
'S
(lambda ()
(print "applied compiler syntax:")
- (for-each
+ (for-each
(lambda (cs) (printf " ~a\t\t~a~%" (car cs) (cdr cs)))
compiler-syntax-statistics))))
(when (debugging '|N| "real name table:")
@@ -721,7 +717,7 @@
(let ((ifs (collect-options 'consult-inline-file)))
(unless (null? ifs)
(set! inline-locally #t)
- (for-each
+ (for-each
(lambda (ilf)
(dribble "Loading inline file ~a ..." ilf)
(load-inline-file ilf) )
@@ -734,7 +730,7 @@
enable-specialization)
(quit-compiling
"default type-database `types.db' not found")))
- (for-each
+ (for-each
(lambda (fn)
(or (load-type-database fn enable-specialization #f)
(quit-compiling "type-database `~a' not found" fn)))
@@ -801,7 +797,7 @@
(end-time "analysis")
(print-db "analysis" '|4| db i)
- (when (memq 's debugging-chicken)
+ (when (memq 's debugging-chicken)
(print-program-statistics db))
;; Optimize (once)
@@ -835,14 +831,14 @@
(let ((progress
(transform-direct-lambdas! node2 db)))
(end-time "leaf routine optimization")
- (loop (add1 i)
+ (loop (add1 i)
node2
progress
#f
l/d-done) ) ) )
(else
(loop (add1 i) node2 #f #f l/d-done)) ) ) )
-
+
(else
;; Secondary flow-analysis
(when do-lfa2
diff --git a/buildversion b/buildversion
index ade65226..09b254e9 100644
--- a/buildversion
+++ b/buildversion
@@ -1 +1 @@
-5.4.1
+6.0.0
diff --git a/c-backend.scm b/c-backend.scm
index 50c4aa55..b0e72336 100644
--- a/c-backend.scm
+++ b/c-backend.scm
@@ -8,11 +8,11 @@
; conditions are met:
;
; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-; disclaimer.
+; 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.
+; 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.
+; 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
@@ -50,6 +50,7 @@
chicken.compiler.core
chicken.compiler.c-platform
chicken.compiler.support)
+(import (only (scheme base) open-output-string get-output-string))
(include "mini-srfi-1.scm")
@@ -59,10 +60,9 @@
(define (gen . data)
(for-each
- (lambda (x)
- (if (eq? #t x)
- (newline output)
- (display x output) ) )
+ (lambda (x)
+ (cond ((eq? #t x) (newline output))
+ (else (display x output) ) ))
data) )
(define (gen-list lst)
@@ -121,10 +121,10 @@
((bwp) (gen "C_SCHEME_BROKEN_WEAK_PTR"))
(else (bomb "bad immediate")) ) )
- ((##core#literal)
+ ((##core#literal)
(let ((lit (first params)))
(if (vector? lit)
- (gen "((C_word)li" (vector-ref lit 0) ")")
+ (gen "((C_word)li" (vector-ref lit 0) ")")
(gen "lf[" (first params) #\])) ) )
((##core#float)
@@ -148,12 +148,12 @@
((##core#proc)
(gen "(C_word)" (first params)) )
- ((##core#bind)
+ ((##core#bind)
(let loop ((bs subs) (i i) (count (first params)))
(cond [(> count 0)
(gen #t #\t i #\=)
(expr (car bs) i)
- (gen #\;)
+ (gen #\;)
(loop (cdr bs) (add1 i) (sub1 count)) ]
[else (expr (car bs) i)] ) ) )
@@ -177,7 +177,7 @@
(expr (first subs) i)
(gen ")"))
- ((##core#ref)
+ ((##core#ref)
(gen "((C_word*)")
(expr (car subs) i)
(gen ")[" (+ (first params) 1) #\]) )
@@ -209,7 +209,7 @@
(gen "C_fix(c - " (+ depth n) ")")
(gen "C_u_i_length(t" (sub1 n) ")"))))
- ((##core#unbox)
+ ((##core#unbox)
(gen "((C_word*)")
(expr (car subs) i)
(gen ")[1]") )
@@ -218,34 +218,34 @@
(gen "C_set_block_item(")
(expr (car subs) i)
(gen #\, (first params) #\,)
- (expr (cadr subs) i)
+ (expr (cadr subs) i)
(gen #\)) )
((##core#update)
(gen "C_mutate(((C_word *)")
(expr (car subs) i)
(gen ")+" (+ (first params) 1) ",")
- (expr (cadr subs) i)
+ (expr (cadr subs) i)
(gen #\)) )
((##core#updatebox_i)
(gen "C_set_block_item(")
(expr (car subs) i)
(gen ",0,")
- (expr (cadr subs) i)
+ (expr (cadr subs) i)
(gen #\)) )
((##core#updatebox)
(gen "C_mutate(((C_word *)")
(expr (car subs) i)
(gen ")+1,")
- (expr (cadr subs) i)
+ (expr (cadr subs) i)
(gen #\)) )
((##core#closure)
(let ((n (first params)))
(gen "(*a=C_CLOSURE_TYPE|" n #\,)
- (for-each
+ (for-each
(lambda (x j)
(gen "a[" j "]=")
(expr x i)
@@ -253,63 +253,63 @@
subs (list-tabulate n add1))
(gen "tmp=(C_word)a,a+=" (add1 n) ",tmp)") ) )
- ((##core#box)
+ ((##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)
+ ((##core#setlocal)
(gen #\t (first params) #\=)
(expr (car subs) i) )
((##core#global)
(let ((index (first params))
- (safe (second params))
+ (safe (second params))
(block (third params)) )
(cond [block
(if safe
(gen "lf[" index "]")
(gen "C_retrieve2(lf[" index "],C_text("
- (c-ify-string (##sys#symbol->string
+ (c-ify-string (##sys#symbol->string/shared
(fourth params))) "))"))]
[safe (gen "*((C_word*)lf[" index "]+1)")]
[else (gen "C_fast_retrieve(lf[" index "])")] ) ) )
((##core#setglobal)
(let ((index (first params))
- (block (second 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 (##sys#symbol->string var)) " ...) */,")
+ (gen " /* (set! " (uncommentify (##sys#symbol->string/shared var)) " ...) */,")
(expr (car subs) i)
(gen #\)) ) )
((##core#setglobal_i)
(let ((index (first params))
- (block (second params))
+ (block (second params))
(var (third params)) )
(cond [block
(gen "lf[" index "] /* "
- (uncommentify (##sys#symbol->string var)) " */ =")
+ (uncommentify (##sys#symbol->string/shared var)) " */ =")
(expr (car subs) i)
(gen #\;) ]
[else
(gen "C_set_block_item(lf[" index "] /* "
- (uncommentify (##sys#symbol->string var)) " */,0,")
+ (uncommentify (##sys#symbol->string/shared var)) " */,0,")
(expr (car subs) i)
(gen #\)) ] ) ) )
((##core#undefined) (gen "C_SCHEME_UNDEFINED"))
- ((##core#call)
+ ((##core#call)
(let* ((args (cdr subs))
(n (length args))
(nc i)
- (nf (add1 n))
+ (nf (add1 n))
(dbi (first params))
(safe-to-call (second params))
(p2 (pair? (cddr params)))
@@ -339,7 +339,7 @@
(for-each
(lambda (arg tr)
(gen #t #\t tr #\=)
- (expr arg i)
+ (expr arg i)
(gen #\;) )
args ts)
(for-each
@@ -364,13 +364,13 @@
(unless customizable (gen nf #\,))
(gen "av2);}") ) ) )))
((and (eq? '##core#global (node-class fn))
- (not unsafe)
+ (not unsafe)
(not no-procedure-checks)
(not safe-to-call))
(let* ((gparams (node-parameters fn))
(index (first gparams))
- (safe (second gparams))
- (block (third gparams))
+ (safe (second gparams))
+ (block (third gparams))
(carg #f))
(gen #t "{C_proc tp=(C_proc)")
(cond (no-global-procedure-checks
@@ -384,13 +384,13 @@
(if safe
(gen "C_fast_retrieve_proc(" carg ")")
(gen "C_retrieve2_symbol_proc(" carg ",C_text("
- (c-ify-string (##sys#symbol->string (fourth gparams))) "))")))
+ (c-ify-string (##sys#symbol->string/shared (fourth gparams))) "))")))
(safe
- (set! carg
+ (set! carg
(string-append "*((C_word*)lf[" (number->string index) "]+1)"))
(gen "C_fast_retrieve_proc(" carg ")"))
(else
- (set! carg
+ (set! carg
(string-append "*((C_word*)lf[" (number->string index) "]+1)"))
(gen "C_fast_retrieve_symbol_proc(lf[" index "])") ))
(gen #\;)
@@ -406,12 +406,12 @@
(gen "(void*)(*((C_word*)t" nc "+1))")
(gen "C_fast_retrieve_proc(t" nc ")") )
(gen ")(" nf ",av2);}") ) ) ) )
-
- ((##core#recurse)
+
+ ((##core#recurse)
(let* ([n (length subs)]
[nf (add1 n)]
[tailcall (first params)]
- [call-id (second params)]
+ [call-id (second params)]
[empty-closure (zero? (lambda-literal-closure-size ll))] )
(cond (tailcall
(let* ((temps (lambda-literal-temporaries ll))
@@ -419,7 +419,7 @@
(for-each
(lambda (arg tr)
(gen #t #\t tr #\=)
- (expr arg i)
+ (expr arg i)
(gen #\;) )
subs ts)
(for-each
@@ -432,7 +432,7 @@
(expr-args subs i)
(gen #\)) ) ) ) )
- ((##core#direct_call)
+ ((##core#direct_call)
(let* ((args (cdr subs))
(n (length args))
(nf (add1 n))
@@ -454,7 +454,7 @@
(gen #t "C_debugger(&(C_debug_info[" dbi "]),"
(if non-av-proc "0,NULL" "c,av") "),")))
(gen #t " " call-id #\()
- (when allocating
+ (when allocating
(gen "C_a_i(&a," demand #\))
(when (or (not empty-closure) (pair? args)) (gen #\,)) )
(unless empty-closure
@@ -503,7 +503,7 @@
((##core#inline_update)
(let ([t (second params)])
- (gen #\( (first params) "=(" (foreign-type-declaration t "") #\) (foreign-argument-conversion t))
+ (gen #\( (first params) "=(" (foreign-type-declaration t "") #\) (foreign-argument-conversion t))
(expr (first subs) i)
(gen "),C_SCHEME_UNDEFINED)") ) )
@@ -518,7 +518,7 @@
(gen "((*(" (foreign-type-declaration t "") "*)C_data_pointer(")
(expr (first subs) i)
(gen "))=" (foreign-argument-conversion t))
- (expr (second subs) i)
+ (expr (second subs) i)
(gen "),C_SCHEME_UNDEFINED)") ) )
((##core#switch)
@@ -546,7 +546,7 @@
(gen #\)) )
(else (bomb "bad form" (node-class n))) ) ) )
-
+
(define (expr-args args i)
(let loop ((xs args))
(unless (null? xs)
@@ -599,7 +599,7 @@
(gen ";"))))
(expr node temps) )
-
+
(define (header)
(gen "/* Generated from " source-file " by the CHICKEN compiler" #t
" http://www.call-cc.org" #t
@@ -625,42 +625,42 @@
(generate-foreign-callback-stub-prototypes foreign-callback-stubs) ) )
(define (trailer)
- (gen #t #t "/*" #t
+ (gen #t #t "/*" #t
(uncommentify
(get-output-string
collected-debugging-output))
"*/"
#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 ")"
- #t "C_externimport void C_ccall C_" uu "(C_word c,C_word *av) C_noret;"))
+ #t "C_extern void C_ccall C_" uu "(C_word c,C_word *av) C_noret;"))
(map toplevel used-units))
(unless (zero? n)
- (gen #t #t "static C_TLS C_word lf[" n "];") )
+ (gen #t #t "static 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("
+ (let* ((ll (car llits))
+ (llen (##sys#size ll)))
+ (gen #t "static C_char 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))) )
+ (gen #\, (##sys#byte 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)
(gen #t)
(for-each
@@ -678,14 +678,12 @@
(gen "C_noret_decl(" id ")" #t)
(gen "static ")
(gen (if direct "C_word " "void "))
- (if customizable
- (gen "C_fcall ")
- (gen "C_ccall ") )
+ (unless customizable (gen "C_ccall "))
(gen id) )
(else
(let ((uname (toplevel unit-name)))
(gen "C_noret_decl(C_" uname ")" #t) ;XXX what's this for?
- (gen "C_externexport void C_ccall ")
+ (gen "C_extern void C_ccall ")
(gen "C_" uname) ) ) )
(gen #\()
(unless customizable (gen "C_word c,"))
@@ -699,10 +697,10 @@
(unless direct (gen " C_noret"))
(gen #\;) ))
lambda-table*) )
-
+
(define (trampolines)
(let ([ns '()]
- [nsr '()]
+ [nsr '()]
[nsrv '()] )
(define (restore n)
@@ -729,7 +727,7 @@
(apply gen (intersperse al #\,)) )
(gen ");}") )))
lambda-table*)))
-
+
(define (literal-frame)
(do ([i 0 (add1 i)]
[lits literals (cdr lits)] )
@@ -777,46 +775,29 @@
((block-variable-literal? lit))
((eq? lit (void))
(gen #t to "=C_SCHEME_UNDEFINED;") )
- ((boolean? lit)
+ ((boolean? lit)
(gen #t to #\= (if lit "C_SCHEME_TRUE" "C_SCHEME_FALSE") #\;) )
((char? lit)
(gen #t to "=C_make_character(" (char->integer lit) ");") )
((or (keyword? lit) (symbol? lit)) ; handled slightly specially (see C_h_intern_in)
- (let* ((str (##sys#slot lit 1))
+ (let* ((str (##sys#symbol->string/shared lit))
(cstr (c-ify-string str))
- (len (##sys#size str))
+ (len (fx- (##sys#size (##sys#slot lit 1)) 1))
(intern (if (keyword? lit)
"C_h_intern_kw"
"C_h_intern")))
(gen #t to "=")
(gen intern "(&" to #\, len ", C_text(" cstr "));")))
- ((null? lit)
+ ((null? lit)
(gen #t to "=C_SCHEME_END_OF_LIST;") )
((and (not (##sys#immediate? lit)) ; nop
(##core#inline "C_lambdainfop" lit)))
((or (fixnum? lit) (not (##sys#immediate? lit)))
- (gen #t to "=C_decode_literal(C_heaptop,C_text(")
- (gen-string-constant (encode-literal lit))
- (gen "));"))
+ (gen #t to "=C_decode_literal(C_heaptop,C_text(\"")
+ (gen (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 (p)
@@ -844,21 +825,19 @@
(when empty-closure (debugging 'o "dropping unused closure argument" id))
(gen #t #t)
(gen "/* " (cleanup rname) " */" #t)
- (cond [(not (eq? 'toplevel id))
+ (cond [(not (eq? 'toplevel id))
(gen "static ")
(gen (if direct "C_word " "void "))
- (if customizable
- (gen "C_fcall ")
- (gen "C_ccall ") )
+ (unless customizable (gen "C_ccall "))
(gen id) ]
[else
- (gen "static C_TLS int toplevel_initialized=0;")
+ (gen "static int toplevel_initialized=0;")
(unless unit-name
(gen #t "C_main_entry_point") )
(gen #t #t "void C_ccall C_" topname) ] )
(gen #\()
(unless customizable (gen "C_word c,"))
- (when (and direct (not (zero? demand)))
+ (when (and direct (not (zero? demand)))
(gen "C_word *a")
(when (pair? varlist) (gen #\,)) )
(if (or customizable direct)
@@ -1042,7 +1021,7 @@
;;; Create name that is safe for C comments:
(define (cleanup s)
- (let ([s2 #f]
+ (let ([s2 #f]
[len (string-length s)] )
(let loop ([i 0])
(if (>= i len)
@@ -1054,7 +1033,7 @@
(begin
(unless s2 (set! s2 (string-copy s)))
(string-set! s2 i #\~) )
- (when s2 (string-set! s2 i c)) )
+ (when s2 (string-set! s2 i c)) )
(loop (add1 i)) ) ) ) ) )
@@ -1064,7 +1043,7 @@
(list-tabulate
n
(lambda (i) (string-append "C_word " prefix (number->string i))) ) )
-
+
(define (make-argument-list n prefix)
(list-tabulate
n
@@ -1090,7 +1069,7 @@
(for-each
(lambda (stub)
(gen #t)
- (generate-foreign-callback-header "C_externexport " stub)
+ (generate-foreign-callback-header "C_extern " stub)
(gen #\;) )
stubs) )
@@ -1101,18 +1080,18 @@
[rname (real-name2 id db)]
[types (foreign-stub-argument-types stub)]
[n (length types)]
- [rtype (foreign-stub-return-type stub)]
- [sname (foreign-stub-name stub)]
+ [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")]
+ [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
+ (gen #t "#define return(x) C_cblock C_r = (" rconv
"(x))); goto C_ret; C_cblockend"))
(cond (cps
(gen #t "C_noret_decl(" id ")"
@@ -1122,14 +1101,14 @@
((>= i n))
(gen #t "C_word C_a" i "=C_av[" (+ i 3) "];")))
(else
- (gen #t "C_regparm static C_word C_fcall " id #\()
+ (gen #t "C_regparm static C_word " id #\()
(apply gen (intersperse (cons "C_word C_buf" (make-variable-list n "C_a")) #\,))
(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
+ (gen #t
+ (foreign-type-declaration
type
(if name (symbol->string name) (sprintf "t~a" index)) )
"=(" (foreign-type-declaration type "") #\)
@@ -1179,7 +1158,9 @@
((float double c-pointer nonnull-c-pointer
c-string-list c-string-list*)
(string-append ns "+3") )
- ((unsigned-integer unsigned-integer32 long integer integer32
+ ((complex cplxnum)
+ (string-append ns "+5") )
+ ((unsigned-integer unsigned-integer32 long integer integer32
unsigned-long number)
(string-append ns "+C_SIZEOF_FIX_BIGNUM"))
((unsigned-integer64 integer64 size_t ssize_t)
@@ -1190,11 +1171,11 @@
((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) (lookup-foreign-type type))
+ (cond ((and (symbol? type) (lookup-foreign-type type))
=> (lambda (t) (compute-size (vector-ref t 0) var ns) ) )
((pair? type)
(case (car type)
- ((ref pointer c-pointer nonnull-pointer nonnull-c-pointer function instance
+ ((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))
@@ -1204,7 +1185,7 @@
(let ((sizestr (let loop ((types argtypes) (vars vlist) (ns "0"))
(if (null? types)
ns
- (loop (cdr types) (cdr vars)
+ (loop (cdr types) (cdr vars)
(compute-size (car types) (car vars) ns))))))
(gen #t)
(when rname
@@ -1265,9 +1246,11 @@
((unsigned-long) (str "unsigned long"))
((float) (str "float"))
((double number) (str "double"))
+ ((complex cplxnum) (str "double complex"))
((c-pointer nonnull-c-pointer scheme-pointer nonnull-scheme-pointer) (str "void *"))
((c-string-list c-string-list*) "C_char **")
- ((blob nonnull-blob u8vector nonnull-u8vector) (str "unsigned char *"))
+ ((bytevector nonnull-bytevector u8vector nonnull-u8vector) (str "unsigned char *"))
+ ((blob nonnull-blob) (str "unsigned char *")) ; DEPRECATED
((u16vector nonnull-u16vector) (str "unsigned short *"))
((s8vector nonnull-s8vector) (str "signed char *"))
((u32vector nonnull-u32vector) (str "unsigned int *")) ;; C_u32?
@@ -1278,7 +1261,7 @@
((f32vector nonnull-f32vector) (str "float *"))
((f64vector nonnull-f64vector) (str "double *"))
((pointer-vector nonnull-pointer-vector) (str "void **"))
- ((nonnull-c-string c-string nonnull-c-string* c-string* symbol)
+ ((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 *"))
@@ -1290,9 +1273,9 @@
((string? type) (str type))
((list? type)
(let ((len (length type)))
- (cond
+ (cond
((and (= 2 len)
- (memq (car type) '(pointer nonnull-pointer c-pointer
+ (memq (car type) '(pointer nonnull-pointer c-pointer
scheme-pointer nonnull-scheme-pointer
nonnull-c-pointer) ) )
(foreign-type-declaration (cadr type) (string-append "*" target)) )
@@ -1302,7 +1285,7 @@
((and (> len 2)
(eq? 'template (car type)))
(str
- (string-append
+ (string-append
(foreign-type-declaration (cadr type) "")
"<"
(string-intersperse
@@ -1312,9 +1295,13 @@
((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))
+ (if (list? (cadr type))
+ (string-append (->string (caadr type)) " " target)
+ (string-append "struct " (->string (cadr type)) " " target)))
((and (= len 2) (eq? 'union (car type)))
- (string-append "union " (->string (cadr type)) " " target))
+ (if (list? (cadr type))
+ (string-append (->string (caadr type)) " " target)
+ (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)))
@@ -1331,10 +1318,10 @@
" (*" target ")("
(string-intersperse
(map (lambda (at)
- (if (eq? '... at)
+ (if (eq? '... at)
"..."
(foreign-type-declaration at "") ) )
- argtypes)
+ argtypes)
",")
")" ) ) )
(else (err)) ) ) )
@@ -1354,6 +1341,7 @@
((unsigned-short) "(unsigned short)C_unfix(")
((unsigned-long) "C_num_to_unsigned_long(")
((double number float) "C_c_double(")
+ ((complex cplxnum) "C_c_cplxnum(")
((integer integer32) "C_num_to_int(")
((integer64) "C_num_to_int64(")
((size_t) "(size_t)C_num_to_uint64(")
@@ -1365,10 +1353,10 @@
((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(")
- ((u8vector) "C_c_u8vector_or_null(")
- ((nonnull-u8vector) "C_c_u8vector(")
+ ((u8vector bytevector) "C_c_bytevector_or_null(")
+ ((nonnull-bytevector nonnull-u8vector) "C_c_bytevector(")
+ ((blob) "C_c_bytevector_or_null(") ; DEPRECATED
+ ((nonnull-blob) "C_c_bytevector(") ; DEPRECATED
((u16vector) "C_c_u16vector_or_null(")
((nonnull-u16vector) "C_c_u16vector(")
((u32vector) "C_c_u32vector_or_null(")
@@ -1390,7 +1378,7 @@
((pointer-vector) "C_c_pointer_vector_or_null(")
((nonnull-pointer-vector) "C_c_pointer_vector(")
((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-c-string nonnull-c-string* nonnull-unsigned-c-string
nonnull-unsigned-c-string* symbol) "C_c_string(")
((bool) "C_truep(")
(else
@@ -1408,6 +1396,10 @@
((function) "C_c_pointer_or_null(")
((const) (foreign-argument-conversion (cadr type)))
((enum) "C_num_to_int(")
+ ((struct union)
+ (if (list? (cadr type))
+ (sprintf "C_build_struct(~a," (caadr type))
+ (sprintf "C_build_struct(~a ~a," (car type) (cadr type))))
((ref)
(string-append "*(" (foreign-type-declaration (cadr type) "*")
")C_c_pointer_nn("))
@@ -1418,7 +1410,7 @@
;; Generate suitable conversion of a result value into Scheme data
-
+
(define (foreign-result-conversion type dest)
(let ((err (lambda ()
(quit-compiling "illegal foreign return type `~A'" type))))
@@ -1431,10 +1423,11 @@
((byte) "C_fix((char)")
((unsigned-byte) "C_fix(0xff&(C_word)")
((float double) (sprintf "C_flonum(&~a," dest)) ;XXX suboptimal for int64
+ ((complex cplxnum) (sprintf "C_inexact_cplxnum(&~a," dest))
((number) (sprintf "C_number(&~a," dest))
- ((nonnull-c-string c-string nonnull-c-pointer c-string* nonnull-c-string*
+ ((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*)
+ 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))
@@ -1455,6 +1448,10 @@
(sprintf "C_mpointer(&~A,(void*)" dest) )
((ref)
(sprintf "C_mpointer(&~A,(void*)&" dest) )
+ ((struct union)
+ (if (list? (cadr type))
+ (sprintf "C_a_extract_struct(&~A,~A," dest (caadr type))
+ (sprintf "C_a_extract_struct(&~A,~A ~A," dest (car type) (cadr type))))
((instance)
(sprintf "C_mpointer_or_false(&~A,(void*)" dest) )
((nonnull-instance)
@@ -1471,9 +1468,16 @@
;;; Encoded literals as strings, to be decoded by "C_decode_literal()"
-;;
+;;
;; - everything hardcoded, using the FFI would be the ugly, but safer method.
+(define (oct n)
+ (string-append
+ (cond ((< n 8) "\\00")
+ ((< n 64) "\\0")
+ (else "\\"))
+ (number->string n 8)))
+
(define (encode-literal lit)
(define getbits
(foreign-lambda* int ((scheme-object lit))
@@ -1494,27 +1498,27 @@ return((C_header_bits(lit) >> 24) & 0xff);
;; and we have no line number information here.
(quit-compiling
"Encoded literal size of ~S is too large (must fit in 24 bits)" n)
- (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)))))
+ (string-append
+ (oct (bitwise-and #xff (arithmetic-shift n -16)))
+ (oct (bitwise-and #xff (arithmetic-shift n -8)))
+ (oct (bitwise-and #xff n)))))
(define (finish str) ; can be taken out at a later stage
- (string-append (string #\xfe) str))
+ (string-append "\\376" 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")
+ (cond ((eq? #t lit) "\\377\\006\\001")
+ ((eq? #f lit) "\\377\\006\\000")
+ ((char? lit) (string-append "\\377\\012" (encode-size (char->integer lit))))
+ ((null? lit) "\\377\\016")
+ ((eof-object? lit) "\\377\\076")
+ ((eq? (void) lit) "\\377\\036")
;; The big-fixnum? check can probably be simplified
((and (fixnum? lit) (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)) ) ) )
+ "\\377\\001"
+ (oct (bitwise-and #xff (arithmetic-shift lit -24)))
+ (oct (bitwise-and #xff (arithmetic-shift lit -16)))
+ (oct (bitwise-and #xff (arithmetic-shift lit -8)))
+ (oct (bitwise-and #xff lit)) ) )
((exact-integer? lit)
;; Encode as hex to save space and get exact size
;; calculation. We could encode as base 32 to save more
@@ -1523,30 +1527,68 @@ return((C_header_bits(lit) >> 24) & 0xff);
;; get a unique new type, as bignums don't have their own
;; type tag (they're encoded as structures).
(let ((str (number->string lit 16)))
- (string-append "\xc2" (encode-size (string-length str)) str)))
+ (string-append "\\320" (encode-size (fx- (##sys#size (##sys#slot str 0)) 1)) str)))
((flonum? lit)
- (string-append "\x55" (number->string lit) "\x00") )
- ((or (keyword? lit) (symbol? lit))
- (let ((str (##sys#slot lit 1)))
- (string-append
- "\x01"
- (encode-size (string-length str))
- (if (keyword? lit) "\x02" "\x01")
- str) ) )
- ((##sys#immediate? lit)
- (bomb "invalid literal - cannot encode" lit))
+ (string-append "\\125" (number->string lit) "\\000") )
+ ((keyword? lit)
+ (let* ((str (keyword->string lit))
+ (bv (##sys#slot str 0)))
+ (string-append
+ "\\001" (encode-size (fx- (##sys#size bv) 1)) "\\002"
+ (byteblock->string bv -1)) ) )
+ ((symbol? lit)
+ (let* ((str (##sys#symbol->string/shared lit))
+ (bv (##sys#slot str 0)))
+ (string-append
+ "\\001" (encode-size (fx- (##sys#size bv) 1)) "\\001"
+ (byteblock->string bv -1) ) ))
+ ((string? lit)
+ (string-append
+ (oct (getbits lit))
+ (encode-size (##sys#size (##sys#slot lit 0)))
+ (byteblock->string (##sys#slot lit 0) 0) ))
((##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) )
+ (oct (getbits lit))
+ (encode-size (getsize lit))
+ (byteblock->string lit 0) ))
+ ((##sys#immediate? lit)
+ (bomb "invalid literal - cannot encode" lit))
(else
(let ((len (getsize lit)))
(string-intersperse
(cons*
- (string (integer->char (getbits lit)))
+ (oct (getbits lit))
(encode-size len)
(list-tabulate len (lambda (i) (encode-literal (##sys#slot lit i)))))
""))))) )
+
+(define (byteblock->string bb mlen)
+ (let ((out (open-output-string))
+ (len (fx+ (##sys#size bb) mlen)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx>= i len) (get-output-string out))
+ (display (oct (##sys#byte bb i)) out))))
+
+(define (c-ify-string str)
+ (list->string
+ (cons
+ #\"
+ (let loop ((bytes (##sys#bytevector->list (##sys#slot str 0))))
+ (if (or (null? bytes)
+ (null? (cdr bytes)))
+ '(#\")
+ (let ((code (car bytes)))
+ (if (or (< code 32)
+ (>= code 127)
+ (memq code '(#\" #\' #\\ #\? #\*)))
+ (append '(#\\)
+ (cond ((< code 8) '(#\0 #\0))
+ ((< code 64) '(#\0))
+ (else '()))
+ (string->list (number->string code 8))
+ (loop (cdr bytes)) )
+ (cons (integer->char code)
+ (loop (cdr bytes))))))))))
+
)
diff --git a/c-platform.scm b/c-platform.scm
index 335009bc..41aa7955 100644
--- a/c-platform.scm
+++ b/c-platform.scm
@@ -46,6 +46,7 @@
chicken.compiler.core
chicken.fixnum
chicken.internal)
+(import (only (scheme base) port?))
(include "tweaks")
(include "mini-srfi-1.scm")
@@ -62,11 +63,12 @@
##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#structure? ##sys#slot
- ##sys#allocate-vector ##sys#list->vector ##sys#block-ref ##sys#block-set!
+ ##sys#allocate-vector ##sys#allocate-bytevector ##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-symbol-argument
##sys#foreign-pointer-argument ##sys#call-with-current-continuation)))
(define default-profiling-declarations
@@ -103,7 +105,7 @@
no-argc-checks no-procedure-checks no-parentheses-synonyms
no-procedure-checks-for-toplevel-bindings
no-bound-checks no-procedure-checks-for-usual-bindings no-compiler-syntax
- no-parentheses-synonyms no-symbol-escape r5rs-syntax emit-all-import-libraries
+ no-parentheses-synonyms r7rs-syntax emit-all-import-libraries
strict-types clustering lfa2 debug-info
regenerate-import-libraries setup-mode
module-registration no-module-registration))
@@ -142,7 +144,7 @@
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
- current-input-port current-output-port
+ current-input-port current-output-port call/cc
make-polar make-rectangular real-part imag-part
load eval interaction-environment null-environment
scheme-report-environment)))
@@ -166,7 +168,7 @@
chicken.base#nan? chicken.base#finite? chicken.base#infinite?
chicken.base#gensym
chicken.base#void chicken.base#print chicken.base#print*
- chicken.base#error chicken.base#call/cc chicken.base#char-name
+ chicken.base#error chicken.base#char-name
chicken.base#current-error-port
chicken.base#symbol-append chicken.base#foldl chicken.base#foldr
chicken.base#setter chicken.base#getter-with-setter
@@ -183,55 +185,47 @@
chicken.bitwise#bitwise-ior chicken.bitwise#bitwise-xor
chicken.bitwise#arithmetic-shift chicken.bitwise#bit->boolean
- chicken.blob#blob-size chicken.blob#blob=?
+ chicken.bytevector#bytevector-length chicken.bytevector#bytevector=?
chicken.keyword#get-keyword
- srfi-4#u8vector? srfi-4#s8vector?
- srfi-4#u16vector? srfi-4#s16vector?
- srfi-4#u32vector? srfi-4#u64vector?
- srfi-4#s32vector? srfi-4#s64vector?
- srfi-4#f32vector? srfi-4#f64vector?
-
- srfi-4#u8vector-length srfi-4#s8vector-length
- srfi-4#u16vector-length srfi-4#s16vector-length
- srfi-4#u32vector-length srfi-4#u64vector-length
- srfi-4#s32vector-length srfi-4#s64vector-length
- srfi-4#f32vector-length srfi-4#f64vector-length
+ chicken.number-vectoru8vector? chicken.number-vectors8vector?
+ chicken.number-vectoru16vector? chicken.number-vectors16vector?
+ chicken.number-vectoru32vector? chicken.number-vectoru64vector?
+ chicken.number-vectors32vector? chicken.number-vectors64vector?
+ chicken.number-vectorf32vector? chicken.number-vectorf64vector?
+ chicken.number-vectorc64vector? chicken.number-vectorf128vector?
+
+ chicken.number-vectoru8vector-length chicken.number-vectors8vector-length
+ chicken.number-vectoru16vector-length chicken.number-vectors16vector-length
+ chicken.number-vectoru32vector-length chicken.number-vectoru64vector-length
+ chicken.number-vectors32vector-length chicken.number-vectors64vector-length
+ chicken.number-vectorf32vector-length chicken.number-vectorf64vector-length
+ chicken.number-vectorc64vector-length chicken.number-vectorc128vector-length
- srfi-4#u8vector-ref srfi-4#s8vector-ref
- srfi-4#u16vector-ref srfi-4#s16vector-ref
- srfi-4#u32vector-ref srfi-4#u64vector-ref
- srfi-4#s32vector-ref srfi-4#s64vector-ref
- srfi-4#f32vector-ref srfi-4#f64vector-ref
-
- srfi-4#u8vector-set! srfi-4#s8vector-set!
- srfi-4#u16vector-set! srfi-4#s16vector-set!
- srfi-4#u32vector-set! srfi-4#u64vector-set!
- srfi-4#s32vector-set! srfi-4#s64vector-set!
- srfi-4#f32vector-set! srfi-4#f64vector-set!
-
- srfi-4#u8vector->blob/shared srfi-4#s8vector->blob/shared
- srfi-4#u16vector->blob/shared srfi-4#s16vector->blob/shared
- srfi-4#u32vector->blob/shared srfi-4#s32vector->blob/shared
- srfi-4#u64vector->blob/shared srfi-4#s64vector->blob/shared
- srfi-4#f32vector->blob/shared srfi-4#f64vector->blob/shared
- srfi-4#blob->u8vector/shared srfi-4#blob->s8vector/shared
- srfi-4#blob->u16vector/shared srfi-4#blob->s16vector/shared
- srfi-4#blob->u32vector/shared srfi-4#blob->s32vector/shared
- srfi-4#blob->u64vector/shared srfi-4#blob->s64vector/shared
- srfi-4#blob->f32vector/shared srfi-4#blob->f64vector/shared
-
- chicken.memory#u8vector-ref chicken.memory#s8vector-ref
- chicken.memory#u16vector-ref chicken.memory#s16vector-ref
- chicken.memory#u32vector-ref chicken.memory#s32vector-ref
- chicken.memory#u64vector-ref chicken.memory#s64vector-ref
- chicken.memory#f32vector-ref chicken.memory#f64vector-ref
- chicken.memory#f32vector-set! chicken.memory#f64vector-set!
- chicken.memory#u8vector-set! chicken.memory#s8vector-set!
- chicken.memory#u16vector-set! chicken.memory#s16vector-set!
- chicken.memory#u32vector-set! chicken.memory#s32vector-set!
- chicken.memory#u64vector-set! chicken.memory#s64vector-set!
+ chicken.number-vectoru8vector-ref chicken.number-vectors8vector-ref
+ chicken.number-vectoru16vector-ref chicken.number-vectors16vector-ref
+ chicken.number-vectoru32vector-ref chicken.number-vectoru64vector-ref
+ chicken.number-vectors32vector-ref chicken.number-vectors64vector-ref
+ chicken.number-vectorf32vector-ref chicken.number-vectorf64vector-ref
+ chicken.number-vectorc64vector-ref chicken.number-vectorc128vector-ref
+
+ chicken.number-vectoru8vector-set! chicken.number-vectors8vector-set!
+ chicken.number-vectoru16vector-set! chicken.number-vectors16vector-set!
+ chicken.number-vectoru32vector-set! chicken.number-vectoru64vector-set!
+ chicken.number-vectors32vector-set! chicken.number-vectors64vector-set!
+ chicken.number-vectorf32vector-set! chicken.number-vectorf64vector-set!
+ chicken.number-vectorc64vector-set! chicken.number-vectorc128vector-set!
+
+ chicken.number-vectoru16vector->bytevector/shared chicken.number-vectors16vector->bytevector/shared
+ chicken.number-vectoru32vector->bytevector/shared chicken.number-vectors32vector->bytevector/shared
+ chicken.number-vectoru64vector->bytevector/shared chicken.number-vectors64vector->bytevector/shared
+ chicken.number-vectorf32vector->bytevector/shared chicken.number-vectorf64vector->bytevector/shared
+ chicken.number-vectorbytevector->u16vector/shared chicken.number-vectorbytevector->s16vector/shared
+ chicken.number-vectorbytevector->u32vector/shared chicken.number-vectorbytevector->s32vector/shared
+ chicken.number-vectorbytevector->u64vector/shared chicken.number-vectorbytevector->s64vector/shared
+ chicken.number-vectorbytevector->f32vector/shared chicken.number-vectorbytevector->f64vector/shared
+ chicken.number-vectorbytevector->c64vector/shared chicken.number-vectorbytevector->c128vector/shared
chicken.memory.representation#number-of-slots
chicken.memory.representation#make-record-instance
@@ -267,13 +261,14 @@
(set! internal-bindings
'(##sys#slot ##sys#setslot ##sys#block-ref ##sys#block-set! ##sys#/-2
- ##sys#call-with-current-continuation ##sys#size ##sys#byte ##sys#setbyte
+ ##sys#call-with-current-continuation ##sys#size ##sys#byte
##sys#pointer? ##sys#generic-structure? ##sys#structure? ##sys#check-structure
##sys#check-number ##sys#check-list ##sys#check-pair ##sys#check-string
##sys#check-symbol ##sys#check-boolean ##sys#check-locative
+ ##sys#check-fixnum ##sys#check-range ##sys#check-range/internal
##sys#check-port ##sys#check-input-port ##sys#check-output-port
- ##sys#check-open-port
- ##sys#check-char ##sys#check-vector ##sys#check-byte-vector ##sys#list ##sys#cons
+ ##sys#check-open-port ##sys#check-bytevector ##sys#signal-hook
+ ##sys#check-char ##sys#check-vector ##sys#check-bytevector ##sys#list ##sys#cons
##sys#call-with-values ##sys#flonum-in-fixnum-range?
##sys#immediate? ##sys#context-switch
##sys#make-structure ##sys#apply ##sys#apply-values
@@ -285,7 +280,10 @@
##sys#foreign-string-argument ##sys#foreign-pointer-argument ##sys#void
##sys#foreign-ranged-integer-argument ##sys#foreign-unsigned-ranged-integer-argument
##sys#peek-fixnum ##sys#setislot ##sys#poke-integer ##sys#permanent? ##sys#values ##sys#poke-double
- ##sys#intern-symbol ##sys#null-pointer? ##sys#peek-byte
+ ##sys#intern-symbol ##sys#intern-keyword ##sys#null-pointer? ##sys#peek-byte
+ ##sys#foreign-symbol-argument
+ ##sys#symbol->string/shared ##sys#buffer->string ##sys#string->symbol-name
+ ##sys#bytevector->list ##sys#list->bytevector ##sys#make-bytevector
##sys#file-exists? ##sys#substring-index ##sys#substring-index-ci ##sys#lcm ##sys#gcd))
(for-each
@@ -528,22 +526,21 @@
(rewrite 'scheme#symbol? 2 1 "C_i_symbolp" #t)
(rewrite 'scheme#vector? 2 1 "C_i_vectorp" #t)
(rewrite '##sys#vector? 2 1 "C_i_vectorp" #t)
-(rewrite '##sys#srfi-4-vector? 2 1 "C_i_srfi_4_vectorp" #t)
-(rewrite 'srfi-4#u8vector? 2 1 "C_i_u8vectorp" #t)
-(rewrite 'srfi-4#s8vector? 2 1 "C_i_s8vectorp" #t)
-(rewrite 'srfi-4#u16vector? 2 1 "C_i_u16vectorp" #t)
-(rewrite 'srfi-4#s16vector? 2 1 "C_i_s16vectorp" #t)
-(rewrite 'srfi-4#u32vector? 2 1 "C_i_u32vectorp" #t)
-(rewrite 'srfi-4#s32vector? 2 1 "C_i_s32vectorp" #t)
-(rewrite 'srfi-4#u64vector? 2 1 "C_i_u64vectorp" #t)
-(rewrite 'srfi-4#s64vector? 2 1 "C_i_s64vectorp" #t)
-(rewrite 'srfi-4#f32vector? 2 1 "C_i_f32vectorp" #t)
-(rewrite 'srfi-4#f64vector? 2 1 "C_i_f64vectorp" #t)
+(rewrite 'chicken.number-vectoru8vector? 2 1 "C_bytevectorp" #t)
+(rewrite 'chicken.number-vectors8vector? 2 1 "C_i_s8vectorp" #t)
+(rewrite 'chicken.number-vectoru16vector? 2 1 "C_i_u16vectorp" #t)
+(rewrite 'chicken.number-vectors16vector? 2 1 "C_i_s16vectorp" #t)
+(rewrite 'chicken.number-vectoru32vector? 2 1 "C_i_u32vectorp" #t)
+(rewrite 'chicken.number-vectors32vector? 2 1 "C_i_s32vectorp" #t)
+(rewrite 'chicken.number-vectoru64vector? 2 1 "C_i_u64vectorp" #t)
+(rewrite 'chicken.number-vectors64vector? 2 1 "C_i_s64vectorp" #t)
+(rewrite 'chicken.number-vectorf32vector? 2 1 "C_i_f32vectorp" #t)
+(rewrite 'chicken.number-vectorf64vector? 2 1 "C_i_f64vectorp" #t)
(rewrite 'scheme#pair? 2 1 "C_i_pairp" #t)
(rewrite '##sys#pair? 2 1 "C_i_pairp" #t)
(rewrite 'chicken.base#weak-pair? 2 1 "C_i_weak_pairp" #t)
(rewrite 'scheme#procedure? 2 1 "C_i_closurep" #t)
-(rewrite 'chicken.base#port? 2 1 "C_i_portp" #t)
+(rewrite 'scheme#port? 2 1 "C_i_portp" #t)
(rewrite 'scheme#boolean? 2 1 "C_booleanp" #t)
(rewrite 'scheme#number? 2 1 "C_i_numberp" #t)
(rewrite 'scheme#complex? 2 1 "C_i_numberp" #t)
@@ -569,10 +566,10 @@
(rewrite 'scheme#inexact? 2 1 "C_u_i_inexactp" #f)
(rewrite 'scheme#list? 2 1 "C_i_listp" #t)
(rewrite 'scheme#eof-object? 2 1 "C_eofp" #t)
+(rewrite 'scheme#string-ref 2 2 "C_utf_subchar" #f)
(rewrite 'chicken.base#bwp-object? 2 1 "C_bwpp" #t)
-(rewrite 'scheme#string-ref 2 2 "C_subchar" #f)
(rewrite 'scheme#string-ref 2 2 "C_i_string_ref" #t)
-(rewrite 'scheme#string-set! 2 3 "C_setsubchar" #f)
+(rewrite 'scheme#string-set! 2 3 "C_utf_setsubchar" #f)
(rewrite 'scheme#string-set! 2 3 "C_i_string_set" #t)
(rewrite 'scheme#vector-ref 2 2 "C_slot" #f)
(rewrite 'scheme#vector-ref 2 2 "C_i_vector_ref" #t)
@@ -670,7 +667,6 @@
(rewrite 'scheme#negative? 2 1 "C_i_negativep" #t)
(rewrite 'scheme#vector-length 6 "C_fix" "C_header_size" #f)
-(rewrite 'scheme#string-length 6 "C_fix" "C_header_size" #f)
(rewrite 'scheme#char->integer 6 "C_fix" "C_character_code" #t)
(rewrite 'scheme#integer->char 6 "C_make_character" "C_unfix" #t)
@@ -686,7 +682,7 @@
(rewrite '##sys#check-locative 2 1 "C_i_check_locative" #t)
(rewrite '##sys#check-symbol 2 1 "C_i_check_symbol" #t)
(rewrite '##sys#check-string 2 1 "C_i_check_string" #t)
-(rewrite '##sys#check-byte-vector 2 1 "C_i_check_bytevector" #t)
+(rewrite '##sys#check-bytevector 2 1 "C_i_check_bytevector" #t)
(rewrite '##sys#check-vector 2 1 "C_i_check_vector" #t)
(rewrite '##sys#check-structure 2 2 "C_i_check_structure" #t)
(rewrite '##sys#check-char 2 1 "C_i_check_char" #t)
@@ -698,10 +694,14 @@
(rewrite '##sys#check-locative 2 2 "C_i_check_locative_2" #t)
(rewrite '##sys#check-symbol 2 2 "C_i_check_symbol_2" #t)
(rewrite '##sys#check-string 2 2 "C_i_check_string_2" #t)
-(rewrite '##sys#check-byte-vector 2 2 "C_i_check_bytevector_2" #t)
+(rewrite '##sys#check-bytevector 2 2 "C_i_check_bytevector_2" #t)
(rewrite '##sys#check-vector 2 2 "C_i_check_vector_2" #t)
(rewrite '##sys#check-structure 2 3 "C_i_check_structure_2" #t)
(rewrite '##sys#check-char 2 2 "C_i_check_char_2" #t)
+(rewrite '##sys#check-range 2 3 "C_i_check_range" #t)
+(rewrite '##sys#check-range 2 4 "C_i_check_range_2" #t)
+(rewrite '##sys#check-range/including 2 3 "C_i_check_range_including" #t)
+(rewrite '##sys#check-range/including 2 4 "C_i_check_range_including_2" #t)
(rewrite 'scheme#= 9 "C_eqp" "C_i_equalp" #t #t)
(rewrite 'scheme#> 9 "C_fixnum_greaterp" "C_flonum_greaterp" #t #f)
@@ -914,11 +914,10 @@
(rewrite 'scheme#number->string 13 '(1 . 2) "C_number_to_string" #t)
(rewrite '##sys#call-with-current-continuation 13 1 "C_call_cc" #t)
(rewrite '##sys#allocate-vector 13 4 "C_allocate_vector" #t)
+(rewrite '##sys#allocate-bytevector 13 4 "C_allocate_bytevector" #t)
(rewrite '##sys#ensure-heap-reserve 13 1 "C_ensure_heap_reserve" #t)
(rewrite 'chicken.platform#return-to-host 13 0 "C_return_to_host" #t)
(rewrite '##sys#context-switch 13 1 "C_context_switch" #t)
-(rewrite '##sys#intern-symbol 13 1 "C_string_to_symbol" #t)
-(rewrite '##sys#make-symbol 13 1 "C_make_symbol" #t)
(rewrite 'scheme#even? 14 'fixnum 1 "C_i_fixnumevenp" "C_i_fixnumevenp")
(rewrite 'scheme#odd? 14 'fixnum 1 "C_i_fixnumoddp" "C_i_fixnumoddp")
@@ -959,7 +958,7 @@
(rewrite 'scheme#vector 16 #f "C_a_i_vector" #t #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 #t)
-(rewrite 'scheme#string 16 #f "C_a_i_string" #t #t) ; the last #t is actually too much, but we don't care
+(rewrite 'scheme#string 16 #f "C_a_i_string" #t '(7 1))
(rewrite 'chicken.memory#address->pointer 16 1 "C_a_i_address_to_pointer" #f 2)
(rewrite 'chicken.memory#pointer->address 16 1 "C_a_i_pointer_to_address" #f words-per-flonum)
(rewrite 'chicken.memory#pointer+ 16 2 "C_a_u_i_pointer_inc" #f 2)
@@ -1051,7 +1050,6 @@
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 'chicken.memory#pointer->object 17 2 "C_pointer_to_object")
@@ -1071,86 +1069,86 @@
(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-symbol-argument 17 1 "C_i_foreign_symbol_argumentp")
(rewrite '##sys#foreign-struct-wrapper-argument 17 2 "C_i_foreign_struct_wrapper_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-ranged-integer-argument 17 2 "C_i_foreign_ranged_integer_argumentp")
(rewrite '##sys#foreign-unsigned-ranged-integer-argument 17 2 "C_i_foreign_unsigned_ranged_integer_argumentp")
-(rewrite 'chicken.blob#blob-size 2 1 "C_block_size" #f)
+(rewrite 'chicken.bytevector#bytevector-length 2 1 "C_block_size" #f)
;; TODO: Move this stuff to types.db
-(rewrite 'srfi-4#u8vector-ref 2 2 "C_u_i_u8vector_ref" #f)
-(rewrite 'srfi-4#u8vector-ref 2 2 "C_i_u8vector_ref" #t)
-(rewrite 'srfi-4#s8vector-ref 2 2 "C_u_i_s8vector_ref" #f)
-(rewrite 'srfi-4#s8vector-ref 2 2 "C_i_s8vector_ref" #t)
-(rewrite 'srfi-4#u16vector-ref 2 2 "C_u_i_u16vector_ref" #f)
-(rewrite 'srfi-4#u16vector-ref 2 2 "C_i_u16vector_ref" #t)
-(rewrite 'srfi-4#s16vector-ref 2 2 "C_u_i_s16vector_ref" #f)
-(rewrite 'srfi-4#s16vector-ref 2 2 "C_i_s16vector_ref" #t)
-
-(rewrite 'srfi-4#u32vector-ref 16 2 "C_a_i_u32vector_ref" #t min-words-per-bignum)
-(rewrite 'srfi-4#s32vector-ref 16 2 "C_a_i_s32vector_ref" #t min-words-per-bignum)
-
-(rewrite 'srfi-4#f32vector-ref 16 2 "C_a_u_i_f32vector_ref" #f words-per-flonum)
-(rewrite 'srfi-4#f32vector-ref 16 2 "C_a_i_f32vector_ref" #t words-per-flonum)
-(rewrite 'srfi-4#f64vector-ref 16 2 "C_a_u_i_f64vector_ref" #f words-per-flonum)
-(rewrite 'srfi-4#f64vector-ref 16 2 "C_a_i_f64vector_ref" #t words-per-flonum)
-
-(rewrite 'srfi-4#u8vector-set! 2 3 "C_u_i_u8vector_set" #f)
-(rewrite 'srfi-4#u8vector-set! 2 3 "C_i_u8vector_set" #t)
-(rewrite 'srfi-4#s8vector-set! 2 3 "C_u_i_s8vector_set" #f)
-(rewrite 'srfi-4#s8vector-set! 2 3 "C_i_s8vector_set" #t)
-(rewrite 'srfi-4#u16vector-set! 2 3 "C_u_i_u16vector_set" #f)
-(rewrite 'srfi-4#u16vector-set! 2 3 "C_i_u16vector_set" #t)
-(rewrite 'srfi-4#s16vector-set! 2 3 "C_u_i_s16vector_set" #f)
-(rewrite 'srfi-4#s16vector-set! 2 3 "C_i_s16vector_set" #t)
-(rewrite 'srfi-4#u32vector-set! 2 3 "C_u_i_u32vector_set" #f)
-(rewrite 'srfi-4#u32vector-set! 2 3 "C_i_u32vector_set" #t)
-(rewrite 'srfi-4#s32vector-set! 2 3 "C_u_i_s32vector_set" #f)
-(rewrite 'srfi-4#s32vector-set! 2 3 "C_i_s32vector_set" #t)
-(rewrite 'srfi-4#u64vector-set! 2 3 "C_u_i_u64vector_set" #f)
-(rewrite 'srfi-4#u64vector-set! 2 3 "C_i_u64vector_set" #t)
-(rewrite 'srfi-4#s64vector-set! 2 3 "C_u_i_s64vector_set" #f)
-(rewrite 'srfi-4#s64vector-set! 2 3 "C_i_s64vector_set" #t)
-(rewrite 'srfi-4#f32vector-set! 2 3 "C_u_i_f32vector_set" #f)
-(rewrite 'srfi-4#f32vector-set! 2 3 "C_i_f32vector_set" #t)
-(rewrite 'srfi-4#f64vector-set! 2 3 "C_u_i_f64vector_set" #f)
-(rewrite 'srfi-4#f64vector-set! 2 3 "C_i_f64vector_set" #t)
-
-(rewrite 'srfi-4#u8vector-length 2 1 "C_u_i_u8vector_length" #f)
-(rewrite 'srfi-4#u8vector-length 2 1 "C_i_u8vector_length" #t)
-(rewrite 'srfi-4#s8vector-length 2 1 "C_u_i_s8vector_length" #f)
-(rewrite 'srfi-4#s8vector-length 2 1 "C_i_s8vector_length" #t)
-(rewrite 'srfi-4#u16vector-length 2 1 "C_u_i_u16vector_length" #f)
-(rewrite 'srfi-4#u16vector-length 2 1 "C_i_u16vector_length" #t)
-(rewrite 'srfi-4#s16vector-length 2 1 "C_u_i_s16vector_length" #f)
-(rewrite 'srfi-4#s16vector-length 2 1 "C_i_s16vector_length" #t)
-(rewrite 'srfi-4#u32vector-length 2 1 "C_u_i_u32vector_length" #f)
-(rewrite 'srfi-4#u32vector-length 2 1 "C_i_u32vector_length" #t)
-(rewrite 'srfi-4#s32vector-length 2 1 "C_u_i_s32vector_length" #f)
-(rewrite 'srfi-4#s32vector-length 2 1 "C_i_s32vector_length" #t)
-(rewrite 'srfi-4#u64vector-length 2 1 "C_u_i_u64vector_length" #f)
-(rewrite 'srfi-4#u64vector-length 2 1 "C_i_u64vector_length" #t)
-(rewrite 'srfi-4#s64vector-length 2 1 "C_u_i_s64vector_length" #f)
-(rewrite 'srfi-4#s64vector-length 2 1 "C_i_s64vector_length" #t)
-(rewrite 'srfi-4#f32vector-length 2 1 "C_u_i_f32vector_length" #f)
-(rewrite 'srfi-4#f32vector-length 2 1 "C_i_f32vector_length" #t)
-(rewrite 'srfi-4#f64vector-length 2 1 "C_u_i_f64vector_length" #f)
-(rewrite 'srfi-4#f64vector-length 2 1 "C_i_f64vector_length" #t)
+(rewrite 'chicken.number-vectors8vector-ref 2 2 "C_u_i_s8vector_ref" #f)
+(rewrite 'chicken.number-vectors8vector-ref 2 2 "C_i_s8vector_ref" #t)
+(rewrite 'chicken.number-vectoru16vector-ref 2 2 "C_u_i_u16vector_ref" #f)
+(rewrite 'chicken.number-vectoru16vector-ref 2 2 "C_i_u16vector_ref" #t)
+(rewrite 'chicken.number-vectors16vector-ref 2 2 "C_u_i_s16vector_ref" #f)
+(rewrite 'chicken.number-vectors16vector-ref 2 2 "C_i_s16vector_ref" #t)
+
+(rewrite 'chicken.number-vectoru32vector-ref 16 2 "C_a_i_u32vector_ref" #t min-words-per-bignum)
+(rewrite 'chicken.number-vectors32vector-ref 16 2 "C_a_i_s32vector_ref" #t min-words-per-bignum)
+
+(rewrite 'chicken.number-vectorf32vector-ref 16 2 "C_a_u_i_f32vector_ref" #f words-per-flonum)
+(rewrite 'chicken.number-vectorf32vector-ref 16 2 "C_a_i_f32vector_ref" #t words-per-flonum)
+(rewrite 'chicken.number-vectorf64vector-ref 16 2 "C_a_u_i_f64vector_ref" #f words-per-flonum)
+(rewrite 'chicken.number-vectorf64vector-ref 16 2 "C_a_i_f64vector_ref" #t words-per-flonum)
+
+(rewrite 'chicken.number-vectoru8vector-set! 2 3 "C_u_i_u8vector_set" #f)
+(rewrite 'chicken.number-vectoru8vector-set! 2 3 "C_i_u8vector_set" #t)
+(rewrite 'chicken.number-vectors8vector-set! 2 3 "C_u_i_s8vector_set" #f)
+(rewrite 'chicken.number-vectors8vector-set! 2 3 "C_i_s8vector_set" #t)
+(rewrite 'chicken.number-vectoru16vector-set! 2 3 "C_u_i_u16vector_set" #f)
+(rewrite 'chicken.number-vectoru16vector-set! 2 3 "C_i_u16vector_set" #t)
+(rewrite 'chicken.number-vectors16vector-set! 2 3 "C_u_i_s16vector_set" #f)
+(rewrite 'chicken.number-vectors16vector-set! 2 3 "C_i_s16vector_set" #t)
+(rewrite 'chicken.number-vectoru32vector-set! 2 3 "C_u_i_u32vector_set" #f)
+(rewrite 'chicken.number-vectoru32vector-set! 2 3 "C_i_u32vector_set" #t)
+(rewrite 'chicken.number-vectors32vector-set! 2 3 "C_u_i_s32vector_set" #f)
+(rewrite 'chicken.number-vectors32vector-set! 2 3 "C_i_s32vector_set" #t)
+(rewrite 'chicken.number-vectoru64vector-set! 2 3 "C_u_i_u64vector_set" #f)
+(rewrite 'chicken.number-vectoru64vector-set! 2 3 "C_i_u64vector_set" #t)
+(rewrite 'chicken.number-vectors64vector-set! 2 3 "C_u_i_s64vector_set" #f)
+(rewrite 'chicken.number-vectors64vector-set! 2 3 "C_i_s64vector_set" #t)
+(rewrite 'chicken.number-vectorf32vector-set! 2 3 "C_u_i_f32vector_set" #f)
+(rewrite 'chicken.number-vectorf32vector-set! 2 3 "C_i_f32vector_set" #t)
+(rewrite 'chicken.number-vectorf64vector-set! 2 3 "C_u_i_f64vector_set" #f)
+(rewrite 'chicken.number-vectorf64vector-set! 2 3 "C_i_f64vector_set" #t)
+
+(rewrite 'chicken.number-vectoru8vector-length 2 1 "C_u_i_bytevector_length" #f)
+(rewrite 'chicken.number-vectoru8vector-length 2 1 "C_i_bytevector_length" #t)
+(rewrite 'chicken.number-vectors8vector-length 2 1 "C_u_i_s8vector_length" #f)
+(rewrite 'chicken.number-vectors8vector-length 2 1 "C_i_s8vector_length" #t)
+(rewrite 'chicken.number-vectoru16vector-length 2 1 "C_u_i_u16vector_length" #f)
+(rewrite 'chicken.number-vectoru16vector-length 2 1 "C_i_u16vector_length" #t)
+(rewrite 'chicken.number-vectors16vector-length 2 1 "C_u_i_s16vector_length" #f)
+(rewrite 'chicken.number-vectors16vector-length 2 1 "C_i_s16vector_length" #t)
+(rewrite 'chicken.number-vectoru32vector-length 2 1 "C_u_i_u32vector_length" #f)
+(rewrite 'chicken.number-vectoru32vector-length 2 1 "C_i_u32vector_length" #t)
+(rewrite 'chicken.number-vectors32vector-length 2 1 "C_u_i_s32vector_length" #f)
+(rewrite 'chicken.number-vectors32vector-length 2 1 "C_i_s32vector_length" #t)
+(rewrite 'chicken.number-vectoru64vector-length 2 1 "C_u_i_u64vector_length" #f)
+(rewrite 'chicken.number-vectoru64vector-length 2 1 "C_i_u64vector_length" #t)
+(rewrite 'chicken.number-vectors64vector-length 2 1 "C_u_i_s64vector_length" #f)
+(rewrite 'chicken.number-vectors64vector-length 2 1 "C_i_s64vector_length" #t)
+(rewrite 'chicken.number-vectorf32vector-length 2 1 "C_u_i_f32vector_length" #f)
+(rewrite 'chicken.number-vectorf32vector-length 2 1 "C_i_f32vector_length" #t)
+(rewrite 'chicken.number-vectorf64vector-length 2 1 "C_u_i_f64vector_length" #f)
+(rewrite 'chicken.number-vectorf64vector-length 2 1 "C_i_f64vector_length" #t)
(rewrite 'chicken.base#atom? 17 1 "C_i_not_pair_p")
-(rewrite 'srfi-4#u8vector->blob/shared 7 1 "C_slot" 1 #f)
-(rewrite 'srfi-4#s8vector->blob/shared 7 1 "C_slot" 1 #f)
-(rewrite 'srfi-4#u16vector->blob/shared 7 1 "C_slot" 1 #f)
-(rewrite 'srfi-4#s16vector->blob/shared 7 1 "C_slot" 1 #f)
-(rewrite 'srfi-4#u32vector->blob/shared 7 1 "C_slot" 1 #f)
-(rewrite 'srfi-4#s32vector->blob/shared 7 1 "C_slot" 1 #f)
-(rewrite 'srfi-4#u64vector->blob/shared 7 1 "C_slot" 1 #f)
-(rewrite 'srfi-4#s64vector->blob/shared 7 1 "C_slot" 1 #f)
-(rewrite 'srfi-4#f32vector->blob/shared 7 1 "C_slot" 1 #f)
-(rewrite 'srfi-4#f64vector->blob/shared 7 1 "C_slot" 1 #f)
+(rewrite 'chicken.number-vectors8vector->bytevector/shared 7 1 "C_slot" 1 #f)
+(rewrite 'chicken.number-vectoru16vector->bytevector/shared 7 1 "C_slot" 1 #f)
+(rewrite 'chicken.number-vectors16vector->bytevector/shared 7 1 "C_slot" 1 #f)
+(rewrite 'chicken.number-vectoru32vector->bytevector/shared 7 1 "C_slot" 1 #f)
+(rewrite 'chicken.number-vectors32vector->bytevector/shared 7 1 "C_slot" 1 #f)
+(rewrite 'chicken.number-vectoru64vector->bytevector/shared 7 1 "C_slot" 1 #f)
+(rewrite 'chicken.number-vectors64vector->bytevector/shared 7 1 "C_slot" 1 #f)
+(rewrite 'chicken.number-vectorf32vector->bytevector/shared 7 1 "C_slot" 1 #f)
+(rewrite 'chicken.number-vectorf64vector->bytevector/shared 7 1 "C_slot" 1 #f)
+(rewrite 'chicken.number-vectorc64vector->bytevector/shared 7 1 "C_slot" 1 #f)
+(rewrite 'chicken.number-vectorc128vector->bytevector/shared 7 1 "C_slot" 1 #f)
(let ()
(define (rewrite-make-vector db classargs cont callargs)
@@ -1202,23 +1200,25 @@
'##core#call (list #t)
(list val cont (qnode #f)) ) ) ) ) ) ) ) ) ) ) ) )
(rewrite 'scheme#call-with-current-continuation 8 rewrite-call/cc)
- (rewrite 'chicken.base#call/cc 8 rewrite-call/cc))
+ (rewrite 'scheme#call/cc 8 rewrite-call/cc))
(define setter-map
'((scheme#car . scheme#set-car!)
(scheme#cdr . scheme#set-cdr!)
(scheme#string-ref . scheme#string-set!)
(scheme#vector-ref . scheme#vector-set!)
- (srfi-4#u8vector-ref . srfi-4#u8vector-set!)
- (srfi-4#s8vector-ref . srfi-4#s8vector-set!)
- (srfi-4#u16vector-ref . srfi-4#u16vector-set!)
- (srfi-4#s16vector-ref . srfi-4#s16vector-set!)
- (srfi-4#u32vector-ref . srfi-4#u32vector-set!)
- (srfi-4#s32vector-ref . srfi-4#s32vector-set!)
- (srfi-4#u64vector-ref . srfi-4#u64vector-set!)
- (srfi-4#s64vector-ref . srfi-4#s64vector-set!)
- (srfi-4#f32vector-ref . srfi-4#f32vector-set!)
- (srfi-4#f64vector-ref . srfi-4#f64vector-set!)
+ (chicken.number-vectoru8vector-ref . chicken.number-vectoru8vector-set!)
+ (chicken.number-vectors8vector-ref . chicken.number-vectors8vector-set!)
+ (chicken.number-vectoru16vector-ref . chicken.number-vectoru16vector-set!)
+ (chicken.number-vectors16vector-ref . chicken.number-vectors16vector-set!)
+ (chicken.number-vectoru32vector-ref . chicken.number-vectoru32vector-set!)
+ (chicken.number-vectors32vector-ref . chicken.number-vectors32vector-set!)
+ (chicken.number-vectoru64vector-ref . chicken.number-vectoru64vector-set!)
+ (chicken.number-vectors64vector-ref . chicken.number-vectors64vector-set!)
+ (chicken.number-vectorf32vector-ref . chicken.number-vectorf32vector-set!)
+ (chicken.number-vectorf64vector-ref . chicken.number-vectorf64vector-set!)
+ (chicken.number-vectorc64vector-ref . chicken.number-vectorc64vector-set!)
+ (chicken.number-vectorc128vector-ref . chicken.number-vectorc128vector-set!)
(chicken.locative#locative-ref . chicken.locative#locative-set!)
(chicken.memory#pointer-u8-ref . chicken.memory#pointer-u8-set!)
(chicken.memory#pointer-s8-ref . chicken.memory#pointer-s8-set!)
diff --git a/chicken-ffi-syntax.scm b/chicken-ffi-syntax.scm
index 34799926..57591f0f 100644
--- a/chicken-ffi-syntax.scm
+++ b/chicken-ffi-syntax.scm
@@ -58,7 +58,7 @@
(lambda (form r c)
(if (feature? 'compiling)
(transformer form r c)
- (syntax-error
+ (##sys#syntax-error
(car form) "The FFI is not supported in interpreted mode")))))
(##sys#extend-macro-environment
@@ -190,7 +190,7 @@
,(cond ((string? code) code)
((symbol? code) (symbol->string code))
(else
- (syntax-error
+ (##sys#syntax-error
'foreign-value
"bad argument type - not a string or symbol"
code))))
diff --git a/chicken-install.scm b/chicken-install.scm
index 36482755..41207b05 100644
--- a/chicken-install.scm
+++ b/chicken-install.scm
@@ -29,6 +29,7 @@
(module main ()
(import (scheme))
+(import (only (scheme base) open-input-bytevector))
(import (chicken base))
(import (chicken condition))
(import (chicken foreign))
@@ -49,8 +50,11 @@
(import (chicken pathname))
(import (chicken process))
(import (chicken process-context))
+(import (chicken process-context posix))
(import (chicken pretty-print))
(import (chicken string))
+(import (chicken bytevector))
+(import (only (scheme base) open-input-string))
(define +defaults-version+ 2)
(define +module-db+ "modules.db")
@@ -99,9 +103,9 @@
(define cached-only #f)
(define platform
- (if (eq? (software-version) 'mingw32) 'windows 'unix))
+ (if (eq? (software-version) 'mingw) 'windows 'unix))
-(define current-status
+(define current-status
(list ##sys#build-id default-prefix
(get-environment-variable "CSC_OPTIONS")
(get-environment-variable "LD_LIBRARY_PATH")
@@ -122,28 +126,28 @@
(define (build-script-extension mode platform)
(string-append "build"
(if (eq? mode 'target) ".target" "")
- (if (eq? platform 'windows) ".bat" ".sh")))
+ ".sh"))
(define (install-script-extension mode platform)
(string-append "install"
(if (eq? mode 'target) ".target" "")
- (if (eq? platform 'windows) ".bat" ".sh")))
+ ".sh"))
;;; validate egg-information tree
(define (egg-version? v)
- (and (list? v)
+ (and (list? v)
(pair? v)
(null? (cdr v))
(let ((str (->string (car v))))
- (irregex-match '(seq (+ numeric)
+ (irregex-match '(seq (+ numeric)
(? #\. (+ numeric)
(? #\. (+ numeric))))
str))))
(define (optname? x)
- (and (list? x)
+ (and (list? x)
(or (null? x)
(string? (car x))
(symbol? (car x)))))
@@ -191,6 +195,7 @@
(inline-file #f #f #f ,optname?)
(extension #f #t #t)
(c-object #f #t #t)
+ (installed-c-object #f #t #t)
(generated-source-file #f #t #t)
(program #f #t #t)
(data #f #t #t)
@@ -205,17 +210,17 @@
(define (validate info top?)
(for-each
(lambda (item)
- (cond ((or (not (pair? item))
- (not (list? item))
+ (cond ((or (not (pair? item))
+ (not (list? item))
(not (symbol? (car item))))
(error "invalid egg information item" item))
((assq (car item) egg-info-items) =>
(lambda (a)
(apply (lambda (name toplevel nested named #!optional validator)
- (cond ((and top?
+ (cond ((and top?
(not (eq? toplevel '*))
(not toplevel))
- (error "egg information item not allowed at toplevel"
+ (error "egg information item not allowed at toplevel"
item))
((and (not (eq? toplevel '*))
toplevel
@@ -307,8 +312,8 @@
((version)
(cond ((not (pair? (cdr x))) (broken x))
((not (= (cadr x) +defaults-version+))
- (error
- (sprintf
+ (error
+ (sprintf
"version of installed `~a' does not match chicken-install version (~a)"
+defaults-file+
+defaults-version+)
@@ -330,7 +335,7 @@
(cdr x)))))
((alias)
(set! aliases
- (append
+ (append
aliases
(map (lambda (a)
(if (and (list? a) (= 2 (length a)) (every string? a))
@@ -350,9 +355,9 @@
(else (broken x))))
(call-with-input-file deff read-list))))))
-
+
;; set variables with HTTP proxy information
-
+
(define (setup-proxy uri)
(and-let* (((string? uri))
(m (irregex-match "(http://)?([^:]+):?([0-9]*)" uri))
@@ -361,7 +366,7 @@
(set! proxy-host (irregex-match-substring m 2))
(set! proxy-port (or (string->number port) 80))))
-
+
;; apply egg->egg mappings loaded from defaults
(define (canonical x)
@@ -378,21 +383,21 @@
(append-map
(lambda (egg)
(cond ((find (lambda (m) (find (cut same? egg <>) (car m)))
- mappings) =>
+ mappings) =>
(lambda (m) (map ->string (cdr m))))
(else (list egg))))
eggs)
same?)))
(unless (and (= (length eggs) (length eggs2))
- (every (lambda (egg)
- (find (cut same? <> egg) eggs2))
+ (every (lambda (egg)
+ (find (cut same? <> egg) eggs2))
eggs))
(d "mapped ~s to ~s~%" eggs eggs2))
eggs2))
-
+
;; override versions, if specified in "overrides" file
-
+
(define (override-version egg)
(let ((name (string->symbol (if (pair? egg) (car egg) egg))))
(cond ((assq name override) =>
@@ -410,11 +415,11 @@
(cadr a))))
((pair? egg) (cdr egg))
(else #f))))
-
-
-;; "locate" egg: either perform HTTP download or copy from a file-system
+
+
+;; "locate" egg: either perform HTTP download or copy from a file-system
;; location, also make sure it is up to date
-
+
(define (locate-egg name version)
(let* ((cached (make-pathname cache-directory name))
(metadata-dir (make-pathname cache-metadata-directory name))
@@ -443,7 +448,7 @@
(when cached-only (error "extension not cached" name))
(fetch #f))
((and (file-exists? status)
- (not (equal? current-status
+ (not (equal? current-status
(with-input-from-file status read))))
(d "status changed for ~a~%" name)
(cond (cached-only
@@ -471,9 +476,9 @@
(with-input-from-file vfile read)))))
(values cached lversion)))
(else (values cached version))))))
-
+
(define (resolve-location name)
- (cond ((assoc name aliases) =>
+ (cond ((assoc name aliases) =>
(lambda (a)
(let ((new (cdr a)))
(d "resolving alias `~a' to: ~a~%" name new)
@@ -523,7 +528,7 @@
(cond ((null? locs)
(let ((tmpdir (create-temporary-directory)))
(let loop ((srvs (map resolve-location default-servers)))
- (if (null? srvs)
+ (if (null? srvs)
(if lax
(print "no connection to server or egg not found remotely - will use cached version")
(begin
@@ -531,14 +536,14 @@
(delete-directory tmpdir)
(error "extension or version not found" name)))
(begin
- (d "trying server ~a ...~%" (car srvs))
+ (d "trying server ~a ...~%" (car srvs))
(receive (dir ver)
(try-download name (car srvs)
- version: version
+ version: version
destination: tmpdir
tests: #t ;; Always fetch tests, otherwise cached eggs can't be tested later
proxy-host: proxy-host
- proxy-port: proxy-port
+ proxy-port: proxy-port
proxy-user-pass: proxy-user-pass)
(cond (dir
(copy-egg-sources tmpdir dest)
@@ -571,15 +576,18 @@
(define (copy-egg-sources from to)
- ;;XXX should probably be done manually, instead of calling tool
- (let ((cmd (string-append
- (copy-directory-command platform)
- ;; Don't quote the globbing character!
- " " (make-pathname (qs* from platform #t) "*")
- " " (qs* to platform #t))))
- (d "~a~%" cmd)
- (system+ cmd platform)))
-
+ (for-each
+ (lambda (f)
+ (let ((cmd (string-append
+ (copy-directory-command platform)
+ " "
+ (qs* f platform #t)
+ " "
+ (qs* to platform #t))))
+ (d "~a~%" cmd)
+ (system+ cmd platform)))
+ (glob (make-pathname from "*"))))
+
(define (check-remote-version name lversion cached)
(let loop ((locs default-locations))
(cond ((null? locs)
@@ -605,7 +613,7 @@
(here here))
(let ((tfs (directory there))
(hfs (directory here)))
- (every (lambda (f)
+ (every (lambda (f)
(and (member f hfs)
(let ((tf2 (make-pathname there f))
(hf2 (make-pathname here f)))
@@ -640,9 +648,9 @@
(let ((bad (matching-installed-files name (cdr (assq 'installed-files info)))))
(unless (null? bad)
(flush-output)
- (fprintf (current-error-port)
+ (fprintf (current-error-port)
"\nthe extension `~a' will overwrite the following files:\n\n" name)
- (for-each
+ (for-each
(lambda (fname)
(fprintf (current-error-port) " ~a~%" fname))
bad)
@@ -650,7 +658,7 @@
;; retrieve eggs, recursively (if needed)
-
+
(define (retrieve-eggs eggs)
(for-each
(lambda (egg)
@@ -681,7 +689,7 @@
(d "checking platform for `~a'~%" (car e+d+v))
(check-platform (car e+d+v) info)
(d "checking dependencies for `~a'~%" (car e+d+v))
- (let-values (((missing upgrade)
+ (let-values (((missing upgrade)
(outdated-dependencies (car e+d+v) info)))
(set! missing (apply-mappings missing))
(set! dependencies
@@ -724,7 +732,7 @@
(append (get-egg-property* info 'dependencies '())
(get-egg-property* info 'build-dependencies '())
(if run-tests
- (get-egg-property* info 'test-dependencies '())
+ (get-egg-property* info 'test-dependencies '())
'())))
(define (check-dependency dep)
@@ -758,9 +766,9 @@
(if force-install
(values #f #f)
(error
- (string-append
+ (string-append
"Your CHICKEN version is not recent enough to use this extension - version "
- (cadr dep)
+ (cadr dep)
" or newer is required"))))
(else
(values #f
@@ -841,10 +849,10 @@
((char-whitespace? (car lst)) (left (cdr lst)))
(else (cons (car lst) (left (cdr lst))))))
(list->string (reverse (left (reverse (left (string->list str)))))))
-
-
+
+
;; list available egg versions on servers
-
+
(define (list-egg-versions eggs)
(let ((srvs (map resolve-location default-servers)))
(let loop1 ((eggs eggs))
@@ -854,7 +862,7 @@
(let loop2 ((srvs srvs))
(and (pair? srvs)
(let ((versions (try-list-versions name (car srvs))))
- (or (and versions
+ (or (and versions
(begin
(printf "~a:" name)
(for-each (cut printf " ~a" <>) versions)
@@ -862,9 +870,9 @@
(loop2 (cdr srvs))))))
(loop1 (cdr eggs)))))))
-
+
;; perform installation of retrieved eggs
-
+
(define (install-eggs)
(for-each
(lambda (egg)
@@ -876,17 +884,17 @@
(vfile (make-pathname metadata-dir +version-file+))
(ver (and (file-exists? vfile)
(with-input-from-file vfile read))))
- (when (or host-extension
+ (when (or host-extension
(and (not target-extension)
(not host-extension)))
- (let-values (((build install info) (compile-egg-info eggfile
+ (let-values (((build install info) (compile-egg-info eggfile
info
ver
platform
'host)))
- (let ((bscript (make-pathname dir name
+ (let ((bscript (make-pathname dir name
(build-script-extension 'host platform)))
- (iscript (make-pathname dir name
+ (iscript (make-pathname dir name
(install-script-extension 'host
platform))))
(generate-shell-commands platform build bscript dir
@@ -902,9 +910,11 @@
(print "building " name)
(run-script dir bscript platform)
(unless (if (member name requested-eggs) no-install no-install-dependencies)
- (check-installed-files name info)
- (print "installing " name)
- (run-script dir iscript platform sudo: sudo-install))
+ (with-lock
+ (lambda ()
+ (check-installed-files name info)
+ (print "installing " name)
+ (run-script dir iscript platform sudo: sudo-install))))
(when (and (member name requested-eggs)
run-tests
(not (test-egg egg platform)))
@@ -915,10 +925,10 @@
ver
platform
'target)))
- (let ((bscript (make-pathname dir name
+ (let ((bscript (make-pathname dir name
(build-script-extension 'target platform)))
- (iscript (make-pathname dir name
- (install-script-extension 'target
+ (iscript (make-pathname dir name
+ (install-script-extension 'target
platform))))
(generate-shell-commands platform build bscript dir
(build-prefix 'target name info)
@@ -962,7 +972,7 @@
(d "running: ~a~%" cmd)
(let ((r (system+ cmd platform)))
(flush-output (current-error-port))
- (cond ((zero? r)
+ (cond ((zero? r)
(change-directory old)
#t)
(else
@@ -973,7 +983,7 @@
(define (run-script dir script platform #!key sudo (stop #t))
(d "running script ~a~%" script)
(exec (if (eq? platform 'windows)
- script
+ (string-append "sh " script)
(string-append
(if sudo
(string-append sudo-program " ")
@@ -1012,8 +1022,8 @@
(import-name (pathname-strip-extension file))
(module-name (pathname-strip-extension import-name)))
(handle-exceptions ex
- (print-error-message
- ex (current-error-port)
+ (print-error-message
+ ex (current-error-port)
(sprintf "Failed to import from `~a'" file))
(unless quiet (print "loading " file " ..."))
(eval `(import-syntax ,(string->symbol module-name))))))
@@ -1065,15 +1075,41 @@
eggs))))
+;; locking of cache directory
+
+(define (with-lock thunk)
+ (cond ((eq? platform 'windows) (thunk))
+ (else
+ (unless (directory-exists? cache-directory)
+ (create-directory cache-directory #t))
+ (let ((fd (file-open cache-directory open/read)))
+ (let loop ((f #t))
+ (cond ((file-lock fd)
+ (handle-exceptions ex
+ (begin
+ (file-close fd)
+ (abort ex))
+ (call-with-values thunk
+ (lambda results
+ (file-close fd)
+ (apply values results)))))
+ (else
+ (when f
+ (d "[~A] cache locked - waiting for release ...\n"
+ (current-process-id)))
+ (sleep 1)
+ (loop #f))))))))
+
+
;; command line parsing and selection of operations
-
+
(define (perform-actions eggs)
(load-defaults)
- (cond (update-module-db (update-db))
- (purge-mode (purge-cache eggs))
+ (cond (update-module-db (with-lock update-db))
+ (purge-mode (with-lock (cut purge-cache eggs)))
(print-repository (print (install-path)))
((null? eggs)
- (cond (list-versions-only
+ (cond ((or list-versions-only retrieve-only)
(print "no eggs specified"))
(else
(let ((files (glob "*.egg" "chicken/*.egg")))
@@ -1083,16 +1119,20 @@
(list (pathname-file fname) (current-directory) #f))
files))
(set! requested-eggs (map car canonical-eggs))
- (retrieve-eggs '())
- (unless retrieve-only (install-eggs))))))
+ (with-lock
+ (lambda ()
+ (retrieve-eggs '())))
+ (install-eggs)))))
(else
(let ((eggs (apply-mappings eggs)))
(cond (list-versions-only (list-egg-versions eggs))
(else
(set! requested-eggs (map (o car canonical) eggs))
- (retrieve-eggs eggs)
+ (with-lock
+ (lambda ()
+ (retrieve-eggs eggs)))
(unless retrieve-only (install-eggs))))))))
-
+
(define (usage code)
(print #<<EOF
usage: chicken-install [OPTION ...] [NAME[:VERSION] ...]
@@ -1234,14 +1274,14 @@ EOF
(call-with-input-file (cadr args) read-list))
(loop (cddr args)))
- ;;XXX
-
+ ;;XXX
+
((and (positive? (string-length arg))
(char=? #\- (string-ref arg 0)))
(if (> (string-length arg) 2)
(let ((sos (string->list (substring arg 1))))
(if (every (cut memq <> +short-options+) sos)
- (loop (append
+ (loop (append
(map (cut string #\- <>) sos)
(cdr args)))
(usage 1)))
@@ -1259,5 +1299,5 @@ EOF
(loop (cdr args)))))))))
(main (command-line-arguments))
-
+
)
diff --git a/chicken-status.scm b/chicken-status.scm
index ed51d2b0..218624e9 100644
--- a/chicken-status.scm
+++ b/chicken-status.scm
@@ -135,9 +135,9 @@
(define (gather-components-rec info mode)
(case (car info)
- ((host)
+ ((host)
(if host-extensions (gather-components (cdr info) 'host) '()))
- ((target)
+ ((target)
(if target-extensions (gather-components (cdr info) 'target) '()))
((extension) (list (list 'extension mode (cadr info))))
((data) (list (list 'data mode (cadr info))))
@@ -146,6 +146,7 @@
((scheme-include) (list (list 'scheme-include mode (cadr info))))
((program) (list (list 'program mode (cadr info))))
((c-object) (list (list 'c-object mode (cadr info))))
+ ((installed-c-object) (list (list 'installed-c-object mode (cadr info))))
(else '())))
(define (list-installed-components eggs)
diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 1f923ee9..fd17c1db 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -132,7 +132,7 @@
type1
(strip-syntax name1))))
(cond ((not type)
- (syntax-error ': "invalid type syntax" name1 type1))
+ (##sys#syntax-error ': "invalid type syntax" name1 type1))
(else
`(##core#declare
(type (,name1 ,type1 ,@(cdddr x)))
@@ -212,7 +212,7 @@
(cadr arg)
'define-specialization)
atypes)))
- (else (syntax-error
+ (else (##sys#syntax-error
'define-specialization
"invalid argument syntax" arg head)))))))))))))
@@ -349,7 +349,7 @@
(null? (cddr slot)))
(cadr slot))
(else
- (syntax-error
+ (##sys#syntax-error
'define-record "invalid slot specification" slot))))
slots)))
`(##core#begin
@@ -432,15 +432,26 @@
'include '()
(##sys#er-transformer
(lambda (form r c)
- (##sys#check-syntax 'include form '(_ string))
- `(##core#include ,(cadr form) #f))))
+ (##sys#check-syntax 'include form '(_ . #(string 1)))
+ `(##core#begin ,@(map (lambda (x) `(##core#include ,x #f))
+ (cdr form))))))
+
+(##sys#extend-macro-environment
+ 'include-ci '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'include-ci form '(_ . #(string 1)))
+ `(##core#begin ,@(map (lambda (x) `(##core#include-ci ,x #f))
+ (cdr form))))))
(##sys#extend-macro-environment
'include-relative '()
(##sys#er-transformer
(lambda (form r c)
- (##sys#check-syntax 'include-relative form '(_ string))
- `(##core#include ,(cadr form) ,##sys#current-source-filename))))
+ (##sys#check-syntax 'include-relative form '(_ . #(string 1)))
+ `(##core#begin ,@(map (lambda (x)
+ `(##core#include ,x ,##sys#current-source-filename))
+ (cdr form))))))
(##sys#extend-macro-environment
'fluid-let '()
@@ -706,7 +717,7 @@
(when (or (not (pair? val))
(and (not (eq? '##core#lambda (car val)))
(not (c (r 'lambda) (car val)))))
- (syntax-error
+ (##sys#syntax-error
'define-inline "invalid substitution form - must be lambda"
name val) )
(list name val) ) ) ] )
@@ -965,109 +976,6 @@
,(loop rvar2 (cdr vardefs)) ) )
`(##core#let ((,head ,args)) ,@body) ) ) ) ) ) ) ))))
-
-;;; case-lambda (SRFI-16):
-
-(##sys#extend-macro-environment
- 'case-lambda
- `((>= . scheme#>=)
- (car . scheme#car)
- (cdr . scheme#cdr)
- (eq? . scheme#eq?)
- (length . scheme#length))
- (##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))) ) ) )
- (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))
- (%>= (r '>=))
- (%eq? (r 'eq?))
- (%car (r 'car))
- (%cdr (r 'cdr))
- (%length (r 'length)))
- `(##core#lambda
- ,(append minvars rvar)
- (##core#let
- ((,lvar (,%length ,rvar)))
- ,(foldr
- (lambda (c body)
- (##sys#decompose-lambda-list
- (car c)
- (lambda (vars argc rest)
- (##sys#check-syntax 'case-lambda (car c) 'lambda-list)
- `(##core#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 `(##core#let ((,rest ,vrest)) ,@(cdr c)))
- ((null? (cddr c)) (cadr c))
- (else `(##core#let () ,@(cdr c))) )
- (let ((vrest2 (r (gensym))))
- `(##core#let ((,(car vars2) (,%car ,vrest))
- (,vrest2 (,%cdr ,vrest)) )
- ,(if (pair? (cdr vars2))
- (build (cdr vars2) vrest2)
- (build '() vrest2) ) ) ) ) ) ) )
- (if (null? vars1)
- bindings
- `(##core#let ,(map list vars1 minvars) ,bindings) ) ) )
- ,body) ) ) )
- '(##core#check (##sys#error (##core#immutable (##core#quote "no matching clause in call to 'case-lambda' form"))))
- (cdr form))))))))
-
-
-;;; Record printing:
-
-(##sys#extend-macro-environment
- 'define-record-printer '() ;; DEPRECATED
- (##sys#er-transformer
- (lambda (form r c)
- (##sys#check-syntax 'define-record-printer form '(_ _ . _))
- (let ((head (cadr form))
- (body (cddr form))
- (%set-record-printer! (r 'chicken.base#set-record-printer!)))
- (cond [(pair? head)
- (##sys#check-syntax
- 'define-record-printer (cons head body)
- '((variable variable variable) . #(_ 1)))
- (let* ((plain-name (strip-syntax (##sys#slot head 0)))
- (tag (if (##sys#current-module)
- (symbol-append
- (##sys#module-name (##sys#current-module))
- '|#| plain-name)
- plain-name)))
- `(,%set-record-printer!
- (##core#quote ,tag)
- (##core#lambda ,(##sys#slot head 1) ,@body)))]
- (else
- (##sys#check-syntax 'define-record-printer (cons head body) '(variable _))
- (let* ((plain-name (strip-syntax head))
- (tag (if (##sys#current-module)
- (symbol-append
- (##sys#module-name (##sys#current-module))
- '|#| plain-name)
- plain-name)))
- `(,%set-record-printer!
- (##core#quote ,tag) ,@body))))))))
-
;;; SRFI-9:
(##sys#extend-macro-environment
@@ -1090,6 +998,9 @@
(pred (cadddr form))
(slots (cddddr form))
(%define (r 'define))
+ (%vector (r 'vector))
+ (%let (r 'let))
+ (%tagvar (r 'tag))
(%getter-with-setter (r 'chicken.base#getter-with-setter))
(vars (cdr conser))
(x (r 'x))
@@ -1098,24 +1009,28 @@
;; Check for inconsistencies in slot names vs constructor args
(for-each (lambda (vname)
(unless (memq vname slotnames)
- (syntax-error
+ (##sys#syntax-error
'define-record-type
"unknown slot name in constructor definition"
vname)))
vars)
`(##core#begin
- ;; TODO: Maybe wrap this in an opaque object?
- (,%define ,type-name (##core#quote ,tag))
- (,%define ,conser
- (##sys#make-structure
- (##core#quote ,tag)
- ,@(map (lambda (sname)
- (if (memq sname vars)
- sname
- '(##core#undefined) ) )
- slotnames) ) )
- (,%define (,pred ,x) (##sys#structure? ,x (##core#quote ,tag)))
- ,@(let loop ([slots slots] [i 1])
+ (,%define ,type-name (,%vector (##core#quote ,tag)))
+ (,%define ,(car conser)
+ (,%let ((,%tagvar ,type-name))
+ (##core#lambda ,(cdr conser)
+ (##sys#make-structure
+ ,%tagvar
+ ,@(map (lambda (sname)
+ (if (memq sname vars)
+ sname
+ '(##core#undefined) ) )
+ slotnames) ) ) ))
+ (,%define ,pred
+ (,%let ((,%tagvar ,type-name))
+ (##core#lambda (,x)
+ (##sys#structure? ,x ,%tagvar))))
+ ,@(let loop ((slots slots) (i 1))
(if (null? slots)
'()
(let* ((slot (car slots))
@@ -1130,7 +1045,7 @@
(##core#check
(##sys#check-structure
,x
- (##core#quote ,tag)
+ ,%tagvar
(##core#quote ,(cadr slot))))
(##sys#block-ref ,x ,i) ) )
(set (and settable
@@ -1139,20 +1054,22 @@
(##core#check
(##sys#check-structure
,x
- (##core#quote ,tag)
+ ,%tagvar
(##core#quote ,ssetter)))
(##sys#block-set! ,x ,i ,y)) )))
`((,%define
- ,(cadr slot)
- ,(if (and ssetter (c ssetter (cadr slot)))
- `(,%getter-with-setter ,get ,set)
- get))
+ ,(cadr slot)
+ (,%let ((,%tagvar ,type-name))
+ ,(if (and ssetter (c ssetter (cadr slot)))
+ `(,%getter-with-setter ,get ,set)
+ get)))
,@(if settable
(if ssetter
(if (not (c ssetter (cadr slot)))
- `(((##sys#setter ##sys#setter) ,ssetter ,set))
+ `((,%let ((,%tagvar ,type-name))
+ ((##sys#setter ##sys#setter) ,ssetter ,set)))
'())
- `((,%define ,setr ,set)))
+ `((,%define ,setr (,%let ((,%tagvar ,type-name)) ,set))))
'())
,@(loop (cdr slots) (add1 i)) ) ) ) ) ) ) ) ) )
@@ -1168,7 +1085,7 @@
(%<...> (r '<...>))
(%apply (r 'apply)))
(when (null? (cdr form))
- (syntax-error 'cut "you need to supply at least a procedure" form))
+ (##sys#syntax-error 'cut "you need to supply at least a procedure" form))
(let loop ([xs (cdr form)] [vars '()] [vals '()] [rest #f])
(if (null? xs)
(let ([rvars (reverse vars)]
@@ -1186,7 +1103,7 @@
((c %<...> (car xs))
(if (null? (cdr xs))
(loop '() vars vals #t)
- (syntax-error
+ (##sys#syntax-error
'cut
"tail patterns after <...> are not supported"
form)))
@@ -1201,7 +1118,7 @@
(%<> (r '<>))
(%<...> (r '<...>)))
(when (null? (cdr form))
- (syntax-error 'cute "you need to supply at least a procedure" form))
+ (##sys#syntax-error 'cute "you need to supply at least a procedure" form))
(let loop ([xs (cdr form)] [vars '()] [bs '()] [vals '()] [rest #f])
(if (null? xs)
(let ([rvars (reverse vars)]
@@ -1220,7 +1137,7 @@
((c %<...> (car xs))
(if (null? (cdr xs))
(loop '() vars bs vals #t)
- (syntax-error
+ (##sys#syntax-error
'cute
"tail patterns after <...> are not supported"
form)))
@@ -1282,6 +1199,78 @@
(cdr msg-and-args)
`((##core#quote ,(strip-syntax exp))))))))))))
+;; R7RS guard & guard-aux copied verbatim from the draft.
+(##sys#extend-macro-environment
+ 'guard '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (let ((%=> (r '=>))
+ (%else (r 'else))
+ (%begin (r 'begin))
+ (%let (r 'let))
+ (%if (r 'if))
+ (%or (r 'or))
+ (%var (r 'var))
+ (%apply (r 'apply))
+ (%values (r 'values))
+ (%condition (r 'condition))
+ (%call-with-values (r 'call-with-values))
+ (%guard-k (r 'guard-k))
+ (%handler-k (r 'handler-k))
+ (%lambda (r 'lambda)))
+ (##sys#check-syntax 'guard form '(_ (variable . #(_ 1)) . #(_ 1)))
+ (let ((var (caadr form))
+ (clauses (cdadr form))
+ (es (cddr form)))
+ (define (guard-aux reraise body more)
+ (cond ((and (pair? body) (c %else (car body))
+ (null? more))
+ `(,%begin ,@(cdr body)))
+ ((and (pair? body) (pair? (cdr body)) (pair? (cddr body))
+ (c %=> (cadr body)))
+ (let ((%temp (r 'temp)))
+ `(,%let ((,%temp ,(car body)))
+ (,%if ,%temp
+ (,(caddr body) ,%temp)
+ ,(if (null? more)
+ reraise
+ (guard-aux reraise (car more) (cdr more)))))))
+ ((and (pair? body) (null? (cdr body)))
+ (if (null? more)
+ `(,%or ,(car body) ,reraise)
+ (let ((%temp (r 'temp)))
+ `(,%let ((,%temp ,(car body)))
+ (,%if ,%temp
+ ,%temp
+ ,(guard-aux reraise (car more) (cdr more)))))))
+ ((and (pair? body) (pair? (cdr body)))
+ `(,%if ,(car body)
+ (,%begin ,@(cdr body))
+ ,(if (null? more)
+ reraise
+ (guard-aux reraise (car more) (cdr more)))))))
+ `((scheme#call-with-current-continuation
+ (,%lambda (,%guard-k)
+ (scheme#with-exception-handler
+ (,%lambda (,%condition)
+ ((scheme#call-with-current-continuation
+ (,%lambda (,%handler-k)
+ (,%guard-k
+ (,%lambda ()
+ (,%let ((,var ,%condition))
+ ,(guard-aux
+ `(,%handler-k
+ (,%lambda ()
+ (scheme#raise-continuable ,%condition)))
+ (car clauses) (cdr clauses)))))))))
+ (,%lambda ()
+ (scheme#call-with-values
+ (,%lambda () ,@es)
+ (,%lambda args
+ (,%guard-k
+ (,%lambda ()
+ (,%apply ,%values args)))))))))))))))
+
(macro-subset me0 ##sys#default-macro-environment)))
@@ -1306,6 +1295,78 @@
(macro-subset me0 ##sys#default-macro-environment)))
+;;; case-lambda (SRFI-16):
+
+(set! ##sys#scheme.case-lambda-macro-environment
+ (let ((me0 (##sys#macro-environment)))
+
+(##sys#extend-macro-environment
+ 'case-lambda
+ `((>= . scheme#>=)
+ (car . scheme#car)
+ (cdr . scheme#cdr)
+ (eq? . scheme#eq?)
+ (length . scheme#length))
+ (##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))) ) ) )
+ (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))
+ (%>= (r '>=))
+ (%eq? (r 'eq?))
+ (%car (r 'car))
+ (%cdr (r 'cdr))
+ (%length (r 'length)))
+ `(##core#lambda
+ ,(append minvars rvar)
+ (##core#let
+ ((,lvar (,%length ,rvar)))
+ ,(foldr
+ (lambda (c body)
+ (##sys#decompose-lambda-list
+ (car c)
+ (lambda (vars argc rest)
+ (##sys#check-syntax 'case-lambda (car c) 'lambda-list)
+ `(##core#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 `(##core#let ((,rest ,vrest)) ,@(cdr c)))
+ ((null? (cddr c)) (cadr c))
+ (else `(##core#let () ,@(cdr c))) )
+ (let ((vrest2 (r (gensym))))
+ `(##core#let ((,(car vars2) (,%car ,vrest))
+ (,vrest2 (,%cdr ,vrest)) )
+ ,(if (pair? (cdr vars2))
+ (build (cdr vars2) vrest2)
+ (build '() vrest2) ) ) ) ) ) ) )
+ (if (null? vars1)
+ bindings
+ `(##core#let ,(map list vars1 minvars) ,bindings) ) ) )
+ ,body) ) ) )
+ '(##core#check (##sys#error (##core#immutable (##core#quote "no matching clause in call to 'case-lambda' form"))))
+ (cdr form))))))))
+
+(macro-subset me0 ##sys#default-macro-environment)))
+
;; register features
(register-feature! 'srfi-2 'srfi-8 'srfi-9 'srfi-11 'srfi-15 'srfi-16 'srfi-26 'srfi-31 'srfi-55)
diff --git a/chicken.base.import.scm b/chicken.base.import.scm
index 1f64f5ea..ec27c02b 100644
--- a/chicken.base.import.scm
+++ b/chicken.base.import.scm
@@ -34,9 +34,9 @@
(bignum? . chicken.base#bignum?)
(bwp-object? . chicken.base#bwp-object?)
(butlast . chicken.base#butlast)
- (call/cc . chicken.base#call/cc)
(case-sensitive . chicken.base#case-sensitive)
(char-name . chicken.base#char-name)
+ (char-foldcase . chicken.base#char-foldcase)
(chop . chicken.base#chop)
(complement . chicken.base#complement)
(compose . chicken.base#compose)
@@ -53,7 +53,6 @@
(error . chicken.base#error)
(exact-integer? . chicken.base#exact-integer?)
(exact-integer-nth-root . chicken.base#exact-integer-nth-root)
- (exact-integer-sqrt . chicken.base#exact-integer-sqrt)
(exit . chicken.base#exit)
(exit-handler . chicken.base#exit-handler)
(finite? . chicken.base#finite?)
@@ -66,27 +65,20 @@
(foldr . chicken.base#foldr)
(gensym . chicken.base#gensym)
(get-call-chain . chicken.base#get-call-chain)
- (get-output-string . chicken.base#get-output-string)
(getter-with-setter . chicken.base#getter-with-setter)
(identity . chicken.base#identity)
(implicit-exit-handler . chicken.base#implicit-exit-handler)
(infinite? . chicken.base#infinite?)
- (input-port-open? . chicken.base#input-port-open?)
(intersperse . chicken.base#intersperse)
(join . chicken.base#join)
(keyword-style . chicken.base#keyword-style)
(list-of? . chicken.base#list-of?)
- (make-parameter . chicken.base#make-parameter)
(make-promise . chicken.base#make-promise)
(nan? . chicken.base#nan?)
(notice . chicken.base#notice)
(o . chicken.base#o)
(on-exit . chicken.base#on-exit)
- (open-input-string . chicken.base#open-input-string)
- (open-output-string . chicken.base#open-output-string)
- (output-port-open? . chicken.base#output-port-open?)
(parentheses-synonyms . chicken.base#parentheses-synonyms)
- (port? . chicken.base#port?)
(port-closed? . chicken.base#port-closed?)
(print-call-chain . chicken.base#print-call-chain)
(print . chicken.base#print)
@@ -103,15 +95,17 @@
(signum . chicken.base#signum)
(sleep . chicken.base#sleep)
(string->uninterned-symbol . chicken.base#string->uninterned-symbol)
+ (string-foldcase . chicken.base#string-foldcase)
(sub1 . chicken.base#sub1)
(subvector . chicken.base#subvector)
(symbol-append . chicken.base#symbol-append)
(symbol-escape . chicken.base#symbol-escape)
(tail? . chicken.base#tail?)
- (vector-copy! . chicken.base#vector-copy!)
+ (vector-copy! . scheme#vector-copy!)
(vector-resize . chicken.base#vector-resize)
(void . chicken.base#void)
(warning . chicken.base#warning)
(weak-cons . chicken.base#weak-cons)
- (weak-pair? . chicken.base#weak-pair?))
+ (weak-pair? . chicken.base#weak-pair?)
+ )
##sys#chicken.base-macro-environment)
diff --git a/chicken.csi.import.scm b/chicken.csi.import.scm
index 44feb988..7ee1c9b6 100644
--- a/chicken.csi.import.scm
+++ b/chicken.csi.import.scm
@@ -27,5 +27,4 @@
(##sys#register-primitive-module
'chicken.csi
'((editor-command . chicken.csi#editor-command)
- (set-describer! . chicken.csi#set-describer!)
(toplevel-command . chicken.csi#toplevel-command)))
diff --git a/chicken.h b/chicken.h
index d0d6be20..ccdefe87 100644
--- a/chicken.h
+++ b/chicken.h
@@ -30,8 +30,8 @@
#ifndef ___CHICKEN
#define ___CHICKEN
-#define C_MAJOR_VERSION 5
-#define C_MINOR_VERSION 4
+#define C_MAJOR_VERSION 6
+#define C_MINOR_VERSION 0
#ifndef _ISOC99_SOURCE
# define _ISOC99_SOURCE
@@ -119,7 +119,6 @@
/* Headers */
-#include <ctype.h>
#include <errno.h>
#include <inttypes.h>
#include <limits.h>
@@ -132,6 +131,12 @@
#include <string.h>
#include <time.h>
#include <unistd.h>
+#if !defined(__STDC_NO_COMPLEX__) && !defined(__cplusplus)
+# include <complex.h>
+# define C_complex complex
+#else
+# define C_complex
+#endif
#include <sys/types.h>
#include <sys/stat.h>
@@ -214,8 +219,6 @@ void *alloca ();
#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
@@ -268,10 +271,6 @@ void *alloca ();
# define C_regparm
#endif
-#ifndef C_fcall
-# define C_fcall
-#endif
-
#ifndef C_ccall
# define C_ccall
#endif
@@ -280,18 +279,6 @@ void *alloca ();
# define C_aligned
#endif
-/* Thread Local Storage */
-#ifdef C_ENABLE_TLS
-# if defined(__GNUC__)
-# define C_TLS __thread
-# endif
-#endif
-
-#ifndef C_TLS
-# define C_TLS
-#endif
-
-
/* Stack growth direction; used to compute stack addresses */
#ifndef C_STACK_GROWS_DOWNWARD
# ifdef __hppa__
@@ -389,6 +376,29 @@ void *alloca ();
#define C_MOST_POSITIVE_32_BIT_FIXNUM 0x3fffffff
#define C_MOST_NEGATIVE_FIXNUM (-C_MOST_POSITIVE_FIXNUM - 1)
+/* Block object layout:
+
+ Bits: B = BYTEBLOC_BIT
+ S = SPECIALBLOCK_BIT
+ A = 8ALIGN_BIT
+
+ Symbol = [ 1|3, Value, Name, Plist] Name = bytevector, 0-terminated
+ String = [ 2|4, Name, Count, Offset, Index] Name = bytevector, 0-terminated
+ Pair = [ 3|2, Car, Cdr]
+ Closure = [ S4|1+N, Ptr, Slot, ...]
+ Flonum = [AB5|8, IEEEDouble]
+ Bignum = [ 6|1, Bits] Bits = bytevector
+ Port = [ S7|15, Slots, ...]
+ Structure = [ 8|1+N, Tag, Slots, ...]
+ Pointer = [ S9|1, Ptr]
+ Locative = [ S0a|4*N, Slots, ...]
+ Taggedpointer = [ S0b|2, Ptr, Tag]
+ Ratnum = [ 0c|2, Num, Den]
+ Lambdainfo = [ B0d|N, Bytes, ...]
+ Cplxnum = [ 0e|2, Imag, Real]
+
+*/
+
#ifdef C_SIXTY_FOUR
# define C_INT_SIGN_BIT 0x8000000000000000L
# define C_INT_TOP_BIT 0x4000000000000000L
@@ -401,7 +411,7 @@ void *alloca ();
# 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_STRING_TYPE (0x0200000000000000L)
# define C_PAIR_TYPE (0x0300000000000000L)
# define C_CLOSURE_TYPE (0x0400000000000000L | C_SPECIALBLOCK_BIT)
# define C_FLONUM_TYPE (0x0500000000000000L | C_BYTEBLOCK_BIT | C_8ALIGN_BIT)
@@ -427,7 +437,7 @@ void *alloca ();
# define C_8ALIGN_BIT 0x10000000
# define C_SYMBOL_TYPE (0x01000000)
-# define C_STRING_TYPE (0x02000000 | C_BYTEBLOCK_BIT)
+# define C_STRING_TYPE (0x02000000)
# define C_PAIR_TYPE (0x03000000)
# define C_CLOSURE_TYPE (0x04000000 | C_SPECIALBLOCK_BIT)
# ifdef C_DOUBLE_IS_32_BITS
@@ -451,7 +461,7 @@ void *alloca ();
#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_STRING(n) (C_SIZEOF_BYTEVECTOR((n) * 4) + 1 + 5)
#define C_SIZEOF_SYMBOL 4
#define C_SIZEOF_INTERNED_SYMBOL(n) (C_SIZEOF_SYMBOL + C_SIZEOF_PAIR + C_SIZEOF_STRING(n))
#ifdef C_DOUBLE_IS_32_BITS
@@ -463,12 +473,12 @@ void *alloca ();
#define C_SIZEOF_TAGGED_POINTER 3
#define C_SIZEOF_VECTOR(n) ((n) + 1)
#define C_SIZEOF_LOCATIVE 5
-#define C_SIZEOF_PORT 16
+#define C_SIZEOF_PORT 17
#define C_SIZEOF_RATNUM 3
#define C_SIZEOF_CPLXNUM 3
#define C_SIZEOF_STRUCTURE(n) ((n)+1)
#define C_SIZEOF_CLOSURE(n) ((n)+1)
-#define C_SIZEOF_BYTEVECTOR C_SIZEOF_STRING
+#define C_SIZEOF_BYTEVECTOR(n) (C_bytestowords(n) + 2)
#define C_SIZEOF_INTERNAL_BIGNUM_VECTOR(n) (C_SIZEOF_VECTOR((n)+1))
#define C_internal_bignum_vector(b) (C_block_item(b,0))
@@ -478,6 +488,7 @@ void *alloca ();
#define C_SIZEOF_BIGNUM(n) (C_SIZEOF_INTERNAL_BIGNUM_VECTOR(n)+C_SIZEOF_BIGNUM_WRAPPER)
/* Fixed size types have pre-computed header tags */
+#define C_STRING_TAG (C_STRING_TYPE | 4)
#define C_PAIR_TAG (C_PAIR_TYPE | (C_SIZEOF_PAIR - 1))
#define C_WEAK_PAIR_TAG (C_PAIR_TAG | C_SPECIALBLOCK_BIT)
#define C_POINTER_TAG (C_POINTER_TYPE | (C_SIZEOF_POINTER - 1))
@@ -588,7 +599,7 @@ void *alloca ();
#define C_BAD_ARGUMENT_TYPE_NO_KEYWORD_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_OUT_OF_BOUNDS_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
@@ -637,6 +648,8 @@ void *alloca ();
#define C_BAD_ARGUMENT_TYPE_FOREIGN_LIMITATION 54
#define C_BAD_ARGUMENT_TYPE_COMPLEX_ABS 55
#define C_REST_ARG_OUT_OF_BOUNDS_ERROR 56
+#define C_DECODING_ERROR 57
+#define C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR 58
/* Platform information */
#if defined(C_BIG_ENDIAN)
@@ -691,6 +704,13 @@ void *alloca ();
# define C_SOFTWARE_TYPE "unknown"
#endif
+#if defined(_WIN32) && !defined(__CYGWIN__)
+# define C_WCHAR_FILENAMES
+# define C_WCHAR wchar_t
+#else
+# define C_WCHAR C_char
+#endif
+
#if defined(__SUNPRO_C)
# define C_BUILD_PLATFORM "sun"
#elif defined(__clang__)
@@ -733,8 +753,8 @@ void *alloca ();
# define C_SOFTWARE_VERSION "hurd"
#elif defined(__CYGWIN__)
# define C_SOFTWARE_VERSION "cygwin"
-#elif defined(__MINGW32__)
-# define C_SOFTWARE_VERSION "mingw32"
+#elif defined(_WIN32) && !defined(__CYGWIN__)
+# define C_SOFTWARE_VERSION "mingw"
#else
# define C_SOFTWARE_VERSION "unknown"
#endif
@@ -824,7 +844,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#endif
/* Clang and G++ support statement expressions, but only in a limited way */
-#if DEBUGBUILD && HAVE_STATEMENT_EXPRESSIONS && !defined(__clang__) && !defined(__cplusplus)
+#if DEBUGBUILD && HAVE_STATEMENT_EXPRESSIONS && !defined(__cplusplus)
/* These are wrappers around the following idiom:
* assert(SOME_PRED(obj));
* do_something_with(obj);
@@ -888,7 +908,6 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
# define C_memchr memchr
# define C_memset memset
# define C_memmove memmove
-# define C_strncasecmp strncasecmp
# define C_malloc malloc
# define C_calloc calloc
# define C_free free
@@ -899,7 +918,15 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
# define C_strtoll strtoll
# define C_strtod strtod
# define C_strtoul strtoul
-# define C_fopen fopen
+# ifdef C_WCHAR_FILENAMES
+# define C_fopen _wfopen
+# define C_system _wsystem
+# define C_access _waccess
+# else
+# define C_fopen fopen
+# define C_system system
+# define C_access access
+# endif
# define C_fclose fclose
# define C_strpbrk strpbrk
# define C_strcspn strcspn
@@ -927,7 +954,6 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
# 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
@@ -936,8 +962,6 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
# endif
# 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
@@ -956,11 +980,6 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
# 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
# define C_sin sin
# define C_cos cos
# define C_tan tan
@@ -986,9 +1005,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
# define C_modf modf
# define C_readlink readlink
# define C_getcwd getcwd
-# define C_access access
# define C_getpid getpid
-# define C_getenv getenv
# define C_fma fma
#else
/* provide this file and define C_PROVIDE_LIBC_STUBS if you want to use
@@ -1019,7 +1036,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_symbol_value(x) (C_block_item(x, 0))
#define C_symbol_name(x) (C_block_item(x, 1))
#define C_symbol_plist(x) (C_block_item(x, 2))
-#define C_save(x) (*(--C_temporary_stack) = (C_word)(x))
+#define C_save(x) (*(--C_temporary_stack) = (C_word)(x))
#define C_rescue(x, i) (C_temporary_stack[ i ] = (x))
#define C_restore (*(C_temporary_stack++))
#define C_heaptop ((C_word **)(&C_fromspace_top))
@@ -1048,8 +1065,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_make_character(c) (((((C_uword)(c)) & C_CHAR_BIT_MASK) << C_CHAR_SHIFT) | C_CHARACTER_BITS)
#define C_character_code(x) C_CHECKp(x,C_charp(C_VAL1(x)),((C_word)(C_VAL1(x)) >> C_CHAR_SHIFT) & C_CHAR_BIT_MASK)
#define C_flonum_magnitude(x) (*C_CHECKp(x,C_flonump(C_VAL1(x)),(double *)C_data_pointer(C_VAL1(x))))
-/* XXX Sometimes this is (ab)used on bytevectors (ie, blob=? uses string_compare) */
-#define C_c_string(x) C_CHECK(x,(C_truep(C_stringp(C_VAL1(x))) || C_truep(C_bytevectorp(C_VAL1(x)))),(C_char *)C_data_pointer(C_VAL1(x)))
+#define C_c_string(x) C_CHECK(x,(C_truep(C_bytevectorp(C_VAL1(x)))),(C_char *)C_data_pointer(C_VAL1(x)))
#define C_c_pointer(x) ((void *)(x))
#define C_c_pointer_nn(x) ((void *)C_block_item(x, 0))
@@ -1064,15 +1080,13 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_bignum_digits(b) C_CHECKp(b,C_bignump(C_VAL1(b)),(((C_uword *)C_data_pointer(C_internal_bignum_vector(C_VAL1(b))))+1))
#define C_fitsinbignumhalfdigitp(n)(C_BIGNUM_DIGIT_HI_HALF(n) == 0)
#define C_bignum_negated_fitsinfixnump(b) (C_bignum_size(b) == 1 && (C_bignum_negativep(b) ? C_ufitsinfixnump(*C_bignum_digits(b)) : !(*C_bignum_digits(b) & C_INT_SIGN_BIT) && C_fitsinfixnump(-(C_word)*C_bignum_digits(b))))
-#define C_bignum_mutate_size(b, s) (C_block_header(C_internal_bignum_vector(b)) = (C_STRING_TYPE | C_wordstobytes((s)+1)))
+#define C_bignum_mutate_size(b, s) (C_block_header(C_internal_bignum_vector(b)) = (C_BYTEVECTOR_TYPE | C_wordstobytes((s)+1)))
#define C_fitsinfixnump(n) (((n) & C_INT_SIGN_BIT) == (((C_uword)(n) & C_INT_TOP_BIT) << 1))
#define C_ufitsinfixnump(n) (((n) & (C_INT_SIGN_BIT | (C_INT_SIGN_BIT >> 1))) == 0)
#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_srfi_4_vector(x) C_data_pointer(C_block_item(x,1))
-#define C_c_u8vector(x) ((unsigned char *)C_srfi_4_vector(x))
-#define C_c_u8vector_or_null(x) ((unsigned char *)C_srfi_4_vector_or_null(x))
#define C_c_s8vector(x) ((signed char *)C_srfi_4_vector(x))
#define C_c_s8vector_or_null(x) ((signed char *)C_srfi_4_vector_or_null(x))
#define C_c_u16vector(x) ((unsigned short *)C_srfi_4_vector(x))
@@ -1171,10 +1185,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_slot(x, i) C_block_item(x, C_unfix(i))
#define C_subbyte(x, i) C_fix(((C_byte *)C_data_pointer(x))[ C_unfix(i) ] & 0xff)
-#define C_subchar(x, i) C_make_character(((C_uchar *)C_data_pointer(x))[ C_unfix(i) ])
-#define C_setbyte(x, i, n) (((C_byte *)C_data_pointer(x))[ C_unfix(i) ] = C_unfix(n), C_SCHEME_UNDEFINED)
-#define C_setsubchar(x, i, n) (((C_char *)C_data_pointer(x))[ C_unfix(i) ] = C_character_code(n), C_SCHEME_UNDEFINED)
-#define C_setsubbyte(x, i, n) (((C_char *)C_data_pointer(x))[ C_unfix(i) ] = C_unfix(n), C_SCHEME_UNDEFINED)
+#define C_setsubbyte(x, i, n) ((((C_byte *)C_data_pointer(x))[ C_unfix(i) ] = C_unfix(n) & 0xff), 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))
@@ -1224,9 +1235,9 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_a_i_pointer_to_address(ptr, c, pptr) C_unsigned_int_to_num(ptr, (unsigned int)C_c_pointer_nn(pptr))
#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_data_pointer(s), sizeof(C_char), C_header_size(s), \
- C_port_file(p)), C_SCHEME_UNDEFINED)
+#define C_display_char(p, c) (C_utf_putc(C_character_code(c), C_port_file(p)), C_SCHEME_UNDEFINED)
+#define C_display_string(p, s, start, len) \
+ (C_fwrite(C_c_string(s) + C_unfix(start), sizeof(C_char), C_unfix(len), C_port_file(p)), C_SCHEME_UNDEFINED)
#define C_flush_output(port) (C_fflush(C_port_file(port)), C_SCHEME_UNDEFINED)
#define C_fix_to_char(x) (C_make_character(C_unfix(x)))
@@ -1236,26 +1247,28 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_u_i_char_lessp(x, y) C_mk_bool(C_character_code(x) < C_character_code(y))
#define C_u_i_char_greater_or_equal_p(x, y) C_mk_bool(C_character_code(x) >= C_character_code(y))
#define C_u_i_char_less_or_equal_p(x, y) C_mk_bool(C_character_code(x) <= C_character_code(y))
-#define C_substring_copy(s1, s2, start1, end1, start2) \
- (C_memmove((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_memcasecmp((C_char *)C_data_pointer(s1) + C_unfix(start1), \
- (C_char *)C_data_pointer(s2) + C_unfix(start2), \
- C_unfix(len) ) == 0)
+
+#define C_bv_compare(x, y, n) C_mk_bool(C_memcmp(C_data_pointer(x), C_data_pointer(y), C_unfix(n)) == 0)
+#define C_u_i_string_equal_p(x, y) C_utf_equal(x, y)
+#define C_u_i_string_ci_equal_p(x, y) C_utf_equal_ci(x, y)
+
+#define C_u_i_substring_equal_p(x, y, s1, s2, len) \
+ C_mk_bool(C_utf_compare(x, y, s1, s2, len) == C_fix(0))
+#define C_u_i_substring_ci_equal_p(x, y, s1, s2, len) \
+ C_mk_bool(C_utf_compare_ci(x, y, s1, s2, len) == C_fix(0))
+
/* this does not use C_mutate: */
+#define C_copy_bytevector(b1, b2, len) (C_memcpy(C_data_pointer(b2), C_data_pointer(b1), C_unfix(len)), (b2))
+#define C_fill_bytevector(bv, code, start, len) \
+ (C_memset(C_data_pointer(bv) + C_unfix(start), C_unfix(code), C_unfix(len)), \
+ C_SCHEME_UNDEFINED)
#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_rand(n) C_fix((C_word)(((double)rand())/(RAND_MAX + 1.0) * C_unfix(n)))
+#define C_rand(n) C_fix((C_word)(((double)C_fast_rand())/(32767 + 1.0) * C_unfix(n)))
#define C_block_size(x) C_fix(C_header_size(x))
#define C_u_i_bignum_size(b) C_fix(C_bignum_size(b))
#define C_a_u_i_big_to_flo(p, n, b) C_flonum(p, C_bignum_to_double(b))
@@ -1285,14 +1298,12 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
# 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_copy_memory(to, from, n) (C_memmove(C_data_pointer(to), C_data_pointer(from), C_unfix(n)), C_SCHEME_UNDEFINED)
+#define C_copy_memory_with_offset(to, from, start1, start2, n) \
+ (C_memmove(C_data_pointer(to) + C_unfix(start1), C_data_pointer(from) + C_unfix(start2), C_unfix(n)), C_SCHEME_UNDEFINED)
#define C_copy_ptr_memory(to, from, n, toff, foff) \
(C_memmove(C_pointer_address(to) + C_unfix(toff), C_pointer_address(from) + C_unfix(foff), \
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_memcmp(C_c_string(to), C_c_string(from), C_unfix(n)))
-#define C_string_compare_case_insensitive(from, to, n) \
- C_fix(C_memcasecmp(C_c_string(from), C_c_string(to), C_unfix(n)))
#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, s) (C_strlcpy((char *)C_block_item(b, C_unfix(i)), C_data_pointer(from), s), C_SCHEME_UNDEFINED)
#define C_peek_fixnum(b, i) C_fix(C_block_item(b, C_unfix(i)))
@@ -1311,8 +1322,7 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
/* These expect C_VECTOR_TYPE to be 0: */
#define C_vector_to_structure(v) (C_block_header(v) |= C_STRUCTURE_TYPE, C_SCHEME_UNDEFINED)
#define C_vector_to_closure(v) (C_block_header(v) |= C_CLOSURE_TYPE, C_SCHEME_UNDEFINED)
-#define C_string_to_bytevector(s) (C_block_header(s) = C_header_size(s) | C_BYTEVECTOR_TYPE, C_SCHEME_UNDEFINED)
-#define C_string_to_lambdainfo(s) (C_block_header(s) = C_header_size(s) | C_LAMBDA_INFO_TYPE, C_SCHEME_UNDEFINED)
+#define C_bytevector_to_lambdainfo(s) (C_block_header(s) = C_header_size(s) | C_LAMBDA_INFO_TYPE, C_SCHEME_UNDEFINED)
#ifdef C_TIMER_INTERRUPTS
# define C_check_for_interrupt if(--C_timer_interrupt_counter <= 0) C_raise_interrupt(C_TIMER_INTERRUPT_NUMBER)
@@ -1363,14 +1373,17 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#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_alphabeticp(x) C_mk_bool(C_utf_isalpha(C_character_code(x)))
+#define C_u_i_char_numericp(x) C_mk_bool(C_utf_isdigit(C_character_code(x)))
+#define C_u_i_char_whitespacep(x) C_mk_bool(C_utf_isspace(C_character_code(x)))
+#define C_u_i_char_upper_casep(x) C_mk_bool(C_utf_isupper(C_character_code(x)))
+#define C_u_i_char_lower_casep(x) C_mk_bool(C_utf_islower(C_character_code(x)))
+#define C_u_i_digit_value(x) C_fix(C_utf_isdigit(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_u_i_char_upcase(x) C_make_character(C_utf_char_upcase(C_character_code(x)))
+#define C_u_i_char_downcase(x) C_make_character(C_utf_char_downcase(C_character_code(x)))
+#define C_utf_length(bv) C_fix(C_utf_count((C_char *)C_data_pointer(bv), C_header_size(bv) - 1))
+#define C_utf_range_length(bv, from, to) C_fix(C_utf_count((C_char *)C_data_pointer(bv) + C_unfix(from), C_unfix(to) - C_unfix(from)))
#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))
@@ -1429,13 +1442,18 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#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_i_check_port(x, in, op) C_i_check_port_2(x, in, op, C_SCHEME_FALSE)
+#define C_i_check_range(i, f, t) C_i_check_range_2(i, f, t, C_SCHEME_FALSE)
+#define C_i_check_range_including(i, f, t) C_i_check_range_including_2(i, f, t, C_SCHEME_FALSE)
-#define C_u_i_8vector_length(x) C_fix(C_header_size(C_block_item(x, 1)))
+#define C_u_i_string_length(x) C_block_item((x), 1)
+#define C_u_i_bytevector_length(x) C_block_size(x)
+
+#define C_u_i_8vector_length C_u_i_bytevector_length
#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_length C_u_i_8vector_length
-#define C_u_i_s8vector_length C_u_i_8vector_length
+#define C_u_i_s8vector_length(x) C_fix(C_header_size(C_block_item(x, 1)))
#define C_u_i_u16vector_length C_u_i_16vector_length
#define C_u_i_s16vector_length C_u_i_16vector_length
#define C_u_i_u32vector_length C_u_i_32vector_length
@@ -1445,7 +1463,8 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_u_i_f32vector_length C_u_i_32vector_length
#define C_u_i_f64vector_length C_u_i_64vector_length
-#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_bytevector_ref(x, i) C_fix(((unsigned char *)C_data_pointer(x))[ C_unfix(i) ])
+#define C_u_i_u8vector_ref C_u_i_bytevector_ref
#define C_u_i_s8vector_ref(x, i) C_fix(((signed 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) ])
@@ -1460,7 +1479,9 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_a_u_i_u64vector_ref(ptr, c, x, i) C_uint64_to_num(ptr, ((C_u64 *)C_data_pointer(C_block_item((x), 1)))[ C_unfix(i) ])
#define C_a_u_i_s64vector_ref(ptr, c, x, i) C_int64_to_num(ptr, ((C_s64 *)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_bytevector_set(x, i, v) ((((unsigned char *)C_data_pointer(x))[ C_unfix(i) ] = C_unfix(v)), C_SCHEME_UNDEFINED)
+#define C_u_i_u8vector_set C_u_i_bytevector_set
+#define C_i_u8vector_set C_i_bytevector_set
#define C_u_i_s8vector_set(x, i, v) ((((signed 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)
@@ -1658,8 +1679,6 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_u_i_flonum_infinitep(x) C_mk_bool(C_isinf(C_flonum_magnitude(x)))
#define C_u_i_flonum_finitep(x) C_mk_bool(C_isfinite(C_flonum_magnitude(x)))
-/* DEPRECATED */
-#define C_a_i_current_milliseconds(ptr, c, dummy) C_uint64_to_num(ptr, C_milliseconds())
#define C_a_i_current_process_milliseconds(ptr, c, dummy) C_uint64_to_num(ptr, C_current_process_milliseconds())
#define C_i_noop1(dummy) ((dummy), C_SCHEME_UNDEFINED)
@@ -1669,6 +1688,10 @@ typedef void (C_ccall *C_proc)(C_word, C_word *) C_noret;
#define C_i_true2(dummy1, dummy2) ((dummy1), (dummy2), C_SCHEME_TRUE)
#define C_i_true3(dummy1, dummy2, dummy3) ((dummy1), (dummy2), (dummy3), C_SCHEME_TRUE)
+/* struct/union wrapping */
+#define C_a_extract_struct(a, t, x) ({t _r = (x); C_a_extract_struct_2(a, sizeof(t), &_r);})
+#define C_build_struct(t, x) ({t _a;_a = *((t *)C_data_pointer(x));_a;})
+
/* debug client interface */
typedef struct C_DEBUG_INFO {
@@ -1691,8 +1714,8 @@ typedef struct C_DEBUG_INFO {
/* Variables: */
-C_varextern C_TLS time_t C_startup_time_seconds;
-C_varextern C_TLS C_word
+C_varextern time_t C_startup_time_seconds;
+C_varextern C_word
*C_temporary_stack,
*C_temporary_stack_bottom,
*C_temporary_stack_limit,
@@ -1702,28 +1725,28 @@ C_varextern C_TLS C_word
*C_scratchspace_top,
*C_scratchspace_limit,
C_scratch_usage;
-C_varextern C_TLS C_long
+C_varextern C_long
C_timer_interrupt_counter,
C_initial_timer_interrupt_period;
-C_varextern C_TLS C_byte
+C_varextern C_byte
*C_fromspace_top,
*C_fromspace_limit;
#ifdef HAVE_SIGSETJMP
-C_varextern C_TLS sigjmp_buf C_restart;
+C_varextern sigjmp_buf C_restart;
#else
-C_varextern C_TLS jmp_buf C_restart;
+C_varextern jmp_buf C_restart;
#endif
-C_varextern C_TLS void *C_restart_address;
-C_varextern C_TLS int C_entry_point_status;
-C_varextern C_TLS int C_gui_mode;
+C_varextern void *C_restart_address;
+C_varextern int C_entry_point_status;
+C_varextern int C_gui_mode;
-C_varextern C_TLS void *C_restart_trampoline;
-C_varextern C_TLS void (*C_pre_gc_hook)(int mode);
-C_varextern C_TLS void (*C_post_gc_hook)(int mode, C_long ms);
-C_varextern C_TLS void (*C_panic_hook)(C_char *msg);
-C_varextern C_TLS C_word (*C_debugger_hook)(C_DEBUG_INFO *cell, C_word c, C_word *av, char *cloc);
+C_varextern void *C_restart_trampoline;
+C_varextern void (*C_pre_gc_hook)(int mode);
+C_varextern void (*C_post_gc_hook)(int mode, C_long ms);
+C_varextern void (*C_panic_hook)(C_char *msg);
+C_varextern C_word (*C_debugger_hook)(C_DEBUG_INFO *cell, C_word c, C_word *av, char *cloc);
-C_varextern C_TLS int
+C_varextern int
C_abort_on_thread_exceptions,
C_interrupts_enabled,
C_disable_overflow_check,
@@ -1732,19 +1755,19 @@ C_varextern C_TLS int
C_trace_buffer_size,
C_debugging,
C_main_argc;
-C_varextern C_TLS C_uword
+C_varextern C_uword
C_heap_growth,
C_heap_shrinkage;
-C_varextern C_TLS char
+C_varextern char
**C_main_argv,
#ifdef SEARCH_EXE_PATH
*C_main_exe,
#endif
*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);
+C_varextern C_uword C_maximal_heap_size;
+C_varextern int (*C_gc_mutation_hook)(C_word *slot, C_word val);
+C_varextern void (*C_gc_trace_hook)(C_word *var, int mode);
+C_varextern C_word (*C_get_unbound_variable_value_hook)(C_word sym);
/* Prototypes: */
@@ -1765,18 +1788,18 @@ 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(C_word *base, int size);
+C_fctexport int C_save_callback_continuation(C_word **ptr, C_word k);
+C_fctexport C_word C_restore_callback_continuation(void);
+C_fctexport C_word C_restore_callback_continuation2(int level);
+C_fctexport C_word C_callback(C_word closure, int argc);
+C_fctexport C_word C_callback_wrapper(void *proc, int argc);
+C_fctexport void 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_a_i_provide(C_word **a, int c, C_word id) C_regparm;
-C_fctexport C_word C_fcall C_i_providedp(C_word id) 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_toplevel_entry(C_char *name) C_regparm;
+C_fctexport C_word C_a_i_provide(C_word **a, int c, C_word id) C_regparm;
+C_fctexport C_word C_i_providedp(C_word id) C_regparm;
+C_fctexport C_word C_enable_interrupts(void) C_regparm;
+C_fctexport C_word C_disable_interrupts(void) C_regparm;
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);
@@ -1785,28 +1808,27 @@ 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 void C_clear_trace_buffer(void) C_regparm;
C_fctexport C_word C_resize_trace_buffer(C_word size);
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_bignum(C_word **ptr, int len, C_char *str) C_regparm;
-C_fctexport C_word C_fcall C_static_bytevector(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_kw(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_kw(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_build_rest(C_word **ptr, C_word c, C_word n, C_word *av) C_regparm;
+C_fctexport C_word C_string(C_word **ptr, int len, C_char *str) C_regparm;
+C_fctexport C_word C_static_string(C_word **ptr, int len, C_char *str) C_regparm;
+C_fctexport C_word C_static_bignum(C_word **ptr, int len, C_char *str) C_regparm;
+C_fctexport C_word C_static_bytevector(C_word **ptr, int len, C_char *str) C_regparm;
+C_fctexport C_word C_static_lambda_info(C_word **ptr, int len, C_char *str) C_regparm;
+C_fctexport C_word C_bytevector(C_word **ptr, int len, C_char *str) C_regparm;
+C_fctexport C_word C_pbytevector(int len, C_char *str) C_regparm;
+C_fctexport C_word C_string2(C_word **ptr, C_char *str) C_regparm;
+C_fctexport C_word C_string2_safe(C_word **ptr, int max, C_char *str) C_regparm;
+C_fctexport C_word C_intern(C_word **ptr, int len, C_char *str) C_regparm;
+C_fctexport C_word C_intern_kw(C_word **ptr, int len, C_char *str) C_regparm;
+C_fctexport C_word C_intern_in(C_word **ptr, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
+C_fctexport C_word C_h_intern(C_word *slot, int len, C_char *str) C_regparm;
+C_fctexport C_word C_h_intern_kw(C_word *slot, int len, C_char *str) C_regparm;
+C_fctexport C_word C_h_intern_in(C_word *slot, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
+C_fctexport C_word C_intern2(C_word **ptr, C_char *str) C_regparm;
+C_fctexport C_word C_intern3(C_word **ptr, C_char *str, C_word value) C_regparm;
+C_fctexport C_word C_build_rest(C_word **ptr, C_word c, C_word n, C_word *av) 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;
@@ -1816,62 +1838,63 @@ C_fctexport void C_bad_min_argc_2(int c, int n, C_word closure) C_noret;
C_fctexport void C_stack_overflow(C_char *loc) 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 void C_div_by_zero_error(char *loc) C_noret;
-C_fctexport void C_not_an_integer_error(char *loc, C_word x) C_noret;
-C_fctexport void C_not_an_uinteger_error(char *loc, C_word x) C_noret;
+C_fctexport void C_div_by_zero_error(C_char *loc) C_noret;
+C_fctexport void C_unimplemented(C_char *msg) C_noret;
+C_fctexport void C_not_an_integer_error(C_char *loc, C_word x) C_noret;
+C_fctexport void C_not_an_uinteger_error(C_char *loc, C_word x) C_noret;
C_fctexport void C_rest_arg_out_of_bounds_error(C_word c, C_word n, C_word ka) C_noret;
C_fctexport void C_rest_arg_out_of_bounds_error_2(C_word c, C_word n, C_word ka, C_word closure) 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_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_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_pair(C_word **ptr, C_word car, C_word cdr) C_regparm;
+C_fctexport C_word C_number(C_word **ptr, double n) C_regparm;
+C_fctexport C_word C_mpointer(C_word **ptr, void *mp) C_regparm;
+C_fctexport C_word C_mpointer_or_false(C_word **ptr, void *mp) C_regparm;
+C_fctexport C_word C_taggedmpointer(C_word **ptr, C_word tag, void *mp) C_regparm;
+C_fctexport C_word C_taggedmpointer_or_false(C_word **ptr, C_word tag, void *mp) C_regparm;
C_fctexport C_word C_vector(C_word **ptr, int n, ...);
C_fctexport C_word C_structure(C_word **ptr, int n, ...);
-C_fctexport C_word C_fcall C_mutate_slot(C_word *slot, C_word val) C_regparm;
-C_fctexport C_word C_fcall C_scratch_alloc(C_uword size) C_regparm;
-C_fctexport C_word C_fcall C_migrate_buffer_object(C_word **ptr, C_word *start, C_word *end, C_word obj) C_regparm;
-C_fctexport void C_fcall C_reclaim(void *trampoline, C_word c) C_regparm C_noret;
+C_fctexport C_word C_mutate_slot(C_word *slot, C_word val) C_regparm;
+C_fctexport C_word C_mutate_scratch_slot(C_word *slot, C_word val) C_regparm;
+C_fctexport C_word C_scratch_alloc(C_uword size) C_regparm;
+C_fctexport C_word C_migrate_buffer_object(C_word **ptr, C_word *start, C_word *end, C_word obj) C_regparm;
+C_fctexport void C_reclaim(void *trampoline, C_word c) C_regparm C_noret;
C_fctexport void C_save_and_reclaim(void *trampoline, int n, C_word *av) C_noret;
C_fctexport void C_save_and_reclaim_args(void *trampoline, int n, ...) C_noret;
-C_fctexport void C_fcall C_rereclaim2(C_uword size, int relative_resize) C_regparm;
+C_fctexport void C_rereclaim2(C_uword size, int relative_resize) C_regparm;
C_fctexport void C_unbound_variable(C_word sym);
-C_fctexport C_word C_fcall C_retrieve2(C_word val, char *name) C_regparm;
-C_fctexport void *C_fcall C_retrieve2_symbol_proc(C_word val, char *name) C_regparm;
+C_fctexport void C_decoding_error(C_word str, C_word index);
+C_fctexport C_word C_retrieve2(C_word val, char *name) C_regparm;
+C_fctexport void *C_retrieve2_symbol_proc(C_word val, char *name) 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 int C_fcall C_in_scratchspacep(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_info2(char *raw, C_word l, C_word x, C_word y, C_word t) C_regparm;
-C_fctexport C_word C_fcall C_u_i_string_hash(C_word str, C_word rnd) C_regparm;
-C_fctexport C_word C_fcall C_u_i_string_ci_hash(C_word str, C_word rnd) C_regparm;
+C_fctexport int C_in_heapp(C_word x) C_regparm;
+C_fctexport int C_in_fromspacep(C_word x) C_regparm;
+C_fctexport int C_in_scratchspacep(C_word x) C_regparm;
+C_fctexport void C_trace(C_char *name) C_regparm;
+C_fctexport C_word C_emit_trace_info2(char *raw, C_word l, C_word x, C_word y, C_word t) C_regparm;
+C_fctexport C_word C_u_i_bytevector_hash(C_word str, C_word start, C_word end, C_word rnd) 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_equalp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_set_gc_report(C_word flag) C_regparm;
+C_fctexport C_word C_start_timer(void) C_regparm;
C_fctexport C_word C_exit_runtime(C_word code) C_noret;
-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 int C_fcall C_check_fd_ready(int fd) C_regparm;
-C_fctexport C_word C_fcall C_char_ready_p(C_word port) C_regparm;
-C_fctexport void C_fcall C_raise_interrupt(int reason) 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_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_word C_set_print_precision(C_word n) C_regparm;
+C_fctexport C_word C_get_print_precision(void) C_regparm;
+C_fctexport C_word C_read_char(C_word port) C_regparm;
+C_fctexport C_word C_execute_shell_command(C_word string) C_regparm;
+C_fctexport int C_check_fd_ready(int fd) C_regparm;
+C_fctexport C_word C_char_ready_p(C_word port) C_regparm;
+C_fctexport void C_raise_interrupt(int reason) C_regparm;
+C_fctexport C_word C_establish_signal_handler(C_word signum, C_word reason) C_regparm;
+C_fctexport C_word C_copy_block(C_word from, C_word to) C_regparm;
+C_fctexport C_word C_evict_block(C_word from, C_word ptr) C_regparm;
+C_fctexport void C_gc_protect(C_word **addr, int n) C_regparm;
+C_fctexport void 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 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_find_keyword(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_lookup_symbol(C_word sym) 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);
@@ -1880,6 +1903,53 @@ C_fctexport C_char *C_private_repository_path();
C_fctexport C_char *C_executable_dirname();
C_fctexport C_char *C_executable_pathname();
C_fctexport C_char *C_resolve_executable_pathname(C_char *fname);
+C_fctexport C_char *C_getenv(C_word var);
+C_fctexport C_char *C_getenventry(int i);
+
+/* utf.c: */
+C_fctexport C_word C_utf_subchar(C_word s, C_word i) C_regparm;
+C_fctexport C_word C_utf_setsubchar(C_word s, C_word i, C_word c) C_regparm;
+C_fctexport C_word C_utf_compare(C_word s1, C_word s2, C_word start1, C_word start2, C_word len) C_regparm;
+C_fctexport C_word C_utf_compare_ci(C_word s1, C_word s2, C_word start1, C_word start2, C_word len) C_regparm;
+C_fctexport C_word C_utf_equal(C_word s1, C_word s2) C_regparm;
+C_fctexport C_word C_utf_equal_ci(C_word s1, C_word s2) C_regparm;
+C_fctexport C_word C_utf_copy(C_word from, C_word to, C_word start1, C_word end1, C_word start2) C_regparm;
+C_fctexport C_word C_utf_position(C_word str, C_word start) C_regparm;
+C_fctexport int C_utf_char_position(C_word bv, int pos) C_regparm;
+C_fctexport C_word C_utf_range(C_word str, C_word start, C_word end) C_regparm;
+C_fctexport int C_utf_count(C_char *str, int len) C_regparm;
+C_fctexport int C_utf_fast_count(C_char *str, int len) C_regparm;
+C_fctexport C_char * C_utf_encode(C_char *str, int chr) C_regparm;
+C_fctexport C_word C_utf_decode_ptr(C_char *bv) C_regparm;
+C_fctexport C_word C_utf_decode(C_word bv, C_word pos) C_regparm;
+C_fctexport int C_utf_char_downcase(int c) C_regparm;
+C_fctexport int C_utf_char_upcase(int c) C_regparm;
+C_fctexport C_word C_utf_advance(C_word bv, C_word pos) C_regparm;
+C_fctexport C_word C_utf_insert(C_word bv, C_word pos, C_word c) C_regparm;
+C_fctexport C_word C_utf_bytes(C_word chr) C_regparm;
+C_fctexport C_word C_utf_fill(C_word bv, C_word chr) C_regparm;
+C_fctexport int C_utf_expect(int byte) C_regparm;
+C_fctexport void C_utf_putc(int chr, C_FILEPTR fp) C_regparm;
+C_fctexport C_word C_utf_fragment_counts(C_word bv, C_word pos, C_word len) C_regparm;
+C_fctexport C_word C_utf_overwrite(C_word s, C_word i, C_word len, C_word bv, C_word c) C_regparm;
+C_fctexport C_word C_utf_list_size(C_word lst) C_regparm;
+C_fctexport int C_utf_isspace(int c) C_regparm;
+C_fctexport int C_utf_isdigit(int c) C_regparm;
+C_fctexport int C_utf_isalpha(int c) C_regparm;
+C_fctexport int C_utf_isupper(int c) C_regparm;
+C_fctexport int C_utf_islower(int c) C_regparm;
+C_fctexport C_word C_utf_validate(C_word bv, C_word blen) C_regparm;
+C_fctexport C_word C_latin_to_utf(C_word from, C_word to, C_word start, C_word len) C_regparm;
+C_fctexport C_word C_utf_to_latin(C_word from, C_word to, C_word start, C_word len) C_regparm;
+C_fctexport C_word C_utf_char_foldcase(C_word c) C_regparm;
+C_fctexport C_word C_utf_string_foldcase(C_word from, C_word to, C_word len) C_regparm;
+#ifdef C_WCHAR_FILENAMES
+C_fctexport C_WCHAR *C_utf16(C_word bv, int cont) C_regparm;
+C_fctexport C_char *C_utf8(C_WCHAR *str) C_regparm;
+# define C_OS_FILENAME(bv, f) C_utf16(bv, f)
+#else
+# define C_OS_FILENAME(bv, f) C_c_string(bv)
+#endif
C_fctimport C_cpsproc(C_toplevel) C_noret;
C_fctimport C_cpsproc(C_invalid_procedure) C_noret;
@@ -1909,6 +1979,7 @@ C_fctexport C_cpsproc(C_less_or_equal_p) C_noret;
C_fctexport C_cpsproc(C_gc) C_noret;
C_fctexport C_cpsproc(C_open_file_port) C_noret;
C_fctexport C_cpsproc(C_allocate_vector) C_noret;
+C_fctexport C_cpsproc(C_allocate_bytevector) C_noret;
C_fctexport C_cpsproc(C_string_to_symbol) C_noret;
C_fctexport C_cpsproc(C_string_to_keyword) C_noret;
C_fctexport C_cpsproc(C_build_symbol) C_noret;
@@ -1944,240 +2015,244 @@ C_fctexport C_cpsproc(C_copy_closure) C_noret;
C_fctexport C_cpsproc(C_dump_heap_state) C_noret;
C_fctexport C_cpsproc(C_filter_heap_objects) C_noret;
-C_fctexport time_t C_fcall C_seconds(C_long *ms) C_regparm;
-C_fctexport C_word C_fcall C_bignum_simplify(C_word big) C_regparm;
-C_fctexport C_word C_fcall C_allocate_scratch_bignum(C_word **ptr, C_word size, C_word negp, C_word initp) C_regparm;
-C_fctexport C_word C_fcall C_bignum_rewrap(C_word **p, C_word big) C_regparm;
+C_fctexport time_t C_seconds(C_long *ms) C_regparm;
+C_fctexport C_word C_bignum_simplify(C_word big) C_regparm;
+C_fctexport C_word C_allocate_scratch_bignum(C_word **ptr, C_word size, C_word negp, C_word initp) C_regparm;
+C_fctexport C_word C_bignum_rewrap(C_word **p, C_word big) C_regparm;
C_fctexport C_word C_i_dump_statistical_profile();
C_fctexport C_word C_a_i_list(C_word **a, 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_listp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_u8vectorp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_s8vectorp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_u16vectorp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_s16vectorp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_u32vectorp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_s32vectorp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_u64vectorp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_s64vectorp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_f32vectorp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_f64vectorp(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_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_u8vector_set(C_word v, C_word i, C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_s8vector_set(C_word v, C_word i, C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_u16vector_set(C_word v, C_word i, C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_s16vector_set(C_word v, C_word i, C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_u32vector_set(C_word v, C_word i, C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_s32vector_set(C_word v, C_word i, C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_u64vector_set(C_word v, C_word i, C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_s64vector_set(C_word v, C_word i, C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_f32vector_set(C_word v, C_word i, C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_f64vector_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_i_inexactp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_nanp(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_infinitep(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; /* DEPRECATED */
-C_fctexport C_word C_fcall C_i_positivep(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_integer_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_i_integer_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_caar(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_cdar(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_i_integer_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_i_integer_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_u8vector_ref(C_word v, C_word i) C_regparm;
-C_fctexport C_word C_fcall C_i_s8vector_ref(C_word v, C_word i) C_regparm;
-C_fctexport C_word C_fcall C_i_u16vector_ref(C_word v, C_word i) C_regparm;
-C_fctexport C_word C_fcall C_i_s16vector_ref(C_word v, C_word i) C_regparm;
-C_fctexport C_word C_fcall C_a_i_u32vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
-C_fctexport C_word C_fcall C_a_i_s32vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
-C_fctexport C_word C_fcall C_a_i_u64vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
-C_fctexport C_word C_fcall C_a_i_s64vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
-C_fctexport C_word C_fcall C_a_i_f32vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
-C_fctexport C_word C_fcall C_a_i_f64vector_ref(C_word **ptr, C_word c, 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_u8vector_length(C_word v) C_regparm;
-C_fctexport C_word C_fcall C_i_s8vector_length(C_word v) C_regparm;
-C_fctexport C_word C_fcall C_i_u16vector_length(C_word v) C_regparm;
-C_fctexport C_word C_fcall C_i_s16vector_length(C_word v) C_regparm;
-C_fctexport C_word C_fcall C_i_u32vector_length(C_word v) C_regparm;
-C_fctexport C_word C_fcall C_i_s32vector_length(C_word v) C_regparm;
-C_fctexport C_word C_fcall C_i_u64vector_length(C_word v) C_regparm;
-C_fctexport C_word C_fcall C_i_s64vector_length(C_word v) C_regparm;
-C_fctexport C_word C_fcall C_i_f32vector_length(C_word v) C_regparm;
-C_fctexport C_word C_fcall C_i_f64vector_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_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_check_closure_2(C_word x, C_word loc) C_regparm;
-C_fctexport C_word C_fcall C_i_check_fixnum_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; /* DEPRECATED */
-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_keyword_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_boolean_2(C_word x, C_word loc) C_regparm;
-C_fctexport C_word C_fcall C_i_check_locative_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_i_check_port_2(C_word x, C_word in, C_word op, C_word loc) C_regparm;
-C_fctexport C_word C_fcall C_i_bignum_cmp(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_integer_equalp(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_integer_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_integer_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_integer_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_integer_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_i_null_pointerp(C_word x) C_regparm;
-C_fctexport C_word C_fcall C_i_char_equalp(C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_i_char_greaterp(C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_i_char_lessp(C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_i_char_greater_or_equal_p(C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_i_char_less_or_equal_p(C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_a_i_locative_ref(C_word **a, int c, C_word loc) 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_i_locative_index(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_i_bit_to_bool(C_word n, C_word i) C_regparm; /* DEPRECATED */
-C_fctexport C_word C_fcall C_i_integer_length(C_word x) 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_sinh(C_word **a, int c, C_word n) C_regparm;
-C_fctexport C_word C_fcall C_a_i_cosh(C_word **a, int c, C_word n) C_regparm;
-C_fctexport C_word C_fcall C_a_i_tanh(C_word **a, int c, C_word n) C_regparm;
-C_fctexport C_word C_fcall C_a_i_asinh(C_word **a, int c, C_word n) C_regparm;
-C_fctexport C_word C_fcall C_a_i_acosh(C_word **a, int c, C_word n) C_regparm;
-C_fctexport C_word C_fcall C_a_i_atanh(C_word **a, int c, C_word n) 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_times(C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_i_o_fixnum_quotient(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_a_i_flonum_round_proper(C_word **a, int c, C_word n) C_regparm;
-C_fctexport C_word C_fcall C_a_i_flonum_gcd(C_word **p, C_word n, C_word x, C_word y) C_regparm;
-
-C_fctexport C_word C_fcall C_i_getprop(C_word sym, C_word prop, C_word def) C_regparm;
-C_fctexport C_word C_fcall C_putprop(C_word **a, C_word sym, C_word prop, C_word val) C_regparm;
-C_fctexport C_word C_fcall C_i_persist_symbol(C_word sym) C_regparm;
-C_fctexport C_word C_fcall C_i_unpersist_symbol(C_word sym) C_regparm;
-C_fctexport C_word C_fcall C_i_get_keyword(C_word key, C_word args, C_word def) C_regparm;
-C_fctexport C_word C_fcall C_i_process_sleep(C_word n) C_regparm;
-C_fctexport C_u64 C_fcall C_milliseconds(void) C_regparm; /* DEPRECATED */
-C_fctexport C_u64 C_fcall C_current_process_milliseconds(void) C_regparm;
-C_fctexport C_u64 C_fcall C_cpu_milliseconds(void) C_regparm;
-C_fctexport double C_fcall C_bignum_to_double(C_word bignum) C_regparm;
-C_fctexport C_word C_fcall C_i_debug_modep(void) C_regparm;
-C_fctexport C_word C_fcall C_i_dump_heap_on_exitp(void) C_regparm;
-C_fctexport C_word C_fcall C_i_accumulated_gc_time(void) C_regparm;
-C_fctexport C_word C_fcall C_i_allocated_finalizer_count(void) C_regparm;
-C_fctexport C_word C_fcall C_i_live_finalizer_count(void) C_regparm;
-C_fctexport C_word C_fcall C_i_profilingp(void) C_regparm;
-C_fctexport C_word C_fcall C_i_tty_forcedp(void) C_regparm;
-
-
-C_fctexport C_word C_fcall C_a_i_cpu_time(C_word **a, int c, C_word buf) C_regparm;
-C_fctexport C_word C_fcall C_a_i_exact_to_inexact(C_word **a, int c, C_word n) C_regparm;
-C_fctexport C_word C_fcall C_i_file_exists_p(C_word name, C_word file, C_word dir) C_regparm;
-
-C_fctexport C_word C_fcall C_s_a_i_abs(C_word **ptr, C_word n, C_word x) C_regparm;
-C_fctexport C_word C_fcall C_s_a_i_negate(C_word **ptr, C_word n, C_word x) C_regparm;
-C_fctexport C_word C_fcall C_s_a_i_minus(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_s_a_u_i_integer_negate(C_word **ptr, C_word n, C_word x) C_regparm;
-C_fctexport C_word C_fcall C_s_a_u_i_integer_minus(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_s_a_i_plus(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_s_a_u_i_integer_plus(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_s_a_u_i_integer_times(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_s_a_i_arithmetic_shift(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_s_a_u_i_integer_gcd(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_s_a_i_quotient(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_s_a_u_i_integer_quotient(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_s_a_i_remainder(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_s_a_u_i_integer_remainder(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_s_a_i_modulo(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_s_a_u_i_integer_modulo(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_s_a_i_bitwise_and(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_s_a_i_bitwise_ior(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_s_a_i_bitwise_xor(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
-C_fctexport C_word C_fcall C_s_a_i_bitwise_not(C_word **ptr, C_word n, C_word x) C_regparm;
-C_fctexport C_word C_fcall C_s_a_i_digits_to_integer(C_word **ptr, C_word n, C_word str, C_word start, C_word end, C_word radix, C_word negp) C_regparm;
-C_fctexport C_word C_fcall C_s_a_u_i_flo_to_int(C_word **ptr, C_word n, C_word x) 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_struct_wrapper_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_ranged_integer_argumentp(C_word x, C_word bits) C_regparm;
-C_fctexport C_word C_fcall C_i_foreign_unsigned_ranged_integer_argumentp(C_word x, C_word bits) C_regparm;
+C_fctexport C_word C_a_i_bytevector(C_word **a, int c, C_word x) C_regparm;
+C_fctexport C_word C_i_listp(C_word x) C_regparm;
+C_fctexport C_word C_i_s8vectorp(C_word x) C_regparm;
+C_fctexport C_word C_i_u16vectorp(C_word x) C_regparm;
+C_fctexport C_word C_i_s16vectorp(C_word x) C_regparm;
+C_fctexport C_word C_i_u32vectorp(C_word x) C_regparm;
+C_fctexport C_word C_i_s32vectorp(C_word x) C_regparm;
+C_fctexport C_word C_i_u64vectorp(C_word x) C_regparm;
+C_fctexport C_word C_i_s64vectorp(C_word x) C_regparm;
+C_fctexport C_word C_i_f32vectorp(C_word x) C_regparm;
+C_fctexport C_word C_i_f64vectorp(C_word x) C_regparm;
+C_fctexport C_word C_i_string_equal_p(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_string_ci_equal_p(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_set_car(C_word p, C_word x) C_regparm;
+C_fctexport C_word C_i_set_cdr(C_word p, C_word x) C_regparm;
+C_fctexport C_word C_i_vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_i_bytevector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_i_s8vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_i_u16vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_i_s16vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_i_u32vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_i_s32vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_i_u64vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_i_s64vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_i_f32vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_i_f64vector_set(C_word v, C_word i, C_word x) C_regparm;
+C_fctexport C_word C_i_exactp(C_word x) C_regparm;
+C_fctexport C_word C_i_inexactp(C_word x) C_regparm;
+C_fctexport C_word C_i_nanp(C_word x) C_regparm;
+C_fctexport C_word C_i_finitep(C_word x) C_regparm;
+C_fctexport C_word C_i_infinitep(C_word x) C_regparm;
+C_fctexport C_word C_i_zerop(C_word x) C_regparm;
+C_fctexport C_word C_u_i_zerop(C_word x) C_regparm; /* DEPRECATED */
+C_fctexport C_word C_i_positivep(C_word x) C_regparm;
+C_fctexport C_word C_i_integer_positivep(C_word x) C_regparm;
+C_fctexport C_word C_i_negativep(C_word x) C_regparm;
+C_fctexport C_word C_i_integer_negativep(C_word x) C_regparm;
+C_fctexport C_word C_i_car(C_word x) C_regparm;
+C_fctexport C_word C_i_cdr(C_word x) C_regparm;
+C_fctexport C_word C_i_caar(C_word x) C_regparm;
+C_fctexport C_word C_i_cadr(C_word x) C_regparm;
+C_fctexport C_word C_i_cdar(C_word x) C_regparm;
+C_fctexport C_word C_i_cddr(C_word x) C_regparm;
+C_fctexport C_word C_i_caddr(C_word x) C_regparm;
+C_fctexport C_word C_i_cdddr(C_word x) C_regparm;
+C_fctexport C_word C_i_cadddr(C_word x) C_regparm;
+C_fctexport C_word C_i_cddddr(C_word x) C_regparm;
+C_fctexport C_word C_i_list_tail(C_word lst, C_word i) C_regparm;
+C_fctexport C_word C_i_evenp(C_word x) C_regparm;
+C_fctexport C_word C_i_integer_evenp(C_word x) C_regparm;
+C_fctexport C_word C_i_oddp(C_word x) C_regparm;
+C_fctexport C_word C_i_integer_oddp(C_word x) C_regparm;
+C_fctexport C_word C_i_vector_ref(C_word v, C_word i) C_regparm;
+C_fctexport C_word C_i_bytevector_ref(C_word v, C_word i) C_regparm;
+C_fctexport C_word C_i_s8vector_ref(C_word v, C_word i) C_regparm;
+C_fctexport C_word C_i_u16vector_ref(C_word v, C_word i) C_regparm;
+C_fctexport C_word C_i_s16vector_ref(C_word v, C_word i) C_regparm;
+C_fctexport C_word C_a_i_u32vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
+C_fctexport C_word C_a_i_s32vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
+C_fctexport C_word C_a_i_u64vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
+C_fctexport C_word C_a_i_s64vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
+C_fctexport C_word C_a_i_f32vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
+C_fctexport C_word C_a_i_f64vector_ref(C_word **ptr, C_word c, C_word v, C_word i) C_regparm;
+C_fctexport C_word C_i_block_ref(C_word x, C_word i) C_regparm;
+C_fctexport C_word C_i_string_set(C_word s, C_word i, C_word c) C_regparm;
+C_fctexport C_word C_i_string_ref(C_word s, C_word i) C_regparm;
+C_fctexport C_word C_i_vector_length(C_word v) C_regparm;
+C_fctexport C_word C_i_bytevector_length(C_word v) C_regparm;
+C_fctexport C_word C_i_s8vector_length(C_word v) C_regparm;
+C_fctexport C_word C_i_u16vector_length(C_word v) C_regparm;
+C_fctexport C_word C_i_s16vector_length(C_word v) C_regparm;
+C_fctexport C_word C_i_u32vector_length(C_word v) C_regparm;
+C_fctexport C_word C_i_s32vector_length(C_word v) C_regparm;
+C_fctexport C_word C_i_u64vector_length(C_word v) C_regparm;
+C_fctexport C_word C_i_s64vector_length(C_word v) C_regparm;
+C_fctexport C_word C_i_f32vector_length(C_word v) C_regparm;
+C_fctexport C_word C_i_f64vector_length(C_word v) C_regparm;
+C_fctexport C_word C_i_string_length(C_word s) C_regparm;
+C_fctexport C_word C_i_assq(C_word x, C_word lst) C_regparm;
+C_fctexport C_word C_i_assv(C_word x, C_word lst) C_regparm;
+C_fctexport C_word C_i_assoc(C_word x, C_word lst) C_regparm;
+C_fctexport C_word C_i_memq(C_word x, C_word lst) C_regparm;
+C_fctexport C_word C_u_i_memq(C_word x, C_word lst) C_regparm;
+C_fctexport C_word C_i_memv(C_word x, C_word lst) C_regparm;
+C_fctexport C_word C_i_member(C_word x, C_word lst) C_regparm;
+C_fctexport C_word C_i_length(C_word lst) C_regparm;
+C_fctexport C_word C_u_i_length(C_word lst) C_regparm;
+C_fctexport C_word C_i_check_closure_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_i_check_fixnum_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_i_check_exact_2(C_word x, C_word loc) C_regparm; /* DEPRECATED */
+C_fctexport C_word C_i_check_inexact_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_i_check_number_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_i_check_string_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_i_check_bytevector_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_i_check_symbol_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_i_check_keyword_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_i_check_list_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_i_check_pair_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_i_check_boolean_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_i_check_locative_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_i_check_vector_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_i_check_structure_2(C_word x, C_word st, C_word loc) C_regparm;
+C_fctexport C_word C_i_check_char_2(C_word x, C_word loc) C_regparm;
+C_fctexport C_word C_i_check_port_2(C_word x, C_word in, C_word op, C_word loc) C_regparm;
+C_fctexport C_word C_i_check_range_2(C_word i, C_word f, C_word t, C_word loc) C_regparm;
+C_fctexport C_word C_i_check_range_including_2(C_word i, C_word f, C_word t, C_word loc) C_regparm;
+C_fctexport C_word C_i_bignum_cmp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_nequalp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_integer_equalp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_greaterp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_integer_greaterp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_lessp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_integer_lessp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_greater_or_equalp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_integer_greater_or_equalp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_less_or_equalp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_integer_less_or_equalp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_not_pair_p_2(C_word x) C_regparm;
+C_fctexport C_word C_i_null_list_p(C_word x) C_regparm;
+C_fctexport C_word C_i_string_null_p(C_word x) C_regparm;
+C_fctexport C_word C_i_null_pointerp(C_word x) C_regparm;
+C_fctexport C_word C_i_char_equalp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_char_greaterp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_char_lessp(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_char_greater_or_equal_p(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_char_less_or_equal_p(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_a_i_locative_ref(C_word **a, int c, C_word loc) C_regparm;
+C_fctexport C_word C_i_locative_set(C_word loc, C_word x) C_regparm;
+C_fctexport C_word C_i_locative_to_object(C_word loc) C_regparm;
+C_fctexport C_word C_i_locative_index(C_word loc) C_regparm;
+C_fctexport C_word 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_i_bit_to_bool(C_word n, C_word i) C_regparm; /* DEPRECATED */
+C_fctexport C_word C_i_integer_length(C_word x) C_regparm;
+C_fctexport C_word C_a_i_exp(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_a_i_log(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_a_i_sin(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_a_i_cos(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_a_i_tan(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_a_i_asin(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_a_i_acos(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_a_i_atan(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2) C_regparm;
+C_fctexport C_word C_a_i_sinh(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_a_i_cosh(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_a_i_tanh(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_a_i_asinh(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_a_i_acosh(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_a_i_atanh(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_a_i_sqrt(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_i_o_fixnum_plus(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_o_fixnum_difference(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_o_fixnum_times(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_o_fixnum_quotient(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_o_fixnum_and(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_o_fixnum_ior(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_i_o_fixnum_xor(C_word x, C_word y) C_regparm;
+C_fctexport C_word C_a_i_flonum_round_proper(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_a_i_flonum_gcd(C_word **p, C_word n, C_word x, C_word y) C_regparm;
+
+C_fctexport C_word C_i_getprop(C_word sym, C_word prop, C_word def) C_regparm;
+C_fctexport C_word C_putprop(C_word **a, C_word sym, C_word prop, C_word val) C_regparm;
+C_fctexport C_word C_i_persist_symbol(C_word sym) C_regparm;
+C_fctexport C_word C_i_unpersist_symbol(C_word sym) C_regparm;
+C_fctexport C_word C_i_get_keyword(C_word key, C_word args, C_word def) C_regparm;
+C_fctexport C_word C_i_process_sleep(C_word n) C_regparm;
+C_fctexport C_u64 C_milliseconds(void) C_regparm; /* DEPRECATED */
+C_fctexport C_u64 C_current_process_milliseconds(void) C_regparm;
+C_fctexport C_u64 C_cpu_milliseconds(void) C_regparm;
+C_fctexport double C_bignum_to_double(C_word bignum) C_regparm;
+C_fctexport C_word C_i_debug_modep(void) C_regparm;
+C_fctexport C_word C_i_dump_heap_on_exitp(void) C_regparm;
+C_fctexport C_word C_i_accumulated_gc_time(void) C_regparm;
+C_fctexport C_word C_i_allocated_finalizer_count(void) C_regparm;
+C_fctexport C_word C_i_live_finalizer_count(void) C_regparm;
+C_fctexport C_word C_i_profilingp(void) C_regparm;
+C_fctexport C_word C_i_tty_forcedp(void) C_regparm;
+C_fctexport C_word C_i_setenv(C_word var, C_word val) C_regparm;
+
+C_fctexport C_word C_a_i_cpu_time(C_word **a, int c, C_word buf) C_regparm;
+C_fctexport C_word C_a_i_exact_to_inexact(C_word **a, int c, C_word n) C_regparm;
+C_fctexport C_word C_i_file_exists_p(C_word name, C_word file, C_word dir) C_regparm;
+
+C_fctexport C_word C_s_a_i_abs(C_word **ptr, C_word n, C_word x) C_regparm;
+C_fctexport C_word C_s_a_i_negate(C_word **ptr, C_word n, C_word x) C_regparm;
+C_fctexport C_word C_s_a_i_minus(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_s_a_u_i_integer_negate(C_word **ptr, C_word n, C_word x) C_regparm;
+C_fctexport C_word C_s_a_u_i_integer_minus(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_s_a_i_plus(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_s_a_u_i_integer_plus(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_s_a_u_i_integer_times(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_s_a_i_arithmetic_shift(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_s_a_u_i_integer_gcd(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_s_a_i_quotient(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_s_a_u_i_integer_quotient(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_s_a_i_remainder(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_s_a_u_i_integer_remainder(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_s_a_i_modulo(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_s_a_u_i_integer_modulo(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_s_a_i_bitwise_and(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_s_a_i_bitwise_ior(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_s_a_i_bitwise_xor(C_word **ptr, C_word n, C_word x, C_word y) C_regparm;
+C_fctexport C_word C_s_a_i_bitwise_not(C_word **ptr, C_word n, C_word x) C_regparm;
+C_fctexport C_word C_s_a_i_digits_to_integer(C_word **ptr, C_word n, C_word str, C_word start, C_word end, C_word radix, C_word negp) C_regparm;
+C_fctexport C_word C_s_a_u_i_flo_to_int(C_word **ptr, C_word n, C_word x) C_regparm;
+
+
+C_fctexport C_word C_i_foreign_char_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_i_foreign_fixnum_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_i_foreign_flonum_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_i_foreign_cplxnum_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_i_foreign_block_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_i_foreign_struct_wrapper_argumentp(C_word t, C_word x) C_regparm;
+C_fctexport C_word C_i_foreign_string_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_i_foreign_symbol_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t) C_regparm;
+C_fctexport C_word C_i_foreign_pointer_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_i_foreign_scheme_or_c_pointer_argumentp(C_word x) C_regparm;
+C_fctexport C_word C_i_foreign_ranged_integer_argumentp(C_word x, C_word bits) C_regparm;
+C_fctexport C_word C_i_foreign_unsigned_ranged_integer_argumentp(C_word x, C_word bits) C_regparm;
C_fctexport C_char *C_lookup_procedure_id(void *ptr);
C_fctexport void *C_lookup_procedure_ptr(C_char *id);
+C_fctexport int C_fast_rand(void);
+C_fctexport void C_fast_srand(int seed);
C_fctexport C_word C_random_fixnum(C_word n) C_regparm;
-C_fctexport C_word C_fcall C_s_a_u_i_random_int(C_word **ptr, C_word n, C_word rn) C_regparm;
-C_fctexport C_word C_fcall C_a_i_random_real(C_word **ptr, C_word n) C_regparm;
+C_fctexport C_word C_s_a_u_i_random_int(C_word **ptr, C_word n, C_word rn) C_regparm;
+C_fctexport C_word C_a_i_random_real(C_word **ptr, C_word n) C_regparm;
C_fctexport C_word C_random_bytes(C_word buf, C_word size);
C_fctexport C_word C_set_random_seed(C_word buf, C_word n);
@@ -2189,8 +2264,8 @@ C_fctexport C_cpsproc(C_peek_unsigned_integer_32);
# 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;
-C_fctexport C_word C_fcall C_i_pending_interrupt(C_word dummy) C_regparm;
+C_fctexport C_word C_decode_literal(C_word **ptr, C_char *str) C_regparm;
+C_fctexport C_word C_i_pending_interrupt(C_word dummy) C_regparm;
C_fctexport void *C_get_statistics(void);
@@ -2208,21 +2283,28 @@ C_fctexport int CHICKEN_yield();
C_fctexport C_cpsproc(C_default_5fstub_toplevel);
+C_fctexport C_word C_a_extract_struct_2(C_word **ptr, size_t sz, void *sp);
-/* Inline functions: */
#ifndef HAVE_STATEMENT_EXPRESSIONS
inline static C_word *C_a_i(C_word **a, int n)
{
C_word *p = *a;
-
+
*a += n;
return p;
}
#endif
+inline static C_word
+C_chop_bv(C_word bv)
+{
+ ((C_SCHEME_BLOCK *)bv)->header = C_make_header(C_BYTEVECTOR_TYPE, C_header_size(bv) - 1);
+ return bv;
+}
+
inline static C_word
C_mutate(C_word *slot, C_word val)
{
@@ -2246,7 +2328,7 @@ inline static C_word C_u_i_namespaced_symbolp(C_word x)
inline static C_word C_flonum(C_word **ptr, double n)
{
- C_word
+ C_word
*p = *ptr,
*p0;
@@ -2265,7 +2347,7 @@ inline static C_word C_flonum(C_word **ptr, double n)
}
-inline static C_word C_fcall C_u_i_zerop2(C_word x)
+inline static C_word C_u_i_zerop2(C_word x)
{
return C_mk_bool(x == C_fix(0) ||
(!C_immediatep(x) &&
@@ -2282,7 +2364,7 @@ inline static C_word C_string_to_pbytevector(C_word s)
inline static C_word C_a_i_record1(C_word **ptr, int n, C_word x1)
{
- C_word *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_STRUCTURE_TYPE | 1;
*(p++) = x1;
@@ -2293,7 +2375,7 @@ inline static C_word C_a_i_record1(C_word **ptr, int n, C_word x1)
inline static C_word C_a_i_record2(C_word **ptr, int n, C_word x1, C_word x2)
{
- C_word *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_STRUCTURE_TYPE | 2;
*(p++) = x1;
@@ -2305,7 +2387,7 @@ inline static C_word C_a_i_record2(C_word **ptr, int n, C_word x1, C_word x2)
inline static C_word C_a_i_record3(C_word **ptr, int n, C_word x1, C_word x2, C_word x3)
{
- C_word *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_STRUCTURE_TYPE | 3;
*(p++) = x1;
@@ -2318,7 +2400,7 @@ inline static C_word C_a_i_record3(C_word **ptr, int n, C_word x1, C_word x2, C_
inline static C_word C_a_i_record4(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4)
{
- C_word *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_STRUCTURE_TYPE | 4;
*(p++) = x1;
@@ -2333,7 +2415,7 @@ inline static C_word C_a_i_record4(C_word **ptr, int n, C_word x1, C_word x2, C_
inline static C_word C_a_i_record5(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
C_word x5)
{
- C_word *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_STRUCTURE_TYPE | 5;
*(p++) = x1;
@@ -2349,7 +2431,7 @@ inline static C_word C_a_i_record5(C_word **ptr, int n, C_word x1, C_word x2, C_
inline static C_word C_a_i_record6(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
C_word x5, C_word x6)
{
- C_word *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_STRUCTURE_TYPE | 6;
*(p++) = x1;
@@ -2366,7 +2448,7 @@ inline static C_word C_a_i_record6(C_word **ptr, int n, C_word x1, C_word x2, C_
inline static C_word C_a_i_record7(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
C_word x5, C_word x6, C_word x7)
{
- C_word *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_STRUCTURE_TYPE | 7;
*(p++) = x1;
@@ -2384,7 +2466,7 @@ inline static C_word C_a_i_record7(C_word **ptr, int n, C_word x1, C_word x2, C_
inline static C_word C_a_i_record8(C_word **ptr, int n, 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 *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_STRUCTURE_TYPE | 8;
*(p++) = x1;
@@ -2401,7 +2483,7 @@ inline static C_word C_a_i_record8(C_word **ptr, int n, C_word x1, C_word x2, C_
inline static C_word C_cplxnum(C_word **ptr, C_word r, C_word i)
{
- C_word *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_CPLXNUM_TAG;
*(p++) = r;
@@ -2410,9 +2492,27 @@ inline static C_word C_cplxnum(C_word **ptr, C_word r, C_word i)
return (C_word)p0;
}
+inline static C_word C_inexact_cplxnum(C_word **ptr, double C_complex n)
+{
+#if defined(__STDC_NO_COMPLEX__) || defined(__cplusplus)
+ C_unimplemented(C_text("native complex numbers"));
+ return 0;
+#else
+ C_word r = C_flonum(ptr, creal(n));
+ C_word i = C_flonum(ptr, cimag(n));
+ C_word *p = *ptr, *p0 = p;
+
+ *(p++) = C_CPLXNUM_TAG;
+ *(p++) = r;
+ *(p++) = i;
+ *ptr = p;
+ return (C_word)p0;
+#endif
+}
+
inline static C_word C_ratnum(C_word **ptr, C_word n, C_word d)
{
- C_word *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_RATNUM_TAG;
*(p++) = n;
@@ -2423,7 +2523,7 @@ inline static C_word C_ratnum(C_word **ptr, C_word n, C_word d)
inline static C_word C_a_i_bignum_wrapper(C_word **ptr, C_word vec)
{
- C_word *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_BIGNUM_TAG;
*(p++) = vec;
@@ -2436,7 +2536,7 @@ inline static C_word C_bignum0(C_word **ptr)
{
C_word *p = *ptr, p0 = (C_word)p;
- *(p++) = C_STRING_TYPE | C_wordstobytes(1);
+ *(p++) = C_BYTEVECTOR_TYPE | C_wordstobytes(1);
*(p++) = 0; /* zero is always positive */
*ptr = p;
@@ -2447,7 +2547,7 @@ inline static C_word C_bignum1(C_word **ptr, int negp, C_uword d1)
{
C_word *p = *ptr, p0 = (C_word)p;
- *(p++) = C_STRING_TYPE | C_wordstobytes(2);
+ *(p++) = C_BYTEVECTOR_TYPE | C_wordstobytes(2);
*(p++) = negp;
*(p++) = d1;
*ptr = p;
@@ -2460,7 +2560,7 @@ inline static C_word C_bignum2(C_word **ptr, int negp, C_uword d1, C_uword d2)
{
C_word *p = *ptr, p0 = (C_word)p;
- *(p++) = C_STRING_TYPE | C_wordstobytes(3);
+ *(p++) = C_BYTEVECTOR_TYPE | C_wordstobytes(3);
*(p++) = negp;
*(p++) = d1;
*(p++) = d2;
@@ -2474,6 +2574,19 @@ inline static C_word C_i_bignump(C_word x)
return C_mk_bool(!C_immediatep(x) && C_block_header(x) == C_BIGNUM_TAG);
}
+inline static double C_complex C_c_cplxnum(C_word x)
+{
+#if defined(__STDC_NO_COMPLEX__) || defined(__cplusplus)
+ C_unimplemented(C_text("native complex numbers"));
+ return 0;
+#else
+ if(x & C_FIXNUM_BIT) return (double)C_unfix(x);
+ else if(C_block_header(x) == C_CPLXNUM_TAG)
+ return C_flonum_magnitude(C_u_i_cplxnum_real(x)) + I *
+ C_flonum_magnitude(C_u_i_cplxnum_imag(x));
+ else return C_flonum_magnitude(x);
+#endif
+}
inline static double C_c_double(C_word x)
{
@@ -2493,7 +2606,7 @@ inline static C_word C_num_to_int(C_word x)
return C_unfix(x);
} else {
#if DEBUGBUILD /* removes a warning with clang */
- C_CHECKp(x,C_bignump(C_VAL1(x)),0);
+ (void)C_CHECKp(x,C_bignump(C_VAL1(x)),0);
#endif
if (C_bignum_negativep(x)) return -(C_word)C_bignum_digits(x)[0];
else return (C_word)C_bignum_digits(x)[0]; /* should never be larger */
@@ -2659,26 +2772,6 @@ inline static C_ulong C_num_to_unsigned_long(C_word x)
}
-inline static C_word C_u_i_string_equal_p(C_word x, C_word y)
-{
- C_uword 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));
-}
-
-/* Like memcmp but case insensitive (to strncasecmp as memcmp is to strncmp) */
-inline static int C_memcasecmp(const char *x, const char *y, unsigned int len)
-{
- const unsigned char *ux = (const unsigned char *)x;
- const unsigned char *uy = (const unsigned char *)y;
-
- while (len--) {
- if (tolower(*ux++) != tolower(*uy++))
- return (tolower(*--ux) - tolower(*--uy));
- }
- return 0;
-}
-
inline static C_word C_ub_i_flonum_eqvp(double x, double y)
{
/* This can distinguish between -0.0 and +0.0 */
@@ -2765,8 +2858,7 @@ inline static C_word C_i_srfi_4_vectorp(C_word x)
{
return C_mk_bool(!C_immediatep(x) &&
C_header_bits(x) == C_STRUCTURE_TYPE &&
- (C_truep(C_i_u8vectorp(x)) ||
- C_truep(C_i_s8vectorp(x)) ||
+ (C_truep(C_i_s8vectorp(x)) ||
C_truep(C_i_u16vectorp(x)) ||
C_truep(C_i_s16vectorp(x)) ||
C_truep(C_i_u32vectorp(x)) ||
@@ -2791,7 +2883,7 @@ inline static C_word C_i_closurep(C_word x)
inline static C_word C_i_numberp(C_word x)
{
return C_mk_bool((x & C_FIXNUM_BIT) ||
- (!C_immediatep(x) &&
+ (!C_immediatep(x) &&
(C_block_header(x) == C_FLONUM_TAG ||
C_block_header(x) == C_BIGNUM_TAG ||
C_block_header(x) == C_RATNUM_TAG ||
@@ -2802,7 +2894,7 @@ inline static C_word C_i_numberp(C_word x)
inline static C_word C_i_realp(C_word x)
{
return C_mk_bool((x & C_FIXNUM_BIT) ||
- (!C_immediatep(x) &&
+ (!C_immediatep(x) &&
(C_block_header(x) == C_FLONUM_TAG ||
C_block_header(x) == C_BIGNUM_TAG ||
C_block_header(x) == C_RATNUM_TAG)));
@@ -2940,7 +3032,7 @@ inline static C_word C_i_fixnum_gcd(C_word x, C_word y)
{
x = (x & C_INT_SIGN_BIT) ? -C_unfix(x) : C_unfix(x);
y = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y);
-
+
while(y != 0) {
C_word r = x % y;
x = y;
@@ -3070,7 +3162,7 @@ inline static C_word C_a_i_fixnum_times(C_word **ptr, C_word n, C_word x, C_word
xhi = C_BIGNUM_DIGIT_HI_HALF(x); xlo = C_BIGNUM_DIGIT_LO_HALF(x);
yhi = C_BIGNUM_DIGIT_HI_HALF(y); ylo = C_BIGNUM_DIGIT_LO_HALF(y);
-
+
/* This is simply bignum_digits_multiply unrolled for 2x2 halfdigits */
p = xlo * ylo;
rlo = C_BIGNUM_DIGIT_LO_HALF(p);
@@ -3096,7 +3188,7 @@ inline static C_word C_a_i_fixnum_times(C_word **ptr, C_word n, C_word x, C_word
inline static C_word C_i_flonum_min(C_word x, C_word y)
{
- double
+ double
xf = C_flonum_magnitude(x),
yf = C_flonum_magnitude(y);
@@ -3106,7 +3198,7 @@ inline static C_word C_i_flonum_min(C_word x, C_word y)
inline static C_word C_i_flonum_max(C_word x, C_word y)
{
- double
+ double
xf = C_flonum_magnitude(x),
yf = C_flonum_magnitude(y);
@@ -3237,9 +3329,9 @@ C_fast_retrieve(C_word sym)
inline static void *
C_fast_retrieve_proc(C_word closure)
{
- if(C_immediatep(closure) || C_header_bits(closure) != C_CLOSURE_TYPE)
+ if(C_immediatep(closure) || C_header_bits(closure) != C_CLOSURE_TYPE)
return (void *)C_invalid_procedure;
- else
+ else
return (void *)C_block_item(closure, 0);
}
@@ -3253,7 +3345,7 @@ C_fast_retrieve_symbol_proc(C_word sym)
inline static C_word C_a_i_vector1(C_word **ptr, int n, C_word x1)
{
- C_word *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_VECTOR_TYPE | 1;
*(p++) = x1;
@@ -3264,7 +3356,7 @@ inline static C_word C_a_i_vector1(C_word **ptr, int n, C_word x1)
inline static C_word C_a_i_vector2(C_word **ptr, int n, C_word x1, C_word x2)
{
- C_word *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_VECTOR_TYPE | 2;
*(p++) = x1;
@@ -3276,7 +3368,7 @@ inline static C_word C_a_i_vector2(C_word **ptr, int n, C_word x1, C_word x2)
inline static C_word C_a_i_vector3(C_word **ptr, int n, C_word x1, C_word x2, C_word x3)
{
- C_word *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_VECTOR_TYPE | 3;
*(p++) = x1;
@@ -3289,7 +3381,7 @@ inline static C_word C_a_i_vector3(C_word **ptr, int n, C_word x1, C_word x2, C_
inline static C_word C_a_i_vector4(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4)
{
- C_word *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_VECTOR_TYPE | 4;
*(p++) = x1;
@@ -3304,7 +3396,7 @@ inline static C_word C_a_i_vector4(C_word **ptr, int n, C_word x1, C_word x2, C_
inline static C_word C_a_i_vector5(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
C_word x5)
{
- C_word *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_VECTOR_TYPE | 5;
*(p++) = x1;
@@ -3320,7 +3412,7 @@ inline static C_word C_a_i_vector5(C_word **ptr, int n, C_word x1, C_word x2, C_
inline static C_word C_a_i_vector6(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
C_word x5, C_word x6)
{
- C_word *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_VECTOR_TYPE | 6;
*(p++) = x1;
@@ -3337,7 +3429,7 @@ inline static C_word C_a_i_vector6(C_word **ptr, int n, C_word x1, C_word x2, C_
inline static C_word C_a_i_vector7(C_word **ptr, int n, C_word x1, C_word x2, C_word x3, C_word x4,
C_word x5, C_word x6, C_word x7)
{
- C_word *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_VECTOR_TYPE | 7;
*(p++) = x1;
@@ -3355,7 +3447,7 @@ inline static C_word C_a_i_vector7(C_word **ptr, int n, C_word x1, C_word x2, C_
inline static C_word C_a_i_vector8(C_word **ptr, int n, 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 *p = *ptr, *p0 = p;
+ C_word *p = *ptr, *p0 = p;
*(p++) = C_VECTOR_TYPE | 8;
*(p++) = x1;
@@ -3371,10 +3463,24 @@ inline static C_word C_a_i_vector8(C_word **ptr, int n, C_word x1, C_word x2, C_
}
-inline static C_word C_fcall C_a_pair(C_word **ptr, C_word car, C_word cdr)
+inline static C_word C_a_ustring(C_word **ptr, int n, C_word bv, C_word c)
{
C_word *p = *ptr, *p0 = p;
-
+
+ *(p++) = C_STRING_TAG;
+ *(p++) = bv;
+ *(p++) = c;
+ *(p++) = C_fix(0);
+ *(p++) = C_fix(0);
+ *ptr = p;
+ return (C_word)p0;
+}
+
+
+inline static C_word C_a_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;
@@ -3382,7 +3488,7 @@ inline static C_word C_fcall C_a_pair(C_word **ptr, C_word car, C_word cdr)
return (C_word)p0;
}
-inline static C_word C_fcall C_a_weak_pair(C_word **ptr, C_word head, C_word tail)
+inline static C_word C_a_weak_pair(C_word **ptr, C_word head, C_word tail)
{
C_word *p = *ptr, *p0 = p;
@@ -3547,19 +3653,20 @@ inline static size_t C_strlcat(char *dst, const char *src, size_t sz)
* non-directory mode in buf.st_mode.
*/
#if defined(__MINGW32__)
-inline static int C_stat(const char *path, struct stat *buf)
+inline static int C_stat(const C_WCHAR *path, struct _stat64i32 *buf)
{
- size_t len = C_strlen(path);
- char slash = len && C_strchr("\\/", path[len - 1]), *str;
+ size_t len = wcslen(path);
+ C_WCHAR slash = len && wcschr(L"\\/", path[len - 1]), *str;
- if(stat(path, buf) == 0)
+ if(_wstat(path, buf) == 0)
goto dircheck;
if(slash && errno == ENOENT) {
- C_strlcpy((str = (char *)C_alloca(len + 1)), path, len + 1);
- while(len > 1 && C_strchr("\\/", path[--len]))
+ C_memcpy((str = (C_WCHAR *)C_alloca((len + 1) * sizeof(C_WCHAR))), path,
+ (len + 1) * sizeof(C_WCHAR));
+ while(len > 1 && wcschr(L"\\/", path[--len]))
str[len] = '\0';
- if(stat(str, buf) == 0)
+ if(_wstat(str, buf) == 0)
goto dircheck;
}
diff --git a/chicken.mdoc b/chicken.mdoc
index a28f06ba..cef12103 100644
--- a/chicken.mdoc
+++ b/chicken.mdoc
@@ -92,10 +92,8 @@ Allow alternative keyword syntax
.Po prefix, suffix or none Pc .
.It Fl no-parentheses-synonyms
Disables list delimiter synonyms.
-.It Fl no-symbol-escape
-Disables support for escaped symbols.
-.It Fl r5rs-syntax
-Disables the CHICKEN extensions to R5RS syntax.
+.It Fl r7rs-syntax
+Disables the CHICKEN extensions to R7RS syntax.
.It Fl compile-syntax
Macros are made available at run-time.
.It Fl emit-import-library Ar MODULE
diff --git a/chicken.syntax.import.scm b/chicken.syntax.import.scm
index d8da42a7..d11a3ffa 100644
--- a/chicken.syntax.import.scm
+++ b/chicken.syntax.import.scm
@@ -34,7 +34,6 @@
(get-line-number . chicken.syntax#get-line-number)
(read-with-source-info . chicken.syntax#read-with-source-info)
(strip-syntax . chicken.syntax#strip-syntax)
- (syntax-error . chicken.syntax#syntax-error)
(er-macro-transformer . chicken.syntax#er-macro-transformer)
(ir-macro-transformer . chicken.syntax#ir-macro-transformer))
##sys#chicken.syntax-macro-environment)
diff --git a/compiler-syntax.scm b/compiler-syntax.scm
index b8afaff6..d431228a 100644
--- a/compiler-syntax.scm
+++ b/compiler-syntax.scm
@@ -152,8 +152,8 @@
(write . scheme#write)
(number->string . scheme#number->string)
(write-char . scheme#write-char)
- (open-output-string . chicken.base#open-output-string)
- (get-output-string . chicken.base#get-output-string))
+ (open-output-string . scheme#open-output-string)
+ (get-output-string . scheme#get-output-string))
(let* ((out (gensym 'out))
(code (compile-format-string
(if (eq? (car x) 'chicken.format#sprintf) 'sprintf 'format)
@@ -169,8 +169,8 @@
(write . scheme#write)
(number->string . scheme#number->string)
(write-char . scheme#write-char)
- (open-output-string . chicken.base#open-output-string)
- (get-output-string . chicken.base#get-output-string))
+ (open-output-string . scheme#open-output-string)
+ (get-output-string . scheme#get-output-string))
(if (>= (length x) 3)
(let ((code (compile-format-string 'fprintf (cadr x) x (cddr x) r c)))
(or code x))
@@ -181,13 +181,13 @@
(write . scheme#write)
(number->string . scheme#number->string)
(write-char . scheme#write-char)
- (open-output-string . chicken.base#open-output-string)
- (get-output-string . chicken.base#get-output-string))
+ (open-output-string . scheme#open-output-string)
+ (get-output-string . scheme#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
+ (call-with-current-continuation
(lambda (return)
(and (>= (length args) 1)
(memq (symbol-append 'chicken.format# func) extended-bindings) ; s.a.
@@ -308,18 +308,20 @@
(%let (r 'let))
(%if (r 'if))
(%pair? (r 'pair?))
+ (fvar (gensym))
(zvar (gensym))
(loopvar (gensym "foldl"))
(lstvar (gensym)))
`(,%let* ((,zvar ,z)
+ (,fvar ,f)
(,lstvar ,lst))
(##core#check (##sys#check-list ,lstvar (##core#quote foldl)))
(,%let ,loopvar ((,lstvar ,lstvar) (,zvar ,zvar))
(,%if (,%pair? ,lstvar)
- (##core#app
+ (##core#app
,loopvar
- (##sys#slot ,lstvar 1)
- (,f ,zvar (##sys#slot ,lstvar 0)))
+ (##sys#slot ,lstvar 1)
+ (,fvar ,zvar (##sys#slot ,lstvar 0)))
,zvar))))
x))
)
diff --git a/config.make b/config.make
deleted file mode 100644
index 0cfe765b..00000000
--- a/config.make
+++ /dev/null
@@ -1,51 +0,0 @@
-### config.make
-
-# You can set build options in this file instead of passing them on
-# the command line. Please consult the README file for more
-# information.
-
-
-# Select platform to use:
-#PLATFORM=linux
-
-# Installation prefix:
-#PREFIX=/usr/local
-
-
-### The options below are optional and should be used with care
-
-# Disable optimizations:
-#DEBUGBUILD=1
-
-# Build static runtime library only:
-#STATICBUILD=1
-
-# Use alternative C compiler
-#C_COMPILER=
-
-# Add additional C compiler options:
-#C_COMPILER_OPTIMIZATION_OPTIONS=...
-
-# Use alternative resource compiler (for Win32 builds)
-#RC_COMPILER=
-
-# Choose prefix to be added to installed programs:
-#PROGRAM_PREFIX=
-
-# Choose suffix to be added to installed programs:
-#PROGRAM_SUFFIX=
-
-# Specification of host (build) system (machine + platform) for cross-compiling:
-#HOSTSYSTEM=
-
-# Specification of target (runtime) system for cross-compiling:
-#TARGETSYSTEM=
-
-# Where the install-location of a cross-build is
-#TARGET_PREFIX=
-
-# Specify that the sources are in a different directory than ".":
-#SRCDIR=
-
-# Use alternative directory for installed binary extensions:
-#VARDIR=
diff --git a/configure b/configure
new file mode 100755
index 00000000..e63386c9
--- /dev/null
+++ b/configure
@@ -0,0 +1,278 @@
+#!/bin/sh
+#
+# configuration script for the CHICKEN build process
+#
+# Copyright (c) 2024, 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.
+
+prefix=/usr/local
+debug=
+static=
+host=
+target=
+tprefix=
+pprefix=
+psuffix=
+srcdir=
+vardir=
+linker=
+platform=
+chicken=
+pobjs=
+mkcmd="make"
+
+usage () {
+ echo "usage: configure [--help] [--prefix DIRECTORY] [--platform PLATFORM | list] [--chicken PROGRAMNAME] [--debugbuild] [--staticbuild] [--disable-shared] [--host HOSTSYSTEM] [--target TARGETSYSTEM] [--program-prefix PREFIX] [--program-suffix SUFFIX] [--target-prefix DIRECTORY] [--srcdir DIRECTORY] [--vardir DIRECTORY] [--c-compiler PROGRAMNAME] [--linker PROGRAMNAME] [--profile-objects OBJECTLIST]"
+ echo
+ echo "consult the README file for more information."
+ exit "$1"
+}
+
+while [ -n "$1" ]; do
+ arg="$1"
+ shift
+ case "$arg" in
+ -h|-help|--help)
+ usage 0;;
+ --chicken=*)
+ chicken=${arg#--chicken=};;
+ --chicken)
+ test -z "$1" && usage 1 >&2
+ chicken="$1"
+ shift;;
+ --prefix=*)
+ prefix=${arg#--prefix=};;
+ --prefix)
+ test -z "$1" && usage 1 >&2
+ prefix="$1"
+ shift;;
+ --platform=*)
+ platform=${arg#--platform=};;
+ --platform)
+ test -z "$1" && usage 1 >&2
+ platform="$1"
+ shift;;
+ --debugbuild)
+ debug=1;;
+ --staticbuild|--disable-shared)
+ static=1;;
+ --host=*)
+ host=${arg#--host=};;
+ --host)
+ test -z "$1" && usage 1 >&2
+ host="$1"
+ shift;;
+ --target=*)
+ target=${arg#--target=};;
+ --target)
+ test -z "$1" && usage 1 >&2
+ target="$1"
+ shift;;
+ --program-prefix=*)
+ pprefix=${arg#--program-prefix=};;
+ --program-prefix)
+ test -z "$1" && usage 1 >&2
+ pprefix="$1"
+ shift;;
+ --program-suffix=*)
+ psuffix=${arg#--program-suffix=};;
+ --program-suffix)
+ test -z "$1" && usage 1
+ psuffix="$1"
+ shift;;
+ --target-prefix=*)
+ tprefix=${arg#--target-prefix=};;
+ --target-prefix)
+ test -z "$1" && usage 1
+ tprefix="$1"
+ shift;;
+ --srcdir=*)
+ srcdir=${arg#--srcdir=};;
+ --srcdir)
+ test -z "$1" && usage 1 >&2
+ srcdir="$1"
+ shift;;
+ --vardir=*)
+ vardir=${arg#--vardir=};;
+ --vardir)
+ test -z "$1" && usage 1 >&2
+ vardir="$1"
+ shift;;
+ --profile-objects=*)
+ pobjs=${arg#--profile-objects=};;
+ --profile-objects)
+ test -z "$1" && usage 1 >&2
+ pobjs="$1"
+ shift;;
+ --c-compiler=*)
+ CC=${arg#--c-compiler=};;
+ --c-compiler)
+ test -z "$1" && usage 1 >&2
+ CC="$1"
+ shift;;
+ --linker=*)
+ linker=${arg#--linker=};;
+ --linker)
+ test -z "$1" && usage 1 >&2
+ linker="$1"
+ shift;;
+ *)
+ usage 1 >&2;;
+ esac
+done
+
+if [ "$platform" = list ]; then
+ echo "available platforms:"
+ echo
+ for mf in Makefile.*; do
+ echo " ${mf#Makefile.}"
+ done
+ echo
+ exit
+fi
+
+if [ -z "$platform" ]; then
+ printf 'detecting platform ... '
+
+ # Detect the PLATFORM with uname.
+ # Based on Chibi Scheme auto-detector
+ # Heavily revamped by John Cowan
+ # Moved into configure script by Felix Winkelmann
+ # Copyright (c) 2009-2018 Alex Shinn, John Cowan
+ # BSD license at <https://github.com/ashinn/chibi-scheme/blob/master/COPYING>
+
+ # Now we can use uname tests
+ uname_s=$(uname)
+ uname_o=$(uname -o 2>/dev/null)
+
+ case "$uname_s" in
+ Darwin)
+ platform=macosx;;
+ *BSD)
+ platform=bsd;;
+ DragonFly)
+ platform=bsd;;
+ Windows_NT)
+ platform=mingw
+ case "$prefix" in
+ [a-zA-Z]:*)
+ ;;
+ *)
+ echo "on Windows, the prefix must contain a drive letter" >&2
+ exit 1;;
+ esac;;
+ SunOS)
+ platform=solaris;;
+ BeOS)
+ platform=haiku;;
+ Haiku)
+ platform=haiku;;
+ GNU)
+ platform=hurd;;
+ AIX)
+ platform=aix;;
+ *)
+ case "$uname_o" in
+ Cygwin)
+ platform=cygwin;;
+ Android)
+ platform=android;;
+ GNU/Linux)
+ platform=linux;;
+ Linux)
+ platform=linux;;
+ *)
+ echo
+ echo "unable to figure out platform" >&2
+ exit 1;;
+ esac;;
+ esac
+ echo "$platform"
+fi
+
+cccmd="gcc"
+if [ "$platform" = "bsd" ]; then
+ cccmd="cc"
+ if command -v gmake >/dev/null; then
+ mkcmd="gmake"
+ else
+ echo "GNU make is required but does not seem to be available" >&2
+ exit 1
+ fi
+fi
+
+echo "installation prefix: $prefix"
+test -n "$chicken" && echo "bootstrap chicken: $chicken"
+
+test -n "$CC" && cccmd="$CC"
+
+printf "testing C compiler (%s) ... " "$cccmd"
+tmpc="$(mktemp).c"
+cat > "$tmpc" <<EOF
+int main() {return 0;}
+EOF
+if command -v $cccmd >/dev/null; then
+ if $cccmd "$tmpc" $CFLAGS -o "${tmpc}.out"; then
+ rm -f "$tmpc"
+ if "${tmpc}.out"; then
+ echo works
+ rm -f "${tmpc}.out"
+ else
+ rm -f "${tmpc}.out"
+ echo
+ echo "$cccmd does not seem to produce working executables" >&2
+ exit 1
+ fi
+ else
+ rm -f "$tmpc" "${tmpc}.out"
+ echo
+ echo "$cccmd does not seem to work" >&2
+ exit 1
+ fi
+else
+ echo
+ echo "cannot find $cccmd" >&2
+ exit 1
+fi
+
+echo "# GENERATED BY configure" > config.make
+echo "PLATFORM ?= $platform" >> config.make
+echo "PREFIX ?= $prefix" >> config.make
+test -n "$debug" && echo "DEBUGBUILD ?= 1" >> config.make
+test -n "$static" && echo "STATICBUILD ?= 1" >> config.make
+test -n "$CC" && echo "C_COMPILER ?= $cccmd" >> config.make
+test -n "$linker" && echo "LINKER ?= $linker" >> config.make
+test -n "$CFLAGS" && echo "C_COMPILER_OPTIMIZATION_OPTIONS ?= $CFLAGS" >> config.make
+test -n "$host" && echo "HOSTSYSTEM ?= $host" >> config.make
+test -n "$target" && echo "TARGETSYSTEM ?= $target" >> config.make
+test -n "$pprefix" && echo "PROGRAM_PREFIX ?= $pprefix" >> config.make
+test -n "$psuffix" && echo "PROGRAM_SUFFIX ?= $psuffix" >> config.make
+test -n "$tprefix" && echo "TARGET_PREFIX ?= $tprefix" >> config.make
+test -n "$srcdir" && echo "SRCDIR ?= $srcdir" >> config.make
+test -n "$vardir" && echo "VARDIR ?= $vardir" >> config.make
+test -n "$chicken" && echo "CHICKEN ?= $chicken" >> config.make
+test -n "$pobjs" && echo "PROFILE_OBJECTS ?= $pobjs" >> config.make
+
+echo
+echo "now run ${mkcmd} to build the system"
+echo
diff --git a/core.scm b/core.scm
index 0a9b301e..0482cadf 100644
--- a/core.scm
+++ b/core.scm
@@ -83,7 +83,7 @@
; ##compiler#local -> BOOL
; ##compiler#visibility -> #f | 'hidden | 'exported
; ##compiler#constant -> BOOL defined as constant
-; ##compiler#intrinsic -> #f | 'standard | 'extended
+; ##compiler#intrinsic -> #f | 'standard | 'extended | 'internal
; ##compiler#inline -> 'no | 'yes
; ##compiler#inline-global -> 'yes | 'no | <node>
; ##compiler#profile -> BOOL
@@ -115,6 +115,7 @@
; (##core#ensure-toplevel-definition <variable>)
; (##core#begin <exp> ...)
; (##core#include <string> <string> | #f [<body>])
+; (##core#include-ci <string> <string> | #f [<body>])
; (##core#loop-lambda <llist> <body>)
; (##core#undefined)
; (##core#primitive <name>)
@@ -270,6 +271,7 @@
; 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
+; has-bad-calls -> <boolean> If true: the procedure has calls with wrong argument counts
;
; <lambda-id>:
;
@@ -339,6 +341,7 @@
line-number-database-size)
(import scheme
+ (only (scheme base) open-output-string get-output-string)
chicken.base
chicken.condition
chicken.compiler.scrutinizer
@@ -630,6 +633,17 @@
(for-each pretty-print imps)
(print "\n;; END OF FILE"))))) ) )
+ (define (include-file x ci e dest ldest h ln tl?)
+ (##sys#include-forms-from-file
+ (cadr x) (caddr x) ci
+ (lambda (forms)
+ (walk (if (pair? (cdddr x)) ; body?
+ (canonicalize-body/ln ln
+ (append forms (cadddr x))
+ compiler-syntax-enabled)
+ `(##core#begin ,@forms))
+ e dest ldest h ln tl?))))
+
(define (walk x e dest ldest h outer-ln tl?)
(cond ((keyword? x) `(quote ,x))
((symbol? x) (resolve-variable x e dest ldest h outer-ln))
@@ -640,10 +654,6 @@
((symbol? (car x))
(let ((ln (or (get-line-number x) outer-ln)))
(emit-syntax-trace-info x #f)
- (unless (list? x)
- (if ln
- (##sys#syntax-error/context (sprintf "(~a) - malformed expression" ln) x)
- (##sys#syntax-error/context "malformed expression" x)))
(set! ##sys#syntax-error-culprit x)
(let* ((name (lookup (car x)))
(xexpanded
@@ -653,6 +663,11 @@
(cond ((not (eq? x xexpanded))
(walk xexpanded e dest ldest h ln tl?))
+ ((not (list? x))
+ (if ln
+ (##sys#syntax-error/context (sprintf "(~a) - malformed expression" ln) x)
+ (##sys#syntax-error/context "malformed expression" x)))
+
((hash-table-ref inline-table name)
=> (lambda (val)
(walk (cons val (cdr x)) e dest ldest h ln #f)))
@@ -989,18 +1004,10 @@
bs) ) ) ) )
((##core#include)
- (##sys#include-forms-from-file
- (cadr x)
- (caddr x)
- (lambda (forms path)
- (let ((code (if (pair? (cdddr x)) ; body?
- (canonicalize-body/ln
- ln
- (append forms (cadddr x))
- compiler-syntax-enabled)
- `(##core#begin ,@forms))))
- (fluid-let ((##sys#current-source-filename path))
- (walk code e dest ldest h ln tl?))))))
+ (include-file x #f e dest ldest h ln tl?))
+
+ ((##core#include-ci)
+ (include-file x #t e dest ldest h ln tl?))
((##core#let-module-alias)
(##sys#with-module-aliases
@@ -1027,13 +1034,13 @@
(loop (cdr exp))))))
exp)
(else
- (##sys#syntax-error-hook
+ (##sys#syntax-error
'module
"invalid export syntax" exp name))))
(strip-syntax (caddr x))))))
(csyntax compiler-syntax))
(when (##sys#current-module)
- (##sys#syntax-error-hook
+ (##sys#syntax-error
'module "modules may not be nested" name))
(let ((body (parameterize ((##sys#current-module mod)
(##sys#current-environment '())
@@ -1408,7 +1415,7 @@
(when (or (not (list? vars))
(not (list? atypes))
(not (= (length vars) (length atypes))) )
- (syntax-error
+ (##sys#syntax-error
"non-matching or invalid argument list to foreign callback-wrapper"
vars atypes) )
`(##core#foreign-callback-wrapper
@@ -1452,7 +1459,7 @@
c-string*
c-string-list
c-string-list*))
- (syntax-error
+ (##sys#syntax-error
"not a valid result type for callback procedures"
rtype
name) )
@@ -1542,7 +1549,7 @@
(define (check-decl spec minlen . maxlen)
(let ([n (length (cdr spec))])
(if (or (< n minlen) (> n (optional maxlen 99999)))
- (syntax-error "invalid declaration" spec) ) ) )
+ (##sys#syntax-error "invalid declaration" spec) ) ) )
(define (globalize var)
(cond ((local? var)
(note-local var)
@@ -1556,7 +1563,7 @@
(call-with-current-continuation
(lambda (return)
(unless (pair? spec)
- (syntax-error "invalid declaration specification" spec) )
+ (##sys#syntax-error "invalid declaration specification" spec) )
(case (strip-syntax (car spec)) ; no global aliasing
((uses)
(let ((units (strip-syntax (cdr spec))))
@@ -1616,7 +1623,7 @@
(let ([fds (cdr spec)])
(if (every string? fds)
(set! foreign-declarations (append foreign-declarations fds))
- (syntax-error 'declare "invalid declaration" spec) ) ) )
+ (##sys#syntax-error 'declare "invalid declaration" spec) ) ) )
((block) (set! block-compilation #t))
((separate) (set! block-compilation #f))
((keep-shadowed-macros) (set! undefine-shadowed-macros #f))
@@ -1818,17 +1825,15 @@
;;; Expand "foreign-lambda"/"foreign-safe-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-record foreign-stub
+ id ; symbol
+ return-type ; type-specifier
+ name ; string or #f
+ argument-types ; (type-specifier...)
+ argument-names ; #f or (symbol ...)
+ body ; #f or string
+ cps ; boolean
+ callback) ; boolean
(define (create-foreign-stub rtype sname argtypes argnames body callback cps)
;; try to describe a foreign-lambda type specification
@@ -2084,16 +2089,11 @@
(when (eq? '##core#variable (node-class fun))
(let* ((name (first (node-parameters fun)))
(val (db-get db name 'value)))
- (when (and first-analysis
- val
- (not (db-get db name 'global))
- (not (db-get db name 'unknown))
+ (when (and val
(eq? '##core#lambda (node-class val))
(not (llist-match? (third (node-parameters val))
(cdr subs))))
- (quit-compiling
- "known procedure called with wrong number of arguments: `~A'"
- (real-name name)))
+ (db-put! db name 'has-bad-calls #t))
(collect! db name 'call-sites (cons here n))))
(walk (first subs) env localenv fullenv here)
(walkeach (cdr subs) env localenv fullenv here)))
@@ -2350,7 +2350,7 @@
(lambda (v) (db-get db v 'global))
(nth-value 0 (scan-free-variables
value block-compilation)) ) ) )
- (if (and (= 1 nreferences) (= 1 ncall-sites))
+ (if (and (not (db-get db sym 'has-bad-calls)) (= 1 nreferences) (= 1 ncall-sites))
(quick-put! plist 'contractable #t)
(quick-put! plist 'inlinable #t) ) ) ) )
(local-value
@@ -2574,13 +2574,15 @@
(and refs sites
(= (length refs) (length sites))
(test varname 'value)
+ (not (test varname 'has-bad-calls))
(list? llist) ) ] )
(cond ((and name
(not (llist-match? llist (cdr subs))))
'())
(else
(register-direct-call! id)
- (when custom (register-customizable! varname id))
+ (when custom
+ (register-customizable! varname id))
(list id custom) ) ) )
'() ) )
'() ) )
@@ -2762,7 +2764,7 @@
'##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))))
+ (list (qnode (##sys#make-lambda-info (->string (car params)))))
'() ) ) ) )
((##core#ref) n)
@@ -2793,29 +2795,25 @@
;;; Do some preparations before code-generation can commence:
-(define-record-type lambda-literal
- (make-lambda-literal id external arguments argument-count rest-argument temporaries
- float-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
+(define-record lambda-literal
+ id ; symbol
+ external ; boolean
;; lambda-literal-arguments is used nowhere
- (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
- (float-temporaries lambda-literal-float-temporaries) ; (integer ...)
- (callee-signatures lambda-literal-callee-signatures) ; (integer ...)
- (allocated lambda-literal-allocated) ; integer
+ arguments ; (symbol ...)
+ argument-count ; integer
+ rest-argument ; symbol | #f
+ temporaries ; integer
+ float-temporaries ; (integer ...)
+ callee-signatures ; (integer ...)
+ allocated ; integer
;; lambda-literal-directly-called is used nowhere
- (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 | NONE
- (body lambda-literal-body) ; expression
- (direct lambda-literal-direct)) ; boolean
+ directly-called ; boolean
+ closure-size ; integer
+ looping ; boolean
+ customizable ; boolean
+ rest-argument-mode ; #f | LIST | NONE
+ body ; expression
+ direct) ; boolean
(define (prepare-for-code-generation node db)
(let ((literals '())
@@ -3160,8 +3158,7 @@
((char? x) `(char ,x))
((null? x) '(nil))
((eof-object? x) '(eof))
- ;; TODO: Remove once we have a bootstrapping libchicken with bwp-object?
- ((##core#inline "C_bwpp" x) #;(bwp-object? x) '(bwp))
+ ((bwp-object? x) '(bwp))
(else (bomb "bad immediate (prepare)")) )
'() ) ) )
diff --git a/csc.mdoc b/csc.mdoc
index a930a3f9..ba5e898f 100644
--- a/csc.mdoc
+++ b/csc.mdoc
@@ -99,8 +99,8 @@ Enable alternative keyword-syntax
Disables list delimiter synonyms.
.It Fl no-symbol-escape
Disables support for escaped symbols.
-.It Fl r5rs-syntax
-Disables the CHICKEN extensions to R5RS syntax.
+.It Fl r7rs-syntax
+Disables the CHICKEN extensions to R7RS syntax.
.It Fl compile-syntax
Macros are made available at run-time.
.It Fl j Ar MODULE , Fl emit-import-library Ar MODULE
diff --git a/csc.scm b/csc.scm
index 1fe896b7..3bdb205f 100644
--- a/csc.scm
+++ b/csc.scm
@@ -8,11 +8,11 @@
; conditions are met:
;
; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-; disclaimer.
+; 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.
+; 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.
+; 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
@@ -38,6 +38,7 @@
chicken.platform
chicken.process
chicken.process-context
+ chicken.irregex
chicken.string)
(include "egg-environment.scm")
@@ -47,7 +48,7 @@
(define-foreign-variable POSTINSTALL_PROGRAM c-string "C_INSTALL_POSTINSTALL_PROGRAM")
(define-foreign-variable INSTALL_LIB_NAME c-string "C_INSTALL_LIB_NAME")
(define-foreign-variable TARGET_LIB_NAME c-string "C_TARGET_LIB_NAME")
-(define host-libs (foreign-value "C_INSTALL_MORE_LIBS" c-string))
+(define host-libs (string-split (foreign-value "C_INSTALL_MORE_LIBS" c-string)))
(define-foreign-variable TARGET_MORE_STATIC_LIBS c-string "C_TARGET_MORE_STATIC_LIBS")
(define-foreign-variable INSTALL_MORE_STATIC_LIBS c-string "C_INSTALL_MORE_STATIC_LIBS")
(define TARGET_CC default-cc)
@@ -64,7 +65,7 @@
;;; Parameters:
(define windows (eq? (software-type) 'windows))
-(define mingw (eq? (software-version) 'mingw32))
+(define mingw (eq? (software-version) 'mingw))
(define osx (eq? (software-version) 'macosx))
(define cygwin (eq? (software-version) 'cygwin))
(define aix (eq? (build-platform) 'aix))
@@ -89,25 +90,22 @@
(define (quotewrap str)
(qs (back-slash->forward-slash (normalize-pathname str))))
-(define (quotewrap-no-slash-trans str)
- (qs (normalize-pathname str)))
-
(define home
(if host-mode host-sharedir default-sharedir))
(define translator
- (quotewrap (make-pathname host-bindir CHICKEN_PROGRAM)))
+ (make-pathname host-bindir CHICKEN_PROGRAM))
-(define compiler (quotewrap (if host-mode host-cc default-cc)))
-(define c++-compiler (quotewrap (if host-mode host-cxx default-cxx)))
-(define rc-compiler (quotewrap (if host-mode INSTALL_RC_COMPILER TARGET_RC_COMPILER)))
-(define linker (quotewrap (if host-mode host-cc default-cc)))
-(define c++-linker (quotewrap (if host-mode host-cxx default-cxx)))
+(define compiler (if host-mode host-cc default-cc))
+(define c++-compiler (if host-mode host-cxx default-cxx))
+(define rc-compiler (if host-mode INSTALL_RC_COMPILER TARGET_RC_COMPILER))
+(define linker (if host-mode host-cc default-cc))
+(define c++-linker (if host-mode host-cxx default-cxx))
(define object-extension (if mingw "obj" "o"))
(define library-extension "a")
-(define link-output-flag "-o ")
+(define link-output-flag "-o")
(define executable-extension "")
-(define compile-output-flag "-o ")
+(define compile-output-flag "-o")
(define shared-library-extension ##sys#load-dynamic-extension)
(define static-object-extension (##sys#string-append "static." object-extension))
(define static-library-extension (##sys#string-append "static." library-extension))
@@ -127,12 +125,12 @@
(libchicken)))
(define (default-library)
- (make-pathname library-dir (libchicken) library-extension))
+ (make-pathname library-dir (string-append (libchicken) "-static") library-extension))
(define default-compilation-optimization-options
(string-split (if host-mode host-cflags default-cflags)))
-(define best-compilation-optimization-options
+(define best-compilation-optimization-options
default-compilation-optimization-options)
(define default-linking-optimization-options
@@ -148,9 +146,9 @@
-block -disable-interrupts -fixnum-arithmetic -to-stdout -profile -raw -accumulate-profile
-check-syntax -case-insensitive -shared -compile-syntax -no-lambda-info
-dynamic -disable-stack-overflow-checks -local
- -emit-external-prototypes-first -inline -release
+ -emit-external-prototypes-first -inline -release
-analyze-only -keep-shadowed-macros -inline-global -ignore-repository
- -no-symbol-escape -no-parentheses-synonyms -r5rs-syntax
+ -no-parentheses-synonyms -r7rs-syntax
-no-argc-checks -no-bound-checks -no-procedure-checks -no-compiler-syntax
-emit-all-import-libraries -no-elevation -module-registration -no-module-registration
-no-procedure-checks-for-usual-bindings -regenerate-import-libraries
@@ -221,18 +219,18 @@
(if host-mode host-libdir default-libdir))
(define extra-libraries
- (if host-mode
- INSTALL_MORE_STATIC_LIBS
- TARGET_MORE_STATIC_LIBS))
+ (string-split (if host-mode
+ INSTALL_MORE_STATIC_LIBS
+ TARGET_MORE_STATIC_LIBS)))
-(define extra-shared-libraries
+(define extra-shared-libraries
(if host-mode host-libs default-libs))
-(define (default-library-files)
- (list (string-append "-l" (if host-mode INSTALL_LIB_NAME TARGET_LIB_NAME))))
+(define (library-files)
+ (list (default-library)))
-(define (library-files) (list (default-library)))
-(define (shared-library-files) (default-library-files))
+(define (shared-library-files)
+ (list "-l" (if host-mode INSTALL_LIB_NAME TARGET_LIB_NAME)))
(define translate-options '())
@@ -246,9 +244,9 @@
(define builtin-compile-options
(append
(if include-dir (list (conc "-I" include-dir)) '())
- (cond ((get-environment-variable "CHICKEN_C_INCLUDE_PATH") =>
- (lambda (path)
- (map (cut string-append "-I" <>) (map quotewrap (string-split path ":;")))))
+ (cond ((get-environment-variable "CHICKEN_C_INCLUDE_PATH") =>
+ (lambda (path)
+ (map (cut string-append "-I" <>) (string-split path ":;"))))
(else '()))))
(define compile-only-flag "-c")
@@ -271,17 +269,17 @@
host-libdir
TARGET_RUN_LIB_HOME)))))
(aix
- (list (conc "-Wl," rpath-option "\"" library-dir "\"")))
+ (list (conc "-Wl," rpath-option library-dir)))
(else
(list (conc "-L" library-dir))))
(if (and deployed (memq (software-version) '(freebsd openbsd netbsd)))
(list "-Wl,-z,origin")
'())
- (cond ((get-environment-variable "CHICKEN_C_LIBRARY_PATH") =>
- (lambda (path)
+ (cond ((get-environment-variable "CHICKEN_C_LIBRARY_PATH") =>
+ (lambda (path)
(map (cut string-append "-L" <>) (string-split path ":;"))))
(else '()))))
-
+
(define target-filename #f)
(define verbose #f)
(define keep-files #f)
@@ -353,18 +351,18 @@ Usage: #{csc} [OPTION ...] [FILENAME ...]
-D -DSYMBOL -feature SYMBOL register feature identifier
-no-feature SYMBOL disable builtin feature identifier
- -c++ compile via a C++ source file (.cpp)
+ -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
+ -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
+ -r7rs-syntax disables the CHICKEN extensions to
+ R7RS syntax
-compile-syntax macros are made available at run-time
-j -emit-import-library MODULE write compile-time module information into
separate file
@@ -390,7 +388,7 @@ Usage: #{csc} [OPTION ...] [FILENAME ...]
-no-trace disable rudimentary debugging information
-debug-info enable debug-information in compiled code for use
with an external debugger
- -profile executable emits profiling information
+ -profile executable emits profiling information
-accumulate-profile executable emits profiling information in
append mode
-profile-name FILENAME name of the generated profile information
@@ -471,7 +469,7 @@ Usage: #{csc} [OPTION ...] [FILENAME ...]
-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
+ -ld COMPILER select other linker than the default
-static link with static CHICKEN libraries and
extensions (if possible)
-F<DIR> pass \"-F<DIR>\" to C compiler
@@ -507,7 +505,7 @@ Usage: #{csc} [OPTION ...] [FILENAME ...]
-host compile for host when configured for
cross-compiling
-private-repository load extensions from executable path
- -deployed link support file to be used from a deployed
+ -deployed link support file to be used from a deployed
executable (sets `rpath' accordingly, if supported
on this platform)
-no-elevation embed manifest on Windows to supress elevation
@@ -581,9 +579,7 @@ EOF
(when (and (null? c-files)
(null? object-files))
(when show-debugging-help
- (command
- (string-intersperse
- (cons* translator "bogus.scm" translate-options))))
+ (exec translator (cons "bogus.scm" translate-options)))
(stop "no source files specified") )
(unless target-filename
(set! target-filename
@@ -596,7 +592,7 @@ EOF
(set! target-filename
(generate-target-filename (first scheme-files))))
(run-translation)))
- (unless translate-only
+ (unless translate-only
(run-compilation)
(unless compile-only
(when (pair? linked-extensions)
@@ -606,12 +602,9 @@ EOF
(fprintf (current-error-port)
"Warning: output file will overwrite source file `~A' - renaming source to `~A.old'~%"
target-filename target-filename)
- (command
- (sprintf
- "~A ~A ~A"
- (if windows-shell "move" "mv")
- ((if windows-shell quotewrap-no-slash-trans quotewrap) target-filename)
- ((if windows-shell quotewrap-no-slash-trans quotewrap) (string-append target-filename ".old")))))
+ (exec (if windows-shell "move" "mv")
+ (list target-filename
+ (string-append target-filename ".old"))))
(run-linking)) ) ]
[else
(let* ([arg (car args)]
@@ -625,18 +618,18 @@ EOF
(print (chicken-version))
(exit) ]
[(-version)
- (system (sprintf "~a ~a" translator " -version"))
+ (exec translator '("-version"))
(exit)]
- [(-c++)
+ [(-c++)
(set! cpp-mode #t)
(when osx (set! compile-options (cons "-no-cpp-precomp" compile-options))) ]
- [(-objc)
+ [(-objc)
(set! objc-mode #t) ]
[(-static)
(set! translate-options (cons "-static" translate-options))
(set! static #t)]
[(-cflags)
- (set! inquiry-only #t)
+ (set! inquiry-only #t)
(set! show-cflags #t) ]
[(-ldflags)
(set! inquiry-only #t)
@@ -699,10 +692,10 @@ EOF
(set! gui #t)
(set! compile-options (cons "-DC_GUI" compile-options))
(when mingw
- (set! object-files
- (cons (make-pathname
+ (set! object-files
+ (cons (make-pathname
host-sharedir "chicken.rc"
- object-extension)
+ object-extension)
object-files))
(set! link-options
(cons* "-lkernel32" "-luser32" "-lgdi32" "-mwindows"
@@ -711,7 +704,7 @@ EOF
(set! deployed #t))
[(-framework)
(check s rest)
- (when osx
+ (when osx
(set! link-options (cons* "-framework" (car rest) link-options)) )
(set! rest (cdr rest)) ]
[(-o -output-file)
@@ -737,7 +730,7 @@ EOF
(set! show-debugging-help #t)
(set! translate-only #t))
(set! rest (cdr rest)))
- [(-dry-run)
+ [(-dry-run)
(set! verbose #t)
(set! dry-run #t)]
[(-s -shared -dynamic)
@@ -782,20 +775,20 @@ EOF
(append link-options (list (string-append "-Wl," rpath-option rpath)))) )
(set! rest (cdr rest)) ]
[(-host) #f]
- ((-oi)
+ ((-oi)
(check s rest)
(t-options "-emit-inline-file" (car rest))
(set! rest (cdr rest)))
- ((-ot)
+ ((-ot)
(check s rest)
(t-options "-emit-types-file" (car rest))
(set! rest (cdr rest)))
- [(-)
+ [(-)
(set! scheme-files (append scheme-files '("-")))
(unless target-filename
(set! target-filename (make-pathname #f "a" executable-extension)))]
[else
- (when (eq? s '-to-stdout)
+ (when (eq? s '-to-stdout)
(set! to-stdout #t)
(set! translate-only #t) )
(when (memq s '(-optimize-level -benchmark-mode))
@@ -831,7 +824,7 @@ EOF
(cond ((null? (lset-difference/eq? opts short-options))
(set! rest
(append (map (lambda (o)
- (string-append "-" (string o))) opts)
+ (string-append "-" (string o))) opts)
rest) ))
((char=? #\l (car opts))
(stop "invalid option `~A' - did you mean `-L -l<library>'?" arg))
@@ -880,33 +873,30 @@ EOF
(when (member fc c-files)
(stop "C file generated from `~a' will overwrite explicitly given source file `~a'"
f fc))
- (command
- (string-intersperse
- (cons* translator (quotewrap f)
- (append
- (if to-stdout
- '("-to-stdout")
- `("-output-file" ,(quotewrap fc)) )
- (if (##sys#debug-mode?)
- '("-:d")
- '())
- (map quote-option
- (append
- extra-features
- translate-options
- (if (and static
- (not (member "-emit-link-file"
- translate-options)))
- (list "-emit-link-file"
- (pathname-replace-extension fc "link"))
- '())
- (cond (cpp-mode '("-feature" "chicken-scheme-to-c++"))
- (objc-mode '("-feature" "chicken-scheme-to-objc"))
- (else '()))
- translation-optimization-options)) ) )
- " ") )
+ (exec
+ translator
+ (cons* f
+ (append
+ (if to-stdout
+ '("-to-stdout")
+ `("-output-file" ,fc) )
+ (if (##sys#debug-mode?)
+ '("-:d")
+ '())
+ extra-features
+ translate-options
+ (if (and static
+ (not (member "-emit-link-file"
+ translate-options)))
+ (list "-emit-link-file"
+ (pathname-replace-extension fc "link"))
+ '())
+ (cond (cpp-mode '("-feature" "chicken-scheme-to-c++"))
+ (objc-mode '("-feature" "chicken-scheme-to-objc"))
+ (else '()))
+ translation-optimization-options ) ) )
(when (and static compile-only)
- (set! transient-link-files
+ (set! transient-link-files
(cons (pathname-replace-extension f "link")
transient-link-files)))
(set! c-files (append (list fc) c-files))
@@ -928,17 +918,15 @@ EOF
(when (member fo object-files)
(stop "object file generated from `~a' will overwrite explicitly given object file `~a'"
f fo))
- (command
- (string-intersperse
- (list (cond (cpp-mode c++-compiler)
- (else compiler) )
- (quotewrap f)
- (string-append compile-output-flag (quotewrap fo))
- compile-only-flag
- (if (and cpp-mode (string=? "g++" c++-compiler))
- "-Wno-write-strings"
- "")
- (compiler-options) ) ) )
+ (exec (cond (cpp-mode c++-compiler)
+ (else compiler) )
+ (cons* f
+ compile-output-flag fo
+ compile-only-flag
+ (append (if (and cpp-mode (string=? "g++" c++-compiler)) ; XXX This is somewhat hacky - g++ might not be *named* g++
+ '("-Wno-write-strings")
+ '())
+ (compiler-options)) ) )
(set! generated-object-files (cons fo generated-object-files))
(set! ofiles (cons fo ofiles))))
c-files)
@@ -950,23 +938,19 @@ EOF
(for-each
(lambda (f)
(let ((fo (string-append f "." object-extension)))
- (command
- (string-intersperse
- (list rc-compiler (quotewrap f) (quotewrap fo))))
+ (exec rc-compiler (list f fo))
(set! generated-object-files (cons fo generated-object-files))
(set! ofiles (cons fo ofiles))))
rc-files)
(set! object-files (append (reverse ofiles) object-files)) ; put generated object files first
- (unless keep-files
+ (unless keep-files
(for-each $delete-file generated-c-files)
(for-each $delete-file generated-rc-files))))
(define (compiler-options)
- (string-intersperse
- (map quote-option
- (append
- compilation-optimization-options
- compile-options) ) ) )
+ (append
+ compilation-optimization-options
+ compile-options) )
;;; Link object files and libraries:
@@ -974,36 +958,28 @@ EOF
(define (run-linking)
(set! object-files
(collect-linked-objects object-files generated-object-files))
- (let* ((files (map quotewrap object-files))
- (target (quotewrap target-filename))
- (targetdir #f))
- (command
- (string-intersperse
- (cons* (cond (cpp-mode c++-linker)
- (else linker) )
- (append
- files
- (list (string-append link-output-flag (quotewrap target-filename))
- (linker-options)
- (linker-libraries) ) ) ) ) )
- (when (and osx host-mode)
- (command
- (string-append
- POSTINSTALL_PROGRAM " -change " (libchicken) ".dylib "
- (quotewrap
- (let ((lib (string-append (libchicken) ".dylib")))
- (if deployed
- (make-pathname "@executable_path" lib)
- (make-pathname (if host-mode
- host-libdir
- TARGET_RUN_LIB_HOME)
- lib))))
- " "
- target) ))
- (unless keep-files
- (for-each $delete-file
- (append generated-object-files
- transient-link-files)))))
+ (exec (cond (cpp-mode c++-linker)
+ (else linker) )
+ (append
+ object-files
+ (list link-output-flag target-filename)
+ (linker-options)
+ (linker-libraries) ) )
+ (when (and osx host-mode)
+ (let ((lib (string-append (libchicken) ".dylib")))
+ (exec POSTINSTALL_PROGRAM
+ (list "-change" lib
+ (if deployed
+ (make-pathname "@executable_path" lib)
+ (make-pathname (if host-mode
+ host-libdir
+ TARGET_RUN_LIB_HOME)
+ lib))
+ target-filename))))
+ (unless keep-files
+ (for-each $delete-file
+ (append generated-object-files
+ transient-link-files))))
(define (collect-linked-objects ofiles gen-ofiles)
(define (locate-link-file o)
@@ -1028,28 +1004,21 @@ EOF
(else (loop (cdr os) (cons (car os) os2))))))
(define (copy-files from to)
- (command
- (sprintf "~a ~a ~a"
- (if windows-shell
- "copy /Y"
- "cp")
- ((if windows-shell quotewrap-no-slash-trans quotewrap) from)
- ((if windows-shell quotewrap-no-slash-trans quotewrap) to))))
+ (exec (if windows-shell "copy" "cp")
+ (append (if windows-shell '("/Y") '())
+ (list from to))))
(define (linker-options)
- (string-intersperse
- (map quote-option
- (append linking-optimization-options link-options) ) ) )
+ (append linking-optimization-options link-options) )
(define (linker-libraries)
- (string-intersperse
- (append
- (if static
- (library-files)
- (shared-library-files))
- (if static
- (list extra-libraries)
- (list extra-shared-libraries)))))
+ (append
+ (if static
+ (library-files)
+ (shared-library-files))
+ (if static
+ extra-libraries
+ extra-shared-libraries)))
;;; Helper procedures:
@@ -1064,32 +1033,21 @@ EOF
(or (criteria c)
(lp i1)))))))
-(define quote-option qs)
-
-(define last-exit-code #f)
-
-(define ($system str)
- (let ((str (cond (windows-shell
- (string-append "\"" str "\""))
- ((and osx (get-environment-variable "DYLD_LIBRARY_PATH"))
- => (lambda (path)
- (string-append "/usr/bin/env DYLD_LIBRARY_PATH="
- (qs path) " " str)))
- (else str))))
- (when verbose (print 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 (command str)
- (unless (zero? ($system str))
- (exit last-exit-code)))
+(define (exec prog args)
+ ;; NOTE: We construct a command line for debugging purposes, but it
+ ;; does not 100% represent what gets executed.
+ (let ((cmdline (string-intersperse (map quotewrap (cons prog args)) " ")))
+ (when verbose
+ (print cmdline))
+ (unless dry-run
+ (let*-values (((pid) (process-run prog args))
+ ((pid success? exit-code) (process-wait pid)))
+ (when (or (not success?) (not (zero? exit-code)))
+ (printf "\nError: shell command terminated with non-zero exit status ~S: ~A~%" exit-code cmdline)
+ (exit exit-code))))))
(define ($delete-file str)
- (when verbose
+ (when verbose
(print "rm " str) )
(unless dry-run (delete-file str) ))
@@ -1119,8 +1077,8 @@ EOF
;;; Run it:
(run
- (append
- (string-split (or (get-environment-variable "CSC_OPTIONS") ""))
+ (append
+ (string-split (or (get-environment-variable "CSC_OPTIONS") ""))
arguments))
)
diff --git a/csi.mdoc b/csi.mdoc
index 255c71b1..0ec74664 100644
--- a/csi.mdoc
+++ b/csi.mdoc
@@ -79,10 +79,8 @@ Enable alternative keyword-syntax
.Po prefix, suffix or none Pc
.It Fl no-parentheses-synonyms
Disable list delimiter synonyms.
-.It Fl no-symbol-escape
-Disables support for escaped symbols.
-.It Fl r5rs-syntax
-Disable the CHICKEN extensions to R5RS syntax.
+.It Fl r7rs-syntax
+Disable the CHICKEN extensions to R7RS syntax.
.It Fl s Ar PATHNAME , Fl script Ar PATHNAME
Use interpreter for shell scripts.
.It Fl ss Ar PATHNAME
diff --git a/csi.scm b/csi.scm
index 4990cedd..2a4c8477 100644
--- a/csi.scm
+++ b/csi.scm
@@ -8,11 +8,11 @@
; conditions are met:
;
; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-; disclaimer.
+; 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.
+; 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.
+; 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
@@ -41,7 +41,7 @@ EOF
) )
(module chicken.csi
- (editor-command toplevel-command set-describer! default-evaluator)
+ (editor-command toplevel-command default-evaluator)
(import scheme
chicken.base
@@ -67,6 +67,10 @@ EOF
chicken.syntax
chicken.time)
+(import (rename (only (scheme write) write) (write write/labels)))
+(import (only (scheme base) make-parameter open-input-string open-output-string
+ get-output-string port?))
+
(include "banner.scm")
(include "mini-srfi-1.scm")
@@ -78,10 +82,15 @@ EOF
(set! ##sys#features (cons #:csi ##sys#features))
(set! ##sys#notices-enabled #t)
+(set! ##sys#repl-print-hook
+ (lambda (o p)
+ (write/labels o p)
+ (newline)))
+
(define editor-command (make-parameter #f))
(define selected-frame #f)
-(define default-editor
+(define default-editor
(or (get-environment-variable "EDITOR")
(get-environment-variable "VISUAL")
(if (get-environment-variable "EMACS")
@@ -96,7 +105,7 @@ EOF
usage: csi [OPTION ...] [FILENAME ...]
`csi' is the CHICKEN interpreter.
-
+
FILENAME is a Scheme source file name with optional extension. OPTION may be
one of the following:
@@ -124,9 +133,8 @@ EOF
-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
+ -r7rs-syntax disables the CHICKEN extensions to
+ R7RS syntax
-s -script PATHNAME use csi as interpreter for Scheme scripts
-ss PATHNAME same as `-s', but invoke `main' procedure
-sx PATHNAME same as `-s', but print each expression
@@ -150,10 +158,10 @@ EOF
(or (and ##sys#windows-platform (char=? c #\\))
(char=? c #\/)))
-(define chop-separator
+(define chop-separator
(let ([substring substring] )
(lambda (str)
- (let* ((len (sub1 (##sys#size str)))
+ (let* ((len (sub1 (string-length str)))
(c (string-ref str len)))
(if (and (fx> len 0) (dirseparator? c))
(substring str 0 len)
@@ -162,7 +170,7 @@ EOF
;;; Find script in PATH (only used for Windows/DOS):
-(define lookup-script-file
+(define lookup-script-file
(let* ([buf (make-string 256)]
[_getcwd (foreign-lambda nonnull-c-string "_getcwd" scheme-pointer int)] )
(define (addext name)
@@ -171,14 +179,14 @@ EOF
(let ([n2 (string-append name ".bat")])
(and (file-exists? n2) n2) ) ) )
(define (string-index proc str1)
- (let ((len (##sys#size str1)))
+ (let ((len (string-length str1)))
(let loop ((i 0))
(cond ((fx>= i len) #f)
- ((proc (##core#inline "C_subchar" str1 i)) i)
+ ((proc (string-ref str1 i)) i)
(else (loop (fx+ i 1))) ) ) ) )
(lambda (name)
(let ([path (get-environment-variable "PATH")])
- (and (> (##sys#size name) 0)
+ (and (> (string-length name) 0)
(cond [(dirseparator? (string-ref name 0)) (addext name)]
[(string-index dirseparator? name)
(let ((p (_getcwd buf 256)))
@@ -191,7 +199,7 @@ EOF
(let ([name2 (string-append (chop-separator (##sys#slot ps 0)) name2)])
(or (addext name2)
(loop (##sys#slot ps 1)) ) ) ) ) ) ] ) ) ) ) ) )
-
+
;;; REPL history references:
@@ -228,7 +236,7 @@ EOF
(define (history-ref index)
(let ([i (inexact->exact index)])
(if (and (fx> i 0) (fx<= i history-count))
- (vector-ref history-list i)
+ (vector-ref history-list i)
(##sys#error "history entry index out of range" index) ) ) )
;;; Reader hooks for REPL history:
@@ -320,7 +328,7 @@ EOF
((dur)
(let* ([x (read)]
[n (read)]
- [xe (eval x)]
+ [xe (eval x)]
[xn (eval n)] )
(dump xe xn) ) )
((r) (report))
@@ -329,7 +337,7 @@ EOF
(let ((fns (string-split (read-line))))
(for-each load fns)
(##sys#void) ) )
- ((ln)
+ ((ln)
(let ((fns (string-split (read-line))))
(for-each (cut load-noisily <> printer: (lambda (x) (pretty-print x) (print* "==> "))) fns)
(##sys#void) ) )
@@ -338,13 +346,13 @@ EOF
(receive rs (time (eval x))
(history-add rs)
(apply values rs) ) ) )
- ((exn)
+ ((exn)
(when ##sys#last-exception
(history-add (list ##sys#last-exception))
(describe ##sys#last-exception) ) )
((e)
(let ((r (system
- (string-append
+ (string-append
(or (editor-command) default-editor)
" " (read-line)))))
(if (not (zero? r))
@@ -369,7 +377,7 @@ EOF
(history-add (list r))
r) )
((?)
- (display
+ (display
"Toplevel commands:
,? Show this text
@@ -392,7 +400,7 @@ EOF
,t EXP Evaluate form and print elapsed time
,x EXP Pretty print expanded expression EXP\n")
(for-each
- (lambda (a)
+ (lambda (a)
(let ((help (caddr a)))
(if help
(print #\space help)
@@ -400,7 +408,7 @@ EOF
command-table)
(##sys#void) )
(else
- (printf "undefined toplevel command ~s - enter `,?' for help~%" form)
+ (printf "undefined toplevel command ~s - enter `,?' for help~%" form)
(##sys#void) ) ) ) ) ) )
(else
(receive rs (eval form)
@@ -411,7 +419,7 @@ EOF
;;; Builtin toplevel commands:
(toplevel-command
- 'm
+ 'm
(let ((printf printf))
(lambda ()
(let ((name (read)))
@@ -449,7 +457,7 @@ EOF
(let ((printf printf)
(sort sort)
(with-output-to-port with-output-to-port)
- (current-output-port current-output-port)
+ (current-output-port current-output-port)
(argv argv)
(prefix (foreign-value "C_INSTALL_PREFIX" c-string)))
(lambda port
@@ -477,7 +485,7 @@ EOF
(cond ((>= c 3)
(display "\n")
(set! c 0))
- (else
+ (else
(display (make-string pad #\space))))))
fs))
(printf "~%~%~
@@ -493,7 +501,7 @@ EOF
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~%~
+ Memory:\theap size is ~S bytes~A with ~S bytes currently in use~%~
nursery size is ~S bytes, stack grows ~A~%~
Command line: \t~S~%"
(machine-type)
@@ -551,11 +559,9 @@ EOF
(define-constant max-describe-lines 40)
-(define describer-table (make-vector 37 '()))
-
(define describe
(let ([sprintf sprintf]
- [printf printf]
+ [printf printf]
[fprintf fprintf]
[length length]
[list-ref list-ref]
@@ -577,7 +583,7 @@ EOF
(lambda ()
(fprintf out " ~S: ~S" i v)))
(if (fx> n 1)
- (fprintf out "\t(followed by ~A identical instance~a)~% ...~%"
+ (fprintf out "\t(followed by ~A identical instance~a)~% ...~%"
(fx- n 1)
(if (eq? n 2) "" "s"))
(newline out) )
@@ -592,8 +598,7 @@ EOF
((eq? x #t) (fprintf out "boolean true~%"))
((eq? x #f) (fprintf out "boolean false~%"))
((null? x) (fprintf out "empty list~%"))
- ((##core#inline "C_bwpp" x)
- ;; TODO: replace with bwp-object? later
+ ((bwp-object? x)
(fprintf out "broken weak pointer~%"))
((eof-object? x) (fprintf out "end-of-file object~%"))
((eq? (##sys#void) x) (fprintf out "unspecified object~%"))
@@ -613,17 +618,17 @@ EOF
((cplxnum? x) (fprintf out "~A complex number ~S~%"
(if (exact? x) "exact" "inexact") x))
((number? x) (fprintf out "number ~S~%" x))
- ((string? x) (descseq "string" ##sys#size string-ref 0))
+ ((string? x) (descseq "string" string-length string-ref 0))
((vector? x) (descseq "vector" ##sys#size ##sys#slot 0))
((keyword? x)
- (fprintf out "keyword symbol with name ~s~%"
- (##sys#symbol->string x)))
+ (fprintf out "keyword symbol with name ~s~%"
+ (##sys#symbol->string/shared x)))
((symbol? x)
(unless (##sys#symbol-has-toplevel-binding? x)
(display "unbound " out))
(fprintf out "~asymbol with name ~S~%"
(if (##sys#interned-symbol? x) "" "uninterned ")
- (##sys#symbol->string x))
+ (##sys#symbol->string/shared x))
(let ((plist (##sys#slot x 2)))
(unless (null? plist)
(display " \nproperties:\n\n" out)
@@ -650,24 +655,24 @@ EOF
((pair? x) (fprintf out "pair with car ~S~%and cdr ~S~%" (car x) (cdr x)))
((procedure? x)
(let ([len (##sys#size x)])
- (descseq
+ (descseq
(sprintf "procedure with code pointer 0x~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~%"
+ "~A port of type ~A with name ~S and ~A encoding~%"
(if (##sys#slot x 1) "input" "output")
(##sys#slot x 7)
(##sys#slot x 3)
- (##sys#peek-unsigned-integer x 0) ) )
- ((not (##core#inline "C_blockp" x))
+ (##sys#slot x 15) ) )
+ ((not (##core#inline "C_blockp" x))
;; catch immediates here, as ##sys#locative? crashes on non-block
(fprintf out "unknown immediate object~%"))
((##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)
+ (case (##sys#slot x 2)
((0) "slot")
((1) "char")
((2) "u8vector")
@@ -683,7 +688,7 @@ EOF
((##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)
+ (fprintf out "bytevector 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)) )
@@ -718,9 +723,8 @@ EOF
(loop (cddr props)) ) ) )
(##sys#slot x 1) ) )
((##sys#generic-structure? x)
- (let ([st (##sys#slot x 0)])
- (cond ((hash-table-ref describer-table st) => (cut <> x out))
- ((assq st bytevector-data) =>
+ (let ((st (##sys#slot x 0)))
+ (cond ((assq st bytevector-data) =>
(lambda (data)
(apply descseq (append (map eval (cdr data)) (list 0)))) )
(else
@@ -729,10 +733,6 @@ EOF
(else (fprintf out "unknown object~%")) )
(##sys#void) ) ) )
-(define (set-describer! tag proc)
- (##sys#check-symbol tag 'set-describer!)
- (hash-table-set! describer-table tag proc))
-
;;; Display hexdump:
@@ -744,7 +744,9 @@ EOF
(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)]
+ [(string? x)
+ (let ((bv (##sys#slot x 0)))
+ (hexdump bv (bestlen (fx- (##sys#size bv) 1)) ##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))
@@ -761,7 +763,7 @@ EOF
(define (justify n m base lead)
(let* ([s (number->string n base)]
- [len (##sys#size s)] )
+ [len (string-length s)] )
(if (fx< len m)
(string-append (make-string (fx- m len) lead) s)
s) ) )
@@ -778,7 +780,7 @@ EOF
(unless (fx= o 0)
(do ((k (fx- 16 o) (fx- k 1)))
((fx= k 0))
- (display " " out) ) ) ) ) )
+ (display " " out) ) ) ) ) )
(write-char #\space out)
(display (justify (ref bv a) 2 16 #\0) out) )
(write-char #\space out)
@@ -788,7 +790,7 @@ EOF
(let ([c (ref bv a)])
(if (and (fx>= c 32) (fx< c 128))
(write-char (integer->char c) out)
- (write-char #\. out) ) ) )
+ (write-char #\. out) ) ) )
(write-char #\newline out) ) ) ) )
@@ -805,7 +807,7 @@ EOF
(##sys#print x #t ##sys#standard-output))))
(let* ((ct (or ##sys#repl-recent-call-chain '()))
(len (length ct)))
- (set! selected-frame
+ (set! selected-frame
(or (and (memq fn ct) fn)
(and (fx> len 0)
(list-ref ct (fx- len 1)))))
@@ -818,7 +820,7 @@ EOF
(data (##sys#slot info 2)) ; cooked2 (cntr/frameinfo)
(finfo (##sys#structure? data 'frameinfo))
(cntr (if finfo (##sys#slot data 1) data))) ; cntr
- (printf "~a~a:~a\t~a\t "
+ (printf "~a~a:~a\t~a\t "
(if here #\* #\space)
i
(if (and finfo (pair? (##sys#slot data 2))) "[]" " ") ; e
@@ -839,7 +841,7 @@ EOF
(newline))))
(##sys#slot data 2) ; e
(##sys#slot data 3))))))))) ; v
-
+
(define select-frame
(let ((display display))
(lambda (n)
@@ -850,7 +852,7 @@ EOF
(display "no such frame\n"))
(else
(set! selected-frame
- (list-ref
+ (list-ref
##sys#repl-recent-call-chain
(fx- (length ##sys#repl-recent-call-chain) (fx+ n 1))))
(show-frameinfo selected-frame))))))
@@ -858,14 +860,14 @@ EOF
(define copy-from-frame
(let ((display display)
(newline newline)
- (call/cc call/cc))
+ (call/cc call-with-current-continuation))
(lambda (name)
(let* ((ct (or ##sys#repl-recent-call-chain '()))
(len (length ct))
- (name
+ (name
(cond ((symbol? name) (##sys#slot name 1)) ; name
((string? name) name)
- (else
+ (else
(display "string or symbol required for `,g'\n")
#f))))
(define (compare sym)
@@ -881,7 +883,7 @@ EOF
(newline)
(return (##sys#void)))
(do ((ct ct (cdr ct)))
- ((null? ct) (fail "no environment in frame"))
+ ((null? ct) (fail "no environment in frame"))
;;XXX this should be refactored as it duplicates the code above
(let* ((info (car ct))
(here (eq? selected-frame info))
@@ -909,7 +911,7 @@ EOF
(define-foreign-variable _sigint int "SIGINT")
-(define-syntax defhandler
+(define-syntax defhandler
(syntax-rules ()
((_ sig handler)
(begin
@@ -929,14 +931,14 @@ EOF
((equal? (car ks) (car set)) set)
(else (find (cdr ks))) ) ) ) ) )
-(define-constant short-options
+(define-constant short-options
'(#\k #\s #\h #\D #\e #\i #\R #\b #\n #\q #\w #\- #\I #\p #\P #\K) )
(define-constant long-options
'("-ss" "-sx" "-script" "-version" "-help" "--help" "-feature" "-no-feature" "-eval"
"-case-insensitive" "-keyword-style" "-no-parentheses-synonyms" "-no-symbol-escape"
- "-r5rs-syntax" "-setup-mode"
- "-require-extension" "-batch" "-quiet" "-no-warnings" "-no-init"
+ "-r7rs-syntax" "-setup-mode"
+ "-require-extension" "-batch" "-quiet" "-no-warnings" "-no-init"
"-include-path" "-release" "-print" "-pretty-print" "--") )
(define (canonicalize-args args)
@@ -945,15 +947,15 @@ EOF
'()
(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)))
- (if (memq (##core#inline "C_subchar" x 1) short-options)
+ ((and (fx= (string-length x) 2)
+ (char=? #\- (string-ref x 0)))
+ (if (memq (string-ref x 1) short-options)
(cons x (loop (cdr args)))
(##sys#error "invalid option" x)))
- ((and (fx> (##sys#size x) 2)
- (char=? #\- (##core#inline "C_subchar" x 0))
+ ((and (fx> (string-length x) 2)
+ (char=? #\- (string-ref x 0))
(not (member x long-options)) )
- (if (char=? #\: (##core#inline "C_subchar" x 1))
+ (if (char=? #\: (string-ref x 1))
(loop (cdr args))
(let ((cs (string->list (substring x 1))))
(if (findall cs short-options)
@@ -968,9 +970,9 @@ EOF
(loop (cdr chars))))))
(define-constant simple-options
- '("--" "-b" "-batch" "-q" "-quiet" "-n" "-no-init" "-w" "-no-warnings"
+ '("--" "-b" "-batch" "-q" "-quiet" "-n" "-no-init" "-w" "-no-warnings"
"-i" "-case-insensitive"
- "-no-parentheses-synonyms" "-no-symbol-escape" "-r5rs-syntax" "-setup-mode"
+ "-no-parentheses-synonyms" "-r7rs-syntax" "-setup-mode"
; Not "simple" but processed early
"-ss" "-sx" "-s" "-script") )
@@ -986,12 +988,12 @@ EOF
((char-whitespace? (string-ref str (sub1 back)))
(loop front (sub1 back)))
(else (substring str front back)))))
-
+
(define (string->extension-name str)
(let ((str (string-trim str)))
(if (and (positive? (string-length str))
(char=? #\( (string-ref str 0)))
- (handle-exceptions ex
+ (handle-exceptions ex
(##sys#error "invalid import specification" str)
(with-input-from-string str read))
(string->symbol str))))
@@ -1011,7 +1013,7 @@ EOF
(command-line-arguments (cddr script))
;; 2012-10-04 (felix) left 'script activated to avoid breaking too much code
(register-feature! 'chicken-script)
- (set-cdr! (cdr script) '())
+ (set-cdr! (cdr script) '())
(when ##sys#windows-platform
(and-let* ((sname (lookup-script-file (cadr script))))
(set-car! (cdr script) sname) ) ) ]
@@ -1087,16 +1089,12 @@ EOF
(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"))
+ (when (member* '("-r7rs-syntax") args)
+ (unless quiet (display "Disabled the CHICKEN extensions to R7RS syntax\n"))
(case-sensitive #f)
(keyword-style #:none)
- (parentheses-synonyms #f)
- (symbol-escape #f) )
- ;; Load the default modules into the evaluation environment.
+ (parentheses-synonyms #f) )
+ ;; Load the the default modules into the evaluation environment.
;; This is done before setting load-verbose => #t to avoid
;; spurious import messages.
(eval `(import-for-syntax ,@default-syntax-imports))
diff --git a/csibatch.bat b/csibatch.bat
deleted file mode 100644
index 8f78a00d..00000000
--- a/csibatch.bat
+++ /dev/null
@@ -1,2 +0,0 @@
-@echo off
-csi -script %1 %2 %3 %4 %5 %6 %7 %8 %9
diff --git a/data-structures.scm b/data-structures.scm
index 1c3f063d..8e4a744f 100644
--- a/data-structures.scm
+++ b/data-structures.scm
@@ -8,11 +8,11 @@
; are met:
;
; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-; disclaimer.
+; 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.
+; 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.
+; 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
@@ -42,6 +42,7 @@
(import chicken.condition)
(import chicken.fixnum)
(import chicken.foreign)
+(import (only (scheme base) open-output-string get-output-string))
; (reverse-string-append l) = (apply string-append (reverse l))
@@ -65,13 +66,13 @@
;;; Anything->string conversion:
-(define ->string
+(define ->string
(lambda (x)
(cond [(string? x) x]
[(symbol? x) (symbol->string x)]
[(char? x) (string x)]
[(number? x) (##sys#number->string x)]
- [else
+ [else
(let ([o (open-output-string)])
(display x o)
(get-output-string o) ) ] ) ) )
@@ -87,35 +88,36 @@
(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))
- (end (fx- wherelen whichlen)))
+ (let* ((wherelen (string-length where))
+ (whichlen (string-length which))
+ (end (fx- wherelen whichlen)))
(##sys#check-fixnum start loc)
(if (and (fx>= start 0)
- (fx>= wherelen start))
- (if (fx= whichlen 0)
- start
- (and (fx>= end 0)
- (let loop ((istart start))
- (cond ((fx> istart end) #f)
- ((test istart whichlen) istart)
- (else (loop (fx+ istart 1)))))))
- (##sys#error-hook (foreign-value "C_OUT_OF_RANGE_ERROR" int)
- loc
- start
- wherelen))))
-
- (set! ##sys#substring-index
+ (fx>= wherelen start))
+ (if (fx= whichlen 0)
+ start
+ (and (fx>= end 0)
+ (let loop ((istart start))
+ (cond ((fx> istart end) #f)
+ ((test istart whichlen) istart)
+ (else (loop (fx+ istart 1)))))))
+ (##sys#error-hook (foreign-value "C_OUT_OF_BOUNDS_ERROR" int)
+ loc
+ where
+ start))))
+
+ (set! ##sys#substring-index
(lambda (which where start)
- (traverse
+ (traverse
which where start
- (lambda (i l) (##core#inline "C_substring_compare" which where 0 i l))
+ (lambda (i l)
+ (##core#inline "C_u_i_substring_equal_p" which where 0 i l))
'substring-index) ) )
- (set! ##sys#substring-index-ci
+ (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))
+ (lambda (i l) (##core#inline "C_u_i_substring_ci_equal_p" which where 0 i l))
'substring-index-ci) ) ) )
(define (substring-index which where #!optional (start 0))
@@ -130,23 +132,26 @@
(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_string_compare" s1 s2 (if (fx< len-diff 0) len1 len2))))
- (if (fx= cmp 0)
- len-diff
+ (let ((len1 (string-length s1))
+ (len2 (string-length s2)) )
+ (let* ((len-diff (fx- len1 len2))
+ (cmp (##core#inline "C_utf_compare" s1 s2 0 0
+ (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
+ (let ((len1 (string-length s1))
+ (len2 (string-length s2)) )
+ (let* ((len-diff (fx- len1 len2))
+ (cmp (##core#inline "C_utf_compare_ci"
+ s1 s2 0 0
+ (if (fx< len-diff 0) len1 len2))))
+ (if (fx= cmp 0)
+ len-diff
cmp))))
@@ -155,14 +160,18 @@
(define (##sys#substring=? s1 s2 start1 start2 n)
(##sys#check-string s1 'substring=?)
(##sys#check-string s2 'substring=?)
- (##sys#check-range start1 0 (fx+ (##sys#size s1) 1) 'substring=?)
- (##sys#check-range start2 0 (fx+ (##sys#size s2) 1) 'substring=?)
- (let* ((maxlen (fxmin (fx- (##sys#size s1) start1)
- (fx- (##sys#size s2) start2)))
+ (##sys#check-fixnum start1 'substring=?)
+ (##sys#check-fixnum start2 'substring=?)
+ (let* ((l1 (string-length s1))
+ (l2 (string-length s2))
+ (maxlen (fxmin (fx- l1 start1)
+ (fx- l2 start2) ) )
(len (if n
(begin (##sys#check-range n 0 (fx+ maxlen 1) 'substring=?) n)
maxlen)))
- (##core#inline "C_substring_compare" s1 s2 start1 start2 len) ) )
+ (##sys#check-range start1 0 (fx+ l1 1) 'substring=?)
+ (##sys#check-range start2 0 (fx+ l2 1) 'substring=?)
+ (##core#inline "C_u_i_substring_equal_p" s1 s2 start1 start2 len) ) )
(define (substring=? s1 s2 #!optional (start1 0) (start2 0) len)
(##sys#substring=? s1 s2 start1 start2 len) )
@@ -170,15 +179,18 @@
(define (##sys#substring-ci=? s1 s2 start1 start2 n)
(##sys#check-string s1 'substring-ci=?)
(##sys#check-string s2 'substring-ci=?)
- (##sys#check-range start1 0 (fx+ (##sys#size s1) 1) 'substring-ci=?)
- (##sys#check-range start2 0 (fx+ (##sys#size s2) 1) 'substring-ci=?)
- (let* ((maxlen (fxmin (fx- (##sys#size s1) start1)
- (fx- (##sys#size s2) start2)))
+ (##sys#check-fixnum start1 'substring-ci=?)
+ (##sys#check-fixnum start2 'substring-ci=?)
+ (let* ((l1 (string-length s1))
+ (l2 (string-length s2))
+ (maxlen (fxmin (fx- l1 start1)
+ (fx- l2 start2) ) )
(len (if n
(begin (##sys#check-range n 0 (fx+ maxlen 1) 'substring-ci=?) n)
maxlen)))
- (##core#inline "C_substring_compare_case_insensitive"
- s1 s2 start1 start2 len) ) )
+ (##sys#check-range start1 0 (fx+ l1 1) 'substring=?)
+ (##sys#check-range start2 0 (fx+ l2 1) 'substring=?)
+ (##core#inline "C_u_i_substring_ci_equal_p" s1 s2 start1 start2 len) ) )
(define (substring-ci=? s1 s2 #!optional (start1 0) (start2 0) len)
(##sys#substring-ci=? s1 s2 start1 start2 len) )
@@ -191,25 +203,25 @@
(##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)] )
+ [strlen (string-length str)] )
(##sys#check-string del 'string-split)
- (let ([dellen (##sys#size del)]
+ (let ([dellen (string-length 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) )
+ (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 ([c (string-ref str i)])
(let scan ([j 0])
(cond [(fx>= j dellen) (loop (fx+ i 1) last from)]
- [(eq? c (##core#inline "C_subchar" del j))
+ [(eq? c (string-ref del j))
(let ([i2 (fx+ i 1)])
(if (or (fx> i from) flag)
(loop i2 (add from i last) i2)
@@ -222,44 +234,50 @@
(define (string-intersperse strs #!optional (ds " "))
(##sys#check-list strs 'string-intersperse)
(##sys#check-string ds 'string-intersperse)
- (let ((dslen (##sys#size ds)))
+ (let* ((dsbv (##sys#slot ds 0))
+ (dslen (fx- (##sys#size dsbv) 1)))
(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* ((bytes (fx- n dslen))
+ (bv (##sys#allocate-bytevector (fx+ bytes 1) 0)))
(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)))
+ (next (##sys#slot ss2 1))
+ (bvi (##sys#slot stri 0))
+ (count (fx- (##sys#size bvi) 1)))
+ (##core#inline "C_copy_memory_with_offset" bv bvi n2 0 count)
+ (let ((n3 (fx+ n2 count)))
(if (##core#inline "C_eqp" next '())
- str2
- (begin
- (##core#inline "C_substring_copy" ds str2 0 dslen n3)
+ (##core#inline_allocate ("C_a_ustring" 5) bv
+ (##core#inline "C_utf_range_length"
+ bv 0 n3))
+
+ (begin
+ (##core#inline "C_copy_memory_with_offset"
+ bv dsbv n3 0 dslen)
(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)) ) ) )
+ (fx+ (fx- (##sys#size (##sys#slot stri 0)) 1)
+ (fx+ dslen n)) ) ) )
(else (##sys#error-not-a-proper-list strs)) ) ) ) )
;;; Translate elements of a string:
-(define string-translate
+(define string-translate
(lambda (str from . to)
-
(define (instring s)
- (let ([len (##sys#size s)])
+ (let ([len (string-length s)])
(lambda (c)
(let loop ([i 0])
(cond [(fx>= i len) #f]
- [(eq? c (##core#inline "C_subchar" s i)) i]
+ [(eq? c (string-ref s i)) i]
[else (loop (fx+ i 1))] ) ) ) ) )
-
(let* ([from
(cond [(char? from) (lambda (c) (eq? c from))]
[(pair? from) (instring (list->string from))]
@@ -273,59 +291,73 @@
[(pair? tx) (list->string tx)]
[else
(##sys#check-string tx 'string-translate)
- tx] ) ) ) ]
- [tlen (and (string? to) (##sys#size to))] )
+ tx] ) ) ) ]
+ [tlen (and (string? to) (string-length to))] )
(##sys#check-string str 'string-translate)
- (let* ([slen (##sys#size str)]
+ (let* ([slen (string-length 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)]
+ (let* ([ci (string-ref str i)]
[found (from ci)] )
(cond [(not found)
- (##core#inline "C_setsubchar" str2 j ci)
+ (string-set! 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)
+ (string-set! str2 j to)
(loop (fx+ i 1) (fx+ j 1)) ]
[(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))
+ [else
+ (string-set! str2 j (string-ref to found))
(loop (fx+ i 1) (fx+ j 1)) ] ) ) ) ) ) ) ) )
+(define (fragments->string total fs)
+ (let ((dest (##sys#make-bytevector (fx+ total 1))))
+ (let loop ((fs fs) (pos 0))
+ (if (null? fs)
+ (##core#inline_allocate ("C_a_ustring" 5) dest
+ (##core#inline "C_utf_length" dest))
+ (let* ((f (##sys#slot fs 0))
+ (flen (fx- (##sys#size f) 1)))
+ (##core#inline "C_copy_memory_with_offset" dest f pos 0 flen)
+ (loop (##sys#slot fs 1) (fx+ pos flen)) ) ) ) ) )
+
(define (string-translate* str smap)
(##sys#check-string str 'string-translate*)
(##sys#check-list smap 'string-translate*)
- (let ((len (##sys#size str)))
+ (let ((len (string-length str)))
(define (collect i from total fs)
(if (fx>= i len)
- (##sys#fragments->string
- total
- (##sys#fast-reverse
- (if (fx> i from)
- (cons (##sys#substring str from i) fs)
- fs) ) )
+ (begin
+ (when (fx> i from)
+ (let ((bv (##sys#slot (##sys#substring str from i) 0)))
+ (set! fs (cons bv fs))
+ (set! total (fx+ total (fx- (##sys#size bv) 1)))))
+ (fragments->string total (##sys#fast-reverse fs)))
(let loop ((smap smap))
- (if (null? smap)
- (collect (fx+ i 1) from (fx+ total 1) fs)
+ (if (null? smap)
+ (collect (fx+ i 1) from total fs)
(let* ((p (car smap))
(sm (car p))
(smlen (string-length sm))
(st (cdr p)) )
(if (and (fx<= (fx+ i smlen) len)
- (##core#inline "C_substring_compare" str sm i 0 smlen))
- (let ((i2 (fx+ i smlen)))
+ (##core#inline "C_u_i_substring_equal_p" str sm i 0 smlen))
+ (let ((i2 (fx+ i smlen))
+ (stbv (##sys#slot st 0)))
(when (fx> i from)
- (set! fs (cons (##sys#substring str from i) fs)) )
- (collect
+ (let ((bv (##sys#slot (##sys#substring str from i) 0)))
+ (set! fs (cons bv fs))
+ (set! total (fx+ total (fx- (##sys#size bv) 1)))))
+ (collect
i2 i2
- (fx+ total (string-length st))
- (cons st fs) ) )
+ (fx+ total (fx- (##sys#size stbv) 1))
+ (cons stbv fs) ) )
(loop (cdr smap)) ) ) ) ) ) )
(collect 0 0 0 '()) ) )
@@ -335,23 +367,23 @@
(define (string-chop str len)
(##sys#check-string str 'string-chop)
(##sys#check-fixnum len 'string-chop)
- (let ([total (##sys#size str)])
+ (let ([total (string-length 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))
+ (let* ((len (string-length str))
+ (slen (string-length suffix))
(diff (fx- len slen)) )
(if (and (fx>= len slen)
- (##core#inline "C_substring_compare" str suffix diff 0 slen) )
+ (##core#inline "C_u_i_substring_equal_p" str suffix diff 0 slen) )
(##sys#substring str 0 diff)
str) ) )
diff --git a/dbg-stub.c b/dbg-stub.c
index 26c90f41..10290f0f 100644
--- a/dbg-stub.c
+++ b/dbg-stub.c
@@ -439,7 +439,7 @@ send_event(int event, C_char *loc, C_char *val, C_char *cloc)
str = name_and_length(rw_buffer, &n);
ptr = malloc(sizeof(C_header) + n + 1);
memcpy(((C_SCHEME_BLOCK*)ptr)->data, str, n + 1);
- ((C_SCHEME_BLOCK *)ptr)->header = C_make_header(C_STRING_TYPE, n);
+ ((C_SCHEME_BLOCK *)ptr)->header = C_make_header(C_BYTEVECTOR_TYPE, n);
x = C_find_symbol((C_word)ptr, NULL);
if(x == C_SCHEME_FALSE)
diff --git a/defaults.make b/defaults.make
index 703e1cf1..5ff724ce 100644
--- a/defaults.make
+++ b/defaults.make
@@ -27,7 +27,7 @@
# basic parameters
-BINARYVERSION = 11
+BINARYVERSION = 12
STACKDIRECTION ?= 1
CROSS_CHICKEN ?= 0
@@ -151,7 +151,7 @@ LINKER_OUTPUT ?= $(LINKER_OUTPUT_OPTION) $@
LINKER_LIBRARY_OPTION ?= -l
ifdef STATICBUILD
LINKER_LIBRARY_PREFIX ?= lib
-LINKER_LIBRARY_SUFFIX ?= .a
+LINKER_LIBRARY_SUFFIX ?= -static.a
else
LINKER_LIBRARY_PREFIX ?= -l
LINKER_LIBRARY_SUFFIX ?=
@@ -185,7 +185,7 @@ ASSEMBLER_OUTPUT_OPTION ?= -o
ASSEMBLER_OUTPUT ?= $(ASSEMBLER_OUTPUT_OPTION) $@
ASSEMBLER_COMPILE_OPTION ?= -c
ifdef STATICBUILD
-PRIMARY_LIBCHICKEN ?= lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)$(A)
+PRIMARY_LIBCHICKEN ?= lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)-static$(A)
else
ifeq ($(PLATFORM),cygwin)
PRIMARY_LIBCHICKEN = cyg$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)-0.dll
@@ -215,8 +215,6 @@ COPY_COMMAND = cp
echo = echo '$(subst ','\'',$(3))'$(1)$(2)
#' fix Emacs syntax highlighting
endif
-WISH ?= "$$wish"
-GENERATE_DEBUGGER ?= cat $< >$@; echo 'exec $(WISH) "$(DATADIR)/feathers.tcl" -- "$$@"' >>$@
# file extensions
@@ -267,13 +265,14 @@ CHICKEN_PROGRAM_OPTIONS += $(if $(PROFILE_OBJECTS),-profile)
# import libraries
PRIMITIVE_IMPORT_LIBRARIES = chicken.base chicken.condition \
- chicken.csi chicken.foreign chicken.syntax chicken.time
+ chicken.csi chicken.foreign chicken.syntax chicken.time scheme.write \
+ scheme.time scheme.file scheme.process-context
DYNAMIC_IMPORT_LIBRARIES = srfi-4
-DYNAMIC_CHICKEN_IMPORT_LIBRARIES = bitwise blob errno file.posix \
+DYNAMIC_CHICKEN_IMPORT_LIBRARIES = bitwise bytevector errno file.posix \
fixnum flonum format gc io keyword load locative memory \
memory.representation platform plist pretty-print \
process process.signal process-context process-context.posix \
- random sort string time.posix
+ random sort string time.posix number-vector
DYNAMIC_CHICKEN_COMPILER_IMPORT_LIBRARIES = user-pass
DYNAMIC_CHICKEN_UNIT_IMPORT_LIBRARIES = continuation eval file \
internal irregex pathname port read-syntax repl tcp
@@ -288,7 +287,6 @@ CHICKEN_INSTALL_PROGRAM = $(PROGRAM_PREFIX)chicken-install$(PROGRAM_SUFFIX)
CHICKEN_UNINSTALL_PROGRAM = $(PROGRAM_PREFIX)chicken-uninstall$(PROGRAM_SUFFIX)
CHICKEN_STATUS_PROGRAM = $(PROGRAM_PREFIX)chicken-status$(PROGRAM_SUFFIX)
CHICKEN_DO_PROGRAM = $(PROGRAM_PREFIX)chicken-do$(PROGRAM_SUFFIX)
-CHICKEN_DEBUGGER_PROGRAM ?= $(PROGRAM_PREFIX)feathers$(PROGRAM_SUFFIX)$(SCRIPT_EXT)
IMPORT_LIBRARIES = $(DYNAMIC_IMPORT_LIBRARIES) \
$(PRIMITIVE_IMPORT_LIBRARIES) \
$(foreach lib,$(DYNAMIC_CHICKEN_IMPORT_LIBRARIES),chicken.$(lib)) \
@@ -300,7 +298,7 @@ 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 ?= lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)$(A)
+TARGETLIBS ?= lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)-static$(A)
TARGETS += $(TARGETLIBS) $(CHICKEN_STATIC_EXECUTABLE) \
$(CSI_STATIC_EXECUTABLE)
else
@@ -308,7 +306,7 @@ 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 ?= lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)$(A) $(LIBCHICKEN_SO_FILE)
+TARGETLIBS ?= lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)-static$(A) $(LIBCHICKEN_SO_FILE)
TARGETS += $(TARGETLIBS) $(CHICKEN_SHARED_EXECUTABLE) \
$(CSI_SHARED_EXECUTABLE) \
$(IMPORT_LIBRARIES:%=%.import.so)
@@ -335,7 +333,7 @@ all: $(TARGETS)
# generic part of chicken-config.h
-chicken-defaults.h:
+chicken-defaults.h: config.make
ifdef OPTIMIZE_FOR_SPEED
$(call echo, >,$@.tmp, /* (this build was optimized for speed) */)
endif
diff --git a/distribution/manifest b/distribution/manifest
index 4c676f87..d27a77f9 100644
--- a/distribution/manifest
+++ b/distribution/manifest
@@ -2,6 +2,7 @@ LICENSE
DEPRECATED
NEWS
README
+configure
config-arch.sh
identify.sh
banner.scm
@@ -40,6 +41,7 @@ irregex.c
posixunix.c
posixwin.c
profiler.c
+r7lib.c
read-syntax.c
scheduler.c
srfi-4.c
@@ -49,10 +51,6 @@ chicken.compiler.support.import.scm
repl.c
tcp.c
user-pass.c
-feathers.in
-feathers.bat.in
-feathers.tcl
-feathers.mdoc
buildversion
buildbranch
c-backend.scm
@@ -71,7 +69,6 @@ csc.mdoc
csc.scm
csi.mdoc
csi.scm
-csibatch.bat
eval.scm
eval-modules.scm
extras.scm
@@ -100,9 +97,11 @@ posixunix.scm
posixwin.scm
posix-common.scm
profiler.scm
+r7lib.scm
read-syntax.scm
repl.scm
runtime.c
+utf.c
scheduler.scm
srfi-4.scm
stub.scm
@@ -141,7 +140,6 @@ tests/null.scm
tests/sgrep.scm
tests/r7rs-tests.scm
tests/runtests.sh
-tests/runtests.bat
tests/runbench.sh
tests/srfi-4-tests.scm
tests/srfi-45-tests.scm
@@ -219,7 +217,6 @@ tests/specialization-test-1.scm
tests/specialization-test-2.scm
tests/specialization-test-2.types
tests/specialization.expected
-tests/test-create-temporary-file.scm
tests/test-irregex.scm
tests/re-tests.txt
tests/lolevel-tests.scm
@@ -258,16 +255,25 @@ tests/version-tests.scm
tests/messages-test.scm
tests/messages.expected
tests/types-db-consistency.scm
+tests/unicode-tests.scm
+tests/UTF-8-test.txt
+tests/invalid-utf-test.scm
+tests/file-encoding-test.scm
+tests/i-dont-know-i-jkust-work-here.utf-8.txt
+tests/i-dont-know-i-jkust-work-here.latin-1.txt
+tests/r7rs-tests-2.scm
+tests/life.scm
+tests/include.scm
+tests/include-ci.scm
+tests/ffi-tests.scm
tweaks.scm
Makefile
Makefile.android
Makefile.aix
-Makefile.detect
Makefile.linux
Makefile.macosx
Makefile.ios
Makefile.mingw
-Makefile.mingw-msys
Makefile.solaris
Makefile.bsd
Makefile.cygwin
@@ -290,8 +296,8 @@ chicken.base.import.scm
chicken.base.import.c
chicken.bitwise.import.scm
chicken.bitwise.import.c
-chicken.blob.import.scm
-chicken.blob.import.c
+chicken.bytevector.import.scm
+chicken.bytevector.import.c
chicken.compiler.user-pass.import.scm
chicken.compiler.user-pass.import.c
chicken.condition.import.scm
@@ -334,6 +340,8 @@ chicken.memory.import.scm
chicken.memory.import.c
chicken.memory.representation.import.scm
chicken.memory.representation.import.c
+chicken.number-vector.import.scm
+chicken.number-vector.import.c
chicken.pathname.import.scm
chicken.pathname.import.c
chicken.platform.import.scm
@@ -372,6 +380,14 @@ chicken.time.posix.import.scm
chicken.time.posix.import.c
srfi-4.import.scm
srfi-4.import.c
+scheme.file.import.scm
+scheme.file.import.c
+scheme.process-context.import.scm
+scheme.process-context.import.c
+scheme.time.import.scm
+scheme.time.import.c
+scheme.write.import.scm
+scheme.write.import.c
chicken-status.scm
chicken-status.c
chicken-install.scm
@@ -391,7 +407,6 @@ chicken-do.mdoc
types.db
chicken.png
scripts/chicken-flymake
-scripts/chicken-flymake.bat
scripts/csc-trans
scripts/compile-all
scripts/compare-documentation-exports.scm
@@ -405,7 +420,6 @@ manual-html/Bugs and limitations.html
manual-html/C interface.html
manual-html/Cross development.html
manual-html/Data representation.html
-manual-html/Debugging.html
manual-html/Declarations.html
manual-html/Deployment.html
manual-html/Deviations from the standard.html
@@ -421,7 +435,7 @@ manual-html/Interface to external functions and variables.html
manual-html/manual.css
manual-html/Module (chicken base).html
manual-html/Module (chicken bitwise).html
-manual-html/Module (chicken blob).html
+manual-html/Module (chicken bytevector).html
manual-html/Module (chicken condition).html
manual-html/Module (chicken continuation).html
manual-html/Module (chicken csi).html
@@ -462,8 +476,24 @@ manual-html/Module (chicken time).html
manual-html/Module (chicken time posix).html
manual-html/Module (chicken type).html
manual-html/Module r4rs.html
-manual-html/Module r5rs.html
manual-html/Module scheme.html
+manual-html/Module (scheme base).html
+manual-html/Module (scheme case-lambda).html
+manual-html/Module (scheme char).html
+manual-html/Module (scheme complex).html
+manual-html/Module (scheme cxr).html
+manual-html/Module (scheme eval).html
+manual-html/Module (scheme file).html
+manual-html/Module (scheme inexact).html
+manual-html/Module (scheme lazy).html
+manual-html/Module (scheme load).html
+manual-html/Module (scheme process-context).html
+manual-html/Module (scheme r4rs).html
+manual-html/Module (scheme r5rs).html
+manual-html/Module (scheme read).html
+manual-html/Module (scheme repl).html
+manual-html/Module (scheme time).html
+manual-html/Module (scheme write).html
manual-html/Modules.html
manual-html/Module srfi-4.html
manual-html/The User's Manual.html
diff --git a/egg-compile.scm b/egg-compile.scm
index ff8f3ecf..8ed3a8d4 100644
--- a/egg-compile.scm
+++ b/egg-compile.scm
@@ -77,43 +77,27 @@
((windows) +windows-executable-extension+)))
(define (copy-directory-command platform)
- (case platform
- ((unix) "cp -r")
- ((windows) "xcopy /y /i /e")))
+ "cp -r")
(define (copy-file-command platform)
- (case platform
- ((unix) "cp")
- ((windows) "copy /y")))
+ "cp")
(define (mkdir-command platform)
- (case platform
- ((unix) "mkdir -p")
- ((windows) "mkdir")))
+ "mkdir -p")
(define (install-executable-command platform)
- (case platform
- ((windows) (copy-file-command 'windows))
- (else
- (string-append default-install-program " "
- default-install-program-executable-flags))))
+ (string-append default-install-program " "
+ default-install-program-executable-flags))
(define (install-file-command platform)
- (case platform
- ((windows) (copy-file-command 'windows))
- (else
- (string-append default-install-program " "
- default-install-program-data-flags))))
+ (string-append default-install-program " "
+ default-install-program-data-flags))
(define (remove-file-command platform)
- (case platform
- ((unix) "rm -f")
- ((windows) "del /f /q")))
+ "rm -f")
(define (cd-command platform)
- (case platform
- ((unix) "cd")
- ((windows) "cd /d")))
+ "cd")
(define (uses-compiled-import-library? mode)
(not (and (eq? mode 'host) staticbuild)))
@@ -180,6 +164,27 @@
(else (fail x)))))
+;;; parse custom configuration information from script
+
+(define (parse-custom-config arg)
+ (define (read-all)
+ (let loop ((lst '()))
+ (let ((x (read)))
+ (if (eof-object? x)
+ (reverse lst)
+ (loop (append (reverse (flatten x)) lst))))))
+ (if (and (list? arg) (eq? 'custom-config (car arg)))
+ (let* ((arg (cdr arg))
+ (in (with-input-from-pipe
+ (conc default-csi " -s "
+ (if (list? arg)
+ (string-intersperse (map ->string arg) " ")
+ (->string arg)))
+ read-all)))
+ (map ->string in))
+ (list arg)))
+
+
;;; compile an egg-information tree into abstract build/install operations
(define (compile-egg-info eggfile info version platform mode)
@@ -207,6 +212,7 @@
(tfile #f)
(ptfile #f)
(ifile #f)
+ (install #t)
(eggfile (locate-egg-file eggfile))
(objext (object-extension platform))
(arcext (archive-extension platform))
@@ -218,6 +224,9 @@
(define (addfiles . filess)
(set! ifiles (concatenate (cons ifiles filess)))
files)
+ (define (checkfiles files target)
+ (when (null? files)
+ (warning "target has no files" target)))
(define (compile-component info)
(case (car info)
((extension)
@@ -241,7 +250,7 @@
(rtarget (or oname target)))
(when (eq? #t tfile) (set! tfile rtarget))
(when (eq? #t ifile) (set! ifile rtarget))
- (addfiles
+ (addfiles
(if (memq 'static link)
(list (conc dest "/" rtarget
(if (null? lobjs)
@@ -250,10 +259,10 @@
(conc dest "/" rtarget +link-file-extension+))
'())
(if (memq 'dynamic link) (list (conc dest "/" rtarget ".so")) '())
- (if tfile
+ (if tfile
(list (conc dest "/" tfile ".types"))
'())
- (if ifile
+ (if ifile
(list (conc dest "/" ifile ".inline"))
'())
(import-libraries mods dest rtarget mode))
@@ -269,7 +278,7 @@
link-objects: lobjs
output-file: rtarget)
exts)))))
- ((c-object)
+ ((installed-c-object c-object)
(fluid-let ((target (check-target (cadr info) exts))
(cdeps '())
(sdeps '())
@@ -278,11 +287,14 @@
(link (if (null? link) default-extension-linkage link))
(oname #f)
(mods #f)
+ (install (eq? 'installed-c-object (car info)))
(opts opts))
(for-each compile-extension/program (cddr info))
(let ((dest (effective-destination-repository mode #t))
;; Respect install-name if specified
(rtarget (or oname target)))
+ (when install
+ (addfiles (list (conc dest "/" rtarget objext))))
(set! objs
(cons (list target dependencies: cdeps source: src
options: opts
@@ -297,6 +309,7 @@
(dest #f)
(files '()))
(for-each compile-data/include (cddr info))
+ (checkfiles files target)
(let* ((dest (or (and dest (normalize-destination dest mode))
(if (eq? mode 'target)
default-sharedir
@@ -304,9 +317,9 @@
(dest (normalize-pathname (conc dest "/"))))
(addfiles (map (cut conc dest <>) files)))
(set! data
- (cons (list target dependencies: '() files: files
- destination: dest mode: mode)
- data))))
+ (cons (list target dependencies: '() files: files
+ destination: dest mode: mode)
+ data))))
((generated-source-file)
(fluid-let ((target (check-target (cadr info) data))
(src #f)
@@ -317,7 +330,7 @@
(unless cbuild
(error "generated source files need a custom build step" target))
(set! genfiles
- (cons (list target dependencies: cdeps source: src
+ (cons (list target dependencies: cdeps source: src
custom: cbuild source-dependencies: sdeps
eggfile: eggfile)
genfiles))))
@@ -326,6 +339,7 @@
(dest #f)
(files '()))
(for-each compile-data/include (cddr info))
+ (checkfiles files target)
(let* ((dest (or (and dest (normalize-destination dest mode))
(if (eq? mode 'target)
default-incdir
@@ -333,13 +347,14 @@
(dest (normalize-pathname (conc dest "/"))))
(addfiles (map (cut conc dest <>) files)))
(set! cinc
- (cons (list target dependencies: '() files: files
- destination: dest mode: mode)
- cinc))))
+ (cons (list target dependencies: '() files: files
+ destination: dest mode: mode)
+ cinc))))
((scheme-include)
(fluid-let ((target (check-target (cadr info) scminc))
(dest #f)
(files '()))
+ (checkfiles files target)
(for-each compile-data/include (cddr info))
(let* ((dest (or (and dest (normalize-destination dest mode))
(if (eq? mode 'target)
@@ -347,10 +362,10 @@
(override-prefix "/share" host-sharedir))))
(dest (normalize-pathname (conc dest "/"))))
(addfiles (map (cut conc dest <>) files)))
- (set! scminc
- (cons (list target dependencies: '() files: files
- destination: dest mode: mode)
- scminc))))
+ (set! scminc
+ (cons (list target dependencies: '() files: files
+ destination: dest mode: mode)
+ scminc))))
((program)
(fluid-let ((target (check-target (cadr info) prgs))
(cdeps '())
@@ -363,18 +378,18 @@
(oname #f)
(opts opts))
(for-each compile-extension/program (cddr info))
- (let ((dest (if (eq? mode 'target)
+ (let ((dest (if (eq? mode 'target)
default-bindir
(override-prefix "/bin" host-bindir)))
;; Respect install-name if specified
(rtarget (or oname target)))
(addfiles (list (conc dest "/" rtarget exeext)))
(set! prgs
- (cons (list target dependencies: cdeps
+ (cons (list target dependencies: cdeps
source: src options: opts
- link-options: lopts linkage: link
+ link-options: lopts linkage: link
custom: cbuild
- mode: mode output-file: rtarget
+ mode: mode output-file: rtarget
source-dependencies: sdeps
link-objects: lobjs
eggfile: eggfile)
@@ -382,7 +397,7 @@
(else (compile-common info compile-component 'component))))
(define (compile-extension/program info)
(case (car info)
- ((linkage)
+ ((linkage)
(set! link (cdr info)))
((types-file)
(set! tfile
@@ -402,10 +417,16 @@
(set! ifile (or (null? (cdr info)) (arg info 1 name?))))
((custom-build)
(set! cbuild (->string (arg info 1 name?))))
- ((csc-options)
- (set! opts (append opts (cdr info))))
+ ((csc-options)
+ (set! opts
+ (apply append
+ opts
+ (map parse-custom-config (cdr info)))))
((link-options)
- (set! lopts (append lopts (cdr info))))
+ (set! lopts
+ (apply append
+ lopts
+ (map parse-custom-config (cdr info)))))
((source)
(set! src (->string (arg info 1 name?))))
((install-name)
@@ -435,19 +456,21 @@
(case (car info)
((destination)
(set! dest (->string (arg info 1 name?))))
- ((files)
+ ((files)
(set! files (append files (map ->string (cdr info)))))
(else (compile-common info compile-data/include 'data/include))))
(define (compile-options info)
+ (define (custom info)
+ (map parse-custom-config info))
(case (car info)
- ((csc-options) (set! opts (append opts (cdr info))))
- ((link-options) (set! lopts (append lopts (cdr info))))
- ((linkage) (set! link (append link (cdr info))))
+ ((csc-options) (set! opts (apply append opts (custom (cdr info)))))
+ ((link-options) (set! lopts (apply append lopts (custom (cdr info)))))
+ ((linkage) (set! link (apply append link (custom (cdr info)))))
(else (error "invalid component-options specification" info))))
(define (compile-cond-expand info walk)
(let loop ((clauses (cdr info)))
(cond ((null? clauses)
- (error "no matching clause in `cond-expand' form"
+ (error "no matching clause in `cond-expand' form"
info))
((or (eq? 'else (caar clauses))
(check-condition (caar clauses) mode link))
@@ -495,9 +518,9 @@
(for-each compile info)
;; sort topologically, by dependencies
(let* ((all (append prgs exts objs genfiles))
- (order (reverse (sort-dependencies
+ (order (reverse (sort-dependencies
(map (lambda (dep)
- (cons (car dep)
+ (cons (car dep)
(filter-deps (car dep)
(get-keyword dependencies: (cdr dep)))))
all)
@@ -505,16 +528,16 @@
;; generate + return build/install commands
(values
;; build commands
- (append-map
+ (append-map
(lambda (id)
(cond ((assq id exts) =>
(lambda (data)
(let ((link (get-keyword linkage: (cdr data)))
(mods (get-keyword modules: (cdr data))))
- (append (if (memq 'dynamic link)
+ (append (if (memq 'dynamic link)
(list (apply compile-dynamic-extension data))
'())
- (if (memq 'static link)
+ (if (memq 'static link)
;; if compiling both static + dynamic, override
;; modules/types-file/inline-file properties to
;; avoid generating things twice:
@@ -536,10 +559,10 @@
((assq id prgs) =>
(lambda (data)
(let ((link (get-keyword linkage: (cdr data))))
- (append (if (memq 'dynamic link)
+ (append (if (memq 'dynamic link)
(list (apply compile-dynamic-program data))
'())
- (if (memq 'static link)
+ (if (memq 'static link)
(list (apply compile-static-program data))
'())))))
((assq id objs) =>
@@ -563,7 +586,7 @@
;; installation commands
(append
(append-map
- (lambda (ext)
+ (lambda (ext)
(let ((link (get-keyword linkage: (cdr ext)))
(mods (get-keyword modules: (cdr ext))))
(append
@@ -590,6 +613,7 @@
(list (apply install-inline-file ext))
'()))))
exts)
+ (map (lambda (obj) (apply install-object obj)) objs)
(map (lambda (prg) (apply install-program prg)) prgs)
(map (lambda (data) (apply install-data data)) data)
(map (lambda (cinc) (apply install-c-include cinc)) cinc)
@@ -648,10 +672,11 @@
`(,@(filelist srcdir source-dependencies) ,src ,eggfile
,@(if custom (list cmd) '())
,@(get-dependency-targets dependencies))
- `(,cmd ,@(if keep-generated-files '("-k") '())
+ `(,@(if custom '("sh") '())
+ ,cmd ,@(if keep-generated-files '("-k") '())
"-regenerate-import-libraries"
,@(if modules '("-J") '()) "-M"
- "-setup-mode" "-static" "-I" ,srcdir
+ "-setup-mode" "-static" "-I" ,srcdir
"-emit-link-file" ,lfile
,@(if (eq? mode 'host) '("-host") '())
"-D" "compiling-extension"
@@ -666,7 +691,7 @@
link-objects))))
(print-build-command (list out3)
`(,out2 ,@lobjs)
- `(,target-librarian ,(raw-arg target-librarian-options) ,out3 ,out2 ,@lobjs)
+ `(,target-librarian ,target-librarian-options ,out3 ,out2 ,@lobjs)
platform)))
(print-end-command platform)))
@@ -716,7 +741,8 @@
,@(filelist srcdir lobjs)
,@(filelist srcdir source-dependencies)
,@(get-dependency-targets dependencies))
- `(,cmd ,@(if keep-generated-files '("-k") '())
+ `(,@(if custom '("sh") '())
+ ,cmd ,@(if keep-generated-files '("-k") '())
,@(if (eq? mode 'host) '("-host") '())
"-D" "compiling-extension"
"-J" "-s" "-regenerate-import-libraries"
@@ -736,7 +762,7 @@
srcdir platform)
(let* ((cmd default-csc)
(sname (prefix srcdir name))
- (opts (if (null? options)
+ (opts (if (null? options)
default-import-library-compilation-options
options))
(out (target-file (conc sname ".import.so") mode))
@@ -777,7 +803,8 @@
`(,@(filelist srcdir source-dependencies) ,src ,eggfile
,@(if custom (list cmd) '())
,@(get-dependency-targets dependencies))
- `(,cmd "-setup-mode" "-static" "-I" ,srcdir
+ `(,@(if custom '("sh") '())
+ ,cmd "-setup-mode" "-static" "-I" ,srcdir
,@(if (eq? mode 'host) '("-host") '())
"-c" "-C" ,(conc "-I" srcdir)
,@opts ,src "-o" ,out)
@@ -808,7 +835,8 @@
`(,src ,eggfile ,@(if custom (list cmd) '())
,@(filelist srcdir source-dependencies)
,@(get-dependency-targets dependencies))
- `(,cmd ,@(if (eq? mode 'host) '("-host") '())
+ `(,@(if custom '("sh") '())
+ ,cmd ,@(if (eq? mode 'host) '("-host") '())
"-s" "-c" "-C" ,(conc "-I" srcdir)
,@opts ,src "-o" ,out)
platform)
@@ -822,11 +850,11 @@
(let* ((cmd (or (custom-cmd custom srcdir platform)
default-csc))
(sname (prefix srcdir name))
- (opts (if (null? options)
+ (opts (if (null? options)
default-dynamic-compilation-options
options))
(out (target-file (conc sname
- (executable-extension platform))
+ (executable-extension platform))
mode))
(lobjs (map (lambda (lo)
(target-file (conc lo
@@ -841,7 +869,8 @@
,@(filelist srcdir source-dependencies)
,@(filelist srcdir lobjs)
,@(get-dependency-targets dependencies))
- `(,cmd ,@(if keep-generated-files '("-k") '())
+ `(,@(if custom '("sh") '())
+ ,cmd ,@(if keep-generated-files '("-k") '())
"-setup-mode"
,@(if (eq? mode 'host) '("-host") '())
"-I" ,srcdir
@@ -860,11 +889,11 @@
(let* ((cmd (or (custom-cmd custom srcdir platform)
default-csc))
(sname (prefix srcdir name))
- (opts (if (null? options)
+ (opts (if (null? options)
default-static-compilation-options
options))
(out (target-file (conc sname
- (executable-extension platform))
+ (executable-extension platform))
mode))
(lobjs (map (lambda (lo)
(target-file (conc lo
@@ -879,7 +908,8 @@
,@(filelist srcdir lobjs)
,@(filelist srcdir source-dependencies)
,@(get-dependency-targets dependencies))
- `(,cmd ,@(if keep-generated-files '("-k") '())
+ `(,@(if custom '("sh") '())
+ ,cmd ,@(if keep-generated-files '("-k") '())
,@(if (eq? mode 'host) '("-host") '())
"-static" "-setup-mode" "-I" ,srcdir
"-C" ,(conc "-I" srcdir)
@@ -890,17 +920,17 @@
(print-end-command platform)))
(define ((compile-generated-file name #!key source custom dependencies
- source-dependencies eggfile)
+ source-dependencies eggfile)
srcdir platform)
(let ((cmd (custom-cmd custom srcdir platform))
(out (or source name)))
(add-dependency-target name out)
(prepare-custom-command cmd platform)
(print-build-command (list out)
- `(,cmd ,eggfile
- ,@(filelist srcdir source-dependencies)
- ,@(get-dependency-targets dependencies))
- (list cmd)
+ (append
+ (filelist srcdir source-dependencies)
+ (get-dependency-targets dependencies))
+ `("sh" ,cmd ,eggfile)
platform)
(print-end-command platform)))
@@ -980,7 +1010,7 @@
(qs* (conc dest "/" types-file ".types") platform #t))
(print-end-command platform)))
-(define ((install-inline-file name #!key mode inline-file)
+(define ((install-inline-file name #!key mode inline-file)
srcdir platform)
(let* ((cmd (install-file-command platform))
(mkdir (mkdir-command platform))
@@ -1010,6 +1040,21 @@
(print cmd " " out " " ddir destf)
(print-end-command platform)))
+(define ((install-object name #!key mode output-file) srcdir platform)
+ (let* ((cmd (install-file-command platform))
+ (mkdir (mkdir-command platform))
+ (ext (object-extension platform))
+ (sname (prefix srcdir name))
+ (out (qs* (target-file (conc sname ext) mode)
+ platform #t))
+ (dest (effective-destination-repository mode))
+ (dfile (qs* dest platform #t))
+ (ddir (shell-variable "DESTDIR" platform)))
+ (print "\n" mkdir " " ddir dfile)
+ (print cmd " " out " " ddir
+ (qs* (conc dest "/" output-file ext) platform #t))
+ (print-end-command platform)))
+
(define (install-random-files dest files mode srcdir platform)
(let* ((fcmd (install-file-command platform))
(dcmd (copy-directory-command platform))
@@ -1059,7 +1104,7 @@
host-sharedir)))
files mode srcdir platform))
-(define ((install-c-include name #!key deps files destination mode)
+(define ((install-c-include name #!key deps files destination mode)
srcdir platform)
(install-random-files (or destination
(if (eq? mode 'target)
@@ -1116,29 +1161,12 @@ export CHICKEN_CSI=~a
EOF
(qs* default-bindir platform) (qs* default-cc platform)
(qs* default-cxx platform) (qs* default-csc platform)
- (qs* default-csi platform)))
- ((windows)
- (printf #<<EOF
-@echo off~%
-set "PATH=~a;%PATH%"
-set "CHICKEN_CC=~a"
-set "CHICKEN_CXX=~a"
-set "CHICKEN_CSC=~a"
-set "CHICKEN_CSI=~a"
-
-EOF
- default-bindir default-cc
- default-cxx default-csc
- default-csi))))
+ (qs* default-csi platform)))))
(define ((build-suffix mode name info) platform)
(case platform
((unix)
(printf #<<EOF
-EOF
- ))
- ((windows)
- (printf #<<EOF
EOF
))))
@@ -1149,11 +1177,6 @@ EOF
#!/bin/sh~%
set -e
-EOF
- ))
- ((windows)
- (printf #<<EOF
-@echo off~%
EOF
))))
@@ -1177,29 +1200,11 @@ cat >~a~a <<'ENDINFO'
EOF
mkdir ddir qdir
dcmd ddir dest
- ddir dest infostr))
- ((windows)
- (printf #<<EOF
-
-~a ~a~a
-copy /y nul ~a~a~%
-~a
-EOF
- mkdir ddir qdir
- ddir dest
- (string-intersperse (map (lambda (line)
- (ensure-line-limit
- (format "echo ~a >>~a~a"
- (caretize line)
- (caretize ddir)
- (caretize dest))
- 8191))
- (string-split infostr "\n"))
- "\n"))))))
+ ddir dest infostr)))))
;;; some utilities for mangling + quoting
-;; The qs procedure quotes for mingw32 or other platforms. We
+;; The qs procedure quotes for mingw or other platforms. We
;; "normalised" the platform to "windows" in chicken-install, so we
;; have to undo that here again. It can also convert slashes to
;; backslashes on Windows, which is necessary in many cases when
@@ -1207,22 +1212,9 @@ EOF
;;
;; It also supports already-quoted arguments which can be taken as-is.
(define (qs* arg platform #!optional slashify?)
- (if (raw-arg? arg)
- (raw-arg-value arg)
- (let* ((arg (->string arg))
- (path (if slashify? (slashify arg platform) arg)))
- (qs path (if (eq? platform 'windows) 'mingw32 platform)))))
-
-(define-record-type raw-arg
- (raw-arg value)
- raw-arg?
- (value raw-arg-value))
-
-(define (slashify str platform)
- (if (eq? platform 'windows)
- (list->string
- (map (lambda (c) (if (char=? #\/ c) #\\ c)) (string->list str)))
- str))
+ (let* ((arg (->string arg))
+ (path arg))
+ (qs path (if (eq? platform 'windows) 'mingw platform))))
(define (prefix dir name)
(make-pathname dir (->string name)))
@@ -1232,7 +1224,7 @@ EOF
;; in an extra set of quotes to avoid the outer quotes being stripped.
;; Don't ask.
(define (system+ str platform)
- (system (if (and (eq? platform 'windows)
+ (system (if (and (eq? platform 'windows)
(positive? (string-length str))
(char=? #\" (string-ref str 0)))
(string-append "\"" str "\"")
@@ -1241,36 +1233,27 @@ EOF
(define (target-file fname mode)
(if (eq? mode 'target) (string-append fname ".target") fname))
-(define (joins strs platform)
+(define (joins strs platform)
(string-intersperse (map (cut qs* <> platform) strs) " "))
(define (filelist dir lst)
(map (cut prefix dir <>) lst))
(define (shell-variable var platform)
- (case platform
- ((unix) (string-append "\"${" var "}\""))
- ((windows) (string-append "%" var "%"))))
+ (string-append "\"${" var "}\""))
-(define (prepare-custom-command cmd platform)
- (unless (eq? 'windows platform)
- (print "chmod +x " (qs* cmd platform))))
+(define prepare-custom-command void)
(define (custom-cmd custom srcdir platform)
- (and custom (prefix srcdir
- (case platform
- ((windows) (conc custom ".bat"))
- (else custom)))))
+ (and custom (prefix srcdir custom)))
(define (print-build-command targets sources command-and-args platform)
(print "\n" (qs* default-builder platform) " "
(joins targets platform)
- " : " (joins sources platform) " "
+ " : " (joins sources platform) " "
" : " (joins command-and-args platform)))
-(define (print-end-command platform)
- (case platform
- ((windows) (print "if errorlevel 1 exit /b 1"))))
+(define print-end-command void)
(define (strip-dir-prefix prefix fname)
(let* ((plen (string-length prefix))
@@ -1282,7 +1265,7 @@ EOF
(define (caretize str)
(string-translate* str '(("&" . "^&") ("^" . "^^") ("|" . "^|")
- ("<" . "^<") (">" . "^>"))))
+ ("<" . "^<") (">" . "^>"))))
(define (ensure-line-limit str lim)
(when (>= (string-length str) lim)
diff --git a/egg-download.scm b/egg-download.scm
index 388fa35f..512fa384 100644
--- a/egg-download.scm
+++ b/egg-download.scm
@@ -79,7 +79,7 @@
""))
(let-values (((in out)
- (tcp-connect (or proxy-host host) (or proxy-port port))))
+ (tcp-connect (or proxy-host host) (or proxy-port port) 'binary)))
(d "requesting ~s ...~%" locn)
(display req out)
(flush-output out)
@@ -137,13 +137,14 @@
(d "reading chunks ")
(let ((data (read-chunks in)))
(close-input-port in)
- (set! in (open-input-string data))) )
+ (set! in (open-input-bytevector data))) )
(values in out datalen))
(else (network-failure "invalid response from server" h1)))))))
(define (http-retrieve-files in out dest)
(d "reading files ...~%")
- (let ((version #f))
+ (let ((version #f)
+ (ws (list->string '(#\tab #\newline #\x0b #\space #\x0c #\x0d #\xa0))))
(define (skip)
(let ((ln (read-line in)))
(cond ((or (eof-object? ln)
@@ -154,18 +155,18 @@
(let ((v (irregex-match-substring m 1)))
(cond ((or (string=? "" v) (string=? "#f" v)))
((and version (not (string=? v version)))
- (warning "files versions are not identical"
- ln version)
+ (warning "file versions are not identical"
+ ln version)
(set! version #f))
(else
(set! version v)))
(open-input-string ln))))
((irregex-match "^[ ]*\\(error .*\\)[ ]*$" ln)
(open-input-string ln)) ; get-files deals with errors
- ((irregex-match '(* ("\x09\x0a\x0b\x0c\x0d\x20\xa0")) ln)
+ ((irregex-match `(* (,ws)) ln)
(skip)) ; Blank line.
(else
- (error "unrecognized file-information - possibly corrupt transmission"
+ (error "unrecognized file-information - possibly corrupt transmission"
ln)))))
(let get-files ((files '()))
(let* ((ins (skip))
@@ -177,18 +178,19 @@
(close-output-port out)
version)
((not (string? name))
- (error "invalid file name - possibly corrupt transmission"
- name) )
+ (error "invalid file name - possibly corrupt transmission"
+ name) )
((string-suffix? "/" name)
(d " ~a~%" name)
(create-directory (make-pathname dest name))
(get-files files) )
(else
- (d " ~a~%" name)
(let* ((size (read ins))
- (data (read-string size in)) )
+ (_ (d " ~a (~a bytes)~%" name size))
+ (data (read-bytevector size in)) )
(with-output-to-file (make-pathname dest name)
- (cut display data) #:binary ) )
+ (lambda () (write-bytevector data))
+ #:binary ) )
(get-files (cons name files)) ) ) ) ) ))
(define (http-retrieve-response in len)
@@ -215,9 +217,9 @@
(error "invalid response from server - please try again"))
((zero? size)
(d "~%")
- (string-intersperse (reverse data) ""))
+ (apply bytevector-append (reverse data)))
(else
- (let ((chunk (read-string size in)))
+ (let ((chunk (read-bytevector size in)))
(d ".")
(read-line in)
(get-chunks (cons chunk data)) ) ) ) ) ))
@@ -227,7 +229,7 @@
(irregex-match "HTTP/[0-9.]+\\s+([0-9]+)\\s+.*" rsp)) )
(define (response-match-code? mrsp code)
- (and mrsp (string=? (number->string code)
+ (and mrsp (string=? (number->string code)
(irregex-match-substring mrsp 1))) )
(define (match-chunked-transfer-encoding ln)
@@ -249,8 +251,8 @@
(content-length 0)
proxy-host proxy-port proxy-user-pass)
(conc
- "GET "
- (if proxy-host
+ "GET "
+ (if proxy-host
(string-append "http://" host location)
location)
" HTTP/1.1" "\r\n"
@@ -269,7 +271,7 @@
(make-composite-condition
(make-property-condition
'exn
- 'message "invalid response from server"
+ 'message msg
'arguments args)
(make-property-condition 'http-fetch))) )
@@ -299,7 +301,7 @@
#f)
(e (exn setup-download-error)
(print "Server error:")
- (print-error-message e)
+ (print-error-message e)
#f)
(e () (abort e) )))
@@ -318,7 +320,7 @@
;; If we get here then version of egg exists
(values eggdir (or fversion version "")) )) ) )
-(define (try-download name url #!key version destination tests
+(define (try-download name url #!key version destination tests
proxy-host proxy-port proxy-user-pass)
(d "downloading ~a: ~a~%" name url)
(condition-case
@@ -338,6 +340,6 @@
(values #f "") )
(e (exn setup-download-error)
(print "Server error:")
- (print-error-message e)
+ (print-error-message e)
(values #f ""))
(e () (abort e) )))
diff --git a/eval-modules.scm b/eval-modules.scm
index cf97ccf2..5c4ed095 100644
--- a/eval-modules.scm
+++ b/eval-modules.scm
@@ -55,7 +55,7 @@
".import.scm"))))))))
(defmod chicken.bitwise)
-(defmod chicken.blob)
+(defmod chicken.bytevector)
(defmod chicken.foreign)
(defmod chicken.fixnum)
(defmod chicken.keyword)
@@ -92,7 +92,12 @@
(defmod chicken.read-syntax)
(defmod chicken.repl)
(defmod chicken.tcp)
+(defmod chicken.number-vector)
(defmod srfi-4)
+(defmod scheme.write)
+(defmod scheme.time)
+(defmod scheme.file)
+(defmod scheme.process-context)
(set! ##sys#import-library-hook
(let ((hook ##sys#import-library-hook))
diff --git a/eval.scm b/eval.scm
index b8e59ae5..faf8face 100644
--- a/eval.scm
+++ b/eval.scm
@@ -8,11 +8,11 @@
; conditions are met:
;
; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-; disclaimer.
+; 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.
+; 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.
+; 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
@@ -49,27 +49,30 @@
(import scheme
chicken.base
- chicken.blob
+ chicken.bytevector
chicken.fixnum
chicken.internal
chicken.keyword
chicken.syntax
- chicken.type)
+ chicken.type
+ chicken.foreign)
+(import (only (scheme base) make-parameter open-output-string get-output-string port?))
(include "common-declarations.scm")
(define-syntax d (syntax-rules () ((_ . _) (void))))
+
;;; Compile lambda to closure:
(define (eval-decorator p ll h cntr)
(##sys#decorate-lambda
- p
+ p
(lambda (x) (and (not (##sys#immediate? x)) (##core#inline "C_lambdainfop" x)))
(lambda (p i)
- (##sys#setslot
- p i
- (##sys#make-lambda-info
+ (##sys#setslot
+ p i
+ (##sys#make-lambda-info
(let ((o (open-output-string)))
(write ll o)
(get-output-string o))))
@@ -111,22 +114,20 @@
(define (emit-trace-info tf ln info cntr e v)
(when tf
- (##core#inline
- "C_emit_trace_info"
+ (##core#inline "C_emit_trace_info"
ln
info
(##sys#make-structure 'frameinfo cntr e v)
(thread-id ##sys#current-thread) ) ) )
-
- (define (emit-syntax-trace-info tf info cntr)
+
+ (define (emit-syntax-trace-info tf info cntr)
(when tf
- (##core#inline
- "C_emit_trace_info"
+ (##core#inline "C_emit_trace_info"
(or (get-line-number info) "<syntax>")
info
cntr
(thread-id ##sys#current-thread) ) ) )
-
+
(define (decorate p ll h cntr)
(eval-decorator p ll h cntr))
@@ -137,6 +138,16 @@
(##sys#update-line-number-database! output ln))
output))
+ (define (include-file x ci e tf cntr tl?)
+ (##sys#include-forms-from-file
+ (cadr x) (caddr x) ci
+ (lambda (forms)
+ (compile (if (pair? (cdddr x)) ; body?
+ (##sys#canonicalize-body (append forms (cadddr x))
+ (##sys#current-environment))
+ `(##core#begin ,@forms))
+ e #f tf cntr tl?))))
+
(define (compile x e h tf cntr tl?)
(cond ((keyword? x) (lambda v x))
((symbol? x)
@@ -162,16 +173,16 @@
(lambda v (##core#inline "C_fast_retrieve" var))))))
(else
(case i
- ((0) (lambda (v)
+ ((0) (lambda (v)
(##sys#slot (##sys#slot v 0) j)))
- ((1) (lambda (v)
+ ((1) (lambda (v)
(##sys#slot (##sys#slot (##sys#slot v 1) 0) j)))
- ((2) (lambda (v)
- (##sys#slot
+ ((2) (lambda (v)
+ (##sys#slot
(##sys#slot (##sys#slot (##sys#slot v 1) 1) 0)
j)))
- ((3) (lambda (v)
- (##sys#slot
+ ((3) (lambda (v)
+ (##sys#slot
(##sys#slot
(##sys#slot (##sys#slot (##sys#slot v 1) 1) 1)
0)
@@ -179,7 +190,7 @@
(else
(lambda (v)
(##sys#slot (##core#inline "C_u_i_list_ref" v i) j))))))))
- [(##sys#number? x)
+ [(number? x)
(case x
[(-1) (lambda v -1)]
[(0) (lambda v 0)]
@@ -192,14 +203,13 @@
(lambda v #f) ) ]
((or (char? x)
(eof-object? x)
- (##core#inline "C_bwpp" x) ; TODO: Remove once we have a bootstrapping libchicken with bwp-object?
- ;;(bwp-object? x)
+ (bwp-object? x)
(string? x)
- (blob? x)
+ (bytevector? x)
(vector? x)
(##sys#srfi-4-vector? x))
(lambda v x) )
- [(not (pair? x))
+ [(not (pair? x))
(##sys#syntax-error/context "illegal non-atomic object" x)]
[(symbol? (##sys#slot x 0))
(emit-syntax-trace-info tf x cntr)
@@ -211,7 +221,7 @@
(if (not (eq? x2 x))
(compile x2 e h tf cntr tl?)
(let ((head (rename (##sys#slot x 0))))
- ;; here we did't resolve ##core#primitive, but that is done in compile-call (via
+ ;; here we did't resolve ##core#primitive, but that is done in compile-call (via
;; a normal walking of the operator)
(case head
@@ -236,7 +246,7 @@
[(##core#immutable)
(compile (cadr x) e #f tf cntr #f) ]
-
+
[(##core#undefined) (lambda (v) (##core#undefined))]
[(##core#if)
@@ -294,7 +304,7 @@
[(##core#let)
(let* ((bindings (cadr x))
- (n (length bindings))
+ (n (length bindings))
(vars (map (lambda (x) (car x)) bindings))
(aliases (map gensym vars))
(e2 (cons aliases e))
@@ -316,7 +326,7 @@
(t (cddr bindings))
(val3 (compile (cadar t) e (caddr vars) tf cntr #f)) )
(lambda (v)
- (##core#app
+ (##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 #f))
@@ -325,7 +335,7 @@
(val3 (compile (cadar t) e (caddr vars) tf cntr #f))
(val4 (compile (cadadr t) e (cadddr vars) tf cntr #f)) )
(lambda (v)
- (##core#app
+ (##core#app
body
(cons (vector (##core#app val1 v)
(##core#app val2 v)
@@ -348,10 +358,10 @@
(compile
`(##core#let
,(##sys#map (lambda (b)
- (list (car b) '(##core#undefined)))
+ (list (car b) '(##core#undefined)))
bindings)
,@(##sys#map (lambda (b)
- `(##core#set! ,(car b) ,(cadr b)))
+ `(##core#set! ,(car b) ,(cadr b)))
bindings)
(##core#let () ,@body) )
e h tf cntr #f)))
@@ -364,7 +374,7 @@
(compile
`(##core#let
,(map (lambda (b)
- (list (car b) '(##core#undefined)))
+ (list (car b) '(##core#undefined)))
bindings)
(##core#let ,(map (lambda (t b) (list t (cadr b))) tmps bindings)
,@(map (lambda (v t)
@@ -376,13 +386,13 @@
[(##core#lambda)
(##sys#check-syntax 'lambda x '(_ lambda-list . #(_ 1)) #f (##sys#current-environment))
(let* ([llist (cadr x)]
- [body (cddr 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 (##sys#current-environment)) ) )
+ (set!-values
+ (llist body)
+ (##sys#expand-extended-lambda-list
+ llist body ##sys#syntax-error (##sys#current-environment)) ) )
(##sys#decompose-lambda-list
llist
(lambda (vars argc rest)
@@ -410,14 +420,14 @@
(decorate
(lambda (a1 . r)
(##core#app body (cons (vector a1 r) v)))
- info h cntr) )
+ info h cntr) )
(lambda (v)
- (decorate
+ (decorate
(lambda (a1)
(##core#app body (cons (vector a1) v)))
info h cntr) ) ) ]
[(2) (if rest
- (lambda (v)
+ (lambda (v)
(decorate
(lambda (a1 a2 . r)
(##core#app body (cons (vector a1 a2 r) v)))
@@ -428,7 +438,7 @@
(##core#app body (cons (vector a1 a2) v)))
info h cntr) ) ) ]
[(3) (if rest
- (lambda (v)
+ (lambda (v)
(decorate
(lambda (a1 a2 a3 . r)
(##core#app body (cons (vector a1 a2 a3 r) v)))
@@ -449,7 +459,7 @@
(lambda (a1 a2 a3 a4)
(##core#app body (##sys#cons (##sys#vector a1 a2 a3 a4) v)))
info h cntr) ) ) ]
- [else
+ [else
(if rest
(lambda (v)
(decorate
@@ -460,7 +470,7 @@
info h cntr) )
(lambda (v)
(decorate
- (lambda as
+ (lambda as
(let ([len (length as)])
(if (not (fx= len argc))
(##sys#error "bad argument count" argc len)
@@ -483,7 +493,7 @@
(compile
(##sys#canonicalize-body (cddr x) (##sys#current-environment) #f)
e #f tf cntr #f)))
-
+
((##core#letrec-syntax)
(let* ((ms (map (lambda (b)
(list
@@ -494,7 +504,7 @@
(strip-syntax (car b)))))
(cadr x) ) )
(se2 (append ms (##sys#current-environment))) )
- (for-each
+ (for-each
(lambda (sb)
(set-car! (cdr sb) se2) )
ms)
@@ -502,7 +512,7 @@
(compile
(##sys#canonicalize-body (cddr x) (##sys#current-environment) #f)
e #f tf cntr #f))))
-
+
((##core#define-syntax)
(let* ((var (cadr x))
(body (caddr x))
@@ -510,7 +520,7 @@
(when (and static (not (assq var (##sys#current-environment))))
(##sys#error 'eval "environment is not mutable" evalenv var))
(##sys#put/restore! name '##sys#override 'syntax)
- (##sys#register-syntax-export
+ (##sys#register-syntax-export
name (##sys#current-module)
body) ; not really necessary, it only shouldn't be #f
(##sys#extend-macro-environment
@@ -528,19 +538,12 @@
e #f tf cntr #f))
((##core#include)
- (##sys#include-forms-from-file
- (cadr x)
- (caddr x)
- (lambda (forms path)
- (let ((code (if (pair? (cdddr x)) ; body?
- (##sys#canonicalize-body
- (append forms (cadddr x))
- (##sys#current-environment))
- `(##core#begin ,@forms))))
- (fluid-let ((##sys#current-source-filename path))
- (compile code e #f tf cntr tl?))))))
-
- ((##core#let-module-alias)
+ (include-file x #f e tf cntr tl?))
+
+ ((##core#include-ci)
+ (include-file x #t e tf cntr tl?))
+
+ ((##core#let-module-alias)
(##sys#with-module-aliases
(map (lambda (b)
(##sys#check-syntax 'functor b '(symbol symbol))
@@ -552,27 +555,27 @@
((##core#module)
(let* ((x (strip-syntax x))
(name (cadr x))
- (exports
+ (exports
(or (eq? #t (caddr x))
(map (lambda (exp)
(cond ((symbol? exp) exp)
- ((and (pair? exp)
+ ((and (pair? exp)
(let loop ((exp exp))
(or (null? exp)
(and (symbol? (car exp))
(loop (cdr exp))))))
exp)
(else
- (##sys#syntax-error-hook
+ (##sys#syntax-error
'module
"invalid export syntax" exp name))))
(caddr x)))))
(when (##sys#current-module)
- (##sys#syntax-error-hook 'module "modules may not be nested" name))
+ (##sys#syntax-error 'module "modules may not be nested" name))
(parameterize ((##sys#current-module
(##sys#register-module name #f exports))
(##sys#current-environment '())
- (##sys#macro-environment
+ (##sys#macro-environment
##sys#initial-macro-environment)
(##sys#module-alias-environment
(##sys#module-alias-environment)))
@@ -593,11 +596,11 @@
(loop2 n))
(else
((car xs) v))))))))
- (loop
+ (loop
(cdr body)
- (cons (compile
- (car body)
- '() #f tf cntr
+ (cons (compile
+ (car body)
+ '() #f tf cntr
#t) ; reset back to toplevel!
xs))))) ) )))
@@ -632,27 +635,27 @@
[(##core#define-inline ##core#define-constant)
(compile `(,(rename 'define) ,@(cdr x)) e #f tf cntr tl?) ]
-
- [(##core#primitive ##core#inline ##core#inline_allocate ##core#foreign-lambda
- ##core#define-foreign-variable
+
+ [(##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#location
##core#foreign-lambda* ##core#define-foreign-type)
- (##sys#syntax-error-hook "cannot evaluate compiler-special-form" x) ]
+ (##sys#syntax-error "cannot evaluate compiler-special-form" x) ]
[(##core#app)
(compile-call (cdr x) e tf cntr (##sys#current-environment)) ]
((##core#the)
(compile (cadddr x) e h tf cntr tl?))
-
+
((##core#typecase)
;; drops exp and requires "else" clause
(cond ((assq 'else (strip-syntax (cdddr x))) =>
(lambda (cl)
(compile (cadr cl) e h tf cntr tl?)))
(else
- (##sys#syntax-error-hook
+ (##sys#syntax-error
'compiler-typecase
"no `else-clause' in unresolved `compiler-typecase' form"
x))))
@@ -660,17 +663,17 @@
(else
(fluid-let ((##sys#syntax-context (cons head ##sys#syntax-context)))
(compile-call x e tf cntr (##sys#current-environment))))))))]
-
+
[else
(emit-syntax-trace-info tf x cntr)
(compile-call x e tf cntr (##sys#current-environment))] ) )
(define (fudge-argument-list n alst)
- (if (null? alst)
+ (if (null? alst)
(list alst)
(do ((n n (fx- n 1))
(c 0 (fx+ c 1))
- (args alst
+ (args alst
(if (eq? '() args)
(##sys#error "bad argument count" n c)
(##sys#slot args 1)))
@@ -687,7 +690,7 @@
(define (compile-call x e tf cntr se)
(let* ((head (##sys#slot x 0))
- (fn (if (procedure? head)
+ (fn (if (procedure? head)
(lambda _ head)
(compile (##sys#slot x 0) e #f tf cntr #f)))
(args (##sys#slot x 1))
@@ -739,16 +742,15 @@
(lambda ()
((compile-to-closure
form
- '()
- #f #f #f ;XXX evalenv? static?
+ '()
+ #f #f #f
#t) ; toplevel.
'()) )
(lambda ()
;; Just before restoring the parameters, update "meta"
;; environments to receive a copy of the current
;; environments one level "down". We don't support more
- ;; than two evaluation phase levels currently. XXX: Should
- ;; we change this to a "stack" of environments?
+ ;; than two evaluation phase levels currently.
(##sys#current-meta-environment (##sys#current-environment))
(##sys#meta-macro-environment (##sys#macro-environment))))))
@@ -767,13 +769,14 @@
'() #f #f #f #t) '()))
(cond (env
(##sys#check-structure env 'environment 'eval)
- (let ((se2 (##sys#slot env 2)))
- ((if se2 ; not interaction-environment?
- (parameterize ((##sys#macro-environment '())
- (##sys#current-environment se2))
- (compile-to-closure x '() #f env (##sys#slot env 3) #t))
- (compile-to-closure x '() #f env #f #t))
- '() ) ) )
+ (let ((ve2 (##sys#slot env 2))
+ (se2 (##sys#slot env 3)))
+ ((if ve2 ; not interaction-environment?
+ (parameterize ((##sys#macro-environment se2)
+ (##sys#current-environment ve2))
+ (compile-to-closure x '() #f env (##sys#slot env 4) #t))
+ (compile-to-closure x '() #f env #f #t))
+ '())))
(else
((compile-to-closure x '() #f #f #f #t) '())))))))
@@ -821,7 +824,7 @@
(define (err)
(set! ##sys#syntax-error-culprit #f)
- (##sys#syntax-error-hook "illegal lambda-list syntax" llist0) )
+ (##sys#syntax-error "illegal lambda-list syntax" llist0) )
(let loop ([llist llist0] [vars '()] [argc 0])
(cond [(eq? llist '()) (k (reverse vars) argc #f)]
@@ -833,7 +836,7 @@
(fx+ argc 1) ) ] ) ) ) ) )
(set! scheme#interaction-environment
- (let ((e (##sys#make-structure 'environment 'interaction-environment #f #f)))
+ (let ((e (##sys#make-structure 'environment 'interaction-environment #f #f #f)))
(lambda () e)))
(set-record-printer! 'environment
@@ -842,10 +845,10 @@
(##sys#print (##sys#slot e 1) #f p)
(##sys#write-char-0 #\> p)))
-(let* ((r4s (chicken.module#module-environment 'r4rs 'scheme-report-environment/4))
- (r5s (chicken.module#module-environment 'scheme 'scheme-report-environment/5))
- (r4n (chicken.module#module-environment 'r4rs-null 'null-environment/4))
- (r5n (chicken.module#module-environment 'r5rs-null 'null-environment/5)))
+(let* ((r4s (chicken.module#module-environment 'scheme.r4rs 'scheme-report-environment/4))
+ (r5s (chicken.module#module-environment 'scheme.r5rs 'scheme-report-environment/5))
+ (r4n (chicken.module#module-environment 'scheme.r4rs-null 'null-environment/4))
+ (r5n (chicken.module#module-environment 'scheme.r5rs-null 'null-environment/5)))
(define (strip se)
(foldr
(lambda (s r)
@@ -856,6 +859,7 @@
export
export/rename
functor
+ define-library
import
import-for-syntax
import-syntax
@@ -870,10 +874,10 @@
'()
se))
;; Strip non-std syntax from SEs
- (##sys#setslot r4s 2 (strip (##sys#slot r4s 2)))
- (##sys#setslot r4n 2 (strip (##sys#slot r4n 2)))
- (##sys#setslot r5s 2 (strip (##sys#slot r5s 2)))
- (##sys#setslot r5n 2 (strip (##sys#slot r5n 2)))
+ (##sys#setslot r4s 3 (strip (##sys#slot r4s 3)))
+ (##sys#setslot r4n 3 (strip (##sys#slot r4n 3)))
+ (##sys#setslot r5s 3 (strip (##sys#slot r5s 3)))
+ (##sys#setslot r5n 3 (strip (##sys#slot r5n 3)))
(set! scheme#scheme-report-environment
(lambda (n)
(##sys#check-fixnum n 'scheme-report-environment)
@@ -912,6 +916,7 @@
chicken.platform
chicken.syntax
chicken.time)
+(import (only (scheme base) make-parameter port?))
(include "mini-srfi-1.scm")
@@ -939,7 +944,7 @@
'(chicken-syntax chicken-ffi-syntax continuation data-structures
debugger-client eval eval-modules expand extras file internal
irregex library lolevel pathname port posix profiler read-syntax
- repl scheduler srfi-4 tcp))
+ repl scheduler srfi-4 tcp r7lib))
(define-constant cygwin-default-dynamic-load-libraries '("cygchicken-0"))
(define-constant macosx-load-library-extension ".dylib")
@@ -982,15 +987,15 @@
(if ##sys#windows-platform '(#\\ #\/) '(#\/)))
(define (path-separator-index/right s)
- (let loop ((i (fx- (##sys#size s) 1)))
- (if (memq (##core#inline "C_subchar" s i) path-separators)
+ (let loop ((i (fx- (string-length s) 1)))
+ (if (memq (string-ref s i) path-separators)
i
(and (fx< 0 i) (loop (fx- i 1))))))
(define (make-relative-pathname from file)
(let ((i (and (string? from)
- (positive? (##sys#size file)) ; XXX probably an error?
- (not (memq (##core#inline "C_subchar" file 0) path-separators))
+ (positive? (string-length file)) ; XXX probably an error?
+ (not (memq (string-ref file 0) path-separators))
(path-separator-index/right from))))
(if (not i) file (string-append (##sys#substring from 0 i) "/" file))))
@@ -1023,7 +1028,7 @@
(if (not name)
"toplevel"
(##sys#string-append
- (string->c-identifier (##sys#slot name 1))
+ (string->c-identifier (##sys#symbol->string/shared name))
"_toplevel")))
(define (c-toplevel name loc)
@@ -1034,6 +1039,7 @@
(display display)
(newline newline)
(eval eval)
+ (case-sensitive case-sensitive)
(open-input-file open-input-file)
(close-input-port close-input-port))
(lambda (input evaluator #!optional pf timer printer unit)
@@ -1083,9 +1089,10 @@
(##sys#current-load-filename fname)
(##sys#current-source-filename fname))
(let ((in (if fname (open-input-file fname) input))
+ (cs (case-sensitive))
(read-with-source-info chicken.syntax#read-with-source-info)) ; OBSOLETE - after bootstrapping we can get rid of this explicit namespacing
(##sys#dynamic-wind
- (lambda () #f)
+ (lambda () (set! cs (case-sensitive)))
(lambda ()
(let ((c1 (peek-char in)))
(when (eq? c1 (integer->char 127))
@@ -1112,26 +1119,34 @@
(newline))
results)))))))
(lambda ()
+ (case-sensitive cs)
(close-input-port in))))))))
(##core#undefined))))
+(define evaluator
+ (let ((eval eval))
+ (lambda (x)
+ (cond ((procedure? x) x)
+ ((not x) #f)
+ (else (lambda (y) (eval y x)))))))
+
(set! scheme#load
- (lambda (filename #!optional evaluator)
- (load/internal filename evaluator)))
+ (lambda (filename #!optional env)
+ (load/internal filename (evaluator env))))
-(define (load-relative filename #!optional evaluator)
+(define (load-relative filename #!optional env)
(let ((fn (make-relative-pathname ##sys#current-load-filename filename)))
- (load/internal fn evaluator)))
+ (load/internal fn (evaluator env))))
-(define (load-noisily filename #!key (evaluator #f) (time #f) (printer #f))
- (load/internal filename evaluator #t time printer))
+(define (load-noisily filename #!key env (time #f) (printer #f))
+ (load/internal filename (evaluator env) #t time printer))
-(define dynamic-load-libraries
+(define dynamic-load-libraries
(let ((ext
(if uses-soname?
(string-append
load-library-extension
- "."
+ "."
(number->string binary-version))
load-library-extension)))
(define complete
@@ -1147,7 +1162,7 @@
(let ((libs
(if lib
(##sys#list lib)
- (cons (##sys#string-append (##sys#slot unit-name 1) load-library-extension)
+ (cons (##sys#string-append (##sys#symbol->string/shared unit-name) load-library-extension)
(dynamic-load-libraries))))
(top
(c-toplevel unit-name loc)))
@@ -1170,22 +1185,22 @@
(define ##sys#include-forms-from-file
(let ((call-with-input-file call-with-input-file)
- (reverse reverse))
- (lambda (filename source k)
+ (reverse reverse))
+ (lambda (filename source ci k)
(let ((path (##sys#resolve-include-filename filename #t #f source))
- (read-with-source-info chicken.syntax#read-with-source-info)) ; OBSOLETE - after bootstrapping we can get rid of this explicit namespacing
- (when (not path)
- (##sys#signal-hook #:file-error 'include "cannot open file" filename))
- (when (load-verbose)
- (print "; including " path " ..."))
- (call-with-input-file path
- (lambda (in)
- (k (fluid-let ((##sys#current-source-filename path))
- (do ((x (read-with-source-info in) (read-with-source-info in))
- (xs '() (cons x xs)))
- ((eof-object? x)
- (reverse xs))))
- path)))))))
+ (read-with-source-info chicken.syntax#read-with-source-info)) ; OBSOLETE - after bootstrapping we can get rid of this explicit namespacing
+ (when (not path)
+ (##sys#signal-hook #:file-error 'include "cannot open file" filename))
+ (when (load-verbose)
+ (print "; including " path " ..."))
+ (call-with-input-file path
+ (lambda (in)
+ (##sys#setislot in 13 (not ci))
+ (fluid-let ((##sys#current-source-filename path))
+ (do ((x (read-with-source-info in) (read-with-source-info in))
+ (xs '() (cons x xs)))
+ ((eof-object? x)
+ (k (reverse xs)))))))))))
;;; Extensions:
@@ -1238,7 +1253,7 @@
(load-unit lib #f loc))
((find-dynamic-extension lib #f) =>
(lambda (ext)
- (load/internal ext #f #f #f #f lib)
+ (load/internal ext #f #f #f #f #f lib)
(##sys#provide lib)
(##core#undefined)))
(else
@@ -1305,7 +1320,7 @@
(list source-file-extension ##sys#load-dynamic-extension)))))
(or (test (make-relative-pathname source fname))
(let loop ((paths (if repo
- (##sys#append
+ (##sys#append
##sys#include-pathnames
(or (repository-path) '()) )
##sys#include-pathnames) ) )
@@ -1321,6 +1336,7 @@
;;; Simple invocation API:
(import scheme chicken.base chicken.condition chicken.eval chicken.fixnum chicken.load)
+(import (only (scheme base) open-output-string get-output-string open-input-string))
(declare
(hide last-error run-safe store-result store-string
@@ -1333,7 +1349,7 @@
(define (run-safe thunk)
(set! last-error #f)
- (handle-exceptions ex
+ (handle-exceptions ex
(let ((o (open-output-string)))
(print-error-message ex o)
(set! last-error (get-output-string o))
@@ -1369,11 +1385,12 @@
<#
(define (store-string str bufsize buf)
- (let ((len (##sys#size str)))
+ (let* ((bv (##sys#slot str 0))
+ (len (fx- (##sys#size bv) 1)))
(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)) ) ) )
+ (else (##core#inline "C_copy_result_string" bv buf len)) ) ) )
(define-external (CHICKEN_eval_to_string (scheme-object exp) ((c-pointer "char") buf)
(int bufsize))
@@ -1385,7 +1402,7 @@
(store-string (get-output-string o) bufsize buf)) ) ) )
(define-external (CHICKEN_eval_string_to_string (c-string str) ((c-pointer "char") buf)
- (int bufsize) )
+ (int bufsize) )
bool
(run-safe
(lambda ()
@@ -1393,18 +1410,18 @@
(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)
+(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)
+(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)
+ (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
diff --git a/expand.scm b/expand.scm
index f100ce89..2f3521e6 100644
--- a/expand.scm
+++ b/expand.scm
@@ -39,7 +39,6 @@
get-line-number
read-with-source-info
strip-syntax
- syntax-error
er-macro-transformer
ir-macro-transformer)
@@ -51,6 +50,7 @@
chicken.keyword
chicken.platform
chicken.string)
+(import (only (scheme base) make-parameter open-output-string get-output-string))
(include "common-declarations.scm")
(include "mini-srfi-1.scm")
@@ -215,7 +215,7 @@
'(exn . message)
(cons (string-append
"during expansion of ("
- (##sys#slot name 1)
+ (##sys#symbol->string/shared name)
" ...) - "
(car r) )
(cdr r) ) )
@@ -229,9 +229,9 @@
(handler exp se dse))
(handler exp se dse))) )
(when (and (not cs) (eq? exp exp2))
- (##sys#syntax-error-hook
+ (##sys#syntax-error
(string-append
- "syntax transformer for `" (symbol->string name)
+ "syntax transformer for `" (##sys#symbol->string/shared name)
"' returns original form, which would result in endless expansion")
exp))
(dx `(,name ~~> ,exp2))
@@ -246,14 +246,12 @@
,(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 does this comment mean? I forgot ...]
- (call-handler head (cadr mdef) exp (car mdef) #f)
- #t))
- (else (values exp #f)) ) )
+ (if (pair? mdef)
+ (values
+ ;; force ref. opaqueness by passing dynamic se [what does this comment mean? I forgot ...]
+ (call-handler head (cadr mdef) exp (car mdef) #f)
+ #t)
+ (values exp #f)) )
(let loop ((exp exp))
(if (pair? exp)
(let ((head (car exp))
@@ -331,7 +329,7 @@
(let ((reverse reverse))
(lambda (llist0 body errh se)
(define (err msg) (errh msg llist0))
- (define (->keyword s) (string->keyword (##sys#slot s 1)))
+ (define (->keyword s) (string->keyword (##sys#symbol->string/shared s)))
(let ((rvar #f)
(hasrest #f)
;; These might not exist in se, use default or chicken env:
@@ -353,7 +351,7 @@
body
`((,%let*
,(map (lambda (k)
- (let ([s (car k)])
+ (let ((s (car k)))
`(,s (##sys#get-keyword
(##core#quote ,(->keyword (strip-syntax s))) ,(or hasrest rvar)
,@(if (pair? (cdr k))
@@ -427,7 +425,7 @@
; (i.e.`"(define define ...)")
(define (defjam-error form)
- (##sys#syntax-error-hook
+ (##sys#syntax-error
"redefinition of currently used defining form" ; help me find something better
form))
@@ -674,16 +672,18 @@
(define ##sys#line-number-database #f)
+
;;; General syntax checking routine:
(define ##sys#syntax-error-culprit #f)
(define ##sys#syntax-context '())
-(define (syntax-error . args)
+(define (##sys#syntax-error-hook . args)
(apply ##sys#signal-hook #:syntax-error
(strip-syntax args)))
-(define ##sys#syntax-error-hook syntax-error)
+(define (##sys#syntax-error . args)
+ (apply ##sys#syntax-error-hook args))
(define ##sys#syntax-error/context
(lambda (msg arg)
@@ -808,18 +808,18 @@
(define (mapupdate xs)
(let loop ((xs xs))
(when (pair? xs)
- (walk (car xs))
- (loop (cdr xs)) ) ) )
+ (walk (car xs))
+ (loop (cdr xs)) ) ))
(define (walk x)
(cond ((not (pair? x)))
- ((symbol? (car x))
- (let* ((name (car x))
- (old (or (hash-table-ref ##sys#line-number-database name) '())))
- (unless (assq x old)
- (hash-table-set! ##sys#line-number-database name (alist-cons x ln old)))
- (mapupdate (cdr x)) ) )
- (else (mapupdate x)) ) )
- (walk exp) )
+ ((symbol? (car x))
+ (let* ((name (car x))
+ (old (or (hash-table-ref ##sys#line-number-database name) '())))
+ (unless (assq x old)
+ (hash-table-set! ##sys#line-number-database name (alist-cons x ln old)))
+ (when (list? x) (mapupdate (cdr x)) )))
+ (else (mapupdate x)) ) )
+ (walk exp))
(define-constant +default-argument-count-limit+ 99999)
@@ -833,7 +833,7 @@
(define (err msg)
(let* ([sexp ##sys#syntax-error-culprit]
[ln (get-line-number sexp)] )
- (##sys#syntax-error-hook
+ (##sys#syntax-error
(if ln
(string-append "(" ln ") in `" (symbol->string id) "' - " msg)
(string-append "in `" (symbol->string id) "' - " msg) )
@@ -1038,8 +1038,9 @@
) ; chicken.syntax module
-(import scheme chicken.base chicken.blob chicken.fixnum)
+(import scheme chicken.base chicken.bytevector chicken.fixnum)
(import chicken.syntax chicken.internal chicken.platform)
+(import (only (scheme base) make-parameter))
;;; Macro definitions:
@@ -1067,10 +1068,10 @@
(let-values (((name lib spec v s i) (##sys#decompose-import x r c 'import))
((mod) (##sys#current-module)))
(when (and mod (eq? name (##sys#module-name mod)))
- (##sys#syntax-error-hook
+ (##sys#syntax-error
'import "cannot import from module currently being defined" name))
(if (not spec)
- (##sys#syntax-error-hook
+ (##sys#syntax-error
'import "cannot import from undefined module" name)
(##sys#import
spec v s i
@@ -1087,17 +1088,23 @@
(##sys#register-meta-expression `(,(r 'import) ,@(cdr x)))
`(##core#elaborationtimeonly (,(r 'import) ,@(cdr x))))))
-
-(##sys#extend-macro-environment
- 'cond-expand
- '()
- (##sys#er-transformer
- (lambda (form r c)
- (let ((clauses (cdr form)))
+(define (process-cond-expand clauses)
(define (err x)
- (##sys#error "syntax error in `cond-expand' form"
+ (##sys#syntax-error "syntax error in `cond-expand' form"
x
(cons 'cond-expand clauses)))
+ (define (file-exists? fname)
+ (##sys#file-exists? fname #f #f 'cond-expand))
+ (define (locate-library name)
+ (let* ((name2 (library-id name))
+ (sname2 (symbol->string name2)))
+ (or (##sys#find-module name2 #f)
+ (let loop ((rp (repository-path)))
+ (and (pair? rp)
+ (let ((p (car rp)))
+ (or (file-exists? (string-append p "/" sname2 ".import.so"))
+ (file-exists? (string-append p "/" sname2 ".import.scm"))
+ (loop (cdr rp)))))))))
(define (test fx)
(cond ((symbol? fx) (feature? (strip-syntax fx)))
((not (pair? fx)) (err fx))
@@ -1118,6 +1125,11 @@
(test `(or ,@(cdr rest))))
(err fx))))
((not) (not (test (cadr fx))))
+ ((library)
+ (if (and (pair? rest)
+ (null? (cdr rest)))
+ (locate-library (strip-syntax (car rest)))
+ (err fx)))
(else (err fx)))))))
(let expand ((cls clauses))
(cond ((eq? cls '())
@@ -1137,7 +1149,14 @@
'(##core#undefined)
`(##core#begin ,@rest))))
((test id) `(##core#begin ,@(cdr clause)))
- (else (expand rclauses)))))))))))))
+ (else (expand rclauses))))))))))
+
+(##sys#extend-macro-environment
+ 'cond-expand
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (process-cond-expand (cdr form)))))
;; The "initial" macro environment, containing only import forms and
;; cond-expand. TODO: Eventually, cond-expand should move to the
@@ -1205,6 +1224,114 @@
`((##core#include ,(car body) ,##sys#current-source-filename))
body))))))))))
+;;; R7RS define-library
+
+(##sys#extend-macro-environment
+ 'define-library '()
+ (##sys#er-transformer
+ (lambda (x r c)
+ (define (register-r7rs-module name)
+ (let ((dummy (string->symbol (string-append (string #\x04) "r7rs" (symbol->string name)))))
+ (##sys#put! name '##r7rs#module dummy)
+ dummy))
+ (define implicit-r7rs-library-bindings
+ '(begin
+ cond-expand
+ export
+ import
+ import-for-syntax
+ include
+ include-ci
+ syntax-rules))
+ (##sys#check-syntax 'define-library x '(_ . #(_ 0)))
+ (let* ((x (strip-syntax x))
+ (name (cadr x))
+ (real-name (library-id name))
+ (decls (cddr x))
+ (dummy (register-r7rs-module real-name)))
+ (define (parse-exports specs)
+ (map (lambda (spec)
+ (cond ((and (list? spec)
+ (= 3 (length spec))
+ (eq? 'rename (car spec)))
+ `(export/rename ,(cdr spec)))
+ ((symbol? spec) `(export ,spec))
+ (else
+ (##sys#syntax-error 'define-library "invalid export specifier" spec name))))
+ specs))
+ (define (parse-imports specs)
+ ;; XXX TODO: Should be import-for-syntax'ed as well?
+ `(import ,@specs))
+ (define (process-includes fnames ci?)
+ `(##core#begin
+ ,@(map (lambda (fname)
+ (if (string? fname)
+ `(##core#begin ,@(read-forms fname ci?)))
+ (fname (##sys#syntax-error 'include "invalid include-filename" fname)))
+ fnames)))
+ (define (expand/begin e)
+ (let ((e2 (expand e '())))
+ (if (and (pair? e2) (eq? '##core#begin (car e2)))
+ (cons '##core#begin (map expand/begin (cdr e2)))
+ e2)))
+ (define (read-forms filename ci?)
+ (fluid-let ((##sys#default-read-info-hook
+ (let ((name 'chicken.compiler.support#read-info-hook))
+ (and (feature? 'compiling)
+ (##sys#symbol-has-toplevel-binding? name)
+ (##sys#slot name 0)))))
+ (##sys#include-forms-from-file
+ filename
+ ##sys#current-source-filename ci?
+ (lambda (forms) (map expand/begin forms)))))
+ (define (process-include-decls fnames)
+ (parse-decls (append-map (lambda (fname) (read-forms fname #t)) fnames)))
+ (define (fail spec)
+ (##sys#syntax-error 'define-library "invalid library declaration" spec))
+ (define (parse-decls decls)
+ (cond ((null? decls) '(##core#begin))
+ ((and (pair? decls) (pair? (car decls)))
+ (let ((spec (car decls))
+ (more (cdr decls)))
+ (case (car spec)
+ ((export)
+ (##sys#check-syntax 'export spec '(_ . #(_ 0)))
+ `(##core#begin ,@(parse-exports (cdr spec))
+ ,(parse-decls more)))
+ ((import)
+ (##sys#check-syntax 'import spec '(_ . #(_ 0)))
+ `(##core#begin ,(parse-imports (cdr spec))
+ ,(parse-decls more)))
+ ((include)
+ (##sys#check-syntax 'include spec '(_ . #(_ 0)))
+ `(##core#begin ,(process-includes (cdr spec) #f)
+ ,(parse-decls more)))
+ ((include-ci)
+ (##sys#check-syntax 'include-ci spec '(_ . #(_ 0)))
+ `(##core#begin ,(process-includes (cdr spec) #t)
+ ,(parse-decls more)))
+ ((include-library-declarations)
+ `(##core#begin ,(process-include-decls (cdr spec))
+ ,(parse-decls more)))
+ ((cond-expand)
+ `(##core#begin ,@(process-cond-expand (cdr spec))
+ ,(parse-decls more)))
+ ((begin)
+ `(##core#begin ,@(cdr spec)
+ ,(parse-decls more)))
+ (else (fail spec)))))
+ (else (fail (car decls)))))
+ `(##core#module ,real-name ((,dummy))
+ ;; gruesome hack: we add a dummy export for adding indirect exports
+ (##core#define-syntax ,dummy
+ (##sys#er-transformer (##core#lambda (x r c) (##core#undefined))))
+ ;; Set up an R7RS environment for the module's body.
+ (import-for-syntax (only scheme.base ,@implicit-r7rs-library-bindings))
+ (import (only scheme.base ,@implicit-r7rs-library-bindings)
+ (only chicken.module export/rename))
+ ;; Now process all toplevel library declarations
+ ,(parse-decls decls))))))
+
(##sys#extend-macro-environment
'export '()
(##sys#er-transformer
@@ -1226,7 +1353,7 @@
(symbol? (cadr ren))
(null? (cddr ren)))
(cons (car ren) (cadr ren))
- (##sys#syntax-error-hook "invalid item in export rename list"
+ (##sys#syntax-error "invalid item in export rename list"
ren)))
(strip-syntax (cdr x))))
(mod (##sys#current-module)))
@@ -1266,7 +1393,7 @@
(= 2 (length argname))
(symbol? (car argname))
(valid-library-specifier? (cadr argname))))
- (##sys#syntax-error-hook "invalid functor argument" name arg))
+ (##sys#syntax-error "invalid functor argument" name arg))
(cons argname exps)))
args))
(##core#quote ,(##sys#validate-exports exps 'functor))
@@ -1285,7 +1412,7 @@
(##sys#check-syntax 'define-interface x '(_ variable _))
(let ((name (strip-syntax (cadr x))))
(when (eq? '* name)
- (syntax-error-hook
+ (##sys#syntax-error
'define-interface "`*' is not allowed as a name for an interface"))
`(##core#elaborationtimeonly
(##sys#put/restore!
@@ -1298,7 +1425,7 @@
((list? exps)
(##sys#validate-exports exps 'define-interface))
(else
- (syntax-error-hook
+ (##sys#syntax-error
'define-interface "invalid exports" (caddr x))))))))))))
(##sys#extend-macro-environment
@@ -1500,10 +1627,8 @@
(char? (car clause))
(string? (car clause))
(eof-object? (car clause))
- ;; TODO: Remove once we have a bootstrapping libchicken with bwp-object?
- (##core#inline "C_bwpp" (car clause))
- #;(bwp-object? (car clause))
- (blob? (car clause))
+ (bytevector? (car clause))
+ (bwp-object? (car clause))
(vector? (car clause))
(##sys#srfi-4-vector? (car clause))
(and (pair? (car clause))
@@ -1689,6 +1814,14 @@
(##sys#make-promise
(##sys#call-with-values (##core#lambda () ,(cadr form)) ##sys#list))))))
+(##sys#extend-macro-environment
+ 'syntax-error
+ '()
+ (##sys#er-transformer
+ (lambda (form r c)
+ (##sys#check-syntax 'syntax-error form '(_ string . #(_ 0)))
+ (apply ##sys#syntax-error (cadr form) (cddr form)))))
+
;;; syntax-rules
(include "synrules.scm")
diff --git a/extras.scm b/extras.scm
index 1b139d2b..921706b4 100644
--- a/extras.scm
+++ b/extras.scm
@@ -28,214 +28,9 @@
(declare
(unit extras)
(uses data-structures))
-
-(module chicken.io
- (read-list read-buffered read-byte read-line
- read-lines read-string read-string! read-token
- write-byte write-line write-string)
-
-(import scheme chicken.base chicken.fixnum)
-
+
(include "common-declarations.scm")
-
-;;; Read expressions from file:
-
-(define read-list
- (let ((read read))
- (lambda (#!optional (port ##sys#standard-input) (reader read) max)
- (##sys#check-input-port port #t 'read-list)
- (do ((x (reader port) (reader port))
- (i 0 (fx+ i 1))
- (xs '() (cons x xs)))
- ((or (eof-object? x) (and max (fx>= i max)))
- (##sys#fast-reverse xs))))))
-
-
-;;; Line I/O:
-
-(define read-line
- (let ()
- (lambda args
- (let* ([parg (pair? args)]
- [p (if parg (car args) ##sys#standard-input)]
- [limit (and parg (pair? (cdr args)) (cadr args))])
- (##sys#check-input-port p #t '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
- (lambda (#!optional (port ##sys#standard-input) max)
- (##sys#check-input-port port #t 'read-lines)
- (when max (##sys#check-fixnum max 'read-lines))
- (let loop ((lns '())
- (n (or max most-positive-fixnum)))
- (if (eq? n 0)
- (##sys#fast-reverse lns)
- (let ((ln (read-line port)))
- (if (eof-object? ln)
- (##sys#fast-reverse lns)
- (loop (cons ln lns) (fx- n 1))))))))
-
-(define write-line
- (lambda (str . port)
- (let* ((p (if (##core#inline "C_eqp" port '())
- ##sys#standard-output
- (##sys#slot port 0) ) ))
- (##sys#check-output-port p #t 'write-line)
- (##sys#check-string str 'write-line)
- ((##sys#slot (##sys#slot p 2) 3) p str) ; write-string method
- (##sys#write-char-0 #\newline p))))
-
-
-;;; Extended I/O
-
-(define (read-string!/port n dest port start)
- (cond ((eq? n 0) 0)
- (else
- (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-input-port port #t 'read-string!)
- (##sys#check-string dest 'read-string!)
- (when n (##sys#check-fixnum n 'read-string!))
- (let ((dest-size (##sys#size dest)))
- (unless (and n (fx<= (fx+ start n) dest-size))
- (set! n (fx- dest-size start))))
- (##sys#check-fixnum start 'read-string!)
- (read-string!/port n dest port start))
-
-(define-constant read-string-buffer-size 2048)
-
-(define read-string/port
- (lambda (n p)
- (cond ((eq? n 0) "") ; Don't attempt to peek (fd might not be ready)
- ((eof-object? (##sys#peek-char-0 p)) #!eof)
- (n (let* ((str (##sys#make-string n))
- (n2 (read-string!/port 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 (read-string!/port 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#check-input-port port #t 'read-string)
- (when n (##sys#check-fixnum n 'read-string))
- (read-string/port n port))
-
-
-;; Make internal reader procedures available for use in srfi-4.scm:
-
-(define chicken.io#read-string/port read-string/port)
-(define chicken.io#read-string!/port read-string!/port)
-
-(define (read-buffered #!optional (port ##sys#standard-input))
- (##sys#check-input-port port #t 'read-buffered)
- (let ((rb (##sys#slot (##sys#slot port 2) 9))) ; read-buffered method
- (if rb
- (rb port)
- "")))
-
-
-;;; read token of characters that satisfy a predicate
-
-(define read-token
- (lambda (pred . port)
- (let ([port (optional port ##sys#standard-input)])
- (##sys#check-input-port port #t '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
- (lambda (s . more)
- (##sys#check-string s 'write-string)
- (let-optionals more ([n #f] [port ##sys#standard-output])
- (##sys#check-output-port port #t 'write-string)
- (when n (##sys#check-fixnum n 'write-string))
- ((##sys#slot (##sys#slot port 2) 3) ; write-string
- port
- (if (and n (fx< n (##sys#size s)))
- (##sys#substring s 0 n)
- s)))))
-
-
-;;; Binary I/O
-
-(define (read-byte #!optional (port ##sys#standard-input))
- (##sys#check-input-port port #t '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-fixnum byte 'write-byte)
- (##sys#check-output-port port #t 'write-byte)
- (##sys#write-char-0 (integer->char byte) port) )
-
-) ; module chicken.io
-
-
;;; Pretty print:
;
; Copyright (c) 1991, Marc Feeley
@@ -249,6 +44,7 @@
(pp pretty-print pretty-print-width)
(import scheme chicken.base chicken.fixnum chicken.keyword chicken.string)
+(import (only (scheme base) make-parameter open-output-string get-output-string port?))
(define generic-write
(lambda (obj display? width output)
@@ -295,11 +91,10 @@
(cond ((pair? obj) (wr-expr obj col))
((null? obj) (wr-lst obj col))
((eof-object? obj) (out "#!eof" col))
- ;; TODO: Remove once we have a bootstrapping libchicken with bwp-object?
- ((##core#inline "C_bwpp" obj) #;(bwp-object? obj) (out "#!bwp" col))
+ ((bwp-object? obj) (out "#!bwp" 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))
+ ((number? obj) (out (##sys#number->string obj) col))
((or (keyword? obj) (symbol? obj))
(let ((s (open-output-string)))
(##sys#print obj #t s)
@@ -320,7 +115,7 @@
(out (##sys#substring obj i j)
col))))
((or (char<? c #\x20)
- (char=? c #\x7f))
+ (char>=? c #\x7f))
(loop (fx+ j 1)
(fx+ j 1)
(let ((col2
@@ -336,49 +131,41 @@
(lambda (a)
(out (cdr a) col2)))
(else
- (out (number->string (char->integer c) 16)
- (out (if (char<? c #\x10) "0" "")
- (out "\\x" col2))))))))
+ (out (string-append
+ "\\x"
+ (number->string (char->integer c) 16)
+ ";")
+ col2))))))
(else (loop i (fx+ 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)] ) ) ) )
+ (let ((code (char->integer obj))
+ (col2 (out "#\\" col)))
+ (cond ((char-name obj)
+ => (lambda (cn)
+ (out (##sys#symbol->string/shared cn) col2) ) )
+ ((or (fx< code 32) (fx> code 127))
+ (out (number->string code 16)
+ (out "x" col2)))
+ (else (out (make-string 1 obj) col2)) ) ) ) )
((##core#inline "C_undefinedp" obj) (out "#<unspecified>" col))
((##core#inline "C_unboundvaluep" obj) (out "#<unbound value>" col))
((##core#inline "C_immp" obj) (out "#<unprintable object>" col))
((##core#inline "C_anypointerp" obj) (out (##sys#pointer->string obj) col))
((##sys#generic-structure? obj)
- (let ([o (open-output-string)])
+ (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)
- (out "#${" col)
- (let ((len (##sys#size obj)))
- (do ((i 0 (fx+ i 1)))
- ((fx>= i len))
- (let ((b (##sys#byte obj i)))
- (when (fx< b 16)
- (out "0" col))
- (out (##sys#number->string b 16) col)))
- (out "}" col)))
+ (out "#u8" col)
+ (wr-lst (##sys#bytevector->list obj) col))
((##core#inline "C_lambdainfop" obj)
- (out "#<lambda info " col)
- (out (##sys#lambda-info->string obj) col)
- (out ">" col) )
+ (out ">"
+ (out (##sys#lambda-info->string obj)
+ (out "#<lambda info " col) )))
(else (out "#<unprintable object>" col)) ) )
(define (pp obj col)
@@ -423,7 +210,7 @@
(let ((proc (style head)))
(if proc
(proc expr col extra)
- (if (> (string-length (##sys#symbol->string head))
+ (if (> (string-length (##sys#symbol->string/shared head))
max-call-head-width)
(pp-general expr col extra #f #f #f pp-expr)
(pp-call expr col extra pp-expr))))
@@ -566,6 +353,7 @@
(format fprintf printf sprintf)
(import scheme chicken.base chicken.fixnum chicken.platform)
+(import (only (scheme base) open-output-string get-output-string))
(define fprintf0
(lambda (loc port msg args)
@@ -576,9 +364,9 @@
(let rec ([msg msg] [args args])
(##sys#check-string msg loc)
(let ((index 0)
- (len (##sys#size msg)) )
+ (len (string-length msg)) )
(define (fetch)
- (let ((c (##core#inline "C_subchar" msg index)))
+ (let ((c (string-ref msg index)))
(set! index (fx+ index 1))
c) )
(define (next)
@@ -654,8 +442,7 @@
(when (##core#inline "C_fixnum_lessp" n 0)
(##sys#error 'set-pseudo-random-seed! "invalid size" n)))
(else (set! n (##sys#size buf))))
- (unless (##core#inline "C_byteblockp" buf)
- (##sys#error 'set-pseudo-random-seed! "invalid buffer type" buf))
+ (##sys#check-bytevector buf 'set-pseudo-random-seed!)
(##core#inline "C_set_random_seed" buf
(##core#inline "C_i_fixnum_min"
n
@@ -685,13 +472,11 @@
(##sys#error 'random-bytes
"invalid buffer type" buf))
buf)
- (else (make-string (or size nstate)))))
+ (else (##sys#make-bytevector (or size nstate)))))
(r (##core#inline "C_random_bytes" dest
(or size (##sys#size dest)))))
(unless r
(##sys#error 'random-bytes "unable to read random bytes"))
- (unless (eq? buf dest)
- (##core#inline "C_string_to_bytevector" dest))
dest))))
)
diff --git a/feathers.bat.in b/feathers.bat.in
deleted file mode 100644
index 2a2cfd89..00000000
--- a/feathers.bat.in
+++ /dev/null
@@ -1,26 +0,0 @@
-@echo off
-
-rem loader for feathers.tcl, the CHICKEN debugger
-rem
-rem Copyright (c) 2015-2022, The CHICKEN Team
-rem All rights reserved.
-rem
-rem Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
-rem conditions are met:
-rem
-rem Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-rem disclaimer.
-rem Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
-rem disclaimer in the documentation and/or other materials provided with the distribution.
-rem Neither the name of the author nor the names of its contributors may be used to endorse or promote
-rem products derived from this software without specific prior written permission.
-rem
-rem THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
-rem OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
-rem AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
-rem CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
-rem CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
-rem SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
-rem THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-rem OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
-rem POSSIBILITY OF SUCH DAMAGE.
diff --git a/feathers.in b/feathers.in
deleted file mode 100644
index 68155af0..00000000
--- a/feathers.in
+++ /dev/null
@@ -1,38 +0,0 @@
-#!/bin/sh
-#
-# loader for feathers.tcl, the CHICKEN debugger
-#
-# Copyright (c) 2015-2022, 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.
-
-wish=`which wish8.5`
-
-if test \! -x "$wish"; then
- wish=`which wish`
-fi
-
-if test \! -x "$wish"; then
- echo 'no "wish" executable found - please put "wish8.5" or "wish" in your PATH' \
- 1>&2
- exit 1
-fi
diff --git a/feathers.mdoc b/feathers.mdoc
deleted file mode 100644
index efafb762..00000000
--- a/feathers.mdoc
+++ /dev/null
@@ -1,95 +0,0 @@
-.\" Copyright (c) 2007-2022, 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:
-.\" 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.
-.\"
-.\"
-.Dd Apr 26, 2017
-.Dt FEATHERS 1
-.Os
-.Sh NAME
-.Nm feathers
-.Nd a simple source-level debugger for CHICKEN Scheme
-.Sh SYNOPSIS
-.Nm
-.Op Ar OPTION ...
-.Op Ar PROGRAM Ar ARGUMENTS ...
-.Sh DESCRIPTION
-.Nm
-runs a program compiled with CHICKEN Scheme and allows basic
-source-level debugging like setting breakpoints, single-stepping and
-inspection of procedure arguments and global variables.
-.Pp
-The Scheme code must be compiled with debug-level 3 for debugging to be
-possible. Communication with the debugger takes place by exchanging
-messages over a TCP socket, the address and port being given by the
-environment variable
-.Ev CHICKEN_DEBUGGER
-which holds a connection address of the form
-.Ao ADDRESS Ac : Ns Ao PORT Ac .
-.Pp
-.Ar PROGRAM
-must give the path to the executable that is to be run,
-.Ev PATH
-is not searched.
-.Pp
-The program accepts following arguments:
-.Bl -tag -width Ds
-.It Fl help
-Shows a list of supported command-line options.
-.It Fl n
-Do not load the default startup file
-.Pa .feathers .
-.It Fl d
-TODO: Document this
-.It Fl dir Ar DIRECTORY
-Add
-.Ar DIRECTORY
-to the list of searched paths for locating source files.
-.It Fl port Ar PORT
-Select a different TCP port than the default
-.Pq 9999 .
-.El
-.Sh ENVIRONMENT
-The following environment variables change the behaviour of
-.Nm Ns :
-.Bl -tag -width CHICKEN_DEBUGGER
-.It Ev CHICKEN_DEBUGGER
-Should hold a TCP server address and port where the debugger is listening.
-This variable is set by the debugger when a program is run from it, and
-defaults to localhost:9999
-.El
-.Sh EXIT STATUS
-.Ex -std
-.Sh SEE ALSO
-.Xr chicken 1 ,
-.Xr csc 1 ,
-.Xr csi 1
-.Pp
-More information can be found in the
-.Lk http://wiki.call-cc.org/manual/index "CHICKEN User's Manual".
-.Sh AUTHORS
-.An The CHICKEN Team
-.Sh BUGS
-Submit bug reports by e-mail to
-.Mt chicken-janitors@nongnu.org
diff --git a/feathers.tcl b/feathers.tcl
deleted file mode 100644
index 2845a0cc..00000000
--- a/feathers.tcl
+++ /dev/null
@@ -1,1925 +0,0 @@
-#!/usr/bin/env wish
-#
-# a graphical debugger for compiled CHICKEN programs
-#
-# Copyright (c) 2015-2022, 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.
-
-
-set version 0
-set protocol_version 1
-set debugger_port 9999
-
-set events(1) call
-set events(2) assign
-set events(3) gc
-set events(4) entry
-set events(5) signal
-set events(6) connect
-set events(7) listen
-set events(8) interrupted
-
-set reply(SETMASK) 1
-set reply(TERMINATE) 2
-set reply(CONTINUE) 3
-set reply(SET_BREAKPOINT) 4
-set reply(CLEAR_BREAKPOINT) 5
-set reply(LIST_EVENTS) 6
-set reply(GET_BYTES) 7
-set reply(GET_AV) 8
-set reply(GET_SLOTS) 9
-set reply(GET_GLOBAL) 10
-set reply(GET_STATS) 11
-set reply(GET_TRACE) 12
-
-set colors(header_foreground) white
-set colors(header_background) black
-set colors(text_foreground) black
-set colors(text_background) gray90
-set colors(event_foreground) black
-set colors(event_background) white
-set colors(breakpoint_foreground) white
-set colors(breakpoint_background) DarkRed
-set colors(highlight_foreground) white
-set colors(highlight_background) CornflowerBlue
-set colors(mark_foreground) black
-set colors(mark_background) yellow
-set colors(trace_background) gray90
-set colors(trace_foreground) black
-
-set typecode(0) VECTOR
-set typecode(1) SYMBOL
-set typecode(66) STRING
-set typecode(3) PAIR
-set typecode(36) CLOSURE
-set typecode(85) FLONUM
-set typecode(39) PORT
-set typecode(8) STRUCTURE
-set typecode(41) POINTER
-set typecode(42) LOCATIVE
-set typecode(43) TAGGED_POINTER
-set typecode(77) LAMBDA_INFO
-set typecode(15) BUCKET
-
-set EXEC_EVENT_MASK 32; # signal
-set STEP_EVENT_MASK 54; # call, entry, assign, signal
-
-set membar_height 50
-set value_cutoff_limit 200; # must be lower than limit in dbg-stub.c
-
-set the_name "feathers"
-set header_text "$the_name - (c)MMXV The CHICKEN Team - Version $version"
-set startup_file ".$the_name"
-
-set client_addr ""
-set client_file ""
-set current_filename ""
-set current_c_filename ""
-set file_list {}
-set bp_queue {}
-set watched_queue {}
-set value_queue {}
-set current_line ""
-set current_c_line ""
-set current_bp_lines {}
-set current_bp_globals {}
-set font_name "Courier"
-set font_size 12
-set program_name ""
-set search_path {"."}
-set data_view ""
-set c_view ""
-set data_queue {}
-set reply_queue {}
-set starting_up 1
-set stepping 0
-set terminated 0
-set arguments_item_id ""
-set watched_variables {}
-set current_variable ""
-set current_value ""
-set listening 0
-set process_id 0
-set statistics_data ""
-set mark_start_index(.t) ""
-set mark_start_index(.code.t) ""
-set current_c_location ""
-set last_marked_widget .t
-set selected_filename ""
-set trace_data ""
-set last_location ""
-set logging 0
-
-set env(CHICKEN_DEBUGGER) "localhost:9999"
-
-
-proc Log {msg} {
- global logging
-
- if {$logging} {puts stderr $msg}
-}
-
-
-proc SetupGUI {} {
- global font_name font_size colors the_name selected_filename
- label .h -height 1 -textvariable header_text -anchor w
- scrollbar .s -command {.t yview}
- text .t -wrap char -yscrollcommand {.s set} -cursor arrow -state disabled \
- -font [list $font_name $font_size]
- frame .f
- ttk::combobox .files -postcommand FilesList -textvariable selected_filename
- pack .h -side top -fill x
- pack .files -side top -fill x
- pack .f -side bottom -fill x
- pack .s -fill y -side right
- pack .t -fill both -expand 1
-
- for {set i 1} {$i <= 10} {incr i} {
- button .f.b$i -text "F$i" -font {Helvetica 10} -borderwidth 0 -relief flat \
- -pady 0
- pack .f.b$i -side left -expand 1 -fill x
- }
-
- .f.b1 configure -text "F1 Run"
- .f.b2 configure -text "F2 Where"
- .f.b3 configure -text "F3 AddDir"
- .f.b4 configure -text "F4 Data"
- .f.b5 configure -text "F5 Continue"
- .f.b6 configure -text "F6 Step"
- .f.b7 configure -text "F7 Find Prev"
- .f.b8 configure -text "F8 Find Next"
- .f.b9 configure -text "F9 C"
- .f.b10 configure -text "F10 Exit"
- .h configure -background $colors(header_background) \
- -foreground $colors(header_foreground) -font {Helvetica 12} \
- -borderwidth 0
- .t configure -background $colors(text_background) \
- -foreground $colors(text_foreground) \
- -insertbackground $colors(text_foreground) -borderwidth 0
-
- .t tag configure ev -background $colors(event_background) \
- -foreground $colors(event_foreground)
- .t tag configure bp -background $colors(breakpoint_background) \
- -foreground $colors(breakpoint_foreground)
- .t tag configure hl -background $colors(highlight_background) \
- -foreground $colors(highlight_foreground)
- .t tag configure mk -background $colors(mark_background) \
- -foreground $colors(mark_foreground)
- .t tag lower mk sel
- .t tag lower bp mk
- .t tag lower hl bp
- .t tag lower ev hl
- focus .t
- wm title . $the_name
-}
-
-
-proc SetupBindings {} {
- for {set i 1} {$i <= 10} {incr i} {
- bind . <F$i> [list .f.b$i invoke]
- }
-
- .f.b1 configure -command RunProcess
- .f.b2 configure -command LocateFocus
- .f.b3 configure -command AddDirectory
- .f.b4 configure -command ShowData
- .f.b5 configure -command ContinueExecution
- .f.b6 configure -command StepExecution
- .f.b7 configure -command FindPrevious
- .f.b8 configure -command FindNext
- .f.b9 configure -command OpenCView
- .f.b10 configure -command Terminate
- bind .t <ButtonPress-1> { focus .t; ToggleBreakpoint %y; break }
- bind .t <ButtonRelease-1> break
- bind .t <space> {StepExecution; break}
- bind .t <Return> {ToggleBreakpoint; break}
- bind .t <Up> {MoveFocus -1; break}
- bind .t <Down> {MoveFocus 1; break}
- bind .t <plus> {ResizeFont 1; break}
- bind .t <minus> {ResizeFont -1; break}
- bind .t <Escape> {Interrupt}
- bind .t <ButtonPress-3> {StartMark %W %x %y; break}
- bind .t <Motion> {MoveMark %W %x %y; break}
- bind .t <ButtonRelease-3> {EndMark %W; break}
- bind .files <<ComboboxSelected>> {SelectFile; focus .t}
- wm protocol . WM_DELETE_WINDOW Terminate
-}
-
-
-proc SetupDataView {} {
- global colors arguments_item_id stats membar_height the_name font_name font_size
- toplevel .data
- ttk::treeview .data.t -yscrollcommand {.data.s set} -columns {Values Addresses} \
- -selectmode browse
- .data.t heading 0 -text Value
- .data.t heading 1 -text Address
- scrollbar .data.s -command {.data.t yview}
- entry .data.e
- canvas .data.c -height $membar_height
- frame .data.f
- text .data.f.tr -state disabled -yscrollcommand {.data.f.trs set} -height 20 \
- -font [list $font_name $font_size] -foreground $colors(trace_foreground) \
- -background $colors(trace_background)
- scrollbar .data.f.trs -command {.data.f.tr yview}
- pack .data.f -side bottom -fill x
- pack .data.c -side bottom -fill x
- pack .data.e -side bottom -fill x
- pack .data.s -fill y -side right
- pack .data.t -fill both -expand 1
- pack .data.f.trs -fill y -side right
- pack .data.f.tr -side bottom -fill both -expand 1
- .data.t tag configure watched -foreground $colors(breakpoint_foreground) \
- -background $colors(breakpoint_background)
- set arguments_item_id [.data.t insert {} end -text "<arguments>"]
- set stats(fromspace_used) [.data.c create rectangle 0 0 0 0 -fill gray80]
- set stats(fromspace_unused) [.data.c create rectangle 0 0 0 0 -fill gray40]
- set stats(scratchspace_used) [.data.c create rectangle 0 0 0 0 -fill gray80]
- set stats(scratchspace_unused) [.data.c create rectangle 0 0 0 0 -fill gray40]
- set stats(nursery_used) [.data.c create rectangle 0 0 0 0 -fill gray80]
- set stats(nursery_unused) [.data.c create rectangle 0 0 0 0 -fill gray40]
- set mh [expr $membar_height / 3]
- set stats(fromspace_name) [.data.c create text 10 0 -anchor nw -text "heap"]
- set stats(scratchspace_name) [.data.c create text 10 $mh -anchor nw -text \
- "scratch"]
- set stats(nursery_name) [.data.c create text 10 [expr $mh * 2] -anchor nw \
- -text "nursery"]
- set stats(fromspace_percentage) [.data.c create text 0 0 -anchor center]
- set stats(scratchspace_percentage) [.data.c create text 0 0 -anchor center]
- set stats(nursery_percentage) [.data.c create text 0 0 -anchor center]
- set stats(fromspace_size) [.data.c create text 0 0 -anchor ne]
- set stats(scratchspace_size) [.data.c create text 0 0 -anchor ne]
- set stats(nursery_size) [.data.c create text 0 0 -anchor ne]
- wm title .data "$the_name - data view"
-}
-
-
-proc SetupDataViewBindings {} {
- bind .data <F3> AddDirectory
- bind .data <F4> ShowData
- bind .data <F5> ContinueExecution
- bind .data <F6> StepExecution
- bind .data <F10> Terminate
- bind .data.e <Return> {WatchGlobal; break}
- bind .data.t <BackSpace> {RemoveGlobal; break}
- bind .data.t <Delete> {RemoveGlobal; break}
- bind .data.t <<TreeviewOpen>> OpenDataItem
- bind .data.t <Return> {ToggleVariableWatch; break}
- bind .data.t <Double-Button-1> {ToggleVariableWatch %x %y; break}
- bind .data.t <<TreeviewSelect>> {Log [.data.t focus]; break}
- bind .data.c <Configure> {RedrawStatistics}
- wm protocol .data WM_DELETE_WINDOW CloseDataView
-}
-
-
-proc SetupCView {} {
- global font_name font_size colors the_name
- toplevel .code
- label .code.h -height 1 -text "" -anchor w
- scrollbar .code.s -command {.code.t yview}
- text .code.t -wrap char -yscrollcommand {.code.s set} -cursor arrow -state \
- disabled -font [list $font_name $font_size]
- frame .code.f
- pack .code.h -side top -fill x
- pack .code.s -fill y -side right
- pack .code.f -fill x -side bottom
- pack .code.t -fill both -expand 1
- .code.h configure -background $colors(header_background) \
- -foreground $colors(header_foreground) -font {Helvetica 12} \
- -borderwidth 0
- .code.t configure -background $colors(text_background) \
- -foreground $colors(text_foreground) \
- -insertbackground $colors(text_foreground) -borderwidth 0
- .code.t tag configure hl -background $colors(highlight_background) \
- -foreground $colors(highlight_foreground)
- .code.t tag configure mk -background $colors(mark_background) \
- -foreground $colors(mark_foreground)
- .code.t tag lower mk sel
- .code.t tag lower hl mk
- wm title .code "$the_name - code view"
- focus .code.t
-}
-
-
-proc SetupCViewBindings {} {
- bind .code <F3> AddDirectory
- bind .code <F4> ShowData
- bind .code <F5> ContinueExecution
- bind .code <F6> StepExecution
- bind .code <F7> {FindPrevious .code.t}
- bind .code <F8> {FindNext .code.t}
- bind .code <F10> Terminate
- bind .code.t <ButtonPress-1> {focus .code.t}
- bind .code.t <ButtonRelease-1> break
- bind .code <plus> {ResizeFont 1; break}
- bind .code <minus> {ResizeFont -1; break}
- bind .code.t <ButtonPress-3> {StartMark %W %x %y; break}
- bind .code.t <Motion> {MoveMark %W %x %y; break}
- bind .code.t <ButtonRelease-3> {EndMark %W; break}
- wm protocol .code WM_DELETE_WINDOW CloseCView
-}
-
-
-proc FilesList {} {
- global file_list
- .files configure -values $file_list
-}
-
-
-proc CloseDataView {} {
- global data_view
-
- if {$data_view != ""} {
- set data_view ""
- destroy .data
- }
-}
-
-
-proc CloseCView {} {
- global c_view
-
- if {$c_view != ""} {
- set c_view ""
- destroy .code
- }
-}
-
-
-proc ShowData {} {
- global data_view starting_up client_file program_name the_name
-
- if {$data_view == ""} {
- SetupDataView
- SetupDataViewBindings
- set data_view .data
- wm title .data "$the_name - $program_name - data view"
-
- if {!$starting_up && $client_file != ""} UpdateData
- }
-}
-
-
-proc OpenCView {} {
- global c_view starting_up current_c_location the_name program_name
-
- if {$c_view == ""} {
- SetupCView
- SetupCViewBindings
- set c_view .code
- wm title .code "$the_name - $program_name - code view"
-
- Log "$current_c_location"
-
- if {$current_c_location != ""} {
- LocateCSource $current_c_location
- }
- }
-}
-
-
-proc AddDirectory {} {
- global search_path current_filename
- set dir "."
-
- if {$current_filename != ""} {
- set dir [file dirname $current_filename]
- }
-
- set dir [tk_chooseDirectory -title "Select directory to add to search path" \
- -initialdir $dir]
-
- if {$dir != ""} {
- lappend search_path $dir
- }
-}
-
-
-proc ResizeFont {n} {
- global font_size font_name c_view
- incr font_size $n
- .t configure -font [list $font_name $font_size]
-
- if {$c_view != ""} {
- .code.t configure -font [list $font_name $font_size]
- }
-}
-
-
-proc Flash {{color red}} {
- global colors
- .t configure -background $color
- update
- after 100 {.t configure -background $colors(text_background)}
-}
-
-
-proc CheckListening {} {
- global listening
-
- if {!$listening} {
- Flash
- return 0
- }
-
- return 1
-}
-
-
-proc MoveFocus {amount} {
- global current_line
- set ln [expr $current_line + $amount]
- SetFocus $ln
-}
-
-
-proc LocateFocus {} {
- global last_location
-
- if {$last_location != ""} {
- SetFocus $last_location
- }
-}
-
-
-proc SetFocus {line} {
- global current_line
-
- if {$line > 0 && $line <= [.t count -lines 1.0 end]} {
- set old [.t tag ranges hl]
-
- if {$old != ""} {
- eval .t tag remove hl $old
- }
-
- set current_line $line
- .t tag add hl $line.0 "$line.0 lineend + 1 chars"
- .t see $line.0
- }
-}
-
-
-proc SetCFocus {line} {
- global current_c_line
-
- if {$line > 0 && $line <= [.code.t count -lines 1.0 end]} {
- set old [.code.t tag ranges hl]
-
- if {$old != ""} {
- eval .code.t tag remove hl $old
- }
-
- set current_c_line $line
- .code.t tag add hl $line.0 "$line.0 lineend + 1 chars"
- .code.t see $line.0
- }
-}
-
-
-proc Interrupt {} {
- global process_id listening
-
- if {$listening || $process_id == 0} return
-
- catch {exec kill -USR2 $process_id}
-}
-
-
-proc ToggleBreakpoint {{y ""}} {
- global current_filename bp_queue current_bp_lines
- global current_line client_file reply_queue
-
- if {$client_file == ""} return
-
- if {$y != ""} {
- if {[catch {set p [.t index @1,$y]}]} return
-
- if {![regexp {^(\d+)\.} $p _ line]} return
- } else {
- set line $current_line
- }
-
- set aname "file:$current_filename"
- global $aname
- set aref "$aname\($line\)"
-
- if {![CheckListening]} return
-
- if {[info exists $aref]} {
- set bps [set $aref]
-
- if {$bps != ""} {
- set bp1 [lindex $bps 0]
- set bprest [lrange $bps 1 end]
- set bp_queue [concat $bp_queue $bprest]
-
- if {[lsearch -exact $current_bp_lines $line] != -1} {
- UnmarkBP $line
- SendReply CLEAR_BREAKPOINT $bp1
- lappend reply_queue RemoveBPReply
- } else {
- MarkBP $line
- SendReply SET_BREAKPOINT $bp1
- lappend reply_queue AddBPReply
- }
- }
- }
-}
-
-
-proc ToggleVariableWatch {{x ""} {y ""}} {
- global globals current_bp_globals bp_queue
-
- if {![CheckListening]} return
-
- if {$x == ""} {
- set item [.data.t focus]
- } else {
- if {[catch {.data.t identify item $x $y} item]} return
- }
-
- if {$item == ""} return
-
- if {[.data.t parent $item] != ""} return
-
- set name [.data.t item $item -text]
-
- if {$name == "<arguments>"} return
-
- if {![info exists globals($name)]} return
-
- Log "globals: $name -> $globals($name)"
-
- set bps $globals($name)
-
- if {$bps != ""} {
- set bp1 [lindex $bps 0]
- set bprest [lrange $bps 1 end]
- set bp_queue [concat $bp_queue $bprest]
-
- if {[lsearch -exact $current_bp_globals $item] != -1} {
- UnmarkWatchedVariable $item
- SendReply CLEAR_BREAKPOINT $bp1
- lappend reply_queue RemoveBPReply
- } else {
- MarkWatchedVariable $item
- SendReply SET_BREAKPOINT $bp1
- lappend reply_queue AddBPReply
- }
- }
-}
-
-
-proc AddBPReply {} {
- global bp_queue reply_queue
-
- if {$bp_queue != ""} {
- set bp1 [lindex $bp_queue 0]
- set bp_queue [lrange $bp_queue 1 end]
- SendReply SET_BREAKPOINT $bp1
-
- if {$bp_queue != ""} {
- lappend reply_queue AddBPReply
- }
- }
-}
-
-
-proc RemoveBPReply {} {
- global bp_queue reply_queue
-
- if {$bp_queue != ""} {
- set bp1 [lindex $bp_queue 0]
- set bp_queue [lrange $bp_queue 1 end]
- SendReply CLEAR_BREAKPOINT $bp1
-
- if {$bp_queue != ""} {
- lappend reply_queue RemoveBPReply
- }
- }
-}
-
-
-proc MarkBP {line} {
- global current_bp_lines
-
- if {[lsearch -exact $current_bp_lines $line] == -1} {
- .t tag add bp $line.0 "$line.0 lineend"
- lappend current_bp_lines $line
- }
-}
-
-
-proc UnmarkBP {line} {
- global current_bp_lines
- set i [lsearch -exact $current_bp_lines $line]
-
- if {$i != -1} {
- set current_bp_lines [lreplace $current_bp_lines $i $i]
- .t tag remove bp $line.0 "$line.0 lineend"
- }
-}
-
-
-proc MarkWatchedVariable {item} {
- global current_bp_globals
-
- if {[lsearch -exact $current_bp_globals $item] == -1} {
- .data.t tag add watched $item
- lappend current_bp_globals $item
- }
-}
-
-
-proc UnmarkWatchedVariable {item} {
- global current_bp_globals
- set i [lsearch -exact $current_bp_globals $item]
-
- if {$i != -1} {
- set current_bp_globals [lreplace $current_bp_globals $i $i]
- .data.t tag remove watched $item
- }
-}
-
-
-proc Terminate {} {
- global client_file process_id
-
- if {$client_file != ""} {
- SendReply TERMINATE
- set f $client_file
- set client_file ""
- close $f
- catch {exec kill -9 $process_id}
- }
-
- exit
-}
-
-
-proc RunProcess {{prg ""}} {
- global env client_file program_name search_path reply_queue current_filename
- global data_queue bp_queue starting_up stepping terminated current_bp_lines
- global terminated watched_variables watched_queue listening file_list
- global value_queue process_id current_bp_globals data_view statistics_data
- global arguments_item_id trace_data last_location
-
- if {$client_file != ""} {
- if {!$terminated} {SendReply TERMINATE}
-
- set f $client_file
- set client_file ""
- close $f
- }
-
- set program_name $prg
-
- if {$program_name == ""} {
- set program_name [tk_getOpenFile -title "Select executable"]
- }
-
- if {$program_name == ""} return
-
- set args [lassign $program_name prgfname]
- set prgfname [file normalize $prgfname]
-
- if {![file exists $prgfname]} {
- .t configure -state normal
- .t insert end "Could not start program:\n\nfile `$prgfname' does not exist"
- .t see end
- .t configure -state disabled
- }
-
- lappend search_path [file dirname $prgfname]
- set reply_queue {}
- set data_queue {}
- set bp_queue {}
- set watched_queue {}
- set value_queue {}
- set last_location ""
- set starting_up 1
- set stepping 0
- set terminated 0
- set current_bp_lines {}
- set current_bp_globals {}
- set current_filename ""
- set watched_variables {}
- set listening 0
- set process_id 0
- set statistics_data ""
- set file_list {}
- set trace_data ""
- .t configure -state normal
- .t delete 1.0 end
- .t configure -state disabled
-
- if {$data_view != ""} {
- .data.t delete [lrange [.data.t children {}] 1 end]
- .data.t delete [.data.t children $arguments_item_id]
- }
-
- if {[catch {eval exec $prgfname {*}$args <@ stdin >@ stdout 2>@ stderr &} result]} {
- .t configure -state normal
- .t insert end "Could not start program:\n\n$result"
- .t see end
- .t configure -state disabled
- } else {
- set process_id $result
- }
-}
-
-
-proc UpdateHeader {{msg ""}} {
- global header_text current_filename client_addr current_line
- set header_text $client_addr
-
- if {$current_filename != ""} {
- set header_text $current_filename
-
- if {$current_line != ""} {
- append header_text ":$current_line"
- }
- }
-
- if {$msg != ""} {
- append header_text " - $msg"
- }
-}
-
-
-proc ProcessInput {} {
- global client_file terminated
- gets $client_file line
-
- if {[eof $client_file]} {
- close $client_file
- set client_file ""
- set terminated 1
- UpdateHeader "connection closed"
- } elseif {![fblocked $client_file]} {
- Log "Input: $line"
- ProcessLine $line
- }
-}
-
-
-proc ProcessLine {line} {
- if {[regexp {^\((\d+)\s+([^\s]*)\s+([^\s]*)\s+([^)]*)\)$} $line _ evt loc val cloc]} {
- set val [ProcessString $val]
- set loc [ProcessString $loc]
- set cloc [ProcessString $cloc]
- ProcessEvent $evt $loc $val $cloc
- } elseif {[regexp {^\(\*\s*(.*)\)$} $line _ data]} {
- ProcessData $data
- } else {
- UpdateHeader "invalid input: [string range $line 0 40]..."
- }
-}
-
-
-proc ProcessEvent {evt loc val cloc} {
- global events reply_queue starting_up EXEC_EVENT_MASK data_queue c_view
- global STEP_EVENT_MASK stepping data_view listening value_queue statistics_data
- global current_c_location protocol_version the_name program_name trace_data
-
- set listening 1
-
- if {[info exists events($evt)]} {
- set eventname $events($evt)
- } else {
- UpdateHeader "unrecognized event: $evt"
- return
- }
-
- if {$data_queue != ""} {
- set data_queue [lrange $data_queue 1 end]
- }
-
- Log "evt: $eventname, dq: $data_queue, rq: $reply_queue, vq: $value_queue"
-
- if {$eventname != "listen"} {
- set statistics_data ""
- set trace_data ""
- }
-
- set current_c_location $cloc
-
- if {$c_view != ""} {
- LocateCSource $cloc
- }
-
- switch $eventname {
- connect {
- if {![regexp {^([^:]+):([^:]+):(\d+)$} $loc _ name pid pv]} {
- UpdateHeader "invalid connection info: $loc"
- return
- }
-
- if {$pv > $protocol_version} {
- UpdateHeader "client protocol doesn't match: $pv"
- return
- }
-
- wm title . "$the_name - $program_name"
-
- Log "\n##################### CONNECT ##################"
- SendReply SETMASK $STEP_EVENT_MASK
- set stepping 1
- lappend reply_queue FetchEventListReply FirstStepReply
- }
- listen {
- if {$reply_queue != ""} {
- set action [lindex $reply_queue 0]
- set reply_queue [lrange $reply_queue 1 end]
- Log "action: $action"
- $action
- } elseif {$val == 1} {
- # new dbg-info was registered
- lappend reply_queue ApplyTags
- FetchEventListReply
- }
- }
- default {
- # call/entry/assign/signal/gc
- LocateEvent $loc $val
- UpdateHeader "\[$eventname\]"
-
- if {$starting_up} {
- SendReply SETMASK $EXEC_EVENT_MASK
- set starting_up 0
- } elseif {$data_view != ""} UpdateData
- }
- }
-}
-
-
-proc UpdateData {} {
- global data_queue reply_queue watched_variables
- global watched_queue
- set watched_queue $watched_variables
- lappend reply_queue GetGlobals
- lappend data_queue GetAVData
- SendReply GET_AV
-}
-
-
-proc GetAVData {data} {
- global arguments_item_id value_queue
- set vals [ParseValueList $data]
- set cs [.data.t children $arguments_item_id]
- set len [llength $vals]
- set clen [llength $cs]
-
- for {set i 0} {$i < $len} {incr i} {
- lassign [ValueData [lindex $vals $i]] type text addr
-
- if {$i >= $clen} {
- set c [.data.t insert $arguments_item_id end -text $type -values \
- [list $text $addr]]
- } else {
- set c [lindex $cs $i]
- .data.t item $c -text $type -values [list $text $addr]
- }
-
- if {$addr != ""} {
- lappend value_queue $c
- }
-
- incr i
- }
-
- if {$i < $clen} {
- .data.t delete [lrange $cs $i end]
- }
-
- .data.t item $arguments_item_id -open 1
-}
-
-
-proc GetGlobals {} {
- global data_queue reply_queue watched_queue current_variable
- global data_view value_queue
-
- if {$watched_queue != ""} {
- set current_variable [lindex $watched_queue 0]
- set watched_queue [lrange $watched_queue 1 end]
- lappend data_queue GetGlobalData
- set name [MangleSymbol [.data.t item $current_variable -text]]
- SendReply GET_GLOBAL "\"$name\""
- lappend reply_queue GetGlobals
- } elseif {$data_view != ""} {
- if {$value_queue != ""} {
- GetValues
- } else {
- GetStatistics
- }
- }
-}
-
-
-proc GetValues {} {
- global data_view value_queue current_value data_queue reply_queue
-
- if {$data_view != ""} {
- if {$value_queue != ""} {
- set current_value [lindex $value_queue 0]
- Log "get value: $current_value"
- set value_queue [lrange $value_queue 1 end]
- lappend data_queue GetValueData
- scan [.data.t set $current_value 1] %x addr
- SendReply GET_SLOTS $addr
- lappend reply_queue GetValues
- } else {
- UpdateValueText {}
- GetTrace
- }
- }
-}
-
-
-proc GetTrace {} {
- global data_queue trace_data reply_queue
-
- if {$trace_data == ""} {
- lappend reply_queue GetStatistics
- lappend data_queue GetTraceData
- SendReply GET_TRACE
- } else GetStatistics
-}
-
-
-proc GetTraceData {data} {
- global trace_data
-
- if {![regexp {^"([^"]*)"$} $data _ str]} {
- append trace_data "<invalid trace data>\n"
- } else {
- append trace_data "$str\n"
- }
-}
-
-
-proc RedrawTrace {} {
- global trace_data
- .data.f.tr configure -state normal
- .data.f.tr delete 1.0 end
- .data.f.tr insert 1.0 $trace_data
- .data.f.tr configure -state disabled
-}
-
-
-proc GetStatistics {} {
- global data_queue statistics_data reply_queue trace_data
-
- if {$trace_data != ""} RedrawTrace
-
- if {$statistics_data == ""} {
- lappend data_queue GetStatisticsData
- SendReply GET_STATS
- }
-}
-
-
-proc GetStatisticsData {data} {
- global statistics_data
- set addrs [ParseValueList $data]
- set statistics_data $addrs
- RedrawStatistics
-}
-
-
-proc RedrawStatistics {} {
- global statistics_data stats membar_height
-
- if {$statistics_data == ""} return
-
- set w [winfo width .data.c]
- set w2 [expr $w / 2]
- set w10 [expr $w - 10]
- set mh [expr $membar_height / 3]
- set mh2 [expr $mh * 2]
-
- # fromspace
- lassign [CalcSize [lindex $statistics_data 0] [lindex $statistics_data 1] \
- [lindex $statistics_data 6] $w] p pc sz
- .data.c coords $stats(fromspace_used) 0 0 $p $mh
- .data.c coords $stats(fromspace_unused) $p 0 $w $mh
- .data.c coords $stats(fromspace_percentage) $w2 [expr $mh / 2]
- .data.c itemconfigure $stats(fromspace_percentage) -text "$pc%"
- .data.c coords $stats(fromspace_size) $w10 0
- .data.c itemconfigure $stats(fromspace_size) -text "${sz}k"
-
- # scratchspace
- if {[lindex $statistics_data 2] != 0} {
- lassign [CalcSize [lindex $statistics_data 2] [lindex $statistics_data 3] \
- [lindex $statistics_data 7] $w] p pc sz
- .data.c coords $stats(scratchspace_used) 0 $mh $p $mh2
- .data.c coords $stats(scratchspace_unused) $p $mh $w $mh2
- .data.c coords $stats(scratchspace_percentage) $w2 [expr int($mh * 1.5)]
- .data.c itemconfigure $stats(scratchspace_percentage) -text "$pc%"
- .data.c coords $stats(scratchspace_size) $w10 $mh
- .data.c itemconfigure $stats(scratchspace_size) -text "${sz}k"
- }
-
- # nursery
- lassign [CalcSize [lindex $statistics_data 4] [lindex $statistics_data 5] \
- [lindex $statistics_data 8] $w 1] p pc sz
- .data.c coords $stats(nursery_used) 0 $mh2 $p $membar_height
- .data.c coords $stats(nursery_unused) $p $mh2 $w $membar_height
- .data.c coords $stats(nursery_percentage) $w2 [expr int($mh * 2.5)]
- .data.c itemconfigure $stats(nursery_percentage) -text "$pc%"
- .data.c coords $stats(nursery_size) $w10 $mh2
- .data.c itemconfigure $stats(nursery_size) -text "${sz}k"
-}
-
-
-proc CalcSize {start limit top width {inv 0}} {
- set total [expr $limit - $start]
-
- if {$inv} {
- set amount [expr $limit - $top]
- } else {
- set amount [expr $top - $start]
- }
-
- set p [expr int(double($amount) / $total * 100)]
- set sz [expr $total / 1024]
- return [list [expr int((double($width) / $total) * $amount)] $p $sz]
-}
-
-
-proc GetValueData {data} {
- global current_value value_queue typecode value_cutoff_limit
-
- set vals [ParseValueList $data]
- set bits [lindex $vals 1]
-
- if {[info exists typecode($bits)]} {
- set type $typecode($bits)
- } else {
- set type "<invalid: $bits>"
- }
-
- .data.t item $current_value -text $type
- set cs {}
-
- switch [lindex $vals 0] {
- "SPECIAL" {
- set cs [.data.t children $current_value]
-
- if {$cs == ""} {
- set c1 [.data.t insert $current_value end]
- set cs {}
- } else {
- set c1 [lindex $cs 0]
- set cs [lrange $cs 1 end]
- }
-
- .data.t item $c1 -text "<native pointer>" -values \
- [list "" [format 0x%x [lindex $vals 2]]]
- set vals [lrange $vals 3 end]
- }
- "VECTOR" {
- set vals [lrange $vals 2 end]
- set cs [.data.t children $current_value]
- }
- "BLOB" {
- if {$type == "STRING" || $type == "LAMBDA_INFO"} {
- set str "\""
-
- foreach c [lrange $vals 2 end] {
- # XXX escape special chars
- append str [format %c $c]
- }
-
- append str "\""
- } elseif {$type == "FLONUM"} {
- set bytes [binary format c* $vals]
- binary scan $bytes d str
- } else {
- set str "#\${"
-
- foreach c [lrange $vals 2 end] {
- append str [format %02x $c]
- }
-
- append str "}"
- }
-
- .data.t set $current_value 0 $str
- set cs [.data.t children $current_value]
-
- if {$cs != ""} {.data.t delete $cs}
-
- return
- }
- default {
- UpdateHeader "invalid value: $data"
- }
- }
-
- set vlen [llength $vals]
- set clen [llength $cs]
-
- for {set i 0} {$i < $vlen} {incr i} {
- set val [lindex $vals $i]
- lassign [ValueData $val] type text addr
-
- if {$i >= $clen} {
- set c [.data.t insert $current_value end -text $type -values \
- [list $text $addr]]
- Log "insert: $c"
- } else {
- set c [lindex $cs $i]
- Log "reuse: $c"
- .data.t item $c -text $type -values [list $text $addr]
- }
-
- if {$i >= $value_cutoff_limit} {
- .data.t item $c -text ":" -values {"" ""}
- incr i
- break
- }
-
- if {$addr != ""} {
- if {[.data.t item [.data.t parent $c] -open]} {
- lappend value_queue $c
- }
- } else {
- .data.t delete [.data.t children $c]
- }
- }
-
- if {$i < $clen} {
- .data.t delete [lrange $cs $i end]
- }
-}
-
-
-proc UpdateValueText {node} {
- global value_cutoff_limit
- set cs [.data.t children $node]
-
- foreach c $cs {
- UpdateValueText $c
- }
-
- if {$node == ""} return
-
- set addr [.data.t set $node 1]
-
- if {$addr == ""} return
-
- set type [.data.t item $node -text]
-
- if {$type == ":"} return
-
- set str "..."
-
- switch $type {
- "" return
- "<arguments>" return
- "<native pointer>" return
- FLONUM return
- LAMBDA_INFO return
- STRING return
- PAIR {
- set car [.data.t set [lindex $cs 0] 0]
- set cdr [.data.t set [lindex $cs 1] 0]
- set str "($car"
-
- switch [.data.t item [lindex $cs 1] -text] {
- NULL {append str ")"}
- PAIR {append str " [string range $cdr 1 end]"}
- default {append str " . $cdr)"}
- }
- }
- VECTOR {
- if {$cs == ""} {
- set str "#()"
- } else {
- set x0 [.data.t set [lindex $cs 0] 0]
- set str "#($x0"
-
- foreach c [lrange $cs 1 end] {
- set x [.data.t set $c 0]
- append str " $x"
- }
-
- append str ")"
- }
- }
- SYMBOL {
- set name [.data.t set [lindex $cs 1] 0]
- set str [DemangleSymbol [string range $name 1 "end-1"]]
- }
- default {
- set str "#<$type $addr>"
- }
- }
-
- if {[string length $str] >= $value_cutoff_limit} {
- set str "[string range $str 0 $value_cutoff_limit]..."
- }
-
- .data.t set $node 0 $str
-}
-
-
-proc OpenDataItem {} {
- global value_queue listening
- set item [.data.t focus]
-
- if {$item == ""} return
-
- if {!$listening} return
-
- if {[.data.t parent $item] == ""} return
-
- set cs [.data.t children $item]
-
- foreach c $cs {
- if {[.data.t set $c 1] != "" && \
- [.data.t item $c -text] != "<native pointer>"} {
- lappend value_queue $c
- }
- }
-
- GetValues
-}
-
-
-proc WatchGlobal {} {
- global data_queue watched_variables current_variable reply_queue
-
- if {![CheckListening]} return
-
- set name [string trim [.data.e get]]
- .data.e delete 0 end
-
- if {$name == ""} return
-
- if {[lsearch -exact $watched_variables $name] != -1} return
-
- set id [.data.t insert {} end -text $name]
- lappend watched_variables $id
- lappend data_queue GetGlobalData
- set current_variable $id
- set name [MangleSymbol $name]
- SendReply GET_GLOBAL "\"$name\""
- lappend reply_queue GetValues
-}
-
-
-proc RemoveGlobal {} {
- global watched_variables arguments_item_id
- set f [.data.t focus]
-
- if {$f == $arguments_item_id || [.data.t parent $f] == $arguments_item_id} return
-
- .data.t delete $f
-
- if {$f == ""} return
-
- set p [lsearch -exact $watched_variables $f]
- set watched_variables [lreplace $watched_variables $p $p]
-}
-
-
-proc GetGlobalData {data} {
- global current_variable watched_variables value_queue
-
- if {$data == "UNKNOWN"} {
- .data.t set $current_variable 0 "UNKNOWN"
- set p [lsearch -exact $watched_variables $current_variable]
- set watched_variables [lreplace $watched_variables $p $p]
- return
- }
-
- set node [.data.t children $current_variable]
-
- if {$node == ""} {
- set node [.data.t insert $current_variable end]
- .data.t item $current_variable -open 1
- }
-
- set val [ParseValueList $data]
- lassign [ValueData $val] type text addr
- .data.t item $node -text $type
- .data.t set $node 0 $text
- .data.t set $node 1 $addr
-
- if {$addr != ""} {
- lappend value_queue $node
- }
-}
-
-
-# returns type, text and address
-proc ValueData {val} {
- set c1 [string index $val 0]
- set rest [string range $val 1 end]
-
- switch $c1 {
- "@" {
- return [list "" "..." [format "0x%x" $rest]]
- }
- "=" {
- switch $rest {
- 6 {return {"BOOLEAN" "#f" ""}}
- 22 {return {"BOOLEAN" "#t" ""}}
- 14 {return {"NULL" "()" ""}}
- 30 {return {"UNDEFINED" "#<undefined>" ""}}
- 46 {return {"UNBOUND" "#<unbound>" ""}}
- 62 {return {"EOF" "#<eof>" ""}}
- default {
- if {($val & 15) == 10} {
- return [list "CHARACTER" [format "#\%c" [expr $val >> 8]] ""]
- }
-
- return [list "???" [format "#<unknown immediate value 0x%x>" \
- $val] ""]
- }
- }
- }
- default {return [list "FIXNUM" $val ""]}
- }
-}
-
-
-proc MangleSymbol {str} {
- if {[regexp {^##([^#]+)#(.+)$} $str _ prefix name]} {
- set len [string length $prefix]
- return [binary format ca*a* $len $prefix $name]
- }
-
- return $str
-}
-
-
-proc DemangleSymbol {str} {
- set b1 ""
- binary scan $str ca* b1 name
-
- if {$b1 == ""} {
- return $str
- } elseif {$b1 == 0} {
- return "#:$name"
- } elseif {$b1 < 32} {
- return [format "##%s#%s" [string range $name 0 2] [string range $name 3 end]]
- }
-
- return $str
-}
-
-
-proc ParseValueList {str} {
- set vals {}
-
- while {[regexp {^\s*(\S+)(.*)$} $str _ val rest]} {
- lappend vals $val
- set str $rest
- }
-
- return $vals
-}
-
-
-proc FirstStepReply {} {
- global stepping
- set stepping 0
- SendReply CONTINUE
-}
-
-
-proc ProcessData {data} {
- global data_queue
-
- if {$data_queue == ""} {
- UpdateHeader "unexpected data: $data"
- }
-
- set handler [lindex $data_queue 0]
- $handler $data
-}
-
-
-proc ExtractLocation args {
- foreach data $args {
- if {[regexp {^([^:]+):(\d+)(: .*)?$} $data _ fname line]} {
- return [list $fname $line]
- }
- }
-
- return ""
-}
-
-
-proc LocateFile {fname} {
- global search_path
-
- foreach d $search_path {
- set fn [file join $d $fname]
-
- if {[file exists $fn]} {
- set fn [file normalize $fn]
- Log "Located: $fn"
- return $fn
- }
- }
-
- return ""
-}
-
-
-proc InsertDebugInfo {index event args} {
- global file_list globals
- set loc [eval ExtractLocation $args]
-
- # check for assignment event
- if {$event == 1} {
- set name [lindex $args 1]
- lappend globals($name) $index
- }
-
- if {$loc != ""} {
- set fname [LocateFile [lindex $loc 0]]
-
- if {[lsearch -exact $file_list $fname] == -1} {
- lappend file_list $fname
- }
-
- set line [lindex $loc 1]
- # icky: compute array variable name from filename:
- set tname "file:$fname"
- global $tname
- set xname "$tname\($line\)"
- lappend $xname $index
- return 1
- }
-
- return 0
-}
-
-proc ProcessString {str} {
- if {$str == "#f"} {
- return ""
- } elseif {[regexp {^"(.*)"$} $str _ strip]} {
- return $strip
- } else {
- return $str
- }
-}
-
-proc FetchEventListReply {} {
- global file_list reply_queue data_queue
- UpdateHeader "fetching debug information ..."
- lappend data_queue EventInfoData
- SendReply LIST_EVENTS {""}
-}
-
-
-proc EventInfoData {data} {
- if {[regexp {(\d+)\s+(\d+)\s+([^\s]*)\s+(.*)$} $data _ index event loc val]} {
- set loc [ProcessString $loc]
- set val [ProcessString $val]
- InsertDebugInfo $index $event $loc $val
- } else {
- UpdateHeader "invalid event data: $data"
- }
-}
-
-
-proc ContinueExecution {} {
- global client_file EXEC_EVENT_MASK stepping reply_queue listening
- global value_queue
-
- if {$client_file == ""} return
-
- if {![CheckListening]} return
-
- UpdateHeader "executing ..."
-
- if {$stepping} {
- set stepping 0
- SendReply SETMASK $EXEC_EVENT_MASK
- lappend reply_queue ContinueExecution
- } else {
- set value_queue {}
- set listening 0
- SendReply CONTINUE
- }
-}
-
-
-proc StepExecution {} {
- global STEP_EVENT_MASK client_file stepping listening value_queue reply_queue
- global watched_queue
-
- if {$client_file == ""} return
-
- if {![CheckListening]} return
-
- if {!$stepping} {
- set stepping 1
- SendReply SETMASK $STEP_EVENT_MASK
- lappend reply_queue StepExecution
- } else {
- set value_queue {}
- set watched_queue {}
- set listening 0
- SendReply CONTINUE
- }
-
- UpdateHeader "stepping ..."
-}
-
-
-proc StartMark {w x y} {
- global mark_start_index last_marked_widget
- set mark_start_index($w) ""
- set last_marked_widget $w
- set old [$w tag ranges mk]
-
- if {$old != ""} {
- eval $w tag remove mk $old
- }
-
- if {![catch {$w index "@$x,$y"} pos]} {
- set mark_start_index($w) $pos
- }
-}
-
-
-proc EndMark {w} {
- global mark_start_index
- set rng [$w tag ranges mk]
-
- if {$rng != ""} {
- set text [eval $w get $rng]
- set len [string length $text]
- set found [$w search -all $text 1.0 end]
-
- foreach f $found {
- $w tag add mk $f "$f + $len chars"
- }
- }
-
- set mark_start_index($w) ""
-}
-
-
-proc MoveMark {w x y} {
- global mark_start_index
-
- if {$mark_start_index($w) == ""} return
-
- if {![catch {$w index "@$x,$y"} pos]} {
- if {$pos == $mark_start_index($w)} return
-
- set old [$w tag ranges mk]
-
- if {$old != ""} {
- eval $w tag remove $old
- }
-
- if {[$w compare $pos < $mark_start_index($w)]} {
- set tmp $mark_start_index($w)
- set mark_start_index($w) $pos
- set pos $tmp
- }
-
- $w tag add mk $mark_start_index($w) $pos
- }
-}
-
-
-proc FindNext {{w ""}} {
- global last_marked_widget
-
- if {$w == ""} {set w $last_marked_widget}
-
- # not sure if this test is needed
- if {[catch {$w index "@1,1"} pos]} return
-
- while 1 {
- set rng [$w tag nextrange mk $pos end]
-
- if {$rng == ""} return
-
- lassign $rng p1 pos
-
- if {[$w dlineinfo $p1] == ""} {
- $w see $p1
- return
- }
- }
-}
-
-
-proc FindPrevious {{w ""}} {
- global last_marked_widget
-
- if {$w == ""} {set w $last_marked_widget}
-
- # not sure if this test is needed
- if {[catch {$w index "@1,1"} pos]} return
-
- set rng [$w tag prevrange mk $pos 1.0]
-
- if {$rng == ""} return
-
- set p1 [lindex $rng 0]
- $w see $p1
-}
-
-
-proc SendReply {rep args} {
- global client_file reply
- set rest ""
-
- if {$args != ""} {
- set rest " [join $args]"
- }
-
- set str "($reply($rep)$rest)"
- Log "send: $str"
- puts $client_file $str
-}
-
-
-proc SelectFile {} {
- global current_filename selected_filename
-
- if {$current_filename == $selected_filename} return
-
- if {![LoadFile $selected_filename]} return
-
- if {[SwitchFile $selected_filename]} ApplyTags
-}
-
-
-proc OpenFile {} {
- global current_filename file_list
- set dir "."
-
- if {$current_filename != ""} {
- set dir [file dirname $current_filename]
- }
-
- set fname [tk_getOpenFile -title "Select source file" -initialdir $dir]
- set fname [file normalize $fname]
-
- if {$fname == "" || $fname == $current_filename} return
-
- if {[lsearch -exact $file_list $fname] == -1} {
- tk_messageBox -message "No debug information available for \"$fname\"" \
- -type ok
- return
- }
-
- if {![LoadFile $fname]} return
-
- if {[SwitchFile $fname]} ApplyTags
-}
-
-
-proc SwitchFile {fname} {
- global current_bp_lines saved_bp_lines file_list current_filename
-
- Log "switch: $current_filename -> $fname"
-
- if {$current_filename != ""} {
- Log "saving bps: $current_bp_lines"
- set saved_bp_lines($current_filename) $current_bp_lines
- }
-
- set current_filename $fname
- Log "searching $fname in $file_list"
-
- if {[lsearch -exact $file_list $fname] != -1} {
- if {[info exists saved_bp_lines($fname)]} {
- set current_bp_lines {}
- foreach line $saved_bp_lines($fname) {MarkBP $line}
- Log "restoring bps: $current_bp_lines"
- } else {
- set current_bp_lines {}
- }
-
- return 1
- }
-
- return 0
-}
-
-
-proc LocateEvent {loc val} {
- global current_filename file_list saved_bp_lines search_path last_location
- set loc [ExtractLocation $loc $val]
-
- if {$loc != ""} {
- set fname0 [lindex $loc 0]
- set fname [LocateFile [lindex $loc 0]]
- set line [lindex $loc 1]
-
- if {$fname != $current_filename} {
- if {![LoadFile $fname]} return
-
- if {[SwitchFile $fname]} ApplyTags
- }
-
- set last_location $line
- SetFocus $line
- }
-}
-
-
-proc LocateCSource {cloc} {
- global current_c_filename search_path
- set loc [ExtractLocation $cloc]
-
- if {$loc != ""} {
- .code.h configure -text $cloc
- set fname [file normalize [lindex $loc 0]]
- set line [lindex $loc 1]
-
- if {$fname != $current_c_filename} {
- foreach d $search_path {
- set fn [file join $d $fname]
-
- if {[file exists $fn]} {
- set fname $fn
- break
- }
- }
-
- if {![LoadFile $fname .code.t]} return
- }
-
- SetCFocus $line
- }
-}
-
-
-proc LoadFile {fname {w .t}} {
- $w configure -state normal
- $w delete 1.0 end
-
- if {[file exists $fname]} {
- set f [open $fname]
- $w insert 1.0 [read $f]
- close $f
- $w configure -state disabled
- return 1
- } else {
- $w insert 1.0 "File not found: \"$fname\""
- $w configure -state disabled
- return 0
- }
-}
-
-
-proc ApplyTags {} {
- global current_filename
- set aname "file:$current_filename"
- global $aname
- set old [.t tag ranges ev]
- Log "apply tags: $current_filename"
-
- if {$old != ""} {
- eval .t tag remove $old
- }
-
- foreach line [array names $aname] {
- set evts [set $aname\($line\)]
- .t tag add ev $line.0 "$line.0 lineend + 1 chars"
- }
-
- UpdateHeader "events tagged"
-}
-
-
-proc Server {channel addr port} {
- global client_addr client_file
-
- if {$client_file != ""} {
- close $channel
- return
- }
-
- fconfigure $channel -buffering line -encoding binary -blocking 0
- fileevent $channel readable ProcessInput
- set client_addr $addr
- set client_file $channel
-}
-
-
-proc SetupServer {} {
- global debugger_port
- socket -server Server $debugger_port
- .t configure -state normal
- .t insert end "Waiting for connection from client ...\n"
- .t configure -state disabled
-}
-
-
-proc Usage {code} {
- global the_name
- set usage "Usage: $the_name "
- append usage {[-help] [-n] [-d] [-dir DIRNAME] [-port PORT] [PROGRAM ARGUMENTS ...]}
- puts stderr $usage
- exit $code
-}
-
-
-set load_startup_file 1
-
-for {set i 0} {$i < $argc} {incr i} {
- set arg [lindex $argv $i]
-
- switch -regexp -- $arg {
- {^--?(h|help)$} {Usage 0}
- {^-dir$} {
- incr i
- lappend search_path [lindex $argv $i]
- }
- {^-n$} {set load_startup_file 0}
- {^-port$} {
- incr i
- set debugger_port [lindex $argv $i]
- }
- {^-d$} {set logging 1}
- {^-} {Usage 1}
- default {
- if {$program_name != ""} {Usage 0}
-
- set program_name [lrange $argv $i end]
- break
- }
- }
-}
-
-
-if {$load_startup_file} {
- if {[file exists $env(HOME)/$startup_file]} {
- source $env(HOME)/$startup_file
- }
-
- if {[file exists $startup_file]} {
- source $startup_file
- }
-}
-
-
-SetupGUI
-SetupBindings
-SetupServer
-
-if {$program_name != ""} {
- RunProcess $program_name
-}
-
-
-# TODO:
-#
-# - F2 is mostly pointless
-# - data-view update is slow
-# - modify only when necessary? or are we creating too many items on the fly?
-# - or too much TCP-traffic?
-# - allow spawning gdb, probably in separate terminal window(?)
-# - may be covered by just running "gdb <program>" as client
-# - setting breakpoints on yet unregistered (i.e. dynamically loaded) files
-# is not possible - a file must be registered first
-# - check whether "listening" check works
-# - when retrieved data is wrong, clear queues
-# - must watched globals be mangled, when qualified? (GET_GLOBAL)
-# - dview: monospace font (needs tags, it seems)
-# - https://sourceware.org/gdb/current/onlinedocs/gdb/GDB_002fMI.html#GDB_002fMI
-# - gdb interface:
-# - toggle bp in C-source line, step/execute
-# - needs a way to trigger gdb from running program (in dbg-stub.c)
-# (send signal to self (SIGUSR2?))
-# - allow explicit connection to debugger from Scheme code
-# - multiple dbg-info for identical filenames will cause havoc
-# - interrupt takes rather long (was in bignum-heavy code, try other)
-# - bignums are shown as raw strings (uses string-type for bitvec)
-# - how to handle threads?
diff --git a/file.scm b/file.scm
index 3448ec65..2a212292 100644
--- a/file.scm
+++ b/file.scm
@@ -73,7 +73,7 @@
#define C_closedir(h) (closedir((DIR *)C_block_item(h, 0)), C_SCHEME_UNDEFINED)
#define C_foundfile(e,b,l) (C_strlcpy(C_c_string(b), ((struct dirent *) C_block_item(e, 0))->d_name, l), C_fix(strlen(((struct dirent *) C_block_item(e, 0))->d_name)))
-static C_word C_fcall C_u_i_symbolic_linkp(C_word path)
+static C_word C_u_i_symbolic_linkp(C_word path)
{
#if !defined(_WIN32) || defined(__CYGWIN__)
struct stat buf;
@@ -154,7 +154,7 @@ EOF
(define (directory #!optional (spec (current-directory)) show-dotfiles?)
(##sys#check-string spec 'directory)
- (let ((buffer (make-string 256))
+ (let ((buffer (##sys#make-bytevector 256))
(handle (##sys#make-pointer))
(entry (##sys#make-pointer)))
(##core#inline
@@ -166,8 +166,8 @@ EOF
(##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 (string-length buffer)))
- (file (##sys#substring buffer 0 flen))
+ (let* ((flen (##core#inline "C_foundfile" entry buffer (##sys#size buffer)))
+ (file (##sys#buffer->string buffer 0 flen))
(char1 (string-ref file 0))
(char2 (and (fx> flen 1) (string-ref file 1))))
(if (and (eq? #\. char1)
@@ -187,7 +187,7 @@ EOF
(define create-directory
(lambda (name #!optional recursive)
(##sys#check-string name 'create-directory)
- (unless (or (fx= 0 (##sys#size name))
+ (unless (or (fx= 0 (string-length name))
(file-exists? name))
(if recursive
(let loop ((dir (let-values (((dir file ext) (decompose-pathname name)))
@@ -260,8 +260,8 @@ EOF
(##sys#error 'copy-file "newfile exists but clobber is false" newfile))
(let* ((i (open-input-file oldfile #:binary))
(o (open-output-file newfile #:binary))
- (s (make-string blocksize)))
- (let loop ((d (read-string! blocksize s i))
+ (s (##sys#make-bytevector blocksize)))
+ (let loop ((d (read-bytevector! s i))
(l 0))
(if (fx= 0 d)
(begin
@@ -269,8 +269,8 @@ EOF
(close-output-port o)
l)
(begin
- (write-string s d o)
- (loop (read-string! blocksize s i) (fx+ d l)))))))
+ (write-bytevector s o 0 d)
+ (loop (read-bytevector! s i) (fx+ d l)))))))
(define (move-file oldfile newfile #!optional (clobber #f) (blocksize 1024))
(##sys#check-string oldfile 'move-file)
@@ -284,8 +284,8 @@ EOF
(##sys#error 'move-file "newfile exists but clobber is false" newfile))
(let* ((i (open-input-file oldfile #:binary))
(o (open-output-file newfile #:binary))
- (s (make-string blocksize)))
- (let loop ((d (read-string! blocksize s i))
+ (s (##sys#make-bytevector blocksize)))
+ (let loop ((d (read-bytevector! s i))
(l 0))
(if (fx= 0 d)
(begin
@@ -294,8 +294,8 @@ EOF
(delete-file oldfile)
l)
(begin
- (write-string s d o)
- (loop (read-string! blocksize s i) (fx+ d l)))))))
+ (write-bytevector s o 0 d)
+ (loop (read-bytevector! s i) (fx+ d l)))))))
;;; Temporary file creation:
diff --git a/identify.sh b/identify.sh
index 23912a29..a1e8ae00 100755
--- a/identify.sh
+++ b/identify.sh
@@ -1,4 +1,4 @@
-#!/bin/sh -e
+#!/bin/sh
#
# identify.sh - check for .git directory and obtain checked out revision and branch
#
diff --git a/internal.scm b/internal.scm
index e523f40d..56d5b967 100644
--- a/internal.scm
+++ b/internal.scm
@@ -57,6 +57,7 @@
default-imports default-syntax-imports)
(import scheme chicken.base chicken.fixnum)
+(import (only (scheme base) open-output-string get-output-string))
(include "common-declarations.scm")
(include "mini-srfi-1.scm")
@@ -96,7 +97,7 @@
(eq? 'srfi (car x))
(fixnum? (cadr x))))
(define (library-part->string x)
- (cond ((symbol? x) (##sys#symbol->string x))
+ (cond ((symbol? x) (##sys#symbol->string/shared x))
((fixnum? x) (##sys#number->string x))
(else (fail))))
(cond
@@ -104,21 +105,21 @@
((null? lib) (fail))
((not (list? lib)) (fail))
((srfi? lib)
- (##sys#intern-symbol
+ (##sys#string->symbol
(##sys#string-append "srfi-" (##sys#number->string (cadr lib)))))
(else
(do ((lst (cdr lib) (cdr lst))
(str (library-part->string (car lib))
(string-append str "." (library-part->string (car lst)))))
((null? lst)
- (##sys#intern-symbol str))))))
+ (##sys#string->symbol str))))))
;;; Requirement identifier for modules:
(define (module-requirement id)
(##sys#string->symbol
- (##sys#string-append (##sys#slot id 1) "#")))
+ (##sys#string-append (##sys#symbol->string/shared id) "#")))
;;; Check for multiple bindings in "let"-style constructs:
@@ -145,6 +146,7 @@
(cons (car me) (loop (cdr me)))))))
(fixup-macro-environment se parent-env)))
+;;XXX clarify what this does!
(define (fixup-macro-environment se #!optional parent-env)
(let ((se2 (if parent-env (##sys#append se parent-env) se)))
(for-each ; fixup se
@@ -169,23 +171,23 @@
(lambda (s n)
(if (eq? s cache-s)
(##core#inline "C_fixnum_modulo" cache-h n)
- (begin
+ (let ((bv (##sys#slot s 1)))
(set! cache-s s)
- (set! cache-h (##core#inline "C_u_i_string_hash" (##sys#slot s 1) rand))
+ (set! cache-h (##core#inline "C_u_i_bytevector_hash" bv 0 (fx- (##sys#size bv) 1) rand))
(##core#inline "C_fixnum_modulo" cache-h n))))))
(define (make-hash-table #!optional (size 301))
(make-vector size '()))
(define (hash-table-ref ht key)
- (let loop ((bucket (##sys#slot ht (hash-symbol key (##core#inline "C_block_size" ht)))))
+ (let loop ((bucket (##sys#slot ht (hash-symbol key (##sys#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 (hash-table-set! ht key val)
- (let* ((k (hash-symbol key (##core#inline "C_block_size" ht)))
+ (let* ((k (hash-symbol key (##sys#size ht)))
(ib (##sys#slot ht k)))
(let loop ((bucket ib))
(if (eq? '() bucket)
diff --git a/irregex-core.scm b/irregex-core.scm
index 5550ace8..60882d5c 100644
--- a/irregex-core.scm
+++ b/irregex-core.scm
@@ -86,9 +86,12 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Data Structures
-(define (vector-copy v)
+(define %vector-copy scheme#vector-copy)
+(define (%vector-copy! from to) (scheme#vector-copy! to 0 from))
+
+(define (%vector-copy v)
(let ((v2 (make-vector (vector-length v))))
- (vector-copy! v v2)
+ (%vector-copy! v v2)
v2))
(cond-expand
@@ -129,7 +132,7 @@
(and (##sys#structure? m 'regexp-match)
(##sys#make-structure
'regexp-match
- (vector-copy (##sys#slot m 1))
+ (%vector-copy (##sys#slot m 1))
(##sys#slot m 2)
(##sys#slot m 3)
(##sys#slot m 4))))
@@ -193,7 +196,7 @@
((<= i 3) m)
(vector-set! m i #f)))
(define (irregex-copy-matches m)
- (and (vector? m) (vector-copy m)))
+ (and (vector? m) (%vector-copy m)))
(define irregex-match-tag '*irregex-match-tag*)
(define (irregex-match-data? obj)
(and (vector? obj)
@@ -2689,7 +2692,7 @@
;; (cset-contains? (car t) (car ls))
;; (lp (+ pos 1) (cdr ls) (cdr t) '())))
;; (any (lambda (e)
-;; (let ((old-matches (vector-copy matches)))
+;; (let ((old-matches (%vector-copy matches)))
;; (cond ((cdr e)
;; (vector-set! matches (cdr e) pos)))
;; (or (and (not (memv (car e) epsilons))
@@ -2749,8 +2752,8 @@
;; NOTE: This doesn't do a deep copy of the mappings. Don't mutate them!
(define (mst-copy mst)
- (let ((v (vector-copy mst)))
- (vector-set! v 0 (vector-copy (vector-ref mst 0)))
+ (let ((v (%vector-copy mst)))
+ (vector-set! v 0 (%vector-copy (vector-ref mst 0)))
v))
(define (nfa-state->mst nfa state mappings)
diff --git a/irregex.scm b/irregex.scm
index 40e47b29..505a96bc 100644
--- a/irregex.scm
+++ b/irregex.scm
@@ -60,6 +60,7 @@
(import scheme chicken.base chicken.fixnum chicken.syntax chicken.type)
+(import (only (scheme base) open-output-string get-output-string))
(import-for-syntax chicken.fixnum)
@@ -115,22 +116,11 @@
(##sys#slot ,%cache ,(add1 (* i 2)))
,(fold (add1 i))))))))))
-(declare (unused %%string-copy!))
-(define-compiler-syntax %%string-copy!
- (syntax-rules ()
- ((_ to tstart from fstart fend)
- (let ((x to)
- (y tstart)
- (z from)
- (u fstart)
- (v fend))
- (##core#inline "C_substring_copy" z x u v y)))))
-
(declare (unused %substring=?))
(define-compiler-syntax %substring=?
(syntax-rules ()
((_ a b start1 start2 len)
- (##core#inline "C_substring_compare" a b start1 start2 len))))
+ (##core#inline "C_u_i_substring_equal_p" a b start1 start2 len))))
(define-compiler-syntax make-irregex
(syntax-rules ()
@@ -221,6 +211,8 @@
(include "irregex-core.scm")
(include "irregex-utils.scm")
+(set! *allow-utf8-mode?* #f)
+
(define glob->sre
(let ((list->string list->string)
(string->list string->list))
diff --git a/lfa2.scm b/lfa2.scm
index 11555c1b..1acf1a3e 100644
--- a/lfa2.scm
+++ b/lfa2.scm
@@ -60,7 +60,7 @@
("C_i_check_inexact" float) ; Or an inexact cplxnum...
("C_i_check_number" fixnum integer bignum ratnum float cplxnum number)
("C_i_check_string" string)
- ("C_i_check_bytevector" blob)
+ ("C_i_check_bytevector" bytevector)
("C_i_check_symbol" symbol)
("C_i_check_keyword" keyword)
("C_i_check_list" null pair list)
@@ -75,7 +75,7 @@
("C_i_check_inexact_2" float) ; Or an inexact cplxnum...
("C_i_check_number_2" fixnum integer bignum ratnum float cplxnum number)
("C_i_check_string_2" string)
- ("C_i_check_bytevector_2" blob)
+ ("C_i_check_bytevector_2" bytevector)
("C_i_check_symbol_2" symbol)
("C_i_check_keyword_2" keyword)
("C_i_check_list_2" null pair list)
@@ -99,7 +99,7 @@
("C_i_ratnump" ratnum)
("C_i_cplxnump" cplxnum)
("C_stringp" string)
- ("C_bytevectorp" blob)
+ ("C_bytevectorp" bytevector)
("C_i_keywordp" keyword)
("C_i_symbolp" symbol)
("C_i_listp" list)
@@ -146,7 +146,7 @@
("C_a_i_vector7" vector)
("C_a_i_vector8" vector)
("C_a_pair" pair)
- ("C_a_i_bytevector" blob)
+ ("C_a_i_bytevector" bytevector)
("C_a_i_make_locative" locative)
("C_a_i_vector" vector)
("C_a_i_list1" pair)
@@ -267,8 +267,7 @@
((list? lit) 'list)
((pair? lit) 'pair)
((eof-object? lit) 'eof)
- ;; TODO: Remove once we have a bootstrapping libchicken with bwp-object?
- ((##core#inline "C_bwpp" lit) #;(bwp-object? lit) 'bwp)
+ ((bwp-object? lit) 'bwp)
((vector? lit) 'vector)
((and (not (##sys#immediate? lit)) (##sys#generic-structure? lit))
`(struct ,(##sys#slot lit 0)))
diff --git a/library.scm b/library.scm
index 4a8a2d33..a5446499 100644
--- a/library.scm
+++ b/library.scm
@@ -1,4 +1,4 @@
-;;;; library.scm - R5RS library for the CHICKEN compiler
+;;;; library.scm - R5RS/R7RS library for the CHICKEN compiler
;
; Copyright (c) 2008-2022, The CHICKEN Team
; Copyright (c) 2000-2007, Felix L. Winkelmann
@@ -8,11 +8,11 @@
; conditions are met:
;
; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-; disclaimer.
+; 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.
+; 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.
+; 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
@@ -30,9 +30,9 @@
(uses build-version)
(disable-interrupts)
(hide ##sys#dynamic-unwind
- ##sys#vector-resize ##sys#default-parameter-vector
+ ##sys#vector-resize ##sys#default-parameter-vector
current-print-length setter-tag
- ##sys#print-exit
+ ##sys#print-exit ##sys#r7rs-exn-handlers
##sys#format-here-doc-warning
exit-in-progress cleanup-before-exit chicken.base#cleanup-tasks
maximal-string-length find-ratio-between find-ratio
@@ -69,6 +69,8 @@
#define C_a_get_current_seconds(ptr, c, dummy) C_int64_to_num(ptr, time(NULL))
#define C_peek_c_string_at(ptr, i) ((C_char *)(((C_char **)ptr)[ i ]))
+#define C_utf_bytes_needed(b) C_fix(C_utf_expect(C_unfix(b)))
+
static C_word
fast_read_line_from_file(C_word str, C_word port, C_word size) {
int n = C_unfix(size);
@@ -111,7 +113,7 @@ fast_read_string_from_file(C_word dest, C_word port, C_word len, C_word pos)
{
size_t m;
int n = C_unfix (len);
- char * buf = ((char *)C_data_pointer (dest) + C_unfix (pos));
+ C_char * buf = C_c_string(dest) + C_unfix(pos);
C_FILEPTR fp = C_port_file (port);
if(feof(fp)) return C_SCHEME_END_OF_FILE;
@@ -134,7 +136,7 @@ shallow_equal(C_word x, C_word y)
/* assumes x and y are non-immediate */
int i, len = C_header_size(x);
- if(C_header_size(y) != len) return C_SCHEME_FALSE;
+ if(C_header_size(y) != len) return C_SCHEME_FALSE;
else return C_mk_bool(!C_memcmp((void *)x, (void *)y, len * sizeof(C_word)));
}
@@ -153,13 +155,13 @@ signal_debug_event(C_word mode, C_word msg, C_word args)
C_debugger(&cell, 3, av);
return C_SCHEME_UNDEFINED;
}
-
+
static C_word C_i_sleep_until_interrupt(C_word secs)
{
while(C_i_process_sleep(secs) == C_fix(-1) && errno == EINTR);
return C_SCHEME_UNDEFINED;
}
-
+
#ifdef NO_DLOAD2
# define HAVE_DLOAD 0
#else
@@ -215,7 +217,7 @@ EOF
if let let* let-syntax letrec letrec-syntax or
quasiquote quote set! syntax-rules
- not boolean? eq? eqv? equal? pair?
+ not boolean? eq? eqv? equal? pair? boolean=? symbol=?
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
@@ -234,11 +236,11 @@ EOF
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-length string-ref string-set! string-append string-copy 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?
+ call-with-current-continuation call/cc 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
@@ -247,6 +249,15 @@ EOF
char-ready? imag-part real-part make-rectangular make-polar angle
magnitude numerator denominator values call-with-values dynamic-wind
+ open-input-string open-output-string open-input-bytevector
+ open-output-bytevector get-output-string get-output-bytevector
+ features make-list port? call-with-port peek-u8 make-parameter
+ string-map vector-map string-for-each vector-for-each
+ make-list list-set! write-string eof-object list-copy
+ string->vector vector->string textual-port? binary-port?
+ input-port-open? output-port-open? floor/ truncate/
+ exact inexact floor-remainder floor-quotient close-port
+
;; The following procedures are overwritten in eval.scm:
eval interaction-environment null-environment
scheme-report-environment load)
@@ -265,6 +276,28 @@ EOF
(define (eqv? x y) (##core#inline "C_i_eqvp" x y))
(define (equal? x y) (##core#inline "C_i_equalp" x y))
+(define (boolean=? x y . more)
+ (##sys#check-boolean x 'boolean=?)
+ (##sys#check-boolean y 'boolean=?)
+ (let loop ((bs more) (f (eq? x y)))
+ (if (null? bs)
+ f
+ (let ((b (##sys#slot bs 0)))
+ (##sys#check-boolean b 'boolean=?)
+ (loop (##sys#slot bs 1)
+ (and f (eq? b y)))))))
+
+(define (symbol=? x y . more)
+ (##sys#check-symbol x 'symbol=?)
+ (##sys#check-symbol y 'symbol=?)
+ (let loop ((bs more) (f (eq? x y)))
+ (if (null? bs)
+ f
+ (let ((b (##sys#slot bs 0)))
+ (##sys#check-symbol b 'symbol=?)
+ (loop (##sys#slot bs 1)
+ (and f (eq? b y)))))))
+
;;; Pairs and lists:
@@ -322,10 +355,27 @@ EOF
(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 (member x lst #!optional eq)
+ (if eq
+ (let loop ((lst lst))
+ (and (pair? lst)
+ (if (eq x (##sys#slot lst 0))
+ lst
+ (loop (##sys#slot lst 1)))))
+ (##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 (assoc x lst #!optional eq)
+ (if eq
+ (let loop ((lst lst))
+ (and (pair? lst)
+ (if (eq x (car (##sys#slot lst 0)))
+ (car lst)
+ (loop (##sys#slot lst 1)))))
+ (##core#inline "C_i_assoc" x lst)))
(define (list? x) (##core#inline "C_i_listp" x))
@@ -338,15 +388,28 @@ EOF
(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 (string=? x y)
- (##core#inline "C_i_string_equal_p" x y))
-
-(define (string-ci=? x y) (##core#inline "C_i_string_ci_equal_p" x y))
+(define (string=? x y . more)
+ (let loop ((s y) (ss more) (f (##core#inline "C_i_string_equal_p" x y)))
+ (if (null? ss)
+ f
+ (let ((s2 (##sys#slot ss 0)))
+ (##sys#check-string s2 'string=?)
+ (loop s2 (##sys#slot ss 1)
+ (and f (##core#inline "C_i_string_equal_p" s s2)))))))
+
+(define (string-ci=? x y . more)
+ (let loop ((s y) (ss more) (f (##core#inline "C_i_string_ci_equal_p" x y)))
+ (if (null? ss)
+ f
+ (let ((s2 (##sys#slot ss 0)))
+ (##sys#check-string s2 'string-ci=?)
+ (loop s2 (##sys#slot ss 1)
+ (and f (##core#inline "C_i_string_ci_equal_p" s s2)))))))
(define string->list)
(define list->string)
-(define string-fill)
(define string-copy)
+(define string-copy!)
(define substring)
(define string-fill!)
@@ -363,6 +426,39 @@ EOF
(define string)
(define string-append)
+(define open-input-string)
+(define open-output-string)
+(define open-input-bytevector)
+(define open-output-bytevector)
+(define get-output-string)
+(define get-output-bytevector)
+(define features)
+(define make-list)
+(define port?)
+(define call-with-port)
+(define close-port)
+(define peek-u8)
+(define string-map)
+(define vector-map)
+(define string-for-each)
+(define vector-for-each)
+(define make-list)
+(define list-set!)
+(define write-string)
+(define eof-object)
+(define list-copy)
+(define string->vector)
+(define vector->string)
+(define input-port-open?)
+(define output-port-open?)
+(define floor/)
+(define truncate/)
+(define exact)
+(define inexact)
+(define floor-remainder)
+(define floor-quotient)
+(define make-parameter)
+
;; Complex numbers
(define make-rectangular)
(define make-polar)
@@ -432,6 +528,7 @@ EOF
(define number->string (##core#primitive "C_number_to_string"))
(define string->number)
+
;;; Symbols:
(define (symbol? x) (##core#inline "C_i_symbolp" x))
@@ -453,6 +550,7 @@ EOF
;;; 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)) )
@@ -461,11 +559,65 @@ EOF
(##sys#check-fixnum n 'integer->char)
(##core#inline "C_make_character" (##core#inline "C_unfix" n)) )
-(define (char=? c1 c2) (##core#inline "C_i_char_equalp" c1 c2))
-(define (char>? c1 c2) (##core#inline "C_i_char_greaterp" c1 c2))
-(define (char<? c1 c2) (##core#inline "C_i_char_lessp" c1 c2))
-(define (char>=? c1 c2) (##core#inline "C_i_char_greater_or_equal_p" c1 c2))
-(define (char<=? c1 c2) (##core#inline "C_i_char_less_or_equal_p" c1 c2))
+(define (char=? c1 c2 . more)
+ (##sys#check-char c1 'char=?)
+ (##sys#check-char c2 'char=?)
+ (let loop ((c c2) (cs more)
+ (f (##core#inline "C_u_i_char_equalp" c1 c2)))
+ (if (null? cs)
+ f
+ (let ((c2 (##sys#slot cs 0)))
+ (##sys#check-char c2 'char=?)
+ (loop c2 (##sys#slot cs 1)
+ (and f (##core#inline "C_u_i_char_equalp" c c2)))))))
+
+(define (char>? c1 c2 . more)
+ (##sys#check-char c1 'char>?)
+ (##sys#check-char c2 'char>?)
+ (let loop ((c c2) (cs more)
+ (f (##core#inline "C_u_i_char_greaterp" c1 c2)))
+ (if (null? cs)
+ f
+ (let ((c2 (##sys#slot cs 0)))
+ (##sys#check-char c2 'char>?)
+ (loop c2 (##sys#slot cs 1)
+ (and f (##core#inline "C_u_i_char_greaterp" c c2)))))))
+
+(define (char<? c1 c2 . more)
+ (##sys#check-char c1 'char<?)
+ (##sys#check-char c2 'char<?)
+ (let loop ((c c2) (cs more)
+ (f (##core#inline "C_u_i_char_lessp" c1 c2)))
+ (if (null? cs)
+ f
+ (let ((c2 (##sys#slot cs 0)))
+ (##sys#check-char c2 'char<?)
+ (loop c2 (##sys#slot cs 1)
+ (and f (##core#inline "C_u_i_char_lessp" c c2)))))))
+
+(define (char>=? c1 c2 . more)
+ (##sys#check-char c1 'char>=?)
+ (##sys#check-char c2 'char>=?)
+ (let loop ((c c2) (cs more)
+ (f (##core#inline "C_u_i_char_greater_or_equal_p" c1 c2)))
+ (if (null? cs)
+ f
+ (let ((c2 (##sys#slot cs 0)))
+ (##sys#check-char c2 'char>=?)
+ (loop c2 (##sys#slot cs 1)
+ (and f (##core#inline "C_u_i_char_greater_or_equal_p" c c2)))))))
+
+(define (char<=? c1 c2 . more)
+ (##sys#check-char c1 'char<=?)
+ (##sys#check-char c2 'char<=?)
+ (let loop ((c c2) (cs more)
+ (f (##core#inline "C_u_i_char_less_or_equal_p" c1 c2)))
+ (if (null? cs)
+ f
+ (let ((c2 (##sys#slot cs 0)))
+ (##sys#check-char c2 'char<=?)
+ (loop c2 (##sys#slot cs 1)
+ (and f (##core#inline "C_u_i_char_less_or_equal_p" c c2)))))))
(define (char-upcase c)
(##sys#check-char c 'char-upcase)
@@ -501,6 +653,12 @@ EOF
(##sys#check-char c 'char-alphabetic?)
(##core#inline "C_u_i_char_alphabeticp" c) )
+(define (scheme.char#digit-value c)
+ (##sys#check-char c 'digit-value)
+ (let ((n (##core#inline "C_u_i_digit_value" c)))
+ (and (not (eq? n 0))
+ (##core#inline "C_fixnum_difference" n 1))))
+
;;; Procedures:
(define (procedure? x) (##core#inline "C_i_closurep" x))
@@ -508,6 +666,7 @@ EOF
(define values (##core#primitive "C_values"))
(define call-with-values (##core#primitive "C_call_with_values"))
(define call-with-current-continuation)
+(define call/cc)
;;; Ports:
@@ -519,6 +678,29 @@ EOF
(and (##core#inline "C_blockp" x)
(##core#inline "C_output_portp" x)))
+(define (binary-port? port)
+ (and (port? port)
+ (eq? 'binary (##sys#slot port 14))))
+
+(define (textual-port? port)
+ (and (port? port)
+ (eq? 'textual (##sys#slot port 14))))
+
+(set! scheme#port?
+ (lambda (x)
+ (and (##core#inline "C_blockp" x)
+ (##core#inline "C_portp" x))))
+
+(set! scheme#input-port-open?
+ (lambda (p)
+ (##sys#check-input-port p 'input-port-open?)
+ (##core#inline "C_input_port_openp" p)))
+
+(set! scheme#output-port-open?
+ (lambda (p)
+ (##sys#check-output-port p 'output-port-open?)
+ (##core#inline "C_output_port_openp" p)))
+
(define current-input-port)
(define current-output-port)
(define open-input-file)
@@ -575,6 +757,7 @@ EOF
) ; scheme
(import scheme)
+(import (only (scheme base) make-parameter open-output-string get-output-string))
;; Pre-declaration of chicken.base, so it can be used later on. Much
;; like the "scheme" module, most declarations will be set! further
@@ -583,27 +766,29 @@ EOF
(module chicken.base
(;; [syntax] and-let* case-lambda cut cute declare define-constant
;; define-inline define-record define-record-type
- ;; define-record-printer define-values delay-force fluid-let include
+ ;; define-values delay-force fluid-let include
;; include-relative let-optionals let-values let*-values letrec*
;; letrec-values nth-value optional parameterize rec receive
;; require-library require-extension set!-values syntax unless when
bignum? flonum? fixnum? ratnum? cplxnum? finite? infinite? nan?
exact-integer? exact-integer-sqrt exact-integer-nth-root
- port? port-closed? input-port-open? output-port-open? flush-output
- get-output-string open-input-string open-output-string
- get-call-chain print print* add1 sub1 sleep call/cc
+ port-closed? flush-output
+ get-call-chain print print* add1 sub1 sleep
current-error-port error void gensym print-call-chain
- make-promise promise? char-name enable-warnings
- equal=? finite? foldl foldr getter-with-setter make-parameter
+ char-name enable-warnings
+ equal=? finite? foldl foldr getter-with-setter
notice procedure-information setter signum string->uninterned-symbol
- subvector symbol-append vector-copy! vector-resize
+ subvector symbol-append vector-resize
warning quotient&remainder quotient&modulo
record-printer set-record-printer!
+ make-promise promise?
alist-ref alist-update alist-update! rassoc atom? butlast chop
compress flatten intersperse join list-of? tail? constantly
complement compose conjoin disjoin each flip identity o
+ char-foldcase string-foldcase
+
case-sensitive keyword-style parentheses-synonyms symbol-escape
on-exit exit exit-handler implicit-exit-handler emergency-exit
@@ -659,12 +844,10 @@ EOF
(define sleep)
-(define call/cc)
(define char-name)
(define enable-warnings)
; (define enable-notices)???
(define getter-with-setter)
-(define make-parameter)
(define procedure-information)
(define setter)
(define string->uninterned-symbol)
@@ -673,7 +856,6 @@ EOF
(define gensym)
-(define vector-copy!)
(define subvector)
(define vector-resize)
@@ -681,13 +863,7 @@ EOF
(define warning)
(define notice)
-(define port?)
(define port-closed?)
-(define input-port-open?)
-(define output-port-open?)
-(define get-output-string)
-(define open-input-string)
-(define open-output-string)
(define flush-output)
;;; Promises:
@@ -894,6 +1070,21 @@ EOF
(else (loop (##sys#slot blst 1) (##sys#slot lst 1))) ) ) ) ) )
+;; case folding
+
+(define (char-foldcase c)
+ (##sys#check-char c 'char-foldcase)
+ (##core#inline "C_utf_char_foldcase" c))
+
+(define (string-foldcase str)
+ (##sys#check-string str 'string-foldcase)
+ (let* ((bv (##sys#slot str 0))
+ (n (##core#inline "C_fixnum_difference" (##sys#size bv) 1))
+ (buf (##sys#make-bytevector (##core#inline "C_fixnum_times" n 2)))
+ (len (##core#inline "C_utf_string_foldcase" bv buf n)))
+ (##sys#buffer->string buf 0 len)))
+
+
;;; Alists:
(define (alist-update! x y lst #!optional (cmp eqv?))
@@ -968,11 +1159,131 @@ EOF
(import chicken.base)
-(define-constant char-name-table-size 37)
(define-constant output-string-initial-size 256)
+
+(set! scheme#open-input-string
+ (lambda (string)
+ (##sys#check-string string 'open-input-string)
+ (let* ((port (##sys#make-port 1 ##sys#string-port-class "(string)" 'string))
+ (bv (##sys#slot string 0))
+ (len (##core#inline "C_fixnum_difference" (##sys#size bv) 1))
+ (bv2 (##sys#make-bytevector len)))
+ (##core#inline "C_copy_memory" bv2 bv len)
+ (##sys#setislot port 10 0)
+ (##sys#setislot port 11 len)
+ (##sys#setslot port 12 bv2)
+ port)))
+
+(set! scheme#open-output-string
+ (lambda ()
+ (let ((port (##sys#make-port 2 ##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-bytevector output-string-initial-size))
+ port)))
+
+(set! scheme#get-output-string
+ (lambda (port)
+ (##sys#check-output-port 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#buffer->string (##sys#slot port 12) 0 (##sys#slot port 10)))))
+
+(set! scheme#open-input-bytevector
+ (lambda (bv)
+ (let ((port (##sys#make-port 1 #f "(bytevector)" 'custom)))
+ (##sys#check-bytevector bv 'open-input-bytevector)
+ (##sys#setslot port 14 'binary)
+ (##sys#setslot
+ port
+ 2
+ (let ((index 0)
+ (bv-len (##sys#size bv)))
+ (vector (lambda (_) ; read-char
+ (if (eq? index bv-len)
+ #!eof
+ (let ((c (##core#inline "C_i_bytevector_ref" bv index)))
+ (set! index (##core#inline "C_fixnum_plus" index 1))
+ (integer->char c))))
+ (lambda (_) ; peek-char
+ (if (eq? index bv-len)
+ #!eof
+ ((##core#inline "C_i_bytevector_ref" bv index))))
+ #f ; write-char
+ #f ; write-bytevector
+ (lambda (_ _) ; close
+ (##sys#setislot port 8 #t))
+ #f ; flush-output
+ (lambda (_) ; char-ready?
+ (not (eq? index bv-len)))
+ (lambda (p n dest start) ; read-bytevector!
+ (let ((n2 (min n (##core#inline "C_fixnum_difference" bv-len index))))
+ (##core#inline "C_copy_memory_with_offset" dest bv start index n2)
+ (set! index (##core#inline "C_fixnum_plus" index n2))
+ n2))
+ #f ; read-line
+ #f))) ; read-buffered
+ port)))
+
+(set! scheme#open-output-bytevector
+ (lambda ()
+ (let ((port (##sys#make-port 2 #f "(bytevector)" 'custom))
+ (buffer (##sys#make-bytevector 256))
+ (index 0)
+ (size 256))
+ (define (add bv start end)
+ (let* ((len (##core#inline "C_fixnum_difference" end start))
+ (i2 (##core#inline "C_fixnum_plus" index len)))
+ (when (##core#inline "C_fixnum_greaterp" i2 size)
+ (let* ((sz2 (##core#inline "C_fixnum_times" size 2))
+ (bv2 (##sys#make-bytevector sz2)))
+ (##core#inline "C_copy_memory_with_offset" bv2 buffer 0 0 index)
+ (set! size sz2)
+ (set! buffer bv2)))
+ (##core#inline "C_copy_memory_with_offset" buffer bv index start len)
+ (set! index i2)))
+ (define (getter)
+ (let ((bv (##sys#make-bytevector index)))
+ (##core#inline "C_copy_memory_with_offset" bv buffer 0 0 index)
+ bv))
+ (##sys#setslot port 9 getter)
+ (##sys#setslot port 14 'binary)
+ (##sys#setslot
+ port
+ 2
+ (vector #f ; read-char
+ #f ; peek-char
+ (lambda (p c) ; write-char
+ (let* ((s (string c))
+ (bv (##sys#slot s 0)))
+ (add bv 0 (##core#inline "C_fixnum_difference" (##sys#size bv) 1))))
+ (lambda (p bv start end) ; write-bytevector
+ (add bv start end))
+ (lambda (_ _) ; close
+ (##sys#setislot port 8 #t))
+ #f ; flush-output
+ #f ; char-ready?
+ #f ; read-bytevector!
+ #f ; read-line
+ #f)) ; read-buffered
+ port)))
+
+(set! scheme#get-output-bytevector
+ (lambda (p)
+ (define (fail) (error 'get-output-bytevector "not an output-bytevector" p))
+ (##sys#check-port p 'get-output-bytevector)
+ (if (eq? (##sys#slot p 7) 'custom)
+ (let ((getter (##sys#slot p 9)))
+ (if (procedure? getter)
+ (getter)
+ (fail)))
+ (fail))))
+
+(define-constant char-name-table-size 37)
(define-constant read-line-buffer-initial-size 1024)
(define-constant default-parameter-vector-size 16)
-(define maximal-string-length (foreign-value "C_HEADER_SIZE_MASK" unsigned-long))
+(define maximal-string-length (- (foreign-value "C_HEADER_SIZE_MASK" unsigned-long) 1))
;;; Fixnum arithmetic:
@@ -1060,6 +1371,7 @@ EOF
(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 ##sys#allocate-bytevector (##core#primitive "C_allocate_bytevector"))
(define ##sys#make-structure (##core#primitive "C_make_structure"))
(define ##sys#ensure-heap-reserve (##core#primitive "C_ensure_heap_reserve"))
(define ##sys#symbol-table-info (##core#primitive "C_get_symbol_table_info"))
@@ -1080,7 +1392,6 @@ EOF
(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 void)
(define ##sys#undefined-value (##core#undefined))
(define (##sys#halt msg) (##core#inline "C_halt" msg))
@@ -1090,9 +1401,9 @@ EOF
(define ##sys#copy-closure (##core#primitive "C_copy_closure"))
(define (##sys#block-set! x i y)
- (when (or (not (##core#inline "C_blockp" x))
+ (when (or (not (##core#inline "C_blockp" x))
(and (##core#inline "C_specialp" x) (fx= i 0))
- (##core#inline "C_byteblockp" x) )
+ (##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!)
(##sys#setslot x i y) )
@@ -1102,21 +1413,16 @@ EOF
;; to be a hardcoded primitive module.
;;
;; [syntax] time
- (cpu-time
- current-milliseconds ; DEPRECATED
+ (cpu-time
current-process-milliseconds current-seconds)
(import scheme)
(import (only chicken.module reexport))
-;; Deprecated
-(define (current-milliseconds)
- (##core#inline_allocate ("C_a_i_current_milliseconds" 7) #f))
-
(define (current-process-milliseconds)
(##core#inline_allocate ("C_a_i_current_process_milliseconds" 7) #f))
-(define (current-seconds)
+(define (current-seconds)
(##core#inline_allocate ("C_a_get_current_seconds" 7) #f))
(define cpu-time
@@ -1131,54 +1437,60 @@ EOF
) ; chicken.time
-(define (##sys#check-structure x y . loc)
+(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)
+;; DEPRECATED
+(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-bytevector ##sys#check-blob)
-(define (##sys#check-pair x . loc)
+(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)
+(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)
+(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)
+(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-fixnum x . loc)
+(define (##sys#check-fixnum x . loc)
(if (pair? loc)
(##core#inline "C_i_check_fixnum_2" x (car loc))
(##core#inline "C_i_check_fixnum" x) ) )
+(define (##sys#check-bytevector 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-exact x . loc) ;; DEPRECATED
(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)
+(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)
+(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) ) )
@@ -1188,12 +1500,12 @@ EOF
(##core#inline "C_i_check_keyword_2" x (car loc))
(##core#inline "C_i_check_keyword" x) ) )
-(define (##sys#check-vector x . loc)
+(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)
+(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) ) )
@@ -1226,11 +1538,14 @@ EOF
(##sys#error-bad-real x (and (pair? loc) (car loc))) ) )
(define (##sys#check-range i from to . loc)
- (##sys#check-fixnum 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) ) )
+ (if (pair? loc)
+ (##core#inline "C_i_check_range_2" i from to (car loc))
+ (##core#inline "C_i_check_range" i from to) ) )
+
+(define (##sys#check-range/including i from to . loc)
+ (if (pair? loc)
+ (##core#inline "C_i_check_range_including_2" i from to (car loc))
+ (##core#inline "C_i_check_range_including" i from to) ) )
(define (##sys#check-special ptr . loc)
(unless (and (##core#inline "C_blockp" ptr) (##core#inline "C_specialp" ptr))
@@ -1328,18 +1643,135 @@ EOF
;;; Strings:
-(define-inline (%make-string size fill)
- (##sys#allocate-vector size #t fill #f) )
+(define (##sys#make-bytevector size #!optional (fill 0))
+ (##sys#allocate-bytevector size fill))
(define (##sys#make-string size #!optional (fill #\space))
- (%make-string size fill))
+ (let* ((count (##core#inline "C_utf_bytes" fill))
+ (n (fx* count size))
+ (bv (##sys#allocate-bytevector (fx+ n 1) 0)))
+ (##core#inline "C_utf_fill" bv fill)
+ (##core#inline_allocate ("C_a_ustring" 5) bv size)))
+
+(define (##sys#buffer->string buf start len)
+ (let ((bv (##sys#make-bytevector (fx+ len 1))))
+ (##core#inline "C_copy_memory_with_offset" bv buf 0 start len)
+ (##core#inline_allocate ("C_a_ustring" 5) bv
+ (##core#inline "C_utf_range_length" bv 0 len))))
+
+(define (##sys#utf-decoder buf start len k)
+ (k buf start len))
+
+(define (##sys#utf-encoder buf start len k)
+ (k buf start len))
+
+(define (##sys#utf-scanner state byte)
+ (if state
+ (if (fx> state 1)
+ (fx- state 1)
+ #f)
+ (let ((n (##core#inline "C_utf_bytes_needed" byte)))
+ (if (eq? n 1)
+ #f
+ (fx- n 1)))))
+
+(define (##sys#latin-decoder bv start len k)
+ (let* ((buf (##sys#make-bytevector (fx* len 2)))
+ (n (##core#inline "C_latin_to_utf" bv buf start len)))
+ (k buf 0 n)))
+
+(define (##sys#latin-encoder bv start len k)
+ (let* ((buf (##sys#make-bytevector (fx+ len 1)))
+ (n (##core#inline "C_utf_to_latin" bv buf start len)))
+ (k buf 0 n)))
+
+(define (##sys#latin-scanner state byte) #f)
+
+(define (##sys#binary-decoder bv start len k)
+ (k bv start len) )
+
+(define (##sys#binary-encoder bv start len k)
+ (k bv start len) )
+
+(define (##sys#binary-scanner state byte) #f)
+
+;; invokes k with encoding and decoding procedures
+(define (##sys#encoding-hook enc k)
+ (case enc
+ ((binary) (k ##sys#binary-decoder ##sys#binary-encoder ##sys#binary-scanner))
+ ((utf-8) (k ##sys#utf-decoder ##sys#utf-encoder ##sys#utf-scanner))
+ ((latin-1) (k ##sys#latin-decoder ##sys#latin-encoder ##sys#latin-scanner))
+ (else (##sys#signal-hook #:type-error #f "invalid file port encoding" enc))))
+
+(define (##sys#register-encoding names dec enc scan)
+ (let ((old ##sys#encoding-hook))
+ (set! ##sys#encoding-hook
+ (lambda (enc k)
+ (if (or (eq? enc names)
+ (and (pair? names) (memq enc names)))
+ (k dec enc scan)
+ (old enc k))))))
+
+;; decode buffer and create string
+(define (##sys#buffer->string/encoding buf start len enc)
+ (##sys#encoding-hook
+ enc
+ (lambda (decoder _ _) (decoder buf start len ##sys#buffer->string))))
+
+;; encode buffer into bytevector
+(define (##sys#encode-buffer bv start len enc k)
+ (##sys#encoding-hook
+ enc
+ (lambda (_ encoder _) (encoder bv start len k))))
+
+;; decode buffer into bytevector
+(define (##sys#decode-buffer bv start len enc k)
+ (##sys#encoding-hook
+ enc
+ (lambda (decoder _ _) (decoder bv start len k))))
+
+;; encode a single character into bytevector, return number of bytes
+(define (##sys#encode-char c bv enc)
+ (##sys#encoding-hook
+ enc
+ (lambda (_ encoder _)
+ (let* ((bv1 (##sys#make-bytevector 4))
+ (n (##core#inline "C_utf_insert" bv1 0 c)))
+ (encoder bv1 0 n
+ (lambda (buf start len)
+ (##core#inline "C_copy_memory_with_offset" bv buf 0 start len)
+ len))))))
+
+(define (##sys#decode-char bv enc start)
+ (##sys#decode-buffer
+ bv start (##sys#size bv) enc
+ (lambda (buf start _)
+ (##core#inline "C_utf_decode" buf start))))
+
+;; read char from port with encoding, scanning minimal number of bytes ahead
+(define (##sys#read-char/encoding p enc k)
+ (##sys#encoding-hook
+ enc
+ (lambda (dec _ scan)
+ (let ((buf (##sys#make-bytevector 4))
+ (rbv! (##sys#slot (##sys#slot p 2) 7))) ; read-bytevector!
+ (let loop ((state #f) (i 0))
+ (let ((rn (rbv! p 1 buf i)))
+ (if (eq? 0 rn)
+ (if (eq? i 0)
+ #!eof
+ (##sys#signal-hook #:file-error 'read-char "incomplete character sequence while decoding" buf i))
+ (let ((s2 (scan state (##core#inline "C_subbyte" buf i))))
+ (if s2
+ (loop s2 (fx+ i 1))
+ (k buf 0 (fx+ i 1) dec))))))))))
(set! scheme#make-string
(lambda (size . fill)
(##sys#check-fixnum size 'make-string)
(when (fx< size 0)
(##sys#signal-hook #:bounds-error 'make-string "size is negative" size))
- (%make-string
+ (##sys#make-string
size
(if (null? fill)
#\space
@@ -1348,14 +1780,20 @@ EOF
c ) ) ) ) )
(set! scheme#string->list
- (lambda (s)
+ (lambda (s #!optional start end)
(##sys#check-string s 'string->list)
- (let ((len (##sys#size s)))
- (let loop ((i (fx- len 1)) (ls '()))
- (if (fx< i 0)
+ (let ((len (##sys#slot s 1)))
+ (if start
+ (##sys#check-range/including start 0 len 'string->list)
+ (set! start 0))
+ (if end
+ (##sys#check-range/including end 0 len 'string->list)
+ (set! end len))
+ (let loop ((i (fx- end 1)) (ls '()))
+ (if (fx< i start)
ls
(loop (fx- i 1)
- (cons (##core#inline "C_subchar" s i) ls)) ) ) )))
+ (cons (string-ref s i) ls)) ) ) )))
(define ##sys#string->list string->list)
@@ -1363,188 +1801,267 @@ EOF
(lambda (lst0)
(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) ) ) ) )))
+ (let* ((len (##core#inline "C_utf_list_size" lst0))
+ (bv (##sys#make-bytevector (fx+ 1 len))))
+ (let loop ((i 0)
+ (p 0)
+ (lst lst0))
+ (if (not (pair? lst))
+ (##core#inline_allocate ("C_a_ustring" 5) bv i)
+ (let ((c (##sys#slot lst 0)))
+ (##sys#check-char c 'list->string)
+ (##core#inline "C_utf_insert" bv p c)
+ (loop (fx+ i 1)
+ (fx+ p (##core#inline "C_utf_bytes" c))
+ (##sys#slot lst 1)))))))))
(define ##sys#list->string list->string)
-;;; By Sven Hartrumpf:
-
(define (##sys#reverse-list->string l)
- (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) ) )
+ (let* ((sz (##core#inline "C_utf_list_size" l))
+ (bv (##sys#make-bytevector (fx+ sz 1))))
+ (let loop ((p sz) (l l) (n 0))
+ (cond ((null? l)
+ (##core#inline_allocate ("C_a_ustring" 5) bv n))
+ ((pair? l)
+ (let ((c (##sys#slot l 0)))
+ (##sys#check-char c 'reverse-list->string)
+ (let* ((bs (##core#inline "C_utf_bytes" c))
+ (p2 (fx- p bs)))
+ (##core#inline "C_utf_insert" bv p2 c)
+ (loop p2 (##sys#slot l 1) (fx+ n 1)))))
+ (else (##sys#error-not-a-proper-list l 'reverse-list->string) ) ))))
(set! scheme#string-fill!
- (lambda (s c)
+ (lambda (s c #!optional start end)
(##sys#check-string s 'string-fill!)
(##sys#check-char c 'string-fill!)
- (##core#inline "C_set_memory" s c (##sys#size s))
- (##core#undefined) ))
+ (let ((len (string-length s)))
+ (cond (start (##sys#check-range start 0 len 'string-fill!)
+ (if end
+ (##sys#check-range end 0 len 'string-fill!)
+ (set! end len)))
+ (else
+ (set! start 0)
+ (set! end len))))
+ (let* ((bv (##sys#slot s 0))
+ (bvlen (##sys#size bv))
+ (count (fxmax 0 (fx- end start)))
+ (code (char->integer c)))
+ (if (and (eq? (fx- bvlen 1) (##sys#slot s 1))
+ (fx< code 128))
+ (##core#inline "C_fill_bytevector" bv code start count)
+ (do ((i start (fx+ i 1)))
+ ((fx>= i end))
+ (string-set! s i c))))))
(set! scheme#string-copy
- (lambda (s)
+ (lambda (s #!optional start end)
(##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) ) )
+ (let ((len (string-length s))
+ (start1 0))
+ (when start
+ (##sys#check-range/including start 0 len 'string-copy)
+ (set! start1 start))
+ (if end
+ (##sys#check-range/including end 0 len 'string-copy)
+ (set! end len))
+ (let* ((bv (if start
+ (##sys#substring s start1 end)
+ (##sys#slot s 0)))
+ (len (##sys#size bv))
+ (n (fx- end start1))
+ (bv2 (##sys#make-bytevector len)) )
+ (##core#inline "C_copy_memory" bv2 bv len)
+ (##core#inline_allocate ("C_a_ustring" 5) bv2 n)))))
+
+(set! scheme#string-copy!
+ (lambda (to at from #!optional start end)
+ (##sys#check-string to 'string-copy!)
+ (##sys#check-string from 'string-copy!)
+ (let ((tlen (string-length to))
+ (flen (string-length from))
+ (d (fx- end start)))
+ (##sys#check-range at 0 tlen 'string-copy!)
+ (if start
+ (begin
+ (##sys#check-range/including start 0 flen 'string-copy!)
+ (if end
+ (##sys#check-range/including end 0 flen 'string-copy!)
+ (set! end flen)))
+ (set! start 0))
+ (if (and (eq? to from) (fx< start at))
+ (do ((at (fx- (fx+ at d) 1) (fx- at 1))
+ (i (fx- end 1) (fx- i 1)))
+ ((fx< i start))
+ (string-set! to at (string-ref from i)))
+ (do ((at at (fx+ at 1))
+ (i start (fx+ i 1)))
+ ((fx>= i end))
+ (string-set! to at (string-ref from i)))))))
+
+(define (##sys#substring s start end)
+ (let* ((n (##core#inline "C_utf_range" s start end))
+ (bv (##sys#make-bytevector (fx+ n 1)))
+ (str (##core#inline_allocate ("C_a_ustring" 5) bv (fx- end start))))
+ (##core#inline "C_utf_copy" s str start end 0)
+ str ) )
(set! scheme#substring
(lambda (s start . end)
(##sys#check-string s 'substring)
(##sys#check-fixnum start 'substring)
(let ((end (if (pair? end)
- (let ((end (car end)))
- (##sys#check-fixnum end 'substring)
- end)
- (##sys#size s) ) ) )
- (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 ) )
-
-(letrec ((compare
- (lambda (s1 s2 loc k)
+ (let ((end (car end)))
+ (##sys#check-fixnum end 'substring)
+ end)
+ (string-length s) ) ) )
+ (let ((len (string-length 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_BOUNDS_ERROR" int)
+ 'substring s start) ) ) )))
+
+(let ((compare
+ (lambda (s1 s2 more loc cmp)
(##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! scheme#string<? (lambda (s1 s2)
+ (let* ((len1 (string-length s1))
+ (len2 (string-length s2))
+ (c (##core#inline "C_utf_compare"
+ s1 s2 0 0
+ (if (fx< len1 len2) len1 len2))))
+ (let loop ((s s2) (len len2) (ss more)
+ (f (cmp (##core#inline "C_utf_compare"
+ s1 s2 0 0
+ (if (fx< len1 len2) len1 len2))
+ len1 len2)))
+ (if (null? ss)
+ f
+ (let* ((s2 (##sys#slot more 0))
+ (len2 (string-length s2))
+ (c (##core#inline "C_utf_compare_ci"
+ s s2 0 0
+ (if (fx< len len2) len len2))))
+ (loop s2 len2 (##sys#slot more 1)
+ (and f (cmp c len len2))))))))))
+ (set! scheme#string<? (lambda (s1 s2 . more)
(compare
- s1 s2 'string<?
- (lambda (len1 len2 cmp)
+ s1 s2 more 'string<?
+ (lambda (cmp len1 len2)
(or (fx< cmp 0)
(and (fx< len1 len2)
(eq? cmp 0) ) ) ) ) ) )
- (set! scheme#string>? (lambda (s1 s2)
+ (set! scheme#string>? (lambda (s1 s2 . more)
(compare
- s1 s2 'string>?
- (lambda (len1 len2 cmp)
+ s1 s2 more 'string>?
+ (lambda (cmp len1 len2)
(or (fx> cmp 0)
(and (fx< len2 len1)
(eq? cmp 0) ) ) ) ) ) )
- (set! scheme#string<=? (lambda (s1 s2)
+ (set! scheme#string<=? (lambda (s1 s2 . more)
(compare
- s1 s2 'string<=?
- (lambda (len1 len2 cmp)
+ s1 s2 more 'string<=?
+ (lambda (cmp len1 len2)
(if (eq? cmp 0)
(fx<= len1 len2)
(fx< cmp 0) ) ) ) ) )
- (set! scheme#string>=? (lambda (s1 s2)
+ (set! scheme#string>=? (lambda (s1 s2 . more)
(compare
- s1 s2 'string>=?
- (lambda (len1 len2 cmp)
+ s1 s2 more 'string>=?
+ (lambda (cmp len1 len2)
(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! scheme#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! scheme#string-ci>? (lambda (s1 s2)
+(let ((compare
+ (lambda (s1 s2 more loc cmp)
+ (##sys#check-string s1 loc)
+ (##sys#check-string s2 loc)
+ (let* ((len1 (string-length s1))
+ (len2 (string-length s2))
+ (c (##core#inline "C_utf_compare_ci"
+ s1 s2 0 0
+ (if (fx< len1 len2) len1 len2))))
+ (let loop ((s s2) (len len2) (ss more)
+ (f (cmp c len1 len2)))
+ (if (null? ss)
+ f
+ (let* ((s2 (##sys#slot ss 0))
+ (len2 (string-length s2))
+ (c (##core#inline "C_utf_compare_ci"
+ s s2 0 0
+ (if (fx< len len2) len len2))))
+ (loop s2 len2 (##sys#slot ss 1)
+ (and f (cmp c len len2))))))))))
+ (set! scheme#string-ci<? (lambda (s1 s2 . more)
+ (compare
+ s1 s2 more 'string-ci<?
+ (lambda (cmp len1 len2)
+ (or (fx< cmp 0)
+ (and (fx< len1 len2)
+ (eq? cmp 0) ) )))))
+ (set! scheme#string-ci>? (lambda (s1 s2 . more)
(compare
- s1 s2 'string-ci>?
- (lambda (len1 len2 cmp)
+ s1 s2 more 'string-ci>?
+ (lambda (cmp len1 len2)
(or (fx> cmp 0)
(and (fx< len2 len1)
(eq? cmp 0) ) ) ) ) ) )
- (set! scheme#string-ci<=? (lambda (s1 s2)
+ (set! scheme#string-ci<=? (lambda (s1 s2 . more)
(compare
- s1 s2 'string-ci<=?
- (lambda (len1 len2 cmp)
+ s1 s2 more 'string-ci<=?
+ (lambda (cmp len1 len2)
(if (eq? cmp 0)
(fx<= len1 len2)
(fx< cmp 0) ) ) ) ) )
- (set! scheme#string-ci>=? (lambda (s1 s2)
+ (set! scheme#string-ci>=? (lambda (s1 s2 . more)
(compare
- s1 s2 'string-ci>=?
- (lambda (len1 len2 cmp)
+ s1 s2 more 'string-ci>=?
+ (lambda (cmp len1 len2)
(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) )
+ (let* ((bv1 (##sys#slot x 0))
+ (bv2 (##sys#slot y 0))
+ (s1 (fx- (##sys#size bv1) 1))
+ (s2 (fx- (##sys#size bv2) 1))
+ (z (##sys#make-bytevector (fx+ s1 (fx+ s2 1)) 0)))
+ (##core#inline "C_copy_memory_with_offset" z bv1 0 0 s1)
+ (##core#inline "C_copy_memory_with_offset" z bv2 s1 0 s2)
+ (##core#inline_allocate ("C_a_ustring" 5) z
+ (fx+ (##sys#slot x 1) (##sys#slot y 1)))))
(set! scheme#string-append
(lambda 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 ) ))
+ (let ((snew #f)
+ (slen 0))
+ (let loop ((strs all) (n 0) (ul 0))
+ (cond ((eq? strs '())
+ (set! snew (##sys#make-bytevector (fx+ n 1) 0))
+ (set! slen ul))
+ (else
+ (let ((s (##sys#slot strs 0)))
+ (##sys#check-string s 'string-append)
+ (let* ((bv (##sys#slot s 0))
+ (len (fx- (##sys#size bv) 1))
+ (ulen (##sys#slot s 1)))
+ (loop (##sys#slot strs 1) (fx+ n len) (fx+ ul ulen))
+ (##core#inline "C_copy_memory_with_offset" snew bv n 0 len) ) ) ) ) )
+ (##core#inline_allocate ("C_a_ustring" 5) snew slen))))
(set! scheme#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)) ) ) ) ) )
+;; legacy procedure, used in some eggs, should be removed one day...
+(define (##sys#char->utf8-string c)
+ (scheme#string c))
(set! chicken.base#chop
(lambda (lst n)
@@ -1592,15 +2109,15 @@ EOF
(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)
+(define (fp+ x y)
(fp-check-flonums x y 'fp+)
(##core#inline_allocate ("C_a_i_flonum_plus" 4) x y) )
-(define (fp- x y)
+(define (fp- x y)
(fp-check-flonums x y 'fp-)
(##core#inline_allocate ("C_a_i_flonum_difference" 4) x y) )
-(define (fp* x y)
+(define (fp* x y)
(fp-check-flonums x y 'fp*)
(##core#inline_allocate ("C_a_i_flonum_times" 4) x y) )
@@ -1622,35 +2139,35 @@ EOF
(fp-check-flonums x y 'fp/?)
(##core#inline_allocate ("C_a_i_flonum_quotient_checked" 4) x y) )
-(define (fp= x y)
+(define (fp= x y)
(fp-check-flonums x y 'fp=)
(##core#inline "C_flonum_equalp" x y) )
-(define (fp> x y)
+(define (fp> x y)
(fp-check-flonums x y 'fp>)
(##core#inline "C_flonum_greaterp" x y) )
-(define (fp< x y)
+(define (fp< x y)
(fp-check-flonums x y 'fp<)
(##core#inline "C_flonum_lessp" x y) )
-(define (fp>= x y)
+(define (fp>= x y)
(fp-check-flonums x y 'fp>=)
(##core#inline "C_flonum_greater_or_equal_p" x y) )
-(define (fp<= x y)
+(define (fp<= x y)
(fp-check-flonums x y 'fp<=)
(##core#inline "C_flonum_less_or_equal_p" x y) )
-(define (fpneg x)
+(define (fpneg x)
(fp-check-flonum x 'fpneg)
(##core#inline_allocate ("C_a_i_flonum_negate" 4) x) )
-(define (fpmax x y)
+(define (fpmax x y)
(fp-check-flonums x y 'fpmax)
(##core#inline "C_i_flonum_max" x y) )
-(define (fpmin x y)
+(define (fpmin x y)
(fp-check-flonums x y 'fpmin)
(##core#inline "C_i_flonum_min" x y) )
@@ -1758,11 +2275,6 @@ EOF
(define-inline (integer-negate x)
(##core#inline_allocate ("C_s_a_u_i_integer_negate" 5) x))
-(define ##sys#number? number?)
-(define ##sys#integer? integer?)
-(define ##sys#exact? exact?)
-(define ##sys#inexact? inexact?)
-
;;; Complex numbers
(define-inline (%cplxnum-real c) (##core#inline "C_u_i_cplxnum_real" c))
@@ -1900,9 +2412,6 @@ EOF
(inexact->exact (%cplxnum-imag x))))
(else (##sys#error-bad-number x 'inexact->exact)) )))
-(define ##sys#exact->inexact exact->inexact)
-(define ##sys#inexact->exact inexact->exact)
-
;;; Bitwise operations:
@@ -2038,10 +2547,10 @@ EOF
(define (find-ratio-between x y)
(define (sr x y)
- (let ((fx (inexact->exact (floor x)))
+ (let ((fx (inexact->exact (floor x)))
(fy (inexact->exact (floor y))))
(cond ((not (< fx x)) (list fx 1))
- ((= fx fy)
+ ((= fx fy)
(let ((rat (sr (##sys#/-2 1 (- y fy))
(##sys#/-2 1 (- x fx)))))
(list (+ (cadr rat) (* fx (car rat)))
@@ -2211,7 +2720,7 @@ EOF
(- (+ r (arithmetic-shift s 1)) 1))
(values s r)))))
-(set! chicken.base#exact-integer-sqrt
+(set! scheme#exact-integer-sqrt
(lambda (x)
(##sys#check-exact-uinteger x 'exact-integer-sqrt)
(##sys#exact-integer-sqrt x)))
@@ -2244,6 +2753,29 @@ EOF
(set! scheme#sqrt (lambda (x) (##sys#sqrt/loc 'sqrt x)))
+;; XXX These are bad bad bad definitions; very inefficient.
+;; But to improve it we would need to provide another implementation
+;; of the quotient procedure which floors instead of truncates.
+(define scheme#truncate/ quotient&remainder)
+
+(define (scheme#floor/ x y)
+ (receive (div rem) (quotient&remainder x y)
+ (if (positive? y)
+ (if (negative? rem)
+ (values (- div 1) (+ rem y))
+ (values div rem))
+ (if (positive? rem)
+ (values (- div 1) (+ rem y))
+ (values div rem)))))
+
+(define (scheme#floor-remainder x y)
+ (receive (div rem) (scheme#floor/ x y) rem))
+
+(define (scheme#floor-quotient x y)
+ (receive (div rem) (scheme#floor/ x y) div))
+
+(define (scheme#square n) (* n n))
+
(set! chicken.base#exact-integer-nth-root
(lambda (k n)
(##sys#check-exact-uinteger k 'exact-integer-nth-root)
@@ -2452,8 +2984,6 @@ EOF
(+ q (if (eqv? (negative? n) (negative? d)) 1 -1))
q)))
-;; Shorthand for readability. TODO: Replace other C_subchar calls with this
-(define-inline (%subchar s i) (##core#inline "C_subchar" s i))
(define (##sys#string->compnum radix str offset exactness)
;; Flipped when a sign is encountered (for inexact numbers only)
(define negative #f)
@@ -2479,7 +3009,7 @@ EOF
;; is not mandated by the standard, but compatible with earlier
;; CHICKENs and it just makes more sense.
(##core#inline_allocate ("C_a_i_flonum_quotient" 4) 0.0 0.0))
- (let* ((len (##sys#size str))
+ (let* ((len (string-length str))
(0..r (integer->char (fx+ (char->integer #\0) (fx- radix 1))))
(a..r (integer->char (fx+ (char->integer #\a) (fx- radix 11))))
(A..r (integer->char (fx+ (char->integer #\A) (fx- radix 11))))
@@ -2494,7 +3024,7 @@ EOF
(let lp ((i start))
(if (fx= i len)
(and (fx> i start) (cons i #f))
- (let ((c (%subchar str i)))
+ (let ((c (string-ref str i)))
(if (fx<= radix 10)
(if (and (char>=? c #\0) (char<=? c 0..r))
(lp (fx+ i 1))
@@ -2509,7 +3039,7 @@ EOF
(let lp ((i start))
(if (fx= i len)
(and (fx> i start) (cons i #f))
- (let ((c (%subchar str i)))
+ (let ((c (string-ref str i)))
(if (eq? c #\#)
(lp (fx+ i 1))
(and (fx> i start) (cons i i))))))))
@@ -2531,7 +3061,7 @@ EOF
(scan-exponent
(lambda (start)
(and (fx< start len)
- (let ((sign (case (%subchar str start)
+ (let ((sign (case (string-ref str start)
((#\+) 'pos) ((#\-) 'neg) (else #f))))
(and-let* ((start (if sign (fx+ start 1) start))
(end (scan-digits start)))
@@ -2546,7 +3076,7 @@ EOF
(next (if tail (cdr tail) start)))
(and (or decimal-head (not next)
(fx> next start)) ; Don't allow empty "."
- (case (and next (%subchar str next))
+ (case (and next (string-ref str next))
((#\e #\s #\f #\d #\l
#\E #\S #\F #\D #\L)
(and-let* (((fx> len next))
@@ -2566,12 +3096,12 @@ EOF
(scan-ureal
(lambda (start neg?)
(if (and (fx> len (fx+ start 1)) (eq? radix 10)
- (eq? (%subchar str start) #\.))
+ (eq? (string-ref str start) #\.))
(begin
(go-inexact! neg?)
(scan-decimal-tail (fx+ start 1) neg? #f))
(and-let* ((end (scan-digits+hashes start neg? #f)))
- (case (and (cdr end) (%subchar str (cdr end)))
+ (case (and (cdr end) (string-ref str (cdr end)))
((#\.)
(go-inexact! neg?)
(and (eq? radix 10)
@@ -2606,11 +3136,11 @@ EOF
(scan-real
(lambda (start)
(and (fx< start len)
- (let* ((sign (case (%subchar str start)
+ (let* ((sign (case (string-ref str start)
((#\+) 'pos) ((#\-) 'neg) (else #f)))
(next (if sign (fx+ start 1) start)))
(and (fx< next len)
- (case (%subchar str next)
+ (case (string-ref str next)
((#\i #\I)
(or (and sign
(cond
@@ -2635,19 +3165,19 @@ EOF
(scan-ureal next (eq? sign 'neg))))
(else (scan-ureal next (eq? sign 'neg)))))))))
(number (and-let* ((r1 (scan-real offset)))
- (case (and (cdr r1) (%subchar str (cdr r1)))
+ (case (and (cdr r1) (string-ref str (cdr r1)))
((#f) (car r1))
((#\i #\I) (and (fx= len (fx+ (cdr r1) 1))
- (or (eq? (%subchar str offset) #\+) ; ugh
- (eq? (%subchar str offset) #\-))
+ (or (eq? (string-ref str offset) #\+) ; ugh
+ (eq? (string-ref str offset) #\-))
(make-rectangular 0 (car r1))))
((#\+ #\-)
(set! seen-hashes? #f) ; Reset flag for imaginary part
(and-let* ((r2 (scan-real (cdr r1)))
((cdr r2))
((fx= len (fx+ (cdr r2) 1)))
- ((or (eq? (%subchar str (cdr r2)) #\i)
- (eq? (%subchar str (cdr r2)) #\I))))
+ ((or (eq? (string-ref str (cdr r2)) #\i)
+ (eq? (string-ref str (cdr r2)) #\I))))
(make-rectangular (car r1) (car r2))))
((#\@)
(set! seen-hashes? #f) ; Reset flag for angle
@@ -2672,9 +3202,9 @@ EOF
(let scan-prefix ((i 0)
(exness #f)
(radix #f)
- (len (##sys#size str)))
- (if (and (fx< (fx+ i 2) len) (eq? (%subchar str i) #\#))
- (case (%subchar str (fx+ i 1))
+ (len (string-length str)))
+ (if (and (fx< (fx+ i 2) len) (eq? (string-ref str i) #\#))
+ (case (string-ref str (fx+ i 1))
((#\i #\I) (and (not exness) (scan-prefix (fx+ i 2) 'i radix len)))
((#\e #\E) (and (not exness) (scan-prefix (fx+ i 2) 'e radix len)))
((#\b #\B) (and (not radix) (scan-prefix (fx+ i 2) exness 2 len)))
@@ -2719,11 +3249,13 @@ EOF
(if (##core#inline "C_closurep" x)
(##core#inline "shallow_equal" x y)
(compare-slots x y 1))))
+ ((##core#inline "C_stringp" x)
+ (walk (##sys#slot x 0) (##sys#slot y 0)))
((##core#inline "C_byteblockp" x)
(and (##core#inline "C_byteblockp" y)
(let ((s1 (##sys#size x)))
(and (eq? s1 (##sys#size y))
- (##core#inline "C_substring_compare" x y 0 0 s1)))))
+ (##core#inline "C_bv_compare" x y s1)))))
(else
(let ((s1 (##sys#size x)))
(and (eq? s1 (##sys#size y))
@@ -2736,58 +3268,77 @@ EOF
(define ##sys#snafu '##sys#fnord)
(define ##sys#intern-symbol (##core#primitive "C_string_to_symbol"))
(define ##sys#intern-keyword (##core#primitive "C_string_to_keyword"))
+(define ##sys#make-symbol (##core#primitive "C_make_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#string->symbol-name s)
+ (let* ((bv (##sys#slot s 0))
+ (len (##sys#size bv))
+ (s2 (##sys#make-bytevector len)))
+ (##core#inline "C_copy_bytevector" bv s2 len)))
+
+(define (##sys#symbol->string/shared s)
+ (let* ((bv (##sys#slot s 1))
+ (count (##core#inline "C_utf_length" bv)))
+ (##core#inline_allocate ("C_a_ustring" 5)
+ bv
+ count)))
(define (##sys#symbol->string s)
- (##sys#slot s 1))
+ (let* ((bv (##sys#slot s 1))
+ (len (##sys#size bv))
+ (s2 (##sys#make-bytevector len))
+ (count (##core#inline "C_utf_length" bv)))
+ (##core#inline_allocate ("C_a_ustring" 5)
+ (##core#inline "C_copy_bytevector" bv s2 len)
+ count)))
+
+(define (##sys#string->symbol str)
+ (##sys#intern-symbol (##sys#string->symbol-name str) ))
(set! scheme#symbol->string
(lambda (s)
(##sys#check-symbol s 'symbol->string)
- (string-copy (##sys#symbol->string s) ) ))
+ (##sys#symbol->string s) ) )
(set! scheme#string->symbol
- (let ((string-copy string-copy))
- (lambda (str)
- (##sys#check-string str 'string->symbol)
- (##sys#intern-symbol (string-copy str)) ) ) )
+ (lambda (str)
+ (##sys#check-string str 'string->symbol)
+ (##sys#string->symbol str)))
(set! chicken.base#string->uninterned-symbol
(let ((string-copy string-copy))
(lambda (str)
(##sys#check-string str 'string->uninterned-symbol)
- ((##core#primitive "C_make_symbol") (string-copy str)))))
+ (##sys#make-symbol (##sys#string->symbol-name str)))))
(set! chicken.base#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))
- ((##core#primitive "C_make_symbol")
+ (##sys#make-symbol
+ (##sys#string->symbol-name
(##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))
+ ((##core#inline "C_symbolp" prefix) (##sys#symbol->string/shared prefix))
(else (err prefix))))
(err prefix) ) ) )
- (##sys#number->string counter) ) ) ) ) ) )
+ (##sys#number->string counter) ) ) ) ) ) ) )
(set! chicken.base#symbol-append
(let ((string-append string-append))
(lambda ss
- (##sys#intern-symbol
+ (##sys#string->symbol
(apply
- string-append
+ string-append
(map (lambda (s)
(##sys#check-symbol s 'symbol-append)
- (##sys#symbol->string s))
+ (##sys#symbol->string/shared s))
ss))))))
;;; Keywords:
@@ -2804,7 +3355,7 @@ EOF
(let ([string string] )
(lambda (s)
(##sys#check-string s 'string->keyword)
- (##sys#intern-keyword s) ) ) )
+ (##sys#intern-keyword (##sys#string->symbol-name s) ) ) ))
(define keyword->string
(let ([keyword? keyword?])
@@ -2828,53 +3379,151 @@ EOF
(import chicken.keyword)
-;;; Blob:
-
-(module chicken.blob
- (blob->string string->blob blob? blob=? blob-size make-blob)
-
-(import scheme)
-
-(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-fixnum size 'make-blob)
- (##sys#make-blob size) )
-
-(define (blob? x)
+;;; bytevectors:
+
+(define (##sys#bytevector->list v)
+ (let ((n (##sys#size v)))
+ (let loop ((i (fx- n 1)) (lst '()))
+ (if (fx< i 0)
+ lst
+ (loop (fx- i 1)
+ (cons (##core#inline "C_subbyte" v i) lst))))))
+
+(define (##sys#list->bytevector lst0)
+ (let* ((n (length lst0))
+ (bv (##sys#make-bytevector n)))
+ (let loop ((lst lst0) (i 0))
+ (if (null? lst)
+ bv
+ (let ((b (car lst)))
+ (if (##core#inline "C_fixnump" b)
+ (##core#inline "C_setsubbyte" bv i b)
+ (##sys#signal-hook #:type-error "can not convert list to bytevector" lst0))
+ (loop (cdr lst) (fx+ i 1)))))))
+
+(module chicken.bytevector
+ (bytevector? bytevector=? bytevector-length
+ make-bytevector bytevector bytevector-u8-ref
+ bytevector-u8-set! bytevector-copy bytevector-copy!
+ bytevector-append utf8->string string->utf8
+ latin1->string string->latin1)
+
+(import scheme (chicken foreign))
+
+(define (make-bytevector size #!optional fill)
+ (##sys#check-fixnum size 'make-bytevector)
+ (if fill (##sys#check-fixnum fill 'make-bytevector))
+ (##sys#make-bytevector size fill) )
+
+(define (bytevector? x)
(and (##core#inline "C_blockp" x)
(##core#inline "C_bytevectorp" x) ) )
-(define (blob-size bv)
- (##sys#check-blob bv 'blob-size)
+(define (bytevector-length bv)
+ (##sys#check-bytevector bv 'bytevector-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 (bytevector-u8-ref bv i)
+ (##core#inline "C_i_bytevector_ref" bv i))
-(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 (bytevector-u8-set! bv i b)
+ (##core#inline "C_i_bytevector_set" bv i b))
+
+(define (string->utf8 s)
+ (##sys#check-string s 'string->utf8)
+ (let* ((sbv (##sys#slot s 0))
+ (n (##core#inline "C_fixnum_difference" (##sys#size sbv) 1))
+ (bv (##sys#make-bytevector n)) )
+ (##core#inline "C_copy_memory" bv sbv n)
+ bv) )
-(define (blob=? b1 b2)
- (##sys#check-blob b1 'blob=?)
- (##sys#check-blob b2 'blob=?)
+(define (utf8->string bv #!optional (validate #t))
+ (##sys#check-bytevector bv 'utf8->string)
+ (if (and validate (not (##core#inline "C_utf_validate" bv (##sys#size bv))))
+ (##sys#error-hook (foreign-value "C_DECODING_ERROR" int)
+ 'utf8->string bv))
+ (##sys#buffer->string bv 0 (##sys#size bv)))
+
+(define (string->latin1 s)
+ (##sys#check-string s 'string->latin1)
+ (let* ((sbv (##sys#slot s 0))
+ (len (##sys#slot s 1))
+ (blen (##core#inline "C_fixnum_difference" (##sys#size sbv) 1))
+ (bv (##sys#make-bytevector len)) )
+ (##core#inline "C_utf_to_latin" sbv bv 0 blen)
+ bv))
+
+(define (latin1->string bv)
+ (##sys#check-bytevector bv 'latin1->string)
+ (let* ((len (##sys#size bv))
+ (buf (##sys#make-bytevector (##core#inline "C_fixnum_times" len 2)))
+ (n (##core#inline "C_latin_to_utf" bv buf 0 len)))
+ (##sys#buffer->string buf 0 n)))
+
+(define (bytevector=? b1 b2)
+ (##sys#check-bytevector b1 'bytevector=?)
+ (##sys#check-bytevector b2 'bytevector=?)
(let ((n (##sys#size b1)))
(and (eq? (##sys#size b2) n)
- (zero? (##core#inline "C_string_compare" b1 b2 n)))))
-
-) ; chicken.blob
+ (##core#inline "C_bv_compare" b1 b2 n))))
+(define (bytevector . args)
+ (let* ((n (length args))
+ (bv (##sys#make-bytevector n)))
+ (let loop ((args args) (i 0))
+ (cond ((null? args) bv)
+ (else
+ (let ((b (car args)))
+ (##sys#check-fixnum b 'bytevector)
+ (##core#inline "C_setsubbyte" bv i b)
+ (loop (cdr args) (##core#inline "C_fixnum_plus" i 1))))))))
+
+(define (bytevector-copy bv #!optional (start 0) end)
+ (##sys#check-bytevector bv 'bytevector-copy)
+ (let* ((n (##sys#size bv))
+ (to (or end n)))
+ (if end
+ (##sys#check-range/including end 0 n 'bytevector->copy))
+ (cond ((and (eq? n 0) (eq? start 0) (eq? 0 to))
+ (##sys#make-bytevector 0))
+ (else
+ (##sys#check-range/including start 0 n 'bytevector->copy)
+ (let* ((n2 (##core#inline "C_fixnum_difference" to start))
+ (v2 (##sys#make-bytevector n2)))
+ (##core#inline "C_copy_memory_with_offset" v2 bv 0 start n2)
+ v2)))))
+
+(define (bytevector-copy! bv1 at bv2 #!optional (start 0) end)
+ (##sys#check-bytevector bv1 'bytevector-copy!)
+ (##sys#check-bytevector bv2 'bytevector-copy!)
+ (let* ((n1 (##sys#size bv1))
+ (n2 (##sys#size bv2))
+ (to (or end n2))
+ (nc (##core#inline "C_fixnum_difference" to start)))
+ (cond ((and (eq? n2 0) (eq? nc 0) (eq? start 0)) (##core#undefined))
+ (else
+ (##sys#check-range/including start 0 n2 'bytevector->copy!)
+ (##sys#check-range/including at 0 n1 'bytevector->copy!)
+ (##sys#check-range/including (##core#inline "C_fixnum_plus" at nc)
+ 0 n1 'bytevector->copy!)
+ (##core#inline "C_copy_memory_with_offset" bv1 bv2 at start nc)))))
+
+(define (bytevector-append . bvs)
+ (let loop ((lst bvs) (len 0))
+ (if (null? lst)
+ (let ((bv (##sys#make-bytevector len)))
+ (let loop ((lst bvs) (i 0))
+ (if (null? lst)
+ bv
+ (let* ((bv1 (car lst))
+ (n (##sys#size bv1)))
+ (##core#inline "C_copy_memory_with_offset" bv bv1 i 0 n)
+ (loop (cdr lst) (##core#inline "C_fixnum_plus" i n))))))
+ (let ((bv (car lst)))
+ (##sys#check-bytevector bv 'bytevector-append)
+ (loop (cdr lst) (##core#inline "C_fixnum_plus" len (##sys#size bv)))))))
+
+) ; chicken.bytevector
;;; Vectors:
@@ -2883,11 +3532,10 @@ EOF
(##sys#check-fixnum size 'make-vector)
(when (fx< size 0) (##sys#error 'make-vector "size is negative" size))
(##sys#allocate-vector
- size #f
+ size
(if (null? fill)
(##core#undefined)
- (car fill) )
- #f) ))
+ (car fill) ))))
(define ##sys#make-vector make-vector)
@@ -2906,11 +3554,17 @@ EOF
(loop (##sys#slot lst 1) (fx+ i 1)) ) ) ) ) )))
(set! scheme#vector->list
- (lambda (v)
+ (lambda (v #!optional start end)
(##sys#check-vector v 'vector->list)
- (let ((len (##core#inline "C_block_size" v)))
- (let loop ((i 0))
- (if (fx>= i len)
+ (let ((len (##sys#size v)))
+ (if start
+ (##sys#check-range/including start 0 len 'vector->list)
+ (set! start 0))
+ (if end
+ (##sys#check-range/including end 0 len 'vector->list)
+ (set! end len))
+ (let loop ((i start))
+ (if (fx>= i end)
'()
(cons (##sys#slot v i)
(loop (fx+ i 1)) ) ) ) ) ))
@@ -2918,28 +3572,67 @@ EOF
(set! scheme#vector (lambda xs (list->vector xs) ))
(set! scheme#vector-fill!
- (lambda (v x)
+ (lambda (v x #!optional start end)
(##sys#check-vector v 'vector-fill!)
- (let ((len (##core#inline "C_block_size" v)))
- (do ((i 0 (fx+ i 1)))
- ((fx>= i len))
+ (let ((len (##sys#size v)))
+ (if start
+ (##sys#check-range/including start 0 len 'vector-fill!)
+ (set! start 0))
+ (if end
+ (##sys#check-range/including end 0 len 'vector-fill!)
+ (set! end len))
+ (do ((i start (fx+ i 1)))
+ ((fx>= i end))
(##sys#setslot v i x) ) ) ))
-(set! chicken.base#vector-copy!
- (lambda (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-fixnum n 'vector-copy!)
- (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))
- (do ((i 0 (fx+ i 1)))
- ((fx>= i n))
- (##sys#setslot to i (##sys#slot from i))))))
+(define (scheme#vector-copy v #!optional start end)
+ (##sys#check-vector v 'vector-copy)
+ (let ((copy (lambda (v start end)
+ (let* ((len (##sys#size v)))
+ (##sys#check-range/including start 0 end 'vector-copy)
+ (##sys#check-range/including end start len 'vector-copy)
+ (let ((vec (##sys#make-vector (fx- end start))))
+ (do ((ti 0 (fx+ ti 1))
+ (fi start (fx+ fi 1)))
+ ((fx>= fi end) vec)
+ (##sys#setslot vec ti (##sys#slot v fi))))))))
+ (if end
+ (copy v start end)
+ (copy v (or start 0) (##sys#size v)))))
+
+(define (scheme#vector-copy! to at from #!optional start end)
+ (##sys#check-vector to 'vector-copy!)
+ (##sys#check-vector from 'vector-copy!)
+ (let ((copy! (lambda (to at from start end)
+ (let* ((tlen (##sys#size to))
+ (flen (##sys#size from))
+ (d (fx- end start)))
+ (##sys#check-range/including at 0 tlen 'vector-copy!)
+ (##sys#check-range/including start 0 end 'vector-copy!)
+ (##sys#check-range/including end start flen 'vector-copy!)
+ (##sys#check-range/including d 0 (fx- tlen at) 'vector-copy!)
+ (if (and (eq? to from) (fx< start at))
+ (do ((fi (fx- end 1) (fx- fi 1))
+ (ti (fx- (fx+ at d) 1) (fx- ti 1)))
+ ((fx< fi start))
+ (##sys#setslot to ti (##sys#slot from fi)))
+ (do ((fi start (fx+ fi 1))
+ (ti at (fx+ ti 1)))
+ ((fx= fi end))
+ (##sys#setslot to ti (##sys#slot from fi))))))))
+ (if end
+ (copy! to at from start end)
+ (copy! to at from (or start 0) (##sys#size from)))))
+
+(define (scheme#vector-append . vs)
+ (##sys#for-each (cut ##sys#check-vector <> 'vector-append) vs)
+ (let* ((lens (map ##sys#size vs))
+ (vec (##sys#make-vector (foldl fx+ 0 lens))))
+ (do ((vs vs (cdr vs))
+ (lens lens (cdr lens))
+ (i 0 (fx+ i (car lens))))
+ ((null? vs) vec)
+ (scheme#vector-copy! vec i (car vs) 0 (car lens)))))
(set! chicken.base#subvector
(lambda (v i #!optional j)
@@ -2947,8 +3640,8 @@ EOF
(let* ((len (##sys#size v))
(j (or j len))
(len2 (fx- j i)))
- (##sys#check-range i 0 (fx+ len 1) 'subvector)
- (##sys#check-range j 0 (fx+ len 1) 'subvector)
+ (##sys#check-range/including i 0 len 'subvector)
+ (##sys#check-range/including j 0 len 'subvector)
(let ((v2 (make-vector len2)))
(do ((k 0 (fx+ k 1)))
((fx>= k len2) v2)
@@ -2969,26 +3662,88 @@ EOF
;;; Characters:
-(let ((char-downcase char-downcase))
- (set! scheme#char-ci=? (lambda (x y)
- (eq? (char-downcase x)
- (char-downcase y))))
- (set! scheme#char-ci>? (lambda (x y)
- (##core#inline "C_u_i_char_greaterp"
- (char-downcase x)
- (char-downcase y))))
- (set! scheme#char-ci<? (lambda (x y)
- (##core#inline "C_u_i_char_lessp"
- (char-downcase x)
- (char-downcase y))))
- (set! scheme#char-ci>=? (lambda (x y)
- (##core#inline "C_u_i_char_greater_or_equal_p"
- (char-downcase x)
- (char-downcase y))))
- (set! scheme#char-ci<=? (lambda (x y)
- (##core#inline "C_u_i_char_less_or_equal_p"
- (char-downcase x)
- (char-downcase y)))) )
+(set! scheme#char-ci=?
+ (lambda (x y . more)
+ (##sys#check-char x 'char-ci=?)
+ (##sys#check-char y 'char-ci=?)
+ (let ((c2 (##core#inline "C_utf_char_foldcase" y)))
+ (let loop ((c c2) (cs more)
+ (f (eq? (##core#inline "C_utf_char_foldcase" x) c2)))
+ (if (null? cs)
+ f
+ (let ((c2 (##sys#slot cs 0)))
+ (##sys#check-char c2 'char-ci=?)
+ (let ((c2 ((##core#inline "C_utf_char_foldcase" c2))))
+ (loop c2 (##sys#slot cs 1)
+ (and f (eq? c c2))))))))))
+
+(set! scheme#char-ci>?
+ (lambda (x y . more)
+ (##sys#check-char x 'char-ci>?)
+ (##sys#check-char y 'char-ci>?)
+ (let ((c2 (##core#inline "C_utf_char_foldcase" y)))
+ (let loop ((c c2) (cs more)
+ (f (##core#inline "C_u_i_char_greaterp"
+ (##core#inline "C_utf_char_foldcase" x)
+ c2)))
+ (if (null? cs)
+ f
+ (let ((c2 (##sys#slot cs 0)))
+ (##sys#check-char c2 'char-ci>?)
+ (let ((c2 ((##core#inline "C_utf_char_foldcase" c2))))
+ (loop c2 (##sys#slot cs 1)
+ (and f (##core#inline "C_u_i_char_greaterp" c c2))))))))))
+
+(set! scheme#char-ci<?
+ (lambda (x y . more)
+ (##sys#check-char x 'char-ci<?)
+ (##sys#check-char y 'char-ci<?)
+ (let ((c2 (##core#inline "C_utf_char_foldcase" y)))
+ (let loop ((c c2) (cs more)
+ (f (##core#inline "C_u_i_char_lessp"
+ (##core#inline "C_utf_char_foldcase" x)
+ c2)))
+ (if (null? cs)
+ f
+ (let ((c2 (##sys#slot cs 0)))
+ (##sys#check-char c2 'char-ci<?)
+ (let ((c2 ((##core#inline "C_utf_char_foldcase" c2))))
+ (loop c2 (##sys#slot cs 1)
+ (and f (##core#inline "C_u_i_char_lessp" c c2))))))))))
+
+(set! scheme#char-ci>=?
+ (lambda (x y . more)
+ (##sys#check-char x 'char-ci>=?)
+ (##sys#check-char y 'char-ci>=?)
+ (let ((c2 (##core#inline "C_utf_char_foldcase" y)))
+ (let loop ((c c2) (cs more)
+ (f (##core#inline "C_u_i_char_greater_or_equal_p"
+ (##core#inline "C_utf_char_foldcase" x)
+ c2)))
+ (if (null? cs)
+ f
+ (let ((c2 (##sys#slot cs 0)))
+ (##sys#check-char c2 'char-ci>=?)
+ (let ((c2 ((##core#inline "C_utf_char_foldcase" c2))))
+ (loop c2 (##sys#slot cs 1)
+ (and f (##core#inline "C_u_i_char_greater_or_equal_p" c c2))))))))))
+
+(set! scheme#char-ci<=?
+ (lambda (x y . more)
+ (##sys#check-char x 'char-ci<=?)
+ (##sys#check-char y 'char-ci<=?)
+ (let ((c2 (##core#inline "C_utf_char_foldcase" y)))
+ (let loop ((c c2) (cs more)
+ (f (##core#inline "C_u_i_char_less_or_equal_p"
+ (##core#inline "C_utf_char_foldcase" x)
+ c2)))
+ (if (null? cs)
+ f
+ (let ((c2 (##sys#slot cs 0)))
+ (##sys#check-char c2 'char-ci<=?)
+ (let ((c2 ((##core#inline "C_utf_char_foldcase" c2))))
+ (loop c2 (##sys#slot cs 1)
+ (and f (##core#inline "C_u_i_char_less_or_equal_p" c c2))))))))))
(set! chicken.base#char-name
(let ((chars-to-names (make-vector char-name-table-size '()))
@@ -3013,7 +3768,7 @@ EOF
(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
+ (if a
(let ([b (assq x names-to-chars)])
(##sys#setslot a 1 x)
(if b
@@ -3021,7 +3776,7 @@ EOF
(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
+ (##sys#setslot
chars-to-names key
(cons (cons chr x) (##sys#slot chars-to-names key))) ) ) ) ]
[else
@@ -3143,7 +3898,7 @@ EOF
(apply cont results) )
(proc continuation) ))) ))
-(set! chicken.base#call/cc call-with-current-continuation)
+(set! scheme#call/cc call-with-current-continuation)
(define (##sys#dynamic-unwind winds n)
(cond [(eq? ##sys#dynamic-winds winds)]
@@ -3160,21 +3915,6 @@ EOF
;;; Ports:
-(set! chicken.base#port?
- (lambda (x)
- (and (##core#inline "C_blockp" x)
- (##core#inline "C_portp" x))))
-
-(set! chicken.base#input-port-open?
- (lambda (p)
- (##sys#check-input-port p 'input-port-open?)
- (##core#inline "C_input_port_openp" p)))
-
-(set! chicken.base#output-port-open?
- (lambda (p)
- (##sys#check-output-port p 'output-port-open?)
- (##core#inline "C_output_port_openp" p)))
-
(set! chicken.base#port-closed?
(lambda (p)
(##sys#check-port p 'port-closed?)
@@ -3184,8 +3924,8 @@ EOF
;;; Port layout:
;
-; 0: FP (special)
-; 1: direction (fixnum)
+; 0: file ptr (special)
+; 1: direction (fixnum, 1 = input)
; 2: class (vector of procedures)
; 3: name (string)
; 4: row (fixnum)
@@ -3194,135 +3934,177 @@ EOF
; 7: type ('stream | 'custom | 'string | 'socket)
; 8: closed (fixnum)
; 9: data
-; 10-15: reserved, port class specific
+; 10-12: reserved, port class specific
+; 13: case sensitive? (boolean)
+; 14: mode ('textual | 'binary)
+; 15: reserved (encoding)
;
; 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)
+; 3: (write-bytevector PORT BYTEVECTOR START END)
+; 4: (close PORT DIRECTION)
; 5: (flush-output PORT)
; 6: (char-ready? PORT) -> BOOL
-; 7: (read-string! PORT COUNT STRING START) -> COUNT'
+; 7: (read-bytevector! PORT COUNT BYTEVECTOR START) -> COUNT'
; 8: (read-line PORT LIMIT) -> STRING | EOF
; 9: (read-buffered PORT) -> STRING
(define (##sys#make-port i/o class name type)
- (let ([port (##core#inline_allocate ("C_a_i_port" 17))])
+ (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#setislot port 6 #f)
(##sys#setslot port 7 type)
(##sys#setslot port 8 i/o)
+ (##sys#setislot port 10 #f)
+ (##sys#setislot port 13 #t)
+ (##sys#setislot port 14 'textual) ; default, only used for R7RS port predicates
+ (##sys#setslot port 15 'utf-8)
port) )
;;; Stream ports:
; Input port slots:
+; 10: peek buffer
; 12: Static buffer for read-line, allocated on-demand
(define ##sys#stream-port-class
- (vector (lambda (p) ; read-char
- (let loop ()
- (let ((c (##core#inline "C_read_char" p)))
- (cond
- ((eq? -1 c)
- (let ((err (##sys#update-errno)))
- (if (eq? err (foreign-value "EINTR" int))
- (##sys#dispatch-interrupt loop)
- (##sys#signal-hook/errno
- #:file-error err 'read-char
- (##sys#string-append "cannot read from port - " strerror)
- p))))
- (else c)))))
- (lambda (p) ; peek-char
- (let loop ()
- (let ((c (##core#inline "C_peek_char" p)))
- (cond
- ((eq? -1 c)
- (let ((err (##sys#update-errno)))
- (if (eq? err (foreign-value "EINTR" int))
- (##sys#dispatch-interrupt loop)
- (##sys#signal-hook/errno
- #:file-error err 'peek-char
- (##sys#string-append "cannot read from port - " strerror)
- p))))
- (else c)))))
- (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 d) ; 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 ((eof-object? len) ; EOF returns 0 bytes read
- act)
- ((fx< len 0)
- (let ((err (##sys#update-errno)))
- (if (eq? err (foreign-value "EINTR" int))
- (##sys#dispatch-interrupt
- (lambda ()
- (loop (fx- rem len) (fx+ act len) (fx+ start len))))
- (##sys#signal-hook/errno
- #:file-error err 'read-string!
- (##sys#string-append "cannot read from port - " strerror)
- p n dest start))))
- ((fx< len rem)
- (loop (fx- rem len) (fx+ act len) (fx+ start len)))
- (else
- (fx+ act len) ) ) )))
- (lambda (p rlimit) ; read-line
- (if rlimit (##sys#check-fixnum rlimit '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 rlimit 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)) ]
- ((fx< n 0)
+ (vector (lambda (p) ; read-char
+ (let loop ()
+ (let ((peeked (##sys#slot p 10)))
+ (cond (peeked
+ (##sys#setislot p 10 #f)
+ (##sys#decode-char peeked (##sys#slot p 15) 0))
+ ((eq? 'utf-8 (##sys#slot p 15)) ; fast path
+ (let ((c (##core#inline "C_read_char" p)))
+ (if (eq? -1 c)
+ (let ((err (##sys#update-errno)))
+ (if (eq? err (foreign-value "EINTR" int))
+ (##sys#dispatch-interrupt loop)
+ (##sys#signal-hook/errno
+ #:file-error err 'read-char
+ (##sys#string-append "cannot read from port - " strerror)
+ p)))
+ c)))
+ (else (##sys#read-char/encoding
+ p (##sys#slot p 15)
+ (lambda (buf start len dec)
+ (dec buf start len
+ (lambda (buf start len)
+ (##core#inline "C_utf_decode" buf start))))))))))
+ (lambda (p) ; peek-char
+ (let ((pb (##sys#slot p 10))
+ (enc (##sys#slot p 15)))
+ (if pb
+ (##sys#decode-char pb enc 0)
+ (##sys#read-char/encoding
+ p enc
+ (lambda (buf start len dec)
+ (let ((pb (##sys#make-bytevector len)))
+ (##core#inline "C_copy_memory_with_offset" pb buf 0 start len)
+ (##sys#setslot p 10 pb)
+ (dec buf start len
+ (lambda (buf start _)
+ (##core#inline "C_utf_decode" buf start)))))))))
+ (lambda (p c) ; write-char
+ (let ((enc (##sys#slot p 15)))
+ (if (eq? enc 'utf-8) ;; fast path
+ (##core#inline "C_display_char" p c)
+ (let* ((bv (##sys#make-bytevector 4))
+ (n (##sys#encode-char c bv enc)))
+ ((##sys#slot (##sys#slot p 2) 3) p bv 0 n))))) ; write-bytevector
+ (lambda (p bv from to) ; write-bytevector
+ (##sys#encode-buffer
+ bv from (fx- to from) (##sys#slot p 15)
+ (lambda (bv start len)
+ (##core#inline "C_display_string" p bv start len))))
+ (lambda (p d) ; 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-bytevector!
+ (let ((pb (##sys#slot p 10))
+ (nc 0))
+ (when pb
+ (set! nc (##sys#size pb))
+ (##core#inline "C_copy_memory_with_offset" dest pb start 0 nc)
+ (set! start (fx+ start nc))
+ (set! n (fx- n nc))
+ (##sys#setislot p 10 #f))
+ ;;XXX "n" below always true?
+ (let loop ((rem (or n (fx- (##sys#size dest) start)))
+ (act nc)
+ (start start))
+ (let ((len (##core#inline "fast_read_string_from_file" dest p rem start)))
+ (cond ((eof-object? len) ; EOF returns 0 bytes read
+ act)
+ ((fx< len 0)
+ (let ((err (##sys#update-errno)))
+ (if (eq? err (foreign-value "EINTR" int))
+ (##sys#dispatch-interrupt
+ (lambda () (loop rem act start)))
+ (##sys#signal-hook/errno
+ #:file-error err 'read-bytevector!
+ (##sys#string-append "cannot read from port - " strerror)
+ p n dest start))))
+ ((fx< len rem)
+ (loop (fx- rem len) (fx+ act len) (fx+ start len)))
+ (else (fx+ act len) ) ) ))))
+ (lambda (p rlimit) ; read-line
+ (when rlimit (##sys#check-fixnum rlimit 'read-line))
+ (let ((sblen read-line-buffer-initial-size))
+ (unless (##sys#slot p 12)
+ (##sys#setslot p 12 (##sys#make-bytevector sblen)))
+ (let loop ([len sblen]
+ [limit (or rlimit maximal-string-length)]
+ [buffer (##sys#slot p 12)]
+ [result ""]
+ [f #f])
+ (let* ((nlimit (fxmin limit len))
+ (n (##core#inline "fast_read_line_from_file" buffer
+ p nlimit)))
+ (cond ((eof-object? n) (if f result #!eof))
+ ((not n)
+ (let ((prev (##sys#buffer->string/encoding buffer 0 nlimit
+ (##sys#slot p 15))))
+ (if (fx< limit len)
+ (##sys#string-append result prev)
+ (loop (fx* len 2)
+ (fx- limit len)
+ (##sys#make-bytevector (fx* len 2))
+ (##sys#string-append result prev)
+ #t)) ) )
+ ((fx< n 0)
(let ((err (##sys#update-errno)))
(if (eq? err (foreign-value "EINTR" int))
- (let ((n (fx- (fxneg n) 1)))
- (##sys#dispatch-interrupt
- (lambda ()
- (loop len limit buffer
- (##sys#string-append
- result (##sys#substring buffer 0 n))
- #t))))
+ (let ((n (fx- (fxneg n) 1)))
+ (##sys#dispatch-interrupt
+ (lambda ()
+ (loop len limit buffer
+ (##sys#string-append
+ result
+ (##sys#buffer->string/encoding buffer 0 n (##sys#slot p 15)))
+ #t))))
(##sys#signal-hook/errno
#:file-error err 'read-line
(##sys#string-append "cannot read from port - " strerror)
p rlimit))))
- [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)] ) ) ) ) )
- #f ; read-buffered
- ) )
+ (f (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
+ (##sys#string-append result
+ (##sys#buffer->string/encoding buffer 0 n (##sys#slot p 15))))
+ (else
+ (##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
+ (##sys#buffer->string/encoding buffer 0 n (##sys#slot p 15))))))))
+ #f ; read-buffered
+ ) )
(define ##sys#open-file-port (##core#primitive "C_open_file_port"))
@@ -3391,23 +4173,37 @@ EOF
(define (##sys#port-data port) (##sys#slot port 9))
(define (##sys#set-port-data! port data) (##sys#setslot port 9 data))
+(define ##sys#default-file-encoding)
+
(let ()
(define (open name inp modes loc)
(##sys#check-string name loc)
- (let ([fmode (if inp "r" "w")]
- [bmode ""] )
- (do ([modes modes (##sys#slot modes 1)])
+ (let ((fmode (if inp "r" "w"))
+ (bmode "")
+ (enc (##sys#default-file-encoding)))
+ (do ((modes modes (##sys#slot modes 1)))
((null? modes))
- (let ([o (##sys#slot modes 0)])
+ (let ((o (##sys#slot modes 0)))
(case o
- [(#:binary) (set! bmode "b")]
- [(#:text) (set! bmode "")]
- [(#:append)
+ ((#:binary binary)
+ (set! bmode "b")
+ (set! enc 'binary))
+ ((#:text text) (set! bmode ""))
+ ((#:utf-8 utf-8)
+ (set! enc 'utf-8))
+ ((#:latin-1 latin-1 #:iso-8859-1 iso-8859-1)
+ (set! enc 'latin-1))
+ ((#:unix #:nl unix nl)
+ (set! bmode "b"))
+ ((#:crnl crnl)
+ (set! bmode ""))
+ ((#:append append)
(if inp
(##sys#error loc "cannot use append mode with input file")
- (set! fmode "a") ) ]
- [else (##sys#error loc "invalid file option" o)] ) ) )
+ (set! fmode "a") ) )
+ (else (##sys#error loc "invalid file option" o)) ) ) )
(let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class name 'stream)))
+ (##sys#setslot port 15 enc)
(unless (##sys#open-file-port port name (##sys#string-append fmode bmode))
(##sys#signal-hook/errno #:file-error (##sys#update-errno) loc
(##sys#string-append "cannot open file - " strerror)
@@ -3462,7 +4258,7 @@ EOF
(set! scheme#with-output-to-file
(let ((open-output-file open-output-file)
- (close-output-port close-output-port) )
+ (close-output-port close-output-port) )
(lambda (str thunk . mode)
(let ((file (apply open-output-file str mode)))
(fluid-let ((##sys#standard-output file))
@@ -3475,9 +4271,9 @@ EOF
(case (##core#inline "C_i_file_exists_p" (##sys#make-c-string name loc) file? dir?)
((#f) #f)
((#t) #t)
- (else
- (##sys#signal-hook
- #:file-error loc "system error while trying to access file"
+ (else
+ (##sys#signal-hook
+ #:file-error loc "system error while trying to access file"
name))))
(define (##sys#flush-output port)
@@ -3526,10 +4322,11 @@ EOF
;;; Create lambda-info object
(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)
+ (let* ((bv (##sys#slot str 0))
+ (sz (fx- (##sys#size bv) 1))
+ (info (##sys#make-bytevector sz)))
+ (##core#inline "C_copy_memory" info bv sz)
+ (##core#inline "C_bytevector_to_lambdainfo" info)
info) )
@@ -3543,26 +4340,27 @@ EOF
(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) )
+ (bv (##sys#make-bytevector (fx+ sz 1))) )
+ (##core#inline "C_copy_memory" bv info sz)
+ (##core#inline_allocate ("C_a_ustring" 5) bv
+ (##core#inline "C_utf_length" bv))))
(set! chicken.base#procedure-information
(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) ) ) )
+ (##sys#read (scheme#open-input-string (##sys#lambda-info->string info)) #f) ) ) )
;;; SRFI-17
(define setter-tag (vector 'setter))
-(define-inline (setter? x)
+(define-inline (setter? x)
(and (pair? x) (eq? setter-tag (##sys#slot x 0))) )
(set! chicken.base#setter
- (##sys#decorate-lambda
+ (##sys#decorate-lambda
(lambda (proc)
(or (and-let* (((procedure? proc))
(d (##sys#lambda-decoration proc setter?)) )
@@ -3570,9 +4368,9 @@ EOF
(##sys#error 'setter "no setter defined" proc) ) )
setter?
(lambda (proc i)
- (##sys#setslot
+ (##sys#setslot
proc i
- (cons
+ (cons
setter-tag
(lambda (get set)
(if (procedure? get)
@@ -3633,13 +4431,18 @@ EOF
scheme#list-ref
(lambda (x i y) (set-car! (list-tail x i) y))))
+(set! chicken.bytevector#bytevector-u8-ref
+ (getter-with-setter chicken.bytevector#bytevector-u8-ref
+ chicken.bytevector#bytevector-u8-set!
+ "(chicken.bytevector#bytevector-u8-ref v i)"))
+
;;; Parameters:
(define ##sys#default-parameter-vector (##sys#make-vector default-parameter-vector-size))
(define ##sys#current-parameter-vector '#())
-(set! chicken.base#make-parameter
+(set! scheme#make-parameter
(let ((count 0))
(lambda (init #!optional (guard (lambda (x) x)))
(let* ((val (guard init))
@@ -3664,7 +4467,6 @@ EOF
(fx+ i 1)
(##core#undefined)) ) )
(##sys#setslot ##sys#default-parameter-vector i val)
-
(getter-with-setter
(lambda args
(let ((n (##sys#size ##sys#current-parameter-vector)))
@@ -3682,7 +4484,7 @@ EOF
(lambda (val)
(let ((n (##sys#size ##sys#current-parameter-vector)))
(assign val n #f #t))))))))
-
+
;;; Input:
@@ -3716,7 +4518,7 @@ EOF
(define (##sys#peek-char-0 p)
(if (##sys#slot p 6)
#!eof
- (let ([c ((##sys#slot (##sys#slot p 2) 1) p)]) ; peek-char
+ (let ((c ((##sys#slot (##sys#slot p 2) 1) p))) ; peek-char
(when (##core#inline "C_eofp" c)
(##sys#setislot p 6 #t) )
c) ) )
@@ -3736,6 +4538,8 @@ EOF
(define (##sys#read-prompt-hook) #f) ; just here so that srfi-18 works without eval
(define (##sys#infix-list-hook lst) lst)
+(set! ##sys#default-file-encoding (make-parameter 'utf-8))
+
(define (##sys#sharp-number-hook port n)
(##sys#read-error port "invalid `#...' read syntax" n) )
@@ -3774,16 +4578,18 @@ EOF
(define ##sys#read
(let ((string-append string-append)
(keyword-style keyword-style)
- (case-sensitive case-sensitive)
(parentheses-synonyms parentheses-synonyms)
+ (case-sensitive case-sensitive)
(symbol-escape symbol-escape)
(current-read-table ##sys#current-read-table))
(lambda (port infohandler)
- (let ((csp (case-sensitive))
+ (let ((csp (and (case-sensitive) (##sys#slot port 13)))
(ksp (keyword-style))
(psp (parentheses-synonyms))
(sep (symbol-escape))
(crt (current-read-table))
+ (warn #f)
+ (shared '())
; set below - needs more state to make a decision
(terminating-characters '(#\, #\; #\( #\) #\' #\" #\[ #\] #\{ #\}))
(reserved-characters #f) )
@@ -3811,12 +4617,42 @@ EOF
(reserved-character c)
c) ) )
+ (define (register-shared! n thunk)
+ (set! shared (cons (cons n thunk) shared)))
+
+ (define (unthunk o fail)
+ (let ((v (o)))
+ (cond ((not (procedure? v)) v)
+ ((eq? v o)
+ (fail "self-referential datum"))
+ (else
+ (unthunk v fail)))))
+
+ ;; Fills holes in `o` destructively.
+ (define (unthunkify! o fail)
+ (let loop! ((o o))
+ (cond ((pair? o)
+ (if (not (procedure? (car o)))
+ (loop! (car o))
+ (set-car! o (unthunk (car o) fail)))
+ (if (not (procedure? (cdr o)))
+ (loop! (cdr o))
+ (set-cdr! o (unthunk (cdr o) fail))))
+ ((vector? o)
+ (let ((len (##sys#size o)))
+ (do ((i 0 (fx+ i 1)))
+ ((eq? i len))
+ (let ((v (##sys#slot o i)))
+ (if (not (procedure? v))
+ (loop! v)
+ (##sys#setslot o i (unthunk v fail))))))))))
+
(define (readrec)
(define (r-spaces)
(let loop ([c (##sys#peek-char-0 port)])
(cond ((##core#inline "C_eofp" c))
- ((eq? #\; c)
+ ((eq? #\; c)
(skip-to-eol)
(loop (##sys#peek-char-0 port)) )
((char-whitespace? c)
@@ -3835,20 +4671,45 @@ EOF
"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")
+ (##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-xsequence delim)
+ (define (parse seq)
+ (let* ((str (##sys#reverse-list->string seq))
+ (n (string->number str 16)))
+ (or n
+ (##sys#read-error port
+ (string-append "invalid escape-sequence '\\x"
+ str ";\'")))))
+ (define (complain)
+ (set! warn "unterminated hexadecimal escape sequence"))
+ (define (abort)
+ (##sys#read-error port "unterminated hexadecimal escape sequence") )
+ (let loop ((seq '()))
+ (let ((x (##sys#peek-char-0 port)))
+ (cond ((eof-object? x) (abort))
+ ((eq? delim x)
+ (let ((n (parse seq)))
+ (if (fx> n #x1ffff)
+ (abort)
+ (begin (complain) n))))
+ ((eq? #\; x)
+ (##sys#read-char-0 port)
+ (parse seq))
+ ((or (and (char>=? x #\0) (char<=? x #\9))
+ (and (char>=? x #\a) (char<=? x #\f))
+ (and (char>=? x #\A) (char<=? x #\F)))
+ (loop (cons (##sys#read-char-0 port) seq)))
+ (else
+ (let ((n (parse seq)))
+ (if (fx> n #x1ffff)
+ (abort)
+ (begin (complain) n))))))))
(define (r-string term)
(let loop ((c (##sys#read-char-0 port)) (lst '()))
- (cond ((##core#inline "C_eofp" c)
+ (cond ((##core#inline "C_eofp" c)
(##sys#read-error port "unterminated string") )
((eq? #\\ c)
(set! c (##sys#read-char-0 port))
@@ -3860,27 +4721,17 @@ EOF
((#\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 16))])
+ ((#\x)
+ (let ((ch (integer->char (r-xsequence term))))
(loop (##sys#read-char-0 port) (cons ch lst)) ) )
((#\u)
- (let ([n (r-usequence "u" 4 16)])
- (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 16))
- (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)) ) ))
+ (let ((n (r-usequence "u" 4 16)))
+ (loop (##sys#read-char-0 port)
+ (cons (integer->char n) lst)) ) )
((#\U)
- (let ([n (r-usequence "U" 8 16)])
- (if (##sys#unicode-surrogate? n)
- (##sys#read-error port "invalid escape (surrogate)" n)
- (loop (##sys#read-char-0 port) (r-cons-codepoint n lst)) )))
+ (let ((n (r-usequence "U" 8 16)))
+ (loop (##sys#read-char-0 port)
+ (cons (integer->char n) lst)) ))
((#\\ #\' #\" #\|)
(loop (##sys#read-char-0 port) (cons c lst)))
((#\newline #\return #\space #\tab)
@@ -3902,8 +4753,8 @@ EOF
(eat-ws (##sys#read-char-0 port) #t)))
(else
(unless nl?
- (##sys#read-warning
- port
+ (##sys#read-warning
+ port
"escaped whitespace, but no newline - collapsing anyway"))
(loop c lst)))))
(else
@@ -3912,19 +4763,19 @@ EOF
((and (char-numeric? c)
(char>=? c #\0)
(char<=? c #\7))
- (let ((ch (integer->char
+ (let ((ch (integer->char
(fx+ (fx* (fx- (char->integer c) 48) 64)
(r-usequence "" 2 8)))))
(loop (##sys#read-char-0 port) (cons ch lst)) ))
(else
- (##sys#read-warning
- port
+ (##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))) ) ))
-
+
(define (r-list start end)
(if (eq? (##sys#read-char-0 port) start)
(let ((first #f)
@@ -3932,7 +4783,7 @@ EOF
(outer-container container) )
(define (starting-line msg)
(if (and ln0 ##sys#read-error-with-line-number)
- (string-append
+ (string-append
msg ", starting in line "
(##sys#number->string ln0))
msg))
@@ -3951,7 +4802,7 @@ EOF
(unless first (set! ln0 (##sys#port-line port)))
(let ([c (##sys#peek-char-0 port)])
(cond ((##core#inline "C_eofp" c)
- (##sys#read-error
+ (##sys#read-error
port
(starting-line "unterminated list") ) )
((eq? c end)
@@ -3989,7 +4840,7 @@ EOF
(##sys#string->number tok)))
(else (build-symbol tok))))
(node (cons val '())))
- (if first
+ (if first
(##sys#setslot last 1 node)
(set! first node) )
(loop node))))))))
@@ -4004,13 +4855,13 @@ EOF
(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 exactness)
(r-xtoken
(lambda (tok kw)
@@ -4019,7 +4870,7 @@ EOF
(info 'symbol-info s (##sys#port-line port)) ))
((string=? tok ".")
(##sys#read-error port "invalid use of `.'"))
- ((and (fx> (##sys#size tok) 0) (char=? (string-ref tok 0) #\#))
+ ((and (fx> (string-length tok) 0) (char=? (string-ref tok 0) #\#))
(##sys#read-error port "unexpected prefix in number syntax" tok))
((##sys#string->number tok (or radix 10) exactness))
(radix (##sys#read-error port "illegal number syntax" tok))
@@ -4029,7 +4880,7 @@ EOF
(cond [(eq? #\# (##sys#peek-char-0 port))
(##sys#read-char-0 port)
(let ([c2 (##sys#read-char-0 port)])
- (cond [(eof-object? c2)
+ (cond [(eof-object? c2)
(##sys#read-error port "unexpected end of numeric literal")]
[(char=? c2 #\i) (r-number radix 'i)]
[(char=? c2 #\e) (r-number radix 'e)]
@@ -4038,7 +4889,7 @@ EOF
port
"illegal number syntax - invalid exactness prefix" c2)] ) ) ]
[else (r-number radix #f)] ) )
-
+
(define (r-number-with-radix exactness)
(cond [(eq? #\# (##sys#peek-char-0 port))
(##sys#read-char-0 port)
@@ -4050,7 +4901,7 @@ EOF
[(char=? c2 #\b) (r-number 2 exactness)]
[else (##sys#read-error port "illegal number syntax - invalid radix" c2)] ) ) ]
[else (r-number 10 exactness)] ) )
-
+
(define (r-token)
(let loop ((c (##sys#peek-char-0 port)) (lst '()))
(cond ((or (eof-object? c)
@@ -4061,8 +4912,8 @@ EOF
(##sys#read-error port "attempt to read expression from something that looks like binary data"))
(else
(read-unreserved-char-0 port)
- (loop (##sys#peek-char-0 port)
- (cons (if csp c (char-downcase c)) lst) ) ) ) ) )
+ (loop (##sys#peek-char-0 port)
+ (cons (if csp c (char-foldcase c)) lst) ) ) ) ) )
(define (r-digits)
(let loop ((c (##sys#peek-char-0 port)) (lst '()))
@@ -4125,41 +4976,41 @@ EOF
(loop (cons c lst) #f qtd))))
(else
(loop
- (cons (if csp c (char-downcase c)) lst)
+ (cons (if csp c (char-foldcase c)) lst)
#f qtd)))))))))
-
+
(define (r-char)
;; Code contributed by Alex Shinn
(let* ([c (##sys#peek-char-0 port)]
[tk (r-token)]
- [len (##sys#size tk)])
+ [len (string-length 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)))
+ [(and-let* ((c0 (char->integer (string-ref 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))
+ (fxand (char->integer
+ (string-ref tk 1))
#b111111))))
(cond ((fx>= n 3)
(set! res (fx+ (fxshl res 6)
- (fxand
+ (fxand
(char->integer
- (##core#inline "C_subchar" tk 2))
+ (string-ref tk 2))
#b111111)))
(if (fx= n 4)
(set! res (fx+ (fxshl res 6)
(fxand (char->integer
- (##core#inline "C_subchar" tk 3))
+ (string-ref tk 3))
#b111111))))))
(integer->char res))]
- [(char-name (##sys#intern-symbol tk))]
+ [(char-name (##sys#string->symbol tk))]
[else (##sys#read-error port "unknown named character" tk)] ) ]
[(memq c terminating-characters) (##sys#read-char-0 port)]
[else c] ) ) )
@@ -4188,16 +5039,15 @@ EOF
(info 'list-info (list q (readrec)) ln)))
(define (build-symbol tok)
- (##sys#intern-symbol tok) )
+ (##sys#string->symbol tok) )
(define (build-keyword tok)
- (##sys#intern-keyword tok))
+ (##sys#intern-keyword (##sys#string->symbol-name tok)))
;; now have the state to make a decision.
(set! reserved-characters
(append (if (not psp) '(#\[ #\] #\{ #\}) '())
(if (not sep) '(#\|) '())))
-
(r-spaces)
(let* ((c (##sys#peek-char-0 port))
(srst (##sys#slot crt 1))
@@ -4232,18 +5082,32 @@ EOF
((char-numeric? dchar)
(let* ((n (string->number (r-digits)))
(dchar2 (##sys#peek-char-0 port))
- (spdrst (##sys#slot crt 3))
- (h (and (char? dchar2) spdrst
- (##sys#slot spdrst (char->integer dchar2)) ) ) )
- ;; #<num> handled by parameterized # read-table entry?
+ (spdrst (##sys#slot crt 3)))
(cond ((eof-object? dchar2)
(##sys#read-error
port "unexpected end of input after reading"
c n))
- (h (##sys#call-with-values
- (lambda () (h dchar2 port n))
- (lambda xs (if (null? xs) (readrec) (car xs)))))
- ;; #<num>?
+ ;; #<num>=...
+ ((eq? #\= dchar2)
+ (##sys#read-char-0 port)
+ (letrec ((datum (begin
+ (register-shared! n (lambda () datum))
+ (readrec))))
+ datum))
+ ;; #<num>#
+ ((eq? #\# dchar2)
+ (##sys#read-char-0 port)
+ (cond ((assq n shared) => cdr)
+ (else (##sys#read-error port "undefined datum" n))))
+ ;; #<num> handled by parameterized # read-table entry?
+ ((and (char? dchar2)
+ spdrst
+ (##sys#slot spdrst (char->integer dchar2))) =>
+ (lambda (h)
+ (h (##sys#call-with-values
+ (lambda () (h dchar2 port n))
+ (lambda xs (if (null? xs) (readrec) (car xs)))))))
+ ;; #<num>
((or (eq? dchar2 #\)) (char-whitespace? dchar2))
(##sys#sharp-number-hook port n))
(else (##sys#read-char-0 port) ; Consume it first
@@ -4258,7 +5122,7 @@ EOF
(##sys#call-with-values
(lambda () (h dchar port))
(lambda xs (if (null? xs) (readrec) (car xs))))
- ;; otherwise chicken extended r5rs syntax
+ ;; otherwise chicken extended R7RS 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))
@@ -4266,16 +5130,6 @@ EOF
((#\b) (##sys#read-char-0 port) (r-number-with-exactness 2))
((#\i) (##sys#read-char-0 port) (r-number-with-radix 'i))
((#\e) (##sys#read-char-0 port) (r-number-with-radix 'e))
- ((#\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))
((#\|)
@@ -4292,20 +5146,15 @@ EOF
(r-quote 'quasisyntax))
((#\$)
(##sys#read-char-0 port)
- (let ((c (##sys#peek-char-0 port)))
- (cond ((char=? c #\{)
- (##sys#read-char-0 port)
- (##sys#read-bytevector-literal port))
- (else
- ;; HACK: reuse r-quote to add line number info
- (r-quote 'location)))))
+ ;; HACK: reuse r-quote to add line number info
+ (r-quote 'location))
((#\:)
(##sys#read-char-0 port)
(let ((c (##sys#peek-char-0 port)))
(fluid-let ((ksp #f))
(r-xtoken
(lambda (str kw)
- (if (and (eq? 0 (##sys#size str))
+ (if (and (eq? 0 (string-length str))
(not (char=? c #\|)))
(##sys#read-error port "empty keyword")
(build-keyword str)))))))
@@ -4325,18 +5174,25 @@ EOF
(readrec) )
(else
(let ([tok (r-token)])
- (cond [(string=? "eof" tok) #!eof]
- ;; TODO: use #!bwp when we have a bootstrapping compiler whose reader supports it
- [(string=? "bwp" tok) (foreign-value "C_SCHEME_BROKEN_WEAK_PTR" scheme-object)]
- [(member tok '("optional" "rest" "key"))
- (build-symbol (##sys#string-append "#!" tok)) ]
- [else
+ (cond ((string=? "eof" tok) #!eof)
+ ((string=? "bwp" tok) #!bwp)
+ ((string=? "fold-case" tok)
+ (set! csp #f)
+ (##sys#setislot port 13 csp)
+ (readrec))
+ ((string=? "no-fold-case" tok)
+ (set! csp #t)
+ (##sys#setislot port 13 csp)
+ (readrec))
+ ((member tok '("optional" "rest" "key"))
+ (build-symbol (##sys#string-append "#!" tok)) )
+ (else
(let ((a (assq (string->symbol tok) ##sys#read-marks)))
(if a
((##sys#slot a 1) port)
(##sys#read-error
port
- "invalid `#!' token" tok) ) ) ] ) ) ) ) ) )
+ "invalid `#!' token" tok) ) ) ) ) ) ) ) ) )
(else
(##sys#call-with-values (lambda () (##sys#user-read-hook dchar port))
(lambda xs (if (null? xs) (readrec) (car xs)))) ) ) ) )) ) ) )
@@ -4356,68 +5212,12 @@ EOF
((#\{) (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)))) )
-
-(define (##sys#read-bytevector-literal port)
- (define (hex c)
- (let ((c (char-downcase c)))
- (cond ((and (char>=? c #\a) (char<=? c #\f))
- (fx- (char->integer c) 87) ) ; - #\a + 10
- ((and (char>=? c #\0) (char<=? c #\9))
- (fx- (char->integer c) 48))
- (else (##sys#read-error port "invalid hex-code in blob-literal")))))
- (let loop ((lst '()) (h #f))
- (let ((c (##sys#read-char-0 port)))
- (cond ((eof-object? c)
- (##sys#read-error port "unexpected end of blob literal"))
- ((char=? #\} c)
- (let ((str (##sys#reverse-list->string
- (if h
- (cons (integer->char (fxshr h 4)) lst)
- lst))))
- (##core#inline "C_string_to_bytevector" str)
- str))
- ((char-whitespace? c)
- (if h
- (loop (cons (integer->char (fxshr h 4)) lst) #f)
- (loop lst h)))
- (h (loop (cons (integer->char (fxior h (hex c))) lst) #f))
- (else (loop lst (fxshl (hex c) 4)))))))
+ (let ((x (readrec)))
+ (when warn (##sys#read-warning port warn))
+ (when (pair? shared)
+ (unthunkify! x (lambda a (apply ##sys#read-error p a))))
+ x)))))
;;; Hooks for user-defined read-syntax:
;
@@ -4426,12 +5226,61 @@ EOF
; - Don't forget to read 'char', it's only peeked at this point.
(define (##sys#user-read-hook char port)
+ (define (fail item) (##sys#read-error port "invalid sharp-sign read syntax" item))
(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) ) ) )
-
+ ((#\f #\t #\u)
+ (let ((sym (##sys#read port ##sys#default-read-info-hook)))
+ (if (not (symbol? sym))
+ (fail char)
+ (case sym
+ ((t true) #t)
+ ((f false) #f)
+ ((u8)
+ ;; u8vectors, srfi-4 handles this already via read-hook but we reimplement it
+ ;; here in case srfi-4 is not loaded
+ (let ((d (##sys#read-numvector-data port)))
+ (if (or (null? d) (pair? d))
+ (##sys#list->bytevector (##sys#canonicalize-number-list! d))
+ ;; reuse already created bytevector
+ (##core#inline "C_chop_bv" (##sys#slot d 0)))))
+ (else (fail sym))))))
+ (else (fail char))))
+
+(define (##sys#read-numvector-data port)
+ (let ((c (##sys#peek-char-0 port)))
+ (case c
+ ((#\() (##sys#read port ##sys#default-read-info-hook))
+ ((#\") (##sys#read port ##sys#default-read-info-hook))
+ (else (##sys#read-error port "invalid numeric vector syntax" c)))))
+
+;; This code is too complicated. We try to avoid mapping over
+;; a potentially large list and creating lots of garbage in the
+;; process, therefore the final result list is constructed
+;; via destructive updates and thus rather inelegant yet avoids
+;; any re-consing unless elements are non-numeric.
+(define (##sys#canonicalize-number-list! lst1)
+ (let loop ((lst lst1) (prev #f))
+ (if (and (##core#inline "C_blockp" lst)
+ (##core#inline "C_pairp" lst))
+ (let retry ((x (##sys#slot lst 0)))
+ (cond ((char? x) (retry (string x)))
+ ((string? x)
+ (if (zero? (string-length x))
+ (loop (##sys#slot lst 1) prev)
+ (let loop2 ((ns (string->list x)) (prev prev))
+ (let ((n (cons (char->integer (##sys#slot ns 0))
+ (##sys#slot lst 1))))
+ (if prev
+ (##sys#setslot prev 1 n)
+ (set! lst1 n))
+ (let ((ns2 (##sys#slot ns 1)))
+ (if (null? ns2)
+ (loop (##sys#slot lst 1) n)
+ (loop2 (##sys#slot ns 1) n)))))))
+ (else (loop (##sys#slot lst 1) lst))))
+ (cond (prev (##sys#setslot prev 1 '())
+ lst1)
+ (else '())))))
;;; Table for specially-handled read-syntax:
;
@@ -4445,7 +5294,7 @@ EOF
;;; Output:
(define (##sys#write-char-0 c p)
- ((##sys#slot (##sys#slot p 2) 2) p c)
+ ((##sys#slot (##sys#slot p 2) 2) p c)
(##sys#void))
(define (##sys#write-char/port c port)
@@ -4475,7 +5324,7 @@ EOF
(define-inline (*print-each lst)
(for-each (cut ##sys#print <> #f ##sys#standard-output) lst) )
-
+
(set! chicken.base#print
(lambda args
(##sys#check-output-port ##sys#standard-output #t 'print)
@@ -4496,17 +5345,19 @@ EOF
(define ##sys#print
(let ((case-sensitive case-sensitive)
+ (symbol-escape symbol-escape)
(keyword-style keyword-style))
(lambda (x readable port)
(##sys#check-output-port port #t #f)
- (let ([csp (case-sensitive)]
- [ksp (keyword-style)]
- [length-limit (##sys#print-length-limit)]
- [special-characters '(#\( #\) #\, #\[ #\] #\{ #\} #\' #\" #\; #\ #\` #\| #\\)] )
+ (let ((csp (case-sensitive))
+ (ksp (keyword-style))
+ (sep (symbol-escape))
+ (length-limit (##sys#print-length-limit))
+ (special-characters '(#\( #\) #\, #\[ #\] #\{ #\} #\' #\" #\; #\ #\` #\| #\\)) )
(define (outstr port str)
(if length-limit
- (let* ((len (##sys#size str))
+ (let* ((len (string-length str))
(cpp0 (current-print-length))
(cpl (fx+ cpp0 len)) )
(if (fx> cpl length-limit)
@@ -4517,9 +5368,10 @@ EOF
(outstr0 port str) )
(current-print-length cpl) )
(outstr0 port str) ) )
-
+
(define (outstr0 port str)
- ((##sys#slot (##sys#slot port 2) 3) port str) )
+ (let ((bv (##sys#slot str 0)))
+ ((##sys#slot (##sys#slot port 2) 3) port bv 0 (fx- (##sys#size bv) 1)))) ; write-bytevector
(define (outchr port chr)
(when length-limit
@@ -4528,7 +5380,7 @@ EOF
(when (fx>= cpp0 length-limit)
(outstr0 port "...")
((##sys#print-exit) (##sys#void)))))
- ((##sys#slot (##sys#slot port 2) 2) port chr))
+ ((##sys#slot (##sys#slot port 2) 2) port chr)) ; write-char
(define (specialchar? chr)
(let ([c (char->integer chr)])
@@ -4536,23 +5388,23 @@ EOF
(memq chr special-characters) ) ) )
(define (outsym port sym)
- (let ((str (##sys#symbol->string sym)))
- (if (or (not readable) (sym-is-readable? str))
+ (let ((str (##sys#symbol->string/shared sym)))
+ (if (or (not sep) (not readable) (sym-is-readable? str))
(outstr port str)
(outreadablesym port str))))
(define (outreadablesym port str)
- (let ((len (##sys#size str)))
+ (let ((len (string-length str)))
(outchr port #\|)
(let loop ((i 0))
(if (fx>= i len)
(outchr port #\|)
- (let ((c (##core#inline "C_subchar" str i)))
+ (let ((c (string-ref str i)))
(cond ((or (char<? c #\space) (char>? c #\~))
(outstr port "\\x")
(let ((n (char->integer c)))
- (when (fx< n 16) (outchr port #\0))
(outstr port (##sys#number->string n 16))
+ (outchr port #\;)
(loop (fx+ i 1))))
(else
(when (or (eq? c #\|) (eq? c #\\)) (outchr port #\\))
@@ -4560,10 +5412,10 @@ EOF
(loop (fx+ i 1)) ) ) ) ) )))
(define (sym-is-readable? str)
- (let ((len (##sys#size str)))
+ (let ((len (string-length str)))
(cond ((eq? len 0) #f)
((eq? len 1)
- (let ((c (##core#inline "C_subchar" str 0)))
+ (let ((c (string-ref str 0)))
(cond ((or (eq? #\# c) (eq? #\. c)) #f)
((specialchar? c) #f)
((char-numeric? c) #f)
@@ -4571,22 +5423,25 @@ EOF
(else
(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)) )
+ (let ((c (string-ref str 0)))
+ (cond ((char-numeric? c) #f)
+ ((or (eq? c #\+) (eq? c #\-))
+ (or (fx= len 1)
+ (not (char-numeric? (string-ref str 1)))))
+ ((eq? c #\.)
+ (and (fx> len 1)
+ (not (char-numeric? (string-ref str 1)))))
((eq? c #\:) #f)
((and (eq? c #\#)
;; Not a qualified symbol?
(not (and (fx> len 2)
- (eq? (##core#inline "C_subchar" str 1) #\#)
- (not (eq? (##core#inline "C_subchar" str 2) #\#)))))
- (member str '("#!rest" "#!key" "#!optional")))
+ (eq? (string-ref str 1) #\#)
+ (not (eq? (string-ref str 2) #\#)))))
+ (member str '("#!rest" "#!key" "#!optional"
+ "#!fold-case" "#!no-fold-case")))
((specialchar? c) #f)
(else #t) ) )
- (let ((c (##core#inline "C_subchar" str i)))
+ (let ((c (string-ref str i)))
(and (or csp (not (char-upper-case? c)))
(not (specialchar? c))
(or (not (eq? c #\:))
@@ -4604,13 +5459,13 @@ EOF
(cond [readable
(outstr port "#\\")
(let ([code (char->integer x)])
- (cond [(char-name x)
- => (lambda (cn)
- (outstr port (##sys#slot cn 1)) ) ]
- [(or (fx< code 32) (fx> code 255))
+ (cond [(char-name x)
+ => (lambda (cn)
+ (outstr port (##sys#symbol->string/shared cn)) ) ]
+ [(or (fx< code 32) (fx> code #x1ffff))
(outchr port #\x)
(outstr port (##sys#number->string code 16)) ]
- [else (outchr port x)] ) ) ]
+ [else (outchr port x)] ) ) ]
[else (outchr port x)] ) )
((##core#inline "C_fixnump" x) (outstr port (##sys#number->string x)))
((##core#inline "C_unboundvaluep" x) (outstr port "#<unbound value>"))
@@ -4629,22 +5484,22 @@ EOF
(outstr port "#:")
(outsym port x))))
((##core#inline "C_i_symbolp" x) (outsym port x))
- ((##sys#number? x) (outstr port (##sys#number->string x)))
+ ((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)) )
+ (c (string-length x) (fx- c 1)) )
((eq? c 0)
(outchr port #\") )
- (let ((chr (##core#inline "C_subbyte" x i)))
+ (let ((chr (char->integer (string-ref x i))))
(case chr
((34) (outstr port "\\\""))
((92) (outstr port "\\\\"))
(else
(cond ((or (fx< chr 32)
- (fx= chr 127))
+ (fx= chr #x1ffff))
(outchr port #\\)
(case chr
((7) (outchr port #\a))
@@ -4657,7 +5512,8 @@ EOF
(else
(outchr port #\x)
(when (fx< chr 16) (outchr port #\0))
- (outstr port (##sys#number->string chr 16)) ) ) )
+ (outstr port (##sys#number->string chr 16))
+ (outchr port #\;) ) ) )
(else (outchr port (##core#inline "C_fix_to_char" chr)) ) ) ) ) ) ) )
(else (outstr port x)) ) )
((##core#inline "C_pairp" x)
@@ -4673,15 +5529,8 @@ EOF
(outchr port #\space)
(out (##sys#slot x 0)) ) )
((##core#inline "C_bytevectorp" x)
- (outstr port "#${")
- (let ((len (##sys#size x)))
- (do ((i 0 (fx+ i 1)))
- ((fx>= i len))
- (let ((b (##sys#byte x i)))
- (when (fx< b 16)
- (outchr port #\0))
- (outstr port (##sys#number->string b 16)))))
- (outchr port #\}) )
+ (outstr port "#u8")
+ (out (##sys#bytevector->list x)))
((##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>"))
@@ -4697,7 +5546,7 @@ EOF
(outstr port (##sys#slot x 3))
(outstr port "\">") )
((##core#inline "C_vectorp" x)
- (let ((n (##core#inline "C_block_size" x)))
+ (let ((n (##sys#size x)))
(cond ((eq? 0 n)
(outstr port "#()") )
(else
@@ -4712,7 +5561,7 @@ EOF
(else (##sys#error "unprintable block object encountered")))))
(##sys#void))))
-(define ##sys#procedure->string
+(define ##sys#procedure->string
(let ((string-append string-append))
(lambda (x)
(let ((info (##sys#lambda-info x)))
@@ -4724,13 +5573,11 @@ EOF
(set! chicken.base#record-printer
(lambda (type)
- (##sys#check-symbol type 'record-printer)
(let ((a (assq type ##sys#record-printers)))
(and a (cdr a)))))
(set! chicken.base#set-record-printer!
(lambda (type proc)
- (##sys#check-symbol type 'set-record-printer!)
(##sys#check-closure proc 'set-record-printer!)
(let ((a (assq type ##sys#record-printers)))
(if a
@@ -4746,11 +5593,12 @@ EOF
(define (##sys#user-print-hook x readable port)
(let* ((type (##sys#slot x 0))
- (a (assq type ##sys#record-printers)) )
+ (a (assq type ##sys#record-printers))
+ (name (if (vector? type) (##sys#slot type 0) type)))
(cond (a (handle-exceptions ex
(begin
(##sys#print "#<Error in printer of record type `" #f port)
- (##sys#print (##sys#symbol->string type) #f port)
+ (##sys#print name #f port)
(if (##sys#structure? ex 'condition)
(and-let* ((a (member '(exn . message) (##sys#slot ex 2))))
(##sys#print "': " #f port)
@@ -4760,7 +5608,7 @@ EOF
((##sys#slot a 1) x port)))
(else
(##sys#print "#<" #f port)
- (##sys#print (##sys#symbol->string type) #f port)
+ (##sys#print name #f port)
(case type
((condition)
(##sys#print ": " #f port)
@@ -4787,76 +5635,77 @@ EOF
;
; Input:
;
-; 10: position
+; 10: position (in bytes)
; 11: len
-; 12: string
+; 12: input bytevector
;
; Output:
;
-; 10: position
+; 10: position (in bytes)
; 11: limit
-; 12: output
+; 12: output bytevector
(define ##sys#string-port-class
- (letrec ([check
+ (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)] )
+ (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)
+ [buf (##sys#make-bytevector limit3)] )
+ (##core#inline "C_copy_memory_with_offset" buf output 0 0 position)
(##sys#setslot p 12 buf)
(##sys#setislot p 11 limit3)
- (check p n) ) ) ) ) ] )
+ (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 (fx>= position len)
- #!eof
- (let ((c (##core#inline "C_subchar" string position)))
- (##sys#setislot p 10 (fx+ position 1))
- c) ) ) )
+ (let ((position (##sys#slot p 10))
+ (input (##sys#slot p 12))
+ (len (##sys#slot p 11)))
+ (if (fx>= position len)
+ #!eof
+ (let ((c (##core#inline "C_utf_decode" input position)))
+ (##sys#setislot p 10
+ (##core#inline "C_utf_advance" input position))
+ 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) ) ) )
+ (let ((position (##sys#slot p 10))
+ (input (##sys#slot p 12))
+ (len (##sys#slot p 11)))
+ (if (fx>= position len)
+ #!eof
+ (##core#inline "C_utf_decode" input position))))
(lambda (p c) ; write-char
- (check p 1)
+ (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)])
+ (##sys#setislot p 10 (##core#inline "C_utf_insert" output position c))))
+ (lambda (p bv from to) ; write-bytevector
+ (let ((len (fx- to from)))
(check p len)
- (let ([position (##sys#slot p 10)]
- [output (##sys#slot p 12)] )
- (##core#inline "C_substring_copy" str output 0 len position)
+ (let* ((position (##sys#slot p 10))
+ (output (##sys#slot p 12)))
+ (##core#inline "C_copy_memory_with_offset" output bv position from len)
(##sys#setislot p 10 (fx+ position len)) ) ) )
void ; close
(lambda (p) #f) ; flush-output
(lambda (p) #t) ; char-ready?
- (lambda (p n dest start) ; read-string!
+ (lambda (p n dest start) ; read-bytevector!
(let* ((pos (##sys#slot p 10))
- (n2 (fx- (##sys#slot p 11) pos) ) )
+ (input (##sys#slot p 12))
+ (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)
+ (##core#inline "C_copy_memory_with_offset" dest input start pos n)
(##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))
+ (size (##sys#slot p 11))
+ (buf (##sys#slot p 12))
(end (if limit (fx+ pos limit) size)))
(if (fx>= pos size)
#!eof
@@ -4869,16 +5718,17 @@ EOF
(begin
(##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
(##sys#setislot p 5 0))
- (##sys#setislot p 5 (fx+ (##sys#slot p 5) (##sys#size line))))
+ (##sys#setislot p 5 (fx+ (##sys#slot p 5) (string-length line))))
(##sys#setislot p 10 next)
line) ) ) )
(lambda (p) ; read-buffered
(let ((pos (##sys#slot p 10))
- (string (##sys#slot p 12))
+ (buf (##sys#slot p 12))
(len (##sys#slot p 11)) )
(if (fx>= pos len)
""
- (let ((buffered (##sys#substring string pos len)))
+ (let* ((rest (fx- len pos))
+ (buffered (##sys#buffer->string buffered pos rest)))
(##sys#setislot p 10 len)
buffered))))
)))
@@ -4886,71 +5736,68 @@ EOF
;; Invokes the eos handler when EOS is reached to get more data.
;; The eos-handler is responsible for stopping, either when EOF is hit or
;; a user-supplied limit is reached (ie, it's indistinguishable from EOF)
-(define (##sys#scan-buffer-line buf limit start-pos eos-handler)
- (define (copy&append buf offset pos old-line)
- (let* ((old-line-len (##sys#size old-line))
- (new-line (##sys#make-string (fx+ old-line-len (fx- pos offset)))))
- (##core#inline "C_substring_copy" old-line new-line 0 old-line-len 0)
- (##core#inline "C_substring_copy" buf new-line offset pos old-line-len)
- new-line))
- (let loop ((buf buf)
- (offset start-pos)
- (pos start-pos)
- (limit limit)
- (line ""))
- (if (fx= pos limit)
- (let ((line (copy&append buf offset pos line)))
- (receive (buf offset limit) (eos-handler pos)
- (if buf
- (loop buf offset offset limit line)
- (values offset line #f))))
- (let ((c (##core#inline "C_subchar" buf pos)))
- (cond ((eq? c #\newline)
- (values (fx+ pos 1) (copy&append buf offset pos line) #t))
- ((and (eq? c #\return) ; \r\n -> drop \r from string
- (fx> limit (fx+ pos 1))
- (eq? (##core#inline "C_subchar" buf (fx+ pos 1)) #\newline))
- (values (fx+ pos 2) (copy&append buf offset pos line) #t))
- ((and (eq? c #\return) ; Edge case (#568): \r{read}[\n|xyz]
- (fx= limit (fx+ pos 1)))
- (let ((line (copy&append buf offset pos line)))
- (receive (buf offset limit) (eos-handler pos)
- (if buf
- (if (eq? (##core#inline "C_subchar" buf offset) #\newline)
- (values (fx+ offset 1) line #t)
- ;; "Restore" \r we didn't copy, loop w/ new string
- (loop buf offset offset limit
- (##sys#string-append line "\r")))
- ;; Restore \r here, too (when we reached EOF)
- (values offset (##sys#string-append line "\r") #t)))))
- ((eq? c #\return)
- (values (fx+ pos 1) (copy&append buf offset pos line) #t))
- (else (loop buf offset (fx+ pos 1) limit line)) ) ) ) ) )
-
-(set! chicken.base#open-input-string
- (lambda (string)
- (##sys#check-string string 'open-input-string)
- (let ((port (##sys#make-port 1 ##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)))
-
-(set! chicken.base#open-output-string
- (lambda ()
- (let ((port (##sys#make-port 2 ##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)))
-
-(set! chicken.base#get-output-string
- (lambda (port)
- (##sys#check-output-port 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#scan-buffer-line buf limit start-pos eos-handler #!optional enc)
+ (let* ((hold 1024)
+ (dpos 0)
+ (line (##sys#make-bytevector hold)))
+ (define (grow)
+ (let* ((h2 (fx* hold 2))
+ (l2 (##sys#make-bytevector h2)))
+ (##core#inline "C_copy_memory" l2 line dpos)
+ (set! line l2)
+ (set! hold h2)))
+ (define (conc buf from to)
+ (let ((len (fx- to from)))
+ (when (fx>= (fx+ dpos len) hold) (grow))
+ (##core#inline "C_copy_memory_with_offset" line buf dpos from len)
+ (set! dpos (fx+ dpos len))))
+ (define (conc1 b)
+ (when (fx>= (fx+ dpos 1) hold) (grow))
+ (##core#inline "C_setsubbyte" line dpos b)
+ (set! dpos (fx+ dpos 1)))
+ (define (getline)
+ (if enc
+ (##sys#buffer->string/encoding line 0 dpos enc)
+ (##sys#buffer->string line 0 dpos)))
+ (let loop ((buf buf)
+ (offset start-pos)
+ (pos start-pos)
+ (limit limit))
+ (cond ((fx= pos limit)
+ (conc buf offset pos)
+ (receive (buf offset limit) (eos-handler pos)
+ (if buf
+ (loop buf offset offset limit)
+ (values offset (getline) #f))))
+ (else
+ (let ((c (##core#inline "C_subbyte" buf pos)))
+ (cond ((eq? c 10)
+ (conc buf offset pos)
+ (values (fx+ pos 1) (getline) #t))
+ ((and (eq? c 13) ; \r\n -> drop \r from string
+ (fx> limit (fx+ pos 1))
+ (eq? (##core#inline "C_subbyte" buf (fx+ pos 1)) 10))
+ (conc buf offset pos)
+ (values (fx+ pos 2) (getline) #t))
+ ((and (eq? c 13) ; Edge case (#568): \r{read}[\n|xyz]
+ (fx= limit (fx+ pos 1)))
+ (conc buf offset pos)
+ (receive (buf offset limit) (eos-handler pos)
+ (if buf
+ (if (eq? (##core#inline "C_subbyte" buf offset) 10)
+ (values (fx+ offset 1) (getline) #t)
+ ;; "Restore" \r we didn't copy, loop w/ new string
+ (begin
+ (conc1 13)
+ (loop buf offset offset limit)))
+ ;; Restore \r here, too (when we reached EOF)
+ (begin
+ (conc1 13)
+ (values offset (getline) #t)))))
+ ((eq? c 13)
+ (conc buf offset pos)
+ (values (fx+ pos 1) (getline) #t))
+ (else (loop buf offset (fx+ pos 1) limit)) ) ) ) ) )))
(define ##sys#print-to-string
(let ([get-output-string get-output-string]
@@ -5096,6 +5943,10 @@ EOF
(lambda ()
((exit-handler) _ex_software))))
+(define (##sys#dbg-hook . args)
+ (##core#inline "C_dbg_hook" #f)
+ (##core#undefined))
+
;;; Condition handling:
@@ -5114,6 +5965,7 @@ EOF
(import scheme chicken.base chicken.fixnum chicken.foreign)
(import chicken.internal.syntax)
+(import (only (scheme base) make-parameter open-output-string get-output-string))
(define (##sys#signal-hook/errno mode errno msg . args)
(##core#inline "C_dbg_hook" #f)
@@ -5151,7 +6003,7 @@ EOF
[args (if hasloc (##sys#slot args 1) args)] )
(abort
(##sys#make-structure
- 'condition
+ 'condition
(case mode
[(#:type-error) '(exn type)]
[(#:syntax-error) '(exn syntax)]
@@ -5187,7 +6039,7 @@ EOF
(abort
(##sys#make-structure
'condition
- '(exn)
+ '(exn)
(list '(exn . message) "exception handler returned"
'(exn . arguments) '()
'(exn . location) #f) ) ) )
@@ -5249,7 +6101,7 @@ EOF
(loc (and loca (cadr loca))) )
(if (and loc (symbol? loc))
(string-append
- "(" (##sys#symbol->string loc) ") "
+ "(" (##sys#symbol->string/shared loc) ") "
(cond ((symbol? msg) (##sys#slot msg 1))
((string? msg) msg)
(else "") ) ) ; Hm...
@@ -5270,13 +6122,13 @@ EOF
((##sys#reset-handler)) ) ) ) )
(abort
(##sys#make-structure
- 'condition
- '(uncaught-exception)
+ 'condition
+ '(uncaught-exception)
(list '(uncaught-exception . reason) c)) ) ) ) )
(define (with-exception-handler handler thunk)
(let ([oldh ##sys#current-exception-handler])
- (##sys#dynamic-wind
+ (##sys#dynamic-wind
(lambda () (set! ##sys#current-exception-handler handler))
thunk
(lambda () (set! ##sys#current-exception-handler oldh)) ) ) )
@@ -5345,7 +6197,7 @@ EOF
(##sys#slot x 1)))
(define (condition-predicate kind)
- (lambda (c)
+ (lambda (c)
(and (condition? c)
(if (memv kind (##sys#slot c 1)) #t #f)) ) )
@@ -5357,7 +6209,7 @@ EOF
(and (memv kind (##sys#slot c 1))
(let ([a (member k+p (##sys#slot c 2))])
(cond [a (cadr a)]
- [err? (##sys#signal-hook
+ [err? (##sys#signal-hook
#:type-error 'condition-property-accessor
"condition has no such property" prop) ]
[else (car err-def)] ) ) ) ) ) )
@@ -5396,7 +6248,7 @@ EOF
(display ": " port)
(let ((loc (errloc ex)))
(when (and loc (symbol? loc))
- (display (string-append "(" (##sys#symbol->string loc) ") ") port) ) )
+ (display (string-append "(" (##sys#symbol->string/shared loc) ") ") port) ) )
(display msg port) ) )
(else
(let ((kinds (##sys#slot ex 1)))
@@ -5454,16 +6306,16 @@ EOF
(lambda (code loc . args)
(case code
((1) (let ([c (car args)]
- [n (cadr args)]
+ [n (cadr args)]
[fn (caddr args)] )
(apply
- ##sys#signal-hook
+ ##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)]
+ [n (cadr args)]
[fn (caddr args)] )
(apply
##sys#signal-hook
@@ -5493,7 +6345,7 @@ EOF
((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))
+ ((25) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a bytevector" 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 block object" args))
((28) (apply ##sys#signal-hook #:type-error loc "bad argument type - not a number vector" args))
@@ -5533,12 +6385,82 @@ EOF
(string-append "attempted rest argument access at index " (##sys#number->string n)
" but rest list length is " (##sys#number->string c) )
(if fn (list fn) '()))))
+ ((57) (apply ##sys#signal-hook #:type-error loc "string contains invalid UTF-8 sequence" args))
+ ((58) (apply ##sys#signal-hook #:type-error loc "bad argument type - numeric value exceeds range" args))
(else (apply ##sys#signal-hook #:runtime-error loc "unknown internal error" args)) ) ) ) )
) ; chicken.condition
(import chicken.condition)
+;;; R7RS exceptions
+
+(define ##sys#r7rs-exn-handlers
+ (make-parameter
+ (let ((lst (list ##sys#current-exception-handler)))
+ (set-cdr! lst lst)
+ lst)))
+
+(define scheme#with-exception-handler
+ (let ((eh ##sys#r7rs-exn-handlers))
+ (lambda (handler thunk)
+ (dynamic-wind
+ (lambda ()
+ ;; We might be interoperating with srfi-12 handlers set by intermediate
+ ;; non-R7RS code, so check if a new handler was set in the meanwhile.
+ (unless (eq? (car (eh)) ##sys#current-exception-handler)
+ (eh (cons ##sys#current-exception-handler (eh))))
+ (eh (cons handler (eh)))
+ (set! ##sys#current-exception-handler handler))
+ thunk
+ (lambda ()
+ (eh (cdr (eh)))
+ (set! ##sys#current-exception-handler (car (eh))))))))
+
+(define scheme#raise
+ (let ((eh ##sys#r7rs-exn-handlers))
+ (lambda (obj)
+ (scheme#with-exception-handler
+ (cadr (eh))
+ (lambda ()
+ ((cadr (eh)) obj)
+ ((car (eh))
+ (make-property-condition
+ 'exn
+ 'message "exception handler returned"
+ 'arguments '()
+ 'location #f)))))))
+
+(define scheme#raise-continuable
+ (let ((eh ##sys#r7rs-exn-handlers))
+ (lambda (obj)
+ (scheme#with-exception-handler
+ (cadr (eh))
+ (lambda ()
+ ((cadr (eh)) obj))))))
+
+(define scheme#error-object? condition?)
+(define scheme#error-object-message (condition-property-accessor 'exn 'message))
+(define scheme#error-object-irritants (condition-property-accessor 'exn 'arguments))
+
+(define scheme#read-error?)
+(define scheme#file-error?)
+
+(let ((exn? (condition-predicate 'exn))
+ (i/o? (condition-predicate 'i/o))
+ (file? (condition-predicate 'file))
+ (syntax? (condition-predicate 'syntax)))
+ (set! scheme#read-error?
+ (lambda (obj)
+ (and (exn? obj)
+ (or (i/o? obj) ; XXX Not fine-grained enough.
+ (syntax? obj)))))
+ (set! scheme#file-error?
+ (lambda (obj)
+ (and (exn? obj)
+ (file? obj)))))
+
+
;;; Miscellaneous low-level routines:
(define (##sys#structure? x s) (##core#inline "C_i_structurep" x s))
@@ -5554,7 +6476,13 @@ EOF
(define (##sys#permanent? x) (##core#inline "C_permanentp" x))
(define (##sys#block-address x) (##core#inline_allocate ("C_block_address" 6) x))
(define (##sys#locative? x) (##core#inline "C_locativep" x))
-(define (##sys#srfi-4-vector? x) (##core#inline "C_i_srfi_4_vectorp" x))
+
+(define (##sys#srfi-4-vector? x)
+ (or (##core#inline "C_i_srfi_4_vectorp" x)
+ (and (##core#inline "C_blockp" x)
+ (##core#inline "C_structurep" x)
+ (let ((t (##sys#slot x 0)))
+ (or (eq? t 'c64vector) (eq? t 'c128vector))))))
(define (##sys#null-pointer)
(let ([ptr (##sys#make-pointer)])
@@ -5573,13 +6501,10 @@ EOF
;;XXX '6' is platform dependent!
(##core#inline_allocate ("C_a_unsigned_int_to_num" 6) (##sys#slot ptr 0)) )
-(define (##sys#make-c-string str #!optional (loc '##sys#make-c-string))
- (let* ([len (##sys#size str)]
- [buf (##sys#make-string (fx+ len 1))] )
- (##core#inline "C_substring_copy" str buf 0 len 0)
- (##core#inline "C_setsubchar" buf len #\nul)
- (if (fx= (##core#inline "C_asciiz_strlen" buf) len)
- buf
+(define (##sys#make-c-string str #!optional loc)
+ (let ((bv (##sys#slot str 0)))
+ (if (fx= (##core#inline "C_asciiz_strlen" bv) (fx- (##sys#size bv) 1))
+ bv
(##sys#error-hook (foreign-value "C_ASCIIZ_REPRESENTATION_ERROR" int)
loc str))) )
@@ -5595,39 +6520,31 @@ EOF
(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 ) ) )
+ (##sys#peek-nonnull-c-string b i)))
(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 ) )
+ [bv (##sys#make-bytevector (fx+ len 1) 0)] )
+ (##core#inline "C_peek_c_string" b i bv len)
+ (##sys#buffer->string bv 0 len)))
(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 ) ) )
+ (let ((str (##sys#peek-c-string b i)))
+ (##core#inline "C_free_mptr" b i)
+ str))
(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)
+ (let ((str (##sys#peek-nonnull-c-string b i)))
(##core#inline "C_free_mptr" b i)
- str2 ) )
+ str))
-(define (##sys#poke-c-string b i s)
+(define (##sys#poke-c-string b i s)
(##core#inline "C_poke_c_string" b i (##sys#make-c-string s) 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
+(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))
@@ -5638,7 +6555,7 @@ EOF
(cons s (loop (fx+ i 1)))
'() ) ) ) ) ) ) )
-(define ##sys#peek-and-free-c-string-list
+(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)
@@ -5660,26 +6577,6 @@ EOF
(define (##sys#symbol-has-toplevel-binding? s)
(##core#inline "C_boundp" s))
-(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#block-pointer x)
(let ([ptr (##sys#make-pointer)])
(##core#inline "C_pointer_to_block" ptr x)
@@ -5693,7 +6590,14 @@ EOF
(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-struct-wrapper-argument t x)
+(define (##sys#foreign-cplxnum-argument x)
+ (if (##core#inline "C_i_numberp" x)
+ (##core#inline_allocate ("C_a_i_exact_to_inexact" 12) x)
+ (##sys#signal-hook
+ #:type-error #f "bad argument type - not a complex number"
+ x)))
+
+(define (##sys#foreign-struct-wrapper-argument t x)
(##core#inline "C_i_foreign_struct_wrapper_argumentp" t x))
(define (##sys#foreign-string-argument x) (##core#inline "C_i_foreign_string_argumentp" x))
@@ -5706,11 +6610,15 @@ EOF
(define (##sys#foreign-unsigned-ranged-integer-argument obj size)
(##core#inline "C_i_foreign_unsigned_ranged_integer_argumentp" obj size))
+(define (##sys#wrap-struct type rec)
+ (##sys#setslot rec 0 type)
+ rec)
+
;;; Low-level threading interface:
(define ##sys#default-thread-quantum 10000)
-(define (##sys#default-exception-handler arg)
+(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)
@@ -5767,7 +6675,7 @@ EOF
;; these two procedures should redefined in thread APIs (e.g. srfi-18):
(define (##sys#resume-thread-on-event t) #f)
-
+
(define (##sys#suspend-thread-on-event t)
;; wait until signal handler fires. If we are only waiting for a finalizer,
;; then this will wait forever:
@@ -5777,11 +6685,11 @@ EOF
(##core#inline "C_i_sleep_until_interrupt" 100)
(##sys#dispatch-interrupt (lambda _ #f)))
-
+
;;; event queues (for signals and finalizers)
-
+
(define (##sys#make-event-queue)
- (##sys#make-structure 'event-queue
+ (##sys#make-structure 'event-queue
'() ; head
'() ; tail
#f)) ; suspended thread
@@ -5826,7 +6734,7 @@ EOF
(##sys#setslot q 1 n)
(when (null? n) (##sys#setslot q 2 '()))
x)))))))
-
+
;;; Sleeping:
@@ -5912,7 +6820,7 @@ EOF
[(#\<)
(##sys#read-char-0 port)
(let ([str (open-output-string)]
- [end (readln port)]
+ [end (readln port)]
[f #f] )
(let ((endlen (if (eof-object? end) 0 (string-length end))))
(cond
@@ -5923,20 +6831,20 @@ EOF
(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
+ (if f
(##sys#write-char-0 #\newline str)
(set! f #t) )
(display ln str) ) ) ]
[(#\#)
(##sys#read-char-0 port)
- (let ([end (readln port)]
+ (let ([end (readln port)]
[str (open-output-string)] )
(define (get/clear-str)
(let ((s (get-output-string str)))
@@ -5962,8 +6870,7 @@ EOF
(cond [(or (eof-object? c) (string=? end s))
(when (eof-object? c)
(##sys#read-warning
- port (##sys#format-here-doc-warning end))
- )
+ 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
@@ -5999,39 +6906,6 @@ EOF
#define C_chdir(str) C_fix(chdir(C_c_string(str)))
#define C_curdir(buf, size) (getcwd(C_c_string(buf), size) ? C_fix(strlen(C_c_string(buf))) : C_SCHEME_FALSE)
-#define C_getenventry(i) (environ[ i ])
-
-#ifdef HAVE_CRT_EXTERNS_H
-# include <crt_externs.h>
-# define environ (*_NSGetEnviron())
-#else
-extern char **environ;
-#endif
-
-#ifdef HAVE_SETENV
-# 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
-# if defined(_WIN32) && !defined(__CYGWIN__)
-# define C_unsetenv(s) C_setenv(s, C_SCHEME_FALSE)
-# else
-# define C_unsetenv(s) C_fix(putenv((char *)C_data_pointer(s)))
-# endif
-static C_word C_fcall C_setenv(C_word x, C_word y) {
- char *sx = C_c_string(x),
- *sy = (y == C_SCHEME_FALSE ? "" : C_c_string(y));
- int n1 = C_strlen(sx), n2 = C_strlen(sy);
- int buf_len = n1 + n2 + 2;
- char *buf = (char *)C_malloc(buf_len);
- if(buf == NULL) return(C_fix(0));
- else {
- C_strlcpy(buf, sx, buf_len);
- C_strlcat(buf, "=", buf_len);
- C_strlcat(buf, sy, buf_len);
- return(C_fix(putenv(buf)));
- }
-}
-#endif
<#
@@ -6045,7 +6919,7 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(import scheme)
(import chicken.base chicken.fixnum chicken.foreign)
(import chicken.internal.syntax)
-
+(import (only (scheme base) make-parameter))
;;; Current directory access:
@@ -6062,55 +6936,63 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(define current-directory
(getter-with-setter
- (lambda ()
- (let* ((buffer-size (foreign-value "C_MAX_PATH" size_t))
- (buffer (make-string buffer-size))
- (len (##core#inline "C_curdir" buffer buffer-size)))
- (unless ##sys#windows-platform ; FIXME need `cond-expand' here
- (##sys#update-errno))
- (if len
- (##sys#substring buffer 0 len)
- (##sys#signal-hook/errno
- #:file-error
- (##sys#errno)
- 'current-directory "cannot retrieve current directory"))))
- (lambda (dir)
- (##sys#change-directory-hook dir))
- "(chicken.process-context#current-directory)"))
+ (lambda ()
+ (let* ((buffer-size (foreign-value "C_MAX_PATH" size_t))
+ (buffer (##sys#make-bytevector buffer-size))
+ (len (##core#inline "C_curdir" buffer buffer-size)))
+ (unless ##sys#windows-platform ; FIXME need `cond-expand' here
+ (##sys#update-errno))
+ (if len
+ (##sys#buffer->string buffer 0 len)
+ (##sys#signal-hook/errno
+ #:file-error
+ (##sys#errno)
+ 'current-directory "cannot retrieve current directory"))))
+ (lambda (dir)
+ (##sys#change-directory-hook dir))
+ "(chicken.process-context#current-directory)"))
;;; Environment access:
-(define get-environment-variable
- (foreign-lambda c-string "C_getenv" nonnull-c-string))
+(define _getenv
+ (foreign-lambda c-string "C_getenv" scheme-object))
+
+(define (get-environment-variable var)
+ (_getenv (##sys#make-c-string var 'get-environment-variable)))
+
+(define get-environment-entry
+ (foreign-lambda c-string* "C_getenventry" int))
(define (set-environment-variable! var val)
(##sys#check-string var 'set-environment-variable!)
- (##sys#check-string val 'set-environment-variable!)
- (##core#inline "C_setenv"
+ (##core#inline "C_i_setenv"
(##sys#make-c-string var 'set-environment-variable!)
- (##sys#make-c-string val 'set-environment-variable!))
+ (and val
+ (begin
+ (##sys#check-string val 'set-environment-variable!)
+ (##sys#make-c-string val 'set-environment-variable!))))
(##core#undefined))
(define (unset-environment-variable! var)
(##sys#check-string var 'unset-environment-variable!)
- (##core#inline "C_unsetenv"
- (##sys#make-c-string var 'unset-environment-variable!))
+ (##core#inline "C_i_setenv"
+ (##sys#make-c-string var 'unset-environment-variable!)
+ #f)
(##core#undefined))
(define get-environment-variables
- (let ((get (foreign-lambda c-string "C_getenventry" int)))
- (lambda ()
+ (lambda ()
(let loop ((i 0))
- (let ((entry (get i)))
+ (let ((entry (get-environment-entry i)))
(if entry
(let scan ((j 0))
- (if (char=? #\= (##core#inline "C_subchar" entry j))
+ (if (char=? #\= (string-ref entry j))
(cons (cons (##sys#substring entry 0 j)
- (##sys#substring entry (fx+ j 1) (##sys#size entry)))
+ (##sys#substring entry (fx+ j 1) (string-length entry)))
(loop (fx+ i 1)))
(scan (fx+ j 1))))
- '()))))))
+ '())))))
;;; Command line handling
@@ -6157,7 +7039,7 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
((string=? "-:" arg) ; Consume first "empty" runtime options list, return rest
rest)
- ((and (fx>= (##sys#size arg) 3)
+ ((and (fx>= (string-length arg) 3)
(string=? "-:" (##sys#substring arg 0 2)))
(loop rest))
@@ -6172,13 +7054,14 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(module chicken.gc
- (current-gc-milliseconds gc memory-statistics
+ (current-gc-milliseconds gc memory-statistics
set-finalizer! make-finalizer add-to-finalizer
set-gc-report! force-finalizers)
(import scheme)
(import chicken.base chicken.fixnum chicken.foreign)
(import chicken.internal.syntax)
+(import (only (scheme base) make-parameter))
;;; GC info:
@@ -6200,7 +7083,7 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(define-foreign-variable _max_pending_finalizers int "C_max_pending_finalizers")
-(define ##sys#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)
@@ -6217,9 +7100,9 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(fx+ (fx* 2 _max_pending_finalizers) 1)
(##core#undefined)))
(when (##sys#debug-mode?)
- (##sys#print
+ (##sys#print
(string-append
- "[debug] too many finalizers ("
+ "[debug] too many finalizers ("
(##sys#number->string
(##core#inline "C_i_live_finalizer_count"))
"), resized max finalizers to "
@@ -6228,7 +7111,7 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
#f ##sys#standard-error)))
(else
(when (##sys#debug-mode?)
- (##sys#print
+ (##sys#print
(string-append
"[debug] too many finalizers ("
(##core#inline "C_i_live_finalizer_count")
@@ -6263,7 +7146,7 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(let ((af (and (procedure? f)
(##sys#lambda-decoration f finalizer?))))
(unless af
- (error 'add-to-finalizer "bad argument type - not a finalizer procedure"
+ (error 'add-to-finalizer "bad argument type - not a finalizer procedure"
f))
(for-each (cdr af) objects)))
@@ -6277,7 +7160,7 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(set! working-thread ##sys#current-thread)
(let* ((c (##sys#slot ##sys#pending-finalizers 0)) )
(when (##sys#debug-mode?)
- (##sys#print
+ (##sys#print
(string-append "[debug] running " (##sys#number->string c)
" finalizer(s) ("
(##sys#number->string
@@ -6295,7 +7178,7 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
((##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)
+ (##sys#setislot ##sys#pending-finalizers 0 0)
(set! working-thread #f)))
(state) ; Got here due to interrupt; continue w/o error
((eq? working-thread ##sys#current-thread)
@@ -6353,16 +7236,13 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(define ##sys#map-n map)
;;; 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)
@@ -6410,16 +7290,18 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(##sys#check-range index 0 (##sys#size v) loc)
(##core#inline_allocate ("C_a_i_make_locative" 5) 11 v index weak?) ) )
;;XXX pointer-vector currently not supported
- (else
+ (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?) ]
+ ((string? obj)
+ (let ((bv (##sys#slot obj 0))
+ (p (##core#inline "C_utf_position" obj index)))
+ (##sys#check-range index 0 (##sys#slot obj 1) loc)
+ (##core#inline_allocate ("C_a_i_make_locative" 5) 1 bv p weak?) ) )
[else
(##sys#signal-hook
#:type-error loc
- "bad argument type - locative cannot refer to objects of this type"
+ "bad argument type - locative cannot refer to objects of this type"
obj) ] ) )
@@ -6471,7 +7353,7 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(##sys#check-symbol sym 'symbol-plist)
(##sys#check-list lst 'symbol-plist/setter)
(if (##core#inline "C_i_fixnumevenp" (##core#inline "C_i_length" lst))
- (##sys#setslot sym 2 lst)
+ (##sys#setslot sym 2 lst)
(##sys#signal-hook
#:type-error "property-list must be of even length"
lst sym))
@@ -6555,12 +7437,10 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
;;; Platform configuration inquiry:
(module chicken.platform
- (build-platform chicken-version
- chicken-home ;; DEPRECATED
- include-path
- feature? features machine-byte-order machine-type
+ (build-platform chicken-version chicken-home
+ feature? machine-byte-order machine-type
repository-path installation-repository
- register-feature! unregister-feature!
+ register-feature! unregister-feature! include-path
software-type software-version return-to-host
system-config-directory system-cache-directory
)
@@ -6568,7 +7448,7 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(import scheme)
(import chicken.fixnum chicken.foreign chicken.keyword chicken.process-context)
(import chicken.internal.syntax)
-(import (only chicken.base make-parameter))
+(import (only (scheme base) make-parameter))
(define software-type
(let ((sym (string->symbol ((##core#primitive "C_software_type")))))
@@ -6605,7 +7485,7 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(if (eq? 'unknown x)
""
(string-append (symbol->string x) "-")))
- (string-append (str sv) (str st) (str bp) (##sys#symbol->string mt))))
+ (string-append (str sv) (str st) (str bp) (##sys#symbol->string/shared mt))))
(if full
(let ((spec (string-append
" " (number->string (foreign-value "C_WORD_SIZE" int)) "bit"
@@ -6619,7 +7499,7 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(if ##sys#build-id (string-append " (rev " ##sys#build-id ")") "")
"\n"
(get-config)
- (if (zero? (##sys#size spec))
+ (if (zero? (string-length spec))
""
(string-append " [" spec " ]"))))
##sys#build-version))
@@ -6630,9 +7510,14 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(define-foreign-variable installation-home c-string "C_INSTALL_SHARE_HOME")
(define-foreign-variable install-egg-home c-string "C_INSTALL_EGG_HOME")
-;; DEPRECATED
(define (chicken-home) installation-home)
+(define (include-path #!optional new)
+ (when new
+ (##sys#check-list new 'include-path)
+ (set! ##sys#include-pathnames new))
+ ##include-pathnames)
+
(define path-list-separator
(if ##sys#windows-platform #\; #\:))
@@ -6708,16 +7593,19 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(lambda (x)
(cond ((keyword? x) x)
((string? x) (string->keyword x))
- ((symbol? x) (string->keyword (##sys#symbol->string x)))
+ ((symbol? x) (string->keyword (##sys#symbol->string/shared x)))
(else (err x))))))
(define ##sys#features
'(#:chicken
#:srfi-6 #:srfi-12 #:srfi-17 #:srfi-23 #:srfi-30
- #:srfi-39 #:srfi-62 #:srfi-88 #:full-numeric-tower))
+ #:exact-complex #:srfi-39 #:srfi-62 #:srfi-88 #:full-numeric-tower #:full-unicode))
;; Add system features:
+;; all platforms we support have this
+(set! ##sys#features `(#:posix #:r7rs #:ieee-float #:ratios ,@##sys#features))
+
(let ((check (lambda (f)
(unless (eq? 'unknown f)
(set! ##sys#features (cons (->feature-id f) ##sys#features))))))
@@ -6772,8 +7660,6 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(cons f (loop r)))))))
(##core#undefined)))
-(define (features) ##sys#features)
-
(define (feature? . ids)
(let loop ((ids ids))
(or (null? ids)
@@ -6799,3 +7685,500 @@ static C_word C_fcall C_setenv(C_word x, C_word y) {
(and home (string-append home "/.cache"))))))
) ; chicken.platform
+
+(set! scheme#features
+ (lambda ()
+ (map (lambda (s)
+ (##sys#string->symbol (##sys#symbol->string s)))
+ ##sys#features)))
+
+(set! scheme#make-list
+ (lambda (n #!optional fill)
+ (##sys#check-integer n 'make-list)
+ (unless (fx>= n 0)
+ (error 'make-list "not a positive integer" n))
+ (do ((i n (fx- i 1))
+ (result '() (cons fill result)))
+ ((eq? i 0) result))))
+
+(set! scheme#list-set!
+ (lambda (l n obj)
+ (##sys#check-integer n 'list-set!)
+ (unless (fx>= n 0)
+ (error 'list-set! "not a positive integer" n))
+ (do ((i n (fx- i 1))
+ (l l (cdr l)))
+ ((fx= i 0) (set-car! l obj))
+ (when (null? l)
+ (error 'list-set! "out of range")))))
+
+;; TODO: Test if this is the quickest way to do this, or whether we
+;; should just cons recursively like our SRFI-1 implementation does.
+(set! scheme#list-copy
+ (lambda (lst)
+ (cond ((pair? lst)
+ (let lp ((res '())
+ (lst lst))
+ (if (pair? lst)
+ (lp (cons (car lst) res) (cdr lst))
+ (append (##sys#fast-reverse res) lst))))
+ (else lst))))
+
+(set! scheme#string->vector
+ (lambda (s #!optional start end)
+ (let ((s->v (lambda (s start end)
+ (##sys#check-string s 'string->vector)
+ (let* ((len (##sys#slot s 1)))
+ (##sys#check-range/including start 0 end 'string->vector)
+ (##sys#check-range/including end start len 'string->vector)
+ (let ((v (##sys#make-vector (fx- end start))))
+ (do ((ti 0 (fx+ ti 1))
+ (fi start (fx+ fi 1)))
+ ((fx= fi end) v)
+ (##sys#setslot v ti (##core#inline "C_utf_subchar" s fi))))))))
+ (if end
+ (s->v s start end)
+ (s->v s (or start 0) (string-length s))))))
+
+(set! scheme#vector->string
+ (lambda (v #!optional start end)
+ (let ((v->s (lambda (v start end)
+ (##sys#check-vector v 'vector->string)
+ (let* ((len (##sys#size v)))
+ (##sys#check-range/including start 0 end 'vector->string)
+ (##sys#check-range/including end start len 'vector->string)
+ (let ((s (##sys#make-bytevector (fx* 4 (fx- end start)))))
+ (let loop ((ti 0)
+ (fi start))
+ (if (fx= fi end)
+ (##sys#buffer->string s 0 ti)
+ (let ((c (##sys#slot v fi)))
+ (##sys#check-char c 'vector->string)
+ (loop (fx+ ti (##core#inline "C_utf_insert" s ti c))
+ (fx+ fi 1))))))))))
+ (if end
+ (v->s v start end)
+ (v->s v (or start 0) (##sys#size v))))))
+
+(set! scheme#string-map
+ (lambda (proc str . more)
+ (define (%string-map proc s)
+ (let* ((len (string-length s))
+ (ans (##sys#make-bytevector (fx* 4 len))))
+ (let loop ((i 0)
+ (j 0))
+ (if (fx>= j len)
+ (##sys#buffer->string ans 0 i)
+ (let ((r (proc (string-ref s j))))
+ (##sys#check-char r 'string-map)
+ (loop (##core#inline "C_utf_insert" ans i r)
+ (fx+ j 1)))))))
+ (if (null? more)
+ (%string-map proc str)
+ (let ((strs (cons str more)))
+ (##sys#check-closure proc 'string-map)
+ (##sys#for-each (cut ##sys#check-string <> 'string-map) strs)
+ (let* ((len (foldl fxmin most-positive-fixnum (map string-length strs)))
+ (str (##sys#make-string len)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len) str)
+ (string-set! str i (apply proc (map (cut string-ref <> i) strs)))))))))
+
+(set! scheme#string-for-each
+ (lambda (proc str . more)
+ (define (%string-for-each proc s)
+ (let ((len (string-length s)))
+ (let lp ((i 0))
+ (if (fx< i len)
+ (begin (proc (string-ref s i))
+ (lp (fx+ i 1)))))))
+ (if (null? more)
+ (%string-for-each proc str)
+ (let ((strs (cons str more)))
+ (##sys#check-closure proc 'string-for-each)
+ (##sys#for-each (cut ##sys#check-string <> 'string-for-each) strs)
+ (let* ((len (foldl fxmin most-positive-fixnum (map string-length strs)))
+ (str (##sys#make-string len)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len))
+ (apply proc (map (cut string-ref <> i) strs))))))))
+
+(set! scheme#vector-map
+ (lambda (proc v . more)
+ (cond ((null? more)
+ (##sys#check-closure proc 'vector-map)
+ (##sys#check-vector v 'vector-map)
+ (let* ((len (##sys#size v))
+ (vec (##sys#make-vector len)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len) vec)
+ (##sys#setslot vec i (proc (##sys#slot v i))))))
+ (else
+ (let ((vs (cons v more)))
+ (##sys#check-closure proc 'vector-map)
+ (##sys#for-each (cut ##sys#check-vector <> 'vector-map) vs)
+ (let* ((len (foldl fxmin most-positive-fixnum (map ##sys#size vs)))
+ (vec (##sys#make-vector len)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len) vec)
+ (##sys#setslot vec i (apply proc (map (cut vector-ref <> i) vs))))))))))
+
+(set! scheme#vector-for-each
+ (lambda (proc v . more)
+ (cond ((null? more)
+ (##sys#check-closure proc 'vector-for-each)
+ (##sys#check-vector v 'vector-for-each)
+ (let ((len (##sys#size v)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len))
+ (proc (##sys#slot v i)))))
+ (else
+ (let ((vs (cons v more)))
+ (##sys#check-closure proc 'vector-for-each)
+ (##sys#for-each (cut ##sys#check-vector <> 'vector-for-each) vs)
+ (let* ((len (foldl fxmin most-positive-fixnum (map ##sys#size vs)))
+ (vec (##sys#make-vector len)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len) vec)
+ (apply proc (map (cut vector-ref <> i) vs)))))))))
+
+(set! scheme#close-port
+ (lambda (port)
+ (##sys#check-port port 'close-port)
+ (when (##core#inline "C_port_openp" port 1)
+ ((##sys#slot (##sys#slot port 2) 4) port 1))
+ (when (##core#inline "C_port_openp" port 2)
+ ((##sys#slot (##sys#slot port 2) 4) port 2))
+ (##sys#setislot port 8 0)))
+
+(set! scheme#call-with-port
+ (lambda (port proc)
+ (receive ret
+ (proc port)
+ (scheme#close-port port)
+ (apply values ret))))
+
+(set! scheme#eof-object (lambda () #!eof))
+
+(set! scheme#peek-u8
+ (case-lambda
+ (()
+ (let ((c (peek-char ##sys#standard-input)))
+ (if (eof-object? c) c
+ (char->integer c))))
+ ((port)
+ (##sys#check-input-port port #t 'peek-u8)
+ (let ((c (peek-char port)))
+ (if (eof-object? c) c
+ (char->integer c))))))
+
+(set! scheme#write-string
+ (lambda (s #!optional (port ##sys#standard-output) start end)
+ (##sys#check-string s 'write-string)
+ (##sys#check-output-port port #t 'write-string)
+ (if start
+ (##sys#check-fixnum start 'write-string)
+ (set! start 0))
+ (if end
+ (##sys#check-fixnum end 'write-string)
+ (set! end (string-length s)))
+ (let* ((part (if start (substring s start end) s))
+ (bv (##sys#slot part 0))
+ (len (fx- (##sys#size bv) 1)))
+ ((##sys#slot (##sys#slot port 2) 3) ; write-bytevector
+ port bv 0 len))))
+
+
+;; I/O
+
+(module chicken.io
+ (read-list read-buffered read-byte read-line
+ read-lines read-string read-string! read-token
+ write-byte write-line write-bytevector read-bytevector
+ read-bytevector!)
+
+(import scheme chicken.base chicken.fixnum)
+(import chicken.internal.syntax)
+(import (only (scheme base) open-output-string get-output-string))
+
+
+;;; Read expressions from file:
+
+(define read-list
+ (let ((read read))
+ (lambda (#!optional (port ##sys#standard-input) (reader read) max)
+ (##sys#check-input-port port #t 'read-list)
+ (do ((x (reader port) (reader port))
+ (i 0 (fx+ i 1))
+ (xs '() (cons x xs)))
+ ((or (eof-object? x) (and max (fx>= i max)))
+ (##sys#fast-reverse xs))))))
+
+
+;;; Line I/O:
+
+(define read-line
+ (let ()
+ (lambda args
+ (let* ([parg (pair? args)]
+ [p (if parg (car args) ##sys#standard-input)]
+ [limit (and parg (pair? (cdr args)) (cadr args))])
+ (##sys#check-input-port p #t '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)) )
+ (string-set! buffer i c)
+ (loop (fx+ i 1)) ] ) ) ) ) ) ) ) ) ) ) ) )
+
+(define read-lines
+ (lambda (#!optional (port ##sys#standard-input) max)
+ (##sys#check-input-port port #t 'read-lines)
+ (when max (##sys#check-fixnum max 'read-lines))
+ (let loop ((lns '())
+ (n (or max most-positive-fixnum)))
+ (if (eq? n 0)
+ (##sys#fast-reverse lns)
+ (let ((ln (read-line port)))
+ (if (eof-object? ln)
+ (##sys#fast-reverse lns)
+ (loop (cons ln lns) (fx- n 1))))))))
+
+(define write-line
+ (lambda (str . port)
+ (let* ((p (if (##core#inline "C_eqp" port '())
+ ##sys#standard-output
+ (##sys#slot port 0) ) ))
+ (##sys#check-output-port p #t 'write-line)
+ (##sys#check-string str 'write-line)
+ (let ((bv (##sys#slot str 0)))
+ ((##sys#slot (##sys#slot p 2) 3) ; write-bytevector
+ p
+ bv
+ 0
+ (fx- (##sys#size bv) 1)))
+ (##sys#write-char-0 #\newline p))))
+
+
+;;; Extended I/O
+
+(define (read-bytevector!/port n dest port start)
+ (if (eq? n 0)
+ 0
+ (let ((rdbvec (##sys#slot (##sys#slot port 2) 7))) ; read-bytevector!
+ (let loop ((start start) (n n) (m 0))
+ (let ((n2 (rdbvec 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))))))))
+
+(define (read-string!/port n dest port start)
+ (let ((buf (##sys#make-bytevector (fx* n 4)))
+ (enc (##sys#slot port 15)))
+ (##sys#encoding-hook
+ enc
+ (lambda (decoder _ _)
+ (define (readb n buf port p)
+ (let ((bytes (read-bytevector!/port n buf port p)))
+ (if (eq? enc 'utf-8) ; fast path, avoid copying
+ bytes
+ (decoder buf p bytes
+ (lambda (dbuf start len)
+ (##core#inline "C_copy_memory_with_offset" buf dbuf p start len)
+ len)))))
+ (define (finish un bytes)
+ (##core#inline "C_utf_overwrite" dest start un buf bytes)
+ un)
+ (let loop ((p 0) (n n) (un 0) (bn 0))
+ (let ((bytes (readb n buf port p)))
+ (cond ((eq? bytes 0) (finish un bn))
+ ((eq? enc 'utf-8)
+ ;; read incomplete fragments
+ ;; FIXME: hardcoded, should be encoding-specific!
+ (let recount ((bytes bytes))
+ (let* ((fc (##core#inline "C_utf_fragment_counts" buf p bytes))
+ (full (fxshr fc 4))
+ (left (fxand fc 15))
+ (total (fx+ un full))
+ (tbytes (fx+ bn bytes))
+ (remain (fx- n full)))
+ (cond ((fx> left 0)
+ (let ((b2 (readb left buf port (fx+ p bytes))))
+ (if (fx< b2 left)
+ (finish total tbytes)
+ (recount (fx+ bytes b2)))))
+ ((eq? remain 0) (finish total tbytes))
+ (else (loop (fx+ p bytes) remain total
+ tbytes))))))
+ ((fx> bytes n)
+ (loop (fx+ p bytes) (fx- n bytes)
+ (fx+ un bytes) (fx+ bn bytes)))
+ (else (finish un bn)))))))))
+
+(define (read-string! n dest #!optional (port ##sys#standard-input) (start 0))
+ (##sys#check-input-port port #t 'read-string!)
+ (##sys#check-string dest 'read-string!)
+ (when n (##sys#check-fixnum n 'read-string!))
+ (let ((dest-size (string-length dest)))
+ (unless (and n (fx<= (fx+ start n) dest-size))
+ (set! n (fx- dest-size start))))
+ (##sys#check-fixnum start 'read-string!)
+ (read-string!/port n dest port start))
+
+(define (read-bytevector! dest #!optional (port ##sys#standard-input) (start 0) end)
+ (##sys#check-input-port port #t 'read-bytevector!)
+ (##sys#check-bytevector dest 'read-bytevector!)
+ (##sys#check-fixnum start 'read-bytevector!)
+ (when end (##sys#check-fixnum end 'read-bytevector!))
+ (let* ((size (##sys#size dest))
+ (n (fx- (or end size) start)))
+ (read-bytevector!/port n dest port start)))
+
+(define read-string/port
+ (lambda (n p)
+ (cond ((eq? n 0) "") ; Don't attempt to peek (fd might not be ready)
+ ((eof-object? (##sys#peek-char-0 p)) #!eof)
+ (n (let* ((str (##sys#make-string n))
+ (n2 (read-string!/port n str p 0)))
+ (if (eq? n n2)
+ str
+ (##sys#substring str 0 n2))))
+ (else
+ (##sys#read-remaining
+ p
+ (lambda (buf len)
+ (##sys#buffer->string/encoding buf 0 len
+ (##sys#slot p 15))))))))
+
+(define (##sys#read-remaining p k)
+ (let ((len 1024))
+ (let loop ((buf (##sys#make-bytevector len))
+ (bsize len)
+ (pos 0))
+ (let* ((nr (fx- (##sys#size buf) pos))
+ (n (read-bytevector!/port nr buf p pos)))
+ (cond ((eq? n nr)
+ (let* ((bsize2 (fx* bsize 2))
+ (buf2 (##sys#make-bytevector bsize2)))
+ (##core#inline "C_copy_memory" buf2 buf bsize)
+ (loop buf2 bsize2 (fx+ pos n))))
+ (else (k buf (fx+ n pos))))))))
+
+(define read-bytevector/port
+ (lambda (n p)
+ (let* ((bv (##sys#make-bytevector n))
+ (n2 (read-bytevector!/port n bv p 0)))
+ (if (eq? n n2)
+ bv
+ (let ((bv2 (##sys#make-bytevector n2)))
+ (##core#inline "C_copy_memory" bv2 bv n2)
+ bv2)))))
+
+(define (read-string #!optional n (port ##sys#standard-input))
+ (##sys#check-input-port port #t 'read-string)
+ (when n (##sys#check-fixnum n 'read-string))
+ (read-string/port n port))
+
+(define (read-bytevector #!optional n (port ##sys#standard-input))
+ (##sys#check-input-port port #t 'read-bytevector)
+ (cond (n (##sys#check-fixnum n 'read-bytevector)
+ (let ((r (read-bytevector/port n port)))
+ (if (eq? (##sys#size r) 0)
+ #!eof
+ r)))
+ (else
+ (##sys#read-remaining
+ port
+ (lambda (buf len)
+ (if (eq? len 0)
+ #!eof
+ (let ((r (##sys#make-bytevector len)))
+ (##core#inline "C_copy_memory" r buf len)
+ r)))))))
+
+
+;; Make internal reader procedures available for use in srfi-4.scm:
+
+(define chicken.io#read-string/port read-string/port)
+(define chicken.io#read-string!/port read-string!/port)
+(define chicken.io#read-bytevector/port read-bytevector/port)
+(define chicken.io#read-bytevector!/port read-bytevector!/port)
+
+(define (read-buffered #!optional (port ##sys#standard-input))
+ (##sys#check-input-port port #t 'read-buffered)
+ (let ((rb (##sys#slot (##sys#slot port 2) 9))) ; read-buffered method
+ (if rb
+ (rb port)
+ "")))
+
+
+;;; read token of characters that satisfy a predicate
+
+(define read-token
+ (lambda (pred . port)
+ (let ([port (optional port ##sys#standard-input)])
+ (##sys#check-input-port port #t '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) ) ) ) ) ) ) )
+
+
+;;; Binary I/O
+
+(define (read-byte #!optional (port ##sys#standard-input))
+ (##sys#check-input-port port #t 'read-byte)
+ (let* ((bv (##sys#make-bytevector 1))
+ (n (read-bytevector!/port 1 bv port 0)))
+ (if (fx< n 1)
+ #!eof
+ (##core#inline "C_subbyte" bv 0))))
+
+(define (write-byte byte #!optional (port ##sys#standard-output))
+ (##sys#check-fixnum byte 'write-byte)
+ (##sys#check-output-port port #t 'write-byte)
+ (let ((bv (##sys#make-bytevector 1 byte)))
+ ((##sys#slot (##sys#slot port 2) 3) ; write-bytevector
+ port bv 0 1)))
+
+(define (write-bytevector bv #!optional (port ##sys#standard-output) (start 0)
+ end)
+ (##sys#check-bytevector bv 'write-bytevector)
+ (##sys#check-output-port port #t 'write-bytevector)
+ (##sys#check-fixnum start 'write-bytevector)
+ (let ((len (##sys#size bv)))
+ (##sys#check-range/including start 0 len 'write-bytevector)
+ (when end (##sys#check-range/including end 0 len 'write-bytevector))
+ (let ((end (if end (fxmin end len) len)))
+ ((##sys#slot (##sys#slot port 2) 3) ; write-bytevector
+ port bv start end))))
+
+) ; module chicken.io
diff --git a/lolevel.scm b/lolevel.scm
index 6238c491..760bbdc9 100644
--- a/lolevel.scm
+++ b/lolevel.scm
@@ -161,29 +161,35 @@ EOF
(##sys#error 'move-memory! "negative source offset" foffset))
(when (fx< toffset 0)
(##sys#error 'move-memory! "negative destination offset" toffset))
- (let move ([from from] [to to])
+ (let move ([from from] [to to] (n n))
(cond [(##sys#generic-structure? from)
(if (memq (##sys#slot from 0) slot1structs)
- (move (##sys#slot from 1) to)
+ (move (##sys#slot from 1) to n)
(typerr from) ) ]
[(##sys#generic-structure? to)
(if (memq (##sys#slot to 0) slot1structs)
- (move from (##sys#slot to 1))
+ (move from (##sys#slot to 1) n)
(typerr to) ) ]
+ ((string? from)
+ (let ((buf (##sys#slot from 0)))
+ (move buf to (or n (fx- (##sys#size buf) 1)))))
+ ((string? to)
+ (let ((buf (##sys#slot to 0)))
+ (move from buf (or n (fx- (##sys#size buf) 1)))))
[(%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) ]
+ ((##sys#bytevector? to)
+ (memmove3 to from (checkn1 (or n (nosizerr)) (##sys#size to) toffset) toffset foffset) )
[else
(typerr to)] ) ]
- [(or (##sys#bytevector? from) (string? from))
+ [(##sys#bytevector? 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))
+ ((##sys#bytevector? to)
(memmove4 to from (checkn2 (or n nfrom) nfrom (##sys#size to) foffset toffset)
- toffset foffset) ]
+ toffset foffset) )
[else
(typerr to)] ) ) ]
[else
@@ -342,7 +348,7 @@ EOF
(##sys#check-fixnum n 'make-pointer-vector)
(let* ((words->bytes (foreign-lambda int "C_wordstobytes" int))
(size (words->bytes n))
- (buf (##sys#make-blob size)))
+ (buf (##sys#make-bytevector size)))
(unless (eq? init unset)
(when init
(##sys#check-pointer init 'make-pointer-vector))
@@ -420,7 +426,7 @@ EOF
(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)))
+ ((symbol? x) (##sys#string->symbol (##sys#slot x 1)))
(else
(let* ((n (##sys#size x))
(words (if (##core#inline "C_byteblockp" x) (##core#inline "C_words" n) n))
@@ -477,14 +483,18 @@ EOF
(##sys#size x) )
(define (number-of-bytes x)
- (cond [(not (##core#inline "C_blockp" 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_bytes" (##sys#size x))] ) )
+ "cannot compute number of bytes of immediate object" x) )
+ ((##core#inline "C_stringp" x)
+ (fx- (##sys#size (##sys#slot x 0)) 1))
+ ((##core#inline "C_symbolp" x)
+ (fx- (##sys#size (##sys#slot x 1)) 1))
+ ((##core#inline "C_byteblockp" x)
+ (##sys#size x))
+ (else
+ (##core#inline "C_bytes" (##sys#size x))) ) )
;;; Record objects:
@@ -567,7 +577,7 @@ EOF
; 2 Type (fixnum)
; 0 vector or pair (C_SLOT_LOCATIVE)
; 1 string (C_CHAR_LOCATIVE)
-; 2 u8vector or blob (C_U8_LOCATIVE)
+; 2 u8vector or bytevector (C_U8_LOCATIVE)
; 3 s8vector (C_S8_LOCATIVE)
; 4 u16vector (C_U16_LOCATIVE)
; 5 s16vector (C_S16_LOCATIVE)
diff --git a/manual/Acknowledgements b/manual/Acknowledgements
index 8e6ac12b..a8f939ad 100644
--- a/manual/Acknowledgements
+++ b/manual/Acknowledgements
@@ -9,7 +9,7 @@ Jean-Francois Bignolles, Oivind Binde, Alaric Blagrave Snell-Pym, Dave
Bodenstab, Fabian Böhlke, T. Kurt Bond, Ashley Bone, Dominique Boucher,
Christopher Brannon, Terence Brannon, Roy Bryant, Adam Buchbinder, Hans Bulfone,
"Category 5", Taylor Campbell, Naruto Canada, Mark Carter, Esteban U. Caamano
-Castro, Semih Cemiloglu, Alex Charlton, Franklin Chen, Joo ChurlSoo,
+Castro, Semih Cemiloglu, Pietro Cerutti, Alex Charlton, Franklin Chen, Joo ChurlSoo,
Thomas Chust, Gian Paolo Ciceri, Fulvio Ciriaco, Paul Colby, Tobia
Conforto, John Cowan, Grzegorz Chrupala, James Crippen, Evan Hanson,
Adhi Hargo, Moritz Heidkamp, Tollef Fog Heen, Drew Hess, Alejandro
@@ -22,8 +22,9 @@ Martin Gasbichler, Abdulaziz Ghuloum, Joey Gibson, Stephen C. Gilardi,
Mario Domenech Goulart, Joshua Griffith, Johannes Groedem, Damian
Gryski, Matt Gushee, Andreas Gustafsson, Sven Hartrumpf, Jun-ichiro
itojun Hagino, Ahdi Hargo, Matthias Heiler, Karl M. Hegbloom, Moritz Heidkamp,
-William P. Heinemann, Bill Hoffman, Eric Hoffman, Bruce Hoult, Hans Hübner,
-Markus Hülsmann, Götz Isenmann, Paulo Jabardo, Wietse Jacobs, David Janssens,
+William P. Heinemann, Christian Himpe, Bill Hoffman, Eric Hoffman, Bruce Hoult,
+Hans Hübner,
+Markus Hülsmann, Anton Idukov, Götz Isenmann, Paulo Jabardo, Wietse Jacobs, David Janssens,
Christian Jäger, Robert Jensen, Matt Jones, Dale Jordan, Valentin Kamyshenko,
Daishi Kato, Peter Keller, Christian Kellermann, Brad Kind, Ron Kneusel, "Kooda",
Matthias Köppe, Krysztof Kowalczyk, Andre Kühne, Todd R. Kueny Sr, Goran Krampe,
@@ -37,7 +38,7 @@ Fadi Moukayed, Chris Moline, Eric E. Moore, Julian Morrison,
Dan Muresan, David N. Murray, Timo Myyrä, "nicktick", Lars Nilsson,
Ian Oversby, "o.t.", Gene Pavlovsky, Levi Pearson, Jeronimo Pellegrini,
Nicolas Pelletier, Derrell Piper, Carlos Pita, "Pluijzer",
-Robin Lee Powell, Alan Post, "Pupeno", Davide Puricelli, "presto",
+Robin Lee Powell, Alan Post, "puck", "Pupeno", Davide Puricelli, "presto",
Doug Quale, Imran Rafique, Eric Raible, Ivan Raikov, Santosh Rajan,
Peder Refnes, Joel Reymont, Kay Rhodes, "rivo", Chris Roberts,
Eric Rochester, Paul Romanchenko,
@@ -61,7 +62,7 @@ Special thanks to Brandon van Every for contributing the (now defunct)
[[http://www.cmake.org|CMake]] support and for helping with Windows
build issues.
-Thanks to Pablo Beyen and [[http://www.bevuta.com|bevuta IT GmbH]] for
+Thanks to Pablo Beyen and [[http://www.bevuta.com|bevuta IT GmbH]] for
their awesome support.
Also special thanks to Benedikt Rosenau for his constant encouragement.
diff --git a/manual/Bibliography b/manual/Bibliography
index 4fde751a..33f13e1e 100644
--- a/manual/Bibliography
+++ b/manual/Bibliography
@@ -4,6 +4,8 @@
Henry Baker: ''CONS Should Not CONS Its Arguments, Part II: Cheney on the M.T.A.'' [[http://home.pipeline.com/~hbaker1/CheneyMTA.html]]
+''Revised^7 Report on the Algorithmic Language Scheme (Small)'' [[https://small.r7rs.org/]]
+
''Revised^5 Report on the Algorithmic Language Scheme'' [[http://www.schemers.org/Documents/Standards/R5RS]]
R. P. Brent, P. Zimmermann: ''Modern Computer Arithmetic'' [[https://members.loria.fr/PZimmermann/mca/pub226.html]]
diff --git a/manual/Bugs and limitations b/manual/Bugs and limitations
index 74563b33..c462f978 100644
--- a/manual/Bugs and limitations
+++ b/manual/Bugs and limitations
@@ -11,7 +11,7 @@
* Leaf routine optimization can theoretically result in code that thrashes, if tight loops perform excessively many mutations. In practice this doesn't happen.
* Due to the header representation of block objects, the maximum size
-of a bytevector-like object (strings, blobs, srfi-4 vectors etc) is
+of a bytevector-like object (strings, bytevectors, srfi-4 vectors etc) is
2^24 bytes or 16MiB. On 64-bit machines the limit is less relevant,
at 2^56 bytes, or 65536 TiB (64 PiB).
diff --git a/manual/C interface b/manual/C interface
index 174ee143..bb750521 100644
--- a/manual/C interface
+++ b/manual/C interface
@@ -142,8 +142,8 @@ Is {{x}} a closure? Accepts only non-immediate objects.
Is {{x}} any kind of vector? Accepts only non-immediate objects.
-This returns true for both regular heterogenous R5RS vectors and
-bytevectors ("blobs"). However, it does ''not'' return true for
+This returns true for both regular heterogenous R7RS vectors and
+bytevectors. However, it does ''not'' return true for
SRFI-4 vectors, as those are actually bytevectors wrapped in a
structure with a type tag.
@@ -151,7 +151,7 @@ structure with a type tag.
[C macro] C_word C_bytevectorp(C_word x)
-Is {{x}} a bytevector ("blob")? Accepts only non-immediate objects.
+Is {{x}} a bytevector? Accepts only non-immediate objects.
===== C_portp
diff --git a/manual/Data representation b/manual/Data representation
index fcc20c35..92091e70 100644
--- a/manual/Data representation
+++ b/manual/Data representation
@@ -16,7 +16,9 @@ numeric value (63 bits on 64-bit architectures).
'''characters''', where the four lowest-order bits are equal to
{{C_CHARACTER_BITS}}, currently 1010. The Unicode code point
-of the character is encoded in the next 24 bits.
+of the character is encoded in the next 24 bits, from 0x00 to 0x1FFFFF.
+Code points from 0xDC80 to 0xDCFF are not allowed and used to
+mark invalid UTF-8 bytes in strings (see below).
'''booleans''', where the four lowest-order bits are equal to {{C_BOOLEAN_BITS}},
currently 0110. The next bit is one for #t and zero for #f.
@@ -56,7 +58,7 @@ collection or internal data type dispatching.
; 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 blob) or pointers to other data objects.
+; C_BYTEBLOCK_BIT : Flag that specifies whether this data object contains raw bytes (a bytevector) 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. This is also used to turn a pair's car into a weak reference in the symbol table, to allow its symbol to be collected.
@@ -75,7 +77,11 @@ the symbol is undefined and has no property list, the symbol table's
container should be a weak reference ({{C_WEAK_PAIR_TYPE}}), otherwise
it should be a strong reference ({{C_PAIR_TYPE}}).
-'''strings''': byte-vector objects with type bits {{C_STRING_TYPE}}, currently 0010.
+'''strings''': objects with type bits {{C_STRING_TYPE}}, currently 0010,
+holding a bytevector with the string contents represented as an UTF-8 encoded
+byte sequence. Note that invalid UTF-8 sequences are allowed inside strings,
+extracted characters at positions that contain invalid UTF-8
+sequences are represented as the trailing surrogate pair half (U+DC00|xx).
'''pairs''': vector-like object with type bits {{C_PAIR_TYPE}}, currently 0011.
The car and the cdr are contained in the first and second slots,
@@ -110,10 +116,10 @@ contain housekeeping data used for this port.
specifies the kind of structure this record is an instance of. The other
slots contain the actual record items.
-'''blob''': a raw sequence of bytes with type bits {{C_BYTEVECTOR_TYPE}}.
+'''bytevector''': a raw sequence of bytes with type bits {{C_BYTEVECTOR_TYPE}}.
'''pointer-vectors''': vector objects of native pointers - these are
-actually structures where the first slot holds a blob containing the 32- or 64-bit
+actually structures where the first slot holds a bytevector containing the 32- or 64-bit
pointer values.
'''locatives''': special vector objects with type bits
diff --git a/manual/Debugging b/manual/Debugging
deleted file mode 100644
index f37b134e..00000000
--- a/manual/Debugging
+++ /dev/null
@@ -1,159 +0,0 @@
-[[tags:manual]]
-
-== Debugging
-
-
-=== Introduction
-
-This document describes "Feathers", a debugger for compiled CHICKEN programs.
-
-"Feathers" is a [[http://tcl.tk|Tcl/Tk]] script, installed together with
-all other components of the CHICKEN system. To use the debugger, Tcl/Tk version
-8.5 or later must be installed.
-
-Once the debugger is started, it waits for a client program to connect to
-it. You can also run a program explicitly by pressing the {{F1}} key and
-selecting an executable to run. If the executable has been compiled with
-debugging information, it will connect to the debugger and the source code
-of the program will be shown in the debugger window, if the original source
-files of the program are available in the search path (see below for more
-details on this.)
-
-To enable debugging in compiled programs a number of requirements must be met:
-
-* The program must be compiled with debug-level 3 or higher (option {{-d3}}) or by providing the {{-debug-info}} option.
-
-* The environment variable {{CHICKEN_DEBUGGER}} must be set to the address and port of a running instance of the debugger, e.g. {{CHICKEN_DEBUGGER=localhost:9999}} (port 9999 is the default port). If you start a program directly out of the debugger, then this variable does not need to be set.
-
-* The source code files must be in the current directory, or in the current "search path" of the debugger. The search path defaults to the current directory, the directory of the debugged program and any additional directories selected by pressing the {{F3}} key.
-
-You can also run the debugger from the command line and directly pass the program
-to be debugged, including any additional arguments that the program should receive:
-
-{{% feathers myprogram 1 2 3}}
-
-The debugger understands a number of command-line options: {{-port PORT}} changes the
-port on which the debugger listens (the default is 9999), {{-dir DIRECTORY}} adds
-{{DIRECTORY}} to the search path (this option can be given multiple times), and
-{{-n}} disables loading of a custom init file ({{~/.feathers}} or {{./.feathers}}).
-
-Debug-level 3 adds intrumentation to the compiled code to allow interacting with
-it from the debugger. This has a slight performance cost, so it should not be
-enabled with performance sensitive code.
-
-Debugging is mostly unintrusive: timing and dynamic (nursery) allocation may be
-influenced by the debugging, but otherwise the program will behave exactly as it
-would without embedded debugging-information: no additional heap allocation
-takes place, and no Scheme library code will be invoked.
-
-User-interrupts triggered from the debugger use {{SIGUSR2}} to indicate that
-the program should be suspended. Be aware of that in case your program implements
-a signal handler for {{SIGUSR2}}.
-
-Remote debugging should be no problem: all communication between debugger and the
-client program takes place over TCP sockets. Note that the source files for
-the debugged program need to be available on the machine that does the debugging.
-
-
-=== Usage
-
-Initially a single window is shown, holding the contents of the source file that
-contains the currently executing code. When the execution changes to another file,
-the contents of the window will be automatically updated. The combo-box at the
-top shows all source-files for which debug-information is currently available.
-Note that this may change during the execution of the program, as files are
-dynamically loaded or statically linked units are not yet initialized.
-
-The "focus" (a line marked blue) shows at what location the program is currently
-suspended. You can move the focus up and down with the {{Up}} and {{Down}} arrow
-keys.
-
-Lines that contain "debug events" are highlighted: these lines can be used to
-set breakpoints by clicking with the left mouse button or by pressing {{Enter}} while
-the focus is on that line. Clicking a line that
-contains a breakpoint will disable the breakpoint. Note that a single line
-can contain multiple "debug events". Setting a breakpoint on such a line
-will interrupt the program on any event that exists on that line.
-
-The following debug events exist:
-
-* Procedure call
-
-* Procedure entry
-
-* Assignment to global variable
-
-* Signal (an error or interrupt)
-
-The topmost line shows the current file and also displays "events" as the debugged
-program runs and interacts with the debugger.
-
-At the bottom the following buttons are visible, each of them can also be activated
-by pressing the function-key shown on the button:
-
-; F1 : Run an executable under the debugger. If a program is already debugged, then the current program will be terminated and the debugger is reinitialized.
-
-; F2 : Move focus back to location where the debugged program has been suspended.
-
-; F3 : Add another directory to the current search path.
-
-; F4 : Open the "data" view (see below.)
-
-; F5 : Continue execution of the program until the next breakpoint is hit, an error occurs, or the program terminates.
-
-; F6 : Execute a single "step", until the next debug-event occurs. You can also press the {{Space}} key to single-step.
-
-; F7 : If text is marked in the current window, search backwards and show the most previous occurrence of the marked text that is not already visible.
-
-: F8 : Search for next occurrence of marked text.
-
-: F9 : Open "C" view (see below.)
-
-: F10 : Terminate the currently debugged program and exit the debugger.
-
-Pressing the {{Esc}} key while the program is executing will suspend it on the
-next debug-event (so this may not take place instantly.)
-
-The keys {{+}} (plus) and {{-}} (minus) increase and decrease the current font-size,
-respectively.
-
-
-=== The "Data" View
-
-When {{F4}} is pressed, a window appears that allows inspection of the current
-arguments of a suspended procedure, together with any additional global variables
-that have been marked for inspection. By opening value items in the shown tree
-view, values can be inspected to arbitrary depth. Note that the values are retrieved
-from the debug-client on-demand, so the textual representation of a value shown
-will only reflect its currently inspected contents.
-
-The entry-field below the view for variables and arguments can be used to add
-global variables to the list of watched variables. Double-clicking on a variable
-(or pressing {{Enter}} while it is
-selected) sets a "watchpoint" - a breakpoint that is trigged when the variable
-is assigned a new value.
-
-The bars indicate current heap-, scratchspace- and nursery
-utilization. These bars update only when the program is suspended.
-
-At the bottom the current call-trace of the executing program is shown. Note
-that this is not a "stack-trace", but a list of recently performed calls,
-ordered from top (earlier) to bottom (later).
-
-
-=== The "C" View
-
-Pressing {{F9}} opens another text-window which shows the current location where
-the program is suspended, but in the compiled C code generated by the {{chicken}}
-compiler. The contents of the window are automatically updated on every suspension
-of the debugged program.
-This may be useful when you want to understand how CHICKEN compiles
-Scheme to C, or when you are doing low-level debugging.
-
-Text can be marked and searched as in the source-code window with {{F7}} and {{F8}}.
-
-
----
-Previous: [[Extensions to the standard]]
-
-Next: [[Interface to external functions and variables]]
diff --git a/manual/Deployment b/manual/Deployment
index 5252d543..61c4ff8f 100644
--- a/manual/Deployment
+++ b/manual/Deployment
@@ -121,6 +121,7 @@ the library that is linked into plain CHICKEN-compiled applications:
% cp $CHICKEN_BUILD/library.c .
% cp $CHICKEN_BUILD/modules.c .
% cp $CHICKEN_BUILD/runtime.c .
+ % cp $CHICKEN_BUILD/utf.c .
% cp $CHICKEN_BUILD/chicken.h .
% cp $CHICKEN_BUILD/chicken-config.h .
% cp $CHICKEN_BUILD/buildtag.h .
@@ -132,7 +133,7 @@ the library that is linked into plain CHICKEN-compiled applications:
Once we have all the files together, we can create a tarball:
% tar czf hello.tar.gz hello.c build-version.c chicken-syntax.c eval.c \
- expand.c internal.c library.c modules.c runtime.c chicken.h \
+ expand.c internal.c library.c modules.c runtime.c utf.c chicken.h \
chicken-config.h buildtag.h
This is naturally rather simplistic. Things like enabling dynamic
diff --git a/manual/Deviations from the standard b/manual/Deviations from the standard
index 7dc45ec3..4f1dcf78 100644
--- a/manual/Deviations from the standard
+++ b/manual/Deviations from the standard
@@ -1,6 +1,6 @@
[[tags: manual]]
-== Confirmed deviations from R5RS
+== Confirmed deviations from R7RS
Identifiers are by default case-sensitive (see [[Using the compiler]]).
@@ -57,39 +57,6 @@ terminal ports.
== Doubtful deviations
-=== {{letrec}}
-
-{{letrec}} does evaluate the initial values for the bound
-variables sequentially and not in parallel, that is:
-
-<enscript highlight="scheme">
-(letrec ((x 1) (y 2)) (cons x y))
-</enscript>
-
-is equivalent to
-
-<enscript highlight="scheme">
-(let ((x (void)) (y (void)))
- (set! x 1)
- (set! y 2)
- (cons x y) )
-</enscript>
-
-where R5RS requires
-
-<enscript highlight="scheme">
-(let ((x (void)) (y (void)))
- (let ((tmp1 1) (tmp2 2))
- (set! x tmp1)
- (set! y tmp2)
- (cons x y) ) )
-</enscript>
-
-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
=== {{let-syntax}} and {{letrec-syntax}}
@@ -100,15 +67,10 @@ lambda-expressions.
=== {{equal?}} compares all structured data recursively
{{equal?}} compares all structured data with the exception of
-procedures 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
-
-
-=== {{transcript-on}} and {{transcript-off}} are not implemented
+procedures recursively, while R7RS specifies that {{eqv?}} is used for
+data other than pairs, strings and vectors. However, R7RS does not
+dictate the treatment of data types that are not specified by R7RS
-The {{transcript-on}} and {{transcript-off}} procedures are
-not implemented. R5RS does not require them.
---
Previous: [[Using the compiler]]
diff --git a/manual/Egg specification format b/manual/Egg specification format
index 2a246a91..c90a3789 100644
--- a/manual/Egg specification format
+++ b/manual/Egg specification format
@@ -68,7 +68,9 @@ built and installed if they do not already exist in the repository.
{{EGG}} should be whether a symbol or a list of the form
{{EGGNAME VERSION}}, where the former means to install the
newest available egg with this name and the latter specifies
-a specific version or higher.
+a specific version or higher. {{EGGNAME}} may also be the string or
+symbol {{chicken}}, in case you want your extension to depend
+on a minimum required CHICKEN of {{VERSION}} or newer.
This property can also be used to specify a minimum version of CHICKEN
required by the egg. For example, to require at least CHICKEN 5.3.0:
@@ -159,9 +161,9 @@ Specifies global options for all programs and extensions compiled for this egg.
[egg property] (cond-expand CLAUSE ...)
-Conditionally expand egg specification forms, depending on system
-features. Each {{CLAUSE}} should be of the form
-{{(TEST PROPERTY)}} where {{TEST}} is a feature identifier or a
+Conditionally expand egg specification forms, depending on system
+features. Each {{CLAUSE}} should be of the form
+{{(TEST PROPERTY)}} where {{TEST}} is a feature identifier or a
conditional form, in the same syntax as used in the {{cond-expand}}
syntactic form.
@@ -231,6 +233,14 @@ to C. If you want to pass compiler-specific options to the build
of the C object, use the {{csc-options}} property and precede
C compiler options with {{-C}}.
+Components of this type are never installed, they just exist at build time.
+
+==== installed-c-object
+
+ [egg property] (installed-c-object NAME PROP ...)
+
+Similar to {{c-object}}, but the compiled object file will be installed in the
+extension repository.
=== Component properties
@@ -268,7 +278,7 @@ extension libraries. The name is optional and defaults to the
name of the extensions (with the proper extension).
If {{NAME}} is a list of the form {{(predefined [NAME])}}, then
-no types file is created during compilation and an existing types file
+no types file is created during compilation and an existing types file
for this extension is assumed and installed.
==== inline-file
@@ -284,17 +294,14 @@ name of the extensions (with the proper extension).
[egg property] (custom-build STRING)
-Specifies a custom build operation that should be executed instead of
+Specifies a custom build script that should be executed instead of
the default build operations. This property is mandatory for
components of type {{generated-source-file}}. {{STRING}} should be the
-name of a shell command (e.g., a script) and thus may be platform
+name of a {{sh(1)}} shell command (e.g., a script) and thus may be platform
sensitive. The path to the file is prepended implicitly, so you
-should '''not''' prefix it with {{./}}. On Windows, a file with the
-{{.bat}} extension will be picked before a plain file with no
-extension.
+should '''not''' prefix it with {{./}}.
-The script will be made executable on UNIX systems, if necessary,
-and will be invoked like the {{csc}} program and
+The script will be invoked like the {{csc}} program and
is executed with the location of the CHICKEN
binaries in the {{PATH}}. Also, the following environment variables
are set in the execution environment of the script:
@@ -320,6 +327,15 @@ compilation of the extension, so multiple options should be specified
as {{(csc-options "OPT1" "OPT2" ...)}} instead of {{(csc-options "OPT1 OPT2")}}
(the latter would be a single option containing a whitespace character).
+OPTION may optionally be a list of the form {{(custom-config FILENAME ARG ...)}},
+which allows to dynamically determine options to be passed to the {{csc}}
+program. FILENAME should be the name of a Scheme source file in the
+current build directory. The file is invoked as {{csc -s FILENAME ARG ...}}
+and should write s-expressions to stdout that are taken as additional
+options to be passed to {{csc}} when compiling a component. The expressions
+are read in, any list structure is flattened and all items are converted to
+strings and added to the list of compilation options.
+
==== link-options
[egg property] (link-options OPTION ...)
@@ -335,6 +351,8 @@ as {{(link-options "OPT1" "OPT2" ...)}} instead of {{(link-options "OPT1 OPT2")}
Note that in order to pass linker options to the underlying C-compiler, these must
be prefixed with {{-L}}, eg. {{(link-options "-L" "-lpng")}}.
+This property supports {{custom-config}} specifications, described above.
+
==== source
[egg property] (source NAME)
@@ -387,7 +405,7 @@ Specifies an alternative installation destination for the
built component and only applies
to components of type {{data}}, {{c-include}} and {{scheme-include}}.
This property should only be used in extreme
-cases, as it is recommended to use the default installation
+cases, as it is recommended to use the default installation
locations, which are:
* for C include files: {{<PREFIX>/include/chicken/}}
diff --git a/manual/Extensions to the standard b/manual/Extensions to the standard
index 9a28ea81..c20f4e35 100644
--- a/manual/Extensions to the standard
+++ b/manual/Extensions to the standard
@@ -2,93 +2,29 @@
[[toc:]]
-== Extensions to the R5RS standard
-
-=== Identifiers
-
-Identifiers may contain special characters if delimited with
-{{| ... |}}.
+== Extensions to the R7RS standard
=== Brackets and braces
The brackets {{[ ... ]}} and the braces {{ { ... } }} are
provided as an alternative syntax for {{( ... )}}. A number of reader
-extensions is provided.
-
-=== Non-standard procedures and syntax
-
-CHICKEN provides numerous non-standard procedures. See the manual
-sections on the included library modules ([[Included modules]]) for
-more information. Here we only document {{cond-expand}} because it is
-always present in a module, even without imports.
-
-==== cond-expand
-
-<macro>(cond-expand FEATURE-CLAUSE ...)</macro>
-
-Expands by selecting feature clauses. This form is allowed to appear in non-toplevel expressions.
-
-Predefined feature-identifiers are "situation" specific:
-
-; compile : {{chicken}}, {{chicken-5}}, {{compiling}}, {{library}}, {{eval}}, {{extras}}, {{regex}}, {{srfi-0}}, {{srfi-2}}, {{srfi-4}}, {{srfi-6}}, {{srfi-8}}, {{srfi-9}}, {{srfi-10}}, {{srfi-11}}, {{srfi-12}}, {{srfi-15}}, {{srfi-16}}, {{srfi-17}}, {{srfi-23}}, {{srfi-26}}, {{srfi-28}}, {{srfi-30}}, {{srfi-31}}, {{srfi-39}}, {{srfi-55}}, {{srfi-61}}, {{srfi-62}}
-
-; load : {{chicken}}, {{chicken-5}}, {{extras}}, {{srfi-0}}, {{srfi-2}}, {{srfi-6}}, {{srfi-8}}, {{srfi-9}}, {{srfi-10}}, {{srfi-12}}, {{srfi-17}}, {{srfi-23}}, {{srfi-28}}, {{srfi-30}}, {{srfi-39}}, {{srfi-55}}, {{srfi-61}}, {{srfi-62}}. {{library}} is implicit.
-
-; eval : {{csi}}, {{chicken}}, {{chicken-5}}, {{extras}}, {{srfi-0}}, {{srfi-2}}, {{srfi-6}}, {{srfi-8}}, {{srfi-9}}, {{srfi-10}}, {{srfi-11}}, {{srfi-12}}, {{srfi-15}}, {{srfi-16}}, {{srfi-17}}, {{srfi-23}}, {{srfi-26}}, {{srfi-28}}, {{srfi-30}}, {{srfi-31}}, {{srfi-39}}, {{srfi-55}}, {{srfi-61}}, {{srfi-62}}. {{library}} is implicit.
-
-Also, features of the form {{chicken-5.X}}, where {{X}} denotes the minor version, are available.
-
-The symbols returned by the following procedures from [[Module (chicken platform)|(chicken platform)]] are also available as feature-identifiers in all situations: {{(machine-byte-order)}}, {{(machine-type)}}, {{(software-type)}}, {{(software-version)}}. For example, the {{machine-type}} class of feature-identifiers include {{arm}},
-{{alpha}}, {{mips}}, etc.
-
-The [[Module (chicken platform)|(chicken platform)]] module also provides a function {{(features)}} that returns a list of all registered features.
-
-In addition the following feature-identifiers may exist: {{cross-chicken}}, {{dload}}, {{manyargs}}, {{ptables}}.
-
-For further information, see the documentation for
-[[http://srfi.schemers.org/srfi-0/srfi-0.html|SRFI-0]].
-
+extensions is provided.
=== User defined character names
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}}.
+{{char-name}}. Numeric hexadecimal character codes above are supported and can be read
+using ''#\uXXXX'' and ''#\UXXXXXXXX'', in addition to the standard ''\x...;'' notation.
-=== Special characters in strings
-
-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.
+Non-standard characters names supported are {{#\linefeed}}, {{#\vtab}}, {{#\nul}}, {{#\page}} and {{#\esc}}.
== Non-standard read syntax
-=== Escapes in symbols
-
-{{| ... |}} may be used to escape a sequence of characters when reading a symbol.
-{{\X}} escapes a single character in a symbols name:
-
- (symbol->string '|abc def|) => "abc def"
- (symbol->string '|abc||def|) => "abcdef"
- (symbol->string '|abc|xyz|def|) => "abcxyzdef"
- (symbol->string '|abc\|def|) => "abc|def"
- (symbol->string 'abc\ def) => "abc def"
-
=== Multiline Block Comment
<read>#|</read>
- #| ... |#
+ #| ... |#
A multiline ''block'' comment. May be nested. Implements [[http://srfi.schemers.org/srfi-30/srfi-30.html|SRFI-30]].
@@ -115,18 +51,11 @@ Allows user-defined extension of external representations. (For more information
An abbreviation for {{(location EXPRESSION)}}.
-=== Blob literals
-
-<read>#${</read>
-
- #${ HEX ... }
+=== Bytevector strings
-Syntax for literal "blobs" (byte-sequences). Expects hexadecimal digits and ignores
-any whitespace characters:
+<read>#u8"..."</read>
- #;1> ,d '#${deadbee f}
- blob of size 4:
- 0: de ad be ef ....
+String syntax for bytevectors, as an alternative to {{#u8(...)}}. The usual escape sequences for strings are recognized.
=== Keyword
@@ -198,7 +127,7 @@ String-literals may contain the following escape sequences:
<tr><td>{{\a}}</td><td>bell</td></tr>
<tr><td>{{\v}}</td><td>vertical tab</td></tr>
<tr><td>{{\f}}</td><td>form feed</td></tr>
-<tr><td>{{\x}}''XX''</td><td>hexadecimal 8-bit character code</td></tr>
+<tr><td>{{\x}}''XX;''</td><td>hexadecimal 8-bit character code</td></tr>
<tr><td>{{\u}}''XXXX''</td><td>hexadecimal 16-bit Unicode character code</td></tr>
<tr><td>{{\U}}''XXXXXXXX''</td><td>hexadecimal 32-bit Unicode character code</td></tr>
<tr><td>{{\}}''OOO''</td><td>octal 8-bit character code</td></tr>
@@ -210,7 +139,7 @@ String-literals may contain the following escape sequences:
<read>#!</read>
- #!...
+ #!...
Interpretation depends on the directly following characters. Only the following are recognized. Any other case results in a read error.
@@ -222,22 +151,6 @@ Interpretation depends on the directly following characters. Only the following
; 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
-
-<read>#cs</read>
-
- #cs...
-
-Read the next expression in case-sensitive mode (regardless of the current global setting).
-
-=== Case Insensitive Expression
-
-<read>#ci</read>
-
- #ci...
-
-Read the next expression in case-insensitive mode (regardless of the current global setting).
-
=== Conditional Expansion
<read>#+</read>
@@ -254,4 +167,4 @@ work as expected when used within a macro form.
---
Previous: [[Deviations from the standard]]
-Next: [[Debugging]]
+Next: [[Interface to external functions and variables]]
diff --git a/manual/Foreign type specifiers b/manual/Foreign type specifiers
index 8221e048..49dd9dce 100644
--- a/manual/Foreign type specifiers
+++ b/manual/Foreign type specifiers
@@ -26,7 +26,7 @@ This type maps to {{int}} in both C and C++.
<type>char</type><br>
<type>unsigned-char</type><br>
-A signed or unsigned character.
+A signed or unsigned character.
As an argument, the input Scheme character is cast to C {{char}} or
{{unsigned char}}, resulting in an 8-bit value. A Scheme character
@@ -98,9 +98,17 @@ so {{integer}} and {{integer32}} are functionally (if not semantically) equivale
<type>integer64</type><br>
<type>unsigned-integer64</type>
-A fixnum or bignum, mapping to {{int64_t}} or {{uint64_t}}.
-When outside of fixnum range the value will overflow into a bignum.
-Prior to CHICKEN 5, the value would overflow into a flonum.
+A fixnum or integral flonum, mapping to {{int64_t}} or {{uint64_t}}.
+When outside of fixnum range the value will overflow into a flonum.
+
+On a 32-bit system, the effective precision of this type is 52 bits
+plus the sign bit, as it is stored in a {{double}} flonum. (In other
+words, numbers between 2^52 and 2^64-1 can be represented but there are
+gaps in the sequence; the same goes for their negative counterparts.)
+On a 64-bit system the range is 62 bits plus the sign bit, the
+maximum range of a fixnum. (Numbers between 2^62 and 2^64-1 have gaps.)
+
+{{unsigned-integer64}} is not valid as a return type until CHICKEN 4.6.4.
<type>long</type><br>
<type>unsigned-long</type>
@@ -127,6 +135,11 @@ 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.
+<type>complex</type>
+
+A C99 {{double complex}} number. Accepts any numeric type but always
+converts to inexact.
+
=== Strings
<type>c-string</type><br>
@@ -177,13 +190,13 @@ to the caller). Attempting to return a NULL string will raise an exception.
=== Bytevectors
-<type>blob</type><br>
-<type>nonnull-blob</type>
+<type>bytevector</type><br>
+<type>nonnull-bytevector</type>
-A blob object, passed as a pointer to its contents. Permitted only as
-argument type, not return type.
+A bytevector object, passed as a pointer to its contents. Permitted only as
+argument type, not return type.
-Arguments of type {{blob}} may optionally be {{#f}}, which is passed
+Arguments of type {{bytevector}} may optionally be {{#f}}, which is passed
as a NULL pointer. For the {{nonnull-}} variant, passing a {{#f}}
value will raise an exception.
@@ -227,7 +240,7 @@ An operating-system pointer or a locative. {{c-pointer}} is untyped, whereas
The value {{#f}} is allowed and is passed to C as a {{NULL}} pointer;
similarly, NULL is returned as {{#f}}. For the two {{nonnull-}} variants,
passing {{#f}} will raise an exception, and returning NULL will result in
-a null {{pointer}} object.
+a null {{pointer}} object.
(Note: It is still possible to deliberately pass a null pointer through a
{{nonnull-c-pointer}} by manually creating a null pointer object,
@@ -267,7 +280,7 @@ An arbitrary, raw Scheme data object (immediate or non-immediate). A
internal CHICKEN type for objects. Typically, this consists of an
object header and tag bits. It is up to you to build or take apart
such objects using the core library routines in {{chicken.h}} and
-{{runtime.c}}.
+{{runtime.c}}.
More information on object structure can be found in [[Data representation]].
@@ -278,7 +291,7 @@ More information on object structure can be found in [[Data representation]].
An untyped pointer to the ''contents'' of a non-immediate Scheme
object; for example, the raw byte contents of a string. Only allowed
-as an argument type, not a return type.
+as an argument type, not a return type.
The optional element type {{TYPE}} may be used to specify what C
type should be used in the generated code. This avoids the need
@@ -291,26 +304,25 @@ Don't confuse this type with {{(c-pointer ...)}} which means something
different (a machine-pointer object).
{{scheme-pointer}} is typically used to get a pointer to the raw byte
-content of strings and blobs. But if you pass in a SRFI-4 vector, you
-will get a pointer to a blob object header (''not'' the blob's contents),
-which is almost certainly wrong. Instead, convert to a blob
+content of bytevectors. But if you pass in a SRFI-4 vector, you
+will get a pointer to a bytevector object header (''not'' the bytevectors's contents),
+which is almost certainly wrong. Instead, convert to a bytevector
beforehand, or use a SRFI-4 specific type.
=== User-defined C types
<type>(struct NAME)</type>
-A struct of the name {{NAME}}, which should be a string.
-
-Structs cannot be directly passed as arguments to foreign functions, nor
-can they be result values. However, pointers to structs are allowed.
+A struct of the name {{NAME}} or {{(NAME)}}, where {{NAME}} should be a string.
+The latter specifies a typedef naming a structure. On the Scheme side, results
+and argumens of this type will
+be wrapped in a record structure named {{struct NAME}} (or {{NAME}}). Values of this type
+arew opaque can not be manipulated directly in Scheme code.
<type>(union NAME)</type>
-A union of the name {{NAME}}, which should be a string.
-
-Unions cannot be directly passed as arguments to foreign functions, nor can
-they be result values. However, pointers to unions are allowed.
+A union of the name {{NAME}}, or {{(NAME)}}. Semantically handled identically
+to {{(struct NAME)}}.
<type>(enum NAME)</type>
@@ -335,7 +347,7 @@ following operations:
<type>(instance-ref CNAME SCHEMECLASS)</type>
-A reference to a C++ class instance.
+A reference to a C++ class instance.
<type>(template TYPE ARGTYPE ...)</type>
@@ -370,9 +382,10 @@ The foreign type {{TYPE}} with an additional {{const}} qualifier.
<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>{{complex}}</td><td>{{double complex}}</td></tr>
<tr><td>{{[nonnull-]c-pointer}}</td><td>{{void *}}</td></tr>
<tr><td>{{[nonnull-]pointer-vector}}</td><td>{{void **}}</td></tr>
-<tr><td>{{[nonnull-]blob}}</td><td>{{unsigned char *}}</td></tr>
+<tr><td>{{[nonnull-]bytevector}}</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>
@@ -392,9 +405,11 @@ The foreign type {{TYPE}} with an additional {{const}} qualifier.
<tr><td>{{([nonnull-]scheme-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>{{(struct (NAME))}}</td><td>{{NAME}}</td></tr>
+<tr><td>{{(union NAME)}}</td><td>{{union NAME}}</td></tr>
+<tr><td>{{(union (NAME))}}</td><td>{{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>
diff --git a/manual/Getting started b/manual/Getting started
index c0ed8167..9dc1e742 100644
--- a/manual/Getting started
+++ b/manual/Getting started
@@ -1,6 +1,6 @@
[[tags: manual]]
-== Getting started
+== 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
@@ -14,7 +14,7 @@ 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.
+writing and running small CHICKEN programs.
=== Scheme
@@ -23,7 +23,7 @@ Lisp, Emacs Lisp and Clojure are other 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
+* 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
@@ -33,19 +33,12 @@ contrast to Emacs Lisp, Scheme is not anchored into a single program
to Clojure, Scheme provides only a very minimal set of concepts but allows
them to be used in very general ways with few restrictions.
-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 a number of Scheme implementations have chosen
-not to be compliant
-with it. Yet another report was released in 2013 ("R7RS"), that was
-less ambitious than R6RS and more minimal.
+Scheme is defined in a document called ''The Revised^7 Report on the
+Algorithmic Language Scheme'', or ''R7RS'' for short. (Yes, it really
+has been revised seven times, so an expanded version of its name would
+be ''The Revised Revised Revised Revised Revised Report''.)
-CHICKEN fully complies with R5RS and, by using a separately available
-extension also with the "R7RS small" language.
+CHICKEN fully complies with R7RS.
Even though Scheme is consciously minimalist, it is recognized that a
language must be more than a minimal core in order to be
@@ -53,16 +46,16 @@ 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.
+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.
+FAQs, lists of useful books and other resources, and the SRFIs.
=== CHICKEN
CHICKEN Scheme combines an optimising compiler with a reasonably fast
-interpreter. It supports almost all of R7RS and the important SRFIs.
+interpreter. It supports all of R7RS 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
@@ -75,11 +68,11 @@ 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.
+and participates actively.
-CHICKEN includes
+CHICKEN includes
-* a Scheme interpreter that supports all of R5(7)RS Scheme, with
+* a Scheme interpreter that supports all of R7RS 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
@@ -100,7 +93,7 @@ number of interesting properties.
* Consing (creation of data on the heap) is inexpensive,
because a generational garbage collection scheme is used in combination
- with allocating on the C stack, in which short-lived data structures are reclaimed
+ with allocating on the C stack, in which short-lived data structures are reclaimed
extremely quickly.
* Moreover, {{call-with-current-continuation}} involves only minimal
@@ -122,16 +115,16 @@ Some of the features supported by CHICKEN:
* Built-in support for cross-compilation
CHICKEN has been used in many environments ranging from embedded
-systems through desktop machines to large-scale server deployments.
+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 libraries,
+* interfaces to database systems, GUIs, and other libraries,
* network applications, such as servers and clients for ftp,
- smtp/pop3, irc, and http
+ 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
@@ -145,7 +138,7 @@ programs.
The master CHICKEN website is
[[http://www.call-cc.org]]. Here you can find
basic information about CHICKEN, downloads and pointers to other key
-resources.
+resources.
The CHICKEN wiki ([[http://wiki.call-cc.org]]) contains the most
current version of the User's manual, along with various tutorials and
@@ -174,39 +167,29 @@ There is also an IRC channel ({{#chicken}}) on
CHICKEN is available as C sources. Refer to the
{{README}} file in the distribution for instructions on installing it
-on your system.
+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.)
+can pretty much ignore the C compiler once you have installed it.)
* On a Linux system, a C toolchain (e.g., GCC, clang) 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
+* On Macintosh OS X, you will need the XCode tools, which are
installable from the App Store.
-* On Windows, you have three choices:
+* On Windows, you have two choices:
* Cygwin ([[https://www.cygwin.com/]]) provides a relatively
full-featured Unix environment for Windows. CHICKEN works
- substantially the same in Cygwin and Unix.
+ substantially the same in Cygwin and Unix.
* The GNU Compiler Collection has been ported to Windows, in the
- MinGW system ([[http://mingw-w64.org/]]). Unlike Cygwin,
+ MinGW system. 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 libraries.
- The only difference is the environment where you actually run make.
- {{Makefile.mingw}} 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.
+ to run.
Refer to the {{README}} file for the version you're installing for
-more information on the installation process.
+more information on the installation process.
Alternatively, third party packages in binary format are
available. See
@@ -224,15 +207,15 @@ or vi-compatible line editing, customization).
It will be helpful to use a text editor that knows Scheme; it can be painful
with editors that don't do parenthesis matching and automatic
-indentation.
+indentation.
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.
+CHICKEN code.
=== The Read-Eval-Print loop
-To invoke the CHICKEN interpreter, you use the {{csi}} command.
+To invoke the CHICKEN interpreter, you use the {{csi}} command.
$ csi
CHICKEN
@@ -240,26 +223,26 @@ To invoke the CHICKEN interpreter, you use the {{csi}} command.
(c) 2000-2007, Felix L. Winkelmann
Version 5.3.0 (rev e31bbee5)
linux-unix-gnu-x86-64 [ 64bit dload ptables ]
-
+
Type ,? for help.
- #;1>
+ #;1>
This brings up a brief banner, and then the prompt. You can use this
-pretty much like any other Scheme system, e.g.,
+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.
+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.
+We can now load this file and try out the function.
#;3> (load "fact.scm")
; loading fact.scm ...
@@ -271,9 +254,9 @@ Scheme system that ''reads'' a Scheme expression, ''eval''uates it,
and ''prints'' out the result. The REPL's prompt can be customized
(see the [[Using the interpreter]])
but the default prompt, showing the number of the form, is quite
-convenient.
+convenient.
-The REPL also supports debugging commands:
+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]].)
@@ -287,7 +270,7 @@ expression and a replacement string. First create a file to hold the "data" call
xyzabcghi
abxawxcgh
- foonly
+ foonly
Next create the scheme code in a file called ''quickrep.scm'' with the
following little program:
@@ -298,13 +281,13 @@ following little program:
(import (chicken irregex)
(chicken io))
-(define (process-line line re rplc)
+(define (process-line line re rplc)
(irregex-replace/all re line rplc))
-(define (quickrep re rplc)
+(define (quickrep re rplc)
(let ((line (read-line)))
(if (not (eof-object? line))
- (begin
+ (begin
(display (process-line line re rplc))
(newline)
(quickrep re rplc)))))
@@ -320,7 +303,7 @@ To run it enter this in your shell:
$ csi -ss quickrep.scm <quickrep.dat 'a.*c' A
xyzAghi
Agh
- foonly
+ foonly
The {{-ss}} option sets several options that work smoothly together to
execute a script. You can make the command directly executable from
@@ -332,15 +315,15 @@ 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
+=== The compiler
-There are several reasons you might want to compile your code.
+There are several reasons you might want to compile your code.
* Compiled code executes substantially faster than interpreted
- code.
+ 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.
+ applications can be self-contained.
* Compiled code can access external libraries written in lower-level
languages that follow the C calling convention.
@@ -351,7 +334,7 @@ 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
+the simplest is to rename one of the two tools, and/or to
organize your {{PATH}} according to the task at hand.)
We can compile our factorial function, producing a file named
@@ -367,7 +350,7 @@ used in Windows, rather than {{dll}})
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.
+palindrome.
<enscript highlight=scheme>
(import (chicken process-context)) ; for "command-line-arguments"
@@ -381,15 +364,15 @@ palindrome.
(check 0 (sub1 (string-length x))))
(let ((arg (car (command-line-arguments))))
- (display
- (string-append arg
- (if (palindrome? arg)
+ (display
+ (string-append arg
+ (if (palindrome? arg)
" is a palindrome\n"
" isn't a palindrome\n"))))
</enscript>
We can compile this program using {{csc}}, creating an executable
-named {{palindrome}}.
+named {{palindrome}}.
$ csc -o palindrome palindrome.scm
$ ./palindrome level
@@ -399,7 +382,7 @@ named {{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}}).
+({{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
@@ -421,7 +404,7 @@ involve separated namespaces; namespaces can be implemented by
</enscript>
Next we have some client code that ''uses'' this separately-compiled
-module.
+module.
<enscript highlight=scheme>
;;; Client pal-user.scm
@@ -430,16 +413,16 @@ module.
(import (chicken process-context))
(let ((arg (car (command-line-arguments))))
- (display
- (string-append arg
- (if (palindrome? arg)
+ (display
+ (string-append arg
+ (if (palindrome? arg)
" is a palindrome\n"
" isn't a palindrome\n"))))
</enscript>
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.)
+into one command.)
$ csc -c pal-proc.scm
$ csc -c pal-user.scm
@@ -447,7 +430,7 @@ into one command.)
$ ./pal-separate level
level is a palindrome
-The "unit" mechanism is relatively low-level and requires some
+The "unit" mechanism is relatively low-level and requires some
familiarity with underlying mechanism used to manage compilation
units. See [[Units and linking model]] for more information.
@@ -460,60 +443,60 @@ egg from the master CHICKEN repository, and install it on your local
system.
In this example, we install the {{uri-common}} egg, for parsing
-Uniform Resource Identifiers.
+Uniform Resource Identifiers.
$ chicken-install uri-common
-
+
{{chicken-install}} connects to a mirror of the egg repository and
retrieves the egg contents. If the egg has any uninstalled
dependencies, it recursively installs them. Then it builds the egg
-code and installs the resulting extension into the
+code and installs the resulting extension into the
local CHICKEN repository.
-Now we can use our new egg.
+Now we can use our new egg.
#;1> (import uri-common)
; loading /usr/lib/chicken/9/uri-common.import.so ...
; [... other loaded files omitted for clarity ...]
-
+
#;2> (uri-host (uri-reference "http://www.foobar.org/blah"))
"www.foobar.org"
-=== Accessing C libraries
+=== 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 any facility available
on the host system is accessible from CHICKEN, with more or less
-work.
+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.)
+real example would take far too much space here.)
/* fib.c */
int fib(int n) {
int prev = 0, curr = 1;
- int next;
- int i;
+ int next;
+ int i;
for (i = 0; i < n; i++) {
next = prev + curr;
prev = curr;
- curr = next;
+ curr = next;
}
return curr;
- }
+ }
-Now we can call this function from CHICKEN.
+Now we can call this function from CHICKEN.
;;; fib-user.scm
(import (chicken foreign) (chicken format))
#>
extern int fib(int n);
- <#
+ <#
(define xfib (foreign-lambda int "fib" int))
(do ((i 0 (+ i 1))) ((> i 10))
(printf "~A " (xfib i)))
@@ -524,7 +507,7 @@ 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.
+{{xfib}} as though it were an ordinary Scheme function.
$ gcc -c fib.c
$ csc -o fib-user fib.o fib-user.scm
@@ -536,10 +519,10 @@ If using MinGW on Windows,
Then run the executable.
$ ./fib-user
- 0 1 1 2 3 5 8 13 21 34 55
+ 0 1 1 2 3 5 8 13 21 34 55
Those who are interfacing to substantial C libraries should consider
-using the [[/egg/bind|bind egg]].
+using the [[/egg/bind|bind egg]].
---
diff --git a/manual/Included modules b/manual/Included modules
index 256b3f09..b2390d46 100644
--- a/manual/Included modules
+++ b/manual/Included modules
@@ -8,13 +8,32 @@ of the manual provides a reference guide to all the modules that are
part of a standard installation. On top of these, you can install
additional modules through the [[Extensions|eggs]] system.
-* [[Module scheme]] : Standard Scheme procedures and syntax
-* [[Module r5rs]] : Standard Scheme procedures and syntax (alias for scheme)
-* [[Module r4rs]] : Standard procedures and syntax of an old Scheme report
-* [[Module srfi-4]] : Homogeneous numeric vector datatypes
+Note that toplevel code that is not contained in a module has by
+default all exports of the [[Module scheme|scheme]],
+[[Module (chicken base)|(chicken base)]] and
+[[Module (chicken syntax)|(chicken syntax)]] available.
+
+* [[Module scheme]] : Compatibility module for CHICKEN 5 code
+* [[Module (scheme r4rs)]] : Standard procedures and syntax of R4RS Scheme
+* [[Module (scheme r5rs)]] : Standard procedures and syntax of R5RS Scheme
+* [[Module (scheme base)]] : R7RS evaluation of forms
+* [[Module (scheme case-lambda)]] : R7RS {{case-lambda}} form
+* [[Module (scheme char)]] : R7RS operations on characters
+* [[Module (scheme complex)]] : R7RS operations on complex number
+* [[Module (scheme cxr)]] : R7RS extended {{c..r}} procedures
+* [[Module (scheme file)]] : R7RS file procedures
+* [[Module (scheme eval)]] : R7RS evaluation of forms
+* [[Module (scheme inexact)]] : R7RS operations on inexact numbers
+* [[Module (scheme lazy)]] : R7RS promises and delayed evaluation of forms
+* [[Module (scheme load)]] : R7RS {{load}} procedure
+* [[Module (scheme process-context)]] : R7RS procedures for interacting with the environment
+* [[Module (scheme read)]] : R7RS {{read}} procedure
+* [[Module (scheme repl)]] : R7RS {{interaction-environment}} procedure
+* [[Module (scheme time)]] : R7RS time procedures
+* [[Module (scheme write)]] : R7RS expression printing
* [[Module (chicken base)]] : Core procedures and macros
* [[Module (chicken bitwise)]] : Bitwise manipulation on integers
-* [[Module (chicken blob)]] : Unstructured byte data
+* [[Module (chicken bytevector)]] : Unstructured byte data
* [[Module (chicken condition)]] : Raising and handling of exceptions, manipulation of condition objects
* [[Module (chicken continuation)]] : Feeley's "a better API for continuations"
* [[Module (chicken csi)]] : Features specific to {{csi}}
@@ -35,6 +54,7 @@ additional modules through the [[Extensions|eggs]] system.
* [[Module (chicken memory)]] : Low-level memory operations
* [[Module (chicken memory representation)]] : Low-level operations on the memory representation of Scheme objects
* [[Module (chicken module)]] : Defining modules
+* [[Module (chicken number-vector)]] : Homogenous numeric vectors
* [[Module (chicken pathname)]] : Manipulating path names
* [[Module (chicken platform)]] : Information about the platform your code is running on
* [[Module (chicken plist)]] : Symbol property lists
@@ -54,30 +74,24 @@ additional modules through the [[Extensions|eggs]] system.
* [[Module (chicken time)]] : Fetching information about the current time
* [[Module (chicken time posix)]] : Manipulating POSIX time
* [[Module (chicken type)]] : Defining and using static typing information
+* [[Module srfi-4]] : The subset of [[Module (chicken number-vector)]] specified by SRFI-4
In addition to the core modules listed above, the following SRFI modules can be
imported. These provide access to identifiers described by the SRFI, but which
may already be defined by other parts of CHICKEN's standard library.
-* Module srfi-0 : Feature-based conditional expansion construct
* Module srfi-2 : AND-LET*: an AND with local bindings, a guarded LET* special form
-* Module srfi-6 : Basic String Ports
* Module srfi-8 : receive: Binding to multiple values
-* Module srfi-9 : Defining Record Types
* Module srfi-10 : #, external form
-* Module srfi-11 : Syntax for receiving multiple values
* Module srfi-12 : Exception Handling
* Module srfi-15 : Syntax for dynamic scoping
* Module srfi-16 : Syntax for procedures of variable arity
* Module srfi-17 : Generalized set!
-* Module srfi-23 : Error reporting mechanism
* Module srfi-26 : Notation for Specializing Parameters without Currying
* Module srfi-28 : Basic Format Strings
* Module srfi-31 : A special form `rec' for recursive evaluation
-* Module srfi-39 : Parameter objects
* Module srfi-55 : require-extension
* Module srfi-88 : Keyword objects
-* Module srfi-98 : An interface to access environment variables
Other SRFI features may be supported but do not correspond to any importable module.
Refer to {{cond-expand}} for a list of non-module SRFI feature identifiers.
diff --git a/manual/Module (chicken base) b/manual/Module (chicken base)
index 42bc92a0..b5e0dbe3 100644
--- a/manual/Module (chicken base)
+++ b/manual/Module (chicken base)
@@ -3,7 +3,7 @@
== Module (chicken base)
-Core procedures and macros, acting as basic extensions to the R5RS
+Core procedures and macros, acting as basic extensions to the R7RS
standard and other essential features.
This module is used by default, unless a program is compiled with
@@ -12,7 +12,7 @@ the {{-explicit-use}} option.
=== Numeric predicates
These allow you to make a more precise differentiation between number
-types and their properties, not provided by R5RS.
+types and their properties, not provided by R7RS.
==== fixnum?
@@ -119,17 +119,6 @@ in combination with comparison of numerical data by value.
Adds/subtracts 1 from {{N}}.
-==== exact-integer-sqrt
-
-<procedure>(exact-integer-sqrt K)</procedure>
-
-Returns two values {{s}} and {{r}}, where {{s^2 + r = K}} and {{K < (s+1)^2}}.
-In other words, {{s}} is the closest square root we can find that's equal to or
-smaller than {{K}}, and {{r}} is the rest if {{K}} isn't a neat square of two numbers.
-
-This procedure is compatible with the definition from the R7RS
-{{(scheme base)}} library.
-
==== exact-integer-nth-root
<procedure>(exact-integer-nth-root K N)</procedure>
@@ -193,14 +182,14 @@ noted above.
(weak-cons "a" '(b c)) ===> ("a" b c)
(weak-cons 'a 3) ===> (a . 3)
(weak-cons '(a b) 'c) ===> ((a b) . c)
-
+
(import (chicken gc))
-
+
(let* ((x '(a b))
(y (weak-cons x 'c)))
(gc #t)
(car x)) ===> (a b)
-
+
(let ((x (weak-cons '(a b) 'c)))
(gc #t)
(car x)) ===> #!bwp
@@ -225,58 +214,6 @@ This predicate returns {{#t}} if {{obj}} is the broken-weak-pointer
value, otherwise {{#f}}.
-=== Lazy evaluation
-
-==== delay-force
-
-<macro>(delay-force <expression>)</macro><br>
-
-The expression {{(delay-force expression)}} is conceptually similar to
-{{(delay (force expression))}}, with the difference that forcing the
-result of {{delay-force}} will in effect result in a tail call to
-{{(force expression)}}, while forcing the result of
-{{(delay (force expression))}} might not.
-
-Thus iterative lazy algorithms that might result in a long series of
-chains of delay and force can be rewritten using delay-force to
-prevent consuming unbounded space during evaluation.
-
-This special form is compatible with the definition from the R7RS
-{{(scheme lazy)}} library.
-
-See the description of force under
-[[Module scheme#control-features|Control features]] in the "scheme"
-module documentation for a more complete description of delayed
-evaluation.
-
-For more information regarding the unbounded build-up of space, see
-the [[http://srfi.schemers.org/srfi-45/srfi-45.html|SRFI-45]]
-rationale.
-
-==== make-promise
-
-<procedure>(make-promise obj)</procedure>
-
-The make-promise procedure returns a promise which, when forced, will
-return {{obj}} . It is similar to {{delay}}, but does not delay its
-argument: it is a procedure rather than syntax. If {{obj}} is already
-a promise, it is returned.
-
-This procedure is compatible with the definition from the R7RS
-{{(scheme lazy)}} library.
-
-
-==== promise?
-
-<procedure>(promise? X)</procedure>
-
-Returns {{#t}} if {{X}} is a promise returned by {{delay}}, or
-{{#f}} otherwise.
-
-This procedure is compatible with the definition from the R7RS
-{{(scheme lazy)}} library.
-
-
=== Input/Output
==== current-error-port
@@ -524,17 +461,6 @@ Returns true if {{X}} is one of the tails (cdr's) of {{LIST}}.
=== 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>
@@ -636,7 +562,7 @@ of the last procedure application. For example
is equivalent to
<enscript highlight=scheme>
-(lambda args
+(lambda args
(apply pp args)
(apply eval args) )
</enscript>
@@ -685,6 +611,23 @@ A single value version of {{compose}} (slightly faster). {{(o)}} is equivalent
to {{identity}}.
+=== UNICODE case folding
+
+==== char-foldcase
+
+<procedure>(char-foldcase CHAR)</procedure>
+
+Performs simple UNICODE case folding to {{CHAR}}, language-specific mappings
+are not used.
+
+==== string-foldcase
+
+<procedure>(string-foldcase STRING)</procedure>
+
+Performs UNICODE case folding to {{STRING}}, language-specific mappings
+are not used. The resulting string may be longer than the original string.
+
+
=== User-defined named characters
==== char-name
@@ -756,7 +699,7 @@ identical to a symbol written before:
(define sym 'foo)
(eq? sym (with-input-from-string
- (with-output-to-string
+ (with-output-to-string
(lambda () (write sym)))
read))
@@ -770,7 +713,7 @@ multiple symbols with the same name may coexist:
(define sym (gensym 'foo)) ; sym is a uninterned symbol like "foo42"
(eq? sym (with-input-from-string ; the symbol read will be an interned symbol
- (with-output-to-string
+ (with-output-to-string
(lambda () (write sym)))
read))
@@ -847,33 +790,6 @@ an error if {{ARGS}} contains more than one value.
</enscript>
-==== case-lambda
-
-<macro>(case-lambda (LAMBDA-LIST1 EXP1 ...) ...)</macro>
-
-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]]
-
-This special form is also compatible with the definition from the R7RS
-{{(scheme case-lambda)}} library.
-
==== let-optionals
<macro> (let-optionals ARGS ((VAR1 DEFAULT1) ...) BODY ...)</macro>
@@ -1019,7 +935,7 @@ notation is supported).
<enscript highlight=scheme>
(letrec-values (((odd even)
- (values
+ (values
(lambda (n) (if (zero? n) #f (even (sub1 n))))
(lambda (n) (if (zero? n) #t (odd (sub1 n)))) ) ) )
(odd 17) ) ==> #t
@@ -1058,57 +974,6 @@ Returns the {{N}}th value (counting from zero) of the values returned
by expression {{EXP}}.
-=== 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]], which
-is also standardized by R7RS.
-
-
-==== parameterize
-
-<macro>(parameterize ((PARAMETER1 X1) ...) BODY ...)</macro>
-
-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.
-
-This special form is compatible with the definition from the R7RS
-{{(scheme base)}} library.
-
-==== make-parameter
-
-<procedure>(make-parameter VALUE [GUARD])</procedure>
-
-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 and returns the new value (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.
-
-This special form is compatible with the definition from the R7RS
-{{(scheme base)}} library.
-
=== Substitution forms and macros
==== define-constant
@@ -1178,7 +1043,6 @@ Equivalent to:
(if TEST (begin EXP1 EXP2 ...))
</enscript>
-
=== Record structures
==== define-record
@@ -1282,16 +1146,56 @@ s ==> "#,(foo 1 2 3)"
=== Other forms
+==== load
+
+<procedure>(load filename [evalproc])</procedure><br>
+
+Filename should be a string naming an existing file containing Scheme
+source code. The load procedure reads expressions and definitions from
+the file and evaluates them sequentially. It is unspecified whether the
+results of the expressions are printed. The load procedure does not
+affect the values returned by current-input-port and
+current-output-port. Load returns an unspecified value.
+
+CHICKEN offers a few extensions to the R7RS definition of {{load}}:
+
+* The {{filename}} may also be an input port.
+* The expressions which are read one by one from the source file are passed to the procedure indicated by the extra optional {{evalproc}} argument, which defaults to {{eval}}.
+* On platforms that support it (currently BSD, Haiku, MacOS X, Linux, Solaris, and Windows), {{load}} can be used to load shared objects.
+
+Example for loading 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>
+
+There are some limitations and caveats to the CHICKEN extensions you
+need to be aware of:
+
+* 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.
+* A compiled file can only be loaded once. Subsequent attempts to load the same file have no effect.
+
==== include
-<macro>(include STRING)</macro>
+<macro>(include STRING1 STRING2 ...)</macro>
+<macro>(include-ci STRING1 STRING2 ...)</macro>
-Include toplevel-expressions from the given source file in the currently
+Include toplevel-expressions from the given source files in the currently
compiled/interpreted program. If the included file has the extension
{{.scm}}, then it may be omitted. The file is searched for in the
current directory and all directories specified by the {{-include-path}}
option.
+{{include-ci}} works as {{include}} but reads files in case-insensitive
+mode.
+
==== include-relative
<macro>(include-relative STRING)</macro>
@@ -1417,32 +1321,6 @@ to sleep and other threads may continue executing. Otherwise, the whole
process is put to sleep.
-=== Ports
-
-==== 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.
-
-
=== File Input/Output
==== flush-output
@@ -1454,29 +1332,12 @@ to the value of {{(current-output-port)}}.
=== Port predicates
-==== input-port-open?
-
-<procedure>(input-port-open? PORT)</procedure>
-
-Is the given {{PORT}} open for input?
-
-<procedure>(output-port-open? PORT)</procedure>
-
-Is the given {{PORT}} open for output?
-
==== port-closed?
<procedure>(port-closed? PORT)</procedure>
Is the given {{PORT}} closed (in all directions)?
-==== port?
-
-<procedure>(port? X)</procedure>
-
-Returns {{#t}} if {{X}} is a port object or {{#f}}
-otherwise.
-
=== Built-in parameters
@@ -1515,7 +1376,8 @@ If true, then the list delimiter synonyms {{#\[}} {{#\]}} and {{#\{}} {{#\}}} ar
<parameter>(symbol-escape)</parameter>
-If true, then the symbol escape {{#\|}} {{#\|}} is enabled. Defaults to {{#t}}.
+If true, then the symbol escape {{#\|}} {{#\|}} is allowed when reading
+and printing expressions. Defaults to {{#t}}.
---
diff --git a/manual/Module (chicken bitwise) b/manual/Module (chicken bitwise)
index 9932c299..7865f728 100644
--- a/manual/Module (chicken bitwise)
+++ b/manual/Module (chicken bitwise)
@@ -36,4 +36,4 @@ Returns the number of bits needed to represent the exact integer N in
---
Previous: [[Module (chicken base)]]
-Next: [[Module (chicken blob)]]
+Next: [[Module (chicken bytevector)]]
diff --git a/manual/Module (chicken blob) b/manual/Module (chicken blob)
deleted file mode 100644
index 48d7a388..00000000
--- a/manual/Module (chicken blob)
+++ /dev/null
@@ -1,55 +0,0 @@
-[[tags: manual]]
-[[toc:]]
-
-== Module (chicken blob)
-
-This module contains procedures for dealing with "blobs". Blobs are
-unstructured byte arrays (basically "binary strings"). You can't do
-much with them, but they allow conversion to and from
-[[Module srfi-4|SRFI-4 number vectors]] which define how to access a
-blob's byte contents.
-
-=== 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.
-
-
----
-Previous: [[Module (chicken bitwise)]]
-
-Next: [[Module (chicken condition)]]
diff --git a/manual/Module (chicken bytevector) b/manual/Module (chicken bytevector)
new file mode 100644
index 00000000..db8fe83f
--- /dev/null
+++ b/manual/Module (chicken bytevector)
@@ -0,0 +1,114 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module (chicken bytevector)
+
+This module contains procedures for dealing with "bytevectors". Blobs are
+unstructured byte arrays (basically "binary strings"). You can't do
+much with them, but they allow conversion to and from
+[[Module srfi-4|SRFI-4 number vectors]] which define how to access a
+bytevector's byte contents.
+
+=== bytevector
+
+<procedure>(bytevector FIXNUM ...)</procedure>
+
+Returns a new bytevector containing the values {{FIXNUM ...}}.
+
+=== make-bytevector
+
+<procedure>(make-bytevector SIZE)</procedure>
+
+Returns a bytevector object of {{SIZE}} bytes, aligned on an 8-byte boundary,
+uninitialized.
+
+=== bytevector?
+
+<procedure>(bytevector? X)</procedure>
+
+Returns {{#t}} if {{X}} is a bytevector object, or
+{{#f}} otherwise.
+
+=== bytevector-length
+
+<procedure>(bytevector-length BYTEVECTOR)</procedure>
+
+Returns the number of bytes in {{BYTEVECTOR}}.
+
+=== bytevector-u8-ref
+
+<procedure>(bytevector-u8-ref BYTEVECTOR INDEX)</procedure>
+
+Returns the byte at {{INDEX}} in {{BYTEVECTOR}}.
+
+=== bytevector-u8-set!
+
+<procedure>(bytevector-u8-set! BYTEVECTOR INDEX VALUE)</procedure>
+
+Destructively modifies the byte at {{INDEX}} in {{BYTEVECTOR}} to {{VALUE}}, which
+should be a fixnum.
+
+=== utf8->string
+
+<procedure>(utf8->string BYTEVECTOR [VALIDATE])</procedure>
+
+Returns a string with the contents of {{BYTEVECTOR}}. if {{VALIDATE}}
+is given and false, then invalidly
+encoded characters do not signal an error - byte-sequences that do no represent
+valid UTF-8 characters are retained and, if extracted with {{string-ref}}
+are converted to a trailing surrogate pair half in the range U+DC80 to U+DCFF.
+
+=== string->utf8
+
+<procedure>(string->utf8 STRING)</procedure>
+
+Returns a bytevector with the contents of {{STRING}}.
+
+=== latin1->string
+
+<procedure>(latin1->string BYTEVECTOR)</procedure>
+
+Returns a string with the contents of {{BYTEVECTOR}} converted from Latin-1 (ISO-8859-1) encoding to UTF-8.
+
+=== string->latin1
+
+<procedure>(string->latin1 STRING)</procedure>
+
+Returns a bytevector with the contents of {{STRING}} encoded as Latin-1 (ISO-?8859-1).
+
+=== bytevector=?
+
+<procedure>(bytevector=? BYTEVECTOR1 BYTEVECTOR2)</procedure>
+
+Returns {{#t}} if the two argument bytevectors are of the same
+size and have the same content.
+
+=== bytevector-append
+
+<procedure>(bytevector-append BYTEVECTOR ...)</procedure>
+
+Returns a new bytevector holding the concatenated contents of all
+argument bytevectors.
+
+=== bytevector-copy
+
+<procedure>(bytevector-copy BYTEVECTOR #!optional START END)</procedure>
+
+Returns a new bytevector holding the contents of {{BYTEVECTOR}} between
+the indices {{START}} to {{END}}.
+
+=== bytevector-copy!
+
+<procedure>(bytevector-copy! TO AT FROM #!optional START END)</procedure>
+
+Copioes the contents of the bytevector FROM between
+the indices {{START}} to {{END}} into the bytevector {{TO}}, starting at
+index {{AT}}.
+
+
+---
+Previous: [[Module (chicken bitwise)]]
+
+Next: [[Module (chicken condition)]]
+
+
diff --git a/manual/Module (chicken condition) b/manual/Module (chicken condition)
index 50090c5c..890d92f2 100644
--- a/manual/Module (chicken condition)
+++ b/manual/Module (chicken condition)
@@ -322,9 +322,7 @@ indicates a continuable exception.
<procedure>(condition? obj)</procedure><br>
-Returns #t if ''obj'' is a condition, otherwise returns #f. If any of
-the predicates listed in Section 3.2 of the R5RS is true of ''obj'', then
-{{condition?}} is false of ''obj''.
+Returns #t if ''obj'' is a condition, otherwise returns #f.
Rationale: Any Scheme object may be passed to an exception handler. This
would cause ambiguity if conditions were not disjoint from all of Scheme's
@@ -451,6 +449,6 @@ extracts the error message from ''exn''. Example:
</enscript>
----
-Previous: [[Module (chicken blob)]]
+Previous: [[Module (chicken bytevector)]]
Next: [[Module (chicken continuation)]]
diff --git a/manual/Module (chicken csi) b/manual/Module (chicken csi)
index 3b8ec30f..c75988d7 100644
--- a/manual/Module (chicken csi)
+++ b/manual/Module (chicken csi)
@@ -17,28 +17,6 @@ argument {{HELPSTRING}} is given, it will be listed by the {{,?}} command.
=== set-describer!
-
-<procedure>(set-describer! TAG PROC)</procedure>
-
-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)
- (with-output-to-port o
- (lambda ()
- (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
-
-
=== default-evaluator
<procedure>(default-evaluator EXPR)</procedure>
diff --git a/manual/Module (chicken file posix) b/manual/Module (chicken file posix)
index 95574f78..1df15369 100644
--- a/manual/Module (chicken file posix)
+++ b/manual/Module (chicken file posix)
@@ -544,7 +544,7 @@ procedure is unimplemented and will raise an error.
<procedure>(file-write FILENO BUFFER [SIZE])</procedure>
-Writes the contents of the string or bytevector {{BUFFER}} into
+Writes the contents of the 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.
@@ -563,14 +563,15 @@ procedure is unimplemented and will raise an error.
==== open-input-file*
==== open-output-file*
-<procedure>(open-input-file* FILENO [OPENMODE])</procedure><br>
-<procedure>(open-output-file* FILENO [OPENMODE])</procedure>
+<procedure>(open-input-file* FILENO [OPENMODE ENCODING])</procedure><br>
+<procedure>(open-output-file* FILENO [OPENMODE ENCODING])</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).
+an output-file for appending). {{ENCODING}} should be a symbol specifying a
+file encoding and defaults to {{utf-8}}.
==== port->fileno
@@ -580,28 +581,28 @@ If {{PORT}} is a file- or tcp-port, then a file-descriptor is returned for
this port. Otherwise an error is signaled.
-=== Record locking
+=== File locking
These procedures are all unsupported on native Windows builds (all
except cygwin).
==== file-lock
-<procedure>(file-lock PORT [START [LEN]])</procedure>
+<procedure>(file-lock PORT [SHARED])</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.
+Locks the file associated with {{PORT}} using an "exclusive" lock
+(see {{flock(2)}} for more information on shared vs exclusive locks).
+If {{SHARED}} is given and true, then a shared lock will be requested.
+Returns {{#t}} if requesting the lock succeeded or {{#f}} otherwise.
+
+{{PORT}} may be a file port or a file-descriptor.
'''NOTE''': On native Windows builds (all except cygwin), this
procedure is unimplemented and will raise an error.
==== file-lock/blocking
-<procedure>(file-lock/blocking PORT [START [LEN]])</procedure>
+<procedure>(file-lock/blocking PORT [SHARED])</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.
@@ -609,22 +610,12 @@ the current process blocks (including all threads) until the lock is released.
'''NOTE''': On native Windows builds (all except cygwin), this
procedure is unimplemented and will raise an error.
-==== 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.
-
-'''NOTE''': On native Windows builds (all except cygwin), this
-procedure is unimplemented and will raise an error.
-
==== file-unlock
-<procedure>(file-unlock LOCK)</procedure>
+<procedure>(file-unlock PORT)</procedure>
-Unlocks the previously locked portion of a file given in {{LOCK}}.
+Unlocks the previously locked file given {{PORT}} which may
+be a file port or a file-scriptor.
'''NOTE''': On native Windows builds (all except cygwin), this
procedure is unimplemented and will raise an error.
diff --git a/manual/Module (chicken flonum) b/manual/Module (chicken flonum)
index b06dcbb6..fe3fc0a7 100644
--- a/manual/Module (chicken flonum)
+++ b/manual/Module (chicken flonum)
@@ -62,7 +62,7 @@ arguments. A non-flonum argument in unsafe mode can crash the
application. {{fp*+}} implements fused multiply-add {{(X * Y) + Z}}.
Note: {{fpround}} uses the rounding mode that your C library
-implements, which is usually different from R5RS.
+implements, which is usually different from R7RS.
== Flonum limits
diff --git a/manual/Module (chicken foreign) b/manual/Module (chicken foreign)
index fac40174..24e14534 100644
--- a/manual/Module (chicken foreign)
+++ b/manual/Module (chicken foreign)
@@ -11,7 +11,7 @@ Note that this interface is source-based, since CHICKEN translates
Scheme code to C. It is not binary, as in many other Scheme implementations.
Several special forms of this interface refer to ''foreign type specifiers'',
-consult the [[/manual/Foreign type specifiers|relevant chapter]] of this manual for
+consult the [[Foreign type specifiers|relevant chapter]] of this manual for
more information.
@@ -62,7 +62,7 @@ Scheme namespace. The optional arguments {{ARGCONVERT}} and
result-values to a value that can be transformed to {{TYPE}}:
<enscript highlight=scheme>
-(define-foreign-type char-vector
+(define-foreign-type char-vector
nonnull-c-string
(compose list->string vector->list)
(compose list->vector string->list) )
@@ -75,7 +75,7 @@ result-values to a value that can be transformed to {{TYPE}}:
(define memset
(foreign-lambda char-vector "memset" char-vector char int) )
-(memset '#(#_ #_ #_) #\X 3) ==> #(#\X #\X #\X)
+(memset '#(#\_ #\_ #\_) #\X 3) ==> #(#\X #\X #\X)
</enscript>
Foreign type-definitions are only visible in the compilation-unit in which
@@ -199,7 +199,7 @@ where {{N}} is the number of values to be returned, and {{X1, ...}}
are the results, which should be Scheme data objects.
See [[/manual/C interface#constructors|Constructors]] for the APIs to construct Scheme data objects from C primitives.
When returning multiple values, the return-type should be omitted.
-Of course, if you have to dynamically compute the values, you do not have to use C's
+Of course, if you have to dynamically compute the values, you do not have to use C's
array initialization syntax, but you can just assign them one by one.
Returning just a single value can still be done via the {{C_return(...)}} macro.
@@ -307,7 +307,7 @@ that the value pointed to by {{ptr}} is located in the stack.
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.
+machine word, and double-precision floating point values.
@@ -316,7 +316,7 @@ machine word, and double-precision floating point values.
<macro>(define-location NAME TYPE [INIT])</macro>
Identical to {{(define-external NAME TYPE [INIT])}}, but the variable
-is not accessible from outside of the current compilation unit (it is
+is not accessible from outside of the current compilation unit (it is
declared {{static}}).
=== let-location
diff --git a/manual/Module (chicken io) b/manual/Module (chicken io)
index 3c67b91b..80675b49 100644
--- a/manual/Module (chicken io)
+++ b/manual/Module (chicken io)
@@ -61,11 +61,9 @@ character(s).
=== read-string
=== read-string!
-=== write-string
<procedure>(read-string [NUM [PORT]])</procedure><br>
<procedure>(read-string! NUM STRING [PORT [START]])</procedure><br>
-<procedure>(write-string STRING [NUM [PORT]])</procedure>
Read or write {{NUM}} characters from/to {{PORT}}, which defaults to the
value of {{(current-input-port)}} or {{(current-output-port)}}, respectively.
@@ -80,6 +78,41 @@ then the read characters are stored starting at that position.
{{read-string!}} returns the actual number of characters read.
+=== read-bytevector
+
+<procedure>(read-bytevector [NUM [PORT]])</procedure>
+
+Read {{NUM}} bytes from {{PORT}}, which defaults to the
+value of {{(current-input-port)}}. {{read-bytevector}} allocates
+a new buffer and returns it (or the end-of-file object, if at the end
+of the input file).
+
+If {{NUM}} is optional and not given, then all remaining input is read
+or the whole bytevector is read/written.
+
+=== read-bytevector!
+
+<procedure>(read-bytevector! BYTEVECTOR [PORT START END])</procedure>
+
+Read bytes from {{PORT}} into {{BYTEVECTOR}}. {{PORT}} defaults to the
+value of {{(current-input-port)}} and returns the actual number of bytes read.
+
+{{START}} and {{END}} designate the range of bytes that should be filled
+with input from {{PORT}}. If {{END}} exceeeds the length of {{BYTEVECTOR}}
+only as much data is read as fits into the destination buffer.
+
+=== write-bytevector
+
+<procedure>(write-bytevector BYTEVECTOR [PORT START END])</procedure>
+
+Write bytes from {{BYTEVECTOR}} to {{PORT}}. {{PORT}} defaults to the
+value of {{(current-output-port)}}.
+
+{{START}} and {{END}} designate the range of bytes that should be written.
+If {{END}} exceeeds the length of {{BYTEVECTOR}}
+only as much data is written as is available.
+
+
=== read-token
<procedure>(read-token PREDICATE [PORT])</procedure>
diff --git a/manual/Module (chicken irregex) b/manual/Module (chicken irregex)
index a5914a95..f0c39dc7 100644
--- a/manual/Module (chicken irregex)
+++ b/manual/Module (chicken irregex)
@@ -662,7 +662,7 @@ The current patterns provided are:
integer ; an integer
real ; a real number (including scientific)
string ; a "quoted" string
- symbol ; an R5RS Scheme symbol
+ symbol ; an R7RS Scheme symbol
ipv4-address ; a numeric decimal ipv4 address
ipv6-address ; a numeric hexadecimal ipv6 address
domain ; a domain name
diff --git a/manual/Module (chicken load) b/manual/Module (chicken load)
index f5c18668..6f2e6c0e 100644
--- a/manual/Module (chicken load)
+++ b/manual/Module (chicken load)
@@ -17,19 +17,19 @@ are supported. Loading source files works everywhere.
=== load-relative
-<procedure>(load-relative FILE [EVALPROC])</procedure>
+<procedure>(load-relative FILE [ENVIRONMENT])</procedure>
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)</procedure>
+<procedure>(load-noisily FILE #!key ENVIRONMENT TIME PRINTER)</procedure>
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
+is written to standard output. If {{ENVIRONMENT}} is given and not {{#f}},
+then each expression is evaluated using this environment. {{ENVIRONMENT}} may also be
+a procedure used to evaluate each toplevel form. 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
diff --git a/manual/Module (chicken locative) b/manual/Module (chicken locative)
index 9c26a2a3..6a5d417b 100644
--- a/manual/Module (chicken locative)
+++ b/manual/Module (chicken locative)
@@ -19,9 +19,10 @@ module.
<procedure>(make-locative OBJ [INDEX])</procedure>
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,
+{{OBJ}} at position {{INDEX}}. {{OBJ}} may be a vector, pair, string, bytevector,
SRFI-4 number-vector, or record structure. {{INDEX}} should be a fixnum.
-{{INDEX}} defaults to 0.
+{{INDEX}} defaults to 0. Note that {{INDEX}} designates a character-position
+for string objects, not a byte offset.
=== make-weak-locative
diff --git a/manual/Module (chicken memory representation) b/manual/Module (chicken memory representation)
index 765e3209..1ca47f43 100644
--- a/manual/Module (chicken memory representation)
+++ b/manual/Module (chicken memory representation)
@@ -68,7 +68,7 @@ These procedures operate with what are known as ''vector-like
objects''. A ''vector-like object'' is a vector, record structure,
pair, symbol or keyword: it is an aggregation of other Scheme objects.
-Note that strings and blobs are not considered vector-like (they are
+Note that strings and bytevectors are not considered vector-like (they are
considered to be ''byte vectors'', which are objects of mostly
unstructured binary data).
@@ -110,7 +110,8 @@ contains.
<procedure>(number-of-bytes BLOCK)</procedure>
Returns the number of bytes that the object {{BLOCK}}
-contains. {{BLOCK}} may be any non-immediate value.
+holds. {{BLOCK}} may be any non-immediate value. For strings and symbols, the size
+of the buffer holding the encoded characters is returned.
==== object-copy
diff --git a/manual/Module (chicken memory) b/manual/Module (chicken memory)
index 544b337b..f30402d4 100644
--- a/manual/Module (chicken memory)
+++ b/manual/Module (chicken memory)
@@ -379,7 +379,7 @@ Set every element in the {{POINTERVECTOR}} to {{POINTER}}.
<procedure>(move-memory! FROM TO [BYTES [FROM-OFFSET [TO-OFFSET]]])</procedure>
Copies {{BYTES}} bytes of memory from {{FROM}} to {{TO}}. {{FROM}} and {{TO}}
-may be strings, blobs, [[Module srfi-4|SRFI-4 number-vectors]], memory
+may be strings, bytevectors, [[Module srfi-4|SRFI-4 number-vectors]], 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
diff --git a/manual/Module (chicken module) b/manual/Module (chicken module)
index d8f42266..fbc2d0cb 100644
--- a/manual/Module (chicken module)
+++ b/manual/Module (chicken module)
@@ -9,4 +9,4 @@ The functionality in this module is available by default. See
---
Previous: [[Module (chicken memory representation)]]
-Next: [[Module (chicken pathname)]]
+Next: [[Module (chicken number-vector)]]
diff --git a/manual/Module (chicken number-vector) b/manual/Module (chicken number-vector)
new file mode 100644
index 00000000..2aeb7118
--- /dev/null
+++ b/manual/Module (chicken number-vector)
@@ -0,0 +1,392 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module (chicken numvector)
+
+Homogeneous numeric vector datatypes. This module provides a superset
+of [[http://srfi.schemers.org/srfi-4/srfi-4.html|SRFI-4]]. The
+module [[Module srfi-4|srfi-4]] is also available for compatibility reasons.
+
+When loaded, the feature identifier {{srfi-4}} is defined.
+
+=== CHICKEN implementation specifics and extensions to SRFI-4
+
+* Procedures for [[Module (chicken bytevector)|bytevector]] conversion, subvectors and vector I/O are provided.
+* SRFI-17 setters for {{XXXvector-ref}} are defined.
+* Constructors allow allocating the storage in non garbage collected memory.
+* Vectors for 64 and 128-bit complex numbers are provided.
+
+This module provides a set of datatypes for vectors whose elements are
+of the same numeric type (signed or unsigned exact integer or inexact
+real of a given precision). These datatypes support operations analogous
+to the Scheme vector type, but they are distinct datatypes. An external
+representation is specified which must be supported by the {{read}} and
+{{write}} procedures and by the program parser (i.e. programs can contain
+references to literal homogeneous vectors).
+
+=== Datatypes
+
+There are 8 datatypes of exact integer homogeneous vectors (which will be
+called integer vectors):
+
+<table>
+<tr><th>Datatype</th><th>Type of elements</th></tr>
+<tr><td>{{s8vector}}</td><td>signed exact integer in the range -(2^7) to (2^7)-1</td></tr>
+<tr><td>{{u8vector}}</td><td>unsigned exact integer in the range 0 to (2^8)-1</td></tr>
+<tr><td>{{s16vector}}</td><td>signed exact integer in the range -(2^15) to (2^15)-1</td></tr>
+<tr><td>{{u16vector}}</td><td>unsigned exact integer in the range 0 to (2^16)-1</td></tr>
+<tr><td>{{s32vector}}</td><td>signed exact integer in the range -(2^31) to (2^31)-1</td></tr>
+<tr><td>{{u32vector}}</td><td>unsigned exact integer in the range 0 to (2^32)-1</td></tr>
+<tr><td>{{s64vector}}</td><td>signed exact integer in the range -(2^31) to (2^31)-1</td></tr>
+<tr><td>{{u64vector}}</td><td>unsigned exact integer in the range 0 to (2^64)-1</td></tr>
+<tr><td>{{s64vector}}</td><td>signed exact integer in the range -(2^63) to (2^63)-1</td></tr>
+<tr><td>{{u64vector}}</td><td>unsigned exact integer in the range 0 to (2^64)-1</td></tr></table>
+
+There are 2 datatypes of inexact real homogeneous vectors (which will be
+called float vectors):
+
+<table>
+<tr><th>Datatype</th><th>Type of elements</th></tr>
+<tr><td>{{f32vector}}</td><td>inexact real</td></tr>
+<tr><td>{{f64vector}}</td><td>inexact real</td></tr></table>
+
+The only difference between the two float vector types is that
+{{f64vector}}s preserve at least as much precision as {{f32vector}}s.
+
+And there are two datatypes of inexact complex homogeneous vectors (which will be called complex vectors):
+
+<table>
+<tr><th>Datatype</th><th>Type of elements</th></tr>
+<tr><td>{{c64vector}}</th><th>inexact complex, typically 64 bits</td></tr>
+<tr><td>{{c128vector}}</th><th>inexact complex, typically 128 bits</td></tr>
+</table>
+
+Each homogeneous vector datatype has an external representation which
+is supported by the {{read}} and {{write}} procedures and by the program
+parser. Each datatype also has a set of associated predefined procedures
+analogous to those available for Scheme's heterogeneous vectors.
+
+=== External representation
+
+<read>#u8</read><br>
+<read>#u16</read><br>
+<read>#u32</read><br>
+<read>#s8</read><br>
+<read>#s16</read><br>
+<read>#s32</read><br>
+<read>#f32</read><br>
+<read>#f64</read><br>
+<read>#c64</read><br>
+<read>#c128</read><br>
+
+The external representation of instances of the datatype {{XXXvector}}
+is {{#XXX( ...elements... )}}.
+
+For example,
+
+ #u8(0 #e1e2 #xff)}} ; a {{u8vector}} of length 3 containing 0, 100, 255
+ #f64(-1.5) ; a {{f64vector}} of length 1 containing -1.5.
+
+This external representation is also available in program source code. For example,
+
+ (set! x '#u8(1 2 3))
+
+will set {{x}} to the object {{#u8(1 2 3)}}. Since CHICKEN 4.9.0, literal homogeneous vectors do not have to be quoted. Homogeneous vectors can appear in quasiquotations but must not contain {{unquote}} or {{unquote-splicing}} forms. ''I.e.'',
+
+ `(,x #u8(1 2)) ; legal
+ `#u8(1 ,x 2) ; illegal
+
+Elements may also be characters or strings, in that case they are interpreted
+as a sequence of numerical character codes. For example,
+
+ '#u8(#\x7f "EL" #\F 2 1)
+
+is equivalent to
+
+ '#u8(#\x7f #\x45 #\x4c #\x46 2 1)
+
+Character literals inside numeric vectors expand into the UTF-8 sequence of
+the characters they represent, for strings the contained characters
+are interpreted in whatever encoding is used for the text file or stream
+in which the literal appears.
+
+Note that {{#u8"..."}} can be used as an abbreviation for the special case
+{{#u8("...")}}.
+
+=== Predicates
+
+<procedure>(u8vector? OBJ)</procedure><br>
+<procedure>(s8vector? OBJ)</procedure><br>
+<procedure>(u16vector? OBJ)</procedure><br>
+<procedure>(s16vector? OBJ)</procedure><br>
+<procedure>(u32vector? OBJ)</procedure><br>
+<procedure>(s32vector? OBJ)</procedure><br>
+<procedure>(u64vector? OBJ)</procedure><br>
+<procedure>(s64vector? OBJ)</procedure><br>
+<procedure>(f32vector? OBJ)</procedure><br>
+<procedure>(f64vector? OBJ)</procedure><br>
+<procedure>(c64vector? OBJ)</procedure><br>
+<procedure>(c128vector? OBJ)</procedure><br>
+
+Return {{#t}} if {{obj}} is an object of the specified type or {{#f}} if not.
+
+<procedure>(number-vector? OBJ)</procedure>
+
+Return {{#t}} if {{obj}} is a number vector, {{#f}} if not. A "number vector" is any of the homogeneous number vector types defined by SRFI-4, ie it's one of {{u8vector}}, {{s8vector}}, {{u16vector}}, {{s16vector}}, {{u32vector}}, {{s32vector}}, {{u64vector}}, {{s64vector}}, {{f32vector}}, {{f64vector}}, {{c64vector}} or {{c128vector}}.
+
+
+=== Constructors
+
+<procedure>(make-u8vector N [U8VALUE NONGC FINALIZE])</procedure><br>
+<procedure>(make-s8vector N [S8VALUE NONGC FINALIZE])</procedure><br>
+<procedure>(make-u16vector N [U16VALUE NONGC FINALIZE])</procedure><br>
+<procedure>(make-s16vector N [S16VALUE NONGC FINALIZE])</procedure><br>
+<procedure>(make-u32vector N [U32VALUE NONGC FINALIZE])</procedure><br>
+<procedure>(make-s32vector N [S32VALUE NONGC FINALIZE])</procedure><br>
+<procedure>(make-u64vector N [U64VALUE NONGC FINALIZE])</procedure><br>
+<procedure>(make-s64vector N [S64VALUE NONGC FINALIZE])</procedure><br>
+<procedure>(make-f32vector N [F32VALUE NONGC FINALIZE])</procedure><br>
+<procedure>(make-f64vector N [F64VALUE NONGC FINALIZE])</procedure><br>
+<procedure>(make-c64vector N [C64VALUE NONGC FINALIZE])</procedure><br>
+<procedure>(make-c128vector N [C128VALUE NONGC FINALIZE])</procedure><br>
+
+Return a newly-allocated SRFI-4 homogeneous number vector of length N.
+
+If the optional fill VALUE is specified, it specifies the initial
+value for each slot in the vector. If not, the content of the vector
+is unspecified but individual elements of the vector are guaranteed to
+be in the range of values permitted for that type of vector.
+
+The type of the fill value must be compatible with the elements of the
+vector datatype. It is an error if otherwise -- for example, if an
+inexact integer is passed to {{make-u8vector}}.
+
+On CHICKEN, these procedures have been extended to allow allocating
+the storage in non-garbage collected memory, as follows:
+
+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.
+
+<procedure>(u8vector U8VALUE ...)</procedure><br>
+<procedure>(s8vector S8VALUE ...)</procedure><br>
+<procedure>(u16vector U16VALUE ...)</procedure><br>
+<procedure>(s16vector S16VALUE ...)</procedure><br>
+<procedure>(u32vector U32VALUE ...)</procedure><br>
+<procedure>(s32vector S32VALUE ...)</procedure><br>
+<procedure>(u64vector U64VALUE ...)</procedure><br>
+<procedure>(s64vector S64VALUE ...)</procedure><br>
+<procedure>(f32vector F32VALUE ...)</procedure><br>
+<procedure>(f64vector F64VALUE ...)</procedure><br>
+<procedure>(c64vector C64VALUE ...)</procedure><br>
+<procedure>(c128vector C128VALUE ...)</procedure><br>
+
+Return a newly-allocated SRFI-4 homogeneous number vector of the specified
+type, composed of the arguments.
+
+=== Length
+
+<procedure>(u8vector-length U8VECTOR)</procedure><br>
+<procedure>(s8vector-length S8VECTOR)</procedure><br>
+<procedure>(u16vector-length U16VECTOR)</procedure><br>
+<procedure>(s16vector-length S16VECTOR)</procedure><br>
+<procedure>(u32vector-length U32VECTOR)</procedure><br>
+<procedure>(s32vector-length S32VECTOR)</procedure><br>
+<procedure>(u64vector-length U64VECTOR)</procedure><br>
+<procedure>(s64vector-length S64VECTOR)</procedure><br>
+<procedure>(f32vector-length F32VECTOR)</procedure><br>
+<procedure>(f64vector-length F64VECTOR)</procedure><br>
+<procedure>(c64vector-length C64VECTOR)</procedure><br>
+<procedure>(c128vector-length C128VECTOR)</procedure><br>
+
+Returns the length of the SRFI-4 homogeneous number VECTOR.
+
+=== Getters
+
+<procedure>(u8vector-ref U8VECTOR I)</procedure><br>
+<procedure>(s8vector-ref S8VECTOR i)</procedure><br>
+<procedure>(u16vector-ref U16VECTOR I)</procedure><br>
+<procedure>(s16vector-ref S16VECTOR I)</procedure><br>
+<procedure>(u32vector-ref U32VECTOR I)</procedure><br>
+<procedure>(s32vector-ref S32VECTOR I)</procedure><br>
+<procedure>(u64vector-ref U64VECTOR I)</procedure><br>
+<procedure>(s64vector-ref S64VECTOR I)</procedure><br>
+<procedure>(f32vector-ref F32VECTOR I)</procedure><br>
+<procedure>(f64vector-ref F64VECTOR I)</procedure><br>
+<procedure>(c64vector-ref C64VECTOR I)</procedure><br>
+<procedure>(c128vector-ref C128VECTOR I)</procedure><br>
+
+Return the value of the ''i''th element of the SRFI-4 homogeneous
+number vector, where {{I}} is a nonnegative exact integer less
+than the length of the vector.
+
+=== Setters
+
+<procedure>(u8vector-set! U8VECTOR I U8VALUE)</procedure><br>
+<procedure>(s8vector-set! S8VECTOR I S8VALUE)</procedure><br>
+<procedure>(u16vector-set! U16VECTOR I U16VALUE)</procedure><br>
+<procedure>(s16vector-set! S16VECTOR I S16VALUE)</procedure><br>
+<procedure>(u32vector-set! U32VECTOR I U32VALUE)</procedure><br>
+<procedure>(s32vector-set! S32VECTOR I S32VALUE)</procedure><br>
+<procedure>(u64vector-set! U64VECTOR I U64VALUE)</procedure><br>
+<procedure>(s64vector-set! S64VECTOR I S64VALUE)</procedure><br>
+<procedure>(f32vector-set! F32VECTOR I F32VALUE)</procedure><br>
+<procedure>(f64vector-set! F64VECTOR I F64VALUE)</procedure><br>
+<procedure>(c64vector-set! C64VECTOR I C64VALUE)</procedure><br>
+<procedure>(c128vector-set! C128VECTOR I C128VALUE)</procedure><br>
+
+Set the {{i}}th element of the SRFI-4 homogeneous number VECTOR to
+VALUE. {{I}} is a nonnegative exact integer less than the length of
+the vector and VALUE must be the same type as the elements of the
+vector datatype.
+
+Additionally, SRFI-17 setters are defined on all {{xxxvector-ref}}
+procedures. For example, to set the {{i}}th element of SRFI-4
+{{u8vector}} to {{u8value}}:
+
+ (set! (u8vector-ref u8vector i) u8value)
+
+=== Conversions
+
+<procedure>(u8vector->list U8VECTOR)</procedure><br>
+<procedure>(s8vector->list S8VECTOR)</procedure><br>
+<procedure>(u16vector->list U16VECTOR)</procedure><br>
+<procedure>(s16vector->list S16VECTOR)</procedure><br>
+<procedure>(u32vector->list U32VECTOR)</procedure><br>
+<procedure>(s32vector->list S32VECTOR)</procedure><br>
+<procedure>(u64vector->list U64VECTOR)</procedure><br>
+<procedure>(s64vector->list S64VECTOR)</procedure><br>
+<procedure>(f32vector->list F32VECTOR)</procedure><br>
+<procedure>(f64vector->list F64VECTOR)</procedure><br>
+<procedure>(c64vector->list C64VECTOR)</procedure><br>
+<procedure>(c128vector->list C128VECTOR)</procedure><br>
+
+Return a list consisting of the elements of SRFI-4 homogeneous number
+VECTOR.
+
+<procedure>(list->u8vector U8LIST)</procedure><br>
+<procedure>(list->s8vector S8LIST)</procedure><br>
+<procedure>(list->u16vector U16LIST)</procedure><br>
+<procedure>(list->s16vector S16LIST)</procedure><br>
+<procedure>(list->u32vector U32LIST)</procedure><br>
+<procedure>(list->s32vector S32LIST)</procedure><br>
+<procedure>(list->u64vector U64LIST)</procedure><br>
+<procedure>(list->s64vector S64LIST)</procedure><br>
+<procedure>(list->f32vector F32LIST)</procedure><br>
+<procedure>(list->f64vector F64LIST)</procedure><br>
+<procedure>(list->c64vector C64LIST)</procedure><br>
+<procedure>(list->c128vector C128LIST)</procedure><br>
+
+Return a newly-allocated SRFI-4 homogeneous number VECTOR consisting
+of the elements of LIST. Each element of LIST must be compatible
+with the datatype of VECTOR.
+
+
+=== Blob conversions
+
+As a number vector is basically just a [[Module (chicken bytevector)|bytevector]]
+wrapped into a record type,
+there are several procedures which can convert between bytevectors and
+number vectors.
+
+Note that built-in bytevectors are identical to u8vectors.
+
+<procedure>(s8vector->bytevector S8VECTOR)</procedure><br>
+<procedure>(u16vector->bytevector U16VECTOR)</procedure><br>
+<procedure>(s16vector->bytevector S16VECTOR)</procedure><br>
+<procedure>(u32vector->bytevector U32VECTOR)</procedure><br>
+<procedure>(s32vector->bytevector S32VECTOR)</procedure><br>
+<procedure>(u64vector->bytevector U64VECTOR)</procedure><br>
+<procedure>(s64vector->bytevector S64VECTOR)</procedure><br>
+<procedure>(f32vector->bytevector F32VECTOR)</procedure><br>
+<procedure>(f64vector->bytevector F64VECTOR)</procedure><br>
+<procedure>(c64vector->bytevector C64VECTOR)</procedure><br>
+<procedure>(c128vector->bytevector C128VECTOR)</procedure><br>
+<procedure>(u8vector->bytevector/shared U8VECTOR)</procedure><br>
+<procedure>(s8vector->bytevector/shared S8VECTOR)</procedure><br>
+<procedure>(u16vector->bytevector/shared U16VECTOR)</procedure><br>
+<procedure>(s16vector->bytevector/shared S16VECTOR)</procedure><br>
+<procedure>(u32vector->bytevector/shared U32VECTOR)</procedure><br>
+<procedure>(s32vector->bytevector/shared S32VECTOR)</procedure><br>
+<procedure>(u64vector->bytevector/shared U64VECTOR)</procedure><br>
+<procedure>(s64vector->bytevector/shared S64VECTOR)</procedure><br>
+<procedure>(f32vector->bytevector/shared F32VECTOR)</procedure><br>
+<procedure>(f64vector->bytevector/shared F64VECTOR)</procedure><br>
+<procedure>(c64vector->bytevector/shared C64VECTOR)</procedure><br>
+<procedure>(c128vector->bytevector/shared C128VECTOR)</procedure><br>
+
+Each of these procedures return the contents of the given vector as a
+'packed' bytevector. The byte order in that vector is platform-dependent
+(for example little-endian on an '''Intel''' processor). The
+{{/shared}} variants return a bytevector that shares memory with the
+contents of the vector, the others will copy the contents of the
+vector's internal bytevector object.
+
+<procedure>(bytevector->s8vector BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->u16vector BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->s16vector BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->u32vector BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->s32vector BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->u64vector BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->s64vector BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->f32vector BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->f64vector BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->c64vector BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->c128vector BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->s8vector/shared BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->u16vector/shared BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->s16vector/shared BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->u32vector/shared BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->s32vector/shared BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->u64vector/shared BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->s64vector/shared BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->f32vector/shared BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->f64vector/shared BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->c64vector/shared BYTEVECTOR)</procedure><br>
+<procedure>(bytevector->c128vector/shared BYTEVECTOR)</procedure><br>
+
+Each of these procedures return a vector where the argument {{BYTEVECTOR}}
+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 bytevector, the others will copy the bytevector.
+
+=== Subvectors
+
+<procedure>(subu8vector U8VECTOR FROM TO)</procedure><br>
+<procedure>(subu16vector U16VECTOR FROM TO)</procedure><br>
+<procedure>(subu32vector U32VECTOR FROM TO)</procedure><br>
+<procedure>(subu64vector U32VECTOR FROM TO)</procedure><br>
+<procedure>(subs8vector S8VECTOR FROM TO)</procedure><br>
+<procedure>(subs16vector S16VECTOR FROM TO)</procedure><br>
+<procedure>(subs32vector S32VECTOR FROM TO)</procedure><br>
+<procedure>(subs64vector S32VECTOR FROM TO)</procedure><br>
+<procedure>(subf32vector F32VECTOR FROM TO)</procedure><br>
+<procedure>(subf64vector F64VECTOR FROM TO)</procedure><br>
+<procedure>(subc64vector C64VECTOR FROM TO)</procedure><br>
+<procedure>(subc128vector C128VECTOR FROM TO)</procedure><br>
+
+Creates a fresh number vector of the same type as the argument vector
+with the elements at the positions {{FROM}} up to but not including
+{{TO}}.
+
+=== Release number vectors allocated in static memory
+
+<procedure>(release-number-vector NVECTOR)</procedure>
+
+Release the storage of a SRFI-4 vector that was allocated in
+non-garbage collected memory (for example using the {{NONGC}} argument
+for one of the {{make-XXXvector}} constructor procedures). The effect
+of calling this procedure with a number vector allocated in normal
+garbage collected memory is undefined.
+
+
+---
+Previous: [[Module (chicken type)]]
+
+Next: [[Interface to external functions and variables]]
+
diff --git a/manual/Module (chicken pathname) b/manual/Module (chicken pathname)
index 59b70bdd..13b3e2e2 100644
--- a/manual/Module (chicken pathname)
+++ b/manual/Module (chicken pathname)
@@ -113,6 +113,6 @@ uses a 16-bit UNICODE encoding with special system calls for
wide-character support. Only single-byte string encoding can be used.
---
-Previous: [[Module (chicken module)]]
+Previous: [[Module (chicken number-vector)]]
Next: [[Module (chicken platform)]]
diff --git a/manual/Module (chicken platform) b/manual/Module (chicken platform)
index 134132c6..e2c9f6b3 100644
--- a/manual/Module (chicken platform)
+++ b/manual/Module (chicken platform)
@@ -19,7 +19,7 @@ Returns a symbol specifying the toolset which has been used for
building the executing system, which is one of the following:
cygwin
- mingw32
+ mingw
gnu
intel
clang
@@ -36,13 +36,11 @@ a full version string is returned.
==== include-path
-<procedure>(include-path)</procedure>
+<procedure>(include-path [PATHLIST])</procedure>
-Returns a list of strings representing directory names where included files are located,
-which defaults to the value of the environment variable
-{{CHICKEN_INCLUDE_PATH}}, split on {{:}} (or {{;}} on Windows).
-If the variable is not set, the list is initialized to contain the installation directory
-(usually {{/usr/local/share/chicken}} on UNIX-like systems).
+Returns a list of directory names where {{include}} and {{include-ci}} locate
+files to be included. If {{PATHLIST}} is given, the current include path
+is changed to that value, which must be a list of strings.
==== repository-path
@@ -173,14 +171,6 @@ 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>
diff --git a/manual/Module (chicken port) b/manual/Module (chicken port)
index 0dcab42d..84de15ce 100644
--- a/manual/Module (chicken port)
+++ b/manual/Module (chicken port)
@@ -15,6 +15,17 @@ of kind {{exn}}.
=== Port attributes
+==== port-encoding
+
+<procedure>(port-encoding PORT)</procedure>
+
+Returns the encoding used for reading and writing data from and to
+the given port. Encoding is currently one of the symbols {{utf-8}},
+{{latin-1}} or {{binary}}. Note that the encoding can be changed by using
+the (SRFI-17) setter procedure for this operation:
+
+{{(set! (port-encoding PORT) ENCODING)}}
+
==== port-name
<procedure>(port-name [PORT])</procedure>
@@ -23,24 +34,22 @@ 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)}}.
+Note that the encoding can be changed by using
+the (SRFI-17) setter procedure for this operation:
+
+{{(set! (port-name PORT) STRING)}}
+
==== port-position
<procedure>(port-position [PORT])</procedure>
-Returns the current position of {{PORT}} as two values: row and column number.
+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}}.
-
-
=== Setting the file buffering mode
==== set-buffering-mode!
@@ -94,7 +103,7 @@ bound to {{PORT}}.
==== make-input-port
-<procedure>(make-input-port READ-CHAR CHAR-READY? CLOSE [PEEK-CHAR [READ-STRING! [READ-LINE]]])</procedure>
+<procedure>(make-input-port READ-CHAR CHAR-READY? CLOSE #!key peek-char read-bytevector read-line)</procedure>
Returns a custom input port. Common operations on this port are
handled by the given parameters, which should be procedures of no
@@ -107,15 +116,15 @@ to be read and it should return a character or {{#!eof}}.
* {{CHAR-READY?}} is a thunk which is called when {{char-ready?}}
is called on this port and should return {{#t}} or {{#f}}.
* {{CLOSE}} is a thunk which is called when the port is closed.
-* {{PEEK-CHAR}} is a thunk which is called when {{peek-char}} is
+* {{peek-char}} is a thunk which is called when {{peek-char}} is
called on this port and should return a character or {{#!eof}}. If it
is not provided or {{#f}}, {{READ-CHAR}} will be used instead and the
created port object handles peeking automatically (by calling {{READ}}
and buffering the character).
-* {{READ-STRING!}} is called when {{read-string!}} is called (or the
-higher-level non-mutating {{read-string}}). It will be invoked with 4
+* {{read-bytevector}} is called when {{read-bytevector}} or {{read-string!}} is called (or the
+higher-level non-mutating {{read-string}} and {{read-bytevector}}). It will be invoked with 4
arguments: the port created by {{make-input-port}}, the number of
-bytes to read, a string (or sometimes a blob) to read into (which may be
+bytes to read, a bytevector to read into (which may be
assumed to be big enough to hold the data) and the offset into the
buffer at which to put the data to read. It should return the number
of bytes that have successfully been read, which should always be
@@ -135,16 +144,20 @@ number (ie, the line) and slot 5 is the column number (ie, the
character on the line). If the port's positions are not updated,
{{port-position}} won't work.
+Note that reading binary input from a custom input is only possible
+when the {{read-bytevector}} operation is given, as byte-input can
+currently not ben synthesized from character-input operations.
+
==== make-output-port
-<procedure>(make-output-port WRITE CLOSE [FLUSH])</procedure>
+<procedure>(make-output-port WRITE CLOSE #!key force-output)</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
+be a procedure of no arguments. {{force-output}} (if provided) is called
for flushing the output port.
diff --git a/manual/Module (chicken process) b/manual/Module (chicken process)
index 3105798a..bcb433c1 100644
--- a/manual/Module (chicken process)
+++ b/manual/Module (chicken process)
@@ -147,7 +147,7 @@ if a signal occurred.
==== process
<procedure>(process COMMANDLINE)</procedure><br>
-<procedure>(process COMMAND ARGUMENT-LIST [ENVIRONMENT-ALIST])</procedure>
+<procedure>(process COMMAND ARGUMENT-LIST [ENVIRONMENT-ALIST ENCODING])</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
@@ -165,6 +165,11 @@ 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-ALIST}}. These arguments have the same form as the ones of {{process-execute}}.
+{{ENCODING}} should be a symbol specifying the encoding to be
+used for I/O operations, the default is {{utf-8}}. The encodings for
+the returned in and output ports can be subsequently changed by
+using the {{port-encoding}} setter.
+
Not using the shell may be preferrable for security reasons.
Once both the input- and output ports are closed, an implicit
@@ -175,7 +180,7 @@ waiting for it will necessarily block all executing threads.
==== process*
<procedure>(process* COMMANDLINE)</procedure><br>
-<procedure>(process* COMMAND ARGUMENT-LIST [ENVIRONMENT-ALIST])</procedure>
+<procedure>(process* COMMAND ARGUMENT-LIST [ENVIRONMENT-ALIST ENCODING])</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
diff --git a/manual/Module (chicken random) b/manual/Module (chicken random)
index 1fe3c316..a5994782 100644
--- a/manual/Module (chicken random)
+++ b/manual/Module (chicken random)
@@ -18,7 +18,7 @@ The pseudo random number generator is an implementation of the
<procedure>(set-pseudo-random-seed! SEED [SIZE])</procedure>
Set seed for the PRNG from the at most {{SIZE}} bytes of {{SEED}}.
-which should be a byte vector or a string containing random data.
+which should be a bytevector containing random data.
If {{SIZE}} is not given, it defaults to the size of {{SEED}}. If {{SIZE}}
(or the size of {{SEED}}) is below the required size of the random
state used by the PRNG, then it will necessarily be initialized in a less
diff --git a/manual/Module (chicken syntax) b/manual/Module (chicken syntax)
index d551818c..1f1e44a4 100644
--- a/manual/Module (chicken syntax)
+++ b/manual/Module (chicken syntax)
@@ -14,7 +14,7 @@ context to register a procedure that can transform s-expressions into
other s-expressions. Only use these when you need to break hygiene in
a controlled way; for many use cases {{syntax-rules}} is more
appropriate, as it offers stronger guarantees of hygiene, is more
-high-level and is standard R5RS Scheme.
+high-level and is standard R7RS Scheme.
For those situations where you need more control, however, CHICKEN
supports two kinds of low-level macros: so-called explicit renaming
@@ -185,7 +185,7 @@ This procedure 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 (see the section "Explicit
-renaming macros" below for a detailed explanation on non-R5RS macros).
+renaming macros" below for a detailed explanation on non-R7RS macros).
Implementation note: this procedure currently just returns its
argument unchanged and is available for writing low-level macros in a
@@ -378,14 +378,6 @@ information is available for this expression, then this procedure
returns the associated source file and line number as a string. If
line-number information is not available, then {{#f}} is returned.
-==== syntax-error
-
-<procedure>(syntax-error [LOCATION] MESSAGE ARGUMENT ...)</procedure>
-
-Signals an exception of the kind {{(exn syntax)}}. Otherwise identical
-to {{error}}.
-
-
=== Compiler macros
==== define-compiler-syntax
diff --git a/manual/Module (chicken tcp) b/manual/Module (chicken tcp)
index 60c993ca..26661a8e 100644
--- a/manual/Module (chicken tcp)
+++ b/manual/Module (chicken tcp)
@@ -36,7 +36,7 @@ Reclaims any resources associated with {{LISTENER}}.
=== tcp-accept
-<procedure>(tcp-accept LISTENER)</procedure>
+<procedure>(tcp-accept LISTENER [ENCODING])</procedure>
Waits until a connection is established on the port on which
{{LISTENER}} is listening and returns two values: an input- and
@@ -50,6 +50,11 @@ and {{tcp-write-timeout}}, respectively, to determine the maximal
number of milliseconds to wait for input/output before a timeout
error is signalled.
+{{ENCODING}} should be a symbol specifying the encoding to be
+used for I/O operations, the default is {{utf-8}}. The encodings for
+the returned in and output ports can be subsequently changed by
+using the {{port-encoding}} setter.
+
Note: this operation and any I/O on the ports returned will not block
other running threads.
@@ -78,7 +83,7 @@ Returns the file-descriptor associated with {{LISTENER}}.
=== tcp-connect
-<procedure>(tcp-connect HOSTNAME [TCPPORT])</procedure>
+<procedure>(tcp-connect HOSTNAME [TCPPORT ENCODING])</procedure>
Establishes a client-side TCP connection to the machine with the name
{{HOSTNAME}} (a string) at {{TCPPORT}} (an exact integer) and returns
@@ -94,6 +99,11 @@ 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}}]].
+{{ENCODING}} should be a symbol specifying the encoding to be
+used for I/O operations, the default is {{utf-8}}. The encodings for
+the returned in and output ports can be subsequently changed by
+using the {{port-encoding}} setter.
+
Note: any I/O on the ports returned will not block other running threads.
diff --git a/manual/Module (chicken type) b/manual/Module (chicken type)
index 30fcd2bd..9673dde7 100644
--- a/manual/Module (chicken type)
+++ b/manual/Module (chicken type)
@@ -9,4 +9,4 @@ The functionality in this module is available by default. See
---
Previous: [[Module (chicken time posix)]]
-Next: [[Interface to external functions and variables]]
+Next: [[Module srfi-4]]
diff --git a/manual/Module (scheme base) b/manual/Module (scheme base)
new file mode 100644
index 00000000..b706ceb8
--- /dev/null
+++ b/manual/Module (scheme base)
@@ -0,0 +1,4347 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module scheme
+
+This module provides all of CHICKEN's R7RS procedures and macros.
+These descriptions are based directly on the ''Revised^7 Report on the
+Algorithmic Language Scheme''.
+
+== Expressions
+
+Expression types are categorized as primitive or derived. Primitive
+expression types include variables and procedure calls. Derived
+expression types are not semantically primitive, but can instead be
+defined as macros. The distinction which R7RS makes between primitive
+and derived is unimportant and does not necessarily reflect how it is
+implemented in CHICKEN itself.
+
+=== Primitive expression types
+
+==== Variable references
+
+<macro><variable></macro><br>
+
+An expression consisting of a variable is a variable reference. The
+value of the variable reference is the value stored in the location to
+which the variable is bound. It is an error to reference an unbound
+variable.
+
+ (define x 28)
+ x ===> 28
+
+==== Literal expressions
+
+<macro>(quote <datum>)</macro><br>
+<macro>'<datum></macro><br>
+<macro><constant></macro><br>
+
+(quote <datum>) evaluates to <datum>. <Datum> may be any external
+representation of a Scheme object. This notation is used to include
+literal constants in Scheme code.
+
+ (quote a) ===> a
+ (quote #(a b c)) ===> #(a b c)
+ (quote (+ 1 2)) ===> (+ 1 2)
+
+(quote <datum>) may be abbreviated as '<datum>. The two notations are
+equivalent in all respects.
+
+ 'a ===> a
+ '#(a b c) ===> #(a b c)
+ '() ===> ()
+ '(+ 1 2) ===> (+ 1 2)
+ '(quote a) ===> (quote a)
+ ''a ===> (quote a)
+
+Numerical constants, string constants, character constants, and boolean
+constants evaluate "to themselves"; they need not be quoted.
+
+ '"abc" ===> "abc"
+ "abc" ===> "abc"
+ '145932 ===> 145932
+ 145932 ===> 145932
+ '#t ===> #t
+ #t ===> #t
+ '#(a 10) ===> #(a 10)
+ #(a 10) ===> #(a 10)
+ '#u8(64 65) ===> #u8(64 65)
+ #u8(64 65) ===> #u8(64 65)
+
+It is an error to alter a constant (i.e. the value of a literal
+expression) using a mutation procedure like set-car! or string-set!.
+In the current implementation of CHICKEN, identical constants don't
+share memory and it is possible to mutate them, but this may change in
+the future.
+
+==== Procedure calls
+
+<macro>(<operator> <operand[1]> ...)</macro><br>
+
+A procedure call is written by simply enclosing in parentheses
+expressions for the procedure to be called and the arguments to be
+passed to it. The operator and operand expressions are evaluated (in an
+unspecified order) and the resulting procedure is passed the resulting
+arguments.
+
+ (+ 3 4) ===> 7
+ ((if #f + *) 3 4) ===> 12
+
+A number of procedures are available as the values of variables in the
+initial environment; for example, the addition and multiplication
+procedures in the above examples are the values of the variables + and
+*. New procedures are created by evaluating lambda
+expressions. Procedure calls may return any number of values (see the
+{{values}} procedure [[#control-features|below]]).
+
+Procedure calls are also called combinations.
+
+Note: In contrast to other dialects of Lisp, the order of
+evaluation is unspecified, and the operator expression and the
+operand expressions are always evaluated with the same evaluation
+rules.
+
+Note: Although the order of evaluation is otherwise unspecified,
+the effect of any concurrent evaluation of the operator and operand
+expressions is constrained to be consistent with some sequential
+order of evaluation. The order of evaluation may be chosen
+differently for each procedure call.
+
+Note: In many dialects of Lisp, the empty combination, (), is a
+legitimate expression. In Scheme, combinations must have at least
+one subexpression, so () is not a syntactically valid expression.
+
+==== Procedures
+
+<macro>(lambda <formals> <body>)</macro><br>
+
+Syntax: <Formals> should be a formal arguments list as described below,
+and <body> should be a sequence of one or more expressions.
+
+Semantics: A lambda expression evaluates to a procedure. The
+environment in effect when the lambda expression was evaluated is
+remembered as part of the procedure. When the procedure is later called
+with some actual arguments, the environment in which the lambda
+expression was evaluated will be extended by binding the variables in
+the formal argument list to fresh locations, the corresponding actual
+argument values will be stored in those locations, and the expressions
+in the body of the lambda expression will be evaluated sequentially in
+the extended environment. The result(s) of the last expression in the
+body will be returned as the result(s) of the procedure call.
+
+ (lambda (x) (+ x x)) ===> a procedure
+ ((lambda (x) (+ x x)) 4) ===> 8
+
+ (define reverse-subtract
+ (lambda (x y) (- y x)))
+ (reverse-subtract 7 10) ===> 3
+
+ (define add4
+ (let ((x 4))
+ (lambda (y) (+ x y))))
+ (add4 6) ===> 10
+
+<Formals> should have one of the following forms:
+
+* (<variable[1]> ...): The procedure takes a fixed number of
+ arguments; when the procedure is called, the arguments will be
+ stored in the bindings of the corresponding variables.
+
+* <variable>: The procedure takes any number of arguments; when the
+ procedure is called, the sequence of actual arguments is converted
+ into a newly allocated list, and the list is stored in the binding
+ of the <variable>.
+
+* (<variable[1]> ... <variable[n]> . <variable[n+1]>): If a
+ space-delimited period precedes the last variable, then the
+ procedure takes n or more arguments, where n is the number of
+ formal arguments before the period (there must be at least one).
+ The value stored in the binding of the last variable will be a
+ newly allocated list of the actual arguments left over after all
+ the other actual arguments have been matched up against the other
+ formal arguments.
+
+It is an error for a <variable> to appear more than once in <formals>.
+
+ ((lambda x x) 3 4 5 6) ===> (3 4 5 6)
+ ((lambda (x y . z) z)
+ 3 4 5 6) ===> (5 6)
+
+Each procedure created as the result of evaluating a lambda expression
+is (conceptually) tagged with a storage location, in order to make eqv?
+and eq? work on procedures.
+
+As an extension to R7RS, CHICKEN also supports "extended" DSSSL style
+parameter lists, which allows embedded special keywords. Such a
+keyword gives a special meaning to the {{<formal>}} it precedes.
+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)
+
+
+
+==== Conditionals
+
+<macro>(if <test> <consequent> <alternate>)</macro><br>
+<macro>(if <test> <consequent>)</macro><br>
+
+Syntax: <Test>, <consequent>, and <alternate> may be arbitrary
+expressions.
+
+Semantics: An if expression is evaluated as follows: first, <test> is
+evaluated. If it yields a true value (see [[#Booleans|the section
+about booleans]] below), then <consequent> is evaluated and its
+value(s) is(are) returned. Otherwise <alternate> is evaluated and its
+value(s) is(are) returned. If <test> yields a false value and no
+<alternate> is specified, then the result of the expression is
+unspecified.
+
+ (if (> 3 2) 'yes 'no) ===> yes
+ (if (> 2 3) 'yes 'no) ===> no
+ (if (> 3 2)
+ (- 3 2)
+ (+ 3 2)) ===> 1
+
+==== Assignments
+
+<macro>(set! <variable> <expression>)</macro><br>
+
+<Expression> is evaluated, and the resulting value is stored in the
+location to which <variable> is bound. <Variable> must be bound either
+in some region enclosing the set! expression or at top level. The
+result of the set! expression is unspecified.
+
+ (define x 2)
+ (+ x 1) ===> 3
+ (set! x 4) ===> unspecified
+ (+ x 1) ===> 5
+
+As an extension to R7RS, {{set!}} for unbound toplevel variables is
+allowed. Also, {{(set! (PROCEDURE ...) ...)}} is supported, as CHICKEN
+implements [[http://srfi.schemers.org/srfi-17/srfi-17.html|SRFI-17]].
+
+==== Inclusion
+
+<macro>(include STRING1 STRING2 ...)</macro>
+<macro>(include-ci STRING1 STRING2 ...)</macro>
+
+Semantics: Both {{include}} and {{include-ci}} take one or
+more filenames expressed as string literals, apply an
+implementation-specific algorithm to find corresponding
+files, read the contents of the files in the specified order
+as if by repeated applications of {{read}}, and effectively replace the {{include}}
+or {{include-ci}} expression with a {{begin}}
+expression containing what was read from the files. The
+difference between the two is that {{include-ci}} reads each
+file as if it began with the {{#!fold-case}} directive, while
+{{include}} does not.
+
+
+=== Derived expression types
+
+The constructs in this section are hygienic. For reference purposes,
+these macro definitions will convert most of the constructs described
+in this section into the primitive constructs described in the
+previous section. This does not necessarily mean that's exactly how
+it's implemented in CHICKEN.
+
+==== Conditionals
+
+<macro>(cond <clause[1]> <clause[2]> ...)</macro><br>
+
+Syntax: Each <clause> should be of the form
+
+ (<test> <expression[1]> ...)
+
+where <test> is any expression. Alternatively, a <clause> may be of the
+form
+
+ (<test> => <expression>)
+
+The last <clause> may be an "else clause," which has the form
+
+ (else <expression[1]> <expression[2]> ...).
+
+Semantics: A cond expression is evaluated by evaluating the <test>
+expressions of successive <clause>s in order until one of them
+evaluates to a true value (see [[#Booleans|the section about
+booleans]] below). When a <test> evaluates to a true value, then the
+remaining <expression>s in its <clause> are evaluated in order, and
+the result(s) of the last <expression> in the <clause> is(are)
+returned as the result(s) of the entire cond expression. If the
+selected <clause> contains only the <test> and no <expression>s, then
+the value of the <test> is returned as the result. If the selected
+<clause> uses the => alternate form, then the <expression> is
+evaluated. Its value must be a procedure that accepts one argument;
+this procedure is then called on the value of the <test> and the
+value(s) returned by this procedure is(are) returned by the cond
+expression. If all <test>s evaluate to false values, and there is no
+else clause, then the result of the conditional expression is
+unspecified; if there is an else clause, then its <expression>s are
+evaluated, and the value(s) of the last one is(are) returned.
+
+ (cond ((> 3 2) 'greater)
+ ((< 3 2) 'less)) ===> greater
+ (cond ((> 3 3) 'greater)
+ ((< 3 3) 'less)
+ (else 'equal)) ===> equal
+ (cond ((assv 'b '((a 1) (b 2))) => cadr)
+ (else #f)) ===> 2
+
+
+As an extension to R7RS, CHICKEN also supports the
+[[http://srfi.schemers.org/srfi-61|SRFI-61]] syntax:
+
+ (<generator> <guard> => <expression>)
+
+In this situation, {{generator}} is ''always'' evaluated. Its
+resulting value(s) are used as argument(s) for the {{guard}}
+procedure. Finally, if {{guard}} returns a non-{{#f}} value, the
+{{expression}} is evaluated by calling it with the result of
+{{guard}}. Otherwise, evaluation procedes to the next clause.
+
+<macro>(case <key> <clause[1]> <clause[2]> ...)</macro><br>
+
+Syntax: <Key> may be any expression. Each <clause> should have the form
+
+ ((<datum[1]> ...) <expression[1]> <expression[2]> ...),
+
+where each <datum> is an external representation of some object.
+Alternatively, as per R7RS, a <clause> may be of the form
+
+ ((<datum[1]> ...) => <expression>).
+
+All the <datum>s must be distinct. The last <clause> may be an
+"else clause," which has one of the following two forms:
+
+ (else <expression[1]> <expression[2]> ...)
+ (else => <expression>).
+
+Semantics: A case expression is evaluated as follows. <Key> is
+evaluated and its result is compared against each <datum>. If the
+result of evaluating <key> is equivalent (in the sense of {{eqv?}};
+see [[#equivalence-predicates|below]]) to a <datum>, then the
+expressions in the corresponding <clause> are evaluated from left to
+right and the result(s) of the last expression in the <clause> is(are)
+returned as the result(s) of the case expression. If the selected
+<clause> uses the => alternate form (an R7RS extension), then the
+<expression> is evaluated. Its value must be a procedure that accepts
+one argument; this procedure is then called on the value of the <key>
+and the value(s) returned by this procedure is(are) returned by the
+case expression. If the result of evaluating <key> is different from
+every <datum>, then if there is an else clause its expressions are
+evaluated and the result(s) of the last is(are) the result(s) of the
+case expression; otherwise the result of the case expression is
+unspecified.
+
+ (case (* 2 3)
+ ((2 3 5 7) 'prime)
+ ((1 4 6 8 9) 'composite)) ===> composite
+ (case (car '(c d))
+ ((a) 'a)
+ ((b) 'b)) ===> unspecified
+ (case (car '(c d))
+ ((a e i o u) 'vowel)
+ ((w y) 'semivowel)
+ (else 'consonant)) ===> consonant
+
+<macro>(and <test[1]> ...)</macro><br>
+
+The <test> expressions are evaluated from left to right, and the value
+of the first expression that evaluates to a false value (see
+[[#Booleans|the section about booleans]]) is returned. Any remaining
+expressions are not evaluated. If all the expressions evaluate to true
+values, the value of the last expression is returned. If there are no
+expressions then #t is returned.
+
+ (and (= 2 2) (> 2 1)) ===> #t
+ (and (= 2 2) (< 2 1)) ===> #f
+ (and 1 2 'c '(f g)) ===> (f g)
+ (and) ===> #t
+
+<macro>(or <test[1]> ...)</macro><br>
+
+The <test> expressions are evaluated from left to right, and the value
+of the first expression that evaluates to a true value (see
+[[#Booleans|the section about booleans]]) is returned. Any remaining
+expressions are not evaluated. If all expressions evaluate to false
+values, the value of the last expression is returned. If there are no
+expressions then #f is returned.
+
+ (or (= 2 2) (> 2 1)) ===> #t
+ (or (= 2 2) (< 2 1)) ===> #t
+ (or #f #f #f) ===> #f
+ (or (memq 'b '(a b c))
+ (/ 3 0)) ===> (b c)
+
+<macro>(unless TEST EXP1 EXP2 ...)</macro>
+
+Equivalent to:
+
+<enscript highlight=scheme>
+(if (not TEST) (begin EXP1 EXP2 ...))
+</enscript>
+
+<macro>(when TEST EXP1 EXP2 ...)</macro>
+
+Equivalent to:
+
+<enscript highlight=scheme>
+(if TEST (begin EXP1 EXP2 ...))
+</enscript>
+
+<macro>(cond-expand <ce-clause1> <ce-clause2> ...)</macro>
+
+The {{cond-expand}} expression type provides a way
+to statically expand different expressions depending on the
+implementation. A <ce-clause> takes the following form:
+
+{{
+(<feature requirement> <expression> ...)
+}}
+
+The last clause can be an "else clause," which has the form
+
+{{
+(else <expression> ...)
+}}]
+
+A ⟨feature requirement⟩ takes one of the following forms:
+
+<feature identifier>
+
+{{(library <library name>)}}
+
+{{(and <feature requirement> ...)}}
+
+{{(or <feature requirement> ...)}}
+
+{{(not <feature requirement>)}}
+
+Each implementation maintains a list of
+feature identifiers which are present, as well as a list
+of libraries which can be imported.
+The value of a <feature requirement> is determined by replacing each
+<feature identifier> and {{(library <library name>)}} on the
+implementation’s lists with {{#t}}, and all other feature identifiers and library names with {{#f}}, then evaluating the resulting expression as a Scheme boolean expression under
+the normal interpretation of {{and}}, {{or}}, and {{not}}.
+
+A {{cond-expand}} is then expanded by evaluating the
+<feature requirement>s of successive <ce-clause>s in order
+until one of them returns {{#t}}. When a true clause is found,
+the corresponding <expression>s are expanded to a {{begin}},
+and the remaining clauses are ignored.
+
+If none of the
+<feature requirement>s evaluate to {{#t}}, then if there is an
+{{else}} clause, its <expression>s are included. Otherwise, the
+behavior of the {{cond}}-expand is unspecified. Unlike {{cond}},
+{{cond-expand}} does not depend on the value of any variables.
+
+The following features are built-in and always available by default:
+{{chicken}}, {{srfi-0}}, {{srfi-2}}, {{srfi-6}}, {{srfi-8}}, {{srfi-9}},
+{{srfi-11}}, {{srfi-12}}, {{srfi-15}}, {{srfi-16}}, {{srfi-17}}, {{srfi-23}},
+{{srfi-26}}, {{srfi-28}}, {{srfi-30}}, {{srfi-31}}, {{srfi-39}}, {{srfi-46}},
+{{srfi-55}}, {{srfi-61}}, {{srfi-62}}, {{srfi-87}}, {{srfi-88}}.
+
+There are also situation-specific feature identifiers: {{compiling}} during
+compilation, {{csi}} when running in the interpreter, and {{compiler-extension}}
+when running within the compiler.
+
+The symbols returned by the following procedures from
+[[Module (chicken platform)|(chicken platform)]] are also available
+as feature-identifiers in all situations: {{(machine-byte-order)}},
+{{(machine-type)}}, {{(software-type)}}, {{(software-version)}}. For
+example, the {{machine-type}} class of feature-identifiers include
+{{arm}}, {{alpha}}, {{mips}}, etc.
+
+Platform endianness is indicated by the {{little-endian}} and {{big-endian}}
+features.
+
+In addition the following feature-identifiers may exist: {{cross-chicken}},
+{{dload}}, {{gchooks}}, {{ptables}}, {{case-insensitive}}.
+
+
+==== Binding constructs
+
+The three binding constructs let, let*, and letrec give Scheme a block
+structure, like Algol 60. The syntax of the three constructs is
+identical, but they differ in the regions they establish for their
+variable bindings. In a let expression, the initial values are computed
+before any of the variables become bound; in a let* expression, the
+bindings and evaluations are performed sequentially; while in a letrec
+expression, all the bindings are in effect while their initial values
+are being computed, thus allowing mutually recursive definitions.
+
+<macro>(let <bindings> <body>)</macro><br>
+
+Syntax: <Bindings> should have the form
+
+ ((<variable[1]> <init[1]>) ...),
+
+where each <init> is an expression, and <body> should be a sequence of
+one or more expressions. It is an error for a <variable> to appear more
+than once in the list of variables being bound.
+
+Semantics: The <init>s are evaluated in the current environment (in
+some unspecified order), the <variable>s are bound to fresh locations
+holding the results, the <body> is evaluated in the extended
+environment, and the value(s) of the last expression of <body> is(are)
+returned. Each binding of a <variable> has <body> as its region.
+
+ (let ((x 2) (y 3))
+ (* x y)) ===> 6
+
+ (let ((x 2) (y 3))
+ (let ((x 7)
+ (z (+ x y)))
+ (* z x))) ===> 35
+
+See also "named let", [[#iteration|below]].
+
+<macro>(let* <bindings> <body>)</macro><br>
+
+Syntax: <Bindings> should have the form
+
+ ((<variable[1]> <init[1]>) ...),
+
+and <body> should be a sequence of one or more expressions.
+
+Semantics: Let* is similar to let, but the bindings are performed
+sequentially from left to right, and the region of a binding indicated
+by (<variable> <init>) is that part of the let* expression to the right
+of the binding. Thus the second binding is done in an environment in
+which the first binding is visible, and so on.
+
+ (let ((x 2) (y 3))
+ (let* ((x 7)
+ (z (+ x y)))
+ (* z x))) ===> 70
+
+<macro>(letrec <bindings> <body>)</macro><br>
+
+Syntax: <Bindings> should have the form
+
+ ((<variable[1]> <init[1]>) ...),
+
+and <body> should be a sequence of one or more expressions. It is an
+error for a <variable> to appear more than once in the list of
+variables being bound.
+
+Semantics: The <variable>s are bound to fresh locations holding
+undefined values, the <init>s are evaluated in the resulting
+environment (in some unspecified order), each <variable> is assigned to
+the result of the corresponding <init>, the <body> is evaluated in the
+resulting environment, and the value(s) of the last expression in
+<body> is(are) returned. Each binding of a <variable> has the entire
+letrec expression as its region, making it possible to define mutually
+recursive procedures.
+
+ (letrec ((even?
+ (lambda (n)
+ (if (zero? n)
+ #t
+ (odd? (- n 1)))))
+ (odd?
+ (lambda (n)
+ (if (zero? n)
+ #f
+ (even? (- n 1))))))
+ (even? 88))
+ ===> #t
+
+One restriction on letrec is very important: it must be possible to
+evaluate each <init> without assigning or referring to the value of any
+<variable>. If this restriction is violated, then it is an error. The
+restriction is necessary because Scheme passes arguments by value
+rather than by name. In the most common uses of letrec, all the <init>s
+are lambda expressions and the restriction is satisfied automatically.
+
+<macro>(letrec* <bindings> <body>) </macro>
+
+Syntax: <Bindings> has the form {{((<variable[1]> <init[1]>) ...)}},and
+<body>is a sequence of zero or more
+definitions followed by one or more expressions as described in section 4.1.4.
+It is an error for a <variable> to appear more than once in the list of
+variables being bound.
+
+Semantics: The <variable>s are bound to fresh locations, each <variable> is
+assigned in left-to-right order to the result of evaluating the corresponding
+<init> (interleaving evaluations and assignments), the <body> is evaluated in
+the resulting environment, and the values of the last expression in <body> are
+returned. Despite the left-to-right evaluation and assignment order, each
+binding of a <variable> has the entire letrec* expression as its region, making
+it possible to define mutually recursive procedures.
+
+If it is not possible to evaluate each <init> without assigning or referring to
+the value of the corresponding <variable> or the <variable> of any of the
+bindings that follow it in <bindings>, it is an error. Another restriction is
+that it is an error to invoke the continuation of an <init> more than once.
+
+{{
+;; Returns the arithmetic, geometric, and
+;; harmonic means of a nested list of numbers
+(define (means ton)
+ (letrec*
+ ((mean
+ (lambda (f g)
+ (f (/ (sum g ton) n))))
+ (sum
+ (lambda (g ton)
+ (if (null? ton)
+ (+)
+ (if (number? ton)
+ (g ton)
+ (+ (sum g (car ton))
+ (sum g (cdr ton)))))))
+ (n (sum (lambda (x) 1) ton)))
+ (values (mean values values)
+ (mean exp log)
+ (mean / /))))
+}}
+
+Evaluating {{(means '(3 (1 4)))}} returns three values: 8/3, 2.28942848510666
+(approximately), and 36/19.
+
+<macro>(let-values <mv binding spec> <body>)</macro>
+
+Syntax: <Mv binding spec> has the form {{((<formals[1]> <init[1]>) ...)}},
+where each <init> is an expression, and <body> is
+zero or more definitions followed by a sequence of one or more expressions as
+described in section 4.1.4. It is an error for a variable to appear more than
+once in the set of <formals>.
+
+Semantics: The <init>s are evaluated in the current environment (in some
+unspecified order) as if by invoking call-with-values, and the variables
+occurring in the <formals> are bound to fresh locations holding the values
+returned by the <init>s, where the <formals> are matched to the return values
+in the same way that the <formals> in a lambda expression are matched to the
+arguments in a procedure call. Then, the <body> is evaluated in the extended
+environment, and the values of the last expression of <body> are returned. Each
+binding of a <variable> has <body> as its region.
+
+It is an error if the <formals> do not match the number of values returned by
+the corresponding <init>.
+
+{{
+(let-values (((root rem) (exact-integer-sqrt 32)))
+ (* root rem)) ==> 35
+}}
+
+<macro>(let*-values <mv binding spec> <body>)</macro>
+
+Syntax: <Mv binding spec> has the form {{((<formals> <init>) ...)}},
+and <body> is a sequence of zero or more definitions
+followed by one or more expressions as described in section 4.1.4. In each
+<formals>, it is an error if any variable appears more than once.
+
+Semantics: The let*-values construct is similar to let-values, but the <init>s
+are evaluated and bindings created sequentially from left to right, with the
+region of the bindings of each <formals> including the <init>s to its right as
+well as <body>. Thus the second <init> is evaluated in an environment in which
+the first set of bindings is visible and initialized, and so on.
+
+{{
+(let ((a 'a) (b 'b) (x 'x) (y 'y))
+ (let*-values (((a b) (values x y))
+ ((x y) (values a b)))
+ (list a b x y))) ⟹ (x y x y)
+}}
+
+==== Sequencing
+
+<macro>(begin <expression[1]> <expression[2]> ...)</macro><br>
+
+The <expression>s are evaluated sequentially from left to right, and
+the value(s) of the last <expression> is(are) returned. This expression
+type is used to sequence side effects such as input and output.
+
+ (define x 0)
+
+ (begin (set! x 5)
+ (+ x 1)) ===> 6
+
+ (begin (display "4 plus 1 equals ")
+ (display (+ 4 1))) ===> unspecified
+ and prints 4 plus 1 equals 5
+
+As an extension to R7RS, CHICKEN also allows {{(begin)}} without body
+expressions in any context, not just at toplevel. This simply
+evaluates to the unspecified value.
+
+
+==== Iteration
+
+<macro>(do ((<variable[1]> <init[1]> <step[1]>) ...) (<test> <expression> ...) <command> ...)</macro><br>
+
+Do is an iteration construct. It specifies a set of variables to be
+bound, how they are to be initialized at the start, and how they are to
+be updated on each iteration. When a termination condition is met, the
+loop exits after evaluating the <expression>s.
+
+Do expressions are evaluated as follows: The <init> expressions are
+evaluated (in some unspecified order), the <variable>s are bound to
+fresh locations, the results of the <init> expressions are stored in
+the bindings of the <variable>s, and then the iteration phase begins.
+
+Each iteration begins by evaluating <test>; if the result is false
+(see [[#Booleans|the section about booleans]]), then the <command>
+expressions are evaluated in order for effect, the <step> expressions
+are evaluated in some unspecified order, the <variable>s are bound to
+fresh locations, the results of the <step>s are stored in the bindings
+of the <variable>s, and the next iteration begins.
+
+If <test> evaluates to a true value, then the <expression>s are
+evaluated from left to right and the value(s) of the last <expression>
+is(are) returned. If no <expression>s are present, then the value of
+the do expression is unspecified.
+
+The region of the binding of a <variable> consists of the entire do
+expression except for the <init>s. It is an error for a <variable> to
+appear more than once in the list of do variables.
+
+A <step> may be omitted, in which case the effect is the same as if
+(<variable> <init> <variable>) had been written instead of (<variable>
+<init>).
+
+ (do ((vec (make-vector 5))
+ (i 0 (+ i 1)))
+ ((= i 5) vec)
+ (vector-set! vec i i)) ===> #(0 1 2 3 4)
+
+ (let ((x '(1 3 5 7 9)))
+ (do ((x x (cdr x))
+ (sum 0 (+ sum (car x))))
+ ((null? x) sum))) ===> 25
+
+<macro>(let <variable> <bindings> <body>)</macro><br>
+
+"Named let" is a variant on the syntax of let which provides a more
+general looping construct than do and may also be used to express
+recursions. It has the same syntax and semantics as ordinary let except
+that <variable> is bound within <body> to a procedure whose formal
+arguments are the bound variables and whose body is <body>. Thus the
+execution of <body> may be repeated by invoking the procedure named by
+<variable>.
+
+ (let loop ((numbers '(3 -2 1 6 -5))
+ (nonneg '())
+ (neg '()))
+ (cond ((null? numbers) (list nonneg neg))
+ ((>= (car numbers) 0)
+ (loop (cdr numbers)
+ (cons (car numbers) nonneg)
+ neg))
+ ((< (car numbers) 0)
+ (loop (cdr numbers)
+ nonneg
+ (cons (car numbers) neg)))))
+ ===> ((6 1 3) (-5 -2))
+
+==== Dynamic bindings
+
+The dynamic extent of a procedure call is the time between when it is initiated
+and when it returns. In Scheme, {{call-with-current-continuation}}
+allows reentering a dynamic extent after its procedure call has returned. Thus,
+the dynamic extent of a call might not be a single, continuous time period.
+
+This sections introduces parameter objects, which can be bound to new values
+for the duration of a dynamic extent. The set of all parameter bindings at a
+given time is called the dynamic environment.
+
+<procedure>(make-parameter init [converter])</procedure>
+
+Returns a newly allocated parameter object, which is a procedure that accepts
+zero arguments and returns the value associated with the parameter object.
+Initially, this value is the value of {{(converter init)}}, or of {{init}}
+if the conversion procedure {{converter}} is not specified. The associated value can be temporarily changed
+using {{parameterize}}, which is described below.
+
+The effect of passing arguments to a parameter object is
+implementation-dependent.
+
+<macro>(parameterize ((<param[1]> <value[1]>) ...) <body>)</procedure>
+
+Syntax: Both <param[1]> and <value[1]> are expressions.
+
+It is an error if the value of any <param> expression is not a parameter
+object.
+
+Semantics: A parameterize expression is used to change the values returned by
+specified parameter objects during the evaluation of the body.
+
+The <param> and <value> expressions are evaluated in an unspecified order. The
+<body> is evaluated in a dynamic environment in which calls to the parameters
+return the results of passing the corresponding values to the conversion
+procedure specified when the parameters were created. Then the previous values
+of the parameters are restored without passing them to the conversion
+procedure. The results of the last expression in the <body> are returned as the
+results of the entire parameterize expression.
+
+ Note: If the conversion procedure is not idempotent, the results of
+ (parameterize ((x (x))) ...), which appears to bind the parameter
+
+ x to its current value, might not be what the user expects.
+
+If an implementation supports multiple threads of execution, then parameterize
+must not change the associated values of any parameters in any thread other
+than the current thread and threads created inside <body>.
+
+Parameter objects can be used to specify configurable settings for a
+computation without the need to pass the value to every procedure in the call
+chain explicitly.
+
+{{
+(define radix
+ (make-parameter
+ 10
+ (lambda (x)
+ (if (and (exact-integer? x) (<= 2 x 16))
+ x
+ (error "invalid radix")))))
+
+(define (f n) (number->string n (radix)))
+
+(f 12) ==> "12"
+(parameterize ((radix 2))
+ (f 12)) ==> "1100"
+(f 12) ==> "12"
+
+(radix 16) ==> unspecified
+
+(parameterize ((radix 0))
+ (f 12)) ==> error
+}}
+
+==== Exception handling
+
+<macro>(guard (<variable> <cond clause[1]> <cond clause[2]> ...) <body>)</macro>
+
+Syntax: Each <cond clause> is as in the specification of cond.
+
+Semantics: The <body> is evaluated with an exception handler that binds the
+raised object (see {{raise}}) to <variable> and, within the scope
+of that binding, evaluates the clauses as if they were the clauses of a cond
+expression. That implicit cond expression is evaluated with the continuation
+and dynamic environment of the guard expression. If every <cond clause>'s
+<test> evaluates to #f and there is no else clause, then raise-continuable is
+invoked on the raised object within the dynamic environment of the original
+call to raise or raise-continuable, except that the current exception handler
+is that of the guard expression.
+
+{{
+(guard (condition
+ ((assq 'a condition) => cdr)
+ ((assq 'b condition)))
+ (raise (list (cons 'a 42))))
+==> 42
+
+(guard (condition
+ ((assq 'a condition) => cdr)
+ ((assq 'b condition)))
+ (raise (list (cons 'b 23))))
+==> (b . 23)
+}}
+
+==== Quasiquotation
+
+<macro>(quasiquote <qq template>)</macro><br>
+<macro>`<qq template></macro><br>
+
+"Backquote" or "quasiquote" expressions are useful for constructing
+a list or vector structure when most but not all of the desired
+structure is known in advance. If no commas appear within the <qq
+template>, the result of evaluating `<qq template> is equivalent to the
+result of evaluating '<qq template>. If a comma appears within the <qq
+template>, however, the expression following the comma is evaluated
+("unquoted") and its result is inserted into the structure instead of
+the comma and the expression. If a comma appears followed immediately
+by an at-sign (@), then the following expression must evaluate to a
+list; the opening and closing parentheses of the list are then
+"stripped away" and the elements of the list are inserted in place of
+the comma at-sign expression sequence. A comma at-sign should only
+appear within a list or vector <qq template>.
+
+ `(list ,(+ 1 2) 4) ===> (list 3 4)
+ (let ((name 'a)) `(list ,name ',name))
+ ===> (list a (quote a))
+ `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)
+ ===> (a 3 4 5 6 b)
+ `(( foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))
+ ===> ((foo 7) . cons)
+ `#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8)
+ ===> #(10 5 2 4 3 8)
+
+Quasiquote forms may be nested. Substitutions are made only for
+unquoted components appearing at the same nesting level as the
+outermost backquote. The nesting level increases by one inside each
+successive quasiquotation, and decreases by one inside each
+unquotation.
+
+ `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)
+ ===> (a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+ (let ((name1 'x)
+ (name2 'y))
+ `(a `(b ,,name1 ,',name2 d) e))
+ ===> (a `(b ,x ,'y d) e)
+
+The two notations `<qq template> and (quasiquote <qq template>) are
+identical in all respects. ,<expression> is identical to (unquote
+<expression>), and ,@<expression> is identical to (unquote-splicing
+<expression>). The external syntax generated by write for two-element
+lists whose car is one of these symbols may vary between
+implementations.
+
+ (quasiquote (list (unquote (+ 1 2)) 4))
+ ===> (list 3 4)
+ '(quasiquote (list (unquote (+ 1 2)) 4))
+ ===> `(list ,(+ 1 2) 4)
+ i.e., (quasiquote (list (unquote (+ 1 2)) 4))
+
+Unpredictable behavior can result if any of the symbols quasiquote,
+unquote, or unquote-splicing appear in positions within a <qq template>
+otherwise than as described above.
+
+=== Macros
+
+Scheme programs can define and use new derived expression types, called
+macros. Program-defined expression types have the syntax
+
+ (<keyword> <datum> ...)
+
+where <keyword> is an identifier that uniquely determines the
+expression type. This identifier is called the syntactic keyword, or
+simply keyword, of the macro. The number of the <datum>s, and their
+syntax, depends on the expression type.
+
+Each instance of a macro is called a use of the macro. The set of rules
+that specifies how a use of a macro is transcribed into a more
+primitive expression is called the transformer of the macro.
+
+The macro definition facility consists of two parts:
+
+* A set of expressions used to establish that certain identifiers are
+ macro keywords, associate them with macro transformers, and control
+ the scope within which a macro is defined, and
+
+* a pattern language for specifying macro transformers.
+
+The syntactic keyword of a macro may shadow variable bindings, and
+local variable bindings may shadow keyword bindings. All macros defined
+using the pattern language are "hygienic" and "referentially
+transparent" and thus preserve Scheme's lexical scoping:
+
+* If a macro transformer inserts a binding for an identifier
+ (variable or keyword), the identifier will in effect be renamed
+ throughout its scope to avoid conflicts with other identifiers.
+ Note that a define at top level may or may not introduce a binding;
+ this depends on whether the binding already existed before (in which
+ case its value will be overridden).
+
+* If a macro transformer inserts a free reference to an identifier,
+ the reference refers to the binding that was visible where the
+ transformer was specified, regardless of any local bindings that
+ may surround the use of the macro.
+
+==== Binding constructs for syntactic keywords
+
+Let-syntax and letrec-syntax are analogous to let and letrec, but they
+bind syntactic keywords to macro transformers instead of binding
+variables to locations that contain values. Syntactic keywords may also
+be bound at top level.
+
+<macro>(let-syntax <bindings> <body>)</macro><br>
+
+Syntax: <Bindings> should have the form
+
+ ((<keyword> <transformer spec>) ...)
+
+Each <keyword> is an identifier, each <transformer spec> is an instance
+of syntax-rules, and <body> should be a sequence of one or more
+expressions. It is an error for a <keyword> to appear more than once in
+the list of keywords being bound.
+
+Semantics: The <body> is expanded in the syntactic environment obtained
+by extending the syntactic environment of the let-syntax expression
+with macros whose keywords are the <keyword>s, bound to the specified
+transformers. Each binding of a <keyword> has <body> as its region.
+
+ (let-syntax ((when (syntax-rules ()
+ ((when test stmt1 stmt2 ...)
+ (if test
+ (begin stmt1
+ stmt2 ...))))))
+ (let ((if #t))
+ (when if (set! if 'now))
+ if)) ===> now
+
+ (let ((x 'outer))
+ (let-syntax ((m (syntax-rules () ((m) x))))
+ (let ((x 'inner))
+ (m)))) ===> outer
+
+<macro>(letrec-syntax <bindings> <body>)</macro><br>
+
+Syntax: Same as for let-syntax.
+
+Semantics: The <body> is expanded in the syntactic environment obtained
+by extending the syntactic environment of the letrec-syntax expression
+with macros whose keywords are the <keyword>s, bound to the specified
+transformers. Each binding of a <keyword> has the <bindings> as well as
+the <body> within its region, so the transformers can transcribe
+expressions into uses of the macros introduced by the letrec-syntax
+expression.
+
+ (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))) ===> 7
+
+==== Pattern language
+
+A <transformer spec> has the following form:
+
+ (syntax-rules <literals> <syntax rule> ...)
+
+Syntax: <Literals> is a list of identifiers and each <syntax rule>
+should be of the form
+
+ (<pattern> <template>)
+
+The <pattern> in a <syntax rule> is a list <pattern> that begins with
+the keyword for the macro.
+
+A <pattern> is either an identifier, a constant, or one of the
+following
+
+ (<pattern> ...)
+ (<pattern> <pattern> ... . <pattern>)
+ (<pattern> ... <pattern> <ellipsis> <pattern> ...)
+ #(<pattern> ...)
+ #(<pattern> ... <pattern> <ellipsis>)
+
+and a template is either an identifier, a constant, or one of the
+following
+
+ (<element> ...)
+ (<element> <element> ... . <template>)
+ (<ellipsis> <template>)
+ #(<element> ...)
+
+where an <element> is a <template> optionally followed by an <ellipsis>
+and an <ellipsis> is the identifier "...".
+
+Semantics: An instance of syntax-rules produces a new macro transformer
+by specifying a sequence of hygienic rewrite rules. A use of a macro
+whose keyword is associated with a transformer specified by
+syntax-rules is matched against the patterns contained in the <syntax
+rule>s, beginning with the leftmost <syntax rule>. When a match is
+found, the macro use is transcribed hygienically according to the
+template.
+
+An identifier appearing within a <pattern> can be an underscore ({{_}}), a literal
+identifier listed in the list of <pattern literal>s, or the <ellipsis>. All
+other identifiers appearing within a <pattern> are pattern variables.
+
+The keyword at the beginning of the pattern in a <syntax rule> is not involved
+in the matching and is considered neither a pattern variable nor a literal
+identifier.
+
+Pattern variables match arbitrary input elements and are used to refer to
+elements of the input in the template. It is an error for the same pattern
+variable to appear more than once in a <pattern>.
+
+Underscores also match arbitrary input elements but are not pattern variables
+and so cannot be used to refer to those elements. If an underscore appears in
+the <pattern literal>s list, then that takes precedence and underscores in the
+<pattern> match as literals. Multiple underscores can appear in a <pattern>.
+
+Identifiers that appear in (<pattern literal> …) are interpreted as literal
+identifiers to be matched against corresponding elements of the input. An
+element in the input matches a literal identifier if and only if it is an
+identifier and either both its occurrence in the macro expression and its
+occurrence in the macro definition have the same lexical binding, or the two
+identifiers are the same and both have no lexical binding.
+
+A subpattern followed by <ellipsis> can match zero or more elements of the
+input, unless <ellipsis> appears in the <pattern literal>s, in which case it is
+matched as a literal.
+
+More formally, an input form F matches a pattern P if and only if:
+
+* P is an underscore (_).
+
+* P is a non-literal identifier; or
+
+* P is a literal identifier and F is an identifier with the same
+ binding; or
+
+* P is a list (P[1] ... P[n]) and F is a list of n forms that match P
+ [1] through P[n], respectively; or
+
+* P is an improper list (P[1] P[2] ... P[n] . P[n+1]) and F is a list
+ or improper list of n or more forms that match P[1] through P[n],
+ respectively, and whose nth "cdr" matches P[n+1]; or
+
+* P is of the form (P[1] … P[k] P[e] <ellipsis> P[m+1] ... P[n] . P[x]) where E
+ is a list or improper list of n elements, the first k of which match P[1]
+ through P[k], whose next m−k elements each match P[e], whose remaining n−m
+ elements match P[m+1] through P[n], and whose nth and final cdr matches P[x
+ ]; or
+
+* P is a vector of the form #(P[1] ... P[n]) and F is a vector of n
+ forms that match P[1] through P[n]; or
+
+ • P is of the form #(P[1] ... P[k] P[e] <ellipsis> P[m+1] ... P[n]) where E is a
+ vector of n elements the first k of which match P[1] through P[k], whose
+ next m−k elements each match P[e], and whose remaining n−m elements match P
+ [m+1] through P[n]; or
+
+* P is a datum and F is equal to P in the sense of the equal?
+ procedure.
+
+It is an error to use a macro keyword, within the scope of its binding,
+in an expression that does not match any of the patterns.
+
+When a macro use is transcribed according to the template of the matching
+<syntax rule>, pattern variables that occur in the template are replaced by the
+elements they match in the input. Pattern variables that occur in subpatterns
+followed by one or more instances of the identifier <ellipsis> are allowed only
+in subtemplates that are followed by as many instances of <ellipsis>. They are
+replaced in the output by all of the elements they match in the input,
+distributed as indicated. It is an error if the output cannot be built up as
+specified.
+
+Identifiers that appear in the template but are not pattern variables or the
+identifier <ellipsis> are inserted into the output as literal identifiers. If a
+literal identifier is inserted as a free identifier then it refers to the
+binding of that identifier within whose scope the instance of syntax-rules
+appears. If a literal identifier is inserted as a bound identifier then it is
+in effect renamed to prevent inadvertent captures of free identifiers.
+
+A template of the form (<ellipsis> <template>) is identical to <template>,
+except that ellipses within the template have no special meaning. That is, any
+ellipses contained within <template> are treated as ordinary identifiers. In
+particular, the template (<ellipsis> <ellipsis>) produces a single <ellipsis>.
+This allows syntactic abstractions to expand into code containing ellipses.
+
+{{
+(define-syntax be-like-begin
+ (syntax-rules ()
+ ((be-like-begin name)
+ (define-syntax name
+ (syntax-rules ()
+ ((name expr (... ...))
+ (begin expr (... ...))))))))
+
+(be-like-begin sequence)
+
+(sequence 1 2 3 4) ==> 4
+}}
+
+As an example, if {{let}} and {{cond}} have their standard meaning
+then they are hygienic (as required) and the following is not an
+error.
+
+ (let ((=> #f))
+ (cond (#t => 'ok))) ===> ok
+
+The macro transformer for cond recognizes => as a local variable, and
+hence an expression, and not as the top-level identifier =>, which the
+macro transformer treats as a syntactic keyword. Thus the example
+expands into
+
+ (let ((=> #f))
+ (if #t (begin => 'ok)))
+
+instead of
+
+ (let ((=> #f))
+ (let ((temp #t))
+ (if temp ('ok temp))))
+
+which would result in an invalid procedure call.
+
+==== Signaling errors in macro transformers
+
+<macro>(syntax-error <message> <args> ...)</macro>
+
+{{syntax-error}} behaves similarly to {{error}} except that implementations with
+an expansion pass separate from evaluation should signal an error as soon as
+{{syntax-error}} is expanded. This can be used as a syntax-rules <template> for a
+<pattern> that is an invalid use of the macro, which can provide more
+descriptive error messages. <message> is a string literal, and <args> arbitrary
+expressions providing additional information. Applications cannot count on
+being able to catch syntax errors with exception handlers or guards.
+
+ (define-syntax simple-let
+ (syntax-rules ()
+ ((_ (head ... ((x . y) val) . tail)
+ body1 body2 ...)
+ (syntax-error
+ "expected an identifier but got"
+ (x . y)))
+ ((_ ((name val) ...) body1 body2 ...)
+ ((lambda (name ...) body1 body2 ...)
+ val ...))))
+
+
+== Program structure
+
+=== Programs
+
+A Scheme program consists of a sequence of expressions, definitions,
+and syntax definitions. Expressions are described in chapter 4;
+definitions and syntax definitions are the subject of the rest of the
+present chapter.
+
+Programs are typically stored in files or entered interactively to a
+running Scheme system, although other paradigms are possible;
+questions of user interface lie outside the scope of this
+report. (Indeed, Scheme would still be useful as a notation for
+expressing computational methods even in the absence of a mechanical
+implementation.)
+
+Definitions and syntax definitions occurring at the top level of a
+program can be interpreted declaratively. They cause bindings to be
+created in the top level environment or modify the value of existing
+top-level bindings. Expressions occurring at the top level of a
+program are interpreted imperatively; they are executed in order when
+the program is invoked or loaded, and typically perform some kind of
+initialization.
+
+At the top level of a program (begin <form1> ...) is equivalent to the
+sequence of expressions, definitions, and syntax definitions that form
+the body of the begin.
+
+=== Import declarations
+
+<macro>(import IMPORT-SET ...)</macro>
+
+An import declaration provides a way to import identifiers exported by a
+library. Each <import set> names a set of bindings from a library and possibly
+specifies local names for the imported bindings. It takes one of the following
+forms:
+
+* <library name>
+
+* {{(only <import set> <identifier> ...)}}
+
+* {{(except <import set> <identifier> ...)}}
+
+* {{(prefix <import set> <identifier>)}}
+
+* {{(rename <import set> (<identifier[1]> <identifier[2]>) ...)}}
+
+In the first form, all of the identifiers in the named library’s export clauses
+are imported with the same names (or the exported names if exported with rename
+). The additional <import set> forms modify this set as follows:
+
+* only produces a subset of the given <import set> including only the listed
+ identifiers (after any renaming). It is an error if any of the listed
+ identifiers are not found in the original set.
+
+* except produces a subset of the given <import set>, excluding the listed
+ identifiers (after any renaming). It is an error if any of the listed
+ identifiers are not found in the original set.
+
+* rename modifies the given <import set>, replacing each instance of
+ <identifier[1]> with <identifier[2]>. It is an error if any of the listed
+ <identifier[1]>s are not found in the original set.
+
+* prefix automatically renames all identifiers in the given <import set>,
+ prefixing each with the specified <identifier>.
+
+=== Definitions
+
+Definitions are valid in some, but not all, contexts where expressions
+are allowed. They are valid only at the top level of a <program> and
+at the beginning of a <body>.
+
+A definition should have one of the following forms:
+
+<macro>(define <variable> <expression>)</macro><br>
+<macro>(define (<variable> <formals>) <body>)</macro><br>
+
+<Formals> should be either a sequence of zero or more variables, or a
+sequence of one or more variables followed by a space-delimited period
+and another variable (as in a lambda expression). This form is
+equivalent to
+
+ (define <variable>
+ (lambda (<formals>) <body>)).
+
+<macro>(define <variable>)</macro>
+
+This form is a CHICKEN extension to R7RS, and is equivalent to
+
+ (define <variable> (void))
+
+<macro>(define (<variable> . <formal>) <body>)</macro><br>
+
+<Formal> should be a single variable. This form is equivalent to
+
+ (define <variable>
+ (lambda <formal> <body>)).
+
+<macro>(define ((<variable> <formal> ...) ...) <body>)</macro><br>
+
+As an extension to R7RS, CHICKEN allows ''curried'' definitions, where
+the variable name may also be a list specifying a name and a nested
+lambda list. For example,
+
+ (define ((make-adder x) y) (+ x y))
+
+is equivalent to
+
+ (define (make-adder x) (lambda (y) (+ x y))).
+
+This type of curried definition can be nested arbitrarily and combined
+with dotted tail notation or DSSSL keywords.
+
+==== Top level definitions
+
+At the top level of a program, a definition
+
+ (define <variable> <expression>)
+
+has essentially the same effect as the assignment expression
+
+ (set! <variable> <expression>)
+
+if <variable> is bound. If <variable> is not bound, however, then the
+definition will bind <variable> to a new location before performing
+the assignment, whereas it would be an error to perform a set! on an
+unbound variable in standard Scheme. In CHICKEN, {{set!}} at toplevel
+has the same effect as a definition, unless inside a module, in which
+case it is an error.
+
+ (define add3
+ (lambda (x) (+ x 3)))
+ (add3 3) ===> 6
+ (define first car)
+ (first '(1 2)) ===> 1
+
+Some implementations of Scheme use an initial environment in which all
+possible variables are bound to locations, most of which contain
+undefined values. Top level definitions in such an implementation are
+truly equivalent to assignments. In CHICKEN, attempting to evaluate
+an unbound identifier will result in an error, but you ''can'' use
+{{set!}} to bind an initial value to it.
+
+==== Internal definitions
+
+Definitions may occur at the beginning of a <body> (that is, the body
+of a lambda, let, let*, letrec, let-syntax, or letrec-syntax
+expression or that of a definition of an appropriate form). Such
+definitions are known as internal definitions as opposed to the top
+level definitions described above. The variable defined by an internal
+definition is local to the <body>. That is, <variable> is bound rather
+than assigned, and the region of the binding is the entire <body>. For
+example,
+
+ (let ((x 5))
+ (define foo (lambda (y) (bar x y)))
+ (define bar (lambda (a b) (+ (* a b) a)))
+ (foo (+ x 3))) ===> 45
+
+A <body> containing internal definitions can always be converted into
+a completely equivalent letrec expression. For example, the let
+expression in the above example is equivalent to
+
+ (let ((x 5))
+ (letrec ((foo (lambda (y) (bar x y)))
+ (bar (lambda (a b) (+ (* a b) a))))
+ (foo (+ x 3))))
+
+Just as for the equivalent letrec expression, it must be possible to
+evaluate each <expression> of every internal definition in a <body>
+without assigning or referring to the value of any <variable> being
+defined.
+
+Wherever an internal definition may occur (begin <definition1> ...) is
+equivalent to the sequence of definitions that form the body of the
+begin.
+
+CHICKEN extends the R7RS 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.
+
+=== Multiple-value definitions
+
+Another kind of definition is provided by define-values, which creates multiple
+definitions from a single expression returning multiple values. It is allowed
+wherever define is allowed.
+
+<macro>(define-values <formals> <expression>)</macro>
+
+It is an error if a variable appears more than once in the set of <formals>.
+
+Semantics: <Expression> is evaluated, and the <formals> are bound to the return
+values in the same way that the <formals> in a lambda expression are matched to
+the arguments in a procedure call.
+
+{{
+(define-values (x y) (exact-integer-sqrt 17))
+(list x y) ==> (4 1)
+
+(let ()
+ (define-values (x y) (values 1 2))
+ (+ x y)) ==> 3
+}}
+
+=== Syntax definitions
+
+Syntax definitions are valid only at the top level of a
+<program>. They have the following form:
+
+<macro>(define-syntax <keyword> <transformer spec>)</macro>
+
+{{<Keyword>}} is an identifier, and the {{<transformer spec>}} should
+be an instance of {{syntax-rules}}. Note that CHICKEN also supports
+{{er-macro-transformer}} and {{ir-macro-transformer}} here. For more
+information see [[Module (chicken syntax)|the (chicken syntax) module]].
+
+The top-level syntactic environment is extended by binding the
+<keyword> to the specified transformer.
+
+In standard Scheme, there is no define-syntax analogue of internal
+definitions in, but CHICKEN allows these as an extension to the
+standard. This means {{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}} 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. Also, "tail" patterns of the form
+
+ (syntax-rules ()
+ ((_ (a b ... c)
+ ...
+
+are supported.
+
+The effect of destructively modifying the s-expression passed to a
+transformer procedure is undefined.
+
+Although macros may expand into definitions and syntax definitions in
+any context that permits them, it is an error for a definition or
+syntax definition to shadow a syntactic keyword whose meaning is
+needed to determine whether some form in the group of forms that
+contains the shadowing definition is in fact a definition, or, for
+internal definitions, is needed to determine the boundary between the
+group and the expressions that follow the group. For example, the
+following are errors:
+
+ (define define 3)
+
+ (begin (define begin list))
+
+ (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)
+ (plus foo x)))
+
+=== Record-type definitions
+
+Record-type definitions are used to introduce new data types, called record
+types. Like other definitions, they can appear either at the outermost level or
+in a body. The values of a record type are called records and are aggregations
+of zero or more fields, each of which holds a single location. A predicate, a
+constructor, and field accessors and mutators are defined for each record type.
+
+<macro>(define-record-type <name> <constructor> <pred> <field> ...)</macro>
+
+Syntax: <name> and <pred> are identifiers. The <constructor> is of the form
+{{(<constructor name> <field name> ...)}} and each <field> is either of the form
+{{(<field name> <accessor name>)}} or of the form {{(<field name> <accessor name> <modifier name>)}}. It is an error for the same identifier to occur more than once
+as a field name. It is also an error for the same identifier to occur more than
+once as an accessor or mutator name.
+
+The define-record-type construct is generative: each use creates a new record
+type that is distinct from all existing types, including Scheme’s predefined
+types and other record types — even record types of the same name or structure.
+
+An instance of define-record-type is equivalent to the following definitions:
+
+* <name> is bound to a representation of the record type itself. This may be
+ a run-time object or a purely syntactic representation. The representation
+ is not utilized in this report, but it serves as a means to identify the
+ record type for use by further language extensions.
+
+* <constructor name> is bound to a procedure that takes as many arguments as
+ there are <field name>s in the {{(<constructor name> ...)}} subexpression and
+ returns a new record of type <name>. Fields whose names are listed with
+ <constructor name> have the corresponding argument as their initial value.
+ The initial values of all other fields are unspecified. It is an error for
+ a field name to appear in <constructor> but not as a <field name>.
+
+* <pred> is bound to a predicate that returns #t when given a value returned
+ by the procedure bound to <constructor name> and #f for everything else.
+
+* Each <accessor name> is bound to a procedure that takes a record of type
+ <name> and returns the current value of the corresponding field. It is an
+ error to pass an accessor a value which is not a record of the appropriate
+ type.
+
+* Each <modifier name> is bound to a procedure that takes a record of type
+ <name> and a value which becomes the new value of the corresponding field;
+ an unspecified value is returned. It is an error to pass a modifier a first
+ argument which is not a record of the appropriate type.
+
+For instance, the following record-type definition
+
+{{
+(define-record-type <pare>
+ (kons x y)
+ pare?
+ (x kar set-kar!)
+ (y kdr))
+}}
+
+defines kons to be a constructor, kar and kdr to be accessors, set-kar! to be a
+modifier, and pare? to be a predicate for instances of <pare>.
+
+{{
+(pare? (kons 1 2)) ⟹ #t
+ (pare? (cons 1 2)) ⟹ #f
+ (kar (kons 1 2)) ⟹ 1
+ (kdr (kons 1 2)) ⟹ 2
+ (let ((k (kons 1 2)))
+ (set-kar! k 3)
+ (kar k)) ⟹ 3
+}}
+
+=== Libraries
+
+Libraries provide a way to organize Scheme programs into reusable parts with
+explicitly defined interfaces to the rest of the program. This section defines
+the notation and semantics for libraries.
+
+==== Library Syntax
+
+A library definition takes the following form:
+
+<macro>(define-library <library name> <library declaration> ...)</macro>
+
+<library name> is a list whose members are identifiers and exact non-negative
+integers. It is used to identify the library uniquely when importing from other
+programs or libraries. Libraries whose first identifier is scheme are reserved
+for use by this report and future versions of this report. Libraries whose
+first identifier is srfi are reserved for libraries implementing Scheme
+Requests for Implementation. It is inadvisable, but not an error, for
+identifiers in library names to contain any of the characters | \ ? * < " : > +
+[ ] / or control characters after escapes are expanded.
+
+A <library declaration> is any of:
+
+* {{(export <export spec> ...)}}
+
+* {{(import <import set> ...)}}
+
+* {{(begin <command or definition> ...)}}
+
+* {{(include <filename[1]> <filename[2]> ...)}}
+
+* {{(include-ci <filename[1]> <filename[2]> ...)}}
+
+* {{(include-library-declarations <filename[1]> <filename[2]> ...)}}
+
+* {{(cond-expand <ce-clause[1]> <ce-clause[2]> ...}}
+
+An export declaration specifies a list of identifiers which can be made visible
+to other libraries or programs. An <export spec> takes one of the following
+forms:
+
+* <identifier>
+
+* {{(rename <identifier[1]> <identifier[2]>)}}
+
+In an <export spec>, an <identifier> names a single binding defined within or
+imported into the library, where the external name for the export is the same
+as the name of the binding within the library. A {{rename}} spec exports the
+binding defined within or imported into the library and named by <identifier
+[1]> in each {{(<identifier[1]> <identifier[2]>)}} pairing, using <identifier[2]>
+as the external name.
+
+An import declaration provides a way to import the identifiers exported by
+another library.
+
+The {{begin}}, {{include}}, and {{include}}-ci declarations are used to specify the body of
+the library. They have the same syntax and semantics as the corresponding
+expression types. This form of begin is analogous to, but not the same as, the
+two types of begin defined in section 4.2.3.
+
+The {{include-library-declarations}} declaration is similar to {{include}} except that
+the contents of the file are spliced directly into the current library
+definition. This can be used, for example, to share the same export declaration
+among multiple libraries as a simple form of library interface.
+
+The {{cond-expand}} declaration has the same syntax and semantics as the
+{{cond-expand}} expression type, except that it expands to spliced-in library
+declarations rather than expressions enclosed in begin.
+
+One possible implementation of libraries is as follows: After all {{cond-expand}}
+library declarations are expanded, a new environment is constructed for the
+library consisting of all imported bindings. The expressions from all begin,
+{{include}} and {{include-ci}} library declarations are expanded in that environment in
+the order in which they occur in the library. Alternatively, {{cond-expand}} and
+{{import}} declarations may be processed in left to right order interspersed with
+the processing of other declarations, with the environment growing as imported
+bindings are added to it by each import declaration.
+
+When a library is loaded, its expressions are executed in textual order. If a
+library’s definitions are referenced in the expanded form of a program or
+library body, then that library must be loaded before the expanded program or
+library body is evaluated. This rule applies transitively. If a library is
+imported by more than one program or library, it may possibly be loaded
+additional times.
+
+Similarly, during the expansion of a library (foo), if any syntax keywords
+imported from another library (bar) are needed to expand the library, then the
+library (bar) must be expanded and its syntax definitions evaluated before the
+expansion of (foo).
+
+
+== Standard procedures
+
+This chapter describes Scheme's built-in procedures. The initial (or
+"top level") Scheme environment starts out with a number of variables
+bound to locations containing useful values, most of which are
+primitive procedures that manipulate data. For example, the variable
+abs is bound to (a location initially containing) a procedure of one
+argument that computes the absolute value of a number, and the variable
++ is bound to a procedure that computes sums. Built-in procedures that
+can easily be written in terms of other built-in procedures are
+identified as "library procedures".
+
+A program may use a top-level definition to bind any variable. It may
+subsequently alter any such binding by an assignment (see
+[[#assignments|assignments]], above). These operations do
+not modify the behavior of Scheme's built-in procedures. Altering any
+top-level binding that has not been introduced by a definition has an
+unspecified effect on the behavior of the built-in procedures.
+
+=== Equivalence predicates
+
+A predicate is a procedure that always returns a boolean value (#t or #f).
+An equivalence predicate is the computational analogue of a
+mathematical equivalence relation (it is symmetric, reflexive, and
+transitive). Of the equivalence predicates described in this section,
+eq? is the finest or most discriminating, and equal? is the coarsest.
+eqv? is slightly less discriminating than eq?.
+
+<procedure>(eqv? obj[1] obj[2])</procedure><br>
+
+The eqv? procedure defines a useful equivalence relation on objects.
+Briefly, it returns #t if obj[1] and obj[2] should normally be regarded
+as the same object. This relation is left slightly open to
+interpretation, but the following partial specification of eqv? holds
+for all implementations of Scheme.
+
+The eqv? procedure returns #t if:
+
+* obj[1] and obj[2] are both #t or both #f.
+
+* obj[1] and obj[2] are both symbols and
+
+ (string=? (symbol->string obj1)
+ (symbol->string obj2))
+ ===> #t
+
+Note: This assumes that neither obj[1] nor obj[2] is an "uninterned
+symbol" as alluded to in the section on [[#symbols|symbols]]. This
+report does not presume to specify the behavior of eqv? on
+implementation-dependent extensions.
+
+* obj[1] and obj[2] are both numbers, are numerically equal (see =,
+ under [[#numerical-operations|numerical operations]]), and are
+ either both exact or both inexact.
+
+* obj[1] and obj[2] are both characters and are the same character
+ according to the char=? procedure (see "[[#characters|characters]]").
+
+* both obj[1] and obj[2] are the empty list.
+
+* obj[1] and obj[2] are pairs, vectors, or strings that denote the
+ same locations in the store.
+
+* obj[1] and obj[2] are procedures whose location tags are equal
+ (see "[[#procedures|procedures]]").
+
+The eqv? procedure returns #f if:
+
+* obj[1] and obj[2] are of different types.
+
+* one of obj[1] and obj[2] is #t but the other is #f.
+
+* obj[1] and obj[2] are symbols but
+
+ (string=? (symbol->string obj[1])
+ (symbol->string obj[2]))
+ ===> #f
+
+* one of obj[1] and obj[2] is an exact number but the other is an
+ inexact number.
+
+* obj[1] and obj[2] are numbers for which the = procedure returns #f.
+
+* obj[1] and obj[2] are characters for which the char=? procedure
+ returns #f.
+
+* one of obj[1] and obj[2] is the empty list but the other is not.
+
+* obj[1] and obj[2] are pairs, vectors, or strings that denote
+ distinct locations.
+
+* obj[1] and obj[2] are procedures that would behave differently
+ (return different value(s) or have different side effects) for some
+ arguments.
+
+ (eqv? 'a 'a) ===> #t
+ (eqv? 'a 'b) ===> #f
+ (eqv? 2 2) ===> #t
+ (eqv? '() '()) ===> #t
+ (eqv? 100000000 100000000) ===> #t
+ (eqv? (cons 1 2) (cons 1 2)) ===> #f
+ (eqv? (lambda () 1)
+ (lambda () 2)) ===> #f
+ (eqv? #f 'nil) ===> #f
+ (let ((p (lambda (x) x)))
+ (eqv? p p)) ===> #t
+
+The following examples illustrate cases in which the above rules do not
+fully specify the behavior of eqv?. All that can be said about such
+cases is that the value returned by eqv? must be a boolean.
+
+ (eqv? "" "") ===> unspecified
+ (eqv? '#() '#()) ===> unspecified
+ (eqv? (lambda (x) x)
+ (lambda (x) x)) ===> unspecified
+ (eqv? (lambda (x) x)
+ (lambda (y) y)) ===> unspecified
+
+The next set of examples shows the use of eqv? with procedures that
+have local state. Gen-counter must return a distinct procedure every
+time, since each procedure has its own internal counter. Gen-loser,
+however, returns equivalent procedures each time, since the local state
+does not affect the value or side effects of the procedures.
+
+ (define gen-counter
+ (lambda ()
+ (let ((n 0))
+ (lambda () (set! n (+ n 1)) n))))
+ (let ((g (gen-counter)))
+ (eqv? g g)) ===> #t
+ (eqv? (gen-counter) (gen-counter))
+ ===> #f
+ (define gen-loser
+ (lambda ()
+ (let ((n 0))
+ (lambda () (set! n (+ n 1)) 27))))
+ (let ((g (gen-loser)))
+ (eqv? g g)) ===> #t
+ (eqv? (gen-loser) (gen-loser))
+ ===> unspecified
+
+ (letrec ((f (lambda () (if (eqv? f g) 'both 'f)))
+ (g (lambda () (if (eqv? f g) 'both 'g))))
+ (eqv? f g))
+ ===> unspecified
+
+ (letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
+ (g (lambda () (if (eqv? f g) 'g 'both))))
+ (eqv? f g))
+ ===> #f
+
+Since it is an error to modify constant objects (those returned by
+literal expressions), implementations are permitted, though not
+required, to share structure between constants where appropriate. Thus
+the value of eqv? on constants is sometimes implementation-dependent.
+
+ (eqv? '(a) '(a)) ===> unspecified
+ (eqv? "a" "a") ===> unspecified
+ (eqv? '(b) (cdr '(a b))) ===> unspecified
+ (let ((x '(a)))
+ (eqv? x x)) ===> #t
+
+Rationale: The above definition of eqv? allows implementations
+latitude in their treatment of procedures and literals:
+implementations are free either to detect or to fail to detect that
+two procedures or two literals are equivalent to each other, and
+can decide whether or not to merge representations of equivalent
+objects by using the same pointer or bit pattern to represent both.
+
+<procedure>(eq? obj[1] obj[2])</procedure><br>
+
+Eq? is similar to eqv? except that in some cases it is capable of
+discerning distinctions finer than those detectable by eqv?.
+
+Eq? and eqv? are guaranteed to have the same behavior on symbols,
+booleans, the empty list, pairs, procedures, and non-empty strings and
+vectors. Eq?'s behavior on numbers and characters is
+implementation-dependent, but it will always return either true or
+false, and will return true only when eqv? would also return true. Eq?
+may also behave differently from eqv? on empty vectors and empty
+strings.
+
+ (eq? 'a 'a) ===> #t
+ (eq? '(a) '(a)) ===> unspecified
+ (eq? (list 'a) (list 'a)) ===> #f
+ (eq? "a" "a") ===> unspecified
+ (eq? "" "") ===> unspecified
+ (eq? '() '()) ===> #t
+ (eq? 2 2) ===> unspecified
+ (eq? #\A #\A) ===> unspecified
+ (eq? car car) ===> #t
+ (let ((n (+ 2 3)))
+ (eq? n n)) ===> unspecified
+ (let ((x '(a)))
+ (eq? x x)) ===> #t
+ (let ((x '#()))
+ (eq? x x)) ===> #t
+ (let ((p (lambda (x) x)))
+ (eq? p p)) ===> #t
+
+Rationale: It will usually be possible to implement eq? much more
+efficiently than eqv?, for example, as a simple pointer comparison
+instead of as some more complicated operation. One reason is that
+it may not be possible to compute eqv? of two numbers in constant
+time, whereas eq? implemented as pointer comparison will always
+finish in constant time. Eq? may be used like eqv? in applications
+using procedures to implement objects with state since it obeys the
+same constraints as eqv?.
+
+<procedure>(equal? obj[1] obj[2])</procedure><br>
+
+Equal? recursively compares the contents of pairs, vectors, and
+strings, applying eqv? on other objects such as numbers and symbols. A
+rule of thumb is that objects are generally equal? if they print the
+same. Equal? may fail to terminate if its arguments are circular data
+structures.
+
+ (equal? 'a 'a) ===> #t
+ (equal? '(a) '(a)) ===> #t
+ (equal? '(a (b) c)
+ '(a (b) c)) ===> #t
+ (equal? "abc" "abc") ===> #t
+ (equal? 2 2) ===> #t
+ (equal? (make-vector 5 'a)
+ (make-vector 5 'a)) ===> #t
+ (equal? (lambda (x) x)
+ (lambda (y) y)) ===> unspecified
+
+=== Numbers
+
+Numerical computation has traditionally been neglected by the Lisp
+community. Until Common Lisp there was no carefully thought out
+strategy for organizing numerical computation, and with the exception
+of the MacLisp system [20] little effort was made to execute numerical
+code efficiently. This report recognizes the excellent work of the
+Common Lisp committee and accepts many of their recommendations. In
+some ways this report simplifies and generalizes their proposals in a
+manner consistent with the purposes of Scheme.
+
+It is important to distinguish between the mathematical numbers, the
+Scheme numbers that attempt to model them, the machine representations
+used to implement the Scheme numbers, and notations used to write
+numbers. This report uses the types number, complex, real, rational,
+and integer to refer to both mathematical numbers and Scheme numbers.
+Machine representations such as fixed point and floating point are
+referred to by names such as fixnum and flonum.
+
+==== Numerical types
+
+Mathematically, numbers may be arranged into a tower of subtypes in
+which each level is a subset of the level above it:
+
+ number
+ complex
+ real
+ rational
+ integer
+
+For example, 3 is an integer. Therefore 3 is also a rational, a real,
+and a complex. The same is true of the Scheme numbers that model 3. For
+Scheme numbers, these types are defined by the predicates number?,
+complex?, real?, rational?, and integer?.
+
+There is no simple relationship between a number's type and its
+representation inside a computer. Although most implementations of
+Scheme will offer at least two different representations of 3, these
+different representations denote the same integer.
+
+Scheme's numerical operations treat numbers as abstract data, as
+independent of their representation as possible. Although an
+implementation of Scheme may use fixnum, flonum, and perhaps other
+representations for numbers, this should not be apparent to a casual
+programmer writing simple programs.
+
+It is necessary, however, to distinguish between numbers that are
+represented exactly and those that may not be. For example, indexes
+into data structures must be known exactly, as must some polynomial
+coefficients in a symbolic algebra system. On the other hand, the
+results of measurements are inherently inexact, and irrational numbers
+may be approximated by rational and therefore inexact approximations.
+In order to catch uses of inexact numbers where exact numbers are
+required, Scheme explicitly distinguishes exact from inexact numbers.
+This distinction is orthogonal to the dimension of type.
+
+==== Exactness
+
+Scheme numbers are either exact or inexact. A number is exact if it was
+written as an exact constant or was derived from exact numbers using
+only exact operations. A number is inexact if it was written as an
+inexact constant, if it was derived using inexact ingredients, or if it
+was derived using inexact operations. Thus inexactness is a contagious
+property of a number. If two implementations produce exact results for
+a computation that did not involve inexact intermediate results, the
+two ultimate results will be mathematically equivalent. This is
+generally not true of computations involving inexact numbers since
+approximate methods such as floating point arithmetic may be used, but
+it is the duty of each implementation to make the result as close as
+practical to the mathematically ideal result.
+
+Rational operations such as + should always produce exact results when
+given exact arguments. If the operation is unable to produce an exact
+result, then it may either report the violation of an implementation
+restriction or it may silently coerce its result to an inexact value.
+See [[#implementation-restrictions|the next section]].
+
+With the exception of inexact->exact, the operations described in this
+section must generally return inexact results when given any inexact
+arguments. An operation may, however, return an exact result if it can
+prove that the value of the result is unaffected by the inexactness of
+its arguments. For example, multiplication of any number by an exact
+zero may produce an exact zero result, even if the other argument is
+inexact.
+
+==== Implementation restrictions
+
+Implementations of Scheme are not required to implement the whole
+tower of subtypes given under "[[#Numerical types|Numerical types]]",
+but they must implement a coherent subset consistent with both the
+purposes of the implementation and the spirit of the Scheme
+language. For example, an implementation in which all numbers are real
+may still be quite useful.
+
+Implementations may also support only a limited range of numbers of any
+type, subject to the requirements of this section. The supported range
+for exact numbers of any type may be different from the supported range
+for inexact numbers of that type. For example, an implementation that
+uses flonums to represent all its inexact real numbers may support a
+practically unbounded range of exact integers and rationals while
+limiting the range of inexact reals (and therefore the range of inexact
+integers and rationals) to the dynamic range of the flonum format.
+Furthermore the gaps between the representable inexact integers and
+rationals are likely to be very large in such an implementation as the
+limits of this range are approached.
+
+An implementation of Scheme must support exact integers throughout the
+range of numbers that may be used for indexes of lists, vectors, and
+strings or that may result from computing the length of a list, vector,
+or string. The length, vector-length, and string-length procedures must
+return an exact integer, and it is an error to use anything but an
+exact integer as an index. Furthermore any integer constant within the
+index range, if expressed by an exact integer syntax, will indeed be
+read as an exact integer, regardless of any implementation restrictions
+that may apply outside this range. Finally, the procedures listed below
+will always return an exact integer result provided all their arguments
+are exact integers and the mathematically expected result is
+representable as an exact integer within the implementation:
+
+ - *
+ + abs
+ ceiling denominator
+ exact-integer-sqrt expt
+ floor floor/
+ floor-quotient floor-remainder
+ gcd lcm
+ max min
+ modulo numerator
+ quotient rationalize
+ remainder round
+ square truncate
+ truncate/ truncate-quotient
+ truncate-remainder
+
+CHICKEN follows the IEEE 32-bit and 64-bit floating point
+standards on all supported platforms.
+
+It is the programmer’s responsibility to avoid using inexact number objects
+with magnitude or significand too large to be represented in the
+implementation.
+
+In addition, implementations may distinguish special numbers called positive
+infinity, negative infinity, NaN, and negative zero.
+
+Positive infinity is regarded as an inexact real (but not rational) number that
+represents an indeterminate value greater than the numbers represented by all
+rational numbers. Negative infinity is regarded as an inexact real (but not
+rational) number that represents an indeterminate value less than the numbers
+represented by all rational numbers.
+
+Adding or multiplying an infinite value by any finite real value results in an
+appropriately signed infinity; however, the sum of positive and negative
+infinities is a NaN. Positive infinity is the reciprocal of zero, and negative
+infinity is the reciprocal of negative zero. The behavior of the transcendental
+functions is sensitive to infinity in accordance with IEEE 754.
+
+A NaN is regarded as an inexact real (but not rational) number so indeterminate
+that it might represent any real value, including positive or negative
+infinity, and might even be greater than positive infinity or less than
+negative infinity. An implementation that does not support non-real numbers may
+use NaN to represent non-real values like (sqrt -1.0) and (asin 2.0).
+
+A NaN always compares false to any number, including a NaN. An arithmetic
+operation where one operand is NaN returns NaN, unless the implementation can
+prove that the result would be the same if the NaN were replaced by any
+rational number. Dividing zero by zero results in NaN unless both zeros are
+exact.
+
+Negative zero is an inexact real value written -0.0 and is distinct (in the
+sense of eqv?) from 0.0. A Scheme implementation is not required to distinguish
+negative zero. If it does, however, the behavior of the transcendental
+functions is sensitive to the distinction in accordance with IEEE 754.
+Specifically, in a Scheme implementing both complex numbers and negative zero,
+the branch cut of the complex logarithm function is such that (imag-part (log
+-1.0-0.0i)) is −π rather than π.
+
+Furthermore, the negation of negative zero is ordinary zero and vice versa.
+This implies that the sum of two or more negative zeros is negative, and the
+result of subtracting (positive) zero from a negative zero is likewise
+negative. However, numerical comparisons treat negative zero as equal to zero.
+
+Note that both the real and the imaginary parts of a complex number can be
+infinities, NaNs, or negative zero.
+
+
+==== Syntax of numerical constants
+
+For a complete formal description of the syntax of the written
+representations for numbers, see the R7RS report. Note that case is
+not significant in numerical constants.
+
+A number may be written in binary, octal, decimal, or hexadecimal by
+the use of a radix prefix. The radix prefixes are #b (binary), #o
+(octal), #d (decimal), and #x (hexadecimal). With no radix prefix, a
+number is assumed to be expressed in decimal.
+
+A numerical constant may be specified to be either exact or inexact by
+a prefix. The prefixes are #e for exact, and #i for inexact. An
+exactness prefix may appear before or after any radix prefix that is
+used. If the written representation of a number has no exactness
+prefix, the constant may be either inexact or exact. It is inexact if
+it contains a decimal point, an exponent, or a "#" character in the
+place of a digit, otherwise it is exact. In systems with inexact
+numbers of varying precisions it may be useful to specify the precision
+of a constant. For this purpose, numerical constants may be written
+with an exponent marker that indicates the desired precision of the
+inexact representation. The letters s, f, d, and l specify the use of
+short, single, double, and long precision, respectively. (When fewer
+than four internal inexact representations exist, the four size
+specifications are mapped onto those available. For example, an
+implementation with two internal representations may map short and
+single together and long and double together.) In addition, the
+exponent marker e specifies the default precision for the
+implementation. The default precision has at least as much precision as
+double, but implementations may wish to allow this default to be set by
+the user.
+
+ 3.14159265358979F0
+ Round to single --- 3.141593
+ 0.6L0
+ Extend to long --- .600000000000000
+
+==== Numerical operations
+
+The numerical routines described below have argument restrictions,
+which are encoded in the naming conventions of the arguments as
+given in the procedure's signature. The conventions are as follows:
+
+; {{obj}} : any object
+; {{list, list1, ... listj, ... list : (see "[[#pairs-and-lists|Pairs and lists]]" below)
+; {{z, z1, ... zj, ...}} : complex number
+; {{x, x1, ... xj, ...}} : real number
+; {{y, y1, ... yj, ...}} : real number
+; {{q, q1, ... qj, ...}} : rational number
+; {{n, n1, ... nj, ...}} : integer
+; {{k, k1, ... kj, ...}} : exact non-negative integer
+
+The examples used in this section assume that any
+numerical constant written using an exact notation is indeed
+represented as an exact number. Some examples also assume that certain
+numerical constants written using an inexact notation can be
+represented without loss of accuracy; the inexact constants were chosen
+so that this is likely to be true in implementations that use flonums
+to represent inexact numbers.
+
+<procedure>(number? obj)</procedure><br>
+<procedure>(complex? obj)</procedure><br>
+<procedure>(real? obj)</procedure><br>
+<procedure>(rational? obj)</procedure><br>
+<procedure>(integer? obj)</procedure><br>
+
+These numerical type predicates can be applied to any kind of argument,
+including non-numbers. They return #t if the object is of the named
+type, and otherwise they return #f. In general, if a type predicate is
+true of a number then all higher type predicates are also true of that
+number. Consequently, if a type predicate is false of a number, then
+all lower type predicates are also false of that number. If z is an
+inexact complex number, then (real? z) is true if and only if (zero?
+(imag-part z)) is true. If x is an inexact real number, then (integer?
+x) is true if and only if (= x (round x)).
+
+ (complex? 3+4i) ===> #t
+ (complex? 3) ===> #t
+ (real? 3) ===> #t
+ (real? -2.5+0.0i) ===> #t
+ (real? #e1e10) ===> #t
+ (rational? 6/10) ===> #t
+ (rational? 6/3) ===> #t
+ (integer? 3+0i) ===> #t
+ (integer? 3.0) ===> #t
+ (integer? 8/4) ===> #t
+
+Note: The behavior of these type predicates on inexact numbers is
+unreliable, since any inaccuracy may affect the result.
+
+Note: In many implementations the rational? procedure will be the
+same as real?, and the complex? procedure will be the same as
+number?, but unusual implementations may be able to represent some
+irrational numbers exactly or may extend the number system to
+support some kind of non-complex numbers.
+
+<procedure>(exact? z)</procedure><br>
+<procedure>(inexact? z)</procedure><br>
+
+These numerical predicates provide tests for the exactness of a
+quantity. For any Scheme number, precisely one of these predicates is
+true.
+
+<procedure>(exact-integer? z)</procedure>
+
+Returns #t if z is both exact and an integer; otherwise returns #f.
+
+ (exact-integer? 32) ===> #t
+ (exact-integer? 32.0) ===> #f
+ (exact-integer? 32/5) ===> #f
+
+<procedure>(= z[1] z[2] z[3] ...)</procedure><br>
+<procedure>(< x[1] x[2] x[3] ...)</procedure><br>
+<procedure>(> x[1] x[2] x[3] ...)</procedure><br>
+<procedure>(<= x[1] x[2] x[3] ...)</procedure><br>
+<procedure>(>= x[1] x[2] x[3] ...)</procedure><br>
+
+These procedures return #t if their arguments are (respectively):
+equal, monotonically increasing, monotonically decreasing,
+monotonically nondecreasing, or monotonically nonincreasing.
+
+These predicates are required to be transitive.
+
+Note: The traditional implementations of these predicates in
+Lisp-like languages are not transitive.
+
+Note: While it is not an error to compare inexact numbers using
+these predicates, the results may be unreliable because a small
+inaccuracy may affect the result; this is especially true of = and
+zero?. When in doubt, consult a numerical analyst.
+
+<procedure>(zero? z)</procedure><br>
+<procedure>(positive? x)</procedure><br>
+<procedure>(negative? x)</procedure><br>
+<procedure>(odd? n)</procedure><br>
+<procedure>(even? n)</procedure><br>
+
+These numerical predicates test a number for a particular property,
+returning #t or #f. See note above.
+
+<procedure>(max x[1] x[2] ...)</procedure><br>
+<procedure>(min x[1] x[2] ...)</procedure><br>
+
+These procedures return the maximum or minimum of their arguments.
+
+ (max 3 4) ===> 4 ; exact
+ (max 3.9 4) ===> 4.0 ; inexact
+
+Note: If any argument is inexact, then the result will also be
+inexact (unless the procedure can prove that the inaccuracy is not
+large enough to affect the result, which is possible only in
+unusual implementations). If min or max is used to compare numbers
+of mixed exactness, and the numerical value of the result cannot be
+represented as an inexact number without loss of accuracy, then the
+procedure may report a violation of an implementation restriction.
+
+<procedure>(+ z[1] ...)</procedure><br>
+<procedure>(* z[1] ...)</procedure><br>
+
+These procedures return the sum or product of their arguments.
+
+ (+ 3 4) ===> 7
+ (+ 3) ===> 3
+ (+) ===> 0
+ (* 4) ===> 4
+ (*) ===> 1
+
+<procedure>(- z[1] z[2])</procedure><br>
+<procedure>(- z)</procedure><br>
+<procedure>(- z[1] z[2] ...)</procedure><br>
+<procedure>(/ z[1] z[2])</procedure><br>
+<procedure>(/ z)</procedure><br>
+<procedure>(/ z[1] z[2] ...)</procedure><br>
+
+With two or more arguments, these procedures return the difference or
+quotient of their arguments, associating to the left. With one
+argument, however, they return the additive or multiplicative inverse
+of their argument.
+
+ (- 3 4) ===> -1
+ (- 3 4 5) ===> -6
+ (- 3) ===> -3
+ (/ 3 4 5) ===> 3/20
+ (/ 3) ===> 1/3
+
+<procedure>(abs x)</procedure><br>
+
+Abs returns the absolute value of its argument.
+
+ (abs -7) ===> 7
+
+<procedure>(floor/ n[1] n[2])</procedure><br>
+<procedure>(floor-quotient n[1] n[2])</procedure><br>
+<procedure>(floor-remainder n[1] n[2])</procedure><br>
+<procedure>(truncate/ n[1] n[2])</procedure><br>
+<procedure>(truncate-quotient n[1] n[2])</procedure><br>
+<procedure>(truncate-remainder n[1] n[2])</procedure><br>
+
+These procedures implement number-theoretic (integer) division. It is an error
+if n[2] is zero. The procedures ending in / return two integers; the other
+procedures return an integer. All the procedures compute a quotient n[q] and remainder
+n[r] such that n[1] = n[2] * n[q] + n[r]. For each of the division operators, there are three procedures defined as
+follows:
+
+ (<operator>/ n[1] n[2]) ==> n[q] n[r]
+ (<operator>-quotient n[1] n[2]) ==> n[q]
+ (<operator>-remainder n[1] n[2]) ==> n[r]
+
+The remainder n[r] is determined by the choice of integer n[q]: n[r] = n[1] − n[2] * n[q]. Each set of operators uses a different choice of n[q]:
+
+ floor n[q] = ⌊n[1] / n[2]⌋
+ truncate n[q] = runcate(n[1] / n[2])
+
+For any of the operators, and for integers n[1] and n[2] with n[2] not equal to 0,
+
+ (= n[1] (+ (* n[2] (<operator>-quotient n[1] n[2]))
+ (<operator>-remainder n[1] n[2])))
+ ==> #t
+
+provided all numbers involved in that computation are exact.
+
+Examples:
+
+ (floor/ 5 2) ==> 2 1
+ (floor/ -5 2) ==> -3 1
+ (floor/ 5 -2) ==> -3 -1
+ (floor/ -5 -2) ==> 2 -1
+ (truncate/ 5 2) ==> 2 1
+ (truncate/ -5 2) ==> -2 -1
+ (truncate/ 5 -2) ==> -2 1
+ (truncate/ -5 -2) ==> 2 -1
+ (truncate/ -5.0 -2) ==> 2.0 -1.0
+
+<procedure>(quotient n[1] n[2])</procedure><br>
+<procedure>(remainder n[1] n[2])</procedure><br>
+<procedure>(modulo n[1] n[2])</procedure><br>
+
+These procedures implement number-theoretic (integer) division. n[2]
+should be non-zero. All three procedures return integers. If n[1]/n[2]
+is an integer:
+
+ (quotient n[1] n[2]) ===> n[1]/n[2]
+ (remainder n[1] n[2]) ===> 0
+ (modulo n[1] n[2]) ===> 0
+
+If n[1]/n[2] is not an integer:
+
+ (quotient n[1] n[2]) ===> n[q]
+ (remainder n[1] n[2]) ===> n[r]
+ (modulo n[1] n[2]) ===> n[m]
+
+where n[q] is n[1]/n[2] rounded towards zero, 0 < |n[r]| < |n[2]|, 0 <
+|n[m]| < |n[2]|, n[r] and n[m] differ from n[1] by a multiple of n[2],
+n[r] has the same sign as n[1], and n[m] has the same sign as n[2].
+
+From this we can conclude that for integers n[1] and n[2] with n[2] not
+equal to 0,
+
+ (= n[1] (+ (* n[2] (quotient n[1] n[2]))
+ (remainder n[1] n[2])))
+ ===> #t
+
+provided all numbers involved in that computation are exact.
+
+ (modulo 13 4) ===> 1
+ (remainder 13 4) ===> 1
+
+ (modulo -13 4) ===> 3
+ (remainder -13 4) ===> -1
+
+ (modulo 13 -4) ===> -3
+ (remainder 13 -4) ===> 1
+
+ (modulo -13 -4) ===> -1
+ (remainder -13 -4) ===> -1
+
+ (remainder -13 -4.0) ===> -1.0 ; inexact
+
+<procedure>(gcd n[1] ...)</procedure><br>
+<procedure>(lcm n[1] ...)</procedure><br>
+
+These procedures return the greatest common divisor or least common
+multiple of their arguments. The result is always non-negative.
+
+ (gcd 32 -36) ===> 4
+ (gcd) ===> 0
+ (lcm 32 -36) ===> 288
+ (lcm 32.0 -36) ===> 288.0 ; inexact
+ (lcm) ===> 1
+
+<procedure>(numerator q)</procedure><br>
+<procedure>(denominator q)</procedure><br>
+
+These procedures return the numerator or denominator of their argument;
+the result is computed as if the argument was represented as a fraction
+in lowest terms. The denominator is always positive. The denominator of
+0 is defined to be 1.
+
+ (numerator (/ 6 4)) ===> 3
+ (denominator (/ 6 4)) ===> 2
+ (denominator
+ (exact->inexact (/ 6 4))) ===> 2.0
+
+<procedure>(floor x)</procedure><br>
+<procedure>(ceiling x)</procedure><br>
+<procedure>(truncate x)</procedure><br>
+<procedure>(round x)</procedure><br>
+
+These procedures return integers. Floor returns the largest integer not
+larger than x. Ceiling returns the smallest integer not smaller than x.
+Truncate returns the integer closest to x whose absolute value is not
+larger than the absolute value of x. Round returns the closest integer
+to x, rounding to even when x is halfway between two integers.
+
+Rationale: Round rounds to even for consistency with the default
+rounding mode specified by the IEEE floating point standard.
+
+Note: If the argument to one of these procedures is inexact, then
+the result will also be inexact. If an exact value is needed, the
+result should be passed to the inexact->exact procedure.
+
+ (floor -4.3) ===> -5.0
+ (ceiling -4.3) ===> -4.0
+ (truncate -4.3) ===> -4.0
+ (round -4.3) ===> -4.0
+
+ (floor 3.5) ===> 3.0
+ (ceiling 3.5) ===> 4.0
+ (truncate 3.5) ===> 3.0
+ (round 3.5) ===> 4.0 ; inexact
+
+ (round 7/2) ===> 4 ; exact
+ (round 7) ===> 7
+
+<procedure>(rationalize x y)</procedure><br>
+
+Rationalize returns the simplest rational number differing from x by no
+more than y. A rational number r[1] is simpler than another rational
+number r[2] if r[1] = p[1]/q[1] and r[2] = p[2]/q[2] (in lowest terms)
+and |p[1]| < |p[2]| and |q[1]| < |q[2]|. Thus 3/5 is simpler than 4/7.
+Although not all rationals are comparable in this ordering (consider 2/
+7 and 3/5) any interval contains a rational number that is simpler than
+every other rational number in that interval (the simpler 2/5 lies
+between 2/7 and 3/5). Note that 0 = 0/1 is the simplest rational of
+all.
+
+ (rationalize
+ (inexact->exact .3) 1/10) ===> 1/3 ; exact
+ (rationalize .3 1/10) ===> #i1/3 ; inexact
+
+<procedure>(exp z)</procedure><br>
+<procedure>(log z [z2])</procedure><br>
+<procedure>(sin z)</procedure><br>
+<procedure>(cos z)</procedure><br>
+<procedure>(tan z)</procedure><br>
+<procedure>(asin z)</procedure><br>
+<procedure>(acos z)</procedure><br>
+<procedure>(atan z)</procedure><br>
+<procedure>(atan y x)</procedure><br>
+
+These procedures are part of every implementation that supports general
+real numbers; they compute the usual transcendental functions. The Log
+procedure computes the natural logarithm of z (not the base ten logarithm)
+if a single argument is given, or the base-z2 logarithm of z1 if two arguments are
+given.
+Asin, acos, and atan compute arcsine (sin^-1), arccosine (cos^-1), and
+arctangent (tan^-1), respectively. The two-argument variant of atan
+computes (angle (make-rectangular x y)) (see below), even in
+implementations that don't support general complex numbers.
+
+In general, the mathematical functions log, arcsine, arccosine, and
+arctangent are multiply defined. The value of log z is defined to be
+the one whose imaginary part lies in the range from -pi
+(exclusive) to pi (inclusive). log 0 is undefined. With log
+defined this way, the values of sin^-1 z, cos^-1 z, and tan^-1 z are
+according to the following formulae:
+
+ sin^-1 z = - i log (i z + (1 - z^2)^1/2)
+
+ cos^-1 z = pi / 2 - sin^-1 z
+
+ tan^-1 z = (log (1 + i z) - log (1 - i z)) / (2 i)
+
+The above specification follows [27], which in turn cites [19]; refer
+to these sources for more detailed discussion of branch cuts, boundary
+conditions, and implementation of these functions. When it is possible
+these procedures produce a real result from a real argument.
+
+<procedure>(square z)</procedure>
+
+Returns the square of z. This is equivalent to {{(* z z)}}-
+
+ (square 42) ==> 1764
+ (square 2.0) ==> 4.0
+
+<procedure>(exact-integer-sqrt k)</procedure>
+
+Returns two non-negative exact integers s and r where k = s^2 + r and k < (s + 1)^2.
+
+ (exact-integer-sqrt 4) ==> 2 0
+ (exact-integer-sqrt 5) ==> 2 1
+
+<procedure>(expt z[1] z[2])</procedure><br>
+
+Returns z[1] raised to the power z[2]. For z[1] != 0
+
+ z[1]^z[2] = e^z[2] log z[1]
+
+0^z is 1 if z = 0 and 0 otherwise.
+
+<procedure>(exact z)</procedure><br>
+<procedure>(inexact z)</procedure><br>
+
+The procedure {{inexact}} returns an inexact representation of z. The value returned is the inexact number that is numerically closest to the
+argument. For inexact arguments, the result is the same as the argument. For
+exact complex numbers, the result is a complex number whose real and imaginary
+parts are the result of applying inexact to the real and imaginary parts of the
+argument, respectively. If an exact argument has no reasonably close inexact
+equivalent (in the sense of =), then a violation of an implementation
+restriction may be reported.
+
+The procedure {{exact}} returns an exact representation of z. The value returned is the exact number that is numerically closest to the
+argument. For exact arguments, the result is the same as the argument. For
+inexact non-integral real arguments, the implementation may return a rational
+approximation, or may report an implementation violation. For inexact complex
+arguments, the result is a complex number whose real and imaginary parts are
+the result of applying exact to the real and imaginary parts of the argument,
+respectively. If an inexact argument has no reasonably close exact equivalent,
+(in the sense of =), then a violation of an implementation restriction may be
+reported.
+
+==== Numerical input and output
+
+<procedure>(number->string z [radix])</procedure>
+
+Radix must be an exact integer. The R7RS standard only requires
+implementations to support 2, 8, 10, or 16, but CHICKEN allows any
+radix between 2 and 36, inclusive (note: a bug in CHICKEN 5 currently
+limits the upper bound to 16). If omitted, radix defaults to
+10. The procedure number->string takes a number and a radix and
+returns as a string an external representation of the given number in
+the given radix such that
+
+ (let ((number number)
+ (radix radix))
+ (eqv? number
+ (string->number (number->string number
+ radix)
+ radix)))
+
+is true. It is an error if no possible result makes this expression
+true.
+
+If z is inexact, the radix is 10, and the above expression can be
+satisfied by a result that contains a decimal point, then the result
+contains a decimal point and is expressed using the minimum number of
+digits (exclusive of exponent and trailing zeroes) needed to make the
+above expression true [3, 5]; otherwise the format of the result is
+unspecified.
+
+The result returned by number->string never contains an explicit radix
+prefix.
+
+Note: The error case can occur only when z is not a complex
+number or is a complex number with a non-rational real or imaginary
+part.
+
+Rationale: If z is an inexact number represented using flonums,
+and the radix is 10, then the above expression is normally
+satisfied by a result containing a decimal point. The unspecified
+case allows for infinities, NaNs, and non-flonum representations.
+
+As an extension to R7RS, CHICKEN supports reading and writing the
+special IEEE floating-point numbers ''+nan'', ''+inf'' and ''-inf'',
+as well as negative zero.
+
+<procedure>(string->number string)</procedure><br>
+<procedure>(string->number string radix)</procedure><br>
+
+Returns a number of the maximally precise representation expressed by
+the given string. Radix must be an exact integer. The R7RS standard
+only requires implementations to support 2, 8, 10, or 16, but CHICKEN
+allows any radix between 2 and 36, inclusive. If supplied, radix is a
+default radix that may be overridden by an explicit radix prefix in
+string (e.g. "#o177"). If radix is not supplied, then the default
+radix is 10. If string is not a syntactically valid notation for a
+number, then string->number returns #f.
+
+ (string->number "100") ===> 100
+ (string->number "100" 16) ===> 256
+ (string->number "1e2") ===> 100.0
+ (string->number "15##") ===> 1500.0
+
+Note: The domain of string->number may be restricted by
+implementations in the following ways. String->number is permitted
+to return #f whenever string contains an explicit radix prefix. If
+all numbers supported by an implementation are real, then string->
+number is permitted to return #f whenever string uses the polar or
+rectangular notations for complex numbers. If all numbers are
+integers, then string->number may return #f whenever the fractional
+notation is used. If all numbers are exact, then string->number may
+return #f whenever an exponent marker or explicit exactness prefix
+is used, or if a # appears in place of a digit. If all inexact
+numbers are integers, then string->number may return #f whenever a
+decimal point is used.
+
+=== Other data types
+
+This section describes operations on some of Scheme's non-numeric data
+types: booleans, pairs, lists, symbols, characters, strings and
+vectors.
+
+==== Booleans
+
+The standard boolean objects for true and false are written as #t and #f.
+What really matters, though, are the objects that the Scheme
+conditional expressions (if, cond, and, or, do) treat as true or false.
+The phrase "a true value" (or sometimes just "true") means any
+object treated as true by the conditional expressions, and the phrase
+"a false value" (or "false") means any object treated as false by
+the conditional expressions.
+
+Of all the standard Scheme values, only #f counts as false in
+conditional expressions. Except for #f, all standard Scheme values,
+including #t, pairs, the empty list, symbols, numbers, strings,
+vectors, and procedures, count as true.
+
+Note: Programmers accustomed to other dialects of Lisp should be
+aware that Scheme distinguishes both #f and the empty list from the
+symbol nil.
+
+Boolean constants evaluate to themselves, so they do not need to be
+quoted in programs.
+
+ #t ===> #t
+ #f ===> #f
+ '#f ===> #f
+
+<procedure>(not obj)</procedure><br>
+
+Not returns #t if obj is false, and returns #f otherwise.
+
+ (not #t) ===> #f
+ (not 3) ===> #f
+ (not (list 3)) ===> #f
+ (not #f) ===> #t
+ (not '()) ===> #f
+ (not (list)) ===> #f
+ (not 'nil) ===> #f
+
+<procedure>(boolean? obj)</procedure><br>
+
+Boolean? returns #t if obj is either #t or #f and returns #f otherwise.
+
+ (boolean? #f) ===> #t
+ (boolean? 0) ===> #f
+ (boolean? '()) ===> #f
+
+<procedure>(boolean=? boolean[1] boolean[2] boolean[3] ...)</procedure>
+
+Returns #t if all the arguments are #t or all are #f.
+
+==== Pairs and lists
+
+A pair (sometimes called a dotted pair) is a record structure with two
+fields called the car and cdr fields (for historical reasons). Pairs
+are created by the procedure cons. The car and cdr fields are accessed
+by the procedures car and cdr. The car and cdr fields are assigned by
+the procedures set-car! and set-cdr!.
+
+Pairs are used primarily to represent lists. A list can be defined
+recursively as either the empty list or a pair whose cdr is a list.
+More precisely, the set of lists is defined as the smallest set X such
+that
+
+* The empty list is in X.
+* If list is in X, then any pair whose cdr field contains list is
+ also in X.
+
+The objects in the car fields of successive pairs of a list are the
+elements of the list. For example, a two-element list is a pair whose
+car is the first element and whose cdr is a pair whose car is the
+second element and whose cdr is the empty list. The length of a list is
+the number of elements, which is the same as the number of pairs.
+
+The empty list is a special object of its own type (it is not a pair);
+it has no elements and its length is zero.
+
+Note: The above definitions imply that all lists have finite
+length and are terminated by the empty list.
+
+The most general notation (external representation) for Scheme pairs is
+the "dotted" notation (c[1] . c[2]) where c[1] is the value of the
+car field and c[2] is the value of the cdr field. For example (4 . 5)
+is a pair whose car is 4 and whose cdr is 5. Note that (4 . 5) is the
+external representation of a pair, not an expression that evaluates to
+a pair.
+
+A more streamlined notation can be used for lists: the elements of the
+list are simply enclosed in parentheses and separated by spaces. The
+empty list is written () . For example,
+
+ (a b c d e)
+
+and
+
+ (a . (b . (c . (d . (e . ())))))
+
+are equivalent notations for a list of symbols.
+
+A chain of pairs not ending in the empty list is called an improper
+list. Note that an improper list is not a list. The list and dotted
+notations can be combined to represent improper lists:
+
+ (a b c . d)
+
+is equivalent to
+
+ (a . (b . (c . d)))
+
+Whether a given pair is a list depends upon what is stored in the cdr
+field. When the set-cdr! procedure is used, an object can be a list one
+moment and not the next:
+
+ (define x (list 'a 'b 'c))
+ (define y x)
+ y ===> (a b c)
+ (list? y) ===> #t
+ (set-cdr! x 4) ===> unspecified
+ x ===> (a . 4)
+ (eqv? x y) ===> #t
+ y ===> (a . 4)
+ (list? y) ===> #f
+ (set-cdr! x x) ===> unspecified
+ (list? x) ===> #f
+
+Within literal expressions and representations of objects read by the
+read procedure, the forms '<datum>, `<datum>, ,<datum>, and ,@<datum>
+denote two-element lists whose first elements are the symbols quote,
+quasiquote, unquote, and unquote-splicing, respectively. The second
+element in each case is <datum>. This convention is supported so that
+arbitrary Scheme programs may be represented as lists. That is,
+according to Scheme's grammar, every <expression> is also a <datum>.
+Among other things, this permits the use of the read procedure to
+parse Scheme programs.
+
+<procedure>(pair? obj)</procedure><br>
+
+Pair? returns #t if obj is a pair, and otherwise returns #f.
+
+ (pair? '(a . b)) ===> #t
+ (pair? '(a b c)) ===> #t
+ (pair? '()) ===> #f
+ (pair? '#(a b)) ===> #f
+
+<procedure>(cons obj[1] obj[2])</procedure><br>
+
+Returns a newly allocated pair whose car is obj[1] and whose cdr is
+obj[2]. The pair is guaranteed to be different (in the sense of eqv?)
+from every existing object.
+
+ (cons 'a '()) ===> (a)
+ (cons '(a) '(b c d)) ===> ((a) b c d)
+ (cons "a" '(b c)) ===> ("a" b c)
+ (cons 'a 3) ===> (a . 3)
+ (cons '(a b) 'c) ===> ((a b) . c)
+
+<procedure>(car pair)</procedure><br>
+
+Returns the contents of the car field of pair. Note that it is an error
+to take the car of the empty list.
+
+ (car '(a b c)) ===> a
+ (car '((a) b c d)) ===> (a)
+ (car '(1 . 2)) ===> 1
+ (car '()) ===> error
+
+<procedure>(cdr pair)</procedure><br>
+
+Returns the contents of the cdr field of pair. Note that it is an error
+to take the cdr of the empty list.
+
+ (cdr '((a) b c d)) ===> (b c d)
+ (cdr '(1 . 2)) ===> 2
+ (cdr '()) ===> error
+
+<procedure>(set-car! pair obj)</procedure><br>
+
+Stores obj in the car field of pair. The value returned by set-car! is
+unspecified.
+
+ (define (f) (list 'not-a-constant-list))
+ (define (g) '(constant-list))
+ (set-car! (f) 3) ===> unspecified
+ (set-car! (g) 3) ===> error
+
+<procedure>(set-cdr! pair obj)</procedure><br>
+
+Stores obj in the cdr field of pair. The value returned by set-cdr! is
+unspecified.
+
+<procedure>(null? obj)</procedure><br>
+
+Returns #t if obj is the empty list, otherwise returns #f.
+
+<procedure>(list? obj)</procedure><br>
+
+Returns #t if obj is a list, otherwise returns #f. By definition, all
+lists have finite length and are terminated by the empty list.
+
+ (list? '(a b c)) ===> #t
+ (list? '()) ===> #t
+ (list? '(a . b)) ===> #f
+ (let ((x (list 'a)))
+ (set-cdr! x x)
+ (list? x)) ===> #f
+
+<procedure>(make-list k [fill]}</procedure>
+
+Returns a newly allocated list of k elements. If a second argument is given, then each element is initialized to {{fill}}. Otherwise the initial contents of each element is unspecified.
+
+ (make-list 2 3) ==> (3 3)
+
+<procedure>(list obj ...)</procedure><br>
+
+Returns a newly allocated list of its arguments.
+
+ (list 'a (+ 3 4) 'c) ===> (a 7 c)
+ (list) ===> ()
+
+<procedure>(length list)</procedure><br>
+
+Returns the length of list.
+
+ (length '(a b c)) ===> 3
+ (length '(a (b) (c d e))) ===> 3
+ (length '()) ===> 0
+
+<procedure>(append list ...)</procedure><br>
+
+Returns a list consisting of the elements of the first list followed by
+the elements of the other lists.
+
+ (append '(x) '(y)) ===> (x y)
+ (append '(a) '(b c d)) ===> (a b c d)
+ (append '(a (b)) '((c))) ===> (a (b) (c))
+
+The resulting list is always newly allocated, except that it shares
+structure with the last list argument. The last argument may actually
+be any object; an improper list results if the last argument is not a
+proper list.
+
+ (append '(a b) '(c . d)) ===> (a b c . d)
+ (append '() 'a) ===> a
+
+<procedure>(reverse list)</procedure><br>
+
+Returns a newly allocated list consisting of the elements of list in
+reverse order.
+
+ (reverse '(a b c)) ===> (c b a)
+ (reverse '(a (b c) d (e (f))))
+ ===> ((e (f)) d (b c) a)
+
+<procedure>(list-tail list k)</procedure><br>
+
+Returns the sublist of list obtained by omitting the first k elements.
+It is an error if list has fewer than k elements. List-tail could be
+defined by
+
+ (define list-tail
+ (lambda (x k)
+ (if (zero? k)
+ x
+ (list-tail (cdr x) (- k 1)))))
+
+<procedure>(list-ref list k)</procedure><br>
+
+Returns the kth element of list. (This is the same as the car of
+(list-tail list k).) It is an error if list has fewer than k elements.
+
+ (list-ref '(a b c d) 2) ===> c
+ (list-ref '(a b c d)
+ (inexact->exact (round 1.8)))
+ ===> c
+
+<procedure>(list-set! list k obj)</procedure>
+
+It is an error if k is not a valid index of list.
+
+The {{list-set!}} procedure stores obj in element k of list.
+
+ (let ((ls (list 'one 'two 'five!)))
+ (list-set! ls 2 'three)
+ ls)
+ ==> (one two three)
+
+ (list-set! '(0 1 2) 1 "oops")
+ ==> error ; constant list
+
+<procedure>(memq obj list)</procedure><br>
+<procedure>(memv obj list)</procedure><br>
+<procedure>(member obj list [compare])</procedure><br>
+
+These procedures return the first sublist of list whose car is obj,
+where the sublists of list are the non-empty lists returned by
+{{(list-tail list k)}} for k less than the length of list. If obj does not
+occur in list, then #f (not the empty list) is returned. {{memq}} uses {{eq?}}
+to compare obj with the elements of list, while {{memv}} uses {{eqv?}} and
+member {{compare}} if given, and {{equal?}} otherwise.
+
+ (memq 'a '(a b c)) ===> (a b c)
+ (memq 'b '(a b c)) ===> (b c)
+ (memq 'a '(b c d)) ===> #f
+ (memq (list 'a) '(b (a) c)) ===> #f
+ (member (list 'a)
+ '(b (a) c)) ===> ((a) c)
+ (memq 101 '(100 101 102)) ===> unspecified
+ (memv 101 '(100 101 102)) ===> (101 102)
+
+<procedure>(assq obj alist)</procedure><br>
+<procedure>(assv obj alist)</procedure><br>
+<procedure>(assoc obj alist [compare])</procedure><br>
+
+Alist (for "association list") must be a list of pairs. These
+procedures find the first pair in alist whose car field is obj, and
+returns that pair. If no pair in alist has obj as its car, then #f (not
+the empty list) is returned. {{assq}} uses {{eq?}} to compare obj with the car
+fields of the pairs in alist, while {{assv}} uses {{eqv?}} and {{assoc}} uses
+{{compare}}, if given, otherwise {{equal?}}.
+
+ (define e '((a 1) (b 2) (c 3)))
+ (assq 'a e) ===> (a 1)
+ (assq 'b e) ===> (b 2)
+ (assq 'd e) ===> #f
+ (assq (list 'a) '(((a)) ((b)) ((c))))
+ ===> #f
+ (assoc (list 'a) '(((a)) ((b)) ((c))))
+ ===> ((a))
+ (assq 5 '((2 3) (5 7) (11 13)))
+ ===> unspecified
+ (assv 5 '((2 3) (5 7) (11 13)))
+ ===> (5 7)
+
+Rationale: Although they are ordinarily used as predicates, memq,
+memv, member, assq, assv, and assoc do not have question marks in
+their names because they return useful values rather than just #t
+or #f.
+
+<procedure>(list-copy obj)</procedure>
+
+Returns a newly allocated copy of the given obj if it is a list. Only the pairs themselves are copied; the cars of the result are the same (in the sense of {{eqv?}}) as the cars of list. If obj is an improper list, so is the result, and the final cdrs are the same in
+the sense of {{eqv?}}. An obj which is not a list is returned unchanged. It is an error if
+obj is a circular list.
+
+ (define a '(1 8 2 8)) ; a may be immutable
+ (define b (list-copy a))
+ (set-car! b 3) ; b is mutable
+ b ==> (3 8 2 8)
+ a ==> (1 8 2 8)
+
+==== Symbols
+
+Symbols are objects whose usefulness rests on the fact that two symbols
+are identical (in the sense of eqv?) if and only if their names are
+spelled the same way. This is exactly the property needed to represent
+identifiers in programs, and so most implementations of Scheme use them
+internally for that purpose. Symbols are useful for many other
+applications; for instance, they may be used the way enumerated values
+are used in Pascal.
+
+The rules for writing a symbol are exactly the same as the rules for
+writing an identifier.
+
+It is guaranteed that any symbol that has been returned as part of a
+literal expression, or read using the read procedure, and subsequently
+written out using the write procedure, will read back in as the
+identical symbol (in the sense of eqv?). The string->symbol procedure,
+however, can create symbols for which this write/read invariance may
+not hold because their names contain special characters or letters in
+the non-standard case.
+
+Note: Some implementations of Scheme have a feature known as
+"slashification" in order to guarantee write/read invariance for
+all symbols, but historically the most important use of this
+feature has been to compensate for the lack of a string data type.
+
+Some implementations also have "uninterned symbols", which defeat
+write/read invariance even in implementations with slashification,
+and also generate exceptions to the rule that two symbols are the
+same if and only if their names are spelled the same.
+
+<procedure>(symbol? obj)</procedure><br>
+
+Returns #t if obj is a symbol, otherwise returns #f.
+
+ (symbol? 'foo) ===> #t
+ (symbol? (car '(a b))) ===> #t
+ (symbol? "bar") ===> #f
+ (symbol? 'nil) ===> #t
+ (symbol? '()) ===> #f
+ (symbol? #f) ===> #f
+
+<procedure>(symbol=? symbol[1] symbol[2] symbol[3] ...)</procedure>
+
+Returns #t if all the arguments all have the same names in the sense of {{string=?}}.
+
+Note: The definition above assumes that none of the arguments are uninterned symbols.
+
+<procedure>(symbol->string symbol)</procedure><br>
+
+Returns the name of symbol as a string. If the symbol was part of an
+object returned as the value of a literal expression (see
+"[[#literal-expressions|literal expressions]]") or by a call to the
+read procedure, and its name contains alphabetic characters, then the
+string returned will contain characters in the implementation's
+preferred standard case -- some implementations will prefer upper
+case, others lower case. If the symbol was returned by string->symbol,
+the case of characters in the string returned will be the same as the
+case in the string that was passed to string->symbol. It is an error
+to apply mutation procedures like string-set! to strings returned by
+this procedure.
+
+The following examples assume that the implementation's standard case
+is lower case:
+
+ (symbol->string 'flying-fish)
+ ===> "flying-fish"
+ (symbol->string 'Martin) ===> "martin"
+ (symbol->string
+ (string->symbol "Malvina"))
+ ===> "Malvina"
+
+<procedure>(string->symbol string)</procedure><br>
+
+Returns the symbol whose name is string. This procedure can create
+symbols with names containing special characters or letters in the
+non-standard case, but it is usually a bad idea to create such symbols
+because in some implementations of Scheme they cannot be read as
+themselves. See symbol->string.
+
+The following examples assume that the implementation's standard case
+is lower case:
+
+ (eq? 'mISSISSIppi 'mississippi)
+ ===> #t
+ (string->symbol "mISSISSIppi")
+ ===> the symbol with name "mISSISSIppi"
+ (eq? 'bitBlt (string->symbol "bitBlt"))
+ ===> #f
+ (eq? 'JollyWog
+ (string->symbol
+ (symbol->string 'JollyWog)))
+ ===> #t
+ (string=? "K. Harper, M.D."
+ (symbol->string
+ (string->symbol "K. Harper, M.D.")))
+ ===> #t
+
+==== Characters
+
+Characters are objects that represent printed characters such as
+letters and digits. Characters are written using the notation #\
+<character> or #\<character name>. For example:
+
+Characters are written using the notation {{#\<character>}} or {{#\<character name>}}
+or {{#\x<hex scalar value>}}.
+
+The following character names must be supported by all implementations with the
+given values. Implementations may add other names provided they cannot be
+interpreted as hex scalar values preceded by x.
+
+ #\alarm ; U+0007
+ #\backspace ; U+0008
+ #\delete ; U+007F
+ #\escape ; U+001B
+ #\newline ; the linefeed character, U+000A
+ #\null ; the null character, U+0000
+ #\return ; the return character, U+000D
+ #\space ; the preferred way to write a space
+ #\tab ; the tab character, U+0009
+
+Here are some additional examples:
+
+ #\a ; lower case letter
+ #\A ; upper case letter
+ #\( ; left parenthesis
+ #\ ; the space character
+ #\space ; the preferred way to write a space
+ #\newline ; the newline character
+
+Case is significant in #\<character>, but not in #\<character name>. If
+<character> in #\<character> is alphabetic, then the character
+following <character> must be a delimiter character such as a space or
+parenthesis. This rule resolves the ambiguous case where, for example,
+the sequence of characters "#\space" could be taken to be either a
+representation of the space character or a representation of the
+character "#\s" followed by a representation of the symbol "pace."
+
+Characters written in the #\ notation are self-evaluating. That is,
+they do not have to be quoted in programs. Some of the procedures that
+operate on characters ignore the difference between upper case and
+lower case. The procedures that ignore case have "-ci" (for "case
+insensitive") embedded in their names.
+
+<procedure>(char? obj)</procedure><br>
+
+Returns #t if obj is a character, otherwise returns #f.
+
+<procedure>(char=? char[1] char[2] char[3] ...)</procedure><br>
+<procedure>(char<? char[1] char[2] char[3] ...)</procedure><br>
+<procedure>(char>? char[1] char[2] char[3] ...)</procedure><br>
+<procedure>(char<=? char[1] char[2] char[3] ...)</procedure><br>
+<procedure>(char>=? char[1] char[2] char[3] ...)</procedure><br>
+
+These procedures impose a total ordering on the set of characters. It
+is guaranteed that under this ordering:
+
+* The upper case characters are in order. For example, (char<? #\A #\
+ B) returns #t.
+* The lower case characters are in order. For example, (char<? #\a #\
+ b) returns #t.
+* The digits are in order. For example, (char<? #\0 #\9) returns #t.
+* Either all the digits precede all the upper case letters, or vice
+ versa.
+* Either all the digits precede all the lower case letters, or vice
+ versa.
+
+Some implementations may generalize these procedures to take more than
+two arguments, as with the corresponding numerical predicates.
+
+<procedure>(char-ci=? char[1] char[2] char[3] ...)</procedure><br>
+<procedure>(char-ci<? char[1] char[2] char[3] ...)</procedure><br>
+<procedure>(char-ci>? char[1] char[2] char[3] ...)</procedure><br>
+<procedure>(char-ci<=? char[1] char[2] char[3] ...)</procedure><br>
+<procedure>(char-ci>=? char[1] char[2] char[3] ...)</procedure><br>
+
+These procedures are similar to char=? et cetera, but they treat upper
+case and lower case letters as the same. For example, (char-ci=? #\A #\
+a) returns #t. Some implementations may generalize these procedures to
+take more than two arguments, as with the corresponding numerical
+predicates.
+
+<procedure>(char-alphabetic? char)</procedure><br>
+<procedure>(char-numeric? char)</procedure><br>
+<procedure>(char-whitespace? char)</procedure><br>
+<procedure>(char-upper-case? letter)</procedure><br>
+<procedure>(char-lower-case? letter)</procedure><br>
+
+These procedures return #t if their arguments are alphabetic, numeric,
+whitespace, upper case, or lower case characters, respectively,
+otherwise they return #f. The following remarks, which are specific to
+the ASCII character set, are intended only as a guide: The alphabetic
+characters are the 52 upper and lower case letters. The numeric
+characters are the ten decimal digits. The whitespace characters are
+space, tab, line feed, form feed, and carriage return.
+
+<procedure>(char->integer char)</procedure><br>
+<procedure>(integer->char n)</procedure><br>
+
+Given a character, char->integer returns an exact integer
+representation of the character. Given an exact integer that is the
+image of a character under char->integer, integer->char returns that
+character. These procedures implement order-preserving isomorphisms
+between the set of characters under the char<=? ordering and some
+subset of the integers under the <= ordering. That is, if
+
+ (char<=? a b) ===> #t and (<= x y) ===> #t
+
+and x and y are in the domain of integer->char, then
+
+ (<= (char->integer a)
+ (char->integer b)) ===> #t
+
+ (char<=? (integer->char x)
+ (integer->char y)) ===> #t
+
+Note that {{integer->char}} does currently not detect
+a negative argument and will quietly convert {{-1}} to
+{{#x1ffff}} in CHICKEN.
+
+==== Strings
+
+Strings are sequences of characters. Strings are written as sequences of
+characters enclosed within quotation marks ("). Within a string literal,
+various escape sequences represent characters other than themselves. Escape
+sequences always start with a backslash (\):
+
+* \a : alarm, U+0007
+
+* \b : backspace, U+0008
+
+* \t : character tabulation, U+0009
+
+* \n : linefeed, U+000A
+
+* \r : return, U+000D
+
+* \" : double quote, U+0022
+
+* \\ : backslash, U+005C
+
+* \| : vertical line, U+007C
+
+* \<intraline whitespace>*<line ending> <intraline whitespace>* : nothing
+
+* \x<hex scalar value>; : specified character (note the terminating
+ semi-colon).
+
+The result is unspecified if any other character in a string occurs after a
+backslash.
+
+Except for a line ending, any character outside of an escape sequence stands
+for itself in the string literal. A line ending which is preceded by \
+<intraline whitespace> expands to nothing (along with any trailing intraline
+whitespace), and can be used to indent strings for improved legibility. Any
+other line ending has the same effect as inserting a \n character into the
+string.
+
+Examples:
+
+ "The word \"recursion\" has many meanings."
+ "Another example:\ntwo lines of text"
+ "Here's text \
+ containing just one line"
+ "\x03B1; is named GREEK SMALL LETTER ALPHA."
+
+The length of a string is the
+number of characters that it contains. This number is an exact, non-negative
+integer that is fixed when the string is created. The valid indexes of a string
+are the exact non-negative integers less than the length of the string. The
+first character of a string has index 0, the second has index 1, and so on.
+
+<procedure>(string? obj)</procedure><br>
+
+Returns #t if obj is a string, otherwise returns #f.
+
+<procedure>(make-string k)</procedure><br>
+<procedure>(make-string k char)</procedure><br>
+
+Make-string returns a newly allocated string of length k. If char is
+given, then all elements of the string are initialized to char,
+otherwise the contents of the string are unspecified.
+
+<procedure>(string char ...)</procedure><br>
+
+Returns a newly allocated string composed of the arguments.
+
+<procedure>(string-length string)</procedure><br>
+
+Returns the number of characters in the given string.
+
+<procedure>(string-ref string k)</procedure><br>
+
+k must be a valid index of string. String-ref returns character k of
+string using zero-origin indexing.
+
+<procedure>(string-set! string k char)</procedure><br>
+
+k must be a valid index of string. String-set! stores char in element k
+of string and returns an unspecified value.
+
+ (define (f) (make-string 3 #\*))
+ (define (g) "***")
+ (string-set! (f) 0 #\?) ===> unspecified
+ (string-set! (g) 0 #\?) ===> error
+ (string-set! (symbol->string 'immutable)
+ 0
+ #\?) ===> error
+
+<procedure>(string=? string[1] string[2] string[3] ...)</procedure><br>
+
+Returns #t if the two strings are the same length and contain the same
+characters in the same positions, otherwise returns #f.
+
+<procedure>(string<? string[1] string[2] string[3] ...)</procedure><br>
+<procedure>(string>? string[1] string[2] string[3] ...)</procedure><br>
+<procedure>(string<=? string[1] string[2] string[3] ...)</procedure><br>
+<procedure>(string>=? string[1] string[2] string[3] ...)</procedure><br>
+
+These procedures are the lexicographic extensions to strings of the
+corresponding orderings on characters. For example, string<? is the
+lexicographic ordering on strings induced by the ordering char<? on
+characters. If two strings differ in length but are the same up to the
+length of the shorter string, the shorter string is considered to be
+lexicographically less than the longer string.
+
+<procedure>(substring string start [end])</procedure><br>
+
+String must be a string, and start and end must be exact integers
+satisfying
+
+ 0 <= start <= end <= (string-length string)
+
+Substring returns a newly allocated string formed from the characters
+of string beginning with index start (inclusive) and ending with index
+end (exclusive). The {{end}} argument is optional and defaults to the
+length of the string, this is a non-standard extension in CHICKEN.
+
+<procedure>(string-append string ...)</procedure><br>
+
+Returns a newly allocated string whose characters form the
+concatenation of the given strings.
+
+<procedure>(string->list string [start [end]])</procedure><br>
+<procedure>(list->string list)</procedure><br>
+
+String->list returns a newly allocated list of the characters that make
+up the given string between start and end. List->string returns a newly allocated string
+formed from the characters in the list list, which must be a list of
+characters. String->list and list->string are inverses so far as equal?
+is concerned.
+
+<procedure>(string-copy string [start [end]])</procedure><br>
+
+Returns a newly allocated copy of the given string.
+
+<procedure>(string-copy! to at from [start [end]])</procedure>
+
+It is an error if at is less than zero or greater than the length of to. It is also an error if {{(- (string-length to) at)}} is less than {{(- end start)}}.
+
+Copies the characters of string from between start and end to string to, starting at
+at. The order in which characters are copied is unspecified, except that if the
+source and destination overlap, copying takes place as if the source is first
+copied into a temporary string and then into the destination. This can be
+achieved without allocating storage by making sure to copy in the correct
+direction in such circumstances.
+
+ (define a "12345")
+ (define b (string-copy "abcde"))
+ (string-copy! b 1 a 0 2)
+ b ==> "a12de"
+
+<procedure>(string-fill! string char +#!optional start end)</procedure><br>
+
+Stores char in every element of the given string and returns an
+unspecified value. The optional start and end arguments specify
+the part of the string to be filled and default to the complete string.
+
+==== Vectors
+
+Vectors are heterogenous structures whose elements are indexed by
+integers. A vector typically occupies less space than a list of the
+same length, and the average time required to access a randomly chosen
+element is typically less for the vector than for the list.
+
+The length of a vector is the number of elements that it contains. This
+number is a non-negative integer that is fixed when the vector is
+created. The valid indexes of a vector are the exact non-negative
+integers less than the length of the vector. The first element in a
+vector is indexed by zero, and the last element is indexed by one less
+than the length of the vector.
+
+Vectors are written using the notation #(obj ...). For example, a
+vector of length 3 containing the number zero in element 0, the list (2
+2 2 2) in element 1, and the string "Anna" in element 2 can be written
+as following:
+
+ #(0 (2 2 2 2) "Anna")
+
+Vector constants are self-evaluating, so they do not need
+to be quoted in programs.
+
+<procedure>(vector? obj)</procedure><br>
+
+Returns #t if obj is a vector, otherwise returns #f.
+
+<procedure>(make-vector k)</procedure><br>
+<procedure>(make-vector k fill)</procedure><br>
+
+Returns a newly allocated vector of k elements. If a second argument is
+given, then each element is initialized to fill. Otherwise the initial
+contents of each element is unspecified.
+
+<procedure>(vector obj ...)</procedure><br>
+
+Returns a newly allocated vector whose elements contain the given
+arguments. Analogous to list.
+
+ (vector 'a 'b 'c) ===> #(a b c)
+
+<procedure>(vector-length vector)</procedure><br>
+
+Returns the number of elements in vector as an exact integer.
+
+<procedure>(vector-ref vector k)</procedure><br>
+
+k must be a valid index of vector. Vector-ref returns the contents of
+element k of vector.
+
+ (vector-ref '#(1 1 2 3 5 8 13 21)
+ 5)
+ ===> 8
+ (vector-ref '#(1 1 2 3 5 8 13 21)
+ (let ((i (round (* 2 (acos -1)))))
+ (if (inexact? i)
+ (inexact->exact i)
+ i)))
+ ===> 13
+
+<procedure>(vector-set! vector k obj)</procedure><br>
+
+k must be a valid index of vector. Vector-set! stores obj in element k
+of vector. The value returned by vector-set! is unspecified.
+
+ (let ((vec (vector 0 '(2 2 2 2) "Anna")))
+ (vector-set! vec 1 '("Sue" "Sue"))
+ vec)
+ ===> #(0 ("Sue" "Sue") "Anna")
+
+ (vector-set! '#(0 1 2) 1 "doe")
+ ===> error ; constant vector
+
+<procedure>(vector->list vector [start [end]])</procedure><br>
+<procedure>(list->vector list)</procedure><br>
+
+Vector->list returns a newly allocated list of the objects contained in
+the elements of vector. List->vector returns a newly created vector
+initialized to the elements of the list list.
+
+ (vector->list '#(dah dah didah))
+ ===> (dah dah didah)
+ (list->vector '(dididit dah))
+ ===> #(dididit dah)
+
+<procedure>(vector-fill! vector fill)</procedure><br>
+
+Stores fill in every element of vector. The value returned by
+vector-fill! is unspecified.
+
+<procedure>(vector->string vector [start [end]])</procedure><br>
+<procedure(string->vector string [start [end]])</procedure>
+
+It is an error if any element of vector between start and end is not a character.
+
+The vector->string procedure returns a newly allocated string of the objects
+contained in the elements of vector between start and end. The string->vector procedure returns a newly created vector initialized to
+the elements of the string string between start and end.
+
+In both procedures, order is preserved.
+
+ (string->vector "ABC") ==> #(#\A #\B #\C)
+ (vector->string #(#\1 #\2 #\3) ==> "123"
+
+<procedure>(vector-copy vector [start [end]])</procedure>
+
+Returns a newly allocated copy of the elements of the given vector between
+start and end. The elements of the new vector are the same (in the sense of eqv?) as the
+elements of the old.
+
+ (define a #(1 8 2 8)) ; a may be immutable
+ (define b (vector-copy a))
+ (vector-set! b 0 3) ; b is mutable
+ b ==> #(3 8 2 8)
+ (define c (vector-copy b 1 3))
+ c ==> #(8 2)
+
+<procedure>(vector-copy! to at from [start [end]])</procedure>
+
+It is an error if at is less than zero or greater than the length of to. It is also an error if {{(- (vector-length to) at)}} is less than {{(- end start)}}.
+
+Copies the elements of vector from between start and end to vector to, starting at
+at. The order in which elements are copied is unspecified, except that if the
+source and destination overlap, copying takes place as if the source is first
+copied into a temporary vector and then into the destination. This can be
+achieved without allocating storage by making sure to copy in the correct
+direction in such circumstances.
+
+ (define a (vector 1 2 3 4 5))
+ (define b (vector 10 20 30 40 50))
+ (vector-copy! b 1 a 0 2)
+ b ==> #(10 1 2 40 50)
+
+<procedure>(vector-append vector ....)</procedure>
+
+Returns a newly allocated vector whose elements are the concatenation of the
+elements of the given vectors.
+
+ (vector-append #(a b c) #(d e f)) ==> #(a b c d e f)
+
+<procedure>(vector-fill! vector fill [start [end)]])</procedure>
+
+The vector-fill! procedure stores fill in the elements of vector between start and
+end.
+
+ (define a (vector 1 2 3 4 5))
+ (vector-fill! a 'smash 2 4)
+ a ==>#(1 2 smash smash 5)
+
+==== Bytevectors
+
+Bytevectors represent blocks of binary data. They are fixed-length sequences of
+bytes, where a byte is an exact integer in the range from 0 to 255 inclusive. A
+bytevector is typically more space-efficient than a vector containing the same
+values.
+
+See [[Module (chicken bytevector)|The (chicken bytevector) module]] for more
+information. {{(scheme base)}} re-exports all R7RS-specific procedures from
+that module.
+
+=== Control features
+
+This chapter describes various primitive procedures which control the
+flow of program execution in special ways. The procedure? predicate is
+also described here.
+
+<procedure>(procedure? obj)</procedure><br>
+
+Returns #t if obj is a procedure, otherwise returns #f.
+
+ (procedure? car) ===> #t
+ (procedure? 'car) ===> #f
+ (procedure? (lambda (x) (* x x)))
+ ===> #t
+ (procedure? '(lambda (x) (* x x)))
+ ===> #f
+ (call-with-current-continuation procedure?)
+ ===> #t
+
+<procedure>(apply proc arg[1] ... args)</procedure><br>
+
+Proc must be a procedure and args must be a list. Calls proc with the
+elements of the list (append (list arg[1] ...) args) as the actual
+arguments.
+
+ (apply + (list 3 4)) ===> 7
+
+ (define compose
+ (lambda (f g)
+ (lambda args
+ (f (apply g args)))))
+
+ ((compose sqrt *) 12 75) ===> 30
+
+<procedure>(map proc list[1] list[2] ...)</procedure><br>
+
+The lists must be lists, and proc must be a procedure taking as many
+arguments as there are lists and returning a single value. Map applies
+proc element-wise to the elements of the lists and returns a list of
+the results, in order. The dynamic order in which proc is applied to
+the elements of the lists is unspecified.
+
+Like in SRFI-1, this procedure allows the arguments to be of unequal
+length; it terminates when the shortest list runs out. This is a
+CHICKEN extension to R7RS.
+
+ (map cadr '((a b) (d e) (g h)))
+ ===> (b e h)
+
+ (map (lambda (n) (expt n n))
+ '(1 2 3 4 5))
+ ===> (1 4 27 256 3125)
+
+ (map + '(1 2 3) '(4 5 6)) ===> (5 7 9)
+
+ (let ((count 0))
+ (map (lambda (ignored)
+ (set! count (+ count 1))
+ count)
+ '(a b))) ===> (1 2) or (2 1)
+
+<procedure>(string-map proc string[1] string[2] ...)</procedure>
+
+It is an error if proc does not accept as many arguments as there are strings and return a single character.
+
+The string-map procedure applies proc element-wise to the elements of the
+strings and returns a string of the results, in order. If more than one
+string is given and not all strings have the same length, string-map terminates
+when the shortest string runs out. The dynamic order in which
+proc is applied to the elements of the
+strings is unspecified. If multiple returns occur from string-map, the values
+returned by earlier returns are not mutated.
+
+ (string-map char-foldcase "AbdEgH") ==> "abdegh"
+
+ (string-map
+ (lambda (c)
+ (integer->char (+ 1 (char->integer c))))
+ "HAL") ==> "IBM"
+
+ (string-map
+ (lambda (c k)
+ ((if (eqv? k #\u) char-upcase char-downcase)
+ c))
+ "studlycaps xxx"
+ "ululululul") ==> "StUdLyCaPs"
+
+<procedure>(vector-map proc vector[1] vector[2] ...)</procedure>
+
+It is an error if proc does not accept as many arguments as there are vectors and return a single value.
+
+The vector-map procedure applies proc element-wise to the elements of the
+vectors and returns a vector of the results, in order. If more than one
+vector is given and not all vectors have the same length, vector-map terminates
+when the shortest vector runs out. The dynamic order in which
+proc is applied to the elements of the
+vectors is unspecified. If multiple returns occur from vector-map, the values
+returned by earlier returns are not mutated.
+
+ (vector-map cadr '#((a b) (d e) (g h)))
+ ==> #(b e h)
+
+ (vector-map (lambda (n) (expt n n))
+ '#(1 2 3 4 5))
+ ==> #(1 4 27 256 3125)
+
+ (vector-map + '#(1 2 3) '#(4 5 6 7))
+ ==> #(5 7 9)
+
+ (let ((count 0))
+ (vector-map
+ (lambda (ignored)
+ (set! count (+ count 1))
+ count)
+ '#(a b))) ==> #(1 2) or #(2 1)
+
+<procedure>(for-each proc list[1] list[2] ...)</procedure><br>
+
+The arguments to for-each are like the arguments to map, but for-each
+calls proc for its side effects rather than for its values. Unlike map,
+for-each is guaranteed to call proc on the elements of the lists in
+order from the first element(s) to the last, and the value returned by
+for-each is unspecified.
+
+ (let ((v (make-vector 5)))
+ (for-each (lambda (i)
+ (vector-set! v i (* i i)))
+ '(0 1 2 3 4))
+ v) ===> #(0 1 4 9 16)
+
+Like in SRFI-1, this procedure allows the arguments to be of unequal
+length; it terminates when the shortest list runs out. This is a
+CHICKEN extension to R7RS.
+
+<procedure>(string-for-each proc string[1] string[2] ...)</procedure>
+
+It is an error if proc does not accept as many arguments as there are strings.
+The arguments to string-for-each are like the arguments to string-map, but
+string-for-each calls
+proc for its side effects rather than for its values. Unlike string-map,
+string-for-each is guaranteed to call
+proc on the elements of the
+strings in order from the first element(s) to the last, and the value returned
+by string-for-each is unspecified. If more than one
+string is given and not all strings have the same length, string-for-each
+terminates when the shortest string runs out. It is an error for
+proc to mutate any of the strings.
+
+ (let ((v '()))
+ (string-for-each
+ (lambda (c) (set! v (cons (char->integer c) v)))
+ "abcde")
+ v) ==> (101 100 99 98 97)
+
+<procedure>(vector-for-each proc vector[1] vector[2] ...)</procedure>
+
+It is an error if proc does not accept as many arguments as there are vectors.
+The arguments to vector-for-each are like the arguments to vector-map, but
+vector-for-each calls
+proc for its side effects rather than for its values. Unlike vector-map,
+vector-for-each is guaranteed to call
+proc on the elements of the
+vectors in order from the first element(s) to the last, and the value returned
+by vector-for-each is unspecified. If more than one
+vector is given and not all vectors have the same length, vector-for-each
+terminates when the shortest vector runs out. It is an error for
+proc to mutate any of the vectors.
+
+ (let ((v (make-list 5)))
+ (vector-for-each
+ (lambda (i) (list-set! v i (* i i)))
+ '#(0 1 2 3 4))
+ v) ==> (0 1 4 9 16)
+
+<procedure>(call-with-current-continuation proc)</procedure><br>
+<procedure>(call/cc proc)</procedure><br>
+
+Proc must be a procedure of one argument. The procedure
+call-with-current-continuation packages up the current continuation
+(see the rationale below) as an "escape procedure" and passes it as
+an argument to proc. The escape procedure is a Scheme procedure that,
+if it is later called, will abandon whatever continuation is in effect
+at that later time and will instead use the continuation that was in
+effect when the escape procedure was created. Calling the escape
+procedure may cause the invocation of before and after thunks installed
+using dynamic-wind.
+
+The escape procedure accepts the same number of arguments as the
+continuation to the original call to call-with-current-continuation.
+Except for continuations created by the call-with-values procedure, all
+continuations take exactly one value. The effect of passing no value or
+more than one value to continuations that were not created by
+call-with-values is unspecified.
+
+The escape procedure that is passed to proc has unlimited extent just
+like any other procedure in Scheme. It may be stored in variables or
+data structures and may be called as many times as desired.
+
+The following examples show only the most common ways in which
+call-with-current-continuation is used. If all real uses were as simple
+as these examples, there would be no need for a procedure with the
+power of call-with-current-continuation.
+
+ (call-with-current-continuation
+ (lambda (exit)
+ (for-each (lambda (x)
+ (if (negative? x)
+ (exit x)))
+ '(54 0 37 -3 245 19))
+ #t)) ===> -3
+
+ (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))))))
+
+ (list-length '(1 2 3 4)) ===> 4
+
+ (list-length '(a b . c)) ===> #f
+
+Rationale:
+
+A common use of call-with-current-continuation is for structured,
+non-local exits from loops or procedure bodies, but in fact
+call-with-current-continuation is extremely useful for implementing
+a wide variety of advanced control structures.
+
+Whenever a Scheme expression is evaluated there is a continuation
+wanting the result of the expression. The continuation represents
+an entire (default) future for the computation. If the expression
+is evaluated at top level, for example, then the continuation might
+take the result, print it on the screen, prompt for the next input,
+evaluate it, and so on forever. Most of the time the continuation
+includes actions specified by user code, as in a continuation that
+will take the result, multiply it by the value stored in a local
+variable, add seven, and give the answer to the top level
+continuation to be printed. Normally these ubiquitous continuations
+are hidden behind the scenes and programmers do not think much
+about them. On rare occasions, however, a programmer may need to
+deal with continuations explicitly. Call-with-current-continuation
+allows Scheme programmers to do that by creating a procedure that
+acts just like the current continuation.
+
+Most programming languages incorporate one or more special-purpose
+escape constructs with names like exit, return, or even goto. In
+1965, however, Peter Landin [16] invented a general purpose escape
+operator called the J-operator. John Reynolds [24] described a
+simpler but equally powerful construct in 1972. The catch special
+form described by Sussman and Steele in the 1975 report on Scheme
+is exactly the same as Reynolds's construct, though its name came
+from a less general construct in MacLisp. Several Scheme
+implementors noticed that the full power of the catch construct
+could be provided by a procedure instead of by a special syntactic
+construct, and the name call-with-current-continuation was coined
+in 1982. This name is descriptive, but opinions differ on the
+merits of such a long name, and some people use the name call/cc
+instead.
+
+<procedure>(values obj ...)</procedure><br>
+
+Delivers all of its arguments to its continuation. Except for
+continuations created by the call-with-values procedure, all
+continuations take exactly one value. Values might be defined as
+follows:
+
+ (define (values . things)
+ (call-with-current-continuation
+ (lambda (cont) (apply cont things))))
+
+<procedure>(call-with-values producer consumer)</procedure><br>
+
+Calls its producer argument with no values and a continuation that,
+when passed some values, calls the consumer procedure with those values
+as arguments. The continuation for the call to consumer is the
+continuation of the call to call-with-values.
+
+ (call-with-values (lambda () (values 4 5))
+ (lambda (a b) b))
+ ===> 5
+
+ (call-with-values * -) ===> -1
+
+<procedure>(dynamic-wind before thunk after)</procedure><br>
+
+Calls thunk without arguments, returning the result(s) of this call.
+Before and after are called, also without arguments, as required by the
+following rules (note that in the absence of calls to continuations
+captured using call-with-current-continuation the three arguments are
+called once each, in order). Before is called whenever execution enters
+the dynamic extent of the call to thunk and after is called whenever it
+exits that dynamic extent. The dynamic extent of a procedure call is
+the period between when the call is initiated and when it returns. In
+Scheme, because of call-with-current-continuation, the dynamic extent
+of a call may not be a single, connected time period. It is defined as
+follows:
+
+* The dynamic extent is entered when execution of the body of the
+ called procedure begins.
+
+* The dynamic extent is also entered when execution is not within the
+ dynamic extent and a continuation is invoked that was captured
+ (using call-with-current-continuation) during the dynamic extent.
+
+* It is exited when the called procedure returns.
+
+* It is also exited when execution is within the dynamic extent and a
+ continuation is invoked that was captured while not within the
+ dynamic extent.
+
+If a second call to dynamic-wind occurs within the dynamic extent of
+the call to thunk and then a continuation is invoked in such a way that
+the afters from these two invocations of dynamic-wind are both to be
+called, then the after associated with the second (inner) call to
+dynamic-wind is called first.
+
+If a second call to dynamic-wind occurs within the dynamic extent of
+the call to thunk and then a continuation is invoked in such a way that
+the befores from these two invocations of dynamic-wind are both to be
+called, then the before associated with the first (outer) call to
+dynamic-wind is called first.
+
+If invoking a continuation requires calling the before from one call to
+dynamic-wind and the after from another, then the after is called
+first.
+
+The effect of using a captured continuation to enter or exit the
+dynamic extent of a call to before or after is undefined. However,
+in CHICKEN it is safe to do this, and they will execute in the outer
+dynamic context of the {{dynamic-wind}} form.
+
+ (let ((path '())
+ (c #f))
+ (let ((add (lambda (s)
+ (set! path (cons s path)))))
+ (dynamic-wind
+ (lambda () (add 'connect))
+ (lambda ()
+ (add (call-with-current-continuation
+ (lambda (c0)
+ (set! c c0)
+ 'talk1))))
+ (lambda () (add 'disconnect)))
+ (if (< (length path) 4)
+ (c 'talk2)
+ (reverse path))))
+
+ ===> (connect talk1 disconnect
+ connect talk2 disconnect)
+
+=== Exceptions
+
+This section describes Scheme’s exception-handling and exception-raising
+procedures.
+
+Exception handlers are one-argument procedures that determine the action the
+program takes when an exceptional situation is signaled. The system implicitly
+maintains a current exception handler in the dynamic environment.
+
+The program raises an exception by invoking the current exception handler,
+passing it an object encapsulating information about the exception. Any
+procedure accepting one argument can serve as an exception handler and any
+object can be used to represent an exception.
+
+<procedure>(with-exception-handler handler thunk)</procedure>
+
+It is an error if handler does not accept one argument. It is also an error if
+thunk does not accept zero arguments.
+The with-exception-handler procedure returns the results of invoking
+thunk.
+Handler is installed as the current exception handler in the dynamic
+environment used for the invocation of
+thunk.
+
+ (call-with-current-continuation
+ (lambda (k)
+ (with-exception-handler
+ (lambda (x)
+ (display "condition: ")
+ (write x)
+ (newline)
+ (k 'exception))
+ (lambda ()
+ (+ 1 (raise 'an-error))))))
+ ==> exception and prints "condition: an-error"
+
+ (with-exception-handler
+ (lambda (x)
+ (display "something went wrong\n"))
+ (lambda ()
+ (+ 1 (raise 'an-error))))
+
+prints "something went wrong"
+After printing, the second example then raises another exception.
+
+<procedure>(raise obj)</procedure>
+
+Raises an exception by invoking the current exception handler on
+obj. The handler is called with the same dynamic environment as that of the
+call to raise, except that the current exception handler is the one that was in
+place when the handler being called was installed. If the handler returns, a
+secondary exception is raised in the same dynamic environment as the handler.
+The relationship between
+obj and the object raised by the secondary exception is unspecified.
+
+<procedure>(raise-continuable obj)</procedure>
+
+Raises an exception by invoking the current exception handler on
+obj. The handler is called with the same dynamic environment as the call to
+raise-continuable, except that: (1) the current exception handler is the one
+that was in place when the handler being called was installed, and (2) if the
+handler being called returns, then it will again become the current exception
+handler. If the handler returns, the values it returns become the values
+returned by the call to raise-continuable.
+
+ (with-exception-handler
+ (lambda (con)
+ (cond
+ ((string? con)
+ (display con))
+ (else
+ (display "a warning has been issued")))
+ 42)
+ (lambda ()
+ (+ (raise-continuable "should be a number")
+ 23)))
+ prints: "should be a number"
+ ==> 65
+
+<procedure>(error [location] message obj ...)</procedure>
+
+Message should be a string.
+Raises an exception as if by calling raise on a newly allocated
+implementation-defined object which encapsulates the information provided by
+message, as well as any
+objs, known as the irritants. The procedure error-object? must return #t on
+such objects.
+
+ (define (null-list? l)
+ (cond ((pair? l) #f)
+ ((null? l) #t)
+ (else
+ (error
+ "null-list?: argument out of domain"
+ l))))
+
+If location is given and a symbol, it indicates the name of the procedure where
+the error occurred.
+
+<procedure>(error-object? obj)</procedure>
+
+Returns #t if
+obj is an object created by error or one of an implementation-defined set of
+objects. Otherwise, it returns #f. The objects used to signal errors, including
+those which satisfy the predicates file-error? and read-error?, may or may not
+satisfy error-object?.
+
+<procedure>(error-object-message error-object)</procedure>
+
+Returns the message encapsulated by
+error-object.
+
+<procedure>(error-object-irritants error-object)</procedure>
+
+Returns a list of the irritants encapsulated by
+error-object.
+
+<procedure>(read-error? obj)</procedure><br>
+<procedure>(file-error? obj)</procedure>
+
+Error type predicates. Returns #t if
+obj is an object raised by the read procedure or by the inability to open an
+input or output port on a file, respectively. Otherwise, it returns #f.
+
+=== Eval
+
+<procedure>(eval expression [environment-specifier])</procedure><br>
+
+Evaluates expression in the specified environment and returns its
+value. Expression must be a valid Scheme expression represented as
+data, and environment-specifier must be a value returned by one of the
+three procedures described below. Implementations may extend eval to
+allow non-expression programs (definitions) as the first argument and
+to allow other values as environments, with the restriction that eval
+is not allowed to create new bindings in the environments associated
+with null-environment or scheme-report-environment.
+
+ (eval '(* 7 3) (scheme-report-environment 5))
+ ===> 21
+
+ (let ((f (eval '(lambda (f x) (f x x))
+ (null-environment 5))))
+ (f + 10))
+ ===> 20
+
+The {{environment-specifier}} is optional, and if not provided it
+defaults to the value of {{(interaction-environment)}}. This is a
+CHICKEN extension to R7RS, which, though strictly nonportable, is very
+common among Scheme implementations.
+
+=== Input and output
+
+==== Ports
+
+Ports represent input and output devices. To Scheme, an input port is a Scheme
+object that can deliver data upon command, while an output port is a Scheme
+object that can accept data.
+
+Different port types operate on different data. Scheme implementations are
+required to support textual ports and binary ports, but may also provide other
+port types.
+
+A textual port supports reading or writing of individual characters from or to
+a backing store containing characters using read-char and write-char below, and
+it supports operations defined in terms of characters, such as read and write.
+
+A binary port supports reading or writing of individual bytes from or to a
+backing store containing bytes using read-u8 and write-u8 below, as well as
+operations defined in terms of bytes. Whether the textual and binary port types
+are disjoint is implementation-dependent.
+
+Ports can be used to access files, devices, and similar things on the host
+system on which the Scheme program is running.
+
+<procedure>(call-with-port port proc)</procedure>
+
+It is an error if
+proc does not accept one argument.
+The call-with-port procedure calls
+proc with
+port as an argument. If
+proc returns, then the port is closed automatically and the values yielded by
+the
+proc are returned. If
+
+proc does not return, then the port must not be closed automatically unless it
+is possible to prove that the port will never again be used for a read or write
+operation.
+
+ Rationale: Because Scheme’s escape procedures have unlimited extent, it is
+ possible to escape from the current continuation but later to resume it. If
+ implementations were permitted to close the port on any escape from the
+ current continuation, then it would be impossible to write portable code
+ using both call-with-current-continuation and call-with-port.
+
+Ports represent input and output devices. To Scheme, an input port is a
+Scheme object that can deliver characters upon command, while an output
+port is a Scheme object that can accept characters.
+
+<procedure>(input-port? obj)</procedure><br>
+<procedure>(output-port? obj)</procedure><br>
+<procedure>(textual-port? obj)</procedure><br>
+<procedure>(binary-port? obj)</procedure><br>
+<procedure>(port? obj)</procedure>
+
+These procedures return #t if
+obj is an input port, output port, textual port, binary port, or any kind of
+port, respectively. Otherwise they return #f.
+
+<procedure>(input-port-open? port)</procedure><br>
+<procedure>(output-port-open? port)</procedure>
+
+Returns #t if
+port is still open and capable of performing input or output, respectively, and
+#f otherwise.
+
+<procedure>(current-input-port [port])</procedure><br>
+<procedure>(current-output-port [port])</procedure><br>
+<procedure>(current-error-port [port])</procedure><br>
+
+Returns the current default input, output or error port.
+
+If the optional {{port}} argument is passed, the current input or
+output port is changed to the provided port. It can also be used with
+{{parameterize}} to temporarily bind the port to another value. This
+is a CHICKEN extension to the R7RS standard.
+
+Note that the default output port is not buffered. Use
+[[Module (chicken port)#set-buffering-mode!|{{set-buffering-mode!}}]]
+if you need a different behavior.
+
+<procedure>(open-input-file filename [mode ...])</procedure><br>
+<procedure>(open-binary-input-file filename [mode ...])</procedure>
+
+Takes a string naming an existing file and returns an input port
+capable of delivering textual or binary data from the file. If the file cannot be
+opened, an error is signalled.
+
+Additional {{mode}} arguments can be passed in, which should be any of
+the keywords {{#:text}} or {{#:binary}}. These indicate the mode in
+which to open the file (this has an effect on non-UNIX platforms
+only). The extra {{mode}} arguments are CHICKEN extensions to the
+R7RS standard.
+
+<procedure>(close-port port)</procedure><br>
+<procedure>(close-input-port port)</procedure><br>
+<procedure>(close-output-port port)</procedure><br>
+
+Closes the resource associated with
+port, rendering the
+port incapable of delivering or accepting data. It is an error to apply the
+last two procedures to a port which is not an input or output port,
+respectively. Scheme implementations may provide ports which are simultaneously
+input and output ports, such as sockets; the close-input-port and
+close-output-port procedures can then be used to close the input and output
+sides of the port independently.
+
+These routines have no effect if the port has already been closed.
+
+<procedure>(open-input-string string)</procedure>
+
+Takes a string and returns a textual input port that delivers characters from
+the string. If the string is modified, the effect is unspecified.
+
+<procedure>(open-output-string)</procedure>
+
+Returns a textual output port that will accumulate characters for retrieval by
+get-output-string.
+
+<procedure>(get-output-string port)</procedure>
+
+It is an error if
+port was not created with open-output-string.
+Returns a string consisting of the characters that have been output to the port
+so far in the order they were output. If the result string is modified, the
+effect is unspecified.
+
+ (parameterize
+ ((current-output-port
+ (open-output-string)))
+ (display "piece")
+ (display " by piece ")
+ (display "by piece.")
+ (newline)
+ (get-output-string (current-output-port)))
+ ==> "piece by piece by piece.\n"
+
+<procedure>(open-input-bytevector bytevector)</procedure>
+
+Takes a bytevector and returns a binary input port that delivers bytes from the
+bytevector.
+
+<procedure>(open-output-bytevector)</procedure>
+
+Returns a binary output port that will accumulate bytes for retrieval by
+get-output-bytevector.
+
+<procedure>(get-output-bytevector port)</procedure>
+
+It is an error if
+port was not created with open-output-bytevector.
+Returns a bytevector consisting of the bytes that have been output to the port
+so far in the order they were output.
+
+==== Input
+
+If port is omitted from any input procedure, it defaults to the value returned by
+(current-input-port). It is an error to attempt an input operation on a closed
+port.
+
+<procedure>(read-char [port])</procedure><br>
+
+Returns the next character available from the input port, updating the
+port to point to the following character. If no more characters are
+available, an end of file object is returned. Port may be omitted, in
+which case it defaults to the value returned by current-input-port.
+
+<procedure>(peek-char [port])</procedure><br>
+
+Returns the next character available from the input port, without
+updating the port to point to the following character. If no more
+characters are available, an end of file object is returned. Port may
+be omitted, in which case it defaults to the value returned by
+current-input-port.
+
+Note: The value returned by a call to peek-char is the same as
+the value that would have been returned by a call to read-char with
+the same port. The only difference is that the very next call to
+read-char or peek-char on that port will return the value returned
+by the preceding call to peek-char. In particular, a call to
+peek-char on an interactive port will hang waiting for input
+whenever a call to read-char would have hung.
+
+<procedure>(read-line [port])</procedure>
+
+Returns the next line of text available from the textual input
+port, updating the
+port to point to the following character. If an end of line is read, a string
+containing all of the text up to (but not including) the end of line is
+returned, and the port is updated to point just past the end of line. If an end
+of file is encountered before any end of line is read, but some characters have
+been read, a string containing those characters is returned. If an end of file
+is encountered before any characters are read, an end-of-file object is
+returned. For the purpose of this procedure, an end of line consists of either
+a linefeed character, a carriage return character, or a sequence of a carriage
+return character followed by a linefeed character. Implementations may also
+recognize other end of line characters or sequences.
+
+<procedure>(eof-object? obj)</procedure><br>
+
+Returns #t if obj is an end of file object, otherwise returns #f. The
+precise set of end of file objects will vary among implementations, but
+in any case no end of file object will ever be an object that can be
+read in using read.
+
+<procedure>(eof-object)</procedure>
+
+Returns an end-of-file object, not necessarily unique.
+
+<procedure>(char-ready? [port])</procedure><br>
+
+Returns #t if a character is ready on the input port and returns #f
+otherwise. If char-ready returns #t then the next read-char operation
+on the given port is guaranteed not to hang. If the port is at end of
+file then char-ready? returns #t. Port may be omitted, in which case it
+defaults to the value returned by current-input-port.
+
+Rationale: Char-ready? exists to make it possible for a program
+to accept characters from interactive ports without getting stuck
+waiting for input. Any input editors associated with such ports
+must ensure that characters whose existence has been asserted by
+char-ready? cannot be rubbed out. If char-ready? were to return #f
+at end of file, a port at end of file would be indistinguishable
+from an interactive port that has no ready characters.
+
+<procedure>(read-string k [port])</procedure>
+
+See [[Module (chicken io)|(chicken io) module]] for more information.
+
+<procedure>(read-u8 [port])</procedure>
+
+Returns the next byte available from the binary input
+port, updating the
+port to point to the following byte. If no more bytes are available, an
+end-of-file object is returned.
+
+<procedure>(peek-u8 [port])</procedure>
+
+Returns the next byte available from the binary input
+port, but without updating the
+port to point to the following byte. If no more bytes are available, an
+end-of-file object is returned.
+
+<procedure>(u8-ready? [port])</procedure>
+
+Returns #t if a byte is ready on the binary input
+port and returns #f otherwise. If u8-ready? returns #t then the next read-u8
+operation on the given
+port is guaranteed not to hang. If the
+port is at end of file then u8-ready?​ ​returns #t.
+
+<procedure>(read-bytevector k [port])</procedure><br>
+<procedure>(read-bytevector! bytevector [port [start [end]]])</procedure>
+
+See [[Module (chicken io)|(chicken io) module]] for more information.
+
+==== Output
+
+If port is omitted from any output procedure, it defaults to the value returned by
+(current-output-port). It is an error to attempt an output operation on a
+closed port.
+
+<procedure>(newline)</procedure><br>
+<procedure>(newline port)</procedure><br>
+
+Writes an end of line to port. Exactly how this is done differs from
+one operating system to another. Returns an unspecified value. The port
+argument may be omitted, in which case it defaults to the value
+returned by current-output-port.
+
+<procedure>(write-char char)</procedure><br>
+<procedure>(write-char char port)</procedure><br>
+
+Writes the character char (not an external representation of the
+character) to the given port and returns an unspecified value. The port
+argument may be omitted, in which case it defaults to the value
+returned by current-output-port.
+
+<procedure>(write-string string [port [start [end]]])</procedurew>
+
+Writes the characters of
+string from
+start to
+end in left-to-right order to the textual output
+port.
+
+<procedure>(write-u8 byte [port])</procedure>
+
+Writes the
+byte to the given binary output
+port and returns an unspecified value.
+
+<procedure>(write-bytevector bytevector [port [start [end]]])</procedure>
+
+See [[Module (chicken bytevector)|The (chicken bytevector) module]] for more
+information.
+
+<procedure>(flush-output-port [port])</procedure>
+
+Flushes any buffered output from the buffer of output-port to the underlying
+file or device and returns an unspecified value.
+
+==== System interface
+
+Questions of system interface generally fall outside of the domain of
+this report. However, the following operations are important enough to
+deserve description here.
+
+<procedure>(features)</procedure>
+
+Returns a list of the feature identifiers which cond-expand treats as true. It
+is an error to modify this list. Here is an example of what features might
+return:
+
+ (features) ==>
+ (r7rs ratios exact-complex full-unicode
+ gnu-linux little-endian
+ fantastic-scheme
+ fantastic-scheme-1.0
+ space-ship-control-system)
+
+---
+Previous: [[Module scheme]]
+
+Next: [[Module (scheme case-lambda)]]
diff --git a/manual/Module (scheme case-lambda) b/manual/Module (scheme case-lambda)
new file mode 100644
index 00000000..61578182
--- /dev/null
+++ b/manual/Module (scheme case-lambda)
@@ -0,0 +1,37 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module (scheme case-lambda)
+
+<macro>(case-lambda <clause> ...)</macro>
+
+Syntax: Each <clause> is of the form (<formals> <body>), where <formals> and
+<body> have the same syntax as in a lambda expression.
+
+Semantics: A case-lambda expression evaluates to a procedure that accepts a
+variable number of arguments and is lexically scoped in the same manner as a
+procedure resulting from a lambda expression. When the procedure is called, the
+first <clause> for which the arguments agree with <formals> is selected, where
+agreement is specified as for the <formals> of a lambda expression. The
+variables of <formals> are bound to fresh locations, the values of the
+arguments are stored in those locations, the <body> is evaluated in the
+extended environment, and the results of <body> are returned as the results of
+the procedure call.
+
+It is an error for the arguments not to agree with the <formals> of any
+<clause>.
+
+ (define range
+ (case-lambda
+ ((e) (range 0 e))
+ ((b e) (do ((r '() (cons e r))
+ (e (- e 1) (- e 1)))
+ ((< e b) r)))))
+
+ (range 3) ==> (0 1 2)
+ (range 3 5) ==> (3 4)
+
+---
+Previous: [[Module (scheme base)]]
+
+Next: [[Module (scheme char))]]
diff --git a/manual/Module (scheme char) b/manual/Module (scheme char)
new file mode 100644
index 00000000..49a0f8c1
--- /dev/null
+++ b/manual/Module (scheme char)
@@ -0,0 +1,95 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module (scheme char)
+
+R7RS Operations on characters.
+
+<procedure>(char-ci=? char[1] char[2] char[3] ...)</procedure><br>
+<procedure>(char-ci>? char[1] char[2] char[3] ...)</procedure><br>
+<procedure>(char-ci<? char[1] char[2] char[3] ...)</procedure><br>
+<procedure>(char-ci>=? char[1] char[2] char[3] ...)</procedure><br>
+<procedure>(char-ci<=? char[1] char[2] char[3] ...)</procedure><br>
+
+These procedures are similar to char=?​ ​et cetera, but they treat upper case
+and lower case letters as the same. For example, {{(char-ci=?​ ​#\A #\a)}} returns
+#t.
+
+Specifically, these procedures behave as if char-foldcase were applied to their
+arguments before they were compared.
+
+<procedure>(char-alphabetic? char)</procedure><br>
+<procedure>(char-numeric? char)</procedure><br>
+<procedure>(char-whitespace? char)</procedure><br>
+<procedure>(char-upper-case? letter)</procedure><br>
+<procedure>(char-lower-case? letter)</procedure><br>
+
+These procedures return #t if their arguments are alphabetic, numeric,
+whitespace, upper case, or lower case characters, respectively, otherwise they
+return #f. Specifically, they must return #t when applied to characters with
+the Unicode properties Alphabetic, Numeric_Type=Decimal, White_Space,
+Uppercase, and Lowercase respectively, and #f when applied to any other Unicode
+characters. Note that many Unicode characters are alphabetic but neither upper
+nor lower case.
+
+<procedure>(digit-value char)</procedure>
+
+This procedure returns the numeric value (0 to 9) of its argument if it is a
+numeric digit (that is, if char-numeric? returns #t), or #f on any other
+character.
+
+ (digit-value #\3) ==> 3
+ (digit-value #\x0664) ==> 4
+ (digit-value #\x0AE6) ==> 0
+ (digit-value #\x0EA6) ==> #f
+
+<procedure>(char-upcase char)</procedure><br>
+<procedure>(char-downcase char)</procedure><br>
+<procedure>(char-foldcase char)</procedure><br>
+
+The char-upcase procedure, given an argument that is the lowercase part of a
+Unicode casing pair, returns the uppercase member of the pair. Note that
+language-sensitive casing pairs are not used. If the argument is not the
+lowercase member of such a pair, it is returned.
+
+The char-downcase procedure, given an argument that is the uppercase part of a
+Unicode casing pair, returns the lowercase member of the pair. Note that
+language-sensitive casing pairs are not used. If the argument is not the
+uppercase member of such a pair, it is returned.
+
+The char-foldcase procedure applies the Unicode simple case-folding algorithm
+to its argument and returns the result. Note that language-sensitive folding is
+not used. If the character that results from folding is not supported by the
+implementation, the argument is returned. See UAX #44 (part of the Unicode
+Standard) for details.
+
+Note that many Unicode lowercase characters do not have uppercase equivalents.
+
+<procedure>(string-ci=? string[1] string[2] string[3] ...)</procedure><br>
+<procedure>(string-ci<? string[1] string[2] string[3] ...)</procedure><br>
+<procedure>(string-ci>? string[1] string[2] string[3] ...)</procedure><br>
+<procedure>(string-ci<=? string[1] string[2] string[3] ...)</procedure><br>
+<procedure>(string-ci>=? string[1] string[2] string[3] ...)</procedure><br>
+
+The "-ci" procedures behave as if they applied string-foldcase to their
+arguments before invoking the corresponding procedures without “-ciâ€.
+
+<procedure>(string-upcase string)</procedure><br>
+<procedure>(string-downcase string)</procedure><br>
+<procedure>(string-foldcase string)</procedure><br>
+
+These procedures apply the Unicode full string uppercasing, lowercasing, and
+case-folding algorithms to their arguments and return the result. In certain
+cases, the result differs in length from the argument. If the result is equal
+to the argument in the sense of string=?, the argument may be returned. Note
+that language-sensitive mappings and foldings are not used. The Unicode
+Standard prescribes special treatment of the Greek letter Σ, whose normal
+lower-case form is σ but which becomes ς at the end of a word. See UAX #44
+(part of the Unicode Standard) for details. However, implementations of
+string-downcase are not required to provide this behavior, and may choose to
+change Σ to σ in all cases.
+
+---
+Previous: [[Module (scheme case-lambda)]]
+
+Next: [[Module (scheme complex)]]
diff --git a/manual/Module (scheme complex) b/manual/Module (scheme complex)
new file mode 100644
index 00000000..8bf504c0
--- /dev/null
+++ b/manual/Module (scheme complex)
@@ -0,0 +1,46 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module (scheme complex)
+
+
+R7RS Operations on complex numbers.
+
+
+<procedure>(make-rectangular x[1] x[2])</procedure><br>
+<procedure>(make-polar x[3] x[4])</procedure><br>
+<procedure>(real-part z)</procedure>
+<procedure>(imag-part z)</procedure>
+<procedure>(magnitude z)</procedure>
+<procedure>(angle z)</procedure>
+
+Let x[1], x[2], x[3] and x[4] be real numbers and z be a complex number such that
+
+ z = x[1] + x[2] * i = x[3] * e^(i * x[4])
+
+Then all of
+
+ (make-rectangular x[1] x[2]) ==> z
+ (make-polar x[3] x[4]) ==> z
+ (real-part z) ==> x[1]
+ (imag-part z) ==> x[2]
+ (magnitude z) ==> |x[3]|
+ (angle z) ==> x[angle]
+
+are true, where
+
+ −π ≤ x[angle] ≤ π with x[angle] = x[4] + 2 * π * n for some integer n.
+
+The make-polar procedure may return an inexact complex number even if its
+arguments are exact. The real-part and imag-part procedures may return exact
+real numbers when applied to an inexact complex number if the corresponding
+argument passed to make-rectangular was exact.
+
+Rationale: The magnitude procedure is the same as abs for a real argument,
+but abs is in the base library, whereas magnitude is in the optional
+complex library.
+
+---
+Previous: [[Module (scheme char)]]
+
+Next: [[Module (scheme cxr)]]
diff --git a/manual/Module (scheme cxr) b/manual/Module (scheme cxr)
new file mode 100644
index 00000000..63ba3708
--- /dev/null
+++ b/manual/Module (scheme cxr)
@@ -0,0 +1,42 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module (scheme cxr)
+
+<procedure>(caaar x)</procedure><br>
+<procedure>(caadr x)</procedure><br>
+<procedure>(cadar x)</procedure><br>
+<procedure>(cdaar x)</procedure><br>
+<procedure>(cdadr x)</procedure><br>
+<procedure>(cddar x)</procedure><br>
+<procedure>(cdddr x)</procedure><br>
+<procedure>(caaaar x)</procedure><br>
+<procedure>(caaadr x)</procedure><br>
+<procedure>(caadar x)</procedure><br>
+<procedure>(caaddr x)</procedure><br>
+<procedure>(cadaar x)</procedure><br>
+<procedure>(cadadr x)</procedure><br>
+<procedure>(caddar x)</procedure><br>
+<procedure>(cadddr x)</procedure><br>
+<procedure>(cdaaar x)</procedure><br>
+<procedure>(cdaadr x)</procedure><br>
+<procedure>(cdadar x)</procedure><br>
+<procedure>(cdaddr x)</procedure><br>
+<procedure>(cddaar x)</procedure><br>
+<procedure>(cddadr x)</procedure><br>
+<procedure>(cdddar x)</procedure><br>
+<procedure>(cddddr x)</procedure><br>
+
+These twenty-four procedures are further compositions of car and cdr on the
+same principles. For example, caddr could be defined by
+
+ (define caddr (lambda (x) (car (cdr (cdr x)))))
+
+Arbitrary compositions up to
+four deep are provided.
+
+
+---
+Previous: [[Module (scheme complex)]]
+
+Next: [[Module (scheme file)]]
diff --git a/manual/Module (scheme eval) b/manual/Module (scheme eval)
new file mode 100644
index 00000000..fd975eae
--- /dev/null
+++ b/manual/Module (scheme eval)
@@ -0,0 +1,42 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module (scheme eval)
+
+This module provides R7RS procedures to evaluate expressions dynamically.
+
+=== environment
+
+<procedure>(environment LIST ...)</procedure>
+
+This procedure returns a specifier for the environment that
+results by starting with an empty environment and then
+importing each list, considered as an import set, into it.
+(See section 5.6 of R7RS for a description of import sets.) The
+bindings of the environment represented by the specifier
+are immutable, as is the environment itself.
+
+=== eval
+
+<procedure>(eval EXPR-OR-DEF [ENVIRONMENT-SPECIFIER])</procedure>
+
+If EXPR-OR-DEF is an expression, it is evaluated in the specified environment and its values are returned. If it is a definition, the specified identifier(s) are defined in the specified
+environment, provided the environment is not immutable.
+
+The {{ENVIRONMENT-SPECIFIER}} is optional, and if not provided it
+defaults to the value of {{(interaction-environment)}}. This is a
+CHICKEN extension to R7RS, which, though strictly nonportable, is very
+common among Scheme implementations.
+
+ (eval '(* 7 3) (environment '(scheme base)))
+ ==> 21
+
+ (let ((f (eval '(lambda (f x) (f x x))
+ (null-environment 5))))
+ (f + 10))
+ ==> 20
+
+---
+Previous: [[Module (scheme file)]]
+
+Next: [[Module (scheme inexact)]]
diff --git a/manual/Module (scheme file) b/manual/Module (scheme file)
new file mode 100644
index 00000000..594e14f7
--- /dev/null
+++ b/manual/Module (scheme file)
@@ -0,0 +1,68 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module (scheme file)
+
+<procedure>(call-with-input-file string proc)</procedure><br>
+<procedure>(call-with-output-file string proc)</procedure>
+
+It is an error if proc does not accept one argument.
+
+These procedures obtain a textual port obtained by opening the named file for
+input or output as if by open-input-file or open-output-file. The port and
+proc are then passed to a procedure equivalent to call-with-port.
+
+<procedure>(with-input-from-file string thunk)</procedure><br>
+<procedure>(with-output-to-file string thunk)</procedure><br>
+
+The file is opened for input or output as if by open-input-file or
+open-output-file, and the new port is made to be the value returned by
+current-input-port or current-output-port (as used by {{(read)}}, {{(write obj)}}, and so forth). The
+thunk is then called with no arguments. When the
+thunk returns, the port is closed and the previous default is restored. It is
+an error if
+thunk does not accept zero arguments. Both procedures return the values yielded
+by
+thunk. If an escape procedure is used to escape from the continuation of these
+procedures, they behave exactly as if the current input or output port had been
+bound dynamically with parameterize.
+
+<procedure>(open-input-file string)</procedure><br>
+<procedure>(open-binary-input-file string)</procedure><br>
+
+Takes a
+string for an existing file and returns a textual input port or binary input
+port that is capable of delivering data from the file. If the file does not
+exist or cannot be opened, an error that satisfies file-error? is signaled.
+
+<procedure>(open-output-file string)</procedure><br>
+<procedure>(open-binary-output-file string)</procedure><br>
+
+Takes a
+string naming an output file to be created and returns a textual output port or
+binary output port that is capable of writing data to a new file by that name.
+If a file with the given name already exists, the effect is unspecified. If the
+file cannot be opened, an error that satisfies file-error? is signaled.
+
+<procedure>(file-exists? filename)</procedure><br>
+
+It is an error if
+filename is not a string.
+
+The file-exists? procedure returns #t if the named file exists at the time the
+procedure is called, and #f otherwise.
+
+<procedure>(delete-file filename)</procedure><br>
+
+It is an error if
+filename is not a string.
+
+The delete-file procedure deletes the named file if it exists and can be
+deleted, and returns an unspecified value. If the file does not exist or cannot
+be deleted, an error that satisfies file-error? is signaled.
+
+---
+Previous: [[Module (scheme complex)]]
+
+Next: [[Module (scheme
+ eval)]]
diff --git a/manual/Module (scheme inexact) b/manual/Module (scheme inexact)
new file mode 100644
index 00000000..32a7b332
--- /dev/null
+++ b/manual/Module (scheme inexact)
@@ -0,0 +1,71 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module (scheme inexact)
+
+The R7RS (scheme inexact) library exports procedures which
+are typically only useful with inexact values.
+
+<procedure>(exp z)</procedure><br>
+<procedure>(log z [z2])</procedure><br>
+<procedure>(sin z)</procedure><br>
+<procedure>(cos z)</procedure><br>
+<procedure>(tan z)</procedure><br>
+<procedure>(asin z)</procedure><br>
+<procedure>(acos z)</procedure><br>
+<procedure>(atan x [y])</procedure>
+
+These procedures compute the usual transcendental functions. The log procedure
+computes the natural logarithm of z (not the base ten logarithm) if a single argument is given, or the base-z2 logarithm of
+z if two arguments are given. The asin, acos, and atan procedures compute
+arcsine (sin^−1), arc-cosine (cos^−1), and arctangent (tan^−1),
+respectively. The two-argument variant of atan computes {{(angle (make-rectangular x y))}}
+ (see below), even in implementations that don’t support complex numbers.
+
+In general, the mathematical functions log, arcsine, arc-cosine, and arctangent
+are multiply defined. The value of log z is defined to be the one whose
+imaginary part lies in the range from −π (inclusive if -0.0 is distinguished,
+exclusive otherwise) to π (inclusive). The value of log 0 is mathematically
+undefined. With log defined this way, the values of sin^−1 z, cos^−1 z, and
+tan^−1 z are according to the following formulæ:
+
+ sin^−1 z = −i * log (i * z + (1 − z^2)^1/2)
+
+ cos^−1 z = π/2 − sin^−1 z
+
+ tan^−1 z = (log (1 + i * z) − log (1 − i * z)) / (2 * i)
+
+However, (log 0.0) returns -inf.0 (and (log -0.0) returns -inf.0+Ï€*i) if the
+implementation supports infinities (and -0.0).
+
+The range of (atan x y) is as in the following table. The asterisk (*) indicates that the entry
+applies to implementations that distinguish minus zero.
+
+ y condition x condition range of result r
+ y = 0.0 x > 0.0 0.0
+ ∗ y = + 0.0 x > 0.0 + 0.0
+ ∗ y = −0.0 x > 0.0 −0.0
+ y > 0.0 x > 0.0 0.0 < r < π/2
+ y > 0.0 x = 0.0 π/2
+ y > 0.0 x < 0.0 π/2 < r < π
+ y = 0.0 x < 0 π
+ ∗ y = + 0.0 x < 0.0 π
+ ∗ y = −0.0 x < 0.0 −π
+ y < 0.0 x < 0.0 −π< r< −π/2
+ y < 0.0 x = 0.0 −π/2
+ y < 0.0 x > 0.0 −π/2 < r< 0.0
+ y = 0.0 x = 0.0 undefined
+ ∗ y = + 0.0 x = + 0.0 + 0.0
+ ∗ y = −0.0 x = + 0.0 −0.0
+ ∗ y = + 0.0 x = −0.0 π
+ ∗ y = −0.0 x = −0.0 −π
+ ∗ y = + 0.0 x = 0 π/2
+ ∗ y = −0.0 x = 0 −π/2
+
+When it is possible, these procedures
+produce a real result from a real argument.
+
+---
+Previous: [[Module (scheme eval)]]
+
+Next: [[Module (scheme lazy)]]
diff --git a/manual/Module (scheme lazy) b/manual/Module (scheme lazy)
new file mode 100644
index 00000000..5838bf06
--- /dev/null
+++ b/manual/Module (scheme lazy)
@@ -0,0 +1,130 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module (scheme lazy)
+
+
+Delayed evaluation
+
+<macro>(delay <expression>)</macro>
+
+Semantics: The delay construct is used together with the procedure force to
+implement lazy evaluation or call by need. {{(delay <expression>)}} returns an
+object called a promise which at some point in the future can be asked (by the
+force procedure) to evaluate <expression>, and deliver the resulting value. The
+effect of <expression> returning multiple values is unspecified.
+
+<macro>(delay-force <expression>)</macro>
+
+Semantics: The expression {{(delay-force expression)}} is conceptually similar to
+{{(delay (force expression))}}, with the difference that forcing the result of delay-force will
+in effect result in a tail call to {{(force expression)}}, while forcing the result of
+{{(delay (force expression))}} might not. Thus iterative lazy algorithms that might result in a
+long series of chains of delay and force can be rewritten using delay-force to
+prevent consuming unbounded space during evaluation.
+
+<macro>(force promise)</macro>
+
+The force procedure forces the value of a
+promise created by delay, delay-force, or make-promise.If no value has been
+computed for the promise, then a value is computed and returned. The value of
+the promise must be cached (or "memoized") so that if it is forced a second
+time, the previously computed value is returned. Consequently, a delayed
+expression is evaluated using the parameter values and exception handler of the
+call to force which first requested its value. If
+promise is not a promise, it may be returned unchanged.
+
+ (force (delay (+ 1 2))) ==> 3
+ (let ((p (delay (+ 1 2))))
+ (list (force p) (force p))) ==> (3 3)
+
+ (define integers
+ (letrec ((next
+ (lambda (n)
+ (delay (cons n (next (+ n 1)))))))
+ (next 0)))
+ (define head
+ (lambda (stream) (car (force stream))))
+ (define tail
+ (lambda (stream) (cdr (force stream))))
+
+ (head (tail (tail integers))) ==> 2
+
+The following example is a mechanical
+transformation of a lazy stream-filtering algorithm into Scheme. Each call to a
+constructor is wrapped in delay, and each argument passed to a deconstructor is
+wrapped in force. The use of {{(delay-force ...)}} instead of {{(delay (force ...))}}
+around the body of the procedure ensures that an ever-growing sequence of
+pending promises does not exhaust available storage, because force will in
+effect force such sequences iteratively.
+
+ (define (stream-filter p? s)
+ (delay-force
+ (if (null? (force s))
+ (delay '())
+ (let ((h (car (force s)))
+ (t (cdr (force s))))
+ (if (p? h)
+ (delay (cons h (stream-filter p? t)))
+ (stream-filter p? t))))))
+
+ (head (tail (tail (stream-filter odd? integers)))) ==> 5
+
+The following examples are not intended to
+illustrate good programming style, as delay, force, and delay-force are mainly
+intended for programs written in the functional style. However, they do
+illustrate the property that only one value is computed for a promise, no
+matter how many times it is forced.
+
+ (define count 0)
+ (define p
+ (delay (begin (set! count (+ count 1))
+ (if (> count x)
+ count
+ (force p)))))
+ (define x 5)
+ p ==> a promise
+ (force p) ==> 6
+ p ==> a promise, still
+ (begin (set! x 10)
+ (force p)) ==> 6
+
+Various extensions to this semantics of delay,
+force and delay-force are supported in some implementations:
+
+* Calling force on an object that is not a promise may simply return the object.
+
+* It may be the case that there is no means by which a promise can be
+ operationally distinguished from its forced value. That is, expressions
+ like the following may evaluate to either #t or to #f, depending on the
+ implementation:
+
+ (eqv? (delay 1) 1) ==> unspecified
+ (pair? (delay (cons 1 2))) ==> unspecified
+
+* Implementations may implement “implicit forcing,†where the value of a
+ promise is forced by procedures that operate only on arguments of a certain
+ type, like cdr and *. However, procedures that operate uniformly on their
+ arguments, like list, must not force them.
+
+ (+ (delay (* 3 7)) 13) ==> unspecified
+ (car
+ (list (delay (* 3 7)) 13)) ==> a promise
+
+<procedure>(promise? obj)</procedure>
+
+The promise? procedure returns #t if its argument is a promise, and #f
+otherwise. Note that promises are not necessarily disjoint from other Scheme
+types such as procedures.
+
+<procedure>(make-promise obj)</promise>
+
+The make-promise procedure returns a promise which, when forced, will return
+obj. It is similar to delay, but does not delay its argument: it is a procedure
+rather than syntax. If
+obj is already a promise, it is returned.
+
+---
+Previous: [[Module (scheme inexact)]]
+
+Next: [[Module (scheme load)]]
diff --git a/manual/Module (scheme load) b/manual/Module (scheme load)
new file mode 100644
index 00000000..17f7e375
--- /dev/null
+++ b/manual/Module (scheme load)
@@ -0,0 +1,46 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module (scheme load)
+
+<procedure>(load filename [environment-specifier])</procedure>
+
+It is an error if filename is not a string.
+
+The load procedure reads expressions and definitions from the file designated
+by filename and evaluates
+them sequentially in the environment specified by
+environment-specifier. If
+environment-specifier is omitted, (interaction-environment) is assumed.
+
+The load procedure does not affect the values returned by current-input-port and
+current-output-port. It returns an unspecified value.
+
+CHICKEN offers a few extensions to the R7RS definition of {{load}}:
+
+* The environment specifier may also be a procedure of a single argument taking a expression and is used to evaluate every toplevel expression read from the input file, if the file contains Scheme source code.
+
+* On platforms that support it (currently BSD, Haiku, MacOS X, Linux, Solaris, and Windows), {{load}} can be used to load shared objects.
+
+Example for loading 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>
+
+There are some limitations and caveats to the CHICKEN extensions you
+need to be aware of:
+
+* The second argument to {{load}} is ignored when loading compiled code.
+* A compiled file can only be loaded once. Subsequent attempts to load the same file have no effect.
+
+---
+Previous: [[Module (scheme lazy)]]
+
+Next: [[Module (scheme process-context)]]
diff --git a/manual/Module (scheme process-context) b/manual/Module (scheme process-context)
new file mode 100644
index 00000000..17782ef6
--- /dev/null
+++ b/manual/Module (scheme process-context)
@@ -0,0 +1,65 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module (scheme process-context
+
+<procedure>(command-line)</procedure>
+
+Returns the command line passed to the process as a list of strings. The first
+string corresponds to the command name. It is
+an error to mutate any of these strings.
+
+<procedure>(exit [obj])</procedure>
+
+Runs all outstanding dynamic-wind after procedures, terminates the running program, and communicates an exit
+value to the operating system. If no argument is supplied, or if
+obj is #t, the exit procedure should communicate to the operating system that
+the program exited normally. If
+obj is #f, the exit procedure should communicate to the operating system that
+the program exited abnormally. Otherwise, exit should translate
+obj into an appropriate exit value for the operating system, if possible.
+
+The exit procedure must not signal an exception or return to its continuation.
+
+Note: Because of the requirement to run handlers, this procedure is not
+just the operating system's exit procedure.
+
+<procedure>(emergency-exit [obj])</procedure>
+
+Terminates the program without running any outstanding dynamic-wind
+after procedures and communicates an exit value to the operating system in the
+same manner as exit.
+
+Note: The emergency-exit procedure corresponds to the _exit procedure in
+Windows and Posix.
+
+<procedure>(get-environment-variable name)</procedure>
+
+Many operating systems provide each running process with an environment
+consisting of environment variables. (This environment is not to be confused
+with the Scheme environments that can be passed to eval)
+Both the name and value of an environment variable are strings. The procedure
+get-environment-variable returns the value of the environment variable
+name, or #f if the named environment variable is not found. It may use locale
+information to encode the name and decode the value of the environment
+variable. It is an error if
+get-environment-variable can’t decode the value. It is also an error to mutate
+the resulting string.
+
+ (get-environment-variable "PATH")
+ ==> "/usr/local/bin:/usr/bin:/bin"
+
+<procedure>(get-environment-variables)</procedure>
+
+Returns the names and values of all the environment variables as an alist,
+where the car of each entry is the name of an environment variable and the cdr
+is its value, both as strings. The order of the list is unspecified. It is an
+error to mutate any of these strings or the alist itself.
+
+ (get-environment-variables)
+ ==> (("USER" . "root") ("HOME" . "/"))
+
+---
+Previous: [[Module (scheme lazy)]]
+
+Next: [[Module (scheme read)]]
diff --git a/manual/Module r4rs b/manual/Module (scheme r4rs)
similarity index 78%
rename from manual/Module r4rs
rename to manual/Module (scheme r4rs)
index 9e9987f2..2fc6b749 100644
--- a/manual/Module r4rs
+++ b/manual/Module (scheme r4rs)
@@ -1,7 +1,7 @@
[[tags: manual]]
[[toc:]]
-== Module r4rs
+== Module (scheme r4rs)
This module provides the subset of procedures and macros from the
{{scheme}} module which are from the R4RS standard.
@@ -10,6 +10,6 @@ This is every procedure and macro from [[/manual/Module scheme|Module scheme]] e
{{dynamic-wind}}, {{eval}}, {{call-with-values}} and {{values}}.
---
-Previous: [[Module r5rs]]
+Previous: [[Module scheme]]
-Next: [[Module srfi-4]]
+Next: [[Module (scheme r5rs)]]
diff --git a/manual/Module (scheme r5rs) b/manual/Module (scheme r5rs)
new file mode 100644
index 00000000..e1bf82a0
--- /dev/null
+++ b/manual/Module (scheme r5rs)
@@ -0,0 +1,15 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module (scheme r5rs)
+
+This module provides the subset of procedures and macros from the
+{{scheme}} module which are from the R4RS standard.
+
+This is every procedure and macro from [[scheme|Module scheme]] except for
+{{dynamic-wind}}, {{eval}}, {{call-with-values}} and {{values}}.
+
+---
+Previous: [[Module (scheme r4rs)]]
+
+Next: [[Module (scheme base)]]
diff --git a/manual/Module (scheme read) b/manual/Module (scheme read)
new file mode 100644
index 00000000..ce85dac5
--- /dev/null
+++ b/manual/Module (scheme read)
@@ -0,0 +1,29 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module (scheme read)
+
+<procedure>(read [port])</procedure>
+
+If port is omitted from {{read}}, it defaults to the value returned by
+(current-input-port). It is an error to attempt an input operation on a closed
+port.
+
+The read procedure converts external representations of Scheme objects into the
+objects themselves. That is, it is a parser for the non-terminal <datum>.
+It returns the next object parsable from the given
+textual input port, updating
+port to point to the first character past the end of the external
+representation of the object.
+
+If an end of file is encountered in the input before any characters are found
+that can begin an object, then an end-of-file object is returned. The port
+remains open, and further attempts to read will also return an end-of-file
+object. If an end of file is encountered after the beginning of an object’s
+external representation, but the external representation is incomplete and
+therefore not parsable, an error that satisfies read-error? is signaled.
+
+---
+Previous: [[Module (scheme process-context)]]
+
+Next: [[Module (scheme repl)]]
diff --git a/manual/Module (scheme repl) b/manual/Module (scheme repl)
new file mode 100644
index 00000000..758d4743
--- /dev/null
+++ b/manual/Module (scheme repl)
@@ -0,0 +1,17 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module (scheme repl)
+
+<procedure>(interaction-environment)</procedure>
+
+This procedure returns a specifier for a mutable environment that contains an
+implementation-defined set of bindings, typically a superset of those exported
+by (scheme base). The intent is that this procedure will return the environment
+in which the implementation would evaluate expressions entered by the user into
+a REPL.
+
+---
+Previous: [[Module (scheme lazy)]]
+
+Next: [[Module (scheme time)]]
diff --git a/manual/Module (scheme time) b/manual/Module (scheme time)
new file mode 100644
index 00000000..918ee510
--- /dev/null
+++ b/manual/Module (scheme time)
@@ -0,0 +1,48 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module (scheme repl)
+
+<procedure>(current-second)</procedure>
+
+Returns an inexact number representing the current time on the International
+Atomic Time (TAI) scale. The value 0.0 represents midnight on January 1, 1970
+TAI (equivalent to 8.000082 seconds before midnight Universal Time) and the
+value 1.0 represents one TAI second later. Neither high accuracy nor high
+precision are required; in particular, returning Coordinated Universal Time
+plus a suitable constant might be the best an implementation can do.
+
+<procedure>(current-jiffy)</procedure>
+
+Returns the number of jiffies as an exact integer that have elapsed since an
+arbitrary, implementation-defined epoch. A jiffy is an implementation-defined
+fraction of a second which is defined by the return value of the
+jiffies-per-second procedure. The starting epoch is guaranteed to be constant
+during a run of the program, but may vary between runs.
+
+Rationale: Jiffies are allowed to be implementation-dependent so that
+current-jiffy can execute with minimum overhead. It should be very likely
+that a compactly represented integer will suffice as the returned
+value. Any particular jiffy size will be inappropriate for some
+implementations: a microsecond is too long for a very fast machine,
+while a much smaller unit would force many implementations to
+return integers which have to be allocated for most calls, rendering
+current-jiffy less useful for accurate timing measurements.
+
+<procedure>(jiffies-per-second)</procedure>
+
+Returns an exact integer representing the number of jiffies per SI second. This
+value is an implementation-specified constant.
+
+ (define (time-length)
+ (let ((list (make-list 100000))
+ (start (current-jiffy)))
+ (length list)
+ (/ (- (current-jiffy) start)
+ (jiffies-per-second))))
+
+
+---
+Previous: [[Module (scheme repl)]]
+
+Next: [[Module (scheme write)]]
diff --git a/manual/Module (scheme write) b/manual/Module (scheme write)
new file mode 100644
index 00000000..6bea3570
--- /dev/null
+++ b/manual/Module (scheme write)
@@ -0,0 +1,60 @@
+[[tags: manual]]
+[[toc:]]
+
+== Module (scheme write)
+
+If port is omitted from any output procedure, it defaults to the value returned by
+(current-output-port). It is an error to attempt an output operation on a
+closed port.
+
+<procedure>(write obj [port9])</procedure>
+
+Writes a representation of obj to the given textual output
+port. Strings that appear in the written representation are enclosed in
+quotation marks, and within those strings backslash and quotation mark
+characters are escaped by backslashes. Symbols that contain non-ASCII
+characters are escaped with vertical lines. Character objects are written using
+the #\ notation.
+
+If obj contains cycles which would cause an infinite loop using the normal written
+representation, then at least the objects that form part of the cycle must be
+represented using datum labels. Datum labels are
+not be used if there are no cycles.
+
+The write procedure returns an unspecified value.
+
+<procedure>(write-shared obj [port])</procedure>
+
+The write-shared procedure is the same as write, except that shared structure
+must be represented using datum labels for all pairs and vectors that appear
+more than once in the output.
+
+<procedure>(write-simple obj [port])</procedure>
+
+The write-simple procedure is the same as write, except that shared structure
+is never represented using datum labels. This can cause write-simple not to
+terminate if
+obj contains circular structure.
+
+<procedure>(display obj [port])</procedure>
+
+Writes a representation of
+obj to the given textual output
+port. Strings that appear in the written representation are output as if by
+write-string instead of by write. Symbols are not escaped. Character objects
+appear in the representation as if written by write-char instead of by write.
+
+The display representation of other objects is unspecified. However, display
+must not loop forever on self-referencing pairs, vectors, or records. Thus if
+the normal write representation is used, datum labels are needed to represent
+cycles as in write.
+
+The display procedure returns an unspecified value.
+
+Rationale: The write procedure is intended for producing machine-readable
+output and display for producing human-readable output.
+
+---
+Previous: [[Module (scheme time)]]
+
+Next: [[Module (chicken base)]]
diff --git a/manual/Module r5rs b/manual/Module r5rs
deleted file mode 100644
index e76c8bab..00000000
--- a/manual/Module r5rs
+++ /dev/null
@@ -1,12 +0,0 @@
-[[tags: manual]]
-[[toc:]]
-
-== The r5rs module
-
-This module is simply an alias for the [[Module scheme|scheme]] module.
-Please see the reference of that module for details on what it provides.
-
----
-Previous: [[Module scheme]]
-
-Next: [[Module r4rs]]
diff --git a/manual/Module scheme b/manual/Module scheme
index 401bb4d6..89f754c0 100644
--- a/manual/Module scheme
+++ b/manual/Module scheme
@@ -3,3546 +3,20 @@
== Module scheme
-This module provides all of CHICKEN's R5RS procedures and macros.
-These descriptions are based directly on the ''Revised^5 Report on the
-Algorithmic Language Scheme''.
+This module is intended for backwards compatibility with older CHICKEN code
+and exports a subset of the R7RS procedures in {{(scheme base)}}, {{(scheme char)}},
+ {{(scheme complex)}}, {{(scheme cxr)}}, {{(scheme eval)}}, {{(scheme file)}},
+{{(scheme inexact)}}, {{(scheme lazy)}}, {{(scheme load)}},
+{{(scheme read)}}, {{(scheme repl)}}, {{(scheme write)}} and all macros that correspond to
+the bindings available by default in R5RS.
-This module is used by default, unless a program is compiled with
-the {{-explicit-use}} option.
+The bindings of this module are available by default at toplevel in interpreted
+and compiled code.
-== Expressions
-
-Expression types are categorized as primitive or derived. Primitive
-expression types include variables and procedure calls. Derived
-expression types are not semantically primitive, but can instead be
-defined as macros. With the exception of quasiquote, whose macro
-definition is complex, the derived expressions are classified as
-library features. The distinction which R5RS makes between primitive
-and derived is unimportant and does not necessarily reflect how it's
-implemented in CHICKEN itself.
-
-=== Primitive expression types
-
-==== Variable references
-
-<macro><variable></macro><br>
-
-An expression consisting of a variable is a variable reference. The
-value of the variable reference is the value stored in the location to
-which the variable is bound. It is an error to reference an unbound
-variable.
-
- (define x 28)
- x ===> 28
-
-==== Literal expressions
-
-<macro>(quote <datum>)</macro><br>
-<macro>'<datum></macro><br>
-<macro><constant></macro><br>
-
-(quote <datum>) evaluates to <datum>. <Datum> may be any external
-representation of a Scheme object. This notation is used to include
-literal constants in Scheme code.
-
- (quote a) ===> a
- (quote #(a b c)) ===> #(a b c)
- (quote (+ 1 2)) ===> (+ 1 2)
-
-(quote <datum>) may be abbreviated as '<datum>. The two notations are
-equivalent in all respects.
-
- 'a ===> a
- '#(a b c) ===> #(a b c)
- '() ===> ()
- '(+ 1 2) ===> (+ 1 2)
- '(quote a) ===> (quote a)
- ''a ===> (quote a)
-
-Numerical constants, string constants, character constants, and boolean
-constants evaluate "to themselves"; they need not be quoted.
-
- '"abc" ===> "abc"
- "abc" ===> "abc"
- '145932 ===> 145932
- 145932 ===> 145932
- '#t ===> #t
- #t ===> #t
-
-It is an error to alter a constant (i.e. the value of a literal
-expression) using a mutation procedure like set-car! or string-set!.
-In the current implementation of CHICKEN, identical constants don't
-share memory and it is possible to mutate them, but this may change in
-the future.
-
-==== Procedure calls
-
-<macro>(<operator> <operand[1]> ...)</macro><br>
-
-A procedure call is written by simply enclosing in parentheses
-expressions for the procedure to be called and the arguments to be
-passed to it. The operator and operand expressions are evaluated (in an
-unspecified order) and the resulting procedure is passed the resulting
-arguments.
-
- (+ 3 4) ===> 7
- ((if #f + *) 3 4) ===> 12
-
-A number of procedures are available as the values of variables in the
-initial environment; for example, the addition and multiplication
-procedures in the above examples are the values of the variables + and
-*. New procedures are created by evaluating lambda
-expressions. Procedure calls may return any number of values (see the
-{{values}} procedure [[#Control_features|below]]).
-
-Procedure calls are also called combinations.
-
-Note: In contrast to other dialects of Lisp, the order of
-evaluation is unspecified, and the operator expression and the
-operand expressions are always evaluated with the same evaluation
-rules.
-
-Note: Although the order of evaluation is otherwise unspecified,
-the effect of any concurrent evaluation of the operator and operand
-expressions is constrained to be consistent with some sequential
-order of evaluation. The order of evaluation may be chosen
-differently for each procedure call.
-
-Note: In many dialects of Lisp, the empty combination, (), is a
-legitimate expression. In Scheme, combinations must have at least
-one subexpression, so () is not a syntactically valid expression.
-
-==== Procedures
-
-<macro>(lambda <formals> <body>)</macro><br>
-
-Syntax: <Formals> should be a formal arguments list as described below,
-and <body> should be a sequence of one or more expressions.
-
-Semantics: A lambda expression evaluates to a procedure. The
-environment in effect when the lambda expression was evaluated is
-remembered as part of the procedure. When the procedure is later called
-with some actual arguments, the environment in which the lambda
-expression was evaluated will be extended by binding the variables in
-the formal argument list to fresh locations, the corresponding actual
-argument values will be stored in those locations, and the expressions
-in the body of the lambda expression will be evaluated sequentially in
-the extended environment. The result(s) of the last expression in the
-body will be returned as the result(s) of the procedure call.
-
- (lambda (x) (+ x x)) ===> a procedure
- ((lambda (x) (+ x x)) 4) ===> 8
-
- (define reverse-subtract
- (lambda (x y) (- y x)))
- (reverse-subtract 7 10) ===> 3
-
- (define add4
- (let ((x 4))
- (lambda (y) (+ x y))))
- (add4 6) ===> 10
-
-<Formals> should have one of the following forms:
-
-* (<variable[1]> ...): The procedure takes a fixed number of
- arguments; when the procedure is called, the arguments will be
- stored in the bindings of the corresponding variables.
-
-* <variable>: The procedure takes any number of arguments; when the
- procedure is called, the sequence of actual arguments is converted
- into a newly allocated list, and the list is stored in the binding
- of the <variable>.
-
-* (<variable[1]> ... <variable[n]> . <variable[n+1]>): If a
- space-delimited period precedes the last variable, then the
- procedure takes n or more arguments, where n is the number of
- formal arguments before the period (there must be at least one).
- The value stored in the binding of the last variable will be a
- newly allocated list of the actual arguments left over after all
- the other actual arguments have been matched up against the other
- formal arguments.
-
-It is an error for a <variable> to appear more than once in <formals>.
-
- ((lambda x x) 3 4 5 6) ===> (3 4 5 6)
- ((lambda (x y . z) z)
- 3 4 5 6) ===> (5 6)
-
-Each procedure created as the result of evaluating a lambda expression
-is (conceptually) tagged with a storage location, in order to make eqv?
-and eq? work on procedures.
-
-As an extension to R5RS, CHICKEN also supports "extended" DSSSL style
-parameter lists, which allows embedded special keywords. Such a
-keyword gives a special meaning to the {{<formal>}} it precedes.
-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)
-
-
-
-==== Conditionals
-
-<macro>(if <test> <consequent> <alternate>)</macro><br>
-<macro>(if <test> <consequent>)</macro><br>
-
-Syntax: <Test>, <consequent>, and <alternate> may be arbitrary
-expressions.
-
-Semantics: An if expression is evaluated as follows: first, <test> is
-evaluated. If it yields a true value (see [[#Booleans|the section
-about booleans]] below), then <consequent> is evaluated and its
-value(s) is(are) returned. Otherwise <alternate> is evaluated and its
-value(s) is(are) returned. If <test> yields a false value and no
-<alternate> is specified, then the result of the expression is
-unspecified.
-
- (if (> 3 2) 'yes 'no) ===> yes
- (if (> 2 3) 'yes 'no) ===> no
- (if (> 3 2)
- (- 3 2)
- (+ 3 2)) ===> 1
-
-==== Assignments
-
-<macro>(set! <variable> <expression>)</macro><br>
-
-<Expression> is evaluated, and the resulting value is stored in the
-location to which <variable> is bound. <Variable> must be bound either
-in some region enclosing the set! expression or at top level. The
-result of the set! expression is unspecified.
-
- (define x 2)
- (+ x 1) ===> 3
- (set! x 4) ===> unspecified
- (+ x 1) ===> 5
-
-As an extension to R5RS, {{set!}} for unbound toplevel variables is
-allowed. Also, {{(set! (PROCEDURE ...) ...)}} is supported, as CHICKEN
-implements [[http://srfi.schemers.org/srfi-17/srfi-17.html|SRFI-17]].
-
-=== Derived expression types
-
-The constructs in this section are hygienic. For reference purposes,
-these macro definitions will convert most of the constructs described
-in this section into the primitive constructs described in the
-previous section. This does not necessarily mean that's exactly how
-it's implemented in CHICKEN.
-
-==== Derived Conditionals
-
-<macro>(cond <clause[1]> <clause[2]> ...)</macro><br>
-
-Syntax: Each <clause> should be of the form
-
- (<test> <expression[1]> ...)
-
-where <test> is any expression. Alternatively, a <clause> may be of the
-form
-
- (<test> => <expression>)
-
-The last <clause> may be an "else clause," which has the form
-
- (else <expression[1]> <expression[2]> ...).
-
-Semantics: A cond expression is evaluated by evaluating the <test>
-expressions of successive <clause>s in order until one of them
-evaluates to a true value (see [[#Booleans|the section about
-booleans]] below). When a <test> evaluates to a true value, then the
-remaining <expression>s in its <clause> are evaluated in order, and
-the result(s) of the last <expression> in the <clause> is(are)
-returned as the result(s) of the entire cond expression. If the
-selected <clause> contains only the <test> and no <expression>s, then
-the value of the <test> is returned as the result. If the selected
-<clause> uses the => alternate form, then the <expression> is
-evaluated. Its value must be a procedure that accepts one argument;
-this procedure is then called on the value of the <test> and the
-value(s) returned by this procedure is(are) returned by the cond
-expression. If all <test>s evaluate to false values, and there is no
-else clause, then the result of the conditional expression is
-unspecified; if there is an else clause, then its <expression>s are
-evaluated, and the value(s) of the last one is(are) returned.
-
- (cond ((> 3 2) 'greater)
- ((< 3 2) 'less)) ===> greater
- (cond ((> 3 3) 'greater)
- ((< 3 3) 'less)
- (else 'equal)) ===> equal
- (cond ((assv 'b '((a 1) (b 2))) => cadr)
- (else #f)) ===> 2
-
-
-As an extension to R5RS, CHICKEN also supports the
-[[http://srfi.schemers.org/srfi-61|SRFI-61]] syntax:
-
- (<generator> <guard> => <expression>)
-
-In this situation, {{generator}} is ''always'' evaluated. Its
-resulting value(s) are used as argument(s) for the {{guard}}
-procedure. Finally, if {{guard}} returns a non-{{#f}} value, the
-{{expression}} is evaluated by calling it with the result of
-{{guard}}. Otherwise, evaluation procedes to the next clause.
-
-<macro>(case <key> <clause[1]> <clause[2]> ...)</macro><br>
-
-Syntax: <Key> may be any expression. Each <clause> should have the form
-
- ((<datum[1]> ...) <expression[1]> <expression[2]> ...),
-
-where each <datum> is an external representation of some object.
-Alternatively, as per R7RS, a <clause> may be of the form
-
- ((<datum[1]> ...) => <expression>).
-
-All the <datum>s must be distinct. The last <clause> may be an
-"else clause," which has one of the following two forms:
-
- (else <expression[1]> <expression[2]> ...)
- (else => <expression>). ; R7RS extension
-
-Semantics: A case expression is evaluated as follows. <Key> is
-evaluated and its result is compared against each <datum>. If the
-result of evaluating <key> is equivalent (in the sense of {{eqv?}};
-see [[#Equivalence_predicates|below]]) to a <datum>, then the
-expressions in the corresponding <clause> are evaluated from left to
-right and the result(s) of the last expression in the <clause> is(are)
-returned as the result(s) of the case expression. If the selected
-<clause> uses the => alternate form (an R7RS extension), then the
-<expression> is evaluated. Its value must be a procedure that accepts
-one argument; this procedure is then called on the value of the <key>
-and the value(s) returned by this procedure is(are) returned by the
-case expression. If the result of evaluating <key> is different from
-every <datum>, then if there is an else clause its expressions are
-evaluated and the result(s) of the last is(are) the result(s) of the
-case expression; otherwise the result of the case expression is
-unspecified.
-
- (case (* 2 3)
- ((2 3 5 7) 'prime)
- ((1 4 6 8 9) 'composite)) ===> composite
- (case (car '(c d))
- ((a) 'a)
- ((b) 'b)) ===> unspecified
- (case (car '(c d))
- ((a e i o u) 'vowel)
- ((w y) 'semivowel)
- (else 'consonant)) ===> consonant
-
-<macro>(and <test[1]> ...)</macro><br>
-
-The <test> expressions are evaluated from left to right, and the value
-of the first expression that evaluates to a false value (see
-[[#Booleans|the section about booleans]]) is returned. Any remaining
-expressions are not evaluated. If all the expressions evaluate to true
-values, the value of the last expression is returned. If there are no
-expressions then #t is returned.
-
- (and (= 2 2) (> 2 1)) ===> #t
- (and (= 2 2) (< 2 1)) ===> #f
- (and 1 2 'c '(f g)) ===> (f g)
- (and) ===> #t
-
-<macro>(or <test[1]> ...)</macro><br>
-
-The <test> expressions are evaluated from left to right, and the value
-of the first expression that evaluates to a true value (see
-[[#Booleans|the section about booleans]]) is returned. Any remaining
-expressions are not evaluated. If all expressions evaluate to false
-values, the value of the last expression is returned. If there are no
-expressions then #f is returned.
-
- (or (= 2 2) (> 2 1)) ===> #t
- (or (= 2 2) (< 2 1)) ===> #t
- (or #f #f #f) ===> #f
- (or (memq 'b '(a b c))
- (/ 3 0)) ===> (b c)
-
-==== Binding constructs
-
-The three binding constructs let, let*, and letrec give Scheme a block
-structure, like Algol 60. The syntax of the three constructs is
-identical, but they differ in the regions they establish for their
-variable bindings. In a let expression, the initial values are computed
-before any of the variables become bound; in a let* expression, the
-bindings and evaluations are performed sequentially; while in a letrec
-expression, all the bindings are in effect while their initial values
-are being computed, thus allowing mutually recursive definitions.
-
-<macro>(let <bindings> <body>)</macro><br>
-
-Syntax: <Bindings> should have the form
-
- ((<variable[1]> <init[1]>) ...),
-
-where each <init> is an expression, and <body> should be a sequence of
-one or more expressions. It is an error for a <variable> to appear more
-than once in the list of variables being bound.
-
-Semantics: The <init>s are evaluated in the current environment (in
-some unspecified order), the <variable>s are bound to fresh locations
-holding the results, the <body> is evaluated in the extended
-environment, and the value(s) of the last expression of <body> is(are)
-returned. Each binding of a <variable> has <body> as its region.
-
- (let ((x 2) (y 3))
- (* x y)) ===> 6
-
- (let ((x 2) (y 3))
- (let ((x 7)
- (z (+ x y)))
- (* z x))) ===> 35
-
-See also "named let", [[#Iteration|below]].
-
-<macro>(let* <bindings> <body>)</macro><br>
-
-Syntax: <Bindings> should have the form
-
- ((<variable[1]> <init[1]>) ...),
-
-and <body> should be a sequence of one or more expressions.
-
-Semantics: Let* is similar to let, but the bindings are performed
-sequentially from left to right, and the region of a binding indicated
-by (<variable> <init>) is that part of the let* expression to the right
-of the binding. Thus the second binding is done in an environment in
-which the first binding is visible, and so on.
-
- (let ((x 2) (y 3))
- (let* ((x 7)
- (z (+ x y)))
- (* z x))) ===> 70
-
-<macro>(letrec <bindings> <body>)</macro><br>
-
-Syntax: <Bindings> should have the form
-
- ((<variable[1]> <init[1]>) ...),
-
-and <body> should be a sequence of one or more expressions. It is an
-error for a <variable> to appear more than once in the list of
-variables being bound.
-
-Semantics: The <variable>s are bound to fresh locations holding
-undefined values, the <init>s are evaluated in the resulting
-environment (in some unspecified order), each <variable> is assigned to
-the result of the corresponding <init>, the <body> is evaluated in the
-resulting environment, and the value(s) of the last expression in
-<body> is(are) returned. Each binding of a <variable> has the entire
-letrec expression as its region, making it possible to define mutually
-recursive procedures.
-
- (letrec ((even?
- (lambda (n)
- (if (zero? n)
- #t
- (odd? (- n 1)))))
- (odd?
- (lambda (n)
- (if (zero? n)
- #f
- (even? (- n 1))))))
- (even? 88))
- ===> #t
-
-One restriction on letrec is very important: it must be possible to
-evaluate each <init> without assigning or referring to the value of any
-<variable>. If this restriction is violated, then it is an error. The
-restriction is necessary because Scheme passes arguments by value
-rather than by name. In the most common uses of letrec, all the <init>s
-are lambda expressions and the restriction is satisfied automatically.
-
-==== Sequencing
-
-<macro>(begin <expression[1]> <expression[2]> ...)</macro><br>
-
-The <expression>s are evaluated sequentially from left to right, and
-the value(s) of the last <expression> is(are) returned. This expression
-type is used to sequence side effects such as input and output.
-
- (define x 0)
-
- (begin (set! x 5)
- (+ x 1)) ===> 6
-
- (begin (display "4 plus 1 equals ")
- (display (+ 4 1))) ===> unspecified
- and prints 4 plus 1 equals 5
-
-As an extension to R5RS, CHICKEN also allows {{(begin)}} without body
-expressions in any context, not just at toplevel. This simply
-evaluates to the unspecified value.
-
-
-==== Iteration
-
-<macro>(do ((<variable[1]> <init[1]> <step[1]>) ...) (<test> <expression> ...) <command> ...)</macro><br>
-
-Do is an iteration construct. It specifies a set of variables to be
-bound, how they are to be initialized at the start, and how they are to
-be updated on each iteration. When a termination condition is met, the
-loop exits after evaluating the <expression>s.
-
-Do expressions are evaluated as follows: The <init> expressions are
-evaluated (in some unspecified order), the <variable>s are bound to
-fresh locations, the results of the <init> expressions are stored in
-the bindings of the <variable>s, and then the iteration phase begins.
-
-Each iteration begins by evaluating <test>; if the result is false
-(see [[#Booleans|the section about booleans]]), then the <command>
-expressions are evaluated in order for effect, the <step> expressions
-are evaluated in some unspecified order, the <variable>s are bound to
-fresh locations, the results of the <step>s are stored in the bindings
-of the <variable>s, and the next iteration begins.
-
-If <test> evaluates to a true value, then the <expression>s are
-evaluated from left to right and the value(s) of the last <expression>
-is(are) returned. If no <expression>s are present, then the value of
-the do expression is unspecified.
-
-The region of the binding of a <variable> consists of the entire do
-expression except for the <init>s. It is an error for a <variable> to
-appear more than once in the list of do variables.
-
-A <step> may be omitted, in which case the effect is the same as if
-(<variable> <init> <variable>) had been written instead of (<variable>
-<init>).
-
- (do ((vec (make-vector 5))
- (i 0 (+ i 1)))
- ((= i 5) vec)
- (vector-set! vec i i)) ===> #(0 1 2 3 4)
-
- (let ((x '(1 3 5 7 9)))
- (do ((x x (cdr x))
- (sum 0 (+ sum (car x))))
- ((null? x) sum))) ===> 25
-
-<macro>(let <variable> <bindings> <body>)</macro><br>
-
-"Named let" is a variant on the syntax of let which provides a more
-general looping construct than do and may also be used to express
-recursions. It has the same syntax and semantics as ordinary let except
-that <variable> is bound within <body> to a procedure whose formal
-arguments are the bound variables and whose body is <body>. Thus the
-execution of <body> may be repeated by invoking the procedure named by
-<variable>.
-
- (let loop ((numbers '(3 -2 1 6 -5))
- (nonneg '())
- (neg '()))
- (cond ((null? numbers) (list nonneg neg))
- ((>= (car numbers) 0)
- (loop (cdr numbers)
- (cons (car numbers) nonneg)
- neg))
- ((< (car numbers) 0)
- (loop (cdr numbers)
- nonneg
- (cons (car numbers) neg)))))
- ===> ((6 1 3) (-5 -2))
-
-==== Delayed evaluation
-
-<macro>(delay <expression>)</macro><br>
-
-The delay construct is used together with the procedure force to
-implement lazy evaluation or call by need. {{(delay <expression>)}}
-returns an object called a promise which at some point in the future
-may be asked (by the force procedure) to evaluate {{<expression>}},
-and deliver the resulting value. The {{<expression>}} may return
-multiple values, which will be correctly memoized and returned by
-subsequent calls to {{force}}. This is a CHICKEN extension to R5RS.
-
-See the description of {{force}} (under [[#control-features|Control
-features]], below) for a more complete description of {{delay}}.
-
-CHICKEN also supports the R7RS {{delay-force}} syntax which allows for
-iterative lazy algorithms to be expressed in bounded space. See the
-[[Module (chicken base)#lazy-evaluation|Lazy evaluation section]] in
-the (chicken base) module documentation for more information.
-
-
-==== Quasiquotation
-
-<macro>(quasiquote <qq template>)</macro><br>
-<macro>`<qq template></macro><br>
-
-"Backquote" or "quasiquote" expressions are useful for constructing
-a list or vector structure when most but not all of the desired
-structure is known in advance. If no commas appear within the <qq
-template>, the result of evaluating `<qq template> is equivalent to the
-result of evaluating '<qq template>. If a comma appears within the <qq
-template>, however, the expression following the comma is evaluated
-("unquoted") and its result is inserted into the structure instead of
-the comma and the expression. If a comma appears followed immediately
-by an at-sign (@), then the following expression must evaluate to a
-list; the opening and closing parentheses of the list are then
-"stripped away" and the elements of the list are inserted in place of
-the comma at-sign expression sequence. A comma at-sign should only
-appear within a list or vector <qq template>.
-
- `(list ,(+ 1 2) 4) ===> (list 3 4)
- (let ((name 'a)) `(list ,name ',name))
- ===> (list a (quote a))
- `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)
- ===> (a 3 4 5 6 b)
- `(( foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))
- ===> ((foo 7) . cons)
- `#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8)
- ===> #(10 5 2 4 3 8)
-
-Quasiquote forms may be nested. Substitutions are made only for
-unquoted components appearing at the same nesting level as the
-outermost backquote. The nesting level increases by one inside each
-successive quasiquotation, and decreases by one inside each
-unquotation.
-
- `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)
- ===> (a `(b ,(+ 1 2) ,(foo 4 d) e) f)
- (let ((name1 'x)
- (name2 'y))
- `(a `(b ,,name1 ,',name2 d) e))
- ===> (a `(b ,x ,'y d) e)
-
-The two notations `<qq template> and (quasiquote <qq template>) are
-identical in all respects. ,<expression> is identical to (unquote
-<expression>), and ,@<expression> is identical to (unquote-splicing
-<expression>). The external syntax generated by write for two-element
-lists whose car is one of these symbols may vary between
-implementations.
-
- (quasiquote (list (unquote (+ 1 2)) 4))
- ===> (list 3 4)
- '(quasiquote (list (unquote (+ 1 2)) 4))
- ===> `(list ,(+ 1 2) 4)
- i.e., (quasiquote (list (unquote (+ 1 2)) 4))
-
-Unpredictable behavior can result if any of the symbols quasiquote,
-unquote, or unquote-splicing appear in positions within a <qq template>
-otherwise than as described above.
-
-=== Macros
-
-Scheme programs can define and use new derived expression types, called
-macros. Program-defined expression types have the syntax
-
- (<keyword> <datum> ...)
-
-where <keyword> is an identifier that uniquely determines the
-expression type. This identifier is called the syntactic keyword, or
-simply keyword, of the macro. The number of the <datum>s, and their
-syntax, depends on the expression type.
-
-Each instance of a macro is called a use of the macro. The set of rules
-that specifies how a use of a macro is transcribed into a more
-primitive expression is called the transformer of the macro.
-
-The macro definition facility consists of two parts:
-
-* A set of expressions used to establish that certain identifiers are
- macro keywords, associate them with macro transformers, and control
- the scope within which a macro is defined, and
-
-* a pattern language for specifying macro transformers.
-
-The syntactic keyword of a macro may shadow variable bindings, and
-local variable bindings may shadow keyword bindings. All macros defined
-using the pattern language are "hygienic" and "referentially
-transparent" and thus preserve Scheme's lexical scoping:
-
-* If a macro transformer inserts a binding for an identifier
- (variable or keyword), the identifier will in effect be renamed
- throughout its scope to avoid conflicts with other identifiers.
- Note that a define at top level may or may not introduce a binding;
- this depends on whether the binding already existed before (in which
- case its value will be overridden).
-
-* If a macro transformer inserts a free reference to an identifier,
- the reference refers to the binding that was visible where the
- transformer was specified, regardless of any local bindings that
- may surround the use of the macro.
-
-==== Binding constructs for syntactic keywords
-
-Let-syntax and letrec-syntax are analogous to let and letrec, but they
-bind syntactic keywords to macro transformers instead of binding
-variables to locations that contain values. Syntactic keywords may also
-be bound at top level.
-
-<macro>(let-syntax <bindings> <body>)</macro><br>
-
-Syntax: <Bindings> should have the form
-
- ((<keyword> <transformer spec>) ...)
-
-Each <keyword> is an identifier, each <transformer spec> is an instance
-of syntax-rules, and <body> should be a sequence of one or more
-expressions. It is an error for a <keyword> to appear more than once in
-the list of keywords being bound.
-
-Semantics: The <body> is expanded in the syntactic environment obtained
-by extending the syntactic environment of the let-syntax expression
-with macros whose keywords are the <keyword>s, bound to the specified
-transformers. Each binding of a <keyword> has <body> as its region.
-
- (let-syntax ((when (syntax-rules ()
- ((when test stmt1 stmt2 ...)
- (if test
- (begin stmt1
- stmt2 ...))))))
- (let ((if #t))
- (when if (set! if 'now))
- if)) ===> now
-
- (let ((x 'outer))
- (let-syntax ((m (syntax-rules () ((m) x))))
- (let ((x 'inner))
- (m)))) ===> outer
-
-<macro>(letrec-syntax <bindings> <body>)</macro><br>
-
-Syntax: Same as for let-syntax.
-
-Semantics: The <body> is expanded in the syntactic environment obtained
-by extending the syntactic environment of the letrec-syntax expression
-with macros whose keywords are the <keyword>s, bound to the specified
-transformers. Each binding of a <keyword> has the <bindings> as well as
-the <body> within its region, so the transformers can transcribe
-expressions into uses of the macros introduced by the letrec-syntax
-expression.
-
- (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))) ===> 7
-
-==== Pattern language
-
-A <transformer spec> has the following form:
-
- (syntax-rules <literals> <syntax rule> ...)
-
-Syntax: <Literals> is a list of identifiers and each <syntax rule>
-should be of the form
-
- (<pattern> <template>)
-
-The <pattern> in a <syntax rule> is a list <pattern> that begins with
-the keyword for the macro.
-
-A <pattern> is either an identifier, a constant, or one of the
-following
-
- (<pattern> ...)
- (<pattern> <pattern> ... . <pattern>)
- (<pattern> ... <pattern> <ellipsis>)
- #(<pattern> ...)
- #(<pattern> ... <pattern> <ellipsis>)
-
-and a template is either an identifier, a constant, or one of the
-following
-
- (<element> ...)
- (<element> <element> ... . <template>)
- #(<element> ...)
-
-where an <element> is a <template> optionally followed by an <ellipsis>
-and an <ellipsis> is the identifier "..." (which cannot be used as an
-identifier in either a template or a pattern).
-
-Semantics: An instance of syntax-rules produces a new macro transformer
-by specifying a sequence of hygienic rewrite rules. A use of a macro
-whose keyword is associated with a transformer specified by
-syntax-rules is matched against the patterns contained in the <syntax
-rule>s, beginning with the leftmost <syntax rule>. When a match is
-found, the macro use is transcribed hygienically according to the
-template.
-
-An identifier that appears in the pattern of a <syntax rule> is a
-pattern variable, unless it is the keyword that begins the pattern, is
-listed in <literals>, or is the identifier "...". Pattern variables
-match arbitrary input elements and are used to refer to elements of the
-input in the template. It is an error for the same pattern variable to
-appear more than once in a <pattern>.
-
-The keyword at the beginning of the pattern in a <syntax rule> is not
-involved in the matching and is not considered a pattern variable or
-literal identifier.
-
-Rationale: The scope of the keyword is determined by the
-expression or syntax definition that binds it to the associated
-macro transformer. If the keyword were a pattern variable or
-literal identifier, then the template that follows the pattern
-would be within its scope regardless of whether the keyword were
-bound by let-syntax or by letrec-syntax.
-
-Identifiers that appear in <literals> are interpreted as literal
-identifiers to be matched against corresponding subforms of the input.
-A subform in the input matches a literal identifier if and only if it
-is an identifier and either both its occurrence in the macro expression
-and its occurrence in the macro definition have the same lexical
-binding, or the two identifiers are equal and both have no lexical
-binding.
-
-A subpattern followed by ... can match zero or more elements of the
-input. It is an error for ... to appear in <literals>. Within a pattern
-the identifier ... must follow the last element of a nonempty sequence
-of subpatterns.
-
-More formally, an input form F matches a pattern P if and only if:
-
-* P is a non-literal identifier; or
-
-* P is a literal identifier and F is an identifier with the same
- binding; or
-
-* P is a list (P[1] ... P[n]) and F is a list of n forms that match P
- [1] through P[n], respectively; or
-
-* P is an improper list (P[1] P[2] ... P[n] . P[n+1]) and F is a list
- or improper list of n or more forms that match P[1] through P[n],
- respectively, and whose nth "cdr" matches P[n+1]; or
-
-* P is of the form (P[1] ... P[n] P[n+1] <ellipsis>) where <ellipsis>
- is the identifier ... and F is a proper list of at least n forms,
- the first n of which match P[1] through P[n], respectively, and
- each remaining element of F matches P[n+1]; or
-
-* P is a vector of the form #(P[1] ... P[n]) and F is a vector of n
- forms that match P[1] through P[n]; or
-
-* P is of the form #(P[1] ... P[n] P[n+1] <ellipsis>) where
- <ellipsis> is the identifier ... and F is a vector of n or more
- forms the first n of which match P[1] through P[n], respectively,
- and each remaining element of F matches P[n+1]; or
-
-* P is a datum and F is equal to P in the sense of the equal?
- procedure.
-
-It is an error to use a macro keyword, within the scope of its binding,
-in an expression that does not match any of the patterns.
-
-When a macro use is transcribed according to the template of the
-matching <syntax rule>, pattern variables that occur in the template
-are replaced by the subforms they match in the input. Pattern variables
-that occur in subpatterns followed by one or more instances of the
-identifier ... are allowed only in subtemplates that are followed by as
-many instances of .... They are replaced in the output by all of the
-subforms they match in the input, distributed as indicated. It is an
-error if the output cannot be built up as specified.
-
-Identifiers that appear in the template but are not pattern variables
-or the identifier ... are inserted into the output as literal
-identifiers. If a literal identifier is inserted as a free identifier
-then it refers to the binding of that identifier within whose scope the
-instance of syntax-rules appears. If a literal identifier is inserted
-as a bound identifier then it is in effect renamed to prevent
-inadvertent captures of free identifiers.
-
-As an example, if let and cond are defined as usual, then they are
-hygienic (as required) and the following is not an error.
-
- (let ((=> #f))
- (cond (#t => 'ok))) ===> ok
-
-The macro transformer for cond recognizes => as a local variable, and
-hence an expression, and not as the top-level identifier =>, which the
-macro transformer treats as a syntactic keyword. Thus the example
-expands into
-
- (let ((=> #f))
- (if #t (begin => 'ok)))
-
-instead of
-
- (let ((=> #f))
- (let ((temp #t))
- (if temp ('ok temp))))
-
-which would result in an invalid procedure call.
-
-== Program structure
-
-=== Programs
-
-A Scheme program consists of a sequence of expressions, definitions,
-and syntax definitions. Expressions are described in chapter 4;
-definitions and syntax definitions are the subject of the rest of the
-present chapter.
-
-Programs are typically stored in files or entered interactively to a
-running Scheme system, although other paradigms are possible;
-questions of user interface lie outside the scope of this
-report. (Indeed, Scheme would still be useful as a notation for
-expressing computational methods even in the absence of a mechanical
-implementation.)
-
-Definitions and syntax definitions occurring at the top level of a
-program can be interpreted declaratively. They cause bindings to be
-created in the top level environment or modify the value of existing
-top-level bindings. Expressions occurring at the top level of a
-program are interpreted imperatively; they are executed in order when
-the program is invoked or loaded, and typically perform some kind of
-initialization.
-
-At the top level of a program (begin <form1> ...) is equivalent to the
-sequence of expressions, definitions, and syntax definitions that form
-the body of the begin.
-
-=== Definitions
-
-Definitions are valid in some, but not all, contexts where expressions
-are allowed. They are valid only at the top level of a <program> and
-at the beginning of a <body>.
-
-A definition should have one of the following forms:
-
-<macro>(define <variable> <expression>)</macro><br>
-<macro>(define (<variable> <formals>) <body>)</macro><br>
-
-<Formals> should be either a sequence of zero or more variables, or a
-sequence of one or more variables followed by a space-delimited period
-and another variable (as in a lambda expression). This form is
-equivalent to
-
- (define <variable>
- (lambda (<formals>) <body>)).
-
-<macro>(define <variable>)</macro>
-
-This form is a CHICKEN extension to R5RS, and is equivalent to
-
- (define <variable> (void))
-
-<macro>(define (<variable> . <formal>) <body>)</macro><br>
-
-<Formal> should be a single variable. This form is equivalent to
-
- (define <variable>
- (lambda <formal> <body>)).
-
-<macro>(define ((<variable> <formal> ...) ...) <body>)</macro><br>
-
-As an extension to R5RS, CHICKEN allows ''curried'' definitions, where
-the variable name may also be a list specifying a name and a nested
-lambda list. For example,
-
- (define ((make-adder x) y) (+ x y))
-
-is equivalent to
-
- (define (make-adder x) (lambda (y) (+ x y))).
-
-This type of curried definition can be nested arbitrarily and combined
-with dotted tail notation or DSSSL keywords.
-
-==== Top level definitions
-
-At the top level of a program, a definition
-
- (define <variable> <expression>)
-
-has essentially the same effect as the assignment expression
-
- (set! <variable> <expression>)
-
-if <variable> is bound. If <variable> is not bound, however, then the
-definition will bind <variable> to a new location before performing
-the assignment, whereas it would be an error to perform a set! on an
-unbound variable in standard Scheme. In CHICKEN, {{set!}} at toplevel
-has the same effect as a definition, unless inside a module, in which
-case it is an error.
-
- (define add3
- (lambda (x) (+ x 3)))
- (add3 3) ===> 6
- (define first car)
- (first '(1 2)) ===> 1
-
-Some implementations of Scheme use an initial environment in which all
-possible variables are bound to locations, most of which contain
-undefined values. Top level definitions in such an implementation are
-truly equivalent to assignments. In CHICKEN, attempting to evaluate
-an unbound identifier will result in an error, but you ''can'' use
-{{set!}} to bind an initial value to it.
-
-==== Internal definitions
-
-Definitions may occur at the beginning of a <body> (that is, the body
-of a lambda, let, let*, letrec, let-syntax, or letrec-syntax
-expression or that of a definition of an appropriate form). Such
-definitions are known as internal definitions as opposed to the top
-level definitions described above. The variable defined by an internal
-definition is local to the <body>. That is, <variable> is bound rather
-than assigned, and the region of the binding is the entire <body>. For
-example,
-
- (let ((x 5))
- (define foo (lambda (y) (bar x y)))
- (define bar (lambda (a b) (+ (* a b) a)))
- (foo (+ x 3))) ===> 45
-
-A <body> containing internal definitions can always be converted into
-a completely equivalent letrec expression. For example, the let
-expression in the above example is equivalent to
-
- (let ((x 5))
- (letrec ((foo (lambda (y) (bar x y)))
- (bar (lambda (a b) (+ (* a b) a))))
- (foo (+ x 3))))
-
-Just as for the equivalent letrec expression, it must be possible to
-evaluate each <expression> of every internal definition in a <body>
-without assigning or referring to the value of any <variable> being
-defined.
-
-Wherever an internal definition may occur (begin <definition1> ...) is
-equivalent to the sequence of definitions that form the body of the
-begin.
-
-CHICKEN extends the R5RS 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.
-
-
-=== Syntax definitions
-
-Syntax definitions are valid only at the top level of a
-<program>. They have the following form:
-
-<macro>(define-syntax <keyword> <transformer spec>)</macro>
-
-{{<Keyword>}} is an identifier, and the {{<transformer spec>}} should
-be an instance of {{syntax-rules}}. Note that CHICKEN also supports
-{{er-macro-transformer}} and {{ir-macro-transformer}} here. For more
-information see [[Module (chicken syntax)|the (chicken syntax) module]].
-
-The top-level syntactic environment is extended by binding the
-<keyword> to the specified transformer.
-
-In standard Scheme, there is no define-syntax analogue of internal
-definitions in, but CHICKEN allows these as an extension to the
-standard. This means {{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}} 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. Also, "tail" patterns of the form
-
- (syntax-rules ()
- ((_ (a b ... c)
- ...
-
-are supported.
-
-The effect of destructively modifying the s-expression passed to a
-transformer procedure is undefined.
-
-Although macros may expand into definitions and syntax definitions in
-any context that permits them, it is an error for a definition or
-syntax definition to shadow a syntactic keyword whose meaning is
-needed to determine whether some form in the group of forms that
-contains the shadowing definition is in fact a definition, or, for
-internal definitions, is needed to determine the boundary between the
-group and the expressions that follow the group. For example, the
-following are errors:
-
- (define define 3)
-
- (begin (define begin list))
-
- (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)
- (plus foo x)))
-
-== Standard procedures
-
-This chapter describes Scheme's built-in procedures. The initial (or
-"top level") Scheme environment starts out with a number of variables
-bound to locations containing useful values, most of which are
-primitive procedures that manipulate data. For example, the variable
-abs is bound to (a location initially containing) a procedure of one
-argument that computes the absolute value of a number, and the variable
-+ is bound to a procedure that computes sums. Built-in procedures that
-can easily be written in terms of other built-in procedures are
-identified as "library procedures".
-
-A program may use a top-level definition to bind any variable. It may
-subsequently alter any such binding by an assignment (see
-[[#assignments|assignments]], above). These operations do
-not modify the behavior of Scheme's built-in procedures. Altering any
-top-level binding that has not been introduced by a definition has an
-unspecified effect on the behavior of the built-in procedures.
-
-=== Equivalence predicates
-
-A predicate is a procedure that always returns a boolean value (#t or #f).
-An equivalence predicate is the computational analogue of a
-mathematical equivalence relation (it is symmetric, reflexive, and
-transitive). Of the equivalence predicates described in this section,
-eq? is the finest or most discriminating, and equal? is the coarsest.
-eqv? is slightly less discriminating than eq?.
-
-<procedure>(eqv? obj[1] obj[2])</procedure><br>
-
-The eqv? procedure defines a useful equivalence relation on objects.
-Briefly, it returns #t if obj[1] and obj[2] should normally be regarded
-as the same object. This relation is left slightly open to
-interpretation, but the following partial specification of eqv? holds
-for all implementations of Scheme.
-
-The eqv? procedure returns #t if:
-
-* obj[1] and obj[2] are both #t or both #f.
-
-* obj[1] and obj[2] are both symbols and
-
- (string=? (symbol->string obj1)
- (symbol->string obj2))
- ===> #t
-
-Note: This assumes that neither obj[1] nor obj[2] is an "uninterned
-symbol" as alluded to in the section on [[#symbols|symbols]]. This
-report does not presume to specify the behavior of eqv? on
-implementation-dependent extensions.
-
-* obj[1] and obj[2] are both numbers, are numerically equal (see =,
- under [[#numerical-operations|numerical operations]]), and are
- either both exact or both inexact.
-
-* obj[1] and obj[2] are both characters and are the same character
- according to the char=? procedure (see "[[#characters|characters]]").
-
-* both obj[1] and obj[2] are the empty list.
-
-* obj[1] and obj[2] are pairs, vectors, or strings that denote the
- same locations in the store.
-
-* obj[1] and obj[2] are procedures whose location tags are equal
- (see "[[#procedures|procedures]]").
-
-The eqv? procedure returns #f if:
-
-* obj[1] and obj[2] are of different types.
-
-* one of obj[1] and obj[2] is #t but the other is #f.
-
-* obj[1] and obj[2] are symbols but
-
- (string=? (symbol->string obj[1])
- (symbol->string obj[2]))
- ===> #f
-
-* one of obj[1] and obj[2] is an exact number but the other is an
- inexact number.
-
-* obj[1] and obj[2] are numbers for which the = procedure returns #f.
-
-* obj[1] and obj[2] are characters for which the char=? procedure
- returns #f.
-
-* one of obj[1] and obj[2] is the empty list but the other is not.
-
-* obj[1] and obj[2] are pairs, vectors, or strings that denote
- distinct locations.
-
-* obj[1] and obj[2] are procedures that would behave differently
- (return different value(s) or have different side effects) for some
- arguments.
-
- (eqv? 'a 'a) ===> #t
- (eqv? 'a 'b) ===> #f
- (eqv? 2 2) ===> #t
- (eqv? '() '()) ===> #t
- (eqv? 100000000 100000000) ===> #t
- (eqv? (cons 1 2) (cons 1 2)) ===> #f
- (eqv? (lambda () 1)
- (lambda () 2)) ===> #f
- (eqv? #f 'nil) ===> #f
- (let ((p (lambda (x) x)))
- (eqv? p p)) ===> #t
-
-The following examples illustrate cases in which the above rules do not
-fully specify the behavior of eqv?. All that can be said about such
-cases is that the value returned by eqv? must be a boolean.
-
- (eqv? "" "") ===> unspecified
- (eqv? '#() '#()) ===> unspecified
- (eqv? (lambda (x) x)
- (lambda (x) x)) ===> unspecified
- (eqv? (lambda (x) x)
- (lambda (y) y)) ===> unspecified
-
-The next set of examples shows the use of eqv? with procedures that
-have local state. Gen-counter must return a distinct procedure every
-time, since each procedure has its own internal counter. Gen-loser,
-however, returns equivalent procedures each time, since the local state
-does not affect the value or side effects of the procedures.
-
- (define gen-counter
- (lambda ()
- (let ((n 0))
- (lambda () (set! n (+ n 1)) n))))
- (let ((g (gen-counter)))
- (eqv? g g)) ===> #t
- (eqv? (gen-counter) (gen-counter))
- ===> #f
- (define gen-loser
- (lambda ()
- (let ((n 0))
- (lambda () (set! n (+ n 1)) 27))))
- (let ((g (gen-loser)))
- (eqv? g g)) ===> #t
- (eqv? (gen-loser) (gen-loser))
- ===> unspecified
-
- (letrec ((f (lambda () (if (eqv? f g) 'both 'f)))
- (g (lambda () (if (eqv? f g) 'both 'g))))
- (eqv? f g))
- ===> unspecified
-
- (letrec ((f (lambda () (if (eqv? f g) 'f 'both)))
- (g (lambda () (if (eqv? f g) 'g 'both))))
- (eqv? f g))
- ===> #f
-
-Since it is an error to modify constant objects (those returned by
-literal expressions), implementations are permitted, though not
-required, to share structure between constants where appropriate. Thus
-the value of eqv? on constants is sometimes implementation-dependent.
-
- (eqv? '(a) '(a)) ===> unspecified
- (eqv? "a" "a") ===> unspecified
- (eqv? '(b) (cdr '(a b))) ===> unspecified
- (let ((x '(a)))
- (eqv? x x)) ===> #t
-
-Rationale: The above definition of eqv? allows implementations
-latitude in their treatment of procedures and literals:
-implementations are free either to detect or to fail to detect that
-two procedures or two literals are equivalent to each other, and
-can decide whether or not to merge representations of equivalent
-objects by using the same pointer or bit pattern to represent both.
-
-<procedure>(eq? obj[1] obj[2])</procedure><br>
-
-Eq? is similar to eqv? except that in some cases it is capable of
-discerning distinctions finer than those detectable by eqv?.
-
-Eq? and eqv? are guaranteed to have the same behavior on symbols,
-booleans, the empty list, pairs, procedures, and non-empty strings and
-vectors. Eq?'s behavior on numbers and characters is
-implementation-dependent, but it will always return either true or
-false, and will return true only when eqv? would also return true. Eq?
-may also behave differently from eqv? on empty vectors and empty
-strings.
-
- (eq? 'a 'a) ===> #t
- (eq? '(a) '(a)) ===> unspecified
- (eq? (list 'a) (list 'a)) ===> #f
- (eq? "a" "a") ===> unspecified
- (eq? "" "") ===> unspecified
- (eq? '() '()) ===> #t
- (eq? 2 2) ===> unspecified
- (eq? #\A #\A) ===> unspecified
- (eq? car car) ===> #t
- (let ((n (+ 2 3)))
- (eq? n n)) ===> unspecified
- (let ((x '(a)))
- (eq? x x)) ===> #t
- (let ((x '#()))
- (eq? x x)) ===> #t
- (let ((p (lambda (x) x)))
- (eq? p p)) ===> #t
-
-Rationale: It will usually be possible to implement eq? much more
-efficiently than eqv?, for example, as a simple pointer comparison
-instead of as some more complicated operation. One reason is that
-it may not be possible to compute eqv? of two numbers in constant
-time, whereas eq? implemented as pointer comparison will always
-finish in constant time. Eq? may be used like eqv? in applications
-using procedures to implement objects with state since it obeys the
-same constraints as eqv?.
-
-<procedure>(equal? obj[1] obj[2])</procedure><br>
-
-Equal? recursively compares the contents of pairs, vectors, and
-strings, applying eqv? on other objects such as numbers and symbols. A
-rule of thumb is that objects are generally equal? if they print the
-same. Equal? may fail to terminate if its arguments are circular data
-structures.
-
- (equal? 'a 'a) ===> #t
- (equal? '(a) '(a)) ===> #t
- (equal? '(a (b) c)
- '(a (b) c)) ===> #t
- (equal? "abc" "abc") ===> #t
- (equal? 2 2) ===> #t
- (equal? (make-vector 5 'a)
- (make-vector 5 'a)) ===> #t
- (equal? (lambda (x) x)
- (lambda (y) y)) ===> unspecified
-
-=== Numbers
-
-Numerical computation has traditionally been neglected by the Lisp
-community. Until Common Lisp there was no carefully thought out
-strategy for organizing numerical computation, and with the exception
-of the MacLisp system [20] little effort was made to execute numerical
-code efficiently. This report recognizes the excellent work of the
-Common Lisp committee and accepts many of their recommendations. In
-some ways this report simplifies and generalizes their proposals in a
-manner consistent with the purposes of Scheme.
-
-It is important to distinguish between the mathematical numbers, the
-Scheme numbers that attempt to model them, the machine representations
-used to implement the Scheme numbers, and notations used to write
-numbers. This report uses the types number, complex, real, rational,
-and integer to refer to both mathematical numbers and Scheme numbers.
-Machine representations such as fixed point and floating point are
-referred to by names such as fixnum and flonum.
-
-==== Numerical types
-
-Mathematically, numbers may be arranged into a tower of subtypes in
-which each level is a subset of the level above it:
-
- number
- complex
- real
- rational
- integer
-
-For example, 3 is an integer. Therefore 3 is also a rational, a real,
-and a complex. The same is true of the Scheme numbers that model 3. For
-Scheme numbers, these types are defined by the predicates number?,
-complex?, real?, rational?, and integer?.
-
-There is no simple relationship between a number's type and its
-representation inside a computer. Although most implementations of
-Scheme will offer at least two different representations of 3, these
-different representations denote the same integer.
-
-Scheme's numerical operations treat numbers as abstract data, as
-independent of their representation as possible. Although an
-implementation of Scheme may use fixnum, flonum, and perhaps other
-representations for numbers, this should not be apparent to a casual
-programmer writing simple programs.
-
-It is necessary, however, to distinguish between numbers that are
-represented exactly and those that may not be. For example, indexes
-into data structures must be known exactly, as must some polynomial
-coefficients in a symbolic algebra system. On the other hand, the
-results of measurements are inherently inexact, and irrational numbers
-may be approximated by rational and therefore inexact approximations.
-In order to catch uses of inexact numbers where exact numbers are
-required, Scheme explicitly distinguishes exact from inexact numbers.
-This distinction is orthogonal to the dimension of type.
-
-==== Exactness
-
-Scheme numbers are either exact or inexact. A number is exact if it was
-written as an exact constant or was derived from exact numbers using
-only exact operations. A number is inexact if it was written as an
-inexact constant, if it was derived using inexact ingredients, or if it
-was derived using inexact operations. Thus inexactness is a contagious
-property of a number. If two implementations produce exact results for
-a computation that did not involve inexact intermediate results, the
-two ultimate results will be mathematically equivalent. This is
-generally not true of computations involving inexact numbers since
-approximate methods such as floating point arithmetic may be used, but
-it is the duty of each implementation to make the result as close as
-practical to the mathematically ideal result.
-
-Rational operations such as + should always produce exact results when
-given exact arguments. If the operation is unable to produce an exact
-result, then it may either report the violation of an implementation
-restriction or it may silently coerce its result to an inexact value.
-See [[#Implementation restrictions|the next section]].
-
-With the exception of inexact->exact, the operations described in this
-section must generally return inexact results when given any inexact
-arguments. An operation may, however, return an exact result if it can
-prove that the value of the result is unaffected by the inexactness of
-its arguments. For example, multiplication of any number by an exact
-zero may produce an exact zero result, even if the other argument is
-inexact.
-
-==== Implementation restrictions
-
-Implementations of Scheme are not required to implement the whole
-tower of subtypes given under "[[#Numerical types|Numerical types]]",
-but they must implement a coherent subset consistent with both the
-purposes of the implementation and the spirit of the Scheme
-language. For example, an implementation in which all numbers are real
-may still be quite useful.
-
-Implementations may also support only a limited range of numbers of any
-type, subject to the requirements of this section. The supported range
-for exact numbers of any type may be different from the supported range
-for inexact numbers of that type. For example, an implementation that
-uses flonums to represent all its inexact real numbers may support a
-practically unbounded range of exact integers and rationals while
-limiting the range of inexact reals (and therefore the range of inexact
-integers and rationals) to the dynamic range of the flonum format.
-Furthermore the gaps between the representable inexact integers and
-rationals are likely to be very large in such an implementation as the
-limits of this range are approached.
-
-An implementation of Scheme must support exact integers throughout the
-range of numbers that may be used for indexes of lists, vectors, and
-strings or that may result from computing the length of a list, vector,
-or string. The length, vector-length, and string-length procedures must
-return an exact integer, and it is an error to use anything but an
-exact integer as an index. Furthermore any integer constant within the
-index range, if expressed by an exact integer syntax, will indeed be
-read as an exact integer, regardless of any implementation restrictions
-that may apply outside this range. Finally, the procedures listed below
-will always return an exact integer result provided all their arguments
-are exact integers and the mathematically expected result is
-representable as an exact integer within the implementation:
-
- + - *
- quotient remainder modulo
- max min abs
- numerator denominator gcd
- lcm floor ceiling
- truncate round rationalize
- expt
-
-Implementations are encouraged, but not required, to support exact
-integers and exact rationals of practically unlimited size and
-precision, and to implement the above procedures and the / procedure in
-such a way that they always return exact results when given exact
-arguments. If one of these procedures is unable to deliver an exact
-result when given exact arguments, then it may either report a
-violation of an implementation restriction or it may silently coerce
-its result to an inexact number. Such a coercion may cause an error
-later.
-
-An implementation may use floating point and other approximate
-representation strategies for inexact numbers. This report recommends,
-but does not require, that the IEEE 32-bit and 64-bit floating point
-standards be followed by implementations that use flonum
-representations, and that implementations using other representations
-should match or exceed the precision achievable using these floating
-point standards [12].
-
-In particular, implementations that use flonum representations must
-follow these rules: A flonum result must be represented with at least
-as much precision as is used to express any of the inexact arguments to
-that operation. It is desirable (but not required) for potentially
-inexact operations such as sqrt, when applied to exact arguments, to
-produce exact answers whenever possible (for example the square root of
-an exact 4 ought to be an exact 2). If, however, an exact number is
-operated upon so as to produce an inexact result (as by sqrt), and if
-the result is represented as a flonum, then the most precise flonum
-format available must be used; but if the result is represented in some
-other way then the representation must have at least as much precision
-as the most precise flonum format available.
-
-Although Scheme allows a variety of written notations for numbers, any
-particular implementation may support only some of them. For example,
-an implementation in which all numbers are real need not support the
-rectangular and polar notations for complex numbers. If an
-implementation encounters an exact numerical constant that it cannot
-represent as an exact number, then it may either report a violation of
-an implementation restriction or it may silently represent the constant
-by an inexact number.
-
-==== Syntax of numerical constants
-
-For a complete formal description of the syntax of the written
-representations for numbers, see the R5RS report. Note that case is
-not significant in numerical constants.
-
-A number may be written in binary, octal, decimal, or hexadecimal by
-the use of a radix prefix. The radix prefixes are #b (binary), #o
-(octal), #d (decimal), and #x (hexadecimal). With no radix prefix, a
-number is assumed to be expressed in decimal.
-
-A numerical constant may be specified to be either exact or inexact by
-a prefix. The prefixes are #e for exact, and #i for inexact. An
-exactness prefix may appear before or after any radix prefix that is
-used. If the written representation of a number has no exactness
-prefix, the constant may be either inexact or exact. It is inexact if
-it contains a decimal point, an exponent, or a "#" character in the
-place of a digit, otherwise it is exact. In systems with inexact
-numbers of varying precisions it may be useful to specify the precision
-of a constant. For this purpose, numerical constants may be written
-with an exponent marker that indicates the desired precision of the
-inexact representation. The letters s, f, d, and l specify the use of
-short, single, double, and long precision, respectively. (When fewer
-than four internal inexact representations exist, the four size
-specifications are mapped onto those available. For example, an
-implementation with two internal representations may map short and
-single together and long and double together.) In addition, the
-exponent marker e specifies the default precision for the
-implementation. The default precision has at least as much precision as
-double, but implementations may wish to allow this default to be set by
-the user.
-
- 3.14159265358979F0
- Round to single --- 3.141593
- 0.6L0
- Extend to long --- .600000000000000
-
-==== Numerical operations
-
-The numerical routines described below have argument restrictions,
-which are encoded in the naming conventions of the arguments as
-given in the procedure's signature. The conventions are as follows:
-
-; {{obj}} : any object
-; {{list, list1, ... listj, ... list : (see "[[#Pairs_and_lists|Pairs and lists]]" below)
-; {{z, z1, ... zj, ...}} : complex number
-; {{x, x1, ... xj, ...}} : real number
-; {{y, y1, ... yj, ...}} : real number
-; {{q, q1, ... qj, ...}} : rational number
-; {{n, n1, ... nj, ...}} : integer
-; {{k, k1, ... kj, ...}} : exact non-negative integer
-
-The examples used in this section assume that any
-numerical constant written using an exact notation is indeed
-represented as an exact number. Some examples also assume that certain
-numerical constants written using an inexact notation can be
-represented without loss of accuracy; the inexact constants were chosen
-so that this is likely to be true in implementations that use flonums
-to represent inexact numbers.
-
-<procedure>(number? obj)</procedure><br>
-<procedure>(complex? obj)</procedure><br>
-<procedure>(real? obj)</procedure><br>
-<procedure>(rational? obj)</procedure><br>
-<procedure>(integer? obj)</procedure><br>
-
-These numerical type predicates can be applied to any kind of argument,
-including non-numbers. They return #t if the object is of the named
-type, and otherwise they return #f. In general, if a type predicate is
-true of a number then all higher type predicates are also true of that
-number. Consequently, if a type predicate is false of a number, then
-all lower type predicates are also false of that number. If z is an
-inexact complex number, then (real? z) is true if and only if (zero?
-(imag-part z)) is true. If x is an inexact real number, then (integer?
-x) is true if and only if (= x (round x)).
-
- (complex? 3+4i) ===> #t
- (complex? 3) ===> #t
- (real? 3) ===> #t
- (real? -2.5+0.0i) ===> #t
- (real? #e1e10) ===> #t
- (rational? 6/10) ===> #t
- (rational? 6/3) ===> #t
- (integer? 3+0i) ===> #t
- (integer? 3.0) ===> #t
- (integer? 8/4) ===> #t
-
-Note: The behavior of these type predicates on inexact numbers is
-unreliable, since any inaccuracy may affect the result.
-
-Note: In many implementations the rational? procedure will be the
-same as real?, and the complex? procedure will be the same as
-number?, but unusual implementations may be able to represent some
-irrational numbers exactly or may extend the number system to
-support some kind of non-complex numbers.
-
-<procedure>(exact? z)</procedure><br>
-<procedure>(inexact? z)</procedure><br>
-
-These numerical predicates provide tests for the exactness of a
-quantity. For any Scheme number, precisely one of these predicates is
-true.
-
-<procedure>(= z[1] z[2] z[3] ...)</procedure><br>
-<procedure>(< x[1] x[2] x[3] ...)</procedure><br>
-<procedure>(> x[1] x[2] x[3] ...)</procedure><br>
-<procedure>(<= x[1] x[2] x[3] ...)</procedure><br>
-<procedure>(>= x[1] x[2] x[3] ...)</procedure><br>
-
-These procedures return #t if their arguments are (respectively):
-equal, monotonically increasing, monotonically decreasing,
-monotonically nondecreasing, or monotonically nonincreasing.
-
-These predicates are required to be transitive.
-
-Note: The traditional implementations of these predicates in
-Lisp-like languages are not transitive.
-
-Note: While it is not an error to compare inexact numbers using
-these predicates, the results may be unreliable because a small
-inaccuracy may affect the result; this is especially true of = and
-zero?. When in doubt, consult a numerical analyst.
-
-<procedure>(zero? z)</procedure><br>
-<procedure>(positive? x)</procedure><br>
-<procedure>(negative? x)</procedure><br>
-<procedure>(odd? n)</procedure><br>
-<procedure>(even? n)</procedure><br>
-
-These numerical predicates test a number for a particular property,
-returning #t or #f. See note above.
-
-<procedure>(max x[1] x[2] ...)</procedure><br>
-<procedure>(min x[1] x[2] ...)</procedure><br>
-
-These procedures return the maximum or minimum of their arguments.
-
- (max 3 4) ===> 4 ; exact
- (max 3.9 4) ===> 4.0 ; inexact
-
-Note: If any argument is inexact, then the result will also be
-inexact (unless the procedure can prove that the inaccuracy is not
-large enough to affect the result, which is possible only in
-unusual implementations). If min or max is used to compare numbers
-of mixed exactness, and the numerical value of the result cannot be
-represented as an inexact number without loss of accuracy, then the
-procedure may report a violation of an implementation restriction.
-
-<procedure>(+ z[1] ...)</procedure><br>
-<procedure>(* z[1] ...)</procedure><br>
-
-These procedures return the sum or product of their arguments.
-
- (+ 3 4) ===> 7
- (+ 3) ===> 3
- (+) ===> 0
- (* 4) ===> 4
- (*) ===> 1
-
-<procedure>(- z[1] z[2])</procedure><br>
-<procedure>(- z)</procedure><br>
-<procedure>(- z[1] z[2] ...)</procedure><br>
-<procedure>(/ z[1] z[2])</procedure><br>
-<procedure>(/ z)</procedure><br>
-<procedure>(/ z[1] z[2] ...)</procedure><br>
-
-With two or more arguments, these procedures return the difference or
-quotient of their arguments, associating to the left. With one
-argument, however, they return the additive or multiplicative inverse
-of their argument.
-
- (- 3 4) ===> -1
- (- 3 4 5) ===> -6
- (- 3) ===> -3
- (/ 3 4 5) ===> 3/20
- (/ 3) ===> 1/3
-
-<procedure>(abs x)</procedure><br>
-
-Abs returns the absolute value of its argument.
-
- (abs -7) ===> 7
-
-<procedure>(quotient n[1] n[2])</procedure><br>
-<procedure>(remainder n[1] n[2])</procedure><br>
-<procedure>(modulo n[1] n[2])</procedure><br>
-
-These procedures implement number-theoretic (integer) division. n[2]
-should be non-zero. All three procedures return integers. If n[1]/n[2]
-is an integer:
-
- (quotient n[1] n[2]) ===> n[1]/n[2]
- (remainder n[1] n[2]) ===> 0
- (modulo n[1] n[2]) ===> 0
-
-If n[1]/n[2] is not an integer:
-
- (quotient n[1] n[2]) ===> n[q]
- (remainder n[1] n[2]) ===> n[r]
- (modulo n[1] n[2]) ===> n[m]
-
-where n[q] is n[1]/n[2] rounded towards zero, 0 < |n[r]| < |n[2]|, 0 <
-|n[m]| < |n[2]|, n[r] and n[m] differ from n[1] by a multiple of n[2],
-n[r] has the same sign as n[1], and n[m] has the same sign as n[2].
-
-From this we can conclude that for integers n[1] and n[2] with n[2] not
-equal to 0,
-
- (= n[1] (+ (* n[2] (quotient n[1] n[2]))
- (remainder n[1] n[2])))
- ===> #t
-
-provided all numbers involved in that computation are exact.
-
- (modulo 13 4) ===> 1
- (remainder 13 4) ===> 1
-
- (modulo -13 4) ===> 3
- (remainder -13 4) ===> -1
-
- (modulo 13 -4) ===> -3
- (remainder 13 -4) ===> 1
-
- (modulo -13 -4) ===> -1
- (remainder -13 -4) ===> -1
-
- (remainder -13 -4.0) ===> -1.0 ; inexact
-
-<procedure>(gcd n[1] ...)</procedure><br>
-<procedure>(lcm n[1] ...)</procedure><br>
-
-These procedures return the greatest common divisor or least common
-multiple of their arguments. The result is always non-negative.
-
- (gcd 32 -36) ===> 4
- (gcd) ===> 0
- (lcm 32 -36) ===> 288
- (lcm 32.0 -36) ===> 288.0 ; inexact
- (lcm) ===> 1
-
-<procedure>(numerator q)</procedure><br>
-<procedure>(denominator q)</procedure><br>
-
-These procedures return the numerator or denominator of their argument;
-the result is computed as if the argument was represented as a fraction
-in lowest terms. The denominator is always positive. The denominator of
-0 is defined to be 1.
-
- (numerator (/ 6 4)) ===> 3
- (denominator (/ 6 4)) ===> 2
- (denominator
- (exact->inexact (/ 6 4))) ===> 2.0
-
-<procedure>(floor x)</procedure><br>
-<procedure>(ceiling x)</procedure><br>
-<procedure>(truncate x)</procedure><br>
-<procedure>(round x)</procedure><br>
-
-These procedures return integers. Floor returns the largest integer not
-larger than x. Ceiling returns the smallest integer not smaller than x.
-Truncate returns the integer closest to x whose absolute value is not
-larger than the absolute value of x. Round returns the closest integer
-to x, rounding to even when x is halfway between two integers.
-
-Rationale: Round rounds to even for consistency with the default
-rounding mode specified by the IEEE floating point standard.
-
-Note: If the argument to one of these procedures is inexact, then
-the result will also be inexact. If an exact value is needed, the
-result should be passed to the inexact->exact procedure.
-
- (floor -4.3) ===> -5.0
- (ceiling -4.3) ===> -4.0
- (truncate -4.3) ===> -4.0
- (round -4.3) ===> -4.0
-
- (floor 3.5) ===> 3.0
- (ceiling 3.5) ===> 4.0
- (truncate 3.5) ===> 3.0
- (round 3.5) ===> 4.0 ; inexact
-
- (round 7/2) ===> 4 ; exact
- (round 7) ===> 7
-
-<procedure>(rationalize x y)</procedure><br>
-
-Rationalize returns the simplest rational number differing from x by no
-more than y. A rational number r[1] is simpler than another rational
-number r[2] if r[1] = p[1]/q[1] and r[2] = p[2]/q[2] (in lowest terms)
-and |p[1]| < |p[2]| and |q[1]| < |q[2]|. Thus 3/5 is simpler than 4/7.
-Although not all rationals are comparable in this ordering (consider 2/
-7 and 3/5) any interval contains a rational number that is simpler than
-every other rational number in that interval (the simpler 2/5 lies
-between 2/7 and 3/5). Note that 0 = 0/1 is the simplest rational of
-all.
-
- (rationalize
- (inexact->exact .3) 1/10) ===> 1/3 ; exact
- (rationalize .3 1/10) ===> #i1/3 ; inexact
-
-<procedure>(exp z)</procedure><br>
-<procedure>(log z)</procedure><br>
-<procedure>(sin z)</procedure><br>
-<procedure>(cos z)</procedure><br>
-<procedure>(tan z)</procedure><br>
-<procedure>(asin z)</procedure><br>
-<procedure>(acos z)</procedure><br>
-<procedure>(atan z)</procedure><br>
-<procedure>(atan y x)</procedure><br>
-
-These procedures are part of every implementation that supports general
-real numbers; they compute the usual transcendental functions. Log
-computes the natural logarithm of z (not the base ten logarithm). Asin,
-acos, and atan compute arcsine (sin^-1), arccosine (cos^-1), and
-arctangent (tan^-1), respectively. The two-argument variant of atan
-computes (angle (make-rectangular x y)) (see below), even in
-implementations that don't support general complex numbers.
-
-In general, the mathematical functions log, arcsine, arccosine, and
-arctangent are multiply defined. The value of log z is defined to be
-the one whose imaginary part lies in the range from -pi
-(exclusive) to pi (inclusive). log 0 is undefined. With log
-defined this way, the values of sin^-1 z, cos^-1 z, and tan^-1 z are
-according to the following formulae:
-
- sin^-1 z = - i log (i z + (1 - z^2)^1/2)
-
- cos^-1 z = pi / 2 - sin^-1 z
-
- tan^-1 z = (log (1 + i z) - log (1 - i z)) / (2 i)
-
-The above specification follows [27], which in turn cites [19]; refer
-to these sources for more detailed discussion of branch cuts, boundary
-conditions, and implementation of these functions. When it is possible
-these procedures produce a real result from a real argument.
-
-<procedure>(sqrt z)</procedure><br>
-
-Returns the principal square root of z. The result will have either
-positive real part, or zero real part and non-negative imaginary part.
-
-<procedure>(expt z[1] z[2])</procedure><br>
-
-Returns z[1] raised to the power z[2]. For z[1] != 0
-
- z[1]^z[2] = e^z[2] log z[1]
-
-0^z is 1 if z = 0 and 0 otherwise.
-
-<procedure>(make-rectangular x[1] x[2])</procedure><br>
-<procedure>(make-polar x[3] x[4])</procedure><br>
-<procedure>(real-part z)</procedure><br>
-<procedure>(imag-part z)</procedure><br>
-<procedure>(magnitude z)</procedure><br>
-<procedure>(angle z)</procedure><br>
-
-These procedures are part of every implementation that supports general
-complex numbers. Suppose x[1], x[2], x[3], and x[4] are real numbers
-and z is a complex number such that
-
- z = x[1] + x[2]i = x[3] . e^i x[4]
-
-Then
-
- (make-rectangular x[1] x[2]) ===> z
- (make-polar x[3] x[4]) ===> z
- (real-part z) ===> x[1]
- (imag-part z) ===> x[2]
- (magnitude z) ===> |x[3]|
- (angle z) ===> x[angle]
-
-where - pi < x[angle] < pi with x[angle] = x[4] + 2 pi n
-for some integer n.
-
-Rationale: Magnitude is the same as abs for a real argument, but
-abs must be present in all implementations, whereas magnitude need
-only be present in implementations that support general complex
-numbers.
-
-<procedure>(exact->inexact z)</procedure><br>
-<procedure>(inexact->exact z)</procedure><br>
-
-Exact->inexact returns an inexact representation of z. The value
-returned is the inexact number that is numerically closest to the
-argument. If an exact argument has no reasonably close inexact
-equivalent, then a violation of an implementation restriction may be
-reported.
-
-Inexact->exact returns an exact representation of z. The value returned
-is the exact number that is numerically closest to the argument. If an
-inexact argument has no reasonably close exact equivalent, then a
-violation of an implementation restriction may be reported.
-
-These procedures implement the natural one-to-one correspondence
-between exact and inexact integers throughout an
-implementation-dependent range.
-See "[[#implementation-restrictions|Implementation restrictions]]".
-
-==== Numerical input and output
-
-<procedure>(number->string z [radix])</procedure>
-
-Radix must be an exact integer. The R5RS standard only requires
-implementations to support 2, 8, 10, or 16, but CHICKEN allows any
-radix between 2 and 36, inclusive (note: a bug in CHICKEN 5 currently
-limits the upper bound to 16). If omitted, radix defaults to
-10. The procedure number->string takes a number and a radix and
-returns as a string an external representation of the given number in
-the given radix such that
-
- (let ((number number)
- (radix radix))
- (eqv? number
- (string->number (number->string number
- radix)
- radix)))
-
-is true. It is an error if no possible result makes this expression
-true.
-
-If z is inexact, the radix is 10, and the above expression can be
-satisfied by a result that contains a decimal point, then the result
-contains a decimal point and is expressed using the minimum number of
-digits (exclusive of exponent and trailing zeroes) needed to make the
-above expression true [3, 5]; otherwise the format of the result is
-unspecified.
-
-The result returned by number->string never contains an explicit radix
-prefix.
-
-Note: The error case can occur only when z is not a complex
-number or is a complex number with a non-rational real or imaginary
-part.
-
-Rationale: If z is an inexact number represented using flonums,
-and the radix is 10, then the above expression is normally
-satisfied by a result containing a decimal point. The unspecified
-case allows for infinities, NaNs, and non-flonum representations.
-
-As an extension to R5RS, CHICKEN supports reading and writing the
-special IEEE floating-point numbers ''+nan'', ''+inf'' and ''-inf'',
-as well as negative zero.
-
-<procedure>(string->number string)</procedure><br>
-<procedure>(string->number string radix)</procedure><br>
-
-Returns a number of the maximally precise representation expressed by
-the given string. Radix must be an exact integer. The R5RS standard
-only requires implementations to support 2, 8, 10, or 16, but CHICKEN
-allows any radix between 2 and 36, inclusive. If supplied, radix is a
-default radix that may be overridden by an explicit radix prefix in
-string (e.g. "#o177"). If radix is not supplied, then the default
-radix is 10. If string is not a syntactically valid notation for a
-number, then string->number returns #f.
-
- (string->number "100") ===> 100
- (string->number "100" 16) ===> 256
- (string->number "1e2") ===> 100.0
- (string->number "15##") ===> 1500.0
-
-Note: The domain of string->number may be restricted by
-implementations in the following ways. String->number is permitted
-to return #f whenever string contains an explicit radix prefix. If
-all numbers supported by an implementation are real, then string->
-number is permitted to return #f whenever string uses the polar or
-rectangular notations for complex numbers. If all numbers are
-integers, then string->number may return #f whenever the fractional
-notation is used. If all numbers are exact, then string->number may
-return #f whenever an exponent marker or explicit exactness prefix
-is used, or if a # appears in place of a digit. If all inexact
-numbers are integers, then string->number may return #f whenever a
-decimal point is used.
-
-As an extension to R5RS, CHICKEN supports reading and writing the
-special IEEE floating-point numbers ''+nan'', ''+inf'' and ''-inf'',
-as well as negative zero.
-
-=== Other data types
-
-This section describes operations on some of Scheme's non-numeric data
-types: booleans, pairs, lists, symbols, characters, strings and
-vectors.
-
-==== Booleans
-
-The standard boolean objects for true and false are written as #t and #f.
-What really matters, though, are the objects that the Scheme
-conditional expressions (if, cond, and, or, do) treat as true or false.
-The phrase "a true value" (or sometimes just "true") means any
-object treated as true by the conditional expressions, and the phrase
-"a false value" (or "false") means any object treated as false by
-the conditional expressions.
-
-Of all the standard Scheme values, only #f counts as false in
-conditional expressions. Except for #f, all standard Scheme values,
-including #t, pairs, the empty list, symbols, numbers, strings,
-vectors, and procedures, count as true.
-
-Note: Programmers accustomed to other dialects of Lisp should be
-aware that Scheme distinguishes both #f and the empty list from the
-symbol nil.
-
-Boolean constants evaluate to themselves, so they do not need to be
-quoted in programs.
-
- #t ===> #t
- #f ===> #f
- '#f ===> #f
-
-<procedure>(not obj)</procedure><br>
-
-Not returns #t if obj is false, and returns #f otherwise.
-
- (not #t) ===> #f
- (not 3) ===> #f
- (not (list 3)) ===> #f
- (not #f) ===> #t
- (not '()) ===> #f
- (not (list)) ===> #f
- (not 'nil) ===> #f
-
-<procedure>(boolean? obj)</procedure><br>
-
-Boolean? returns #t if obj is either #t or #f and returns #f otherwise.
-
- (boolean? #f) ===> #t
- (boolean? 0) ===> #f
- (boolean? '()) ===> #f
-
-==== Pairs and lists
-
-A pair (sometimes called a dotted pair) is a record structure with two
-fields called the car and cdr fields (for historical reasons). Pairs
-are created by the procedure cons. The car and cdr fields are accessed
-by the procedures car and cdr. The car and cdr fields are assigned by
-the procedures set-car! and set-cdr!.
-
-Pairs are used primarily to represent lists. A list can be defined
-recursively as either the empty list or a pair whose cdr is a list.
-More precisely, the set of lists is defined as the smallest set X such
-that
-
-* The empty list is in X.
-* If list is in X, then any pair whose cdr field contains list is
- also in X.
-
-The objects in the car fields of successive pairs of a list are the
-elements of the list. For example, a two-element list is a pair whose
-car is the first element and whose cdr is a pair whose car is the
-second element and whose cdr is the empty list. The length of a list is
-the number of elements, which is the same as the number of pairs.
-
-The empty list is a special object of its own type (it is not a pair);
-it has no elements and its length is zero.
-
-Note: The above definitions imply that all lists have finite
-length and are terminated by the empty list.
-
-The most general notation (external representation) for Scheme pairs is
-the "dotted" notation (c[1] . c[2]) where c[1] is the value of the
-car field and c[2] is the value of the cdr field. For example (4 . 5)
-is a pair whose car is 4 and whose cdr is 5. Note that (4 . 5) is the
-external representation of a pair, not an expression that evaluates to
-a pair.
-
-A more streamlined notation can be used for lists: the elements of the
-list are simply enclosed in parentheses and separated by spaces. The
-empty list is written () . For example,
-
- (a b c d e)
-
-and
-
- (a . (b . (c . (d . (e . ())))))
-
-are equivalent notations for a list of symbols.
-
-A chain of pairs not ending in the empty list is called an improper
-list. Note that an improper list is not a list. The list and dotted
-notations can be combined to represent improper lists:
-
- (a b c . d)
-
-is equivalent to
-
- (a . (b . (c . d)))
-
-Whether a given pair is a list depends upon what is stored in the cdr
-field. When the set-cdr! procedure is used, an object can be a list one
-moment and not the next:
-
- (define x (list 'a 'b 'c))
- (define y x)
- y ===> (a b c)
- (list? y) ===> #t
- (set-cdr! x 4) ===> unspecified
- x ===> (a . 4)
- (eqv? x y) ===> #t
- y ===> (a . 4)
- (list? y) ===> #f
- (set-cdr! x x) ===> unspecified
- (list? x) ===> #f
-
-Within literal expressions and representations of objects read by the
-read procedure, the forms '<datum>, `<datum>, ,<datum>, and ,@<datum>
-denote two-element lists whose first elements are the symbols quote,
-quasiquote, unquote, and unquote-splicing, respectively. The second
-element in each case is <datum>. This convention is supported so that
-arbitrary Scheme programs may be represented as lists. That is,
-according to Scheme's grammar, every <expression> is also a <datum>.
-Among other things, this permits the use of the read procedure to
-parse Scheme programs.
-
-<procedure>(pair? obj)</procedure><br>
-
-Pair? returns #t if obj is a pair, and otherwise returns #f.
-NOTE: [[Module (chicken base)#weak-pairs|Weak pairs]] are regarded
-as pairs by this procedure.
-
- (pair? '(a . b)) ===> #t
- (pair? '(a b c)) ===> #t
- (pair? '()) ===> #f
- (pair? '#(a b)) ===> #f
- (pair? (cons 1 2)) ===> #t
-
- (import (chicken base))
- (pair? (weak-cons 1 2)) ===> #t
-
-<procedure>(cons obj[1] obj[2])</procedure><br>
-
-Returns a newly allocated pair whose car is obj[1] and whose cdr is
-obj[2]. The pair is guaranteed to be different (in the sense of eqv?)
-from every existing object.
-
- (cons 'a '()) ===> (a)
- (cons '(a) '(b c d)) ===> ((a) b c d)
- (cons "a" '(b c)) ===> ("a" b c)
- (cons 'a 3) ===> (a . 3)
- (cons '(a b) 'c) ===> ((a b) . c)
-
-<procedure>(car pair)</procedure><br>
-
-Returns the contents of the car field of pair. Note that it is an error
-to take the car of the empty list.
-
- (car '(a b c)) ===> a
- (car '((a) b c d)) ===> (a)
- (car '(1 . 2)) ===> 1
- (car '()) ===> error
- (car (cons 1 2)) ===> 1
-
- (import (chicken base))
- (car (weak-cons 1 2)) ===> 1
-
-<procedure>(cdr pair)</procedure><br>
-
-Returns the contents of the cdr field of pair. Note that it is an error
-to take the cdr of the empty list.
-
- (cdr '((a) b c d)) ===> (b c d)
- (cdr '(1 . 2)) ===> 2
- (cdr '()) ===> error
- (cdr (cons 1 2)) ===> 2
-
- (import (chicken base))
- (cdr (weak-cons 1 2)) ===> 2
-
-<procedure>(set-car! pair obj)</procedure><br>
-
-Stores obj in the car field of pair. The value returned by set-car! is
-unspecified.
-
- (define (f) (list 'not-a-constant-list))
- (define (g) '(constant-list))
- (set-car! (f) 3) ===> unspecified
- (set-car! (g) 3) ===> error
-
-<procedure>(set-cdr! pair obj)</procedure><br>
-
-Stores obj in the cdr field of pair. The value returned by set-cdr! is
-unspecified.
-
-<procedure>(caar pair)</procedure><br>
-<procedure>(cadr pair)</procedure><br>
-<procedure>(cdar pair)</procedure><br>
-<procedure>(cddr pair)</procedure><br>
-<procedure>(caaar pair)</procedure><br>
-<procedure>(caadr pair)</procedure><br>
-<procedure>(cadar pair)</procedure><br>
-<procedure>(caddr pair)</procedure><br>
-<procedure>(cdaar pair)</procedure><br>
-<procedure>(cdadr pair)</procedure><br>
-<procedure>(cddar pair)</procedure><br>
-<procedure>(cdddr pair)</procedure><br>
-<procedure>(caaaar pair)</procedure><br>
-<procedure>(caaadr pair)</procedure><br>
-<procedure>(caadar pair)</procedure><br>
-<procedure>(caaddr pair)</procedure><br>
-<procedure>(cadaar pair)</procedure><br>
-<procedure>(cadadr pair)</procedure><br>
-<procedure>(caddar pair)</procedure><br>
-<procedure>(cadddr pair)</procedure><br>
-<procedure>(cdaaar pair)</procedure><br>
-<procedure>(cdaadr pair)</procedure><br>
-<procedure>(cdadar pair)</procedure><br>
-<procedure>(cdaddr pair)</procedure><br>
-<procedure>(cddaar pair)</procedure><br>
-<procedure>(cddadr pair)</procedure><br>
-<procedure>(cdddar pair)</procedure><br>
-<procedure>(cddddr pair)</procedure><br>
-
-These procedures are compositions of car and cdr, where for example
-caddr could be defined by
-
- (define caddr (lambda (x) (car (cdr (cdr x))))).
-
-<procedure>(null? obj)</procedure><br>
-
-Returns #t if obj is the empty list, otherwise returns #f.
-
-<procedure>(list? obj)</procedure><br>
-
-Returns #t if obj is a list, otherwise returns #f. By definition, all
-lists have finite length and are terminated by the empty list.
-
- (list? '(a b c)) ===> #t
- (list? '()) ===> #t
- (list? '(a . b)) ===> #f
- (let ((x (list 'a)))
- (set-cdr! x x)
- (list? x)) ===> #f
-
-<procedure>(list obj ...)</procedure><br>
-
-Returns a newly allocated list of its arguments.
-
- (list 'a (+ 3 4) 'c) ===> (a 7 c)
- (list) ===> ()
-
-<procedure>(length list)</procedure><br>
-
-Returns the length of list.
-
- (length '(a b c)) ===> 3
- (length '(a (b) (c d e))) ===> 3
- (length '()) ===> 0
-
-<procedure>(append list ...)</procedure><br>
-
-Returns a list consisting of the elements of the first list followed by
-the elements of the other lists.
-
- (append '(x) '(y)) ===> (x y)
- (append '(a) '(b c d)) ===> (a b c d)
- (append '(a (b)) '((c))) ===> (a (b) (c))
-
-The resulting list is always newly allocated, except that it shares
-structure with the last list argument. The last argument may actually
-be any object; an improper list results if the last argument is not a
-proper list.
-
- (append '(a b) '(c . d)) ===> (a b c . d)
- (append '() 'a) ===> a
-
-<procedure>(reverse list)</procedure><br>
-
-Returns a newly allocated list consisting of the elements of list in
-reverse order.
-
- (reverse '(a b c)) ===> (c b a)
- (reverse '(a (b c) d (e (f))))
- ===> ((e (f)) d (b c) a)
-
-<procedure>(list-tail list k)</procedure><br>
-
-Returns the sublist of list obtained by omitting the first k elements.
-It is an error if list has fewer than k elements. List-tail could be
-defined by
-
- (define list-tail
- (lambda (x k)
- (if (zero? k)
- x
- (list-tail (cdr x) (- k 1)))))
-
-<procedure>(list-ref list k)</procedure><br>
-
-Returns the kth element of list. (This is the same as the car of
-(list-tail list k).) It is an error if list has fewer than k elements.
-
- (list-ref '(a b c d) 2) ===> c
- (list-ref '(a b c d)
- (inexact->exact (round 1.8)))
- ===> c
-
-<procedure>(memq obj list)</procedure><br>
-<procedure>(memv obj list)</procedure><br>
-<procedure>(member obj list)</procedure><br>
-
-These procedures return the first sublist of list whose car is obj,
-where the sublists of list are the non-empty lists returned by
-(list-tail list k) for k less than the length of list. If obj does not
-occur in list, then #f (not the empty list) is returned. Memq uses eq?
-to compare obj with the elements of list, while memv uses eqv? and
-member uses equal?.
-
- (memq 'a '(a b c)) ===> (a b c)
- (memq 'b '(a b c)) ===> (b c)
- (memq 'a '(b c d)) ===> #f
- (memq (list 'a) '(b (a) c)) ===> #f
- (member (list 'a)
- '(b (a) c)) ===> ((a) c)
- (memq 101 '(100 101 102)) ===> unspecified
- (memv 101 '(100 101 102)) ===> (101 102)
-
-<procedure>(assq obj alist)</procedure><br>
-<procedure>(assv obj alist)</procedure><br>
-<procedure>(assoc obj alist)</procedure><br>
-
-Alist (for "association list") must be a list of pairs. These
-procedures find the first pair in alist whose car field is obj, and
-returns that pair. If no pair in alist has obj as its car, then #f (not
-the empty list) is returned. Assq uses eq? to compare obj with the car
-fields of the pairs in alist, while assv uses eqv? and assoc uses
-equal?.
-
- (define e '((a 1) (b 2) (c 3)))
- (assq 'a e) ===> (a 1)
- (assq 'b e) ===> (b 2)
- (assq 'd e) ===> #f
- (assq (list 'a) '(((a)) ((b)) ((c))))
- ===> #f
- (assoc (list 'a) '(((a)) ((b)) ((c))))
- ===> ((a))
- (assq 5 '((2 3) (5 7) (11 13)))
- ===> unspecified
- (assv 5 '((2 3) (5 7) (11 13)))
- ===> (5 7)
-
-Rationale: Although they are ordinarily used as predicates, memq,
-memv, member, assq, assv, and assoc do not have question marks in
-their names because they return useful values rather than just #t
-or #f.
-
-==== Symbols
-
-Symbols are objects whose usefulness rests on the fact that two symbols
-are identical (in the sense of eqv?) if and only if their names are
-spelled the same way. This is exactly the property needed to represent
-identifiers in programs, and so most implementations of Scheme use them
-internally for that purpose. Symbols are useful for many other
-applications; for instance, they may be used the way enumerated values
-are used in Pascal.
-
-The rules for writing a symbol are exactly the same as the rules for
-writing an identifier.
-
-It is guaranteed that any symbol that has been returned as part of a
-literal expression, or read using the read procedure, and subsequently
-written out using the write procedure, will read back in as the
-identical symbol (in the sense of eqv?). The string->symbol procedure,
-however, can create symbols for which this write/read invariance may
-not hold because their names contain special characters or letters in
-the non-standard case.
-
-Note: Some implementations of Scheme have a feature known as
-"slashification" in order to guarantee write/read invariance for
-all symbols, but historically the most important use of this
-feature has been to compensate for the lack of a string data type.
-
-Some implementations also have "uninterned symbols", which defeat
-write/read invariance even in implementations with slashification,
-and also generate exceptions to the rule that two symbols are the
-same if and only if their names are spelled the same.
-
-<procedure>(symbol? obj)</procedure><br>
-
-Returns #t if obj is a symbol, otherwise returns #f.
-
- (symbol? 'foo) ===> #t
- (symbol? (car '(a b))) ===> #t
- (symbol? "bar") ===> #f
- (symbol? 'nil) ===> #t
- (symbol? '()) ===> #f
- (symbol? #f) ===> #f
-
-<procedure>(symbol->string symbol)</procedure><br>
-
-Returns the name of symbol as a string. If the symbol was part of an
-object returned as the value of a literal expression (see
-"[[#literal-expressions|literal expressions]]") or by a call to the
-read procedure, and its name contains alphabetic characters, then the
-string returned will contain characters in the implementation's
-preferred standard case -- some implementations will prefer upper
-case, others lower case. If the symbol was returned by string->symbol,
-the case of characters in the string returned will be the same as the
-case in the string that was passed to string->symbol. It is an error
-to apply mutation procedures like string-set! to strings returned by
-this procedure.
-
-The following examples assume that the implementation's standard case
-is lower case:
-
- (symbol->string 'flying-fish)
- ===> "flying-fish"
- (symbol->string 'Martin) ===> "martin"
- (symbol->string
- (string->symbol "Malvina"))
- ===> "Malvina"
-
-<procedure>(string->symbol string)</procedure><br>
-
-Returns the symbol whose name is string. This procedure can create
-symbols with names containing special characters or letters in the
-non-standard case, but it is usually a bad idea to create such symbols
-because in some implementations of Scheme they cannot be read as
-themselves. See symbol->string.
-
-The following examples assume that the implementation's standard case
-is lower case:
-
- (eq? 'mISSISSIppi 'mississippi)
- ===> #t
- (string->symbol "mISSISSIppi")
- ===> the symbol with name "mISSISSIppi"
- (eq? 'bitBlt (string->symbol "bitBlt"))
- ===> #f
- (eq? 'JollyWog
- (string->symbol
- (symbol->string 'JollyWog)))
- ===> #t
- (string=? "K. Harper, M.D."
- (symbol->string
- (string->symbol "K. Harper, M.D.")))
- ===> #t
-
-==== Characters
-
-Characters are objects that represent printed characters such as
-letters and digits. Characters are written using the notation #\
-<character> or #\<character name>. For example:
-
- #\a ; lower case letter
- #\A ; upper case letter
- #\( ; left parenthesis
- #\ ; the space character
- #\space ; the preferred way to write a space
- #\newline ; the newline character
-
-Case is significant in #\<character>, but not in #\<character name>. If
-<character> in #\<character> is alphabetic, then the character
-following <character> must be a delimiter character such as a space or
-parenthesis. This rule resolves the ambiguous case where, for example,
-the sequence of characters "#\space" could be taken to be either a
-representation of the space character or a representation of the
-character "#\s" followed by a representation of the symbol "pace."
-
-Characters written in the #\ notation are self-evaluating. That is,
-they do not have to be quoted in programs. Some of the procedures that
-operate on characters ignore the difference between upper case and
-lower case. The procedures that ignore case have "-ci" (for "case
-insensitive") embedded in their names.
-
-<procedure>(char? obj)</procedure><br>
-
-Returns #t if obj is a character, otherwise returns #f.
-
-<procedure>(char=? char[1] char[2])</procedure><br>
-<procedure>(char<? char[1] char[2])</procedure><br>
-<procedure>(char>? char[1] char[2])</procedure><br>
-<procedure>(char<=? char[1] char[2])</procedure><br>
-<procedure>(char>=? char[1] char[2])</procedure><br>
-
-These procedures impose a total ordering on the set of characters. It
-is guaranteed that under this ordering:
-
-* The upper case characters are in order. For example, (char<? #\A #\
- B) returns #t.
-* The lower case characters are in order. For example, (char<? #\a #\
- b) returns #t.
-* The digits are in order. For example, (char<? #\0 #\9) returns #t.
-* Either all the digits precede all the upper case letters, or vice
- versa.
-* Either all the digits precede all the lower case letters, or vice
- versa.
-
-Some implementations may generalize these procedures to take more than
-two arguments, as with the corresponding numerical predicates.
-
-<procedure>(char-ci=? char[1] char[2])</procedure><br>
-<procedure>(char-ci<? char[1] char[2])</procedure><br>
-<procedure>(char-ci>? char[1] char[2])</procedure><br>
-<procedure>(char-ci<=? char[1] char[2])</procedure><br>
-<procedure>(char-ci>=? char[1] char[2])</procedure><br>
-
-These procedures are similar to char=? et cetera, but they treat upper
-case and lower case letters as the same. For example, (char-ci=? #\A #\
-a) returns #t. Some implementations may generalize these procedures to
-take more than two arguments, as with the corresponding numerical
-predicates.
-
-<procedure>(char-alphabetic? char)</procedure><br>
-<procedure>(char-numeric? char)</procedure><br>
-<procedure>(char-whitespace? char)</procedure><br>
-<procedure>(char-upper-case? letter)</procedure><br>
-<procedure>(char-lower-case? letter)</procedure><br>
-
-These procedures return #t if their arguments are alphabetic, numeric,
-whitespace, upper case, or lower case characters, respectively,
-otherwise they return #f. The following remarks, which are specific to
-the ASCII character set, are intended only as a guide: The alphabetic
-characters are the 52 upper and lower case letters. The numeric
-characters are the ten decimal digits. The whitespace characters are
-space, tab, line feed, form feed, and carriage return.
-
-<procedure>(char->integer char)</procedure><br>
-<procedure>(integer->char n)</procedure><br>
-
-Given a character, char->integer returns an exact integer
-representation of the character. Given an exact integer that is the
-image of a character under char->integer, integer->char returns that
-character. These procedures implement order-preserving isomorphisms
-between the set of characters under the char<=? ordering and some
-subset of the integers under the <= ordering. That is, if
-
- (char<=? a b) ===> #t and (<= x y) ===> #t
-
-and x and y are in the domain of integer->char, then
-
- (<= (char->integer a)
- (char->integer b)) ===> #t
-
- (char<=? (integer->char x)
- (integer->char y)) ===> #t
-
-Note that {{integer->char}} does currently not detect
-a negative argument and will quietly convert {{-1}} to
-{{#x1ffff}} in CHICKEN.
-
-<procedure>(char-upcase char)</procedure><br>
-<procedure>(char-downcase char)</procedure><br>
-
-These procedures return a character char[2] such that (char-ci=? char
-char[2]). In addition, if char is alphabetic, then the result of
-char-upcase is upper case and the result of char-downcase is lower
-case.
-
-==== Strings
-
-Strings are sequences of characters. Strings are written as sequences
-of characters enclosed within doublequotes ("). A doublequote can be
-written inside a string only by escaping it with a backslash (\), as in
-
-"The word \"recursion\" has many meanings."
-
-A backslash can be written inside a string only by escaping it with
-another backslash. Scheme does not specify the effect of a backslash
-within a string that is not followed by a doublequote or backslash.
-
-A string constant may continue from one line to the next, but the exact
-contents of such a string are unspecified. The length of a string is
-the number of characters that it contains. This number is an exact,
-non-negative integer that is fixed when the string is created. The
-valid indexes of a string are the exact non-negative integers less than
-the length of the string. The first character of a string has index 0,
-the second has index 1, and so on.
-
-In phrases such as "the characters of string beginning with index
-start and ending with index end," it is understood that the index
-start is inclusive and the index end is exclusive. Thus if start and
-end are the same index, a null substring is referred to, and if start
-is zero and end is the length of string, then the entire string is
-referred to.
-
-Some of the procedures that operate on strings ignore the difference
-between upper and lower case. The versions that ignore case have
-"-ci" (for "case insensitive") embedded in their names.
-
-<procedure>(string? obj)</procedure><br>
-
-Returns #t if obj is a string, otherwise returns #f.
-
-<procedure>(make-string k)</procedure><br>
-<procedure>(make-string k char)</procedure><br>
-
-Make-string returns a newly allocated string of length k. If char is
-given, then all elements of the string are initialized to char,
-otherwise the contents of the string are unspecified.
-
-<procedure>(string char ...)</procedure><br>
-
-Returns a newly allocated string composed of the arguments.
-
-<procedure>(string-length string)</procedure><br>
-
-Returns the number of characters in the given string.
-
-<procedure>(string-ref string k)</procedure><br>
-
-k must be a valid index of string. String-ref returns character k of
-string using zero-origin indexing.
-
-<procedure>(string-set! string k char)</procedure><br>
-
-k must be a valid index of string. String-set! stores char in element k
-of string and returns an unspecified value.
-
- (define (f) (make-string 3 #\*))
- (define (g) "***")
- (string-set! (f) 0 #\?) ===> unspecified
- (string-set! (g) 0 #\?) ===> error
- (string-set! (symbol->string 'immutable)
- 0
- #\?) ===> error
-
-<procedure>(string=? string[1] string[2])</procedure><br>
-<procedure>(string-ci=? string[1] string[2])</procedure><br>
-
-Returns #t if the two strings are the same length and contain the same
-characters in the same positions, otherwise returns #f. String-ci=?
-treats upper and lower case letters as though they were the same
-character, but string=? treats upper and lower case as distinct
-characters.
-
-<procedure>(string<? string[1] string[2])</procedure><br>
-<procedure>(string>? string[1] string[2])</procedure><br>
-<procedure>(string<=? string[1] string[2])</procedure><br>
-<procedure>(string>=? string[1] string[2])</procedure><br>
-<procedure>(string-ci<? string[1] string[2])</procedure><br>
-<procedure>(string-ci>? string[1] string[2])</procedure><br>
-<procedure>(string-ci<=? string[1] string[2])</procedure><br>
-<procedure>(string-ci>=? string[1] string[2])</procedure><br>
-
-These procedures are the lexicographic extensions to strings of the
-corresponding orderings on characters. For example, string<? is the
-lexicographic ordering on strings induced by the ordering char<? on
-characters. If two strings differ in length but are the same up to the
-length of the shorter string, the shorter string is considered to be
-lexicographically less than the longer string.
-
-Implementations may generalize these and the string=? and string-ci=?
-procedures to take more than two arguments, as with the corresponding
-numerical predicates.
-
-<procedure>(substring string start [end])</procedure><br>
-
-String must be a string, and start and end must be exact integers
-satisfying
-
- 0 <= start <= end <= (string-length string)
-
-Substring returns a newly allocated string formed from the characters
-of string beginning with index start (inclusive) and ending with index
-end (exclusive). The {{end}} argument is optional and defaults to the
-length of the string, this is a non-standard extension in CHICKEN.
-
-<procedure>(string-append string ...)</procedure><br>
-
-Returns a newly allocated string whose characters form the
-concatenation of the given strings.
-
-<procedure>(string->list string)</procedure><br>
-<procedure>(list->string list)</procedure><br>
-
-String->list returns a newly allocated list of the characters that make
-up the given string. List->string returns a newly allocated string
-formed from the characters in the list list, which must be a list of
-characters. String->list and list->string are inverses so far as equal?
-is concerned.
-
-<procedure>(string-copy string)</procedure><br>
-
-Returns a newly allocated copy of the given string.
-
-<procedure>(string-fill! string char)</procedure><br>
-
-Stores char in every element of the given string and returns an
-unspecified value.
-
-==== Vectors
-
-Vectors are heterogenous structures whose elements are indexed by
-integers. A vector typically occupies less space than a list of the
-same length, and the average time required to access a randomly chosen
-element is typically less for the vector than for the list.
-
-The length of a vector is the number of elements that it contains. This
-number is a non-negative integer that is fixed when the vector is
-created. The valid indexes of a vector are the exact non-negative
-integers less than the length of the vector. The first element in a
-vector is indexed by zero, and the last element is indexed by one less
-than the length of the vector.
-
-Vectors are written using the notation #(obj ...). For example, a
-vector of length 3 containing the number zero in element 0, the list (2
-2 2 2) in element 1, and the string "Anna" in element 2 can be written
-as following:
-
- #(0 (2 2 2 2) "Anna")
-
-Note that this is the external representation of a vector, not an
-expression evaluating to a vector. Like list constants, vector
-constants must be quoted:
-
- '#(0 (2 2 2 2) "Anna")
- ===> #(0 (2 2 2 2) "Anna")
-
-<procedure>(vector? obj)</procedure><br>
-
-Returns #t if obj is a vector, otherwise returns #f.
-
-<procedure>(make-vector k)</procedure><br>
-<procedure>(make-vector k fill)</procedure><br>
-
-Returns a newly allocated vector of k elements. If a second argument is
-given, then each element is initialized to fill. Otherwise the initial
-contents of each element is unspecified.
-
-<procedure>(vector obj ...)</procedure><br>
-
-Returns a newly allocated vector whose elements contain the given
-arguments. Analogous to list.
-
- (vector 'a 'b 'c) ===> #(a b c)
-
-<procedure>(vector-length vector)</procedure><br>
-
-Returns the number of elements in vector as an exact integer.
-
-<procedure>(vector-ref vector k)</procedure><br>
-
-k must be a valid index of vector. Vector-ref returns the contents of
-element k of vector.
-
- (vector-ref '#(1 1 2 3 5 8 13 21)
- 5)
- ===> 8
- (vector-ref '#(1 1 2 3 5 8 13 21)
- (let ((i (round (* 2 (acos -1)))))
- (if (inexact? i)
- (inexact->exact i)
- i)))
- ===> 13
-
-<procedure>(vector-set! vector k obj)</procedure><br>
-
-k must be a valid index of vector. Vector-set! stores obj in element k
-of vector. The value returned by vector-set! is unspecified.
-
- (let ((vec (vector 0 '(2 2 2 2) "Anna")))
- (vector-set! vec 1 '("Sue" "Sue"))
- vec)
- ===> #(0 ("Sue" "Sue") "Anna")
-
- (vector-set! '#(0 1 2) 1 "doe")
- ===> error ; constant vector
-
-<procedure>(vector->list vector)</procedure><br>
-<procedure>(list->vector list)</procedure><br>
-
-Vector->list returns a newly allocated list of the objects contained in
-the elements of vector. List->vector returns a newly created vector
-initialized to the elements of the list list.
-
- (vector->list '#(dah dah didah))
- ===> (dah dah didah)
- (list->vector '(dididit dah))
- ===> #(dididit dah)
-
-<procedure>(vector-fill! vector fill)</procedure><br>
-
-Stores fill in every element of vector. The value returned by
-vector-fill! is unspecified.
-
-=== Control features
-
-This chapter describes various primitive procedures which control the
-flow of program execution in special ways. The procedure? predicate is
-also described here.
-
-<procedure>(procedure? obj)</procedure><br>
-
-Returns #t if obj is a procedure, otherwise returns #f.
-
- (procedure? car) ===> #t
- (procedure? 'car) ===> #f
- (procedure? (lambda (x) (* x x)))
- ===> #t
- (procedure? '(lambda (x) (* x x)))
- ===> #f
- (call-with-current-continuation procedure?)
- ===> #t
-
-<procedure>(apply proc arg[1] ... args)</procedure><br>
-
-Proc must be a procedure and args must be a list. Calls proc with the
-elements of the list (append (list arg[1] ...) args) as the actual
-arguments.
-
- (apply + (list 3 4)) ===> 7
-
- (define compose
- (lambda (f g)
- (lambda args
- (f (apply g args)))))
-
- ((compose sqrt *) 12 75) ===> 30
-
-<procedure>(map proc list[1] list[2] ...)</procedure><br>
-
-The lists must be lists, and proc must be a procedure taking as many
-arguments as there are lists and returning a single value. Map applies
-proc element-wise to the elements of the lists and returns a list of
-the results, in order. The dynamic order in which proc is applied to
-the elements of the lists is unspecified.
-
-Like in SRFI-1, this procedure allows the arguments to be of unequal
-length; it terminates when the shortest list runs out. This is a
-CHICKEN extension to R5RS.
-
- (map cadr '((a b) (d e) (g h)))
- ===> (b e h)
-
- (map (lambda (n) (expt n n))
- '(1 2 3 4 5))
- ===> (1 4 27 256 3125)
-
- (map + '(1 2 3) '(4 5 6)) ===> (5 7 9)
-
- (let ((count 0))
- (map (lambda (ignored)
- (set! count (+ count 1))
- count)
- '(a b))) ===> (1 2) or (2 1)
-
-<procedure>(for-each proc list[1] list[2] ...)</procedure><br>
-
-The arguments to for-each are like the arguments to map, but for-each
-calls proc for its side effects rather than for its values. Unlike map,
-for-each is guaranteed to call proc on the elements of the lists in
-order from the first element(s) to the last, and the value returned by
-for-each is unspecified.
-
- (let ((v (make-vector 5)))
- (for-each (lambda (i)
- (vector-set! v i (* i i)))
- '(0 1 2 3 4))
- v) ===> #(0 1 4 9 16)
-
-Like in SRFI-1, this procedure allows the arguments to be of unequal
-length; it terminates when the shortest list runs out. This is a
-CHICKEN extension to R5RS.
-
-<procedure>(force promise)</procedure><br>
-
-Forces the value of promise (see "[[#delayed-evaluation|delayed
-evaluation]]"). If no value has been computed for the promise, then a
-value is computed and returned. The value of the promise is cached
-(or "memoized") so that if it is forced a second time, the previously
-computed value is returned.
-
- (force (delay (+ 1 2))) ===> 3
- (let ((p (delay (+ 1 2))))
- (list (force p) (force p)))
- ===> (3 3)
-
- (define a-stream
- (letrec ((next
- (lambda (n)
- (cons n (delay (next (+ n 1)))))))
- (next 0)))
- (define head car)
- (define tail
- (lambda (stream) (force (cdr stream))))
-
- (head (tail (tail a-stream)))
- ===> 2
-
-Force and delay are mainly intended for programs written in functional
-style. The following examples should not be considered to illustrate
-good programming style, but they illustrate the property that only one
-value is computed for a promise, no matter how many times it is forced.
-
- (define count 0)
- (define p
- (delay (begin (set! count (+ count 1))
- (if (> count x)
- count
- (force p)))))
- (define x 5)
- p ===> a promise
- (force p) ===> 6
- p ===> a promise, still
- (begin (set! x 10)
- (force p)) ===> 6
-
-Here is a possible implementation of delay and force. Promises are
-implemented here as procedures of no arguments, and force simply calls
-its argument:
-
- (define force
- (lambda (object)
- (object)))
-
-We define the expression
-
- (delay <expression>)
-
-to have the same meaning as the procedure call
-
- (make-promise (lambda () <expression>))
-
-as follows
-
- (define-syntax delay
- (syntax-rules ()
- ((delay expression)
- (make-promise (lambda () expression))))),
-
-where make-promise is defined as follows:
-
- (define make-promise
- (lambda (proc)
- (let ((result-ready? #f)
- (result #f))
- (lambda ()
- (if result-ready?
- result
- (let ((x (proc)))
- (if result-ready?
- result
- (begin (set! result-ready? #t)
- (set! result x)
- result))))))))
-
-Rationale: A promise may refer to its own value, as in the last
-example above. Forcing such a promise may cause the promise to be
-forced a second time before the value of the first force has been
-computed. This complicates the definition of make-promise.
-
-Various extensions to this semantics of delay and force are supported
-in some implementations:
-
-* Calling force on an object that is not a promise may simply return
- the object (this is the case in CHICKEN).
-
-* It may be the case that there is no means by which a promise can be
- operationally distinguished from its forced value. That is,
- expressions like the following may evaluate to either #t or to #f,
- depending on the implementation:
-
- (eqv? (delay 1) 1) ===> unspecified
- (pair? (delay (cons 1 2))) ===> unspecified
-
- In CHICKEN, promises are separate objects, so the above expressions
- will both evaluate to {{#f}}.
-
-* Some implementations may implement "implicit forcing," where the
- value of a promise is forced by primitive procedures like cdr and
- +:
-
- (+ (delay (* 3 7)) 13) ===> 34
-
- This is '''not''' the case in CHICKEN.
-
-
-<procedure>(call-with-current-continuation proc)</procedure><br>
-
-Proc must be a procedure of one argument. The procedure
-call-with-current-continuation packages up the current continuation
-(see the rationale below) as an "escape procedure" and passes it as
-an argument to proc. The escape procedure is a Scheme procedure that,
-if it is later called, will abandon whatever continuation is in effect
-at that later time and will instead use the continuation that was in
-effect when the escape procedure was created. Calling the escape
-procedure may cause the invocation of before and after thunks installed
-using dynamic-wind.
-
-The escape procedure accepts the same number of arguments as the
-continuation to the original call to call-with-current-continuation.
-Except for continuations created by the call-with-values procedure, all
-continuations take exactly one value. The effect of passing no value or
-more than one value to continuations that were not created by
-call-with-values is unspecified.
-
-The escape procedure that is passed to proc has unlimited extent just
-like any other procedure in Scheme. It may be stored in variables or
-data structures and may be called as many times as desired.
-
-The following examples show only the most common ways in which
-call-with-current-continuation is used. If all real uses were as simple
-as these examples, there would be no need for a procedure with the
-power of call-with-current-continuation.
-
- (call-with-current-continuation
- (lambda (exit)
- (for-each (lambda (x)
- (if (negative? x)
- (exit x)))
- '(54 0 37 -3 245 19))
- #t)) ===> -3
-
- (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))))))
-
- (list-length '(1 2 3 4)) ===> 4
-
- (list-length '(a b . c)) ===> #f
-
-Rationale:
-
-A common use of call-with-current-continuation is for structured,
-non-local exits from loops or procedure bodies, but in fact
-call-with-current-continuation is extremely useful for implementing
-a wide variety of advanced control structures.
-
-Whenever a Scheme expression is evaluated there is a continuation
-wanting the result of the expression. The continuation represents
-an entire (default) future for the computation. If the expression
-is evaluated at top level, for example, then the continuation might
-take the result, print it on the screen, prompt for the next input,
-evaluate it, and so on forever. Most of the time the continuation
-includes actions specified by user code, as in a continuation that
-will take the result, multiply it by the value stored in a local
-variable, add seven, and give the answer to the top level
-continuation to be printed. Normally these ubiquitous continuations
-are hidden behind the scenes and programmers do not think much
-about them. On rare occasions, however, a programmer may need to
-deal with continuations explicitly. Call-with-current-continuation
-allows Scheme programmers to do that by creating a procedure that
-acts just like the current continuation.
-
-Most programming languages incorporate one or more special-purpose
-escape constructs with names like exit, return, or even goto. In
-1965, however, Peter Landin [16] invented a general purpose escape
-operator called the J-operator. John Reynolds [24] described a
-simpler but equally powerful construct in 1972. The catch special
-form described by Sussman and Steele in the 1975 report on Scheme
-is exactly the same as Reynolds's construct, though its name came
-from a less general construct in MacLisp. Several Scheme
-implementors noticed that the full power of the catch construct
-could be provided by a procedure instead of by a special syntactic
-construct, and the name call-with-current-continuation was coined
-in 1982. This name is descriptive, but opinions differ on the
-merits of such a long name, and some people use the name call/cc
-instead.
-
-<procedure>(values obj ...)</procedure><br>
-
-Delivers all of its arguments to its continuation. Except for
-continuations created by the call-with-values procedure, all
-continuations take exactly one value. Values might be defined as
-follows:
-
- (define (values . things)
- (call-with-current-continuation
- (lambda (cont) (apply cont things))))
-
-<procedure>(call-with-values producer consumer)</procedure><br>
-
-Calls its producer argument with no values and a continuation that,
-when passed some values, calls the consumer procedure with those values
-as arguments. The continuation for the call to consumer is the
-continuation of the call to call-with-values.
-
- (call-with-values (lambda () (values 4 5))
- (lambda (a b) b))
- ===> 5
-
- (call-with-values * -) ===> -1
-
-<procedure>(dynamic-wind before thunk after)</procedure><br>
-
-Calls thunk without arguments, returning the result(s) of this call.
-Before and after are called, also without arguments, as required by the
-following rules (note that in the absence of calls to continuations
-captured using call-with-current-continuation the three arguments are
-called once each, in order). Before is called whenever execution enters
-the dynamic extent of the call to thunk and after is called whenever it
-exits that dynamic extent. The dynamic extent of a procedure call is
-the period between when the call is initiated and when it returns. In
-Scheme, because of call-with-current-continuation, the dynamic extent
-of a call may not be a single, connected time period. It is defined as
-follows:
-
-* The dynamic extent is entered when execution of the body of the
- called procedure begins.
-
-* The dynamic extent is also entered when execution is not within the
- dynamic extent and a continuation is invoked that was captured
- (using call-with-current-continuation) during the dynamic extent.
-
-* It is exited when the called procedure returns.
-
-* It is also exited when execution is within the dynamic extent and a
- continuation is invoked that was captured while not within the
- dynamic extent.
-
-If a second call to dynamic-wind occurs within the dynamic extent of
-the call to thunk and then a continuation is invoked in such a way that
-the afters from these two invocations of dynamic-wind are both to be
-called, then the after associated with the second (inner) call to
-dynamic-wind is called first.
-
-If a second call to dynamic-wind occurs within the dynamic extent of
-the call to thunk and then a continuation is invoked in such a way that
-the befores from these two invocations of dynamic-wind are both to be
-called, then the before associated with the first (outer) call to
-dynamic-wind is called first.
-
-If invoking a continuation requires calling the before from one call to
-dynamic-wind and the after from another, then the after is called
-first.
-
-The effect of using a captured continuation to enter or exit the
-dynamic extent of a call to before or after is undefined. However,
-in CHICKEN it is safe to do this, and they will execute in the outer
-dynamic context of the {{dynamic-wind}} form.
-
- (let ((path '())
- (c #f))
- (let ((add (lambda (s)
- (set! path (cons s path)))))
- (dynamic-wind
- (lambda () (add 'connect))
- (lambda ()
- (add (call-with-current-continuation
- (lambda (c0)
- (set! c c0)
- 'talk1))))
- (lambda () (add 'disconnect)))
- (if (< (length path) 4)
- (c 'talk2)
- (reverse path))))
-
- ===> (connect talk1 disconnect
- connect talk2 disconnect)
-
-=== Eval
-
-<procedure>(eval expression [environment-specifier])</procedure><br>
-
-Evaluates expression in the specified environment and returns its
-value. Expression must be a valid Scheme expression represented as
-data, and environment-specifier must be a value returned by one of the
-three procedures described below. Implementations may extend eval to
-allow non-expression programs (definitions) as the first argument and
-to allow other values as environments, with the restriction that eval
-is not allowed to create new bindings in the environments associated
-with null-environment or scheme-report-environment.
-
- (eval '(* 7 3) (scheme-report-environment 5))
- ===> 21
-
- (let ((f (eval '(lambda (f x) (f x x))
- (null-environment 5))))
- (f + 10))
- ===> 20
-
-The {{environment-specifier}} is optional, and if not provided it
-defaults to the value of {{(interaction-environment)}}. This is a
-CHICKEN extension to R5RS, which, though strictly nonportable, is very
-common among Scheme implementations.
-
-<procedure>(scheme-report-environment version [mutable])</procedure><br>
-<procedure>(null-environment version [mutable])</procedure><br>
-
-Version must be either the exact integer 4 or 5, corresponding to the
-respective revisions of the Scheme report (the Revised^N Report on
-Scheme). Scheme-report-environment returns a specifier for an
-environment that is empty except for all bindings defined in this
-report that are either required or both optional and supported by the
-implementation. Null-environment returns a specifier for an
-environment that is empty except for the (syntactic) bindings for all
-syntactic keywords defined in this report that are either required or
-both optional and supported by the implementation.
-
-The environments specified by scheme-report-environment and
-null-environment are immutable by default. In CHICKEN, as an
-extension to R5RS, an extra {{mutable}} argument can be passed, which
-makes the environments mutable when non-{{#f}}. Mutability means new
-top-level definitions are accepted and the values of existing
-top-level bindings can be mutated.
-
-<procedure>(interaction-environment)</procedure><br>
-
-This procedure returns a specifier for the environment that contains
-implementation-defined bindings, typically a superset of those listed
-in the report. The intent is that this procedure will return the
-environment in which the implementation would evaluate expressions
-dynamically typed by the user.
-
-=== Input and output
-
-==== Ports
-
-Ports represent input and output devices. To Scheme, an input port is a
-Scheme object that can deliver characters upon command, while an output
-port is a Scheme object that can accept characters.
-
-<procedure>(call-with-input-file string proc [mode ...])</procedure><br>
-<procedure>(call-with-output-file string proc [mode ...])</procedure><br>
-
-String should be a string naming a file, and proc should be a procedure
-that accepts one argument. For call-with-input-file, the file should
-already exist; for call-with-output-file, the effect is unspecified if
-the file already exists. These procedures call proc with one argument:
-the port obtained by opening the named file for input or output. If the
-file cannot be opened, an error is signalled. If proc returns, then the
-port is closed automatically and the value(s) yielded by the proc is
-(are) returned. If proc does not return, then the port will not be
-closed automatically unless it is possible to prove that the port will
-never again be used for a read or write operation.
-
-Rationale: Because Scheme's escape procedures have unlimited
-extent, it is possible to escape from the current continuation but
-later to escape back in. If implementations were permitted to close
-the port on any escape from the current continuation, then it would
-be impossible to write portable code using both
-call-with-current-continuation and call-with-input-file or
-call-with-output-file.
-
-Additional {{mode}} arguments can be passed in, which should be any of
-the keywords {{#:text}}, {{#:binary}} or {{#:append}}. {{#:text}} and
-{{#:binary}} indicate the mode in which to open the file (this has an
-effect on non-UNIX platforms only), while {{#:append}} indicates that
-instead of truncating the file on open, data written to it should be
-appended at the end (only for output files). The extra {{mode}}
-arguments are CHICKEN extensions to the R5RS standard.
-
-<procedure>(input-port? obj)</procedure><br>
-<procedure>(output-port? obj)</procedure><br>
-
-Returns #t if obj is an input port or output port respectively,
-otherwise returns #f.
-
-<procedure>(current-input-port [port])</procedure><br>
-<procedure>(current-output-port [port])</procedure><br>
-
-Returns the current default input or output port.
-
-If the optional {{port}} argument is passed, the current input or
-output port is changed to the provided port. It can also be used with
-{{parameterize}} to temporarily bind the port to another value. This
-is a CHICKEN extension to the R5RS standard.
-
-Note that the default output port is not buffered. Use
-[[Module (chicken port)#set-buffering-mode!|{{set-buffering-mode!}}]]
-if you need a different behavior.
-
-
-<procedure>(with-input-from-file string thunk [mode ...])</procedure><br>
-<procedure>(with-output-to-file string thunk [mode ...])</procedure><br>
-
-String should be a string naming a file, and thunk should be a procedure
-of no arguments. For with-input-from-file, the file should already
-exist; for with-output-to-file, the effect is unspecified if the file
-already exists. The file is opened for input or output, an input or
-output port connected to it is made the default value returned by
-current-input-port or current-output-port (and is used by (read),
-(write obj), and so forth), and the thunk is called with no arguments.
-When the thunk returns, the port is closed and the previous default is
-restored. With-input-from-file and with-output-to-file return(s) the
-value(s) yielded by thunk. If an escape procedure is used to escape
-from the continuation of these procedures, their behavior is
-implementation dependent.
-
-Additional {{mode}} arguments can be passed in, which should be any of
-the keywords {{#:text}}, {{#:binary}} or {{#:append}}. {{#:text}} and
-{{#:binary}} indicate the mode in which to open the file (this has an
-effect on non-UNIX platforms only), while {{#:append}} indicates that
-instead of truncating the file on open, data written to it should be
-appended at the end (only for output files). The extra {{mode}}
-arguments are CHICKEN extensions to the R5RS standard.
-
-<procedure>(open-input-file filename [mode ...])</procedure><br>
-
-Takes a string naming an existing file and returns an input port
-capable of delivering characters from the file. If the file cannot be
-opened, an error is signalled.
-
-Additional {{mode}} arguments can be passed in, which should be any of
-the keywords {{#:text}} or {{#:binary}}. These indicate the mode in
-which to open the file (this has an effect on non-UNIX platforms
-only). The extra {{mode}} arguments are CHICKEN extensions to the
-R5RS standard.
-
-<procedure>(open-output-file filename [mode ...])</procedure><br>
-
-Takes a string naming an output file to be created and returns an
-output port capable of writing characters to a new file by that name.
-If the file cannot be opened, an error is signalled. If a file with the
-given name already exists, the effect is unspecified.
-
-Additional {{mode}} arguments can be passed in, which should be any of
-the keywords {{#:text}}, {{#:binary}} or {{#:append}}. {{#:text}} and
-{{#:binary}} indicate the mode in which to open the file (this has an
-effect on non-UNIX platforms only), while {{#:append}} indicates that
-instead of truncating the file on open, data written to it should be
-appended at the end. The extra {{mode}} arguments are CHICKEN
-extensions to the R5RS standard.
-
-<procedure>(close-input-port port)</procedure><br>
-<procedure>(close-output-port port)</procedure><br>
-
-Closes the file associated with port, rendering the port incapable of
-delivering or accepting characters. These routines have no effect if
-the file has already been closed. The value returned is unspecified.
-
-==== Input
-
-<procedure>(read)</procedure><br>
-<procedure>(read port)</procedure><br>
-
-Read converts external representations of Scheme objects into the
-objects themselves. That is, it is a parser for the nonterminal
-<datum> (see also "[[#pairs-and-lists|pairs and lists]]"). Read
-returns the next object parsable from the given input port, updating
-port to point to the first character past the end of the external
-representation of the object.
-
-If an end of file is encountered in the input before any characters are
-found that can begin an object, then an end of file object is returned.
-The port remains open, and further attempts to read will also return an
-end of file object. If an end of file is encountered after the
-beginning of an object's external representation, but the external
-representation is incomplete and therefore not parsable, an error is
-signalled.
-
-The port argument may be omitted, in which case it defaults to the
-value returned by current-input-port. It is an error to read from a
-closed port.
-
-<procedure>(read-char)</procedure><br>
-<procedure>(read-char port)</procedure><br>
-
-Returns the next character available from the input port, updating the
-port to point to the following character. If no more characters are
-available, an end of file object is returned. Port may be omitted, in
-which case it defaults to the value returned by current-input-port.
-
-<procedure>(peek-char)</procedure><br>
-<procedure>(peek-char port)</procedure><br>
-
-Returns the next character available from the input port, without
-updating the port to point to the following character. If no more
-characters are available, an end of file object is returned. Port may
-be omitted, in which case it defaults to the value returned by
-current-input-port.
-
-Note: The value returned by a call to peek-char is the same as
-the value that would have been returned by a call to read-char with
-the same port. The only difference is that the very next call to
-read-char or peek-char on that port will return the value returned
-by the preceding call to peek-char. In particular, a call to
-peek-char on an interactive port will hang waiting for input
-whenever a call to read-char would have hung.
-
-<procedure>(eof-object? obj)</procedure><br>
-
-Returns #t if obj is an end of file object, otherwise returns #f. The
-precise set of end of file objects will vary among implementations, but
-in any case no end of file object will ever be an object that can be
-read in using read.
-
-<procedure>(char-ready?)</procedure><br>
-<procedure>(char-ready? port)</procedure><br>
-
-Returns #t if a character is ready on the input port and returns #f
-otherwise. If char-ready returns #t then the next read-char operation
-on the given port is guaranteed not to hang. If the port is at end of
-file then char-ready? returns #t. Port may be omitted, in which case it
-defaults to the value returned by current-input-port.
-
-Rationale: Char-ready? exists to make it possible for a program
-to accept characters from interactive ports without getting stuck
-waiting for input. Any input editors associated with such ports
-must ensure that characters whose existence has been asserted by
-char-ready? cannot be rubbed out. If char-ready? were to return #f
-at end of file, a port at end of file would be indistinguishable
-from an interactive port that has no ready characters.
-
-==== Output
-
-<procedure>(write obj)</procedure><br>
-<procedure>(write obj port)</procedure><br>
-
-Writes a written representation of obj to the given port. Strings that
-appear in the written representation are enclosed in doublequotes, and
-within those strings backslash and doublequote characters are escaped
-by backslashes. Character objects are written using the #\ notation.
-Write returns an unspecified value. The port argument may be omitted,
-in which case it defaults to the value returned by current-output-port.
-
-<procedure>(display obj)</procedure><br>
-<procedure>(display obj port)</procedure><br>
-
-Writes a representation of obj to the given port. Strings that appear
-in the written representation are not enclosed in doublequotes, and no
-characters are escaped within those strings. Character objects appear
-in the representation as if written by write-char instead of by write.
-Display returns an unspecified value. The port argument may be omitted,
-in which case it defaults to the value returned by current-output-port.
-
-Rationale: Write is intended for producing machine-readable
-output and display is for producing human-readable output.
-Implementations that allow "slashification" within symbols will
-probably want write but not display to slashify funny characters in
-symbols.
-
-<procedure>(newline)</procedure><br>
-<procedure>(newline port)</procedure><br>
-
-Writes an end of line to port. Exactly how this is done differs from
-one operating system to another. Returns an unspecified value. The port
-argument may be omitted, in which case it defaults to the value
-returned by current-output-port.
-
-<procedure>(write-char char)</procedure><br>
-<procedure>(write-char char port)</procedure><br>
-
-Writes the character char (not an external representation of the
-character) to the given port and returns an unspecified value. The port
-argument may be omitted, in which case it defaults to the value
-returned by current-output-port.
-
-==== System interface
-
-Questions of system interface generally fall outside of the domain of
-this report. However, the following operations are important enough to
-deserve description here.
-
-<procedure>(load filename [evalproc])</procedure><br>
-
-Filename should be a string naming an existing file containing Scheme
-source code. The load procedure reads expressions and definitions from
-the file and evaluates them sequentially. It is unspecified whether the
-results of the expressions are printed. The load procedure does not
-affect the values returned by current-input-port and
-current-output-port. Load returns an unspecified value.
-
-CHICKEN offers a few extensions to the R5RS definition of {{load}}:
-
-* The {{filename}} may also be an input port.
-* The expressions which are read one by one from the source file are passed to the procedure indicated by the extra optional {{evalproc}} argument, which defaults to {{eval}}.
-* On platforms that support it (currently BSD, Haiku, MacOS X, Linux, Solaris, and Windows), {{load}} can be used to load shared objects.
-
-Example for loading 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>
-
-There are some limitations and caveats to the CHICKEN extensions you
-need to be aware of:
-
-* 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.
-* A compiled file can only be loaded once. Subsequent attempts to load the same file have no effect.
-
-
-<procedure>(transcript-on filename)</procedure><br>
-<procedure>(transcript-off)</procedure><br>
-
-(These procedures are not implemented in CHICKEN.)
-
-Filename must be a string naming an output file to be created. The
-effect of transcript-on is to open the named file for output, and to
-cause a transcript of subsequent interaction between the user and the
-Scheme system to be written to the file. The transcript is ended by a
-call to transcript-off, which closes the transcript file. Only one
-transcript may be in progress at any time, though some implementations
-may relax this restriction. The values returned by these procedures are
-unspecified.
+For portable code is recommended to put toplevel code into modules and
+import {{(scheme base)}} which provides the base R7RS environment.
---
Previous: [[Included modules]]
-Next: [[Module r5rs]]
+Next: [[Module (scheme r4rs)]]
diff --git a/manual/Module srfi-4 b/manual/Module srfi-4
index 42c6d3f1..aa66ced6 100644
--- a/manual/Module srfi-4
+++ b/manual/Module srfi-4
@@ -3,79 +3,13 @@
== Module srfi-4
-Homogeneous numeric vector datatypes. Also see the
+This module only reexports a subset of [[Module (chicken number-vector)|(chicken number-vector)]].
+Also see the
[[http://srfi.schemers.org/srfi-4/srfi-4.html|original SRFI-4 document]].
When loaded, the feature identifier {{srfi-4}} is defined.
-=== CHICKEN implementation specifics and extensions
-
-* Procedures for [[Module (chicken blob)|blob]] conversion, subvectors and vector I/O are provided.
-* SRFI-17 setters for {{XXXvector-ref}} are defined.
-* Constructors allow allocating the storage in non garbage collected memory.
-
-=== Blob conversions
-
-As a SRFI-4 vector is basically just a [[Module (chicken blob)|blob]]
-wrapped by a SRFI-4 type "header object" to structure its contents,
-there are several procedures which can convert between blobs and
-SRFI-4 vectors.
-
-<procedure>(u8vector->blob U8VECTOR)</procedure><br>
-<procedure>(s8vector->blob S8VECTOR)</procedure><br>
-<procedure>(u16vector->blob U16VECTOR)</procedure><br>
-<procedure>(s16vector->blob S16VECTOR)</procedure><br>
-<procedure>(u32vector->blob U32VECTOR)</procedure><br>
-<procedure>(s32vector->blob S32VECTOR)</procedure><br>
-<procedure>(u64vector->blob U64VECTOR)</procedure><br>
-<procedure>(s64vector->blob S64VECTOR)</procedure><br>
-<procedure>(f32vector->blob F32VECTOR)</procedure><br>
-<procedure>(f64vector->blob F64VECTOR)</procedure><br>
-<procedure>(u8vector->blob/shared U8VECTOR)</procedure><br>
-<procedure>(s8vector->blob/shared S8VECTOR)</procedure><br>
-<procedure>(u16vector->blob/shared U16VECTOR)</procedure><br>
-<procedure>(s16vector->blob/shared S16VECTOR)</procedure><br>
-<procedure>(u32vector->blob/shared U32VECTOR)</procedure><br>
-<procedure>(s32vector->blob/shared S32VECTOR)</procedure><br>
-<procedure>(u64vector->blob/shared U64VECTOR)</procedure><br>
-<procedure>(s64vector->blob/shared S64VECTOR)</procedure><br>
-<procedure>(f32vector->blob/shared F32VECTOR)</procedure><br>
-<procedure>(f64vector->blob/shared F64VECTOR)</procedure><br>
-
-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, the others will copy the contents of the
-SRFI-4 vector's internal blob object.
-
-<procedure>(blob->u8vector BLOB)</procedure><br>
-<procedure>(blob->s8vector BLOB)</procedure><br>
-<procedure>(blob->u16vector BLOB)</procedure><br>
-<procedure>(blob->s16vector BLOB)</procedure><br>
-<procedure>(blob->u32vector BLOB)</procedure><br>
-<procedure>(blob->s32vector BLOB)</procedure><br>
-<procedure>(blob->u64vector BLOB)</procedure><br>
-<procedure>(blob->s64vector BLOB)</procedure><br>
-<procedure>(blob->f32vector BLOB)</procedure><br>
-<procedure>(blob->f64vector BLOB)</procedure><br>
-<procedure>(blob->u8vector/shared BLOB)</procedure><br>
-<procedure>(blob->s8vector/shared BLOB)</procedure><br>
-<procedure>(blob->u16vector/shared BLOB)</procedure><br>
-<procedure>(blob->s16vector/shared BLOB)</procedure><br>
-<procedure>(blob->u32vector/shared BLOB)</procedure><br>
-<procedure>(blob->s32vector/shared BLOB)</procedure><br>
-<procedure>(blob->u64vector/shared BLOB)</procedure><br>
-<procedure>(blob->s64vector/shared BLOB)</procedure><br>
-<procedure>(blob->f32vector/shared BLOB)</procedure><br>
-<procedure>(blob->f64vector/shared BLOB)</procedure><br>
-
-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, the others will copy the blob.
-
-=== Subvectors
+The module exports the following identifiers:
<procedure>(subu8vector U8VECTOR FROM TO)</procedure><br>
<procedure>(subu16vector U16VECTOR FROM TO)</procedure><br>
@@ -87,129 +21,6 @@ with the contents of the blob, the others will copy the blob.
<procedure>(subs64vector S32VECTOR FROM TO)</procedure><br>
<procedure>(subf32vector F32VECTOR FROM TO)</procedure><br>
<procedure>(subf64vector F64VECTOR FROM TO)</procedure><br>
-
-Creates a fresh number vector of the same type as the argument vector
-with the elements at the positions {{FROM}} up to but not including
-{{TO}}.
-
-=== Vector I/O
-
-<procedure>(read-u8vector [LENGTH [PORT]])</procedure>
-
-Reads {{LENGTH}} bytes from the {{PORT}} and returns a fresh
-{{u8vector}}, or as many as are available before end-of-file is
-encountered. {{PORT}} defaults to the value of {{(current-input-port)}}.
-If no bytes are available before the end-of-file, {{#!eof}} is returned.
-
-If {{LENGTH}} is {{#f}}, the vector will be filled completely until
-end-of-file is reached.
-
-<procedure>(read-u8vector! LENGTH U8VECTOR [PORT [START]])</procedure>
-
-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.
-
-<procedure>(write-u8vector U8VECTOR [PORT [START [END]]])</procedure>
-
-Writes the bytes {{U8VECTOR}} between the indices {{START}} (inclusive) and {{END}} (exclusive) to {{PORT}}.
-
-{{PORT}} defaults to the value of {{(current-output-port)}}.
-
-== SRFI-4 specification
-
-SRFI-4 describes a set of datatypes for vectors whose elements are
-of the same numeric type (signed or unsigned exact integer or inexact
-real of a given precision). These datatypes support operations analogous
-to the Scheme vector type, but they are distinct datatypes. An external
-representation is specified which must be supported by the {{read}} and
-{{write}} procedures and by the program parser (i.e. programs can contain
-references to literal homogeneous vectors).
-
-=== Datatypes
-
-There are 8 datatypes of exact integer homogeneous vectors (which will be
-called integer vectors):
-
-<table>
-<tr><th>Datatype</th><th>Type of elements</th></tr>
-<tr><td>{{s8vector}}</td><td>signed exact integer in the range -(2^7) to (2^7)-1</td></tr>
-<tr><td>{{u8vector}}</td><td>unsigned exact integer in the range 0 to (2^8)-1</td></tr>
-<tr><td>{{s16vector}}</td><td>signed exact integer in the range -(2^15) to (2^15)-1</td></tr>
-<tr><td>{{u16vector}}</td><td>unsigned exact integer in the range 0 to (2^16)-1</td></tr>
-<tr><td>{{s32vector}}</td><td>signed exact integer in the range -(2^31) to (2^31)-1</td></tr>
-<tr><td>{{u32vector}}</td><td>unsigned exact integer in the range 0 to (2^32)-1</td></tr>
-<tr><td>{{s64vector}}</td><td>signed exact integer in the range -(2^31) to (2^31)-1</td></tr>
-<tr><td>{{u64vector}}</td><td>unsigned exact integer in the range 0 to (2^64)-1</td></tr>
-<tr><td>{{s64vector}}</td><td>signed exact integer in the range -(2^63) to (2^63)-1</td></tr>
-<tr><td>{{u64vector}}</td><td>unsigned exact integer in the range 0 to (2^64)-1</td></tr></table>
-
-There are 2 datatypes of inexact real homogeneous vectors (which will be
-called float vectors):
-
-<table>
-<tr><th>Datatype</th><th>Type of elements</th></tr>
-<tr><td>{{f32vector}}</td><td>inexact real</td></tr>
-<tr><td>{{f64vector}}</td><td>inexact real</td></tr></table>
-
-The only difference between the two float vector types is that
-{{f64vector}}s preserve at least as much precision as {{f32vector}}s.
-
-Each homogeneous vector datatype has an external representation which
-is supported by the {{read}} and {{write}} procedures and by the program
-parser. Each datatype also has a set of associated predefined procedures
-analogous to those available for Scheme's heterogeneous vectors.
-
-=== External representation
-
-<read>#u8</read><br>
-<read>#u16</read><br>
-<read>#u32</read><br>
-<read>#s8</read><br>
-<read>#s16</read><br>
-<read>#s32</read><br>
-<read>#f32</read><br>
-<read>#f64</read><br>
-
-The external representation of instances of the datatype {{XXXvector}}
-is {{#XXX( ...elements... )}}.
-
-For example,
-
- #u8(0 #e1e2 #xff) ; a u8vector of length 3 containing 0, 100, 255
- #f64(-1.5) ; a f64vector of length 1 containing -1.5.
-
-This external representation is also available in program source code. For example,
-
- (set! x '#u8(1 2 3))
-
-will set {{x}} to the object {{#u8(1 2 3)}}. Since CHICKEN 4.9.0, literal homogeneous vectors do not have to be quoted. Homogeneous vectors can appear in quasiquotations but must not contain {{unquote}} or {{unquote-splicing}} forms. ''I.e.'',
-
- `(,x #u8(1 2)) ; legal
- `#u8(1 ,x 2) ; illegal
-
-Elements may also be characters or strings, in that case they are interpreted
-as a sequence of numerical character codes. For example,
-
- '#u8(#\x7f "EL" #\F 2 1)
-
-is equivalent to
-
- '#u8(#\x7f #\x45 #\x4c #\x46 2 1)
-
-Character literals inside numeric vectors expand into the UTF-8 sequence of
-the characters they represent, for strings the contained characters
-are interpreted in whatever encoding is used for the text file or stream
-in which the literal appears.
-
-Note that {{#u8"..."}} can be used as an abbreviation for the special case
-{{#u8("...")}}.
-
-=== Predicates
-
<procedure>(u8vector? OBJ)</procedure><br>
<procedure>(s8vector? OBJ)</procedure><br>
<procedure>(u16vector? OBJ)</procedure><br>
@@ -220,16 +31,6 @@ Note that {{#u8"..."}} can be used as an abbreviation for the special case
<procedure>(s64vector? OBJ)</procedure><br>
<procedure>(f32vector? OBJ)</procedure><br>
<procedure>(f64vector? OBJ)</procedure><br>
-
-Return {{#t}} if {{obj}} is an object of the specified type or {{#f}} if not.
-
-<procedure>(number-vector? OBJ)</procedure>
-
-Return {{#t}} if {{obj}} is a number vector, {{#f}} if not. A "number vector" is any of the homogeneous number vector types defined by SRFI-4, ie it's one of {{u8vector}}, {{s8vector}}, {{u16vector}}, {{s16vector}}, {{u32vector}}, {{s32vector}}, {{u64vector}}, {{s64vector}}, {{f32vector}} or {{f64vector}}).
-
-
-=== Constructors
-
<procedure>(make-u8vector N [U8VALUE NONGC FINALIZE])</procedure><br>
<procedure>(make-s8vector N [S8VALUE NONGC FINALIZE])</procedure><br>
<procedure>(make-u16vector N [U16VALUE NONGC FINALIZE])</procedure><br>
@@ -240,31 +41,6 @@ Return {{#t}} if {{obj}} is a number vector, {{#f}} if not. A "number vector" i
<procedure>(make-s64vector N [S64VALUE NONGC FINALIZE])</procedure><br>
<procedure>(make-f32vector N [F32VALUE NONGC FINALIZE])</procedure><br>
<procedure>(make-f64vector N [F64VALUE NONGC FINALIZE])</procedure><br>
-
-Return a newly-allocated SRFI-4 homogeneous number vector of length N.
-
-If the optional fill VALUE is specified, it specifies the initial
-value for each slot in the vector. If not, the content of the vector
-is unspecified as the underlying memory is uninitialized.
-Particularly this means that entries in {{f32vector}} or {{f64vector}}
-may be i.e. a NaN-value.
-
-The type of the fill value must be compatible with the elements of the
-vector datatype. It is an error if otherwise -- for example, if an
-inexact integer is passed to {{make-u8vector}}.
-
-On CHICKEN, these procedures have been extended to allow allocating
-the storage in non-garbage collected memory, as follows:
-
-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.
-
<procedure>(u8vector U8VALUE ...)</procedure><br>
<procedure>(s8vector S8VALUE ...)</procedure><br>
<procedure>(u16vector U16VALUE ...)</procedure><br>
@@ -275,12 +51,6 @@ to {{#t}}. Note that the {{FINALIZE}} argument is only used when
<procedure>(s64vector S64VALUE ...)</procedure><br>
<procedure>(f32vector F32VALUE ...)</procedure><br>
<procedure>(f64vector F64VALUE ...)</procedure><br>
-
-Return a newly-allocated SRFI-4 homogeneous number vector of the specified
-type, composed of the arguments.
-
-=== Length
-
<procedure>(u8vector-length U8VECTOR)</procedure><br>
<procedure>(s8vector-length S8VECTOR)</procedure><br>
<procedure>(u16vector-length U16VECTOR)</procedure><br>
@@ -291,11 +61,6 @@ type, composed of the arguments.
<procedure>(s64vector-length S64VECTOR)</procedure><br>
<procedure>(f32vector-length F32VECTOR)</procedure><br>
<procedure>(f64vector-length F64VECTOR)</procedure><br>
-
-Returns the length of the SRFI-4 homogeneous number VECTOR.
-
-=== Getters
-
<procedure>(u8vector-ref U8VECTOR I)</procedure><br>
<procedure>(s8vector-ref S8VECTOR i)</procedure><br>
<procedure>(u16vector-ref U16VECTOR I)</procedure><br>
@@ -306,13 +71,6 @@ Returns the length of the SRFI-4 homogeneous number VECTOR.
<procedure>(s64vector-ref S64VECTOR I)</procedure><br>
<procedure>(f32vector-ref F32VECTOR I)</procedure><br>
<procedure>(f64vector-ref F64VECTOR I)</procedure><br>
-
-Return the value of the ''i''th element of the SRFI-4 homogeneous
-number vector, where {{I}} is a nonnegative exact integer less
-than the length of the vector.
-
-=== Setters
-
<procedure>(u8vector-set! U8VECTOR I U8VALUE)</procedure><br>
<procedure>(s8vector-set! S8VECTOR I S8VALUE)</procedure><br>
<procedure>(u16vector-set! U16VECTOR I U16VALUE)</procedure><br>
@@ -323,20 +81,6 @@ than the length of the vector.
<procedure>(s64vector-set! S64VECTOR I S64VALUE)</procedure><br>
<procedure>(f32vector-set! F32VECTOR I F32VALUE)</procedure><br>
<procedure>(f64vector-set! F64VECTOR I F64VALUE)</procedure><br>
-
-Set the {{i}}th element of the SRFI-4 homogeneous number VECTOR to
-VALUE. {{I}} is a nonnegative exact integer less than the length of
-the vector and VALUE must be the same type as the elements of the
-vector datatype.
-
-Additionally, SRFI-17 setters are defined on all {{xxxvector-ref}}
-procedures. For example, to set the {{i}}th element of SRFI-4
-{{u8vector}} to {{u8value}}:
-
- (set! (u8vector-ref u8vector i) u8value)
-
-=== Conversions
-
<procedure>(u8vector->list U8VECTOR)</procedure><br>
<procedure>(s8vector->list S8VECTOR)</procedure><br>
<procedure>(u16vector->list U16VECTOR)</procedure><br>
@@ -347,10 +91,6 @@ procedures. For example, to set the {{i}}th element of SRFI-4
<procedure>(s64vector->list S64VECTOR)</procedure><br>
<procedure>(f32vector->list F32VECTOR)</procedure><br>
<procedure>(f64vector->list F64VECTOR)</procedure><br>
-
-Return a list consisting of the elements of SRFI-4 homogeneous number
-VECTOR.
-
<procedure>(list->u8vector U8LIST)</procedure><br>
<procedure>(list->s8vector S8LIST)</procedure><br>
<procedure>(list->u16vector U16LIST)</procedure><br>
@@ -362,22 +102,8 @@ VECTOR.
<procedure>(list->f32vector F32LIST)</procedure><br>
<procedure>(list->f64vector F64LIST)</procedure><br>
-Return a newly-allocated SRFI-4 homogeneous number VECTOR consisting
-of the elements of LIST. Each element of LIST must be compatible
-with the datatype of VECTOR.
-
-=== Release number vectors allocated in static memory
-
-<procedure>(release-number-vector NVECTOR)</procedure>
-
-Release the storage of a SRFI-4 vector that was allocated in
-non-garbage collected memory (for example using the {{NONGC}} argument
-for one of the {{make-XXXvector}} constructor procedures). The effect
-of calling this procedure with a number vector allocated in normal
-garbage collected memory is undefined.
-
-
---
-Previous: [[Module r4rs]]
+Previous: [[Module (chicken type)]]
+
+Next: [[Interface to external functions and variables]]
-Next: [[Module (chicken base)]]
diff --git a/manual/The User's Manual b/manual/The User's Manual
index 444e6908..15b69e9a 100644
--- a/manual/The User's Manual
+++ b/manual/The User's Manual
@@ -6,14 +6,13 @@
<img id="big-logo" style="float:right; margin-left:1em;" src="http://wiki.call-cc.org/chicken-small.png" alt="Stylized picture of a chicken"/>
</nowiki>
-This is the manual for CHICKEN Scheme, version 5.4.1
+This is the manual for CHICKEN Scheme, version 6.0.0
* [[Getting started]] : What is CHICKEN and how do I use it?
* [[Using the interpreter]] : How to use the interactive interpreter, {{csi}}
* [[Using the compiler]] : How to use the batch compiler
* [[Deviations from the standard]] : Where CHICKEN deviates from R5RS
* [[Extensions to the standard]] : Extensions to R5RS that CHICKEN provides
-* [[Debugging]] : Using the "feathers" debugger to inspect running CHICKEN programs.
* [[Included modules]] : A reference to CHICKEN's core module library
* [[Interface to external functions and variables]] : Accessing C/C++ code and data
* [[Modules]] : How CHICKEN manages namespaces
diff --git a/manual/Types b/manual/Types
index 27ef0fc6..77ed8394 100644
--- a/manual/Types
+++ b/manual/Types
@@ -71,7 +71,7 @@ Declares that at the start of execution of {{BODY ..}}, the variables will
be of the given types. This is equivalent to
<enscript hightlight=scheme>
-(let ((VARIABLE (the TYPE VARIABLE)) ...)
+(let ((VARIABLE (the TYPE VARIABLE)) ...)
BODY ...)
</enscript>
@@ -97,7 +97,7 @@ or {{:}} should follow the syntax given below:
<tr><td>VALUETYPE</td><td></td></tr>
</table>
-<table>
+<table>
<tr><th>VALUETYPE</th><th>meaning</th></tr>
<tr><td>{{(or VALUETYPE1 VALUETYPE2 ...)}}</td><td>"union" or "sum" type</td></tr>
<tr><td>{{(not VALUETYPE)}}</td><td>non-matching type (*)</td></tr>
@@ -130,7 +130,7 @@ or {{:}} should follow the syntax given below:
<tr><td>{{null}}</td><td>empty list</td></tr>
<tr><td>{{number}}</td><td>either integer, float, ratnum or cplxnum</td></tr>
<tr><td>{{pair}}</td><td>pair</td></tr>
-<tr><td>{{pointer-vector}}</td><td>vector or native pointers</td></tr>
+<tr><td>{{pointer-vector}}</td><td>vector of native pointers</td></tr>
<tr><td>{{pointer}}</td><td>native pointer</td></tr>
<tr><td>{{input-port}} {{output-port}}</td><td>input- or output-port</td></tr>
<tr><td>{{procedure}}</td><td>unspecific procedure</td></tr>
@@ -151,13 +151,13 @@ or {{:}} should follow the syntax given below:
<tr><td>{{(vector TYPE1 ...)}}</td><td>vector with given length and element types</td></tr>
</table>
-<table>
+<table>
<tr><th>RESULTS</th><th>meaning</th></tr>
<tr><td>{{*}}</td><td>any number of unspecific results</td></tr>
<tr><td>{{(RESULTTYPE ...)}}</td><td>specific number of results with given types</td></tr>
</table>
-<table>
+<table>
<tr><th>RESULTTYPE</th><th>meaning</th></tr>
<tr><td>{{undefined}}</td><td>a single undefined result</td></tr>
<tr><td>{{noreturn}}</td><td>procedure does not return normally</td></tr>
@@ -190,7 +190,7 @@ Some types are internally represented as structure types, but you can also use
these names directly in type-specifications - {{TYPE}} corresponds to
{{(struct TYPE)}} in this case:
-<table>
+<table>
<tr><th>Structure type</th><th>meaning</th></tr>
<tr><td>{{u8vector}}</td><td>SRFI-4 byte vector</td></tr>
<tr><td>{{s8vector}}</td><td>SRFI-4 byte vector</td></tr>
@@ -322,7 +322,7 @@ compilation.
Evaluates {{EXP}} and executes the first clause which names a type that
matches the type inferred during flow analysis as the result of {{EXP}}.
-The result of {{EXP}} is ignored and should be a single value. If a
+The result of {{EXP}} is ignored and should be a single value. If a
{{compiler-typecase}} form occurs in evaluated code, or if it occurs in
compiled code but specialization is not enabled, then it must have
an {{else}} clause which specifies the default code to be executed
diff --git a/manual/Using the compiler b/manual/Using the compiler
index 079e2cf1..c3b68d74 100644
--- a/manual/Using the compiler
+++ b/manual/Using the compiler
@@ -112,8 +112,6 @@ the source text should be read from standard input.
; -no-procedure-checks-for-toplevel-bindings : disable bound and procedure call checks for calls to procedures referenced through a toplevel variable.
-; -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.
@@ -172,7 +170,7 @@ the source text should be read from standard input.
; -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.
+; -r7rs-syntax : Disables the CHICKEN extensions to R7RS syntax. Does not disable 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}}). Use this only when you know what you are doing.
diff --git a/manual/Using the interpreter b/manual/Using the interpreter
index 8ae57d43..de1f3097 100644
--- a/manual/Using the interpreter
+++ b/manual/Using the interpreter
@@ -10,7 +10,7 @@ and expressions interactively.
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}}.
+symbols {{#!optional, #!key, #!rest, #!fold-case, #!no-fold-case}} and {{#!eof}}.
The easiest way is to use the {{-script}} option like this:
@@ -30,24 +30,6 @@ 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.
-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
- (import (chicken port)
- (chicken process-context))
- (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))}}
@@ -238,7 +220,7 @@ 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.
+; -i -case-insensitive : Enables the reader to read symbols case insensitive. The ddefault is to read case sensitive (as defined by R7RS). This option registers the {{case-insensitive}} feature identifier.
; -b -batch : Quit the interpreter after processing all command line options.
@@ -260,13 +242,11 @@ The options recognized by the interpreter are:
; -no-parentheses-synonyms : 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.
+; -r7rs-syntax : Disables the CHICKEN extensions to R7RS syntax. Does not disable 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.
diff --git a/modules.scm b/modules.scm
index ac4f0dc2..372249fd 100644
--- a/modules.scm
+++ b/modules.scm
@@ -7,11 +7,11 @@
; conditions are met:
;
; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-; disclaimer.
+; 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.
+; 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.
+; 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
@@ -45,6 +45,7 @@
chicken.syntax
(only chicken.string string-split)
(only chicken.format fprintf format))
+(import (only (scheme base) make-parameter open-output-string get-output-string))
(include "common-declarations.scm")
(include "mini-srfi-1.scm")
@@ -57,7 +58,7 @@
#+debugbuild
(define (map-se se)
- (map (lambda (a)
+ (map (lambda (a)
(cons (car a) (if (symbol? (cdr a)) (cdr a) '<macro>)))
se))
@@ -77,12 +78,12 @@
(define ##sys#current-module (make-parameter #f))
(define ##sys#module-alias-environment (make-parameter '()))
-(declare
+(declare
(hide make-module module? %make-module
module-name module-library
module-vexports module-sexports
set-module-vexports! set-module-sexports!
- module-export-list set-module-export-list!
+ 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!
@@ -95,8 +96,8 @@
(define-record-type module
(%make-module name library export-list defined-list exist-list defined-syntax-list
- undefined-list import-forms meta-import-forms meta-expressions
- vexports sexports iexports saved-environments rename-list)
+ undefined-list import-forms meta-import-forms meta-expressions
+ vexports sexports iexports saved-environments rename-list)
module?
(name module-name) ; SYMBOL
(library module-library) ; SYMBOL
@@ -118,7 +119,7 @@
(define ##sys#module-name module-name)
(define (##sys#module-exports m)
- (values
+ (values
(module-export-list m)
(module-vexports m)
(module-sexports m)))
@@ -160,7 +161,7 @@
(cond ((##sys#current-module) =>
(lambda (m)
(set-module-saved-environments! m now)))
- (else
+ (else
(set! saved-default-envs now)))
(let ((saved (if mod (module-saved-environments mod) saved-default-envs)))
(when saved
@@ -197,9 +198,9 @@
(define (check-for-redef sym env senv)
(and-let* ((a (assq sym env)))
- (##sys#warn "redefinition of imported value binding" sym) )
+ (##sys#warn "redefinition of value binding" sym) )
(and-let* ((a (assq sym senv)))
- (##sys#warn "redefinition of imported syntax binding" sym)))
+ (##sys#warn "redefinition of syntax binding" sym)))
(define (##sys#register-export sym mod)
(when mod
@@ -214,7 +215,7 @@
(set-module-exist-list! mod (cons sym (module-exist-list mod)))
(when exp
(dm "defined: " sym)
- (set-module-defined-list!
+ (set-module-defined-list!
mod
(cons (cons sym #f)
(module-defined-list mod)))))) )
@@ -225,16 +226,16 @@
(find-export sym mod #t)))
(ulist (module-undefined-list mod))
(mname (module-name mod)))
- (when (assq sym ulist)
+ (when (assq sym ulist)
(##sys#warn "use of syntax precedes definition" sym)) ;XXX could report locations
(check-for-redef sym (##sys#current-environment) (##sys#macro-environment))
(dm "defined syntax: " sym)
(when exp
- (set-module-defined-list!
+ (set-module-defined-list!
mod
(cons (cons sym val)
(module-defined-list mod))) )
- (set-module-defined-syntax-list!
+ (set-module-defined-syntax-list!
mod
(cons (cons sym val) (module-defined-syntax-list mod))))))
@@ -287,9 +288,9 @@
(warn "indirect export of syntax binding" (car iexports))
(loop2 (cdr iexports)))
((assq (car iexports) dlist) => ; defined in current module?
- (lambda (a)
- (cons
- (cons
+ (lambda (a)
+ (cons
+ (cons
(car iexports)
(or (cdr a) (module-rename (car iexports) mname)))
(loop2 (cdr iexports)))))
@@ -300,7 +301,7 @@
(else
(warn "indirect reexport of syntax" (car iexports))
(loop2 (cdr iexports))))))
- (else
+ (else
(warn "indirect export of unknown binding" (car iexports))
(loop2 (cdr iexports)))))))))))
@@ -361,7 +362,7 @@
,@(map (lambda (sexport)
(let* ((name (car sexport))
(a (assq name dlist)))
- (cond ((pair? a)
+ (cond ((pair? a)
`(scheme#cons ',(car sexport) ,(strip-syntax (cdr a))))
(else
(dm "re-exported syntax" name mname)
@@ -428,7 +429,7 @@
mod
(cons (merge-se (##sys#current-environment) vexports sexps)
(##sys#macro-environment)))
- (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
+ (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
mod))
(define (##sys#register-core-module name lib vexports #!optional (sexports '()))
@@ -440,7 +441,7 @@
(if (symbol? se)
(or (assq se me)
(##sys#error
- "unknown syntax referenced while registering module"
+ "unknown syntax referenced while registering module"
se name))
se))
sexports)
@@ -451,7 +452,7 @@
(module-vexports mod)
(module-sexports mod))
(##sys#macro-environment)))
- (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
+ (set! ##sys#module-table (cons (cons name mod) ##sys#module-table))
mod))
;; same as register-core-module (above) but does not load any code,
@@ -470,7 +471,7 @@
(loop (cdr xl))))
(else (loop (cdr xl)))))))
-(define ##sys#finalize-module
+(define ##sys#finalize-module
(let ((display display)
(write-char write-char))
(lambda (mod #!optional (invalid-export (lambda _ #f)))
@@ -567,12 +568,12 @@
(cond ((eq? (##sys#get id '##sys#override) 'syntax)
(loop (cdr xl)))
((assq id sexports) (loop (cdr xl)))
- (else
- (cons
- (cons
+ (else
+ (cons
+ (cons
id
(let ((def (assq id dlist)))
- (if (and def (symbol? (cdr def)))
+ (if (and def (symbol? (cdr def)))
(cdr def)
(let ((a (assq id (##sys#current-environment))))
(define (fail msg)
@@ -608,15 +609,15 @@
(when missing
(##sys#error "module unresolved" name))
- (let* ((iexports
+ (let* ((iexports
(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)
+ (new-se (merge-se
+ (##sys#macro-environment)
+ (##sys#current-environment)
iexports vexports sexports sdlist)))
(for-each
(lambda (m)
@@ -624,8 +625,8 @@
(dm `(FIXUP: ,(car m) ,@(map-se se)))
(set-car! (cdr m) se)))
sdlist)
- (dm `(EXPORTS:
- ,(module-name mod)
+ (dm `(EXPORTS:
+ ,(module-name mod)
(DLIST: ,@dlist)
(SDLIST: ,@(map-se sdlist))
(IEXPORTS: ,@(map-se iexports))
@@ -633,7 +634,7 @@
(SEXPORTS: ,@(map-se sexports))))
(set-module-vexports! mod vexports)
(set-module-sexports! mod sexports)
- (set-module-iexports!
+ (set-module-iexports!
mod
(merge-se (module-iexports mod) iexports)) ; "reexport" may already have added some
(set-module-saved-environments!
@@ -679,17 +680,17 @@
(##sys#warn (string-append msg " in module `" (symbol->string mod) "'") id))
(define (tostr x)
(cond ((string? x) x)
- ((keyword? x) (##sys#string-append (##sys#symbol->string x) ":")) ; hack
- ((symbol? x) (##sys#symbol->string x))
+ ((keyword? x) (##sys#string-append (##sys#symbol->string/shared x) ":")) ; hack
+ ((symbol? x) (##sys#symbol->string/shared x))
((number? x) (number->string x))
- (else (##sys#syntax-error-hook loc "invalid prefix" ))))
+ (else (##sys#syntax-error loc "invalid prefix" ))))
(define (export-rename mod lst)
(let ((ren (module-rename-list mod)))
(if (null? ren)
lst
(map (lambda (a)
(cond ((assq (car a) ren) =>
- (lambda (b)
+ (lambda (b)
(cons (cdr b) (cdr a))))
(else a)))
lst))))
@@ -710,7 +711,7 @@
(cond ((symbol? x)
(module-imports (strip-syntax x)))
((not (pair? x))
- (##sys#syntax-error-hook loc "invalid import specification" x))
+ (##sys#syntax-error loc "invalid import specification" x))
(else
(let ((head (car x)))
(cond ((c %only head)
@@ -789,7 +790,7 @@
(define (rename imp)
(cons
(##sys#string->symbol
- (##sys#string-append (tostr prefix) (##sys#symbol->string (car imp))))
+ (##sys#string-append (tostr prefix) (##sys#symbol->string/shared (car imp))))
(cdr imp)))
(values name lib `(,head ,spec ,prefix) (map rename impv) (map rename imps) impi)))
(else
@@ -801,7 +802,7 @@
(lambda (x)
(let-values (((name _ spec v s i) (##sys#decompose-import x r c loc)))
(if (not spec)
- (##sys#syntax-error-hook loc "cannot import from undefined module" name x)
+ (##sys#syntax-error loc "cannot import from undefined module" name x)
(##sys#import spec v s i import-env macro-env meta? reexp? loc))))
(cdr x))
'(##core#undefined))
@@ -838,7 +839,7 @@
vss)
(when reexp?
(unless cm
- (##sys#syntax-error-hook loc "`reexport' only valid inside a module"))
+ (##sys#syntax-error loc "`reexport' only valid inside a module"))
(let ((el (module-export-list cm)))
(cond ((eq? #t el)
(set-module-sexports! cm (append vss (module-sexports cm)))
@@ -865,16 +866,16 @@
(define (module-rename sym prefix)
(##sys#string->symbol
(string-append
- (##sys#slot prefix 1)
+ (##sys#symbol->string/shared prefix)
"#"
- (##sys#slot sym 1) ) ) )
+ (##sys#symbol->string/shared sym) ) ) )
(define (##sys#alias-global-hook sym assign where)
(define (mrename sym)
- (cond ((##sys#current-module) =>
+ (cond ((##sys#current-module) =>
(lambda (mod)
(dm "(ALIAS) global alias " sym " in " (module-name mod))
- (unless assign
+ (unless assign
(register-undefined sym mod where))
(module-rename sym (module-name mod))))
(else sym)))
@@ -890,7 +891,7 @@
(define (##sys#validate-exports exps loc)
;; expects "exps" to be stripped
(define (err . args)
- (apply ##sys#syntax-error-hook loc args))
+ (apply ##sys#syntax-error loc args))
(define (iface name)
(or (getp name '##core#interface)
(err "unknown interface" name exps)))
@@ -926,13 +927,13 @@
(define (##sys#instantiate-functor name fname args)
(let ((funcdef (getp fname '##core#functor)))
(define (err . args)
- (apply ##sys#syntax-error-hook name args))
+ (apply ##sys#syntax-error name args))
(unless funcdef (err "instantation of undefined functor" fname))
(let ((fargs (car funcdef))
(exports (cadr funcdef))
(body (cddr funcdef)))
(define (merr)
- (err "argument list mismatch in functor instantiation"
+ (err "argument list mismatch in functor instantiation"
(cons name args) (cons fname (map car fargs))))
`(##core#let-module-alias
,(let loop ((as args) (fas fargs))
@@ -980,10 +981,10 @@
(set! missing (cons sym missing)))))
exps)
(when (pair? missing)
- (##sys#syntax-error-hook
- 'module
+ (##sys#syntax-error
+ 'module
(apply
- string-append
+ string-append
"argument module `" (symbol->string mname) "' does not match required signature\n"
"in instantiation `" (symbol->string name) "' of functor `"
(symbol->string fname) "', because the following required exports are missing:\n"
@@ -1119,21 +1120,181 @@
(null-environment . scheme#null-environment)
(interaction-environment . scheme#interaction-environment)))
(r4rs-syntax ##sys#scheme-macro-environment))
- (##sys#register-core-module 'r4rs 'library r4rs-values r4rs-syntax)
+ (##sys#register-core-module 'scheme.r4rs 'library r4rs-values r4rs-syntax)
(##sys#register-core-module
- 'scheme 'library
+ 'scheme.r5rs 'library
(append '((dynamic-wind . scheme#dynamic-wind)
(eval . scheme#eval)
(values . scheme#values)
(call-with-values . scheme#call-with-values))
r4rs-values)
r4rs-syntax)
- (##sys#register-core-module 'r4rs-null #f '() r4rs-syntax)
- (##sys#register-core-module 'r5rs-null #f '() r4rs-syntax))
-
-(##sys#register-module-alias 'r5rs 'scheme)
-
-(define-inline (se-subset names env) (map (cut assq <> env) names))
+ (##sys#register-core-module 'scheme.r4rs-null #f '() r4rs-syntax)
+ (##sys#register-core-module 'scheme.r5rs-null #f '() r4rs-syntax))
+
+(##sys#register-module-alias 'scheme 'scheme.r5rs)
+
+(define (se-subset names env)
+ (map (lambda (n) (assq n env)) names))
+
+(##sys#register-core-module 'scheme.base
+ 'library
+ '((not . scheme#not) (boolean? . scheme#boolean?)
+ (eq? . scheme#eq?) (eqv? . scheme#eqv?) (equal? . scheme#equal?)
+ (pair? . scheme#pair?) (cons . scheme#cons)
+ (car . scheme#car) (cdr . scheme#cdr)
+ (caar . scheme#caar) (cadr . scheme#cadr) (cdar . scheme#cdar)
+ (cddr . scheme#cddr)
+ (set-car! . scheme#set-car!) (set-cdr! . scheme#set-cdr!)
+ (null? . scheme#null?) (list? . scheme#list?)
+ (list . scheme#list) (length . scheme#length)
+ (list-tail . scheme#list-tail) (list-ref . scheme#list-ref)
+ (list-set! . scheme#list-set!) (list-copy . scheme#list-copy)
+ (boolean=? . scheme#boolean=?) (symbol=? . scheme#symbol=?)
+ (append . scheme#append) (reverse . scheme#reverse)
+ (memq . scheme#memq) (memv . scheme#memv)
+ (member . scheme#member) (assq . scheme#assq)
+ (assv . scheme#assv) (assoc . scheme#assoc)
+ (symbol? . scheme#symbol?)
+ (port? . scheme#port?)
+ (input-port-open? . scheme#input-port-open?)
+ (output-port-open? . scheme#output-port-open?)
+ (call-with-port . scheme#call-with-port)
+ (symbol->string . scheme#symbol->string)
+ (string->symbol . scheme#string->symbol)
+ (string->vector . scheme#string->vector)
+ (vector->string . scheme#vector->string)
+ (vector-append . scheme#vector-append)
+ (vector-map . scheme#vector-map)
+ (vector-for-each . scheme#vector-for-each)
+ (string-map . scheme#string-map)
+ (string-for-each . scheme#string-for-each)
+ (number? . scheme#number?) (integer? . scheme#integer?)
+ (exact? . scheme#exact?) (real? . scheme#real?)
+ (complex? . scheme#complex?) (inexact? . scheme#inexact?)
+ (rational? . scheme#rational?) (zero? . scheme#zero?)
+ (odd? . scheme#odd?) (even? . scheme#even?)
+ (positive? . scheme#positive?) (negative? . scheme#negative?)
+ (max . scheme#max) (min . scheme#min)
+ (+ . scheme#+) (- . scheme#-) (* . scheme#*) (/ . scheme#/)
+ (= . scheme#=) (> . scheme#>) (< . scheme#<)
+ (>= . scheme#>=) (<= . scheme#<=)
+ (quotient . scheme#quotient) (remainder . scheme#remainder)
+ (floor-quotient . scheme#floor-quotient) (floor-remainder . scheme#floor-remainder)
+ (truncate-quotient . scheme#quotient) (truncate-remainder . scheme#remainder)
+ (floor/ . scheme#floor/) (truncate/ . scheme#truncate/)
+ (modulo . scheme#modulo)
+ (gcd . scheme#gcd) (lcm . scheme#lcm) (abs . scheme#abs)
+ (floor . scheme#floor) (ceiling . scheme#ceiling)
+ (truncate . scheme#truncate) (round . scheme#round)
+ (rationalize . scheme#rationalize)
+ (inexact . scheme#exact->inexact)
+ (exact . scheme#inexact->exact)
+ (sqrt . scheme#sqrt)
+ (square . scheme#square)
+ (exact-integer-sqrt . scheme#exact-integer-sqrt)
+ (number->string . scheme#number->string)
+ (string->number . scheme#string->number)
+ (char? . scheme#char?) (char=? . scheme#char=?)
+ (char>? . scheme#char>?) (char<? . scheme#char<?)
+ (char>=? . scheme#char>=?) (char<=? . scheme#char<=?)
+ (char->integer . scheme#char->integer)
+ (integer->char . scheme#integer->char)
+ (string? . scheme#string?) (string=? . scheme#string=?)
+ (string>? . scheme#string>?) (string<? . scheme#string<?)
+ (string>=? . scheme#string>=?) (string<=? . scheme#string<=?)
+ (make-string . scheme#make-string)
+ (make-list . scheme#make-list)
+ (string-length . scheme#string-length)
+ (string-ref . scheme#string-ref)
+ (string-set! . scheme#string-set!)
+ (string-append . scheme#string-append)
+ (string-copy . scheme#string-copy)
+ (string-copy! . scheme#string-copy!)
+ (string->list . scheme#string->list)
+ (list->string . scheme#list->string)
+ (substring . scheme#substring)
+ (string-fill! . scheme#string-fill!)
+ (vector? . scheme#vector?) (make-vector . scheme#make-vector)
+ (vector-ref . scheme#vector-ref)
+ (vector-set! . scheme#vector-set!)
+ (string . scheme#string) (vector . scheme#vector)
+ (vector-length . scheme#vector-length)
+ (vector->list . scheme#vector->list)
+ (list->vector . scheme#list->vector)
+ (vector-copy . scheme#vector-copy)
+ (vector-copy! . scheme#vector-copy!)
+ (vector-fill! . scheme#vector-fill!)
+ (call-with-values . scheme#call-with-values)
+ (values . scheme#values)
+ (procedure? . scheme#procedure?)
+ (make-parameter . scheme#make-parameter)
+ (map . scheme#map) (for-each . scheme#for-each)
+ (apply . scheme#apply) (dynamic-wind . scheme#dynamic-wind)
+ (call-with-current-continuation . scheme#call-with-current-continuation)
+ (call/cc . scheme#call-with-current-continuation)
+ (input-port? . scheme#input-port?)
+ (output-port? . scheme#output-port?)
+ (current-input-port . scheme#current-input-port)
+ (current-output-port . scheme#current-output-port)
+ (current-error-port . chicken.base#current-error-port)
+ (open-input-file . scheme#open-input-file)
+ (open-output-file . scheme#open-output-file)
+ (close-input-port . scheme#close-input-port)
+ (close-output-port . scheme#close-output-port)
+ (read-char . scheme#read-char) (peek-char . scheme#peek-char)
+ (read-string . chicken.io#read-string)
+ (peek-u8 . scheme#peek-u8) (features . scheme#features)
+ (read-u8 . chicken.io#read-byte) (write-u8 . chicken.io#write-byte)
+ (write-char . scheme#write-char) (newline . scheme#newline)
+ (eof-object? . scheme#eof-object?)
+ (eof-object . scheme#eof-object)
+ (flush-output-port . chicken.base#flush-output)
+ (with-input-from-file . scheme#with-input-from-file)
+ (with-output-to-file . scheme#with-output-to-file)
+ (close-port . scheme#close-port)
+ (char-ready? . scheme#char-ready?)
+ (u8-ready? . scheme#u8-ready?)
+ (numerator . scheme#numerator)
+ (denominator . scheme#denominator)
+ (scheme-report-environment . scheme#scheme-report-environment)
+ (null-environment . scheme#null-environment)
+ (open-input-string . scheme#open-input-string)
+ (open-output-string . scheme#open-output-string)
+ (open-output-bytevector . scheme#open-output-bytevector)
+ (open-input-bytevector . scheme#open-input-bytevector)
+ (get-output-string . scheme#get-output-string)
+ (get-output-bytevector . scheme#get-output-bytevector)
+ (with-exception-handler . scheme#with-exception-handler)
+ (raise . scheme#raise) (raise-continuable . scheme#raise-continuable)
+ (error . chicken.base#error)
+ (file-error? . scheme#file-error?)
+ (read-error? . scheme#read-error?)
+ (error-object? . scheme#error-object?)
+ (error-object-message . scheme#error-object-message)
+ (error-object-irritants . scheme#error-object-irritants)
+ (string->utf8 . chicken.bytevector#string->utf8)
+ (utf8->string . chicken.bytevector#utf8->string)
+ (write-bytevector . scheme#write-bytevector)
+ (bytevector . chicken.bytevector#bytevector)
+ (bytevector-length . chicken.bytevector#bytevector-length)
+ (bytevector? . chicken.bytevector#bytevector?)
+ (make-bytevector . chicken.bytevector#make-bytevector)
+ (bytevector-append . chicken.bytevector#bytevector-append)
+ (bytevector-copy . chicken.bytevector#bytevector-copy)
+ (bytevector-copy! . chicken.bytevector#bytevector-copy!)
+ (bytevector-u8-ref . chicken.bytevector#bytevector-u8-ref)
+ (bytevector-u8-set! . chicken.bytevector#bytevector-u8-set!)
+ (read-bytevector . chicken.io#read-bytevector)
+ (read-bytevector! . chicken.io#read-bytevector!)
+ (read-line . chicken.io#read-line)
+ (write-string . scheme#write-string) )
+ (se-subset '(define let let* letrec letrec* let-values define-values let*-values
+ parameterize when unless do define define-syntax case cond guard
+ define-record-type include include-ci set! syntax-rules cond-expand
+ import export begin import-for-syntax and or lambda if quote
+ case-lambda quasiquote syntax-error)
+ (##sys#macro-environment)))
;; Hack for library.scm to use macros from modules it defines itself.
(##sys#register-primitive-module
@@ -1145,18 +1306,9 @@
(##sys#register-primitive-module
'chicken.type '() ##sys#chicken.type-macro-environment)
-(##sys#register-primitive-module
- 'srfi-0 '() (se-subset '(cond-expand) ##sys#default-macro-environment))
-
(##sys#register-primitive-module
'srfi-2 '() (se-subset '(and-let*) ##sys#chicken.base-macro-environment))
-(##sys#register-core-module
- 'srfi-6 'library
- '((get-output-string . chicken.base#get-output-string)
- (open-input-string . chicken.base#open-input-string)
- (open-output-string . chicken.base#open-output-string)))
-
(##sys#register-primitive-module
'srfi-8 '() (se-subset '(receive) ##sys#chicken.base-macro-environment))
@@ -1166,9 +1318,6 @@
(##sys#register-core-module
'srfi-10 'read-syntax '((define-reader-ctor . chicken.read-syntax#define-reader-ctor)))
-(##sys#register-primitive-module
- 'srfi-11 '() (se-subset '(let-values let*-values) ##sys#chicken.base-macro-environment))
-
(##sys#register-core-module
'srfi-12 'library
'((abort . chicken.condition#abort)
@@ -1185,8 +1334,61 @@
(##sys#register-primitive-module
'srfi-15 '() (se-subset '(fluid-let) ##sys#chicken.base-macro-environment))
-(##sys#register-primitive-module
- 'srfi-16 '() (se-subset '(case-lambda) ##sys#chicken.base-macro-environment))
+(##sys#register-core-module
+ 'scheme.case-lambda
+ 'library '()
+ ##sys#scheme.case-lambda-macro-environment)
+
+(##sys#register-core-module
+ 'scheme.lazy 'library
+ '((force . scheme#force)
+ (promise? . chicken.base#promise?)
+ (make-promise . chicken.base#make-promise))
+ (cons (assq 'delay ##sys#scheme-macro-environment)
+ (se-subset '(delay-force) ##sys#chicken.base-macro-environment)))
+
+(##sys#register-core-module
+ 'scheme.complex 'library
+ '((imag-part . scheme#imag-part) (real-part . scheme#real-part)
+ (make-rectangular . scheme#make-rectangular)
+ (make-polar . scheme#make-polar)
+ (angle . scheme#angle) (magnitude . scheme#magnitude)))
+
+(##sys#register-core-module
+ 'scheme.cxr 'library
+ '((caaar . scheme#caaar)
+ (caadr . scheme#caadr)
+ (cadar . scheme#cadar)
+ (caddr . scheme#caddr)
+ (cdaar . scheme#cdaar)
+ (cdadr . scheme#cdadr)
+ (cddar . scheme#cddar)
+ (cdddr . scheme#cdddr)
+ (caaaar . scheme#caaaar)
+ (caaadr . scheme#caaadr)
+ (caadar . scheme#caadar)
+ (caaddr . scheme#caaddr)
+ (cadaar . scheme#cadaar)
+ (cadadr . scheme#cadadr)
+ (caddar . scheme#caddar)
+ (cadddr . scheme#cadddr)
+ (cdaaar . scheme#cdaaar)
+ (cdaadr . scheme#cdaadr)
+ (cdadar . scheme#cdadar)
+ (cdaddr . scheme#cdaddr)
+ (cddaar . scheme#cddaar)
+ (cddadr . scheme#cddadr)
+ (cdddar . scheme#cdddar)
+ (cddddr . scheme#cddddr)))
+
+(##sys#register-core-module
+ 'scheme.inexact 'library
+ '((exp . scheme#exp) (log . scheme#log) (expt . scheme#expt)
+ (sqrt . scheme#sqrt) (nan? . chicken.base#nan?)
+ (sin . scheme#sin) (cos . scheme#cos) (tan . scheme#tan)
+ (asin . scheme#asin) (acos . scheme#acos) (atan . scheme#atan)
+ (finite? . chicken.base#finite?)
+ (infinite? . chicken.base#infinite?)))
(##sys#register-core-module
'srfi-17 'library
@@ -1194,9 +1396,6 @@
(setter . chicken.base#setter))
(se-subset '(set!) ##sys#default-macro-environment))
-(##sys#register-core-module
- 'srfi-23 'library '((error . chicken.base#error)))
-
(##sys#register-primitive-module
'srfi-26 '() (se-subset '(cut cute) ##sys#chicken.base-macro-environment))
@@ -1206,10 +1405,6 @@
(##sys#register-primitive-module
'srfi-31 '() (se-subset '(rec) ##sys#chicken.base-macro-environment))
-(##sys#register-core-module
- 'srfi-39 'library '((make-parameter . chicken.base#make-parameter))
- (se-subset '(parameterize) ##sys#chicken.base-macro-environment))
-
(##sys#register-primitive-module
'srfi-55 '() (se-subset '(require-extension) ##sys#chicken.base-macro-environment))
@@ -1219,18 +1414,85 @@
(keyword->string . chicken.keyword#keyword->string)
(string->keyword . chicken.keyword#string->keyword)))
-(##sys#register-core-module
- 'srfi-98 'posix
- '((get-environment-variable . chicken.process-context#get-environment-variable)
- (get-environment-variables . chicken.process-context#get-environment-variables)))
-
(define (chicken.module#module-environment mname #!optional (ename mname))
(let ((mod (find-module/import-library mname 'module-environment)))
(if (not mod)
- (##sys#syntax-error-hook
+ (##sys#syntax-error
'module-environment "undefined module" mname)
- (##sys#make-structure
- 'environment ename (car (module-saved-environments mod)) #t))))
+ (let ((senv (module-saved-environments mod)))
+ (##sys#make-structure 'environment
+ ename
+ (car senv)
+ (cdr senv)
+ #t)))))
+
+(define (scheme.eval#environment . specs)
+ (let ((name (gensym "environment-module-")))
+ (define (delmod)
+ (and-let* ((modp (assq name ##sys#module-table)))
+ (set! ##sys#module-table (delq modp ##sys#module-table))))
+ (define (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)))) ) ) )
+ (dynamic-wind
+ void
+ (lambda ()
+ ;; create module...
+ (scheme#eval `(module ,name ()
+ ,@(map (lambda (spec) `(import ,spec)) specs)))
+ (let* ((mod (##sys#find-module name))
+ (env (module-saved-environments mod)))
+ (##sys#make-structure 'environment
+ (cons 'import specs)
+ (car env)
+ (cdr env)
+ #t)))
+ ;; ...and remove it right away
+ delmod)))
+
+(##sys#register-core-module
+ 'scheme.eval 'eval
+ '((eval . scheme#eval)
+ (environment . scheme.eval#environment)))
+
+(##sys#register-core-module
+ 'scheme.load 'eval
+ '((load . scheme#load)))
+
+(##sys#register-core-module
+ 'scheme.read 'library
+ '((read . scheme#read)))
+
+(##sys#register-core-module
+ 'scheme.repl 'eval
+ '((interaction-environment . scheme#interaction-environment)))
+
+(##sys#register-core-module
+ 'scheme.char 'library
+ '((char-alphabetic? . scheme#char-alphabetic?)
+ (char-ci<=? . scheme#char-ci<=?)
+ (char-ci<? . scheme#char-ci<?)
+ (char-ci=? . scheme#char-ci=?)
+ (char-ci>=? . scheme#char-ci>=?)
+ (char-ci>? . scheme#char-ci>?)
+ (char-downcase . scheme#char-downcase)
+ (char-foldcase . scheme#char-foldcase)
+ (char-lower-case? . scheme#char-lower-case?)
+ (char-numeric? . scheme#char-numeric?)
+ (char-upcase . scheme#char-upcase)
+ (char-upper-case? . scheme#char-upper-case?)
+ (char-whitespace? . scheme#char-whitespace?)
+ (digit-value . scheme.char#digit-value)
+ (string-ci<=? . scheme#string-ci<=?)
+ (string-ci<? . scheme#string-ci<?)
+ (string-ci=? . scheme#string-ci=?)
+ (string-ci>=? . scheme#string-ci>=?)
+ (string-ci>? . scheme#string-ci>?)
+ (string-downcase . scheme#string-downcase)
+ (string-foldcase . scheme#string-foldcase)
+ (string-upcase . scheme#string-upcase)))
;; Ensure default modules are available in "eval", too
;; TODO: Figure out a better way to make this work for static programs.
diff --git a/optimizer.scm b/optimizer.scm
index e99c2af3..7d0a6610 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -42,6 +42,7 @@
chicken.internal
chicken.sort
chicken.string)
+(import (only (scheme base) make-parameter))
(include "tweaks")
(include "mini-srfi-1.scm")
@@ -442,7 +443,7 @@
(for-each (cut db-put! db <> 'inline-target #t)
fids)
(debugging 'o "inlining procedure" info)
- (call/cc
+ (call-with-current-continuation
(lambda (return)
(define (cfk cvar)
(debugging
@@ -1128,7 +1129,7 @@
;; (<op> ...) -> (##core#inline <iop> ...)
((2) ; classargs = (<argc> <iop> <safe>)
- ;; - <safe> by be 'specialized (see rule #16 below)
+ ;; - <safe> may be 'specialized (see rule #16 below)
(and may-rewrite
(= (length callargs) (first classargs))
(intrinsic? name)
diff --git a/pathname.scm b/pathname.scm
index 669c022b..b8ab39be 100644
--- a/pathname.scm
+++ b/pathname.scm
@@ -53,6 +53,7 @@
chicken.irregex
chicken.platform
chicken.string)
+(import (only (scheme base) open-output-string get-output-string))
(include "common-declarations.scm")
@@ -88,11 +89,11 @@
(define (chop-pds str)
(and str
- (let lp ((len (##sys#size str)))
+ (let lp ((len (string-length str)))
(cond ((and (fx>= len 1)
- (*char-pds? (##core#inline "C_subchar" str (fx- len 1))))
+ (*char-pds? (string-ref str (fx- len 1))))
(lp (fx- len 1)))
- ((fx< len (##sys#size str))
+ ((fx< len (string-length str))
(##sys#substring str 0 len))
(else str)))))
@@ -127,13 +128,13 @@
(##sys#check-string ext loc)
(string-append
dir
- (if (and (fx>= (##sys#size dir) 1)
- (fx>= (##sys#size file) 1)
- (*char-pds? (##core#inline "C_subchar" file 0)))
- (##sys#substring file 1 (##sys#size file))
+ (if (and (fx>= (string-length dir) 1)
+ (fx>= (string-length file) 1)
+ (*char-pds? (string-ref file 0)))
+ (##sys#substring file 1 (string-length file))
file)
- (if (and (fx> (##sys#size ext) 0)
- (not (char=? (##core#inline "C_subchar" ext 0) #\.)))
+ (if (and (fx> (string-length ext) 0)
+ (not (char=? (string-ref ext 0) #\.)))
"."
"")
ext)))
@@ -165,12 +166,12 @@
(lambda (dir)
(and dir
(let ((chopped (chop-pds dir)))
- (if (fx> (##sys#size chopped) 0)
+ (if (fx> (string-length chopped) 0)
chopped
(##sys#substring dir 0 1)))))))
(lambda (pn)
(##sys#check-string pn 'decompose-pathname)
- (if (fx= 0 (##sys#size pn))
+ (if (fx= 0 (string-length pn))
(values #f #f #f)
(let ((ms (irregex-search rx1 pn)))
(if ms
@@ -229,7 +230,7 @@
;;; normalize pathname for a particular platform
(define normalize-pathname
- (let ((bldplt (if (eq? (software-version) 'mingw32) 'windows 'unix)))
+ (let ((bldplt (if (eq? (software-version) 'mingw) 'windows 'unix)))
(define (addpart part parts)
(cond ((string=? "." part) parts)
((string=? ".." part)
@@ -245,7 +246,7 @@
(memq c '(#\/ #\\))
(eq? c #\/)))
(##sys#check-string path 'normalize-pathname)
- (let ((len (##sys#size path))
+ (let ((len (string-length path))
(type #f)
(drive #f))
(let loop ((i 0) (prev 0) (parts '()))
@@ -311,13 +312,13 @@
(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))
+ (let ((olen (string-length org)))
+ (if (not (##core#inline "C_u_i_substring_equal_p" 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)))
+ (elen (string-length 1st)))
(if (fx= olen elen)
; then origin is a list prefix
rst
diff --git a/port.scm b/port.scm
index 38dbec85..83e49fef 100644
--- a/port.scm
+++ b/port.scm
@@ -42,6 +42,7 @@
copy-port
make-input-port
make-output-port
+ port-encoding
port-fold
port-for-each
port-map
@@ -51,7 +52,6 @@
make-broadcast-port
make-concatenated-port
set-buffering-mode!
- set-port-name!
terminal-name
terminal-port?
terminal-size
@@ -67,6 +67,7 @@
chicken.fixnum
chicken.foreign
chicken.io)
+(import (only (scheme base) open-output-string get-output-string open-input-string))
(include "common-declarations.scm")
@@ -116,14 +117,27 @@ char *ttyname(int fd) {
(define-foreign-variable _ionbf int "_IONBF")
(define-foreign-variable _bufsiz int "BUFSIZ")
-(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 port-encoding
+ (getter-with-setter
+ (lambda (port)
+ (##sys#check-port port 'port-encoding)
+ (##sys#slot port 15))
+ (lambda (port enc)
+ (##sys#check-port port 'port-encoding)
+ (##sys#check-symbol enc 'port-encoding)
+ (##sys#setslot port 15 enc))
+ "(chicken.port#port-encoding port)"))
+
+(define port-name
+ (getter-with-setter
+ (lambda (#!optional (port ##sys#standard-input))
+ (##sys#check-port port 'port-name)
+ (##sys#slot port 3))
+ (lambda (port name)
+ (##sys#check-port port 'set-port-name!)
+ (##sys#check-string name 'set-port-name!)
+ (##sys#setslot port 3 name))
+ "(chicken.port#port-name port)"))
(define (port-position #!optional (port ##sys#standard-input))
(##sys#check-port port 'port-position)
@@ -174,7 +188,7 @@ char *ttyname(int fd) {
(define-constant +buf-size+ 1024)
-(define copy-port
+(define copy-port
(let ((read-char read-char)
(write-char write-char))
(define (read-buf port writer)
@@ -187,7 +201,7 @@ char *ttyname(int fd) {
(define (write-buf buf n port writer)
(do ((i 0 (fx+ i 1)))
((fx>= i n))
- (writer (integer->char (##sys#byte buf i)) port)))
+ (writer (string-ref buf i) port)))
(define (read-and-write reader writer)
(let loop ()
(let ((x (reader)))
@@ -198,14 +212,14 @@ char *ttyname(int fd) {
(let ((buf (make-string +buf-size+)))
(let loop ((n 0))
(when (fx>= n +buf-size+)
- (write-string buf +buf-size+ dest)
+ (scheme#write-string buf dest 0 +buf-size+)
(set! n 0))
(let ((c (reader src)))
(cond ((eof-object? c)
(when (fx>= n 0)
- (write-string buf n dest)))
+ (scheme#write-string buf dest 0 n)))
(else
- (##sys#setbyte buf n (char->integer c))
+ (string-set! buf n c)
(loop (fx+ n 1))))))))
(lambda (src dest #!optional (read read-char) (write write-char))
;; does not check port args intentionally
@@ -213,12 +227,12 @@ char *ttyname(int fd) {
(read-buf
src
(if (eq? write write-char)
- (lambda (buf n) (write-string buf n dest))
+ (lambda (buf n) (scheme#write-string buf dest 0 n))
(lambda (buf n) (write-buf buf n dest write)))))
((eq? write write-char)
(read-and-write-buf src dest read))
(else
- (read-and-write
+ (read-and-write
(lambda () (read src))
(lambda (x) (write x dest))))))))
@@ -227,7 +241,7 @@ char *ttyname(int fd) {
(define (make-broadcast-port . ports)
(make-output-port
- (lambda (s) (for-each (cut write-string s #f <>) ports))
+ (lambda (s) (for-each (cut scheme#write-string s <>) ports))
void
(lambda () (for-each flush-output ports)) ) )
@@ -248,6 +262,7 @@ char *ttyname(int fd) {
(and (not (null? ports))
(char-ready? (car ports))))
void
+ peek-char:
(lambda ()
(let loop ()
(if (null? ports)
@@ -257,15 +272,16 @@ char *ttyname(int fd) {
(set! ports (cdr ports))
(loop) )
(else c))))))
+ read-bytevector:
(lambda (p n dest start)
- (let loop ((n n) (c 0))
+ (let loop ((n n) (c 0) (p start))
(cond ((null? ports) c)
((fx<= n 0) c)
(else
- (let ((m (read-string! n dest (car ports) (fx+ start c))))
+ (let ((m (read-bytevector! dest (car ports) p (+ p n))))
(when (fx< m n)
(set! ports (cdr ports)) )
- (loop (fx- n m) (fx+ c m))))))))))
+ (loop (fx- n m) (fx+ c m) (fx+ p m))))))))))
;;; Redirect standard ports:
@@ -286,8 +302,8 @@ char *ttyname(int fd) {
(thunk) ) )
;;; Extended string-port operations:
-
-(define call-with-input-string
+
+(define call-with-input-string
(lambda (str proc)
(let ((in (open-input-string str)))
(proc in) ) ) )
@@ -306,7 +322,7 @@ char *ttyname(int fd) {
(define with-output-to-string
(lambda (thunk)
(fluid-let ((##sys#standard-output (open-output-string)))
- (thunk)
+ (thunk)
(get-output-string ##sys#standard-output) ) ) )
(define with-error-output-to-string
@@ -319,62 +335,74 @@ char *ttyname(int fd) {
;
; - Port-slots:
;
-; 10: last
+; 10: last/peeked
(define make-input-port
- (lambda (read ready? close #!optional peek read-string read-line read-buffered)
+ (lambda (read ready? close #!rest r
+ #!key peek-char read-bytevector read-line read-buffered)
+ ;XXX this is for ensuring old-style calls fail and can be removed at some stage
+ (when (and (pair? r) (not (##core#inline "C_i_keywordp" (car r))))
+ (error 'make-input-port "invalid invocation - use keyword parameters" r))
(let* ((class
- (vector
+ (vector
(lambda (p) ; read-char
- (let ([last (##sys#slot p 10)])
- (cond [peek (read)]
- [last
+ (let ((last (##sys#slot p 10)))
+ (cond (peek-char (read))
+ (last
(##sys#setislot p 10 #f)
- last]
- [else (read)] ) ) )
+ last)
+ (else (read)) ) ) )
(lambda (p) ; peek-char
- (let ([last (##sys#slot p 10)])
- (cond [peek (peek)]
- [last last]
- [else
- (let ([last (read)])
+ (let ((last (##sys#slot p 10)))
+ (cond (peek-char (peek-char))
+ (last last)
+ (else
+ (let ((last (read)))
(##sys#setslot p 10 last)
- last) ] ) ) )
+ last) ) ) ) )
#f ; write-char
- #f ; write-string
+ #f ; write-bytevector
(lambda (p d) ; close
(close))
#f ; flush-output
(lambda (p) ; char-ready?
(ready?) )
- read-string ; read-string!
+ (or read-bytevector ; read-bytevector!
+ (lambda (p n dest start)
+ (error "binary I/O not supported for custom text input port without bytevector-read method" p)))
read-line ; read-line
read-buffered))
(data (vector #f))
(port (##sys#make-port 1 class "(custom)" 'custom)))
- (##sys#set-port-data! port data)
+ (##sys#setslot port 10 #f)
+ (##sys#set-port-data! port data)
port) ) )
(define make-output-port
- (lambda (write close #!optional flush)
+ (lambda (write close #!rest r #!key force-output)
+ ;XXX this is for ensuring old-style calls fail and can be removed at some stage
+ (when (and (pair? r) (not (##core#inline "C_i_keywordp" (car r))))
+ (error 'make-output-port "invalid invocation - use keyword parameters" r))
(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 bv from to) ; write-bytevector
+ (let ((len (fx- to from)))
+ (write (##sys#buffer->string bv from len))))
(lambda (p d) ; close
(close))
(lambda (p) ; flush-output
- (when flush (flush)) )
+ (when force-output (force-output)) )
#f ; char-ready?
- #f ; read-string!
- #f) ) ; read-line
+ #f ; read-bytevector!
+ #f ; read-line
+ #f)) ; read-buffered
(data (vector #f))
(port (##sys#make-port 2 class "(custom)" 'custom)))
- (##sys#set-port-data! port data)
+ (##sys#set-port-data! port data)
port) ) )
(define (make-bidirectional-port i o)
@@ -385,8 +413,8 @@ char *ttyname(int fd) {
(peek-char i))
(lambda (_ c) ; write-char
(write-char c o))
- (lambda (_ s) ; write-string
- (write-string s #f o))
+ (lambda (_ bv from to) ; write-bytevector
+ (chicken.io#write-bytevector bv o from to))
(lambda (_ d) ; close
(case d
((1) (close-input-port i))
@@ -395,8 +423,8 @@ char *ttyname(int fd) {
(flush-output o))
(lambda (_) ; char-ready?
(char-ready? i))
- (lambda (_ n d s) ; read-string!
- (read-string! n d i s))
+ (lambda (_ n d s) ; read-bytevector!
+ (chicken.io#read-bytevector! d i s (fx+ s n)))
(lambda (_ l) ; read-line
(read-line i l))
(lambda () ; read-buffered
diff --git a/posix-common.scm b/posix-common.scm
index 96e4da10..7ea2cf56 100644
--- a/posix-common.scm
+++ b/posix-common.scm
@@ -24,7 +24,7 @@
; POSSIBILITY OF SUCH DAMAGE.
-(declare
+(declare
(foreign-declare #<<EOF
#include <signal.h>
@@ -32,13 +32,19 @@
static int C_not_implemented(void);
int C_not_implemented() { return -1; }
-static C_TLS struct stat C_statbuf;
+#if defined(_WIN32) && !defined(__CYGWIN__)
+static struct _stat64i32 C_statbuf;
+#define C_fstat _fstat64i32
+#else
+static struct stat C_statbuf;
+#define C_fstat fstat
+#endif
#define C_stat_type (C_statbuf.st_mode & S_IFMT)
#define C_stat_perm (C_statbuf.st_mode & ~S_IFMT)
-#define C_u_i_stat(fn) C_fix(C_stat(C_c_string(fn), &C_statbuf))
-#define C_u_i_fstat(fd) C_fix(fstat(C_unfix(fd), &C_statbuf))
+#define C_u_i_stat(fn) C_fix(C_stat(C_OS_FILENAME(fn, 0), &C_statbuf))
+#define C_u_i_fstat(fd) C_fix(C_fstat(C_unfix(fd), &C_statbuf))
#ifndef S_IFSOCK
# define S_IFSOCK 0140000
@@ -126,6 +132,8 @@ EOF
(include "common-declarations.scm")
+(import (only (scheme base) port?))
+
(define-syntax define-unimplemented
(syntax-rules ()
((_ ?name)
@@ -244,7 +252,7 @@ EOF
#:type-error loc "bad argument type - not a fixnum, port or string" file)) ) ) )
(if (fx< r 0)
(if err
- (posix-error #:file-error loc "cannot access file" file)
+ (posix-error #:file-error loc "cannot access file" file)
#f)
#t)))
@@ -291,7 +299,7 @@ EOF
(when atime (##sys#check-exact-integer atime 'set-file-times!))
(when mtime (##sys#check-exact-integer mtime 'set-file-times!))
(let ((r ((foreign-lambda int "set_file_mtime"
- c-string scheme-object scheme-object)
+ scheme-object scheme-object scheme-object)
f atime mtime)))
(when (fx< r 0)
(apply posix-error
@@ -481,28 +489,27 @@ EOF
(let ()
(define (mode inp m loc)
(##sys#make-c-string
- (cond ((pair? m)
- (let ([m (car m)])
- (case m
+ (cond (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"] )
+ (else (##sys#error "invalid mode argument" m)) ) )
+ (inp "r")
+ (else "w") )
loc) )
- (define (check loc fd inp r)
+ (define (check loc fd inp r enc)
(if (##sys#null-pointer? r)
(posix-error #:file-error loc "cannot open file" fd)
(let ((port (##sys#make-port (if inp 1 2) ##sys#stream-port-class "(fdport)" 'stream)))
(##core#inline "C_set_file_ptr" port r)
+ (##sys#setslot port 15 enc)
port) ) )
(set! chicken.file.posix#open-input-file*
- (lambda (fd . m)
+ (lambda (fd #!optional m (enc 'utf-8))
(##sys#check-fixnum fd 'open-input-file*)
- (check 'open-input-file* fd #t (##core#inline_allocate ("C_fdopen" 2) fd (mode #t m 'open-input-file*))) ) )
+ (check 'open-input-file* fd #t (##core#inline_allocate ("C_fdopen" 2) fd (mode #t m 'open-input-file*)) enc)) )
(set! chicken.file.posix#open-output-file*
- (lambda (fd . m)
+ (lambda (fd #!optional m (enc 'utf-8))
(##sys#check-fixnum fd 'open-output-file*)
- (check 'open-output-file* fd #f (##core#inline_allocate ("C_fdopen" 2) fd (mode #f m 'open-output-file*)) ) ) ) )
+ (check 'open-output-file* fd #f (##core#inline_allocate ("C_fdopen" 2) fd (mode #f m 'open-output-file*)) enc) ) ) )
(set! chicken.file.posix#port->fileno
(lambda (port)
@@ -595,7 +602,7 @@ EOF
(##sys#check-exact-integer secs 'seconds->string)
(let ([str (ctime secs)])
(if str
- (##sys#substring str 0 (fx- (##sys#size str) 1))
+ (##sys#substring str 0 (fx- (string-length str) 1))
(##sys#error 'seconds->string "cannot convert seconds to string" secs) ) ) ) ) )
(set! chicken.time.posix#local-time->seconds
@@ -620,7 +627,7 @@ EOF
(##sys#error 'time->string "time formatting overflows buffer" tm)) )
(let ([str (asctime tm (##sys#make-string tm-size #\nul))])
(if str
- (##sys#substring str 0 (fx- (##sys#size str) 1))
+ (##sys#substring str 0 (fx- (string-length str) 1))
(##sys#error 'time->string "cannot convert time vector to string" tm) ) ) ) ) ) )
@@ -639,7 +646,7 @@ EOF
(##sys#slot ##sys#signal-vector sig) )
chicken.process.signal#set-signal-handler!
"(chicken.process.signal#signal-handler sig)"))
-
+
(set! chicken.process.signal#make-signal-handler
(lambda sigs
(let ((q (##sys#make-event-queue)))
@@ -647,14 +654,14 @@ EOF
(lambda (sig)
(##sys#check-fixnum sig 'make-signal-handler)
(##core#inline "C_establish_signal_handler" sig sig)
- (vector-set! ##sys#signal-vector sig
+ (vector-set! ##sys#signal-vector sig
(lambda (sig) (##sys#add-event-to-queue! q sig))))
sigs)
- (lambda (#!optional wait)
+ (lambda (#!optional wait)
(if wait
(##sys#wait-for-next-event q)
(##sys#get-next-event q))))))
-
+
(set! chicken.process.signal#signal-ignore
(lambda (sig)
(##sys#check-fixnum sig 'signal-ignore)
diff --git a/posix.scm b/posix.scm
index 78e54065..c49906bc 100644
--- a/posix.scm
+++ b/posix.scm
@@ -47,7 +47,7 @@
file-close file-control file-creation-mode file-group file-link
file-lock file-lock/blocking file-mkstemp file-open file-owner
file-permissions file-position file-read file-select file-size
- file-stat file-test-lock file-truncate file-unlock file-write
+ file-stat file-truncate file-unlock file-write
file-type block-device? character-device? directory? fifo?
regular-file? socket? symbolic-link?
fileno/stderr fileno/stdin fileno/stdout
@@ -95,7 +95,6 @@
(define file-select)
(define file-size)
(define file-stat)
-(define file-test-lock)
(define file-truncate)
(define file-unlock)
(define file-write)
@@ -108,14 +107,14 @@
(define regular-file?)
(define socket?)
(define symbolic-link?)
-
+
(define fileno/stderr)
(define fileno/stdin)
(define fileno/stdout)
-
+
(define open-input-file*)
(define open-output-file*)
-
+
(define open/append)
(define open/binary)
(define open/creat)
@@ -132,7 +131,7 @@
(define open/trunc)
(define open/write)
(define open/wronly)
-
+
(define perm/irgrp)
(define perm/iroth)
(define perm/irusr)
@@ -148,7 +147,7 @@
(define perm/ixgrp)
(define perm/ixoth)
(define perm/ixusr)
-
+
(define port->fileno)
(define seek/cur)
@@ -214,8 +213,8 @@
;;; Quote string for shell:
(define (qs str #!optional (platform (software-version)))
- (let* ((delim (if (eq? platform 'mingw32) #\" #\'))
- (escaped (if (eq? platform 'mingw32) "\"\"" "'\\''"))
+ (let* ((delim (if (eq? platform 'mingw) #\" #\'))
+ (escaped (if (eq? platform 'mingw) "\"\"" "'\\''"))
(escaped-parts
(map (lambda (c)
(cond
diff --git a/posixunix.scm b/posixunix.scm
index 665c89e0..9f6fdb28 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -34,7 +34,7 @@
#>
-static C_TLS int C_wait_status;
+static int C_wait_status;
#include <sys/time.h>
#include <sys/wait.h>
@@ -49,6 +49,10 @@ static C_TLS int C_wait_status;
# include <termios.h>
#endif
+#ifdef __linux__
+# include <sys/file.h>
+#endif
+
#include <sys/mman.h>
#include <poll.h>
@@ -83,9 +87,8 @@ static C_TLS int C_wait_status;
# define FILENAME_MAX 1024
#endif
-static C_TLS struct flock C_flock;
-static C_TLS DIR *temphandle;
-static C_TLS struct passwd *C_user;
+static DIR *temphandle;
+static struct passwd *C_user;
/* Android doesn't provide pw_gecos in the passwd struct */
#ifdef __ANDROID__
@@ -94,10 +97,10 @@ static C_TLS struct passwd *C_user;
# define C_PW_GECOS (C_user->pw_gecos)
#endif
-static C_TLS int C_pipefds[ 2 ];
-static C_TLS time_t C_secs;
-static C_TLS struct timeval C_timeval;
-static C_TLS struct stat C_statbuf;
+static int C_pipefds[ 2 ];
+static time_t C_secs;
+static struct timeval C_timeval;
+static struct stat C_statbuf;
#define C_fchdir(fd) C_fix(fchdir(C_unfix(fd)))
@@ -142,7 +145,7 @@ static C_TLS struct stat C_statbuf;
#define C_u_i_execvp(f,a) C_fix(execvp(C_c_string(f), (char *const *)C_c_pointer_vector_or_null(a)))
#define C_u_i_execve(f,a,e) C_fix(execve(C_c_string(f), (char *const *)C_c_pointer_vector_or_null(a), (char *const *)C_c_pointer_vector_or_null(e)))
-static C_TLS int C_uw;
+static 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)))
@@ -156,12 +159,12 @@ static C_TLS int C_uw;
# define C_mkfifo(fn, m) C_fix(mkfifo(C_c_string(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_word C_flock(C_word n, C_word f)
+{
+ return C_fix(flock(C_unfix(n), C_unfix(f)));
+}
-static C_TLS sigset_t C_sigset;
+static 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)
@@ -172,8 +175,8 @@ static C_TLS sigset_t C_sigset;
#define C_sigprocmask_get(d) C_fix(sigprocmask(SIG_SETMASK, NULL, &C_sigset))
#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_read(fd, b, n) C_fix(read(C_unfix(fd), C_c_string(b), C_unfix(n)))
+#define C_write(fd, b, start, n) C_fix(write(C_unfix(fd), C_c_string(b) + C_unfix(start), C_unfix(n)))
#define C_mkstemp(t) C_fix(mkstemp(C_c_string(t)))
#define C_ctime(n) (C_secs = (n), ctime(&C_secs))
@@ -250,14 +253,15 @@ C_tm_get( C_word v, void *tm )
#define C_strptime(s, f, v, stm) \
(strptime(C_c_string(s), C_c_string(f), ((struct tm *)(stm))) ? C_tm_get((v), (stm)) : C_SCHEME_FALSE)
-static int set_file_mtime(char *filename, C_word atime, C_word mtime)
+static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
{
struct stat sb;
struct utimbuf tb;
+ C_word bv = C_block_item(filename, 0);
/* Only lstat if needed */
if (atime == C_SCHEME_FALSE || mtime == C_SCHEME_FALSE) {
- if (lstat(filename, &sb) == -1) return -1;
+ if (lstat(C_c_string(bv), &sb) == -1) return -1;
}
if (atime == C_SCHEME_FALSE) {
@@ -270,7 +274,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
} else {
tb.modtime = C_num_to_int64(mtime);
}
- return utime(filename, &tb);
+ return utime(C_c_string(bv), &tb);
}
<#
@@ -360,9 +364,9 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(lambda (fd size . buffer)
(##sys#check-fixnum fd 'file-read)
(##sys#check-fixnum 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 ([buf (if (pair? buffer) (car buffer) (##sys#make-bytevector size))])
+ (unless (##core#inline "C_byteblockp" buf)
+ (##sys#signal-hook #:type-error 'file-read "bad argument type - not a bytevector" 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) )
@@ -371,11 +375,11 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(set! chicken.file.posix#file-write
(lambda (fd buffer . size)
(##sys#check-fixnum 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) )
+ (unless (##core#inline "C_byteblockp" buffer)
+ (##sys#signal-hook #:type-error 'file-write "bad argument type - not a bytevector" buffer) )
(let ([size (if (pair? size) (car size) (##sys#size buffer))])
(##sys#check-fixnum size 'file-write)
- (let ([n (##core#inline "C_write" fd buffer size)])
+ (let ([n (##core#inline "C_write" fd buffer 0 size)])
(when (eq? -1 n)
(posix-error #:file-error 'file-write "cannot write to file" fd size) )
n) ) ) )
@@ -385,7 +389,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(##sys#check-string template 'file-mkstemp)
(let* ([buf (##sys#make-c-string template 'file-mkstemp)]
[fd (##core#inline "C_mkstemp" buf)]
- [path-length (##sys#size buf)])
+ [path-length (string-length 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) ) ) ) ) )
@@ -407,7 +411,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(nfdsr (##sys#length fdsrl))
(nfdsw (##sys#length fdswl))
(nfds (fx+ nfdsr nfdsw))
- (fds-blob (##sys#make-blob
+ (fds-blob (##sys#make-bytevector
(fx* nfds (foreign-value "sizeof(struct pollfd)" int)))))
(do ((i 0 (fx+ i 1))
(fdsrl fdsrl (cdr fdsrl)))
@@ -629,7 +633,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
"(chicken.process-context.posix#current-group-id)") )
(set! chicken.process-context.posix#current-effective-group-id
- (getter-with-setter
+ (getter-with-setter
(foreign-lambda int "C_getegid")
(lambda (id)
(##sys#check-fixnum id 'current-effective-group-id)
@@ -735,14 +739,15 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(define-foreign-variable _filename_max int "FILENAME_MAX")
(define ##sys#read-symbolic-link
- (let ((buf (make-string (fx+ _filename_max 1))))
+ (let ((buf (##sys#make-bytevector (fx+ _filename_max 1) 0)))
(lambda (fname location)
(let ((len (##core#inline
"C_do_readlink"
- (##sys#make-c-string fname location) buf)))
+ (##sys#make-c-string fname location)
+ buf)))
(if (fx< len 0)
(posix-error #:file-error location "cannot read symbolic link" fname)
- (substring buf 0 len))))))
+ (##sys#buffer->string buf 0 len))))))
(set! chicken.file.posix#read-symbolic-link
(lambda (fname #!optional canonicalize)
@@ -775,12 +780,13 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(define ##sys#custom-input-port
- (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 1) (on-close void) (more? #f))
+ (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 1) (on-close void) (more? #f) enc)
(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 ((bufsiz (if (fixnum? bufi) bufi (##sys#size bufi)))
+ (buf (if (fixnum? bufi) (##sys#make-bytevector bufi) bufi))
+ (buflen 0)
+ (bufpos 0)
+ (this-port #f))
(let ([ready?
(lambda ()
(let ((res (##sys#file-select-one fd)))
@@ -794,7 +800,9 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(lambda ()
(if (fx>= bufpos buflen)
#!eof
- (##core#inline "C_subchar" buf bufpos)) )]
+ (##sys#decode-buffer buf bufpos 1 (##sys#slot this-port 15)
+ (lambda (buf start n)
+ (##core#inline "C_utf_decode" buf start)))))]
[fetch
(lambda ()
(let loop ()
@@ -812,7 +820,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
[(and more? (fx= cnt 0))
;; When "more" keep trying, otherwise read once more
;; to guard against race conditions
- (if (more?)
+ (if more?
(begin
(##sys#thread-yield!)
(loop) )
@@ -827,14 +835,17 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
[else
(set! buflen cnt)
(set! bufpos 0)]) ) ) )] )
- (letrec ([this-port
+ (let ([the-port
(make-input-port
(lambda () ; read-char
(when (fx>= bufpos buflen)
(fetch))
- (let ([ch (peek)])
- (unless (eof-object? ch) (set! bufpos (fx+ bufpos 1)))
- ch ) )
+ (if (fx>= bufpos buflen)
+ #!eof
+ (##sys#decode-buffer buf bufpos 1 (##sys#slot this-port 15)
+ (lambda (buf start n)
+ (set! bufpos (fx+ bufpos n))
+ (##core#inline "C_utf_decode" buf start)))))
(lambda () ; char-ready?
(or (fx< bufpos buflen)
(ready?)) )
@@ -842,24 +853,30 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(when (fx< (##core#inline "C_close" fd) 0)
(posix-error #:file-error loc "cannot close" fd nam))
(on-close))
- (lambda () ; peek-char
+ peek-char:
+ (lambda () ; peek-char
(when (fx>= bufpos buflen)
(fetch))
(peek) )
- (lambda (port n dest start) ; read-string!
- (let loop ([n (or n (fx- (##sys#size dest) start))] [m 0] [start start])
+ read-bytevector:
+ (lambda (port n dest start) ; read-bytevector!
+ (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)
+ (##core#inline "C_copy_memory_with_offset"
+ dest buf start bufpos n2)
(set! bufpos (fx+ bufpos n2))
(loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) ]
[else
(fetch)
- (if (eq? 0 buflen)
+ (if (eq? 0 buflen)
m
(loop n m start) ) ] ) ) )
+ read-line:
(lambda (p limit) ; read-line
(when (fx>= bufpos buflen)
(fetch))
@@ -882,79 +899,91 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(values buf bufpos
(fxmin buflen
(fx+ bufpos limit)))
- (values #f bufpos #f)))))))
+ (values #f bufpos #f))))))
+ (##sys#slot this-port 15))
;; Update row & column position
(if full-line?
(begin
(##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
(##sys#setislot p 5 0))
(##sys#setislot p 5 (fx+ (##sys#slot p 5)
- (##sys#size line))))
+ (string-length line))))
(set! bufpos next)
line)) ) )
+ read-buffered:
(lambda (port) ; read-buffered
(if (fx>= bufpos buflen)
""
- (let ((str (##sys#substring buf bufpos buflen)))
+ (let* ((len (fx- buflen bufpos))
+ (str (##sys#buffer->string/encoding buf bufpos len (##sys#slot this-port 15))))
(set! bufpos buflen)
- str)))
- ) ] )
+ str))))])
+ (set! this-port the-port)
(##sys#setslot this-port 3 nam)
+ (##sys#setslot this-port 15 enc)
this-port ) ) ) ) )
(define ##sys#custom-output-port
- (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 0) (on-close void))
+ (lambda (loc nam fd #!optional (nonblocking? #f) (bufi 0) (on-close void)
+ enc)
(when nonblocking? (##sys#file-nonblocking! fd) )
- (letrec ([poke
- (lambda (str len)
+ (letrec ((this-port #f)
+ (poke
+ (lambda (bv start len)
(let loop ()
- (let ((cnt (##core#inline "C_write" fd str len)))
+ (let ((cnt (##core#inline "C_write" fd bv start len)))
(cond ((fx= -1 cnt)
(cond
((or (fx= _errno _ewouldblock)
(fx= _errno _eagain))
(##sys#thread-yield!)
- (poke str len) )
+ (poke bv start len) )
((fx= _errno _eintr)
(##sys#dispatch-interrupt loop))
(else
(posix-error loc #:file-error "cannot write" fd nam) ) ) )
((fx< cnt len)
- (poke (##sys#substring str cnt len) (fx- len cnt)) ) ) ) ))]
- [store
+ (poke bv (fx+ start cnt) (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])
+ (let ((bv (##sys#slot str 0)))
+ (poke bv 0 (fx- (##sys#size bv) 1)))))
+ (let ((buf (if (fixnum? bufi) (##sys#make-bytevector 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)
+ (let ((bv (##sys#slot str 0)))
+ (let loop ((rem (fx- bufsiz bufpos))
+ (start 0)
+ (len (fx- (##sys#size bv) 1)))
+ (cond ((fx= 0 rem)
+ (poke buf 0 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))] ) )
+ (loop bufsiz 0 len))
+ ((fx< rem len)
+ (##core#inline "C_copy_memory_with_offset" buf bv bufpos 0 len)
+ (loop 0 rem (fx- len rem)))
+ (else
+ (##core#inline "C_copy_memory_with_offset" buf bv bufpos start len)
+ (set! bufpos (fx+ bufpos len))) ) )
(when (fx< 0 bufpos)
- (poke buf bufpos) ) ) ) ) ) )])
- (letrec ([this-port
+ (poke buf bufpos) ) ) ) ) ) ))))
+ (let ((the-port
(make-output-port
- (lambda (str) ; write-string
- (store str) )
+ (lambda (str) (store str))
(lambda () ; close
(when (fx< (##core#inline "C_close" fd) 0)
(posix-error #:file-error loc "cannot close" fd nam))
(on-close))
+ force-output:
(lambda () ; flush
- (store #f) ) )] )
+ (store #f) ) )) )
+ (set! this-port the-port)
(##sys#setslot this-port 3 nam)
+ (##sys#setslot this-port 15 enc)
this-port ) ) ) )
@@ -971,59 +1000,46 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(posix-error #:file-error 'file-truncate "cannot truncate file" fname off) ) ) )
-;;; Record locking:
+;;; File 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")
+(define-foreign-variable _lock_sh int "LOCK_SH")
+(define-foreign-variable _lock_ex int "LOCK_EX")
+(define-foreign-variable _lock_un int "LOCK_UN")
+(define-foreign-variable _lock_nb int "LOCK_NB")
(let ()
- (define (setup port args loc)
- (let-optionals* args ([start 0]
- [len #t] )
- (##sys#check-open-port port loc)
- (##sys#check-exact-integer start loc)
- (if (eq? #t len)
- (set! len 0)
- (##sys#check-exact-integer len loc) )
- (##core#inline "C_flock_setup" (if (= (##sys#slot port 1) 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)) )
+ (define (err msg port loc)
+ (posix-error #:file-error loc msg port) )
+ (define (fileno x loc)
+ (if (port? x)
+ (chicken.file.posix#port->fileno x)
+ (begin
+ (##sys#check-exact-integer x loc)
+ x)))
(set! chicken.file.posix#file-lock
- (lambda (port . args)
+ (lambda (port #!optional shared)
(let loop ()
- (let ((lock (setup port args 'file-lock)))
- (if (fx< (##core#inline "C_flock_lock" port) 0)
- (cond
- ((fx= _errno _eintr) (##sys#dispatch-interrupt loop))
- (else (err "cannot lock file" lock 'file-lock)))
- lock)))))
+ (let ((r (##core#inline "C_flock" (fileno port 'file-lock)
+ (##core#inline "C_fixnum_or" _lock_nb (if shared _lock_sh _lock_ex)))))
+ (cond ((eq? r 0) #t)
+ ((fx= _errno _eintr) (loop))
+ ((fx= _errno _ewouldblock) #f)
+ (else (err "locking file failed" port 'file-lock)))))))
(set! chicken.file.posix#file-lock/blocking
- (lambda (port . args)
+ (lambda (port #!optional shared)
(let loop ()
- (let ((lock (setup port args 'file-lock/blocking)))
- (if (fx< (##core#inline "C_flock_lockw" port) 0)
- (cond
- ((fx= _errno _eintr) (##sys#dispatch-interrupt loop))
- (else (err "cannot lock file" lock 'file-lock/blocking)))
- lock)))))
- (set! chicken.file.posix#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)] ) ) ) ) )
-
-(set! chicken.file.posix#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)
- (cond
- ((fx= _errno _eintr)
- (##sys#dispatch-interrupt
- (lambda () (chicken.file.posix#file-unlock lock))))
- (else (posix-error #:file-error 'file-unlock "cannot unlock file" lock))))))
+ (let ((r (##core#inline "C_flock" (fileno port 'file-lock/blocking)
+ (if shared _lock_sh _lock_ex))))
+ (cond ((eq? r 0) #t)
+ ((fx= _errno _eintr) (loop))
+ (else (err "locking file failed" port 'file-lock/blocking)))))))
+ (set! chicken.file.posix#file-unlock
+ (lambda (port)
+ (let loop ()
+ (let ((r (##core#inline "C_flock" (fileno port 'file-unlock) _lock_un)))
+ (cond ((eq? r 0))
+ ((fx= _errno _eintr) (loop))
+ (else (err "unlocking file failed" port 'file-unlock))))))))
;;; FIFOs:
@@ -1082,7 +1098,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
;; flush all stdio streams before fork
((foreign-lambda int "C_fflush" c-pointer) #f)
(let ((pid (fork)))
- (when (fx= -1 pid)
+ (when (fx= -1 pid)
(posix-error #:process-error 'process-fork "cannot create child process"))
(if (and thunk (zero? pid))
((if killothers
@@ -1096,7 +1112,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
pid)))))
(set! chicken.process#process-execute
- (lambda (filename #!optional (arglist '()) envlist exactf)
+ (lambda (filename #!optional (arglist '()) envlist _)
(call-with-exec-args
'process-execute filename (lambda (x) x) arglist envlist
(lambda (prg argbuf envbuf)
@@ -1220,14 +1236,14 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(connect-child loc (swapped-ends epipe) stderrf chicken.file.posix#fileno/stderr)
(chicken.process#process-execute cmd args env)))) ) ) ))
[input-port
- (lambda (loc pid cmd pipe stdf stdfd on-close)
+ (lambda (loc pid cmd pipe stdf stdfd on-close enc)
(and-let* ([fd (connect-parent loc pipe stdf stdfd)])
- (##sys#custom-input-port loc cmd fd #t DEFAULT-INPUT-BUFFER-SIZE on-close) ) )]
+ (##sys#custom-input-port loc cmd fd #t DEFAULT-INPUT-BUFFER-SIZE on-close #f enc) ) )]
[output-port
- (lambda (loc pid cmd pipe stdf stdfd on-close)
+ (lambda (loc pid cmd pipe stdf stdfd on-close enc)
(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)
+ (##sys#custom-output-port loc cmd fd #t DEFAULT-OUTPUT-BUFFER-SIZE on-close enc) ) )] )
+ (lambda (loc cmd args env stdoutf stdinf stderrf enc)
(receive [inpipe outpipe errpipe pid]
(spawn loc cmd args env stdoutf stdinf stderrf)
;When shared assume already "closed", since only created ports
@@ -1237,20 +1253,23 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(values
(input-port loc pid cmd inpipe stdinf
chicken.file.posix#fileno/stdin
- (make-on-close loc pid clsvec 0 1 2))
+ (make-on-close loc pid clsvec 0 1 2)
+ enc)
(output-port loc pid cmd outpipe stdoutf
chicken.file.posix#fileno/stdout
- (make-on-close loc pid clsvec 1 0 2))
+ (make-on-close loc pid clsvec 1 0 2)
+ enc)
pid
(input-port loc pid cmd errpipe stderrf
chicken.file.posix#fileno/stderr
- (make-on-close loc pid clsvec 2 0 1)) ) ) ) ) ) ) ) )
+ (make-on-close loc pid clsvec 2 0 1)
+ enc) ) ) ) ) ) ) ) )
;;; Run subprocess connected with pipes:
;; TODO: See if this can be moved to posix-common
(let ((%process
- (lambda (loc err? cmd args env k)
+ (lambda (loc err? cmd args env enc k)
(let ((chkstrlst
(lambda (lst)
(##sys#check-list lst loc)
@@ -1263,17 +1282,17 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(set! cmd (shell-command loc)) ) )
(when env (check-environment-list env loc))
(##sys#call-with-values
- (lambda () (process-impl loc cmd args env #t #t err?))
+ (lambda () (process-impl loc cmd args env #t #t err? enc))
k)))))
(set! chicken.process#process
- (lambda (cmd #!optional args env exactf)
- (%process
- 'process #f cmd args env
+ (lambda (cmd #!optional args env (enc 'utf-8) exactf)
+ (%process
+ 'process #f cmd args env enc
(lambda (i o p e) (values i o p)))))
(set! chicken.process#process*
- (lambda (cmd #!optional args env exactf)
+ (lambda (cmd #!optional args env (enc 'utf-8) exactf)
(%process
- 'process* #t cmd args env
+ 'process* #t cmd args env enc
values))))
diff --git a/posixwin.scm b/posixwin.scm
index cadba1b3..13c9a987 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -88,41 +88,41 @@
# define EWOULDBLOCK 0
#endif
-static C_TLS int C_pipefds[ 2 ];
-static C_TLS time_t C_secs;
+static int C_pipefds[ 2 ];
+static time_t C_secs;
/* 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;
+static HANDLE C_rd0, C_wr0, C_wr0_, C_rd1, C_wr1, C_rd1_;
+static HANDLE C_save0, C_save1; /* saved I/O handles */
+static char C_rdbuf; /* one-char buffer for read */
+static int C_exstatus;
/* platform information; initialized for cached testing */
-static C_TLS char C_shlcmd[256] = "";
+static char C_shlcmd[256] = "";
/* Current user name */
-static C_TLS TCHAR C_username[255 + 1] = "";
+static C_char C_username[255 + 1] = "";
-#define open_binary_input_pipe(a, n, name) C_mpointer(a, _popen(C_c_string(name), "r"))
+#define open_binary_input_pipe(a, n, name) C_mpointer(a, _wpopen(C_OS_FILENAME(name, 0), L"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_binary_output_pipe(a, n, name) C_mpointer(a, _wpopen(C_OS_FILENAME(name, 0), L"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_chmod(fn, m) C_fix(chmod(C_c_string(fn), C_unfix(m)))
+#define C_chmod(fn, m) C_fix(_wchmod(C_OS_FILENAME(fn, 0), 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_u_i_lstat(fn) C_u_i_stat(fn)
-#define C_u_i_execvp(f,a) C_fix(execvp(C_c_string(f), (const char *const *)C_c_pointer_vector_or_null(a)))
-#define C_u_i_execve(f,a,e) C_fix(execve(C_c_string(f), (const char *const *)C_c_pointer_vector_or_null(a), (const char *const *)C_c_pointer_vector_or_null(e)))
+#define C_u_i_execvp(f, a) C_fix(execvp(C_c_string(f), (void *)C_c_pointer_vector_or_null(a)))
+#define C_u_i_execve(f,a,e) C_fix(execve(C_c_string(f), (void *)C_c_pointer_vector_or_null(a), (void *)C_c_pointer_vector_or_null(e)))
/* MS replacement for the fork-exec pair */
-#define C_u_i_spawnvp(m,f,a) C_fix(spawnvp(C_unfix(m), C_c_string(f), (const char *const *)C_c_pointer_vector_or_null(a)))
-#define C_u_i_spawnvpe(m,f,a,e) C_fix(spawnvpe(C_unfix(m), C_c_string(f), (const char *const *)C_c_pointer_vector_or_null(a), (const char *const *)C_c_pointer_vector_or_null(e)))
+#define C_u_i_spawnvp(m,f,a) C_fix(spawnvp(C_unfix(m), C_c_string(f), (void *)C_c_pointer_vector_or_null(a)))
+#define C_u_i_spawnvpe(m,f,a,e) C_fix(spawnvpe(C_unfix(m), C_c_string(f), (void *)C_c_pointer_vector_or_null(a), (void *)C_c_pointer_vector_or_null(e)))
-#define C_open(fn, fl, m) C_fix(open(C_c_string(fn), C_unfix(fl), C_unfix(m)))
+#define C_open(fn, fl, m) C_fix(_wopen(C_OS_FILENAME(fn, 0), 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)))
@@ -196,7 +196,7 @@ static errmap_t errmap[] =
{0, 0}
};
-static void C_fcall
+static void
set_errno(DWORD w32err)
{
errmap_t *map;
@@ -211,14 +211,14 @@ set_errno(DWORD w32err)
errno = ENOSYS; /* For lack of anything better */
}
-static int C_fcall
+static int
set_last_errno()
{
set_errno(GetLastError());
return 0;
}
-static int fd_to_path(C_word fd, TCHAR path[])
+static int fd_to_path(C_word fd, C_WCHAR path[])
{
DWORD result;
HANDLE fh = (HANDLE)_get_osfhandle(C_unfix(fd));
@@ -228,7 +228,8 @@ static int fd_to_path(C_word fd, TCHAR path[])
return -1;
}
- result = GetFinalPathNameByHandle(fh, path, MAX_PATH, VOLUME_NAME_DOS);
+ /* XXX wchar_t */
+ result = GetFinalPathNameByHandleW(fh, path, MAX_PATH, VOLUME_NAME_DOS);
if (result == 0) {
set_last_errno();
return -1;
@@ -242,19 +243,19 @@ static int fd_to_path(C_word fd, TCHAR path[])
static C_word C_fchmod(C_word fd, C_word m)
{
- TCHAR path[MAX_PATH];
+ C_WCHAR path[MAX_PATH];
if (fd_to_path(fd, path) == -1) return C_fix(-1);
- else return C_fix(chmod(path, C_unfix(m)));
+ else return C_fix(_wchmod(path, C_unfix(m)));
}
static C_word C_fchdir(C_word fd)
{
- TCHAR path[MAX_PATH];
+ C_WCHAR path[MAX_PATH];
if (fd_to_path(fd, path) == -1) return C_fix(-1);
- else return C_fix(chdir(path));
+ else return C_fix(_wchdir(path));
}
-static int C_fcall
+static int
process_wait(C_word h, C_word t)
{
if (WaitForSingleObject((HANDLE)h, (t ? 0 : INFINITE)) == WAIT_OBJECT_0)
@@ -273,10 +274,10 @@ process_wait(C_word h, C_word t)
#define C_process_wait(p, t) (process_wait(C_unfix(p), C_truep(t)) ? C_SCHEME_TRUE : C_SCHEME_FALSE)
-static C_TLS int C_isNT = 0;
+static int C_isNT = 0;
-static int C_fcall
+static int
C_windows_nt()
{
static int has_info = 0;
@@ -301,14 +302,14 @@ C_windows_nt()
}
-static int C_fcall
+static int
get_shlcmd()
{
/* Do we need to build the shell command pathname? */
if (!strlen(C_shlcmd))
{
char *cmdnam = C_windows_nt() ? "\\cmd.exe" : "\\command.com";
- UINT len = GetSystemDirectory(C_shlcmd, sizeof(C_shlcmd) - strlen(cmdnam));
+ UINT len = GetSystemDirectoryA(C_shlcmd, sizeof(C_shlcmd) - strlen(cmdnam));
if (len)
C_strlcpy(C_shlcmd + len, cmdnam, sizeof(C_shlcmd));
else
@@ -323,13 +324,13 @@ get_shlcmd()
/* GetUserName */
-static int C_fcall
+static int
get_user_name()
{
- if (!strlen(C_username))
+ if (!C_strlen(C_username))
{
DWORD bufCharCount = sizeof(C_username) / sizeof(C_username[0]);
- if (!GetUserName(C_username, &bufCharCount))
+ if (!GetUserNameA(C_username, &bufCharCount))
return set_last_errno();
}
return 1;
@@ -355,7 +356,7 @@ get_user_name()
Returns: zero return value indicates failure.
*/
-static int C_fcall
+static int
C_process(const char *app, const char *cmdlin, const char **env,
int *phandle, int *pstdin_fd, int *pstdout_fd, int *pstderr_fd,
int params)
@@ -484,14 +485,16 @@ C_process(const char *app, const char *cmdlin, const char **env,
return success;
}
-static int set_file_mtime(char *filename, C_word atime, C_word mtime)
+static int set_file_mtime(C_word filename, C_word atime, C_word mtime)
{
- struct stat sb;
+ struct _stat64i32 sb;
struct _utimbuf tb;
+ C_word bv = C_block_item(filename, 0);
+ C_WCHAR *fn = C_OS_FILENAME(bv, 0);
/* Only stat if needed */
if (atime == C_SCHEME_FALSE || mtime == C_SCHEME_FALSE) {
- if (C_stat(filename, &sb) == -1) return -1;
+ if (C_stat(fn, &sb) == -1) return -1;
}
if (atime == C_SCHEME_FALSE) {
@@ -504,7 +507,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
} else {
tb.modtime = C_num_to_int64(mtime);
}
- return _utime(filename, &tb);
+ return _wutime(fn, &tb);
}
<#
@@ -545,7 +548,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(##sys#check-fixnum 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) )
+ (##sys#signal-hook #:type-error 'file-read "bad argument type - not a string or bytevector" buf) )
(let ([n (##core#inline "C_read" fd buf size)])
(when (eq? -1 n)
(##sys#signal-hook/errno
@@ -553,11 +556,14 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(list buf n) ) ) ) )
(set! chicken.file.posix#file-write
- (lambda (fd buffer . size)
+ (lambda (fd buffer #!optional size)
(##sys#check-fixnum 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))])
+ (when (string? buffer)
+ (set! buffer (##sys#slot buffer 0))
+ (unless size (set! size (fx- (##sys#size buffer) 1))))
+ (unless (##core#inline "C_byteblockp" buffer)
+ (##sys#signal-hook #:type-error 'file-write "bad argument type - not a string or bytevector" buffer) )
+ (let ((size (or size (##sys#size buffer))))
(##sys#check-fixnum size 'file-write)
(let ([n (##core#inline "C_write" fd buffer size)])
(when (eq? -1 n)
@@ -797,7 +803,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
; 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)
+ (lambda (loc cmd args env stdoutf stdinf stderrf exactf enc)
(let* ((arglist (cons cmd args))
(cmdlin (string-intersperse
(if exactf
@@ -824,7 +830,7 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
;; TODO: See if this can be moved to posix-common
(let ((%process
- (lambda (loc err? cmd args env exactf)
+ (lambda (loc err? cmd args env exactf enc)
(let ((chkstrlst
(lambda (lst)
(##sys#check-list lst loc)
@@ -838,16 +844,16 @@ static int set_file_mtime(char *filename, C_word atime, C_word mtime)
(set! cmd (shell-command loc)) ) )
(when env (check-environment-list env loc))
(receive (in out pid err)
- (process-impl loc cmd args env #t #t err? exactf)
+ (process-impl loc cmd args env #t #t err? exactf enc)
(if err?
(values in out pid err)
(values in out pid) ) ) ) )) )
(set! chicken.process#process
- (lambda (cmd #!optional args env exactf)
- (%process 'process #f cmd args env exactf) ))
+ (lambda (cmd #!optional args env (enc 'utf-8) exactf)
+ (%process 'process #f cmd args env exactf enc) ))
(set! chicken.process#process*
- (lambda (cmd #!optional args env exactf)
- (%process 'process* #t cmd args env exactf) )) )
+ (lambda (cmd #!optional args env (enc 'utf-8) exactf)
+ (%process 'process* #t cmd args env exactf enc) )) )
(define-foreign-variable _exstatus int "C_exstatus")
diff --git a/r7lib.scm b/r7lib.scm
new file mode 100644
index 00000000..bf546a75
--- /dev/null
+++ b/r7lib.scm
@@ -0,0 +1,252 @@
+;;;; r7lib.scm - R7RS library code
+;
+; Copyright (c) 2022, 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 r7lib)
+ (disable-interrupts))
+
+(include "common-declarations.scm")
+
+(module scheme.write (display
+ write
+ write-shared
+ write-simple)
+ (import (rename scheme (display display-simple) (write write-simple))
+ (only chicken.base foldl when optional)
+ (only chicken.platform feature?)
+ (only chicken.fixnum fx+ fx= fx<= fx-))
+
+ (define (interesting? o)
+ (or (pair? o)
+ (and (vector? o)
+ (fx<= 1 (##sys#size o)))))
+
+ (define (uninteresting? o)
+ (not (interesting? o)))
+
+ (define (display-char c p)
+ ((##sys#slot (##sys#slot p 2) 2) p c))
+
+ (define (display-string s p)
+ (let ((bv (##sys#slot s 0)))
+ ((##sys#slot (##sys#slot p 2) 3) p bv 0 (fx- (##sys#size bv) 1))))
+
+ ;; Build an alist mapping `interesting?` objects to boolean values
+ ;; indicating whether those objects occur shared in `o`.
+ (define (find-shared o cycles-only?)
+
+ (define seen '())
+ (define (seen? x) (assq x seen))
+ (define (seen! x) (set! seen (cons (cons x 1) seen)))
+
+ ;; Walk the form, tallying the number of times each object is
+ ;; encountered. This has the effect of filling `seen` with
+ ;; occurence counts for all objects satisfying `interesting?`.
+ (let walk! ((o o))
+ (when (interesting? o)
+ (cond ((seen? o) =>
+ (lambda (p)
+ (##sys#setslot p 1 (fx+ (cdr p) 1))))
+ ((pair? o)
+ (seen! o)
+ (walk! (car o))
+ (walk! (cdr o)))
+ ((vector? o)
+ (seen! o)
+ (let ((len (##sys#size o)))
+ (do ((i 0 (fx+ i 1)))
+ ((fx= i len))
+ (walk! (##sys#slot o i))))))
+ ;; If we're only interested in cycles and this object isn't
+ ;; self-referential, discount it (resulting in `write` rather
+ ;; than `write-shared` behavior).
+ (when cycles-only?
+ (let ((p (seen? o)))
+ (when (fx<= (cdr p) 1)
+ (##sys#setslot p 1 0))))))
+
+ ;; Mark shared objects #t, unshared objects #f.
+ (foldl (lambda (a p)
+ (if (fx<= (cdr p) 1)
+ (cons (cons (car p) #f) a)
+ (cons (cons (car p) #t) a)))
+ '()
+ seen))
+
+ (define (write-with-shared-structure writer obj cycles-only? port)
+
+ (define label 0)
+ (define (assign-label! pair)
+ (##sys#setslot pair 1 label)
+ (set! label (fx+ label 1)))
+
+ (define shared
+ (find-shared obj cycles-only?))
+
+ (define (write-interesting/shared o)
+ (cond ((pair? o)
+ (display-char #\( port)
+ (write/shared (car o))
+ (let loop ((o (cdr o)))
+ (cond ((null? o)
+ (display-char #\) port))
+ ((and (pair? o)
+ (not (cdr (assq o shared))))
+ (display-char #\space port)
+ (write/shared (car o))
+ (loop (cdr o)))
+ (else
+ (display-string " . " port)
+ (write/shared o)
+ (display-char #\) port)))))
+ ((vector? o)
+ (display-string "#(" port)
+ (write/shared (##sys#slot o 0))
+ (let ((len (##sys#size o)))
+ (do ((i 1 (fx+ i 1)))
+ ((fx= i len)
+ (display-char #\) port))
+ (display-char #\space port)
+ (write/shared (##sys#slot o i)))))))
+
+ (define (write/shared o)
+ (if (uninteresting? o)
+ (writer o port)
+ (let* ((p (assq o shared))
+ (d (cdr p)))
+ (cond ((not d)
+ (write-interesting/shared o))
+ ((number? d)
+ (display-char #\# port)
+ (writer d port)
+ (display-char #\# port))
+ (else
+ (display-char #\# port)
+ (writer label port)
+ (display-char #\= port)
+ (assign-label! p)
+ (write-interesting/shared o))))))
+
+ (write/shared obj))
+
+ (define (display o #!optional (p ##sys#standard-output))
+ (write-with-shared-structure
+ display-simple
+ o
+ #t
+ p))
+
+ (define (write o #!optional (p ##sys#standard-output))
+ (write-with-shared-structure
+ write-simple
+ o
+ #t
+ p))
+
+ (define (write-shared o #!optional (p ##sys#standard-output))
+ (write-with-shared-structure
+ write-simple
+ o
+ #f
+ p))
+
+)
+
+(module scheme.time (current-second
+ current-jiffy
+ jiffies-per-second)
+ (import (only chicken.base define-constant)
+ (chicken foreign)
+ (only chicken.time current-seconds)
+ (only scheme + define inexact->exact))
+
+ ;; As of 2012-06-30.
+ (define-constant tai-offset 35.)
+
+ (define (current-second) (+ (current-seconds) tai-offset))
+
+ (define current-jiffy (foreign-lambda integer "clock"))
+
+ (define (jiffies-per-second) (foreign-value "CLOCKS_PER_SEC" integer))
+
+)
+
+(module scheme.file (file-exists? delete-file
+ open-input-file open-binary-input-file
+ open-output-file open-binary-output-file
+ call-with-input-file call-with-output-file
+ with-input-from-file with-output-to-file)
+ (import (only scheme and define quote let apply open-input-file open-output-file call-with-input-file
+ call-with-output-file with-input-from-file with-output-to-file)
+ (rename (only (chicken file) delete-file file-exists?) (file-exists? file-exists?/base)))
+
+ (define (open-binary-input-file fname . args)
+ (let ((p (apply open-input-file fname #:binary args)))
+ (##sys#setslot p 14 'binary)
+ p))
+
+ (define (open-binary-output-file fname . args)
+ (let ((p (apply open-output-file fname #:binary args)))
+ (##sys#setslot p 14 'binary)
+ p))
+
+ (define (file-exists? fname)
+ (and (file-exists?/base fname) #t))
+
+)
+
+(module scheme.process-context (command-line
+ emergency-exit
+ exit
+ get-environment-variable
+ get-environment-variables)
+ (import scheme
+ chicken.process-context
+ chicken.type
+ (rename chicken.base (exit chicken-exit)))
+
+(define (command-line)
+ ;; Don't cache these; they may be parameterized at any time!
+ (cons (program-name) (command-line-arguments)))
+
+(define (->exit-status obj)
+ (cond ((integer? obj) obj)
+ ((eq? obj #f) 1)
+ (else 0)))
+
+(define (exit #!optional (obj 0))
+ ;; ##sys#dynamic-unwind is hidden, have to unwind manually.
+ ; (##sys#dynamic-unwind '() (length ##sys#dynamic-winds))
+ (let unwind ()
+ (unless (null? ##sys#dynamic-winds)
+ (let ((after (cdar ##sys#dynamic-winds)))
+ (set! ##sys#dynamic-winds (cdr ##sys#dynamic-winds))
+ (after)
+ (unwind))))
+ ;; The built-in exit runs cleanup handlers for us.
+ (chicken-exit (->exit-status obj)))
+
+)
+
diff --git a/repl.scm b/repl.scm
index d1106930..fc84c5fe 100644
--- a/repl.scm
+++ b/repl.scm
@@ -38,6 +38,7 @@
chicken.foreign
chicken.load
chicken.syntax)
+(import (only (scheme base) make-parameter))
(include "common-declarations.scm")
diff --git a/rules.make b/rules.make
index f7393527..659560c1 100644
--- a/rules.make
+++ b/rules.make
@@ -8,11 +8,11 @@
# conditions are met:
#
# Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-# disclaimer.
+# 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.
+# 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.
+# 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
@@ -37,8 +37,8 @@ LIBCHICKEN_SCHEME_OBJECTS_1 = \
library eval read-syntax repl data-structures pathname port file \
extras lolevel tcp srfi-4 continuation $(POSIXFILE) internal \
irregex scheduler debugger-client profiler stub expand modules \
- chicken-syntax chicken-ffi-syntax build-version
-LIBCHICKEN_OBJECTS_1 = $(LIBCHICKEN_SCHEME_OBJECTS_1) runtime
+ chicken-syntax chicken-ffi-syntax build-version r7lib
+LIBCHICKEN_OBJECTS_1 = $(LIBCHICKEN_SCHEME_OBJECTS_1) runtime utf
LIBCHICKEN_SHARED_OBJECTS = $(LIBCHICKEN_OBJECTS_1:=$(O))
LIBCHICKEN_STATIC_OBJECTS = $(LIBCHICKEN_OBJECTS_1:=-static$(O)) \
eval-modules-static$(O)
@@ -65,7 +65,7 @@ INSTALLED_PROGRAMS = \
# These generated files make up a bootstrapped distribution build.
# They are not cleaned by the 'clean' target, but only by 'spotless'.
-DISTFILES = $(filter-out runtime.c,$(LIBCHICKEN_OBJECTS_1:=.c)) \
+DISTFILES = $(filter-out runtime.c utf.c,$(LIBCHICKEN_OBJECTS_1:=.c)) \
$(UTILITY_PROGRAM_OBJECTS_1:=.c) \
$(COMPILER_OBJECTS_1:=.c) \
$(IMPORT_LIBRARIES:=.import.c) \
@@ -85,12 +85,6 @@ DISTFILES := $(sort $(DISTFILES))
## ruleset evaluated by Make. This allows us to automatically generate
## similar rules for long lists of targets.
-## Note: in some of the rules that follow it is important to add
-## $(INCLUDES) last, because on raw mingw (using the DOS shell) the
-## backslash in "-I.\" seems to be interpreted as a line-terminator.
-## This may be caused by cmd.exe-stupidness or a bug in mingw32-make
-## or some other obscure reason.
-
define declare-shared-library-object
$(1)$(O): $(1).c chicken.h $$(CHICKEN_CONFIG_H)
$$(C_COMPILER) $$(C_COMPILER_OPTIONS) \
@@ -168,7 +162,7 @@ define declare-utility-program-object
$(1)$(O): $(1).c chicken.h $$(CHICKEN_CONFIG_H)
$$(C_COMPILER) $$(C_COMPILER_OPTIONS) $$(C_COMPILER_SHARED_OPTIONS) \
$$(C_COMPILER_COMPILE_OPTION) $$(C_COMPILER_OPTIMIZATION_OPTIONS) $$< $$(C_COMPILER_OUTPUT) \
- $$(INCLUDES)
+ $$(INCLUDES)
endef
$(foreach obj, $(UTILITY_PROGRAM_OBJECTS_1),\
@@ -203,7 +197,7 @@ cyg$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)-0.dll: $(LIBCHICKEN_SHARED_OBJECTS)
-Wl,--whole-archive $(LIBCHICKEN_SHARED_OBJECTS) \
-Wl,--no-whole-archive $(LIBCHICKEN_SO_LIBRARIES)
-lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)$(A): $(LIBCHICKEN_STATIC_OBJECTS)
+lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)-static$(A): $(LIBCHICKEN_STATIC_OBJECTS)
$(LIBRARIAN) $(LIBRARIAN_OPTIONS) $(LIBRARIAN_OUTPUT) $^
# import libraries and extensions
@@ -241,12 +235,12 @@ $(eval $(call declare-program-from-object,$(CSC_PROGRAM)$(EXE),csc))
# static executables
-$(CHICKEN_STATIC_EXECUTABLE): $(COMPILER_STATIC_OBJECTS) lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)$(A)
- $(LINKER) $(LINKER_OPTIONS) $(LINKER_STATIC_OPTIONS) $(COMPILER_STATIC_OBJECTS) $(LINKER_OUTPUT) lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)$(A) $(LIBRARIES)
+$(CHICKEN_STATIC_EXECUTABLE): $(COMPILER_STATIC_OBJECTS) lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)-static$(A)
+ $(LINKER) $(LINKER_OPTIONS) $(LINKER_STATIC_OPTIONS) $(COMPILER_STATIC_OBJECTS) $(LINKER_OUTPUT) lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)-static$(A) $(LIBRARIES)
define declare-static-program-from-object
-$(1): $(2)$(O) lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)$(A)
- $$(LINKER) $$(LINKER_OPTIONS) $$(LINKER_STATIC_OPTIONS) $$< $$(LINKER_OUTPUT) lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)$(A) $$(LIBRARIES)
+$(1): $(2)$(O) lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)-static$(A)
+ $$(LINKER) $$(LINKER_OPTIONS) $$(LINKER_STATIC_OPTIONS) $$< $$(LINKER_OUTPUT) lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)-static$(A) $$(LIBRARIES)
endef
$(eval $(call declare-program-from-object,$(CSI_STATIC_EXECUTABLE),csi))
@@ -256,11 +250,6 @@ $(eval $(call declare-program-from-object,$(CSI_STATIC_EXECUTABLE),csi))
$(CHICKEN_DO_PROGRAM)$(EXE): $(SRCDIR)chicken-do.c chicken.h $(CHICKEN_CONFIG_H)
$(C_COMPILER) $(C_COMPILER_OPTIONS) $(C_COMPILER_OPTIMIZATION_OPTIONS) $< -o $@
-# scripts
-
-$(CHICKEN_DEBUGGER_PROGRAM): $(SRCDIR)feathers$(SCRIPT_EXT).in
- $(GENERATE_DEBUGGER)
-
# installation
@@ -273,7 +262,7 @@ install-target: install-libs
install-libs: libs $(LIBCHICKEN_IMPORT_LIBRARY)
$(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) "$(DESTDIR)$(ILIBDIR)"
-ifneq ($(LIBCHICKEN_IMPORT_LIBRARY),)
+ifneq ($(LIBCHICKEN_IMPORT_LIBRARY),)
$(INSTALL_PROGRAM) $(INSTALL_PROGRAM_STATIC_LIBRARY_OPTIONS) $(LIBCHICKEN_IMPORT_LIBRARY) "$(DESTDIR)$(ILIBDIR)"
endif
ifndef STATICBUILD
@@ -301,9 +290,9 @@ install-dev: install-libs
$(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) "$(DESTDIR)$(IEGGDIR)"
$(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) "$(DESTDIR)$(ICHICKENINCDIR)"
$(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) "$(DESTDIR)$(IDATADIR)"
- $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_STATIC_LIBRARY_OPTIONS) lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)$(A) "$(DESTDIR)$(ILIBDIR)"
+ $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_STATIC_LIBRARY_OPTIONS) lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)-static$(A) "$(DESTDIR)$(ILIBDIR)"
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)lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)-static$(A)"
endif
$(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)chicken.h "$(DESTDIR)$(ICHICKENINCDIR)"
$(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(CHICKEN_CONFIG_H) "$(DESTDIR)$(ICHICKENINCDIR)"
@@ -336,8 +325,6 @@ install-bin: $(TARGETS) install-libs install-dev
$(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) \
$(prog)$(EXE) "$(DESTDIR)$(IBINDIR)" $(NL))
- $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) $(CHICKEN_DEBUGGER_PROGRAM) "$(DESTDIR)$(IBINDIR)"
-
ifdef STATICBUILD
$(foreach lib,$(IMPORT_LIBRARIES),\
$(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) \
@@ -367,9 +354,6 @@ else
@echo
endif
endif
-ifdef WINDOWS_SHELL
- $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_EXECUTABLE_OPTIONS) $(SRCDIR)csibatch.bat "$(DESTDIR)$(IBINDIR)"
-endif
install-other-files:
$(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) "$(DESTDIR)$(IMAN1DIR)"
@@ -384,7 +368,6 @@ install-other-files:
$(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)chicken-uninstall$(MAN) "$(DESTDIR)$(IMAN1DIR)$(SEP)$(CHICKEN_UNINSTALL_PROGRAM).1"
$(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)chicken-status$(MAN) "$(DESTDIR)$(IMAN1DIR)$(SEP)$(CHICKEN_STATUS_PROGRAM).1"
$(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)chicken-profile$(MAN) "$(DESTDIR)$(IMAN1DIR)$(SEP)$(CHICKEN_PROFILE_PROGRAM).1"
- $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)feathers$(MAN) "$(DESTDIR)$(IMAN1DIR)$(SEP)$(CHICKEN_DEBUGGER_PROGRAM).1"
$(MAKEDIR_COMMAND) $(MAKEDIR_COMMAND_OPTIONS) "$(DESTDIR)$(IDOCDIR)$(SEP)manual"
-$(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)manual-html$(SEP)* "$(DESTDIR)$(IDOCDIR)$(SEP)manual"
@@ -392,11 +375,10 @@ install-other-files:
$(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)DEPRECATED "$(DESTDIR)$(IDOCDIR)"
$(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)LICENSE "$(DESTDIR)$(IDOCDIR)"
$(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)setup.defaults "$(DESTDIR)$(IDATADIR)"
- $(INSTALL_PROGRAM) $(INSTALL_PROGRAM_FILE_OPTIONS) $(SRCDIR)feathers.tcl "$(DESTDIR)$(IDATADIR)"
install-wrappers:
ifeq ($(WRAPPERDIR),)
- @echo
+ @echo
@echo Error: WRAPPERDIR is not set
@echo
@exit 1
@@ -408,8 +390,7 @@ uninstall:
$(foreach prog,$(INSTALLED_PROGRAMS),\
$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS)\
"$(DESTDIR)$(IBINDIR)$(SEP)$(prog)$(EXE)" $(NL))
- $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) "$(DESTDIR)$(IBINDIR)$(SEP)$(CHICKEN_DEBUGGER_PROGRAM)"
- $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) "$(DESTDIR)$(ILIBDIR)$(SEP)lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)$(A)"
+ $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) "$(DESTDIR)$(ILIBDIR)$(SEP)lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)-static$(A)"
$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) "$(DESTDIR)$(ILIBDIR)$(SEP)lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)$(SO)"
ifdef USES_SONAME
-$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) "$(DESTDIR)$(ILIBDIR)$(SEP)lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)$(SO).$(BINARYVERSION)"
@@ -430,15 +411,11 @@ endif
$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) "$(DESTDIR)$(IMAN1DIR)$(SEP)$(CHICKEN_UNINSTALL_PROGRAM).1"
$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) "$(DESTDIR)$(IMAN1DIR)$(SEP)$(CHICKEN_STATUS_PROGRAM).1"
$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) "$(DESTDIR)$(IMAN1DIR)$(SEP)$(CHICKEN_PROFILE_PROGRAM).1"
- $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) "$(DESTDIR)$(IMAN1DIR)$(SEP)$(CHICKEN_DEBUGGER_PROGRAM).1"
$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) "$(DESTDIR)$(ICHICKENINCDIR)$(SEP)chicken.h"
$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) "$(DESTDIR)$(ICHICKENINCDIR)$(SEP)$(CHICKEN_CONFIG_H)"
$(REMOVE_COMMAND) $(REMOVE_COMMAND_RECURSIVE_OPTIONS) "$(DESTDIR)$(IDATADIR)"
$(REMOVE_COMMAND) $(REMOVE_COMMAND_RECURSIVE_OPTIONS) "$(DESTDIR)$(IEGGDIR)"
-ifdef WINDOWS_SHELL
- $(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) "$(DESTDIR)$(IBINDIR)$(SEP)csibatch.bat"
-endif
# build versioning
@@ -489,7 +466,7 @@ $(eval $(call declare-emitted-import-lib-dependency,chicken.process,$(POSIXFILE)
$(eval $(call declare-emitted-import-lib-dependency,chicken.process.signal,$(POSIXFILE)))
$(eval $(call declare-emitted-import-lib-dependency,chicken.process-context.posix,$(POSIXFILE)))
$(eval $(call declare-emitted-import-lib-dependency,chicken.bitwise,library))
-$(eval $(call declare-emitted-import-lib-dependency,chicken.blob,library))
+$(eval $(call declare-emitted-import-lib-dependency,chicken.bytevector,library))
$(eval $(call declare-emitted-import-lib-dependency,chicken.fixnum,library))
$(eval $(call declare-emitted-import-lib-dependency,chicken.flonum,library))
$(eval $(call declare-emitted-import-lib-dependency,chicken.gc,library))
@@ -500,14 +477,19 @@ $(eval $(call declare-emitted-import-lib-dependency,chicken.process-context,libr
$(eval $(call declare-emitted-import-lib-dependency,chicken.time,library))
$(eval $(call declare-emitted-import-lib-dependency,chicken.load,eval))
$(eval $(call declare-emitted-import-lib-dependency,chicken.format,extras))
-$(eval $(call declare-emitted-import-lib-dependency,chicken.io,extras))
+$(eval $(call declare-emitted-import-lib-dependency,chicken.io,library))
$(eval $(call declare-emitted-import-lib-dependency,chicken.pretty-print,extras))
$(eval $(call declare-emitted-import-lib-dependency,chicken.random,extras))
$(eval $(call declare-emitted-import-lib-dependency,chicken.locative,lolevel))
$(eval $(call declare-emitted-import-lib-dependency,chicken.memory,lolevel))
$(eval $(call declare-emitted-import-lib-dependency,chicken.memory.representation,lolevel))
+$(eval $(call declare-emitted-import-lib-dependency,chicken.number-vector,srfi-4))
$(eval $(call declare-emitted-import-lib-dependency,chicken.sort,data-structures))
$(eval $(call declare-emitted-import-lib-dependency,chicken.string,data-structures))
+$(eval $(call declare-emitted-import-lib-dependency,scheme.write,r7lib))
+$(eval $(call declare-emitted-import-lib-dependency,scheme.time,r7lib))
+$(eval $(call declare-emitted-import-lib-dependency,scheme.file,r7lib))
+$(eval $(call declare-emitted-import-lib-dependency,scheme.process-context,r7lib))
chicken.c: chicken.scm mini-srfi-1.scm \
chicken.compiler.batch-driver.import.scm \
@@ -607,7 +589,7 @@ chicken-ffi-syntax.c: chicken-ffi-syntax.scm \
chicken.string.import.scm
support.c: support.scm mini-srfi-1.scm \
chicken.bitwise.import.scm \
- chicken.blob.import.scm \
+ chicken.bytevector.import.scm \
chicken.condition.import.scm \
chicken.file.import.scm \
chicken.fixnum.import.scm \
@@ -627,6 +609,7 @@ support.c: support.scm mini-srfi-1.scm \
chicken.time.import.scm
modules.c: modules.scm \
chicken.internal.import.scm \
+ chicken.format.import.scm \
chicken.keyword.import.scm \
chicken.base.import.scm \
chicken.syntax.import.scm \
@@ -658,7 +641,8 @@ csi.c: csi.scm \
chicken.process-context.import.scm \
chicken.repl.import.scm \
chicken.sort.import.scm \
- chicken.string.import.scm
+ chicken.string.import.scm \
+ scheme.write.import.scm
chicken-profile.c: chicken-profile.scm \
chicken.internal.import.scm \
chicken.file.import.scm \
@@ -715,6 +699,7 @@ chicken-syntax.c: chicken-syntax.scm \
chicken.internal.import.scm
srfi-4.c: srfi-4.scm \
chicken.bitwise.import.scm \
+ chicken.bytevector.import.scm \
chicken.fixnum.import.scm \
chicken.foreign.import.scm \
chicken.gc.import.scm \
@@ -745,7 +730,7 @@ data-structures.c: data-structures.scm \
chicken.fixnum.import.scm \
chicken.foreign.import.scm
expand.c: expand.scm \
- chicken.blob.import.scm \
+ chicken.bytevector.import.scm \
chicken.condition.import.scm \
chicken.fixnum.import.scm \
chicken.keyword.import.scm \
@@ -757,7 +742,7 @@ extras.c: extras.scm \
chicken.string.import.scm \
chicken.time.import.scm
eval.c: eval.scm \
- chicken.blob.import.scm \
+ chicken.bytevector.import.scm \
chicken.condition.import.scm \
chicken.fixnum.import.scm \
chicken.foreign.import.scm \
@@ -808,7 +793,12 @@ profiler.c: profiler.scm \
chicken.fixnum.import.scm
stub.c: stub.scm \
chicken.platform.import.scm
-
+r7lib.c: r7lib.scm \
+ chicken.platform.import.scm \
+ chicken.process-context.import.scm \
+ chicken.time.import.scm \
+ chicken.io.import.scm \
+ chicken.file.import.scm
define profile-flags
$(if $(filter $(basename $(1)),$(PROFILE_OBJECTS)),-profile)
@@ -820,13 +810,14 @@ library.c: $(SRCDIR)library.scm
$(bootstrap-lib) \
-no-module-registration \
-emit-import-library chicken.bitwise \
- -emit-import-library chicken.blob \
+ -emit-import-library chicken.bytevector \
-emit-import-library chicken.fixnum \
-emit-import-library chicken.flonum \
-emit-import-library chicken.gc \
-emit-import-library chicken.keyword \
-emit-import-library chicken.platform \
-emit-import-library chicken.plist \
+ -emit-import-library chicken.io \
-emit-import-library chicken.process-context
internal.c: $(SRCDIR)internal.scm $(SRCDIR)mini-srfi-1.scm
$(bootstrap-lib) -emit-import-library chicken.internal
@@ -834,6 +825,11 @@ eval.c: $(SRCDIR)eval.scm $(SRCDIR)common-declarations.scm $(SRCDIR)mini-srfi-1.
$(bootstrap-lib) \
-emit-import-library chicken.eval \
-emit-import-library chicken.load
+r7lib.c: $(SRCDIR)r7lib.scm $(SRCDIR)common-declarations.scm
+ $(bootstrap-lib) -emit-import-library scheme.write \
+ -emit-import-library scheme.time \
+ -emit-import-library scheme.file \
+ -emit-import-library scheme.process-context
read-syntax.c: $(SRCDIR)read-syntax.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib) -emit-import-library chicken.read-syntax
repl.c: $(SRCDIR)repl.scm $(SRCDIR)common-declarations.scm
@@ -846,7 +842,6 @@ modules.c: $(SRCDIR)modules.scm $(SRCDIR)common-declarations.scm $(SRCDIR)mini-s
extras.c: $(SRCDIR)extras.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib) \
-emit-import-library chicken.format \
- -emit-import-library chicken.io \
-emit-import-library chicken.pretty-print \
-emit-import-library chicken.random
posixunix.c: $(SRCDIR)posix.scm $(SRCDIR)posixunix.scm $(SRCDIR)posix-common.scm $(SRCDIR)common-declarations.scm
@@ -893,13 +888,14 @@ lolevel.c: $(SRCDIR)lolevel.scm $(SRCDIR)common-declarations.scm
tcp.c: $(SRCDIR)tcp.scm $(SRCDIR)common-declarations.scm
$(bootstrap-lib) -emit-import-library chicken.tcp
srfi-4.c: $(SRCDIR)srfi-4.scm $(SRCDIR)common-declarations.scm
- $(bootstrap-lib) -emit-import-library srfi-4
+ $(bootstrap-lib) -emit-import-library srfi-4 \
+ -emit-import-library chicken.number-vector
scheduler.c: $(SRCDIR)scheduler.scm $(SRCDIR)common-declarations.scm
- $(bootstrap-lib)
+ $(bootstrap-lib)
profiler.c: $(SRCDIR)profiler.scm $(SRCDIR)common-declarations.scm
- $(bootstrap-lib)
+ $(bootstrap-lib)
stub.c: $(SRCDIR)stub.scm $(SRCDIR)common-declarations.scm
- $(bootstrap-lib)
+ $(bootstrap-lib)
debugger-client.c: $(SRCDIR)debugger-client.scm $(SRCDIR)common-declarations.scm dbg-stub.c
$(bootstrap-lib)
build-version.c: $(SRCDIR)build-version.scm $(SRCDIR)buildversion buildbranch buildid
@@ -920,7 +916,7 @@ $(foreach obj, $(IMPORT_LIBRARIES),\
define declare-bootstrap-compiler-object
$(1).c: $$(SRCDIR)$(1).scm $$(SRCDIR)tweaks.scm
$$(CHICKEN) $$< $$(CHICKEN_PROGRAM_OPTIONS) -emit-import-library chicken.compiler.$(1) \
- -output-file $$@
+ -output-file $$@
endef
$(foreach obj, $(COMPILER_OBJECTS_1),\
@@ -929,15 +925,15 @@ $(foreach obj, $(COMPILER_OBJECTS_1),\
csi.c: $(SRCDIR)csi.scm $(SRCDIR)banner.scm $(SRCDIR)mini-srfi-1.scm
$(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
chicken-profile.c: $(SRCDIR)chicken-profile.scm $(SRCDIR)mini-srfi-1.scm
- $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
+ $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
chicken-install.c: $(SRCDIR)chicken-install.scm $(SRCDIR)mini-srfi-1.scm $(SRCDIR)egg-compile.scm $(SRCDIR)egg-download.scm $(SRCDIR)egg-environment.scm $(SRCDIR)egg-information.scm
- $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
+ $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
chicken-uninstall.c: $(SRCDIR)chicken-uninstall.scm $(SRCDIR)mini-srfi-1.scm $(SRCDIR)egg-environment.scm $(SRCDIR)egg-information.scm
- $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
+ $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
chicken-status.c: $(SRCDIR)chicken-status.scm $(SRCDIR)mini-srfi-1.scm $(SRCDIR)egg-environment.scm $(SRCDIR)egg-information.scm
- $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
+ $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
csc.c: $(SRCDIR)csc.scm $(SRCDIR)mini-srfi-1.scm $(SRCDIR)egg-environment.scm
- $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
+ $(CHICKEN) $< $(CHICKEN_PROGRAM_OPTIONS) -output-file $@
# distribution files
@@ -946,6 +942,7 @@ csc.c: $(SRCDIR)csc.scm $(SRCDIR)mini-srfi-1.scm $(SRCDIR)egg-environment.scm
distfiles: $(DISTFILES)
dist: distfiles html
+ echo '# this file is intentionally empty' > config.make
CSI=$(CSI) $(CSI) -s $(SRCDIR)scripts$(SEP)makedist.scm -platform $(PLATFORM) CHICKEN=$(CHICKEN)
# Jim's `manual-labor' must be installed (just run "chicken-install manual-labor")
@@ -970,10 +967,9 @@ clean:
$(CHICKEN_STATUS_PROGRAM)$(EXE) \
*$(O) \
$(CHICKEN_DO_PROGRAM)$(EXE) \
- $(CHICKEN_DEBUGGER_PROGRAM) \
$(LIBCHICKEN_SO_FILE) \
$(PRIMARY_LIBCHICKEN) \
- lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)$(A) \
+ lib$(PROGRAM_PREFIX)chicken$(PROGRAM_SUFFIX)-static$(A) \
$(IMPORT_LIBRARIES:=.import.so) $(LIBCHICKEN_IMPORT_LIBRARY) \
$(foreach lib,$(DYNAMIC_IMPORT_LIBRARIES),chicken.$(lib).import.scm) \
$(BUILD_CONFIG_FILES)
@@ -983,6 +979,7 @@ endif
confclean:
-$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(BUILD_CONFIG_FILES)
+ touch config.make
spotless: clean testclean
-$(REMOVE_COMMAND) $(REMOVE_COMMAND_OPTIONS) $(DISTFILES) \
@@ -1017,11 +1014,7 @@ export PROGRAM_PREFIX
export PROGRAM_SUFFIX
check: $(TARGETS)
-ifndef WINDOWS_SHELL
cd tests; sh runtests.sh
-else
- cd tests & runtests.bat
-endif
# benchmark
diff --git a/runtime.c b/runtime.c
index 29dbcb00..ec40f219 100644
--- a/runtime.c
+++ b/runtime.c
@@ -8,11 +8,11 @@
; conditions are met:
;
; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-; disclaimer.
+; 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.
+; 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.
+; 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
@@ -90,7 +90,7 @@
#ifdef ECOS
#include <cyg/kernel/kapi.h>
-static C_TLS int timezone;
+static int timezone;
#define NSIG 32
#endif
@@ -256,7 +256,7 @@ static C_TLS int timezone;
/* Type definitions: */
-typedef C_regparm C_word C_fcall (*integer_plusmin_op) (C_word **ptr, C_word n, C_word x, C_word y);
+typedef C_regparm C_word (*integer_plusmin_op) (C_word **ptr, C_word n, C_word x, C_word y);
typedef struct lf_list_struct
{
@@ -304,7 +304,7 @@ typedef struct profile_bucket_struct
/* Variables: */
-C_TLS C_word
+C_word
*C_temporary_stack,
*C_temporary_stack_bottom,
*C_temporary_stack_limit,
@@ -314,28 +314,28 @@ C_TLS C_word
*C_scratchspace_top,
*C_scratchspace_limit,
C_scratch_usage;
-C_TLS C_long
+C_long
C_timer_interrupt_counter,
C_initial_timer_interrupt_period;
-C_TLS C_byte
+C_byte
*C_fromspace_top,
*C_fromspace_limit;
#ifdef HAVE_SIGSETJMP
-C_TLS sigjmp_buf C_restart;
+sigjmp_buf C_restart;
#else
-C_TLS jmp_buf C_restart;
+jmp_buf C_restart;
#endif
-C_TLS void *C_restart_trampoline;
-C_TLS C_word C_restart_c;
-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 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, C_long ms) = NULL;
-C_TLS C_word (*C_debugger_hook)(C_DEBUG_INFO *cell, C_word c, C_word *av, C_char *cloc) = NULL;
-
-C_TLS int
+void *C_restart_trampoline;
+C_word C_restart_c;
+int C_entry_point_status;
+int (*C_gc_mutation_hook)(C_word *slot, C_word val);
+void (*C_gc_trace_hook)(C_word *var, int mode);
+void (*C_panic_hook)(C_char *msg) = NULL;
+void (*C_pre_gc_hook)(int mode) = NULL;
+void (*C_post_gc_hook)(int mode, C_long ms) = NULL;
+C_word (*C_debugger_hook)(C_DEBUG_INFO *cell, C_word c, C_word *av, C_char *cloc) = NULL;
+
+int
C_gui_mode = 0,
C_abort_on_thread_exceptions,
C_interrupts_enabled,
@@ -345,31 +345,31 @@ C_TLS int
C_max_pending_finalizers = C_DEFAULT_MAX_PENDING_FINALIZERS,
C_debugging = 0,
C_main_argc;
-C_TLS C_uword
+C_uword
C_heap_growth = DEFAULT_HEAP_GROWTH,
C_heap_shrinkage = DEFAULT_HEAP_SHRINKAGE,
C_heap_shrinkage_used = DEFAULT_HEAP_SHRINKAGE_USED,
C_heap_half_min_free = DEFAULT_HEAP_MIN_FREE,
C_maximal_heap_size = DEFAULT_MAXIMAL_HEAP_SIZE,
heap_shrink_counter = 0;
-C_TLS time_t
+time_t
C_startup_time_sec,
C_startup_time_msec,
profile_frequency = 10000;
-C_TLS char
+char
**C_main_argv,
#ifdef SEARCH_EXE_PATH
*C_main_exe = NULL,
#endif
*C_dlerror;
-static C_TLS TRACE_INFO
+static TRACE_INFO
*trace_buffer,
*trace_buffer_limit,
*trace_buffer_top;
-static C_TLS C_byte
- *heapspace1,
+static C_byte
+ *heapspace1,
*heapspace2,
*fromspace_start,
*tospace_start,
@@ -378,7 +378,7 @@ static C_TLS C_byte
*new_tospace_start,
*new_tospace_top,
*new_tospace_limit;
-static C_TLS C_uword
+static C_uword
heapspace1_size,
heapspace2_size,
heap_size,
@@ -386,16 +386,16 @@ static C_TLS C_uword
temporary_stack_size,
fixed_temporary_stack_size = 0,
maximum_heap_usage;
-static C_TLS C_char
+static C_char
buffer[ STRING_BUFFER_SIZE ],
*private_repository = NULL,
*current_module_name,
*save_string;
-static C_TLS C_SYMBOL_TABLE
+static C_SYMBOL_TABLE
*symbol_table,
*symbol_table_list,
*keyword_table;
-static C_TLS C_word
+static C_word
**collectibles,
**collectibles_top,
**collectibles_limit,
@@ -412,7 +412,6 @@ static C_TLS C_word
pending_finalizers_symbol,
callback_continuation_stack_symbol,
core_provided_symbol,
- u8vector_symbol,
s8vector_symbol,
u16vector_symbol,
s16vector_symbol,
@@ -423,7 +422,7 @@ static C_TLS C_word
f32vector_symbol,
f64vector_symbol,
*forwarding_table;
-static C_TLS int
+static int
trace_buffer_full,
forwarding_table_size,
return_to_host,
@@ -446,50 +445,50 @@ static C_TLS int
chicken_ran_once,
pass_serious_signals = 1,
callback_continuation_level;
-static volatile C_TLS int
+static volatile int
serious_signal_occurred = 0,
profiling = 0;
-static C_TLS unsigned int
+static unsigned int
mutation_count,
tracked_mutation_count,
stack_check_demand,
stack_size;
-static C_TLS int chicken_is_initialized;
+static int chicken_is_initialized;
#ifdef HAVE_SIGSETJMP
-static C_TLS sigjmp_buf gc_restart;
+static sigjmp_buf gc_restart;
#else
-static C_TLS jmp_buf gc_restart;
+static jmp_buf gc_restart;
#endif
-static C_TLS double
+static double
timer_start_ms,
gc_ms,
timer_accumulated_gc_ms,
interrupt_time,
last_interrupt_latency;
-static C_TLS LF_LIST *lf_list;
-static C_TLS int signal_mapping_table[ NSIG ];
-static C_TLS int
+static LF_LIST *lf_list;
+static int signal_mapping_table[ NSIG ];
+static int
live_finalizer_count,
allocated_finalizer_count,
pending_finalizer_count,
callback_returned_flag;
-static C_TLS C_GC_ROOT *gc_root_list = NULL;
-static C_TLS FINALIZER_NODE
+static C_GC_ROOT *gc_root_list = NULL;
+static 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;
-static C_TLS HDUMP_BUCKET **hdump_table;
-static C_TLS PROFILE_BUCKET
+static void *current_module_handle;
+static int flonum_print_precision = FLONUM_PRINT_PRECISION;
+static HDUMP_BUCKET **hdump_table;
+static PROFILE_BUCKET
*next_profile_bucket = NULL,
**profile_table = NULL;
-static C_TLS int
+static int
pending_interrupts[ MAX_PENDING_INTERRUPTS ],
pending_interrupts_count,
handling_interrupts;
-static C_TLS C_uword random_state[ C_RANDOM_STATE_SIZE / sizeof(C_uword) ];
-static C_TLS int random_state_index = 0;
+static C_uword random_state[ C_RANDOM_STATE_SIZE / sizeof(C_uword) ];
+static int random_state_index = 0;
/* Prototypes: */
@@ -503,10 +502,10 @@ static void try_extended_number(char *ext_proc_name, C_word c, C_word k, ...) C_
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 really_mark(C_word *x, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;
+static void really_mark(C_word *x, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;
static C_cpsproc(values_continuation) C_noret;
static C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stable);
-static C_regparm int C_fcall C_in_new_heapp(C_word x);
+static C_regparm int C_in_new_heapp(C_word x);
static C_regparm C_word bignum_times_bignum_unsigned(C_word **ptr, C_word x, C_word y, C_word negp);
static C_regparm C_word bignum_extract_digits(C_word **ptr, C_word n, C_word x, C_word start, C_word end);
@@ -533,18 +532,18 @@ static C_word rat_flo_cmp(C_word ratnum, C_word flonum);
static C_word flo_rat_cmp(C_word flonum, C_word ratnum);
static C_word basic_cmp(C_word x, C_word y, char *loc, int eqp);
static int bignum_cmp_unsigned(C_word x, C_word y);
-static C_word C_fcall hash_string(int len, C_char *str, C_word m, C_word r, int ci) C_regparm;
-static C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
-static C_word C_fcall lookup_bucket(C_word sym, C_SYMBOL_TABLE *stable) C_regparm;
+static C_word hash_string(int len, C_char *str, C_word m, C_word r) C_regparm;
+static C_word lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable) C_regparm;
+static C_word lookup_bucket(C_word sym, C_SYMBOL_TABLE *stable) C_regparm;
static double compute_symbol_table_load(double *avg_bucket_len, int *total);
-static double C_fcall decode_flonum_literal(C_char *str) C_regparm;
+static double decode_flonum_literal(C_char *str) C_regparm;
static C_regparm C_word str_to_bignum(C_word bignum, char *str, char *str_end, int radix);
-static void C_fcall mark_nested_objects(C_byte *heap_scan_top, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;
-static void C_fcall mark_live_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;
-static void C_fcall mark_live_heap_only_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;
-static C_word C_fcall intern0(C_char *name) C_regparm;
-static void C_fcall update_weak_pairs(int mode, C_byte *undead_start, C_byte *undead_end) C_regparm;
-static void C_fcall update_locatives(int mode, C_byte *undead_start, C_byte *undead_end) C_regparm;
+static void mark_nested_objects(C_byte *heap_scan_top, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;
+static void mark_live_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;
+static void mark_live_heap_only_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit) C_regparm;
+static C_word intern0(C_char *name) C_regparm;
+static void update_weak_pairs(int mode, C_byte *undead_start, C_byte *undead_end) C_regparm;
+static void update_locatives(int mode, C_byte *undead_start, C_byte *undead_end) C_regparm;
static LF_LIST *find_module_handle(C_char *name);
static void set_profile_timer(C_uword freq);
static void take_profile_sample();
@@ -553,6 +552,7 @@ static C_cpsproc(call_cc_wrapper) C_noret;
static C_cpsproc(call_cc_values_wrapper) C_noret;
static C_cpsproc(gc_2) C_noret;
static C_cpsproc(allocate_vector_2) C_noret;
+static C_cpsproc(allocate_bytevector_2) C_noret;
static C_cpsproc(generic_trampoline) C_noret;
static void handle_interrupt(void *trampoline) C_noret;
static C_cpsproc(callback_return_continuation) C_noret;
@@ -604,7 +604,7 @@ C_dbg(C_char *prefix, C_char *fstr, ...)
/* Startup code: */
-int CHICKEN_main(int argc, char *argv[], void *toplevel)
+int CHICKEN_main(int argc, char *argv[], void *toplevel)
{
C_word h, s, n;
@@ -620,7 +620,7 @@ int CHICKEN_main(int argc, char *argv[], void *toplevel)
pass_serious_signals = 0;
CHICKEN_parse_command_line(argc, argv, &h, &s, &n);
-
+
if(!CHICKEN_initialize(h, s, n, toplevel))
panic(C_text("cannot initialize - out of memory"));
@@ -645,11 +645,11 @@ void parse_argv(C_char *cmds)
C_main_argc = 0;
for(;;) {
- while(isspace((int)(*ptr))) ++ptr;
+ while(C_utf_isspace((int)(*ptr))) ++ptr;
if(*ptr == '\0') break;
- for(bptr0 = bptr = buffer; !isspace((int)(*ptr)) && *ptr != '\0'; *(bptr++) = *(ptr++))
+ for(bptr0 = bptr = buffer; !C_utf_isspace((int)(*ptr)) && *ptr != '\0'; *(bptr++) = *(ptr++))
++n;
*bptr = '\0';
@@ -664,6 +664,21 @@ void parse_argv(C_char *cmds)
}
}
+/* simple linear congruential PRNG, to avoid OpenBSD warnings.
+ https://stackoverflow.com/questions/26237419/faster-than-rand
+*/
+
+static int g_seed;
+
+void C_fast_srand(int seed) { g_seed = seed; }
+
+/* Output value in range [0, 32767] */
+int C_fast_rand(void)
+{
+ g_seed = (214013*g_seed+2531011);
+ return (g_seed>>16)&0x7FFF;
+}
+
/* Initialize runtime system: */
@@ -680,7 +695,7 @@ int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
# if defined(__MINGW64_VERSION_MAJOR)
ULONGLONG tick_count = GetTickCount64();
# else
- /* mingw32 doesn't yet have GetTickCount64 support */
+ /* mingw doesn't yet have GetTickCount64 support */
ULONGLONG tick_count = GetTickCount();
# endif
C_startup_time_sec = tick_count / 1000;
@@ -703,7 +718,7 @@ int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
debug_mode = 2;
#endif
- if(debug_mode)
+ if(debug_mode)
C_dbg(C_text("debug"), C_text("application startup...\n"));
C_panic_hook = usual_panic;
@@ -727,10 +742,10 @@ int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
temporary_stack_size = fixed_temporary_stack_size ? fixed_temporary_stack_size : DEFAULT_TEMPORARY_STACK_SIZE;
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 *));
@@ -754,7 +769,7 @@ int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
(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;
@@ -766,7 +781,7 @@ int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
collectibles_top = collectibles;
collectibles_limit = collectibles + DEFAULT_COLLECTIBLES_SIZE;
gc_root_list = NULL;
-
+
#if !defined(NO_DLOAD2) && defined(HAVE_DLFCN_H)
dlopen_flags = RTLD_LAZY | RTLD_GLOBAL;
#else
@@ -826,12 +841,12 @@ int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
locative_chain = (C_word)NULL;
gc_ms = 0;
if (!random_state_initialized) {
- srand(time(NULL));
+ C_fast_srand(time(NULL));
random_state_initialized = 1;
}
for(i = 0; i < C_RANDOM_STATE_SIZE / sizeof(C_uword); ++i)
- random_state[ i ] = rand();
+ random_state[ i ] = C_fast_rand();
initialize_symbol_table();
@@ -851,7 +866,7 @@ int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
C_memset(profile_table, 0, sizeof(PROFILE_BUCKET *) * PROFILE_TABLE_SIZE);
}
-
+
/* create k to invoke code for system-startup: */
k0 = (C_SCHEME_BLOCK *)C_align((C_word)C_fromspace_top);
C_fromspace_top += C_align(2 * sizeof(C_word));
@@ -883,7 +898,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
{
/* IMPORTANT: hardcoded table size -
this must match the number of C_pte calls + 1 (NULL terminator)! */
- C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 63);
+ C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 64);
int i = 0;
if(pt == NULL)
@@ -896,6 +911,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(call_cc_wrapper);
C_pte(C_gc);
C_pte(C_allocate_vector);
+ C_pte(C_allocate_bytevector);
C_pte(C_make_structure);
C_pte(C_ensure_heap_reserve);
C_pte(C_return_to_host);
@@ -1005,9 +1021,9 @@ void CHICKEN_delete_gc_root(void *root)
void *CHICKEN_global_lookup(char *name)
{
- int
+ int
len = C_strlen(name),
- key = hash_string(len, name, symbol_table->size, symbol_table->rand, 0);
+ key = hash_string(len, name, symbol_table->size, symbol_table->rand);
C_word s;
void *root = CHICKEN_new_gc_root();
@@ -1047,7 +1063,7 @@ C_regparm C_SYMBOL_TABLE *C_new_symbol_table(char *name, unsigned int size)
stp->name = name;
stp->size = size;
stp->next = symbol_table_list;
- stp->rand = rand();
+ stp->rand = C_fast_rand();
if((stp->table = (C_word *)C_malloc(size * sizeof(C_word))) == NULL)
return NULL;
@@ -1056,7 +1072,7 @@ C_regparm C_SYMBOL_TABLE *C_new_symbol_table(char *name, unsigned int size)
symbol_table_list = stp;
return stp;
-}
+}
C_regparm C_SYMBOL_TABLE *C_find_symbol_table(char *name)
@@ -1070,16 +1086,16 @@ C_regparm C_SYMBOL_TABLE *C_find_symbol_table(char *name)
}
-C_regparm C_word C_find_symbol(C_word str, C_SYMBOL_TABLE *stable)
+C_regparm C_word C_find_symbol(C_word bv, C_SYMBOL_TABLE *stable)
{
- C_char *sptr = C_c_string(str);
- int len = C_header_size(str);
+ C_char *sptr = C_c_string(bv);
+ int len = C_header_size(bv) - 1;
int key;
C_word s;
if(stable == NULL) stable = symbol_table;
- key = hash_string(len, sptr, stable->size, stable->rand, 0);
+ key = hash_string(len, sptr, stable->size, stable->rand);
if(C_truep(s = lookup(key, len, sptr, stable))) return s;
else return C_SCHEME_FALSE;
@@ -1103,7 +1119,6 @@ void initialize_symbol_table(void)
current_thread_symbol = C_intern3(C_heaptop, C_text("##sys#current-thread"), C_SCHEME_FALSE);
/* SRFI-4 tags */
- u8vector_symbol = C_intern2(C_heaptop, C_text("u8vector"));
s8vector_symbol = C_intern2(C_heaptop, C_text("s8vector"));
u16vector_symbol = C_intern2(C_heaptop, C_text("u16vector"));
s16vector_symbol = C_intern2(C_heaptop, C_text("s16vector"));
@@ -1119,13 +1134,13 @@ void initialize_symbol_table(void)
C_regparm C_word C_find_keyword(C_word str, C_SYMBOL_TABLE *kwtable)
{
C_char *sptr = C_c_string(str);
- int len = C_header_size(str);
+ int len = C_header_size(str) - 1;
int key;
C_word s;
if(kwtable == NULL) kwtable = keyword_table;
- key = hash_string(len, sptr, kwtable->size, kwtable->rand, 0);
+ key = hash_string(len, sptr, kwtable->size, kwtable->rand);
if(C_truep(s = lookup(key, len, sptr, kwtable))) return s;
else return C_SCHEME_FALSE;
@@ -1163,7 +1178,7 @@ void global_signal_handler(int signum)
#if defined(HAVE_SIGPROCMASK)
if(signum == SIGSEGV || signum == SIGFPE || signum == SIGILL || signum == SIGBUS) {
sigset_t sset;
-
+
if(serious_signal_occurred || !chicken_is_running) {
switch(signum) {
case SIGSEGV: panic(C_text("unrecoverable segmentation violation"));
@@ -1279,7 +1294,7 @@ void C_set_or_change_heap_size(C_word heap, int reintern)
if(reintern) initialize_symbol_table();
}
-
+
/* Modify stack-size at runtime: */
@@ -1289,7 +1304,7 @@ void C_do_resize_stack(C_word stack)
diff = stack - old;
if(diff != 0 && !stack_size_changed) {
- if(debug_mode)
+ if(debug_mode)
C_dbg(C_text("debug"), C_text("stack resized to " UWORD_COUNT_FORMAT_STRING " bytes\n"), stack);
stack_size = stack;
@@ -1315,9 +1330,9 @@ void C_check_nursery_minimum(C_word words)
C_word C_resize_pending_finalizers(C_word size) {
int sz = C_num_to_int(size);
- FINALIZER_NODE **newmem =
+ FINALIZER_NODE **newmem =
(FINALIZER_NODE **)C_realloc(pending_finalizer_indices, sz * sizeof(FINALIZER_NODE *));
-
+
if (newmem == NULL)
return C_SCHEME_FALSE;
@@ -1388,7 +1403,7 @@ void CHICKEN_parse_command_line(int argc, char *argv[], C_word *heap, C_word *st
case 'h':
switch(*ptr) {
case 'i':
- *heap = arg_val(ptr + 1);
+ *heap = arg_val(ptr + 1);
heap_size_changed = 1;
goto next;
case 'f':
@@ -1407,7 +1422,7 @@ void CHICKEN_parse_command_line(int argc, char *argv[], C_word *heap, C_word *st
C_heap_shrinkage_used = arg_val(ptr + 1);
goto next;
default:
- *heap = arg_val(ptr);
+ *heap = arg_val(ptr);
heap_size_changed = 1;
C_heap_size_is_fixed = 1;
goto next;
@@ -1484,7 +1499,7 @@ void CHICKEN_parse_command_line(int argc, char *argv[], C_word *heap, C_word *st
break;
case 'R':
- srand((unsigned int)arg_val(ptr));
+ C_fast_srand((unsigned int)arg_val(ptr));
random_state_initialized = 1;
goto next;
@@ -1508,18 +1523,18 @@ C_word arg_val(C_char *arg)
C_long val, mul = 1;
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': mul = 1024; break;
-
+
case 'm':
case 'M': mul = 1024 * 1024; break;
-
+
case 'g':
case 'G': mul = 1024 * 1024 * 1024; break;
@@ -1528,7 +1543,7 @@ C_word arg_val(C_char *arg)
val = C_strtow(arg, &end, 10);
- if((mul != 1 ? end[ 1 ] != '\0' : end[ 0 ] != '\0'))
+ if((mul != 1 ? end[ 1 ] != '\0' : end[ 0 ] != '\0'))
panic(C_text("invalid runtime-option argument suffix"));
return val * mul;
@@ -1655,7 +1670,7 @@ void horror(C_char *msg)
#endif
} /* fall through */
- C_dbg("horror", C_text("\n%s - execution terminated"), msg);
+ C_dbg("horror", C_text("\n%s - execution terminated"), msg);
C_exit_runtime(C_fix(1));
}
@@ -1668,7 +1683,7 @@ void barf(int code, char *loc, ...)
C_word err = error_hook_symbol;
int c, i;
va_list v;
- C_word *av;
+ C_word *av;
C_dbg_hook(C_SCHEME_UNDEFINED);
@@ -1685,7 +1700,7 @@ void barf(int code, char *loc, ...)
msg = C_text("too few arguments");
c = 3;
break;
-
+
case C_BAD_ARGUMENT_TYPE_ERROR:
msg = C_text("bad argument type");
c = 1;
@@ -1711,7 +1726,7 @@ void barf(int code, char *loc, ...)
c = 0;
break;
- case C_OUT_OF_RANGE_ERROR:
+ case C_OUT_OF_BOUNDS_ERROR:
msg = C_text("out of range");
c = 2;
break;
@@ -1807,7 +1822,7 @@ void barf(int code, char *loc, ...)
break;
case C_BAD_ARGUMENT_TYPE_NO_BYTEVECTOR_ERROR:
- msg = C_text("bad argument type - not a blob");
+ msg = C_text("bad argument type - not a bytevector");
c = 1;
break;
@@ -1890,7 +1905,7 @@ void barf(int code, char *loc, ...)
msg = C_text("port already closed");
c = 1;
break;
-
+
case C_ASCIIZ_REPRESENTATION_ERROR:
msg = C_text("cannot represent string with NUL bytes as C string");
c = 1;
@@ -1956,6 +1971,16 @@ void barf(int code, char *loc, ...)
c = 3;
break;
+ case C_DECODING_ERROR:
+ msg = C_text("string contains invalid UTF-8 sequence");
+ c = 2;
+ break;
+
+ case C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR:
+ msg = C_text("bad argument type - value exceeds numeric range");
+ c = 1;
+ break;
+
default: panic(C_text("illegal internal error code"));
}
@@ -1969,7 +1994,7 @@ void barf(int code, char *loc, ...)
/* No continuation is passed: '##sys#error-hook' may not return: */
av[ 1 ] = C_SCHEME_UNDEFINED;
av[ 2 ] = C_fix(code);
-
+
if(loc != NULL)
av[ 3 ] = intern0(loc);
else {
@@ -2031,12 +2056,12 @@ C_word C_dbg_hook(C_word dummy)
/* Timing routines: */
/* DEPRECATED */
-C_regparm C_u64 C_fcall C_milliseconds(void)
+C_regparm C_u64 C_milliseconds(void)
{
return C_current_process_milliseconds();
}
-C_regparm C_u64 C_fcall C_current_process_milliseconds(void)
+C_regparm C_u64 C_current_process_milliseconds(void)
{
#if defined(__MINGW32__)
# if defined(__MINGW64_VERSION_MAJOR)
@@ -2054,7 +2079,7 @@ C_regparm C_u64 C_fcall C_current_process_milliseconds(void)
}
-C_regparm time_t C_fcall C_seconds(C_long *ms)
+C_regparm time_t C_seconds(C_long *ms)
{
#ifdef C_NONUNIX
if(ms != NULL) *ms = 0;
@@ -2077,7 +2102,7 @@ C_regparm time_t C_fcall C_seconds(C_long *ms)
}
-C_regparm C_u64 C_fcall C_cpu_milliseconds(void)
+C_regparm C_u64 C_cpu_milliseconds(void)
{
#if defined(C_NONUNIX) || defined(__CYGWIN__)
if(CLOCKS_PER_SEC == 1000) return clock();
@@ -2094,16 +2119,16 @@ C_regparm C_u64 C_fcall C_cpu_milliseconds(void)
/* Support code for callbacks: */
-int C_fcall C_save_callback_continuation(C_word **ptr, C_word k)
+int C_save_callback_continuation(C_word **ptr, C_word k)
{
C_word p = C_a_pair(ptr, k, C_block_item(callback_continuation_stack_symbol, 0));
-
+
C_mutate_slot(&C_block_item(callback_continuation_stack_symbol, 0), p);
return ++callback_continuation_level;
}
-C_word C_fcall C_restore_callback_continuation(void)
+C_word C_restore_callback_continuation(void)
{
/* obsolete, but retained for keeping old code working */
C_word p = C_block_item(callback_continuation_stack_symbol, 0),
@@ -2118,7 +2143,7 @@ C_word C_fcall C_restore_callback_continuation(void)
}
-C_word C_fcall C_restore_callback_continuation2(int level)
+C_word C_restore_callback_continuation2(int level)
{
C_word p = C_block_item(callback_continuation_stack_symbol, 0),
k;
@@ -2134,14 +2159,14 @@ C_word C_fcall C_restore_callback_continuation2(int level)
}
-C_word C_fcall C_callback(C_word closure, int argc)
+C_word C_callback(C_word closure, int argc)
{
#ifdef HAVE_SIGSETJMP
sigjmp_buf prev;
#else
jmp_buf prev;
#endif
- C_word
+ C_word
*a = C_alloc(C_SIZEOF_CLOSURE(2)),
k = C_closure(&a, 2, (C_word)callback_return_continuation, C_SCHEME_FALSE),
*av;
@@ -2151,7 +2176,7 @@ C_word C_fcall C_callback(C_word closure, int argc)
panic(C_text("callback invoked in non-safe context"));
C_memcpy(&prev, &C_restart, sizeof(C_restart));
- callback_returned_flag = 0;
+ callback_returned_flag = 0;
chicken_is_running = 1;
av = C_alloc(argc + 2);
av[ 0 ] = closure;
@@ -2159,7 +2184,7 @@ C_word C_fcall C_callback(C_word closure, int argc)
/*XXX is the order of arguments an issue? */
C_memcpy(av + 2, C_temporary_stack, argc * sizeof(C_word));
C_temporary_stack = C_temporary_stack_bottom;
-
+
#ifdef HAVE_SIGSETJMP
if(!C_sigsetjmp(C_restart, 0)) C_do_apply(argc + 2, av);
#else
@@ -2182,17 +2207,17 @@ C_word C_fcall C_callback(C_word closure, int argc)
C_memcpy(&C_restart, &prev, sizeof(C_restart));
callback_returned_flag = 0;
}
-
+
chicken_is_running = old;
return C_restore;
}
-void C_fcall C_callback_adjust_stack(C_word *a, int size)
+void C_callback_adjust_stack(C_word *a, int size)
{
if(!chicken_is_running && !C_in_stackp((C_word)a)) {
if(debug_mode)
- C_dbg(C_text("debug"),
+ C_dbg(C_text("debug"),
C_text("callback invoked in lower stack region - adjusting limits:\n"
"[debug] current: \t%p\n"
"[debug] previous: \t%p (bottom) - %p (limit)\n"),
@@ -2214,7 +2239,7 @@ void C_fcall C_callback_adjust_stack(C_word *a, int size)
}
-C_word C_fcall C_callback_wrapper(void *proc, int argc)
+C_word C_callback_wrapper(void *proc, int argc)
{
C_word
*a = C_alloc(C_SIZEOF_CLOSURE(1)),
@@ -2285,7 +2310,7 @@ LF_LIST *find_module_handle(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))
+ if(np->module_name != NULL && !C_strcmp(np->module_name, name))
return np;
}
@@ -2310,19 +2335,19 @@ void C_unregister_lf(void *handle)
/* Intern symbol into symbol-table: */
-C_regparm C_word C_fcall C_intern(C_word **ptr, int len, C_char *str)
+C_regparm C_word 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)
+C_regparm C_word 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_kw(C_word **ptr, int len, C_char *str)
+C_regparm C_word C_intern_kw(C_word **ptr, int len, C_char *str)
{
C_word kw = C_intern_in(ptr, len, str, keyword_table);
C_set_block_item(kw, 0, kw); /* Keywords evaluate to themselves */
@@ -2331,7 +2356,7 @@ C_regparm C_word C_fcall C_intern_kw(C_word **ptr, int len, C_char *str)
}
-C_regparm C_word C_fcall C_h_intern_kw(C_word *slot, int len, C_char *str)
+C_regparm C_word C_h_intern_kw(C_word *slot, int len, C_char *str)
{
C_word kw = C_h_intern_in(slot, len, str, keyword_table);
C_set_block_item(kw, 0, kw); /* Keywords evaluate to themselves */
@@ -2339,23 +2364,23 @@ C_regparm C_word C_fcall C_h_intern_kw(C_word *slot, int len, C_char *str)
return kw;
}
-C_regparm C_word C_fcall C_intern_in(C_word **ptr, int len, C_char *str, C_SYMBOL_TABLE *stable)
+C_regparm C_word 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, stable->rand, 0);
+ key = hash_string(len, str, stable->size, stable->rand);
if(C_truep(s = lookup(key, len, str, stable))) return s;
- s = C_string(ptr, len, str);
+ s = C_bytevector(ptr, len + 1, 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)
+C_regparm C_word C_h_intern_in(C_word *slot, int len, C_char *str, C_SYMBOL_TABLE *stable)
{
/* Intern as usual, but remember slot, and allocate in static
* memory. If symbol already exists, replace its string by a fresh
@@ -2363,32 +2388,35 @@ C_regparm C_word C_fcall C_h_intern_in(C_word *slot, int len, C_char *str, C_SYM
* lf[] entries are not tracked by the GC.
*/
int key;
- C_word s;
+ C_word s, bv;
if(stable == NULL) stable = symbol_table;
- key = hash_string(len, str, stable->size, stable->rand, 0);
+ key = hash_string(len, str, stable->size, stable->rand);
if(C_truep(s = lookup(key, len, str, stable))) {
if(C_in_stackp(s)) C_mutate_slot(slot, s);
-
+
if(!C_truep(C_permanentp(C_symbol_name(s)))) {
/* Replace by statically allocated string, and persist it */
- C_set_block_item(s, 1, C_static_string(C_heaptop, len, str));
+ bv = C_static_bytevector(C_heaptop, len + 1, str);
+ C_c_bytevector(bv)[ len ] = 0;
+ C_set_block_item(s, 1, bv);
C_i_persist_symbol(s);
}
return s;
}
- s = C_static_string(C_heaptop, len, str);
- return add_symbol(C_heaptop, key, s, stable);
+ bv = C_static_bytevector(C_heaptop, len + 1, str);
+ C_c_bytevector(bv)[ len ] = 0;
+ return add_symbol(C_heaptop, key, bv, stable);
}
-C_regparm C_word C_fcall intern0(C_char *str)
+C_regparm C_word intern0(C_char *str)
{
int len = C_strlen(str);
- int key = hash_string(len, str, symbol_table->size, symbol_table->rand, 0);
+ int key = hash_string(len, str, symbol_table->size, symbol_table->rand);
C_word s;
if(C_truep(s = lookup(key, len, str, symbol_table))) return s;
@@ -2396,52 +2424,50 @@ C_regparm C_word C_fcall intern0(C_char *str)
}
-C_regparm C_word C_fcall C_lookup_symbol(C_word sym)
+C_regparm C_word C_lookup_symbol(C_word sym)
{
int key;
- C_word str = C_block_item(sym, 1);
- int len = C_header_size(str);
+ C_word bv = C_block_item(sym, 1);
+ int len = C_header_size(bv) - 1;
- key = hash_string(len, C_c_string(str), symbol_table->size, symbol_table->rand, 0);
+ key = hash_string(len, C_c_string(bv), symbol_table->size, symbol_table->rand);
- return lookup(key, len, C_c_string(str), symbol_table);
+ return lookup(key, len, C_c_string(bv), symbol_table);
}
-C_regparm C_word C_fcall C_intern2(C_word **ptr, C_char *str)
+C_regparm C_word 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_regparm C_word 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_block_item(s,0), value);
C_i_persist_symbol(s); /* Symbol has a value now; persist it */
return s;
}
-C_regparm C_word C_fcall hash_string(int len, C_char *str, C_word m, C_word r, int ci)
+C_regparm C_word hash_string(int len, C_char *str, C_word m, C_word r)
{
C_uword key = r;
- if (ci)
- while(len--) key ^= (key << 6) + (key >> 2) + C_tolower((int)(*str++));
- else
- while(len--) key ^= (key << 6) + (key >> 2) + *(str++);
+ while(len--)
+ key ^= (key << 6) + (key >> 2) + *(str++);
return (C_word)(key % (C_uword)m);
}
-C_regparm C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable)
+C_regparm C_word lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE *stable)
{
C_word bucket, last = 0, sym, s;
- for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST;
+ for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST;
bucket = C_block_item(bucket,1)) {
sym = C_block_item(bucket,0);
@@ -2453,7 +2479,7 @@ C_regparm C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE
last = bucket;
s = C_block_item(sym, 1);
- if(C_header_size(s) == (C_word)len
+ if(C_header_size(s) - 1 == (C_word)len
&& !C_memcmp(str, (C_char *)C_data_pointer(s), len))
return sym;
}
@@ -2463,7 +2489,7 @@ C_regparm C_word C_fcall lookup(C_word key, int len, C_char *str, C_SYMBOL_TABLE
}
/* Mark a symbol as "persistent", to prevent it from being GC'ed */
-C_regparm C_word C_fcall C_i_persist_symbol(C_word sym)
+C_regparm C_word C_i_persist_symbol(C_word sym)
{
C_word bucket;
C_SYMBOL_TABLE *stp;
@@ -2493,7 +2519,7 @@ C_regparm C_word C_fcall C_i_persist_symbol(C_word sym)
* This is only done if the symbol is unbound, has an empty plist and
* is allocated in managed memory.
*/
-C_regparm C_word C_fcall C_i_unpersist_symbol(C_word sym)
+C_regparm C_word C_i_unpersist_symbol(C_word sym)
{
C_word bucket;
C_SYMBOL_TABLE *stp;
@@ -2517,14 +2543,14 @@ C_regparm C_word C_fcall C_i_unpersist_symbol(C_word sym)
return C_SCHEME_FALSE;
}
-C_regparm C_word C_fcall lookup_bucket(C_word sym, C_SYMBOL_TABLE *stable)
+C_regparm C_word lookup_bucket(C_word sym, C_SYMBOL_TABLE *stable)
{
C_word bucket, str = C_block_item(sym, 1);
- int key, len = C_header_size(str);
+ int key, len = C_header_size(str) - 1;
if (stable == NULL) stable = symbol_table;
- key = hash_string(len, C_c_string(str), stable->size, stable->rand, 0);
+ key = hash_string(len, C_c_string(str), stable->size, stable->rand);
for(bucket = stable->table[ key ]; bucket != C_SCHEME_END_OF_LIST;
bucket = C_block_item(bucket,1)) {
@@ -2542,7 +2568,7 @@ double compute_symbol_table_load(double *avg_bucket_len, int *total_n)
for(i = 0; i < symbol_table->size; ++i) {
last = 0;
j = 0;
- for(bucket = symbol_table->table[ i ]; bucket != C_SCHEME_END_OF_LIST;
+ for(bucket = symbol_table->table[ i ]; bucket != C_SCHEME_END_OF_LIST;
bucket = C_block_item(bucket,1)) {
/* If the symbol is unreferenced, drop it: */
if (C_block_item(bucket,0) == C_SCHEME_BROKEN_WEAK_PTR) {
@@ -2572,22 +2598,22 @@ double compute_symbol_table_load(double *avg_bucket_len, int *total_n)
}
-C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stable)
+C_word add_symbol(C_word **ptr, C_word key, C_word bv, C_SYMBOL_TABLE *stable)
{
C_word bucket, sym, b2, *p;
p = *ptr;
sym = (C_word)p;
p += C_SIZEOF_SYMBOL;
- C_block_header_init(sym, C_SYMBOL_TYPE | (C_SIZEOF_SYMBOL - 1));
+ C_block_header_init(sym, C_SYMBOL_TAG);
C_set_block_item(sym, 0, C_SCHEME_UNBOUND);
- C_set_block_item(sym, 1, string);
+ C_set_block_item(sym, 1, bv);
C_set_block_item(sym, 2, C_SCHEME_END_OF_LIST);
*ptr = p;
b2 = stable->table[ key ]; /* previous bucket */
/* Create new weak or strong bucket depending on persistability */
- if (C_truep(C_permanentp(string))) {
+ if (C_truep(C_permanentp(bv))) {
bucket = C_a_pair(ptr, sym, b2);
} else {
bucket = C_a_weak_pair(ptr, sym, b2);
@@ -2595,9 +2621,9 @@ C_word add_symbol(C_word **ptr, C_word key, C_word string, C_SYMBOL_TABLE *stabl
if(ptr != C_heaptop) C_mutate_slot(&stable->table[ key ], bucket);
else {
- /* If a stack-allocated bucket was here, and we allocate from
+ /* 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
+ to inform the memory manager that a 2nd gen. block points to a
1st gen. block, hence the mutation: */
C_mutate(&C_block_item(bucket,1), b2);
stable->table[ key ] = bucket;
@@ -2619,7 +2645,7 @@ C_regparm int C_in_stackp(C_word x)
}
-C_regparm int C_fcall C_in_heapp(C_word x)
+C_regparm int C_in_heapp(C_word x)
{
C_byte *ptr = (C_byte *)(C_uword)x;
return (ptr >= fromspace_start && ptr < C_fromspace_limit) ||
@@ -2627,19 +2653,19 @@ C_regparm int C_fcall C_in_heapp(C_word x)
}
/* Only used during major GC (heap realloc) */
-static C_regparm int C_fcall C_in_new_heapp(C_word x)
+static C_regparm int C_in_new_heapp(C_word x)
{
C_byte *ptr = (C_byte *)(C_uword)x;
return (ptr >= new_tospace_start && ptr < new_tospace_limit);
}
-C_regparm int C_fcall C_in_fromspacep(C_word x)
+C_regparm int C_in_fromspacep(C_word x)
{
C_byte *ptr = (C_byte *)(C_uword)x;
return (ptr >= fromspace_start && ptr < C_fromspace_limit);
}
-C_regparm int C_fcall C_in_scratchspacep(C_word x)
+C_regparm int C_in_scratchspacep(C_word x)
{
C_word *ptr = (C_word *)(C_uword)x;
return (ptr >= C_scratchspace_start && ptr < C_scratchspace_limit);
@@ -2647,7 +2673,7 @@ C_regparm int C_fcall C_in_scratchspacep(C_word x)
/* Cons the rest-aguments together: */
-C_regparm C_word C_fcall C_build_rest(C_word **ptr, C_word c, C_word n, C_word *av)
+C_regparm C_word C_build_rest(C_word **ptr, C_word c, C_word n, C_word *av)
{
C_word
x = C_SCHEME_END_OF_LIST,
@@ -2716,29 +2742,29 @@ void C_stack_overflow(C_char *loc)
}
-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);
}
-void C_div_by_zero_error(char *loc)
+void C_div_by_zero_error(C_char *loc)
{
barf(C_DIVISION_BY_ZERO_ERROR, loc);
}
-void C_not_an_integer_error(char *loc, C_word x)
+void C_unimplemented(C_char *msg)
+{
+ C_fprintf(C_stderr, C_text("Error: unimplemented feature: %s\n"), msg);
+ C_exit_runtime(C_fix(EX_SOFTWARE));
+}
+
+void C_not_an_integer_error(C_char *loc, C_word x)
{
barf(C_BAD_ARGUMENT_TYPE_NO_INTEGER_ERROR, loc, x);
}
-void C_not_an_uinteger_error(char *loc, C_word x)
+void C_not_an_uinteger_error(C_char *loc, C_word x)
{
barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, loc, x);
}
@@ -2755,32 +2781,39 @@ void C_rest_arg_out_of_bounds_error_2(C_word c, C_word n, C_word ka, C_word clos
/* Allocate and initialize record: */
-C_regparm C_word C_fcall C_string(C_word **ptr, int len, C_char *str)
+C_regparm C_word 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_block_header_init(strblock, C_STRING_TYPE | len);
- C_memcpy(C_data_pointer(strblock), str, len);
- return strblock;
+ C_word buf = C_bytevector(ptr, len + 1, str);
+ C_word s = (C_word)(*ptr);
+ int n;
+ *ptr += 5; /* C_SIZEOF_STRING */
+ C_c_bytevector(buf)[ len ] = 0;
+ C_block_header_init(s, C_STRING_TAG);
+ C_set_block_item(s, 0, buf);
+ n = C_utf_count(str, len);
+ C_set_block_item(s, 1, C_fix(n));
+ C_set_block_item(s, 2, C_fix(0));
+ C_set_block_item(s, 3, C_fix(0));
+ return s;
}
-
-C_regparm C_word C_fcall C_static_string(C_word **ptr, int len, C_char *str)
+C_regparm C_word 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_block_header_init(strblock, C_STRING_TYPE | len);
- C_memcpy(C_data_pointer(strblock), str, len);
- return strblock;
+ C_word buf = C_static_bytevector(ptr, len + 1, str);
+ C_word s = (C_word)(*ptr);
+ int n;
+ *ptr += 5; /* C_SIZEOF_STRING */
+ C_c_bytevector(buf)[ len ] = 0;
+ C_block_header_init(s, C_STRING_TAG);
+ C_set_block_item(s, 0, buf);
+ n = C_utf_count(str, len);
+ C_set_block_item(s, 1, C_fix(n));
+ C_set_block_item(s, 2, C_fix(0));
+ C_set_block_item(s, 3, C_fix(0));
+ return s;
}
-C_regparm C_word C_fcall C_static_bignum(C_word **ptr, int len, C_char *str)
+C_regparm C_word C_static_bignum(C_word **ptr, int len, C_char *str)
{
C_word *dptr, bignum, bigvec, retval, size, negp = 0;
@@ -2795,7 +2828,7 @@ C_regparm C_word C_fcall C_static_bignum(C_word **ptr, int len, C_char *str)
panic(C_text("out of memory - cannot allocate static bignum"));
bigvec = (C_word)dptr;
- C_block_header_init(bigvec, C_STRING_TYPE | C_wordstobytes(size + 1));
+ C_block_header_init(bigvec, C_BYTEVECTOR_TYPE | C_wordstobytes(size + 1));
C_set_block_item(bigvec, 0, negp);
/* This needs to be allocated at ptr, not dptr, because GC moves type tag */
bignum = C_a_i_bignum_wrapper(ptr, bigvec);
@@ -2806,7 +2839,7 @@ C_regparm C_word C_fcall C_static_bignum(C_word **ptr, int len, C_char *str)
return retval;
}
-C_regparm C_word C_fcall C_static_lambda_info(C_word **ptr, int len, C_char *str)
+C_regparm C_word 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);
@@ -2822,29 +2855,37 @@ C_regparm C_word C_fcall C_static_lambda_info(C_word **ptr, int len, C_char *str
}
-C_regparm C_word C_fcall C_bytevector(C_word **ptr, int len, C_char *str)
+C_regparm C_word C_bytevector(C_word **ptr, int len, C_char *str)
{
- C_word strblock = C_string(ptr, len, str);
-
- (void)C_string_to_bytevector(strblock);
- return strblock;
+ C_word block = (C_word)(*ptr);
+ *ptr = (C_word *)((C_word)(*ptr) + sizeof(C_header) + C_align(len));
+ C_block_header_init(block, C_BYTEVECTOR_TYPE | len);
+ C_memcpy(C_data_pointer(block), str, len);
+ return block;
}
-C_regparm C_word C_fcall C_static_bytevector(C_word **ptr, int len, C_char *str)
+C_regparm C_word C_static_bytevector(C_word **ptr, int len, C_char *str)
{
- C_word strblock = C_static_string(ptr, len, str);
+ /* we need to add 4 here, as utf8_decode does 3-byte lookahead */
+ C_word *dptr = (C_word *)C_malloc(sizeof(C_header) + C_align(len + 4));
+ C_word block;
- C_block_header_init(strblock, C_BYTEVECTOR_TYPE | len);
- return strblock;
+ if(dptr == NULL)
+ panic(C_text("out of memory - cannot allocate static bytevector"));
+
+ block = (C_word)dptr;
+ C_block_header_init(block, C_BYTEVECTOR_TYPE | len);
+ C_memcpy(C_data_pointer(block), str, len);
+ return block;
}
-C_regparm C_word C_fcall C_pbytevector(int len, C_char *str)
+C_regparm C_word 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"));
+ if(pbv == NULL) panic(C_text("out of memory - cannot allocate permanent bytevector"));
pbv->header = C_BYTEVECTOR_TYPE | len;
C_memcpy(pbv->data, str, len);
@@ -2852,25 +2893,7 @@ C_regparm C_word C_fcall C_pbytevector(int len, C_char *str)
}
-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(C_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_regparm C_word C_string2(C_word **ptr, C_char *str)
{
C_word strblock = (C_word)(*ptr);
int len;
@@ -2878,14 +2901,11 @@ C_regparm C_word C_fcall C_string2(C_word **ptr, C_char *str)
if(str == NULL) return C_SCHEME_FALSE;
len = C_strlen(str);
- *ptr = (C_word *)((C_word)(*ptr) + sizeof(C_header) + C_align(len));
- C_block_header_init(strblock, C_STRING_TYPE | len);
- C_memcpy(C_data_pointer(strblock), str, len);
- return strblock;
+ return C_string(ptr, len, str);
}
-C_regparm C_word C_fcall C_string2_safe(C_word **ptr, int max, C_char *str)
+C_regparm C_word C_string2_safe(C_word **ptr, int max, C_char *str)
{
C_word strblock = (C_word)(*ptr);
int len;
@@ -2899,14 +2919,11 @@ C_regparm C_word C_fcall C_string2_safe(C_word **ptr, int max, C_char *str)
panic(buffer);
}
- *ptr = (C_word *)((C_word)(*ptr) + sizeof(C_header) + C_align(len));
- C_block_header_init(strblock, C_STRING_TYPE | len);
- C_memcpy(C_data_pointer(strblock), str, len);
- return strblock;
+ return C_string(ptr, len, str);
}
-C_word C_fcall C_closure(C_word **ptr, int cells, C_word proc, ...)
+C_word C_closure(C_word **ptr, int cells, C_word proc, ...)
{
va_list va;
C_word *p = *ptr,
@@ -2924,11 +2941,11 @@ C_word C_fcall C_closure(C_word **ptr, int cells, C_word proc, ...)
/* obsolete: replaced by C_a_pair in chicken.h */
-C_regparm C_word C_fcall C_pair(C_word **ptr, C_word car, C_word cdr)
+C_regparm C_word 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;
@@ -2937,9 +2954,9 @@ C_regparm C_word C_fcall C_pair(C_word **ptr, C_word car, C_word cdr)
}
-C_regparm C_word C_fcall C_number(C_word **ptr, double n)
+C_regparm C_word C_number(C_word **ptr, double n)
{
- C_word
+ C_word
*p = *ptr,
*p0;
double m;
@@ -2964,9 +2981,9 @@ C_regparm C_word C_fcall C_number(C_word **ptr, double n)
}
-C_regparm C_word C_fcall C_mpointer(C_word **ptr, void *mp)
+C_regparm C_word C_mpointer(C_word **ptr, void *mp)
{
- C_word
+ C_word
*p = *ptr,
*p0 = p;
@@ -2977,9 +2994,9 @@ C_regparm C_word C_fcall C_mpointer(C_word **ptr, void *mp)
}
-C_regparm C_word C_fcall C_mpointer_or_false(C_word **ptr, void *mp)
+C_regparm C_word C_mpointer_or_false(C_word **ptr, void *mp)
{
- C_word
+ C_word
*p = *ptr,
*p0 = p;
@@ -2992,9 +3009,9 @@ C_regparm C_word C_fcall C_mpointer_or_false(C_word **ptr, void *mp)
}
-C_regparm C_word C_fcall C_taggedmpointer(C_word **ptr, C_word tag, void *mp)
+C_regparm C_word C_taggedmpointer(C_word **ptr, C_word tag, void *mp)
{
- C_word
+ C_word
*p = *ptr,
*p0 = p;
@@ -3006,14 +3023,14 @@ C_regparm C_word C_fcall C_taggedmpointer(C_word **ptr, C_word tag, void *mp)
}
-C_regparm C_word C_fcall C_taggedmpointer_or_false(C_word **ptr, C_word tag, void *mp)
+C_regparm C_word C_taggedmpointer_or_false(C_word **ptr, C_word tag, void *mp)
{
- C_word
+ C_word
*p = *ptr,
*p0 = p;
if(mp == NULL) return C_SCHEME_FALSE;
-
+
*(p++) = C_TAGGED_POINTER_TAG;
*((void **)p) = mp;
*(++p) = tag;
@@ -3025,9 +3042,9 @@ C_regparm C_word C_fcall C_taggedmpointer_or_false(C_word **ptr, C_word tag, voi
C_word C_vector(C_word **ptr, int n, ...)
{
va_list v;
- C_word
+ C_word
*p = *ptr,
- *p0 = p;
+ *p0 = p;
*(p++) = C_VECTOR_TYPE | n;
va_start(v, n);
@@ -3045,7 +3062,7 @@ C_word C_structure(C_word **ptr, int n, ...)
{
va_list v;
C_word *p = *ptr,
- *p0 = p;
+ *p0 = p;
*(p++) = C_STRUCTURE_TYPE | n;
va_start(v, n);
@@ -3059,7 +3076,7 @@ C_word C_structure(C_word **ptr, int n, ...)
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_mutate_slot(C_word *slot, C_word val)
{
unsigned int mssize, newmssize, bytes;
@@ -3069,7 +3086,7 @@ C_mutate_slot(C_word *slot, C_word val)
* into nursery. Stuff pointing anywhere else can be skipped, as
* well as mutations on nursery objects.
*/
- if(!C_in_stackp(val) || C_in_stackp((C_word)slot))
+ if(C_in_stackp((C_word)slot) || (!C_in_stackp(val) && !C_in_scratchspacep(val)))
return *slot = val;
#ifdef C_GC_HOOKS
@@ -3082,7 +3099,7 @@ C_mutate_slot(C_word *slot, C_word val)
newmssize = mssize * 2;
bytes = newmssize * sizeof(C_word *);
- if(debug_mode)
+ if(debug_mode)
C_dbg(C_text("debug"), C_text("resizing mutation stack from %uk to %uk ...\n"),
(mssize * sizeof(C_word *)) / 1024, bytes / 1024);
@@ -3120,10 +3137,10 @@ C_mutate_slot(C_word *slot, C_word val)
* which now holds a value that happens to have the same bit pattern
* but represents another thing entirely.
*/
-C_regparm C_word C_fcall C_scratch_alloc(C_uword size)
+C_regparm C_word C_scratch_alloc(C_uword size)
{
C_word result;
-
+
if (C_scratchspace_top + size + 2 >= C_scratchspace_limit) {
C_word *new_scratch_start, *new_scratch_top, *new_scratch_limit;
C_uword needed = C_scratch_usage + size + 2,
@@ -3132,7 +3149,7 @@ C_regparm C_word C_fcall C_scratch_alloc(C_uword size)
/* Shrink if the needed size is much smaller, but not below minimum */
if (needed < (new_size >> 4)) new_size >>= 1;
new_size = nmax(new_size, DEFAULT_SCRATCH_SPACE_SIZE);
-
+
/* TODO: Maybe we should work with two semispaces to reduce mallocs? */
new_scratch_start = (C_word *)C_malloc(C_wordstobytes(new_size));
if (new_scratch_start == NULL)
@@ -3149,14 +3166,14 @@ C_regparm C_word C_fcall C_scratch_alloc(C_uword size)
}
if(gc_report_flag) {
- C_dbg(C_text("GC"), C_text("(old) scratchspace: \tstart=" UWORD_FORMAT_STRING
+ C_dbg(C_text("GC"), C_text("(old) scratchspace: \tstart=" UWORD_FORMAT_STRING
", \tlimit=" UWORD_FORMAT_STRING "\n"),
(C_word)C_scratchspace_start, (C_word)C_scratchspace_limit);
C_dbg(C_text("GC"), C_text("(new) scratchspace: \tstart=" UWORD_FORMAT_STRING
", \tlimit=" UWORD_FORMAT_STRING "\n"),
(C_word)new_scratch_start, (C_word)new_scratch_limit);
}
-
+
/* Move scratch data into new space and mutate slots pointing there.
* This is basically a much-simplified version of really_mark.
*/
@@ -3176,7 +3193,7 @@ C_regparm C_word C_fcall C_scratch_alloc(C_uword size)
else val = (C_word)(sscan+2);
sscan += words + 2;
-
+
p = (C_SCHEME_BLOCK *)val;
h = p->header;
if (is_fptr(h)) /* TODO: Support scratch->scratch pointers? */
@@ -3194,15 +3211,15 @@ C_regparm C_word C_fcall C_scratch_alloc(C_uword size)
/* If orig slot still points here, copy data and update it */
if (slot != NULL) {
- assert(C_in_stackp((C_word)slot) && *slot == val);
+ assert(*slot == val);
n = C_header_size(p);
n = (h & C_BYTEBLOCK_BIT) ? C_bytestowords(n) : n;
-
+
*slot = (C_word)p2;
/* size = header plus block size plus optional alignment hole */
*new_scratch_top = ((C_word *)p2-(C_word *)new_scratch_top-2) + n + 1;
*(new_scratch_top+1) = (C_word)slot;
-
+
new_scratch_top = (C_word *)p2 + n + 1;
if(new_scratch_top > new_scratch_limit)
panic(C_text("out of memory - scratch space full while resizing"));
@@ -3239,7 +3256,7 @@ C_regparm C_word C_fcall C_scratch_alloc(C_uword size)
* boundaries is updated to point to the new memory region. If the
* supplied pointer is NULL, the scratch memory is marked reclaimable.
*/
-C_regparm C_word C_fcall
+C_regparm C_word
C_migrate_buffer_object(C_word **ptr, C_word *start, C_word *end, C_word obj)
{
C_word size, header, *data, *p = NULL, obj_in_buffer;
@@ -3258,7 +3275,7 @@ C_migrate_buffer_object(C_word **ptr, C_word *start, C_word *end, C_word obj)
}
if (p != NULL) *p++ = header;
-
+
if (header & C_BYTEBLOCK_BIT) {
if (p != NULL) {
*ptr = (C_word *)((C_byte *)(*ptr) + sizeof(C_header) + C_align(size));
@@ -3266,7 +3283,7 @@ C_migrate_buffer_object(C_word **ptr, C_word *start, C_word *end, C_word obj)
}
} else {
if (p != NULL) *ptr += size + 1;
-
+
if(header & C_SPECIALBLOCK_BIT) {
if (p != NULL) *(p++) = *data;
size--;
@@ -3306,11 +3323,12 @@ C_migrate_buffer_object(C_word **ptr, C_word *start, C_word *end, C_word obj)
* one slot can point to a scratch space object; the object in scratch
* space is preceded by a pointer that points to this slot (or NULL).
*/
-C_regparm C_word C_fcall C_mutate_scratch_slot(C_word *slot, C_word val)
+C_regparm C_word C_mutate_scratch_slot(C_word *slot, C_word val)
{
C_word *ptr = (C_word *)val;
assert(C_in_scratchspacep(val));
- assert(slot == NULL || C_in_stackp((C_word)slot));
+/* XXX assert(slot == NULL || C_in_stackp((C_word)slot));
+*/
if (*(ptr-1) == ALIGNMENT_HOLE_MARKER) --ptr;
if (*(ptr-1) == (C_word)NULL && slot != NULL)
C_scratch_usage += *(ptr-2) + 2;
@@ -3318,7 +3336,7 @@ C_regparm C_word C_fcall C_mutate_scratch_slot(C_word *slot, C_word val)
C_scratch_usage -= *(ptr-2) + 2;
*(ptr-1) = (C_word)slot; /* Remember the slot pointing here, for realloc */
if (slot != NULL) *slot = val;
- return val;
+ return val;
}
/* Initiate garbage collection: */
@@ -3369,7 +3387,7 @@ void C_save_and_reclaim_args(void *trampoline, int n, ...)
{
va_list v;
int i;
-
+
va_start(v, n);
for(i = 0; i < n; ++i)
@@ -3396,7 +3414,7 @@ static void _mark(C_word *x, C_byte *s, C_byte **t, C_byte *l) { \
/* NOTE: This macro is particularly unhygienic! */
#define mark(x) _mark(x, tgt_space_start, tgt_space_top, tgt_space_limit)
-C_regparm void C_fcall C_reclaim(void *trampoline, C_word c)
+C_regparm void C_reclaim(void *trampoline, C_word c)
{
int i, j, fcount;
C_uword count;
@@ -3408,7 +3426,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, C_word c)
FINALIZER_NODE *flist;
C_DEBUG_INFO cell;
C_byte *tgt_space_start, **tgt_space_top, *tgt_space_limit;
-
+
/* assert(C_timer_interrupt_counter >= 0); */
if(pending_interrupts_count > 0 && C_interrupts_enabled) {
@@ -3464,7 +3482,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, C_word c)
goto never_mind_edsger;
}
- start = (C_byte *)C_align((C_uword)tospace_top);
+ start = (C_byte *)C_align((C_uword)tospace_top);
gc_mode = GC_MAJOR;
tgt_space_start = tospace_start;
tgt_space_top = &tospace_top;
@@ -3504,7 +3522,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, C_word c)
/* 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) {
+ 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_dbg(C_text("GC"), C_text("%d finalized item(s) still pending\n"), j);
@@ -3531,7 +3549,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, C_word c)
/* move into pending */
for(flist = finalizer_list; flist != NULL; flist = flist->next) {
if(j < C_max_pending_finalizers) {
- if(!is_fptr(C_block_header(flist->item)))
+ if(!is_fptr(C_block_header(flist->item)))
pending_finalizer_indices[ j++ ] = flist;
}
}
@@ -3552,13 +3570,13 @@ C_regparm void C_fcall C_reclaim(void *trampoline, C_word c)
finalizers_checked = 1;
if(pending_finalizer_count > 0 && gc_report_flag)
- C_dbg(C_text("GC"), C_text("%d finalizer(s) pending (%d live)\n"),
+ C_dbg(C_text("GC"), C_text("%d finalizer(s) pending (%d live)\n"),
pending_finalizer_count, live_finalizer_count);
/* Once more mark nested objects after (maybe) copying finalizer objects: */
mark_nested_objects(start, tgt_space_start, tgt_space_top, tgt_space_limit);
- /* Copy finalized items with remembered indices into `##sys#pending-finalizers'
+ /* Copy finalized items with remembered indices into `##sys#pending-finalizers'
(and release finalizer node): */
if(pending_finalizer_count > 0) {
if(gc_report_flag)
@@ -3572,7 +3590,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, C_word c)
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;
@@ -3643,7 +3661,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, C_word c)
timer_accumulated_gc_ms += tgc;
}
- /* Display GC report:
+ /* Display GC report:
Note: stubbornly writes to stderr - there is no provision for other output-ports */
if(gc_report_flag == 1 || (gc_report_flag && gc_mode == GC_MAJOR)) {
C_dbg(C_text("GC"), C_text("level %d\tgcs(minor) %d\tgcs(major) %d\n"),
@@ -3651,26 +3669,26 @@ C_regparm void C_fcall C_reclaim(void *trampoline, C_word c)
i = (C_uword)C_stack_pointer;
#if C_STACK_GROWS_DOWNWARD
- C_dbg("GC", C_text("stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),
+ C_dbg("GC", C_text("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_dbg("GC", C_text("stack\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING),
+ C_dbg("GC", C_text("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)
+ if(gc_mode == GC_MINOR)
C_fprintf(C_stderr, C_text("\t" UWORD_FORMAT_STRING), (C_uword)count);
C_fputc('\n', C_stderr);
C_dbg("GC", C_text(" 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)
+ if(gc_mode == GC_MAJOR)
C_fprintf(C_stderr, C_text("\t" UWORD_FORMAT_STRING), (C_uword)count);
C_fputc('\n', C_stderr);
- C_dbg("GC", C_text(" to\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING "\t" UWORD_FORMAT_STRING" \n"),
- (C_uword)tospace_start, (C_uword)tospace_top,
+ C_dbg("GC", C_text(" 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);
}
@@ -3704,7 +3722,7 @@ C_regparm void C_fcall C_reclaim(void *trampoline, C_word c)
/* Mark live objects which can exist in the nursery and/or the heap */
-static C_regparm void C_fcall mark_live_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)
+static C_regparm void mark_live_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)
{
C_word *p;
TRACE_INFO *tinfo;
@@ -3741,13 +3759,13 @@ static C_regparm void C_fcall mark_live_objects(C_byte *tgt_space_start, C_byte
* This function does not need to be called on a minor GC, since these
* objects won't ever exist in the nursery.
*/
-static C_regparm void C_fcall mark_live_heap_only_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)
+static C_regparm void mark_live_heap_only_objects(C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)
{
LF_LIST *lfn;
C_word *p, **msp, last;
unsigned int i;
C_SYMBOL_TABLE *stp;
-
+
/* Mark items in forwarding table: */
for(p = forwarding_table; *p != 0; p += 2) {
last = p[ 1 ];
@@ -3777,7 +3795,6 @@ static C_regparm void C_fcall mark_live_heap_only_objects(C_byte *tgt_space_star
mark(&pending_finalizers_symbol);
mark(¤t_thread_symbol);
- mark(&u8vector_symbol);
mark(&s8vector_symbol);
mark(&u16vector_symbol);
mark(&s16vector_symbol);
@@ -3794,7 +3811,7 @@ static C_regparm void C_fcall mark_live_heap_only_objects(C_byte *tgt_space_star
* Mark nested values in already moved (i.e., marked) blocks in
* breadth-first manner (Cheney's algorithm).
*/
-static C_regparm void C_fcall mark_nested_objects(C_byte *heap_scan_top, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)
+static C_regparm void mark_nested_objects(C_byte *heap_scan_top, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)
{
int n;
C_word bytes;
@@ -3805,7 +3822,7 @@ static C_regparm void C_fcall mark_nested_objects(C_byte *heap_scan_top, C_byte
while(heap_scan_top < *tgt_space_top) {
bp = (C_SCHEME_BLOCK *)heap_scan_top;
- if(*((C_word *)bp) == ALIGNMENT_HOLE_MARKER)
+ if(*((C_word *)bp) == ALIGNMENT_HOLE_MARKER)
bp = (C_SCHEME_BLOCK *)((C_word *)bp + 1);
n = C_header_size(bp);
@@ -3827,7 +3844,7 @@ static C_regparm void C_fcall mark_nested_objects(C_byte *heap_scan_top, C_byte
}
-static C_regparm void C_fcall really_mark(C_word *x, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)
+static C_regparm void really_mark(C_word *x, C_byte *tgt_space_start, C_byte **tgt_space_top, C_byte *tgt_space_limit)
{
C_word val;
C_uword n, bytes;
@@ -3838,7 +3855,7 @@ static C_regparm void C_fcall really_mark(C_word *x, C_byte *tgt_space_start, C_
if (!C_in_stackp(val) && !C_in_heapp(val) && !C_in_scratchspacep(val)) {
#ifdef C_GC_HOOKS
- if(C_gc_trace_hook != NULL)
+ if(C_gc_trace_hook != NULL)
C_gc_trace_hook(x, gc_mode);
#endif
return;
@@ -3880,7 +3897,7 @@ static C_regparm void C_fcall really_mark(C_word *x, C_byte *tgt_space_start, C_
panic(C_text("Detected corrupted data in heap"));
if(C_heap_size_is_fixed)
panic(C_text("out of memory - heap full"));
-
+
gc_mode = GC_REALLOC;
} else if (gc_mode == GC_REALLOC) {
if (new_tospace_top > new_tospace_limit) {
@@ -3914,7 +3931,7 @@ static C_regparm void C_fcall really_mark(C_word *x, C_byte *tgt_space_start, C_
#define remark(x) _mark(x, new_tospace_start, &new_tospace_top, new_tospace_limit)
-C_regparm void C_fcall C_rereclaim2(C_uword size, int relative_resize)
+C_regparm void C_rereclaim2(C_uword size, int relative_resize)
{
int i;
C_GC_ROOT *gcrp;
@@ -3964,7 +3981,7 @@ C_regparm void C_fcall C_rereclaim2(C_uword size, int relative_resize)
}
if(gc_report_flag) {
- C_dbg(C_text("GC"), C_text("(old) fromspace: \tstart=" UWORD_FORMAT_STRING
+ C_dbg(C_text("GC"), C_text("(old) fromspace: \tstart=" UWORD_FORMAT_STRING
", \tlimit=" UWORD_FORMAT_STRING "\n"),
(C_word)fromspace_start, (C_word)C_fromspace_limit);
C_dbg(C_text("GC"), C_text("(old) tospace: \tstart=" UWORD_FORMAT_STRING
@@ -3974,7 +3991,7 @@ C_regparm void C_fcall C_rereclaim2(C_uword size, int relative_resize)
heap_size = size; /* Total heap size of the two halves... */
size /= 2; /* ...each half is this big */
-
+
/*
* Start by allocating the new heap's fromspace. After remarking,
* allocate the other half of the new heap (its tospace).
@@ -4015,7 +4032,7 @@ C_regparm void C_fcall C_rereclaim2(C_uword size, int relative_resize)
heap_free (heapspace1, heapspace1_size);
heap_free (heapspace2, heapspace2_size);
-
+
if ((heapspace2 = heap_alloc (size, &tospace_start)) == NULL)
panic(C_text("out of memory - cannot allocate next heap segment"));
heapspace2_size = size;
@@ -4030,7 +4047,7 @@ C_regparm void C_fcall C_rereclaim2(C_uword size, int relative_resize)
if(gc_report_flag) {
C_dbg(C_text("GC"), C_text("resized heap to %d bytes\n"), heap_size);
- C_dbg(C_text("GC"), C_text("(new) fromspace: \tstart=" UWORD_FORMAT_STRING
+ C_dbg(C_text("GC"), C_text("(new) fromspace: \tstart=" UWORD_FORMAT_STRING
", \tlimit=" UWORD_FORMAT_STRING "\n"),
(C_word)fromspace_start, (C_word)C_fromspace_limit);
C_dbg(C_text("GC"), C_text("(new) tospace: \tstart=" UWORD_FORMAT_STRING
@@ -4056,7 +4073,7 @@ C_regparm void C_fcall C_rereclaim2(C_uword size, int relative_resize)
* can *only* contain weak-pairs-turned-forwarding-pointer, we may
* freely access the first slot of such forwarding pointers.
*/
-static C_regparm void C_fcall update_weak_pairs(int mode, C_byte *undead_start, C_byte *undead_end)
+static C_regparm void update_weak_pairs(int mode, C_byte *undead_start, C_byte *undead_end)
{
int weakn = 0;
C_word p, pair, car, h;
@@ -4115,7 +4132,7 @@ static C_regparm void C_fcall update_weak_pairs(int mode, C_byte *undead_start,
* so the updating of that pointer is not handled by the GC proper
* (which only deals with full objects).
*/
-static C_regparm void C_fcall update_locatives(int mode, C_byte *undead_start, C_byte *undead_end)
+static C_regparm void update_locatives(int mode, C_byte *undead_start, C_byte *undead_end)
{
int weakn = 0;
C_word p, loc, ptr, obj, h, offset;
@@ -4169,7 +4186,7 @@ void handle_interrupt(void *trampoline)
{
C_word *p, h, reason, state, proc, n;
double c;
- C_word av[ 4 ];
+ C_word av[ 4 ];
/* Build vector with context information: */
n = C_temporary_stack_bottom - C_temporary_stack;
@@ -4185,7 +4202,7 @@ void handle_interrupt(void *trampoline)
/* Restore state to the one at the time of the interrupt: */
C_temporary_stack = C_temporary_stack_bottom;
C_stack_limit = C_stack_hard_limit;
-
+
/* Invoke high-level interrupt handler: */
reason = C_fix(pending_interrupts[ --pending_interrupts_count ]);
proc = C_block_item(interrupt_hook_symbol, 0);
@@ -4205,16 +4222,23 @@ void handle_interrupt(void *trampoline)
}
-void
+void
C_unbound_variable(C_word sym)
{
barf(C_UNBOUND_VARIABLE_ERROR, NULL, sym);
}
+void
+C_decoding_error(C_word str, C_word index)
+{
+ barf(C_DECODING_ERROR, NULL, str, index);
+}
+
+
/* XXX: This needs to be given a better name.
C_retrieve used to exist but it just called C_fast_retrieve */
-C_regparm C_word C_fcall C_retrieve2(C_word val, char *name)
+C_regparm C_word C_retrieve2(C_word val, char *name)
{
C_word *p;
int len;
@@ -4234,11 +4258,11 @@ C_regparm C_word C_fcall C_retrieve2(C_word val, char *name)
void C_ccall C_invalid_procedure(C_word c, C_word *av)
{
C_word self = av[0];
- barf(C_NOT_A_CLOSURE_ERROR, NULL, self);
+ barf(C_NOT_A_CLOSURE_ERROR, NULL, self);
}
-C_regparm void *C_fcall C_retrieve2_symbol_proc(C_word val, char *name)
+C_regparm void *C_retrieve2_symbol_proc(C_word val, char *name)
{
C_word *p;
int len;
@@ -4318,7 +4342,7 @@ static void take_profile_sample()
}
/* We could also just hash the pointer but that's a bit trickier */
- bp = profile_table + hash_string(C_strlen(key), key, PROFILE_TABLE_SIZE, 0, 0);
+ bp = profile_table + hash_string(C_strlen(key), key, PROFILE_TABLE_SIZE, 0);
b = *bp;
/* First try to find pre-existing item in hash table */
@@ -4350,7 +4374,7 @@ done:
}
-C_regparm void C_fcall C_trace(C_char *name)
+C_regparm void C_trace(C_char *name)
{
C_word thread;
@@ -4385,7 +4409,7 @@ C_regparm void C_fcall C_trace(C_char *name)
}
-C_regparm C_word C_fcall C_emit_trace_info2(char *raw, C_word l, C_word x, C_word y, C_word t)
+C_regparm C_word C_emit_trace_info2(char *raw, C_word l, C_word x, C_word y, C_word t)
{
/* See above */
if(profiling && next_profile_bucket == NULL) {
@@ -4446,7 +4470,8 @@ C_char *C_dump_trace(int start)
if (ptr->raw_location != NULL) {
C_strlcat(result, ptr->raw_location, result_len);
} else if (ptr->cooked_location != C_SCHEME_FALSE) {
- C_strlcat(result, C_c_string(ptr->cooked_location), nmin(C_header_size(ptr->cooked_location), result_len));
+ C_word bv = C_block_item(ptr->cooked_location, 0);
+ C_strlcat(result, C_c_string(bv), nmin(C_header_size(bv) - 1, result_len));
} else {
C_strlcat(result, "<unknown>", result_len);
}
@@ -4460,7 +4485,7 @@ C_char *C_dump_trace(int start)
}
-C_regparm void C_fcall C_clear_trace_buffer(void)
+C_regparm void C_clear_trace_buffer(void)
{
int i, old_profiling = profiling;
@@ -4536,37 +4561,29 @@ C_word C_fetch_trace(C_word starti, C_word buffer)
return C_fix(p);
}
-C_regparm C_word C_fcall C_u_i_string_hash(C_word str, C_word rnd)
+C_regparm C_word C_u_i_bytevector_hash(C_word str, C_word start, C_word end, C_word rnd)
{
int len = C_header_size(str);
- C_char *ptr = C_data_pointer(str);
- return C_fix(hash_string(len, ptr, C_MOST_POSITIVE_FIXNUM, C_unfix(rnd), 0));
+ C_char *ptr = C_c_string(str);
+ return C_fix(hash_string(C_unfix(end) - C_unfix(start), ptr + C_unfix(start), C_MOST_POSITIVE_FIXNUM, C_unfix(rnd)));
}
-C_regparm C_word C_fcall C_u_i_string_ci_hash(C_word str, C_word rnd)
-{
- int len = C_header_size(str);
- C_char *ptr = C_data_pointer(str);
- return C_fix(hash_string(len, ptr, C_MOST_POSITIVE_FIXNUM, C_unfix(rnd), 1));
-}
-
-C_regparm void C_fcall C_toplevel_entry(C_char *name)
+C_regparm void C_toplevel_entry(C_char *name)
{
if(debug_mode)
C_dbg(C_text("debug"), C_text("entering %s...\n"), name);
}
-C_regparm C_word C_fcall C_a_i_provide(C_word **a, int c, C_word id)
+C_regparm C_word C_a_i_provide(C_word **a, int c, C_word id)
{
if (debug_mode == 2) {
C_word str = C_block_item(id, 1);
- C_snprintf(buffer, C_header_size(str) + 1, C_text("%s"), (C_char *) C_data_pointer(str));
- C_dbg(C_text("debug"), C_text("providing %s...\n"), buffer);
+ C_dbg(C_text("debug"), C_text("providing %s...\n"), C_c_string(str));
}
return C_a_i_putprop(a, 3, core_provided_symbol, id, C_SCHEME_TRUE);
}
-C_regparm C_word C_fcall C_i_providedp(C_word id)
+C_regparm C_word C_i_providedp(C_word id)
{
return C_i_getprop(core_provided_symbol, id, C_SCHEME_FALSE);
}
@@ -4590,7 +4607,7 @@ C_word C_halt(C_word msg)
if(dmp != NULL) C_strlcat(buffer, dmp, sizeof(buffer));
-#if defined(_WIN32) && !defined(__CYGWIN__)
+#if defined(_WIN32) && !defined(__CYGWIN__)
MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONERROR);
ExitProcess(1);
#endif
@@ -4601,9 +4618,9 @@ C_word C_halt(C_word msg)
C_fputc('\n', C_stderr);
}
- if(dmp != NULL)
+ if(dmp != NULL)
C_dbg("", C_text("\n%s"), dmp);
-
+
C_exit_runtime(C_fix(EX_SOFTWARE));
return 0;
}
@@ -4611,18 +4628,19 @@ C_word C_halt(C_word msg)
C_word C_message(C_word msg)
{
- unsigned int n = C_header_size(msg);
+ C_word m = C_block_item(msg, 0);
+ unsigned int n = C_header_size(m);
/*
* Strictly speaking this isn't necessary for the non-gui-mode,
* but let's try and keep this consistent across modes.
*/
- if (C_memchr(C_c_string(msg), '\0', n) != NULL)
+ if (C_memchr(C_c_string(m), '\0', n - 1) != NULL)
barf(C_ASCIIZ_REPRESENTATION_ERROR, "##sys#message", msg);
if(C_gui_mode) {
if (n >= sizeof(buffer))
n = sizeof(buffer) - 1;
- C_strncpy(buffer, C_c_string(msg), n);
+ C_strncpy(buffer, C_c_string(m), n);
buffer[ n ] = '\0';
#if defined(_WIN32) && !defined(__CYGWIN__)
MessageBox(NULL, buffer, C_text("CHICKEN runtime"), MB_OK | MB_ICONEXCLAMATION);
@@ -4630,13 +4648,13 @@ C_word C_message(C_word msg)
#endif
} /* fall through */
- C_fwrite(C_c_string(msg), n, sizeof(C_char), stdout);
+ C_fwrite(C_c_string(m), n, sizeof(C_char), stdout);
C_putchar('\n');
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_equalp(C_word x, C_word y)
+C_regparm C_word C_equalp(C_word x, C_word y)
{
C_header header;
C_word bits, n, i;
@@ -4656,6 +4674,8 @@ C_regparm C_word C_fcall C_equalp(C_word x, C_word y)
C_flonum_magnitude(y));
else return !C_memcmp(C_data_pointer(x), C_data_pointer(y), header & C_HEADER_SIZE_MASK);
}
+ else if(C_header_bits(x) == C_STRING_TYPE)
+ return C_equalp(C_block_item(x, 0), C_block_item(y, 0));
else if(header == C_SYMBOL_TAG) return 0;
else {
i = 0;
@@ -4684,7 +4704,7 @@ C_regparm C_word C_fcall C_equalp(C_word x, C_word y)
}
-C_regparm C_word C_fcall C_set_gc_report(C_word flag)
+C_regparm C_word 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;
@@ -4693,7 +4713,7 @@ C_regparm C_word C_fcall C_set_gc_report(C_word flag)
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_i_accumulated_gc_time(void)
+C_regparm C_word C_i_accumulated_gc_time(void)
{
double tgc;
@@ -4702,7 +4722,7 @@ C_regparm C_word C_fcall C_i_accumulated_gc_time(void)
return C_fix(tgc);
}
-C_regparm C_word C_fcall C_start_timer(void)
+C_regparm C_word C_start_timer(void)
{
tracked_mutation_count = 0;
mutation_count = 0;
@@ -4717,18 +4737,18 @@ C_regparm C_word C_fcall C_start_timer(void)
void C_ccall C_stop_timer(C_word c, C_word *av)
{
- C_word
+ C_word
closure = av[ 0 ],
k = av[ 1 ];
double t0 = C_cpu_milliseconds() - timer_start_ms;
- C_word
+ C_word
ab[ WORDS_PER_FLONUM * 2 + C_SIZEOF_BIGNUM(1) + C_SIZEOF_VECTOR(7) ],
*a = ab,
elapsed = C_flonum(&a, t0 / 1000.0),
gc_time = C_flonum(&a, gc_ms / 1000.0),
heap_usage = C_unsigned_int_to_num(&a, maximum_heap_usage),
info;
-
+
info = C_vector(&a, 7, elapsed, gc_time, C_fix(mutation_count),
C_fix(tracked_mutation_count), C_fix(gc_count_1_total),
C_fix(gc_count_2), heap_usage);
@@ -4743,66 +4763,55 @@ C_word C_exit_runtime(C_word code)
}
-C_regparm C_word C_fcall C_set_print_precision(C_word n)
+C_regparm C_word 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)
+C_regparm C_word C_get_print_precision(void)
{
return C_fix(flonum_print_precision);
}
-C_regparm C_word C_fcall C_read_char(C_word port)
+C_regparm C_word C_read_char(C_word port)
{
C_FILEPTR fp = C_port_file(port);
- int c = C_getc(fp);
+ C_char buf[ 5 ];
+ int n = 0, r, c;
- if(c == EOF) {
- if(ferror(fp)) {
- clearerr(fp);
- return C_fix(-1);
- }
+ do {
+ c = C_getc(fp);
+
+ if(c == EOF) {
+ if(ferror(fp)) {
+ clearerr(fp);
+ if(n == 0) return C_fix(-1);
+ }
/* Found here:
http://mail.python.org/pipermail/python-bugs-list/2002-July/012579.html */
#if defined(_WIN32) && !defined(__CYGWIN__)
- else if(GetLastError() == ERROR_OPERATION_ABORTED) return C_fix(-1);
+ else if(GetLastError() == ERROR_OPERATION_ABORTED) {
+ if(n == 0) return C_fix(-1);
+ }
#endif
- else return C_SCHEME_END_OF_FILE;
- }
-
- return 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);
-
- if(c == EOF) {
- if(ferror(fp)) {
- clearerr(fp);
- return C_fix(-1);
+ else if(n == 0) return C_SCHEME_END_OF_FILE;
}
- /* see above */
-#if defined(_WIN32) && !defined(__CYGWIN__)
- else if(GetLastError() == ERROR_OPERATION_ABORTED) return C_fix(-1);
-#endif
- else return C_SCHEME_END_OF_FILE;
- }
- C_ungetc(c, fp);
- return C_make_character(c);
+ if(n == 0) r = C_utf_expect(c);
+ buf[ n++ ] = c;
+ } while(n < r);
+
+ return C_utf_decode_ptr(buf);
}
-C_regparm C_word C_fcall C_execute_shell_command(C_word string)
+C_regparm C_word C_execute_shell_command(C_word string)
{
- int n = C_header_size(string);
+ C_word bv = C_block_item(string, 0);
+ int n = C_header_size(bv);
char *buf = buffer;
/* Windows doc says to flush all output streams before calling system.
@@ -4814,12 +4823,11 @@ C_regparm C_word C_fcall C_execute_shell_command(C_word string)
barf(C_OUT_OF_MEMORY_ERROR, "system");
}
- C_memcpy(buf, C_data_pointer(string), n);
- buf[ n ] = '\0';
- if (n != strlen(buf))
+ C_memcpy(buf, C_data_pointer(bv), n); /* includes 0 */
+ if (n - 1 != strlen(buf))
barf(C_ASCIIZ_REPRESENTATION_ERROR, "system", string);
- n = C_system(buf);
+ n = C_system(C_OS_FILENAME(bv, 0));
if(buf != buffer) C_free(buf);
@@ -4831,7 +4839,7 @@ C_regparm C_word C_fcall C_execute_shell_command(C_word string)
* arbitrary fds (there, select() only works on network sockets and
* poll() is not available at all).
*/
-C_regparm int C_fcall C_check_fd_ready(int fd)
+C_regparm int C_check_fd_ready(int fd)
{
#ifdef NO_POSIX_POLL
fd_set in;
@@ -4851,7 +4859,7 @@ C_regparm int C_fcall C_check_fd_ready(int fd)
#endif
}
-C_regparm C_word C_fcall C_char_ready_p(C_word port)
+C_regparm C_word C_char_ready_p(C_word port)
{
#if defined(C_NONUNIX)
/* The best we can currently do on Windows... */
@@ -4862,38 +4870,38 @@ C_regparm C_word C_fcall C_char_ready_p(C_word port)
#endif
}
-C_regparm C_word C_fcall C_i_tty_forcedp(void)
+C_regparm C_word C_i_tty_forcedp(void)
{
return C_mk_bool(fake_tty_flag);
}
-C_regparm C_word C_fcall C_i_debug_modep(void)
+C_regparm C_word C_i_debug_modep(void)
{
return C_mk_bool(debug_mode);
}
-C_regparm C_word C_fcall C_i_dump_heap_on_exitp(void)
+C_regparm C_word C_i_dump_heap_on_exitp(void)
{
return C_mk_bool(dump_heap_on_exit);
}
-C_regparm C_word C_fcall C_i_profilingp(void)
+C_regparm C_word C_i_profilingp(void)
{
return C_mk_bool(profiling);
}
-C_regparm C_word C_fcall C_i_live_finalizer_count(void)
+C_regparm C_word C_i_live_finalizer_count(void)
{
return C_fix(live_finalizer_count);
}
-C_regparm C_word C_fcall C_i_allocated_finalizer_count(void)
+C_regparm C_word C_i_allocated_finalizer_count(void)
{
return C_fix(allocated_finalizer_count);
}
-C_regparm void C_fcall C_raise_interrupt(int reason)
+C_regparm void C_raise_interrupt(int reason)
{
if(C_interrupts_enabled) {
if(pending_interrupts_count == 0 && !handling_interrupts) {
@@ -4921,7 +4929,7 @@ C_regparm void C_fcall C_raise_interrupt(int reason)
}
-C_regparm C_word C_fcall C_enable_interrupts(void)
+C_regparm C_word C_enable_interrupts(void)
{
C_timer_interrupt_counter = C_initial_timer_interrupt_period;
/* assert(C_timer_interrupt_counter > 0); */
@@ -4930,14 +4938,14 @@ C_regparm C_word C_fcall C_enable_interrupts(void)
}
-C_regparm C_word C_fcall C_disable_interrupts(void)
+C_regparm C_word 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)
+C_regparm C_word C_establish_signal_handler(C_word signum, C_word reason)
{
int sig = C_unfix(signum);
#if defined(HAVE_SIGACTION)
@@ -4967,7 +4975,7 @@ C_regparm C_word C_fcall C_establish_signal_handler(C_word signum, C_word reason
/* Copy blocks into collected or static memory: */
-C_regparm C_word C_fcall C_copy_block(C_word from, C_word to)
+C_regparm C_word C_copy_block(C_word from, C_word to)
{
int n = C_header_size(from);
C_long bytes;
@@ -4985,7 +4993,7 @@ C_regparm C_word C_fcall C_copy_block(C_word from, C_word to)
}
-C_regparm C_word C_fcall C_evict_block(C_word from, C_word ptr)
+C_regparm C_word C_evict_block(C_word from, C_word ptr)
{
int n = C_header_size(from);
C_long bytes;
@@ -5001,14 +5009,14 @@ C_regparm C_word C_fcall C_evict_block(C_word from, C_word ptr)
/* Inline versions of some standard procedures: */
-C_regparm C_word C_fcall C_i_listp(C_word x)
+C_regparm C_word C_i_listp(C_word x)
{
C_word fast = x, slow = x;
while(fast != C_SCHEME_END_OF_LIST)
if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {
fast = C_u_i_cdr(fast);
-
+
if(fast == C_SCHEME_END_OF_LIST) return C_SCHEME_TRUE;
else if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {
fast = C_u_i_cdr(fast);
@@ -5023,98 +5031,73 @@ C_regparm C_word C_fcall C_i_listp(C_word x)
return C_SCHEME_TRUE;
}
-C_regparm C_word C_fcall C_i_u8vectorp(C_word x)
-{
- return C_i_structurep(x, u8vector_symbol);
-}
-
-C_regparm C_word C_fcall C_i_s8vectorp(C_word x)
+C_regparm C_word C_i_s8vectorp(C_word x)
{
return C_i_structurep(x, s8vector_symbol);
}
-C_regparm C_word C_fcall C_i_u16vectorp(C_word x)
+C_regparm C_word C_i_u16vectorp(C_word x)
{
return C_i_structurep(x, u16vector_symbol);
}
-C_regparm C_word C_fcall C_i_s16vectorp(C_word x)
+C_regparm C_word C_i_s16vectorp(C_word x)
{
return C_i_structurep(x, s16vector_symbol);
}
-C_regparm C_word C_fcall C_i_u32vectorp(C_word x)
+C_regparm C_word C_i_u32vectorp(C_word x)
{
return C_i_structurep(x, u32vector_symbol);
}
-C_regparm C_word C_fcall C_i_s32vectorp(C_word x)
+C_regparm C_word C_i_s32vectorp(C_word x)
{
return C_i_structurep(x, s32vector_symbol);
}
-C_regparm C_word C_fcall C_i_u64vectorp(C_word x)
+C_regparm C_word C_i_u64vectorp(C_word x)
{
return C_i_structurep(x, u64vector_symbol);
}
-C_regparm C_word C_fcall C_i_s64vectorp(C_word x)
+C_regparm C_word C_i_s64vectorp(C_word x)
{
return C_i_structurep(x, s64vector_symbol);
}
-C_regparm C_word C_fcall C_i_f32vectorp(C_word x)
+C_regparm C_word C_i_f32vectorp(C_word x)
{
return C_i_structurep(x, f32vector_symbol);
}
-C_regparm C_word C_fcall C_i_f64vectorp(C_word x)
+C_regparm C_word C_i_f64vectorp(C_word x)
{
return C_i_structurep(x, f64vector_symbol);
}
-C_regparm C_word C_fcall C_i_string_equal_p(C_word x, C_word y)
+C_regparm C_word 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));
+ return C_utf_equal(x, y);
}
-C_regparm C_word C_fcall C_i_string_ci_equal_p(C_word x, C_word y)
+C_regparm C_word 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((int)(*(p1++))) != C_tolower((int)(*(p2++))))
- return C_SCHEME_FALSE;
- }
-
- return C_SCHEME_TRUE;
+ return C_utf_equal_ci(x, y);
}
@@ -5143,22 +5126,34 @@ C_word C_a_i_list(C_word **a, int c, ...)
C_word C_a_i_string(C_word **a, int c, ...)
{
va_list v;
- C_word x, s = (C_word)(*a);
+ C_word x, s, b;
char *p;
+ int len;
- *a = (C_word *)((C_word)(*a) + sizeof(C_header) + C_align(c));
- C_block_header_init(s, C_STRING_TYPE | c);
- p = (char *)C_data_pointer(s);
+ s = (C_word)(*a);
+ *a = (C_word *)((C_word)(*a) + sizeof(C_word) * 5); /* C_SIZEOF_STRING */
+ b = (C_word)(*a);
+
+ C_block_header_init(s, C_STRING_TAG);
+ C_set_block_item(s, 0, b);
+ C_set_block_item(s, 1, C_fix(c));
+ C_set_block_item(s, 2, C_fix(0));
+ C_set_block_item(s, 3, C_fix(0));
+ p = (char *)C_data_pointer(b);
va_start(v, c);
for(; c; c--) {
x = va_arg(v, C_word);
if((x & C_IMMEDIATE_TYPE_BITS) == C_CHARACTER_BITS)
- *(p++) = C_character_code(x);
+ p = C_utf_encode(p, C_character_code(x));
else break;
}
+ len = p - (char *)C_data_pointer(b) + 1;
+ *a = (C_word *)((C_word)(*a) + sizeof(C_header) + C_align(len));
+ *p = '\0';
+ C_block_header_init(b, C_BYTEVECTOR_TYPE | len);
va_end(v);
if (c) barf(C_BAD_ARGUMENT_TYPE_ERROR, "string", x);
return s;
@@ -5169,7 +5164,7 @@ C_word C_a_i_record(C_word **ptr, int n, ...)
{
va_list v;
C_word *p = *ptr,
- *p0 = p;
+ *p0 = p;
*(p++) = C_STRUCTURE_TYPE | n;
va_start(v, n);
@@ -5185,14 +5180,14 @@ C_word C_a_i_record(C_word **ptr, int n, ...)
C_word C_a_i_port(C_word **ptr, int n)
{
- C_word
+ C_word
*p = *ptr,
- *p0 = p;
+ *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;
@@ -5201,7 +5196,7 @@ C_word C_a_i_port(C_word **ptr, int n)
}
-C_regparm C_word C_fcall C_a_i_bytevector(C_word **ptr, int c, C_word num)
+C_regparm C_word C_a_i_bytevector(C_word **ptr, int c, C_word num)
{
C_word *p = *ptr,
*p0;
@@ -5219,9 +5214,9 @@ C_regparm C_word C_fcall C_a_i_bytevector(C_word **ptr, int c, C_word num)
}
-C_word C_fcall C_a_i_smart_mpointer(C_word **ptr, int c, C_word x)
+C_word C_a_i_smart_mpointer(C_word **ptr, int c, C_word x)
{
- C_word
+ C_word
*p = *ptr,
*p0 = p;
void *mp;
@@ -5236,7 +5231,7 @@ C_word C_fcall C_a_i_smart_mpointer(C_word **ptr, int c, C_word x)
return (C_word)p0;
}
-C_regparm C_word C_fcall C_i_nanp(C_word x)
+C_regparm C_word C_i_nanp(C_word x)
{
if (x & C_FIXNUM_BIT) {
return C_SCHEME_FALSE;
@@ -5256,7 +5251,7 @@ C_regparm C_word C_fcall C_i_nanp(C_word x)
}
}
-C_regparm C_word C_fcall C_i_finitep(C_word x)
+C_regparm C_word C_i_finitep(C_word x)
{
if (x & C_FIXNUM_BIT) {
return C_SCHEME_TRUE;
@@ -5276,7 +5271,7 @@ C_regparm C_word C_fcall C_i_finitep(C_word x)
}
}
-C_regparm C_word C_fcall C_i_infinitep(C_word x)
+C_regparm C_word C_i_infinitep(C_word x)
{
if (x & C_FIXNUM_BIT) {
return C_SCHEME_FALSE;
@@ -5296,7 +5291,7 @@ C_regparm C_word C_fcall C_i_infinitep(C_word x)
}
}
-C_regparm C_word C_fcall C_i_exactp(C_word x)
+C_regparm C_word C_i_exactp(C_word x)
{
if (x & C_FIXNUM_BIT) {
return C_SCHEME_TRUE;
@@ -5316,7 +5311,7 @@ C_regparm C_word C_fcall C_i_exactp(C_word x)
}
-C_regparm C_word C_fcall C_i_inexactp(C_word x)
+C_regparm C_word C_i_inexactp(C_word x)
{
if (x & C_FIXNUM_BIT) {
return C_SCHEME_FALSE;
@@ -5336,7 +5331,7 @@ C_regparm C_word C_fcall C_i_inexactp(C_word x)
}
-C_regparm C_word C_fcall C_i_zerop(C_word x)
+C_regparm C_word C_i_zerop(C_word x)
{
if (x & C_FIXNUM_BIT) {
return C_mk_bool(x == C_fix(0));
@@ -5354,7 +5349,7 @@ C_regparm C_word C_fcall C_i_zerop(C_word x)
}
/* DEPRECATED */
-C_regparm C_word C_fcall C_u_i_zerop(C_word x)
+C_regparm C_word C_u_i_zerop(C_word x)
{
return C_mk_bool(x == C_fix(0) ||
(!C_immediatep(x) &&
@@ -5363,7 +5358,7 @@ C_regparm C_word C_fcall C_u_i_zerop(C_word x)
}
-C_regparm C_word C_fcall C_i_positivep(C_word x)
+C_regparm C_word C_i_positivep(C_word x)
{
if (x & C_FIXNUM_BIT)
return C_i_fixnum_positivep(x);
@@ -5381,13 +5376,13 @@ C_regparm C_word C_fcall C_i_positivep(C_word x)
barf(C_BAD_ARGUMENT_TYPE_NO_NUMBER_ERROR, "positive?", x);
}
-C_regparm C_word C_fcall C_i_integer_positivep(C_word x)
+C_regparm C_word C_i_integer_positivep(C_word x)
{
if (x & C_FIXNUM_BIT) return C_i_fixnum_positivep(x);
else return C_mk_nbool(C_bignum_negativep(x));
}
-C_regparm C_word C_fcall C_i_negativep(C_word x)
+C_regparm C_word C_i_negativep(C_word x)
{
if (x & C_FIXNUM_BIT)
return C_i_fixnum_negativep(x);
@@ -5406,14 +5401,14 @@ C_regparm C_word C_fcall C_i_negativep(C_word x)
}
-C_regparm C_word C_fcall C_i_integer_negativep(C_word x)
+C_regparm C_word C_i_integer_negativep(C_word x)
{
if (x & C_FIXNUM_BIT) return C_i_fixnum_negativep(x);
else return C_mk_bool(C_bignum_negativep(x));
}
-C_regparm C_word C_fcall C_i_evenp(C_word x)
+C_regparm C_word C_i_evenp(C_word x)
{
if(x & C_FIXNUM_BIT) {
return C_i_fixnumevenp(x);
@@ -5433,14 +5428,14 @@ C_regparm C_word C_fcall C_i_evenp(C_word x)
}
}
-C_regparm C_word C_fcall C_i_integer_evenp(C_word x)
+C_regparm C_word C_i_integer_evenp(C_word x)
{
if (x & C_FIXNUM_BIT) return C_i_fixnumevenp(x);
return C_mk_nbool(C_bignum_digits(x)[0] & 1);
}
-C_regparm C_word C_fcall C_i_oddp(C_word x)
+C_regparm C_word C_i_oddp(C_word x)
{
if(x & C_FIXNUM_BIT) {
return C_i_fixnumoddp(x);
@@ -5461,14 +5456,14 @@ C_regparm C_word C_fcall C_i_oddp(C_word x)
}
-C_regparm C_word C_fcall C_i_integer_oddp(C_word x)
+C_regparm C_word C_i_integer_oddp(C_word x)
{
if (x & C_FIXNUM_BIT) return C_i_fixnumoddp(x);
return C_mk_bool(C_bignum_digits(x)[0] & 1);
}
-C_regparm C_word C_fcall C_i_car(C_word x)
+C_regparm C_word C_i_car(C_word x)
{
if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)
barf(C_BAD_ARGUMENT_TYPE_ERROR, "car", x);
@@ -5477,7 +5472,7 @@ C_regparm C_word C_fcall C_i_car(C_word x)
}
-C_regparm C_word C_fcall C_i_cdr(C_word x)
+C_regparm C_word C_i_cdr(C_word x)
{
if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)
barf(C_BAD_ARGUMENT_TYPE_ERROR, "cdr", x);
@@ -5486,7 +5481,7 @@ C_regparm C_word C_fcall C_i_cdr(C_word x)
}
-C_regparm C_word C_fcall C_i_caar(C_word x)
+C_regparm C_word C_i_caar(C_word x)
{
if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {
bad:
@@ -5501,7 +5496,7 @@ C_regparm C_word C_fcall C_i_caar(C_word x)
}
-C_regparm C_word C_fcall C_i_cadr(C_word x)
+C_regparm C_word C_i_cadr(C_word x)
{
if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {
bad:
@@ -5516,7 +5511,7 @@ C_regparm C_word C_fcall C_i_cadr(C_word x)
}
-C_regparm C_word C_fcall C_i_cdar(C_word x)
+C_regparm C_word C_i_cdar(C_word x)
{
if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {
bad:
@@ -5531,7 +5526,7 @@ C_regparm C_word C_fcall C_i_cdar(C_word x)
}
-C_regparm C_word C_fcall C_i_cddr(C_word x)
+C_regparm C_word C_i_cddr(C_word x)
{
if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {
bad:
@@ -5545,7 +5540,7 @@ C_regparm C_word C_fcall C_i_cddr(C_word x)
}
-C_regparm C_word C_fcall C_i_caddr(C_word x)
+C_regparm C_word C_i_caddr(C_word x)
{
if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {
bad:
@@ -5561,7 +5556,7 @@ C_regparm C_word C_fcall C_i_caddr(C_word x)
}
-C_regparm C_word C_fcall C_i_cdddr(C_word x)
+C_regparm C_word C_i_cdddr(C_word x)
{
if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {
bad:
@@ -5577,7 +5572,7 @@ C_regparm C_word C_fcall C_i_cdddr(C_word x)
}
-C_regparm C_word C_fcall C_i_cadddr(C_word x)
+C_regparm C_word C_i_cadddr(C_word x)
{
if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {
bad:
@@ -5595,7 +5590,7 @@ C_regparm C_word C_fcall C_i_cadddr(C_word x)
}
-C_regparm C_word C_fcall C_i_cddddr(C_word x)
+C_regparm C_word C_i_cddddr(C_word x)
{
if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {
bad:
@@ -5613,12 +5608,12 @@ C_regparm C_word C_fcall C_i_cddddr(C_word x)
}
-C_regparm C_word C_fcall C_i_list_tail(C_word lst, C_word i)
+C_regparm C_word C_i_list_tail(C_word lst, C_word i)
{
C_word lst0 = lst;
int n;
- if(lst != C_SCHEME_END_OF_LIST &&
+ if(lst != C_SCHEME_END_OF_LIST &&
(C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE))
barf(C_BAD_ARGUMENT_TYPE_ERROR, "list-tail", lst);
@@ -5627,8 +5622,8 @@ C_regparm C_word C_fcall C_i_list_tail(C_word lst, C_word i)
while(n--) {
if(C_immediatep(lst) || C_header_type(lst) != C_PAIR_TYPE)
- barf(C_OUT_OF_RANGE_ERROR, "list-tail", lst0, i);
-
+ barf(C_OUT_OF_BOUNDS_ERROR, "list-tail", lst0, i);
+
lst = C_u_i_cdr(lst);
}
@@ -5636,7 +5631,7 @@ C_regparm C_word C_fcall C_i_list_tail(C_word lst, C_word i)
}
-C_regparm C_word C_fcall C_i_vector_ref(C_word v, C_word i)
+C_regparm C_word C_i_vector_ref(C_word v, C_word i)
{
int j;
@@ -5646,36 +5641,36 @@ C_regparm C_word C_fcall C_i_vector_ref(C_word v, C_word i)
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);
+ if(j < 0 || j >= C_header_size(v)) barf(C_OUT_OF_BOUNDS_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_u8vector_ref(C_word v, C_word i)
+C_regparm C_word C_i_bytevector_ref(C_word v, C_word i)
{
int j;
- if(!C_truep(C_i_u8vectorp(v)))
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-ref", v);
+ if(!C_truep(C_bytevectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-u8-ref", v);
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= C_header_size(C_block_item(v, 1))) barf(C_OUT_OF_RANGE_ERROR, "u8vector-ref", v, i);
+ if(j < 0 || j >= C_header_size(v))
+ barf(C_OUT_OF_BOUNDS_ERROR, "bytevector-u8-ref", v, i);
- return C_fix(((unsigned char *)C_data_pointer(C_block_item(v, 1)))[j]);
+ return C_fix(((unsigned char *)C_data_pointer(v))[j]);
}
-
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-ref", i);
+
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-u8-ref", i);
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_i_s8vector_ref(C_word v, C_word i)
+C_regparm C_word C_i_s8vector_ref(C_word v, C_word i)
{
int j;
@@ -5685,16 +5680,17 @@ C_regparm C_word C_fcall C_i_s8vector_ref(C_word v, C_word i)
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= C_header_size(C_block_item(v, 1))) barf(C_OUT_OF_RANGE_ERROR, "s8vector-ref", v, i);
+ if(j < 0 || j >= C_header_size(C_block_item(v, 1)))
+ barf(C_OUT_OF_BOUNDS_ERROR, "s8vector-ref", v, i);
return C_fix(((signed char *)C_data_pointer(C_block_item(v, 1)))[j]);
}
-
+
barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-ref", i);
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_i_u16vector_ref(C_word v, C_word i)
+C_regparm C_word C_i_u16vector_ref(C_word v, C_word i)
{
int j;
@@ -5704,16 +5700,17 @@ C_regparm C_word C_fcall C_i_u16vector_ref(C_word v, C_word i)
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1)) barf(C_OUT_OF_RANGE_ERROR, "u16vector-ref", v, i);
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1))
+ barf(C_OUT_OF_BOUNDS_ERROR, "u16vector-ref", v, i);
return C_fix(((unsigned short *)C_data_pointer(C_block_item(v, 1)))[j]);
}
-
+
barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-ref", i);
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_i_s16vector_ref(C_word v, C_word i)
+C_regparm C_word C_i_s16vector_ref(C_word v, C_word i)
{
C_word size;
int j;
@@ -5725,16 +5722,17 @@ C_regparm C_word C_fcall C_i_s16vector_ref(C_word v, C_word i)
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1)) barf(C_OUT_OF_RANGE_ERROR, "u16vector-ref", v, i);
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1))
+ barf(C_OUT_OF_BOUNDS_ERROR, "u16vector-ref", v, i);
return C_fix(((signed short *)C_data_pointer(C_block_item(v, 1)))[j]);
}
-
+
barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-ref", i);
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_a_i_u32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
+C_regparm C_word C_a_i_u32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
{
int j;
@@ -5744,16 +5742,17 @@ C_regparm C_word C_fcall C_a_i_u32vector_ref(C_word **ptr, C_word c, C_word v, C
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "u32vector-ref", v, i);
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))
+ barf(C_OUT_OF_BOUNDS_ERROR, "u32vector-ref", v, i);
return C_unsigned_int_to_num(ptr, ((C_u32 *)C_data_pointer(C_block_item(v, 1)))[j]);
}
-
+
barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-ref", i);
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_a_i_s32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
+C_regparm C_word C_a_i_s32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
{
int j;
@@ -5763,16 +5762,17 @@ C_regparm C_word C_fcall C_a_i_s32vector_ref(C_word **ptr, C_word c, C_word v, C
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "s32vector-ref", v, i);
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))
+ barf(C_OUT_OF_BOUNDS_ERROR, "s32vector-ref", v, i);
return C_int_to_num(ptr, ((C_s32 *)C_data_pointer(C_block_item(v, 1)))[j]);
}
-
+
barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-ref", i);
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_a_i_u64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
+C_regparm C_word C_a_i_u64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
{
int j;
@@ -5782,16 +5782,17 @@ C_regparm C_word C_fcall C_a_i_u64vector_ref(C_word **ptr, C_word c, C_word v, C
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "u64vector-ref", v, i);
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))
+ barf(C_OUT_OF_BOUNDS_ERROR, "u64vector-ref", v, i);
return C_uint64_to_num(ptr, ((C_u64 *)C_data_pointer(C_block_item(v, 1)))[j]);
}
-
+
barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-ref", i);
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_a_i_s64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
+C_regparm C_word C_a_i_s64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
{
int j;
@@ -5801,16 +5802,17 @@ C_regparm C_word C_fcall C_a_i_s64vector_ref(C_word **ptr, C_word c, C_word v, C
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "s64vector-ref", v, i);
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))
+ barf(C_OUT_OF_BOUNDS_ERROR, "s64vector-ref", v, i);
return C_int64_to_num(ptr, ((C_s64 *)C_data_pointer(C_block_item(v, 1)))[j]);
}
-
+
barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-ref", i);
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_a_i_f32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
+C_regparm C_word C_a_i_f32vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
{
int j;
@@ -5820,16 +5822,17 @@ C_regparm C_word C_fcall C_a_i_f32vector_ref(C_word **ptr, C_word c, C_word v, C
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "f32vector-ref", v, i);
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))
+ barf(C_OUT_OF_BOUNDS_ERROR, "f32vector-ref", v, i);
return C_flonum(ptr, ((float *)C_data_pointer(C_block_item(v, 1)))[j]);
}
-
+
barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-ref", i);
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_a_i_f64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
+C_regparm C_word C_a_i_f64vector_ref(C_word **ptr, C_word c, C_word v, C_word i)
{
C_word size;
int j;
@@ -5840,17 +5843,18 @@ C_regparm C_word C_fcall C_a_i_f64vector_ref(C_word **ptr, C_word c, C_word v, C
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "f64vector-ref", v, i);
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))
+ barf(C_OUT_OF_BOUNDS_ERROR, "f64vector-ref", v, i);
return C_flonum(ptr, ((double *)C_data_pointer(C_block_item(v, 1)))[j]);
}
-
+
barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-ref", i);
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_i_block_ref(C_word x, C_word i)
+C_regparm C_word C_i_block_ref(C_word x, C_word i)
{
int j;
@@ -5860,17 +5864,18 @@ C_regparm C_word C_fcall C_i_block_ref(C_word x, C_word i)
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);
+ if(j < 0 || j >= C_header_size(x))
+ barf(C_OUT_OF_BOUNDS_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)
+C_regparm C_word C_i_string_set(C_word s, C_word i, C_word c)
{
int j;
@@ -5883,9 +5888,10 @@ C_regparm C_word C_fcall C_i_string_set(C_word s, C_word i, C_word 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);
+ if(j < 0 || j >= C_unfix(C_block_item(s, 1)))
+ barf(C_OUT_OF_BOUNDS_ERROR, "string-set!", s, i);
- return C_setsubchar(s, i, c);
+ return C_utf_setsubchar(s, i, c);
}
barf(C_BAD_ARGUMENT_TYPE_ERROR, "string-set!", i);
@@ -5893,7 +5899,7 @@ C_regparm C_word C_fcall C_i_string_set(C_word s, C_word i, C_word c)
}
-C_regparm C_word C_fcall C_i_string_ref(C_word s, C_word i)
+C_regparm C_word C_i_string_ref(C_word s, C_word i)
{
int j;
@@ -5903,17 +5909,18 @@ C_regparm C_word C_fcall C_i_string_ref(C_word s, C_word i)
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);
+ if(j < 0 || j >= C_unfix(C_block_item(s, 1)))
+ barf(C_OUT_OF_BOUNDS_ERROR, "string-ref", s, i);
- return C_subchar(s, i);
+ return C_utf_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)
+C_regparm C_word 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);
@@ -5921,15 +5928,15 @@ C_regparm C_word C_fcall C_i_vector_length(C_word v)
return C_fix(C_header_size(v));
}
-C_regparm C_word C_fcall C_i_u8vector_length(C_word v)
+C_regparm C_word C_i_bytevector_length(C_word v)
{
- if(!C_truep(C_i_u8vectorp(v)))
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-length", v);
+ if(!C_truep(C_bytevectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-length", v);
- return C_fix(C_header_size(C_block_item(v, 1)));
+ return C_fix(C_header_size(v));
}
-C_regparm C_word C_fcall C_i_s8vector_length(C_word v)
+C_regparm C_word C_i_s8vector_length(C_word v)
{
if(!C_truep(C_i_s8vectorp(v)))
barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-length", v);
@@ -5937,7 +5944,7 @@ C_regparm C_word C_fcall C_i_s8vector_length(C_word v)
return C_fix(C_header_size(C_block_item(v, 1)));
}
-C_regparm C_word C_fcall C_i_u16vector_length(C_word v)
+C_regparm C_word C_i_u16vector_length(C_word v)
{
if(!C_truep(C_i_u16vectorp(v)))
barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-length", v);
@@ -5945,7 +5952,7 @@ C_regparm C_word C_fcall C_i_u16vector_length(C_word v)
return C_fix(C_header_size(C_block_item(v, 1)) >> 1);
}
-C_regparm C_word C_fcall C_i_s16vector_length(C_word v)
+C_regparm C_word C_i_s16vector_length(C_word v)
{
if(!C_truep(C_i_s16vectorp(v)))
barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-length", v);
@@ -5953,7 +5960,7 @@ C_regparm C_word C_fcall C_i_s16vector_length(C_word v)
return C_fix(C_header_size(C_block_item(v, 1)) >> 1);
}
-C_regparm C_word C_fcall C_i_u32vector_length(C_word v)
+C_regparm C_word C_i_u32vector_length(C_word v)
{
if(!C_truep(C_i_u32vectorp(v)))
barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-length", v);
@@ -5961,7 +5968,7 @@ C_regparm C_word C_fcall C_i_u32vector_length(C_word v)
return C_fix(C_header_size(C_block_item(v, 1)) >> 2);
}
-C_regparm C_word C_fcall C_i_s32vector_length(C_word v)
+C_regparm C_word C_i_s32vector_length(C_word v)
{
if(!C_truep(C_i_s32vectorp(v)))
barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-length", v);
@@ -5969,7 +5976,7 @@ C_regparm C_word C_fcall C_i_s32vector_length(C_word v)
return C_fix(C_header_size(C_block_item(v, 1)) >> 2);
}
-C_regparm C_word C_fcall C_i_u64vector_length(C_word v)
+C_regparm C_word C_i_u64vector_length(C_word v)
{
if(!C_truep(C_i_u64vectorp(v)))
barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-length", v);
@@ -5977,7 +5984,7 @@ C_regparm C_word C_fcall C_i_u64vector_length(C_word v)
return C_fix(C_header_size(C_block_item(v, 1)) >> 3);
}
-C_regparm C_word C_fcall C_i_s64vector_length(C_word v)
+C_regparm C_word C_i_s64vector_length(C_word v)
{
if(!C_truep(C_i_s64vectorp(v)))
barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-length", v);
@@ -5986,7 +5993,7 @@ C_regparm C_word C_fcall C_i_s64vector_length(C_word v)
}
-C_regparm C_word C_fcall C_i_f32vector_length(C_word v)
+C_regparm C_word C_i_f32vector_length(C_word v)
{
if(!C_truep(C_i_f32vectorp(v)))
barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-length", v);
@@ -5994,7 +6001,7 @@ C_regparm C_word C_fcall C_i_f32vector_length(C_word v)
return C_fix(C_header_size(C_block_item(v, 1)) >> 2);
}
-C_regparm C_word C_fcall C_i_f64vector_length(C_word v)
+C_regparm C_word C_i_f64vector_length(C_word v)
{
if(!C_truep(C_i_f64vectorp(v)))
barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-length", v);
@@ -6003,16 +6010,16 @@ C_regparm C_word C_fcall C_i_f64vector_length(C_word v)
}
-C_regparm C_word C_fcall C_i_string_length(C_word s)
+C_regparm C_word 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));
+ return C_block_item(s, 1);
}
-C_regparm C_word C_fcall C_i_length(C_word lst)
+C_regparm C_word C_i_length(C_word lst)
{
C_word fast = lst, slow = lst;
int n = 0;
@@ -6021,7 +6028,7 @@ C_regparm C_word C_fcall C_i_length(C_word lst)
if(fast != C_SCHEME_END_OF_LIST) {
if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {
fast = C_u_i_cdr(fast);
-
+
if(fast != C_SCHEME_END_OF_LIST) {
if(!C_immediatep(fast) && C_header_type(fast) == C_PAIR_TYPE) {
fast = C_u_i_cdr(fast);
@@ -6029,7 +6036,7 @@ C_regparm C_word C_fcall C_i_length(C_word lst)
else barf(C_NOT_A_PROPER_LIST_ERROR, "length", lst);
}
- if(fast == slow)
+ if(fast == slow)
barf(C_BAD_ARGUMENT_TYPE_CYCLIC_LIST_ERROR, "length", lst);
}
}
@@ -6045,7 +6052,7 @@ C_regparm C_word C_fcall C_i_length(C_word lst)
}
-C_regparm C_word C_fcall C_u_i_length(C_word lst)
+C_regparm C_word C_u_i_length(C_word lst)
{
int n = 0;
@@ -6057,7 +6064,7 @@ C_regparm C_word C_fcall C_u_i_length(C_word lst)
return C_fix(n);
}
-C_regparm C_word C_fcall C_i_set_car(C_word x, C_word val)
+C_regparm C_word C_i_set_car(C_word x, C_word val)
{
if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)
barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-car!", x);
@@ -6067,7 +6074,7 @@ C_regparm C_word C_fcall C_i_set_car(C_word x, C_word val)
}
-C_regparm C_word C_fcall C_i_set_cdr(C_word x, C_word val)
+C_regparm C_word C_i_set_cdr(C_word x, C_word val)
{
if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)
barf(C_BAD_ARGUMENT_TYPE_ERROR, "set-cdr!", x);
@@ -6077,7 +6084,7 @@ C_regparm C_word C_fcall C_i_set_cdr(C_word x, C_word val)
}
-C_regparm C_word C_fcall C_i_vector_set(C_word v, C_word i, C_word x)
+C_regparm C_word C_i_vector_set(C_word v, C_word i, C_word x)
{
int j;
@@ -6087,7 +6094,8 @@ C_regparm C_word C_fcall C_i_vector_set(C_word v, C_word i, C_word x)
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);
+ if(j < 0 || j >= C_header_size(v))
+ barf(C_OUT_OF_BOUNDS_ERROR, "vector-set!", v, i);
C_mutate(&C_block_item(v, j), x);
}
@@ -6096,33 +6104,33 @@ C_regparm C_word C_fcall C_i_vector_set(C_word v, C_word i, C_word x)
return C_SCHEME_UNDEFINED;
}
-
-C_regparm C_word C_fcall C_i_u8vector_set(C_word v, C_word i, C_word x)
+C_regparm C_word C_i_bytevector_set(C_word v, C_word i, C_word x)
{
int j;
C_word n;
- if(!C_truep(C_i_u8vectorp(v)))
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-set!", v);
+ if(!C_truep(C_bytevectorp(v)))
+ barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-set!", v);
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= C_header_size(C_block_item(v, 1))) barf(C_OUT_OF_RANGE_ERROR, "u8vector-set!", v, i);
+ if(j < 0 || j >= C_header_size(v))
+ barf(C_OUT_OF_BOUNDS_ERROR, "bytevector-u8-set!", v, i);
if(x & C_FIXNUM_BIT) {
- if (!(x & C_INT_SIGN_BIT) && C_ilen(C_unfix(x)) <= 8) n = C_unfix(x);
- else barf(C_OUT_OF_RANGE_ERROR, "u8vector-set!", x);
+ if (C_unfix(C_i_fixnum_length(x)) <= 8) n = C_unfix(x);
+ else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "bytevector-u8-set!", x);
}
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-set!", x);
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-u8-set!", x);
}
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u8vector-set!", i);
+ else barf(C_BAD_ARGUMENT_TYPE_ERROR, "bytevector-u8-set!", i);
- ((unsigned char *)C_data_pointer(C_block_item(v, 1)))[j] = n;
+ ((signed char *)C_data_pointer(v))[j] = n;
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_i_s8vector_set(C_word v, C_word i, C_word x)
+C_regparm C_word C_i_s8vector_set(C_word v, C_word i, C_word x)
{
int j;
C_word n;
@@ -6133,11 +6141,12 @@ C_regparm C_word C_fcall C_i_s8vector_set(C_word v, C_word i, C_word x)
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= C_header_size(C_block_item(v, 1))) barf(C_OUT_OF_RANGE_ERROR, "s8vector-set!", v, i);
+ if(j < 0 || j >= C_header_size(C_block_item(v, 1)))
+ barf(C_OUT_OF_BOUNDS_ERROR, "s8vector-set!", v, i);
if(x & C_FIXNUM_BIT) {
if (C_unfix(C_i_fixnum_length(x)) <= 8) n = C_unfix(x);
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", x);
+ else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "s8vector-set!", x);
}
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s8vector-set!", x);
}
@@ -6147,7 +6156,7 @@ C_regparm C_word C_fcall C_i_s8vector_set(C_word v, C_word i, C_word x)
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_i_u16vector_set(C_word v, C_word i, C_word x)
+C_regparm C_word C_i_u16vector_set(C_word v, C_word i, C_word x)
{
int j;
C_word n;
@@ -6158,11 +6167,12 @@ C_regparm C_word C_fcall C_i_u16vector_set(C_word v, C_word i, C_word x)
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1)) barf(C_OUT_OF_RANGE_ERROR, "u16vector-set!", v, i);
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1))
+ barf(C_OUT_OF_BOUNDS_ERROR, "u16vector-set!", v, i);
if(x & C_FIXNUM_BIT) {
if (!(x & C_INT_SIGN_BIT) && C_ilen(C_unfix(x)) <= 16) n = C_unfix(x);
- else barf(C_OUT_OF_RANGE_ERROR, "u16vector-set!", x);
+ else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "u16vector-set!", x);
}
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u16vector-set!", x);
}
@@ -6172,7 +6182,7 @@ C_regparm C_word C_fcall C_i_u16vector_set(C_word v, C_word i, C_word x)
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_i_s16vector_set(C_word v, C_word i, C_word x)
+C_regparm C_word C_i_s16vector_set(C_word v, C_word i, C_word x)
{
int j;
C_word n;
@@ -6183,11 +6193,12 @@ C_regparm C_word C_fcall C_i_s16vector_set(C_word v, C_word i, C_word x)
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1)) barf(C_OUT_OF_RANGE_ERROR, "u16vector-set!", v, i);
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 1))
+ barf(C_OUT_OF_BOUNDS_ERROR, "u16vector-set!", v, i);
if(x & C_FIXNUM_BIT) {
if (C_unfix(C_i_fixnum_length(x)) <= 16) n = C_unfix(x);
- else barf(C_OUT_OF_RANGE_ERROR, "s16vector-set!", x);
+ else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "s16vector-set!", x);
}
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s16vector-set!", x);
}
@@ -6197,7 +6208,7 @@ C_regparm C_word C_fcall C_i_s16vector_set(C_word v, C_word i, C_word x)
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_i_u32vector_set(C_word v, C_word i, C_word x)
+C_regparm C_word C_i_u32vector_set(C_word v, C_word i, C_word x)
{
int j;
C_u32 n;
@@ -6208,11 +6219,12 @@ C_regparm C_word C_fcall C_i_u32vector_set(C_word v, C_word i, C_word x)
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "u32vector-set!", v, i);
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))
+ barf(C_OUT_OF_BOUNDS_ERROR, "u32vector-set!", v, i);
if(C_truep(C_i_exact_integerp(x))) {
if (C_unfix(C_i_integer_length(x)) <= 32) n = C_num_to_unsigned_int(x);
- else barf(C_OUT_OF_RANGE_ERROR, "u32vector-set!", x);
+ else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "u32vector-set!", x);
}
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u32vector-set!", x);
}
@@ -6222,7 +6234,7 @@ C_regparm C_word C_fcall C_i_u32vector_set(C_word v, C_word i, C_word x)
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_i_s32vector_set(C_word v, C_word i, C_word x)
+C_regparm C_word C_i_s32vector_set(C_word v, C_word i, C_word x)
{
int j;
C_s32 n;
@@ -6233,11 +6245,12 @@ C_regparm C_word C_fcall C_i_s32vector_set(C_word v, C_word i, C_word x)
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "s32vector-set!", v, i);
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))
+ barf(C_OUT_OF_BOUNDS_ERROR, "s32vector-set!", v, i);
if(C_truep(C_i_exact_integerp(x))) {
if (C_unfix(C_i_integer_length(x)) <= 32) n = C_num_to_int(x);
- else barf(C_OUT_OF_RANGE_ERROR, "s32vector-set!", x);
+ else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "s32vector-set!", x);
}
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s32vector-set!", x);
}
@@ -6247,7 +6260,7 @@ C_regparm C_word C_fcall C_i_s32vector_set(C_word v, C_word i, C_word x)
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_i_u64vector_set(C_word v, C_word i, C_word x)
+C_regparm C_word C_i_u64vector_set(C_word v, C_word i, C_word x)
{
int j;
C_u64 n;
@@ -6258,11 +6271,12 @@ C_regparm C_word C_fcall C_i_u64vector_set(C_word v, C_word i, C_word x)
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "u64vector-set!", v, i);
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))
+ barf(C_OUT_OF_BOUNDS_ERROR, "u64vector-set!", v, i);
if(C_truep(C_i_exact_integerp(x))) {
if (C_unfix(C_i_integer_length(x)) <= 64) n = C_num_to_uint64(x);
- else barf(C_OUT_OF_RANGE_ERROR, "u64vector-set!", x);
+ else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "u64vector-set!", x);
}
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "u64vector-set!", x);
}
@@ -6272,7 +6286,7 @@ C_regparm C_word C_fcall C_i_u64vector_set(C_word v, C_word i, C_word x)
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_i_s64vector_set(C_word v, C_word i, C_word x)
+C_regparm C_word C_i_s64vector_set(C_word v, C_word i, C_word x)
{
int j;
C_s64 n;
@@ -6283,11 +6297,12 @@ C_regparm C_word C_fcall C_i_s64vector_set(C_word v, C_word i, C_word x)
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "s64vector-set!", v, i);
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))
+ barf(C_OUT_OF_BOUNDS_ERROR, "s64vector-set!", v, i);
if(C_truep(C_i_exact_integerp(x))) {
if (C_unfix(C_i_integer_length(x)) <= 64) n = C_num_to_int64(x);
- else barf(C_OUT_OF_RANGE_ERROR, "s64vector-set!", x);
+ else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "s64vector-set!", x);
}
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "s64vector-set!", x);
}
@@ -6297,7 +6312,7 @@ C_regparm C_word C_fcall C_i_s64vector_set(C_word v, C_word i, C_word x)
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_i_f32vector_set(C_word v, C_word i, C_word x)
+C_regparm C_word C_i_f32vector_set(C_word v, C_word i, C_word x)
{
int j;
double f;
@@ -6308,12 +6323,13 @@ C_regparm C_word C_fcall C_i_f32vector_set(C_word v, C_word i, C_word x)
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2)) barf(C_OUT_OF_RANGE_ERROR, "f32vector-set!", v, i);
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 2))
+ barf(C_OUT_OF_BOUNDS_ERROR, "f32vector-set!", v, i);
if(C_truep(C_i_flonump(x))) f = C_flonum_magnitude(x);
else if(x & C_FIXNUM_BIT) f = C_unfix(x);
else if (C_truep(C_i_bignump(x))) f = C_bignum_to_double(x);
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-set!", x);
+ else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "f32vector-set!", x);
}
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f32vector-set!", i);
@@ -6321,7 +6337,7 @@ C_regparm C_word C_fcall C_i_f32vector_set(C_word v, C_word i, C_word x)
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_i_f64vector_set(C_word v, C_word i, C_word x)
+C_regparm C_word C_i_f64vector_set(C_word v, C_word i, C_word x)
{
int j;
double f;
@@ -6332,12 +6348,13 @@ C_regparm C_word C_fcall C_i_f64vector_set(C_word v, C_word i, C_word x)
if(i & C_FIXNUM_BIT) {
j = C_unfix(i);
- if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3)) barf(C_OUT_OF_RANGE_ERROR, "f64vector-set!", v, i);
+ if(j < 0 || j >= (C_header_size(C_block_item(v, 1)) >> 3))
+ barf(C_OUT_OF_BOUNDS_ERROR, "f64vector-set!", v, i);
if(C_truep(C_i_flonump(x))) f = C_flonum_magnitude(x);
else if(x & C_FIXNUM_BIT) f = C_unfix(x);
else if (C_truep(C_i_bignump(x))) f = C_bignum_to_double(x);
- else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-set!", x);
+ else barf(C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR, "f64vector-set!", x);
}
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "f64vector-set!", i);
@@ -6348,7 +6365,7 @@ C_regparm C_word C_fcall C_i_f64vector_set(C_word v, C_word i, C_word x)
/* This needs at most C_SIZEOF_FIX_BIGNUM + max(C_SIZEOF_RATNUM, C_SIZEOF_CPLXNUM) so 7 words */
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_i_abs(C_word **ptr, C_word n, C_word x)
{
if (x & C_FIXNUM_BIT) {
@@ -6397,7 +6414,7 @@ void C_ccall C_signum(C_word c, C_word *av)
* ratnums that consist of 2 fix bignums each. So that's
* C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM * 2 + C_SIZEOF_FIX_BIGNUM * 4 = 29 words!
*/
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_i_negate(C_word **ptr, C_word n, C_word x)
{
if (x & C_FIXNUM_BIT) {
@@ -6429,7 +6446,7 @@ inline static void bignum_digits_destructive_copy(C_word target, C_word source)
C_wordstobytes(C_bignum_size(source)));
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_u_i_integer_negate(C_word **ptr, C_word n, C_word x)
{
if (x & C_FIXNUM_BIT) {
@@ -6461,7 +6478,7 @@ inline static int integer_length_abs(C_word x)
}
}
-C_regparm C_word C_fcall C_i_integer_length(C_word x)
+C_regparm C_word C_i_integer_length(C_word x)
{
if (x & C_FIXNUM_BIT) {
return C_i_fixnum_length(x);
@@ -6543,7 +6560,7 @@ inline static C_word maybe_negate_bignum_for_bitwise_op(C_word x, C_word size)
}
/* DEPRECATED */
-C_regparm C_word C_fcall C_i_bit_to_bool(C_word n, C_word i)
+C_regparm C_word C_i_bit_to_bool(C_word n, C_word i)
{
if (!C_truep(C_i_exact_integerp(n))) {
barf(C_BAD_ARGUMENT_TYPE_NO_EXACT_INTEGER_ERROR, "bit->boolean", n);
@@ -6576,7 +6593,7 @@ C_regparm C_word C_fcall C_i_bit_to_bool(C_word n, C_word i)
}
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_i_bitwise_and(C_word **ptr, C_word n, C_word x, C_word y)
{
if ((x & y) & C_FIXNUM_BIT) {
@@ -6602,7 +6619,7 @@ C_s_a_i_bitwise_and(C_word **ptr, C_word n, C_word x, C_word y)
res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);
scanr = C_bignum_digits(res);
endr = scanr + C_bignum_size(res);
-
+
if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;
if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;
@@ -6620,7 +6637,7 @@ C_s_a_i_bitwise_and(C_word **ptr, C_word n, C_word x, C_word y)
if (C_truep(nx)) free_tmp_bignum(nx);
if (C_truep(ny)) free_tmp_bignum(ny);
if (C_bignum_negativep(res)) bignum_digits_destructive_negate(res);
-
+
return C_bignum_simplify(res);
}
}
@@ -6632,7 +6649,7 @@ void C_ccall C_bitwise_and(C_word c, C_word *av)
C_word next_val, result, prev_result;
C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;
- c -= 2;
+ c -= 2;
av += 2;
if (c == 0) C_kontinue(k, C_fix(-1));
@@ -6654,7 +6671,7 @@ void C_ccall C_bitwise_and(C_word c, C_word *av)
C_kontinue(k, result);
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_i_bitwise_ior(C_word **ptr, C_word n, C_word x, C_word y)
{
if ((x & y) & C_FIXNUM_BIT) {
@@ -6675,7 +6692,7 @@ C_s_a_i_bitwise_ior(C_word **ptr, C_word n, C_word x, C_word y)
res = C_allocate_scratch_bignum(ptr, C_fix(size), negp, C_SCHEME_FALSE);
scanr = C_bignum_digits(res);
endr = scanr + C_bignum_size(res);
-
+
if (C_truep(nx = maybe_negate_bignum_for_bitwise_op(x, size))) x = nx;
if (C_truep(ny = maybe_negate_bignum_for_bitwise_op(y, size))) y = ny;
@@ -6707,7 +6724,7 @@ void C_ccall C_bitwise_ior(C_word c, C_word *av)
C_word next_val, result, prev_result;
C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;
- c -= 2;
+ c -= 2;
av += 2;
if (c == 0) C_kontinue(k, C_fix(0));
@@ -6729,7 +6746,7 @@ void C_ccall C_bitwise_ior(C_word c, C_word *av)
C_kontinue(k, result);
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_i_bitwise_xor(C_word **ptr, C_word n, C_word x, C_word y)
{
if ((x & y) & C_FIXNUM_BIT) {
@@ -6782,7 +6799,7 @@ void C_ccall C_bitwise_xor(C_word c, C_word *av)
C_word next_val, result, prev_result;
C_word ab[2][C_SIZEOF_BIGNUM_WRAPPER], *a;
- c -= 2;
+ c -= 2;
av += 2;
if (c == 0) C_kontinue(k, C_fix(0));
@@ -6804,7 +6821,7 @@ void C_ccall C_bitwise_xor(C_word c, C_word *av)
C_kontinue(k, result);
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_i_bitwise_not(C_word **ptr, C_word n, C_word x)
{
if (!C_truep(C_i_exact_integerp(x))) {
@@ -6814,7 +6831,7 @@ C_s_a_i_bitwise_not(C_word **ptr, C_word n, C_word x)
}
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_i_arithmetic_shift(C_word **ptr, C_word n, C_word x, C_word y)
{
C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, size, negp, res,
@@ -6846,7 +6863,7 @@ C_s_a_i_arithmetic_shift(C_word **ptr, C_word n, C_word x, C_word y)
}
negp = C_mk_bool(C_bignum_negativep(x));
-
+
if (y > 0) { /* Shift left */
C_uword *startr, *startx, *endx, *endr;
@@ -6912,7 +6929,7 @@ C_s_a_i_arithmetic_shift(C_word **ptr, C_word n, C_word x, C_word y)
}
-C_regparm C_word C_fcall C_a_i_exp(C_word **a, int c, C_word n)
+C_regparm C_word C_a_i_exp(C_word **a, int c, C_word n)
{
double f;
@@ -6921,7 +6938,7 @@ C_regparm C_word C_fcall C_a_i_exp(C_word **a, int c, C_word n)
}
-C_regparm C_word C_fcall C_a_i_log(C_word **a, int c, C_word n)
+C_regparm C_word C_a_i_log(C_word **a, int c, C_word n)
{
double f;
@@ -6930,7 +6947,7 @@ C_regparm C_word C_fcall C_a_i_log(C_word **a, int c, C_word n)
}
-C_regparm C_word C_fcall C_a_i_sin(C_word **a, int c, C_word n)
+C_regparm C_word C_a_i_sin(C_word **a, int c, C_word n)
{
double f;
@@ -6939,7 +6956,7 @@ C_regparm C_word C_fcall C_a_i_sin(C_word **a, int c, C_word n)
}
-C_regparm C_word C_fcall C_a_i_cos(C_word **a, int c, C_word n)
+C_regparm C_word C_a_i_cos(C_word **a, int c, C_word n)
{
double f;
@@ -6948,7 +6965,7 @@ C_regparm C_word C_fcall C_a_i_cos(C_word **a, int c, C_word n)
}
-C_regparm C_word C_fcall C_a_i_tan(C_word **a, int c, C_word n)
+C_regparm C_word C_a_i_tan(C_word **a, int c, C_word n)
{
double f;
@@ -6957,7 +6974,7 @@ C_regparm C_word C_fcall C_a_i_tan(C_word **a, int c, C_word n)
}
-C_regparm C_word C_fcall C_a_i_asin(C_word **a, int c, C_word n)
+C_regparm C_word C_a_i_asin(C_word **a, int c, C_word n)
{
double f;
@@ -6966,7 +6983,7 @@ C_regparm C_word C_fcall C_a_i_asin(C_word **a, int c, C_word n)
}
-C_regparm C_word C_fcall C_a_i_acos(C_word **a, int c, C_word n)
+C_regparm C_word C_a_i_acos(C_word **a, int c, C_word n)
{
double f;
@@ -6975,7 +6992,7 @@ C_regparm C_word C_fcall C_a_i_acos(C_word **a, int c, C_word n)
}
-C_regparm C_word C_fcall C_a_i_atan(C_word **a, int c, C_word n)
+C_regparm C_word C_a_i_atan(C_word **a, int c, C_word n)
{
double f;
@@ -6984,7 +7001,7 @@ C_regparm C_word C_fcall C_a_i_atan(C_word **a, int c, C_word n)
}
-C_regparm C_word C_fcall C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2)
+C_regparm C_word C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2)
{
double f1, f2;
@@ -6994,7 +7011,7 @@ C_regparm C_word C_fcall C_a_i_atan2(C_word **a, int c, C_word n1, C_word n2)
}
-C_regparm C_word C_fcall C_a_i_sinh(C_word **a, int c, C_word n)
+C_regparm C_word C_a_i_sinh(C_word **a, int c, C_word n)
{
double f;
@@ -7003,7 +7020,7 @@ C_regparm C_word C_fcall C_a_i_sinh(C_word **a, int c, C_word n)
}
-C_regparm C_word C_fcall C_a_i_cosh(C_word **a, int c, C_word n)
+C_regparm C_word C_a_i_cosh(C_word **a, int c, C_word n)
{
double f;
@@ -7012,7 +7029,7 @@ C_regparm C_word C_fcall C_a_i_cosh(C_word **a, int c, C_word n)
}
-C_regparm C_word C_fcall C_a_i_tanh(C_word **a, int c, C_word n)
+C_regparm C_word C_a_i_tanh(C_word **a, int c, C_word n)
{
double f;
@@ -7021,7 +7038,7 @@ C_regparm C_word C_fcall C_a_i_tanh(C_word **a, int c, C_word n)
}
-C_regparm C_word C_fcall C_a_i_asinh(C_word **a, int c, C_word n)
+C_regparm C_word C_a_i_asinh(C_word **a, int c, C_word n)
{
double f;
@@ -7030,7 +7047,7 @@ C_regparm C_word C_fcall C_a_i_asinh(C_word **a, int c, C_word n)
}
-C_regparm C_word C_fcall C_a_i_acosh(C_word **a, int c, C_word n)
+C_regparm C_word C_a_i_acosh(C_word **a, int c, C_word n)
{
double f;
@@ -7039,7 +7056,7 @@ C_regparm C_word C_fcall C_a_i_acosh(C_word **a, int c, C_word n)
}
-C_regparm C_word C_fcall C_a_i_atanh(C_word **a, int c, C_word n)
+C_regparm C_word C_a_i_atanh(C_word **a, int c, C_word n)
{
double f;
@@ -7048,7 +7065,7 @@ C_regparm C_word C_fcall C_a_i_atanh(C_word **a, int c, C_word n)
}
-C_regparm C_word C_fcall C_a_i_sqrt(C_word **a, int c, C_word n)
+C_regparm C_word C_a_i_sqrt(C_word **a, int c, C_word n)
{
double f;
@@ -7057,7 +7074,7 @@ C_regparm C_word C_fcall C_a_i_sqrt(C_word **a, int c, C_word n)
}
-C_regparm C_word C_fcall C_i_assq(C_word x, C_word lst)
+C_regparm C_word C_i_assq(C_word x, C_word lst)
{
C_word a;
@@ -7068,7 +7085,7 @@ C_regparm C_word C_fcall C_i_assq(C_word x, C_word lst)
if(C_u_i_car(a) == x) return a;
}
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "assq", a);
-
+
lst = C_u_i_cdr(lst);
}
@@ -7079,7 +7096,7 @@ C_regparm C_word C_fcall C_i_assq(C_word x, C_word lst)
}
-C_regparm C_word C_fcall C_i_assv(C_word x, C_word lst)
+C_regparm C_word C_i_assv(C_word x, C_word lst)
{
C_word a;
@@ -7090,7 +7107,7 @@ C_regparm C_word C_fcall C_i_assv(C_word x, C_word lst)
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);
}
@@ -7101,7 +7118,7 @@ C_regparm C_word C_fcall C_i_assv(C_word x, C_word lst)
}
-C_regparm C_word C_fcall C_i_assoc(C_word x, C_word lst)
+C_regparm C_word C_i_assoc(C_word x, C_word lst)
{
C_word a;
@@ -7112,7 +7129,7 @@ C_regparm C_word C_fcall C_i_assoc(C_word x, C_word lst)
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);
}
@@ -7123,7 +7140,7 @@ C_regparm C_word C_fcall C_i_assoc(C_word x, C_word lst)
}
-C_regparm C_word C_fcall C_i_memq(C_word x, C_word lst)
+C_regparm C_word C_i_memq(C_word x, C_word lst)
{
while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {
if(C_u_i_car(lst) == x) return lst;
@@ -7137,7 +7154,7 @@ C_regparm C_word C_fcall C_i_memq(C_word x, C_word lst)
}
-C_regparm C_word C_fcall C_u_i_memq(C_word x, C_word lst)
+C_regparm C_word C_u_i_memq(C_word x, C_word lst)
{
while(!C_immediatep(lst)) {
if(C_u_i_car(lst) == x) return lst;
@@ -7148,7 +7165,7 @@ C_regparm C_word C_fcall C_u_i_memq(C_word x, C_word lst)
}
-C_regparm C_word C_fcall C_i_memv(C_word x, C_word lst)
+C_regparm C_word C_i_memv(C_word x, C_word lst)
{
while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {
if(C_truep(C_i_eqvp(C_u_i_car(lst), x))) return lst;
@@ -7157,12 +7174,12 @@ C_regparm C_word C_fcall C_i_memv(C_word x, C_word lst)
if(lst!=C_SCHEME_END_OF_LIST)
barf(C_BAD_ARGUMENT_TYPE_ERROR, "memv", lst);
-
+
return C_SCHEME_FALSE;
}
-C_regparm C_word C_fcall C_i_member(C_word x, C_word lst)
+C_regparm C_word C_i_member(C_word x, C_word lst)
{
while(!C_immediatep(lst) && C_header_type(lst) == C_PAIR_TYPE) {
if(C_equalp(C_u_i_car(lst), x)) return lst;
@@ -7171,14 +7188,14 @@ C_regparm C_word C_fcall C_i_member(C_word x, C_word lst)
if(lst!=C_SCHEME_END_OF_LIST)
barf(C_BAD_ARGUMENT_TYPE_ERROR, "member", 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)
+C_regparm C_word 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;
@@ -7188,7 +7205,7 @@ C_regparm C_word C_fcall C_i_check_closure_2(C_word x, C_word loc)
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_i_check_fixnum_2(C_word x, C_word loc)
+C_regparm C_word C_i_check_fixnum_2(C_word x, C_word loc)
{
if(!(x & C_FIXNUM_BIT)) {
error_location = loc;
@@ -7199,7 +7216,7 @@ C_regparm C_word C_fcall C_i_check_fixnum_2(C_word x, C_word loc)
}
/* DEPRECATED */
-C_regparm C_word C_fcall C_i_check_exact_2(C_word x, C_word loc)
+C_regparm C_word C_i_check_exact_2(C_word x, C_word loc)
{
if(C_u_i_exactp(x) == C_SCHEME_FALSE) {
error_location = loc;
@@ -7210,7 +7227,7 @@ C_regparm C_word C_fcall C_i_check_exact_2(C_word x, C_word loc)
}
-C_regparm C_word C_fcall C_i_check_inexact_2(C_word x, C_word loc)
+C_regparm C_word 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;
@@ -7221,7 +7238,7 @@ C_regparm C_word C_fcall C_i_check_inexact_2(C_word x, C_word loc)
}
-C_regparm C_word C_fcall C_i_check_char_2(C_word x, C_word loc)
+C_regparm C_word C_i_check_char_2(C_word x, C_word loc)
{
if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS) {
error_location = loc;
@@ -7232,7 +7249,7 @@ C_regparm C_word C_fcall C_i_check_char_2(C_word x, C_word loc)
}
-C_regparm C_word C_fcall C_i_check_number_2(C_word x, C_word loc)
+C_regparm C_word C_i_check_number_2(C_word x, C_word loc)
{
if (C_i_numberp(x) == C_SCHEME_FALSE) {
error_location = loc;
@@ -7243,7 +7260,7 @@ C_regparm C_word C_fcall C_i_check_number_2(C_word x, C_word loc)
}
-C_regparm C_word C_fcall C_i_check_string_2(C_word x, C_word loc)
+C_regparm C_word 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;
@@ -7254,7 +7271,7 @@ C_regparm C_word C_fcall C_i_check_string_2(C_word x, C_word loc)
}
-C_regparm C_word C_fcall C_i_check_bytevector_2(C_word x, C_word loc)
+C_regparm C_word 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;
@@ -7265,7 +7282,7 @@ C_regparm C_word C_fcall C_i_check_bytevector_2(C_word x, C_word loc)
}
-C_regparm C_word C_fcall C_i_check_vector_2(C_word x, C_word loc)
+C_regparm C_word 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;
@@ -7276,7 +7293,7 @@ C_regparm C_word C_fcall C_i_check_vector_2(C_word x, C_word loc)
}
-C_regparm C_word C_fcall C_i_check_structure_2(C_word x, C_word st, C_word loc)
+C_regparm C_word 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_block_item(x,0) != st) {
error_location = loc;
@@ -7287,7 +7304,7 @@ C_regparm C_word C_fcall C_i_check_structure_2(C_word x, C_word st, C_word loc)
}
-C_regparm C_word C_fcall C_i_check_pair_2(C_word x, C_word loc)
+C_regparm C_word C_i_check_pair_2(C_word x, C_word loc)
{
if(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE) {
error_location = loc;
@@ -7298,7 +7315,7 @@ C_regparm C_word C_fcall C_i_check_pair_2(C_word x, C_word loc)
}
-C_regparm C_word C_fcall C_i_check_boolean_2(C_word x, C_word loc)
+C_regparm C_word C_i_check_boolean_2(C_word x, C_word loc)
{
if((x & C_IMMEDIATE_TYPE_BITS) != C_BOOLEAN_BITS) {
error_location = loc;
@@ -7309,7 +7326,7 @@ C_regparm C_word C_fcall C_i_check_boolean_2(C_word x, C_word loc)
}
-C_regparm C_word C_fcall C_i_check_locative_2(C_word x, C_word loc)
+C_regparm C_word C_i_check_locative_2(C_word x, C_word loc)
{
if(C_immediatep(x) || C_block_header(x) != C_LOCATIVE_TAG) {
error_location = loc;
@@ -7320,7 +7337,7 @@ C_regparm C_word C_fcall C_i_check_locative_2(C_word x, C_word loc)
}
-C_regparm C_word C_fcall C_i_check_symbol_2(C_word x, C_word loc)
+C_regparm C_word C_i_check_symbol_2(C_word x, C_word loc)
{
if(!C_truep(C_i_symbolp(x))) {
error_location = loc;
@@ -7331,7 +7348,7 @@ C_regparm C_word C_fcall C_i_check_symbol_2(C_word x, C_word loc)
}
-C_regparm C_word C_fcall C_i_check_keyword_2(C_word x, C_word loc)
+C_regparm C_word C_i_check_keyword_2(C_word x, C_word loc)
{
if(!C_truep(C_i_keywordp(x))) {
error_location = loc;
@@ -7341,7 +7358,7 @@ C_regparm C_word C_fcall C_i_check_keyword_2(C_word x, C_word loc)
return C_SCHEME_UNDEFINED;
}
-C_regparm C_word C_fcall C_i_check_list_2(C_word x, C_word loc)
+C_regparm C_word C_i_check_list_2(C_word x, C_word loc)
{
if(x != C_SCHEME_END_OF_LIST && (C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE)) {
error_location = loc;
@@ -7352,7 +7369,7 @@ C_regparm C_word C_fcall C_i_check_list_2(C_word x, C_word loc)
}
-C_regparm C_word C_fcall C_i_check_port_2(C_word x, C_word dir, C_word open, C_word loc)
+C_regparm C_word C_i_check_port_2(C_word x, C_word dir, C_word open, C_word loc)
{
if(C_immediatep(x) || C_header_bits(x) != C_PORT_TYPE) {
@@ -7383,8 +7400,54 @@ C_regparm C_word C_fcall C_i_check_port_2(C_word x, C_word dir, C_word open, C_w
}
+C_regparm C_word C_i_check_range_2(C_word i, C_word f, C_word t, C_word loc)
+{
+ if(!(i & C_FIXNUM_BIT)) {
+ error_location = loc;
+ barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, i);
+ }
+
+ int index = C_unfix(i);
+
+ if(index < C_unfix(f)) {
+ error_location = loc;
+ barf(C_OUT_OF_BOUNDS_ERROR, NULL, f, i);
+ }
+
+ if(index >= C_unfix(t)) {
+ error_location = loc;
+ barf(C_OUT_OF_BOUNDS_ERROR, NULL, t, i);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
+C_regparm C_word C_i_check_range_including_2(C_word i, C_word f, C_word t, C_word loc)
+{
+ if(!(i & C_FIXNUM_BIT)) {
+ error_location = loc;
+ barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, i);
+ }
+
+ int index = C_unfix(i);
+
+ if(index < C_unfix(f)) {
+ error_location = loc;
+ barf(C_OUT_OF_BOUNDS_ERROR, NULL, f, i);
+ }
+
+ if(index > C_unfix(t)) {
+ error_location = loc;
+ barf(C_OUT_OF_BOUNDS_ERROR, NULL, t, i);
+ }
+
+ return C_SCHEME_UNDEFINED;
+}
+
+
/*XXX these are not correctly named */
-C_regparm C_word C_fcall C_i_foreign_char_argumentp(C_word x)
+C_regparm C_word 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);
@@ -7393,7 +7456,7 @@ C_regparm C_word C_fcall C_i_foreign_char_argumentp(C_word x)
}
-C_regparm C_word C_fcall C_i_foreign_fixnum_argumentp(C_word x)
+C_regparm C_word C_i_foreign_fixnum_argumentp(C_word x)
{
if((x & C_FIXNUM_BIT) == 0)
barf(C_BAD_ARGUMENT_TYPE_NO_FIXNUM_ERROR, NULL, x);
@@ -7402,7 +7465,7 @@ C_regparm C_word C_fcall C_i_foreign_fixnum_argumentp(C_word x)
}
-C_regparm C_word C_fcall C_i_foreign_flonum_argumentp(C_word x)
+C_regparm C_word C_i_foreign_flonum_argumentp(C_word x)
{
if((x & C_FIXNUM_BIT) != 0) return x;
@@ -7413,7 +7476,18 @@ C_regparm C_word C_fcall C_i_foreign_flonum_argumentp(C_word x)
}
-C_regparm C_word C_fcall C_i_foreign_block_argumentp(C_word x)
+C_regparm C_word C_i_foreign_cplxnum_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_i_foreign_block_argumentp(C_word x)
{
if(C_immediatep(x))
barf(C_BAD_ARGUMENT_TYPE_NO_BLOCK_ERROR, NULL, x);
@@ -7422,7 +7496,7 @@ C_regparm C_word C_fcall C_i_foreign_block_argumentp(C_word x)
}
-C_regparm C_word C_fcall C_i_foreign_struct_wrapper_argumentp(C_word t, C_word x)
+C_regparm C_word C_i_foreign_struct_wrapper_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_BAD_STRUCT_ERROR, NULL, t, x);
@@ -7431,7 +7505,7 @@ C_regparm C_word C_fcall C_i_foreign_struct_wrapper_argumentp(C_word t, C_word x
}
-C_regparm C_word C_fcall C_i_foreign_string_argumentp(C_word x)
+C_regparm C_word 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);
@@ -7440,7 +7514,7 @@ C_regparm C_word C_fcall C_i_foreign_string_argumentp(C_word x)
}
-C_regparm C_word C_fcall C_i_foreign_symbol_argumentp(C_word x)
+C_regparm C_word 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);
@@ -7449,7 +7523,7 @@ C_regparm C_word C_fcall C_i_foreign_symbol_argumentp(C_word x)
}
-C_regparm C_word C_fcall C_i_foreign_pointer_argumentp(C_word x)
+C_regparm C_word C_i_foreign_pointer_argumentp(C_word x)
{
if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0)
barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);
@@ -7459,7 +7533,7 @@ C_regparm C_word C_fcall C_i_foreign_pointer_argumentp(C_word x)
/* TODO: Is this used? */
-C_regparm C_word C_fcall C_i_foreign_scheme_or_c_pointer_argumentp(C_word x)
+C_regparm C_word C_i_foreign_scheme_or_c_pointer_argumentp(C_word x)
{
if(C_immediatep(x) || (C_header_bits(x) & C_SPECIALBLOCK_BIT) == 0)
barf(C_BAD_ARGUMENT_TYPE_NO_POINTER_ERROR, NULL, x);
@@ -7468,7 +7542,7 @@ C_regparm C_word C_fcall C_i_foreign_scheme_or_c_pointer_argumentp(C_word x)
}
-C_regparm C_word C_fcall C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t)
+C_regparm C_word 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)))
@@ -7477,7 +7551,7 @@ C_regparm C_word C_fcall C_i_foreign_tagged_pointer_argumentp(C_word x, C_word t
return x;
}
-C_regparm C_word C_fcall C_i_foreign_ranged_integer_argumentp(C_word x, C_word bits)
+C_regparm C_word C_i_foreign_ranged_integer_argumentp(C_word x, C_word bits)
{
if((x & C_FIXNUM_BIT) != 0) {
if (C_truep(C_fixnum_lessp(C_i_fixnum_length(x), bits))) return x;
@@ -7490,7 +7564,7 @@ C_regparm C_word C_fcall C_i_foreign_ranged_integer_argumentp(C_word x, C_word b
}
}
-C_regparm C_word C_fcall C_i_foreign_unsigned_ranged_integer_argumentp(C_word x, C_word bits)
+C_regparm C_word C_i_foreign_unsigned_ranged_integer_argumentp(C_word x, C_word bits)
{
if((x & C_FIXNUM_BIT) != 0) {
if(x & C_INT_SIGN_BIT) barf(C_BAD_ARGUMENT_TYPE_NO_UINTEGER_ERROR, NULL, x);
@@ -7506,13 +7580,13 @@ C_regparm C_word C_fcall C_i_foreign_unsigned_ranged_integer_argumentp(C_word x,
}
/* I */
-C_regparm C_word C_fcall C_i_not_pair_p_2(C_word x)
+C_regparm C_word C_i_not_pair_p_2(C_word x)
{
return C_mk_bool(C_immediatep(x) || C_header_type(x) != C_PAIR_TYPE);
}
-C_regparm C_word C_fcall C_i_null_list_p(C_word x)
+C_regparm C_word 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_header_type(x) == C_PAIR_TYPE) return C_SCHEME_FALSE;
@@ -7523,10 +7597,10 @@ C_regparm C_word C_fcall C_i_null_list_p(C_word x)
}
-C_regparm C_word C_fcall C_i_string_null_p(C_word x)
+C_regparm C_word 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);
+ return C_mk_bool(C_unfix(C_block_item(x, 1)) == 0);
else {
barf(C_BAD_ARGUMENT_TYPE_NO_STRING_ERROR, "string-null?", x);
return C_SCHEME_FALSE;
@@ -7534,7 +7608,7 @@ C_regparm C_word C_fcall C_i_string_null_p(C_word x)
}
-C_regparm C_word C_fcall C_i_null_pointerp(C_word x)
+C_regparm C_word C_i_null_pointerp(C_word x)
{
if(!C_immediatep(x) && (C_header_bits(x) & C_SPECIALBLOCK_BIT) != 0)
return C_null_pointerp(x);
@@ -7544,7 +7618,7 @@ C_regparm C_word C_fcall C_i_null_pointerp(C_word x)
}
/* only used here for char comparators below: */
-static C_word C_fcall check_char_internal(C_word x, C_char *loc)
+static C_word check_char_internal(C_word x, C_char *loc)
{
if((x & C_IMMEDIATE_TYPE_BITS) != C_CHARACTER_BITS) {
error_location = intern0(loc);
@@ -7653,15 +7727,15 @@ void C_ccall C_call_cc(C_word c, C_word *av)
wrapper;
void *pr = (void *)C_block_item(cont,0);
C_word av2[ 3 ];
-
+
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_block_item(k, 0) == (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);
-
+
av2[ 0 ] = cont;
av2[ 1 ] = k;
av2[ 2 ] = wrapper;
@@ -7692,7 +7766,7 @@ void C_ccall call_cc_values_wrapper(C_word c, C_word *av)
k = C_block_item(closure, 1),
x1,
n = c;
-
+
av[ 0 ] = k; /* reuse av */
C_memmove(av + 1, av + 2, (n - 1) * sizeof(C_word));
C_do_apply(n - 1, av);
@@ -7728,7 +7802,7 @@ void C_ccall C_values(C_word c, C_word *av)
C_memmove(av + 1, av + 2, (c - 2) * sizeof(C_word));
C_do_apply(c - 1, av);
}
-
+
if(c != 3) {
#ifdef RELAX_MULTIVAL_CHECK
if(c == 2) n = C_SCHEME_UNDEFINED;
@@ -7783,7 +7857,7 @@ void C_ccall C_apply_values(C_word c, C_word *av)
C_do_apply(n, av2);
}
-
+
if(C_immediatep(lst)) {
#ifdef RELAX_MULTIVAL_CHECK
n = C_SCHEME_UNDEFINED;
@@ -7803,7 +7877,7 @@ void C_ccall C_apply_values(C_word c, C_word *av)
}
}
else barf(C_BAD_ARGUMENT_TYPE_ERROR, "apply", lst);
-
+
C_kontinue(k, n);
}
@@ -7903,7 +7977,7 @@ static C_word rat_times_integer(C_word **ptr, C_word rat, C_word i)
num = move_buffer_object(ptr, ab, num);
denom = move_buffer_object(ptr, ab, denom);
-
+
clear_buffer_object(ab, gcd);
clear_buffer_object(ab, a_div_g);
@@ -7978,7 +8052,7 @@ cplx_times(C_word **ptr, C_word rx, C_word ix, C_word ry, C_word iy)
r2 = C_s_a_i_times(&a, 2, ix, iy);
i1 = C_s_a_i_times(&a, 2, rx, iy);
i2 = C_s_a_i_times(&a, 2, ix, ry);
-
+
r = C_s_a_i_minus(ptr, 2, r1, r2);
i = C_s_a_i_plus(ptr, 2, i1, i2);
@@ -8000,7 +8074,7 @@ cplx_times(C_word **ptr, C_word rx, C_word ix, C_word ry, C_word iy)
* from a fixnum multiplication (2 digits each), so we're looking at
* C_SIZEOF_RATNUM * 3 + C_SIZEOF_BIGNUM(2) * 4 = 33 words!
*/
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y)
{
if (x & C_FIXNUM_BIT) {
@@ -8089,7 +8163,7 @@ C_s_a_i_times(C_word **ptr, C_word n, C_word x, C_word y)
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_u_i_integer_times(C_word **ptr, C_word n, C_word x, C_word y)
{
if (x & C_FIXNUM_BIT) {
@@ -8113,7 +8187,7 @@ C_s_a_u_i_integer_times(C_word **ptr, C_word n, C_word x, C_word y)
negp = C_mk_bool((y & C_INT_SIGN_BIT) ?
!C_bignum_negativep(x) :
C_bignum_negativep(x));
-
+
if (C_fitsinbignumhalfdigitp(absy) ||
(((C_uword)1 << (C_ilen(absy)-1)) == absy && C_fitsinfixnump(absy))) {
C_word size, res;
@@ -8186,7 +8260,7 @@ bignum_times_bignum_karatsuba(C_word **ptr, C_word x, C_word y, C_word negp)
/* Ran out of stack? Fall back to non-recursive multiplication */
C_stack_check1(return C_SCHEME_FALSE);
-
+
/* Split |x| in half: <xhi,xlo> and |y|: <yhi,ylo> with len(ylo)=len(xlo) */
x = o[i++] = C_s_a_u_i_integer_abs(&ka, 1, x);
y = o[i++] = C_s_a_u_i_integer_abs(&ka, 1, y);
@@ -8228,7 +8302,7 @@ void C_ccall C_times(C_word c, C_word *av)
prev_result = result;
C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_BIGNUM(2) * 4], *a;
- c -= 2;
+ c -= 2;
av += 2;
while (c--) {
@@ -8283,7 +8357,7 @@ static C_word bignum_plus_unsigned(C_word **ptr, C_word x, C_word y, C_word negp
}
(*scan_r++) = sum;
}
-
+
/* The end of y, the smaller number. Propagate carry into the rest of x. */
while (carry) {
sum = (*scan_r) + 1;
@@ -8395,7 +8469,7 @@ static C_word rat_plusmin_rat(C_word **ptr, C_word x, C_word y, integer_plusmin_
* bignums", so we're looking at C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM *
* 2 + C_SIZEOF_FIX_BIGNUM * 4 = 29 words!
*/
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_i_plus(C_word **ptr, C_word n, C_word x, C_word y)
{
if (x & C_FIXNUM_BIT) {
@@ -8499,7 +8573,7 @@ C_s_a_i_plus(C_word **ptr, C_word n, C_word x, C_word y)
}
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_u_i_integer_plus(C_word **ptr, C_word n, C_word x, C_word y)
{
if ((x & y) & C_FIXNUM_BIT) {
@@ -8534,7 +8608,7 @@ void C_ccall C_plus(C_word c, C_word *av)
prev_result = result;
C_word ab[2][C_SIZEOF_CPLXNUM + C_SIZEOF_RATNUM*2 + C_SIZEOF_FIX_BIGNUM * 4], *a;
- c -= 2;
+ c -= 2;
av += 2;
while (c--) {
@@ -8606,7 +8680,7 @@ static C_word bignum_minus_unsigned(C_word **ptr, C_word x, C_word y)
}
/* Like C_s_a_i_plus, this needs at most 29 words */
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_i_minus(C_word **ptr, C_word n, C_word x, C_word y)
{
if (x & C_FIXNUM_BIT) {
@@ -8710,7 +8784,7 @@ C_s_a_i_minus(C_word **ptr, C_word n, C_word x, C_word y)
}
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_u_i_integer_minus(C_word **ptr, C_word n, C_word x, C_word y)
{
if ((x & y) & C_FIXNUM_BIT) {
@@ -9192,7 +9266,7 @@ void C_ccall C_u_integer_quotient_and_remainder(C_word c, C_word *av)
C_values(4, av);
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_i_remainder(C_word **ptr, C_word n, C_word x, C_word y)
{
C_word ab[C_SIZEOF_FIX_BIGNUM*4+C_SIZEOF_FLONUM*2], *a = ab, r,
@@ -9230,7 +9304,7 @@ C_s_a_i_remainder(C_word **ptr, C_word n, C_word x, C_word y)
return move_buffer_object(ptr, ab, r);
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_u_i_integer_remainder(C_word **ptr, C_word n, C_word x, C_word y)
{
C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, r;
@@ -9240,7 +9314,7 @@ C_s_a_u_i_integer_remainder(C_word **ptr, C_word n, C_word x, C_word y)
}
/* Modulo's sign follows y (whereas remainder's sign follows x) */
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_i_modulo(C_word **ptr, C_word n, C_word x, C_word y)
{
C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, r,
@@ -9290,7 +9364,7 @@ C_s_a_i_modulo(C_word **ptr, C_word n, C_word x, C_word y)
return move_buffer_object(ptr, ab, r);
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_u_i_integer_modulo(C_word **ptr, C_word n, C_word x, C_word y)
{
C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, r;
@@ -9306,7 +9380,7 @@ C_s_a_u_i_integer_modulo(C_word **ptr, C_word n, C_word x, C_word y)
return move_buffer_object(ptr, ab, r);
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_i_quotient(C_word **ptr, C_word n, C_word x, C_word y)
{
C_word ab[C_SIZEOF_FIX_BIGNUM*4+C_SIZEOF_FLONUM*2], *a = ab, q,
@@ -9344,7 +9418,7 @@ C_s_a_i_quotient(C_word **ptr, C_word n, C_word x, C_word y)
return move_buffer_object(ptr, ab, q);
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_u_i_integer_quotient(C_word **ptr, C_word n, C_word x, C_word y)
{
C_word ab[C_SIZEOF_FIX_BIGNUM*2], *a = ab, q;
@@ -9462,7 +9536,7 @@ static C_word rat_cmp(C_word x, C_word y)
return result;
}
-C_regparm double C_fcall C_bignum_to_double(C_word bignum)
+C_regparm double C_bignum_to_double(C_word bignum)
{
double accumulator = 0;
C_uword *start = C_bignum_digits(bignum),
@@ -9475,7 +9549,7 @@ C_regparm double C_fcall C_bignum_to_double(C_word bignum)
return(C_bignum_negativep(bignum) ? -accumulator : accumulator);
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_u_i_flo_to_int(C_word **ptr, C_word n, C_word x)
{
int exponent;
@@ -9510,7 +9584,7 @@ fabs_frexp_to_digits(C_uword exp, double sign, C_uword *start, C_uword *scan)
assert(C_isfinite(sign));
assert(0.5 <= sign && sign < 1); /* Guaranteed by frexp() and fabs() */
assert((scan - start) == C_BIGNUM_BITS_TO_DIGITS(exp));
-
+
if (odd_bits > 0) { /* Handle most significant digit first */
sign *= (C_uword)1 << odd_bits;
digit = (C_uword)sign;
@@ -9779,7 +9853,7 @@ static int bignum_cmp_unsigned(C_word x, C_word y)
}
}
-C_regparm C_word C_fcall C_i_bignum_cmp(C_word x, C_word y)
+C_regparm C_word C_i_bignum_cmp(C_word x, C_word y)
{
if (C_bignum_negativep(x)) {
if (C_bignum_negativep(y)) { /* Largest negative number is smallest */
@@ -9819,12 +9893,12 @@ void C_ccall C_nequalp(C_word c, C_word *av)
C_kontinue(k, result);
}
-C_regparm C_word C_fcall C_i_nequalp(C_word x, C_word y)
+C_regparm C_word C_i_nequalp(C_word x, C_word y)
{
return C_mk_bool(basic_cmp(x, y, "=", 1) == C_fix(0));
}
-C_regparm C_word C_fcall C_i_integer_equalp(C_word x, C_word y)
+C_regparm C_word C_i_integer_equalp(C_word x, C_word y)
{
if (x & C_FIXNUM_BIT)
return C_mk_bool(x == y);
@@ -9842,7 +9916,7 @@ void C_ccall C_greaterp(C_word c, C_word *av)
k = av[ 1 ],
result = C_SCHEME_TRUE;
- c -= 2;
+ c -= 2;
av += 2;
if (c == 0) C_kontinue(k, result);
@@ -9862,12 +9936,12 @@ void C_ccall C_greaterp(C_word c, C_word *av)
}
-C_regparm C_word C_fcall C_i_greaterp(C_word x, C_word y)
+C_regparm C_word C_i_greaterp(C_word x, C_word y)
{
return C_mk_bool(basic_cmp(x, y, ">", 0) == C_fix(1));
}
-C_regparm C_word C_fcall C_i_integer_greaterp(C_word x, C_word y)
+C_regparm C_word C_i_integer_greaterp(C_word x, C_word y)
{
if (x & C_FIXNUM_BIT) {
if (y & C_FIXNUM_BIT) {
@@ -9889,7 +9963,7 @@ void C_ccall C_lessp(C_word c, C_word *av)
k = av[ 1 ],
result = C_SCHEME_TRUE;
- c -= 2;
+ c -= 2;
av += 2;
if (c == 0) C_kontinue(k, result);
@@ -9909,12 +9983,12 @@ void C_ccall C_lessp(C_word c, C_word *av)
}
-C_regparm C_word C_fcall C_i_lessp(C_word x, C_word y)
+C_regparm C_word C_i_lessp(C_word x, C_word y)
{
return C_mk_bool(basic_cmp(x, y, "<", 0) == C_fix(-1));
}
-C_regparm C_word C_fcall C_i_integer_lessp(C_word x, C_word y)
+C_regparm C_word C_i_integer_lessp(C_word x, C_word y)
{
if (x & C_FIXNUM_BIT) {
if (y & C_FIXNUM_BIT) {
@@ -9936,7 +10010,7 @@ void C_ccall C_greater_or_equal_p(C_word c, C_word *av)
k = av[ 1 ],
result = C_SCHEME_TRUE;
- c -= 2;
+ c -= 2;
av += 2;
if (c == 0) C_kontinue(k, result);
@@ -9956,13 +10030,13 @@ void C_ccall C_greater_or_equal_p(C_word c, C_word *av)
}
-C_regparm C_word C_fcall C_i_greater_or_equalp(C_word x, C_word y)
+C_regparm C_word C_i_greater_or_equalp(C_word x, C_word y)
{
C_word res = basic_cmp(x, y, ">=", 0);
return C_mk_bool(res == C_fix(0) || res == C_fix(1));
}
-C_regparm C_word C_fcall C_i_integer_greater_or_equalp(C_word x, C_word y)
+C_regparm C_word C_i_integer_greater_or_equalp(C_word x, C_word y)
{
if (x & C_FIXNUM_BIT) {
if (y & C_FIXNUM_BIT) {
@@ -9985,7 +10059,7 @@ void C_ccall C_less_or_equal_p(C_word c, C_word *av)
k = av[ 1 ],
result = C_SCHEME_TRUE;
- c -= 2;
+ c -= 2;
av += 2;
if (c == 0) C_kontinue(k, result);
@@ -10005,14 +10079,14 @@ void C_ccall C_less_or_equal_p(C_word c, C_word *av)
}
-C_regparm C_word C_fcall C_i_less_or_equalp(C_word x, C_word y)
+C_regparm C_word C_i_less_or_equalp(C_word x, C_word y)
{
C_word res = basic_cmp(x, y, "<=", 0);
return C_mk_bool(res == C_fix(0) || res == C_fix(-1));
}
-C_regparm C_word C_fcall C_i_integer_less_or_equalp(C_word x, C_word y)
+C_regparm C_word C_i_integer_less_or_equalp(C_word x, C_word y)
{
if (x & C_FIXNUM_BIT) {
if (y & C_FIXNUM_BIT) {
@@ -10035,7 +10109,7 @@ void C_ccall C_gc(C_word c, C_word *av)
/* closure = av[ 0 ] */
k = av[ 1 ];
int f;
- C_word
+ C_word
arg, *p,
size = 0;
@@ -10076,43 +10150,33 @@ void C_ccall C_open_file_port(C_word c, C_word *av)
{
C_word
/* closure = av[ 0 ] */
- k = av[ 1 ],
+ k = av[ 1 ],
port = av[ 2 ],
channel = av[ 3 ],
mode = av[ 4 ];
C_FILEPTR fp = (C_FILEPTR)NULL;
- C_char fmode[ 4 ];
- C_word n;
- char *buf;
+ C_char *fmode;
+ C_word n, bv, fbv;
+ C_char *buf;
+ C_WCHAR *fbuf;
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';
- if (n != strlen(buf))
+ bv = C_block_item(channel, 0);
+ buf = C_c_string(bv);
+ fbv = C_block_item(mode, 0);
+ fmode = C_c_string(fbv);
+ if (C_header_size(C_block_item(channel, 0)) - 1 != strlen(buf))
barf(C_ASCIIZ_REPRESENTATION_ERROR, "open", channel);
- n = C_header_size(mode);
- if (n >= sizeof(fmode)) n = sizeof(fmode) - 1;
- C_strncpy(fmode, C_c_string(mode), n);
- fmode[ n ] = '\0';
- if (n != strlen(fmode)) /* Shouldn't happen, but never hurts */
+ if (C_header_size(C_block_item(mode, 0)) - 1 != strlen(fmode))
barf(C_ASCIIZ_REPRESENTATION_ERROR, "open", mode);
- fp = C_fopen(buf, fmode);
-
- if(buf != buffer) C_free(buf);
+ fbuf = C_OS_FILENAME(bv, 0);
+ fp = C_fopen(fbuf, C_OS_FILENAME(fbv, 1));
}
-
+
C_set_block_item(port, 0, (C_word)fp);
C_kontinue(k, C_mk_bool(fp != NULL));
}
@@ -10120,46 +10184,37 @@ void C_ccall C_open_file_port(C_word c, C_word *av)
void C_ccall C_allocate_vector(C_word c, C_word *av)
{
- C_word
+ C_word
/* closure = av[ 0 ] */
k = av[ 1 ],
- size, bvecf, init, align8,
- bytes,
- n, *p;
+ size, init, bytes, n, *p;
- if(c != 6) C_bad_argc(c, 6);
+ if(c != 4) C_bad_argc(c, 4);
size = av[ 2 ];
- bvecf = av[ 3 ];
- init = av[ 4 ];
- align8 = av[ 5 ];
+ init = av[ 3 ];
n = C_unfix(size);
if(n > C_HEADER_SIZE_MASK || n < 0)
- barf(C_OUT_OF_RANGE_ERROR, NULL, size, C_fix(C_HEADER_SIZE_MASK));
+ barf(C_OUT_OF_BOUNDS_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);
+ bytes = C_wordstobytes(n) + 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);
- /* We explicitly pass 7 here, that's the number of things saved.
+ /* We explicitly pass 5 here, that's the number of things saved.
* That's the arguments, plus one additional thing: the mode.
*/
- C_reclaim((void *)allocate_vector_2, 7);
+ C_reclaim((void *)allocate_vector_2, 5);
}
C_save(C_SCHEME_FALSE);
@@ -10171,14 +10226,12 @@ void C_ccall C_allocate_vector(C_word c, C_word *av)
void C_ccall allocate_vector_2(C_word c, C_word *av)
{
- C_word
+ C_word
mode = av[ 0 ],
bytes = C_unfix(av[ 1 ]),
- align8 = av[ 2 ],
- bvecf = av[ 3 ],
- init = av[ 4 ],
- size = C_unfix(av[ 5 ]),
- k = av[ 6 ],
+ init = av[ 2 ],
+ size = C_unfix(av[ 3 ]),
+ k = av[ 4 ],
*v0, v;
if(C_truep(mode)) {
@@ -10198,23 +10251,90 @@ void C_ccall allocate_vector_2(C_word c, C_word *av)
}
else v0 = C_alloc(C_bytestowords(bytes));
-#ifndef C_SIXTY_FOUR
- if(C_truep(align8) && C_aligned8(v0)) ++v0;
-#endif
-
v = (C_word)v0;
+ *(v0++) = C_VECTOR_TYPE | size;
+ while(size--) *(v0++) = init;
+ C_kontinue(k, v);
+}
+
+void C_ccall C_allocate_bytevector(C_word c, C_word *av)
+{
+ C_word
+ /* closure = av[ 0 ] */
+ k = av[ 1 ],
+ size, init, align8, bytes, str, n, *p;
+
+ if(c != 4) C_bad_argc(c, 4);
+
+ size = av[ 2 ];
+ init = av[ 3 ];
+ n = C_unfix(size);
+
+ if(n > C_HEADER_SIZE_MASK || n < 0)
+ barf(C_OUT_OF_BOUNDS_ERROR, NULL, size, C_fix(C_HEADER_SIZE_MASK));
- if(!C_truep(bvecf)) {
- *(v0++) = C_VECTOR_TYPE | size | (C_truep(align8) ? C_8ALIGN_BIT : 0);
-
- while(size--) *(v0++) = init;
+ bytes = n + sizeof(C_word) * 2;
+
+ C_save(k);
+ C_save(size);
+ C_save(init);
+ 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);
+ /* We explicitly pass 5 here, that's the number of things saved.
+ * That's the arguments, plus one additional thing: the mode.
+ */
+ C_reclaim((void *)allocate_bytevector_2, 5);
}
- else {
- *(v0++) = C_STRING_TYPE | size;
- if(C_truep(init))
- C_memset(v0, C_character_code(init), size);
+ C_save(C_SCHEME_FALSE);
+ p = C_temporary_stack;
+ C_temporary_stack = C_temporary_stack_bottom;
+ allocate_bytevector_2(0, p);
+}
+
+
+void C_ccall allocate_bytevector_2(C_word c, C_word *av)
+{
+ C_word
+ mode = av[ 0 ],
+ bytes = C_unfix(av[ 1 ]),
+ init = av[ 2 ],
+ size = C_unfix(av[ 3 ]),
+ k = av[ 4 ],
+ *v0, v;
+ char buf[ 4 ];
+
+ 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_aligned8(v0)) ++v0;
+#endif
+
+ v = (C_word)v0;
+ *(v0++) = C_BYTEVECTOR_TYPE | size;
+
+ if(C_truep(init)) C_memset(v0, C_unfix(init), size);
C_kontinue(k, v);
}
@@ -10224,8 +10344,8 @@ static C_word allocate_tmp_bignum(C_word size, C_word negp, C_word initp)
C_word *mem = C_malloc(C_wordstobytes(C_SIZEOF_BIGNUM(C_unfix(size)))),
bigvec = (C_word)(mem + C_SIZEOF_BIGNUM_WRAPPER);
if (mem == NULL) abort(); /* TODO: panic */
-
- C_block_header_init(bigvec, C_STRING_TYPE | C_wordstobytes(C_unfix(size)+1));
+
+ C_block_header_init(bigvec, C_BYTEVECTOR_TYPE | C_wordstobytes(C_unfix(size)+1));
C_set_block_item(bigvec, 0, C_truep(negp));
if (C_truep(initp)) {
@@ -10236,12 +10356,12 @@ static C_word allocate_tmp_bignum(C_word size, C_word negp, C_word initp)
return C_a_i_bignum_wrapper(&mem, bigvec);
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_allocate_scratch_bignum(C_word **ptr, C_word size, C_word negp, C_word initp)
{
C_word big, bigvec = C_scratch_alloc(C_SIZEOF_INTERNAL_BIGNUM_VECTOR(C_unfix(size)));
-
- C_block_header_init(bigvec, C_STRING_TYPE | C_wordstobytes(C_unfix(size)+1));
+
+ C_block_header_init(bigvec, C_BYTEVECTOR_TYPE | C_wordstobytes(C_unfix(size)+1));
C_set_block_item(bigvec, 0, C_truep(negp));
if (C_truep(initp)) {
@@ -10259,7 +10379,7 @@ C_allocate_scratch_bignum(C_word **ptr, C_word size, C_word negp, C_word initp)
* in scratch space, we mark it as reclaimable. This means any
* references to the original bignum are invalid after simplification!
*/
-C_regparm C_word C_fcall C_bignum_simplify(C_word big)
+C_regparm C_word C_bignum_simplify(C_word big)
{
C_uword *start = C_bignum_digits(big),
*last_digit = start + C_bignum_size(big) - 1,
@@ -10352,7 +10472,7 @@ bignum_digits_destructive_scale_down(C_uword *start, C_uword *end, C_uword denom
k = C_BIGNUM_DIGIT_COMBINE(k, C_BIGNUM_DIGIT_LO_HALF(digit)); /* j-1 */
q_j_lo = k / denominator;
k -= q_j_lo * denominator;
-
+
*end = C_BIGNUM_DIGIT_COMBINE(q_j_hi, q_j_lo);
}
return k;
@@ -10434,7 +10554,7 @@ bignum_destructive_divide_unsigned_small(C_word **ptr, C_word x, C_word y, C_wor
start = C_bignum_digits(quotient);
end = start + C_bignum_size(quotient);
-
+
y = (y & C_INT_SIGN_BIT) ? -C_unfix(y) : C_unfix(y);
shift_amount = C_ilen(y) - 1;
@@ -10565,56 +10685,44 @@ bignum_destructive_divide_normalized(C_word big_u, C_word big_v, C_word big_q)
}
-void C_ccall C_string_to_symbol(C_word c, C_word *av)
-{
+/* XXX this should be an inline_allocate routine */
+void C_ccall C_string_to_symbol(C_word c, C_word *av)
+{
C_word
/* closure = av[ 0 ] */
- k = av[ 1 ],
- string;
+ k = av[ 1 ];
int len, key;
- C_word s, *a = C_alloc(C_SIZEOF_SYMBOL + C_SIZEOF_PAIR);
+ C_word s, *a = C_alloc(C_SIZEOF_SYMBOL + C_SIZEOF_PAIR), b;
C_char *name;
- if(c != 3) C_bad_argc(c, 3);
-
- string = av[ 2 ];
-
- 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);
+ b = av[ 2 ];
+ len = C_header_size(b) - 1;
+ name = C_c_string(b);
- key = hash_string(len, name, symbol_table->size, symbol_table->rand, 0);
+ key = hash_string(len, name, symbol_table->size, symbol_table->rand);
if(!C_truep(s = lookup(key, len, name, symbol_table)))
- s = add_symbol(&a, key, string, symbol_table);
+ s = add_symbol(&a, key, b, symbol_table);
C_kontinue(k, s);
}
-void C_ccall C_string_to_keyword(C_word c, C_word *av)
-{
+/* XXX this should be an inline_allocate routine */
+void C_ccall C_string_to_keyword(C_word c, C_word *av)
+{
C_word
/* closure = av[ 0 ] */
- k = av[ 1 ],
- string;
+ k = av[ 1 ];
int len, key;
- C_word s, *a = C_alloc(C_SIZEOF_SYMBOL + C_SIZEOF_PAIR);
+ C_word s, *a = C_alloc(C_SIZEOF_SYMBOL + C_SIZEOF_PAIR), b;
C_char *name;
- if(c != 3) C_bad_argc(c, 3);
-
- string = av[ 2 ];
-
- if(C_immediatep(string) || C_header_bits(string) != C_STRING_TYPE)
- barf(C_BAD_ARGUMENT_TYPE_ERROR, "string->keyword", string);
-
- len = C_header_size(string);
- name = (C_char *)C_data_pointer(string);
- key = hash_string(len, name, keyword_table->size, keyword_table->rand, 0);
+ b = av[ 2 ];
+ len = C_header_size(b) - 1;
+ name = C_c_string(b);
+ key = hash_string(len, name, keyword_table->size, keyword_table->rand);
if(!C_truep(s = lookup(key, len, name, keyword_table))) {
- s = add_symbol(&a, key, string, keyword_table);
+ s = add_symbol(&a, key, b, keyword_table);
C_set_block_item(s, 0, s); /* Keywords evaluate to themselves */
C_set_block_item(s, 2, C_SCHEME_FALSE); /* Keywords have no plists */
}
@@ -10624,7 +10732,7 @@ void C_ccall C_string_to_keyword(C_word c, C_word *av)
/* This will usually return a flonum, but it may also return a cplxnum
* consisting of two flonums, making for a total of 11 words.
*/
-C_regparm C_word C_fcall
+C_regparm C_word
C_a_i_exact_to_inexact(C_word **ptr, int c, C_word n)
{
if (n & C_FIXNUM_BIT) {
@@ -10718,7 +10826,7 @@ C_a_i_exact_to_inexact(C_word **ptr, int c, C_word n)
/* this is different from C_a_i_flonum_round, for R5RS compatibility */
-C_regparm C_word C_fcall C_a_i_flonum_round_proper(C_word **ptr, int c, C_word n)
+C_regparm C_word C_a_i_flonum_round_proper(C_word **ptr, int c, C_word n)
{
double fn, i, f, i2, r;
@@ -10743,7 +10851,7 @@ C_regparm C_word C_fcall C_a_i_flonum_round_proper(C_word **ptr, int c, C_word n
return C_flonum(ptr, r);
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_a_i_flonum_gcd(C_word **p, C_word n, C_word x, C_word y)
{
double xub, yub, r;
@@ -10758,7 +10866,7 @@ C_a_i_flonum_gcd(C_word **p, C_word n, C_word x, C_word y)
if (xub < 0.0) xub = -xub;
if (yub < 0.0) yub = -yub;
-
+
while(yub != 0.0) {
r = fmod(xub, yub);
xub = yub;
@@ -10836,7 +10944,7 @@ inline static void lehmer_gcd(C_word **ptr, C_word u, C_word v, C_word *x, C_wor
* have a C implementation that doesn't consume stack. However,
* we *can* use Lehmer's GCD.
*/
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_u_i_integer_gcd(C_word **ptr, C_word n, C_word x, C_word y)
{
C_word ab[2][C_SIZEOF_BIGNUM(2) * 2], *a, newx, newy, size, i = 0;
@@ -10889,14 +10997,14 @@ C_s_a_u_i_integer_gcd(C_word **ptr, C_word n, C_word x, C_word y)
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_i_digits_to_integer(C_word **ptr, C_word n, C_word str, C_word start, C_word end, C_word radix, C_word negp)
{
if (start == end) {
return C_SCHEME_FALSE;
} else {
size_t nbits;
- char *s = C_c_string(str);
+ char *s = C_c_string(C_block_item(str, 0));
C_word result, size;
end = C_unfix(end);
start = C_unfix(start);
@@ -10993,7 +11101,7 @@ str_to_bignum(C_word bignum, char *str, char *str_end, int radix)
}
-static C_regparm double C_fcall decode_flonum_literal(C_char *str)
+static C_regparm double decode_flonum_literal(C_char *str)
{
C_char *eptr;
double flo;
@@ -11099,7 +11207,7 @@ void C_ccall C_fixnum_to_string(C_word c, C_word *av)
p = to_n_nary(num, radix, neg, 0);
num = C_strlen(p);
- a = C_alloc((C_bytestowords(num) + 1));
+ a = C_alloc(C_SIZEOF_STRING(num));
C_kontinue(k, C_string(&a, num, p));
}
@@ -11156,7 +11264,7 @@ void C_ccall C_flonum_to_string(C_word c, C_word *av)
}
radix = C_strlen(p);
- a = C_alloc((C_bytestowords(radix) + 1));
+ a = C_alloc(C_SIZEOF_STRING(radix));
radix = C_string(&a, radix, p);
C_kontinue(k, radix);
}
@@ -11193,7 +11301,7 @@ void C_ccall C_integer_to_string(C_word c, C_word *av)
len = C_ilen(radix)-1;
len = (nbits + len - 1) / len;
len += C_bignum_negativep(num) ? 1 : 0; /* Add space for negative sign */
-
+
radix_shift = C_ilen(radix) - 1;
if (len > C_RECURSIVE_TO_STRING_THRESHOLD &&
/* The power of two fast path is much faster than recursion */
@@ -11201,16 +11309,14 @@ void C_ccall C_integer_to_string(C_word c, C_word *av)
try_extended_number("##sys#integer->string/recursive",
4, k, num, C_fix(radix), C_fix(len));
} else {
- C_word kab[C_SIZEOF_CLOSURE(4)], *ka = kab, kav[6];
+ C_word kab[C_SIZEOF_CLOSURE(4)], *ka = kab, kav[4];
kav[ 0 ] = (C_word)NULL; /* No "self" closure */
kav[ 1 ] = C_closure(&ka, 4, (C_word)bignum_to_str_2,
k, num, C_fix(radix));
- kav[ 2 ] = C_fix(len);
- kav[ 3 ] = C_SCHEME_TRUE; /* Byte vector */
- kav[ 4 ] = C_SCHEME_FALSE; /* No initialization */
- kav[ 5 ] = C_SCHEME_FALSE; /* Don't align at 8 bytes */
- C_allocate_vector(6, kav);
+ kav[ 2 ] = C_fix(len + 1);
+ kav[ 3 ] = C_SCHEME_FALSE; /* No initialization */
+ C_allocate_bytevector(4, kav);
}
}
}
@@ -11226,10 +11332,12 @@ static void bignum_to_str_2(C_word c, C_word *av)
radix = C_unfix(C_block_item(self, 3));
char
*buf = C_c_string(string),
- *index = buf + C_header_size(string) - 1;
+ *index = buf + C_header_size(string) - 2;
int radix_shift,
negp = (C_bignum_negativep(bignum) ? 1 : 0);
+ C_word us[ 5 ], *a = us;
+ *(index + 1) = '\0';
radix_shift = C_ilen(radix) - 1;
if (((C_uword)1 << radix_shift) == radix) { /* Power of two? */
int radix_mask = radix - 1, big_digit_len = 0, radix_digit;
@@ -11311,21 +11419,23 @@ static void bignum_to_str_2(C_word c, C_word *av)
/* Move index onto first nonzero digit. We're writing a bignum
here: it can't consist of only zeroes. */
while(*++index == '0');
-
+
if (negp) *--index = '-';
-
+
/* Shorten with distance between start and index. */
if (buf != index) {
i = C_header_size(string) - (index - buf);
C_memmove(buf, index, i); /* Move start of number to beginning. */
- C_block_header(string) = C_STRING_TYPE | i; /* Mutate strlength. */
+ buf[ i ] = '\0'; /* terminating 0 */
+ C_block_header(string) = C_BYTEVECTOR_TYPE | i; /* Mutate strlength. */
}
}
- C_kontinue(k, string);
+ C_kontinue(k, C_a_ustring(&a, 0, string, C_fix(C_header_size(string) - 1)));
}
+/* XXX replace with inline routine */
void C_ccall C_make_structure(C_word c, C_word *av)
{
C_word
@@ -11351,13 +11461,14 @@ void C_ccall C_make_structure(C_word c, C_word *av)
}
+/* XXX replace with inline routine */
void C_ccall C_make_symbol(C_word c, C_word *av)
{
C_word
/* closure = av[ 0 ] */
k = av[ 1 ],
name = av[ 2 ],
- ab[ C_SIZEOF_SYMBOL ],
+ ab[ C_SIZEOF_SYMBOL ],
*a = ab,
s0 = (C_word)a;
@@ -11369,12 +11480,13 @@ void C_ccall C_make_symbol(C_word c, C_word *av)
}
+/* XXX replace with inline routine */
void C_ccall C_make_pointer(C_word c, C_word *av)
{
C_word
/* closure = av[ 0 ] */
k = av[ 1 ],
- ab[ 2 ],
+ ab[ 2 ],
*a = ab,
p;
@@ -11383,6 +11495,7 @@ void C_ccall C_make_pointer(C_word c, C_word *av)
}
+/* XXX replace with inline routine */
void C_ccall C_make_tagged_pointer(C_word c, C_word *av)
{
C_word
@@ -11398,14 +11511,14 @@ void C_ccall C_make_tagged_pointer(C_word c, C_word *av)
}
-void C_ccall C_ensure_heap_reserve(C_word c, C_word *av)
+void C_ccall C_ensure_heap_reserve(C_word c, C_word *av)
{
C_word
/* closure = av[ 0 ] */
k = av[ 1 ],
n = av[ 2 ],
*p;
-
+
C_save(k);
if(!C_demand(C_bytestowords(C_unfix(n))))
@@ -11452,7 +11565,7 @@ void C_ccall C_get_symbol_table_info(C_word c, C_word *av)
for(stp = symbol_table_list; stp != NULL; stp = stp->next)
++n;
-
+
d1 = compute_symbol_table_load(&d2, &total);
x = C_flonum(&a, d1); /* load */
y = C_flonum(&a, d2); /* avg bucket length */
@@ -11565,18 +11678,18 @@ void C_ccall C_decode_seconds(C_word c, C_word *av)
time_t tsecs;
struct tm *tmt;
C_word
- ab[ C_SIZEOF_VECTOR(10) ],
+ ab[ C_SIZEOF_VECTOR(10) ],
*a = ab,
info;
tsecs = (time_t)C_num_to_int64(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),
@@ -11613,7 +11726,7 @@ void C_ccall C_machine_byte_order(C_word c, C_word *av)
C_cblockend;
#endif
- a = C_alloc(2 + C_bytestowords(strlen(str)));
+ a = C_alloc(C_SIZEOF_STRING(strlen(str)));
s = C_string2(&a, str);
C_kontinue(k, s);
@@ -11622,16 +11735,16 @@ void C_ccall C_machine_byte_order(C_word c, C_word *av)
void C_ccall C_machine_type(C_word c, C_word *av)
{
- C_word
+ C_word
/* closure = av[ 0 ] */
k = av[ 1 ],
*a, s;
if(c != 2) C_bad_argc(c, 2);
- a = C_alloc(2 + C_bytestowords(strlen(C_MACHINE_TYPE)));
+ a = C_alloc(C_SIZEOF_STRING(C_strlen(C_MACHINE_TYPE)));
s = C_string2(&a, C_MACHINE_TYPE);
-
+
C_kontinue(k, s);
}
@@ -11645,7 +11758,7 @@ void C_ccall C_software_type(C_word c, C_word *av)
if(c != 2) C_bad_argc(c, 2);
- a = C_alloc(2 + C_bytestowords(strlen(C_SOFTWARE_TYPE)));
+ a = C_alloc(C_SIZEOF_STRING(C_strlen(C_SOFTWARE_TYPE)));
s = C_string2(&a, C_SOFTWARE_TYPE);
C_kontinue(k, s);
@@ -11661,7 +11774,7 @@ void C_ccall C_build_platform(C_word c, C_word *av)
if(c != 2) C_bad_argc(c, 2);
- a = C_alloc(2 + C_bytestowords(strlen(C_BUILD_PLATFORM)));
+ a = C_alloc(C_SIZEOF_STRING(C_strlen(C_BUILD_PLATFORM)));
s = C_string2(&a, C_BUILD_PLATFORM);
C_kontinue(k, s);
@@ -11677,7 +11790,7 @@ void C_ccall C_software_version(C_word c, C_word *av)
if(c != 2) C_bad_argc(c, 2);
- a = C_alloc(2 + C_bytestowords(strlen(C_SOFTWARE_VERSION)));
+ a = C_alloc(C_SIZEOF_STRING(C_strlen(C_SOFTWARE_VERSION)));
s = C_string2(&a, C_SOFTWARE_VERSION);
C_kontinue(k, s);
@@ -11703,7 +11816,7 @@ void C_ccall C_register_finalizer(C_word c, C_word *av)
}
-/*XXX could this be made static? is it used in eggs somewhere?
+/*XXX could this be made static? is it used in eggs somewhere?
if not, declare as fcall/regparm (and static, remove from chicken.h)
*/
void C_ccall C_do_register_finalizer(C_word x, C_word proc)
@@ -11808,13 +11921,13 @@ void C_ccall dload_2(C_word c, C_word *av0)
name = av0[ 1 ],
k = av0[ 2 ],,
av[ 2 ];
- C_char *mname = (C_char *)C_data_pointer(name);
+ C_char *mname = C_c_string(name);
/*
* C_fprintf(C_stderr,
* "shl_loading %s : %s\n",
- * (char *) C_data_pointer(name),
- * (char *) C_data_pointer(entry));
+ * (char *) C_c_string(name),
+ * (char *) C_c_string(entry));
*/
if ((handle = (void *) shl_load(mname,
@@ -11823,7 +11936,7 @@ void C_ccall dload_2(C_word c, C_word *av0)
shl_t shl_handle = (shl_t) handle;
/*** This version does not check for C_dynamic_and_unsafe. Fix it. */
- if (shl_findsym(&shl_handle, (char *) C_data_pointer(entry), TYPE_PROCEDURE, &p) == 0) {
+ if (shl_findsym(&shl_handle, (char *) C_c_string(entry), TYPE_PROCEDURE, &p) == 0) {
current_module_name = C_strdup(mname);
current_module_handle = handle;
@@ -11855,13 +11968,13 @@ void C_ccall dload_2(C_word c, C_word *av0)
void C_ccall dload_2(C_word c, C_word *av0)
{
void *handle, *p, *p2;
- C_word
+ C_word
entry = av0[ 0 ],
name = av0[ 1 ],
k = av0[ 2 ],
av[ 2 ];
- C_char *topname = (C_char *)C_data_pointer(entry);
- C_char *mname = (C_char *)C_data_pointer(name);
+ C_char *topname = (C_char *)C_c_string(entry);
+ C_char *mname = (C_char *)C_c_string(name);
C_char *tmp;
int tmp_len = 0;
@@ -11895,7 +12008,7 @@ void C_ccall dload_2(C_word c, C_word *av0)
C_dlclose(handle);
}
-
+
C_dlerror = (char *)dlerror();
C_kontinue(k, C_SCHEME_FALSE);
}
@@ -11914,15 +12027,17 @@ void C_ccall dload_2(C_word c, C_word *av0)
name = av0[ 1 ],
k = av0[ 2 ],
av[ 2 ];
- C_char *topname = (C_char *)C_data_pointer(entry);
- C_char *mname = (C_char *)C_data_pointer(name);
+ C_char *topname = (C_char *)C_c_string(entry);
+ C_char *mname = (C_char *)C_c_string(name);
/* cannot use LoadLibrary on non-DLLs, so we use extension checking */
- if (C_header_size(name) >= 5) {
- char *n = (char*) C_data_pointer(name);
- int l = C_header_size(name);
- if (C_strncasecmp(".dll", n+l-5, 4) &&
- C_strncasecmp(".so", n+l-4, 3))
+ if (C_strlen(mname) >= 5) {
+ C_char *n = mname;
+ int l = C_strlen(mname);
+ if (C_strncmp(".dll", n+l-4, 4) &&
+ C_strncmp(".DLL", n+l-4, 4) &&
+ C_strncmp(".so", n+l-3, 3) &&
+ C_strncmp(".SO", n+l-3, 3))
C_kontinue(k, C_SCHEME_FALSE);
}
@@ -11949,7 +12064,7 @@ void C_ccall dload_2(C_word c, C_word *av0)
#endif
-void C_ccall C_become(C_word c, C_word *av)
+void C_ccall C_become(C_word c, C_word *av)
{
C_word
/* closure = av[ 0 ] */
@@ -11968,7 +12083,7 @@ void C_ccall C_become(C_word c, C_word *av)
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;
@@ -11994,7 +12109,7 @@ void C_ccall become_2(C_word c, C_word *av)
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_a_i_cpu_time(C_word **a, int c, C_word buf)
{
C_word u, s = C_fix(0);
@@ -12019,7 +12134,7 @@ C_a_i_cpu_time(C_word **a, int c, C_word buf)
}
-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_regparm C_word 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);
@@ -12048,7 +12163,7 @@ C_regparm C_word C_fcall C_a_i_make_locative(C_word **a, int c, C_word type, C_w
return (C_word)loc;
}
-C_regparm C_word C_fcall C_a_i_locative_ref(C_word **a, int c, C_word loc)
+C_regparm C_word C_a_i_locative_ref(C_word **a, int c, C_word loc)
{
C_word *ptr;
@@ -12061,7 +12176,7 @@ C_regparm C_word C_fcall C_a_i_locative_ref(C_word **a, int c, C_word loc)
switch(C_unfix(C_block_item(loc, 2))) {
case C_SLOT_LOCATIVE: return *ptr;
- case C_CHAR_LOCATIVE: return C_make_character(*((char *)ptr));
+ case C_CHAR_LOCATIVE: return C_utf_decode_ptr((C_char *)ptr);
case C_U8_LOCATIVE: return C_fix(*((unsigned char *)ptr));
case C_S8_LOCATIVE: return C_fix(*((char *)ptr));
case C_U16_LOCATIVE: return C_fix(*((unsigned short *)ptr));
@@ -12076,7 +12191,7 @@ C_regparm C_word C_fcall C_a_i_locative_ref(C_word **a, int c, C_word loc)
}
}
-C_regparm C_word C_fcall C_i_locative_set(C_word loc, C_word x)
+C_regparm C_word C_i_locative_set(C_word loc, C_word x)
{
C_word *ptr, val;
@@ -12094,78 +12209,79 @@ C_regparm C_word C_fcall C_i_locative_set(C_word loc, C_word x)
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);
+
+ /* does not check for exceeded buffer length! */
+ C_utf_encode((C_char *)ptr, C_character_code(x));
break;
- case C_U8_LOCATIVE:
+ 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);
+ *((unsigned char *)ptr) = C_unfix(x);
break;
- case C_S8_LOCATIVE:
+ case C_S8_LOCATIVE:
if((x & C_FIXNUM_BIT) == 0)
barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
-
- *((char *)ptr) = C_unfix(x);
+
+ *((char *)ptr) = C_unfix(x);
break;
- case C_U16_LOCATIVE:
+ 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);
+ *((unsigned short *)ptr) = C_unfix(x);
break;
- case C_S16_LOCATIVE:
+ case C_S16_LOCATIVE:
if((x & C_FIXNUM_BIT) == 0)
barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
- *((short *)ptr) = C_unfix(x);
+ *((short *)ptr) = C_unfix(x);
break;
- case C_U32_LOCATIVE:
+ case C_U32_LOCATIVE:
if(!C_truep(C_i_exact_integerp(x)))
barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
- *((C_u32 *)ptr) = C_num_to_unsigned_int(x);
+ *((C_u32 *)ptr) = C_num_to_unsigned_int(x);
break;
- case C_S32_LOCATIVE:
+ case C_S32_LOCATIVE:
if(!C_truep(C_i_exact_integerp(x)))
barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
-
- *((C_s32 *)ptr) = C_num_to_int(x);
+
+ *((C_s32 *)ptr) = C_num_to_int(x);
break;
- case C_U64_LOCATIVE:
+ case C_U64_LOCATIVE:
if(!C_truep(C_i_exact_integerp(x)))
barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
- *((C_u64 *)ptr) = C_num_to_uint64(x);
+ *((C_u64 *)ptr) = C_num_to_uint64(x);
break;
- case C_S64_LOCATIVE:
+ case C_S64_LOCATIVE:
if(!C_truep(C_i_exact_integerp(x)))
barf(C_BAD_ARGUMENT_TYPE_ERROR, "locative-set!", x);
-
- *((C_s64 *)ptr) = C_num_to_int64(x);
+
+ *((C_s64 *)ptr) = C_num_to_int64(x);
break;
- case C_F32_LOCATIVE:
+ 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);
+
+ *((float *)ptr) = C_flonum_magnitude(x);
break;
- case C_F64_LOCATIVE:
+ 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);
+
+ *((double *)ptr) = C_flonum_magnitude(x);
break;
default: panic(C_text("bad locative type"));
@@ -12175,7 +12291,7 @@ C_regparm C_word C_fcall C_i_locative_set(C_word loc, C_word x)
}
-C_regparm C_word C_fcall C_i_locative_to_object(C_word loc)
+C_regparm C_word C_i_locative_to_object(C_word loc)
{
C_word *ptr;
@@ -12189,7 +12305,7 @@ C_regparm C_word C_fcall C_i_locative_to_object(C_word loc)
}
-C_regparm C_word C_fcall C_i_locative_index(C_word loc)
+C_regparm C_word C_i_locative_index(C_word loc)
{
int bytes;
@@ -12202,6 +12318,11 @@ C_regparm C_word C_fcall C_i_locative_index(C_word loc)
case C_SLOT_LOCATIVE: return C_fix(bytes/sizeof(C_word)); break;
case C_CHAR_LOCATIVE:
+ { C_word x = C_i_locative_to_object(loc);
+ if(x == C_SCHEME_FALSE)
+ barf(C_LOST_LOCATIVE_ERROR, "locative-index", loc);
+ return C_fix(C_utf_char_position(x, bytes)); }
+
case C_U8_LOCATIVE:
case C_S8_LOCATIVE: return C_fix(bytes); break;
@@ -12223,7 +12344,7 @@ C_regparm C_word C_fcall C_i_locative_index(C_word loc)
/* GC protection of user-variables: */
-C_regparm void C_fcall C_gc_protect(C_word **addr, int n)
+C_regparm void C_gc_protect(C_word **addr, int n)
{
int k;
@@ -12233,7 +12354,7 @@ C_regparm void C_fcall C_gc_protect(C_word **addr, int n)
if(collectibles == NULL)
panic(C_text("out of memory - cannot allocate GC protection vector"));
-
+
collectibles_top = collectibles + k;
collectibles_limit = collectibles + k * 2;
}
@@ -12243,7 +12364,7 @@ C_regparm void C_fcall C_gc_protect(C_word **addr, int n)
}
-C_regparm void C_fcall C_gc_unprotect(int n)
+C_regparm void C_gc_unprotect(int n)
{
collectibles_top -= n;
}
@@ -12300,7 +12421,7 @@ void C_ccall C_copy_closure(C_word c, C_word *av)
*p;
int n = C_header_size(proc);
- if(!C_demand(n + 1))
+ if(!C_demand(n + 1))
C_save_and_reclaim_args((void *)copy_closure_2, 2, proc, k);
else {
C_save(proc);
@@ -12314,7 +12435,7 @@ void C_ccall C_copy_closure(C_word c, C_word *av)
static void C_ccall copy_closure_2(C_word c, C_word *av)
{
- C_word
+ C_word
k = av[ 0 ],
proc = av[ 1 ];
int cells = C_header_size(proc);
@@ -12344,14 +12465,14 @@ void C_ccall C_call_with_cthulhu(C_word c, C_word *av)
}
-/* fixnum arithmetic with overflow detection (from "Hacker's Delight" by Hank Warren)
- These routines return #f if the operation failed due to overflow.
+/* 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_regparm C_word 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);
@@ -12367,7 +12488,7 @@ C_regparm C_word C_fcall C_i_o_fixnum_plus(C_word n1, C_word n2)
}
-C_regparm C_word C_fcall C_i_o_fixnum_difference(C_word n1, C_word n2)
+C_regparm C_word C_i_o_fixnum_difference(C_word n1, C_word n2)
{
C_word x1, x2, s;
@@ -12376,7 +12497,7 @@ C_regparm C_word C_fcall C_i_o_fixnum_difference(C_word n1, C_word n2)
x1 = C_unfix(n1);
x2 = C_unfix(n2);
s = x1 - x2;
-
+
#ifdef C_SIXTY_FOUR
if((((s ^ x1) & ~(s ^ x2)) >> 62) != 0) return C_SCHEME_FALSE;
#else
@@ -12386,7 +12507,7 @@ C_regparm C_word C_fcall C_i_o_fixnum_difference(C_word n1, C_word n2)
}
-C_regparm C_word C_fcall C_i_o_fixnum_times(C_word n1, C_word n2)
+C_regparm C_word C_i_o_fixnum_times(C_word n1, C_word n2)
{
C_word x1, x2;
C_uword x1u, x2u;
@@ -12410,7 +12531,7 @@ C_regparm C_word C_fcall C_i_o_fixnum_times(C_word n1, C_word n2)
x2u = x2 < 0 ? -x2 : x2;
if(x2u != 0 && x1u > (c / x2u)) return C_SCHEME_FALSE;
-
+
x1 = x1 * x2;
if(C_fitsinfixnump(x1)) return C_fix(x1);
@@ -12418,7 +12539,7 @@ C_regparm C_word C_fcall C_i_o_fixnum_times(C_word n1, C_word n2)
}
-C_regparm C_word C_fcall C_i_o_fixnum_quotient(C_word n1, C_word n2)
+C_regparm C_word C_i_o_fixnum_quotient(C_word n1, C_word n2)
{
C_word x1, x2;
@@ -12443,7 +12564,7 @@ C_regparm C_word C_fcall C_i_o_fixnum_quotient(C_word n1, C_word n2)
}
-C_regparm C_word C_fcall C_i_o_fixnum_and(C_word n1, C_word n2)
+C_regparm C_word C_i_o_fixnum_and(C_word n1, C_word n2)
{
C_uword x1, x2, r;
@@ -12452,13 +12573,13 @@ C_regparm C_word C_fcall C_i_o_fixnum_and(C_word n1, C_word n2)
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_regparm C_word C_i_o_fixnum_ior(C_word n1, C_word n2)
{
C_uword x1, x2, r;
@@ -12467,13 +12588,13 @@ C_regparm C_word C_fcall C_i_o_fixnum_ior(C_word n1, C_word n2)
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_regparm C_word C_i_o_fixnum_xor(C_word n1, C_word n2)
{
C_uword x1, x2, r;
@@ -12482,7 +12603,7 @@ C_regparm C_word C_fcall C_i_o_fixnum_xor(C_word n1, C_word n2)
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);
}
@@ -12490,7 +12611,7 @@ C_regparm C_word C_fcall C_i_o_fixnum_xor(C_word n1, C_word n2)
/* decoding of literals in compressed format */
-static C_regparm C_uword C_fcall decode_size(C_char **str)
+static C_regparm C_uword decode_size(C_char **str)
{
C_uchar **ustr = (C_uchar **)str;
C_uword size = (*((*ustr)++) & 0xff) << 16; /* always big endian */
@@ -12501,7 +12622,7 @@ static C_regparm C_uword C_fcall decode_size(C_char **str)
}
-static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
+static C_regparm C_word decode_literal2(C_word **ptr, C_char **str,
C_word *dest)
{
C_ulong bits = *((*str)++) & 0xff;
@@ -12523,10 +12644,10 @@ static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
if(bits == C_HEADER_BITS_MASK) { /* special/immediate */
switch(0xff & *((*str)++)) {
- case C_BOOLEAN_BITS:
+ case C_BOOLEAN_BITS:
return C_mk_bool(*((*str)++));
- case C_CHARACTER_BITS:
+ case C_CHARACTER_BITS:
return C_make_character(decode_size(str));
case C_SCHEME_END_OF_LIST:
@@ -12540,8 +12661,9 @@ static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
val |= ((C_uword)*((*str)++) & 0xff) << 16;
val |= ((C_uword)*((*str)++) & 0xff) << 8;
val |= ((C_uword)*((*str)++) & 0xff);
- return C_fix(val);
+ return C_fix(val);
+/* XXX Handle legacy bignum encoding */
#ifdef C_SIXTY_FOUR
case ((C_STRING_TYPE | C_GC_FORWARDING_BIT) >> (24 + 32)) & 0xff:
#else
@@ -12549,8 +12671,17 @@ static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
#endif
bits = (C_STRING_TYPE | C_GC_FORWARDING_BIT);
break;
+/* XXX */
+
+#ifdef C_SIXTY_FOUR
+ case ((C_BYTEVECTOR_TYPE | C_GC_FORWARDING_BIT) >> (24 + 32)) & 0xff:
+#else
+ case ((C_BYTEVECTOR_TYPE | C_GC_FORWARDING_BIT) >> 24) & 0xff:
+#endif
+ bits = (C_BYTEVECTOR_TYPE | C_GC_FORWARDING_BIT);
+ break;
- default:
+ default:
panic(C_text("invalid encoded special literal"));
}
}
@@ -12576,27 +12707,39 @@ static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
size = decode_size(str);
switch(bits) {
- /* This cannot be encoded as a blob due to endianness differences */
- case (C_STRING_TYPE | C_GC_FORWARDING_BIT): /* This represents "exact int" */
+ /* This cannot be encoded as a bytevector due to endianness differences */
+
+ /* XXX legacy bignum encoding: */
+ case (C_STRING_TYPE | C_BYTEBLOCK_BIT | C_GC_FORWARDING_BIT): /* This represents "exact int" */
+ /* XXX */
+ case (C_BYTEVECTOR_TYPE | C_GC_FORWARDING_BIT): /* This represents "exact int" */
/* bignums are also allocated statically */
val = C_static_bignum(ptr, size, *str);
*str += size;
break;
- case C_STRING_TYPE:
+ /* XXX legacy encoding: */
+ case (C_STRING_TYPE | C_BYTEBLOCK_BIT):
/* strings are always allocated statically */
val = C_static_string(ptr, size, *str);
*str += size;
break;
-
+ /* XXX */
+
+ case C_STRING_TYPE:
+ /* strings are always allocated statically */
+ val = C_static_string(ptr, size - 1, *str);
+ *str += size;
+ break;
+
case C_BYTEVECTOR_TYPE:
- /* ... as are bytevectors (blobs) */
+ /* ... as are bytevectors */
val = C_static_bytevector(ptr, size, *str);
*str += size;
break;
-
+
case C_SYMBOL_TYPE:
- if(dest == NULL)
+ if(dest == NULL)
panic(C_text("invalid literal symbol destination"));
if (**str == '\1') {
@@ -12641,7 +12784,7 @@ static C_regparm C_word C_fcall decode_literal2(C_word **ptr, C_char **str,
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_decode_literal(C_word **ptr, C_char *str)
{
return decode_literal2(ptr, &str, NULL);
@@ -12692,7 +12835,7 @@ C_char *
C_resolve_executable_pathname(C_char *fname)
{
int n;
- C_char *buffer = (C_char *) C_malloc(C_MAX_PATH);
+ C_WCHAR *buffer = (C_WCHAR *) C_malloc(C_MAX_PATH);
if(buffer == NULL) return NULL;
@@ -12713,11 +12856,13 @@ C_resolve_executable_pathname(C_char *fname)
buffer[n] = '\0';
return buffer;
#elif defined(_WIN32) && !defined(__CYGWIN__)
- n = GetModuleFileName(NULL, buffer, C_MAX_PATH);
+ n = GetModuleFileNameW(NULL, buffer, C_MAX_PATH);
if(n == 0 || n >= C_MAX_PATH)
goto error;
- return buffer;
+ C_char *buf2 = C_strdup(C_utf8(buffer));
+ C_free(buffer);
+ return buf2;
#elif defined(C_MACOSX)
C_char buf[C_MAX_PATH];
C_u32 size = C_MAX_PATH;
@@ -12775,7 +12920,7 @@ C_resolve_executable_pathname(C_char *fname)
}
/* walk PATH */
- if((path = C_getenv("PATH")) == NULL)
+ if((path = getenv("PATH")) == NULL)
goto error;
do {
@@ -12808,7 +12953,7 @@ error:
return NULL;
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_i_getprop(C_word sym, C_word prop, C_word def)
{
C_word pl = C_symbol_plist(sym);
@@ -12823,7 +12968,7 @@ C_i_getprop(C_word sym, C_word prop, C_word def)
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_putprop(C_word **ptr, C_word sym, C_word prop, C_word val)
{
C_word pl = C_symbol_plist(sym);
@@ -12846,7 +12991,7 @@ C_putprop(C_word **ptr, C_word sym, C_word prop, C_word val)
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_i_get_keyword(C_word kw, C_word args, C_word def)
{
while(!C_immediatep(args)) {
@@ -12891,8 +13036,7 @@ C_word C_i_dump_statistical_profile()
if(debug_mode)
C_dbg(C_text("debug"), C_text("dumping statistical profile to `%s'...\n"), buffer);
-
- fp = C_fopen(buffer, "w");
+ fp = fopen(buffer, "w");
if (fp == NULL)
panic(C_text("could not write profile!"));
@@ -12961,7 +13105,7 @@ hdump_count(C_word key, int n, int t)
}
b = (HDUMP_BUCKET *)C_malloc(sizeof(HDUMP_BUCKET));
-
+
if(b == 0)
panic(C_text("out of memory - can not allocate heap-dump table-bucket"));
@@ -12983,7 +13127,7 @@ static void C_ccall dump_heap_state_2(C_word c, C_word *av)
C_header h;
C_word x, key, *p;
int imm = 0, blk = 0;
-
+
hdump_table = (HDUMP_BUCKET **)C_malloc(HDUMP_TABLE_SIZE * sizeof(HDUMP_BUCKET *));
if(hdump_table == NULL)
@@ -12997,7 +13141,7 @@ static void C_ccall dump_heap_state_2(C_word c, C_word *av)
++blk;
sbp = (C_SCHEME_BLOCK *)scan;
- if(*((C_word *)sbp) == ALIGNMENT_HOLE_MARKER)
+ if(*((C_word *)sbp) == ALIGNMENT_HOLE_MARKER)
sbp = (C_SCHEME_BLOCK *)((C_word *)sbp + 1);
n = C_header_size(sbp);
@@ -13042,7 +13186,7 @@ static void C_ccall dump_heap_state_2(C_word c, C_word *av)
bp = hdump_table;
/* HACK */
#define C_WEAK_PAIR_TYPE (C_PAIR_TYPE | C_SPECIALBLOCK_BIT)
-
+
for(n = 0; n < HDUMP_TABLE_SIZE; ++n) {
for(b = bp[ n ]; b != NULL; b = b2) {
b2 = b->next;
@@ -13073,7 +13217,7 @@ static void C_ccall dump_heap_state_2(C_word c, C_word *av)
case C_CPLXNUM_TYPE: C_fprintf(C_stderr, C_text("cplxnum ")); break;
case C_RATNUM_TYPE: C_fprintf(C_stderr, C_text("ratnum ")); break;
/* XXX this is sort of funny: */
- case C_BYTEBLOCK_BIT: C_fprintf(C_stderr, C_text("blob ")); break;
+ case C_BYTEBLOCK_BIT: C_fprintf(C_stderr, C_text("bytevector ")); break;
default:
x = b->key;
@@ -13086,7 +13230,7 @@ static void C_ccall dump_heap_state_2(C_word c, C_word *av)
C_fprintf(C_stderr, C_text("\t%d"), b->count);
- if(b->total > 0)
+ if(b->total > 0)
C_fprintf(C_stderr, C_text("\t%d bytes"), b->total);
C_fputc('\n', C_stderr);
@@ -13104,7 +13248,7 @@ static void C_ccall dump_heap_state_2(C_word c, C_word *av)
static void C_ccall filter_heap_objects_2(C_word c, C_word *av)
{
void *func = C_pointer_address(av[ 0 ]);
- C_word
+ C_word
userarg = av[ 1 ],
vector = av[ 2 ],
k = av[ 3 ];
@@ -13123,7 +13267,7 @@ static void C_ccall filter_heap_objects_2(C_word c, C_word *av)
while(scan < C_fromspace_top) {
sbp = (C_SCHEME_BLOCK *)scan;
- if(*((C_word *)sbp) == ALIGNMENT_HOLE_MARKER)
+ if(*((C_word *)sbp) == ALIGNMENT_HOLE_MARKER)
sbp = (C_SCHEME_BLOCK *)((C_word *)sbp + 1);
n = C_header_size(sbp);
@@ -13166,7 +13310,7 @@ void C_ccall C_filter_heap_objects(C_word c, C_word *av)
C_reclaim((void *)filter_heap_objects_2, 4);
}
-C_regparm C_word C_fcall C_i_process_sleep(C_word n)
+C_regparm C_word C_i_process_sleep(C_word n)
{
#if defined(_WIN32) && !defined(__CYGWIN__)
Sleep(C_unfix(n) * 1000);
@@ -13176,13 +13320,17 @@ C_regparm C_word C_fcall C_i_process_sleep(C_word n)
#endif
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_i_file_exists_p(C_word name, C_word file, C_word dir)
{
+#if defined(_WIN32) && !defined(__CYGWIN__)
+ struct _stat64i32 buf;
+#else
struct stat buf;
+#endif
int res;
- res = C_stat(C_c_string(name), &buf);
+ res = C_stat(C_OS_FILENAME(name, 0), &buf);
if(res != 0) {
switch(errno) {
@@ -13200,7 +13348,7 @@ C_i_file_exists_p(C_word name, C_word file, C_word dir)
}
-C_regparm C_word C_fcall
+C_regparm C_word
C_i_pending_interrupt(C_word dummy)
{
if(pending_interrupts_count > 0) {
@@ -13213,7 +13361,7 @@ C_i_pending_interrupt(C_word dummy)
}
-/* random numbers, mostly lifted from
+/* random numbers, mostly lifted from
https://github.com/jedisct1/libsodium/blob/master/src/libsodium/randombytes/sysrandom/randombytes_sysrandom.c
*/
@@ -13222,7 +13370,7 @@ C_i_pending_interrupt(C_word dummy)
#endif
-#if !defined(_WIN32)
+#if !defined(_WIN32)
static C_word random_urandom(C_word buf, int count)
{
static int fd = -1;
@@ -13283,19 +13431,19 @@ C_word C_random_bytes(C_word buf, C_word size)
#elif defined(_WIN32) && !defined(__CYGWIN__)
typedef BOOLEAN (*func)(PVOID, ULONG);
static func RtlGenRandom = NULL;
-
+
if(RtlGenRandom == NULL) {
HMODULE mod = LoadLibrary("advapi32.dll");
-
+
if(mod == NULL) return C_SCHEME_FALSE;
-
+
if((RtlGenRandom = (func)GetProcAddress(mod, "SystemFunction036")) == NULL)
return C_SCHEME_FALSE;
}
-
- if(!RtlGenRandom((PVOID)C_data_pointer(buf), (LONG)count))
+
+ if(!RtlGenRandom((PVOID)C_data_pointer(buf), (LONG)count))
return C_SCHEME_FALSE;
-#else
+#else
return random_urandom(buf, count);
#endif
@@ -13309,21 +13457,21 @@ C_word C_random_bytes(C_word buf, C_word size)
*/
static C_uword random_word(void)
-{
- C_uword a, b, c, d, r;
- a = random_state[random_state_index];
- c = random_state[(random_state_index+13)&15];
- b = a^c^(a<<16)^(c<<15);
- c = random_state[(random_state_index+9)&15];
- c ^= (c>>11);
- a = random_state[random_state_index] = b^c;
- d = a^((a<<5)&0xDA442D24UL);
- random_state_index = (random_state_index + 15)&15;
- a = random_state[random_state_index];
- random_state[random_state_index] = a^b^d^(a<<2)^(b<<18)^(c<<28);
+{
+ C_uword a, b, c, d, r;
+ a = random_state[random_state_index];
+ c = random_state[(random_state_index+13)&15];
+ b = a^c^(a<<16)^(c<<15);
+ c = random_state[(random_state_index+9)&15];
+ c ^= (c>>11);
+ a = random_state[random_state_index] = b^c;
+ d = a^((a<<5)&0xDA442D24UL);
+ random_state_index = (random_state_index + 15)&15;
+ a = random_state[random_state_index];
+ random_state[random_state_index] = a^b^d^(a<<2)^(b<<18)^(c<<28);
r = random_state[random_state_index];
return r;
-}
+}
static C_uword random_uniform(C_uword bound)
@@ -13341,10 +13489,10 @@ static C_uword random_uniform(C_uword bound)
return r % bound;
}
-
+
C_regparm C_word C_random_fixnum(C_word n)
-{
+{
C_word nf;
if (!(n & C_FIXNUM_BIT))
@@ -13353,19 +13501,19 @@ C_regparm C_word C_random_fixnum(C_word n)
nf = C_unfix(n);
if(nf < 0)
- barf(C_OUT_OF_RANGE_ERROR, "pseudo-random-integer", n, C_fix(0));
+ barf(C_OUT_OF_BOUNDS_ERROR, "pseudo-random-integer", n, C_fix(0));
return C_fix(random_uniform(nf));
-}
+}
-C_regparm C_word C_fcall
+C_regparm C_word
C_s_a_u_i_random_int(C_word **ptr, C_word n, C_word rn)
{
C_uword *start, *end;
if(C_bignum_negativep(rn))
- barf(C_OUT_OF_RANGE_ERROR, "pseudo-random-integer", rn, C_fix(0));
+ barf(C_OUT_OF_BOUNDS_ERROR, "pseudo-random-integer", rn, C_fix(0));
int len = integer_length_abs(rn);
C_word size = C_fix(C_BIGNUM_BITS_TO_DIGITS(len));
@@ -13403,7 +13551,7 @@ static inline C_u64 random64() {
}
#if defined(__GNUC__) && !defined(__TINYC__)
-# define clz64 __builtin_clzll
+# define clz64 __builtin_clzll
#else
/* https://en.wikipedia.org/wiki/Find_first_set#CLZ */
static const C_uchar clz_table_4bit[16] = { 4, 3, 2, 2, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0 };
@@ -13418,7 +13566,7 @@ int clz32(C_u32 x)
return n;
}
-int clz64(C_u64 x)
+int clz64(C_u64 x)
{
int y = clz32(x >> 32);
@@ -13428,7 +13576,7 @@ int clz64(C_u64 x)
}
#endif
-C_regparm C_word C_fcall
+C_regparm C_word
C_a_i_random_real(C_word **ptr, C_word n) {
int exponent = -64;
uint64_t significand;
@@ -13466,3 +13614,77 @@ C_word C_set_random_seed(C_word buf, C_word n)
random_state_index = 0;
return C_SCHEME_FALSE;
}
+
+C_word C_a_extract_struct_2(C_word **ptr, size_t sz, void *sp)
+{
+ C_word bv = C_scratch_alloc(C_SIZEOF_BYTEVECTOR(sz));
+ C_word w;
+ C_block_header_init(bv, C_make_header(C_BYTEVECTOR_TYPE, sz));
+ C_memcpy(C_data_pointer(bv), sp, sz);
+ w = C_a_i_record2(ptr, 2, C_SCHEME_FALSE, bv);
+ return w;
+}
+
+C_regparm C_word C_i_setenv(C_word var, C_word val)
+{
+#if defined(_WIN32) && !defined(__CYGWIN__)
+ C_WCHAR *wvar = C_utf16(var,0);
+ C_WCHAR *wval = val == C_SCHEME_FALSE ? NULL : C_utf16(val, 1);
+ SetEnvironmentVariableW(wvar, wval);
+ return C_fix(0);
+#elif defined(HAVE_SETENV)
+ C_char *cvar = C_c_string(var);
+ if(val == C_SCHEME_FALSE) unsetenv(C_c_string(var));
+ else setenv(C_c_string(var), C_c_string(val), 1);
+ return(C_fix(0));
+#else
+ char *sx = C_c_string(C_var),
+ *sy = (val == C_SCHEME_FALSE ? "" : C_c_string(val));
+ int n1 = C_strlen(sx), n2 = C_strlen(sy);
+ int buf_len = n1 + n2 + 2;
+ char *buf = (char *)C_malloc(buf_len);
+ if(buf == NULL) return(C_fix(0));
+ else {
+ C_strlcpy(buf, sx, buf_len);
+ C_strlcat(buf, "=", buf_len);
+ C_strlcat(buf, sy, buf_len);
+ return(C_fix(putenv(buf)));
+ }
+#endif
+}
+
+C_char *C_getenv(C_word var)
+{
+#if defined(_WIN32) && !defined(__CYGWIN__)
+ C_WCHAR *wvar = C_utf16(var, 0);
+ if(GetEnvironmentVariableW(wvar, (C_WCHAR *)buffer, STRING_BUFFER_SIZE) ==
+ 0) return NULL;
+ return C_utf8((C_WCHAR *)buffer);
+#else
+ return getenv(C_c_string(var));
+#endif
+}
+
+#ifdef HAVE_CRT_EXTERNS_H
+# include <crt_externs.h>
+# define environ (*_NSGetEnviron())
+#elif !defined(_WIN32) || defined(__CYGWIN__)
+extern char **environ;
+#endif
+
+C_char *C_getenventry(int i)
+{
+#if defined(_WIN32) && !defined(__CYGWIN__)
+ C_WCHAR *env = GetEnvironmentStringsW();
+ C_WCHAR *p = env;
+ while(i--) {
+ while(*p != 0) ++p;
+ if(*(++p) == 0) return NULL;
+ }
+ C_char *s = C_strdup(C_utf8(p));
+ FreeEnvironmentStringsW(env);
+ return s;
+#else
+ return environ[ i ] == NULL ? NULL : C_strdup(environ[ i ]);
+#endif
+}
diff --git a/scripts/bootstrap.sh b/scripts/bootstrap.sh
index 2c77ddab..ad0b1413 100755
--- a/scripts/bootstrap.sh
+++ b/scripts/bootstrap.sh
@@ -2,29 +2,39 @@
set -e
-# build 5.3.0 release
+# build 6.0.0-bootstrap tarball
+
+getcmd="wget -c"
+mkcmd=make
+case "$(uname)" in
+ FreeBSD)
+ mkcmd=gmake
+ getcmd=fetch;;
+ *BSD)
+ mkcmd=gmake;;
+esac
mkdir -p boot/snapshot
cd boot
-wget -c https://code.call-cc.org/releases/5.3.0/chicken-5.3.0.tar.gz
-tar -xzf chicken-5.3.0.tar.gz
-cd chicken-5.3.0
-make "$@" PREFIX="$(pwd)"/../snapshot
-make "$@" PREFIX="$(pwd)"/../snapshot install
+$getcmd https://code.call-cc.org/dev-snapshots/2024/07/01/chicken-6.0.0-bootstrap.tar.gz
+tar -xzf chicken-6.0.0-bootstrap.tar.gz
+cd chicken-6.0.0
+$mkcmd "$@" PREFIX="$(pwd)"/../snapshot
+$mkcmd "$@" PREFIX="$(pwd)"/../snapshot install
cd ../..
# build a boot-chicken from git head using the snapshot
# chicken and then use that to build the real thing
-make "$@" spotless
-make "$@" CHICKEN="$(pwd)"/boot/snapshot/bin/chicken boot-chicken
+./configure --chicken "$(pwd)"/boot/snapshot/bin/chicken
+$mkcmd boot-chicken
# remove snapshot installation and tarball
rm -fr boot/snapshot
-rm -fr boot/chicken-5.3.0
-rm -f boot/chicken-5.3.0.tar.gz
+rm -fr boot/chicken-6.0.0
+rm -f boot/chicken-6.0.0-bootstrap.tar.gz
echo
-echo 'Now, build chicken by passing "CHICKEN=./chicken-boot" to make,'
+echo 'Now, build chicken by passing "--chicken ./chicken-boot" to "configure",'
echo 'in addition to PREFIX, PLATFORM, and other parameters.'
echo
diff --git a/scripts/chicken-flymake.bat b/scripts/chicken-flymake.bat
deleted file mode 100644
index 8cbcac7b..00000000
--- a/scripts/chicken-flymake.bat
+++ /dev/null
@@ -1,4 +0,0 @@
-@echo off
-rem usage: chicken-flymake.bat OPTION-OR-FILENAME ...
-csc -SAv %1 %2 %3 %4 %5 %6 %7 %8 %9
-rem status of last command must be successful
diff --git a/scripts/foldcase.awk b/scripts/foldcase.awk
new file mode 100644
index 00000000..027b4f6b
--- /dev/null
+++ b/scripts/foldcase.awk
@@ -0,0 +1,27 @@
+function num(x) {
+ return substr(x, 1, length(x) - 1)
+}
+BEGIN {
+ print "static int fold1[][ 2 ] = {"
+ i = 0
+}
+/ S;/ {print " {0x" num($1) ", 0x" num($3) "},"}
+/ C;/ {print " {0x" num($1) ", 0x" num($3) "},"}
+/ F;/ {
+ if(match($5, /;$/)) {
+ c[ i ] = $4
+ d[ i ] = num($5)
+ } else {
+ c[ i ] = num($4)
+ d[ i ] = 0
+ }
+ a[ i ] = num($1); b[ i++ ] = $3
+}
+END {
+ print "};"
+ print "static int fold2[][ 4 ] = {"
+ for(j = 0; j < i; ++j) {
+ print " {0x" a[ j ] ", 0x" b[ j ] ", 0x" c[ j ] ", 0x" d[ j ] "},"
+ }
+ print "};"
+}
diff --git a/scripts/makedist.scm b/scripts/makedist.scm
index bc601ada..8857cb0a 100644
--- a/scripts/makedist.scm
+++ b/scripts/makedist.scm
@@ -19,18 +19,13 @@
(define BUILDVERSION (with-input-from-file "buildversion" read))
-(define *platform*
+(define *platform*
(let ((sv (symbol->string (software-version))))
(cond ((irregex-match ".*bsd" sv) "bsd")
- ((string=? sv "mingw32")
- (if (equal? (get-environment-variable "MSYSTEM") "MINGW32")
- "mingw-msys"
- "mingw32"))
(else sv))))
-(define *make*
+(define *make*
(cond ((string=? "bsd" *platform*) "gmake")
- ((string=? "mingw32" *platform*) "mingw32-make")
(else "make")))
(define (prefix dir . files)
@@ -57,8 +52,8 @@
(define (release full?)
(let* ((files (with-input-from-file "distribution/manifest" read-lines))
- (distname (conc "chicken-" BUILDVERSION))
- (distfiles (map (cut prefix distname <>) files))
+ (distname (conc "chicken-" BUILDVERSION))
+ (distfiles (map (cut prefix distname <>) files))
(tgz (conc distname ".tar.gz")))
(run "rm -fr ~a ~a" distname tgz)
(create-directory distname)
@@ -91,7 +86,7 @@
(if (null? args)
'()
(let ((arg (car args)))
- (cond ((string=? "-release" arg)
+ (cond ((string=? "-release" arg)
(set! *release* #t)
(loop (cdr args)))
((string=? "-make" arg)
diff --git a/scripts/mkrunetype.awk b/scripts/mkrunetype.awk
new file mode 100644
index 00000000..32a08638
--- /dev/null
+++ b/scripts/mkrunetype.awk
@@ -0,0 +1,242 @@
+# See LICENSE file for copyright and license details.
+# invoke as:
+# curl http://unicode.org/Public/UCD/latest/ucd/UnicodeData.txt | awk -f scripts/mkrunetype.awk
+
+BEGIN {
+ FS = ";"
+ # set up hexadecimal lookup table
+ for(i = 0; i < 16; i++)
+ hex[sprintf("%X",i)] = i;
+ HEADER = "/* Automatically generated by mkrunetype.awk */\n#include <stdlib.h>\n\n#include \"../utf.h\"\n#include \"runetype.h\"\n"
+ HEADER_OTHER = "/* Automatically generated by mkrunetype.awk */\n#include \"../utf.h\"\n#include \"runetype.h\"\n"
+}
+
+$3 ~ /^L/ { alphav[alphac++] = $1; }
+($3 ~ /^Z/) || ($5 == "WS") || ($5 == "S") || ($5 == "B") { spacev[spacec++] = $1; }
+$3 == "Cc" { cntrlv[cntrlc++] = $1; }
+$3 == "Lu" { upperv[upperc++] = $1; tolowerv[uppercc++] = ($14 == "") ? $1 : $14; }
+$3 == "Ll" { lowerv[lowerc++] = $1; toupperv[lowercc++] = ($13 == "") ? $1 : $13; }
+$3 == "Lt" { titlev[titlec++] = $1; }
+$3 == "Nd" { digitv[digitc++] = $1; }
+
+END {
+ system("rm -f isalpharune.c isspacerune.c iscntrlrune.c upperrune.c lowerrune.c istitlerune.c isdigitrune.c");
+
+ mkis("alpha", alphav, alphac, "isalpharune.c", q, "");
+ mkis("space", spacev, spacec, "isspacerune.c", q, "");
+ mkis("cntrl", cntrlv, cntrlc, "iscntrlrune.c", q, "");
+ mkis("upper", upperv, upperc, "upperrune.c", tolowerv, "lower");
+ mkis("lower", lowerv, lowerc, "lowerrune.c", toupperv, "upper");
+ mkis("title", titlev, titlec, "istitlerune.c", q, "");
+ mkis("digit", digitv, digitc, "isdigitrune.c", q, "");
+
+ system("rm -f isalnumrune.c isblankrune.c isprintrune.c isgraphrune.c ispunctrune.c isxdigitrune.c");
+
+ otheris();
+}
+
+# parse hexadecimal rune index to int
+function code(s) {
+ x = 0;
+ for(i = 1; i <= length(s); i++) {
+ c = substr(s, i, 1);
+ x = (x*16) + hex[c];
+ }
+ return x;
+}
+
+# generate 'is<name>rune' unicode lookup function
+function mkis(name, runev, runec, file, casev, casename) {
+ rune1c = 0;
+ rune2c = 0;
+ rune3c = 0;
+ rune4c = 0;
+ mode = 1;
+
+ #sort rune groups into singletons, ranges and laces
+ for(j = 0; j < runec; j++) {
+ # range
+ if(code(runev[j+1]) == code(runev[j])+1 && ((length(casev) == 0) ||
+ code(casev[j+1]) == code(casev[j])+1) && j+1 < runec) {
+ if (mode == 2) {
+ continue;
+ } else if (mode == 3) {
+ rune3v1[rune3c] = runev[j];
+ rune3c++;
+ } else if (mode == 4) {
+ rune4v1[rune4c] = runev[j];
+ rune4c++;
+ }
+ mode = 2;
+ rune2v0[rune2c] = runev[j];
+ if(length(casev) > 0) {
+ case2v[rune2c] = casev[j];
+ }
+ continue;
+ }
+ # lace 1
+ if(code(runev[j+1]) == code(runev[j])+2 && ((length(casev) == 0) ||
+ (code(casev[j+1]) == code(runev[j+1])+1 && code(casev[j]) == code(runev[j])+1)) &&
+ j+1 < runec) {
+ if (mode == 3) {
+ continue;
+ } else if (mode == 2) {
+ rune2v1[rune2c] = runev[j];
+ rune2c++;
+ } else if (mode == 4) {
+ rune4v1[rune2c] = runev[j];
+ rune4c++;
+ }
+ mode = 3;
+ rune3v0[rune3c] = runev[j];
+ continue;
+ }
+ # lace 2
+ if(code(runev[j+1]) == code(runev[j])+2 && ((length(casev) == 0) ||
+ (code(casev[j+1]) == code(runev[j+1])-1 && code(casev[j]) == code(runev[j])-1)) &&
+ j+1 < runec) {
+ if (mode == 4) {
+ continue;
+ } else if (mode == 2) {
+ rune2v1[rune2c] = runev[j];
+ rune2c++;
+ } else if (mode == 3) {
+ rune3v1[rune2c] = runev[j];
+ rune3c++;
+ }
+ mode = 4;
+ rune4v0[rune4c] = runev[j];
+ continue;
+ }
+ # terminating case
+ if (mode == 1) {
+ rune1v[rune1c] = runev[j];
+ if (length(casev) > 0) {
+ case1v[rune1c] = casev[j];
+ }
+ rune1c++;
+ } else if (mode == 2) {
+ rune2v1[rune2c] = runev[j];
+ rune2c++;
+ } else if (mode == 3) {
+ rune3v1[rune3c] = runev[j];
+ rune3c++;
+ } else { #lace 2
+ rune4v1[rune4c] = runev[j];
+ rune4c++;
+ }
+ mode = 1;
+ }
+ print HEADER > file;
+
+ #generate list of laces 1
+ if(rune3c > 0) {
+ print "static Rune "name"3[][2] = {" > file;
+ for(j = 0; j < rune3c; j++) {
+ print "\t{ 0x"rune3v0[j]", 0x"rune3v1[j]" }," > file;
+ }
+ print "};\n" > file;
+ }
+
+ #generate list of laces 2
+ if(rune4c > 0) {
+ print "static Rune "name"4[][2] = {" > file;
+ for(j = 0; j < rune4c; j++) {
+ print "\t{ 0x"rune4v0[j]", 0x"rune4v1[j]" }," > file;
+ }
+ print "};\n" > file;
+ }
+
+ # generate list of ranges
+ if(rune2c > 0) {
+ if(length(casev) > 0) {
+ print "static Rune "name"2[][3] = {" > file;
+ for(j = 0; j < rune2c; j++) {
+ print "\t{ 0x"rune2v0[j]", 0x"rune2v1[j]", 0x"case2v[j]" }," > file;
+ }
+ } else {
+ print "static Rune "name"2[][2] = {" > file
+ for(j = 0; j < rune2c; j++) {
+ print "\t{ 0x"rune2v0[j]", 0x"rune2v1[j]" }," > file;
+ }
+ }
+ print "};\n" > file;
+ }
+
+ # generate list of singletons
+ if(rune1c > 0) {
+ if(length(casev) > 0) {
+ print "static Rune "name"1[][2] = {" > file;
+ for(j = 0; j < rune1c; j++) {
+ print "\t{ 0x"rune1v[j]", 0x"case1v[j]" }," > file;
+ }
+ } else {
+ print "static Rune "name"1[] = {" > file;
+ for(j = 0; j < rune1c; j++) {
+ print "\t0x"rune1v[j]"," > file;
+ }
+ }
+ print "};\n" > file;
+ }
+ # generate lookup function
+ print "int\nis"name"rune(Rune r)\n{" > file;
+ if(rune4c > 0 || rune3c > 0)
+ print "\tRune *match;\n" > file;
+ if(rune4c > 0) {
+ print "\tif((match = bsearch(&r, "name"4, nelem("name"4), sizeof *"name"4, &rune2cmp)))" > file;
+ print "\t\treturn !((r - match[0]) % 2);" > file;
+ }
+ if(rune3c > 0) {
+ print "\tif((match = bsearch(&r, "name"3, nelem("name"3), sizeof *"name"3, &rune2cmp)))" > file;
+ print "\t\treturn !((r - match[0]) % 2);" > file;
+ }
+ if(rune2c > 0) {
+ print "\tif(bsearch(&r, "name"2, nelem("name"2), sizeof *"name"2, &rune2cmp))\n\t\treturn 1;" > file;
+ }
+ if(rune1c > 0) {
+ print "\tif(bsearch(&r, "name"1, nelem("name"1), sizeof *"name"1, &rune1cmp))\n\t\treturn 1;" > file;
+ }
+ print "\treturn 0;\n}" > file;
+
+ # generate case conversion function
+ if(length(casev) > 0) {
+ print "\nint\nto"casename"rune(Rune r)\n{\n\tRune *match;\n" > file;
+ if(rune4c > 0) {
+ print "\tmatch = bsearch(&r, "name"4, nelem("name"4), sizeof *"name"4, &rune2cmp);" > file;
+ print "\tif (match)" > file;
+ print "\t\treturn ((r - match[0]) % 2) ? r : r - 1;" > file;
+ }
+ if(rune3c > 0) {
+ print "\tmatch = bsearch(&r, "name"3, nelem("name"3), sizeof *"name"3, &rune2cmp);" > file;
+ print "\tif (match)" > file;
+ print "\t\treturn ((r - match[0]) % 2) ? r : r + 1;" > file;
+ }
+ if(rune2c > 0) {
+ print "\tmatch = bsearch(&r, "name"2, nelem("name"2), sizeof *"name"2, &rune2cmp);" > file;
+ print "\tif (match)" > file;
+ print "\t\treturn match[2] + (r - match[0]);" > file;
+ }
+ if(rune1c > 0) {
+ print "\tmatch = bsearch(&r, "name"1, nelem("name"1), sizeof *"name"1, &rune1cmp);" > file;
+ print "\tif (match)" > file;
+ print "\t\treturn match[1];" > file;
+ }
+ print "\treturn r;\n}" > file;
+ }
+}
+
+function otheris() {
+ print HEADER_OTHER > "isalnumrune.c";
+ print "int\nisalnumrune(Rune r)\n{\n\treturn isalpharune(r) || isdigitrune(r);\n}" > "isalnumrune.c";
+ print HEADER_OTHER > "isblankrune.c";
+ print "int\nisblankrune(Rune r)\n{\n\treturn r == ' ' || r == '\\t';\n}" > "isblankrune.c";
+ print HEADER_OTHER > "isprintrune.c";
+ print "int\nisprintrune(Rune r)\n{\n\treturn !iscntrlrune(r) && (r != 0x2028) && (r != 0x2029) &&" > "isprintrune.c";
+ print "\t ((r < 0xFFF9) || (r > 0xFFFB));\n}" > "isprintrune.c";
+ print HEADER_OTHER > "isgraphrune.c";
+ print "int\nisgraphrune(Rune r)\n{\n\treturn !isspacerune(r) && isprintrune(r);\n}" > "isgraphrune.c";
+ print HEADER_OTHER > "ispunctrune.c";
+ print "int\nispunctrune(Rune r)\n{\n\treturn isgraphrune(r) && !isalnumrune(r);\n}" > "ispunctrune.c";
+ print HEADER_OTHER > "isxdigitrune.c";
+ print "int\nisxdigitrune(Rune r)\n{\n\treturn (r >= '0' && (r - '0') < 10) || (r >= 'a' && (r - 'a') < 6);\n}" > "isxdigitrune.c";
+}
diff --git a/scripts/test-dist.sh b/scripts/test-dist.sh
index 6ba17364..bbbe4a64 100755
--- a/scripts/test-dist.sh
+++ b/scripts/test-dist.sh
@@ -15,7 +15,7 @@ fi
case $# in
1|2) ;;
- *)
+ *)
echo "usage: test-dist.sh [-bootstrap] PLATFORM [TARBALL]"
exit 1;;
esac
@@ -29,8 +29,8 @@ if test -z `which gmake`; then
makeprg=make
fi
-# need Windows-style drive letter on mingw/msys
-if test -n "$MSYSTEM"; then
+# need Windows-style drive letter on mingw
+if [ $(uname) = Windows_NT ]; then
pwdopts=-W
fi
diff --git a/scrutinizer.scm b/scrutinizer.scm
index 35f889e2..a8a78852 100644
--- a/scrutinizer.scm
+++ b/scrutinizer.scm
@@ -50,6 +50,7 @@
chicken.pretty-print
chicken.string
chicken.syntax)
+(import (only (scheme base) call/cc))
(include "tweaks")
(include "mini-srfi-1.scm")
@@ -88,7 +89,7 @@
; | (deprecated NAME)
; VALUE = string | symbol | keyword | char | number |
; boolean | true | false |
-; null | eof | bwp | blob | pointer | port | locative | fixnum |
+; null | eof | bwp | bytevector | pointer | port | locative | fixnum |
; float | bignum | ratnum | cplxnum | integer | pointer-vector
; BASIC = * | list | pair | procedure | vector | undefined | noreturn | values
; COMPLEX = (pair TYPE TYPE)
@@ -133,7 +134,7 @@
(define-constant +maximal-complex-object-constructor-result-type-length+ 256)
(define-constant value-types
- '(string symbol keyword char null boolean true false blob eof bwp
+ '(string symbol keyword char null boolean true false bytevector eof bwp
fixnum float number integer bignum ratnum cplxnum
pointer-vector port pointer locative))
@@ -213,8 +214,7 @@
(simplify-type
`(pair ,(constant-result (car lit)) ,(constant-result (cdr lit)))))
((eof-object? lit) 'eof)
- ;; TODO: Remove once we have a bootstrapping libchicken with bwp-object?
- ((##core#inline "C_bwpp" lit) #;(bwp-object? lit) 'bwp)
+ ((bwp-object? lit) 'bwp)
((vector? lit)
(simplify-type
`(vector ,@(map constant-result (vector->list lit)))))
@@ -1825,6 +1825,7 @@
;; - coalesces all "forall" forms into one (remove "forall" if typevar-set is empty)
;; - renames type-variables
;; - replaces type-abbreviations
+ ;; - replaces "blob" by "bytevector" for backwards compatibility
(let ((ptype #f) ; (T . PT) | #f
(clean #f)
(typevars '())
@@ -1864,7 +1865,8 @@
((memq t struct-types) `(struct ,t))
((eq? t 'immediate) '(or eof null fixnum char boolean))
((eq? t 'any) '*)
- ((eq? t 'void) 'undefined)
+ ((eq? t 'blob) 'bytevector) ; DEPRECATED
+ ((eq? t 'void) 'undefined)
((eq? t 'input-port) '(refine (input) port))
((eq? t 'output-port) '(refine (output) port))
((and (symbol? t) (##sys#get t '##compiler#type-abbreviation)))
@@ -2083,8 +2085,8 @@
(n (string-length s)))
(let loop ((i 0))
(cond ((eq? i n) sym)
- ((eq? (##core#inline "C_subchar" s i) #\#)
- (##sys#intern-symbol (##sys#substring s (fx+ i 1) n)))
+ ((eq? (string-ref s i) #\#)
+ (##sys#string->symbol (##sys#substring s (fx+ i 1) n)))
(else (loop (fx+ i 1)))))))
diff --git a/setup.defaults b/setup.defaults
index ba4692b9..840dca91 100644
--- a/setup.defaults
+++ b/setup.defaults
@@ -20,7 +20,8 @@
;
; URL may be an alias (see below) or a real URL.
-(server "kitten-technologies")
+; TEMPORARY DISABLED
+;(server "kitten-technologies")
(server "call-cc")
@@ -35,7 +36,7 @@
;
; (alias (NAME REALNAME) ...)
-(alias
+(alias
("call-cc" "http://code.call-cc.org/cgi-bin/henrietta.cgi")
("kitten-technologies" "http://chicken.kitten-technologies.co.uk/henrietta.cgi"))
@@ -53,7 +54,7 @@
;
; (hack EXPR)
;
-; EXPR should evaluate to a procedure of the type, where the
+; EXPR should evaluate to a procedure of the type, where the
; procedure is of type EGGNAME DEPENDENCIES -> DEPENDENCIES' and
; may modify the dependencies-list of an arbitrary egg. All
; hack procedures are invoked in the order given here
diff --git a/srfi-4.scm b/srfi-4.scm
index 0d908f0c..3e8c3fb4 100644
--- a/srfi-4.scm
+++ b/srfi-4.scm
@@ -37,51 +37,57 @@
EOF
) )
-(module srfi-4
- (blob->f32vector blob->f32vector/shared
- blob->f64vector blob->f64vector/shared
- blob->s16vector blob->s16vector/shared
- blob->s32vector blob->s32vector/shared
- blob->s64vector blob->s64vector/shared
- blob->s8vector blob->s8vector/shared
- blob->u16vector blob->u16vector/shared
- blob->u32vector blob->u32vector/shared
- blob->u64vector blob->u64vector/shared
- blob->u8vector blob->u8vector/shared
- f32vector f32vector->blob f32vector->blob/shared f32vector->list
+(module chicken.number-vector
+ (bytevector->f32vector bytevector->f32vector/shared
+ bytevector->f64vector bytevector->f64vector/shared
+ bytevector->s16vector bytevector->s16vector/shared
+ bytevector->s32vector bytevector->s32vector/shared
+ bytevector->s64vector bytevector->s64vector/shared
+ bytevector->s8vector bytevector->s8vector/shared
+ bytevector->u16vector bytevector->u16vector/shared
+ bytevector->u32vector bytevector->u32vector/shared
+ bytevector->u64vector bytevector->u64vector/shared
+ bytevector->c64vector bytevector->c64vector/shared
+ bytevector->c128vector bytevector->c128vector/shared
+ f32vector f32vector->bytevector f32vector->bytevector/shared f32vector->list
f32vector-length f32vector-ref f32vector-set! f32vector?
- f64vector f64vector->blob f64vector->blob/shared f64vector->list
+ f64vector f64vector->bytevector f64vector->bytevector/shared f64vector->list
f64vector-length f64vector-ref f64vector-set! f64vector?
- s8vector s8vector->blob s8vector->blob/shared s8vector->list
+ s8vector s8vector->bytevector s8vector->bytevector/shared s8vector->list
s8vector-length s8vector-ref s8vector-set! s8vector?
- s16vector s16vector->blob s16vector->blob/shared s16vector->list
+ s16vector s16vector->bytevector s16vector->bytevector/shared s16vector->list
s16vector-length s16vector-ref s16vector-set! s16vector?
- s32vector s32vector->blob s32vector->blob/shared s32vector->list
+ s32vector s32vector->bytevector s32vector->bytevector/shared s32vector->list
s32vector-length s32vector-ref s32vector-set! s32vector?
- s64vector s64vector->blob s64vector->blob/shared s64vector->list
+ s64vector s64vector->bytevector s64vector->bytevector/shared s64vector->list
s64vector-length s64vector-ref s64vector-set! s64vector?
- u8vector u8vector->blob u8vector->blob/shared u8vector->list
+ u8vector u8vector->list
u8vector-length u8vector-ref u8vector-set! u8vector?
- u16vector u16vector->blob u16vector->blob/shared u16vector->list
+ u16vector u16vector->bytevector u16vector->bytevector/shared u16vector->list
u16vector-length u16vector-ref u16vector-set! u16vector?
- u32vector u32vector->blob u32vector->blob/shared u32vector->list
+ u32vector u32vector->bytevector u32vector->bytevector/shared u32vector->list
u32vector-length u32vector-ref u32vector-set! u32vector?
- u64vector u64vector->blob u64vector->blob/shared u64vector->list
+ u64vector u64vector->bytevector u64vector->bytevector/shared u64vector->list
u64vector-length u64vector-ref u64vector-set! u64vector?
+ c64vector c64vector->bytevector c64vector->bytevector/shared c64vector->list
+ c64vector-length c64vector-ref c64vector-set! c64vector?
+ c128vector c128vector->bytevector c128vector->bytevector/shared c128vector->list
+ c128vector-length c128vector-ref c128vector-set! c128vector?
list->f32vector list->f64vector list->s16vector list->s32vector
list->s64vector list->s8vector list->u16vector list->u32vector
- list->u8vector list->u64vector
+ list->u8vector list->u64vector list->c64vector list->c128vector
make-f32vector make-f64vector make-s16vector make-s32vector
make-s64vector make-s8vector make-u16vector make-u32vector
- make-u64vector make-u8vector
- number-vector? read-u8vector read-u8vector! release-number-vector
+ make-u64vector make-u8vector make-c64vector make-c128vector
+ number-vector? release-number-vector
subf32vector subf64vector subs16vector subs32vector subs64vector
subs8vector subu16vector subu8vector subu32vector subu64vector
- write-u8vector)
+ subc64vector subc128vector)
(import scheme
chicken.base
chicken.bitwise
+ chicken.bytevector
chicken.fixnum
chicken.foreign
chicken.gc
@@ -98,30 +104,31 @@ EOF
(##core#inline "C_i_flonump" x))
(##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int) loc x) ) )
-(define-inline (check-range i from to loc)
- (##sys#check-fixnum i loc)
- (unless (and (fx<= from i) (fx< i to))
- (##sys#error-hook
- (foreign-value "C_OUT_OF_RANGE_ERROR" int)
- loc i from to) ) )
-
(define-inline (check-uint-length obj len loc)
(##sys#check-exact-uinteger obj loc)
(when (fx> (integer-length obj) len)
(##sys#error-hook
- (foreign-value "C_OUT_OF_RANGE_ERROR" int) loc obj 0 (expt 2 len))))
+ (foreign-value "C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR" int) loc obj)))
(define-inline (check-int-length obj len loc)
(##sys#check-exact-integer obj loc)
(when (fx> (integer-length obj) (fx- len 1))
(##sys#error-hook
- (foreign-value "C_OUT_OF_RANGE_ERROR" int)
- loc obj (- (expt 2 len)) (sub1 (expt 2 len)))))
+ (foreign-value "C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR" int)
+ loc obj)))
+
+(define-syntax ->f
+ (syntax-rules ()
+ ((_ x)
+ (let ((tmp x))
+ (if (##core#inline "C_i_flonump" tmp)
+ tmp
+ (##core#inline_allocate ("C_a_u_i_int_to_flo" 4) tmp))))))
;;; Get vector length:
(define (u8vector-length x)
- (##core#inline "C_i_u8vector_length" x))
+ (##core#inline "C_i_bytevector_length" x))
(define (s8vector-length x)
(##core#inline "C_i_s8vector_length" x))
@@ -150,11 +157,18 @@ EOF
(define (f64vector-length x)
(##core#inline "C_i_f64vector_length" x))
+(define (c64vector-length x)
+ (##sys#check-structure x 'c64vector 'c64vector-length)
+ (fx/ (##core#inline "C_i_bytevector_length" (##sys#slot x 1)) 8))
+
+(define (c128vector-length x)
+ (##sys#check-structure x 'c128vector 'c128vector-length)
+ (fx/ (##core#inline "C_i_bytevector_length" (##sys#slot x 1)) 16))
+
;;; Safe accessors:
-(define (u8vector-set! x i y)
- (##core#inline "C_i_u8vector_set" x i y))
+(define u8vector-set! bytevector-u8-set!)
(define (s8vector-set! x i y)
(##core#inline "C_i_s8vector_set" x i y))
@@ -183,65 +197,103 @@ EOF
(define (f64vector-set! x i y)
(##core#inline "C_i_f64vector_set" x i y))
-(define u8vector-ref
- (getter-with-setter
- (lambda (x i) (##core#inline "C_i_u8vector_ref" x i))
- u8vector-set!
- "(chicken.srfi-4#u8vector-ref v i)"))
+(define (c64vector-set! x i y)
+ (##sys#check-structure x 'c64vector 'c64vector-set!)
+ (let* ((bv (##sys#slot x 1))
+ (len (fx/ (##core#inline "C_i_bytevector_length" bv) 8)))
+ (##sys#check-range i 0 len 'c64vector-set!)
+ (##sys#check-number y 'c64vector-set!)
+ (##core#inline "C_u_i_f32vector_set" x (fx/ i 2) (->f (real-part y)))
+ (##core#inline "C_u_i_f32vector_set" x (fx+ (fx/ i 2) 1) (->f (imag-part y)))))
+
+(define (c128vector-set! x i y)
+ (##sys#check-structure x 'c128vector 'c128vector-set!)
+ (let* ((bv (##sys#slot x 1))
+ (len (fx/ (##core#inline "C_i_bytevector_length" bv) 16)))
+ (##sys#check-range i 0 len 'c128vector-set!)
+ (##sys#check-number y 'c128vector-set!)
+ (##core#inline "C_u_i_f64vector_set" x (fx/ i 2) (->f (real-part y)))
+ (##core#inline "C_u_i_f64vector_set" x (fx+ (fx/ i 2) 1) (->f (imag-part y)))))
+
+(define u8vector-ref bytevector-u8-ref)
(define s8vector-ref
(getter-with-setter
(lambda (x i) (##core#inline "C_i_s8vector_ref" x i))
s8vector-set!
- "(chicken.srfi-4#s8vector-ref v i)"))
+ "(chicken.number-vector#s8vector-ref v i)"))
(define u16vector-ref
(getter-with-setter
(lambda (x i) (##core#inline "C_i_u16vector_ref" x i))
u16vector-set!
- "(chicken.srfi-4#u16vector-ref v i)"))
+ "(chicken.number-vector#u16vector-ref v i)"))
(define s16vector-ref
(getter-with-setter
(lambda (x i) (##core#inline "C_i_s16vector_ref" x i))
s16vector-set!
- "(chicken.srfi-4#s16vector-ref v i)"))
+ "(chicken.number-vector#s16vector-ref v i)"))
(define u32vector-ref
(getter-with-setter
(lambda (x i) (##core#inline_allocate ("C_a_i_u32vector_ref" 5) x i))
u32vector-set!
- "(chicken.srfi-4#u32vector-ref v i)"))
+ "(chicken.number-vector#u32vector-ref v i)"))
(define s32vector-ref
(getter-with-setter
(lambda (x i) (##core#inline_allocate ("C_a_i_s32vector_ref" 5) x i))
s32vector-set!
- "(chicken.srfi-4#s32vector-ref v i)"))
+ "(chicken.number-vector#s32vector-ref v i)"))
(define u64vector-ref
(getter-with-setter
(lambda (x i) (##core#inline_allocate ("C_a_i_u64vector_ref" 7) x i))
u64vector-set!
- "(chicken.srfi-4#u64vector-ref v i)"))
+ "(chicken.number-vector#u64vector-ref v i)"))
(define s64vector-ref
(getter-with-setter
(lambda (x i) (##core#inline_allocate ("C_a_i_s64vector_ref" 7) x i))
s64vector-set!
- "(chicken.srfi-4#s64vector-ref v i)"))
+ "(chicken.number-vector#s64vector-ref v i)"))
(define f32vector-ref
(getter-with-setter
(lambda (x i) (##core#inline_allocate ("C_a_i_f32vector_ref" 4) x i))
f32vector-set!
- "(chicken.srfi-4#f32vector-ref v i)"))
+ "(chicken.number-vector#f32vector-ref v i)"))
(define f64vector-ref
(getter-with-setter
(lambda (x i) (##core#inline_allocate ("C_a_i_f64vector_ref" 4) x i))
f64vector-set!
- "(chicken.srfi-4#f64vector-ref v i)"))
+ "(chicken.number-vector#f64vector-ref v i)"))
+
+(define c64vector-ref
+ (getter-with-setter
+ (lambda (x i)
+ (##sys#check-structure x 'c64vector 'c64vector-ref)
+ (##sys#check-range i 0 (fx/ (##core#inline "C_i_bytevector_length" (##sys#slot x 1))
+ 8) 'c64vector-ref)
+ (let ((p (fx/ i 2)))
+ (make-rectangular (##core#inline_allocate ("C_a_u_i_f32vector_ref" 4) x p)
+ (##core#inline_allocate ("C_a_u_i_f32vector_ref" 4) x (fx+ p 1)))))
+ c64vector-set!
+ "(chicken.number-vector#c64vector-ref v i)"))
+
+(define c128vector-ref
+ (getter-with-setter
+ (lambda (x i)
+ (##sys#check-structure x 'c128vector 'c128vector-ref)
+ (##sys#check-range i 0 (fx/ (##core#inline "C_i_bytevector_length" (##sys#slot x 1))
+ 16) 'c128vector-ref)
+ (let ((p (fx/ i 2)))
+ (make-rectangular (##core#inline_allocate ("C_a_u_i_f64vector_ref" 4) x p)
+ (##core#inline_allocate ("C_a_u_i_f64vector_ref" 4) x (fx+ p 1)))))
+ c128vector-set!
+ "(chicken.number-vector#c128vector-ref v i)"))
;;; Basic constructors:
@@ -256,6 +308,8 @@ EOF
(define make-u16vector)
(define make-u32vector)
(define make-u64vector)
+(define make-c64vector)
+(define make-c128vector)
(define release-number-vector)
(let* ((ext-alloc
@@ -278,9 +332,7 @@ EOF
(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) ) ) ) ))
+ (##sys#allocate-bytevector len #f))))))
(set! release-number-vector
(lambda (v)
@@ -290,7 +342,7 @@ EOF
(set! make-u8vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
- (let ((v (##sys#make-structure 'u8vector (alloc 'make-u8vector 1 len ext?))))
+ (let ((v (alloc 'make-u8vector 1 len ext?)))
(when (and ext? fin?) (set-finalizer! v ext-free))
(if (not init)
v
@@ -298,7 +350,7 @@ EOF
(check-uint-length init 8 'make-u8vector)
(do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
- (##core#inline "C_u_i_u8vector_set" v i init) ) ) ) ) ) )
+ (##core#inline "C_setsubbyte" v i init) ) ) ) ) ) )
(set! make-s8vector
(lambda (len #!optional (init #f) (ext? #f) (fin? #t))
@@ -410,7 +462,33 @@ EOF
(set! init (##core#inline_allocate ("C_a_u_i_int_to_flo" 4) init)) )
(do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
- (##core#inline "C_u_i_f64vector_set" v i init) ) ) ) ) ) ) )
+ (##core#inline "C_u_i_f64vector_set" v i init) ) ) ) ) ) )
+
+ (set! make-c64vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin? #t))
+ (let ((v (##sys#make-structure 'c64vector (alloc 'make-c64vector 4 (fx* len 2) ext?))))
+ (when (and ext? fin?) (set-finalizer! v ext-free))
+ (if (not init)
+ v
+ (let ((len2 (fx* len 2)))
+ (check-int/flonum init 'make-c64vector)
+ (do ((i 0 (fx+ i 2)))
+ ((fx>= i len2) v)
+ (##core#inline "C_u_i_f32vector_set" v i (real-part init))
+ (##core#inline "C_u_i_f32vector_set" v (fx+ i 1) (imag-part init))))))))
+
+ (set! make-c128vector
+ (lambda (len #!optional (init #f) (ext? #f) (fin? #t))
+ (let ((v (##sys#make-structure 'c128vector (alloc 'make-c128vector 8 (fx* len 2) ext?))))
+ (when (and ext? fin?) (set-finalizer! v ext-free))
+ (if (not init)
+ v
+ (let ((len2 (fx* len 2)))
+ (check-int/flonum init 'make-c128vector)
+ (do ((i 0 (fx+ i 2)))
+ ((fx>= i len2) v)
+ (##core#inline "C_u_i_f64vector_set" v i (real-part init))
+ (##core#inline "C_u_i_f64vector_set" v (fx+ i 1) (imag-part init)))))))))
;;; Creating vectors from a list:
@@ -436,7 +514,8 @@ EOF
(,set v i (##core#inline "C_slot" p 0))
(##sys#error-not-a-proper-list lst ',name) ) ) ) )))))))
-(list->NNNvector u8vector)
+(define list->u8vector ##sys#list->bytevector)
+
(list->NNNvector s8vector)
(list->NNNvector u16vector)
(list->NNNvector s16vector)
@@ -446,6 +525,8 @@ EOF
(list->NNNvector s64vector)
(list->NNNvector f32vector)
(list->NNNvector f64vector)
+(list->NNNvector c64vector)
+(list->NNNvector c128vector)
;;; More constructors:
@@ -480,6 +561,12 @@ EOF
(define f64vector
(lambda xs (list->f64vector xs)) )
+(define c64vector
+ (lambda xs (list->c64vector xs)) )
+
+(define c128vector
+ (lambda xs (list->c128vector xs)) )
+
;;; Creating lists from a vector:
@@ -501,7 +588,10 @@ EOF
`(##core#inline ,(string-append "C_u_i_" tag "_ref") v i))
(loop (fx+ i 1)) ) ) ) ) ) ) )))
-(NNNvector->list u8vector)
+(define (u8vector->list v)
+ (##sys#check-bytevector v 'u8vector->list)
+ (##sys#bytevector->list v))
+
(NNNvector->list s8vector)
(NNNvector->list u16vector)
(NNNvector->list s16vector)
@@ -513,22 +603,49 @@ EOF
(NNNvector->list f32vector 4)
(NNNvector->list f64vector 4)
+(define c64vector->list
+ (let ((c64vector-length c64vector-length)
+ (c64vector-ref c64vector-ref))
+ (lambda (v)
+ (##sys#check-structure v 'c64vector 'c64vector->list)
+ (let ((len (c64vector-length v)))
+ (let loop ((i 0))
+ (if (fx>= i len)
+ '()
+ (cons (c64vector-ref v i)
+ (loop (fx+ i 1)) ) ) ) ))))
+
+(define c128vector->list
+ (let ((c128vector-length c128vector-length)
+ (c128vector-ref c128vector-ref))
+ (lambda (v)
+ (##sys#check-structure v 'c128vector 'c128vector->list)
+ (let ((len (c128vector-length v)))
+ (let loop ((i 0))
+ (if (fx>= i len)
+ '()
+ (cons (c128vector-ref v i)
+ (loop (fx+ i 1)) ) ) ) ) )))
+
;;; Predicates:
-(define (u8vector? x) (##core#inline "C_i_u8vectorp" x))
-(define (s8vector? x) (##core#inline "C_i_s8vectorp" x))
-(define (u16vector? x) (##core#inline "C_i_u16vectorp" x))
-(define (s16vector? x) (##core#inline "C_i_s16vectorp" x))
-(define (u32vector? x) (##core#inline "C_i_u32vectorp" x))
-(define (s32vector? x) (##core#inline "C_i_s32vectorp" x))
-(define (u64vector? x) (##core#inline "C_i_u64vectorp" x))
-(define (s64vector? x) (##core#inline "C_i_s64vectorp" x))
-(define (f32vector? x) (##core#inline "C_i_f32vectorp" x))
-(define (f64vector? x) (##core#inline "C_i_f64vectorp" x))
+(define (u8vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_bytevectorp" x)))
+(define (s8vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_s8vectorp" x)))
+(define (u16vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_u16vectorp" x)))
+(define (s16vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_s16vectorp" x)))
+(define (u32vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_u32vectorp" x)))
+(define (s32vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_s32vectorp" x)))
+(define (u64vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_u64vectorp" x)))
+(define (s64vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_s64vectorp" x)))
+(define (f32vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_f32vectorp" x)))
+(define (f64vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_f64vectorp" x)))
+(define (c64vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_structurep" x 'c64vector)))
+(define (c128vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_structurep" x 'c128vector)))
;; Catch-all predicate
-(define number-vector? ##sys#srfi-4-vector?)
+(define (number-vector? x)
+ (or (bytevector? x) (##sys#srfi-4-vector? x)))
;;; Accessing the packed bytevector:
@@ -541,157 +658,77 @@ EOF
(lambda (v)
(##sys#check-structure v tag loc)
(let* ((old (##sys#slot v 1))
- (new (##sys#make-blob (##sys#size old))))
+ (new (##sys#make-bytevector (##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)])
+ (##sys#check-bytevector 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) ) ) ) )
+ (##sys#error loc "bytevector does not have correct size for packing" tag len sz) ) ) ) )
(define (unpack-copy tag sz loc)
(lambda (str)
- (##sys#check-byte-vector str loc)
+ (##sys#check-bytevector str loc)
(let* ((len (##sys#size str))
- (new (##sys#make-blob len)))
+ (new (##sys#make-bytevector 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) ) ) ) )
-
-(define u8vector->blob/shared (pack 'u8vector 'u8vector->blob/shared))
-(define s8vector->blob/shared (pack 's8vector 's8vector->blob/shared))
-(define u16vector->blob/shared (pack 'u16vector 'u16vector->blob/shared))
-(define s16vector->blob/shared (pack 's16vector 's16vector->blob/shared))
-(define u32vector->blob/shared (pack 'u32vector 'u32vector->blob/shared))
-(define s32vector->blob/shared (pack 's32vector 's32vector->blob/shared))
-(define u64vector->blob/shared (pack 'u64vector 'u64vector->blob/shared))
-(define s64vector->blob/shared (pack 's64vector 's64vector->blob/shared))
-(define f32vector->blob/shared (pack 'f32vector 'f32vector->blob/shared))
-(define f64vector->blob/shared (pack 'f64vector 'f64vector->blob/shared))
-
-(define u8vector->blob (pack-copy 'u8vector 'u8vector->blob))
-(define s8vector->blob (pack-copy 's8vector 's8vector->blob))
-(define u16vector->blob (pack-copy 'u16vector 'u16vector->blob))
-(define s16vector->blob (pack-copy 's16vector 's16vector->blob))
-(define u32vector->blob (pack-copy 'u32vector 'u32vector->blob))
-(define s32vector->blob (pack-copy 's32vector 's32vector->blob))
-(define u64vector->blob (pack-copy 'u64vector 'u64vector->blob))
-(define s64vector->blob (pack-copy 's64vector 's64vector->blob))
-(define f32vector->blob (pack-copy 'f32vector 'f32vector->blob))
-(define f64vector->blob (pack-copy 'f64vector 'f64vector->blob))
-
-(define blob->u8vector/shared (unpack 'u8vector #t 'blob->u8vector/shared))
-(define blob->s8vector/shared (unpack 's8vector #t 'blob->s8vector/shared))
-(define blob->u16vector/shared (unpack 'u16vector 2 'blob->u16vector/shared))
-(define blob->s16vector/shared (unpack 's16vector 2 'blob->s16vector/shared))
-(define blob->u32vector/shared (unpack 'u32vector 4 'blob->u32vector/shared))
-(define blob->s32vector/shared (unpack 's32vector 4 'blob->s32vector/shared))
-(define blob->u64vector/shared (unpack 'u64vector 4 'blob->u64vector/shared))
-(define blob->s64vector/shared (unpack 's64vector 4 'blob->s64vector/shared))
-(define blob->f32vector/shared (unpack 'f32vector 4 'blob->f32vector/shared))
-(define blob->f64vector/shared (unpack 'f64vector 8 'blob->f64vector/shared))
-
-(define blob->u8vector (unpack-copy 'u8vector #t 'blob->u8vector))
-(define blob->s8vector (unpack-copy 's8vector #t 'blob->s8vector))
-(define blob->u16vector (unpack-copy 'u16vector 2 'blob->u16vector))
-(define blob->s16vector (unpack-copy 's16vector 2 'blob->s16vector))
-(define blob->u32vector (unpack-copy 'u32vector 4 'blob->u32vector))
-(define blob->s32vector (unpack-copy 's32vector 4 'blob->s32vector))
-(define blob->u64vector (unpack-copy 'u64vector 4 'blob->u64vector))
-(define blob->s64vector (unpack-copy 's64vector 4 'blob->s64vector))
-(define blob->f32vector (unpack-copy 'f32vector 4 'blob->f32vector))
-(define blob->f64vector (unpack-copy 'f64vector 8 'blob->f64vector))
-
-
-;;; Read syntax:
-
-;; This code is too complicated. We try to avoid mapping over
-;; a potentially large list anc creating lots of garbage in the
-;; process, therefore the final result list is constructed
-;; via destructive updates and thus rather inelegant yet avoids
-;; any re-consing unless elements are non-numeric.
-(define (canonicalize-number-list! lst1)
- (let loop ((lst lst1) (prev #f))
- (if (and (##core#inline "C_blockp" lst)
- (##core#inline "C_pairp" lst))
- (let retry ((x (##sys#slot lst 0)))
- (cond ((char? x) (retry (##sys#char->utf8-string x)))
- ((string? x)
- (if (zero? (string-length x))
- (loop (##sys#slot lst 1) prev)
- (let loop2 ((ns (string->list x)) (prev prev))
- (let ((n (cons (char->integer (##sys#slot ns 0))
- (##sys#slot lst 1))))
- (if prev
- (##sys#setslot prev 1 n)
- (set! lst1 n))
- (let ((ns2 (##sys#slot ns 1)))
- (if (null? ns2)
- (loop (##sys#slot lst 1) n)
- (loop2 (##sys#slot ns 1) n)))))))
- (else (loop (##sys#slot lst 1) lst))))
- (cond (prev (##sys#setslot prev 1 '())
- lst1)
- (else '())))))
-
-(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
- 'u64 list->u64vector
- 's64 list->s64vector
- '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)
- (let ((val (read port)))
- (if (string? val)
- (set! val (map char->integer (string->list val)))
- (set! val (canonicalize-number-list! val)))
- ((##sys#slot (##sys#slot c 1) 0) val))))
- (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)
- (u64vector u64 ,u64vector->list)
- (s64vector s64 ,s64vector->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)) ) ) ) ) )
-
+ (##sys#error loc "bytevector does not have correct size for packing" tag len sz) ) ) ) )
+
+(define s8vector->bytevector/shared (pack 's8vector 's8vector->bytevector/shared))
+(define u16vector->bytevector/shared (pack 'u16vector 'u16vector->bytevector/shared))
+(define s16vector->bytevector/shared (pack 's16vector 's16vector->bytevector/shared))
+(define u32vector->bytevector/shared (pack 'u32vector 'u32vector->bytevector/shared))
+(define s32vector->bytevector/shared (pack 's32vector 's32vector->bytevector/shared))
+(define u64vector->bytevector/shared (pack 'u64vector 'u64vector->bytevector/shared))
+(define s64vector->bytevector/shared (pack 's64vector 's64vector->bytevector/shared))
+(define f32vector->bytevector/shared (pack 'f32vector 'f32vector->bytevector/shared))
+(define f64vector->bytevector/shared (pack 'f64vector 'f64vector->bytevector/shared))
+(define c64vector->bytevector/shared (pack 'c64vector 'c64vector->bytevector/shared))
+(define c128vector->bytevector/shared (pack 'c128vector 'c128vector->bytevector/shared))
+
+(define s8vector->bytevector (pack-copy 's8vector 's8vector->bytevector))
+(define u16vector->bytevector (pack-copy 'u16vector 'u16vector->bytevector))
+(define s16vector->bytevector (pack-copy 's16vector 's16vector->bytevector))
+(define u32vector->bytevector (pack-copy 'u32vector 'u32vector->bytevector))
+(define s32vector->bytevector (pack-copy 's32vector 's32vector->bytevector))
+(define u64vector->bytevector (pack-copy 'u64vector 'u64vector->bytevector))
+(define s64vector->bytevector (pack-copy 's64vector 's64vector->bytevector))
+(define f32vector->bytevector (pack-copy 'f32vector 'f32vector->bytevector))
+(define f64vector->bytevector (pack-copy 'f64vector 'f64vector->bytevector))
+(define c64vector->bytevector (pack-copy 'c64vector 'c64vector->bytevector))
+(define c128vector->bytevector (pack-copy 'c128vector 'c128vector->bytevector))
+
+(define bytevector->s8vector/shared (unpack 's8vector #t 'bytevector->s8vector/shared))
+(define bytevector->u16vector/shared (unpack 'u16vector 2 'bytevector->u16vector/shared))
+(define bytevector->s16vector/shared (unpack 's16vector 2 'bytevector->s16vector/shared))
+(define bytevector->u32vector/shared (unpack 'u32vector 4 'bytevector->u32vector/shared))
+(define bytevector->s32vector/shared (unpack 's32vector 4 'bytevector->s32vector/shared))
+(define bytevector->u64vector/shared (unpack 'u64vector 4 'bytevector->u64vector/shared))
+(define bytevector->s64vector/shared (unpack 's64vector 4 'bytevector->s64vector/shared))
+(define bytevector->f32vector/shared (unpack 'f32vector 4 'bytevector->f32vector/shared))
+(define bytevector->f64vector/shared (unpack 'f64vector 8 'bytevector->f64vector/shared))
+(define bytevector->c64vector/shared (unpack 'c64vector 8 'bytevector->c64vector/shared))
+(define bytevector->c128vector/shared (unpack 'c128vector 16 'bytevector->c128vector/shared))
+
+(define bytevector->s8vector (unpack-copy 's8vector #t 'bytevector->s8vector))
+(define bytevector->u16vector (unpack-copy 'u16vector 2 'bytevector->u16vector))
+(define bytevector->s16vector (unpack-copy 's16vector 2 'bytevector->s16vector))
+(define bytevector->u32vector (unpack-copy 'u32vector 4 'bytevector->u32vector))
+(define bytevector->s32vector (unpack-copy 's32vector 4 'bytevector->s32vector))
+(define bytevector->u64vector (unpack-copy 'u64vector 4 'bytevector->u64vector))
+(define bytevector->s64vector (unpack-copy 's64vector 4 'bytevector->s64vector))
+(define bytevector->f32vector (unpack-copy 'f32vector 4 'bytevector->f32vector))
+(define bytevector->f64vector (unpack-copy 'f64vector 8 'bytevector->f64vector))
+(define bytevector->c64vector (unpack-copy 'c64vector 8 'bytevector->c64vector))
+(define bytevector->c128vector (unpack-copy 'c128vector 16 'bytevector->c128vector))
;;; Subvectors:
@@ -700,16 +737,21 @@ EOF
(let* ([bv (##sys#slot v 1)]
[len (##sys#size bv)]
[ilen (##core#inline "C_u_fixnum_divide" len es)] )
- (check-range from 0 (fx+ ilen 1) loc)
- (check-range to 0 (fx+ ilen 1) loc)
+ (##sys#check-range/including from 0 ilen loc)
+ (##sys#check-range/including to 0 ilen loc)
(let* ([size2 (fx* es (fx- to from))]
- [bv2 (##sys#allocate-vector size2 #t #f #t)] )
- (##core#inline "C_string_to_bytevector" bv2)
+ [bv2 (##sys#allocate-bytevector size2 #f)] )
(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) (subnvector v 'u8vector 1 from to 'subu8vector))
+(define (subu8vector v from to)
+ (##sys#check-bytevector v 'subu8vector)
+ (let ((n (##sys#size v)))
+ (##sys#check-range/including from 0 n 'subu8vector)
+ (##sys#check-range/including to 0 n 'subu8vector)
+ (bytevector-copy v from to)))
+
(define (subu16vector v from to) (subnvector v 'u16vector 2 from to 'subu16vector))
(define (subu32vector v from to) (subnvector v 'u32vector 4 from to 'subu32vector))
(define (subu64vector v from to) (subnvector v 'u64vector 8 from to 'subu64vector))
@@ -719,39 +761,98 @@ EOF
(define (subs64vector v from to) (subnvector v 's64vector 8 from to 'subs64vector))
(define (subf32vector v from to) (subnvector v 'f32vector 4 from to 'subf32vector))
(define (subf64vector v from to) (subnvector v 'f64vector 8 from to 'subf64vector))
+(define (subc64vector v from to) (subnvector v 'c64vector 8 from to 'subc64vector))
+(define (subc128vector v from to) (subnvector v 'c128vector 16 from to 'subc128vector))
-(define (write-u8vector v #!optional (port ##sys#standard-output) (from 0) to)
- (##sys#check-structure v 'u8vector 'write-u8vector)
- (##sys#check-output-port port #t 'write-u8vector)
- (let ((len (##core#inline "C_u_i_8vector_length" v)))
- (check-range from 0 (fx+ (or to len) 1) 'write-u8vector)
- (when to (check-range to from (fx+ len 1) 'write-u8vector))
- ; using (write-string) since the "data" slot of a u8vector is
- ; represented the same as a string
- ((##sys#slot (##sys#slot port 2) 3) ; write-string
- port
- (if (and (fx= from 0) (or (not to) (fx= to len)))
- (##sys#slot v 1)
- (##sys#slot (subu8vector v from (or to len)) 1)))))
-
-(define (read-u8vector! n dest #!optional (port ##sys#standard-input) (start 0))
- (##sys#check-input-port port #t 'read-u8vector!)
- (##sys#check-fixnum start 'read-u8vector!)
- (##sys#check-structure dest 'u8vector 'read-u8vector!)
- (when n (##sys#check-fixnum n 'read-u8vector!))
- (let* ((dest (##sys#slot dest 1))
- (size (##sys#size dest)))
- (unless (and n (fx<= (fx+ start n) size))
- (set! n (fx- size start)))
- (chicken.io#read-string!/port n dest port start)))
-
-(define (read-u8vector #!optional n (p ##sys#standard-input))
- (##sys#check-input-port p #t 'read-u8vector)
- (when n (##sys#check-fixnum n 'read-u8vector))
- (let ((str (chicken.io#read-string/port n p)))
- (cond ((eof-object? str) str)
- (else
- (##core#inline "C_string_to_bytevector" str)
- (##sys#make-structure 'u8vector str)))))
-
-(register-feature! 'srfi-4))
+) ; module chicken.number-vector
+
+(module srfi-4
+ (f32vector f32vector->list
+ f32vector-length f32vector-ref f32vector-set! f32vector?
+ f64vector f64vector->list
+ f64vector-length f64vector-ref f64vector-set! f64vector?
+ s8vector s8vector->list
+ s8vector-length s8vector-ref s8vector-set! s8vector?
+ s16vector s16vector->list
+ s16vector-length s16vector-ref s16vector-set! s16vector?
+ s32vector s32vector->list
+ s32vector-length s32vector-ref s32vector-set! s32vector?
+ s64vector s64vector->list
+ s64vector-length s64vector-ref s64vector-set! s64vector?
+ u8vector u8vector->list
+ u8vector-length u8vector-ref u8vector-set! u8vector?
+ u16vector u16vector->list
+ u16vector-length u16vector-ref u16vector-set! u16vector?
+ u32vector u32vector->list
+ u32vector-length u32vector-ref u32vector-set! u32vector?
+ u64vector u64vector->list
+ u64vector-length u64vector-ref u64vector-set! u64vector?
+ list->f32vector list->f64vector list->s16vector list->s32vector
+ list->s64vector list->s8vector list->u16vector list->u32vector
+ list->u8vector list->u64vector
+ make-f32vector make-f64vector make-s16vector make-s32vector
+ make-s64vector make-s8vector make-u16vector make-u32vector
+ make-u64vector make-u8vector)
+(import (chicken number-vector)))
+
+
+;;; Read syntax:
+
+(import scheme (chicken number-vector))
+
+(set! ##sys#user-read-hook
+ (let ((old-hook ##sys#user-read-hook)
+ (consers (list 'u8 chicken.number-vector#list->u8vector
+ 's8 chicken.number-vector#list->s8vector
+ 'u16 chicken.number-vector#list->u16vector
+ 's16 chicken.number-vector#list->s16vector
+ 'u32 chicken.number-vector#list->u32vector
+ 's32 chicken.number-vector#list->s32vector
+ 'u64 chicken.number-vector#list->u64vector
+ 's64 chicken.number-vector#list->s64vector
+ 'f32 chicken.number-vector#list->f32vector
+ 'f64 chicken.number-vector#list->f64vector
+ 'c64 chicken.number-vector#list->c64vector
+ 'c128 chicken.number-vector#list->c128vector) ) )
+ (lambda (char port)
+ (if (memq char '(#\u #\s #\f #\c))
+ (let* ((x (##sys#read port ##sys#default-read-info-hook))
+ (tag (and (symbol? x) x)) )
+ (cond ((or (eq? tag 'f) (eq? tag 'false)) #f)
+ ((memq tag consers) =>
+ (lambda (c)
+ (let ((d (##sys#read-numvector-data port)))
+ (cond ((or (null? d) (pair? d))
+ ((cadr c) (##sys#canonicalize-number-list! d)))
+ ((eq? tag 'u8)
+ ;; reuse already created bytevector
+ (##core#inline "C_chop_bv" (##sys#slot d 0)))
+ (else
+ ((cadr c) (##sys#string->list d)))))))
+ (else (##sys#read-error port "invalid sharp-sign read 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 ,chicken.number-vector#u8vector->list)
+ (s8vector s8 ,chicken.number-vector#s8vector->list)
+ (u16vector u16 ,chicken.number-vector#u16vector->list)
+ (s16vector s16 ,chicken.number-vector#s16vector->list)
+ (u32vector u32 ,chicken.number-vector#u32vector->list)
+ (s32vector s32 ,chicken.number-vector#s32vector->list)
+ (u64vector u64 ,chicken.number-vector#u64vector->list)
+ (s64vector s64 ,chicken.number-vector#s64vector->list)
+ (f32vector f32 ,chicken.number-vector#f32vector->list)
+ (f64vector f64 ,chicken.number-vector#f64vector->list)
+ (c64vector c64 ,chicken.number-vector#c64vector->list)
+ (c128vector c128 ,chicken.number-vector#c128vector->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)) ) ) ) ) )
diff --git a/support.scm b/support.scm
index a11c26ed..c7eeb6b5 100644
--- a/support.scm
+++ b/support.scm
@@ -8,11 +8,11 @@
; conditions are met:
;
; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-; disclaimer.
+; 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.
+; 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.
+; 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
@@ -33,7 +33,7 @@
(compiler-cleanup-hook bomb collected-debugging-output debugging
debugging-chicken with-debugging-output quit-compiling
emit-syntax-trace-info check-signature build-lambda-list
- c-ify-string valid-c-identifier? read-expressions
+ valid-c-identifier? read-expressions
bytes->words words->bytes replace-rest-op-with-list-ops
check-and-open-input-file close-checked-input-file fold-inner
constant? collapsable-literal? immediate? basic-literal?
@@ -77,7 +77,7 @@
(import scheme
chicken.base
chicken.bitwise
- chicken.blob
+ chicken.bytevector
chicken.condition
chicken.file
chicken.fixnum
@@ -95,6 +95,7 @@
chicken.string
chicken.syntax
chicken.time)
+(import (only (scheme base) open-output-string get-output-string))
(include "tweaks")
(include "mini-srfi-1.scm")
@@ -133,7 +134,7 @@
(when (pair? args)
(display ": ")
(for-each
- (lambda (x) (printf "~s " (force x)))
+ (lambda (x) (printf "~s " (force x)))
args) )
(newline))))
(define (dump txt)
@@ -176,21 +177,19 @@
(set! ##sys#syntax-error-hook
(lambda (msg . args)
(let ((out (current-error-port))
- (loc (and (symbol? msg)
+ (loc (and (symbol? msg)
(let ((loc msg))
(set! msg (car args))
(set! args (cdr args))
loc))))
(if loc
- (fprintf out "\nSyntax error (~a): ~a~%~%" loc msg)
+ (fprintf out "\nSyntax error (~a): ~a~%~%" loc msg)
(fprintf out "\nSyntax 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)
+(define (emit-syntax-trace-info info cntr)
(define (thread-id t) (##sys#slot t 14))
(##core#inline "C_emit_syntax_trace_info" info cntr
(thread-id ##sys#current-thread)))
@@ -216,25 +215,6 @@
(cond ((or (zero? n) (null? vars)) (or rest '()))
(else (cons (car vars) (loop (cdr vars) (sub1 n)))) ) ) )
-;; XXX: Put this too in c-platform or c-backend?
-(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))) ) ) ) ) ) ) )
-
;; XXX: This too, but it's used only in core.scm, WTF?
(define (valid-c-identifier? name)
(let ([str (string->list (->string name))])
@@ -244,6 +224,11 @@
(every (lambda (c) (or (char-alphabetic? c) (char-numeric? c) (char=? #\_ c)))
(cdr str)))))))
+(define (struct/union-wrapper-type-name x)
+ (cond ((list? (cadr x)) (string->symbol (->string (caadr x))))
+ (else (string->symbol (string-append (symbol->string (car x)) " "
+ (->string (cadr x)))))))
+
;; TODO: Move these to (chicken memory)?
(define bytes->words (foreign-lambda int "C_bytestowords" int))
(define words->bytes (foreign-lambda int "C_wordstobytes" int))
@@ -260,11 +245,11 @@
(unless (string=? fname "-") (close-input-port port)) )
(define (fold-inner proc lst)
- (if (null? (cdr lst))
+ (if (null? (cdr lst))
lst
(let fold ((xs (reverse lst)))
(apply
- proc
+ proc
(if (null? (cddr xs))
(list (cadr xs) (car xs))
(list (fold (cdr xs)) (car xs)) ) ) ) ) )
@@ -287,17 +272,14 @@
;;; Predicates on expressions and literals:
-;; TODO: Remove once we have a bootstrapping libchicken with bwp-object?
-(define (bwp-object? x) (##core#inline "C_bwpp" x))
-
(define (constant? x)
(or (number? x)
(char? x)
(string? x)
(boolean? x)
(eof-object? x)
+ (bytevector? x)
(bwp-object? x)
- (blob? x)
(vector? x)
(##sys#srfi-4-vector? x)
(and (pair? x) (eq? 'quote (car x))) ) )
@@ -324,7 +306,7 @@
(symbol? x)
(constant? x)
(and (vector? x) (every basic-literal? (vector->list x)))
- (and (pair? x)
+ (and (pair? x)
(basic-literal? (car x))
(basic-literal? (cdr x)) ) ) )
@@ -337,7 +319,7 @@
((null? (cdr xs)) (car xs))
((let ([h (car xs)])
(or (equal? h '(##core#undefined))
- (constant? h)
+ (constant? h)
(equal? h '(##sys#void)) ) )
(loop (cdr xs)) )
(else `(let ((,(gensym 't) ,(car xs)))
@@ -349,11 +331,11 @@
[exn-msg (condition-property-accessor 'exn 'message)] )
(lambda (str)
(handle-exceptions ex
- (quit-compiling "cannot parse expression: ~s [~a]~%"
+ (quit-compiling "cannot parse expression: ~s [~a]~%"
str
- (if (exn? ex)
+ (if (exn? ex)
(exn-msg ex)
- (->string ex) ) )
+ (->string ex) ) )
(let ((xs (with-input-from-string
str
(lambda ()
@@ -388,7 +370,7 @@
(define profile-lambda-index 0)
(define (expand-profile-lambda name llist body)
- (let ([index profile-lambda-index]
+ (let ([index profile-lambda-index]
[args (gensym)] )
(set! profile-lambda-list (alist-cons index name profile-lambda-list))
(set! profile-lambda-index (add1 index))
@@ -400,7 +382,7 @@
;; Get expressions which initialize and populate the profiling vector
(define (profiling-prelude-exps profile-name)
- `((set! ,profile-info-vector-name
+ `((set! ,profile-info-vector-name
(##sys#register-profile-info
',(length profile-lambda-list)
',profile-name))
@@ -450,12 +432,10 @@
;; 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-record node
+ class ; symbol
+ parameters ; (value...)
+ subexpressions ) ; (node...)
(set-record-printer! node
(lambda (n out)
@@ -495,7 +475,7 @@
'let (unzip1 bs)
(append (map (lambda (b) (walk (cadr b))) (cadr x))
(list (walk body)) ) ) ) ) )
- ((lambda ##core#lambda)
+ ((lambda ##core#lambda)
(make-node 'lambda (list (cadr x)) (list (walk (caddr x)))))
((##core#the)
(make-node '##core#the
@@ -506,7 +486,7 @@
(let loop ((cls (cdddr x)) (types '()) (exps (list (walk (caddr x)))))
(cond ((null? cls) ; no "else" clause given
(make-node
- '##core#typecase
+ '##core#typecase
(cons (cadr x) (reverse types))
(reverse
(cons (make-node '##core#undefined '() '()) exps))))
@@ -568,7 +548,7 @@
(define (build-expression-tree node)
(let walk ((n node))
(let ((subs (node-subexpressions n))
- (params (node-parameters n))
+ (params (node-parameters n))
(class (node-class n)) )
(case class
((if ##core#box ##core#cond) (cons class (map walk subs)))
@@ -583,7 +563,7 @@
((let)
`(let ,(map list params (map walk (butlast subs)))
,(walk (last subs)) ) )
- ((##core#lambda)
+ ((##core#lambda)
(list (if (second params)
'lambda
'##core#lambda)
@@ -603,17 +583,17 @@
`((else ,(walk (car bodies)))))
(cons (list (car types) (walk (car bodies)))
(loop (cdr types) (cdr bodies)))))))
- ((##core#call)
+ ((##core#call)
(map walk subs))
((##core#callunit) (cons* '##core#callunit (car params) (map walk subs)))
((##core#undefined) (list class))
- ((##core#bind)
+ ((##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))) )
+ (cons* class (walk (car subs)) params (map walk (cdr subs))) )
((##core#inline_allocate)
(cons* class params (map walk subs)))
(else (cons class (append params (map walk subs)))) ) ) ) )
@@ -622,8 +602,8 @@
(let fold ([vars lst])
(if (null? (cddr vars))
(apply proc vars)
- (make-node
- '##core#inline '("C_and")
+ (make-node
+ '##core#inline '("C_and")
(list (proc (first vars) (second vars))
(fold (cdr vars)) ) ) ) ) )
@@ -634,7 +614,7 @@
(lambda (vars argc rest)
(receive (largs rargs) (split-at args argc)
(let* ((rlist (if copy? (map gensym vars) vars))
- (body (if copy?
+ (body (if copy?
(copy-node-tree-and-rename body vars rlist db cfk)
body) )
(rarg-aliases (map (lambda (r) (gensym 'rarg)) rargs)) )
@@ -667,7 +647,7 @@
(qnode '())
(make-node
'##core#inline_allocate
- (list "C_a_i_list" (* 3 (length rargs)))
+ (list "C_a_i_list" (* 3 (length rargs)))
rargs) )
body) ))
(make-node 'let (list (car rarg-aliases))
@@ -689,22 +669,22 @@
(case class
((quote)
(make-node class params '()))
- ((##core#variable)
+ ((##core#variable)
(let ((var (first params)))
(when (db-get db var 'contractable)
(cfk var))
(varnode (rename var rl))) )
- ((set!)
+ ((set!)
(make-node
'set! (list (rename (first params) rl))
(list (walk (first subs) rl)) ) )
- ((let)
+ ((let)
(let* ((v (first params))
(val1 (walk (first subs) rl))
(a (gensym v))
(rl2 (alist-cons v a rl)) )
(db-put! db a 'inline-transient #t)
- (make-node
+ (make-node
'let (list a)
(list val1 (walk (second subs) rl2)))) )
((##core#lambda)
@@ -717,7 +697,7 @@
a))
vars) )
(rl2 (append (map cons vars as) rl)) )
- (make-node
+ (make-node
'##core#lambda
(list (gensym 'f) (second params) ; new function-id
(build-lambda-list as argc (and rest (rename rest rl2)))
@@ -803,7 +783,7 @@
(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))
+ (node-subexpressions-set! to (node-subexpressions from))
to)
(define (node->sexpr n)
@@ -871,9 +851,9 @@
(let loop ()
(let ((x (read)))
(unless (eof-object? x)
- (mark-variable
+ (mark-variable
(car x)
- '##compiler#inline-global
+ '##compiler#inline-global
(sexpr->node (cadr x)))
(loop)))))))
@@ -895,7 +875,7 @@
((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)
@@ -923,7 +903,7 @@
(let ([subs (node-subexpressions n)])
(case (node-class n)
[(##core#variable quote ##core#undefined ##core#proc) #f]
- [(##core#lambda)
+ [(##core#lambda)
(let ([id (first (node-parameters n))])
(find (lambda (fs)
(eq? id (foreign-callback-stub-id fs)))
@@ -935,14 +915,14 @@
(let* ([params (node-parameters node)]
[llist (third params)]
[k (and (pair? llist) (first llist))] ) ; leaf-routine has no continuation argument
- (and k
+ (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))
+ (and (eq? '##core#variable (node-class f))
(eq? k (first (node-parameters f)))
(every rec (cdr subs)) ) ) ]
[(##core#callunit) #f]
@@ -996,14 +976,12 @@
(define foreign-callback-stubs '())
-(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 ...)
+(define-record foreign-callback-stub
+ id ; symbol
+ name ; string
+ qualifiers ; string
+ return-type ; type-specifier
+ argument-types ) ; (type-specifier ...)
(define (register-foreign-callback-stub! id params)
(set! foreign-callback-stubs
@@ -1060,8 +1038,10 @@
;; TODO: Should "[unsigned-]byte" be range checked?
((int unsigned-int 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)))
- ((blob scheme-pointer)
+ ((float double number)
+ (if unsafe param `(##sys#foreign-flonum-argument ,param)))
+ ((u8vector bytevector scheme-pointer
+ blob) ; DEPRECATED
(let ((tmp (gensym)))
`(##core#let ((,tmp ,param))
(##core#if ,tmp
@@ -1069,7 +1049,8 @@
tmp
`(##sys#foreign-block-argument ,tmp) )
(##core#quote #f)) ) ) )
- ((nonnull-scheme-pointer nonnull-blob)
+ ((nonnull-scheme-pointer nonnull-bytevector nonnull-u8vector
+ nonnull-blob) ; DEPRECATED
(if unsafe
param
`(##sys#foreign-block-argument ,param) ) )
@@ -1085,7 +1066,7 @@
(if unsafe
param
`(##sys#foreign-struct-wrapper-argument (##core#quote pointer-vector) ,param) ) )
- ((u8vector u16vector s8vector s16vector u32vector s32vector
+ ((u16vector s8vector s16vector u32vector s32vector
u64vector s64vector f32vector f64vector)
(let ((tmp (gensym)))
`(##core#let ((,tmp ,param))
@@ -1094,16 +1075,19 @@
tmp
`(##sys#foreign-struct-wrapper-argument (##core#quote ,t) ,tmp) )
(##core#quote #f)) ) ) )
- ((nonnull-u8vector nonnull-u16vector
+ ((nonnull-u16vector
nonnull-s8vector nonnull-s16vector
nonnull-u32vector nonnull-s32vector
nonnull-u64vector nonnull-s64vector
nonnull-f32vector nonnull-f64vector)
(if unsafe
param
- `(##sys#foreign-struct-wrapper-argument
+ `(##sys#foreign-struct-wrapper-argument
(##core#quote ,(##sys#slot (assq t tmap) 1))
,param) ) )
+ ((complex cplxnum)
+ ;; always converts to inexact
+ `(##sys#foreign-cplxnum-argument ,param))
((integer32 integer64 integer short long ssize_t)
(let* ((foreign-type (##sys#slot (assq t ftmap) 1))
(size-expr (sprintf "sizeof(~A) * CHAR_BIT" foreign-type)))
@@ -1131,18 +1115,18 @@
(let ((tmp (gensym)))
`(##core#let ((,tmp ,param))
(##core#if ,tmp
- ,(if unsafe
- `(##sys#make-c-string ,tmp)
+ ,(if unsafe
+ `(##sys#slot ,tmp 0)
`(##sys#make-c-string (##sys#foreign-string-argument ,tmp)) )
(##core#quote #f)) ) ) )
((nonnull-c-string nonnull-c-string* nonnull-unsigned-c-string*)
- (if unsafe
- `(##sys#make-c-string ,param)
+ (if unsafe
+ `(##sys#slot ,param 0)
`(##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))) ) )
+ (if unsafe
+ `(##sys#slot ,param 1)
+ `(##sys#slot (##sys#foreign-symbol-argument ,param) 1)) )
(else
(cond ((and (symbol? t) (lookup-foreign-type t))
=> (lambda (t) (next (vector-ref t 0)) ) )
@@ -1160,6 +1144,9 @@
(##core#if ,tmp
(slot-ref ,param (##core#quote this))
(##core#quote #f)) ) ) )
+ ((struct union)
+ `(##sys#slot (##sys#foreign-struct-wrapper-argument (##core#quote ,(struct/union-wrapper-type-name t))
+ ,param) 1))
((scheme-pointer)
(let ((tmp (gensym)))
`(##core#let ((,tmp ,param))
@@ -1233,7 +1220,7 @@
(lambda (t next)
(case t
((char int short bool void unsigned-short scheme-object unsigned-char unsigned-int byte unsigned-byte
- int32 unsigned-int32)
+ 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*
@@ -1241,8 +1228,10 @@
(words->bytes 3) )
((unsigned-integer long integer unsigned-long integer32 unsigned-integer32)
(words->bytes 6) ) ; 1 bignum digit on 32-bit (overallocs on 64-bit)
- ((float double number)
+ ((float double number)
(words->bytes 4) ) ; possibly 8-byte aligned 64-bit double
+ ((complex cplxnum)
+ (words->bytes 8)) ; 2 double numbers, possibly 8-byte aligned (overallocs on 64-bit)
((integer64 unsigned-integer64 size_t ssize_t)
(words->bytes 7)) ; 2 bignum digits on 32-bit (overallocs on 64-bit)
(else
@@ -1250,16 +1239,17 @@
=> (lambda (t2) (next (vector-ref t2 0)) ) )
((pair? t)
(case (car t)
- ((ref nonnull-pointer pointer c-pointer nonnull-c-pointer function instance instance-ref nonnull-instance)
+ ((ref nonnull-pointer pointer c-pointer nonnull-c-pointer function instance instance-ref nonnull-instance)
(words->bytes 3) )
((const) (next (cadr t)))
+ ((struct union) (words->bytes 3)) ;; struct wrapper
((enum) (words->bytes 6)) ; 1 bignum digit on 32-bit (overallocs on 64-bit)
(else (err t))))
(else (err t))))))
(lambda () (quit-compiling "foreign type `~S' refers to itself" type)) ) )
(define (estimate-foreign-result-location-size type) ; Used only in compiler.scm
- (define (err t)
+ (define (err t)
(quit-compiling "cannot compute size of location for foreign type `~S'" t) )
(follow-without-loop
type
@@ -1273,6 +1263,8 @@
(words->bytes 1) )
((double integer64 unsigned-integer64 size_t ssize_t)
(words->bytes 2) )
+ ((complex cplxnum)
+ (words->bytes 4))
(else
(cond ((and (symbol? t) (lookup-foreign-type t))
=> (lambda (t2) (next (vector-ref t2 0)) ) )
@@ -1281,6 +1273,7 @@
((ref nonnull-pointer pointer c-pointer nonnull-c-pointer function
scheme-pointer nonnull-scheme-pointer enum)
(words->bytes 1))
+ ((struct union) (words->bytes 3)) ;; struct wrapper
((const) (next (cadr t)))
(else (err t)) ) )
(else (err t)) ) ) ) )
@@ -1296,32 +1289,34 @@
((nonnull-c-string) `(##sys#peek-nonnull-c-string ,body (##core#quote 0)))
((c-string* unsigned-c-string*) `(##sys#peek-and-free-c-string ,body (##core#quote 0)))
((nonnull-c-string* nonnull-unsigned-c-string*) `(##sys#peek-and-free-nonnull-c-string ,body (##core#quote 0)))
- ((symbol) `(##sys#intern-symbol (##sys#peek-c-string ,body (##core#quote 0))))
+ ((symbol) `(##sys#string->symbol (##sys#peek-c-string ,body (##core#quote 0))))
((c-string-list) `(##sys#peek-c-string-list ,body (##core#quote #f)))
((c-string-list*) `(##sys#peek-and-free-c-string-list ,body (##core#quote #f)))
(else
- (if (list? type)
- (if (and (eq? (car type) 'const)
- (= 2 (length type))
- (memq (cadr type) '(c-string c-string* unsigned-c-string
- unsigned-c-string* nonnull-c-string
- nonnull-c-string*
- nonnull-unsigned-string*)))
- (finish-foreign-result (cadr type) body)
- (if (= 3 (length type))
- (case (car type)
- ((instance instance-ref)
- (let ((tmp (gensym)))
- `(let ((,tmp ,body))
- (and ,tmp
- (not (##sys#null-pointer? ,tmp))
- (make ,(caddr type)
- (##core#quote this) ,tmp) ) ) ) )
- ((nonnull-instance)
- `(make ,(caddr type) (##core#quote this) ,body) )
- (else body))
- body))
- body)))))
+ (cond ((not (list? type)) body)
+ ((and (memq (car type) '(struct union))
+ (= 2 (length type)))
+ `(##sys#wrap-struct (##core#quote ,(struct/union-wrapper-type-name type)) ,body))
+ ((and (eq? (car type) 'const)
+ (= 2 (length type))
+ (memq (cadr type) '(c-string c-string* unsigned-c-string
+ unsigned-c-string* nonnull-c-string
+ nonnull-c-string*
+ nonnull-unsigned-string*)))
+ (finish-foreign-result (cadr type) body))
+ ((= 3 (length type))
+ (case (car type)
+ ((instance instance-ref)
+ (let ((tmp (gensym)))
+ `(let ((,tmp ,body))
+ (and ,tmp
+ (not (##sys#null-pointer? ,tmp))
+ (make ,(caddr type)
+ (##core#quote this) ,tmp) ) ) ) )
+ ((nonnull-instance)
+ `(make ,(caddr type) (##core#quote this) ,body) )
+ (else body)))
+ (else body))))))
;;; Translate foreign-type into scrutinizer type:
@@ -1345,22 +1340,25 @@
(case mode
((arg) 'number)
(else 'float)))
+ ((complex cplxnum) 'complex)
((scheme-pointer nonnull-scheme-pointer) '*)
- ((blob)
+ ((bytevector u8vector
+ blob) ; DEPRECATED
(case mode
- ((arg) '(or false blob))
- (else 'blob)))
- ((nonnull-blob) 'blob)
+ ((arg) '(or false bytevector))
+ (else 'bytevector)))
+ ((nonnull-bytevector) 'bytevector)
+ ((nonnull-blob) 'bytevector) ; DEPRECATED
((pointer-vector)
(case mode
((arg) '(or false pointer-vector))
(else 'pointer-vector)))
((nonnull-pointer-vector) 'pointer-vector)
- ((u8vector u16vector s8vector s16vector u32vector s32vector u64vector s64vector f32vector f64vector)
+ ((u16vector s8vector s16vector u32vector s32vector u64vector s64vector f32vector f64vector)
(case mode
((arg) `(or false (struct ,ft)))
(else `(struct ,ft))))
- ((nonnull-u8vector) '(struct u8vector))
+ ((nonnull-u8vector) 'bytevector)
((nonnull-s8vector) '(struct s8vector))
((nonnull-u16vector) '(struct u16vector))
((nonnull-s16vector) '(struct s16vector))
@@ -1395,6 +1393,8 @@
'(or false pointer locative)
'(or false pointer)))
((const) (foreign-type->scrutiny-type (cadr t) mode))
+ ((struct union)
+ `(struct ,(struct/union-wrapper-type-name t)))
((enum) 'integer)
((nonnull-pointer nonnull-c-pointer)
(if (eq? 'arg mode)
@@ -1411,10 +1411,10 @@
(let walk ([n node])
(let ([subs (node-subexpressions n)])
(case (node-class n)
- [(##core#variable set!)
+ [(##core#variable set!)
(let ([var (first (node-parameters n))])
(when (and (memq var vars) (not (memq var used)))
- (set! used (cons var used)) )
+ (set! used (cons var used)) )
(for-each walk subs) ) ]
[(quote ##core#undefined ##core#primitive) #f]
[else (for-each walk subs)] ) ) )
@@ -1432,17 +1432,17 @@
[params (node-parameters n)] )
(case (node-class n)
((quote ##core#undefined ##core#primitive ##core#proc ##core#inline_ref) #f)
- ((##core#variable)
+ ((##core#variable)
(let ((var (first params)))
(unless (memq var e)
(set! vars (lset-adjoin/eq? vars var))
- (unless (variable-visible? var block-compilation)
+ (unless (variable-visible? var block-compilation)
(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)
+ ((let)
(walk (first subs) e)
(walk (second subs) (append params e)) )
((##core#lambda)
@@ -1459,12 +1459,19 @@
(values vars hvars) ) ) ; => freevars hiddenvars
+;;; Some pathname operations:
+
+(define (chop-separator str) ; Used only in batch-driver.scm
+ (let ([len (sub1 (string-length str))])
+ (if (and (> len 0)
+ (memq (string-ref str len) '(#\\ #\/)))
+ (substring str 0 len)
+ str) ) )
+
;;; 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
+(define-record block-variable-literal
+ name) ; symbol
;;; Generation of random names:
@@ -1508,7 +1515,7 @@
(let ((n2 (hash-table-ref real-name-table n)))
(if n2
(or (hash-table-ref real-name-table n2)
- n2)
+ n2)
n) ) )
(let ((rn (resolve var)))
(cond ((not rn) (##sys#symbol->string var))
@@ -1611,8 +1618,10 @@
(and str (fits? (string-length str)))))
((flonum? lit))
((symbol? lit)
- (let ((str (##sys#slot lit 1)))
+ (let ((str (##sys#symbol->string/shared lit)))
(fits? (string-length str))))
+ ((string? lit)
+ (fits? (getsize (##sys#slot lit 0))))
((##core#inline "C_byteblockp" lit)
(fits? (getsize lit)))
(else
@@ -1630,8 +1639,8 @@
(let loop ([i 0] [n n])
(let ([class (node-class n)]
[params (node-parameters n)]
- [subs (node-subexpressions n)]
- [ind (make-string i #\space)]
+ [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)
@@ -1655,7 +1664,7 @@
(set! ##sys#user-read-hook
(let ([old-hook ##sys#user-read-hook])
(lambda (char port)
- (if (char=? #\> char)
+ (if (char=? #\> char)
(let* ((_ (read-char port)) ; swallow #\>
(text (scan-sharp-greater-string port)))
`(declare (foreign-declare ,text)) )
@@ -1676,7 +1685,7 @@
(get-output-string out)
(begin
(write-char #\< out)
- (write-char c out)
+ (write-char c out)
(loop) ) ) ) )
(else
(write-char c out)
@@ -1741,7 +1750,7 @@
(for-each
(lambda (e)
(let ((id (car e)))
- (##sys#put!
+ (##sys#put!
id '##core#db
(append (or (##sys#get id '##core#db) '()) (list (cdr e))) )))
(call-with-input-file dbfile read-expressions))))
@@ -1762,7 +1771,7 @@
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:
@@ -1790,9 +1799,8 @@ Usage: chicken FILENAME [OPTION ...]
-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
+ -r7rs-syntax disables the CHICKEN extensions to
+ R7RS syntax
-compile-syntax macros are made available at run-time
-emit-import-library MODULE write compile-time module information into
separate file
@@ -1817,7 +1825,7 @@ Usage: chicken FILENAME [OPTION ...]
-no-trace disable tracing information
-debug-info enable debug-information in compiled code for use
with an external debugger
- -profile executable emits profiling 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
@@ -1877,7 +1885,7 @@ Usage: chicken FILENAME [OPTION ...]
Obscure options:
-debug MODES display debugging output for the given modes
- -raw do not generate implicit init- and exit code
+ -raw do not generate implicit init- and exit code
-emit-external-prototypes-first
emit prototypes for callbacks before foreign
declarations
@@ -1902,7 +1910,7 @@ Available debugging options:
h you already figured that out
i show information about inlining
m show GC statistics during compilation
- n print the line-number database
+ n print the line-number database
o show performed optimizations
p display information about what the compiler is currently doing
r show invocation parameters
@@ -1930,3 +1938,4 @@ Available debugging options:
EOF
))
)
+
diff --git a/synrules.scm b/synrules.scm
index d0919862..fa12a32b 100644
--- a/synrules.scm
+++ b/synrules.scm
@@ -23,12 +23,10 @@
;; (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
+;; [Hacked even more by Felix L. Winkelmann to make it work in the
;; Hi-Lo expander]
; Example:
@@ -55,21 +53,19 @@
(set! subkeywords (car rules))
(set! rules (cdr rules)))
(chicken.internal.syntax-rules#process-syntax-rules
- ellipsis rules subkeywords r c)))))
-
+ ellipsis rules subkeywords r c #t)))))
;; Runtime internal support module exclusively for syntax-rules
(module chicken.internal.syntax-rules
- (drop-right take-right syntax-rules-mismatch)
+ (drop-right take-right safe-length syntax-rules-mismatch)
(import scheme)
(define (syntax-rules-mismatch input)
- (##sys#syntax-error-hook "no rule matches form" input))
+ (##sys#syntax-error "no rule matches form" input))
(define (drop-right input temp)
- ;;XXX use unsafe accessors
- (let loop ((len (length input))
+ (let loop ((len (safe-length input))
(input input))
(cond
((> len temp)
@@ -78,15 +74,20 @@
(else '()))))
(define (take-right input temp)
- ;;XXX use unsafe accessors
- (let loop ((len (length input))
+ (let loop ((len (safe-length input))
(input input))
(cond
((> len temp)
(loop (- len 1) (cdr input)))
(else input))))
-(define (process-syntax-rules ellipsis rules subkeywords r c)
+(define (safe-length lst)
+ (let loop ((lst lst) (len 0))
+ (if (pair? lst)
+ (loop (cdr lst) (+ 1 len))
+ len)))
+
+(define (process-syntax-rules ellipsis rules subkeywords r c r7ext)
(define %append '##sys#append)
(define %apply '##sys#apply)
@@ -114,7 +115,6 @@
(define %lambda (r 'lambda))
(define %let (r 'let))
(define %let* (r 'let*))
- (define %list? '##sys#list?)
(define %loop (r 'loop))
(define %map1 '##sys#map)
(define %map '##sys#map-n)
@@ -125,8 +125,9 @@
(define %rename (r 'rename))
(define %tail (r 'tail))
(define %temp (r 'temp))
- (define %syntax-error '##sys#syntax-error-hook)
+ (define %syntax-error '##sys#syntax-error)
(define %ellipsis (r ellipsis))
+ (define %safe-length (r 'chicken.internal.syntax-rules#safe-length))
(define %take-right (r 'chicken.internal.syntax-rules#take-right))
(define %drop-right (r 'chicken.internal.syntax-rules#drop-right))
(define %syntax-rules-mismatch
@@ -135,6 +136,10 @@
(define (ellipsis? x)
(c x %ellipsis))
+ ;; R7RS support: underscore matches anything
+ (define (underscore? x)
+ (c x (r '_)))
+
(define (make-transformer rules)
`(##sys#er-transformer
(,%lambda (,%input ,%rename ,%compare)
@@ -148,64 +153,65 @@
(null? (cddr rule)))
(let ((pattern (cdar rule))
(template (cadr rule)))
- `((,%and ,@(process-match %tail pattern #f))
+ `((,%and ,@(process-match %tail pattern #f ellipsis?))
(,%let* ,(process-pattern pattern
%tail
- (lambda (x) x) #f)
+ (lambda (x) x) #f ellipsis?)
,(process-template template
- 0
- (meta-variables pattern 0 '() #f)))))
- (##sys#syntax-error-hook "ill-formed syntax rule" rule)))
+ 0 ellipsis?
+ (meta-variables pattern 0 ellipsis? '() #f)))))
+ (##sys#syntax-error "ill-formed syntax rule" rule)))
;; Generate code to test whether input expression matches pattern
- (define (process-match input pattern seen-segment?)
+ (define (process-match input pattern seen-segment? el?)
(cond ((symbol? pattern)
(if (memq pattern subkeywords)
`((,%compare ,input (,%rename (##core#syntax ,pattern))))
`()))
- ((segment-pattern? pattern seen-segment?)
- (process-segment-match input pattern))
+ ((segment-pattern? pattern seen-segment? el?)
+ (process-segment-match input pattern el?))
((pair? pattern)
`((,%let ((,%temp ,input))
(,%and (,%pair? ,%temp)
- ,@(process-match `(,%car ,%temp) (car pattern) #f)
- ,@(process-match `(,%cdr ,%temp) (cdr pattern) #f)))))
+ ,@(process-match `(,%car ,%temp) (car pattern) #f el?)
+ ,@(process-match `(,%cdr ,%temp) (cdr pattern) #f el?)))))
((vector? pattern)
`((,%let ((,%temp ,input))
(,%and (,%vector? ,%temp)
,@(process-match `(,%vector->list ,%temp)
- (vector->list pattern) #f)))))
+ (vector->list pattern) #f el?)))))
((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) (car pattern) #f)))
- `((,%and (,%list? ,input) ; Can't ask for its length if not a proper list
- (,%let ((,%len (,%length ,input)))
- (,%and (,%>= ,%len ,(length (cddr pattern)))
- (,%let ,%loop ((,%l ,input)
- (,%len ,%len))
- (,%cond
- ((,%= ,%len ,(length (cddr pattern)))
- ,@(process-match %l (cddr pattern) #t))
- (,%else
- (,%and ,@conjuncts
- (,%loop (,%cdr ,%l) (,%+ ,%len -1))))))))))))
+ (define (process-segment-match input pattern el?)
+ (let ((conjuncts (process-match `(,%car ,%l) (car pattern) #f el?))
+ (plen (safe-length (cddr pattern))))
+ `((,%let ((,%len (,%safe-length ,input)))
+ (,%and (,%>= ,%len ,plen)
+ (,%let ,%loop ((,%l ,input)
+ (,%len ,%len))
+ (,%cond ((,%= ,%len ,plen)
+ ,@(process-match %l (cddr pattern) #t el?))
+ (,%else (,%and ,@conjuncts
+ (,%loop (,%cdr ,%l)
+ (,%+ ,%len -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 seen-segment?)
+ (define (process-pattern pattern path mapit seen-segment? el?)
(cond ((symbol? pattern)
- (if (memq pattern subkeywords)
+ (if (or (memq pattern subkeywords)
+ (and r7ext (underscore? pattern)))
'()
(list (list pattern (mapit path)))))
- ((segment-pattern? pattern seen-segment?)
- (let* ((tail-length (length (cddr pattern)))
- (%match (if (zero? tail-length) ; Simple segment?
+ ((segment-pattern? pattern seen-segment? el?)
+ (let* ((tail-length (safe-length (cddr pattern)))
+ (%match (if (and (list? (cddr pattern))
+ (zero? tail-length) ) ; Simple segment?
path ; No list traversing overhead at runtime!
`(,%drop-right ,path ,tail-length))))
(append
@@ -216,37 +222,44 @@
(if (eq? %temp x)
%match ; Optimization: no map+lambda
`(,%map1 (,%lambda (,%temp) ,x) ,%match))))
- #f)
+ #f el?)
(process-pattern (cddr pattern)
- `(,%take-right ,path ,tail-length) mapit #t))))
+ `(,%take-right ,path ,tail-length)
+ mapit #t el?))))
((pair? pattern)
- (append (process-pattern (car pattern) `(,%car ,path) mapit #f)
- (process-pattern (cdr pattern) `(,%cdr ,path) mapit #f)))
+ (append (process-pattern (car pattern) `(,%car ,path) mapit #f el?)
+ (process-pattern (cdr pattern) `(,%cdr ,path) mapit #f el?)))
((vector? pattern)
(process-pattern (vector->list pattern)
- `(,%vector->list ,path) mapit #f))
+ `(,%vector->list ,path)
+ mapit #f el?))
(else '())))
;; Generate code to compose the output expression according to template
- (define (process-template template dim env)
+ (define (process-template template dim el? 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?)"
+ (##sys#syntax-error "template dimension error (too few ellipses?)"
template))
`(,%rename (##core#syntax ,template)))))
- ((segment-template? template)
- (let* ((depth (segment-depth template))
+ ((and r7ext
+ (ellipsis-escaped-pattern? template el?))
+ (if (or (not (pair? (cdr template))) (pair? (cddr template)))
+ (##sys#syntax-error "Invalid escaped ellipsis template" template)
+ (process-template (cadr template) dim (lambda _ #f) env)))
+ ((segment-template? template el?)
+ (let* ((depth (segment-depth template el?))
(seg-dim (+ dim depth))
(vars
- (free-meta-variables (car template) seg-dim env '())))
+ (free-meta-variables (car template) seg-dim el? env '())))
(if (null? vars)
- (##sys#syntax-error-hook "too many ellipses" template)
+ (##sys#syntax-error "too many ellipses" template)
(let* ((x (process-template (car template)
- seg-dim
+ seg-dim el?
env))
(gen (if (and (pair? vars)
(null? (cdr vars))
@@ -259,86 +272,87 @@
(gen gen `(,%apply ,%append ,gen)))
((= d 1)
gen))))
- (if (null? (segment-tail template))
+ (if (null? (segment-tail template el?))
gen ;+++
- `(,%append ,gen ,(process-template (segment-tail template)
- dim env)))))))
+ `(,%append ,gen ,(process-template (segment-tail template el?)
+ dim el? env)))))))
((pair? template)
- `(,%cons ,(process-template (car template) dim env)
- ,(process-template (cdr template) dim env)))
+ `(,%cons ,(process-template (car template) dim el? env)
+ ,(process-template (cdr template) dim el? env)))
((vector? template)
`(,%list->vector
- ,(process-template (vector->list template) dim env)))
+ ,(process-template (vector->list template) dim el? env)))
(else
`(,%quote ,template))))
;; Return an association list of (var . dim)
- (define (meta-variables pattern dim vars seen-segment?)
+ (define (meta-variables pattern dim el? vars seen-segment?)
(cond ((symbol? pattern)
- (if (memq pattern subkeywords)
+ (if (or (memq pattern subkeywords)
+ (and r7ext (underscore? pattern)))
vars
(cons (cons pattern dim) vars)))
- ((segment-pattern? pattern seen-segment?)
- (meta-variables (car pattern) (+ dim 1)
- (meta-variables (cddr pattern) dim vars #t) #f))
+ ((segment-pattern? pattern seen-segment? el?)
+ (meta-variables (car pattern) (+ dim 1) el?
+ (meta-variables (cddr pattern) dim el? vars #t) #f))
((pair? pattern)
- (meta-variables (car pattern) dim
- (meta-variables (cdr pattern) dim vars #f) #f))
+ (meta-variables (car pattern) dim el?
+ (meta-variables (cdr pattern) dim el? vars #f) #f))
((vector? pattern)
- (meta-variables (vector->list pattern) dim vars #f))
+ (meta-variables (vector->list pattern) dim el? vars #f))
(else vars)))
;; Return a list of meta-variables of given higher dim
- (define (free-meta-variables template dim env free)
+ (define (free-meta-variables template dim el? 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)
+ ((segment-template? template el?)
(free-meta-variables (car template)
- dim env
+ dim el? env
(free-meta-variables (cddr template)
- dim env free)))
+ dim el? env free)))
((pair? template)
(free-meta-variables (car template)
- dim env
+ dim el? env
(free-meta-variables (cdr template)
- dim env free)))
+ dim el? env free)))
((vector? template)
- (free-meta-variables (vector->list template) dim env free))
+ (free-meta-variables (vector->list template) dim el? env free))
(else free)))
- (define (segment-pattern? p seen-segment?)
- (and (segment-template? p)
- (cond
- (seen-segment?
- (##sys#syntax-error-hook "Only one segment per level is allowed" p))
- ((not (list? p)) ; Improper list
- (##sys#syntax-error-hook "Cannot combine dotted tail and ellipsis" p))
- (else #t))))
+ (define (ellipsis-escaped-pattern? pattern el?)
+ (and (pair? pattern) (el? (car pattern))))
+
+ (define (segment-pattern? p seen-segment? el?)
+ (and (segment-template? p el?)
+ (if seen-segment?
+ (##sys#syntax-error "Only one segment per level is allowed" p)
+ #t)))
- (define (segment-template? pattern)
+ (define (segment-template? pattern el?)
(and (pair? pattern)
(pair? (cdr pattern))
- (ellipsis? (cadr pattern))))
+ ((if r7ext el? ellipsis?) (cadr pattern))))
;; Count the number of `...'s in PATTERN.
- (define (segment-depth pattern)
- (if (segment-template? pattern)
- (+ 1 (segment-depth (cdr pattern)))
+ (define (segment-depth pattern el?)
+ (if (segment-template? pattern el?)
+ (+ 1 (segment-depth (cdr pattern) el?))
0))
;; Get whatever is after the `...'s in PATTERN.
- (define (segment-tail pattern)
+ (define (segment-tail pattern el?)
(let loop ((pattern (cdr pattern)))
(if (and (pair? pattern)
- (ellipsis? (car pattern)))
+ ((if r7ext el? ellipsis?) (car pattern)))
(loop (cdr pattern))
pattern)))
diff --git a/tcp.scm b/tcp.scm
index faab6551..11d5f908 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -52,7 +52,7 @@ static C_word make_socket_nonblocking (C_word sock) {
}
/* This is a bit of a hack, but it keeps things simple */
-static C_TLS char *last_wsa_errorstring = NULL;
+static C_char *last_wsa_errorstring = NULL;
static char *errormsg_from_code(int code) {
int bufsize;
@@ -149,6 +149,7 @@ EOF
chicken.foreign
chicken.port
chicken.time)
+(import (only (scheme base) make-parameter))
(include "common-declarations.scm")
@@ -276,11 +277,11 @@ EOF
(define parse-host
(let ((substring substring))
(lambda (host proto)
- (let ((len (##sys#size host)))
+ (let ((len (string-length host)))
(let loop ((i 0))
(if (fx>= i len)
(values host #f)
- (let ((c (##core#inline "C_subchar" host i)))
+ (let ((c (string-ref host i)))
(if (char=? c #\:)
(values
(substring host (fx+ i 1) len)
@@ -360,17 +361,19 @@ EOF
(define io-ports
(let ((tbs tcp-buffer-size))
- (lambda (loc fd)
+ (lambda (loc fd enc)
(unless (##core#inline "make_socket_nonblocking" fd)
(network-error/close loc "cannot create TCP ports" fd) )
- (let* ((buf (make-string +input-buffer-size+))
+ (let* ((buf (##sys#make-bytevector +input-buffer-size+))
(data (vector fd #f #f buf 0))
(buflen 0)
- (bufindex 0)
+ (bufindex 0) ; also used as outbuf-position
(iclosed #f)
(oclosed #f)
(outbufsize (tbs))
- (outbuf (and outbufsize (fx> outbufsize 0) ""))
+ (outbuf (and outbufsize
+ (fx> outbufsize 0)
+ (##sys#make-bytevector outbufsize)))
(read-input
(lambda ()
(let* ((tmr (tcp-read-timeout))
@@ -397,17 +400,19 @@ EOF
(set! buflen n)
(##sys#setislot data 4 n)
(set! bufindex 0) ) ) ) )) ) )
+ (inport #f)
(in
(make-input-port
- (lambda ()
+ (lambda () ; read
(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 ()
+ (##sys#decode-buffer buf bufindex 1 (##sys#slot inport 15)
+ (lambda (buf start n)
+ (set! bufindex (fx+ bufindex n))
+ (##core#inline "C_utf_decode" buf start)))))
+ (lambda () ; char-ready?
(or (fx< bufindex buflen)
;; XXX: This "knows" that check_fd_ready is
;; implemented using a winsock2 call on Windows
@@ -415,25 +420,30 @@ EOF
(when (eq? _socket_error f)
(network-error #f "cannot check socket for input" fd) )
(eq? f 1) ) ) )
- (lambda ()
+ (lambda () ; close
(unless iclosed
(set! iclosed #t)
(unless (##sys#slot data 1) (shutdown fd _shut_rd))
(when (and oclosed (eq? _socket_error (close fd)))
(network-error #f "cannot close socket input port" fd) ) ) )
- (lambda ()
+ peek-char:
+ (lambda () ; peek-char
(when (fx>= bufindex buflen)
(read-input))
- (if (fx< bufindex buflen)
- (##core#inline "C_subchar" buf bufindex)
- #!eof))
- (lambda (p n dest start) ; read-string!
+ (if (fx>= bufindex buflen)
+ #!eof
+ (##sys#decode-buffer buf bufindex 1 (##sys#slot inport 15)
+ (lambda (buf start n)
+ (##core#inline "C_utf_decode" buf start)))))
+ read-bytevector:
+ (lambda (p n dest start) ; read-bytevector!
(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)
+ (##core#inline "C_copy_memory_with_offset" dest buf start
+ bufindex n2)
(set! bufindex (fx+ bufindex n2))
(loop (fx- n n2) (fx+ m n2) (fx+ start n2)) ) )
(else
@@ -441,7 +451,8 @@ EOF
(if (eq? buflen 0)
m
(loop n m start) ) ) ) ) )
- (lambda (p limit) ; read-line
+ read-line:
+ (lambda (p limit) ; read-line
(when (fx>= bufindex buflen)
(read-input))
(if (fx>= bufindex buflen)
@@ -462,88 +473,119 @@ EOF
(values buf bufindex
(fxmin buflen
(fx+ bufindex limit)))
- (values #f bufindex #f))))) ) )
+ (values #f bufindex #f))))))
+ (##sys#slot inport 15))
;; Update row & column position
(if full-line?
(begin
(##sys#setislot p 4 (fx+ (##sys#slot p 4) 1))
(##sys#setislot p 5 0))
(##sys#setislot p 5 (fx+ (##sys#slot p 5)
- (##sys#size line))))
+ (string-length line))))
(set! bufindex next)
line) )) )
+ read-buffered:
(lambda (p) ; read-buffered
(if (fx>= bufindex buflen)
""
- (let ((str (##sys#substring buf bufindex buflen)))
+ (let ((str (##sys#buffer->string/encoding buf bufindex buflen (##sys#slot inport 15))))
(set! bufindex buflen)
str)))
) )
- (output
- (lambda (s)
+ (outport #f)
+ (output-to-socket
+ (lambda (bv n)
(let ((tmw (tcp-write-timeout)))
- (let loop ((len (##sys#size s))
- (offset 0)
- (dlw (and tmw (+ (current-process-milliseconds) tmw))))
- (let* ((count (fxmin +output-chunk-size+ len))
- (n (send fd s offset count 0)))
- (cond ((eq? _socket_error n)
- (cond ((retry?)
- (when dlw
- (##sys#thread-block-for-timeout!
- ##sys#current-thread dlw) )
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output)
- (##sys#thread-yield!)
- (when (##sys#slot ##sys#current-thread 13)
- (##sys#signal-hook
- #:network-timeout-error
- "write operation timed out" tmw fd) )
- (loop len offset dlw) )
- ((interrupted?)
- (##sys#dispatch-interrupt
- (cut loop len offset dlw)))
- (else
- (network-error #f "cannot write to socket" fd) ) ) )
- ((fx< n len)
- (loop (fx- len n) (fx+ offset n)
- (if (fx= n 0)
- tmw
- ;; If we wrote *something*, reset timeout
- (and tmw (+ (current-process-milliseconds) tmw)) )) ) ) ) )) ) )
- (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 ()
+ (##sys#encode-buffer
+ bv 0 n (##sys#slot outport 15)
+ (lambda (buf start len)
+ (let loop ((len len)
+ (offset start)
+ (dlw (and tmw (+ (current-process-milliseconds) tmw))))
+ (let* ((count (fxmin +output-chunk-size+ len))
+ (n (send fd buf offset count 0)))
+ (cond ((eq? _socket_error n)
+ (cond ((retry?)
+ (when dlw
+ (##sys#thread-block-for-timeout! ##sys#current-thread dlw) )
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output)
+ (##sys#thread-yield!)
+ (when (##sys#slot ##sys#current-thread 13)
+ (##sys#signal-hook #:network-timeout-error
+ "write operation timed out" tmw fd) )
+ (loop len offset dlw) )
+ ((interrupted?)
+ (##sys#dispatch-interrupt
+ (cut loop len offset dlw)))
+ (else
+ (network-error #f "cannot write to socket" fd) ) ) )
+ ((fx< n len)
+ (loop (fx- len n) (fx+ offset n)
+ (if (fx= n 0)
+ tmw
+ ;; If we wrote *something*, reset timeout
+ (and tmw (+ (current-process-milliseconds) tmw)) )) ) ) ) )) ) )))
+ (add-to-buf
+ (lambda (bv n)
+ (let loop ((n n) (p 0))
+ (unless (eq? n 0)
+ (let ((newindex (fx+ bufindex n)))
+ (cond ((fx> newindex outbufsize)
+ (let ((part (fx- outbufsize bufindex)))
+ (##core#inline "C_copy_memory_with_offset" outbuf bv
+ bufindex p part)
+ (output-to-socket outbuf outbufsize)
+ (set! bufindex 0)
+ (loop (fx- n part) (fx+ p part))))
+ (else
+ (##core#inline "C_copy_memory_with_offset" outbuf bv
+ bufindex p n)
+ (set! bufindex (fx+ bufindex n)))))))))
+ (outclass
+ (vector
+ #f ; read-char
+ #f ; peek-char
+ (lambda (p c) ; write-char
+ (let* ((bv (##sys#make-bytevector 4))
+ (n (##core#inline "C_utf_insert" bv 0 c)))
+ (if outbuf
+ (add-to-buf bv n)
+ (output-to-socket bv n))))
+ (lambda (p bv from to) ; write-bytevector
+ (let ((n (fx- to from)))
+ (when (fx> n 0)
+ (if outbuf
+ (add-to-buf bv n)
+ (output-to-socket bv n)))))
+ (lambda (p d) ; close
(unless oclosed
(set! oclosed #t)
- (when (and outbuf (fx> (##sys#size outbuf) 0))
- (output outbuf)
- (set! outbuf "") )
+ (when (and outbuf (fx> bufindex 0))
+ (output-to-socket outbuf bufindex)
+ (set! bufindex 0))
(unless (##sys#slot data 2) (shutdown fd _shut_wr))
(when (and iclosed (eq? _socket_error (close fd)))
(network-error #f "cannot close socket output port" fd) ) ) )
- (and outbuf
- (lambda ()
- (when (fx> (##sys#size outbuf) 0)
- (output outbuf)
- (set! outbuf "") ) ) ) ) ) )
- (##sys#setslot in 3 "(tcp)")
- (##sys#setslot out 3 "(tcp)")
+ (lambda (p) ; flush
+ (when (and outbuf (fx> bufindex 0))
+ (output-to-socket outbuf bufindex)
+ (set! bufindex 0) ) )
+ #f ; char-ready?
+ #f ; read-bytevector?
+ #f ; read-line
+ #f)) ; read-buffered
+ (out (##sys#make-port 2 outclass "(tcp)" 'socket)))
+ (##sys#setslot in 3 "(tcp)")
(##sys#setslot in 7 'socket)
- (##sys#setslot out 7 'socket)
(##sys#set-port-data! in data)
(##sys#set-port-data! out data)
+ (set! inport in)
+ (set! outport out)
+ (##sys#setslot in 15 enc)
+ (##sys#setslot out 15 enc)
(values in out) ) ) ) )
-(define (tcp-accept tcpl)
+(define (tcp-accept tcpl #!optional (enc 'utf-8))
(##sys#check-structure tcpl 'tcp-listener)
(let* ((fd (##sys#slot tcpl 1))
(tma (tcp-accept-timeout))
@@ -560,7 +602,7 @@ EOF
"accept operation timed out" tma fd) )
(let ((fd (accept fd #f #f)))
(cond ((not (eq? _invalid_socket fd))
- (io-ports 'tcp-accept fd))
+ (io-ports 'tcp-accept fd enc))
((interrupted?)
(##sys#dispatch-interrupt loop))
(else
@@ -582,9 +624,8 @@ EOF
" C_return(SOCKET_ERROR);"
"C_return(err);"))
-(define (tcp-connect host . more)
- (let* ((port (optional more #f))
- (tmc (tcp-connect-timeout))
+(define (tcp-connect host #!optional port (enc 'utf-8))
+ (let* ((tmc (tcp-connect-timeout))
(dlc (and tmc (+ (current-process-milliseconds) tmc)))
(addr (make-string _sockaddr_in_size)))
(##sys#check-string host)
@@ -619,7 +660,7 @@ EOF
((fx> err 0)
(close s)
(network-error/code 'tcp-connect err "cannot create socket"))))
- (io-ports 'tcp-connect s))) )
+ (io-ports 'tcp-connect s enc))) )
(define (tcp-port->fileno p loc)
(let ((data (##sys#port-data p)))
diff --git a/tests/UTF-8-test.txt b/tests/UTF-8-test.txt
new file mode 100644
index 00000000..a5b5d50e
Binary files /dev/null and b/tests/UTF-8-test.txt differ
diff --git a/tests/arithmetic-test.scm b/tests/arithmetic-test.scm
index bb2046a8..c3b5c373 100644
--- a/tests/arithmetic-test.scm
+++ b/tests/arithmetic-test.scm
@@ -39,7 +39,7 @@
(cond-expand
(fully-random)
- (else (set-pseudo-random-seed! "abcdefgh")))
+ (else (set-pseudo-random-seed! #u8(1 2 3 4 5 6))))
(define (push c total opname args res)
(let ((x (list (cons c total) (cons opname args) '-> res)))
diff --git a/tests/bootstrap.sh b/tests/bootstrap.sh
deleted file mode 100644
index 84019965..00000000
--- a/tests/bootstrap.sh
+++ /dev/null
@@ -1,20 +0,0 @@
-# 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/callback-tests.scm b/tests/callback-tests.scm
index b7c6eee2..86027551 100644
--- a/tests/callback-tests.scm
+++ b/tests/callback-tests.scm
@@ -1,6 +1,7 @@
;;;; callback-tests.scm
(import (only (chicken process-context) command-line-arguments))
+(import (only (scheme base) call/cc))
(define k1)
diff --git a/tests/compiler-tests.scm b/tests/compiler-tests.scm
index 7bdfda99..2e23942a 100644
--- a/tests/compiler-tests.scm
+++ b/tests/compiler-tests.scm
@@ -209,7 +209,7 @@
(print "BUG! We got, without error, length = "
((foreign-lambda* int ((c-string str))
"C_return(strlen(str));")
- "foo\x00bar")))
+ "foo\x00;bar")))
;; failed compile-time argument count check (reported by Alan Post)
@@ -403,7 +403,6 @@
" result += v[i];"
"}"
"C_return(result);") arg (srfi-4-vector-length type arg)))))
-(assert (= 10 (s4v-sum "integer" u8vector '#u8(1 2 3 4))))
(assert (= 10 (s4v-sum "integer" u16vector '#u16(1 2 3 4))))
(assert (= 10 (s4v-sum "integer" u32vector '#u32(1 2 3 4))))
(assert (= 10 (s4v-sum "integer" s64vector '#s64(1 2 3 4))))
diff --git a/tests/csc-tests.scm b/tests/csc-tests.scm
index b661e723..932e48a1 100644
--- a/tests/csc-tests.scm
+++ b/tests/csc-tests.scm
@@ -21,7 +21,7 @@
(csc "null.scm" "-t")
(assert (file-exists? "null.c"))
-(define obj-file (if (eq? (software-version) 'mingw32) "null.obj" "null.o"))
+(define obj-file (if (eq? (software-version) 'mingw) "null.obj" "null.o"))
(csc "null.c" "-c")
(assert (file-exists? obj-file))
diff --git a/tests/data-structures-tests.scm b/tests/data-structures-tests.scm
index a81b87b6..ac6921a5 100644
--- a/tests/data-structures-tests.scm
+++ b/tests/data-structures-tests.scm
@@ -38,26 +38,18 @@
;; #808: strings with embedded nul bytes should not be compared
;; with ASCIIZ string comparison functions
-(assert (substring=? "foo\x00a" "foo\x00a" 1 1))
-(assert (substring-ci=? "foo\x00a" "foo\x00a" 1 1))
-(assert (substring-ci=? "foo\x00a" "foo\x00A" 1 1))
-(assert (= 2 (substring-index "o\x00bar" "foo\x00bar")))
-(assert (= 2 (substring-index-ci "o\x00bar" "foo\x00bar")))
-(assert (= 2 (substring-index-ci "o\x00bar" "foo\x00BAR")))
-(assert (not (substring=? "foo\x00a" "foo\x00b" 1 1)))
-(assert (not (substring-ci=? "foo\x00a" "foo\x00b" 1 1)))
-(assert (substring=? "" "" 0 0 0))
-(assert (substring-ci=? "" "" 0 0 0))
-(assert (substring=? "" "abc"))
-(assert (substring-ci=? "" "abc"))
-(assert (substring=? "abc" ""))
-(assert (substring-ci=? "abc" ""))
-(assert-error (substring=? "" "" 0 0 1))
-(assert-error (substring-ci=? "" "" 0 0 1))
+(assert (substring=? "foo\x00;a" "foo\x00;a" 1 1))
+(assert (substring-ci=? "foo\x00;a" "foo\x00;a" 1 1))
+(assert (substring-ci=? "foo\x00;a" "foo\x00;A" 1 1))
+(assert (= 2 (substring-index "o\x00;bar" "foo\x00;bar")))
+(assert (= 2 (substring-index-ci "o\x00;bar" "foo\x00;bar")))
+(assert (= 2 (substring-index-ci "o\x00;bar" "foo\x00;BAR")))
+(assert (not (substring=? "foo\x00;a" "foo\x00;b" 1 1)))
+(assert (not (substring-ci=? "foo\x00;a" "foo\x00;b" 1 1)))
(assert (substring=? "foo" "foo" 0 0 3))
(assert (substring-ci=? "foo" "foo" 0 0 3))
-(assert (not (substring-index "o\x00bar" "foo\x00baz")))
-(assert (not (substring-index-ci "o\x00bar" "foo\x00baz")))
+(assert (not (substring-index "o\x00;bar" "foo\x00;baz")))
+(assert (not (substring-index-ci "o\x00;bar" "foo\x00;baz")))
(assert (= 0 (substring-index "" "")))
(assert (= 1 (substring-index "" "a" 1)))
(assert-error (substring=? "a" "a" 2))
@@ -77,15 +69,15 @@
(assert-error (substring-index "a" "b" 2))
(assert (not (substring-index "a" "b" 1)))
(assert (not (substring-index "ab" "")))
-(assert (= 0 (string-compare3 "foo\x00a" "foo\x00a")))
-(assert (> 0 (string-compare3 "foo\x00a" "foo\x00b")))
-(assert (< 0 (string-compare3 "foo\x00b" "foo\x00a")))
-(assert (= 0 (string-compare3-ci "foo\x00a" "foo\x00a")))
-(assert (= 0 (string-compare3-ci "foo\x00a" "foo\x00A")))
-(assert (> 0 (string-compare3-ci "foo\x00a" "foo\x00b")))
-(assert (> 0 (string-compare3-ci "foo\x00A" "foo\x00b")))
-(assert (< 0 (string-compare3-ci "foo\x00b" "foo\x00a")))
-(assert (< 0 (string-compare3-ci "foo\x00b" "foo\x00A")))
+(assert (= 0 (string-compare3 "foo\x00;a" "foo\x00;a")))
+(assert (> 0 (string-compare3 "foo\x00;a" "foo\x00;b")))
+(assert (< 0 (string-compare3 "foo\x00;b" "foo\x00;a")))
+(assert (= 0 (string-compare3-ci "foo\x00;a" "foo\x00;a")))
+(assert (= 0 (string-compare3-ci "foo\x00;a" "foo\x00;A")))
+(assert (> 0 (string-compare3-ci "foo\x00;a" "foo\x00;b")))
+(assert (> 0 (string-compare3-ci "foo\x00;A" "foo\x00;b")))
+(assert (< 0 (string-compare3-ci "foo\x00;b" "foo\x00;a")))
+(assert (< 0 (string-compare3-ci "foo\x00;b" "foo\x00;A")))
(assert (string=? "bde" (string-translate* "abcd"
'(("a" . "b")
@@ -104,8 +96,8 @@
(assert (equal? '(a b c d) (topological-sort '((a b) (b c) (c d)) eq?)))
(assert (equal? '(a b c d) (topological-sort '((a b) (c d)) eq?)))
(assert-error (topological-sort '((a b) (b a)) eq?))
-(assert
- (equal?
+(assert
+ (equal?
(topological-sort
'((i am)
(not trying)
diff --git a/tests/environment-tests.scm b/tests/environment-tests.scm
index c9d22d46..e41f6e3e 100644
--- a/tests/environment-tests.scm
+++ b/tests/environment-tests.scm
@@ -39,7 +39,7 @@
(define baz 100)
(module foo (bar)
- (import r5rs)
+ (import (scheme r5rs))
(define (bar) 99))
(define foo-env (module-environment 'foo))
diff --git a/tests/ffi-tests.scm b/tests/ffi-tests.scm
new file mode 100644
index 00000000..f1de4bd7
--- /dev/null
+++ b/tests/ffi-tests.scm
@@ -0,0 +1,54 @@
+;;; FFI tests
+
+(import (only (scheme base) open-output-string get-output-string))
+(import (chicken memory representation))
+
+(include "test.scm")
+
+(import (chicken foreign))
+
+(foreign-declare "typedef struct foo {int x;} FOO;
+int bar(struct foo x) {return x.x;}
+struct foo baz(int x) {struct foo y;y.x=x;return y;}
+int bar_t(FOO x) {return x.x;}
+FOO baz_t(int x) {struct foo y;y.x=x;return y;}")
+
+(test-begin "struct arg/return")
+
+(define bar (foreign-lambda int "bar" (struct "foo")))
+(define bar_t (foreign-lambda int "bar" (struct ("FOO"))))
+
+(define safe-bar (foreign-safe-lambda int "bar" (struct "foo")))
+(define safe-bar_t (foreign-safe-lambda int "bar_t" (struct ("FOO"))))
+
+(define baz (foreign-lambda (struct "foo") "baz" int))
+(define baz_t (foreign-lambda (struct ("FOO")) "baz" int))
+
+(define safe-baz (foreign-safe-lambda (struct "foo") "baz" int))
+(define safe-baz_t (foreign-safe-lambda (struct ("FOO")) "baz" int))
+
+(define x (baz 123))
+(define x_t (baz_t 123))
+(define safe-x (safe-baz 123))
+(define safe-x_t (safe-baz_t 123))
+
+(test-assert "struct return" (record-instance? x '|struct foo|))
+(test-assert "struct return (typedef)" (record-instance? x_t '|FOO|))
+(test-assert "struct return (safe)" (record-instance? safe-x '|struct foo|))
+(test-assert "struct return (safe, typedef)" (record-instance? safe-x_t '|FOO|))
+
+(define out (open-output-string))
+(display x out)
+(test-equal "string representation" "#<struct foo>" (get-output-string out))
+(define out (open-output-string))
+(display x_t out)
+(test-equal "string representation" "#<FOO>" (get-output-string out))
+(test-equal "struct argument" 123 (bar x))
+(test-equal "struct argument (typedef)" 123 (bar_t x_t))
+(test-equal "struct arg (safe)" 123 (safe-bar x))
+(test-equal "struct arg (safe, typedef)" 123 (safe-bar_t x_t))
+(test-equal "foreign value" 99 (bar (foreign-value "(struct foo){99}" (struct foo))))
+(test-equal "location" 100 (let-location ((f1 (struct foo) (baz 100)))
+ (bar f1)))
+(test-end)
+(test-exit)
diff --git a/tests/fft.scm b/tests/fft.scm
index b98d65cb..333ace08 100644
--- a/tests/fft.scm
+++ b/tests/fft.scm
@@ -59,7 +59,7 @@
(defalias list->f64vector list->vector)
(defalias f64vector-length vector-length)) )
(chicken
- (import srfi-4))
+ (import (chicken number-vector)))
(else) )
;;; end of *ignored* definitions
diff --git a/tests/file-encoding-test.scm b/tests/file-encoding-test.scm
new file mode 100644
index 00000000..0d652f07
--- /dev/null
+++ b/tests/file-encoding-test.scm
@@ -0,0 +1,48 @@
+(import (chicken io))
+(import (only (scheme base) write-string))
+
+(include "test.scm")
+
+(define utf-file "i-dont-know-i-just-work-here.utf-8.txt")
+(define latin-file "i-dont-know-i-just-work-here.latin-1.txt")
+
+(test-begin "file encoding")
+
+(define utf (with-input-from-file utf-file read-string #:unix))
+(define latin (with-input-from-file latin-file read-string #:unix 'latin-1))
+
+(test-equal "latin-1 decoded matches utf" latin utf)
+
+(with-output-to-file "latin.out"
+ (lambda () (write-string utf))
+ #:unix 'latin-1)
+
+(with-output-to-file "utf.out"
+ (lambda () (write-string latin))
+ #:unix)
+
+(let ((a (with-input-from-file "latin.out" read-bytevector #:binary))
+ (b (with-input-from-file latin-file read-bytevector #:binary)))
+ (test-equal "latin-1 encoded matches original" a b))
+
+(let ((a (with-input-from-file "utf.out" read-bytevector #:binary))
+ (b (with-input-from-file utf-file read-bytevector #:binary)))
+ (test-equal "utf-8 encoded matches original" a b))
+
+(with-output-to-file "chars.out"
+ (lambda ()
+ (display "äöü")
+ (write-char #\ß)
+ (display #\á))
+ #:unix 'latin-1)
+
+(define in (open-input-file "chars.out" #:unix 'latin-1))
+
+(test-equal "read latin-1 char" (read-char in) #\ä)
+(test-equal "peek latin-1 char" (peek-char in) #\ö)
+
+(test-equal "read remaining latin-1 chars"
+ (read-string #f in) "öüßá")
+
+(test-end)
+(test-exit)
diff --git a/tests/i-dont-know-i-just-work-here.latin-1.txt b/tests/i-dont-know-i-just-work-here.latin-1.txt
new file mode 100644
index 00000000..19601aa4
--- /dev/null
+++ b/tests/i-dont-know-i-just-work-here.latin-1.txt
@@ -0,0 +1,143 @@
+Dwn i ddim. Dim ond gweithio fan hyn dw i.
+
+-Welsh (cy) from David Wood.
+
+Keine Ahnung. Ich arbeite hier nur.
+
+-German (de) from Anya A'Hearn, Adam Twardoch, and Otto Stolz.
+
+Waaß I net. I oarbeit do nur.
+
+-Viennese (de-at-vienna) from Jens Kager.
+
+I weiss es nid. I schaffe nume hie.
+
+-Bernese Swiss German (de-ch-be) from Beat Bolli.
+
+Wat weiß ich. Ich tu hier nur malochen.
+
+-Ruhrdeutsch (de-de-ruhr) from Arne "Timwi" Heizmann.
+
+Det ved jeg ikke. Jeg arbejder her bare.
+
+-Danish (dk) from Katrine Krogh Andersen.
+
+I don't know. I only work here.
+
+-English (en) from Chris Maden.
+
+Yo no sé. Yo nada mas que trabajo aquí.
+
+-Spanish (es) from Bill Peña.
+
+No sé, yo sólo trabajo acá.
+
+-Colombian Spanish (es-co) from Lina María Mercado.
+
+En tiedä. Olen täällä vain töissä.
+
+-Finnish (fi) from Jouni Paakkinen.
+
+Je ne sais pas. Je ne fais que travailler ici.
+
+-French (fr) from Chris Maden with help from Ludmilla Mach.
+
+Níl a fhios agam. Nílimse ach ag obair anseo.
+
+-Irish (ga) from David Wood.
+
+Non o sei. Eu so traballo aqui.
+
+-Gallegan (gl) from Marcos Martinez.
+
+Nem tudom. Én csak itt dolgozom.
+
+-Hungarian (hu) from Dr. László Borhy.
+
+Saya tidak tahu. Saya cuma bekerja disini.
+
+-Indonesian (id) from Noor Hilmi.
+
+Diakammo. Agtrabtrabaho ak la ditoy.
+
+-Ilocano (ilo) from Johnny Agsalog.
+
+Ég veit það ekki, ég bara vinn hérna.
+
+-Icelandic (is) from Kristján Valur Jónsson.
+
+Non lo so. Io qui lavoro soltanto.
+
+-Italian (it) from Tommaso Russo.
+
+Kula mboten ngertos. Kula namung nyambut damel wonten mriki.
+
+-Korean (ko) from Jungshik Shin.
+
+Saya tak tahu. Saya cuma kerja sini.
+
+-Malay (ms) from Ong Guan Sin.
+
+Jeg vet ikke. Jeg bare jobber her.
+
+-Norwegian (Bokmål) (nb) from Dag Øien.
+
+Wöß'sch nüsch. 'Sch tu' hier bloß arbeidn.
+
+-Saxon (nds) from André Müller.
+
+Geen idee. Ik werk hier alleen maar.
+
+-Dutch (nl) from William Bijsterbosch.
+
+Eg veit ikkje. Eg berre arbeider her.
+
+-Norwegian (Nynorsk) (nn) from Dag Øien.
+
+Eu não sei. Eu só trabalho aqui.
+
+-Brazilian Portuguese (pt-br) from Richard Strohm.
+
+Det vet jag inte. Jag arbetar bara här.
+
+-Swedish (se) from Karen Kohfeld and Christian Liljeberg.
+
+Nuk e di. Unë jam punëtor këtu.
+
+-Albanian (sq) from Artan Simeqi.
+
+Abdi teu ngartos. Abdi mung didamel di dieu.
+
+-Sudanese (su) from Noor Hilmi.
+
+Ewan ko. Empleyado lang ako dito.
+
+-Modern Filipino (tl) from Marian Nebriaga.
+
+Di ko alam. Trabahador lang ako dito.
+
+-Tagalog (tl) from Johnny Agsalog.
+
+jIH ta'Sov'be. jIH neH vum naDev.
+
+-Klingon (x-klingon) from Ben Trafford and Justin Kerk.
+
+No sé pas. Yo aquí nomás i treballo.
+
+-Aragonese (x-sil-axx) from Lizer Tena.
+
+Sô nò. Ghe laôri dômà chì ch'inscì.
+
+-Lombard (x-sil-lom) from Marco Cimarosti.
+
+Nunn'òssaccio. Ije accà ce fatico e bbasta.
+
+-Neapolitan (x-sil-npl) from Riccardo Distasi.
+
+Nenti sacciu. Cà ci travagghiu sulamenti.
+
+-Sicilian (x-sil-scn) from Marco Cimarosti.
+
+Des woiß doch i net. I schaff dähanna bloß.
+
+-Swabian (x-sil-swg) from Otto Stolz.
diff --git a/tests/i-dont-know-i-just-work-here.utf-8.txt b/tests/i-dont-know-i-just-work-here.utf-8.txt
new file mode 100644
index 00000000..b3e9ab6c
--- /dev/null
+++ b/tests/i-dont-know-i-just-work-here.utf-8.txt
@@ -0,0 +1,143 @@
+Dwn i ddim. Dim ond gweithio fan hyn dw i.
+
+-Welsh (cy) from David Wood.
+
+Keine Ahnung. Ich arbeite hier nur.
+
+-German (de) from Anya A'Hearn, Adam Twardoch, and Otto Stolz.
+
+Waaß I net. I oarbeit do nur.
+
+-Viennese (de-at-vienna) from Jens Kager.
+
+I weiss es nid. I schaffe nume hie.
+
+-Bernese Swiss German (de-ch-be) from Beat Bolli.
+
+Wat weiß ich. Ich tu hier nur malochen.
+
+-Ruhrdeutsch (de-de-ruhr) from Arne "Timwi" Heizmann.
+
+Det ved jeg ikke. Jeg arbejder her bare.
+
+-Danish (dk) from Katrine Krogh Andersen.
+
+I don't know. I only work here.
+
+-English (en) from Chris Maden.
+
+Yo no sé. Yo nada mas que trabajo aquÃ.
+
+-Spanish (es) from Bill Peña.
+
+No sé, yo sólo trabajo acá.
+
+-Colombian Spanish (es-co) from Lina MarÃa Mercado.
+
+En tiedä. Olen täällä vain töissä.
+
+-Finnish (fi) from Jouni Paakkinen.
+
+Je ne sais pas. Je ne fais que travailler ici.
+
+-French (fr) from Chris Maden with help from Ludmilla Mach.
+
+NÃl a fhios agam. NÃlimse ach ag obair anseo.
+
+-Irish (ga) from David Wood.
+
+Non o sei. Eu so traballo aqui.
+
+-Gallegan (gl) from Marcos Martinez.
+
+Nem tudom. Én csak itt dolgozom.
+
+-Hungarian (hu) from Dr. László Borhy.
+
+Saya tidak tahu. Saya cuma bekerja disini.
+
+-Indonesian (id) from Noor Hilmi.
+
+Diakammo. Agtrabtrabaho ak la ditoy.
+
+-Ilocano (ilo) from Johnny Agsalog.
+
+Ég veit það ekki, ég bara vinn hérna.
+
+-Icelandic (is) from Kristján Valur Jónsson.
+
+Non lo so. Io qui lavoro soltanto.
+
+-Italian (it) from Tommaso Russo.
+
+Kula mboten ngertos. Kula namung nyambut damel wonten mriki.
+
+-Korean (ko) from Jungshik Shin.
+
+Saya tak tahu. Saya cuma kerja sini.
+
+-Malay (ms) from Ong Guan Sin.
+
+Jeg vet ikke. Jeg bare jobber her.
+
+-Norwegian (Bokmål) (nb) from Dag Øien.
+
+Wöß'sch nüsch. 'Sch tu' hier bloß arbeidn.
+
+-Saxon (nds) from André Müller.
+
+Geen idee. Ik werk hier alleen maar.
+
+-Dutch (nl) from William Bijsterbosch.
+
+Eg veit ikkje. Eg berre arbeider her.
+
+-Norwegian (Nynorsk) (nn) from Dag Øien.
+
+Eu não sei. Eu só trabalho aqui.
+
+-Brazilian Portuguese (pt-br) from Richard Strohm.
+
+Det vet jag inte. Jag arbetar bara här.
+
+-Swedish (se) from Karen Kohfeld and Christian Liljeberg.
+
+Nuk e di. Unë jam punëtor këtu.
+
+-Albanian (sq) from Artan Simeqi.
+
+Abdi teu ngartos. Abdi mung didamel di dieu.
+
+-Sudanese (su) from Noor Hilmi.
+
+Ewan ko. Empleyado lang ako dito.
+
+-Modern Filipino (tl) from Marian Nebriaga.
+
+Di ko alam. Trabahador lang ako dito.
+
+-Tagalog (tl) from Johnny Agsalog.
+
+jIH ta'Sov'be. jIH neH vum naDev.
+
+-Klingon (x-klingon) from Ben Trafford and Justin Kerk.
+
+No sé pas. Yo aquà nomás i treballo.
+
+-Aragonese (x-sil-axx) from Lizer Tena.
+
+Sô nò. Ghe laôri dômà chì ch'inscì.
+
+-Lombard (x-sil-lom) from Marco Cimarosti.
+
+Nunn'òssaccio. Ije accà ce fatico e bbasta.
+
+-Neapolitan (x-sil-npl) from Riccardo Distasi.
+
+Nenti sacciu. CÃ ci travagghiu sulamenti.
+
+-Sicilian (x-sil-scn) from Marco Cimarosti.
+
+Des woiß doch i net. I schaff dähanna bloß.
+
+-Swabian (x-sil-swg) from Otto Stolz.
diff --git a/tests/include-ci.scm b/tests/include-ci.scm
new file mode 100644
index 00000000..9fa9c33c
--- /dev/null
+++ b/tests/include-ci.scm
@@ -0,0 +1 @@
+(DISPLAY "abc")
diff --git a/tests/include.scm b/tests/include.scm
new file mode 100644
index 00000000..217e1740
--- /dev/null
+++ b/tests/include.scm
@@ -0,0 +1 @@
+(display "abc")
diff --git a/tests/invalid-utf-test.scm b/tests/invalid-utf-test.scm
new file mode 100644
index 00000000..d6001067
--- /dev/null
+++ b/tests/invalid-utf-test.scm
@@ -0,0 +1,29 @@
+;;; ensure invalid UTF-8 sequences are reproducibly read and written
+
+(import (chicken io) (chicken irregex) (chicken file))
+(import (chicken bytevector) (chicken file posix))
+
+(define in "UTF-8-test.txt")
+(define out "UTF-8-test.out")
+
+(when (file-exists? out) (delete-file out))
+
+(with-input-from-file in
+ (lambda ()
+ (call-with-output-file out
+ (lambda (o)
+ (let loop ()
+ (let ((line (read-line)))
+ (unless (eof-object? line)
+ (display line o)
+ (newline o)
+ (loop)))))
+ #:unix))
+ #:unix)
+
+(define sz (file-size in))
+
+;(assert (= sz (file-size out)))
+(let ((old (with-input-from-file in (cut read-bytevector sz) #:binary))
+ (new (with-input-from-file out (cut read-bytevector sz) #:binary)))
+ (assert (bytevector=? old new)))
diff --git a/tests/library-tests.scm b/tests/library-tests.scm
index 93e048f7..38ab88dd 100644
--- a/tests/library-tests.scm
+++ b/tests/library-tests.scm
@@ -1,7 +1,8 @@
;;;; library-tests.scm
-(import chicken.blob chicken.bitwise chicken.fixnum chicken.flonum
+(import chicken.bytevector chicken.bitwise chicken.fixnum chicken.flonum
chicken.keyword chicken.port chicken.condition)
+(import (only (scheme base) make-parameter call/cc get-output-string))
(define-syntax assert-fail
(syntax-rules ()
@@ -389,18 +390,13 @@
(assert (string=? "aBc" (symbol->string (with-input-from-string "|aBc|" read))))
(assert (string=? "aBc" (symbol->string (with-input-from-string "a\\Bc" read)))))
-(parameterize ((symbol-escape #f))
- (assert (string=? "aBc" (symbol->string (with-input-from-string "aBc" read))))
- (assert-fail (with-input-from-string "|aBc|" read))
- (assert-fail (with-input-from-string "a|Bc" read)))
-(parameterize ((symbol-escape #t))
(assert (string=? "aBc" (symbol->string (with-input-from-string "aBc" read))))
(assert (string=? "aBc" (symbol->string (with-input-from-string "|aBc|" read))))
(assert (string=? "aB c" (symbol->string (with-input-from-string "|aB c|" read))))
;; The following is an extension/generalisation of r7RS
(assert (string=? "aBc" (symbol->string (with-input-from-string "a|Bc|" read))))
;; "Unterminated string" (unterminated identifier?)
- (assert-fail (with-input-from-string "a|Bc" read)))
+ (assert-fail (with-input-from-string "a|Bc" read))
;;; Old style qualified low byte, see #1077
@@ -408,9 +404,9 @@
(assert (string=? "##foo#bar" (symbol->string '##foo#bar)))
(assert (eq? '##foo#bar '|##foo#bar|))
-(assert (string=? "|\\x0a|" (with-output-to-string (lambda () (write '|\n|)))))
+(assert (string=? "|\\xa;|" (with-output-to-string (lambda () (write '|\n|)))))
;; #1576
-(assert (string=? "|\\x00foo|" (with-output-to-string (lambda () (write '|\000foo|)))))
+(assert (string=? "|\\x0;foo|" (with-output-to-string (lambda () (write '|\000foo|)))))
(assert (not (keyword? '|\000foo|)))
(assert (string=? "|###foo#bar|" (with-output-to-string (lambda () (write '|###foo#bar|)))))
@@ -597,9 +593,9 @@
(assert (string=? "" (keyword->string empty-kw))))
;; TODO: It should eventually be possible to distinguish these (#1077)
-#;(let ((nul-sym (with-input-from-string "|\\x00|" read)))
+#;(let ((nul-sym (with-input-from-string "|\\x00;|" read)))
(assert (not (keyword? nul-sym)))
- (assert (string=? "\x00" (symbol->string nul-sym))))
+ (assert (string=? "\x00;" (symbol->string nul-sym))))
(assert (keyword? (with-input-from-string "42:" read)))
(assert (keyword? (with-input-from-string ".:" read)))
@@ -663,37 +659,23 @@ A
(assert (= 1000 (p)))
-;;; blob-literal syntax
-
-(assert (equal? '#${a} '#${0a}))
-(assert (equal? '#${ab cd} '#${abcd}))
-(assert (equal? '#${ab c} '#${ab0c}))
-(assert (equal? '#${abc} '#${ab0c}))
-(assert (equal? '#${a b c} '#${0a0b0c}))
-
-;; self-evaluating
-(assert (equal? '#${a} #${a}))
-(assert (equal? '#${abcd} #${abcd}))
-(assert (equal? '#${abc} #${abc}))
-
-
-;; #808: blobs and strings with embedded nul bytes should not be compared
+;; #808: bytevectors and strings with embedded nul bytes should not be compared
;; with ASCIIZ string comparison functions
-(assert (equal? '#${a b 0 c} '#${a b 0 c}))
-(assert (blob=? '#${a b 0 c} '#${a b 0 c}))
-(assert (equal=? "foo\x00a" "foo\x00a"))
-(assert (string=? "foo\x00a" "foo\x00a"))
-(assert (string-ci=? "foo\x00a" "foo\x00a"))
-(assert (string-ci=? "foo\x00a" "foo\x00A"))
-(assert (not (equal? '#${a b 0 c} '#${a b 0 d})))
-(assert (not (blob=? '#${a b 0 c} '#${a b 0 d})))
-(assert (not (equal=? "foo\x00a" "foo\x00b")))
-(assert (not (string=? "foo\x00a" "foo\x00b")))
-(assert (not (string-ci=? "foo\x00a" "foo\x00b")))
-(assert (string<? "foo\x00a" "foo\x00b"))
-(assert (string>? "foo\x00b" "foo\x00a"))
-(assert (string-ci<? "foo\x00a" "foo\x00B"))
-(assert (string-ci>? "foo\x00b" "foo\x00A"))
+(assert (equal? '#u8(#xa #xb 0 #xc) '#u8(#xa #xb 0 #xc)))
+(assert (bytevector=? '#u8(#xa #xb 0 #xc) '#u8(#xa #xb 0 #xc)))
+(assert (equal=? "foo\x00;a" "foo\x00;a"))
+(assert (string=? "foo\x00;a" "foo\x00;a"))
+(assert (string-ci=? "foo\x00;a" "foo\x00;a"))
+(assert (string-ci=? "foo\x00;a" "foo\x00;A"))
+(assert (not (equal? '#u8(#xa #xb 0 #xc) '#u8(#xa #xb 0 #xd))))
+(assert (not (bytevector=? '#u8(#xa #xb 0 #xc) '#u8(#xa #xb 0 #xd))))
+(assert (not (equal=? "foo\x00;a" "foo\x00;b")))
+(assert (not (string=? "foo\x00;a" "foo\x00;b")))
+(assert (not (string-ci=? "foo\x00;a" "foo\x00;b")))
+(assert (string<? "foo\x00;a" "foo\x00;b"))
+(assert (string>? "foo\x00;b" "foo\x00;a"))
+(assert (string-ci<? "foo\x00;a" "foo\x00;B"))
+(assert (string-ci>? "foo\x00;b" "foo\x00;A"))
;; reported by Nils Holm (#1534)
;; https://groups.google.com/group/comp.lang.scheme/t/6b8be06b84b39a7
@@ -844,9 +826,9 @@ A
(c 'e)
(assert (equal? '(a b c d c e d e e d) (reverse path))))))
-;;; vector and blob limits
+;;; vector and bytevector limits
-(assert-fail (make-blob -1))
+(assert-fail (make-bytevector -1))
(assert-fail (make-vector -1))
;;; Resizing of vectors works to both sides
@@ -870,7 +852,7 @@ A
;;; message checks for invalid strings
-(assert-fail (##sys#message "123\x00456"))
+(assert-fail (##sys#message "123\x00;456"))
;;; vector procedures
diff --git a/tests/life.scm b/tests/life.scm
new file mode 100644
index 00000000..cdd92456
--- /dev/null
+++ b/tests/life.scm
@@ -0,0 +1,86 @@
+;;; The following example shows how a program can be divided into libraries plus a
+;;; relatively small main program.
+
+(define-library (example grid)
+ (export make rows cols ref each
+ (rename put! set!))
+ (import (scheme base))
+ (begin
+ ;; Create an NxM grid.
+ (define (make n m)
+ (let ((grid (make-vector n)))
+ (do ((i 0 (+ i 1)))
+ ((= i n) grid)
+ (let ((v (make-vector m #false)))
+ (vector-set! grid i v)))))
+ (define (rows grid)
+ (vector-length grid))
+ (define (cols grid)
+ (vector-length (vector-ref grid 0)))
+ (define (ref grid n m)
+ (vector-ref (vector-ref grid (modulo n (rows grid))) (modulo m (cols grid))))
+ (define (put! grid n m v)
+ (vector-set! (vector-ref grid n) m v))
+ (define (each grid proc)
+ (do ((j 0 (+ j 1)))
+ ((= j (rows grid)))
+ (do ((k 0 (+ k 1)))
+ ((= k (cols grid)))
+ (proc j k (ref grid j k)))))))
+
+(define-library (example life)
+ (export life)
+ (import (except (scheme base) set!)
+ (scheme write)
+ (example grid))
+ (begin
+ (define (life-count grid i j)
+ (define (count i j)
+ (if (ref grid i j) 1 0))
+ (+ (count (- i 1) (- j 1))
+ (count (- i 1) j)
+ (count (- i 1) (+ j 1))
+ (count i (- j 1))
+ (count i (+ j 1))
+ (count (+ i 1) (- j 1))
+ (count (+ i 1) j)
+ (count (+ i 1) (+ j 1))))
+ (define (life-alive? grid i j)
+ (case (life-count grid i j)
+ ((3) #true)
+ ((2) (ref grid i j))
+ (else #false)))
+ (define (life-print grid)
+ (newline) ;(display "\x1B;[1H\x1B;[J") ; clear vt100
+ (each grid
+ (lambda (i j v)
+ (display (if v "*" " "))
+ (when (= j (- (cols grid) 1))
+ (newline)))))
+ (define (life grid iterations)
+ (do ((i 0 (+ i 1))
+ (grid0 grid grid1)
+ (grid1 (make (rows grid) (cols grid))
+ grid0))
+ ((= i iterations))
+ (each grid0
+ (lambda (j k v)
+ (let ((a (life-alive? grid0 j k)))
+ (set! grid1 j k a))))
+ (life-print grid1)))))
+
+;; Main program.
+(import (only (example life) life)
+ (rename (prefix (example grid) grid-)
+ (grid-make make-grid)))
+
+;; Initialize a grid with a glider.
+(define grid (make-grid 8 8))
+(grid-set! grid 1 1 #true)
+(grid-set! grid 2 2 #true)
+(grid-set! grid 3 0 #true)
+(grid-set! grid 3 1 #true)
+(grid-set! grid 3 2 #true)
+
+;; Run for 40 iterations.
+(life grid 40)
diff --git a/tests/lolevel-tests.scm b/tests/lolevel-tests.scm
index 88e3a626..58d400bb 100644
--- a/tests/lolevel-tests.scm
+++ b/tests/lolevel-tests.scm
@@ -1,7 +1,7 @@
;;;; Unit lolevel testing
(import chicken.format chicken.locative chicken.platform
- chicken.memory chicken.memory.representation srfi-4)
+ chicken.memory chicken.memory.representation chicken.number-vector)
(define-syntax assert-error
(syntax-rules ()
@@ -178,7 +178,7 @@
(,ref new ,(- size i 1))))
res)))))))))
-(check-type-locative string #\nul #\y #\o #\xff)
+(check-type-locative string #\a #\b #\c #\d)
(check-type-locative vector 'yo 1 2 #f #t '(1 2 3) #(1 2 3))
(check-type-locative u8vector 0 1 2 #xfe #xff)
(check-type-locative s8vector #x-80 #x-7f -2 -1 0 1 2 #x7e #x7f)
@@ -207,7 +207,6 @@
(assert (= 0 (locative-index (make-locative '(0 . 1)))))
(assert (= 0 (locative-index (make-locative #(a b c d e)))))
(assert (= 0 (locative-index (make-locative "abcde"))))
-(assert (= 0 (locative-index (make-locative #${012345}))))
(assert (= 0 (locative-index (make-locative #u8(0 1 2 3 4)))))
(assert (= 0 (locative-index (make-locative #s8(0 1 2 3 4)))))
(assert (= 0 (locative-index (make-locative #u16(0 1 2 3 4)))))
@@ -223,7 +222,6 @@
(assert (= 1 (locative-index (make-locative '(0 . 1) 1))))
(assert (= 2 (locative-index (make-locative #(a b c d e) 2))))
(assert (= 3 (locative-index (make-locative "abcde" 3))))
-(assert (= 2 (locative-index (make-locative #${01234} 2))))
(assert (= 1 (locative-index (make-locative #u8(0 1 2 3 4) 1))))
(assert (= 2 (locative-index (make-locative #s8(0 1 2 3 4) 2))))
(assert (= 3 (locative-index (make-locative #u16(0 1 2 3 4) 3))))
diff --git a/tests/module-tests.scm b/tests/module-tests.scm
index 2105b081..72aa4655 100644
--- a/tests/module-tests.scm
+++ b/tests/module-tests.scm
@@ -13,13 +13,13 @@
(test-assert
"r4rs"
(module test-r4rs ()
- (import r4rs)
+ (import (scheme r4rs))
(equal? 1 1)))
(test-assert
"r4rs-null"
(module test-r4rs-null ()
- (import r4rs-null)
+ (import (scheme r4rs-null))
(begin #t)))
(test-equal "internal/variable"
diff --git a/tests/multiple-values.scm b/tests/multiple-values.scm
index 219bdcac..3e89024f 100644
--- a/tests/multiple-values.scm
+++ b/tests/multiple-values.scm
@@ -1,3 +1,5 @@
+(import (only (scheme base) call/cc))
+
(define-syntax assert-fail
(syntax-rules ()
((_ exp)
diff --git a/tests/numbers-string-conversion-tests.scm b/tests/numbers-string-conversion-tests.scm
index ad673a46..577ceb56 100644
--- a/tests/numbers-string-conversion-tests.scm
+++ b/tests/numbers-string-conversion-tests.scm
@@ -111,7 +111,7 @@
("#i1" 1.0 "1.0" "1.")
("#I1" 1.0 "1.0" "1.")
("#i-1" (- 1.0) "-1.0" "-1.")
- ("123\x00456" #f)
+ ("123\x00;456" #f)
("-#i1" #f)
("+-1" #f)
("" #f)
diff --git a/tests/numbers-test-gauche.scm b/tests/numbers-test-gauche.scm
index 6bd45a54..ae7ecaf7 100644
--- a/tests/numbers-test-gauche.scm
+++ b/tests/numbers-test-gauche.scm
@@ -49,6 +49,7 @@
;; Gauche compat
(import (chicken bitwise) (chicken port) (chicken format) (chicken string) (chicken fixnum))
+(import (only (scheme base) exact-integer-sqrt))
(define (greatest-fixnum) most-positive-fixnum)
(define (least-fixnum) most-negative-fixnum)
diff --git a/tests/numbers-test.scm b/tests/numbers-test.scm
index 3141d5d2..dc564534 100644
--- a/tests/numbers-test.scm
+++ b/tests/numbers-test.scm
@@ -9,6 +9,8 @@
(chicken platform)
(chicken time))
+(import (only (scheme base) exact-integer-sqrt))
+
;; The default "comparator" doesn't know how to deal with extended number types
(current-test-comparator
(lambda (exp act)
diff --git a/tests/port-tests.scm b/tests/port-tests.scm
index 4e688b54..ccf74a68 100644
--- a/tests/port-tests.scm
+++ b/tests/port-tests.scm
@@ -1,13 +1,17 @@
(import chicken.condition chicken.file chicken.file.posix
chicken.flonum chicken.format chicken.io chicken.port
- chicken.process chicken.process.signal chicken.tcp srfi-4)
+ chicken.bytevector
+ chicken.process chicken.process.signal chicken.tcp chicken.number-vector)
+
+(import (only (scheme base) input-port-open? output-port-open? open-input-string
+ write-string open-output-string get-output-string))
(include "test.scm")
(test-begin "ports")
(define-syntax assert-error
(syntax-rules ()
- ((_ expr)
+ ((_ expr)
(assert (handle-exceptions _ #t expr #f)))))
(define *text* #<<EOF
@@ -30,7 +34,7 @@ this is a test
<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>
+ERC>
EOF
)
@@ -39,7 +43,7 @@ EOF
(assert (string=? "this is a test" (read-line p)))
(assert
- (string=?
+ (string=?
"<foof> #;33> (let ((in (open-input-string \"\"))) (close-input-port in)"
(read-line p)))
(assert (= 20 (length (read-lines (open-input-string *text*)))))
@@ -61,14 +65,14 @@ EOF
;;; copy-port
(assert
- (string=?
+ (string=?
*text*
(with-output-to-string
(lambda ()
(copy-port (open-input-string *text*) (current-output-port)))))) ; read-char -> write-char
-(assert
- (equal?
+(assert
+ (equal?
'(3 2 1)
(let ((out '()))
(copy-port ; read -> custom
@@ -79,18 +83,18 @@ EOF
out)))
(assert
- (equal?
+ (equal?
"abc"
(let ((out (open-output-string)))
(copy-port ; read-char -> custom
- (open-input-string "abc")
+ (open-input-string "abc")
out
read-char
(lambda (x out) (write-char x out)))
(get-output-string out))))
(assert
- (equal?
+ (equal?
"abc"
(let ((in (open-input-string "abc") )
(out (open-output-string)))
@@ -177,7 +181,7 @@ EOF
(lambda ()
(with-output-to-file "compiler.scm.2"
(lambda ()
- (copy-port
+ (copy-port
(current-input-port) (current-output-port)
(lambda (port) (read-char port))
(lambda (x port) (write-char x port))))))))
@@ -208,7 +212,7 @@ EOF
((exn i/o file) (printf "OK\n") okay))))))))
(cond-expand
- ((not mingw32)
+ ((not mingw)
(define proc (process-fork (lambda () (tcp-accept (tcp-listen 8080)))))
@@ -226,7 +230,7 @@ EOF
(check (tcp-port-numbers in))
(check (tcp-abandon-port in))) ; Not sure about abandon-port
-
+
;; This tests for two bugs which occurred on NetBSD and possibly
;; other platforms, possibly due to multiprocessing:
;; read-line with EINTR would loop endlessly and process-wait would
@@ -270,18 +274,13 @@ EOF
(check (newline out))
(check (write-char #\x out))
(check (write-line "foo" out))
- (check (write-u8vector '#u8(1 2 3) out))
+ (check (write-bytevector '#u8(1 2 3) out))
;;(check (port->fileno in))
(check (flush-output out))
- #+(not mingw32)
- (begin
- (check (file-test-lock out))
- (check (file-lock out))
- (check (file-lock/blocking out)))
-
(check (write-byte 120 out))
- (check (write-string "foo" #f out))))
+ (check (write-string "foo" out))))
+
(print "\n\nProcedures check on input ports being closed\n")
(call-with-input-file "empty-file"
@@ -294,14 +293,9 @@ EOF
;;(check (port->fileno in))
(check (terminal-port? in)) ; Calls isatty() on C_SCHEME_FALSE?
(check (read-line in 5))
- (check (read-u8vector 5 in))
- (check "read-u8vector!" (let ((dest (make-u8vector 5)))
- (read-u8vector! 5 dest in)))
- #+(not mingw32)
- (begin
- (check (file-test-lock in))
- (check (file-lock in))
- (check (file-lock/blocking in)))
+ (check (read-bytevector 5 in))
+ (check "read-bytevector!" (let ((dest (make-u8vector 5)))
+ (read-bytevector! dest in 0 5)))
(check (read-byte in))
(check (read-token (constantly #t) in))
@@ -310,7 +304,7 @@ EOF
(read-string! 10 buf in) buf))))
(print "\nEmbedded NUL bytes in filenames are rejected\n")
-(assert-error (with-output-to-file "embedded\x00null-byte" void))
+(assert-error (with-output-to-file "embedded\x00;null-byte" void))
;;; #978 -- port-position checks for read-line
@@ -332,7 +326,7 @@ EOF
(read-process-line/pos "echo" (list "-n" str) limit))
(define (test-port-position proc)
- (test-equal "advance row when encountering delim"
+ (test-equal "advance row when encountering delim"
(proc "abcde\nfghi" 6)
'("abcde" 2 0))
(test-equal "reaching limit sets col to limit, and does not advance row"
@@ -434,6 +428,66 @@ EOF
"read-line process port position tests"
(test-port-position read-echo-line/pos))
+;; bytevector I/O, moved here from srf-4-tests.scm:
+;; Ticket #1124: read-u8vector! w/o length, dest smaller than source.
+(test-group
+ "bytevector I/O"
+(let ((input (open-input-string "abcdefghijklmnopqrstuvwxyz"))
+ (u8vec (make-bytevector 10)))
+ (assert (= 10 (read-bytevector! u8vec input)))
+ (assert (equal? u8vec #u8(97 98 99 100 101 102 103 104 105 106)))
+ (assert (= 5 (read-bytevector! u8vec input 5)))
+ (assert (equal? u8vec #u8(97 98 99 100 101 107 108 109 110 111)))
+ (assert (= 5 (read-bytevector! u8vec input 0 5)))
+ (assert (equal? u8vec #u8(112 113 114 115 116 107 108 109 110 111)))
+ (assert (= 6 (read-bytevector! u8vec input 0 10)))
+ (assert (equal? u8vec #u8(117 118 119 120 121 122 108 109 110 111))))
+
+(let ((input (open-input-string "abcdefghijklmnopqrs")))
+ (assert (equal? (read-bytevector 5 input)
+ #u8(97 98 99 100 101)))
+ (assert (equal? (read-bytevector 5 input) #u8(102 103 104 105 106)))
+ (assert (equal? (read-bytevector #f input)
+ #u8(107 108 109 110 111 112 113 114 115)))
+ (with-input-from-string "abcdefghijklmnopqrs"
+ (lambda ()
+ (assert (equal? (read-bytevector 5)
+ #u8(97 98 99 100 101)))
+ (assert (equal? (read-bytevector 5) #u8(102 103 104 105 106)))
+ (assert (equal? (read-bytevector)
+ #u8(107 108 109 110 111 112 113 114 115))))))
+
+(assert (string=?
+ "abc"
+ (with-output-to-string
+ (lambda ()
+ (write-bytevector #u8(97 98 99))))))
+
+(assert (string=?
+ "bc"
+ (with-output-to-string
+ (lambda ()
+ (write-bytevector #u8(97 98 99) (current-output-port) 1)))))
+
+(assert (string=?
+ "a"
+ (with-output-to-string
+ (lambda ()
+ (write-bytevector #u8(97 98 99) (current-output-port) 0 1)))))
+
+(assert (string=?
+ "b"
+ (with-output-to-string
+ (lambda ()
+ (write-bytevector #u8(97 98 99) (current-output-port) 1 2)))))
+
+(assert (string=?
+ ""
+ (with-output-to-string
+ (lambda ()
+ (write-bytevector #u8())))))
+)
+
;;;
(test-end)
diff --git a/tests/posix-tests.scm b/tests/posix-tests.scm
index 126ae77b..dccd483f 100644
--- a/tests/posix-tests.scm
+++ b/tests/posix-tests.scm
@@ -31,15 +31,15 @@
(close-output-port port)
(delete-file* tnpfilpn) ) ) )
-(assert-error (get-environment-variable "with\x00embedded-NUL"))
-(assert-error (set-environment-variable! "with\x00embedded-NUL" "blabla"))
-(assert-error (set-environment-variable! "blabla" "with\x00embedded-NUL"))
-(assert-error (system "echo this is \x00 not okay"))
+(assert-error (get-environment-variable "with\x00;embedded-NUL"))
+(assert-error (set-environment-variable! "with\x00;embedded-NUL" "blabla"))
+(assert-error (set-environment-variable! "blabla" "with\x00;embedded-NUL"))
+(assert-error (system "echo this is \x00; not okay"))
;; Use "false" to signal to the calling script that there was an error,
;; even if the process will get called
-(assert-error (process-execute "false\x00123"))
-(assert-error (process-execute "false" '("1" "123\x00456")))
-(assert-error (process-execute "false" '("123\x00456") '("foo\x00bar" "blabla") '("lalala" "qux\x00mooh")))
+(assert-error (process-execute "false\x00;123"))
+(assert-error (process-execute "false" '("1" "123\x00;456")))
+(assert-error (process-execute "false" '("123\x00;456") '(("foo\x00;bar" . "blabla") '("lalala" . "qux\x00;mooh"))))
(receive (in out pid)
(process csi-path '("-n" "-I" ".." "-e"
diff --git a/tests/r5rs_pitfalls.scm b/tests/r5rs_pitfalls.scm
index 5813dfc2..b81a44e1 100644
--- a/tests/r5rs_pitfalls.scm
+++ b/tests/r5rs_pitfalls.scm
@@ -54,9 +54,9 @@
(should-be 1.3 #t
(letrec ((x (call-with-current-continuation
(lambda (c)
- (list #T c)))))
+ (list #t c)))))
(if (car x)
- ((cadr x) (list #F (lambda () x)))
+ ((cadr x) (list #f (lambda () x)))
(eq? x ((cadr x))))))
;; Section 2: Proper call/cc and procedure application
diff --git a/tests/r7rs-tests-2.scm b/tests/r7rs-tests-2.scm
new file mode 100644
index 00000000..7648ec1a
--- /dev/null
+++ b/tests/r7rs-tests-2.scm
@@ -0,0 +1,1050 @@
+(import (scheme base)
+ (chicken base)
+ (chicken io)
+ (chicken port)
+ (chicken string)
+ (scheme char)
+ (scheme eval)
+ (scheme file)
+ (scheme read)
+ (scheme write))
+
+(define (read-from-string s)
+ (with-input-from-string s read))
+
+(include "test.scm")
+
+(define-syntax test
+ (syntax-rules ()
+ ((_ val expr) (test-equal expr val))
+ ((_ name val expr) (test-equal name expr val))))
+
+(test-begin "r7rs tests")
+
+(test-group "2.1: Identifiers"
+ (test "#!(no-)fold-case"
+ '(FOO mooh qux blah foo BAR)
+ (append
+ (with-input-from-string
+ "FOO #!fold-case mooh QUX blah #!no-fold-case foo BAR" read-list)))
+ (test "#!(no-)fold-case only affects subsequent reads from the same port"
+ '(FOO bar baz downcased UPCASED)
+ (append
+ (with-input-from-string "FOO #!fold-case bar BAZ" read-list)
+ (with-input-from-string "downcased UPCASED" read-list))))
+
+(test-group "4.1.7: Inclusion"
+ (test-group "include"
+ (test "multiple filenames"
+ "abcabc"
+ (with-output-to-string
+ (lambda () (include "include.scm" "include.scm"))))
+ (test-error "case sensitivity"
+ (with-output-to-string
+ (lambda () (include "include-ci.scm")))))
+ (test-group "include-ci"
+ (test "multiple filenames"
+ "abcabc"
+ (with-output-to-string
+ (lambda () (include-ci "include.scm" "include.scm"))))
+ (test "case sensitivity"
+ "abc"
+ (with-output-to-string
+ (lambda () (include-ci "include-ci.scm"))))))
+
+(test-group "4.2.1: Conditionals"
+ (test-group "cond-expand"
+ (test "(scheme base)"
+ 'scheme-base
+ (cond-expand
+ ((library (scheme base)) 'scheme-base)
+ (else #f)))
+ (test "(chicken base)"
+ 'chicken-base
+ (cond-expand
+ ((library (chicken base)) 'chicken-base)
+ (else #f)))
+ (test "chicken.base"
+ 'chicken.base
+ (cond-expand
+ ((library chicken.base) 'chicken.base)
+ (else #f)))
+ (test "(bogus identifier)"
+ #f
+ (cond-expand
+ ((library (bogus identifier)) 'bogus-identifier)
+ (else #f)))))
+
+(test-group "6.2.6: numerical operations"
+ (test-group "floor/...truncate-remainder"
+ (test '(2 1) (receive (floor/ 5 2)))
+ (test 2 (floor-quotient 5 2))
+ (test 1 (floor-remainder 5 2))
+ (test '(-3 1) (receive (floor/ -5 2)))
+ (test -3 (floor-quotient -5 2))
+ (test 1 (floor-remainder -5 2))
+ (test '(-3 -1) (receive (floor/ 5 -2)))
+ (test -3 (floor-quotient 5 -2))
+ (test -1 (floor-remainder 5 -2))
+ (test '(2 -1) (receive (floor/ -5 -2)))
+ (test 2 (floor-quotient -5 -2))
+ (test -1 (floor-remainder -5 -2))
+ (test '(2.0 -1.0) (receive (floor/ -5 -2.0)))
+ ;; From the Guile manual
+ (test 12 (floor-quotient 123 10))
+ (test 3 (floor-remainder 123 10))
+ (test '(12 3) (receive (floor/ 123 10)))
+ (test '(-13 -7) (receive (floor/ 123 -10)))
+ (test '(-13 7) (receive (floor/ -123 10)))
+ (test '(12 -3) (receive (floor/ -123 -10)))
+
+ (test '(2 1) (receive (truncate/ 5 2)))
+ (test 2 (truncate-quotient 5 2))
+ (test 1 (truncate-remainder 5 2))
+ (test '(-2 -1) (receive (truncate/ -5 2)))
+ (test -2 (truncate-quotient -5 2))
+ (test -1 (truncate-remainder -5 2))
+ (test '(-2 1) (receive (truncate/ 5 -2)))
+ (test -2 (truncate-quotient 5 -2))
+ (test 1 (truncate-remainder 5 -2))
+ (test '(2 -1) (receive (truncate/ -5 -2)))
+ (test 2 (truncate-quotient -5 -2))
+ (test -1 (truncate-remainder -5 -2))
+ (test '(2.0 -1.0) (receive (truncate/ -5.0 -2)))
+ (test 2.0 (truncate-quotient -5.0 -2))
+ (test -1.0 (truncate-remainder -5.0 -2))
+ ;; From the Guile manual
+ (test 12 (truncate-quotient 123 10))
+ (test 3 (truncate-remainder 123 10))
+ (test '(12 3) (receive (truncate/ 123 10)))
+ (test '(-12 3) (receive (truncate/ 123 -10)))
+ (test '(-12 -3) (receive (truncate/ -123 10)))
+ (test '(12 -3) (receive (truncate/ -123 -10))))
+
+ (test-group "quotient, remainder and modulo"
+ (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 -1.0 (remainder -13 -4.0)))
+
+ (test-group "square"
+ (test 1 (square 1))
+ (test 16 (square 4))
+ (test 16.0 (square 4.0))))
+
+(test-group "6.3: booleans"
+ ;; How silly...
+ (test-group "not"
+ (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-error (not))
+ (test-error (not 1 2)))
+
+ (test-group "long boolean literals"
+ (test #t (read-from-string "#t"))
+ (test #f (read-from-string "#f"))
+ (test #t (read-from-string "#true"))
+ (test #f (read-from-string "#false"))
+ (test-error (read-from-string "#faux")))
+
+ (test-group "boolean=?"
+ (test #t (boolean=? #t #t))
+ (test #t (boolean=? #t #t #t #t))
+ (test #t (boolean=? #f #f))
+ (test #t (boolean=? #f #f #f #f))
+ (test #f (boolean=? #f #t))
+ (test #f (boolean=? #f #t #t #t))
+ (test #f (boolean=? #f #f #t #t))
+ (test #f (boolean=? #f #f #f #t))
+ (test #f (boolean=? #t #f #f #f))
+ (test #f (boolean=? #t #f #f #t))
+ (test #f (boolean=? #t #t #f #t))
+ (test #f (boolean=? #f #f #f #t))
+ (test #f (boolean=? #f #t #f #f))
+ (test-error (boolean=? #f))
+ (test-error (boolean=? #f 1))
+ (test-error "no shortcutting" (boolean=? #f #t 2))))
+
+(test-group "6.4: pairs and lists"
+ (test-group "pair?"
+ (test #t (pair? '(a . b)))
+ (test #t (pair? '(a b c)))
+ (test #f (pair? '()))
+ (test #f (pair? '#(a b)))
+ (test #f (pair? #f))
+ (test #f (pair? #t))
+ (test #f (pair? "some string"))
+ (test #f (pair? 123)))
+
+ (test-group "cons"
+ (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-group "car"
+ (test 'a (car '(a b c)))
+ (test '(a) (car '((a) b c d)))
+ (test 1 (car '(1 . 2)))
+ (test-error (car '()))
+ (test-error (car '#(1 2 3)))
+ (test-error (car "not a pair")))
+
+ (test-group "cdr"
+ (test '(b c d) (cdr '((a) b c d)))
+ (test 2 (cdr '(1 . 2)))
+ (test-error (cdr '()))
+ (test-error (cdr '#(1 2 3)))
+ (test-error (cdr "not a pair")))
+
+ (test-group "set-car!"
+ (define (f) (list 'not-a-constant-list))
+ (define (g) '(constant-list))
+ ;; Examples from the text are very incomplete and strange
+ (let ((res (f)))
+ (set-car! res 2)
+ (test 2 (car res))
+ (set-car! (f) 3)
+ (test 'not-a-constant-list (car (f))))
+ ;; XXX Should this *raise* an error? R5RS also says this it "is an error"
+ #;(test-error (set-car! (g) 3))
+ (test-error (set-car! 'x 'y)))
+
+ (test-group "set-cdr!"
+ (define (f) (list 'not-a-constant-list))
+ (define (g) '(constant-list))
+ ;; Examples from the text are very incomplete and strange
+ (let ((res (f)))
+ (set-cdr! res 2)
+ (test 2 (cdr res))
+ (set-cdr! (f) 3)
+ (test '() (cdr (f))))
+ ;; XXX Should this *raise* an error? R5RS also says this it "is an error"
+ #;(test-error (set-cdr! (g) 3))
+ (test-error (set-cdr! 'x 'y)))
+
+ (test-group "c..r (base)"
+ (test 'x (caar '((x) y)))
+ (test-error (caar '(x y)))
+ (test 'y (cadr '((x) y)))
+ (test-error (cadr '(x)))
+ (test '() (cdar '((x) y)))
+ (test-error (cdar '(x)))
+ (test '() (cddr '((x) y)))
+ (test-error (cddr '(x))))
+
+ ;; TODO: c..r (cxr)
+
+ (test-group "null?"
+ (test #t (null? '()))
+ (test #t (null? (list)))
+ (test #f (null? '(a)))
+ (test #f (null? 'a))
+ (test #f (null? '#()))
+ (test #f (null? "foo")))
+
+ (test-group "list?"
+ (test #t (list? '(a b c)))
+ (test #t (list? (list 'a 'b 'c)))
+ (test #t (list? '()))
+ (test #f (list? '(a . b)))
+ (let ((x (list 'a)))
+ (set-cdr! x x)
+ (test #f (list? x)))
+ (test #f (list? 'a))
+ (test #f (list? '#()))
+ (test #f (list? "foo")))
+
+ (test-group "make-list"
+ (test-error (make-list))
+ (test '() (make-list 0))
+ (test '(#f) (make-list 1)) ; Unspecified
+
+ (test '(#f) (make-list 1 #f))
+ ;(test-error (make-list 1 2 3))
+ (test '(3 3) (make-list 2 3))
+ (test '() (make-list 0 3))
+ (test-error (make-list -1 3))
+ (test-error (make-list #f 3)))
+
+ (test-group "list"
+ (test '(a 7 c) (list 'a (+ 3 4) 'c))
+ (test '() (list))
+ (test '(#f) (list #f))
+ (test '(a b c) (list 'a 'b 'c)))
+
+ (test-group "length"
+ (test 3 (length '(a b c)))
+ (test 3 (length '(a (b) (c d e))))
+ (test 0 (length '()))
+
+ (test-error (length '(x . y)))
+ (test-error (length '#(x y)))
+ (test-error (length "foo")))
+
+ (test-group "append"
+ (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 '(a b c . d) (append '(a b) '(c . d)))
+ (test 'a (append '() 'a))
+ (test '(a b . c) (append '(a b) 'c))
+ (test-error (append 'x '()))
+ (test-error (append '(x) 'y '())))
+
+ (test-group "reverse"
+ (test '(c b a) (reverse '(a b c)))
+ (test '((e (f)) d (b c) a) (reverse '(a (b c) d (e (f)))))
+ (test '() (reverse '()))
+ (test-error (reverse '(a . b)))
+ (test-error (reverse '(a b) '(c d)))
+ (test-error (reverse 'a))
+ (test-error (reverse '#(a b c)))
+ (test-error (reverse "foo")))
+
+ (test-group "list-tail"
+ (test '(a b c d e f) (list-tail '(a b c d e f) 0))
+ (test '(d e f) (list-tail '(a b c d e f) 3))
+ (test '() (list-tail '(a b c d e f) 6))
+ (test '() (list-tail '() 0))
+ (test-error (list-tail '(a b c d e f) -1))
+ (test-error (list-tail '(a b c d e f) 7))
+ (test-error (list-tail '(a b c d e . f) 6)))
+
+ (test-group "list-ref"
+ (test 'a (list-ref '(a b c d) 0))
+ (test 'b (list-ref '(a b c d) 1))
+ (test 'c (list-ref '(a b c d) 2))
+ (test 'd (list-ref '(a b c d) 3))
+ (test-error (list-ref '(a b c d) 4))
+ (test-error (list-ref '(a b c d) -1)))
+
+ (test-group "list-set!"
+ (let ((ls (list 'one 'two 'five!)))
+ (list-set! ls 2 'three)
+ (test '(two three) (cdr ls)))
+ ;; Should be an error?
+ #;(list-set! '(0 1 2) 1 "oops")
+ (test-error (list-set! (list 1 2 3) 3 'foo)))
+
+ (test-group "mem*"
+ (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 '("b" "c") (member "B" '("a" "b" "c") string-ci=?))
+ (test '(101 102) (memq 101 '(100 101 102))) ; unspecified in R7RS
+ (test '(101 102) (memv 101 '(100 101 102))))
+
+ (test-group "ass*"
+ (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 '(2 4) (assoc 2.0 '((1 1) (2 4) (3 9)) =))
+ (test '(5 7) (assq 5 '((2 3) (5 7) (11 13)))) ; unspecified in R7RS
+ (test '(5 7) (assv 5 '((2 3) (5 7) (11 13))))
+ (test-error (assq 5 '(5 6 7)))
+ (test-error (assv 5 '(5 6 7)))
+ (test-error (assoc 5 '(5 6 7))))
+
+ (test-group "list-copy"
+ (define a '(1 8 2 8)) ; a may be immutable
+ (define b (list-copy a))
+ (set-car! b 3) ; b is mutable
+ (test '((3 8 2 8)) (list b))
+ (test '((1 8 2 8)) (list a))))
+
+(test-group "6.5: Symbols"
+ (test-group "symbol=?"
+ (test-error (symbol=?))
+ (test-error (symbol=? 'a))
+ (test-error (symbol=? 'a 1))
+ (test-error (symbol=? 'a 'b 1))
+ (test #t (symbol=? '|| '||))
+ (test #t (symbol=? '|a b| '|a b|))
+ (test #t (symbol=? 'a 'a))
+ (test #f (symbol=? 'a 'b))
+ (test #t (symbol=? 'a 'a 'a))
+ (test #f (symbol=? 'a 'a 'b))
+ (test #f (symbol=? 'a 'b 'b))
+ (test #t (symbol=? 'a 'a 'a 'a))
+ (test #f (symbol=? 'a 'a 'a 'b))
+ (test #f (symbol=? 'a 'a 'b 'b))
+ (test #f (symbol=? 'a 'b 'b 'b))))
+
+(test-group "6.6: characters"
+ (test-group "char*?"
+ (test-error "arity" (char=? #\a))
+ (test-error "type check" (char=? #\a #\a 1))
+ (test-error "no shortcutting" (char=? #\a #\b 1))
+ (test #f (char? 1))
+ (test #t (char? #\a))
+ (test #t (char=? #\a #\a))
+ (test #f (char=? #\a #\b))
+ (test #t (char=? #\a #\a #\a))
+ (test #f (char=? #\a #\b #\a))
+ (test #f (char=? #\a #\a #\b))
+ (test #t (char=? #\a #\a #\a #\a))
+ (test #f (char=? #\a #\b #\a #\a))
+ (test #f (char=? #\a #\a #\a #\b))
+ (test #t (char<? #\a #\b #\c))
+ (test #f (char<? #\a #\b #\b))
+ (test #t (char<=? #\a #\b #\b))
+ (test #f (char<=? #\a #\b #\a))
+ (test #t (char>? #\c #\b #\a))
+ (test #f (char>? #\a #\a #\a))
+ (test #t (char>=? #\b #\b #\a))
+ (test #f (char>=? #\b #\a #\b))))
+
+(test-group "6.7: strings"
+
+ (test-group "string*?"
+ (test-error "arity" (string=? "a"))
+ (test-error "type check" (string=? "a" "a" 1))
+ (test-error "no shortcutting" (string=? "a" "b" 1))
+ (test #f (string? 1))
+ (test #t (string? "a"))
+ (test #t (string=? "a" "a"))
+ (test #f (string=? "a" "b"))
+ (test #t (string=? "a" "a" "a"))
+ (test #f (string=? "a" "b" "a"))
+ (test #f (string=? "a" "a" "b"))
+ (test #t (string=? "a" "a" "a" "a"))
+ (test #f (string=? "a" "b" "a" "a"))
+ (test #f (string=? "a" "a" "a" "b"))
+ (test #t (string<? "a" "b" "c"))
+ (test #f (string<? "a" "b" "b"))
+ (test #t (string<=? "a" "b" "b"))
+ (test #f (string<=? "a" "b" "a"))
+ (test #t (string>? "c" "b" "a"))
+ (test #f (string>? "c" "b" "b"))
+ (test #t (string>=? "b" "b" "a"))
+ (test #f (string>=? "b" "a" "b")))
+
+ (test-group "string->list"
+ (test-error (string->list "" 1))
+ (test-error (string->list "a" 1 2))
+ (test '(#\a) (string->list "a"))
+ (test '() (string->list "a" 1))
+ (test '(#\b) (string->list "abc" 1 2))
+ (test '() (string->list "abc" 2 2)))
+
+ (test-group "string->vector"
+ (test-error (string->vector "" 1))
+ (test-error (string->vector "a" 0 2))
+ (test #(#\a) (string->vector "a"))
+ (test #() (string->vector "a" 1 1))
+ (test #(#\b) (string->vector "abc" 1 2))
+ (test #() (string->vector "abc" 2 2)))
+
+ (test-group "string-copy!"
+ (let ((r "abcdef"))
+ (string-copy! r 2 r 0 3)
+ (test "string-copy! r 2 r 0 3)" "ababcf" r)))
+
+ (test-group "vector->string"
+ (test-error (vector->string #() 1))
+ (test-error (vector->string #(1)))
+ (test-error (vector->string #(#\a) 0 2))
+ (test "a" (vector->string #(#\a)))
+ (test "" (vector->string #(#\a) 1 1))
+ (test "b" (vector->string #(#\a #\b #\c) 1 2))
+ (test "" (vector->string #(#\a #\b #\c) 2 2))))
+
+(test-group "6.8: vectors"
+
+ (test-group "vector-copy"
+ (test-error (vector-copy ""))
+ (test-error (vector-copy #() #()))
+ (test-error (vector-copy #() 1))
+ (test-error (vector-copy #(0) -1))
+ (test-error (vector-copy #(0) 0 2))
+ (test #() (vector-copy #()))
+ (test #(0 1 2) (vector-copy #(0 1 2)))
+ (test #(1 2) (vector-copy #(0 1 2) 1))
+ (test #(1) (vector-copy #(0 1 2) 1 2))
+ (test #() (vector-copy #(0 1 2) 1 1)))
+
+ (test-group "vector-copy!"
+ (test-error (vector-copy! ""))
+ (test-error (vector-copy! #(0) 0 ""))
+ (test-error (vector-copy! #() #() 0))
+ (test-error (vector-copy! #() 0 #(0)))
+ (test-error (vector-copy! #(0) 1 #(0)))
+ (test-error (vector-copy! #(0) 1 #(0) 0))
+ (test-error (vector-copy! #(0) 0 #(0) 0 2))
+ (test-error (vector-copy! #(0) 0 #(0 1) 1 0))
+ (test-assert (vector-copy! #() 0 #()))
+ (let ((t #(0 1 2))
+ (f #(3 4 5 6))
+ (r #(1 2 3 4 5)))
+ (vector-copy! t 0 f 1 1)
+ (test "(vector-copy! t 1 f 1 1)" #(0 1 2) t)
+ (vector-copy! t 0 f 0 1)
+ (test "(vector-copy! t 0 f 0 1)" #(3 1 2) t)
+ (vector-copy! t 0 f 1 3)
+ (test "(vector-copy! t 0 f 1 3)" #(4 5 2) t)
+ (vector-copy! t 1 f 2)
+ (test "(vector-copy! t 1 f 1)" #(4 5 6) t)
+ (vector-copy! t 0 f 1)
+ (test "(vector-copy! t 0 f)" #(4 5 6) t)
+ (vector-copy! r 2 r 0 3)
+ (test "(vector-copy! r 2 r 0 3)" #(1 2 1 2 3) r)))
+
+ (test-group "vector-append"
+ (test-error (vector-append ""))
+ (test-error (vector-append #() 1))
+ (test #() (vector-append))
+ (test #(0) (vector-append #(0)))
+ (test #() (vector-append #() #()))
+ (test #(0 1) (vector-append #(0) #(1)))
+ (test #(0 1 2 3 4 5) (vector-append #(0 1) #(2 3) #(4 5))))
+
+ (test-group "vector->list"
+ (test-error (vector->list ""))
+ (test-error (vector->list #() 1))
+ (test '() (vector->list #()))
+ (test '(0 1 2) (vector->list #(0 1 2)))
+ (test '(1 2) (vector->list #(0 1 2) 1))
+ (test '(1) (vector->list #(0 1 2) 1 2))
+ (test '() (vector->list #(0 1 2) 2 2))))
+
+(test-group "6.9: bytevectors"
+
+ (test-group "bytevector-copy"
+ (test-error (bytevector-copy ""))
+ (test-error (bytevector-copy #u8() #u8()))
+ (test-error (bytevector-copy #u8() 1))
+ (test-error (bytevector-copy #u8(0) -1))
+ (test-error (bytevector-copy #u8(0) 0 2))
+ (test #u8() (bytevector-copy #u8()))
+ (test #u8(0 1 2) (bytevector-copy #u8(0 1 2)))
+ (test #u8(1 2) (bytevector-copy #u8(0 1 2) 1))
+ (test #u8(1) (bytevector-copy #u8(0 1 2) 1 2))
+ (test #u8() (bytevector-copy #u8(0 1 2) 1 1)))
+
+ (test-group "bytevector-copy!"
+ (test-error (bytevector-copy! ""))
+ (test-error (bytevector-copy! #u8(0) 0 ""))
+ (test-error (bytevector-copy! #u8() #u8() 0))
+ (test-error (bytevector-copy! #u8() 0 #u8(0)))
+ (test-error (bytevector-copy! #u8(0) 1 #u8(0)))
+ (test-error (bytevector-copy! #u8(0) 1 #u8(0) 0))
+ (test-error (bytevector-copy! #u8(0) 0 #u8(0) 0 2))
+ (test-error (bytevector-copy! #u8(0) 0 #u8(0 1) 1 0))
+ (test-assert (bytevector-copy! #u8() 0 #u8()))
+ (let ((t #u8(0 1 2))
+ (f #u8(3 4 5 6))
+ (r #u8(1 2 3 4 5)))
+ (bytevector-copy! t 0 f 1 1)
+ (test "(bytevector-copy! t 1 f 1 1)" #u8(0 1 2) t)
+ (bytevector-copy! t 0 f 0 1)
+ (test "(bytevector-copy! t 0 f 0 1)" #u8(3 1 2) t)
+ (bytevector-copy! t 0 f 1 3)
+ (test "(bytevector-copy! t 0 f 1 3)" #u8(4 5 2) t)
+ (bytevector-copy! t 1 f 2)
+ (test "(bytevector-copy! t 1 f 1)" #u8(4 5 6) t)
+ (bytevector-copy! t 0 f 1)
+ (test "(bytevector-copy! t 0 f)" #u8(4 5 6) t)
+ (bytevector-copy! r 2 r 0 3)
+ (test "(bytevector-copy! r 2 r 0 3)" #u8(1 2 1 2 3) r)))
+
+ (test-group "bytevector-append"
+ (test-error (bytevector-append #u8() 1))
+ (test #u8() (bytevector-append))
+ (test #u8(0) (bytevector-append #u8(0)))
+ (test #u8() (bytevector-append #u8() #u8()))
+ (test #u8(0 1) (bytevector-append #u8(0) #u8(1)))
+ (test #u8(0 1 2 3 4 5) (bytevector-append #u8(0 1) #u8(2 3) #u8(4 5))))
+
+ (test-group "bytevector read syntax"
+ (test (bytevector 1 2 3) (read-from-string "#u8(1 2 3)")))
+
+ )
+
+(test-group "6.10: Control features"
+
+ (define (1st . a) (car a))
+ (define (2nd . a) (cadr a))
+ (define (acc proc f . rest) ; accumulate results of `f`
+ (let ((a '()))
+ (apply proc (lambda args (set! a (cons (apply f args) a))) rest)
+ (reverse a)))
+
+ (define char-add1
+ (compose integer->char add1 char->integer))
+
+ (test-group "string-map"
+ (test-error (string-map "abc"))
+ (test-error (string-map values))
+ (test-error (string-map values '(1 2 3)))
+ (test-error (string-map (constantly 1) "abc"))
+ (test "" (string-map values ""))
+ (test "abc" (string-map values "abc"))
+ (test "aaa" (string-map (constantly #\a) "abc"))
+ (test "bcd" (string-map char-add1 "abc"))
+ (test "abc" (string-map 1st "abc" "123"))
+ (test "123" (string-map 2nd "abc" "123"))
+ (test "abc" (string-map 1st "abc" "123456"))
+ (test "123" (string-map 2nd "abc" "123456")))
+
+ (test-group "string-for-each"
+ (test-error (string-for-each "abc"))
+ (test-error (string-for-each values))
+ (test-error (string-for-each values '(1 2 3)))
+ (test '() (acc string-for-each values ""))
+ (test '(#\a #\b #\c) (acc string-for-each values "abc"))
+ (test '(#\b #\c #\d) (acc string-for-each char-add1 "abc"))
+ (test '((#\a #\1) (#\b #\2) (#\c #\3)) (acc string-for-each list "abc" "123"))
+ (test '(#\1 #\2 #\3) (acc string-for-each 2nd "abc" "123"))
+ (test '(#\a #\b #\c) (acc string-for-each 1st "abc" "123456"))
+ (test '(#\1 #\2 #\3) (acc string-for-each 2nd "abc" "123456")))
+
+ (test-group "vector-map"
+ (test-error (vector-map #(1 2 3)))
+ (test-error (vector-map values))
+ (test-error (vector-map values '(1 2 3)))
+ (test #() (vector-map values #()))
+ (test #(1 2 3) (vector-map values #(1 2 3)))
+ (test #(1 1 1) (vector-map (constantly 1) #(1 2 3)))
+ (test #(2 3 4) (vector-map add1 #(1 2 3)))
+ (test #(1 2 3) (vector-map 1st #(1 2 3) #(4 5 6)))
+ (test #(4 5 6) (vector-map 2nd #(1 2 3) #(4 5 6)))
+ (test #(1 2 3) (vector-map 1st #(1 2 3) #(4 5 6 7 8 9)))
+ (test #(4 5 6) (vector-map 2nd #(1 2 3) #(4 5 6 7 8 9))))
+
+ (test-group "vector-for-each"
+ (test-error (vector-for-each #(1 2 3)))
+ (test-error (vector-for-each values))
+ (test-error (vector-for-each values '(1 2 3)))
+ (test '() (acc vector-for-each values #()))
+ (test '(1 2 3) (acc vector-for-each values #(1 2 3)))
+ (test '(2 3 4) (acc vector-for-each add1 #(1 2 3)))
+ (test '((1 4) (2 5) (3 6)) (acc vector-for-each list #(1 2 3) #(4 5 6)))
+ (test '(4 5 6) (acc vector-for-each 2nd #(1 2 3) #(4 5 6)))
+ (test '(1 2 3) (acc vector-for-each 1st #(1 2 3) #(4 5 6 7 8 9)))
+ (test '(4 5 6) (acc vector-for-each 2nd #(1 2 3) #(4 5 6 7 8 9)))))
+
+(test-group "6.13: Input"
+ (test-assert "read-string returns eof-object for empty string"
+ (eof-object? (with-input-from-string "" (lambda () (read-string 1)))))
+ (test-assert "read-bytevector returns eof-object for empty string"
+ (eof-object? (with-input-from-string "" (lambda () (read-bytevector 1))))))
+
+(define-syntax catch
+ (syntax-rules ()
+ ((_ . body) (handle-exceptions e e . body))))
+
+(test-group "exceptions"
+ (test "with-exception-handler (escape)"
+ 'exception
+ (call-with-current-continuation
+ (lambda (k)
+ (with-exception-handler
+ (lambda (e) (k 'exception))
+ (lambda () (+ 1 (raise 'an-error)))))))
+ (test-error "with-exception-handler (return)"
+ (with-exception-handler
+ (lambda (e) 'ignore)
+ (lambda () (+ 1 (raise 'an-error)))))
+ (test-error "with-exception-handler (raise)"
+ (with-exception-handler
+ (lambda (e) (raise 'another-error))
+ (lambda () (+ 1 (raise 'an-error)))))
+ (test "with-exception-handler (raise-continuable)"
+ '("should be a number" 65)
+ (let* ((exception-object #f)
+ (return-value
+ (with-exception-handler
+ (lambda (e) (set! exception-object e) 42)
+ (lambda () (+ (raise-continuable "should be a number") 23)))))
+ (list exception-object return-value)))
+ (test "error-object? (#f)" #f (error-object? 'no))
+ (test "error-object? (#t)" #t (error-object? (catch (car '()))))
+ (test "error-object-message" "fubar" (error-object-message (catch (error "fubar"))))
+ (test "error-object-irritants" '(42) (error-object-irritants (catch (error "fubar" 42))))
+ (test "read-error? (#f)" #f (read-error? (catch (car '()))))
+ (test "read-error? (#t)" #t (read-error? (catch (read-from-string ")"))))
+ (test "file-error? (#f)" #f (file-error? (catch (car '()))))
+ (test "file-error? (#t)" #t (file-error? (catch (open-input-file "foo"))))
+ (test-error "guard (no match)"
+ (guard (condition ((assq 'c condition))) (raise '((a . 42)))))
+ (test "guard (match)"
+ '(b . 23)
+ (guard (condition ((assq 'b condition))) (raise '((b . 23)))))
+ (test "guard (=>)"
+ 42
+ (guard (condition ((assq 'a condition) => cdr)) (raise '((a . 42)))))
+ (test "guard (multiple)"
+ '(b . 23)
+ (guard (condition
+ ((assq 'a condition) => cdr)
+ ((assq 'b condition)))
+ (raise '((b . 23))))))
+
+;; call-with-port is not supposed to close its port when leaving the
+;; dynamic extent, only on normal return.
+;;
+;; XXX TODO: Rewrite in terms of SRFI-6 string port interface, so
+;; no call-with-*-string, but use get-output-string and such!
+;; Do this when it's clear how to re-export Chicken stuff.
+(test-group "string ports"
+ (receive (jump-back? jump!)
+ (call/cc (lambda (k) (values #f k)))
+ (when jump-back? (jump! (void)))
+ (let ((string (call-with-output-string
+ (lambda (the-string-port)
+ (receive (one two three)
+ (call-with-port the-string-port
+ (lambda (p)
+ (display "foo" p)
+ ;; Leave the dynamic extent momentarily;
+ ;; jump! will immediately return with #t.
+ (call/cc (lambda (k) (jump! #t k)))
+ (test-assert "Port is still open after excursion"
+ (output-port-open? the-string-port))
+ (display "bar" p)
+ (values 1 2 3)))
+ (test "call-with-port returns all values yielded by proc"
+ '(1 2 3)
+ (list one two three)))
+ (test-assert "call-with-port closes the port on normal return"
+ (not (output-port-open? the-string-port)))
+ (test-assert "It's ok to close output ports that are closed"
+ (close-port the-string-port))
+ (test-error "input-port-open? fails on output ports"
+ (input-port-open? the-string-port))))))
+ (test "call-with-port passes the port correctly and allows temporary escapes"
+ "foobar" string)))
+
+ (call-with-input-string "foo"
+ (lambda (the-string-port)
+ (test-error "output-port-open? fails on input ports"
+ (output-port-open? the-string-port))
+ (test-assert "Initially, string port is open"
+ (input-port-open? the-string-port))
+ (test "Reading from string delivers the data"
+ 'foo (read the-string-port))
+ (test "After reading all, we get the eof-object"
+ (eof-object) (read the-string-port))
+ (test-assert "Port is still open after all reads"
+ (input-port-open? the-string-port))
+ (close-port the-string-port)
+ (test-assert "Port is no longer open after closing it"
+ (not (input-port-open? the-string-port)))
+ (test-assert "It's ok to close input ports that are already closed"
+ (close-port the-string-port)))))
+
+;; This is for later. We can't define it inside a group because that
+;; would make it locally scoped (as a letrec rewrite), which breaks
+;; the syntax-rules underscore tests. Very subtle (and annoying), this!
+(define (_) 'underscore-procedure)
+(define ___ 'triple-underscore-literal)
+
+(test-group "syntax-rules"
+ (test "let-syntax w/ basic syntax-rules"
+ 100
+ (let-syntax ((foo (syntax-rules ()
+ ((_ x form)
+ (let ((tmp x))
+ (if (number? tmp)
+ form
+ (error "not a number" tmp)))))))
+ (foo 2 100)))
+ (let-syntax ((foo (syntax-rules ()
+ ((_ #(a ...)) (list a ...)))))
+ (test "Basic matching of vectors"
+ '(1 2 3) (foo #(1 2 3))))
+ ;; ellipsis pattern element wasn't matched - reported by Jim Ursetto (fixed rev. 13582)
+ (let-syntax ((foo (syntax-rules ()
+ ((_ (a b) ...)
+ (list 'first '(a b) ...))
+ ((_ a ...)
+ (list 'second '(a) ...)))))
+ (test "Basic ellipsis match"
+ '(first (1 2) (3 4) (5 6)) (foo (1 2) (3 4) (5 6)))
+ (test "Ellipsis match of length 1 does not match length 2"
+ '(second (1)) (foo 1))
+ (test "Ellipsis match of lists with mismatched lengths (used to fail)"
+ '(second ((1 2)) ((3)) ((5 6))) (foo (1 2) (3) (5 6))))
+
+ (test "letrec-syntax"
+ 34
+ (letrec-syntax ((foo (syntax-rules () ((_ x) (bar x))))
+ (bar (syntax-rules () ((_ x) (+ x 1)))))
+ (foo 33)))
+ (test "Basic hygienic rename of syntactic keywords"
+ 'now
+ (let-syntax ((when (syntax-rules ()
+ ((when test stmt1 stmt2 ...)
+ (if test
+ (begin stmt1
+ stmt2 ...))))))
+ (let ((if #t))
+ (when if (set! if 'now))
+ if)))
+ (test "Basic hygienic rename of shadowed outer let"
+ 'outer
+ (let ((x 'outer))
+ (let-syntax ((m (syntax-rules () ((m) x))))
+ (let ((x 'inner))
+ (m)))))
+ (test "Simple recursive letrec expansion"
+ 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))))
+ ;; From Al* Petrofsky's "An Advanced Syntax-Rules Primer for the Mildly Insane"
+ (let ((a 1))
+ (letrec-syntax
+ ((foo (syntax-rules ()
+ ((_ b)
+ (bar a b))))
+ (bar (syntax-rules ()
+ ((_ c d)
+ (cons c (let ((c 3))
+ (list d c 'c)))))))
+ (let ((a 2))
+ (test "Al* Petrofsky torture test" '(1 2 3 a) (foo a)))))
+ (let-syntax
+ ((foo (syntax-rules ()
+ ((_)
+ '#(b)))))
+ (test "Quoted symbols inside vectors are stripped of syntactic info"
+ '#(b) (foo)))
+ (let-syntax ((kw (syntax-rules (baz)
+ ((_ baz) "baz")
+ ((_ any) "no baz"))))
+ (test "syntax-rules keywords match" "baz" (kw baz))
+ (test "syntax-rules keywords no match" "no baz" (kw xxx))
+ (let ((baz 100))
+ (test "keyword loses meaning if shadowed" "no baz" (kw baz))))
+ (test "keyword also loses meaning for builtins (from R7RS section 4.3.2)"
+ 'ok
+ (let ((=> #f))
+ (cond (#t => 'ok))))
+ (test "Nested identifier shadowing works correctly"
+ '(3 4)
+ (let ((foo 3))
+ (let-syntax ((bar (syntax-rules () ((_ x) (list foo x)))))
+ (let ((foo 4))
+ (bar foo)))))
+ (let-syntax ((c (syntax-rules ()
+ ((_)
+ (let ((x 10))
+ (let-syntax ((z (syntax-rules ()
+ ((_) (quote x)))))
+ (z))))))
+ (c2 (syntax-rules ()
+ ((_)
+ (let ((x 10))
+ (let-syntax
+ ((z (syntax-rules ()
+ ((_) (let-syntax
+ ((w (syntax-rules ()
+ ((_) (quote x)))))
+ (w))))))
+ (z)))))))
+ ;; Reported by Matthew Flatt
+ (test "strip-syntax cuts across three levels of syntax"
+ "x" (symbol->string (c)))
+ (test "strip-syntax cuts across four levels of syntax"
+ "x" (symbol->string (c2))))
+ (let-syntax ((foo (syntax-rules
+ ___ ()
+ ((_ vals ___) (list '... vals ___)))))
+ (test "Alternative ellipsis (from SRFI-46)"
+ '(... 1 2 3) (foo 1 2 3)))
+ (let-syntax ((let-alias (syntax-rules
+ ___ ()
+ ((_ new old code ___)
+ (let-syntax
+ ((new
+ (syntax-rules ()
+ ((_ args ...) (old args ...)))))
+ code ___)))))
+ (let-alias inc (lambda (x) (+ 1 x))
+ (test "Ellipsis rules are reset in new macro expansion phase"
+ 3 (inc 2))))
+ (let-syntax ((foo (syntax-rules ()
+ ((_ (a ... b) ... (c d))
+ (list (list (list a ...) ... b ...) c d))
+ ((_ #(a ... b) ... #(c d) #(e f))
+ (list (list (vector a ...) ... b ...) c d e f))
+ ((_ #(a ... b) ... #(c d))
+ (list (list (vector a ...) ... b ...) c d)))))
+ (test-group "rest patterns after ellipsis (SRFI-46 smoke test)"
+ (test '(() 1 2) (foo (1 2)))
+ (test '(((1) 2) 3 4) (foo (1 2) (3 4)))
+ (test '(((1 2) (4) 3 5) 6 7)
+ (foo (1 2 3) (4 5) (6 7)))
+ (test '(() 1 2)
+ (foo #(1 2)))
+ (test '((#() 1) 2 3)
+ (foo #(1) #(2 3)))
+ (test '((#(1 2) 3) 4 5)
+ (foo #(1 2 3) #(4 5)))
+ (test '((#(1 2) 3) 4 5 6 7)
+ (foo #(1 2 3) #(4 5) #(6 7)))
+ (test '(() 1 2 3 4)
+ (foo #(1 2) #(3 4)))
+ (test '((#(1) 2) 3 4 5 6)
+ (foo #(1 2) #(3 4) #(5 6)))
+ (test '((#(1 2) #(4) 3 5) 6 7 8 9)
+ (foo #(1 2 3) #(4 5) #(6 7) #(8 9)))))
+ (let-syntax ((foo (syntax-rules ()
+ ((_ #((a) ...)) (list a ...)))))
+ (test "Bug discovered during implementation of rest patterns"
+ '(1)
+ (foo #((1)))))
+ ;; R7RS: (<ellipsis> <template>) is like <template>, ignoring
+ ;; occurrances of <ellipsis> inside the template.
+ (let-syntax ((be-like-begin
+ (syntax-rules ()
+ ((be-like-begin name)
+ (define-syntax name
+ (syntax-rules ()
+ ((name expr (... ...))
+ (begin expr (... ...)))))))))
+ (be-like-begin sequence)
+ (test "be-like-begin from R7RS 4.3.2 (nested ellipsis are not expanded)"
+ 4 (sequence 1 2 3 4)))
+ (let-syntax ((ignore-underscores
+ (syntax-rules ()
+ ((_ _ _ _) (_)))))
+ (test "underscores are ignored in patterns"
+ 'underscore-procedure (ignore-underscores _ b c)))
+
+ (test-group "undefined behaviours: mixing keywords, ellipsis and underscores"
+ (test-group "underscore as keyword literal"
+ (define-syntax match-literal-underscores ; for eval
+ (syntax-rules (_)
+ ((x a _ c) (_))
+ ((x _ b c) 1)))
+ (test-error "Missing literal underscore keyword causes syntax-error"
+ (eval '(match-literal-underscores d e f)))
+ (test "Literal underscore matches"
+ 1 (match-literal-underscores _ h i))
+ (test "Literal underscore matches even if it refers to toplevel binding"
+ 'underscore-procedure (match-literal-underscores g _ i)))
+
+ (test-group "underscore as ellipsis"
+ ;; It's undefined what this should do. Logically, it should be
+ ;; possible to bind _ as an ellipsis identifier.
+ (define-syntax match-ellipsis-underscores ; for eval
+ (syntax-rules _ () ((x a _ c) (list a _ c))))
+ (test-error "No rule matching if prefix is omitted"
+ (eval '(match-ellipsis-underscores)))
+ (test "Only prefix is supplied"
+ '(1) (match-ellipsis-underscores 1))
+ (test "Ellipsis does its work if multiple arguments given"
+ '(1 2 3 4 5 6) (match-ellipsis-underscores 1 2 3 4 5 6)))
+
+ (test-group "underscore as ellipsis mixed with underscore literal"
+ ;; Even more undefined behaviour: mixing literals and ellipsis identifiers
+ ;; Currently, ellipsis identifiers have precedence over the other two.
+ (define-syntax match-ellipsis-and-literals-underscores ; for eval
+ (syntax-rules _ (_) ((x a _ c) (list a _ c))))
+ (test-error "No rule matching if prefix is omitted"
+ (eval '(match-ellipsis-and-literals-underscores)))
+ (test '(1) (match-ellipsis-and-literals-underscores 1))
+ (test '(1 2 3) (match-ellipsis-and-literals-underscores 1 2 3))
+ (test '(1 2 3 4 5 6) (match-ellipsis-and-literals-underscores 1 2 3 4 5 6)))
+
+ (test-group "\"custom\" ellipsis and literal of the same identifier"
+ ;; This is similar to the above, but maybe a little simpler because
+ ;; it does not use reserved names:
+ (define-syntax match-ellipsis-literals
+ (syntax-rules ___ (___)
+ ((_ x ___) (list x ___))))
+ (test "Ellipsis as literals"
+ '(1) (match-ellipsis-literals 1))
+ (test "Ellipsis as literals multiple args"
+ '(1 2) (match-ellipsis-literals 1 2))
+ (test "Toplevel binding of the same name as ellipsis"
+ '(1 triple-underscore-literal) (match-ellipsis-literals 1 ___))))
+
+ (letrec-syntax ((usetmp
+ (syntax-rules ()
+ ((_ var)
+ (list var))))
+ (withtmp
+ (syntax-rules ()
+ ((_ val exp)
+ (let ((tmp val))
+ (exp tmp))))))
+ (test "Passing a macro as argument to macro"
+ '(99)
+ (withtmp 99 usetmp)))
+
+ ;; renaming of keyword argument (#277)
+ (let-syntax ((let-hello-proc
+ (syntax-rules ()
+ ((_ procname code ...)
+ (let ((procname (lambda (#!key (who "world"))
+ (string-append "hello, " who))))
+ code ...)))))
+ (let-hello-proc bar
+ ;; This is not R7RS, but R7RS should not interfere with other
+ ;; CHICKEN features!
+ (test "DSSSL keyword arguments aren't renamed (not R7RS)"
+ "hello, XXX" (bar who: "XXX")))))
+
+(test-group "define-record-type"
+ (define-record-type foo (make-foo) foo?)
+ (define foo1 (make-foo))
+ (test-assert "Record instances satisfy their predicates" (foo? foo1))
+ (define-record-type foo (make-foo) foo?)
+ (test-assert "Record type definitions are generative" (not (foo? foo1))))
+
+(test-group "open-input-bytevector"
+ (test (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)
+ (let ((bv (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)))
+ (read-bytevector 12 (open-input-bytevector bv)))))
+
+(test-group "open-output-bytevector"
+ (test (bytevector 0 1 2 10 13 40 41 42 128 140 240 255)
+ (let ((p (open-output-bytevector)))
+ (write-bytevector (bytevector 0 1 2 10 13) p)
+ (write-bytevector (bytevector 40 41 42 128) p)
+ (write-bytevector (bytevector 140 240 255) p)
+ (close-output-port p)
+ (get-output-bytevector p))))
+
+;; this was submitted as broken by Lukas Bröger:
+(test-group "eval environments"
+ (test 42 (eval '42 (scheme-report-environment 5))))
+
+(test-end "r7rs tests")
+
+(test-exit)
diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm
index 22488edf..94af614e 100644
--- a/tests/r7rs-tests.scm
+++ b/tests/r7rs-tests.scm
@@ -1,7 +1,7 @@
;; R7RS Tests
(import (only (chicken port) with-input-from-string with-output-to-string)
- (chicken condition))
+ (chicken condition) (scheme lazy))
;; Copied from R4RS tests
(define cur-section '())
@@ -219,9 +219,8 @@
;; Edge case
(test "" read-escaped-string (string-append " " (string #\newline) " "))
-;; NOT YET (is ambiguous with existing \xNN syntax in CHICKEN)
-#;(test #\tab escaped-char "x9;")
-#;(test #\tab escaped-char "x09;")
+(test #\tab escaped-char "x9;")
+(test #\tab escaped-char "x09;")
diff --git a/tests/reader-tests.scm b/tests/reader-tests.scm
index 808f9fb6..13dc7c31 100644
--- a/tests/reader-tests.scm
+++ b/tests/reader-tests.scm
@@ -22,4 +22,4 @@
!! bye
(assert (string=? output "hi\nfoo\nbaz\nbye\n"))
-(assert (string=? " ." (with-input-from-string "\x20\u0020\U00000020\056" read-string)))
+(assert (string=? " ." (with-input-from-string "\x20;\u0020\U00000020\056" read-string)))
diff --git a/tests/runtests.bat b/tests/runtests.bat
deleted file mode 100644
index a0b88918..00000000
--- a/tests/runtests.bat
+++ /dev/null
@@ -1,746 +0,0 @@
-@echo off
-@rem runtests.bat - run CHICKEN testsuite on cmd.exe with mingw
-
-setlocal enableextensions
-
-set TEST_DIR=%cd%
-
-set CHICKEN=..\%PROGRAM_PREFIX%chicken%PROGRAM_SUFFIX%
-set CHICKEN_PROFILE=..\%PROGRAM_PREFIX%chicken-profile%PROGRAM_SUFFIX%
-set CHICKEN_INSTALL_REPOSITORY=%TEST_DIR%\test-repository
-set CHICKEN_REPOSITORY_PATH=%TEST_DIR%\..;%CHICKEN_INSTALL_REPOSITORY%
-set PATH=%TEST_DIR%\..;%PATH%
-
-rem Increase this when tests start failing on "inexplicable" diffs
-set FCBUFSIZE=500
-
-set TYPESDB=..\types.db
-set COMPILE_OPTIONS=-v -compiler %CHICKEN% -I%TEST_DIR%/.. -L%TEST_DIR%/.. -include-path %TEST_DIR%/.. -libdir %TEST_DIR%/..
-
-set compile=..\%PROGRAM_PREFIX%csc%PROGRAM_SUFFIX% %COMPILE_OPTIONS% -o a.out -types %TYPESDB% -ignore-repository
-set compile_r=..\%PROGRAM_PREFIX%csc%PROGRAM_SUFFIX% %COMPILE_OPTIONS%
-set compile_s=..\%PROGRAM_PREFIX%csc%PROGRAM_SUFFIX% %COMPILE_OPTIONS% -s -types %TYPESDB% -ignore-repository
-set interpret=..\%PROGRAM_PREFIX%csi%PROGRAM_SUFFIX% -n -include-path %TEST_DIR%/..
-
-del /f /q /s *.exe *.so *.o *.obj *.out *.import.* ..\foo.import.* %CHICKEN_INSTALL_REPOSITORY%
-rmdir /q /s %CHICKEN_INSTALL_REPOSITORY%
-mkdir %CHICKEN_INSTALL_REPOSITORY%
-copy %TYPESDB% %CHICKEN_INSTALL_REPOSITORY%
-
-echo ======================================== repository search path ...
-setlocal
-set "CHICKEN_REPOSITORY_PATH="
-%interpret% -s repository-path-default.scm
-if errorlevel 1 exit /b 1
-endlocal
-%compile_s% sample-module.scm -j sample-module
-if errorlevel 1 exit /b 1
-copy sample-module.so %CHICKEN_INSTALL_REPOSITORY%
-copy sample-module.import.scm %CHICKEN_INSTALL_REPOSITORY%
-%interpret% -s repository-path.scm "%TEST_DIR%\.." "%TEST_DIR%\test-repository"
-if errorlevel 1 exit /b 1
-
-echo ======================================== types.db consistency ...
-%interpret% -s types-db-consistency.scm %TYPESDB%
-if errorlevel 1 exit /b 1
-
-echo ======================================== version tests ...
-%compile% version-tests.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== compiler tests ...
-%compile% compiler-tests.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo "======================================== csc tests ..."
-%interpret% -s csc-tests.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== compiler inlining tests ...
-%compile_r% inline-me.scm -s -J -oi inline-me.inline
-if errorlevel 1 exit /b 1
-%compile% inlining-tests.scm -optimize-level 3
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-%compile% inline-unroll.scm -optimize-level 3
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== compiler message tests ...
-%compile% -analyze-only messages-test.scm 2>messages.out
-if errorlevel 1 exit /b 1
-fc /lb%FCBUFSIZE% /w messages.expected messages.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== optimizer tests ...
-%compile% clustering-tests.scm -clustering
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-%compile% rest-arg-tests.scm -specialize
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== profiler tests ...
-%compile% null.scm -profile -profile-name TEST.profile
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-%CHICKEN_PROFILE% TEST.profile
-if errorlevel 1 exit /b 1
-
-echo ======================================== scrutiny tests ...
-%compile% scrutinizer-tests.scm -analyze-only
-%compile% typematch-tests.scm -specialize -w
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-%compile% test-scrutinizer-message-format.scm -analyze-only -specialize 2>scrutinizer-message-format.out
-rem this is expected to fail, so no errorlevel check
-%compile% scrutiny-tests.scm -analyze-only -specialize 2>scrutiny.out
-if errorlevel 1 exit /b 1
-%compile% scrutiny-tests-2.scm -analyze-only -specialize 2>scrutiny-2.out
-if errorlevel 1 exit /b 1
-%compile% specialization-tests.scm -analyze-only -specialize 2>specialization.out
-if errorlevel 1 exit /b 1
-
-rem Replace foo123 -> fooXX so gensyms don't trigger failures
-%compile% redact-gensyms.scm -o redact-gensyms
-if errorlevel 1 exit /b 1
-redact-gensyms "tmp,g,scm:,a,b" < scrutinizer-message-format.out > scrutinizer-message-format.redacted
-if errorlevel 1 exit /b 1
-redact-gensyms < scrutiny-2.out > scrutiny-2.redacted
-if errorlevel 1 exit /b 1
-redact-gensyms < scrutiny.out > scrutiny.redacted
-if errorlevel 1 exit /b 1
-redact-gensyms < specialization.out > specialization.redacted
-if errorlevel 1 exit /b 1
-
-fc /lb%FCBUFSIZE% /w scrutinizer-message-format.expected scrutinizer-message-format.redacted
-if errorlevel 1 exit /b 1
-fc /lb%FCBUFSIZE% /w scrutiny.expected scrutiny.redacted
-if errorlevel 1 exit /b 1
-fc /lb%FCBUFSIZE% /w scrutiny-2.expected scrutiny-2.redacted
-if errorlevel 1 exit /b 1
-fc /lb%FCBUFSIZE% /w specialization.expected specialization.redacted
-if errorlevel 1 exit /b 1
-
-%compile% scrutiny-tests-3.scm -specialize -block
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-%compile% scrutiny-tests-strict.scm -strict-types -specialize
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== line number database ...
-%compile% -O3 test-line-numbers.scm 2>test-line-numbers.out
-if errorlevel 1 exit /b 1
-fc /lb%FCBUFSIZE% /w test-line-numbers.expected test-line-numbers.out
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== specialization tests ...
-del /f /q foo.types foo.import.*
-%compile% specialization-test-1.scm -emit-types-file foo.types -specialize -debug ox -emit-import-library foo
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-%compile% specialization-test-2.scm -types foo.types -types specialization-test-2.types -specialize -debug ox
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-del /f /q foo.types foo.import.*
-
-echo ======================================== specialization benchmark ...
-%compile% fft.scm -O2 -local -d0 -disable-interrupts -b -o fft1.out
-if errorlevel 1 exit /b 1
-%compile% fft.scm -O2 -local -specialize -debug x -d0 -disable-interrupts -b -o fft2.out -specialize
-if errorlevel 1 exit /b 1
-echo normal:
-fft1.out 1000 7
-if errorlevel 1 exit /b 1
-echo specialized:
-fft2.out 1000 7
-if errorlevel 1 exit /b 1
-
-echo ======================================== unboxing benchmark ...
-%compile% fft.scm -O2 -local -d0 -disable-interrupts -b -o fft1.out
-if errorlevel 1 exit /b 1
-%compile% fft.scm -O4 -debug x -d0 -disable-interrupts -b -o fft2.out
-if errorlevel 1 exit /b 1
-echo normal:
-fft1.out 1000 7
-if errorlevel 1 exit /b 1
-echo unboxing:
-fft2.out 1000 7
-if errorlevel 1 exit /b 1
-
-echo ======================================== callback tests ...
-%compile% -extend c-id-valid.scm callback-tests.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-a.out twice
-
-if errorlevel 1 (
- echo double-return from callback failed as it should.
-) else (
- echo double-return from callback didn't fail
- exit /b 1
-)
-
-echo ======================================== runtime tests ...
-%interpret% -s apply-test.scm
-if errorlevel 1 exit /b 1
-%compile% apply-test.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-a.out -:A10k
-
-if errorlevel 1 (
- echo apply test with limited temp stack failed as it should.
-) else (
- echo apply test with limited temp stack didn't fail
- exit /b 1
-)
-
-%compile% test-gc-hooks.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== library tests ...
-%interpret% -s library-tests.scm
-if errorlevel 1 exit /b 1
-%compile% -specialize library-tests.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-%interpret% -s records-and-setters-test.scm
-if errorlevel 1 exit /b 1
-%compile% records-and-setters-test.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-%interpret% -s record-printer-test.scm
-if errorlevel 1 exit /b 1
-%compile% record-printer-test.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== reader tests ...
-%interpret% -s reader-tests.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== dynamic-wind tests ...
-%interpret% -s dwindtst.scm >dwindtst.out
-if errorlevel 1 exit /b 1
-fc /lb%FCBUFSIZE% /w dwindtst.expected dwindtst.out
-if errorlevel 1 exit /b 1
-%compile% dwindtst.scm
-if errorlevel 1 exit /b 1
-a.out >dwindtst.out
-if errorlevel 1 exit /b 1
-fc /lb%FCBUFSIZE% /w dwindtst.expected dwindtst.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== lolevel tests ...
-%interpret% -s lolevel-tests.scm
-if errorlevel 1 exit /b 1
-%compile% lolevel-tests.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== arithmetic tests ...
-%interpret% -D check -s arithmetic-test.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== pretty-printer tests ...
-%interpret% -s pp-test.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== evaluation environment tests ...
-%interpret% -s environment-tests.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== syntax tests ...
-%interpret% -s syntax-tests.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== syntax tests (compiled) ...
-%compile% syntax-tests.scm
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== syntax tests (v2, compiled) ...
-%compile% syntax-tests-2.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== meta-syntax tests ...
-%interpret% -bnq meta-syntax-test.scm -e "(import foo)" -e "(assert (equal? '((1)) (bar 1 2)))" -e "(assert (equal? '(list 1 2 3) (listify)))" -e "(import test-import-syntax-for-syntax)" -e "(assert (equal? '(1) (test)))" -e "(import test-begin-for-syntax)" -e "(assert (equal? '(1) (test)))"
-if errorlevel 1 exit /b 1
-%compile_s% meta-syntax-test.scm -j foo
-if errorlevel 1 exit /b 1
-%compile_s% foo.import.scm
-if errorlevel 1 exit /b 1
-%interpret% -bnq meta-syntax-test.scm -e "(require-library meta-syntax-test)" -e "(import foo)" -e "(assert (equal? '((1)) (bar 1 2)))" -e "(assert (equal? '(list 1 2 3) (listify)))" -e "(import test-import-syntax-for-syntax)" -e "(assert (equal? '(1) (test)))" -e "(import test-begin-for-syntax)" -e "(assert (equal? '(1) (test)))"
-if errorlevel 1 exit /b 1
-
-echo ======================================== reexport tests ...
-%interpret% -bnq reexport-tests.scm
-if errorlevel 1 exit /b 1
-%compile% reexport-tests.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-del /f /q reexport-m*.import*
-%compile_s% reexport-m1.scm -J
-if errorlevel 1 exit /b 1
-%compile_s% reexport-m1.import.scm
-if errorlevel 1 exit /b 1
-%interpret% -s reexport-m2.scm
-if errorlevel 1 exit /b 1
-%compile% reexport-m2.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-%compile_s% reexport-m3.scm -J
-if errorlevel 1 exit /b 1
-%compile_s% reexport-m4.scm -J
-if errorlevel 1 exit /b 1
-%compile_s% reexport-m5.scm -J
-if errorlevel 1 exit /b 1
-%compile_s% reexport-m6.scm -J
-if errorlevel 1 exit /b 1
-%compile_s% reexport-m7.scm -J
-if errorlevel 1 exit /b 1
-%compile_s% reexport-m8.scm -J
-if errorlevel 1 exit /b 1
-%compile_s% reexport-m9.scm -J
-if errorlevel 1 exit /b 1
-%compile_s% reexport-m10.scm -J
-if errorlevel 1 exit /b 1
-%compile% reexport-tests-2.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-
-echo ======================================== functor tests ...
-%interpret% -bnq simple-functors-test.scm
-if errorlevel 1 exit /b 1
-%compile% simple-functors-test.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-%interpret% -bnq functor-tests.scm
-if errorlevel 1 exit /b 1
-%compile% functor-tests.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-%compile% -s square-functor.scm -J
-if errorlevel 1 exit /b 1
-%compile% -s square-functor.import.scm
-if errorlevel 1 exit /b 1
-%interpret% -bnq use-square-functor.scm
-if errorlevel 1 exit /b 1
-%compile% use-square-functor.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-%compile% -s use-square-functor.scm -J
-if errorlevel 1 exit /b 1
-%interpret% -nqe "(require-library use-square-functor)" -e "(import sf1)" -e "(import sf2)"
-if errorlevel 1 exit /b 1
-del /f /q sf1.import.* sf2.import.* lst.import.* mod.import.*
-
-echo ======================================== compiler syntax tests ...
-%compile% compiler-syntax-tests.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== import tests ...
-%interpret% -bnq import-tests.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== import library tests ...
-del /f /q ..\foo.import.* foo.import.*
-%compile% import-library-test1.scm -emit-import-library foo
-if errorlevel 1 exit /b 1
-%interpret% -s import-library-test2.scm
-if errorlevel 1 exit /b 1
-%compile_s% foo.import.scm -o foo.import.so
-if errorlevel 1 exit /b 1
-%interpret% -s import-library-test2.scm
-if errorlevel 1 exit /b 1
-%compile% import-library-test2.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-del /f /q foo.import.*
-
-echo ======================================== optionals test ...
-%interpret% -s test-optional.scm
-if errorlevel 1 exit /b 1
-%compile% test-optional.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== syntax tests (matchable) ...
-%interpret% matchable.scm -s match-test.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== syntax tests (loopy-loop) ...
-%interpret% -s loopy-test.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== r4rstest ...
-echo (expect mult-float-print-test to fail)
-%interpret% -e "(set! ##sys#procedure->string (constantly \"#<procedure>\"))" -i -s r4rstest.scm >r4rstest.out
-if errorlevel 1 exit /b 1
-
-type r4rstest.out
-
-echo ======================================== syntax tests (r5rs_pitfalls) ...
-echo (expect two failures)
-%interpret% -i -s r5rs_pitfalls.scm
-if errorlevel 1 exit /b 1
-
-echo "======================================== r7rs tests ..."
-echo (expect two failures)
-%interpret% -i -s r7rs-tests.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== module tests ...
-%interpret% -include-path %TEST_DIR%/.. -s module-tests.scm
-if errorlevel 1 exit /b 1
-%interpret% -include-path %TEST_DIR%/.. -s module-tests-2.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== module tests (command line options) ...
-set module="test"
-%compile% test.scm -w -A -j %module% -module %module%
-if errorlevel 1 exit /b 1
-%interpret% -e "(import-syntax %module%)"
-if errorlevel 1 exit /b 1
-del /f /q %module%.import.scm
-
-echo ======================================== module tests (compiled) ...
-%compile% module-tests-compiled.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-%compile% module-static-eval-compiled.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-%compile% -static module-static-eval-compiled.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== module tests (chained) ...
-del /f /q m*.import.* test-chained-modules.so
-%interpret% -bnq test-chained-modules.scm
-if errorlevel 1 exit /b 1
-%compile_s% test-chained-modules.scm -j m3
-if errorlevel 1 exit /b 1
-%compile_s% m3.import.scm
-if errorlevel 1 exit /b 1
-%interpret% -bn test-chained-modules.so
-if errorlevel 1 exit /b 1
-%interpret% -bn test-chained-modules.so -e "(import m3) (s3)"
-if errorlevel 1 exit /b 1
-
-echo ======================================== module tests (ec) ...
-del /f /q ec.so ec.import.*
-%interpret% -bqn ec.scm ec-tests.scm
-if errorlevel 1 exit /b 1
-%compile_s% ec.scm -emit-import-library ec -o ec.so
-if errorlevel 1 exit /b 1
-%compile_s% ec.import.scm -o ec.import.so
-if errorlevel 1 exit /b 1
-%interpret% -bnq ec.so ec-tests.scm
-rem %compile% ec-tests.scm
-rem a.out # takes ages to compile
-
-echo ======================================== module tests (static link) ...
-%compile_r% -static -unit sample-module -J -c sample-module.scm -o sample-module.obj
-if errorlevel 1 exit /b 1
-move sample-module.link %CHICKEN_INSTALL_REPOSITORY%
-move sample-module.import.scm %CHICKEN_INSTALL_REPOSITORY%
-move sample-module.obj %CHICKEN_INSTALL_REPOSITORY%
-%compile_r% -static module-static-link.scm -o a.out
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== port tests ...
-%interpret% -s port-tests.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== read-lines tests ...
-%interpret% -s read-lines-tests.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== fixnum tests ...
-%compile% fixnum-tests.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-%compile% -unsafe fixnum-tests.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo"======================================== random number tests ...
-%interpret% -s random-tests.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== string-^>number tests ...
-%interpret% -s numbers-string-conversion-tests.scm
-if errorlevel 1 exit /b 1
-%compile% -specialize numbers-string-conversion-tests.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== basic numeric ops tests ...
-%interpret% -s numbers-test.scm
-if errorlevel 1 exit /b 1
-%compile% -specialize numbers-test.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== Alex Shinns numeric ops tests ...
-%interpret% -s numbers-test-ashinn.scm
-if errorlevel 1 exit /b 1
-%compile% -specialize numbers-test-ashinn.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== Gauche numeric ops tests ...
-%interpret% -s numbers-test-gauche.scm
-if errorlevel 1 exit /b 1
-%compile% -specialize numbers-test-gauche.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== srfi-4 tests ...
-%interpret% -s srfi-4-tests.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== condition tests ...
-%interpret% -s condition-tests.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== data-structures tests ...
-%interpret% -s data-structures-tests.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== path tests ...
-%interpret% -bnq path-tests.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== srfi-45 tests ...
-%interpret% -s srfi-45-tests.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== posix tests ...
-%compile% posix-tests.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== file access tests ...
-%interpret% -s file-access-tests.scm /
-if errorlevel 1 exit /b 1
-%interpret% -s file-access-tests.scm \
-if errorlevel 1 exit /b 1
-
-echo ======================================== find-files tests ...
-%interpret% -bnq test-find-files.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== create-temporary-file tests ...
-echo == SKIPPED due to problematic unsetenv behaviour on Windows ==
-@rem %interpret% -bnq test-create-temporary-file.scm
-@rem if errorlevel 1 exit /b 1
-
-echo ======================================== record-renaming tests ...
-%interpret% -bnq record-rename-test.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== regular expression tests ...
-%interpret% -bnq test-irregex.scm
-if errorlevel 1 exit /b 1
-%interpret% -bnq test-glob.scm
-if errorlevel 1 exit /b 1
-
-echo ======================================== compiler/nursery stress test ...
-for %%s in (100000 120000 200000 250000 300000 350000 400000 450000 500000) do (
- echo %%s
- %CHICKEN% -ignore-repository ..\port.scm -:s%%s -output-file tmp.c -include-path %TEST_DIR%/..
- if errorlevel 1 exit /b 1
-)
-
-echo ======================================== heap literal stress test ...
-%compile% heap-literal-stress-test.scm
-if errorlevel 1 exit /b 1
-
-for %%s in (100000 120000 200000 250000 300000 350000 400000 450000 500000) do (
- echo %%s
- a.out -:hi%%s
- if errorlevel 1 exit /b 1
-)
-
-echo ======================================== weak pointer test ...
-%compile% weak-pointer-test.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== symbol-GC tests ...
-%compile% symbolgc-tests.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== finalizer tests ...
-%interpret% -s test-finalizers.scm
-if errorlevel 1 exit /b 1
-%compile% test-finalizers.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== finalizer tests (2) ...
-%compile% finalizer-error-test.scm
-if errorlevel 1 exit /b 1
-a.out -:hg101
-if errorlevel 1 exit /b 1
-%compile% test-finalizers-2.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== locative stress test ...
-%compile% locative-stress-test.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== syntax-rules stress test ...
-%interpret% -bnq syntax-rule-stress-test.scm
-
-echo "======================================== include test ..."
-mkdir a\b
-echo > a\b\ok.scm
-echo '(include "a/b/ok.scm")' > a\b\include.scm
-%compile% -analyze-only a\b\include.scm
-if errorlevel 1 exit /b 1
-echo '(include "b/ok.scm")' > a\b\include.scm
-%compile% -analyze-only a\b\include.scm -include-path a
-if errorlevel 1 exit /b 1
-echo '(include-relative "ok.scm")' > a\b\include.scm
-%compile% -analyze-only a\b\include.scm
-if errorlevel 1 exit /b 1
-echo '(include-relative "b/ok.scm")' > a\include.scm
-%compile% -analyze-only a\include.scm
-if errorlevel 1 exit /b 1
-echo '(include-relative "b/ok.scm")' > a\b\include.scm
-%compile% -analyze-only a\b\include.scm -include-path a
-if errorlevel 1 exit /b 1
-del /f /s /q a
-
-echo "======================================== executable tests ..."
-%compile% executable-tests.scm
-if errorlevel 1 exit /b 1
-a.out %TEST_DIR%\a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== embedding (1) ...
-%compile% embedded1.c
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== embedding (2) ...
-%compile% -e embedded2.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== embedding (3) ...
-%compile% -e embedded3.c embedded4.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== linking tests ...
-%compile_r% -unit reverser reverser\tags\1.0\reverser.scm -J -c -o reverser.obj
-%compile_r% -link reverser linking-tests.scm -o a.out
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-%compile_r% -link reverser linking-tests.scm -o a.out -static
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-move reverser.obj %CHICKEN_INSTALL_REPOSITORY%
-move reverser.import.scm %CHICKEN_INSTALL_REPOSITORY%
-%compile_r% -link reverser linking-tests.scm -o a.out
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-%compile_r% -link reverser linking-tests.scm -o a.out -static
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-echo ======================================== private repository test ...
-del /f /s /q tmp
-mkdir tmp
-%compile% private-repository-test.scm -private-repository -o tmp\xxx
-if errorlevel 1 exit /b 1
-tmp\xxx %CD%\tmp
-set PATH=%CD%\tmp;%PATH% xxx %CD%\tmp
-rem this may crash, if the PATH contains a non-matching libchicken.dll on Windows:
-set PATH=%PATH%;%CD%\tmp xxx %CD%\tmp
-
-echo ======================================== multiple return values tests ...
-%interpret% -s multiple-values.scm
-if errorlevel 1 exit /b 1
-%compile% multiple-values.scm
-if errorlevel 1 exit /b 1
-a.out
-if errorlevel 1 exit /b 1
-
-rem echo ======================================== reinstall tests
-rem currently disabled for windows
-
-echo ======================================== done. All tests passed.
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 0e6bbd36..5981b76c 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -5,13 +5,13 @@
# (just the compiler and the Windows shell, without MSYS)
set -e
+if [ $(uname) = Windows_NT ]; then
+ MSYSTEM=1
+fi
+TEST_DIR=`pwd`
if test -z "$MSYSTEM"; then
- TEST_DIR=`pwd`
PATH_SEP=':'
else
- # Use Windows-native format with drive letters instead of awkward
- # MSYS /c/blabla "pseudo-paths" which break when used in syscalls.
- TEST_DIR=`pwd -W`
PATH_SEP=';'
fi
@@ -21,7 +21,7 @@ LIBRARY_PATH=${TEST_DIR}/..:${LIBRARY_PATH}
# Cygwin uses LD_LIBRARY_PATH for dlopen(), but the dlls linked into
# the binary are read by the OS itself, which uses $PATH (mingw too)
# Oddly, prefixing .. with ${TEST_DIR}/ does _not_ work on mingw!
-PATH=..:${PATH}
+PATH=..${PATH_SEP}${PATH}
export DYLD_LIBRARY_PATH LD_LIBRARY_PATH LIBRARY_PATH PATH
@@ -87,6 +87,10 @@ echo "======================================== compiler tests ..."
$compile compiler-tests.scm
./a.out
+echo "======================================== FFI tests ..."
+$compile ffi-tests.scm
+./a.out
+
echo "======================================== csc tests ..."
$interpret -s csc-tests.scm
@@ -207,6 +211,13 @@ $interpret -s record-printer-test.scm
$compile record-printer-test.scm
./a.out
+echo "======================================== unicode tests ..."
+$interpret -s unicode-tests.scm
+$compile -specialize unicode-tests.scm
+./a.out
+$interpret -s invalid-utf-test.scm
+$interpret -s file-encoding-test.scm
+
echo "======================================== reader tests ..."
$interpret -s reader-tests.scm
@@ -325,7 +336,9 @@ echo "(expect two failures)"
$interpret -i -s r5rs_pitfalls.scm
echo "======================================== r7rs tests ..."
-$interpret -i -s r7rs-tests.scm
+$interpret -s r7rs-tests.scm
+$interpret -s r7rs-tests-2.scm
+$interpret -s life.scm
echo "======================================== module tests ..."
$interpret -include-path ${TEST_DIR}/.. -s module-tests.scm
@@ -357,7 +370,7 @@ 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
+$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
@@ -433,13 +446,6 @@ fi
echo "======================================== find-files tests ..."
$interpret -bnq test-find-files.scm
-echo "======================================== create-temporary-file tests ..."
-if test -z "$MSYSTEM"; then
- echo "== SKIPPED due to problematic unsetenv behaviour on Windows =="
-else
- $interpret -bnq test-create-temporary-file.scm
-fi
-
echo "======================================== record-renaming tests ..."
$interpret -bnq record-rename-test.scm
@@ -545,7 +551,7 @@ echo "======================================== private repository test ..."
mkdir -p tmp
$compile private-repository-test.scm -private-repository -o tmp/xxx
tmp/xxx ${TEST_DIR}/tmp
-# This MUST be `pwd`: ${PWD} is not portable, and ${TEST_DIR} breaks mingw-msys
+# This MUST be `pwd`: ${PWD} is not portable, and ${TEST_DIR} breaks mingw
PATH=`pwd`/tmp:$PATH xxx ${TEST_DIR}/tmp
# this may crash, if the PATH contains a non-matching libchicken.dll on Windows:
#PATH=$PATH:${TEST_DIR}/tmp xxx ${TEST_DIR}/tmp
diff --git a/tests/scrutiny-tests.scm b/tests/scrutiny-tests.scm
index b0516716..e0ee6cb5 100644
--- a/tests/scrutiny-tests.scm
+++ b/tests/scrutiny-tests.scm
@@ -117,14 +117,14 @@
; - assignment inside first conditional does not invalidate blist
;; entries for "ins"/"del" in outer flow.
-(define (write-blob-to-sql sql identifier last blob c-c)
+(define (write-bytevector-to-sql sql identifier last bytevector c-c)
(define ins '())
(define del '())
- (if (vector? blob)
+ (if (vector? bytevector)
(begin
- (set! ins (vector-ref blob 1))
- (set! del (vector-ref blob 2))
- (set! blob (vector-ref blob 0))))
+ (set! ins (vector-ref bytevector 1))
+ (set! del (vector-ref bytevector 2))
+ (set! bytevector (vector-ref bytevector 0))))
(if (or (pair? ins)
(pair? del))
(<handle-ins-and-del>))
@@ -322,3 +322,4 @@
(compiler-typecase (list 2 'a)
((forall (x) (list x x)) 1)
(else #t))
+
diff --git a/tests/specialization-tests.scm b/tests/specialization-tests.scm
index 01832167..87df3e9a 100644
--- a/tests/specialization-tests.scm
+++ b/tests/specialization-tests.scm
@@ -5,6 +5,8 @@
;; bidirectional ports are specialized
+(import (only (scheme base) open-input-string))
+
(let ((p (open-input-string "foo")))
(when (output-port? p) ; indicates `p' is bidirectional
(if (input-port? p) 'ok 'no)
diff --git a/tests/srfi-4-tests.scm b/tests/srfi-4-tests.scm
index 9fa498fc..0675bd81 100644
--- a/tests/srfi-4-tests.scm
+++ b/tests/srfi-4-tests.scm
@@ -1,7 +1,7 @@
;;;; srfi-4-tests.scm
-(import (srfi 4) (chicken port))
+(import (chicken number-vector) (chicken port))
(import-for-syntax (chicken base))
(define-syntax test1
@@ -93,62 +93,6 @@
(assert (equal? #f32(1 2 3) '#f32(1 2 3)))
(assert (equal? #f64(-1 2 3) '#f64(-1 2 3)))
-;; Ticket #1124: read-u8vector! w/o length, dest smaller than source.
-(let ((input (open-input-string "abcdefghijklmnopqrstuvwxyz"))
- (u8vec (make-u8vector 10)))
- (assert (= 10 (read-u8vector! #f u8vec input)))
- (assert (equal? u8vec #u8(97 98 99 100 101 102 103 104 105 106)))
- (assert (= 5 (read-u8vector! #f u8vec input 5)))
- (assert (equal? u8vec #u8(97 98 99 100 101 107 108 109 110 111)))
- (assert (= 5 (read-u8vector! 5 u8vec input)))
- (assert (equal? u8vec #u8(112 113 114 115 116 107 108 109 110 111)))
- (assert (= 6 (read-u8vector! 10 u8vec input)))
- (assert (equal? u8vec #u8(117 118 119 120 121 122 108 109 110 111))))
-
-(let ((input (open-input-string "abcdefghijklmnopqrs")))
- (assert (equal? (read-u8vector 5 input)
- #u8(97 98 99 100 101)))
- (assert (equal? (read-u8vector 5 input) #u8(102 103 104 105 106)))
- (assert (equal? (read-u8vector #f input)
- #u8(107 108 109 110 111 112 113 114 115)))
- (with-input-from-string "abcdefghijklmnopqrs"
- (lambda ()
- (assert (equal? (read-u8vector 5)
- #u8(97 98 99 100 101)))
- (assert (equal? (read-u8vector 5) #u8(102 103 104 105 106)))
- (assert (equal? (read-u8vector)
- #u8(107 108 109 110 111 112 113 114 115))))))
-
-(assert (string=?
- "abc"
- (with-output-to-string
- (lambda ()
- (write-u8vector #u8(97 98 99))))))
-
-(assert (string=?
- "bc"
- (with-output-to-string
- (lambda ()
- (write-u8vector #u8(97 98 99) (current-output-port) 1)))))
-
-(assert (string=?
- "a"
- (with-output-to-string
- (lambda ()
- (write-u8vector #u8(97 98 99) (current-output-port) 0 1)))))
-
-(assert (string=?
- "b"
- (with-output-to-string
- (lambda ()
- (write-u8vector #u8(97 98 99) (current-output-port) 1 2)))))
-
-(assert (string=?
- ""
- (with-output-to-string
- (lambda ()
- (write-u8vector #u8())))))
-
; make sure the N parameter is a fixnum
(assert
(handle-exceptions exn #t
diff --git a/tests/syntax-tests.scm b/tests/syntax-tests.scm
index 336707eb..ef5d4086 100644
--- a/tests/syntax-tests.scm
+++ b/tests/syntax-tests.scm
@@ -2,6 +2,7 @@
(import-for-syntax chicken.pretty-print)
(import chicken.gc chicken.pretty-print chicken.port)
+(import (only (scheme base) call/cc))
(define-syntax t
(syntax-rules ()
@@ -44,14 +45,14 @@
;; some basic contrived testing
(define (fac n)
- (let-syntax ((m1
+ (let-syntax ((m1
(er-macro-transformer
- (lambda (n r c)
+ (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)
+ #;(print "fac: " n)
(if (test n (zero? n))
1
(* n (fac (m1 n))))))
@@ -113,7 +114,7 @@
(let ((x 'outer))
(let-syntax ((m (syntax-rules () ((m) x))))
(let ((x 'inner))
- (m))))
+ (m))))
)
(t 7
@@ -227,10 +228,10 @@
;;; strip-syntax cuts across multiple levels of syntax
;;; reported by Matthew Flatt
-(define-syntax c
- (syntax-rules ()
- [(_)
- (let ([x 10])
+(define-syntax c
+ (syntax-rules ()
+ [(_)
+ (let ([x 10])
(let-syntax ([z (syntax-rules ()
[(_) (quote x)])])
(z)))]))
@@ -298,8 +299,8 @@
;;; alternative ellipsis test (SRFI-46)
(define-syntax foo
- (syntax-rules
- ___ ()
+ (syntax-rules
+ ___ ()
((_ vals ___) (list '... vals ___))))
(t '(... 1 2 3)
@@ -371,7 +372,7 @@
(define-syntax usetmp
(syntax-rules ()
- ((_ var)
+ ((_ var)
(list var))))
(define-syntax withtmp
@@ -424,7 +425,7 @@
(let ((n 10))
(loop
- (print* n " ")
+ (print* n " ")
(set! n (sub1 n))
(when (zero? n) (exit #f)))
(newline))
@@ -432,7 +433,7 @@
(define-syntax while0
(syntax-rules ()
((_ t b ...)
- (loop (if (not t) (exit #f))
+ (loop (if (not t) (exit #f))
b ...))))
(f (while0 #f (print "no.")))
@@ -440,7 +441,7 @@
(define-syntax while
(er-macro-transformer
(lambda (x r c)
- `(,(r 'loop)
+ `(,(r 'loop)
(,(r 'if) (,(r 'not) ,(cadr x)) (exit #f))
,@(cddr x)))))
@@ -561,7 +562,7 @@
(import scheme (prefix (chicken base) c:) (prefix (chicken condition) c:))
(c:define-values (a b c) (values 1 2 3))
(c:print "ok")
- (c:condition-case
+ (c:condition-case
(c:abort "ugh")
(ex () (c:print "caught"))))
@@ -606,7 +607,7 @@
(er-macro-transformer
(lambda (x r c)
(r `(vector (s1 ,(cadr x))))))) ) ; without renaming the local version of `s1'
- ; below will be captured
+ ; below will be captured
(import m1)
@@ -625,7 +626,7 @@
(let ((n 10))
(loop2
- (print* n " ")
+ (print* n " ")
(set! n (sub1 n))
(when (zero? n) (exit #f)))
(newline))
@@ -633,7 +634,7 @@
(define-syntax while20
(syntax-rules ()
((_ t b ...)
- (loop2 (if (not t) (exit #f))
+ (loop2 (if (not t) (exit #f))
b ...))))
(f (while20 #f (print "no.")))
@@ -641,7 +642,7 @@
(define-syntax while2
(ir-macro-transformer
(lambda (x i c)
- `(loop
+ `(loop
(if (not ,(cadr x)) (,(i 'exit) #f))
,@(cddr x)))))
@@ -661,7 +662,7 @@
(ir-macro-transformer
(lambda (x r c)
`(vector (s3 ,(cadr x)))))) ) ; without implicit renaming the local version
- ; of `s3' below would be captured
+ ; of `s3' below would be captured
(import m2)
@@ -1085,7 +1086,7 @@
;; The following are explicitly left undefined by R5RS. For consistency
;; we define any unquote-(splicing) or quasiquote that occurs in the CAR of
;; a pair to decrease, respectively increase the level count by one.
-
+
(t '(quasiquote . #(1 (unquote x) 3)) ; cdr is not a pair
(quasiquote (quasiquote . #(1 (unquote x) 3))))
(t '(quasiquote #(1 (unquote x) 3)) ; cdr is a list of one
@@ -1177,7 +1178,7 @@ other-eval
;; #805: case-lambda is unhygienic (see 4706afb4 and bc5cc698)
(module case-lambda-and-ensure-hygiene ()
- (import (prefix (chicken base) c/) (prefix scheme s/))
+ (import (prefix (scheme case-lambda) c/) (prefix scheme s/))
(c/case-lambda ((a) a)))
@@ -1294,7 +1295,7 @@ other-eval
tmp)))
(bar #f)))
-;; Deeper issue uncovered by fixing the above issue
+;; Deeper issue uncovered by fixing the above issue
(t 1 (letrec ((bar (lambda (x) (if x 1 (bar bar)))))
(bar #f)))
@@ -1358,3 +1359,47 @@ other-eval
(define begin -)
(assert (eq? -1 (begin 0 1)))
+
+;; #1736 - dotted pairs after ellipsis
+
+(define-syntax match-ellipsis-and-dotted-tail1
+ (syntax-rules ()
+ ((_ a ... . b)
+ '(a ... b))))
+
+(t '(x y z) (match-ellipsis-and-dotted-tail1 x y . z))
+
+(define-syntax match-ellipsis-and-dotted-tail2
+ (syntax-rules ()
+ ((_ (a) ... . (b))
+ '(a ... b))))
+
+(t '(x y z) (match-ellipsis-and-dotted-tail2 (x) (y) z))
+
+;; from SRFI-46 document:
+(define-syntax fake-begin
+ (syntax-rules ()
+ ((fake-begin ?body ... ?tail)
+ (let* ((ignored ?body) ...) ?tail))))
+
+(t 3 (fake-begin 1 2 3))
+
+;; #1793
+
+(let ([x 'outer])
+ (define-syntax m
+ (syntax-rules ()
+ ((m a)
+ (let ([a 'inner]) x))))
+ (t 'outer (m x)))
+
+; fails with error when compiled ("toplevel def. in non-toplevel context")
+#;(let ([x 'outer])
+ (define-syntax m
+ (syntax-rules ()
+ ((m a)
+ (begin
+ (define a 'inner)
+ x))))
+ (m x)
+ (t 'inner x))
diff --git a/tests/test-create-temporary-file.scm b/tests/test-create-temporary-file.scm
deleted file mode 100644
index 67e664c3..00000000
--- a/tests/test-create-temporary-file.scm
+++ /dev/null
@@ -1,33 +0,0 @@
-(import (chicken file)
- (chicken pathname)
- (chicken process-context))
-
-(define (with-environment-variable var val thunk)
- (let ((old-val (get-environment-variable var)))
- (set-environment-variable! var val)
- (thunk)
- (if old-val
- (set-environment-variable! var old-val)
- (unset-environment-variable! var))))
-
-(let ((tmp (create-temporary-file)))
- (delete-file tmp)
- (assert (pathname-directory tmp)))
-
-;; Assert that changes to the environment variables used by
-;; create-temporary-file and create-temporary-directory get used (see
-;; https://bugs.call-cc.org/ticket/1830).
-;;
-;; Here the use of "" as value of TMPDIR is because
-;; (pathname-directory (make-pathname "" filename)) => #f
-(with-environment-variable "TMPDIR" ""
- (lambda ()
- (let ((tmp (create-temporary-file)))
- (delete-file tmp)
- (assert (not (pathname-directory tmp))))))
-
-(with-environment-variable "TMPDIR" ""
- (lambda ()
- (let ((tmp (create-temporary-directory)))
- (delete-directory tmp)
- (assert (not (pathname-directory tmp))))))
diff --git a/tests/test-gc-hooks.scm b/tests/test-gc-hooks.scm
index ba124335..288ce46d 100644
--- a/tests/test-gc-hooks.scm
+++ b/tests/test-gc-hooks.scm
@@ -13,7 +13,7 @@ gc_start(int mode)
}
static void
-gc_end(int mode, long ms)
+gc_end(int mode, C_long ms)
{
printf("<<<<< GC post hook - mode=%d, count=%d, ms=%ld\n", mode, --count, ms);
}
diff --git a/tests/test-irregex.scm b/tests/test-irregex.scm
index 8c0464ad..fc30ef12 100644
--- a/tests/test-irregex.scm
+++ b/tests/test-irregex.scm
@@ -6,6 +6,8 @@
chicken.format chicken.io chicken.irregex chicken.port)
(include "test.scm")
+
+(import (only (scheme base) open-output-string get-output-string open-input-string))
(define (cat . args)
(let ((out (open-output-string)))
diff --git a/tests/test.scm b/tests/test.scm
index 5434e751..35251234 100644
--- a/tests/test.scm
+++ b/tests/test.scm
@@ -4,6 +4,7 @@
(import (only chicken.string ->string))
(import (only chicken.time current-process-milliseconds))
+(import (only (scheme base) make-parameter))
(define *current-group-name* "")
(define *pass* 0)
diff --git a/tests/typematch-tests.scm b/tests/typematch-tests.scm
index 42a97ac9..adc14f17 100644
--- a/tests/typematch-tests.scm
+++ b/tests/typematch-tests.scm
@@ -1,7 +1,8 @@
;;;; typematch-tests.scm
-(import chicken.blob chicken.condition chicken.memory chicken.locative)
+(import chicken.bytevector chicken.condition chicken.memory chicken.locative)
+(import (only (scheme base) port? open-output-string open-input-string get-output-string))
(include "test.scm")
@@ -169,7 +170,7 @@
(check null '() 1)
(check port (current-input-port) 1.2)
(check input-port (current-input-port) 1.2)
-(check blob (make-blob 10) 1.2)
+(check bytevector (make-bytevector 10) 1.2)
(check pointer (address->pointer 0) 1.2)
(check pointer-vector (make-pointer-vector 1) 1.2)
(check locative (make-locative "a") 1.2)
@@ -191,7 +192,7 @@
(ms '() 1 null)
(ms (void) 1.2 undefined)
(ms (current-input-port) 1.2 input-port)
-(ms (make-blob 10) 1.2 blob)
+(ms (make-bytevector 10) 1.2 bytevector)
(ms (address->pointer 0) 1.2 pointer)
(ms (make-pointer-vector 1) 1.2 pointer-vector)
(ms (make-locative "a") 1.2 locative)
@@ -222,7 +223,7 @@
(checkp string? string "a")
(checkp vector? vector '#())
(checkp procedure? procedure +)
-(checkp blob? blob (make-blob 1))
+(checkp bytevector? bytevector (make-bytevector 1))
(checkp condition? (struct condition) (##sys#make-structure 'condition))
(checkp fixnum? fixnum 1)
(checkp flonum? float 1.2)
@@ -451,3 +452,4 @@
(infer fixnum (unconverted)))
(test-exit)
+
diff --git a/tests/types-db-consistency.scm b/tests/types-db-consistency.scm
index 0f637694..a7e391ed 100644
--- a/tests/types-db-consistency.scm
+++ b/tests/types-db-consistency.scm
@@ -8,11 +8,13 @@
(chicken irregex)
(chicken memory)
(chicken port)
+ (chicken io)
(chicken format)
(chicken process-context)
(chicken process-context posix)
(chicken tcp)
- srfi-4)
+ (chicken number-vector)
+ (scheme write))
(define ignored-symbols
'(;; internal procedures
diff --git a/tests/unicode-tests.scm b/tests/unicode-tests.scm
new file mode 100644
index 00000000..2f56d6cd
--- /dev/null
+++ b/tests/unicode-tests.scm
@@ -0,0 +1,165 @@
+;;; unicode tests, taken from Chibi
+
+(import (chicken port) (chicken sort))
+(import (chicken string) (chicken io))
+(import (chicken bytevector))
+(import (only (scheme base) write-string))
+
+(include "test.scm")
+
+(test-begin "scheme")
+
+(test-equal #\Ð (string-ref "РуÑÑкий" 0))
+(test-equal #\и (string-ref "РуÑÑкий" 5))
+(test-equal #\й (string-ref "РуÑÑкий" 6))
+
+(test-equal 7 (string-length "РуÑÑкий"))
+
+(test-equal #\日 (string-ref "日本語" 0))
+(test-equal #\本 (string-ref "日本語" 1))
+(test-equal #\語 (string-ref "日本語" 2))
+
+(test-equal 3 (string-length "日本語"))
+
+(test-equal '(#\日 #\本 #\語) (string->list "日本語"))
+(test-equal "日本語" (list->string '(#\日 #\本 #\語)))
+
+(test-equal "日本" (substring "日本語" 0 2))
+(test-equal "本語" (substring "日本語" 1 3))
+
+(test-equal "日-語"
+ (let ((s (substring "日本語" 0 3)))
+ (string-set! s 1 #\-)
+ s))
+
+(test-equal "日本人"
+ (let ((s (substring "日本語" 0 3)))
+ (string-set! s 2 #\人)
+ s))
+
+(test-equal "å—å—å—" (make-string 3 #\å—))
+
+(test-equal "å—å—å—"
+ (let ((s (make-string 3)))
+ (string-fill! s #\å—)
+ s))
+
+; tests from the utf8 egg:
+
+(test-equal 2 (string-length "æ¼¢å—"))
+
+(test-equal 28450 (char->integer (string-ref "æ¼¢å—" 0)))
+
+(define str (string-copy "æ¼¢å—"))
+
+(test-equal "赤å—" (begin (string-set! str 0 (string-ref "赤" 0)) str))
+
+(test-equal "赤外" (begin (string-set! str 1 (string-ref "外" 0)) str))
+
+(test-equal "赤x" (begin (string-set! str 1 #\x) str))
+
+(test-equal "赤々" (begin (string-set! str 1 (string-ref "々" 0)) str))
+
+(test-equal "æ–‡å—列" (substring "æ–‡å—列" 0))
+(test-equal "å—列" (substring "æ–‡å—列" 1))
+(test-equal "列" (substring "æ–‡å—列" 2))
+(test-equal "æ–‡" (substring "æ–‡å—列" 0 1))
+(test-equal "å—" (substring "æ–‡å—列" 1 2))
+(test-equal "æ–‡å—" (substring "æ–‡å—列" 0 2))
+
+(define *string* "æ–‡å—列")
+(define *list* '("æ–‡" "å—" "列"))
+(define *chars* '(25991 23383 21015))
+
+(test-equal *chars* (map char->integer (string->list "æ–‡å—列")))
+
+(test-equal *list* (map string (map integer->char *chars*)))
+
+(test-equal *string* (list->string (map integer->char '(25991 23383 21015))))
+
+(test-equal "列列列" (make-string 3 (string-ref "列" 0)))
+
+(test-equal "文文文" (let ((s (string-copy "abc"))) (string-fill! s (string-ref "文" 0)) s))
+
+(test-equal (string-ref "ﾊ" 0) (with-input-from-string "全角ﾊï¾ï½¶ï½¸"
+ (lambda () (read-char) (read-char) (read-char))))
+
+(test-equal "個々" (with-output-to-string
+ (lambda ()
+ (write-char (string-ref "個" 0))
+ (write-char (string-ref "々" 0)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; library
+
+(test-equal "出力改行\n" (with-output-to-string
+ (lambda () (print "出" (string-ref "力" 0) "改行"))))
+
+(test-equal "出力" (with-output-to-string
+ (lambda () (print* "出" (string-ref "力" 0) ""))))
+
+(test-equal "逆リスト→文å—列" (reverse-list->string
+ (map (cut string-ref <> 0)
+ '("列" "å—" "æ–‡" "→" "ト" "ス" "リ" "逆"))))
+
+(test-error (utf8->string #u8(255 1 2)))
+(test-assert (utf8->string #u8(255 1 2) #f))
+(test-equal (string-length (utf8->string #u8(255 1 2) #f)) 3)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; extras
+
+(test-equal "这是" (with-input-from-string "这是ä¸æ–‡" (cut read-string 2)))
+
+(define s "abcdef")
+(call-with-input-string "这是ä¸æ–‡" (cut read-string! 2 s <> 2))
+(test-equal "ab这是ef" s)
+
+(define s "这是ä¸æ–‡")
+(call-with-input-string "abcd" (cut read-string! 1 s <> 2))
+(test-equal "这是a文" s)
+
+(test-equal "这是" (with-output-to-string (cut write-string "这是ä¸æ–‡" (current-output-port) 0 2)))
+
+(test-equal "我爱她" (conc (with-input-from-string "æˆ‘çˆ±ä½ "
+ (cut read-token (lambda (c)
+ (memv c (map (cut string-ref <> 0)
+ '("爱" "您" "我"))))))
+ "她"))
+
+(test-equal '("第一" "第二" "第三") (string-chop "第一第二第三" 2))
+
+(test-equal '("第一" "第二" "第三" "…") (string-chop "第一第二第三…" 2))
+
+(test-equal '("a" "bc" "第" "få‡ ") (string-split "a,bcã€ç¬¬,få‡ " ",ã€"))
+
+(test-equal "THE QUICK BROWN FOX JUMPED OVER THE LAZY SLEEPING DOG"
+ (string-translate "the quick brown fox jumped over the lazy sleeping dog"
+ "abcdefghijklmnopqrstuvwxyz"
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
+(test-equal ":foo:bar:baz" (string-translate "/foo/bar/baz" "/" ":"))
+(test-equal "ä½ çˆ±æˆ‘" (string-translate "æˆ‘çˆ±ä½ " "æˆ‘ä½ " "ä½ æˆ‘"))
+(test-equal "ä½ çˆ±æˆ‘" (string-translate "æˆ‘çˆ±ä½ " '(#\我 #\ä½ ) '(#\ä½ #\我)))
+(test-equal "æˆ‘ä½ " (string-translate "æˆ‘çˆ±ä½ " "爱"))
+(test-equal "æˆ‘ä½ " (string-translate "æˆ‘çˆ±ä½ " #\爱))
+
+(test-assert (substring=? "日本語" "日本語"))
+(test-assert (substring=? "日本語" "日本"))
+(test-assert (substring=? "日本" "日本語"))
+(test-assert (substring=? "日本語" "本語" 1))
+(test-assert (substring=? "日本語" "本" 1 0 1))
+(test-assert (substring=? "å¬è¯´ä¸Šæµ·çš„东西很贵" "上海的东西很便宜" 2 0 5))
+
+(test-equal 2 (substring-index "上海" "å¬è¯´ä¸Šæµ·çš„东西很贵"))
+
+;; case folding
+
+(test-assert (string-ci=? "abc" "ABC"))
+(test-assert (string-ci=? "Xῌηιx" "xηιῌX"))
+(test-assert (string-ci=? "αβξ" "αβξ"))
+(test-assert (string-ci=? "αβξ" "ΑΒΞ"))
+
+(test-end)
+
+(test-exit)
+
diff --git a/tests/version-tests.scm b/tests/version-tests.scm
index 2a786dc8..879fc547 100644
--- a/tests/version-tests.scm
+++ b/tests/version-tests.scm
@@ -1,4 +1,5 @@
-(import chicken.irregex chicken.platform chicken.keyword chicken.string)
+(import chicken.irregex chicken.platform chicken.string)
+(import (only (scheme base) features))
(let* ((version-tokens (string-split (chicken-version) "."))
(major (string->number (car version-tokens)))
@@ -13,7 +14,7 @@
(let loop ((features (features)))
(if (null? features)
(error "Could not find feature chicken-<major>.<minor>")
- (let ((feature (keyword->string (car features))))
+ (let ((feature (symbol->string (car features))))
(cond ((irregex-match "chicken-(\\d+)\\.(\\d+)" feature)
=> (lambda (match)
(assert (= (string->number
@@ -28,7 +29,7 @@
(let loop ((features (features)))
(if (null? features)
(error "Could not find feature chicken-<major>")
- (let ((feature (keyword->string (car features))))
+ (let ((feature (symbol->string (car features))))
(cond ((irregex-match "chicken-(\\d+)" feature)
=> (lambda (match)
(assert (= (string->number
diff --git a/types.db b/types.db
index ed2f9628..5ee90b8f 100644
--- a/types.db
+++ b/types.db
@@ -7,11 +7,11 @@
; conditions are met:
;
; Redistributions of source code must retain the above copyright notice, this list of conditions and the following
-; disclaimer.
+; 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.
+; 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.
+; 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
@@ -193,7 +193,8 @@
(((or symbol keyword procedure immediate) list)
(##core#inline "C_u_i_memq" #(1) #(2))))
-(scheme#member (forall (a b) (#(procedure #:clean #:foldable) scheme#member (a (list-of b))
+(scheme#member (forall (a b) (#(procedure #:clean #:foldable) scheme#member (a (list-of b)
+ #!optional (procedure (a b) *))
(or false (pair a (list-of b)))))
((* null) (let ((#(tmp) #(1))) '#f))
(((or symbol keyword procedure immediate) list)
@@ -217,7 +218,7 @@
(##core#inline "C_u_i_assq" #(1) #(2))))
(scheme#assoc (forall (a b c) (#(procedure #:clean #:foldable) scheme#assoc
- (a (list-of (pair b c)))
+ (a (list-of (pair b c)) #!optional (procedure (a b) *))
(or false (pair a c))))
((* null) (let ((#(tmp) #(1))) '#f))
(((or symbol keyword procedure immediate) (list-of pair))
@@ -534,6 +535,8 @@
(scheme#sqrt (#(procedure #:clean #:enforce #:foldable) scheme#sqrt (number) number)
;; Unfortunately this doesn't work when the argument is negative
#;((float) (float) (##core#inline_allocate ("C_a_i_flonum_sqrt" 4) #(1))))
+(scheme#exact-integer-sqrt (#(procedure #:clean #:enforce #:foldable) scheme#exact-integer-sqrt (integer) integer integer)
+ ((integer) (##sys#exact-integer-sqrt #(1))))
(scheme#sin (#(procedure #:clean #:enforce #:foldable) scheme#sin (number) (or float cplxnum))
((float) (float) (##core#inline_allocate ("C_a_i_flonum_sin" 4) #(1))))
@@ -577,22 +580,22 @@
(scheme#char? (#(procedure #:pure #:predicate char) scheme#char? (*) boolean))
;; safe rewrites are already done by the optimizer
-(scheme#char=? (#(procedure #:clean #:enforce #:foldable) scheme#char=? (char char) boolean)
+(scheme#char=? (#(procedure #:clean #:enforce #:foldable) scheme#char=? (char char #!rest char) boolean)
((char char) (##core#inline "C_u_i_char_equalp" #(1) #(2))))
-(scheme#char>? (#(procedure #:clean #:enforce #:foldable) scheme#char>? (char char) boolean)
+(scheme#char>? (#(procedure #:clean #:enforce #:foldable) scheme#char>? (char char #!rest char) boolean)
((char char) (##core#inline "C_u_i_char_greaterp" #(1) #(2))))
-(scheme#char<? (#(procedure #:clean #:enforce #:foldable) scheme#char<? (char char) boolean)
+(scheme#char<? (#(procedure #:clean #:enforce #:foldable) scheme#char<? (char char #!rest char) boolean)
((char char) (##core#inline "C_u_i_char_lessp" #(1) #(2))))
-(scheme#char>=? (#(procedure #:clean #:enforce #:foldable) scheme#char>=? (char char) boolean)
+(scheme#char>=? (#(procedure #:clean #:enforce #:foldable) scheme#char>=? (char char #!rest char) boolean)
((char char) (##core#inline "C_u_i_char_greater_or_equal_p" #(1) #(2))))
-(scheme#char<=? (#(procedure #:clean #:enforce #:foldable) scheme#char<=? (char char) boolean)
+(scheme#char<=? (#(procedure #:clean #:enforce #:foldable) scheme#char<=? (char char #!rest char) boolean)
((char char) (##core#inline "C_u_i_char_less_or_equal_p" #(1) #(2))))
-(scheme#char-ci=? (#(procedure #:clean #:enforce #:foldable) scheme#char-ci=? (char char) boolean))
-(scheme#char-ci<? (#(procedure #:clean #:enforce #:foldable) scheme#char-ci<? (char char) boolean))
-(scheme#char-ci>? (#(procedure #:clean #:enforce #:foldable) scheme#char-ci>? (char char) boolean))
-(scheme#char-ci>=? (#(procedure #:clean #:enforce #:foldable) scheme#char-ci>=? (char char) boolean))
-(scheme#char-ci<=? (#(procedure #:clean #:enforce #:foldable) scheme#char-ci<=? (char char) boolean))
+(scheme#char-ci=? (#(procedure #:clean #:enforce #:foldable) scheme#char-ci=? (char char #!rest char) boolean))
+(scheme#char-ci<? (#(procedure #:clean #:enforce #:foldable) scheme#char-ci<? (char char #!rest char) boolean))
+(scheme#char-ci>? (#(procedure #:clean #:enforce #:foldable) scheme#char-ci>? (char char #!rest char) boolean))
+(scheme#char-ci>=? (#(procedure #:clean #:enforce #:foldable) scheme#char-ci>=? (char char #!rest char) boolean))
+(scheme#char-ci<=? (#(procedure #:clean #:enforce #:foldable) scheme#char-ci<=? (char char #!rest char) boolean))
(scheme#char-alphabetic? (#(procedure #:clean #:enforce #:foldable) scheme#char-alphabetic? (char) boolean))
(scheme#char-whitespace? (#(procedure #:clean #:enforce #:foldable) scheme#char-whitespace? (char) boolean))
(scheme#char-numeric? (#(procedure #:clean #:enforce #:foldable) scheme#char-numeric? (char) boolean))
@@ -607,24 +610,25 @@
(scheme#string? (#(procedure #:pure #:predicate string) scheme#string? (*) boolean))
(scheme#string=? (#(procedure #:clean #:enforce #:foldable) scheme#string=? (string string) boolean)
- ((string string) (##core#inline "C_u_i_string_equal_p" #(1) #(2))))
-
-(scheme#string>? (#(procedure #:clean #:enforce #:foldable) scheme#string>? (string string) boolean))
-(scheme#string<? (#(procedure #:clean #:enforce #:foldable) scheme#string<? (string string) boolean))
-(scheme#string>=? (#(procedure #:clean #:enforce #:foldable) scheme#string>=? (string string) boolean))
-(scheme#string<=? (#(procedure #:clean #:enforce #:foldable) scheme#string<=? (string string) boolean))
-(scheme#string-ci=? (#(procedure #:clean #:enforce #:foldable) scheme#string-ci=? (string string) boolean))
-(scheme#string-ci<? (#(procedure #:clean #:enforce #:foldable) scheme#string-ci<? (string string) boolean))
-(scheme#string-ci>? (#(procedure #:clean #:enforce #:foldable) scheme#string-ci>? (string string) boolean))
-(scheme#string-ci>=? (#(procedure #:clean #:enforce #:foldable) scheme#string-ci>=? (string string) boolean))
-(scheme#string-ci<=? (#(procedure #:clean #:enforce #:foldable) scheme#string-ci<=? (string string) boolean))
+ ((* *) (##core#inline "C_i_string_equal_p" #(1) #(2))))
+(scheme#string>? (#(procedure #:clean #:enforce #:foldable) scheme#string>? (string string #!rest string) boolean)
+ ((string string) (##core#inline "C_i_string_equal_p" #(1) #(2))))
+(scheme#string<? (#(procedure #:clean #:enforce #:foldable) scheme#string<? (string string #!rest string) boolean))
+(scheme#string>=? (#(procedure #:clean #:enforce #:foldable) scheme#string>=? (string string #!rest string) boolean))
+(scheme#string<=? (#(procedure #:clean #:enforce #:foldable) scheme#string<=? (string string #!rest string) boolean))
+(scheme#string-ci=? (#(procedure #:clean #:enforce #:foldable) scheme#string-ci=? (string string #!rest string) boolean)
+ ((* *) (##core#inline "C_i_string_ci_equal_p" #(1) #(2))))
+(scheme#string-ci<? (#(procedure #:clean #:enforce #:foldable) scheme#string-ci<? (string string #!rest string) boolean))
+(scheme#string-ci>? (#(procedure #:clean #:enforce #:foldable) scheme#string-ci>? (string string #!rest string) boolean))
+(scheme#string-ci>=? (#(procedure #:clean #:enforce #:foldable) scheme#string-ci>=? (string string #!rest string) boolean))
+(scheme#string-ci<=? (#(procedure #:clean #:enforce #:foldable) scheme#string-ci<=? (string string #!rest string) boolean))
(scheme#make-string (#(procedure #:clean #:enforce) scheme#make-string (fixnum #!optional char) string)
((fixnum char) (##sys#make-string #(1) #(2)))
((fixnum) (##sys#make-string #(1) '#\space)))
(scheme#string-length (#(procedure #:clean #:enforce #:foldable) scheme#string-length (string) fixnum)
- ((string) (##sys#size #(1))))
+ ((string) (##core#inline "C_u_i_string_length" #(1))))
(scheme#string-ref (#(procedure #:clean #:enforce #:foldable) scheme#string-ref (string fixnum) char)
((string fixnum) (##core#inline "C_i_string_ref" #(1) #(2))))
@@ -635,12 +639,13 @@
(scheme#string-append (#(procedure #:clean #:enforce) scheme#string-append (#!rest string) string)
((string string) (##sys#string-append #(1) #(2))))
-(scheme#string-copy (#(procedure #:clean #:enforce) scheme#string-copy (string) string))
+(scheme#string-copy (#(procedure #:clean #:enforce) scheme#string-copy (string #!optional fixnum fixnum) string))
+(scheme#string-copy! (#(procedure #:clean #:enforce) scheme#string-copy! (string fixnum string #!optional fixnum fixnum) undefined))
-(scheme#string->list (#(procedure #:clean #:enforce) scheme#string->list (string) (list-of char)))
+(scheme#string->list (#(procedure #:clean #:enforce) scheme#string->list (string #!optional fixnum fixnum) (list-of char)))
(scheme#list->string (#(procedure #:clean #:enforce) scheme#list->string ((list-of char)) string))
(scheme#substring (#(procedure #:clean #:enforce) scheme#substring (string fixnum #!optional fixnum) string))
-(scheme#string-fill! (#(procedure #:enforce) scheme#string-fill! (string char) string))
+(scheme#string-fill! (#(procedure #:enforce) scheme#string-fill! (string char #!optional fixnum fixnum) string))
(scheme#string (#(procedure #:clean #:enforce) scheme#string (#!rest char) string))
(scheme#vector? (#(procedure #:pure #:predicate vector) scheme#vector? (*) boolean))
@@ -665,15 +670,16 @@
(##sys#vector-length (#(procedure #:clean #:enforce #:foldable) ##sys#vector-length (vector) fixnum)
((vector) (##sys#size #(1))))
-(scheme#vector->list (forall (a) (#(procedure #:clean #:enforce) scheme#vector->list ((vector-of a)) (list-of a))))
+(scheme#vector->list (forall (a) (#(procedure #:clean #:enforce) scheme#vector->list ((vector-of a) #!optional fixnum fixnum) (list-of a))))
(##sys#vector->list (forall (a) (#(procedure #:clean #:enforce) ##sys#vector->list ((vector-of a)) (list-of a))))
(scheme#list->vector (forall (a) (#(procedure #:clean #:enforce) scheme#list->vector ((list-of a)) (vector-of a))))
(##sys#list->vector (forall (a) (#(procedure #:clean #:enforce) ##sys#list->vector ((list-of a)) (vector-of a))))
-(scheme#vector-fill! (#(procedure #:enforce) scheme#vector-fill! (vector *) undefined))
+(scheme#vector-fill! (#(procedure #:enforce) scheme#vector-fill! (vector * #!optional fixnum fixnum) undefined))
+(scheme#vector-copy (#(procedure #:enforce) scheme#vector-copy (vector #!optional fixnum fixnum) vector))
+(scheme#vector-copy! (#(procedure #:enforce) scheme#vector-copy! (vector fixnum vector #!optional fixnum fixnum) undefined))
(scheme#procedure? (#(procedure #:pure #:predicate procedure) scheme#procedure? (*) boolean))
-
(scheme#map (forall (a b) (#(procedure #:enforce) scheme#map ((procedure (a #!rest) b) (list-of a) #!rest list) (list-of b))))
(scheme#for-each
@@ -682,16 +688,20 @@
(scheme#apply (#(procedure #:enforce) scheme#apply (procedure #!rest) . *))
(##sys#apply (#(procedure #:enforce) ##sys#apply (procedure #!rest) . *))
-(scheme#force (procedure scheme#force (*) . *)
- (((not (struct promise))) #(1)))
+(scheme#force (procedure scheme#force (*) . *) (((not (struct promise))) #(1)))
(scheme#call-with-current-continuation
(#(procedure #:enforce) scheme#call-with-current-continuation
((procedure (procedure) . *)) . *))
+(scheme#call/cc (#(procedure #:enforce) scheme#call-with-current-continuation ((procedure (*) . *)) . *))
(scheme#input-port? (#(procedure #:pure #:predicate (refine (input) port)) scheme#input-port? (*) boolean))
(scheme#output-port? (#(procedure #:pure #:predicate (refine (output) port)) scheme#output-port? (*) boolean))
+(scheme#port? (#(procedure #:pure #:predicate port) scheme#port? (*) boolean))
+(scheme#input-port-open? (#(procedure #:enforce) scheme#input-port-open? (input-port) boolean))
+(scheme#output-port-open? (#(procedure #:enforce) scheme#output-port-open? (output-port) boolean))
+
(scheme#current-input-port
(#(procedure #:clean #:enforce) scheme#current-input-port
(#!optional input-port boolean boolean) input-port)
@@ -771,6 +781,9 @@
(scheme#char-ready? (#(procedure #:enforce) scheme#char-ready? (#!optional input-port) boolean))
+(scheme#make-rectangular (#(procedure #:enforce #:clean) scheme#make-rectangular (number number) number))
+(scheme#make-polar (#(procedure #:enforce #:clean) scheme#make-polar (number number) number))
+
(scheme#real-part (#(procedure #:clean #:enforce #:foldable) scheme#real-part (number) (or integer float ratnum))
(((or fixnum float bignum ratnum)) #(1))
((cplxnum) (##core#inline "C_u_i_cplxnum_real" #(1))))
@@ -812,7 +825,7 @@
((integer) (fixnum) (let ((#(tmp) #(1))) '1))
((ratnum) (integer) (##core#inline "C_u_i_ratnum_denom" #(1))))
-(scheme#load (procedure scheme#load (string #!optional (procedure (*) . *)) undefined))
+(scheme#load (procedure scheme#load (string #!optional (or (struct environment) (procedure (*) . *))) undefined))
(scheme#eval (procedure scheme#eval (* #!optional (struct environment)) . *))
@@ -821,10 +834,74 @@
(scheme#null-environment
(#(procedure #:clean #:enforce) scheme#null-environment (#!optional fixnum) (struct environment)))
-
(scheme#interaction-environment
(#(procedure #:clean) scheme#interaction-environment () (struct environment)))
+(scheme#with-exception-handler (#(procedure #:clean #:enforce) scheme#with-exception-handler ((procedure (*) . *) (procedure () . *)) . *))
+(scheme#raise (#(procedure #:clean #:enforce) scheme#raise (*) noreturn))
+(scheme#raise-continuable (#(procedure #:clean #:enforce) scheme#raise-continuable (*) . *))
+(scheme#error-object-irritants
+ (#(procedure #:clean #:enforce)
+ scheme#error-object-irritants
+ ((struct condition))
+ (or list false)))
+(scheme#error-object-message
+ (#(procedure #:clean #:enforce)
+ scheme#error-object-message
+ ((struct condition))
+ (or string false)))
+(scheme#error-object?
+ (#(procedure #:pure #:predicate (struct condition))
+ scheme#error-object?
+ (*)
+ boolean))
+(scheme#file-error? (#(procedure #:pure) scheme#file-error? (*) boolean))
+(scheme#read-error? (#(procedure #:pure) scheme#read-error? (*) boolean))
+
+(scheme#square (#(procedure #:pure) scheme#square ((or integer ratnum float)) (or integer ratnum float)))
+(scheme#floor/ (#(procedure #:clean #:enforce #:foldable) scheme#floor/ ((or integer float) (or integer float)) (or integer float) (or integer float)))
+(scheme#truncate/ (#(procedure #:clean #:enforce #:foldable) scheme#truncate/ ((or integer float) (or integer float)) (or integer float) (or integer float)))
+(scheme#floor-quotient (#(procedure #:clean #:enforce #:foldable) scheme#floor-quotient ((or integer float) (or integer float))))
+(scheme#floor-remainder (#(procedure #:clean #:enforce #:foldable) scheme#floor-remainder ((or integer float) (or integer float))))
+
+(scheme#boolean=? (#(procedure #:pure) scheme#boolean=? (boolean boolean #!rest boolean) boolean))
+(scheme#symbol=? (#(procedure #:pure) scheme#symbol=? (symbol symbol #!rest symbol) boolean))
+
+(scheme#close-port (#(procedure #:enforce) scheme#close-port (port) undefined))
+
+(scheme#get-output-string (#(procedure #:clean #:enforce) scheme#get-output-string (output-port) string))
+(scheme#open-input-string (#(procedure #:clean #:enforce) scheme#open-input-string (string #!rest) input-port))
+(scheme#open-output-string (#(procedure #:clean) scheme#open-output-string (#!rest) output-port))
+(scheme#get-output-bytevector (#(procedure #:clean #:enforce) scheme#get-output-bytevector (output-port) bytevector))
+(scheme#open-input-bytevector (#(procedure #:clean #:enforce) scheme#open-input-bytevector (bytevector #!rest) input-port))
+(scheme#open-output-bytevector (#(procedure #:clean) scheme#open-output-bytevector (#!rest) output-port))
+
+(scheme#make-list (#(procedure #:clean #:enforce) scheme#make-list (fixnum *) list))
+
+(scheme#list-set! (#(procedure #:clean #:enforce) scheme#list-set! (list fixnum *) undefined))
+(scheme#list-copy (forall (a) (#(procedure #:clean #:enforce) scheme#list-copy ((list-of a)) (list-of a))))
+(scheme#string->vector (#(procedure #:clean #:enforce) scheme#string->vector (string #!optional fixnum fixnum) vector))
+(scheme#vector->string (#(procedure #:clean #:enforce) scheme#vector->string (vector #!optional fixnum fixnum) string))
+(scheme#string-for-each (#(procedure #:clean #:enforce) scheme#string-for-each ((procedure (#!rest char) char) #!rest string) undefined))
+(scheme#vector-for-each (#(procedure #:clean #:enforce) scheme#vector-for-each ((procedure (#!rest *) . *) #!rest vector) undefined))
+(scheme#string-map (#(procedure #:clean #:enforce) scheme#string-map ((procedure (#!rest char) char) #!rest string) string))
+(scheme#vector-map (#(procedure #:clean #:enforce) scheme#vector-map ((procedure (#!rest *) . *) #!rest vector) vector))
+
+(scheme#binary-port? (#(procedure #:pure) scheme#binary-port? (*) boolean))
+(scheme#textual-port? (#(procedure #:pure) scheme#textual-port? (*) boolean))
+(scheme#call-with-port (#(procedure #:clean #:enforce) scheme#call-with-port (port (procedure (port) . *)) . *))
+(scheme#eof-object (#(procedure #:pure) scheme#eof-object () eof))
+(scheme#features (#(procedure #:clean) scheme#features () (list-of symbol)))
+
+(scheme#peek-u8 (#(procedure #:clean #:enforce) scheme#peek-u8 (#!optional input-port) (or eof fixnum)))
+(scheme#write-string (#(procedure #:clean #:enforce) scheme#write-string (string #!optional output-port fixnum fixnum) undefined))
+
+(scheme#make-parameter (#(procedure #:clean #:enforce) scheme#make-parameter (* #!optional procedure) procedure))
+
+
+;; scheme.eval
+
+(scheme.eval#environment (procedure scheme.eval#environment (* #!optional (struct environment)) . *))
;; eval
@@ -840,7 +917,7 @@
(##core#inline_allocate ("C_a_i_fixnum_plus" 5) #(1) '1))
((integer) (integer)
(##core#inline_allocate ("C_s_a_u_i_integer_plus" 5) #(1) '1))
- ((float) (float)
+ ((float) (float)
(##core#inline_allocate ("C_a_i_flonum_plus" 4) #(1) '1.0))
((*) (number)
(##core#inline_allocate ("C_s_a_i_plus" 29) #(1) '1)))
@@ -856,7 +933,6 @@
(##core#inline_allocate ("C_s_a_i_minus" 29) #(1) '1)))
(chicken.base#subvector (forall (a) (#(procedure #:clean #:enforce) chicken.base#subvector ((vector-of a) fixnum #!optional fixnum) (vector-of a))))
-(chicken.base#vector-copy! (#(procedure #:enforce) chicken.base#vector-copy! (vector vector #!optional fixnum) undefined))
(chicken.base#vector-resize
(forall (a b) (#(procedure #:clean #:enforce) chicken.base#vector-resize ((vector-of a) fixnum #!optional b)
(vector-of (or a b)))))
@@ -872,9 +948,6 @@
(chicken.base#exact-integer-nth-root (#(procedure #:clean #:enforce #:foldable) chicken.base#exact-integer-nth-root (integer integer) integer integer)
((integer integer) (##sys#exact-integer-nth-root/loc 'exact-integer-nth-root #(1) #(2))))
-(chicken.base#exact-integer-sqrt (#(procedure #:clean #:enforce #:foldable) chicken.base#exact-integer-sqrt (integer) integer integer)
- ((integer) (##sys#exact-integer-sqrt #(1))))
-
(chicken.base#weak-cons (forall (a b) (#(procedure #:pure) chicken.base#weak-cons (a b) (pair (or a bwp) b))))
;; NOTE: This is *not* a #:predicate, as we don't want to introduce a completely new weak-pair type
(chicken.base#weak-pair? (#(procedure #:pure) chicken.base#weak-pair? (*) boolean))
@@ -910,26 +983,11 @@
(chicken.base#print (procedure chicken.base#print (#!rest *) undefined))
(chicken.base#print* (procedure chicken.base#print* (#!rest) undefined))
(chicken.base#procedure-information (#(procedure #:clean #:enforce) chicken.base#procedure-information (procedure) *))
-(chicken.base#promise? (#(procedure #:pure #:predicate (struct promise)) chicken.base#promise? (*) boolean))
-
-(chicken.base#make-promise (#(procedure #:enforce) chicken.base#make-promise (*) (struct promise))
- (((struct promise)) #(1)))
-
-(chicken.base#call/cc (#(procedure #:enforce) chicken.base#call/cc ((procedure (*) . *)) . *))
-
-(chicken.base#port? (#(procedure #:pure #:predicate port) chicken.base#port? (*) boolean))
(chicken.base#port-closed?
(#(procedure #:clean #:enforce) chicken.base#port-closed? (port) boolean)
((port) (scheme#eq? (##sys#slot #(1) '8) '0)))
-(chicken.base#input-port-open? (#(procedure #:enforce) chicken.base#input-port-open? (input-port) boolean))
-(chicken.base#output-port-open? (#(procedure #:enforce) chicken.base#output-port-open? (output-port) boolean))
-
-(chicken.base#get-output-string (#(procedure #:clean #:enforce) chicken.base#get-output-string (output-port) string))
-(chicken.base#open-input-string (#(procedure #:clean #:enforce) chicken.base#open-input-string (string #!rest) input-port))
-(chicken.base#open-output-string (#(procedure #:clean) chicken.base#open-output-string (#!rest) output-port))
-
(chicken.base#current-error-port
(#(procedure #:clean #:enforce) chicken.base#current-error-port (#!optional output-port boolean boolean) output-port)
((output-port) (let ((#(tmp1) #(1)))
@@ -978,7 +1036,6 @@
(##core#inline "C_u_i_ratnum_num" #(1))))
((cplxnum) ((or float cplxnum)) (##sys#extended-signum #(1))))
-(chicken.base#make-parameter (#(procedure #:clean #:enforce) chicken.base#make-parameter (* #!optional procedure) procedure))
(chicken.base#string->uninterned-symbol (#(procedure #:clean #:enforce) chicken.base#string->uninterned-symbol (string) symbol))
(chicken.base#symbol-append (#(procedure #:clean #:enforce #:foldable) chicken.base#symbol-append (#!rest symbol) symbol))
@@ -1011,8 +1068,8 @@
;; TODO: Add nonspecializing type specific entries, to help flow analysis?
(chicken.base#quotient&modulo (#(procedure #:clean #:enforce #:foldable) chicken.base#quotient&modulo ((or integer float) (or integer float)) (or integer float) (or integer float)))
-(chicken.base#record-printer (#(procedure #:enforce) chicken.base#record-printer (symbol) (or false procedure)))
-(chicken.base#set-record-printer! (#(procedure #:enforce) chicken.base#set-record-printer! (symbol procedure) undefined))
+(chicken.base#record-printer (#(procedure #:enforce) chicken.base#record-printer (*) (or false procedure)))
+(chicken.base#set-record-printer! (#(procedure #:enforce) chicken.base#set-record-printer! (* procedure) undefined))
(chicken.base#alist-ref
(forall (a b c d)
@@ -1050,6 +1107,10 @@
(chicken.base#join (#(procedure #:clean #:enforce) chicken.base#join ((list-of list) #!optional list) list))
(chicken.base#list-of? (#(procedure #:clean #:enforce) chicken.base#list-of? ((procedure (*) *)) (procedure (list) boolean)))
+(chicken.base#char-foldcase (#(procedure #:clean #:enforce #:foldable) chicken.base#char-foldcase (char) char)
+ ((char) (##core#inline "C_utf_char_foldcase" #(1))))
+(chicken.base#string-foldcase (#(procedure #:clean #:enforce) chicken.base#string-foldcase (string) string))
+
(chicken.base#o (#(procedure #:clean #:enforce) chicken.base#o (#!rest (procedure (*) *)) (procedure (*) *)))
(chicken.base#rassoc
@@ -1058,6 +1119,11 @@
(or false (pair b c)))))
(chicken.base#tail? (#(procedure #:clean) chicken.base#tail? (* *) boolean))
+(chicken.base#promise? (#(procedure #:pure #:predicate (struct promise)) chicken.base#promise? (*) boolean))
+
+(chicken.base#make-promise (#(procedure #:enforce) chicken.base#make-promise (*) (struct promise))
+ (((struct promise)) #(1)))
+
;; bitwise
@@ -1097,16 +1163,24 @@
(chicken.bitwise#bitwise-not
(#(procedure #:clean #:enforce #:foldable) chicken.bitwise#bitwise-not (integer) integer))
-;; blob
-
-(chicken.blob#blob? (#(procedure #:pure #:predicate blob) chicken.blob#blob? (*) boolean))
-(chicken.blob#blob=? (#(procedure #:clean #:enforce #:foldable) chicken.blob#blob=? (blob blob) boolean))
-(chicken.blob#blob-size (#(procedure #:clean #:enforce #:foldable) chicken.blob#blob-size (blob) fixnum)
- ((blob) (##sys#size #(1))))
-(chicken.blob#blob->string (#(procedure #:clean #:enforce) chicken.blob#blob->string (blob) string))
-(chicken.blob#make-blob (#(procedure #:clean #:enforce) chicken.blob#make-blob (fixnum) blob)
- ((fixnum) (##sys#make-blob #(1))))
-(chicken.blob#string->blob (#(procedure #:clean #:enforce) chicken.blob#string->blob (string) blob))
+;; bytevector
+
+(chicken.bytevector#bytevector (#(procedure #:clean) chicken.bytevector#bytevector (#!rest fixnum) bytevector))
+(chicken.bytevector#bytevector? (#(procedure #:pure #:predicate bytevector) chicken.bytevector#bytevector? (*) boolean))
+(chicken.bytevector#bytevector=? (#(procedure #:clean #:enforce #:foldable) chicken.bytevector#bytevector=? (bytevector bytevector) boolean))
+(chicken.bytevector#bytevector-length (#(procedure #:clean #:enforce #:foldable) chicken.bytevector#bytevector-size (bytevector) fixnum)
+ ((bytevector) (##sys#size #(1))))
+(chicken.bytevector#utf8->string (#(procedure #:clean #:enforce) chicken.bytevector#utf8->string (bytevector #!optional boolean) string))
+(chicken.bytevector#latin1->string (#(procedure #:clean #:enforce) chicken.bytevector#latin1->string (bytevector) string))
+(chicken.bytevector#make-bytevector (#(procedure #:clean #:enforce) chicken.bytevector#make-bytevector (fixnum) bytevector)
+ ((fixnum) (##sys#make-bytevector #(1))))
+(chicken.bytevector#string->utf8 (#(procedure #:clean #:enforce) chicken.bytevector#string->utf8 (string) bytevector))
+(chicken.bytevector#string->latin1 (#(procedure #:clean #:enforce) chicken.bytevector#string->latin1 (string) bytevector))
+(chicken.bytevector#bytevector-u8-ref (#(procedure #:clean #:pure #:enforce) chicken.bytevector#bytevector-u8-ref (bytevector fixnum) fixnum))
+(chicken.bytevector#bytevector-u8-set! (#(procedure #:clean #:enforce) chicken.bytevector#bytevector-u8-set! (bytevector fixnum fixnum) undefined))
+(chicken.bytevector#bytevector-copy (#(procedure #:clean #:enforce) chicken.bytevector#bytevector-copy (bytevector #!optional fixnum fixnum) bytevector))
+(chicken.bytevector#bytevector-copy! (#(procedure #:clean #:enforce) chicken.bytevector#bytevector-copy! (bytevector fixnum bytevector #!optional fixnum fixnum) undefined))
+(chicken.bytevector#bytevector-append (#(procedure #:clean #:enforce) chicken.bytevector#bytevector-append (#!rest bytevector) bytevector))
;; condition
@@ -1163,7 +1237,6 @@
(chicken.time#cpu-time (#(procedure #:clean) chicken.time#cpu-time () fixnum fixnum))
(chicken.time#current-seconds (#(procedure #:clean) chicken.time#current-seconds () integer))
-(chicken.time#current-milliseconds deprecated)
(chicken.time#current-process-milliseconds (#(procedure #:clean) chicken.time#current-process-milliseconds () integer))
(##sys#error (procedure ##sys#error (* #!rest) noreturn))
@@ -1344,7 +1417,7 @@
(#(procedure #:clean) chicken.load#dynamic-load-libraries (#!optional (list-of string)) (list-of string)))
(chicken.load#load-library (#(procedure #:enforce) chicken.load#load-library (symbol #!optional string) undefined))
(chicken.load#load-noisily (procedure chicken.load#load-noisily (string #!rest) undefined))
-(chicken.load#load-relative (#(procedure #:enforce) chicken.load#load-relative (string #!optional (procedure (*) . *)) undefined))
+(chicken.load#load-relative (#(procedure #:enforce) chicken.load#load-relative (string #!optional (or (struct environment) (procedure (*) . *))) undefined))
(chicken.load#load-verbose (#(procedure #:clean) chicken.load#load-verbose (#!optional *) *))
(chicken.load#provide (#(procedure #:clean #:enforce) chicken.load#provide (#!rest symbol) undefined))
(chicken.load#provided? (#(procedure #:clean #:enforce) chicken.load#provided? (#!rest symbol) boolean))
@@ -1356,10 +1429,9 @@
(chicken.platform#build-platform (#(procedure #:pure) chicken.platform#build-platform () symbol))
(chicken.platform#chicken-version (#(procedure #:pure) chicken.platform#chicken-version (#!optional *) string))
-(chicken.platform#chicken-home deprecated)
-(chicken.platform#include-path (#(procedure #:clean) chicken.platform#include-path () string))
+(chicken.platform#chicken-home (#(procedure #:clean) chicken.platform#chicken-home () string))
+(chicken.platform#include-path (#(procedure #:clean) chicken.platform#include-path (#!optional (list-of string)) (list-of string)))
(chicken.platform#feature? (#(procedure #:clean) chicken.platform#feature? (#!rest (or keyword symbol string)) boolean))
-(chicken.platform#features (#(procedure #:clean) chicken.platform#features () (list-of keyword)))
(chicken.platform#software-type (#(procedure #:pure) chicken.platform#software-type () symbol))
(chicken.platform#software-version (#(procedure #:pure) chicken.platform#software-version () symbol))
(chicken.platform#register-feature! (#(procedure #:clean #:enforce) chicken.platform#register-feature! (#!rest (or keyword symbol string)) undefined))
@@ -1426,9 +1498,9 @@
((pointer) (pointer) #(1))
((locative) (locative) #(1)))
-(##sys#check-blob (#(procedure #:clean #:enforce) ##sys#check-blob (blob #!optional *) *)
- ((blob) (let ((#(tmp) #(1))) '#t))
- ((blob *) (let ((#(tmp) #(1))) '#t)))
+(##sys#check-bytevector (#(procedure #:clean #:enforce) ##sys#check-bytevector (bytevector #!optional *) *)
+ ((bytevector) (let ((#(tmp) #(1))) '#t))
+ ((bytevector *) (let ((#(tmp) #(1))) '#t)))
(##sys#check-pair (#(procedure #:clean #:enforce) ##sys#check-pair (pair #!optional *) *)
((pair) (let ((#(tmp) #(1))) '#t))
((pair *) (let ((#(tmp) #(1))) '#t)))
@@ -1441,6 +1513,12 @@
(##sys#check-number (#(procedure #:clean #:enforce) ##sys#check-number (number #!optional *) *)
((number) (let ((#(tmp) #(1))) '#t))
((number *) (let ((#(tmp) #(1))) '#t)))
+(##sys#check-fixnum (#(procedure #:clean #:enforce) ##sys#check-fixnum (fixnum #!optional *) *)
+ ((fixnum) (let ((#(tmp) #(1))) '#t))
+ ((fixnum *) (let ((#(tmp) #(1))) '#t)))
+(##sys#check-bytevector (#(procedure #:clean #:enforce) ##sys#check-bytevector (bytevector #!optional *) *)
+ ((bytevector) (let ((#(tmp) #(1))) '#t))
+ ((bytevector *) (let ((#(tmp) #(1))) '#t)))
(##sys#check-exact (#(procedure #:clean #:enforce) ##sys#check-exact (fixnum #!optional *) *)
((fixnum) (let ((#(tmp) #(1))) '#t))
((fixnum *) (let ((#(tmp) #(1))) '#t)))
@@ -1469,7 +1547,10 @@
((keyword) (let ((#(tmp) #(1))) '#t))
((keyword *) (let ((#(tmp) #(1))) '#t)))
-(##sys#check-port
+(##sys#check-range (#(procedure #:clean #:enforce) ##sys#check-range (fixnum #!rest *) *))
+(##sys#check-range/including (#(procedure #:clean #:enforce) ##sys#check-range/including (fixnum #!rest *) *))
+
+(##sys#check-port
(#(procedure #:clean #:enforce) ##sys#check-port ((or input-port output-port) #!optional *) *)
(((or (refine (input) port) (refine (output) port))) (let ((#(tmp) #(1))) '#t))
(((or (refine (input) port) (refine (output) port)) *) (let ((#(tmp) #(1))) '#t)))
@@ -1556,7 +1637,9 @@
(chicken.io#read-token (#(procedure #:enforce) chicken.io#read-token ((procedure (char) *) #!optional input-port) string))
(chicken.io#write-byte (#(procedure #:enforce) chicken.io#write-byte (fixnum #!optional output-port) undefined))
(chicken.io#write-line (#(procedure #:enforce) chicken.io#write-line (string #!optional output-port) undefined))
-(chicken.io#write-string (#(procedure #:enforce) chicken.io#write-string (string #!optional * output-port) undefined))
+(chicken.io#write-bytevector (#(procedure #:enforce) chicken.io#write-bytevector (bytevector #!optional output-port fixnum fixnum) undefined))
+(chicken.io#read-bytevector (#(procedure #:enforce) chicken.io#read-bytevector (#!optional * input-port) bytevector))
+(chicken.io#read-bytevector! (#(procedure #:enforce) chicken.io#read-bytevector! (bytevector #!optional input-port fixnum fixnum) fixnum))
;; pretty-print
@@ -1576,7 +1659,7 @@
(chicken.random#pseudo-random-integer (#(procedure #:clean #:enforce) chicken.random#pseudo-random-integer (integer) integer)
((fixnum) (##core#inline "C_random_fixnum" #(1))))
(chicken.random#pseudo-random-real (#(procedure #:clean #:enforce) chicken.random#pseudo-random-real () float))
-(chicken.random#set-pseudo-random-seed! (#(procedure #:clean #:enforce) chicken.random#set-pseudo-random-seed! ((or blob string) #!optional fixnum) undefined))
+(chicken.random#set-pseudo-random-seed! (#(procedure #:clean #:enforce) chicken.random#set-pseudo-random-seed! (bytevector #!optional fixnum) undefined))
(chicken.random#random-bytes (#(procedure #:clean #:enforce) chicken.random#random-bytes (#!optional * fixnum) *))
;; file
@@ -1600,6 +1683,13 @@
(chicken.file#file-executable? (#(procedure #:clean #:enforce) chicken.file#file-executable? (string) boolean))
+;; scheme.file
+
+(scheme.file#file-exists? (#(procedure #:clean #:enforce) scheme.file#file-exists? (string) boolean))
+(scheme.file#open-binary-input-file (#(procedure #:clean #:enforce) scheme.file#open-binary-input-file (string #!rest keyword) input-port))
+(scheme.file#open-binary-output-file (#(procedure #:clean #:enforce) scheme.file#open-binary-output-file (string #!rest keyword) output-port))
+
+
;; pathname
(chicken.pathname#absolute-pathname? (#(procedure #:clean #:enforce) chicken.pathname#absolute-pathname? (string) boolean))
@@ -1813,7 +1903,7 @@
(#(procedure #:enforce) chicken.memory.representation#mutate-procedure! (procedure (procedure (procedure) . *)) procedure))
(chicken.memory.representation#number-of-bytes (#(procedure #:clean) chicken.memory.representation#number-of-bytes (*) fixnum)
- (((or blob string)) (##sys#size #(1)))
+ ((bytevector) (##sys#size #(1)))
(((or port procedure symbol keyword pair vector locative float pointer-vector))
;; would be applicable to all structure types, but we can't specify
;; "(struct *)" (yet)
@@ -1857,8 +1947,8 @@
(chicken.port#call-with-input-string (#(procedure #:enforce) chicken.port#call-with-input-string (string (procedure (input-port) . *)) . *))
(chicken.port#call-with-output-string (#(procedure #:enforce) chicken.port#call-with-output-string ((procedure (output-port) . *)) string))
(chicken.port#copy-port (#(procedure #:enforce) chicken.port#copy-port (* * #!optional (procedure (*) *) (procedure (* output-port) *)) undefined))
-(chicken.port#make-input-port (#(procedure #:clean #:enforce) chicken.port#make-input-port ((procedure () (or char eof)) (procedure () *) (procedure () . *) #!optional * * * *) input-port))
-(chicken.port#make-output-port (#(procedure #:clean #:enforce) chicken.port#make-output-port ((procedure (string) . *) (procedure () . *) #!optional (procedure () . *)) output-port))
+(chicken.port#make-input-port (#(procedure #:clean #:enforce) chicken.port#make-input-port ((procedure () (or char eof)) (procedure () *) (procedure () . *) #!rest *) input-port))
+(chicken.port#make-output-port (#(procedure #:clean #:enforce) chicken.port#make-output-port ((procedure (string) . *) (procedure () . *) #!rest *) output-port))
(chicken.port#port-for-each (#(procedure #:enforce) chicken.port#port-for-each ((procedure (*) *) (procedure () . *)) undefined))
(chicken.port#port-map
@@ -1877,14 +1967,14 @@
(chicken.port#with-output-to-string (#(procedure #:enforce) chicken.port#with-output-to-string ((procedure () . *)) string))
(chicken.port#with-error-output-to-string (#(procedure #:enforce) chicken.port#with-error-output-to-string ((procedure () . *)) string))
+(chicken.port#port-encoding
+ (#(procedure #:clean #:enforce) chicken.port#port-encoding (port) *)
+ ((port) (##sys#slot #(1) '15)))
+
(chicken.port#port-name
(#(procedure #:clean #:enforce) chicken.port#port-name (#!optional port) *)
((port) (##sys#slot #(1) '3)))
-(chicken.port#set-port-name!
- (#(procedure #:clean #:enforce) chicken.port#set-port-name! (port string) undefined)
- ((port string) (##sys#setslot #(1) '3 #(2))))
-
(chicken.port#terminal-name (#(procedure #:clean #:enforce) chicken.port#terminal-name (port) string))
(chicken.port#terminal-port? (#(procedure #:clean #:enforce) chicken.port#terminal-port? (port) boolean))
(chicken.port#terminal-size (#(procedure #:clean #:enforce) chicken.port#terminal-size (port) fixnum fixnum))
@@ -1986,8 +2076,8 @@
(chicken.file.posix#file-creation-mode (#(procedure #:clean #:enforce) chicken.file.posix#file-creation-mode (#!optional fixnum) fixnum))
(chicken.file.posix#file-group (#(procedure #:clean #:enforce) chicken.file.posix#file-owner ((or string fixnum port)) fixnum))
(chicken.file.posix#file-link (#(procedure #:clean #:enforce) chicken.file.posix#file-link (string string) undefined))
-(chicken.file.posix#file-lock (#(procedure #:clean #:enforce) chicken.file.posix#file-lock (port #!optional fixnum integer) (struct lock)))
-(chicken.file.posix#file-lock/blocking (#(procedure #:clean #:enforce) chicken.file.posix#file-lock/blocking (port #!optional fixnum integer) (struct lock)))
+(chicken.file.posix#file-lock (#(procedure #:clean #:enforce) chicken.file.posix#file-lock ((or port fixnum) #!optional *) boolean))
+(chicken.file.posix#file-lock/blocking (#(procedure #:clean #:enforce) chicken.file.posix#file-lock/blocking ((or port fixnum) #!optional *) boolean))
(chicken.file.posix#file-mkstemp (#(procedure #:clean #:enforce) chicken.file.posix#file-mkstemp (string) fixnum string))
(chicken.file.posix#file-open (#(procedure #:clean #:enforce) chicken.file.posix#file-open (string fixnum #!optional fixnum) fixnum))
(chicken.file.posix#file-owner (#(procedure #:clean #:enforce) chicken.file.posix#file-owner ((or string fixnum port)) fixnum))
@@ -1997,10 +2087,9 @@
(chicken.file.posix#file-select (#(procedure #:clean #:enforce) chicken.file.posix#file-select ((or (list-of fixnum) fixnum false) (or (list-of fixnum) fixnum false) #!optional number) * *))
(chicken.file.posix#file-size (#(procedure #:clean #:enforce) chicken.file.posix#file-size ((or string fixnum port)) integer))
(chicken.file.posix#file-stat (#(procedure #:clean #:enforce) chicken.file.posix#file-stat ((or string fixnum port) #!optional *) (vector-of integer)))
-(chicken.file.posix#file-test-lock (#(procedure #:clean #:enforce) chicken.file.posix#file-test-lock (port #!optional fixnum *) boolean))
(chicken.file.posix#file-truncate (#(procedure #:clean #:enforce) chicken.file.posix#file-truncate ((or string fixnum output-port) integer) undefined))
-(chicken.file.posix#file-unlock (#(procedure #:clean #:enforce) chicken.file.posix#file-unlock ((struct lock)) undefined))
-(chicken.file.posix#file-write (#(procedure #:clean #:enforce) chicken.file.posix#file-write (fixnum * #!optional fixnum) fixnum))
+(chicken.file.posix#file-unlock (#(procedure #:clean #:enforce) chicken.file.posix#file-unlock ((or fixnum port)) undefined))
+(chicken.file.posix#file-write (#(procedure #:clean #:enforce) chicken.file.posix#file-write (fixnum bytevector #!optional fixnum) fixnum))
(chicken.file.posix#file-type (#(procedure #:clean #:enforce) chicken.file.posix#file-type ((or string fixnum port) #!optional * *) symbol))
(chicken.file.posix#block-device? (#(procedure #:clean #:enforce) chicken.file.posix#block-device? ((or string fixnum port)) boolean))
@@ -2015,8 +2104,8 @@
(chicken.file.posix#fileno/stdin fixnum)
(chicken.file.posix#fileno/stdout fixnum)
-(chicken.file.posix#open-input-file* (#(procedure #:clean #:enforce) chicken.file.posix#open-input-file* (fixnum #!optional keyword) input-port))
-(chicken.file.posix#open-output-file* (#(procedure #:clean #:enforce) chicken.file.posix#open-output-file* (fixnum #!optional keyword) output-port))
+(chicken.file.posix#open-input-file* (#(procedure #:clean #:enforce) chicken.file.posix#open-input-file* (fixnum #!optional keyword symbol) input-port))
+(chicken.file.posix#open-output-file* (#(procedure #:clean #:enforce) chicken.file.posix#open-output-file* (fixnum #!optional keyword symbol) output-port))
(chicken.file.posix#open/append fixnum)
(chicken.file.posix#open/binary fixnum)
@@ -2078,7 +2167,7 @@
;; process
(chicken.process#process-execute
- (#(procedure #:clean #:enforce) chicken.process#process-execute (string #!optional (list-of string) (list-of (pair string string)) fixnum) noreturn))
+ (#(procedure #:clean #:enforce) chicken.process#process-execute (string #!optional (list-of string) (list-of (pair string string)) boolean) noreturn))
(chicken.process#process-fork (#(procedure #:enforce) chicken.process#process-fork (#!optional (or (procedure () . *) false) *) fixnum))
(chicken.process#qs (#(procedure #:clean #:enforce) chicken.process#qs (string #!optional symbol) string))
(chicken.process#process-run (#(procedure #:clean #:enforce) chicken.process#process-run (string #!optional (list-of string)) fixnum))
@@ -2087,8 +2176,8 @@
(#(procedure #:clean #:enforce) chicken.process#process-spawn (fixnum string #!optional (list-of string) (list-of (pair string string)) boolean) fixnum))
(chicken.process#system (#(procedure #:clean #:enforce) chicken.process#system (string) fixnum))
(chicken.process#system* (#(procedure #:clean #:enforce) chicken.process#system* (string) undefined))
-(chicken.process#process (#(procedure #:clean #:enforce) chicken.process#process (string #!optional (list-of string) (list-of (pair string string)) boolean) input-port output-port fixnum))
-(chicken.process#process* (#(procedure #:clean #:enforce) chicken.process#process* (string #!optional (list-of string) (list-of (pair string string)) boolean) input-port output-port fixnum *))
+(chicken.process#process (#(procedure #:clean #:enforce) chicken.process#process (string #!optional (list-of string) (list-of (pair string string)) symbol boolean) input-port output-port fixnum))
+(chicken.process#process* (#(procedure #:clean #:enforce) chicken.process#process* (string #!optional (list-of string) (list-of (pair string string)) symbol boolean) input-port output-port fixnum))
(chicken.process#process-wait (#(procedure #:clean #:enforce) chicken.process#process-wait (#!optional fixnum *) fixnum fixnum fixnum))
(chicken.process#process-sleep (#(procedure #:clean #:enforce) chicken.process#process-sleep (fixnum) fixnum))
(chicken.process#call-with-input-pipe (#(procedure #:enforce) chicken.process#call-with-input-pipe (string (procedure (input-port) . *) #!optional keyword) . *))
@@ -2178,177 +2267,150 @@
(chicken.sort#topological-sort (#(procedure #:enforce) chicken.sort#topological-sort ((list-of list) (procedure (* *) *)) list))
-;; srfi-4
-
-(srfi-4#blob->f32vector (#(procedure #:clean #:enforce) srfi-4#blob->f32vector (blob) (struct f32vector)))
-(srfi-4#blob->f32vector/shared (#(procedure #:clean #:enforce) srfi-4#blob->f32vector/shared (blob) (struct f32vector)))
-(srfi-4#blob->f64vector (#(procedure #:clean #:enforce) srfi-4#blob->f64vector (blob) (struct f64vector)))
-(srfi-4#blob->f64vector/shared (#(procedure #:clean #:enforce) srfi-4#blob->f64vector/shared (blob) (struct f64vector)))
-(srfi-4#blob->s16vector (#(procedure #:clean #:enforce) srfi-4#blob->s16vector (blob) (struct s16vector)))
-(srfi-4#blob->s16vector/shared (#(procedure #:clean #:enforce) srfi-4#blob->s16vector/shared (blob) (struct s16vector)))
-(srfi-4#blob->s32vector (#(procedure #:clean #:enforce) srfi-4#blob->s32vector (blob) (struct s32vector)))
-(srfi-4#blob->s32vector/shared (#(procedure #:clean #:enforce) srfi-4#blob->s32vector/shared (blob) (struct s32vector)))
-(srfi-4#blob->s8vector (#(procedure #:clean #:enforce) srfi-4#blob->s8vector (blob) (struct s8vector)))
-(srfi-4#blob->s8vector/shared (#(procedure #:clean #:enforce) srfi-4#blob->s8vector/shared (blob) (struct s8vector)))
-(srfi-4#blob->u16vector (#(procedure #:clean #:enforce) srfi-4#blob->u16vector (blob) (struct u16vector)))
-(srfi-4#blob->u16vector/shared (#(procedure #:clean #:enforce) srfi-4#blob->u16vector/shared (blob) (struct u16vector)))
-(srfi-4#blob->u32vector (#(procedure #:clean #:enforce) srfi-4#blob->u32vector (blob) (struct u32vector)))
-(srfi-4#blob->u32vector/shared (#(procedure #:clean #:enforce) srfi-4#blob->u32vector/shared (blob) (struct u32vector)))
-(srfi-4#blob->u64vector (#(procedure #:clean #:enforce) srfi-4#blob->u64vector (blob) (struct u64vector)))
-(srfi-4#blob->u64vector/shared (#(procedure #:clean #:enforce) srfi-4#blob->u64vector/shared (blob) (struct u64vector)))
-(srfi-4#blob->u8vector (#(procedure #:clean #:enforce) blob->u8vector (blob) (struct u8vector)))
-(srfi-4#blob->u8vector/shared (#(procedure #:clean #:enforce) srfi-4#blob->u8vector/shared (blob) (struct u8vector)))
-(srfi-4#f32vector (#(procedure #:clean #:enforce) srfi-4#f32vector (#!rest (or integer float)) (struct f32vector)))
-(srfi-4#f32vector->blob (#(procedure #:clean #:enforce) srfi-4#f32vector->blob ((struct f32vector)) blob))
-(srfi-4#f32vector->blob/shared (#(procedure #:clean #:enforce) srfi-4#f32vector->blob/shared ((struct f32vector)) blob))
-(srfi-4#f32vector->list (#(procedure #:clean #:enforce) srfi-4#f32vector->list ((struct f32vector)) (list-of float)))
-
-(srfi-4#f32vector-length (#(procedure #:clean #:enforce) srfi-4#f32vector-length ((struct f32vector)) fixnum)
- (((struct f32vector)) (##core#inline "C_u_i_32vector_length" #(1))))
-
-(srfi-4#f32vector-ref (#(procedure #:clean #:enforce) srfi-4#f32vector-ref ((struct f32vector) fixnum) float))
-(srfi-4#f32vector-set! (#(procedure #:clean #:enforce) srfi-4#f32vector-set! ((struct f32vector) fixnum (or integer float)) undefined))
-
-(srfi-4#f32vector? (#(procedure #:pure #:predicate (struct f32vector)) srfi-4#f32vector? (*) boolean))
-
-(srfi-4#f64vector (#(procedure #:clean #:enforce) srfi-4#f64vector (#!rest (or integer float)) (struct f64vector)))
-(srfi-4#f64vector->blob (#(procedure #:clean #:enforce) srfi-4#f64vector->blob ((struct f64vector)) blob))
-(srfi-4#f64vector->blob/shared (#(procedure #:clean #:enforce) srfi-4#f64vector->blob/shared ((struct f64vector)) blob))
-(srfi-4#f64vector->list (#(procedure #:clean #:enforce) srfi-4#f64vector->list ((struct f64vector)) (list-of float)))
-
-(srfi-4#f64vector-length (#(procedure #:clean #:enforce) srfi-4#f64vector-length ((struct f64vector)) fixnum)
- (((struct f64vector)) (##core#inline "C_u_i_64vector_length" #(1))))
-
-(srfi-4#f64vector-ref (#(procedure #:clean #:enforce) srfi-4#f64vector-ref ((struct f64vector) fixnum) float))
-(srfi-4#f64vector-set! (#(procedure #:clean #:enforce) srfi-4#f64vector-set! ((struct f64vector) fixnum (or integer float)) undefined))
-
-(srfi-4#f64vector? (#(procedure #:pure #:predicate (struct f64vector)) srfi-4#f64vector? (*) boolean))
-
-(srfi-4#list->f32vector (#(procedure #:clean #:enforce) srfi-4#list->f32vector ((list-of (or float integer))) (struct f32vector)))
-(srfi-4#list->f64vector (#(procedure #:clean #:enforce) srfi-4#list->f64vector ((list-of (or float integer))) (struct f64vector)))
-(srfi-4#list->s16vector (#(procedure #:clean #:enforce) srfi-4#list->s16vector ((list-of fixnum)) (struct s16vector)))
-(srfi-4#list->s32vector (#(procedure #:clean #:enforce) srfi-4#list->s32vector ((list-of integer)) (struct s32vector)))
-(srfi-4#list->s8vector (#(procedure #:clean #:enforce) srfi-4#list->s8vector ((list-of fixnum)) (struct s8vector)))
-(srfi-4#list->u16vector (#(procedure #:clean #:enforce) srfi-4#list->u16vector ((list-of fixnum)) (struct u16vector)))
-(srfi-4#list->u32vector (#(procedure #:clean #:enforce) srfi-4#list->u32vector ((list-of integer)) (struct u32vector)))
-(srfi-4#list->u64vector (#(procedure #:clean #:enforce) srfi-4#list->u64vector ((list-of integer)) (struct u64vector)))
-(srfi-4#list->u8vector (#(procedure #:clean #:enforce) srfi-4#list->u8vector ((list-of fixnum)) (struct u8vector)))
-(srfi-4#make-f32vector (#(procedure #:clean #:enforce) srfi-4#make-f32vector (fixnum #!optional (or integer float false) boolean boolean) (struct f32vector)))
-(srfi-4#make-f64vector (#(procedure #:clean #:enforce) srfi-4#make-f64vector (fixnum #!optional (or integer float false) boolean) (struct f64vector)))
-(srfi-4#make-s16vector (#(procedure #:clean #:enforce) srfi-4#make-s16vector (fixnum #!optional (or fixnum false) boolean boolean) (struct s16vector)))
-(srfi-4#make-s32vector (#(procedure #:clean #:enforce) srfi-4#make-s32vector (fixnum #!optional (or integer false) boolean boolean) (struct s32vector)))
-(srfi-4#make-s8vector (#(procedure #:clean #:enforce) srfi-4#make-s8vector (fixnum #!optional (or fixnum false) boolean boolean) (struct s8vector)))
-(srfi-4#make-u16vector (#(procedure #:clean #:enforce) srfi-4#make-u16vector (fixnum #!optional (or fixnum false) boolean boolean) (struct u16vector)))
-(srfi-4#make-u32vector (#(procedure #:clean #:enforce) srfi-4#make-u32vector (fixnum #!optional (or integer false) boolean boolean) (struct u32vector)))
-(srfi-4#make-u64vector (#(procedure #:clean #:enforce) srfi-4#make-u64vector (fixnum #!optional (or integer false) boolean boolean) (struct u64vector)))
-(srfi-4#make-u8vector (#(procedure #:clean #:enforce) srfi-4#make-u8vector (fixnum #!optional (or fixnum false) boolean boolean) (struct u8vector)))
-(srfi-4#read-u8vector (#(procedure #:enforce) srfi-4#read-u8vector (#!optional (or fixnum false) input-port) (or (struct u8vector) eof)))
-(srfi-4#read-u8vector! (#(procedure #:enforce) srfi-4#read-u8vector! ((or fixnum false) (struct u8vector) #!optional input-port fixnum) integer))
-(srfi-4#release-number-vector (procedure srfi-4#release-number-vector (*) undefined))
-(srfi-4#s16vector (#(procedure #:clean #:enforce) srfi-4#s16vector (#!rest fixnum) (struct s16vector)))
-(srfi-4#s16vector->blob (#(procedure #:clean #:enforce) srfi-4#s16vector->blob ((struct s16vector)) blob))
-(srfi-4#s16vector->blob/shared (#(procedure #:clean #:enforce) srfi-4#s16vector->blob/shared ((struct s16vector)) blob))
-(srfi-4#s16vector->list (#(procedure #:clean #:enforce) srfi-4#s16vector->list ((struct s16vector)) (list-of fixnum)))
-
-(srfi-4#s16vector-length (#(procedure #:clean #:enforce) srfi-4#s16vector-length ((struct s16vector)) fixnum)
- (((struct s16vector)) (##core#inline "C_u_i_16vector_length" #(1))))
-
-(srfi-4#s16vector-ref (#(procedure #:clean #:enforce) srfi-4#s16vector-ref ((struct s16vector) fixnum) fixnum))
-(srfi-4#s16vector-set! (#(procedure #:clean #:enforce) srfi-4#s16vector-set! ((struct s16vector) fixnum fixnum) undefined))
-
-(srfi-4#s16vector? (#(procedure #:pure #:predicate (struct s16vector)) srfi-4#s16vector? (*) boolean))
-
-(srfi-4#s32vector (#(procedure #:clean #:enforce) srfi-4#s32vector (#!rest integer) (struct s32vector)))
-(srfi-4#s32vector->blob (#(procedure #:clean #:enforce) srfi-4#s32vector->blob ((struct s32vector)) blob))
-(srfi-4#s32vector->blob/shared (#(procedure #:clean #:enforce) srfi-4#s32vector->blob/shared ((struct s32vector)) blob))
-(srfi-4#s32vector->list (#(procedure #:clean #:enforce) srfi-4#s32vector->list ((struct s32vector)) (list-of integer)))
-
-(srfi-4#s32vector-length (#(procedure #:clean #:enforce) srfi-4#s32vector-length ((struct s32vector)) fixnum)
- (((struct s32vector)) (##core#inline "C_u_i_32vector_length" #(1))))
-
-(srfi-4#s32vector-ref (#(procedure #:clean #:enforce) srfi-4#s32vector-ref ((struct s32vector) fixnum) integer))
-(srfi-4#s32vector-set! (#(procedure #:clean #:enforce) srfi-4#s32vector-set! ((struct s32vector) fixnum integer) undefined))
-
-(srfi-4#s32vector? (#(procedure #:pure #:predicate (struct s32vector)) srfi-4#s32vector? (*) boolean))
-
-(srfi-4#s8vector (#(procedure #:clean #:enforce) srfi-4#s8vector (#!rest fixnum) (struct s8vector)))
-(srfi-4#s8vector->blob (#(procedure #:clean #:enforce) srfi-4#s8vector->blob ((struct s8vector)) blob))
-(srfi-4#s8vector->blob/shared (#(procedure #:clean #:enforce) srfi-4#s8vector->blob/shared ((struct s8vector)) blob))
-(srfi-4#s8vector->list (#(procedure #:clean #:enforce) srfi-4#s8vector->list ((struct s8vector)) (list-of fixnum)))
-
-(srfi-4#s8vector-length (#(procedure #:clean #:enforce) srfi-4#s8vector-length ((struct s8vector)) fixnum)
- (((struct s8vector)) (##core#inline "C_u_i_8vector_length" #(1))))
-
-(srfi-4#s8vector-ref (#(procedure #:clean #:enforce) srfi-4#s8vector-ref ((struct s8vector) fixnum) fixnum))
-(srfi-4#s8vector-set! (#(procedure #:clean #:enforce) srfi-4#s8vector-set! ((struct s8vector) fixnum fixnum) undefined))
-
-(srfi-4#s8vector? (#(procedure #:pure #:predicate (struct s8vector)) srfi-4#s8vector? (*) boolean))
-
-(srfi-4#subf32vector (#(procedure #:clean #:enforce) srfi-4#subf32vector ((struct f32vector) fixnum fixnum) (struct f32vector)))
-(srfi-4#subf64vector (#(procedure #:clean #:enforce) srfi-4#subf64vector ((struct f64vector) fixnum fixnum) (struct f64vector)))
-(srfi-4#subs16vector (#(procedure #:clean #:enforce) srfi-4#subs16vector ((struct s16vector) fixnum fixnum) (struct s16vector)))
-(srfi-4#subs32vector (#(procedure #:clean #:enforce) srfi-4#subs32vector ((struct s32vector) fixnum fixnum) (struct s32vector)))
-(srfi-4#subs8vector (#(procedure #:clean #:enforce) srfi-4#subs8vector ((struct s8vector) fixnum fixnum) (struct s8vector)))
-(srfi-4#subu16vector (#(procedure #:clean #:enforce) srfi-4#subu16vector ((struct u16vector) fixnum fixnum) (struct u16vector)))
-(srfi-4#subu32vector (#(procedure #:clean #:enforce) srfi-4#subu32vector ((struct u32vector) fixnum fixnum) (struct u32vector)))
-(srfi-4#subu64vector (#(procedure #:clean #:enforce) srfi-4#subu64vector ((struct u64vector) fixnum fixnum) (struct u64vector)))
-(srfi-4#subu8vector (#(procedure #:clean #:enforce) srfi-4#subu8vector ((struct u8vector) fixnum fixnum) (struct u8vector)))
-(srfi-4#u16vector (#(procedure #:clean #:enforce) srfi-4#u16vector (#!rest fixnum) (struct u16vector)))
-(srfi-4#u16vector->blob (#(procedure #:clean #:enforce) srfi-4#u16vector->blob ((struct u16vector)) blob))
-(srfi-4#u16vector->blob/shared (#(procedure #:clean #:enforce) srfi-4#u16vector->blob/shared ((struct u16vector)) blob))
-(srfi-4#u16vector->list (#(procedure #:clean #:enforce) srfi-4#u16vector->list ((struct u16vector)) (list-of fixnum)))
-
-(srfi-4#u16vector-length (#(procedure #:clean #:enforce) srfi-4#u16vector-length ((struct u16vector)) fixnum)
- (((struct u16vector)) (##core#inline "C_u_i_16vector_length" #(1))))
-
-(srfi-4#u16vector-ref (#(procedure #:clean #:enforce) srfi-4#u16vector-ref ((struct u16vector) fixnum) fixnum))
-(srfi-4#u16vector-set! (#(procedure #:clean #:enforce) srfi-4#u16vector-set! ((struct u16vector) fixnum fixnum) undefined))
-
-(srfi-4#u16vector? (#(procedure #:pure #:predicate (struct u16vector)) srfi-4#u16vector? (*) boolean))
-
-(srfi-4#u32vector (#(procedure #:clean #:enforce) srfi-4#u32vector (#!rest integer) (struct u32vector)))
-(srfi-4#u32vector->blob (#(procedure #:clean #:enforce) srfi-4#u32vector->blob ((struct u32vector)) blob))
-(srfi-4#u32vector->blob/shared (#(procedure #:clean #:enforce) srfi-4#u32vector->blob/shared ((struct u32vector)) blob))
-(srfi-4#u32vector->list (#(procedure #:clean #:enforce) srfi-4#u32vector->list ((struct u32vector)) (list-of integer)))
-
-(srfi-4#u32vector-length (#(procedure #:clean #:enforce) srfi-4#u32vector-length ((struct u32vector)) fixnum)
- (((struct u32vector)) (##core#inline "C_u_i_32vector_length" #(1))))
-
-(srfi-4#u32vector-ref (#(procedure #:clean #:enforce) srfi-4#u32vector-ref ((struct u32vector) fixnum) integer))
-(srfi-4#u32vector-set! (#(procedure #:clean #:enforce) srfi-4#u32vector-set! ((struct u32vector) fixnum integer) undefined))
-
-(srfi-4#u32vector? (#(procedure #:pure #:predicate (struct u32vector)) srfi-4#u32vector? (*) boolean))
-
-(srfi-4#u64vector (#(procedure #:clean #:enforce) srfi-4#u64vector (#!rest integer) (struct u64vector)))
-(srfi-4#u64vector->blob (#(procedure #:clean #:enforce) srfi-4#u64vector->blob ((struct u64vector)) blob))
-(srfi-4#u64vector->blob/shared (#(procedure #:clean #:enforce) srfi-4#u64vector->blob/shared ((struct u64vector)) blob))
-(srfi-4#u64vector->list (#(procedure #:clean #:enforce) srfi-4#u64vector->list ((struct u64vector)) (list-of integer)))
-
-(srfi-4#u64vector-length (#(procedure #:clean #:enforce) srfi-4#u64vector-length ((struct u64vector)) fixnum)
- (((struct u64vector)) (##core#inline "C_u_i_64vector_length" #(1))))
-
-(srfi-4#u64vector-ref (#(procedure #:clean #:enforce) srfi-4#u64vector-ref ((struct u64vector) fixnum) integer))
-(srfi-4#u64vector-set! (#(procedure #:clean #:enforce) srfi-4#u64vector-set! ((struct u64vector) fixnum integer) undefined))
-
-(srfi-4#u64vector? (#(procedure #:pure #:predicate (struct u64vector)) srfi-4#u64vector? (*) boolean))
-
-(srfi-4#u8vector (#(procedure #:clean #:enforce) srfi-4#u8vector (#!rest fixnum) (struct u8vector)))
-(srfi-4#u8vector->blob (#(procedure #:clean #:enforce) srfi-4#u8vector->blob ((struct u8vector)) blob))
-(srfi-4#u8vector->blob/shared (#(procedure #:clean #:enforce) srfi-4#u8vector->blob/shared ((struct u8vector)) blob))
-(srfi-4#u8vector->list (#(procedure #:clean #:enforce) srfi-4#u8vector->list ((struct u8vector)) (list-of fixnum)))
-
-(srfi-4#u8vector-length (#(procedure #:clean #:enforce) srfi-4#u8vector-length ((struct u8vector)) fixnum)
- (((struct u8vector)) (##core#inline "C_u_i_8vector_length" #(1))))
-
-(srfi-4#u8vector-ref (#(procedure #:clean #:enforce) srfi-4#u8vector-ref ((struct u8vector) fixnum) fixnum))
-(srfi-4#u8vector-set! (#(procedure #:clean #:enforce) srfi-4#u8vector-set! ((struct u8vector) fixnum fixnum) undefined))
-
-(srfi-4#u8vector? (#(procedure #:pure #:predicate (struct u8vector)) srfi-4#u8vector? (*) boolean))
-
-(srfi-4#write-u8vector (#(procedure #:enforce) srfi-4#write-u8vector ((struct u8vector) #!optional output-port fixnum fixnum) undefined))
-
-(srfi-4#number-vector? (#(procedure #:pure #:predicate (or (struct u8vector) (struct u16vector) (struct s8vector) (struct s16vector) (struct u32vector) (struct s32vector) (struct u64vector) (struct s64vector) (struct f32vector) (struct f64vector))) srfi-4#number-vector? (*) boolean))
-(##sys#srfi-4-vector? (#(procedure #:pure #:predicate (or (struct u8vector) (struct u16vector) (struct s8vector) (struct s16vector) (struct u32vector) (struct s32vector) (struct u64vector) (struct s64vector) (struct f32vector) (struct f64vector))) ##sys#srfi-4-vector? (*) boolean))
+;; (chicken number-vector)
+
+(chicken.number-vector#bytevector->c128vector (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->c128vector (bytevector) (struct c128vector)))
+(chicken.number-vector#bytevector->c128vector/shared (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->c128vector/shared (bytevector) (struct c128vector)))
+(chicken.number-vector#bytevector->c64vector (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->c64vector (bytevector) (struct c64vector)))
+(chicken.number-vector#bytevector->c64vector/shared (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->c64vector/shared (bytevector) (struct c64vector)))
+(chicken.number-vector#bytevector->f32vector (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->f32vector (bytevector) (struct f32vector)))
+(chicken.number-vector#bytevector->f32vector/shared (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->f32vector/shared (bytevector) (struct f32vector)))
+(chicken.number-vector#bytevector->f64vector (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->f64vector (bytevector) (struct f64vector)))
+(chicken.number-vector#bytevector->f64vector/shared (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->f64vector/shared (bytevector) (struct f64vector)))
+(chicken.number-vector#bytevector->s16vector (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->s16vector (bytevector) (struct s16vector)))
+(chicken.number-vector#bytevector->s16vector/shared (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->s16vector/shared (bytevector) (struct s16vector)))
+(chicken.number-vector#bytevector->s32vector (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->s32vector (bytevector) (struct s32vector)))
+(chicken.number-vector#bytevector->s32vector/shared (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->s32vector/shared (bytevector) (struct s32vector)))
+(chicken.number-vector#bytevector->s8vector (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->s8vector (bytevector) (struct s8vector)))
+(chicken.number-vector#bytevector->s8vector/shared (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->s8vector/shared (bytevector) (struct s8vector)))
+(chicken.number-vector#bytevector->u16vector (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->u16vector (bytevector) (struct u16vector)))
+(chicken.number-vector#bytevector->u16vector/shared (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->u16vector/shared (bytevector) (struct u16vector)))
+(chicken.number-vector#bytevector->u32vector (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->u32vector (bytevector) (struct u32vector)))
+(chicken.number-vector#bytevector->u32vector/shared (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->u32vector/shared (bytevector) (struct u32vector)))
+(chicken.number-vector#bytevector->u64vector (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->u64vector (bytevector) (struct u64vector)))
+(chicken.number-vector#bytevector->u64vector/shared (#(procedure #:clean #:enforce) chicken.number-vector#bytevector->u64vector/shared (bytevector) (struct u64vector)))
+(chicken.number-vector#c128vector->bytevector (#(procedure #:clean #:enforce) chicken.number-vector#c128vector->bytevector ((struct c128vector)) bytevector))
+(chicken.number-vector#c128vector->bytevector/shared (#(procedure #:clean #:enforce) chicken.number-vector#c128vector->bytevector/shared ((struct c128vector)) bytevector))
+(chicken.number-vector#c128vector-length (#(procedure #:clean #:enforce) chicken.number-vector#c128vector-length ((struct c128vector)) fixnum))
+(chicken.number-vector#c128vector->list (#(procedure #:clean #:enforce) chicken.number-vector#c128vector->list ((struct c128vector)) (list-of float)))
+(chicken.number-vector#c128vector (#(procedure #:clean #:enforce) chicken.number-vector#c128vector (#!rest (or integer float)) (struct c128vector)))
+(chicken.number-vector#c128vector? (#(procedure #:pure #:predicate (struct c128vector)) chicken.number-vector#c128vector? (*) boolean))
+(chicken.number-vector#c128vector-ref (#(procedure #:clean #:enforce) chicken.number-vector#c128vector-ref ((struct c128vector) fixnum) float))
+(chicken.number-vector#c128vector-set! (#(procedure #:clean #:enforce) chicken.number-vector#c128vector-set! ((struct c128vector) fixnum (or integer float)) undefined))
+(chicken.number-vector#c64vector->bytevector (#(procedure #:clean #:enforce) chicken.number-vector#c64vector->bytevector ((struct c64vector)) bytevector))
+(chicken.number-vector#c64vector->bytevector/shared (#(procedure #:clean #:enforce) chicken.number-vector#c64vector->bytevector/shared ((struct c64vector)) bytevector))
+(chicken.number-vector#c64vector-length (#(procedure #:clean #:enforce) chicken.number-vector#c64vector-length ((struct c64vector)) fixnum))
+(chicken.number-vector#c64vector->list (#(procedure #:clean #:enforce) chicken.number-vector#c64vector->list ((struct c64vector)) (list-of float)))
+(chicken.number-vector#c64vector (#(procedure #:clean #:enforce) chicken.number-vector#c64vector (#!rest (or integer float)) (struct c64vector)))
+(chicken.number-vector#c64vector? (#(procedure #:pure #:predicate (struct c64vector)) chicken.number-vector#c64vector? (*) boolean))
+(chicken.number-vector#c64vector-ref (#(procedure #:clean #:enforce) chicken.number-vector#c64vector-ref ((struct c64vector) fixnum) float))
+(chicken.number-vector#c64vector-set! (#(procedure #:clean #:enforce) chicken.number-vector#c64vector-set! ((struct c64vector) fixnum (or integer float)) undefined))
+(chicken.number-vector#f32vector->bytevector (#(procedure #:clean #:enforce) chicken.number-vector#f32vector->bytevector ((struct f32vector)) bytevector))
+(chicken.number-vector#f32vector->bytevector/shared (#(procedure #:clean #:enforce) chicken.number-vector#f32vector->bytevector/shared ((struct f32vector)) bytevector))
+(chicken.number-vector#f32vector-length (#(procedure #:clean #:enforce) chicken.number-vector#f32vector-length ((struct f32vector)) fixnum) (((struct f32vector)) (##core#inline "C_u_i_32vector_length" #(1))))
+(chicken.number-vector#f32vector->list (#(procedure #:clean #:enforce) chicken.number-vector#f32vector->list ((struct f32vector)) (list-of float)))
+(chicken.number-vector#f32vector (#(procedure #:clean #:enforce) chicken.number-vector#f32vector (#!rest (or integer float)) (struct f32vector)))
+(chicken.number-vector#f32vector? (#(procedure #:pure #:predicate (struct f32vector)) chicken.number-vector#f32vector? (*) boolean))
+(chicken.number-vector#f32vector-ref (#(procedure #:clean #:enforce) chicken.number-vector#f32vector-ref ((struct f32vector) fixnum) float))
+(chicken.number-vector#f32vector-set! (#(procedure #:clean #:enforce) chicken.number-vector#f32vector-set! ((struct f32vector) fixnum (or integer float)) undefined))
+(chicken.number-vector#f64vector->bytevector (#(procedure #:clean #:enforce) chicken.number-vector#f64vector->bytevector ((struct f64vector)) bytevector))
+(chicken.number-vector#f64vector->bytevector/shared (#(procedure #:clean #:enforce) chicken.number-vector#f64vector->bytevector/shared ((struct f64vector)) bytevector))
+(chicken.number-vector#f64vector-length (#(procedure #:clean #:enforce) chicken.number-vector#f64vector-length ((struct f64vector)) fixnum) (((struct f64vector)) (##core#inline "C_u_i_64vector_length" #(1))))
+(chicken.number-vector#f64vector->list (#(procedure #:clean #:enforce) chicken.number-vector#f64vector->list ((struct f64vector)) (list-of float)))
+(chicken.number-vector#f64vector (#(procedure #:clean #:enforce) chicken.number-vector#f64vector (#!rest (or integer float)) (struct f64vector)))
+(chicken.number-vector#f64vector? (#(procedure #:pure #:predicate (struct f64vector)) chicken.number-vector#f64vector? (*) boolean))
+(chicken.number-vector#f64vector-ref (#(procedure #:clean #:enforce) chicken.number-vector#f64vector-ref ((struct f64vector) fixnum) float))
+(chicken.number-vector#f64vector-set! (#(procedure #:clean #:enforce) chicken.number-vector#f64vector-set! ((struct f64vector) fixnum (or integer float)) undefined))
+(chicken.number-vector#list->c128vector (#(procedure #:clean #:enforce) chicken.number-vector#list->c128vector ((list-of integer)) (struct c128vector)))
+(chicken.number-vector#list->c64vector (#(procedure #:clean #:enforce) chicken.number-vector#list->c64vector ((list-of integer)) (struct c64vector)))
+(chicken.number-vector#list->f32vector (#(procedure #:clean #:enforce) chicken.number-vector#list->f32vector ((list-of (or float integer))) (struct f32vector)))
+(chicken.number-vector#list->f64vector (#(procedure #:clean #:enforce) chicken.number-vector#list->f64vector ((list-of (or float integer))) (struct f64vector)))
+(chicken.number-vector#list->s16vector (#(procedure #:clean #:enforce) chicken.number-vector#list->s16vector ((list-of fixnum)) (struct s16vector)))
+(chicken.number-vector#list->s32vector (#(procedure #:clean #:enforce) chicken.number-vector#list->s32vector ((list-of integer)) (struct s32vector)))
+(chicken.number-vector#list->s8vector (#(procedure #:clean #:enforce) chicken.number-vector#list->s8vector ((list-of fixnum)) (struct s8vector)))
+(chicken.number-vector#list->u16vector (#(procedure #:clean #:enforce) chicken.number-vector#list->u16vector ((list-of fixnum)) (struct u16vector)))
+(chicken.number-vector#list->u32vector (#(procedure #:clean #:enforce) chicken.number-vector#list->u32vector ((list-of integer)) (struct u32vector)))
+(chicken.number-vector#list->u64vector (#(procedure #:clean #:enforce) chicken.number-vector#list->u64vector ((list-of integer)) (struct u64vector)))
+(chicken.number-vector#list->u8vector (#(procedure #:clean #:enforce) chicken.number-vector#list->u8vector ((list-of fixnum)) bytevector))
+(chicken.number-vector#make-c128vector (#(procedure #:clean #:enforce) chicken.number-vector#make-c128vector (fixnum #!optional (or integer float false) boolean boolean) (struct c128vector)))
+(chicken.number-vector#make-c64vector (#(procedure #:clean #:enforce) chicken.number-vector#make-c64vector (fixnum #!optional (or integer float false) boolean boolean) (struct c64vector)))
+(chicken.number-vector#make-f32vector (#(procedure #:clean #:enforce) chicken.number-vector#make-f32vector (fixnum #!optional (or integer float false) boolean boolean) (struct f32vector)))
+(chicken.number-vector#make-f64vector (#(procedure #:clean #:enforce) chicken.number-vector#make-f64vector (fixnum #!optional (or integer float false) boolean) (struct f64vector)))
+(chicken.number-vector#make-s16vector (#(procedure #:clean #:enforce) chicken.number-vector#make-s16vector (fixnum #!optional (or fixnum false) boolean boolean) (struct s16vector)))
+(chicken.number-vector#make-s32vector (#(procedure #:clean #:enforce) chicken.number-vector#make-s32vector (fixnum #!optional (or integer false) boolean boolean) (struct s32vector)))
+(chicken.number-vector#make-s8vector (#(procedure #:clean #:enforce) chicken.number-vector#make-s8vector (fixnum #!optional (or fixnum false) boolean boolean) (struct s8vector)))
+(chicken.number-vector#make-u16vector (#(procedure #:clean #:enforce) chicken.number-vector#make-u16vector (fixnum #!optional (or fixnum false) boolean boolean) (struct u16vector)))
+(chicken.number-vector#make-u32vector (#(procedure #:clean #:enforce) chicken.number-vector#make-u32vector (fixnum #!optional (or integer false) boolean boolean) (struct u32vector)))
+(chicken.number-vector#make-u64vector (#(procedure #:clean #:enforce) chicken.number-vector#make-u64vector (fixnum #!optional (or integer false) boolean boolean) (struct u64vector)))
+(chicken.number-vector#make-u8vector (#(procedure #:clean #:enforce) chicken.number-vector#make-u8vector (fixnum #!optional (or fixnum false) boolean boolean) bytevector))
+(chicken.number-vector#number-vector? (#(procedure #:pure #:predicate (or bytevector (struct u16vector) (struct s8vector) (struct s16vector) (struct u32vector) (struct s32vector) (struct u64vector) (struct s64vector) (struct f32vector) (struct f64vector) (struct c64vector) (struct c128vector))) chicken.number-vector#number-vector? (*) boolean))
+(chicken.number-vector#release-number-vector (procedure chicken.number-vector#release-number-vector (*) undefined))
+(chicken.number-vector#s16vector->bytevector (#(procedure #:clean #:enforce) chicken.number-vector#s16vector->bytevector ((struct s16vector)) bytevector))
+(chicken.number-vector#s16vector->bytevector/shared (#(procedure #:clean #:enforce) chicken.number-vector#s16vector->bytevector/shared ((struct s16vector)) bytevector))
+(chicken.number-vector#s16vector-length (#(procedure #:clean #:enforce) chicken.number-vector#s16vector-length ((struct s16vector)) fixnum) (((struct s16vector)) (##core#inline "C_u_i_16vector_length" #(1))))
+(chicken.number-vector#s16vector->list (#(procedure #:clean #:enforce) chicken.number-vector#s16vector->list ((struct s16vector)) (list-of fixnum)))
+(chicken.number-vector#s16vector (#(procedure #:clean #:enforce) chicken.number-vector#s16vector (#!rest fixnum) (struct s16vector)))
+(chicken.number-vector#s16vector? (#(procedure #:pure #:predicate (struct s16vector)) chicken.number-vector#s16vector? (*) boolean))
+(chicken.number-vector#s16vector-ref (#(procedure #:clean #:enforce) chicken.number-vector#s16vector-ref ((struct s16vector) fixnum) fixnum))
+(chicken.number-vector#s16vector-set! (#(procedure #:clean #:enforce) chicken.number-vector#s16vector-set! ((struct s16vector) fixnum fixnum) undefined))
+(chicken.number-vector#s32vector->bytevector (#(procedure #:clean #:enforce) chicken.number-vector#s32vector->bytevector ((struct s32vector)) bytevector))
+(chicken.number-vector#s32vector->bytevector/shared (#(procedure #:clean #:enforce) chicken.number-vector#s32vector->bytevector/shared ((struct s32vector)) bytevector))
+(chicken.number-vector#s32vector-length (#(procedure #:clean #:enforce) chicken.number-vector#s32vector-length ((struct s32vector)) fixnum) (((struct s32vector)) (##core#inline "C_u_i_32vector_length" #(1))))
+(chicken.number-vector#s32vector->list (#(procedure #:clean #:enforce) chicken.number-vector#s32vector->list ((struct s32vector)) (list-of integer)))
+(chicken.number-vector#s32vector (#(procedure #:clean #:enforce) chicken.number-vector#s32vector (#!rest integer) (struct s32vector)))
+(chicken.number-vector#s32vector? (#(procedure #:pure #:predicate (struct s32vector)) chicken.number-vector#s32vector? (*) boolean))
+(chicken.number-vector#s32vector-ref (#(procedure #:clean #:enforce) chicken.number-vector#s32vector-ref ((struct s32vector) fixnum) integer))
+(chicken.number-vector#s32vector-set! (#(procedure #:clean #:enforce) chicken.number-vector#s32vector-set! ((struct s32vector) fixnum integer) undefined))
+(chicken.number-vector#s8vector->bytevector (#(procedure #:clean #:enforce) chicken.number-vector#s8vector->bytevector ((struct s8vector)) bytevector))
+(chicken.number-vector#s8vector->bytevector/shared (#(procedure #:clean #:enforce) chicken.number-vector#s8vector->bytevector/shared ((struct s8vector)) bytevector))
+(chicken.number-vector#s8vector-length (#(procedure #:clean #:enforce) chicken.number-vector#s8vector-length ((struct s8vector)) fixnum) (((struct s8vector)) (##core#inline "C_u_i_8vector_length" #(1))))
+(chicken.number-vector#s8vector->list (#(procedure #:clean #:enforce) chicken.number-vector#s8vector->list ((struct s8vector)) (list-of fixnum)))
+(chicken.number-vector#s8vector (#(procedure #:clean #:enforce) chicken.number-vector#s8vector (#!rest fixnum) (struct s8vector)))
+(chicken.number-vector#s8vector? (#(procedure #:pure #:predicate (struct s8vector)) chicken.number-vector#s8vector? (*) boolean))
+(chicken.number-vector#s8vector-ref (#(procedure #:clean #:enforce) chicken.number-vector#s8vector-ref ((struct s8vector) fixnum) fixnum))
+(chicken.number-vector#s8vector-set! (#(procedure #:clean #:enforce) chicken.number-vector#s8vector-set! ((struct s8vector) fixnum fixnum) undefined))
+(chicken.number-vector#subc128vector (#(procedure #:clean #:enforce) chicken.number-vector#subc128vector ((struct c128vector) fixnum fixnum) (struct c128vector)))
+(chicken.number-vector#subc64vector (#(procedure #:clean #:enforce) chicken.number-vector#subc64vector ((struct c64vector) fixnum fixnum) (struct c64vector)))
+(chicken.number-vector#subf32vector (#(procedure #:clean #:enforce) chicken.number-vector#subf32vector ((struct f32vector) fixnum fixnum) (struct f32vector)))
+(chicken.number-vector#subf64vector (#(procedure #:clean #:enforce) chicken.number-vector#subf64vector ((struct f64vector) fixnum fixnum) (struct f64vector)))
+(chicken.number-vector#subs16vector (#(procedure #:clean #:enforce) chicken.number-vector#subs16vector ((struct s16vector) fixnum fixnum) (struct s16vector)))
+(chicken.number-vector#subs32vector (#(procedure #:clean #:enforce) chicken.number-vector#subs32vector ((struct s32vector) fixnum fixnum) (struct s32vector)))
+(chicken.number-vector#subs8vector (#(procedure #:clean #:enforce) chicken.number-vector#subs8vector ((struct s8vector) fixnum fixnum) (struct s8vector)))
+(chicken.number-vector#subu16vector (#(procedure #:clean #:enforce) chicken.number-vector#subu16vector ((struct u16vector) fixnum fixnum) (struct u16vector)))
+(chicken.number-vector#subu32vector (#(procedure #:clean #:enforce) chicken.number-vector#subu32vector ((struct u32vector) fixnum fixnum) (struct u32vector)))
+(chicken.number-vector#subu64vector (#(procedure #:clean #:enforce) chicken.number-vector#subu64vector ((struct u64vector) fixnum fixnum) (struct u64vector)))
+(chicken.number-vector#subu8vector (#(procedure #:clean #:enforce) chicken.number-vector#subu8vector (bytevector fixnum fixnum) bytevector))
+(chicken.number-vector#u16vector->bytevector (#(procedure #:clean #:enforce) chicken.number-vector#u16vector->bytevector ((struct u16vector)) bytevector))
+(chicken.number-vector#u16vector->bytevector/shared (#(procedure #:clean #:enforce) chicken.number-vector#u16vector->bytevector/shared ((struct u16vector)) bytevector))
+(chicken.number-vector#u16vector-length (#(procedure #:clean #:enforce) chicken.number-vector#u16vector-length ((struct u16vector)) fixnum) (((struct u16vector)) (##core#inline "C_u_i_16vector_length" #(1))))
+(chicken.number-vector#u16vector->list (#(procedure #:clean #:enforce) chicken.number-vector#u16vector->list ((struct u16vector)) (list-of fixnum)))
+(chicken.number-vector#u16vector (#(procedure #:clean #:enforce) chicken.number-vector#u16vector (#!rest fixnum) (struct u16vector)))
+(chicken.number-vector#u16vector? (#(procedure #:pure #:predicate (struct u16vector)) chicken.number-vector#u16vector? (*) boolean))
+(chicken.number-vector#u16vector-ref (#(procedure #:clean #:enforce) chicken.number-vector#u16vector-ref ((struct u16vector) fixnum) fixnum))
+(chicken.number-vector#u16vector-set! (#(procedure #:clean #:enforce) chicken.number-vector#u16vector-set! ((struct u16vector) fixnum fixnum) undefined))
+(chicken.number-vector#u32vector->bytevector (#(procedure #:clean #:enforce) chicken.number-vector#u32vector->bytevector ((struct u32vector)) bytevector))
+(chicken.number-vector#u32vector->bytevector/shared (#(procedure #:clean #:enforce) chicken.number-vector#u32vector->bytevector/shared ((struct u32vector)) bytevector))
+(chicken.number-vector#u32vector-length (#(procedure #:clean #:enforce) chicken.number-vector#u32vector-length ((struct u32vector)) fixnum) (((struct u32vector)) (##core#inline "C_u_i_32vector_length" #(1))))
+(chicken.number-vector#u32vector->list (#(procedure #:clean #:enforce) chicken.number-vector#u32vector->list ((struct u32vector)) (list-of integer)))
+(chicken.number-vector#u32vector (#(procedure #:clean #:enforce) chicken.number-vector#u32vector (#!rest integer) (struct u32vector)))
+(chicken.number-vector#u32vector? (#(procedure #:pure #:predicate (struct u32vector)) chicken.number-vector#u32vector? (*) boolean))
+(chicken.number-vector#u32vector-ref (#(procedure #:clean #:enforce) chicken.number-vector#u32vector-ref ((struct u32vector) fixnum) integer))
+(chicken.number-vector#u32vector-set! (#(procedure #:clean #:enforce) chicken.number-vector#u32vector-set! ((struct u32vector) fixnum integer) undefined))
+(chicken.number-vector#u64vector->bytevector (#(procedure #:clean #:enforce) chicken.number-vector#u64vector->bytevector ((struct u64vector)) bytevector))
+(chicken.number-vector#u64vector->bytevector/shared (#(procedure #:clean #:enforce) chicken.number-vector#u64vector->bytevector/shared ((struct u64vector)) bytevector))
+(chicken.number-vector#u64vector-length (#(procedure #:clean #:enforce) chicken.number-vector#u64vector-length ((struct u64vector)) fixnum) (((struct u64vector)) (##core#inline "C_u_i_64vector_length" #(1))))
+(chicken.number-vector#u64vector->list (#(procedure #:clean #:enforce) chicken.number-vector#u64vector->list ((struct u64vector)) (list-of integer)))
+(chicken.number-vector#u64vector (#(procedure #:clean #:enforce) chicken.number-vector#u64vector (#!rest integer) (struct u64vector)))
+(chicken.number-vector#u64vector? (#(procedure #:pure #:predicate (struct u64vector)) chicken.number-vector#u64vector? (*) boolean))
+(chicken.number-vector#u64vector-ref (#(procedure #:clean #:enforce) chicken.number-vector#u64vector-ref ((struct u64vector) fixnum) integer))
+(chicken.number-vector#u64vector-set! (#(procedure #:clean #:enforce) chicken.number-vector#u64vector-set! ((struct u64vector) fixnum integer) undefined))
+(chicken.number-vector#u8vector-length (#(procedure #:clean #:enforce) chicken.number-vector#u8vector-length (bytevector) fixnum) ((bytevector) (##core#inline "C_u_i_8vector_length" #(1))))
+(chicken.number-vector#u8vector->list (#(procedure #:clean #:enforce) chicken.number-vector#u8vector->list (bytevector) (list-of fixnum)))
+(chicken.number-vector#u8vector (#(procedure #:clean #:enforce) chicken.number-vector#u8vector (#!rest fixnum) bytevector))
+(chicken.number-vector#u8vector? (#(procedure #:pure #:predicate bytevector) chicken.number-vector#u8vector? (*) boolean))
+(chicken.number-vector#u8vector-ref (#(procedure #:clean #:enforce) chicken.number-vector#u8vector-ref (bytevector fixnum) fixnum))
+(chicken.number-vector#u8vector-set! (#(procedure #:clean #:enforce) chicken.number-vector#u8vector-set! (bytevector fixnum fixnum) undefined))
+(##sys#srfi-4-vector? (#(procedure #:pure #:predicate (or bytevector (struct u16vector) (struct s8vector) (struct s16vector) (struct u32vector) (struct s32vector) (struct u64vector) (struct s64vector) (struct f32vector) (struct f64vector) (struct c64vector) (struct c128vector))) ##sys#srfi-4-vector? (*) boolean))
;; syntax
@@ -2365,18 +2427,17 @@
(struct transformer)))
(chicken.syntax#read-with-source-info (#(procedure #:enforce) chicken.syntax#read-with-source-info (#!optional input-port) *))
(chicken.syntax#strip-syntax (#(procedure #:clean) chicken.syntax#strip-syntax (*) *))
-(chicken.syntax#syntax-error (procedure chicken.syntax#syntax-error (* #!rest) noreturn))
;; tcp
(chicken.tcp#tcp-abandon-port (#(procedure #:clean #:enforce) chicken.tcp#tcp-abandon-port (port) undefined))
-(chicken.tcp#tcp-accept (#(procedure #:clean #:enforce) chicken.tcp#tcp-accept ((struct tcp-listener)) input-port output-port))
+(chicken.tcp#tcp-accept (#(procedure #:clean #:enforce) chicken.tcp#tcp-accept ((struct tcp-listener) #!optional symbol) input-port output-port))
(chicken.tcp#tcp-accept-ready? (#(procedure #:clean #:enforce) chicken.tcp#tcp-accept-ready? ((struct tcp-listener)) boolean))
(chicken.tcp#tcp-accept-timeout (#(procedure #:clean #:enforce) chicken.tcp#tcp-accept-timeout (#!optional (or false integer)) (or false integer)))
(chicken.tcp#tcp-addresses (#(procedure #:clean #:enforce) chicken.tcp#tcp-addresses (port) string string))
(chicken.tcp#tcp-buffer-size (#(procedure #:clean #:enforce) chicken.tcp#tcp-buffer-size (#!optional (or false fixnum)) (or false fixnum)))
(chicken.tcp#tcp-close (#(procedure #:clean #:enforce) chicken.tcp#tcp-close ((struct tcp-listener)) undefined))
-(chicken.tcp#tcp-connect (#(procedure #:clean #:enforce) chicken.tcp#tcp-connect (string #!optional fixnum) input-port output-port))
+(chicken.tcp#tcp-connect (#(procedure #:clean #:enforce) chicken.tcp#tcp-connect (string #!optional fixnum symbol) input-port output-port))
(chicken.tcp#tcp-connect-timeout (#(procedure #:clean #:enforce) chicken.tcp#tcp-connect-timeout (#!optional (or false integer)) (or false integer)))
(chicken.tcp#tcp-listen (#(procedure #:clean #:enforce) chicken.tcp#tcp-listen (fixnum #!optional fixnum *) (struct tcp-listener)))
@@ -2391,6 +2452,22 @@
(chicken.tcp#tcp-read-timeout (#(procedure #:clean #:enforce) chicken.tcp#tcp-read-timeout (#!optional (or false integer)) (or false integer)))
(chicken.tcp#tcp-write-timeout (#(procedure #:clean #:enforce) chicken.tcp#tcp-write-timeout (#!optional (or false integer)) (or false integer)))
-
;; Undocumented internal module, only here to have the deprecation warning because some eggs use it
(chicken.compiler.support#read/source-info deprecated)
+
+;; scheme.write
+
+(scheme.write#write (#(procedure #:enforce) scheme.write#write (* #!optional output-port) undefined))
+(scheme.write#write-shared (#(procedure #:enforce) scheme.write#write-shared (* #!optional output-port) undefined))
+(scheme.write#display (#(procedure #:enforce) scheme.write#display (* #!optional output-port) undefined))
+
+;; scheme.time
+
+(scheme.time#current-second (#(procedure #:enforce) scheme.time#current-second () float))
+(scheme.time#current-jiffy (#(procedure #:enforce) scheme.time#current-jiffy () fixnum))
+(scheme.time#jiffies-per-second (#(procedure #:enforce) scheme.time#jiffies-per-second () fixnum))
+
+;; scheme.process-context
+
+(scheme.process-context#exit (procedure scheme.process-context#exit (#!optional *) noreturn))
+(scheme.process-context#command-line (procedure scheme.process-context#command-line () (list-of string)))
diff --git a/user-pass.scm b/user-pass.scm
index 2afbffd8..916730ba 100644
--- a/user-pass.scm
+++ b/user-pass.scm
@@ -32,7 +32,7 @@
user-pass
user-post-analysis-pass)
-(import scheme chicken.base)
+(import scheme (only (scheme base) make-parameter))
(define user-options-pass (make-parameter #f))
(define user-read-pass (make-parameter #f))
diff --git a/utf.c b/utf.c
new file mode 100644
index 00000000..a4a42c5d
--- /dev/null
+++ b/utf.c
@@ -0,0 +1,3748 @@
+/* utf.c - UTF-8 support code
+;
+; Copyright (c) 2022-2022, 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"
+
+#if defined(_WIN32) && !defined(__CYGWIN__)
+# include <windows.h>
+#endif
+
+/* partially generated by mkrunetype.awk from http://git.suckless.org/ubase/
+ see LICENSE for more information */
+
+#define nelem(x) (sizeof (x) / sizeof *(x))
+
+static int
+rune1cmp(const void *v1, const void *v2)
+{
+ int r1 = *(int *)v1, r2 = *(int *)v2;
+
+ return r1 - r2;
+}
+
+static int
+rune2cmp(const void *v1, const void *v2)
+{
+ int r = *(int *)v1, *p = (int *)v2;
+
+ if(r >= p[0] && r <= p[1])
+ return 0;
+ else
+ return r - p[0];
+}
+
+static int
+runemapcmp(const void *v1, const void *v2)
+{
+ return *(int *)v1 - *(int *)v2;
+}
+
+/* generated by mkrunetype.awk from http://git.suckless.org/ubase/
+ see LICENSE for more information */
+
+static int upper3[][2] = {
+ { 0x0100, 0x012E },
+ { 0x0132, 0x0136 },
+ { 0x0139, 0x0147 },
+ { 0x014A, 0x0176 },
+ { 0x0179, 0x017D },
+ { 0x0182, 0x0184 },
+ { 0x01A0, 0x01A4 },
+ { 0x01B3, 0x01B5 },
+ { 0x01CD, 0x01DB },
+ { 0x01DE, 0x01EE },
+ { 0x01F8, 0x021E },
+ { 0x0222, 0x0232 },
+ { 0x0246, 0x024E },
+ { 0x0370, 0x0372 },
+ { 0x03D8, 0x03EE },
+ { 0x0460, 0x0480 },
+ { 0x048A, 0x04BE },
+ { 0x04C1, 0x04CD },
+ { 0x04D0, 0x052E },
+ { 0x1E00, 0x1E94 },
+ { 0x1EA0, 0x1EFE },
+ { 0x2C67, 0x2C6B },
+ { 0x2C80, 0x2CE2 },
+ { 0x2CEB, 0x2CED },
+ { 0xA640, 0xA66C },
+ { 0xA680, 0xA69A },
+ { 0xA722, 0xA72E },
+ { 0xA732, 0xA76E },
+ { 0xA779, 0xA77B },
+ { 0xA77E, 0xA786 },
+ { 0xA790, 0xA792 },
+ { 0xA796, 0xA7A8 },
+ { 0xA7B4, 0xA7C2 },
+ { 0xA7C7, 0xA7C9 },
+ { 0xA7D6, 0xA7D8 },
+};
+
+static int upper2[][3] = {
+ { 0x0041, 0x005A, 0x0061 },
+ { 0x00C0, 0x00D6, 0x00E0 },
+ { 0x00D8, 0x00DE, 0x00F8 },
+ { 0x0189, 0x018A, 0x0256 },
+ { 0x01B1, 0x01B2, 0x028A },
+ { 0x0388, 0x038A, 0x03AD },
+ { 0x038E, 0x038F, 0x03CD },
+ { 0x0391, 0x03A1, 0x03B1 },
+ { 0x03A3, 0x03AB, 0x03C3 },
+ { 0x03D2, 0x03D4, 0x03D2 },
+ { 0x03FD, 0x03FF, 0x037B },
+ { 0x0400, 0x040F, 0x0450 },
+ { 0x0410, 0x042F, 0x0430 },
+ { 0x0531, 0x0556, 0x0561 },
+ { 0x10A0, 0x10C5, 0x2D00 },
+ { 0x13A0, 0x13EF, 0xAB70 },
+ { 0x13F0, 0x13F5, 0x13F8 },
+ { 0x1C90, 0x1CBA, 0x10D0 },
+ { 0x1CBD, 0x1CBF, 0x10FD },
+ { 0x1F08, 0x1F0F, 0x1F00 },
+ { 0x1F18, 0x1F1D, 0x1F10 },
+ { 0x1F28, 0x1F2F, 0x1F20 },
+ { 0x1F38, 0x1F3F, 0x1F30 },
+ { 0x1F48, 0x1F4D, 0x1F40 },
+ { 0x1F68, 0x1F6F, 0x1F60 },
+ { 0x1FB8, 0x1FB9, 0x1FB0 },
+ { 0x1FBA, 0x1FBB, 0x1F70 },
+ { 0x1FC8, 0x1FCB, 0x1F72 },
+ { 0x1FD8, 0x1FD9, 0x1FD0 },
+ { 0x1FDA, 0x1FDB, 0x1F76 },
+ { 0x1FE8, 0x1FE9, 0x1FE0 },
+ { 0x1FEA, 0x1FEB, 0x1F7A },
+ { 0x1FF8, 0x1FF9, 0x1F78 },
+ { 0x1FFA, 0x1FFB, 0x1F7C },
+ { 0x210B, 0x210D, 0x210B },
+ { 0x2110, 0x2112, 0x2110 },
+ { 0x2119, 0x211D, 0x2119 },
+ { 0x212C, 0x212D, 0x212C },
+ { 0x2130, 0x2131, 0x2130 },
+ { 0x213E, 0x213F, 0x213E },
+ { 0x2C00, 0x2C2F, 0x2C30 },
+ { 0x2C7E, 0x2C7F, 0x023F },
+ { 0xFF21, 0xFF3A, 0xFF41 },
+ { 0x10400, 0x10427, 0x10428 },
+ { 0x104B0, 0x104D3, 0x104D8 },
+ { 0x10570, 0x1057A, 0x10597 },
+ { 0x1057C, 0x1058A, 0x105A3 },
+ { 0x1058C, 0x10592, 0x105B3 },
+ { 0x10594, 0x10595, 0x105BB },
+ { 0x10C80, 0x10CB2, 0x10CC0 },
+ { 0x118A0, 0x118BF, 0x118C0 },
+ { 0x16E40, 0x16E5F, 0x16E60 },
+ { 0x1D400, 0x1D419, 0x1D400 },
+ { 0x1D434, 0x1D44D, 0x1D434 },
+ { 0x1D468, 0x1D481, 0x1D468 },
+ { 0x1D49E, 0x1D49F, 0x1D49E },
+ { 0x1D4A5, 0x1D4A6, 0x1D4A5 },
+ { 0x1D4A9, 0x1D4AC, 0x1D4A9 },
+ { 0x1D4AE, 0x1D4B5, 0x1D4AE },
+ { 0x1D4D0, 0x1D4E9, 0x1D4D0 },
+ { 0x1D504, 0x1D505, 0x1D504 },
+ { 0x1D507, 0x1D50A, 0x1D507 },
+ { 0x1D50D, 0x1D514, 0x1D50D },
+ { 0x1D516, 0x1D51C, 0x1D516 },
+ { 0x1D538, 0x1D539, 0x1D538 },
+ { 0x1D53B, 0x1D53E, 0x1D53B },
+ { 0x1D540, 0x1D544, 0x1D540 },
+ { 0x1D54A, 0x1D550, 0x1D54A },
+ { 0x1D56C, 0x1D585, 0x1D56C },
+ { 0x1D5A0, 0x1D5B9, 0x1D5A0 },
+ { 0x1D5D4, 0x1D5ED, 0x1D5D4 },
+ { 0x1D608, 0x1D621, 0x1D608 },
+ { 0x1D63C, 0x1D655, 0x1D63C },
+ { 0x1D670, 0x1D689, 0x1D670 },
+ { 0x1D6A8, 0x1D6C0, 0x1D6A8 },
+ { 0x1D6E2, 0x1D6FA, 0x1D6E2 },
+ { 0x1D71C, 0x1D734, 0x1D71C },
+ { 0x1D756, 0x1D76E, 0x1D756 },
+ { 0x1D790, 0x1D7A8, 0x1D790 },
+ { 0x1E900, 0x1E921, 0x1E922 },
+};
+
+static int upper1[][2] = {
+ { 0x0130, 0x0069 },
+ { 0x0178, 0x00FF },
+ { 0x0181, 0x0253 },
+ { 0x0186, 0x0254 },
+ { 0x0187, 0x0188 },
+ { 0x018B, 0x018C },
+ { 0x018E, 0x01DD },
+ { 0x018F, 0x0259 },
+ { 0x0190, 0x025B },
+ { 0x0191, 0x0192 },
+ { 0x0193, 0x0260 },
+ { 0x0194, 0x0263 },
+ { 0x0196, 0x0269 },
+ { 0x0197, 0x0268 },
+ { 0x0198, 0x0199 },
+ { 0x019C, 0x026F },
+ { 0x019D, 0x0272 },
+ { 0x019F, 0x0275 },
+ { 0x01A6, 0x0280 },
+ { 0x01A7, 0x01A8 },
+ { 0x01A9, 0x0283 },
+ { 0x01AC, 0x01AD },
+ { 0x01AE, 0x0288 },
+ { 0x01AF, 0x01B0 },
+ { 0x01B7, 0x0292 },
+ { 0x01B8, 0x01B9 },
+ { 0x01BC, 0x01BD },
+ { 0x01C4, 0x01C6 },
+ { 0x01C7, 0x01C9 },
+ { 0x01CA, 0x01CC },
+ { 0x01F1, 0x01F3 },
+ { 0x01F4, 0x01F5 },
+ { 0x01F6, 0x0195 },
+ { 0x01F7, 0x01BF },
+ { 0x0220, 0x019E },
+ { 0x023A, 0x2C65 },
+ { 0x023B, 0x023C },
+ { 0x023D, 0x019A },
+ { 0x023E, 0x2C66 },
+ { 0x0241, 0x0242 },
+ { 0x0243, 0x0180 },
+ { 0x0244, 0x0289 },
+ { 0x0245, 0x028C },
+ { 0x0376, 0x0377 },
+ { 0x037F, 0x03F3 },
+ { 0x0386, 0x03AC },
+ { 0x038C, 0x03CC },
+ { 0x03CF, 0x03D7 },
+ { 0x03F4, 0x03B8 },
+ { 0x03F7, 0x03F8 },
+ { 0x03F9, 0x03F2 },
+ { 0x03FA, 0x03FB },
+ { 0x04C0, 0x04CF },
+ { 0x10C7, 0x2D27 },
+ { 0x10CD, 0x2D2D },
+ { 0x1E9E, 0x00DF },
+ { 0x1F59, 0x1F51 },
+ { 0x1F5B, 0x1F53 },
+ { 0x1F5D, 0x1F55 },
+ { 0x1F5F, 0x1F57 },
+ { 0x1FEC, 0x1FE5 },
+ { 0x2102, 0x2102 },
+ { 0x2107, 0x2107 },
+ { 0x2115, 0x2115 },
+ { 0x2124, 0x2124 },
+ { 0x2126, 0x03C9 },
+ { 0x2128, 0x2128 },
+ { 0x212A, 0x006B },
+ { 0x212B, 0x00E5 },
+ { 0x2132, 0x214E },
+ { 0x2133, 0x2133 },
+ { 0x2145, 0x2145 },
+ { 0x2183, 0x2184 },
+ { 0x2C60, 0x2C61 },
+ { 0x2C62, 0x026B },
+ { 0x2C63, 0x1D7D },
+ { 0x2C64, 0x027D },
+ { 0x2C6D, 0x0251 },
+ { 0x2C6E, 0x0271 },
+ { 0x2C6F, 0x0250 },
+ { 0x2C70, 0x0252 },
+ { 0x2C72, 0x2C73 },
+ { 0x2C75, 0x2C76 },
+ { 0x2CF2, 0x2CF3 },
+ { 0xA77D, 0x1D79 },
+ { 0xA78B, 0xA78C },
+ { 0xA78D, 0x0265 },
+ { 0xA7AA, 0x0266 },
+ { 0xA7AB, 0x025C },
+ { 0xA7AC, 0x0261 },
+ { 0xA7AD, 0x026C },
+ { 0xA7AE, 0x026A },
+ { 0xA7B0, 0x029E },
+ { 0xA7B1, 0x0287 },
+ { 0xA7B2, 0x029D },
+ { 0xA7B3, 0xAB53 },
+ { 0xA7C4, 0xA794 },
+ { 0xA7C5, 0x0282 },
+ { 0xA7C6, 0x1D8E },
+ { 0xA7D0, 0xA7D1 },
+ { 0xA7F5, 0xA7F6 },
+ { 0x1D49C, 0x1D49C },
+ { 0x1D4A2, 0x1D4A2 },
+ { 0x1D546, 0x1D546 },
+ { 0x1D7CA, 0x1D7CA },
+};
+
+C_regparm int C_utf_isupper(int r)
+{
+ int *match;
+
+ if((match = bsearch(&r, upper3, nelem(upper3), sizeof *upper3, &rune2cmp)))
+ return !((r - match[0]) % 2);
+ if(bsearch(&r, upper2, nelem(upper2), sizeof *upper2, &rune2cmp))
+ return 1;
+ if(bsearch(&r, upper1, nelem(upper1), sizeof *upper1, &rune1cmp))
+ return 1;
+ return 0;
+}
+
+C_regparm int C_utf_char_downcase(int r)
+{
+ int *match;
+
+ match = bsearch(&r, upper3, nelem(upper3), sizeof *upper3, &rune2cmp);
+ if (match)
+ return ((r - match[0]) % 2) ? r : r + 1;
+ match = bsearch(&r, upper2, nelem(upper2), sizeof *upper2, &rune2cmp);
+ if (match)
+ return match[2] + (r - match[0]);
+ match = bsearch(&r, upper1, nelem(upper1), sizeof *upper1, &rune1cmp);
+ if (match)
+ return match[1];
+ return r;
+}
+
+static int lower4[][2] = {
+ { 0x0101, 0x012F },
+ { 0x0133, 0x0137 },
+ { 0x013A, 0x0148 },
+ { 0x014B, 0x0177 },
+ { 0x017A, 0x017E },
+ { 0x0183, 0x0185 },
+ { 0x01A1, 0x01A5 },
+ { 0x01B4, 0x01B6 },
+ { 0x01CE, 0x01DC },
+ { 0x01DF, 0x01EF },
+ { 0x01F9, 0x021F },
+ { 0x0223, 0x0233 },
+ { 0x0247, 0x024F },
+ { 0x0371, 0x0373 },
+ { 0x03D9, 0x03EF },
+ { 0x0461, 0x0481 },
+ { 0x048B, 0x04BF },
+ { 0x04C2, 0x04CE },
+ { 0x04D1, 0x052F },
+ { 0x1E01, 0x1E95 },
+ { 0x1EA1, 0x1EFF },
+ { 0x2C68, 0x2C6C },
+ { 0x2C81, 0x2CE3 },
+ { 0x2CEC, 0x2CEE },
+ { 0xA641, 0xA66D },
+ { 0xA681, 0xA69B },
+ { 0xA723, 0xA72F },
+ { 0xA733, 0xA76F },
+ { 0xA77A, 0xA77C },
+ { 0xA77F, 0xA787 },
+ { 0xA791, 0xA793 },
+ { 0xA797, 0xA7A9 },
+ { 0xA7B5, 0xA7C3 },
+ { 0xA7C8, 0xA7CA },
+ { 0xA7D7, 0xA7D9 },
+};
+
+static int lower2[][3] = {
+ { 0x0061, 0x007A, 0x0041 },
+ { 0x00E0, 0x00F6, 0x00C0 },
+ { 0x00F8, 0x00FE, 0x00D8 },
+ { 0x01AA, 0x01AB, 0x01AA },
+ { 0x0234, 0x0239, 0x0234 },
+ { 0x023F, 0x0240, 0x2C7E },
+ { 0x0256, 0x0257, 0x0189 },
+ { 0x025D, 0x025F, 0x025D },
+ { 0x026D, 0x026E, 0x026D },
+ { 0x0273, 0x0274, 0x0273 },
+ { 0x0276, 0x027C, 0x0276 },
+ { 0x027E, 0x027F, 0x027E },
+ { 0x0284, 0x0286, 0x0284 },
+ { 0x028A, 0x028B, 0x01B1 },
+ { 0x028D, 0x0291, 0x028D },
+ { 0x0295, 0x029C, 0x0295 },
+ { 0x029F, 0x02AF, 0x029F },
+ { 0x037B, 0x037D, 0x03FD },
+ { 0x03AD, 0x03AF, 0x0388 },
+ { 0x03B1, 0x03C1, 0x0391 },
+ { 0x03C3, 0x03CB, 0x03A3 },
+ { 0x03CD, 0x03CE, 0x038E },
+ { 0x0430, 0x044F, 0x0410 },
+ { 0x0450, 0x045F, 0x0400 },
+ { 0x0561, 0x0586, 0x0531 },
+ { 0x0587, 0x0588, 0x0587 },
+ { 0x10D0, 0x10FA, 0x1C90 },
+ { 0x10FD, 0x10FF, 0x1CBD },
+ { 0x13F8, 0x13FD, 0x13F0 },
+ { 0x1C83, 0x1C84, 0x0421 },
+ { 0x1D00, 0x1D2B, 0x1D00 },
+ { 0x1D6B, 0x1D77, 0x1D6B },
+ { 0x1D7A, 0x1D7C, 0x1D7A },
+ { 0x1D7E, 0x1D8D, 0x1D7E },
+ { 0x1D8F, 0x1D9A, 0x1D8F },
+ { 0x1E96, 0x1E9A, 0x1E96 },
+ { 0x1E9C, 0x1E9D, 0x1E9C },
+ { 0x1F00, 0x1F07, 0x1F08 },
+ { 0x1F10, 0x1F15, 0x1F18 },
+ { 0x1F20, 0x1F27, 0x1F28 },
+ { 0x1F30, 0x1F37, 0x1F38 },
+ { 0x1F40, 0x1F45, 0x1F48 },
+ { 0x1F60, 0x1F67, 0x1F68 },
+ { 0x1F70, 0x1F71, 0x1FBA },
+ { 0x1F72, 0x1F75, 0x1FC8 },
+ { 0x1F76, 0x1F77, 0x1FDA },
+ { 0x1F78, 0x1F79, 0x1FF8 },
+ { 0x1F7A, 0x1F7B, 0x1FEA },
+ { 0x1F7C, 0x1F7D, 0x1FFA },
+ { 0x1F80, 0x1F87, 0x1F88 },
+ { 0x1F90, 0x1F97, 0x1F98 },
+ { 0x1FA0, 0x1FA7, 0x1FA8 },
+ { 0x1FB0, 0x1FB1, 0x1FB8 },
+ { 0x1FB6, 0x1FB7, 0x1FB6 },
+ { 0x1FC6, 0x1FC7, 0x1FC6 },
+ { 0x1FD0, 0x1FD1, 0x1FD8 },
+ { 0x1FD2, 0x1FD3, 0x1FD2 },
+ { 0x1FD6, 0x1FD7, 0x1FD6 },
+ { 0x1FE0, 0x1FE1, 0x1FE8 },
+ { 0x1FE2, 0x1FE4, 0x1FE2 },
+ { 0x1FE6, 0x1FE7, 0x1FE6 },
+ { 0x1FF6, 0x1FF7, 0x1FF6 },
+ { 0x210E, 0x210F, 0x210E },
+ { 0x213C, 0x213D, 0x213C },
+ { 0x2146, 0x2149, 0x2146 },
+ { 0x2C30, 0x2C5F, 0x2C00 },
+ { 0x2C77, 0x2C7B, 0x2C77 },
+ { 0x2D00, 0x2D25, 0x10A0 },
+ { 0xA730, 0xA731, 0xA730 },
+ { 0xA771, 0xA778, 0xA771 },
+ { 0xAB30, 0xAB52, 0xAB30 },
+ { 0xAB54, 0xAB5A, 0xAB54 },
+ { 0xAB60, 0xAB68, 0xAB60 },
+ { 0xAB70, 0xABBF, 0x13A0 },
+ { 0xFB00, 0xFB06, 0xFB00 },
+ { 0xFB13, 0xFB17, 0xFB13 },
+ { 0xFF41, 0xFF5A, 0xFF21 },
+ { 0x10428, 0x1044F, 0x10400 },
+ { 0x104D8, 0x104FB, 0x104B0 },
+ { 0x10597, 0x105A1, 0x10570 },
+ { 0x105A3, 0x105B1, 0x1057C },
+ { 0x105B3, 0x105B9, 0x1058C },
+ { 0x105BB, 0x105BC, 0x10594 },
+ { 0x10CC0, 0x10CF2, 0x10C80 },
+ { 0x118C0, 0x118DF, 0x118A0 },
+ { 0x16E60, 0x16E7F, 0x16E40 },
+ { 0x1D41A, 0x1D433, 0x1D41A },
+ { 0x1D44E, 0x1D454, 0x1D44E },
+ { 0x1D456, 0x1D467, 0x1D456 },
+ { 0x1D482, 0x1D49B, 0x1D482 },
+ { 0x1D4B6, 0x1D4B9, 0x1D4B6 },
+ { 0x1D4BD, 0x1D4C3, 0x1D4BD },
+ { 0x1D4C5, 0x1D4CF, 0x1D4C5 },
+ { 0x1D4EA, 0x1D503, 0x1D4EA },
+ { 0x1D51E, 0x1D537, 0x1D51E },
+ { 0x1D552, 0x1D56B, 0x1D552 },
+ { 0x1D586, 0x1D59F, 0x1D586 },
+ { 0x1D5BA, 0x1D5D3, 0x1D5BA },
+ { 0x1D5EE, 0x1D607, 0x1D5EE },
+ { 0x1D622, 0x1D63B, 0x1D622 },
+ { 0x1D656, 0x1D66F, 0x1D656 },
+ { 0x1D68A, 0x1D6A5, 0x1D68A },
+ { 0x1D6C2, 0x1D6DA, 0x1D6C2 },
+ { 0x1D6DC, 0x1D6E1, 0x1D6DC },
+ { 0x1D6FC, 0x1D714, 0x1D6FC },
+ { 0x1D716, 0x1D71B, 0x1D716 },
+ { 0x1D736, 0x1D74E, 0x1D736 },
+ { 0x1D750, 0x1D755, 0x1D750 },
+ { 0x1D770, 0x1D788, 0x1D770 },
+ { 0x1D78A, 0x1D78F, 0x1D78A },
+ { 0x1D7AA, 0x1D7C2, 0x1D7AA },
+ { 0x1D7C4, 0x1D7C9, 0x1D7C4 },
+ { 0x1DF00, 0x1DF09, 0x1DF00 },
+ { 0x1DF0B, 0x1DF1E, 0x1DF0B },
+ { 0x1E922, 0x1E943, 0x1E900 },
+};
+
+static int lower1[][2] = {
+ { 0x00B5, 0x039C },
+ { 0x00DF, 0x00DF },
+ { 0x00FF, 0x0178 },
+ { 0x0131, 0x0049 },
+ { 0x0138, 0x0138 },
+ { 0x0149, 0x0149 },
+ { 0x017F, 0x0053 },
+ { 0x0180, 0x0243 },
+ { 0x0188, 0x0187 },
+ { 0x018C, 0x018B },
+ { 0x018D, 0x018D },
+ { 0x0192, 0x0191 },
+ { 0x0195, 0x01F6 },
+ { 0x0199, 0x0198 },
+ { 0x019A, 0x023D },
+ { 0x019B, 0x019B },
+ { 0x019E, 0x0220 },
+ { 0x01A8, 0x01A7 },
+ { 0x01AD, 0x01AC },
+ { 0x01B0, 0x01AF },
+ { 0x01B9, 0x01B8 },
+ { 0x01BA, 0x01BA },
+ { 0x01BD, 0x01BC },
+ { 0x01BE, 0x01BE },
+ { 0x01BF, 0x01F7 },
+ { 0x01C6, 0x01C4 },
+ { 0x01C9, 0x01C7 },
+ { 0x01CC, 0x01CA },
+ { 0x01DD, 0x018E },
+ { 0x01F0, 0x01F0 },
+ { 0x01F3, 0x01F1 },
+ { 0x01F5, 0x01F4 },
+ { 0x0221, 0x0221 },
+ { 0x023C, 0x023B },
+ { 0x0242, 0x0241 },
+ { 0x0250, 0x2C6F },
+ { 0x0251, 0x2C6D },
+ { 0x0252, 0x2C70 },
+ { 0x0253, 0x0181 },
+ { 0x0254, 0x0186 },
+ { 0x0255, 0x0255 },
+ { 0x0258, 0x0258 },
+ { 0x0259, 0x018F },
+ { 0x025A, 0x025A },
+ { 0x025B, 0x0190 },
+ { 0x025C, 0xA7AB },
+ { 0x0260, 0x0193 },
+ { 0x0261, 0xA7AC },
+ { 0x0262, 0x0262 },
+ { 0x0263, 0x0194 },
+ { 0x0264, 0x0264 },
+ { 0x0265, 0xA78D },
+ { 0x0266, 0xA7AA },
+ { 0x0267, 0x0267 },
+ { 0x0268, 0x0197 },
+ { 0x0269, 0x0196 },
+ { 0x026A, 0xA7AE },
+ { 0x026B, 0x2C62 },
+ { 0x026C, 0xA7AD },
+ { 0x026F, 0x019C },
+ { 0x0270, 0x0270 },
+ { 0x0271, 0x2C6E },
+ { 0x0272, 0x019D },
+ { 0x0275, 0x019F },
+ { 0x027D, 0x2C64 },
+ { 0x0280, 0x01A6 },
+ { 0x0281, 0x0281 },
+ { 0x0282, 0xA7C5 },
+ { 0x0283, 0x01A9 },
+ { 0x0287, 0xA7B1 },
+ { 0x0288, 0x01AE },
+ { 0x0289, 0x0244 },
+ { 0x028C, 0x0245 },
+ { 0x0292, 0x01B7 },
+ { 0x0293, 0x0293 },
+ { 0x029D, 0xA7B2 },
+ { 0x029E, 0xA7B0 },
+ { 0x0377, 0x0376 },
+ { 0x0390, 0x0390 },
+ { 0x03AC, 0x0386 },
+ { 0x03B0, 0x03B0 },
+ { 0x03C2, 0x03A3 },
+ { 0x03CC, 0x038C },
+ { 0x03D0, 0x0392 },
+ { 0x03D1, 0x0398 },
+ { 0x03D5, 0x03A6 },
+ { 0x03D6, 0x03A0 },
+ { 0x03D7, 0x03CF },
+ { 0x03F0, 0x039A },
+ { 0x03F1, 0x03A1 },
+ { 0x03F2, 0x03F9 },
+ { 0x03F3, 0x037F },
+ { 0x03F5, 0x0395 },
+ { 0x03F8, 0x03F7 },
+ { 0x03FB, 0x03FA },
+ { 0x03FC, 0x03FC },
+ { 0x04CF, 0x04C0 },
+ { 0x0560, 0x0560 },
+ { 0x1C80, 0x0412 },
+ { 0x1C81, 0x0414 },
+ { 0x1C82, 0x041E },
+ { 0x1C85, 0x0422 },
+ { 0x1C86, 0x042A },
+ { 0x1C87, 0x0462 },
+ { 0x1C88, 0xA64A },
+ { 0x1D79, 0xA77D },
+ { 0x1D7D, 0x2C63 },
+ { 0x1D8E, 0xA7C6 },
+ { 0x1E9B, 0x1E60 },
+ { 0x1E9F, 0x1E9F },
+ { 0x1F50, 0x1F50 },
+ { 0x1F51, 0x1F59 },
+ { 0x1F52, 0x1F52 },
+ { 0x1F53, 0x1F5B },
+ { 0x1F54, 0x1F54 },
+ { 0x1F55, 0x1F5D },
+ { 0x1F56, 0x1F56 },
+ { 0x1F57, 0x1F5F },
+ { 0x1FB2, 0x1FB2 },
+ { 0x1FB3, 0x1FBC },
+ { 0x1FB4, 0x1FB4 },
+ { 0x1FBE, 0x0399 },
+ { 0x1FC2, 0x1FC2 },
+ { 0x1FC3, 0x1FCC },
+ { 0x1FC4, 0x1FC4 },
+ { 0x1FE5, 0x1FEC },
+ { 0x1FF2, 0x1FF2 },
+ { 0x1FF3, 0x1FFC },
+ { 0x1FF4, 0x1FF4 },
+ { 0x210A, 0x210A },
+ { 0x2113, 0x2113 },
+ { 0x212F, 0x212F },
+ { 0x2134, 0x2134 },
+ { 0x2139, 0x2139 },
+ { 0x214E, 0x2132 },
+ { 0x2184, 0x2183 },
+ { 0x2C61, 0x2C60 },
+ { 0x2C65, 0x023A },
+ { 0x2C66, 0x023E },
+ { 0x2C71, 0x2C71 },
+ { 0x2C73, 0x2C72 },
+ { 0x2C74, 0x2C74 },
+ { 0x2C76, 0x2C75 },
+ { 0x2CE4, 0x2CE4 },
+ { 0x2CF3, 0x2CF2 },
+ { 0x2D27, 0x10C7 },
+ { 0x2D2D, 0x10CD },
+ { 0xA78C, 0xA78B },
+ { 0xA78E, 0xA78E },
+ { 0xA794, 0xA7C4 },
+ { 0xA795, 0xA795 },
+ { 0xA7AF, 0xA7AF },
+ { 0xA7D1, 0xA7D0 },
+ { 0xA7D3, 0xA7D3 },
+ { 0xA7D5, 0xA7D5 },
+ { 0xA7F6, 0xA7F5 },
+ { 0xA7FA, 0xA7FA },
+ { 0xAB53, 0xA7B3 },
+ { 0x1D4BB, 0x1D4BB },
+ { 0x1D7CB, 0x1D7CB },
+};
+
+C_regparm int C_utf_islower(int r)
+{
+ int *match;
+
+ if((match = bsearch(&r, lower4, nelem(lower4), sizeof *lower4, &rune2cmp)))
+ return !((r - match[0]) % 2);
+ if(bsearch(&r, lower2, nelem(lower2), sizeof *lower2, &rune2cmp))
+ return 1;
+ if(bsearch(&r, lower1, nelem(lower1), sizeof *lower1, &rune1cmp))
+ return 1;
+ return 0;
+}
+
+C_regparm int C_utf_char_upcase(int r)
+{
+ int *match;
+
+ match = bsearch(&r, lower4, nelem(lower4), sizeof *lower4, &rune2cmp);
+ if (match)
+ return ((r - match[0]) % 2) ? r : r - 1;
+ match = bsearch(&r, lower2, nelem(lower2), sizeof *lower2, &rune2cmp);
+ if (match)
+ return match[2] + (r - match[0]);
+ match = bsearch(&r, lower1, nelem(lower1), sizeof *lower1, &rune1cmp);
+ if (match)
+ return match[1];
+ return r;
+}
+
+static int digit2[][2] = {
+ { 0x0030, 0x0039 },
+ { 0x0660, 0x0669 },
+ { 0x06F0, 0x06F9 },
+ { 0x07C0, 0x07C9 },
+ { 0x0966, 0x096F },
+ { 0x09E6, 0x09EF },
+ { 0x0A66, 0x0A6F },
+ { 0x0AE6, 0x0AEF },
+ { 0x0B66, 0x0B6F },
+ { 0x0BE6, 0x0BEF },
+ { 0x0C66, 0x0C6F },
+ { 0x0CE6, 0x0CEF },
+ { 0x0D66, 0x0D6F },
+ { 0x0DE6, 0x0DEF },
+ { 0x0E50, 0x0E59 },
+ { 0x0ED0, 0x0ED9 },
+ { 0x0F20, 0x0F29 },
+ { 0x1040, 0x1049 },
+ { 0x1090, 0x1099 },
+ { 0x17E0, 0x17E9 },
+ { 0x1810, 0x1819 },
+ { 0x1946, 0x194F },
+ { 0x19D0, 0x19D9 },
+ { 0x1A80, 0x1A89 },
+ { 0x1A90, 0x1A99 },
+ { 0x1B50, 0x1B59 },
+ { 0x1BB0, 0x1BB9 },
+ { 0x1C40, 0x1C49 },
+ { 0x1C50, 0x1C59 },
+ { 0xA620, 0xA629 },
+ { 0xA8D0, 0xA8D9 },
+ { 0xA900, 0xA909 },
+ { 0xA9D0, 0xA9D9 },
+ { 0xA9F0, 0xA9F9 },
+ { 0xAA50, 0xAA59 },
+ { 0xABF0, 0xABF9 },
+ { 0xFF10, 0xFF19 },
+ { 0x104A0, 0x104A9 },
+ { 0x10D30, 0x10D39 },
+ { 0x11066, 0x1106F },
+ { 0x110F0, 0x110F9 },
+ { 0x11136, 0x1113F },
+ { 0x111D0, 0x111D9 },
+ { 0x112F0, 0x112F9 },
+ { 0x11450, 0x11459 },
+ { 0x114D0, 0x114D9 },
+ { 0x11650, 0x11659 },
+ { 0x116C0, 0x116C9 },
+ { 0x11730, 0x11739 },
+ { 0x118E0, 0x118E9 },
+ { 0x11950, 0x11959 },
+ { 0x11C50, 0x11C59 },
+ { 0x11D50, 0x11D59 },
+ { 0x11DA0, 0x11DA9 },
+ { 0x16A60, 0x16A69 },
+ { 0x16AC0, 0x16AC9 },
+ { 0x16B50, 0x16B59 },
+ { 0x1D7CE, 0x1D7FF },
+ { 0x1E140, 0x1E149 },
+ { 0x1E2F0, 0x1E2F9 },
+ { 0x1E950, 0x1E959 },
+ { 0x1FBF0, 0x1FBF9 },
+};
+
+C_regparm int C_utf_isdigit(int r)
+{
+ int *dp = bsearch(&r, digit2, nelem(digit2), sizeof *digit2, &rune2cmp);
+ if(dp != NULL) return 1 + r - dp[ 0 ];
+ return 0;
+}
+
+static int alpha3[][2] = {
+ { 0x00D6, 0x00D8 },
+ { 0x00F6, 0x00F8 },
+ { 0x02EC, 0x02EE },
+ { 0x0374, 0x0376 },
+ { 0x037D, 0x037F },
+ { 0x0386, 0x0388 },
+ { 0x038A, 0x038E },
+ { 0x03A1, 0x03A3 },
+ { 0x03F5, 0x03F7 },
+ { 0x052F, 0x0531 },
+ { 0x066F, 0x0671 },
+ { 0x06D3, 0x06D5 },
+ { 0x0710, 0x0712 },
+ { 0x0887, 0x0889 },
+ { 0x09A8, 0x09AA },
+ { 0x09B0, 0x09B2 },
+ { 0x09DD, 0x09DF },
+ { 0x0A28, 0x0A2A },
+ { 0x0A30, 0x0A32 },
+ { 0x0A33, 0x0A35 },
+ { 0x0A36, 0x0A38 },
+ { 0x0A5C, 0x0A5E },
+ { 0x0A8D, 0x0A8F },
+ { 0x0A91, 0x0A93 },
+ { 0x0AA8, 0x0AAA },
+ { 0x0AB0, 0x0AB2 },
+ { 0x0AB3, 0x0AB5 },
+ { 0x0B28, 0x0B2A },
+ { 0x0B30, 0x0B32 },
+ { 0x0B33, 0x0B35 },
+ { 0x0B5D, 0x0B5F },
+ { 0x0B83, 0x0B85 },
+ { 0x0B90, 0x0B92 },
+ { 0x0B9A, 0x0B9E },
+ { 0x0C0C, 0x0C0E },
+ { 0x0C10, 0x0C12 },
+ { 0x0C28, 0x0C2A },
+ { 0x0C8C, 0x0C8E },
+ { 0x0C90, 0x0C92 },
+ { 0x0CA8, 0x0CAA },
+ { 0x0CB3, 0x0CB5 },
+ { 0x0CDE, 0x0CE0 },
+ { 0x0D0C, 0x0D0E },
+ { 0x0D10, 0x0D12 },
+ { 0x0DB1, 0x0DB3 },
+ { 0x0DBB, 0x0DBD },
+ { 0x0E30, 0x0E32 },
+ { 0x0E82, 0x0E86 },
+ { 0x0E8A, 0x0E8C },
+ { 0x0EA3, 0x0EA7 },
+ { 0x0EB0, 0x0EB2 },
+ { 0x0EC4, 0x0EC6 },
+ { 0x0F47, 0x0F49 },
+ { 0x10C5, 0x10C7 },
+ { 0x10FA, 0x10FC },
+ { 0x1248, 0x124A },
+ { 0x1256, 0x125A },
+ { 0x1288, 0x128A },
+ { 0x12B0, 0x12B2 },
+ { 0x12BE, 0x12C2 },
+ { 0x12D6, 0x12D8 },
+ { 0x1310, 0x1312 },
+ { 0x167F, 0x1681 },
+ { 0x176C, 0x176E },
+ { 0x18A8, 0x18AA },
+ { 0x1CEC, 0x1CEE },
+ { 0x1CF3, 0x1CF5 },
+ { 0x1F57, 0x1F5F },
+ { 0x1FB4, 0x1FB6 },
+ { 0x1FBC, 0x1FBE },
+ { 0x1FC4, 0x1FC6 },
+ { 0x1FF4, 0x1FF6 },
+ { 0x2113, 0x2115 },
+ { 0x2124, 0x212A },
+ { 0x212D, 0x212F },
+ { 0x2D25, 0x2D27 },
+ { 0x2DA6, 0x2DA8 },
+ { 0x2DAE, 0x2DB0 },
+ { 0x2DB6, 0x2DB8 },
+ { 0x2DBE, 0x2DC0 },
+ { 0x2DC6, 0x2DC8 },
+ { 0x2DCE, 0x2DD0 },
+ { 0x2DD6, 0x2DD8 },
+ { 0x309F, 0x30A1 },
+ { 0x30FA, 0x30FC },
+ { 0x312F, 0x3131 },
+ { 0xA7D1, 0xA7D5 },
+ { 0xA801, 0xA803 },
+ { 0xA805, 0xA807 },
+ { 0xA80A, 0xA80C },
+ { 0xA8FB, 0xA8FD },
+ { 0xA9E4, 0xA9E6 },
+ { 0xA9FE, 0xAA00 },
+ { 0xAA42, 0xAA44 },
+ { 0xAAAF, 0xAAB1 },
+ { 0xAAC0, 0xAAC2 },
+ { 0xAB26, 0xAB28 },
+ { 0xAB2E, 0xAB30 },
+ { 0xAB5A, 0xAB5C },
+ { 0xFB1D, 0xFB1F },
+ { 0xFB28, 0xFB2A },
+ { 0xFB36, 0xFB38 },
+ { 0xFB3C, 0xFB40 },
+ { 0xFB41, 0xFB43 },
+ { 0xFB44, 0xFB46 },
+ { 0xFE74, 0xFE76 },
+ { 0x1000B, 0x1000D },
+ { 0x10026, 0x10028 },
+ { 0x1003A, 0x1003C },
+ { 0x1003D, 0x1003F },
+ { 0x10340, 0x10342 },
+ { 0x1057A, 0x1057C },
+ { 0x1058A, 0x1058C },
+ { 0x10592, 0x10594 },
+ { 0x10595, 0x10597 },
+ { 0x105A1, 0x105A3 },
+ { 0x105B1, 0x105B3 },
+ { 0x105B9, 0x105BB },
+ { 0x10785, 0x10787 },
+ { 0x107B0, 0x107B2 },
+ { 0x10808, 0x1080A },
+ { 0x10835, 0x10837 },
+ { 0x108F2, 0x108F4 },
+ { 0x10A13, 0x10A15 },
+ { 0x10A17, 0x10A19 },
+ { 0x10AC7, 0x10AC9 },
+ { 0x111DA, 0x111DC },
+ { 0x11211, 0x11213 },
+ { 0x11286, 0x1128A },
+ { 0x1128D, 0x1128F },
+ { 0x1129D, 0x1129F },
+ { 0x11328, 0x1132A },
+ { 0x11330, 0x11332 },
+ { 0x11333, 0x11335 },
+ { 0x114C5, 0x114C7 },
+ { 0x11913, 0x11915 },
+ { 0x11916, 0x11918 },
+ { 0x1193F, 0x11941 },
+ { 0x119E1, 0x119E3 },
+ { 0x11C08, 0x11C0A },
+ { 0x11D06, 0x11D08 },
+ { 0x11D09, 0x11D0B },
+ { 0x11D65, 0x11D67 },
+ { 0x11D68, 0x11D6A },
+ { 0x16FE1, 0x16FE3 },
+ { 0x1AFF3, 0x1AFF5 },
+ { 0x1AFFB, 0x1AFFD },
+ { 0x1AFFE, 0x1B000 },
+ { 0x1D454, 0x1D456 },
+ { 0x1D49C, 0x1D49E },
+ { 0x1D4AC, 0x1D4AE },
+ { 0x1D4B9, 0x1D4BD },
+ { 0x1D4C3, 0x1D4C5 },
+ { 0x1D505, 0x1D507 },
+ { 0x1D514, 0x1D516 },
+ { 0x1D51C, 0x1D51E },
+ { 0x1D539, 0x1D53B },
+ { 0x1D53E, 0x1D540 },
+ { 0x1D544, 0x1D546 },
+ { 0x1D550, 0x1D552 },
+ { 0x1D6C0, 0x1D6C2 },
+ { 0x1D6DA, 0x1D6DC },
+ { 0x1D6FA, 0x1D6FC },
+ { 0x1D714, 0x1D716 },
+ { 0x1D734, 0x1D736 },
+ { 0x1D74E, 0x1D750 },
+ { 0x1D76E, 0x1D770 },
+ { 0x1D788, 0x1D78A },
+ { 0x1D7A8, 0x1D7AA },
+ { 0x1D7C2, 0x1D7C4 },
+ { 0x1E7E6, 0x1E7E8 },
+ { 0x1E7EB, 0x1E7ED },
+ { 0x1E7EE, 0x1E7F0 },
+ { 0x1E7FE, 0x1E800 },
+ { 0x1EE03, 0x1EE05 },
+ { 0x1EE1F, 0x1EE21 },
+ { 0x1EE22, 0x1EE24 },
+ { 0x1EE27, 0x1EE29 },
+ { 0x1EE32, 0x1EE34 },
+ { 0x1EE37, 0x1EE3B },
+ { 0x1EE47, 0x1EE4D },
+ { 0x1EE4F, 0x1EE51 },
+ { 0x1EE52, 0x1EE54 },
+ { 0x1EE57, 0x1EE61 },
+ { 0x1EE62, 0x1EE64 },
+ { 0x1EE6A, 0x1EE6C },
+ { 0x1EE72, 0x1EE74 },
+ { 0x1EE77, 0x1EE79 },
+ { 0x1EE7C, 0x1EE80 },
+ { 0x1EE89, 0x1EE8B },
+ { 0x1EEA3, 0x1EEA5 },
+ { 0x1EEA9, 0x1EEAB },
+};
+
+static int alpha2[][2] = {
+ { 0x0041, 0x005A },
+ { 0x0061, 0x007A },
+ { 0x00C0, 0x00D6 },
+ { 0x00D8, 0x00F6 },
+ { 0x00F8, 0x02C1 },
+ { 0x02C6, 0x02D1 },
+ { 0x02E0, 0x02E4 },
+ { 0x0370, 0x0374 },
+ { 0x0376, 0x0377 },
+ { 0x037A, 0x037D },
+ { 0x0388, 0x038A },
+ { 0x038E, 0x03A1 },
+ { 0x03A3, 0x03F5 },
+ { 0x03F7, 0x0481 },
+ { 0x048A, 0x052F },
+ { 0x0531, 0x0556 },
+ { 0x0560, 0x0588 },
+ { 0x05D0, 0x05EA },
+ { 0x05EF, 0x05F2 },
+ { 0x0620, 0x064A },
+ { 0x066E, 0x066F },
+ { 0x0671, 0x06D3 },
+ { 0x06E5, 0x06E6 },
+ { 0x06EE, 0x06EF },
+ { 0x06FA, 0x06FC },
+ { 0x0712, 0x072F },
+ { 0x074D, 0x07A5 },
+ { 0x07CA, 0x07EA },
+ { 0x07F4, 0x07F5 },
+ { 0x0800, 0x0815 },
+ { 0x0840, 0x0858 },
+ { 0x0860, 0x086A },
+ { 0x0870, 0x0887 },
+ { 0x0889, 0x088E },
+ { 0x08A0, 0x08C9 },
+ { 0x0904, 0x0939 },
+ { 0x0958, 0x0961 },
+ { 0x0971, 0x0980 },
+ { 0x0985, 0x098C },
+ { 0x098F, 0x0990 },
+ { 0x0993, 0x09A8 },
+ { 0x09AA, 0x09B0 },
+ { 0x09B6, 0x09B9 },
+ { 0x09DC, 0x09DD },
+ { 0x09DF, 0x09E1 },
+ { 0x09F0, 0x09F1 },
+ { 0x0A05, 0x0A0A },
+ { 0x0A0F, 0x0A10 },
+ { 0x0A13, 0x0A28 },
+ { 0x0A2A, 0x0A30 },
+ { 0x0A32, 0x0A33 },
+ { 0x0A35, 0x0A36 },
+ { 0x0A38, 0x0A39 },
+ { 0x0A59, 0x0A5C },
+ { 0x0A72, 0x0A74 },
+ { 0x0A85, 0x0A8D },
+ { 0x0A8F, 0x0A91 },
+ { 0x0A93, 0x0AA8 },
+ { 0x0AAA, 0x0AB0 },
+ { 0x0AB2, 0x0AB3 },
+ { 0x0AB5, 0x0AB9 },
+ { 0x0AE0, 0x0AE1 },
+ { 0x0B05, 0x0B0C },
+ { 0x0B0F, 0x0B10 },
+ { 0x0B13, 0x0B28 },
+ { 0x0B2A, 0x0B30 },
+ { 0x0B32, 0x0B33 },
+ { 0x0B35, 0x0B39 },
+ { 0x0B5C, 0x0B5D },
+ { 0x0B5F, 0x0B61 },
+ { 0x0B85, 0x0B8A },
+ { 0x0B8E, 0x0B90 },
+ { 0x0B92, 0x0B95 },
+ { 0x0B99, 0x0B9A },
+ { 0x0B9E, 0x0B9F },
+ { 0x0BA3, 0x0BA4 },
+ { 0x0BA8, 0x0BAA },
+ { 0x0BAE, 0x0BB9 },
+ { 0x0C05, 0x0C0C },
+ { 0x0C0E, 0x0C10 },
+ { 0x0C12, 0x0C28 },
+ { 0x0C2A, 0x0C39 },
+ { 0x0C58, 0x0C5A },
+ { 0x0C60, 0x0C61 },
+ { 0x0C85, 0x0C8C },
+ { 0x0C8E, 0x0C90 },
+ { 0x0C92, 0x0CA8 },
+ { 0x0CAA, 0x0CB3 },
+ { 0x0CB5, 0x0CB9 },
+ { 0x0CDD, 0x0CDE },
+ { 0x0CE0, 0x0CE1 },
+ { 0x0CF1, 0x0CF2 },
+ { 0x0D04, 0x0D0C },
+ { 0x0D0E, 0x0D10 },
+ { 0x0D12, 0x0D3A },
+ { 0x0D54, 0x0D56 },
+ { 0x0D5F, 0x0D61 },
+ { 0x0D7A, 0x0D7F },
+ { 0x0D85, 0x0D96 },
+ { 0x0D9A, 0x0DB1 },
+ { 0x0DB3, 0x0DBB },
+ { 0x0DC0, 0x0DC6 },
+ { 0x0E01, 0x0E30 },
+ { 0x0E32, 0x0E33 },
+ { 0x0E40, 0x0E46 },
+ { 0x0E81, 0x0E82 },
+ { 0x0E86, 0x0E8A },
+ { 0x0E8C, 0x0EA3 },
+ { 0x0EA7, 0x0EB0 },
+ { 0x0EB2, 0x0EB3 },
+ { 0x0EC0, 0x0EC4 },
+ { 0x0EDC, 0x0EDF },
+ { 0x0F40, 0x0F47 },
+ { 0x0F49, 0x0F6C },
+ { 0x0F88, 0x0F8C },
+ { 0x1000, 0x102A },
+ { 0x1050, 0x1055 },
+ { 0x105A, 0x105D },
+ { 0x1065, 0x1066 },
+ { 0x106E, 0x1070 },
+ { 0x1075, 0x1081 },
+ { 0x10A0, 0x10C5 },
+ { 0x10D0, 0x10FA },
+ { 0x10FC, 0x1248 },
+ { 0x124A, 0x124D },
+ { 0x1250, 0x1256 },
+ { 0x125A, 0x125D },
+ { 0x1260, 0x1288 },
+ { 0x128A, 0x128D },
+ { 0x1290, 0x12B0 },
+ { 0x12B2, 0x12B5 },
+ { 0x12B8, 0x12BE },
+ { 0x12C2, 0x12C5 },
+ { 0x12C8, 0x12D6 },
+ { 0x12D8, 0x1310 },
+ { 0x1312, 0x1315 },
+ { 0x1318, 0x135A },
+ { 0x1380, 0x138F },
+ { 0x13A0, 0x13F5 },
+ { 0x13F8, 0x13FD },
+ { 0x1401, 0x166C },
+ { 0x166F, 0x167F },
+ { 0x1681, 0x169A },
+ { 0x16A0, 0x16EA },
+ { 0x16F1, 0x16F8 },
+ { 0x1700, 0x1711 },
+ { 0x171F, 0x1731 },
+ { 0x1740, 0x1751 },
+ { 0x1760, 0x176C },
+ { 0x176E, 0x1770 },
+ { 0x1780, 0x17B3 },
+ { 0x1820, 0x1878 },
+ { 0x1880, 0x1884 },
+ { 0x1887, 0x18A8 },
+ { 0x18B0, 0x18F5 },
+ { 0x1900, 0x191E },
+ { 0x1950, 0x196D },
+ { 0x1970, 0x1974 },
+ { 0x1980, 0x19AB },
+ { 0x19B0, 0x19C9 },
+ { 0x1A00, 0x1A16 },
+ { 0x1A20, 0x1A54 },
+ { 0x1B05, 0x1B33 },
+ { 0x1B45, 0x1B4C },
+ { 0x1B83, 0x1BA0 },
+ { 0x1BAE, 0x1BAF },
+ { 0x1BBA, 0x1BE5 },
+ { 0x1C00, 0x1C23 },
+ { 0x1C4D, 0x1C4F },
+ { 0x1C5A, 0x1C7D },
+ { 0x1C80, 0x1C88 },
+ { 0x1C90, 0x1CBA },
+ { 0x1CBD, 0x1CBF },
+ { 0x1CE9, 0x1CEC },
+ { 0x1CEE, 0x1CF3 },
+ { 0x1CF5, 0x1CF6 },
+ { 0x1D00, 0x1DBF },
+ { 0x1E00, 0x1F15 },
+ { 0x1F18, 0x1F1D },
+ { 0x1F20, 0x1F45 },
+ { 0x1F48, 0x1F4D },
+ { 0x1F50, 0x1F57 },
+ { 0x1F5F, 0x1F7D },
+ { 0x1F80, 0x1FB4 },
+ { 0x1FB6, 0x1FBC },
+ { 0x1FC2, 0x1FC4 },
+ { 0x1FC6, 0x1FCC },
+ { 0x1FD0, 0x1FD3 },
+ { 0x1FD6, 0x1FDB },
+ { 0x1FE0, 0x1FEC },
+ { 0x1FF2, 0x1FF4 },
+ { 0x1FF6, 0x1FFC },
+ { 0x2090, 0x209C },
+ { 0x210A, 0x2113 },
+ { 0x2119, 0x211D },
+ { 0x212A, 0x212D },
+ { 0x212F, 0x2139 },
+ { 0x213C, 0x213F },
+ { 0x2145, 0x2149 },
+ { 0x2183, 0x2184 },
+ { 0x2C00, 0x2CE4 },
+ { 0x2CEB, 0x2CEE },
+ { 0x2CF2, 0x2CF3 },
+ { 0x2D00, 0x2D25 },
+ { 0x2D30, 0x2D67 },
+ { 0x2D80, 0x2D96 },
+ { 0x2DA0, 0x2DA6 },
+ { 0x2DA8, 0x2DAE },
+ { 0x2DB0, 0x2DB6 },
+ { 0x2DB8, 0x2DBE },
+ { 0x2DC0, 0x2DC6 },
+ { 0x2DC8, 0x2DCE },
+ { 0x2DD0, 0x2DD6 },
+ { 0x2DD8, 0x2DDE },
+ { 0x3005, 0x3006 },
+ { 0x3031, 0x3035 },
+ { 0x303B, 0x303C },
+ { 0x3041, 0x3096 },
+ { 0x309D, 0x309F },
+ { 0x30A1, 0x30FA },
+ { 0x30FC, 0x30FF },
+ { 0x3105, 0x312F },
+ { 0x3131, 0x318E },
+ { 0x31A0, 0x31BF },
+ { 0x31F0, 0x31FF },
+ { 0x9FFF, 0xA48C },
+ { 0xA4D0, 0xA4FD },
+ { 0xA500, 0xA60C },
+ { 0xA610, 0xA61F },
+ { 0xA62A, 0xA62B },
+ { 0xA640, 0xA66E },
+ { 0xA67F, 0xA69D },
+ { 0xA6A0, 0xA6E5 },
+ { 0xA717, 0xA71F },
+ { 0xA722, 0xA788 },
+ { 0xA78B, 0xA7CA },
+ { 0xA7D0, 0xA7D1 },
+ { 0xA7D5, 0xA7D9 },
+ { 0xA7F2, 0xA801 },
+ { 0xA803, 0xA805 },
+ { 0xA807, 0xA80A },
+ { 0xA80C, 0xA822 },
+ { 0xA840, 0xA873 },
+ { 0xA882, 0xA8B3 },
+ { 0xA8F2, 0xA8F7 },
+ { 0xA8FD, 0xA8FE },
+ { 0xA90A, 0xA925 },
+ { 0xA930, 0xA946 },
+ { 0xA960, 0xA97C },
+ { 0xA984, 0xA9B2 },
+ { 0xA9E0, 0xA9E4 },
+ { 0xA9E6, 0xA9EF },
+ { 0xA9FA, 0xA9FE },
+ { 0xAA00, 0xAA28 },
+ { 0xAA40, 0xAA42 },
+ { 0xAA44, 0xAA4B },
+ { 0xAA60, 0xAA76 },
+ { 0xAA7E, 0xAAAF },
+ { 0xAAB5, 0xAAB6 },
+ { 0xAAB9, 0xAABD },
+ { 0xAADB, 0xAADD },
+ { 0xAAE0, 0xAAEA },
+ { 0xAAF2, 0xAAF4 },
+ { 0xAB01, 0xAB06 },
+ { 0xAB09, 0xAB0E },
+ { 0xAB11, 0xAB16 },
+ { 0xAB20, 0xAB26 },
+ { 0xAB28, 0xAB2E },
+ { 0xAB30, 0xAB5A },
+ { 0xAB5C, 0xAB69 },
+ { 0xAB70, 0xABE2 },
+ { 0xD7B0, 0xD7C6 },
+ { 0xD7CB, 0xD7FB },
+ { 0xF900, 0xFA6D },
+ { 0xFA70, 0xFAD9 },
+ { 0xFB00, 0xFB06 },
+ { 0xFB13, 0xFB17 },
+ { 0xFB1F, 0xFB28 },
+ { 0xFB2A, 0xFB36 },
+ { 0xFB38, 0xFB3C },
+ { 0xFB40, 0xFB41 },
+ { 0xFB43, 0xFB44 },
+ { 0xFB46, 0xFBB1 },
+ { 0xFBD3, 0xFD3D },
+ { 0xFD50, 0xFD8F },
+ { 0xFD92, 0xFDC7 },
+ { 0xFDF0, 0xFDFB },
+ { 0xFE70, 0xFE74 },
+ { 0xFE76, 0xFEFC },
+ { 0xFF21, 0xFF3A },
+ { 0xFF41, 0xFF5A },
+ { 0xFF66, 0xFFBE },
+ { 0xFFC2, 0xFFC7 },
+ { 0xFFCA, 0xFFCF },
+ { 0xFFD2, 0xFFD7 },
+ { 0xFFDA, 0xFFDC },
+ { 0x10000, 0x1000B },
+ { 0x1000D, 0x10026 },
+ { 0x10028, 0x1003A },
+ { 0x1003C, 0x1003D },
+ { 0x1003F, 0x1004D },
+ { 0x10050, 0x1005D },
+ { 0x10080, 0x100FA },
+ { 0x10280, 0x1029C },
+ { 0x102A0, 0x102D0 },
+ { 0x10300, 0x1031F },
+ { 0x1032D, 0x10340 },
+ { 0x10342, 0x10349 },
+ { 0x10350, 0x10375 },
+ { 0x10380, 0x1039D },
+ { 0x103A0, 0x103C3 },
+ { 0x103C8, 0x103CF },
+ { 0x10400, 0x1049D },
+ { 0x104B0, 0x104D3 },
+ { 0x104D8, 0x104FB },
+ { 0x10500, 0x10527 },
+ { 0x10530, 0x10563 },
+ { 0x10570, 0x1057A },
+ { 0x1057C, 0x1058A },
+ { 0x1058C, 0x10592 },
+ { 0x10594, 0x10595 },
+ { 0x10597, 0x105A1 },
+ { 0x105A3, 0x105B1 },
+ { 0x105B3, 0x105B9 },
+ { 0x105BB, 0x105BC },
+ { 0x10600, 0x10736 },
+ { 0x10740, 0x10755 },
+ { 0x10760, 0x10767 },
+ { 0x10780, 0x10785 },
+ { 0x10787, 0x107B0 },
+ { 0x107B2, 0x107BA },
+ { 0x10800, 0x10805 },
+ { 0x1080A, 0x10835 },
+ { 0x10837, 0x10838 },
+ { 0x1083F, 0x10855 },
+ { 0x10860, 0x10876 },
+ { 0x10880, 0x1089E },
+ { 0x108E0, 0x108F2 },
+ { 0x108F4, 0x108F5 },
+ { 0x10900, 0x10915 },
+ { 0x10920, 0x10939 },
+ { 0x10980, 0x109B7 },
+ { 0x109BE, 0x109BF },
+ { 0x10A10, 0x10A13 },
+ { 0x10A15, 0x10A17 },
+ { 0x10A19, 0x10A35 },
+ { 0x10A60, 0x10A7C },
+ { 0x10A80, 0x10A9C },
+ { 0x10AC0, 0x10AC7 },
+ { 0x10AC9, 0x10AE4 },
+ { 0x10B00, 0x10B35 },
+ { 0x10B40, 0x10B55 },
+ { 0x10B60, 0x10B72 },
+ { 0x10B80, 0x10B91 },
+ { 0x10C00, 0x10C48 },
+ { 0x10C80, 0x10CB2 },
+ { 0x10CC0, 0x10CF2 },
+ { 0x10D00, 0x10D23 },
+ { 0x10E80, 0x10EA9 },
+ { 0x10EB0, 0x10EB1 },
+ { 0x10F00, 0x10F1C },
+ { 0x10F30, 0x10F45 },
+ { 0x10F70, 0x10F81 },
+ { 0x10FB0, 0x10FC4 },
+ { 0x10FE0, 0x10FF6 },
+ { 0x11003, 0x11037 },
+ { 0x11071, 0x11072 },
+ { 0x11083, 0x110AF },
+ { 0x110D0, 0x110E8 },
+ { 0x11103, 0x11126 },
+ { 0x11150, 0x11172 },
+ { 0x11183, 0x111B2 },
+ { 0x111C1, 0x111C4 },
+ { 0x11200, 0x11211 },
+ { 0x11213, 0x1122B },
+ { 0x11280, 0x11286 },
+ { 0x1128A, 0x1128D },
+ { 0x1128F, 0x1129D },
+ { 0x1129F, 0x112A8 },
+ { 0x112B0, 0x112DE },
+ { 0x11305, 0x1130C },
+ { 0x1130F, 0x11310 },
+ { 0x11313, 0x11328 },
+ { 0x1132A, 0x11330 },
+ { 0x11332, 0x11333 },
+ { 0x11335, 0x11339 },
+ { 0x1135D, 0x11361 },
+ { 0x11400, 0x11434 },
+ { 0x11447, 0x1144A },
+ { 0x1145F, 0x11461 },
+ { 0x11480, 0x114AF },
+ { 0x114C4, 0x114C5 },
+ { 0x11580, 0x115AE },
+ { 0x115D8, 0x115DB },
+ { 0x11600, 0x1162F },
+ { 0x11680, 0x116AA },
+ { 0x11700, 0x1171A },
+ { 0x11740, 0x11746 },
+ { 0x11800, 0x1182B },
+ { 0x118A0, 0x118DF },
+ { 0x118FF, 0x11906 },
+ { 0x1190C, 0x11913 },
+ { 0x11915, 0x11916 },
+ { 0x11918, 0x1192F },
+ { 0x119A0, 0x119A7 },
+ { 0x119AA, 0x119D0 },
+ { 0x11A0B, 0x11A32 },
+ { 0x11A5C, 0x11A89 },
+ { 0x11AB0, 0x11AF8 },
+ { 0x11C00, 0x11C08 },
+ { 0x11C0A, 0x11C2E },
+ { 0x11C72, 0x11C8F },
+ { 0x11D00, 0x11D06 },
+ { 0x11D08, 0x11D09 },
+ { 0x11D0B, 0x11D30 },
+ { 0x11D60, 0x11D65 },
+ { 0x11D67, 0x11D68 },
+ { 0x11D6A, 0x11D89 },
+ { 0x11EE0, 0x11EF2 },
+ { 0x12000, 0x12399 },
+ { 0x12480, 0x12543 },
+ { 0x12F90, 0x12FF0 },
+ { 0x13000, 0x1342E },
+ { 0x14400, 0x14646 },
+ { 0x16800, 0x16A38 },
+ { 0x16A40, 0x16A5E },
+ { 0x16A70, 0x16ABE },
+ { 0x16AD0, 0x16AED },
+ { 0x16B00, 0x16B2F },
+ { 0x16B40, 0x16B43 },
+ { 0x16B63, 0x16B77 },
+ { 0x16B7D, 0x16B8F },
+ { 0x16E40, 0x16E7F },
+ { 0x16F00, 0x16F4A },
+ { 0x16F93, 0x16F9F },
+ { 0x16FE0, 0x16FE1 },
+ { 0x18800, 0x18CD5 },
+ { 0x1AFF0, 0x1AFF3 },
+ { 0x1AFF5, 0x1AFFB },
+ { 0x1AFFD, 0x1AFFE },
+ { 0x1B000, 0x1B122 },
+ { 0x1B150, 0x1B152 },
+ { 0x1B164, 0x1B167 },
+ { 0x1B170, 0x1B2FB },
+ { 0x1BC00, 0x1BC6A },
+ { 0x1BC70, 0x1BC7C },
+ { 0x1BC80, 0x1BC88 },
+ { 0x1BC90, 0x1BC99 },
+ { 0x1D400, 0x1D454 },
+ { 0x1D456, 0x1D49C },
+ { 0x1D49E, 0x1D49F },
+ { 0x1D4A5, 0x1D4A6 },
+ { 0x1D4A9, 0x1D4AC },
+ { 0x1D4AE, 0x1D4B9 },
+ { 0x1D4BD, 0x1D4C3 },
+ { 0x1D4C5, 0x1D505 },
+ { 0x1D507, 0x1D50A },
+ { 0x1D50D, 0x1D514 },
+ { 0x1D516, 0x1D51C },
+ { 0x1D51E, 0x1D539 },
+ { 0x1D53B, 0x1D53E },
+ { 0x1D540, 0x1D544 },
+ { 0x1D54A, 0x1D550 },
+ { 0x1D552, 0x1D6A5 },
+ { 0x1D6A8, 0x1D6C0 },
+ { 0x1D6C2, 0x1D6DA },
+ { 0x1D6DC, 0x1D6FA },
+ { 0x1D6FC, 0x1D714 },
+ { 0x1D716, 0x1D734 },
+ { 0x1D736, 0x1D74E },
+ { 0x1D750, 0x1D76E },
+ { 0x1D770, 0x1D788 },
+ { 0x1D78A, 0x1D7A8 },
+ { 0x1D7AA, 0x1D7C2 },
+ { 0x1D7C4, 0x1D7CB },
+ { 0x1DF00, 0x1DF1E },
+ { 0x1E100, 0x1E12C },
+ { 0x1E137, 0x1E13D },
+ { 0x1E290, 0x1E2AD },
+ { 0x1E2C0, 0x1E2EB },
+ { 0x1E7E0, 0x1E7E6 },
+ { 0x1E7E8, 0x1E7EB },
+ { 0x1E7ED, 0x1E7EE },
+ { 0x1E7F0, 0x1E7FE },
+ { 0x1E800, 0x1E8C4 },
+ { 0x1E900, 0x1E943 },
+ { 0x1EE00, 0x1EE03 },
+ { 0x1EE05, 0x1EE1F },
+ { 0x1EE21, 0x1EE22 },
+ { 0x1EE29, 0x1EE32 },
+ { 0x1EE34, 0x1EE37 },
+ { 0x1EE4D, 0x1EE4F },
+ { 0x1EE51, 0x1EE52 },
+ { 0x1EE61, 0x1EE62 },
+ { 0x1EE67, 0x1EE6A },
+ { 0x1EE6C, 0x1EE72 },
+ { 0x1EE74, 0x1EE77 },
+ { 0x1EE79, 0x1EE7C },
+ { 0x1EE80, 0x1EE89 },
+ { 0x1EE8B, 0x1EE9B },
+ { 0x1EEA1, 0x1EEA3 },
+ { 0x1EEA5, 0x1EEA9 },
+ { 0x1EEAB, 0x1EEBB },
+ { 0x2F800, 0x2FA1D },
+};
+
+static int alpha1[] = {
+ 0x00AA,
+ 0x00B5,
+ 0x00BA,
+ 0x0559,
+ 0x06FF,
+ 0x07B1,
+ 0x07FA,
+ 0x081A,
+ 0x0824,
+ 0x0828,
+ 0x093D,
+ 0x0950,
+ 0x09BD,
+ 0x09CE,
+ 0x09FC,
+ 0x0ABD,
+ 0x0AD0,
+ 0x0AF9,
+ 0x0B3D,
+ 0x0B71,
+ 0x0BD0,
+ 0x0C3D,
+ 0x0C5D,
+ 0x0C80,
+ 0x0CBD,
+ 0x0D3D,
+ 0x0D4E,
+ 0x0EBD,
+ 0x0F00,
+ 0x103F,
+ 0x1061,
+ 0x108E,
+ 0x10CD,
+ 0x17D7,
+ 0x17DC,
+ 0x1AA7,
+ 0x1CFA,
+ 0x2071,
+ 0x207F,
+ 0x2102,
+ 0x2107,
+ 0x214E,
+ 0x2D2D,
+ 0x2D6F,
+ 0x2E2F,
+ 0x3400,
+ 0x4DBF,
+ 0x4E00,
+ 0xA9CF,
+ 0xAA7A,
+ 0xAC00,
+ 0xD7A3,
+ 0x1083C,
+ 0x10A00,
+ 0x10F27,
+ 0x11075,
+ 0x11144,
+ 0x11147,
+ 0x11176,
+ 0x1133D,
+ 0x11350,
+ 0x11644,
+ 0x116B8,
+ 0x11909,
+ 0x11A00,
+ 0x11A3A,
+ 0x11A50,
+ 0x11A9D,
+ 0x11C40,
+ 0x11D46,
+ 0x11D98,
+ 0x11FB0,
+ 0x16F50,
+ 0x17000,
+ 0x187F7,
+ 0x18D00,
+ 0x18D08,
+ 0x1D4A2,
+ 0x1E14E,
+ 0x1E94B,
+ 0x1EE42,
+ 0x20000,
+ 0x2A6DF,
+ 0x2A700,
+ 0x2B738,
+ 0x2B740,
+ 0x2B81D,
+ 0x2B820,
+ 0x2CEA1,
+ 0x2CEB0,
+ 0x2EBE0,
+ 0x30000,
+ 0x3134A,
+};
+
+C_regparm int C_utf_isalpha(int r)
+{
+ int *match;
+
+ if((match = bsearch(&r, alpha3, nelem(alpha3), sizeof *alpha3, &rune2cmp)))
+ return !((r - match[0]) % 2);
+ if(bsearch(&r, alpha2, nelem(alpha2), sizeof *alpha2, &rune2cmp))
+ return 1;
+ if(bsearch(&r, alpha1, nelem(alpha1), sizeof *alpha1, &rune1cmp))
+ return 1;
+ return 0;
+}
+
+static int space2[][2] = {
+ { 0x0009, 0x000D },
+ { 0x001C, 0x0020 },
+ { 0x2000, 0x200A },
+ { 0x2028, 0x2029 },
+};
+
+static int space1[] = {
+ 0x0085,
+ 0x00A0,
+ 0x1680,
+ 0x202F,
+ 0x205F,
+ 0x3000,
+};
+
+C_regparm int C_utf_isspace(int r)
+{
+ if(bsearch(&r, space2, nelem(space2), sizeof *space2, &rune2cmp))
+ return 1;
+ if(bsearch(&r, space1, nelem(space1), sizeof *space1, &rune1cmp))
+ return 1;
+ return 0;
+}
+
+static int fold1[][ 2 ] = {
+ {0x0041, 0x0061},
+ {0x0042, 0x0062},
+ {0x0043, 0x0063},
+ {0x0044, 0x0064},
+ {0x0045, 0x0065},
+ {0x0046, 0x0066},
+ {0x0047, 0x0067},
+ {0x0048, 0x0068},
+ {0x0049, 0x0069},
+ {0x004A, 0x006A},
+ {0x004B, 0x006B},
+ {0x004C, 0x006C},
+ {0x004D, 0x006D},
+ {0x004E, 0x006E},
+ {0x004F, 0x006F},
+ {0x0050, 0x0070},
+ {0x0051, 0x0071},
+ {0x0052, 0x0072},
+ {0x0053, 0x0073},
+ {0x0054, 0x0074},
+ {0x0055, 0x0075},
+ {0x0056, 0x0076},
+ {0x0057, 0x0077},
+ {0x0058, 0x0078},
+ {0x0059, 0x0079},
+ {0x005A, 0x007A},
+ {0x00B5, 0x03BC},
+ {0x00C0, 0x00E0},
+ {0x00C1, 0x00E1},
+ {0x00C2, 0x00E2},
+ {0x00C3, 0x00E3},
+ {0x00C4, 0x00E4},
+ {0x00C5, 0x00E5},
+ {0x00C6, 0x00E6},
+ {0x00C7, 0x00E7},
+ {0x00C8, 0x00E8},
+ {0x00C9, 0x00E9},
+ {0x00CA, 0x00EA},
+ {0x00CB, 0x00EB},
+ {0x00CC, 0x00EC},
+ {0x00CD, 0x00ED},
+ {0x00CE, 0x00EE},
+ {0x00CF, 0x00EF},
+ {0x00D0, 0x00F0},
+ {0x00D1, 0x00F1},
+ {0x00D2, 0x00F2},
+ {0x00D3, 0x00F3},
+ {0x00D4, 0x00F4},
+ {0x00D5, 0x00F5},
+ {0x00D6, 0x00F6},
+ {0x00D8, 0x00F8},
+ {0x00D9, 0x00F9},
+ {0x00DA, 0x00FA},
+ {0x00DB, 0x00FB},
+ {0x00DC, 0x00FC},
+ {0x00DD, 0x00FD},
+ {0x00DE, 0x00FE},
+ {0x0100, 0x0101},
+ {0x0102, 0x0103},
+ {0x0104, 0x0105},
+ {0x0106, 0x0107},
+ {0x0108, 0x0109},
+ {0x010A, 0x010B},
+ {0x010C, 0x010D},
+ {0x010E, 0x010F},
+ {0x0110, 0x0111},
+ {0x0112, 0x0113},
+ {0x0114, 0x0115},
+ {0x0116, 0x0117},
+ {0x0118, 0x0119},
+ {0x011A, 0x011B},
+ {0x011C, 0x011D},
+ {0x011E, 0x011F},
+ {0x0120, 0x0121},
+ {0x0122, 0x0123},
+ {0x0124, 0x0125},
+ {0x0126, 0x0127},
+ {0x0128, 0x0129},
+ {0x012A, 0x012B},
+ {0x012C, 0x012D},
+ {0x012E, 0x012F},
+ {0x0132, 0x0133},
+ {0x0134, 0x0135},
+ {0x0136, 0x0137},
+ {0x0139, 0x013A},
+ {0x013B, 0x013C},
+ {0x013D, 0x013E},
+ {0x013F, 0x0140},
+ {0x0141, 0x0142},
+ {0x0143, 0x0144},
+ {0x0145, 0x0146},
+ {0x0147, 0x0148},
+ {0x014A, 0x014B},
+ {0x014C, 0x014D},
+ {0x014E, 0x014F},
+ {0x0150, 0x0151},
+ {0x0152, 0x0153},
+ {0x0154, 0x0155},
+ {0x0156, 0x0157},
+ {0x0158, 0x0159},
+ {0x015A, 0x015B},
+ {0x015C, 0x015D},
+ {0x015E, 0x015F},
+ {0x0160, 0x0161},
+ {0x0162, 0x0163},
+ {0x0164, 0x0165},
+ {0x0166, 0x0167},
+ {0x0168, 0x0169},
+ {0x016A, 0x016B},
+ {0x016C, 0x016D},
+ {0x016E, 0x016F},
+ {0x0170, 0x0171},
+ {0x0172, 0x0173},
+ {0x0174, 0x0175},
+ {0x0176, 0x0177},
+ {0x0178, 0x00FF},
+ {0x0179, 0x017A},
+ {0x017B, 0x017C},
+ {0x017D, 0x017E},
+ {0x017F, 0x0073},
+ {0x0181, 0x0253},
+ {0x0182, 0x0183},
+ {0x0184, 0x0185},
+ {0x0186, 0x0254},
+ {0x0187, 0x0188},
+ {0x0189, 0x0256},
+ {0x018A, 0x0257},
+ {0x018B, 0x018C},
+ {0x018E, 0x01DD},
+ {0x018F, 0x0259},
+ {0x0190, 0x025B},
+ {0x0191, 0x0192},
+ {0x0193, 0x0260},
+ {0x0194, 0x0263},
+ {0x0196, 0x0269},
+ {0x0197, 0x0268},
+ {0x0198, 0x0199},
+ {0x019C, 0x026F},
+ {0x019D, 0x0272},
+ {0x019F, 0x0275},
+ {0x01A0, 0x01A1},
+ {0x01A2, 0x01A3},
+ {0x01A4, 0x01A5},
+ {0x01A6, 0x0280},
+ {0x01A7, 0x01A8},
+ {0x01A9, 0x0283},
+ {0x01AC, 0x01AD},
+ {0x01AE, 0x0288},
+ {0x01AF, 0x01B0},
+ {0x01B1, 0x028A},
+ {0x01B2, 0x028B},
+ {0x01B3, 0x01B4},
+ {0x01B5, 0x01B6},
+ {0x01B7, 0x0292},
+ {0x01B8, 0x01B9},
+ {0x01BC, 0x01BD},
+ {0x01C4, 0x01C6},
+ {0x01C5, 0x01C6},
+ {0x01C7, 0x01C9},
+ {0x01C8, 0x01C9},
+ {0x01CA, 0x01CC},
+ {0x01CB, 0x01CC},
+ {0x01CD, 0x01CE},
+ {0x01CF, 0x01D0},
+ {0x01D1, 0x01D2},
+ {0x01D3, 0x01D4},
+ {0x01D5, 0x01D6},
+ {0x01D7, 0x01D8},
+ {0x01D9, 0x01DA},
+ {0x01DB, 0x01DC},
+ {0x01DE, 0x01DF},
+ {0x01E0, 0x01E1},
+ {0x01E2, 0x01E3},
+ {0x01E4, 0x01E5},
+ {0x01E6, 0x01E7},
+ {0x01E8, 0x01E9},
+ {0x01EA, 0x01EB},
+ {0x01EC, 0x01ED},
+ {0x01EE, 0x01EF},
+ {0x01F1, 0x01F3},
+ {0x01F2, 0x01F3},
+ {0x01F4, 0x01F5},
+ {0x01F6, 0x0195},
+ {0x01F7, 0x01BF},
+ {0x01F8, 0x01F9},
+ {0x01FA, 0x01FB},
+ {0x01FC, 0x01FD},
+ {0x01FE, 0x01FF},
+ {0x0200, 0x0201},
+ {0x0202, 0x0203},
+ {0x0204, 0x0205},
+ {0x0206, 0x0207},
+ {0x0208, 0x0209},
+ {0x020A, 0x020B},
+ {0x020C, 0x020D},
+ {0x020E, 0x020F},
+ {0x0210, 0x0211},
+ {0x0212, 0x0213},
+ {0x0214, 0x0215},
+ {0x0216, 0x0217},
+ {0x0218, 0x0219},
+ {0x021A, 0x021B},
+ {0x021C, 0x021D},
+ {0x021E, 0x021F},
+ {0x0220, 0x019E},
+ {0x0222, 0x0223},
+ {0x0224, 0x0225},
+ {0x0226, 0x0227},
+ {0x0228, 0x0229},
+ {0x022A, 0x022B},
+ {0x022C, 0x022D},
+ {0x022E, 0x022F},
+ {0x0230, 0x0231},
+ {0x0232, 0x0233},
+ {0x023A, 0x2C65},
+ {0x023B, 0x023C},
+ {0x023D, 0x019A},
+ {0x023E, 0x2C66},
+ {0x0241, 0x0242},
+ {0x0243, 0x0180},
+ {0x0244, 0x0289},
+ {0x0245, 0x028C},
+ {0x0246, 0x0247},
+ {0x0248, 0x0249},
+ {0x024A, 0x024B},
+ {0x024C, 0x024D},
+ {0x024E, 0x024F},
+ {0x0345, 0x03B9},
+ {0x0370, 0x0371},
+ {0x0372, 0x0373},
+ {0x0376, 0x0377},
+ {0x037F, 0x03F3},
+ {0x0386, 0x03AC},
+ {0x0388, 0x03AD},
+ {0x0389, 0x03AE},
+ {0x038A, 0x03AF},
+ {0x038C, 0x03CC},
+ {0x038E, 0x03CD},
+ {0x038F, 0x03CE},
+ {0x0391, 0x03B1},
+ {0x0392, 0x03B2},
+ {0x0393, 0x03B3},
+ {0x0394, 0x03B4},
+ {0x0395, 0x03B5},
+ {0x0396, 0x03B6},
+ {0x0397, 0x03B7},
+ {0x0398, 0x03B8},
+ {0x0399, 0x03B9},
+ {0x039A, 0x03BA},
+ {0x039B, 0x03BB},
+ {0x039C, 0x03BC},
+ {0x039D, 0x03BD},
+ {0x039E, 0x03BE},
+ {0x039F, 0x03BF},
+ {0x03A0, 0x03C0},
+ {0x03A1, 0x03C1},
+ {0x03A3, 0x03C3},
+ {0x03A4, 0x03C4},
+ {0x03A5, 0x03C5},
+ {0x03A6, 0x03C6},
+ {0x03A7, 0x03C7},
+ {0x03A8, 0x03C8},
+ {0x03A9, 0x03C9},
+ {0x03AA, 0x03CA},
+ {0x03AB, 0x03CB},
+ {0x03C2, 0x03C3},
+ {0x03CF, 0x03D7},
+ {0x03D0, 0x03B2},
+ {0x03D1, 0x03B8},
+ {0x03D5, 0x03C6},
+ {0x03D6, 0x03C0},
+ {0x03D8, 0x03D9},
+ {0x03DA, 0x03DB},
+ {0x03DC, 0x03DD},
+ {0x03DE, 0x03DF},
+ {0x03E0, 0x03E1},
+ {0x03E2, 0x03E3},
+ {0x03E4, 0x03E5},
+ {0x03E6, 0x03E7},
+ {0x03E8, 0x03E9},
+ {0x03EA, 0x03EB},
+ {0x03EC, 0x03ED},
+ {0x03EE, 0x03EF},
+ {0x03F0, 0x03BA},
+ {0x03F1, 0x03C1},
+ {0x03F4, 0x03B8},
+ {0x03F5, 0x03B5},
+ {0x03F7, 0x03F8},
+ {0x03F9, 0x03F2},
+ {0x03FA, 0x03FB},
+ {0x03FD, 0x037B},
+ {0x03FE, 0x037C},
+ {0x03FF, 0x037D},
+ {0x0400, 0x0450},
+ {0x0401, 0x0451},
+ {0x0402, 0x0452},
+ {0x0403, 0x0453},
+ {0x0404, 0x0454},
+ {0x0405, 0x0455},
+ {0x0406, 0x0456},
+ {0x0407, 0x0457},
+ {0x0408, 0x0458},
+ {0x0409, 0x0459},
+ {0x040A, 0x045A},
+ {0x040B, 0x045B},
+ {0x040C, 0x045C},
+ {0x040D, 0x045D},
+ {0x040E, 0x045E},
+ {0x040F, 0x045F},
+ {0x0410, 0x0430},
+ {0x0411, 0x0431},
+ {0x0412, 0x0432},
+ {0x0413, 0x0433},
+ {0x0414, 0x0434},
+ {0x0415, 0x0435},
+ {0x0416, 0x0436},
+ {0x0417, 0x0437},
+ {0x0418, 0x0438},
+ {0x0419, 0x0439},
+ {0x041A, 0x043A},
+ {0x041B, 0x043B},
+ {0x041C, 0x043C},
+ {0x041D, 0x043D},
+ {0x041E, 0x043E},
+ {0x041F, 0x043F},
+ {0x0420, 0x0440},
+ {0x0421, 0x0441},
+ {0x0422, 0x0442},
+ {0x0423, 0x0443},
+ {0x0424, 0x0444},
+ {0x0425, 0x0445},
+ {0x0426, 0x0446},
+ {0x0427, 0x0447},
+ {0x0428, 0x0448},
+ {0x0429, 0x0449},
+ {0x042A, 0x044A},
+ {0x042B, 0x044B},
+ {0x042C, 0x044C},
+ {0x042D, 0x044D},
+ {0x042E, 0x044E},
+ {0x042F, 0x044F},
+ {0x0460, 0x0461},
+ {0x0462, 0x0463},
+ {0x0464, 0x0465},
+ {0x0466, 0x0467},
+ {0x0468, 0x0469},
+ {0x046A, 0x046B},
+ {0x046C, 0x046D},
+ {0x046E, 0x046F},
+ {0x0470, 0x0471},
+ {0x0472, 0x0473},
+ {0x0474, 0x0475},
+ {0x0476, 0x0477},
+ {0x0478, 0x0479},
+ {0x047A, 0x047B},
+ {0x047C, 0x047D},
+ {0x047E, 0x047F},
+ {0x0480, 0x0481},
+ {0x048A, 0x048B},
+ {0x048C, 0x048D},
+ {0x048E, 0x048F},
+ {0x0490, 0x0491},
+ {0x0492, 0x0493},
+ {0x0494, 0x0495},
+ {0x0496, 0x0497},
+ {0x0498, 0x0499},
+ {0x049A, 0x049B},
+ {0x049C, 0x049D},
+ {0x049E, 0x049F},
+ {0x04A0, 0x04A1},
+ {0x04A2, 0x04A3},
+ {0x04A4, 0x04A5},
+ {0x04A6, 0x04A7},
+ {0x04A8, 0x04A9},
+ {0x04AA, 0x04AB},
+ {0x04AC, 0x04AD},
+ {0x04AE, 0x04AF},
+ {0x04B0, 0x04B1},
+ {0x04B2, 0x04B3},
+ {0x04B4, 0x04B5},
+ {0x04B6, 0x04B7},
+ {0x04B8, 0x04B9},
+ {0x04BA, 0x04BB},
+ {0x04BC, 0x04BD},
+ {0x04BE, 0x04BF},
+ {0x04C0, 0x04CF},
+ {0x04C1, 0x04C2},
+ {0x04C3, 0x04C4},
+ {0x04C5, 0x04C6},
+ {0x04C7, 0x04C8},
+ {0x04C9, 0x04CA},
+ {0x04CB, 0x04CC},
+ {0x04CD, 0x04CE},
+ {0x04D0, 0x04D1},
+ {0x04D2, 0x04D3},
+ {0x04D4, 0x04D5},
+ {0x04D6, 0x04D7},
+ {0x04D8, 0x04D9},
+ {0x04DA, 0x04DB},
+ {0x04DC, 0x04DD},
+ {0x04DE, 0x04DF},
+ {0x04E0, 0x04E1},
+ {0x04E2, 0x04E3},
+ {0x04E4, 0x04E5},
+ {0x04E6, 0x04E7},
+ {0x04E8, 0x04E9},
+ {0x04EA, 0x04EB},
+ {0x04EC, 0x04ED},
+ {0x04EE, 0x04EF},
+ {0x04F0, 0x04F1},
+ {0x04F2, 0x04F3},
+ {0x04F4, 0x04F5},
+ {0x04F6, 0x04F7},
+ {0x04F8, 0x04F9},
+ {0x04FA, 0x04FB},
+ {0x04FC, 0x04FD},
+ {0x04FE, 0x04FF},
+ {0x0500, 0x0501},
+ {0x0502, 0x0503},
+ {0x0504, 0x0505},
+ {0x0506, 0x0507},
+ {0x0508, 0x0509},
+ {0x050A, 0x050B},
+ {0x050C, 0x050D},
+ {0x050E, 0x050F},
+ {0x0510, 0x0511},
+ {0x0512, 0x0513},
+ {0x0514, 0x0515},
+ {0x0516, 0x0517},
+ {0x0518, 0x0519},
+ {0x051A, 0x051B},
+ {0x051C, 0x051D},
+ {0x051E, 0x051F},
+ {0x0520, 0x0521},
+ {0x0522, 0x0523},
+ {0x0524, 0x0525},
+ {0x0526, 0x0527},
+ {0x0528, 0x0529},
+ {0x052A, 0x052B},
+ {0x052C, 0x052D},
+ {0x052E, 0x052F},
+ {0x0531, 0x0561},
+ {0x0532, 0x0562},
+ {0x0533, 0x0563},
+ {0x0534, 0x0564},
+ {0x0535, 0x0565},
+ {0x0536, 0x0566},
+ {0x0537, 0x0567},
+ {0x0538, 0x0568},
+ {0x0539, 0x0569},
+ {0x053A, 0x056A},
+ {0x053B, 0x056B},
+ {0x053C, 0x056C},
+ {0x053D, 0x056D},
+ {0x053E, 0x056E},
+ {0x053F, 0x056F},
+ {0x0540, 0x0570},
+ {0x0541, 0x0571},
+ {0x0542, 0x0572},
+ {0x0543, 0x0573},
+ {0x0544, 0x0574},
+ {0x0545, 0x0575},
+ {0x0546, 0x0576},
+ {0x0547, 0x0577},
+ {0x0548, 0x0578},
+ {0x0549, 0x0579},
+ {0x054A, 0x057A},
+ {0x054B, 0x057B},
+ {0x054C, 0x057C},
+ {0x054D, 0x057D},
+ {0x054E, 0x057E},
+ {0x054F, 0x057F},
+ {0x0550, 0x0580},
+ {0x0551, 0x0581},
+ {0x0552, 0x0582},
+ {0x0553, 0x0583},
+ {0x0554, 0x0584},
+ {0x0555, 0x0585},
+ {0x0556, 0x0586},
+ {0x10A0, 0x2D00},
+ {0x10A1, 0x2D01},
+ {0x10A2, 0x2D02},
+ {0x10A3, 0x2D03},
+ {0x10A4, 0x2D04},
+ {0x10A5, 0x2D05},
+ {0x10A6, 0x2D06},
+ {0x10A7, 0x2D07},
+ {0x10A8, 0x2D08},
+ {0x10A9, 0x2D09},
+ {0x10AA, 0x2D0A},
+ {0x10AB, 0x2D0B},
+ {0x10AC, 0x2D0C},
+ {0x10AD, 0x2D0D},
+ {0x10AE, 0x2D0E},
+ {0x10AF, 0x2D0F},
+ {0x10B0, 0x2D10},
+ {0x10B1, 0x2D11},
+ {0x10B2, 0x2D12},
+ {0x10B3, 0x2D13},
+ {0x10B4, 0x2D14},
+ {0x10B5, 0x2D15},
+ {0x10B6, 0x2D16},
+ {0x10B7, 0x2D17},
+ {0x10B8, 0x2D18},
+ {0x10B9, 0x2D19},
+ {0x10BA, 0x2D1A},
+ {0x10BB, 0x2D1B},
+ {0x10BC, 0x2D1C},
+ {0x10BD, 0x2D1D},
+ {0x10BE, 0x2D1E},
+ {0x10BF, 0x2D1F},
+ {0x10C0, 0x2D20},
+ {0x10C1, 0x2D21},
+ {0x10C2, 0x2D22},
+ {0x10C3, 0x2D23},
+ {0x10C4, 0x2D24},
+ {0x10C5, 0x2D25},
+ {0x10C7, 0x2D27},
+ {0x10CD, 0x2D2D},
+ {0x13F8, 0x13F0},
+ {0x13F9, 0x13F1},
+ {0x13FA, 0x13F2},
+ {0x13FB, 0x13F3},
+ {0x13FC, 0x13F4},
+ {0x13FD, 0x13F5},
+ {0x1C80, 0x0432},
+ {0x1C81, 0x0434},
+ {0x1C82, 0x043E},
+ {0x1C83, 0x0441},
+ {0x1C84, 0x0442},
+ {0x1C85, 0x0442},
+ {0x1C86, 0x044A},
+ {0x1C87, 0x0463},
+ {0x1C88, 0xA64B},
+ {0x1C90, 0x10D0},
+ {0x1C91, 0x10D1},
+ {0x1C92, 0x10D2},
+ {0x1C93, 0x10D3},
+ {0x1C94, 0x10D4},
+ {0x1C95, 0x10D5},
+ {0x1C96, 0x10D6},
+ {0x1C97, 0x10D7},
+ {0x1C98, 0x10D8},
+ {0x1C99, 0x10D9},
+ {0x1C9A, 0x10DA},
+ {0x1C9B, 0x10DB},
+ {0x1C9C, 0x10DC},
+ {0x1C9D, 0x10DD},
+ {0x1C9E, 0x10DE},
+ {0x1C9F, 0x10DF},
+ {0x1CA0, 0x10E0},
+ {0x1CA1, 0x10E1},
+ {0x1CA2, 0x10E2},
+ {0x1CA3, 0x10E3},
+ {0x1CA4, 0x10E4},
+ {0x1CA5, 0x10E5},
+ {0x1CA6, 0x10E6},
+ {0x1CA7, 0x10E7},
+ {0x1CA8, 0x10E8},
+ {0x1CA9, 0x10E9},
+ {0x1CAA, 0x10EA},
+ {0x1CAB, 0x10EB},
+ {0x1CAC, 0x10EC},
+ {0x1CAD, 0x10ED},
+ {0x1CAE, 0x10EE},
+ {0x1CAF, 0x10EF},
+ {0x1CB0, 0x10F0},
+ {0x1CB1, 0x10F1},
+ {0x1CB2, 0x10F2},
+ {0x1CB3, 0x10F3},
+ {0x1CB4, 0x10F4},
+ {0x1CB5, 0x10F5},
+ {0x1CB6, 0x10F6},
+ {0x1CB7, 0x10F7},
+ {0x1CB8, 0x10F8},
+ {0x1CB9, 0x10F9},
+ {0x1CBA, 0x10FA},
+ {0x1CBD, 0x10FD},
+ {0x1CBE, 0x10FE},
+ {0x1CBF, 0x10FF},
+ {0x1E00, 0x1E01},
+ {0x1E02, 0x1E03},
+ {0x1E04, 0x1E05},
+ {0x1E06, 0x1E07},
+ {0x1E08, 0x1E09},
+ {0x1E0A, 0x1E0B},
+ {0x1E0C, 0x1E0D},
+ {0x1E0E, 0x1E0F},
+ {0x1E10, 0x1E11},
+ {0x1E12, 0x1E13},
+ {0x1E14, 0x1E15},
+ {0x1E16, 0x1E17},
+ {0x1E18, 0x1E19},
+ {0x1E1A, 0x1E1B},
+ {0x1E1C, 0x1E1D},
+ {0x1E1E, 0x1E1F},
+ {0x1E20, 0x1E21},
+ {0x1E22, 0x1E23},
+ {0x1E24, 0x1E25},
+ {0x1E26, 0x1E27},
+ {0x1E28, 0x1E29},
+ {0x1E2A, 0x1E2B},
+ {0x1E2C, 0x1E2D},
+ {0x1E2E, 0x1E2F},
+ {0x1E30, 0x1E31},
+ {0x1E32, 0x1E33},
+ {0x1E34, 0x1E35},
+ {0x1E36, 0x1E37},
+ {0x1E38, 0x1E39},
+ {0x1E3A, 0x1E3B},
+ {0x1E3C, 0x1E3D},
+ {0x1E3E, 0x1E3F},
+ {0x1E40, 0x1E41},
+ {0x1E42, 0x1E43},
+ {0x1E44, 0x1E45},
+ {0x1E46, 0x1E47},
+ {0x1E48, 0x1E49},
+ {0x1E4A, 0x1E4B},
+ {0x1E4C, 0x1E4D},
+ {0x1E4E, 0x1E4F},
+ {0x1E50, 0x1E51},
+ {0x1E52, 0x1E53},
+ {0x1E54, 0x1E55},
+ {0x1E56, 0x1E57},
+ {0x1E58, 0x1E59},
+ {0x1E5A, 0x1E5B},
+ {0x1E5C, 0x1E5D},
+ {0x1E5E, 0x1E5F},
+ {0x1E60, 0x1E61},
+ {0x1E62, 0x1E63},
+ {0x1E64, 0x1E65},
+ {0x1E66, 0x1E67},
+ {0x1E68, 0x1E69},
+ {0x1E6A, 0x1E6B},
+ {0x1E6C, 0x1E6D},
+ {0x1E6E, 0x1E6F},
+ {0x1E70, 0x1E71},
+ {0x1E72, 0x1E73},
+ {0x1E74, 0x1E75},
+ {0x1E76, 0x1E77},
+ {0x1E78, 0x1E79},
+ {0x1E7A, 0x1E7B},
+ {0x1E7C, 0x1E7D},
+ {0x1E7E, 0x1E7F},
+ {0x1E80, 0x1E81},
+ {0x1E82, 0x1E83},
+ {0x1E84, 0x1E85},
+ {0x1E86, 0x1E87},
+ {0x1E88, 0x1E89},
+ {0x1E8A, 0x1E8B},
+ {0x1E8C, 0x1E8D},
+ {0x1E8E, 0x1E8F},
+ {0x1E90, 0x1E91},
+ {0x1E92, 0x1E93},
+ {0x1E94, 0x1E95},
+ {0x1E9B, 0x1E61},
+ {0x1E9E, 0x00DF},
+ {0x1EA0, 0x1EA1},
+ {0x1EA2, 0x1EA3},
+ {0x1EA4, 0x1EA5},
+ {0x1EA6, 0x1EA7},
+ {0x1EA8, 0x1EA9},
+ {0x1EAA, 0x1EAB},
+ {0x1EAC, 0x1EAD},
+ {0x1EAE, 0x1EAF},
+ {0x1EB0, 0x1EB1},
+ {0x1EB2, 0x1EB3},
+ {0x1EB4, 0x1EB5},
+ {0x1EB6, 0x1EB7},
+ {0x1EB8, 0x1EB9},
+ {0x1EBA, 0x1EBB},
+ {0x1EBC, 0x1EBD},
+ {0x1EBE, 0x1EBF},
+ {0x1EC0, 0x1EC1},
+ {0x1EC2, 0x1EC3},
+ {0x1EC4, 0x1EC5},
+ {0x1EC6, 0x1EC7},
+ {0x1EC8, 0x1EC9},
+ {0x1ECA, 0x1ECB},
+ {0x1ECC, 0x1ECD},
+ {0x1ECE, 0x1ECF},
+ {0x1ED0, 0x1ED1},
+ {0x1ED2, 0x1ED3},
+ {0x1ED4, 0x1ED5},
+ {0x1ED6, 0x1ED7},
+ {0x1ED8, 0x1ED9},
+ {0x1EDA, 0x1EDB},
+ {0x1EDC, 0x1EDD},
+ {0x1EDE, 0x1EDF},
+ {0x1EE0, 0x1EE1},
+ {0x1EE2, 0x1EE3},
+ {0x1EE4, 0x1EE5},
+ {0x1EE6, 0x1EE7},
+ {0x1EE8, 0x1EE9},
+ {0x1EEA, 0x1EEB},
+ {0x1EEC, 0x1EED},
+ {0x1EEE, 0x1EEF},
+ {0x1EF0, 0x1EF1},
+ {0x1EF2, 0x1EF3},
+ {0x1EF4, 0x1EF5},
+ {0x1EF6, 0x1EF7},
+ {0x1EF8, 0x1EF9},
+ {0x1EFA, 0x1EFB},
+ {0x1EFC, 0x1EFD},
+ {0x1EFE, 0x1EFF},
+ {0x1F08, 0x1F00},
+ {0x1F09, 0x1F01},
+ {0x1F0A, 0x1F02},
+ {0x1F0B, 0x1F03},
+ {0x1F0C, 0x1F04},
+ {0x1F0D, 0x1F05},
+ {0x1F0E, 0x1F06},
+ {0x1F0F, 0x1F07},
+ {0x1F18, 0x1F10},
+ {0x1F19, 0x1F11},
+ {0x1F1A, 0x1F12},
+ {0x1F1B, 0x1F13},
+ {0x1F1C, 0x1F14},
+ {0x1F1D, 0x1F15},
+ {0x1F28, 0x1F20},
+ {0x1F29, 0x1F21},
+ {0x1F2A, 0x1F22},
+ {0x1F2B, 0x1F23},
+ {0x1F2C, 0x1F24},
+ {0x1F2D, 0x1F25},
+ {0x1F2E, 0x1F26},
+ {0x1F2F, 0x1F27},
+ {0x1F38, 0x1F30},
+ {0x1F39, 0x1F31},
+ {0x1F3A, 0x1F32},
+ {0x1F3B, 0x1F33},
+ {0x1F3C, 0x1F34},
+ {0x1F3D, 0x1F35},
+ {0x1F3E, 0x1F36},
+ {0x1F3F, 0x1F37},
+ {0x1F48, 0x1F40},
+ {0x1F49, 0x1F41},
+ {0x1F4A, 0x1F42},
+ {0x1F4B, 0x1F43},
+ {0x1F4C, 0x1F44},
+ {0x1F4D, 0x1F45},
+ {0x1F59, 0x1F51},
+ {0x1F5B, 0x1F53},
+ {0x1F5D, 0x1F55},
+ {0x1F5F, 0x1F57},
+ {0x1F68, 0x1F60},
+ {0x1F69, 0x1F61},
+ {0x1F6A, 0x1F62},
+ {0x1F6B, 0x1F63},
+ {0x1F6C, 0x1F64},
+ {0x1F6D, 0x1F65},
+ {0x1F6E, 0x1F66},
+ {0x1F6F, 0x1F67},
+ {0x1F88, 0x1F80},
+ {0x1F89, 0x1F81},
+ {0x1F8A, 0x1F82},
+ {0x1F8B, 0x1F83},
+ {0x1F8C, 0x1F84},
+ {0x1F8D, 0x1F85},
+ {0x1F8E, 0x1F86},
+ {0x1F8F, 0x1F87},
+ {0x1F98, 0x1F90},
+ {0x1F99, 0x1F91},
+ {0x1F9A, 0x1F92},
+ {0x1F9B, 0x1F93},
+ {0x1F9C, 0x1F94},
+ {0x1F9D, 0x1F95},
+ {0x1F9E, 0x1F96},
+ {0x1F9F, 0x1F97},
+ {0x1FA8, 0x1FA0},
+ {0x1FA9, 0x1FA1},
+ {0x1FAA, 0x1FA2},
+ {0x1FAB, 0x1FA3},
+ {0x1FAC, 0x1FA4},
+ {0x1FAD, 0x1FA5},
+ {0x1FAE, 0x1FA6},
+ {0x1FAF, 0x1FA7},
+ {0x1FB8, 0x1FB0},
+ {0x1FB9, 0x1FB1},
+ {0x1FBA, 0x1F70},
+ {0x1FBB, 0x1F71},
+ {0x1FBC, 0x1FB3},
+ {0x1FBE, 0x03B9},
+ {0x1FC8, 0x1F72},
+ {0x1FC9, 0x1F73},
+ {0x1FCA, 0x1F74},
+ {0x1FCB, 0x1F75},
+ {0x1FCC, 0x1FC3},
+ {0x1FD8, 0x1FD0},
+ {0x1FD9, 0x1FD1},
+ {0x1FDA, 0x1F76},
+ {0x1FDB, 0x1F77},
+ {0x1FE8, 0x1FE0},
+ {0x1FE9, 0x1FE1},
+ {0x1FEA, 0x1F7A},
+ {0x1FEB, 0x1F7B},
+ {0x1FEC, 0x1FE5},
+ {0x1FF8, 0x1F78},
+ {0x1FF9, 0x1F79},
+ {0x1FFA, 0x1F7C},
+ {0x1FFB, 0x1F7D},
+ {0x1FFC, 0x1FF3},
+ {0x2126, 0x03C9},
+ {0x212A, 0x006B},
+ {0x212B, 0x00E5},
+ {0x2132, 0x214E},
+ {0x2160, 0x2170},
+ {0x2161, 0x2171},
+ {0x2162, 0x2172},
+ {0x2163, 0x2173},
+ {0x2164, 0x2174},
+ {0x2165, 0x2175},
+ {0x2166, 0x2176},
+ {0x2167, 0x2177},
+ {0x2168, 0x2178},
+ {0x2169, 0x2179},
+ {0x216A, 0x217A},
+ {0x216B, 0x217B},
+ {0x216C, 0x217C},
+ {0x216D, 0x217D},
+ {0x216E, 0x217E},
+ {0x216F, 0x217F},
+ {0x2183, 0x2184},
+ {0x24B6, 0x24D0},
+ {0x24B7, 0x24D1},
+ {0x24B8, 0x24D2},
+ {0x24B9, 0x24D3},
+ {0x24BA, 0x24D4},
+ {0x24BB, 0x24D5},
+ {0x24BC, 0x24D6},
+ {0x24BD, 0x24D7},
+ {0x24BE, 0x24D8},
+ {0x24BF, 0x24D9},
+ {0x24C0, 0x24DA},
+ {0x24C1, 0x24DB},
+ {0x24C2, 0x24DC},
+ {0x24C3, 0x24DD},
+ {0x24C4, 0x24DE},
+ {0x24C5, 0x24DF},
+ {0x24C6, 0x24E0},
+ {0x24C7, 0x24E1},
+ {0x24C8, 0x24E2},
+ {0x24C9, 0x24E3},
+ {0x24CA, 0x24E4},
+ {0x24CB, 0x24E5},
+ {0x24CC, 0x24E6},
+ {0x24CD, 0x24E7},
+ {0x24CE, 0x24E8},
+ {0x24CF, 0x24E9},
+ {0x2C00, 0x2C30},
+ {0x2C01, 0x2C31},
+ {0x2C02, 0x2C32},
+ {0x2C03, 0x2C33},
+ {0x2C04, 0x2C34},
+ {0x2C05, 0x2C35},
+ {0x2C06, 0x2C36},
+ {0x2C07, 0x2C37},
+ {0x2C08, 0x2C38},
+ {0x2C09, 0x2C39},
+ {0x2C0A, 0x2C3A},
+ {0x2C0B, 0x2C3B},
+ {0x2C0C, 0x2C3C},
+ {0x2C0D, 0x2C3D},
+ {0x2C0E, 0x2C3E},
+ {0x2C0F, 0x2C3F},
+ {0x2C10, 0x2C40},
+ {0x2C11, 0x2C41},
+ {0x2C12, 0x2C42},
+ {0x2C13, 0x2C43},
+ {0x2C14, 0x2C44},
+ {0x2C15, 0x2C45},
+ {0x2C16, 0x2C46},
+ {0x2C17, 0x2C47},
+ {0x2C18, 0x2C48},
+ {0x2C19, 0x2C49},
+ {0x2C1A, 0x2C4A},
+ {0x2C1B, 0x2C4B},
+ {0x2C1C, 0x2C4C},
+ {0x2C1D, 0x2C4D},
+ {0x2C1E, 0x2C4E},
+ {0x2C1F, 0x2C4F},
+ {0x2C20, 0x2C50},
+ {0x2C21, 0x2C51},
+ {0x2C22, 0x2C52},
+ {0x2C23, 0x2C53},
+ {0x2C24, 0x2C54},
+ {0x2C25, 0x2C55},
+ {0x2C26, 0x2C56},
+ {0x2C27, 0x2C57},
+ {0x2C28, 0x2C58},
+ {0x2C29, 0x2C59},
+ {0x2C2A, 0x2C5A},
+ {0x2C2B, 0x2C5B},
+ {0x2C2C, 0x2C5C},
+ {0x2C2D, 0x2C5D},
+ {0x2C2E, 0x2C5E},
+ {0x2C2F, 0x2C5F},
+ {0x2C60, 0x2C61},
+ {0x2C62, 0x026B},
+ {0x2C63, 0x1D7D},
+ {0x2C64, 0x027D},
+ {0x2C67, 0x2C68},
+ {0x2C69, 0x2C6A},
+ {0x2C6B, 0x2C6C},
+ {0x2C6D, 0x0251},
+ {0x2C6E, 0x0271},
+ {0x2C6F, 0x0250},
+ {0x2C70, 0x0252},
+ {0x2C72, 0x2C73},
+ {0x2C75, 0x2C76},
+ {0x2C7E, 0x023F},
+ {0x2C7F, 0x0240},
+ {0x2C80, 0x2C81},
+ {0x2C82, 0x2C83},
+ {0x2C84, 0x2C85},
+ {0x2C86, 0x2C87},
+ {0x2C88, 0x2C89},
+ {0x2C8A, 0x2C8B},
+ {0x2C8C, 0x2C8D},
+ {0x2C8E, 0x2C8F},
+ {0x2C90, 0x2C91},
+ {0x2C92, 0x2C93},
+ {0x2C94, 0x2C95},
+ {0x2C96, 0x2C97},
+ {0x2C98, 0x2C99},
+ {0x2C9A, 0x2C9B},
+ {0x2C9C, 0x2C9D},
+ {0x2C9E, 0x2C9F},
+ {0x2CA0, 0x2CA1},
+ {0x2CA2, 0x2CA3},
+ {0x2CA4, 0x2CA5},
+ {0x2CA6, 0x2CA7},
+ {0x2CA8, 0x2CA9},
+ {0x2CAA, 0x2CAB},
+ {0x2CAC, 0x2CAD},
+ {0x2CAE, 0x2CAF},
+ {0x2CB0, 0x2CB1},
+ {0x2CB2, 0x2CB3},
+ {0x2CB4, 0x2CB5},
+ {0x2CB6, 0x2CB7},
+ {0x2CB8, 0x2CB9},
+ {0x2CBA, 0x2CBB},
+ {0x2CBC, 0x2CBD},
+ {0x2CBE, 0x2CBF},
+ {0x2CC0, 0x2CC1},
+ {0x2CC2, 0x2CC3},
+ {0x2CC4, 0x2CC5},
+ {0x2CC6, 0x2CC7},
+ {0x2CC8, 0x2CC9},
+ {0x2CCA, 0x2CCB},
+ {0x2CCC, 0x2CCD},
+ {0x2CCE, 0x2CCF},
+ {0x2CD0, 0x2CD1},
+ {0x2CD2, 0x2CD3},
+ {0x2CD4, 0x2CD5},
+ {0x2CD6, 0x2CD7},
+ {0x2CD8, 0x2CD9},
+ {0x2CDA, 0x2CDB},
+ {0x2CDC, 0x2CDD},
+ {0x2CDE, 0x2CDF},
+ {0x2CE0, 0x2CE1},
+ {0x2CE2, 0x2CE3},
+ {0x2CEB, 0x2CEC},
+ {0x2CED, 0x2CEE},
+ {0x2CF2, 0x2CF3},
+ {0xA640, 0xA641},
+ {0xA642, 0xA643},
+ {0xA644, 0xA645},
+ {0xA646, 0xA647},
+ {0xA648, 0xA649},
+ {0xA64A, 0xA64B},
+ {0xA64C, 0xA64D},
+ {0xA64E, 0xA64F},
+ {0xA650, 0xA651},
+ {0xA652, 0xA653},
+ {0xA654, 0xA655},
+ {0xA656, 0xA657},
+ {0xA658, 0xA659},
+ {0xA65A, 0xA65B},
+ {0xA65C, 0xA65D},
+ {0xA65E, 0xA65F},
+ {0xA660, 0xA661},
+ {0xA662, 0xA663},
+ {0xA664, 0xA665},
+ {0xA666, 0xA667},
+ {0xA668, 0xA669},
+ {0xA66A, 0xA66B},
+ {0xA66C, 0xA66D},
+ {0xA680, 0xA681},
+ {0xA682, 0xA683},
+ {0xA684, 0xA685},
+ {0xA686, 0xA687},
+ {0xA688, 0xA689},
+ {0xA68A, 0xA68B},
+ {0xA68C, 0xA68D},
+ {0xA68E, 0xA68F},
+ {0xA690, 0xA691},
+ {0xA692, 0xA693},
+ {0xA694, 0xA695},
+ {0xA696, 0xA697},
+ {0xA698, 0xA699},
+ {0xA69A, 0xA69B},
+ {0xA722, 0xA723},
+ {0xA724, 0xA725},
+ {0xA726, 0xA727},
+ {0xA728, 0xA729},
+ {0xA72A, 0xA72B},
+ {0xA72C, 0xA72D},
+ {0xA72E, 0xA72F},
+ {0xA732, 0xA733},
+ {0xA734, 0xA735},
+ {0xA736, 0xA737},
+ {0xA738, 0xA739},
+ {0xA73A, 0xA73B},
+ {0xA73C, 0xA73D},
+ {0xA73E, 0xA73F},
+ {0xA740, 0xA741},
+ {0xA742, 0xA743},
+ {0xA744, 0xA745},
+ {0xA746, 0xA747},
+ {0xA748, 0xA749},
+ {0xA74A, 0xA74B},
+ {0xA74C, 0xA74D},
+ {0xA74E, 0xA74F},
+ {0xA750, 0xA751},
+ {0xA752, 0xA753},
+ {0xA754, 0xA755},
+ {0xA756, 0xA757},
+ {0xA758, 0xA759},
+ {0xA75A, 0xA75B},
+ {0xA75C, 0xA75D},
+ {0xA75E, 0xA75F},
+ {0xA760, 0xA761},
+ {0xA762, 0xA763},
+ {0xA764, 0xA765},
+ {0xA766, 0xA767},
+ {0xA768, 0xA769},
+ {0xA76A, 0xA76B},
+ {0xA76C, 0xA76D},
+ {0xA76E, 0xA76F},
+ {0xA779, 0xA77A},
+ {0xA77B, 0xA77C},
+ {0xA77D, 0x1D79},
+ {0xA77E, 0xA77F},
+ {0xA780, 0xA781},
+ {0xA782, 0xA783},
+ {0xA784, 0xA785},
+ {0xA786, 0xA787},
+ {0xA78B, 0xA78C},
+ {0xA78D, 0x0265},
+ {0xA790, 0xA791},
+ {0xA792, 0xA793},
+ {0xA796, 0xA797},
+ {0xA798, 0xA799},
+ {0xA79A, 0xA79B},
+ {0xA79C, 0xA79D},
+ {0xA79E, 0xA79F},
+ {0xA7A0, 0xA7A1},
+ {0xA7A2, 0xA7A3},
+ {0xA7A4, 0xA7A5},
+ {0xA7A6, 0xA7A7},
+ {0xA7A8, 0xA7A9},
+ {0xA7AA, 0x0266},
+ {0xA7AB, 0x025C},
+ {0xA7AC, 0x0261},
+ {0xA7AD, 0x026C},
+ {0xA7AE, 0x026A},
+ {0xA7B0, 0x029E},
+ {0xA7B1, 0x0287},
+ {0xA7B2, 0x029D},
+ {0xA7B3, 0xAB53},
+ {0xA7B4, 0xA7B5},
+ {0xA7B6, 0xA7B7},
+ {0xA7B8, 0xA7B9},
+ {0xA7BA, 0xA7BB},
+ {0xA7BC, 0xA7BD},
+ {0xA7BE, 0xA7BF},
+ {0xA7C0, 0xA7C1},
+ {0xA7C2, 0xA7C3},
+ {0xA7C4, 0xA794},
+ {0xA7C5, 0x0282},
+ {0xA7C6, 0x1D8E},
+ {0xA7C7, 0xA7C8},
+ {0xA7C9, 0xA7CA},
+ {0xA7D0, 0xA7D1},
+ {0xA7D6, 0xA7D7},
+ {0xA7D8, 0xA7D9},
+ {0xA7F5, 0xA7F6},
+ {0xAB70, 0x13A0},
+ {0xAB71, 0x13A1},
+ {0xAB72, 0x13A2},
+ {0xAB73, 0x13A3},
+ {0xAB74, 0x13A4},
+ {0xAB75, 0x13A5},
+ {0xAB76, 0x13A6},
+ {0xAB77, 0x13A7},
+ {0xAB78, 0x13A8},
+ {0xAB79, 0x13A9},
+ {0xAB7A, 0x13AA},
+ {0xAB7B, 0x13AB},
+ {0xAB7C, 0x13AC},
+ {0xAB7D, 0x13AD},
+ {0xAB7E, 0x13AE},
+ {0xAB7F, 0x13AF},
+ {0xAB80, 0x13B0},
+ {0xAB81, 0x13B1},
+ {0xAB82, 0x13B2},
+ {0xAB83, 0x13B3},
+ {0xAB84, 0x13B4},
+ {0xAB85, 0x13B5},
+ {0xAB86, 0x13B6},
+ {0xAB87, 0x13B7},
+ {0xAB88, 0x13B8},
+ {0xAB89, 0x13B9},
+ {0xAB8A, 0x13BA},
+ {0xAB8B, 0x13BB},
+ {0xAB8C, 0x13BC},
+ {0xAB8D, 0x13BD},
+ {0xAB8E, 0x13BE},
+ {0xAB8F, 0x13BF},
+ {0xAB90, 0x13C0},
+ {0xAB91, 0x13C1},
+ {0xAB92, 0x13C2},
+ {0xAB93, 0x13C3},
+ {0xAB94, 0x13C4},
+ {0xAB95, 0x13C5},
+ {0xAB96, 0x13C6},
+ {0xAB97, 0x13C7},
+ {0xAB98, 0x13C8},
+ {0xAB99, 0x13C9},
+ {0xAB9A, 0x13CA},
+ {0xAB9B, 0x13CB},
+ {0xAB9C, 0x13CC},
+ {0xAB9D, 0x13CD},
+ {0xAB9E, 0x13CE},
+ {0xAB9F, 0x13CF},
+ {0xABA0, 0x13D0},
+ {0xABA1, 0x13D1},
+ {0xABA2, 0x13D2},
+ {0xABA3, 0x13D3},
+ {0xABA4, 0x13D4},
+ {0xABA5, 0x13D5},
+ {0xABA6, 0x13D6},
+ {0xABA7, 0x13D7},
+ {0xABA8, 0x13D8},
+ {0xABA9, 0x13D9},
+ {0xABAA, 0x13DA},
+ {0xABAB, 0x13DB},
+ {0xABAC, 0x13DC},
+ {0xABAD, 0x13DD},
+ {0xABAE, 0x13DE},
+ {0xABAF, 0x13DF},
+ {0xABB0, 0x13E0},
+ {0xABB1, 0x13E1},
+ {0xABB2, 0x13E2},
+ {0xABB3, 0x13E3},
+ {0xABB4, 0x13E4},
+ {0xABB5, 0x13E5},
+ {0xABB6, 0x13E6},
+ {0xABB7, 0x13E7},
+ {0xABB8, 0x13E8},
+ {0xABB9, 0x13E9},
+ {0xABBA, 0x13EA},
+ {0xABBB, 0x13EB},
+ {0xABBC, 0x13EC},
+ {0xABBD, 0x13ED},
+ {0xABBE, 0x13EE},
+ {0xABBF, 0x13EF},
+ {0xFF21, 0xFF41},
+ {0xFF22, 0xFF42},
+ {0xFF23, 0xFF43},
+ {0xFF24, 0xFF44},
+ {0xFF25, 0xFF45},
+ {0xFF26, 0xFF46},
+ {0xFF27, 0xFF47},
+ {0xFF28, 0xFF48},
+ {0xFF29, 0xFF49},
+ {0xFF2A, 0xFF4A},
+ {0xFF2B, 0xFF4B},
+ {0xFF2C, 0xFF4C},
+ {0xFF2D, 0xFF4D},
+ {0xFF2E, 0xFF4E},
+ {0xFF2F, 0xFF4F},
+ {0xFF30, 0xFF50},
+ {0xFF31, 0xFF51},
+ {0xFF32, 0xFF52},
+ {0xFF33, 0xFF53},
+ {0xFF34, 0xFF54},
+ {0xFF35, 0xFF55},
+ {0xFF36, 0xFF56},
+ {0xFF37, 0xFF57},
+ {0xFF38, 0xFF58},
+ {0xFF39, 0xFF59},
+ {0xFF3A, 0xFF5A},
+ {0x10400, 0x10428},
+ {0x10401, 0x10429},
+ {0x10402, 0x1042A},
+ {0x10403, 0x1042B},
+ {0x10404, 0x1042C},
+ {0x10405, 0x1042D},
+ {0x10406, 0x1042E},
+ {0x10407, 0x1042F},
+ {0x10408, 0x10430},
+ {0x10409, 0x10431},
+ {0x1040A, 0x10432},
+ {0x1040B, 0x10433},
+ {0x1040C, 0x10434},
+ {0x1040D, 0x10435},
+ {0x1040E, 0x10436},
+ {0x1040F, 0x10437},
+ {0x10410, 0x10438},
+ {0x10411, 0x10439},
+ {0x10412, 0x1043A},
+ {0x10413, 0x1043B},
+ {0x10414, 0x1043C},
+ {0x10415, 0x1043D},
+ {0x10416, 0x1043E},
+ {0x10417, 0x1043F},
+ {0x10418, 0x10440},
+ {0x10419, 0x10441},
+ {0x1041A, 0x10442},
+ {0x1041B, 0x10443},
+ {0x1041C, 0x10444},
+ {0x1041D, 0x10445},
+ {0x1041E, 0x10446},
+ {0x1041F, 0x10447},
+ {0x10420, 0x10448},
+ {0x10421, 0x10449},
+ {0x10422, 0x1044A},
+ {0x10423, 0x1044B},
+ {0x10424, 0x1044C},
+ {0x10425, 0x1044D},
+ {0x10426, 0x1044E},
+ {0x10427, 0x1044F},
+ {0x104B0, 0x104D8},
+ {0x104B1, 0x104D9},
+ {0x104B2, 0x104DA},
+ {0x104B3, 0x104DB},
+ {0x104B4, 0x104DC},
+ {0x104B5, 0x104DD},
+ {0x104B6, 0x104DE},
+ {0x104B7, 0x104DF},
+ {0x104B8, 0x104E0},
+ {0x104B9, 0x104E1},
+ {0x104BA, 0x104E2},
+ {0x104BB, 0x104E3},
+ {0x104BC, 0x104E4},
+ {0x104BD, 0x104E5},
+ {0x104BE, 0x104E6},
+ {0x104BF, 0x104E7},
+ {0x104C0, 0x104E8},
+ {0x104C1, 0x104E9},
+ {0x104C2, 0x104EA},
+ {0x104C3, 0x104EB},
+ {0x104C4, 0x104EC},
+ {0x104C5, 0x104ED},
+ {0x104C6, 0x104EE},
+ {0x104C7, 0x104EF},
+ {0x104C8, 0x104F0},
+ {0x104C9, 0x104F1},
+ {0x104CA, 0x104F2},
+ {0x104CB, 0x104F3},
+ {0x104CC, 0x104F4},
+ {0x104CD, 0x104F5},
+ {0x104CE, 0x104F6},
+ {0x104CF, 0x104F7},
+ {0x104D0, 0x104F8},
+ {0x104D1, 0x104F9},
+ {0x104D2, 0x104FA},
+ {0x104D3, 0x104FB},
+ {0x10570, 0x10597},
+ {0x10571, 0x10598},
+ {0x10572, 0x10599},
+ {0x10573, 0x1059A},
+ {0x10574, 0x1059B},
+ {0x10575, 0x1059C},
+ {0x10576, 0x1059D},
+ {0x10577, 0x1059E},
+ {0x10578, 0x1059F},
+ {0x10579, 0x105A0},
+ {0x1057A, 0x105A1},
+ {0x1057C, 0x105A3},
+ {0x1057D, 0x105A4},
+ {0x1057E, 0x105A5},
+ {0x1057F, 0x105A6},
+ {0x10580, 0x105A7},
+ {0x10581, 0x105A8},
+ {0x10582, 0x105A9},
+ {0x10583, 0x105AA},
+ {0x10584, 0x105AB},
+ {0x10585, 0x105AC},
+ {0x10586, 0x105AD},
+ {0x10587, 0x105AE},
+ {0x10588, 0x105AF},
+ {0x10589, 0x105B0},
+ {0x1058A, 0x105B1},
+ {0x1058C, 0x105B3},
+ {0x1058D, 0x105B4},
+ {0x1058E, 0x105B5},
+ {0x1058F, 0x105B6},
+ {0x10590, 0x105B7},
+ {0x10591, 0x105B8},
+ {0x10592, 0x105B9},
+ {0x10594, 0x105BB},
+ {0x10595, 0x105BC},
+ {0x10C80, 0x10CC0},
+ {0x10C81, 0x10CC1},
+ {0x10C82, 0x10CC2},
+ {0x10C83, 0x10CC3},
+ {0x10C84, 0x10CC4},
+ {0x10C85, 0x10CC5},
+ {0x10C86, 0x10CC6},
+ {0x10C87, 0x10CC7},
+ {0x10C88, 0x10CC8},
+ {0x10C89, 0x10CC9},
+ {0x10C8A, 0x10CCA},
+ {0x10C8B, 0x10CCB},
+ {0x10C8C, 0x10CCC},
+ {0x10C8D, 0x10CCD},
+ {0x10C8E, 0x10CCE},
+ {0x10C8F, 0x10CCF},
+ {0x10C90, 0x10CD0},
+ {0x10C91, 0x10CD1},
+ {0x10C92, 0x10CD2},
+ {0x10C93, 0x10CD3},
+ {0x10C94, 0x10CD4},
+ {0x10C95, 0x10CD5},
+ {0x10C96, 0x10CD6},
+ {0x10C97, 0x10CD7},
+ {0x10C98, 0x10CD8},
+ {0x10C99, 0x10CD9},
+ {0x10C9A, 0x10CDA},
+ {0x10C9B, 0x10CDB},
+ {0x10C9C, 0x10CDC},
+ {0x10C9D, 0x10CDD},
+ {0x10C9E, 0x10CDE},
+ {0x10C9F, 0x10CDF},
+ {0x10CA0, 0x10CE0},
+ {0x10CA1, 0x10CE1},
+ {0x10CA2, 0x10CE2},
+ {0x10CA3, 0x10CE3},
+ {0x10CA4, 0x10CE4},
+ {0x10CA5, 0x10CE5},
+ {0x10CA6, 0x10CE6},
+ {0x10CA7, 0x10CE7},
+ {0x10CA8, 0x10CE8},
+ {0x10CA9, 0x10CE9},
+ {0x10CAA, 0x10CEA},
+ {0x10CAB, 0x10CEB},
+ {0x10CAC, 0x10CEC},
+ {0x10CAD, 0x10CED},
+ {0x10CAE, 0x10CEE},
+ {0x10CAF, 0x10CEF},
+ {0x10CB0, 0x10CF0},
+ {0x10CB1, 0x10CF1},
+ {0x10CB2, 0x10CF2},
+ {0x118A0, 0x118C0},
+ {0x118A1, 0x118C1},
+ {0x118A2, 0x118C2},
+ {0x118A3, 0x118C3},
+ {0x118A4, 0x118C4},
+ {0x118A5, 0x118C5},
+ {0x118A6, 0x118C6},
+ {0x118A7, 0x118C7},
+ {0x118A8, 0x118C8},
+ {0x118A9, 0x118C9},
+ {0x118AA, 0x118CA},
+ {0x118AB, 0x118CB},
+ {0x118AC, 0x118CC},
+ {0x118AD, 0x118CD},
+ {0x118AE, 0x118CE},
+ {0x118AF, 0x118CF},
+ {0x118B0, 0x118D0},
+ {0x118B1, 0x118D1},
+ {0x118B2, 0x118D2},
+ {0x118B3, 0x118D3},
+ {0x118B4, 0x118D4},
+ {0x118B5, 0x118D5},
+ {0x118B6, 0x118D6},
+ {0x118B7, 0x118D7},
+ {0x118B8, 0x118D8},
+ {0x118B9, 0x118D9},
+ {0x118BA, 0x118DA},
+ {0x118BB, 0x118DB},
+ {0x118BC, 0x118DC},
+ {0x118BD, 0x118DD},
+ {0x118BE, 0x118DE},
+ {0x118BF, 0x118DF},
+ {0x16E40, 0x16E60},
+ {0x16E41, 0x16E61},
+ {0x16E42, 0x16E62},
+ {0x16E43, 0x16E63},
+ {0x16E44, 0x16E64},
+ {0x16E45, 0x16E65},
+ {0x16E46, 0x16E66},
+ {0x16E47, 0x16E67},
+ {0x16E48, 0x16E68},
+ {0x16E49, 0x16E69},
+ {0x16E4A, 0x16E6A},
+ {0x16E4B, 0x16E6B},
+ {0x16E4C, 0x16E6C},
+ {0x16E4D, 0x16E6D},
+ {0x16E4E, 0x16E6E},
+ {0x16E4F, 0x16E6F},
+ {0x16E50, 0x16E70},
+ {0x16E51, 0x16E71},
+ {0x16E52, 0x16E72},
+ {0x16E53, 0x16E73},
+ {0x16E54, 0x16E74},
+ {0x16E55, 0x16E75},
+ {0x16E56, 0x16E76},
+ {0x16E57, 0x16E77},
+ {0x16E58, 0x16E78},
+ {0x16E59, 0x16E79},
+ {0x16E5A, 0x16E7A},
+ {0x16E5B, 0x16E7B},
+ {0x16E5C, 0x16E7C},
+ {0x16E5D, 0x16E7D},
+ {0x16E5E, 0x16E7E},
+ {0x16E5F, 0x16E7F},
+ {0x1E900, 0x1E922},
+ {0x1E901, 0x1E923},
+ {0x1E902, 0x1E924},
+ {0x1E903, 0x1E925},
+ {0x1E904, 0x1E926},
+ {0x1E905, 0x1E927},
+ {0x1E906, 0x1E928},
+ {0x1E907, 0x1E929},
+ {0x1E908, 0x1E92A},
+ {0x1E909, 0x1E92B},
+ {0x1E90A, 0x1E92C},
+ {0x1E90B, 0x1E92D},
+ {0x1E90C, 0x1E92E},
+ {0x1E90D, 0x1E92F},
+ {0x1E90E, 0x1E930},
+ {0x1E90F, 0x1E931},
+ {0x1E910, 0x1E932},
+ {0x1E911, 0x1E933},
+ {0x1E912, 0x1E934},
+ {0x1E913, 0x1E935},
+ {0x1E914, 0x1E936},
+ {0x1E915, 0x1E937},
+ {0x1E916, 0x1E938},
+ {0x1E917, 0x1E939},
+ {0x1E918, 0x1E93A},
+ {0x1E919, 0x1E93B},
+ {0x1E91A, 0x1E93C},
+ {0x1E91B, 0x1E93D},
+ {0x1E91C, 0x1E93E},
+ {0x1E91D, 0x1E93F},
+ {0x1E91E, 0x1E940},
+ {0x1E91F, 0x1E941},
+ {0x1E920, 0x1E942},
+ {0x1E921, 0x1E943},
+};
+
+static int fold2[][ 4 ] = {
+ {0x00DF, 0x0073, 0x0073, 0x0},
+ {0x0130, 0x0069, 0x0307, 0x0},
+ {0x0149, 0x02BC, 0x006E, 0x0},
+ {0x01F0, 0x006A, 0x030C, 0x0},
+ {0x0390, 0x03B9, 0x0308, 0x0301},
+ {0x03B0, 0x03C5, 0x0308, 0x0301},
+ {0x0587, 0x0565, 0x0582, 0x0},
+ {0x1E96, 0x0068, 0x0331, 0x0},
+ {0x1E97, 0x0074, 0x0308, 0x0},
+ {0x1E98, 0x0077, 0x030A, 0x0},
+ {0x1E99, 0x0079, 0x030A, 0x0},
+ {0x1E9A, 0x0061, 0x02BE, 0x0},
+ {0x1E9E, 0x0073, 0x0073, 0x0},
+ {0x1F50, 0x03C5, 0x0313, 0x0},
+ {0x1F52, 0x03C5, 0x0313, 0x0300},
+ {0x1F54, 0x03C5, 0x0313, 0x0301},
+ {0x1F56, 0x03C5, 0x0313, 0x0342},
+ {0x1F80, 0x1F00, 0x03B9, 0x0},
+ {0x1F81, 0x1F01, 0x03B9, 0x0},
+ {0x1F82, 0x1F02, 0x03B9, 0x0},
+ {0x1F83, 0x1F03, 0x03B9, 0x0},
+ {0x1F84, 0x1F04, 0x03B9, 0x0},
+ {0x1F85, 0x1F05, 0x03B9, 0x0},
+ {0x1F86, 0x1F06, 0x03B9, 0x0},
+ {0x1F87, 0x1F07, 0x03B9, 0x0},
+ {0x1F88, 0x1F00, 0x03B9, 0x0},
+ {0x1F89, 0x1F01, 0x03B9, 0x0},
+ {0x1F8A, 0x1F02, 0x03B9, 0x0},
+ {0x1F8B, 0x1F03, 0x03B9, 0x0},
+ {0x1F8C, 0x1F04, 0x03B9, 0x0},
+ {0x1F8D, 0x1F05, 0x03B9, 0x0},
+ {0x1F8E, 0x1F06, 0x03B9, 0x0},
+ {0x1F8F, 0x1F07, 0x03B9, 0x0},
+ {0x1F90, 0x1F20, 0x03B9, 0x0},
+ {0x1F91, 0x1F21, 0x03B9, 0x0},
+ {0x1F92, 0x1F22, 0x03B9, 0x0},
+ {0x1F93, 0x1F23, 0x03B9, 0x0},
+ {0x1F94, 0x1F24, 0x03B9, 0x0},
+ {0x1F95, 0x1F25, 0x03B9, 0x0},
+ {0x1F96, 0x1F26, 0x03B9, 0x0},
+ {0x1F97, 0x1F27, 0x03B9, 0x0},
+ {0x1F98, 0x1F20, 0x03B9, 0x0},
+ {0x1F99, 0x1F21, 0x03B9, 0x0},
+ {0x1F9A, 0x1F22, 0x03B9, 0x0},
+ {0x1F9B, 0x1F23, 0x03B9, 0x0},
+ {0x1F9C, 0x1F24, 0x03B9, 0x0},
+ {0x1F9D, 0x1F25, 0x03B9, 0x0},
+ {0x1F9E, 0x1F26, 0x03B9, 0x0},
+ {0x1F9F, 0x1F27, 0x03B9, 0x0},
+ {0x1FA0, 0x1F60, 0x03B9, 0x0},
+ {0x1FA1, 0x1F61, 0x03B9, 0x0},
+ {0x1FA2, 0x1F62, 0x03B9, 0x0},
+ {0x1FA3, 0x1F63, 0x03B9, 0x0},
+ {0x1FA4, 0x1F64, 0x03B9, 0x0},
+ {0x1FA5, 0x1F65, 0x03B9, 0x0},
+ {0x1FA6, 0x1F66, 0x03B9, 0x0},
+ {0x1FA7, 0x1F67, 0x03B9, 0x0},
+ {0x1FA8, 0x1F60, 0x03B9, 0x0},
+ {0x1FA9, 0x1F61, 0x03B9, 0x0},
+ {0x1FAA, 0x1F62, 0x03B9, 0x0},
+ {0x1FAB, 0x1F63, 0x03B9, 0x0},
+ {0x1FAC, 0x1F64, 0x03B9, 0x0},
+ {0x1FAD, 0x1F65, 0x03B9, 0x0},
+ {0x1FAE, 0x1F66, 0x03B9, 0x0},
+ {0x1FAF, 0x1F67, 0x03B9, 0x0},
+ {0x1FB2, 0x1F70, 0x03B9, 0x0},
+ {0x1FB3, 0x03B1, 0x03B9, 0x0},
+ {0x1FB4, 0x03AC, 0x03B9, 0x0},
+ {0x1FB6, 0x03B1, 0x0342, 0x0},
+ {0x1FB7, 0x03B1, 0x0342, 0x03B9},
+ {0x1FBC, 0x03B1, 0x03B9, 0x0},
+ {0x1FC2, 0x1F74, 0x03B9, 0x0},
+ {0x1FC3, 0x03B7, 0x03B9, 0x0},
+ {0x1FC4, 0x03AE, 0x03B9, 0x0},
+ {0x1FC6, 0x03B7, 0x0342, 0x0},
+ {0x1FC7, 0x03B7, 0x0342, 0x03B9},
+ {0x1FCC, 0x03B7, 0x03B9, 0x0},
+ {0x1FD2, 0x03B9, 0x0308, 0x0300},
+ {0x1FD3, 0x03B9, 0x0308, 0x0301},
+ {0x1FD6, 0x03B9, 0x0342, 0x0},
+ {0x1FD7, 0x03B9, 0x0308, 0x0342},
+ {0x1FE2, 0x03C5, 0x0308, 0x0300},
+ {0x1FE3, 0x03C5, 0x0308, 0x0301},
+ {0x1FE4, 0x03C1, 0x0313, 0x0},
+ {0x1FE6, 0x03C5, 0x0342, 0x0},
+ {0x1FE7, 0x03C5, 0x0308, 0x0342},
+ {0x1FF2, 0x1F7C, 0x03B9, 0x0},
+ {0x1FF3, 0x03C9, 0x03B9, 0x0},
+ {0x1FF4, 0x03CE, 0x03B9, 0x0},
+ {0x1FF6, 0x03C9, 0x0342, 0x0},
+ {0x1FF7, 0x03C9, 0x0342, 0x03B9},
+ {0x1FFC, 0x03C9, 0x03B9, 0x0},
+ {0xFB00, 0x0066, 0x0066, 0x0},
+ {0xFB01, 0x0066, 0x0069, 0x0},
+ {0xFB02, 0x0066, 0x006C, 0x0},
+ {0xFB03, 0x0066, 0x0066, 0x0069},
+ {0xFB04, 0x0066, 0x0066, 0x006C},
+ {0xFB05, 0x0073, 0x0074, 0x0},
+ {0xFB06, 0x0073, 0x0074, 0x0},
+ {0xFB13, 0x0574, 0x0576, 0x0},
+ {0xFB14, 0x0574, 0x0565, 0x0},
+ {0xFB15, 0x0574, 0x056B, 0x0},
+ {0xFB16, 0x057E, 0x0576, 0x0},
+ {0xFB17, 0x0574, 0x056D, 0x0},
+};
+
+
+/* Branchless UTF-8 decoder
+ * https://raw.githubusercontent.com/skeeto/branchless-utf8/
+ * This is free and unencumbered software released into the public domain.
+ */
+
+/* Decode the next character, C, from BUF, reporting errors in E.
+ *
+ * Since this is a branchless decoder, four bytes will be read from the
+ * buffer regardless of the actual length of the next character. This
+ * means the buffer _must_ have at least three bytes of zero padding
+ * following the end of the data stream.
+ *
+ * Errors are reported in E, which will be non-zero if the parsed
+ * character was somehow invalid: invalid byte sequence, non-canonical
+ * encoding, or a surrogate half.
+ *
+ * The function returns a pointer to the next character. When an error
+ * occurs, this pointer will be a guess that depends on the particular
+ * error, but it will always advance at least one byte.
+ */
+static const char lengths[] = {
+ 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1,
+ 0, 0, 0, 0, 0, 0, 0, 0, 2, 2, 2, 2, 3, 3, 4, 0
+};
+
+static C_char *utf8_decode(C_char *buf, C_u32 *c, int *e)
+{
+ static const int masks[] = {0x00, 0x7f, 0x1f, 0x0f, 0x07};
+ static const uint32_t mins[] = {4194304, 0, 128, 2048, 65536};
+ static const int shiftc[] = {0, 18, 12, 6, 0};
+ static const int shifte[] = {0, 6, 4, 2, 0};
+
+#ifdef DEBUGBUILD
+ if(buf == NULL)
+ C_panic_hook(C_text("possibly invalid string index"));
+#endif
+
+ unsigned char *s = (unsigned char *)buf;
+ int len = lengths[s[0] >> 3];
+
+ /* Compute the pointer to the next character early so that the next
+ * iteration can start working on the next character. Neither Clang
+ * nor GCC figure out this reordering on their own.
+ */
+ unsigned char *next = s + len + !len;
+
+ /* Assume a four-byte character and load four bytes. Unused bits are
+ * shifted out.
+ */
+ *c = (C_u32)(s[0] & masks[len]) << 18;
+ *c |= (C_u32)(s[1] & 0x3f) << 12;
+ *c |= (C_u32)(s[2] & 0x3f) << 6;
+ *c |= (C_u32)(s[3] & 0x3f) << 0;
+ *c >>= shiftc[len];
+
+ /* Accumulate the various error conditions. */
+ *e = (*c < mins[len]) << 6; // non-canonical encoding
+ *e |= ((*c >> 11) == 0x1b) << 7; // surrogate half?
+ *e |= (*c > 0x10FFFF) << 8; // out of range?
+ *e |= (s[1] & 0xc0) >> 2;
+ *e |= (s[2] & 0xc0) >> 4;
+ *e |= (s[3] ) >> 6;
+ *e ^= 0x2a; // top two bits of each tail byte correct?
+ *e >>= shifte[len];
+
+ /* now make all that optimization pointless... */
+ if(*e) {
+ *c = 0xdc00 | *s;
+ return (C_char *)s + 1;
+ }
+
+ return (C_char *)next;
+}
+/* */
+
+static C_char *utf8_encode(C_u32 u, C_char *p1)
+{
+ unsigned char *p = (unsigned char *)p1;
+ if(u < 0x80) *(p++) = u;
+ else if((u & 0xff00) == 0xdc00) {
+ *(p++) = u & 0xff;
+ } else if(u < 0x800) {
+ *(p++) = (u >> 6) | 0xC0;
+ *(p++) = (u & 0x3F) | 0x80;
+ } else if(u < 0x10000) {
+ *(p++) = (u >> 12) | 0xE0;
+ *(p++) = ((u >> 6) & 0x3F) | 0x80;
+ *(p++) = (u & 0x3F) | 0x80;
+ } else if(u < 0x110000) {
+ *(p++) = (u >> 18) | 0xF0;
+ *(p++) = ((u >> 12) & 0x3F) | 0x80;
+ *(p++) = ((u >> 6) & 0x3F) | 0x80;
+ *(p++) = (u & 0x3F) | 0x80;
+ }
+ return (C_char *)p;
+}
+
+static C_char *utf_index1(C_word s, C_word i)
+{
+ C_word i0 = C_unfix(C_block_item(s, 2));
+ C_word count = C_unfix(C_block_item(s, 1));
+ C_word off = 0, index = 0;
+ C_char *p1, *p = C_c_string(C_block_item(s, 0));
+ int e;
+ C_u32 c;
+ if(i >= i0) {
+ p += off = C_unfix(C_block_item(s, 3));
+ index = i0;
+ }
+ while(index <= count) {
+ if(index == i) {
+ C_set_block_item(s, 2, C_fix(index));
+ C_set_block_item(s, 3, C_fix(off));
+ return p;
+ }
+ p1 = p;
+ p = utf8_decode(p, &c, &e);
+ ++index;
+ off += p - p1;
+ }
+ return NULL;
+}
+
+static C_char *utf_index(C_word s, C_word i)
+{
+ C_word bv = C_block_item(s, 0);
+ if(i == 0) {
+ C_set_block_item(s, 2, C_fix(0));
+ C_set_block_item(s, 3, C_fix(0));
+ return C_c_string(bv);
+ } else if(C_header_size(bv) - 1 == C_unfix(C_block_item(s, 1))) {
+ /* len == codepoints */
+ C_set_block_item(s, 2, C_fix(i));
+ C_set_block_item(s, 3, C_fix(i));
+ return C_c_string(bv) + i;
+ }
+ return utf_index1(s, i);
+}
+
+C_regparm C_word C_utf_subchar(C_word s, C_word i)
+{
+ C_char *p = utf_index(s, C_unfix(i));
+ int e;
+ C_u32 c;
+ utf8_decode(p, &c, &e);
+ return C_make_character(c);
+}
+
+C_regparm C_word C_utf_setsubchar(C_word s, C_word i, C_word c)
+{
+ C_char buf[ 4 ];
+ C_char *p = utf8_encode(C_character_code(c), buf);
+ int e;
+ C_u32 old;
+ C_char *p1 = utf_index(s, C_unfix(i));
+ C_char *p2 = utf8_decode(p1, &old, &e);
+ int nl = p - buf, ol = p2 - p1;
+ C_word bv = C_block_item(s, 0);
+ C_word bvlen = C_header_size(bv) - 1;
+ int prefix = C_unfix(C_block_item(s, 3)); /* offset */
+ int suffix = bvlen - prefix - ol;
+
+ if(nl > ol) {
+ int tl = bvlen + nl - ol;
+ if(C_in_scratchspacep(bv)) C_mutate_scratch_slot(NULL, bv);
+ C_word bvn = C_scratch_alloc(C_SIZEOF_BYTEVECTOR(tl + 1));
+ C_block_header_init(bvn, C_make_header(C_BYTEVECTOR_TYPE, tl + 1));
+ if(prefix) C_memcpy(C_c_string(bvn), C_c_string(bv), prefix);
+ C_memcpy((C_char *)C_data_pointer(bvn) + prefix, buf, nl);
+ C_memcpy((C_char *)C_data_pointer(bvn) + prefix + nl,
+ (C_char *)C_data_pointer(bv) + prefix + ol, suffix + 1); /* include 0 byte */
+ C_mutate_slot(&C_block_item(s, 0), bvn);
+ C_mutate_scratch_slot(&C_block_item(s, 0), bvn);
+ } else if(nl < ol) {
+ C_memcpy(p1, buf, nl);
+ C_memmove(p1 + nl, p1 + ol, suffix + 1); /* include 0 byte */
+ C_block_header_init(bv, C_make_header(C_BYTEVECTOR_TYPE, bvlen - (ol - nl) + 1));
+ } else C_memcpy(p1, buf, nl);
+
+ return C_SCHEME_UNDEFINED;
+}
+
+/* copy c bytes of bv into s at position i, occupying len characters */
+C_regparm C_word C_utf_overwrite(C_word s, C_word i, C_word len, C_word bv,
+ C_word c)
+{
+ C_word bvs = C_block_item(s, 0);
+ C_word bvlen = C_header_size(bvs) - 1;
+ C_char *p1 = utf_index(s, C_unfix(i));
+ C_char *p2 = utf_index(s, C_unfix(i) + C_unfix(len));
+ int count = C_unfix(c);
+ int d = p2 - p1;
+ int prefix = p1 - (C_char *)C_data_pointer(bvs);
+ int suffix = bvlen - prefix - d;
+
+ if(count > d) {
+ int tl = bvlen + count - d;
+ C_word bvn = C_scratch_alloc(C_SIZEOF_BYTEVECTOR(tl + 1));
+ if(C_in_scratchspacep(bvs)) C_mutate_scratch_slot(NULL, bvs);
+ C_block_header_init(bvn, C_make_header(C_BYTEVECTOR_TYPE, tl + 1));
+ if(prefix) C_memcpy(C_c_string(bvn), C_data_pointer(bvs), prefix);
+ C_memcpy((C_char *)C_data_pointer(bvn) + prefix, (C_char *)C_data_pointer(bv),
+ count);
+ C_memcpy((C_char *)C_data_pointer(bvn) + prefix + count,
+ p2, suffix + 1); /* include 0 byte */
+ C_mutate_slot(&C_block_item(s, 0), bvn);
+ C_mutate_scratch_slot(&C_block_item(s, 0), bvn);
+ } else if(count < d && count) {
+ C_memcpy(p1, C_data_pointer(bv), count);
+ C_memmove(p1 + count, p2, suffix + 1); /* include 0 byte */
+ C_block_header_init(bvs, C_make_header(C_BYTEVECTOR_TYPE,
+ bvlen - (d - count) + 1));
+ } else if(count) C_memcpy(p1, C_data_pointer(bv), count);
+
+ return C_SCHEME_UNDEFINED;
+}
+
+C_regparm C_word C_utf_compare(C_word s1, C_word s2, C_word start1, C_word start2,
+ C_word len)
+{
+ C_char *p1 = utf_index(s1, C_unfix(start1));
+ C_char *p2 = utf_index(s2, C_unfix(start2));
+ int e, n = C_unfix(len);
+ while(n--) {
+ C_u32 c1, c2;
+ p1 = utf8_decode(p1, &c1, &e);
+ p2 = utf8_decode(p2, &c2, &e);
+ if(c1 != c2) return C_fix((C_word)c1 - (C_word)c2);
+ }
+ return C_fix(0);
+}
+
+C_regparm C_word C_utf_compare_ci(C_word s1, C_word s2, C_word start1, C_word start2, C_word len)
+{
+ C_char *p1 = utf_index(s1, C_unfix(start1));
+ C_char *p2 = utf_index(s2, C_unfix(start2));
+ int e, n = C_unfix(len);
+ while(n--) {
+ C_u32 c1, c2;
+ int *m, r1, r2, i;
+ p1 = utf8_decode(p1, &c1, &e);
+ p2 = utf8_decode(p2, &c2, &e);
+ if(c1 >= 'A' && c1 <= 'Z') r1 = c1 + 32;
+ else r1 = c1;
+ if(c2 >= 'A' && c2 <= 'Z') r2 = c2 + 32;
+ else r2 = c2;
+ if(r1 == r2) continue;
+ if(r1 < 128 || r2 < 128) goto fail;
+ m = bsearch(&r1, fold2, nelem(fold2), sizeof(*fold2), &runemapcmp);
+ if(m) {
+ for(i = 1; i < 3; ++i) {
+ if(m[ i ] == 0) break;
+ if(m[ i ] != c2) return C_fix(m[ i ] - c2);
+ if(i != 2 && m[ i + 1 ] != 0) p2 = utf8_decode(p2, &c2, &e);
+ }
+ } else {
+ m = bsearch(&r1, fold1, nelem(fold1), sizeof(*fold1), &runemapcmp);
+ if(m) {
+ if(m[ 1 ] != c2) return C_fix(m[ 1 ] - c2);
+ }
+ }
+ m = bsearch(&r2, fold2, nelem(fold2), sizeof(*fold2), &runemapcmp);
+ if(m) {
+ for(i = 1; i < 3; ++i) {
+ if(m[ i ] == 0) break;
+ if(c1 != m[ i ]) return C_fix(c1 - m[ i ]);
+ if(i != 2 && m[ i + 1 ]) p1 = utf8_decode(p1, &c1, &e);
+ }
+ } else {
+ m = bsearch(&r2, fold1, nelem(fold1), sizeof(*fold1), &runemapcmp);
+ if(m) {
+ if(c1 != m[ 1 ]) return C_fix(c1 - m[ 1 ]);
+ }
+ }
+ continue;
+fail:
+ return C_fix(r1 - r2);
+ }
+ return C_fix(0);
+}
+
+/* XXX inline this? */
+C_regparm C_word C_utf_equal(C_word s1, C_word s2)
+{
+ C_word b1 = C_block_item(s1, 0);
+ C_word b2 = C_block_item(s2, 0);
+ int n1 = C_header_size(b1);
+ int n2 = C_header_size(b2);
+ if(n1 != n2) return C_SCHEME_FALSE;
+ return C_mk_bool(C_memcmp(C_c_string(b1), C_c_string(b2), n1) == 0);
+}
+
+/* XXX inline this? */
+C_regparm C_word C_utf_equal_ci(C_word s1, C_word s2)
+{
+ C_word n1 = C_block_item(s1, 1);
+ if(n1 != C_block_item(s2, 1)) return C_SCHEME_FALSE;
+ return C_mk_bool(C_utf_compare_ci(s1, s2, C_fix(0), C_fix(0), n1) == C_fix(0));
+}
+
+C_regparm C_word C_utf_copy(C_word from, C_word to, C_word start1, C_word end1, C_word start2)
+{
+ C_char *p1 = utf_index(from, C_unfix(start1));
+ C_char *p2 = utf_index(to, C_unfix(start2));
+ C_char *p3 = utf_index(from, C_unfix(end1));
+ C_memcpy(p2, p1, p3 - p1);
+ return C_SCHEME_UNDEFINED;
+}
+
+/* compute byte-index from char-index */
+C_regparm C_word C_utf_position(C_word str, C_word index)
+{
+ C_char *p1 = utf_index(str, C_unfix(index));
+ return C_fix(p1 - C_c_string(C_block_item(str, 0)));
+}
+
+/* compute char-index from byte-index (slow, uncached) */
+C_regparm int C_utf_char_position(C_word bv, int pos)
+{
+ int p = 0;
+ C_u32 c;
+ int e;
+ C_char *ptr = C_c_string(bv), *ptr2;
+ while(pos > 0) {
+ ptr2 = utf8_decode(ptr, &c, &e);
+ pos -= ptr2 - ptr;
+ ptr = ptr2;
+ ++p;
+ }
+ return p;
+}
+
+/* compute byte-offset between two char-indices */
+C_regparm C_word C_utf_range(C_word str, C_word start, C_word end)
+{
+ C_char *p1 = utf_index(str, C_unfix(start));
+ C_char *p2 = utf_index(str, C_unfix(end));
+ return C_fix(p2 - p1);
+}
+
+/* Count characters - slow variant, handles invalid sequences */
+C_regparm int C_utf_count(C_char *s, int len)
+{
+ int i = 0;
+ C_u32 c;
+ int e;
+ C_char *s2;
+ while (len > 0) {
+ s2 = utf8_decode(s, &c, &e);
+ len -= (s2 - s);
+ s = s2;
+ i++;
+ }
+ return i;
+}
+
+/* Count characters - slow variant, detects invalid sequences */
+C_regparm C_word C_utf_validate(C_word bv, C_word blen)
+{
+ int i = 0;
+ C_u32 c;
+ int e;
+ C_char *s = C_c_string(bv), *s2;
+ int len = C_unfix(blen);
+ while (len > 0) {
+ s2 = utf8_decode(s, &c, &e);
+ if(e) return C_SCHEME_FALSE;
+ len -= (s2 - s);
+ s = s2;
+ i++;
+ }
+ return C_fix(i);
+}
+
+/* count characters, fast, unsafe variant
+ http://canonical.org/~kragen/strlen-utf8.html */
+C_regparm int C_utf_fast_count(C_char *s, int len)
+{
+ int i = 0, j = 0;
+ while (len--) {
+ if ((s[i] & 0xc0) != 0x80) j++;
+ i++;
+ }
+ return j;
+}
+
+C_regparm C_word C_utf_bytes(C_word chr)
+{
+ int e;
+ char buf[ 5 ];
+ C_char *p1 = utf8_encode(C_character_code(chr), buf);
+ return C_fix(p1 - buf);
+}
+
+C_regparm C_char * C_utf_encode(C_char *str, int chr)
+{
+ return utf8_encode(chr, str);
+}
+
+C_regparm C_word C_utf_decode(C_word bv, C_word pos)
+{
+ C_u32 c;
+ int e;
+ utf8_decode(C_c_string(bv) + C_unfix(pos), &c, &e);
+ return C_make_character(c);
+}
+
+C_regparm C_word C_utf_decode_ptr(C_char *bv)
+{
+ C_u32 c;
+ int e;
+ utf8_decode(bv, &c, &e);
+ return C_make_character(c);
+}
+
+C_regparm C_word C_utf_advance(C_word bv, C_word pos)
+{
+ C_char *p1 = (C_char *)C_data_pointer(bv) + C_unfix(pos);
+ C_u32 c;
+ int e;
+ C_char *p2 = utf8_decode(p1, &c, &e);
+ return C_fix(C_unfix(pos) + p2 - p1);
+}
+
+C_regparm C_word C_utf_insert(C_word bv, C_word pos, C_word c)
+{
+ C_char *p1 = C_c_string(bv) + C_unfix(pos);
+ C_char *p2 = utf8_encode(C_character_code(c), p1);
+ return C_fix(C_unfix(pos) + p2 - p1);
+}
+
+C_regparm C_word C_utf_fill(C_word bv, C_word chr)
+{
+ char buf[ 5 ];
+ int size = C_header_size(bv) - 1;
+ int len = C_utf_encode(buf, C_character_code(chr)) - buf;
+ C_char *p;
+ int n;
+
+ if(len == 1) {
+ C_memset(C_data_pointer(bv), *buf, size);
+ return bv;
+ }
+
+ p = C_data_pointer(bv);
+ n = size / len;
+
+ while(n--) {
+ C_memcpy(p, buf, len);
+ p += len;
+ }
+ ((C_char *)C_data_pointer(bv))[ size ] = 0; /* terminating zero */
+ return bv;
+}
+
+C_regparm int C_utf_expect(int byte)
+{
+ int len = lengths[ byte >> 3 ];
+ return len + !len;
+}
+
+/* take bytevector section and compute full + incomplete codepoints */
+C_regparm C_word C_utf_fragment_counts(C_word bv, C_word pos, C_word len)
+{
+ int full = 0;
+ C_uchar *ptr = C_data_pointer(bv) + C_unfix(pos);
+ int count = C_unfix(len);
+
+ while(count) {
+ unsigned int byte = *(ptr++);
+ int n = lengths[ byte >> 3 ];
+ int bn = n + !n;
+ if(count >= bn) {
+ ++full;
+ count -= bn;
+ ptr += bn - 1;
+ } else return C_fix((full << 4) | (bn - count));
+ }
+
+ return C_fix(full << 4);
+}
+
+C_regparm void C_utf_putc(int chr, C_FILEPTR fp)
+{
+ C_char buf[ 5 ];
+ C_char *p = utf8_encode(chr, buf);
+ *p = '\0';
+ C_fputs(buf, fp);
+}
+
+C_regparm C_word C_utf_list_size(C_word lst)
+{
+ int n = 0;
+ while(!C_immediatep(lst) && C_header_bits(lst) == C_PAIR_TYPE) {
+ C_word x = C_block_item(lst, 0);
+ if(((x) & C_IMMEDIATE_TYPE_BITS) == C_CHARACTER_BITS)
+ n += C_unfix(C_utf_bytes(x));
+ lst = C_block_item(lst, 1);
+ }
+ return C_fix(n);
+}
+
+C_regparm C_word C_latin_to_utf(C_word from, C_word to, C_word start, C_word len)
+{
+ int n = C_unfix(len);
+ C_uchar *pf = (C_uchar *)C_c_string(from) + C_unfix(start);
+ C_char *pt = C_c_string(to), *pt0 = pt;
+ while(n-- > 0) {
+ C_u32 c = *(pf++);
+ pt = utf8_encode(c, pt);
+ }
+ return C_fix(pt - pt0);
+}
+
+C_regparm C_word C_utf_to_latin(C_word from, C_word to, C_word start, C_word blen)
+{
+ int n = C_unfix(blen);
+ C_char *pf = C_c_string(from) + C_unfix(start), *pf2;
+ C_char *pt = C_c_string(to), *pt0 = pt;
+ C_u32 c;
+ int e;
+ while(n > 0) {
+ pf2 = utf8_decode(pf, &c, &e);
+ n -= pf2 - pf;
+ pf = pf2;
+ *(pt++) = c & 0xff;
+ }
+ *pt = '\0';
+ return C_fix(pt - pt0);
+}
+
+C_regparm C_word C_utf_char_foldcase(C_word c)
+{
+ int r = C_character_code(c);
+ int *m = bsearch(&r, fold1, nelem(fold1), sizeof(*fold1), &runemapcmp);
+ if(m) return C_make_character(m[ 1 ]);
+ return c;
+}
+
+C_regparm C_word C_utf_string_foldcase(C_word from, C_word to, C_word len)
+{
+ C_u32 c;
+ int e;
+ C_char *pf = C_c_string(from), *pf2;
+ C_char *pt = C_c_string(to), *pt0 = pt;
+ int count = C_unfix(len);
+ while(count > 0) {
+ pf2 = utf8_decode(pf, &c, &e);
+ if(!e) {
+ int r = c;
+ int *m = bsearch(&r, fold2, nelem(fold2), sizeof(*fold2), &runemapcmp);
+ if(m) {
+ pt = utf8_encode(m[ 1 ], pt);
+ if(m[ 3 ] != 0) {
+ pt = utf8_encode(m[ 2 ], pt);
+ c = m[ 3 ];
+ } else c = m[ 2 ];
+ } else {
+ m = bsearch(&r, fold1, nelem(fold1), sizeof(*fold1), &runemapcmp);
+ if(m) c = m[ 1 ];
+ }
+ }
+ pt = utf8_encode(c, pt);
+ count -= pf2 - pf;
+ pf = pf2;
+ }
+ return C_fix(pt - pt0);
+}
+
+#if defined(_WIN32) && !defined(__CYGWIN__)
+#define C_WCHAR_FNBUF_SIZE 2048
+static C_WCHAR fnbuf[ C_WCHAR_FNBUF_SIZE ], *pfnbuf;
+C_regparm C_WCHAR *C_utf16(C_word bv, int cont)
+{
+ int len = C_header_size(bv) - 1;
+ C_WCHAR *p;
+ if(!cont) pfnbuf = fnbuf;
+ p = pfnbuf;
+ int n = MultiByteToWideChar(CP_UTF8,
+ 0,
+ C_c_string(bv),
+ -1,
+ pfnbuf,
+ C_WCHAR_FNBUF_SIZE - (pfnbuf - fnbuf));
+ if(n == 0) C_decoding_error(bv, C_fix(0));
+ pfnbuf += n;
+ return p;
+}
+
+C_regparm C_char *C_utf8(C_WCHAR *str)
+{
+ int n = WideCharToMultiByte(CP_UTF8,
+ 0,
+ str,
+ -1,
+ (C_char *)fnbuf,
+ C_WCHAR_FNBUF_SIZE,
+ NULL, NULL);
+ if(n == 0) C_decoding_error(C_SCHEME_UNDEFINED, C_fix(0));
+ ((C_char *)fnbuf)[ n ] = '\0';
+ return (C_char *)fnbuf;
+}
+#endif
Trap