summaryrefslogtreecommitdiff
path: root/libguile
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2009-08-17 23:39:56 +0200
committerLudovic Courtès <ludo@gnu.org>2009-08-18 00:06:45 +0200
commitfbb857a472eb4e69c1cba05e86646b7004f32df6 (patch)
treeff23e64de5a558b575ed812349d8af6e64d8ceb4 /libguile
parent49c9839eae84f7f3cd10db45f389fa1ea1050659 (diff)
parente33a910dd0f430f34c32fe6846899aee33fc2cf6 (diff)
downloadguile-fbb857a472eb4e69c1cba05e86646b7004f32df6.tar.gz
Merge branch 'master' into boehm-demers-weiser-gc
Conflicts: lib/Makefile.am libguile/Makefile.am libguile/frames.c libguile/gc-card.c libguile/gc-freelist.c libguile/gc-mark.c libguile/gc-segment.c libguile/gc_os_dep.c libguile/load.c libguile/macros.c libguile/objcodes.c libguile/programs.c libguile/strings.c libguile/vm.c m4/gnulib-cache.m4 m4/gnulib-comp.m4 m4/inline.m4
Diffstat (limited to 'libguile')
-rw-r--r--libguile/Makefile.am99
-rw-r--r--libguile/__scm.h39
-rw-r--r--libguile/_scm.h60
-rw-r--r--libguile/alist.c13
-rw-r--r--libguile/alist.h13
-rw-r--r--libguile/arbiters.c13
-rw-r--r--libguile/arbiters.h13
-rw-r--r--libguile/async.c15
-rw-r--r--libguile/async.h13
-rw-r--r--libguile/backtrace.c13
-rw-r--r--libguile/backtrace.h13
-rw-r--r--libguile/boolean.c13
-rw-r--r--libguile/boolean.h13
-rw-r--r--libguile/bytevectors.c2096
-rw-r--r--libguile/bytevectors.h146
-rw-r--r--libguile/chars.c226
-rw-r--r--libguile/chars.h38
-rw-r--r--libguile/continuations.c17
-rw-r--r--libguile/continuations.h13
-rw-r--r--libguile/convert.c13
-rw-r--r--libguile/convert.h13
-rw-r--r--libguile/debug-malloc.c13
-rw-r--r--libguile/debug-malloc.h13
-rw-r--r--libguile/debug.c56
-rw-r--r--libguile/debug.h14
-rw-r--r--libguile/deprecated.c13
-rw-r--r--libguile/deprecated.h13
-rw-r--r--libguile/deprecation.c22
-rw-r--r--libguile/deprecation.h27
-rw-r--r--libguile/discouraged.c13
-rw-r--r--libguile/discouraged.h13
-rw-r--r--libguile/dynl.c13
-rw-r--r--libguile/dynl.h13
-rw-r--r--libguile/dynwind.c13
-rw-r--r--libguile/dynwind.h13
-rw-r--r--libguile/environments.c13
-rw-r--r--libguile/environments.h13
-rw-r--r--libguile/eq.c13
-rw-r--r--libguile/eq.h13
-rw-r--r--libguile/error.c13
-rw-r--r--libguile/error.h13
-rw-r--r--libguile/eval.c370
-rw-r--r--libguile/eval.h58
-rw-r--r--libguile/eval.i.c17
-rw-r--r--libguile/evalext.c59
-rw-r--r--libguile/evalext.h13
-rw-r--r--libguile/extensions.c18
-rw-r--r--libguile/extensions.h15
-rw-r--r--libguile/feature.c13
-rw-r--r--libguile/feature.h13
-rw-r--r--libguile/filesys.c67
-rw-r--r--libguile/filesys.h16
-rw-r--r--libguile/fluids.c13
-rw-r--r--libguile/fluids.h13
-rw-r--r--libguile/fports.c63
-rw-r--r--libguile/fports.h17
-rw-r--r--libguile/frames.c65
-rw-r--r--libguile/frames.h104
-rw-r--r--libguile/futures.c13
-rw-r--r--libguile/futures.h13
-rw-r--r--libguile/gc-malloc.c13
-rw-r--r--libguile/gc-segment-table.c13
-rw-r--r--libguile/gc.c13
-rw-r--r--libguile/gc.h13
-rw-r--r--libguile/gdb_interface.h27
-rw-r--r--libguile/gdbint.c13
-rw-r--r--libguile/gdbint.h13
-rw-r--r--libguile/gen-scmconfig.c42
-rw-r--r--libguile/gettext.c13
-rw-r--r--libguile/gettext.h13
-rw-r--r--libguile/goops.c22
-rw-r--r--libguile/goops.h13
-rw-r--r--libguile/gsubr.c29
-rw-r--r--libguile/gsubr.h13
-rw-r--r--libguile/guardians.c13
-rw-r--r--libguile/guardians.h13
-rwxr-xr-xlibguile/guile-doc-snarf.in26
-rw-r--r--libguile/guile-func-name-check.in22
-rwxr-xr-xlibguile/guile-snarf-docs.in22
-rw-r--r--libguile/guile-snarf.awk.in22
-rw-r--r--libguile/guile-snarf.in26
-rw-r--r--libguile/guile.c13
-rw-r--r--libguile/hash.c13
-rw-r--r--libguile/hash.h13
-rw-r--r--libguile/hashtab.c13
-rw-r--r--libguile/hashtab.h13
-rw-r--r--libguile/hooks.c13
-rw-r--r--libguile/hooks.h13
-rw-r--r--libguile/i18n.c13
-rw-r--r--libguile/i18n.h13
-rw-r--r--libguile/ieee-754.h90
-rw-r--r--libguile/init.c17
-rw-r--r--libguile/init.h13
-rw-r--r--libguile/inline.c13
-rw-r--r--libguile/inline.h13
-rw-r--r--libguile/instructions.c80
-rw-r--r--libguile/instructions.h72
-rw-r--r--libguile/ioext.c13
-rw-r--r--libguile/ioext.h13
-rw-r--r--libguile/iselect.h13
-rw-r--r--libguile/keywords.c13
-rw-r--r--libguile/keywords.h13
-rw-r--r--libguile/lang.c13
-rw-r--r--libguile/lang.h13
-rw-r--r--libguile/libguile.map44
-rw-r--r--libguile/list.c13
-rw-r--r--libguile/list.h13
-rw-r--r--libguile/load.c281
-rw-r--r--libguile/load.h15
-rw-r--r--libguile/locale-categories.h13
-rw-r--r--libguile/macros.c116
-rw-r--r--libguile/macros.h26
-rw-r--r--libguile/mallocs.c13
-rw-r--r--libguile/mallocs.h13
-rw-r--r--libguile/measure-hwm.scm136
-rw-r--r--libguile/modules.c50
-rw-r--r--libguile/modules.h14
-rw-r--r--libguile/net_db.c21
-rw-r--r--libguile/net_db.h13
-rw-r--r--libguile/null-threads.c13
-rw-r--r--libguile/null-threads.h13
-rw-r--r--libguile/numbers.c66
-rw-r--r--libguile/numbers.h20
-rw-r--r--libguile/objcodes.c127
-rw-r--r--libguile/objcodes.h76
-rw-r--r--libguile/objects.c13
-rw-r--r--libguile/objects.h13
-rw-r--r--libguile/objprop.c13
-rw-r--r--libguile/objprop.h13
-rw-r--r--libguile/options.c13
-rw-r--r--libguile/options.h13
-rw-r--r--libguile/pairs.c13
-rw-r--r--libguile/pairs.h13
-rw-r--r--libguile/ports.c119
-rw-r--r--libguile/ports.h46
-rw-r--r--libguile/posix.c373
-rw-r--r--libguile/posix.h15
-rw-r--r--libguile/print.c210
-rw-r--r--libguile/print.h14
-rw-r--r--libguile/private-gc.h22
-rw-r--r--libguile/private-options.h13
-rw-r--r--libguile/procprop.c13
-rw-r--r--libguile/procprop.h13
-rw-r--r--libguile/procs.c25
-rw-r--r--libguile/procs.h15
-rw-r--r--libguile/programs.c102
-rw-r--r--libguile/programs.h90
-rw-r--r--libguile/properties.c13
-rw-r--r--libguile/properties.h13
-rw-r--r--libguile/pthread-threads.h13
-rw-r--r--libguile/putenv.c13
-rw-r--r--libguile/r6rs-ports.c1122
-rw-r--r--libguile/r6rs-ports.h44
-rw-r--r--libguile/ramap.c13
-rw-r--r--libguile/ramap.h13
-rw-r--r--libguile/random.c13
-rw-r--r--libguile/random.h13
-rw-r--r--libguile/rdelim.c13
-rw-r--r--libguile/rdelim.h13
-rw-r--r--libguile/read.c384
-rw-r--r--libguile/read.h13
-rw-r--r--libguile/regex-posix.c13
-rw-r--r--libguile/regex-posix.h13
-rw-r--r--libguile/root.c13
-rw-r--r--libguile/root.h13
-rw-r--r--libguile/rw.c21
-rw-r--r--libguile/rw.h13
-rw-r--r--libguile/scmconfig.h.top13
-rw-r--r--libguile/scmsigs.c49
-rw-r--r--libguile/scmsigs.h13
-rw-r--r--libguile/script.c43
-rw-r--r--libguile/script.h13
-rw-r--r--libguile/simpos.c13
-rw-r--r--libguile/simpos.h13
-rw-r--r--libguile/smob.c13
-rw-r--r--libguile/smob.h13
-rw-r--r--libguile/snarf.h13
-rw-r--r--libguile/socket.c16
-rw-r--r--libguile/socket.h13
-rw-r--r--libguile/sort.c13
-rw-r--r--libguile/sort.h13
-rw-r--r--libguile/srcprop.c13
-rw-r--r--libguile/srcprop.h13
-rw-r--r--libguile/srfi-13.c36
-rw-r--r--libguile/srfi-13.h13
-rw-r--r--libguile/srfi-14.c13
-rw-r--r--libguile/srfi-14.h13
-rw-r--r--libguile/srfi-4.c22
-rw-r--r--libguile/srfi-4.h13
-rw-r--r--libguile/stackchk.c13
-rw-r--r--libguile/stackchk.h13
-rw-r--r--libguile/stacks.c13
-rw-r--r--libguile/stacks.h13
-rw-r--r--libguile/stime.c26
-rw-r--r--libguile/stime.h13
-rw-r--r--libguile/strerror.c27
-rw-r--r--libguile/strings.c882
-rw-r--r--libguile/strings.h91
-rw-r--r--libguile/strorder.c13
-rw-r--r--libguile/strorder.h13
-rw-r--r--libguile/strports.c27
-rw-r--r--libguile/strports.h13
-rw-r--r--libguile/struct.c13
-rw-r--r--libguile/struct.h13
-rw-r--r--libguile/symbols.c13
-rw-r--r--libguile/symbols.h13
-rw-r--r--libguile/tags.h13
-rw-r--r--libguile/threads.c24
-rw-r--r--libguile/threads.h13
-rw-r--r--libguile/throw.c13
-rw-r--r--libguile/throw.h13
-rw-r--r--libguile/unif.c91
-rw-r--r--libguile/unif.h16
-rw-r--r--libguile/validate.h18
-rw-r--r--libguile/values.c13
-rw-r--r--libguile/values.h13
-rw-r--r--libguile/variable.c13
-rw-r--r--libguile/variable.h13
-rw-r--r--libguile/vectors.c27
-rw-r--r--libguile/vectors.h13
-rw-r--r--libguile/version.c13
-rw-r--r--libguile/version.h.in13
-rw-r--r--libguile/vm-bootstrap.h57
-rw-r--r--libguile/vm-engine.c93
-rw-r--r--libguile/vm-engine.h134
-rw-r--r--libguile/vm-expand.h49
-rw-r--r--libguile/vm-i-loader.c131
-rw-r--r--libguile/vm-i-scheme.c411
-rw-r--r--libguile/vm-i-system.c496
-rw-r--r--libguile/vm.c136
-rw-r--r--libguile/vm.h113
-rw-r--r--libguile/vports.c13
-rw-r--r--libguile/vports.h13
-rw-r--r--libguile/weaks.c13
-rw-r--r--libguile/weaks.h13
-rw-r--r--libguile/win32-dirent.c13
-rw-r--r--libguile/win32-dirent.h13
-rw-r--r--libguile/win32-socket.c13
-rw-r--r--libguile/win32-socket.h13
-rw-r--r--libguile/win32-uname.c13
-rw-r--r--libguile/win32-uname.h13
241 files changed, 9021 insertions, 3772 deletions
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index dda3994a3..f000f8332 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -1,23 +1,23 @@
## Process this file with Automake to create Makefile.in
##
-## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
+## Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
-## GUILE is free software; you can redistribute it and/or modify
-## it under the terms of the GNU General Public License as
-## published by the Free Software Foundation; either version 2, or
+## GUILE is free software; you can redistribute it and/or modify it
+## under the terms of the GNU Lesser General Public License as
+## published by the Free Software Foundation; either version 3, or
## (at your option) any later version.
##
## GUILE is distributed in the hope that it will be useful, but
## WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-## GNU General Public License for more details.
+## GNU Lesser General Public License for more details.
##
-## You should have received a copy of the GNU General Public
-## License along with GUILE; see the file COPYING. If not, write
-## to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
-## Floor, Boston, MA 02110-1301 USA
+## You should have received a copy of the GNU Lesser General Public
+## License along with GUILE; see the file COPYING.LESSER. If not,
+## write to the Free Software Foundation, Inc., 51 Franklin Street,
+## Fifth Floor, Boston, MA 02110-1301 USA
AUTOMAKE_OPTIONS = gnu
@@ -32,10 +32,10 @@ DEFAULT_INCLUDES =
## Check for headers in $(srcdir)/.., so that #include
## <libguile/MUMBLE.h> will find MUMBLE.h in this dir when we're
## building. Also look for Gnulib headers in `lib'.
-AM_CPPFLAGS = -I$(top_srcdir) -I$(top_builddir) \
+AM_CPPFLAGS = -DBUILDING_LIBGUILE=1 -I$(top_srcdir) -I$(top_builddir) \
-I$(top_srcdir)/lib -I$(top_builddir)/lib
-AM_CFLAGS = $(GCC_CFLAGS)
+AM_CFLAGS = $(GCC_CFLAGS) $(CFLAG_VISIBILITY)
## The Gnulib Libtool archive.
gnulib_library = $(top_builddir)/lib/libgnu.la
@@ -106,7 +106,8 @@ guile_LDFLAGS = $(GUILE_CFLAGS)
libguile_la_CFLAGS = $(GUILE_CFLAGS) $(AM_CFLAGS)
libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
- chars.c continuations.c convert.c debug.c deprecation.c \
+ bytevectors.c chars.c continuations.c \
+ convert.c debug.c deprecation.c \
deprecated.c discouraged.c dynwind.c eq.c error.c \
eval.c evalext.c extensions.c feature.c fluids.c fports.c \
futures.c gc.c gc-malloc.c \
@@ -114,7 +115,8 @@ libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
guardians.c hash.c hashtab.c hooks.c init.c inline.c \
ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \
modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \
- print.c procprop.c procs.c properties.c random.c rdelim.c read.c \
+ print.c procprop.c procs.c properties.c \
+ r6rs-ports.c random.c rdelim.c read.c \
root.c rw.c scmsigs.c script.c simpos.c smob.c sort.c srcprop.c \
stackchk.c stacks.c stime.c strings.c srfi-4.c srfi-13.c srfi-14.c \
strorder.c strports.c struct.c symbols.c threads.c null-threads.c \
@@ -133,7 +135,8 @@ libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_LDFLAGS = \
-module -L$(builddir) -lguile \
-version-info @LIBGUILE_I18N_INTERFACE@
-DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \
+DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x \
+ bytevectors.x chars.x \
continuations.x debug.x deprecation.x deprecated.x discouraged.x \
dynl.x dynwind.x environments.x eq.x error.x eval.x evalext.x \
extensions.x feature.x fluids.x fports.x futures.x gc.x \
@@ -141,7 +144,8 @@ DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \
hash.x hashtab.x hooks.x i18n.x init.x ioext.x keywords.x lang.x \
list.x load.x macros.x mallocs.x modules.x numbers.x objects.x \
objprop.x options.x pairs.x ports.x print.x procprop.x procs.x \
- properties.x random.x rdelim.x read.x root.x rw.x scmsigs.x \
+ properties.x r6rs-ports.x random.x rdelim.x \
+ read.x root.x rw.x scmsigs.x \
script.x simpos.x smob.x sort.x srcprop.x stackchk.x stacks.x \
stime.x strings.x srfi-4.x srfi-13.x srfi-14.x strorder.x \
strports.x struct.x symbols.x threads.x throw.x values.x \
@@ -153,7 +157,8 @@ DOT_X_FILES += frames.x instructions.x objcodes.x programs.x vm.x
EXTRA_DOT_X_FILES = @EXTRA_DOT_X_FILES@
DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
- boolean.doc chars.doc continuations.doc debug.doc deprecation.doc \
+ boolean.doc bytevectors.doc chars.doc \
+ continuations.doc debug.doc deprecation.doc \
deprecated.doc discouraged.doc dynl.doc dynwind.doc \
eq.doc error.doc eval.doc evalext.doc \
extensions.doc feature.doc fluids.doc fports.doc futures.doc \
@@ -162,7 +167,8 @@ DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
hooks.doc i18n.doc init.doc ioext.doc keywords.doc lang.doc \
list.doc load.doc macros.doc mallocs.doc modules.doc numbers.doc \
objects.doc objprop.doc options.doc pairs.doc ports.doc print.doc \
- procprop.doc procs.doc properties.doc random.doc rdelim.doc \
+ procprop.doc procs.doc properties.doc r6rs-ports.doc \
+ random.doc rdelim.doc \
read.doc root.doc rw.doc scmsigs.doc script.doc simpos.doc \
smob.doc sort.doc srcprop.doc stackchk.doc stacks.doc stime.doc \
strings.doc srfi-4.doc srfi-13.doc srfi-14.doc strorder.doc \
@@ -201,7 +207,7 @@ install-exec-hook:
## working.
noinst_HEADERS = convert.i.c \
conv-integer.i.c conv-uinteger.i.c \
- eval.i.c \
+ eval.i.c ieee-754.h \
srfi-4.i.c \
quicksort.i.c \
win32-uname.h win32-dirent.h win32-socket.h \
@@ -211,16 +217,23 @@ noinst_HEADERS = convert.i.c \
noinst_HEADERS += vm-engine.c vm-i-system.c vm-i-scheme.c vm-i-loader.c
libguile_la_DEPENDENCIES = @LIBLOBJS@
-libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library)
+libguile_la_LIBADD = @LIBLOBJS@ $(gnulib_library) $(LTLIBGMP) $(LTLIBUNISTRING)
libguile_la_LDFLAGS = @LTLIBINTL@ -version-info @LIBGUILE_INTERFACE_CURRENT@:@LIBGUILE_INTERFACE_REVISION@:@LIBGUILE_INTERFACE_AGE@ -export-dynamic -no-undefined
+if HAVE_LD_VERSION_SCRIPT
+
+libguile_la_LDFLAGS += -Wl,--version-script="$(srcdir)/libguile.map"
+
+endif HAVE_LD_VERSION_SCRIPT
+
+
# These are headers visible as <guile/mumble.h>
pkginclude_HEADERS =
# These are headers visible as <libguile/mumble.h>.
modincludedir = $(includedir)/libguile
modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \
- boehm-gc.h \
+ boehm-gc.h bytevectors.h \
boolean.h chars.h continuations.h convert.h debug.h debug-malloc.h \
deprecation.h deprecated.h discouraged.h dynl.h dynwind.h \
eq.h error.h eval.h evalext.h extensions.h \
@@ -230,7 +243,8 @@ modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h \
hashtab.h hooks.h i18n.h init.h inline.h ioext.h iselect.h \
keywords.h lang.h list.h load.h macros.h mallocs.h modules.h \
net_db.h numbers.h objects.h objprop.h options.h pairs.h ports.h \
- posix.h regex-posix.h print.h procprop.h procs.h properties.h \
+ posix.h r6rs-ports.h regex-posix.h print.h \
+ procprop.h procs.h properties.h \
random.h ramap.h rdelim.h read.h root.h rw.h scmsigs.h validate.h \
script.h simpos.h smob.h snarf.h socket.h sort.h srcprop.h \
stackchk.h stacks.h stime.h strings.h srfi-4.h srfi-13.h srfi-14.h \
@@ -254,7 +268,7 @@ EXTRA_DIST = ChangeLog-scm ChangeLog-threads \
cpp_errno.c cpp_err_symbols.in cpp_err_symbols.c \
cpp_sig_symbols.c cpp_sig_symbols.in cpp_cnvt.awk \
c-tokenize.lex version.h.in \
- scmconfig.h.top libgettext.h measure-hwm.scm
+ scmconfig.h.top libgettext.h libguile.map
# $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \
# guile-procedures.txt guile.texi
@@ -276,6 +290,8 @@ libpath.h: $(srcdir)/Makefile.in $(top_builddir)/config.status
@echo '#define SCM_PKGDATA_DIR "$(pkgdatadir)"' >> libpath.tmp
@echo '#define SCM_LIBRARY_DIR "$(pkgdatadir)/$(GUILE_EFFECTIVE_VERSION)"'>>libpath.tmp
@echo '#define SCM_SITE_DIR "$(pkgdatadir)/site"' >> libpath.tmp
+ @echo '#define SCM_CCACHE_DIR "$(pkglibdir)/$(GUILE_EFFECTIVE_VERSION)/ccache"' >> libpath.tmp
+ @echo '#define SCM_EFFECTIVE_VERSION "$(GUILE_EFFECTIVE_VERSION)"' >> libpath.tmp
@echo '#define SCM_BUILD_INFO { \' >> libpath.tmp
@echo ' { "srcdir", "'"`cd @srcdir@; pwd`"'" }, \' >> libpath.tmp
@echo ' { "top_srcdir", "@top_srcdir_absolute@" }, \' >> libpath.tmp
@@ -289,12 +305,13 @@ libpath.h: $(srcdir)/Makefile.in $(top_builddir)/config.status
@echo ' { "sharedstatedir", "@sharedstatedir@" }, \' >> libpath.tmp
@echo ' { "localstatedir", "@localstatedir@" }, \' >> libpath.tmp
@echo ' { "libdir", "@libdir@" }, \' >> libpath.tmp
+ @echo ' { "ccachedir", SCM_CCACHE_DIR }, \' >> libpath.tmp
@echo ' { "infodir", "@infodir@" }, \' >> libpath.tmp
@echo ' { "mandir", "@mandir@" }, \' >> libpath.tmp
@echo ' { "includedir", "@includedir@" }, \' >> libpath.tmp
- @echo ' { "pkgdatadir", "$(datadir)/@PACKAGE@" }, \' >> libpath.tmp
- @echo ' { "pkglibdir", "$(libdir)/@PACKAGE@" }, \' >> libpath.tmp
- @echo ' { "pkgincludedir", "$(includedir)/@PACKAGE@" }, \' \
+ @echo ' { "pkgdatadir", "@pkgdatadir@" }, \' >> libpath.tmp
+ @echo ' { "pkglibdir", "@pkglibdir@" }, \' >> libpath.tmp
+ @echo ' { "pkgincludedir", "@pkgincludedir@" }, \' \
>> libpath.tmp
@echo ' { "guileversion", "@GUILE_VERSION@" }, \' >> libpath.tmp
@echo ' { "libguileinterface", "@LIBGUILE_INTERFACE@" }, \' \
@@ -324,10 +341,8 @@ error.x: cpp_err_symbols.c
posix.x: cpp_sig_symbols.c
load.x: libpath.h
-include $(top_srcdir)/am/pre-inst-guile
-
alldotdocfiles = $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES)
-snarf2checkedtexi = GUILE="$(GUILE_FOR_BUILD)" $(top_srcdir)/scripts/snarf-check-and-output-texi
+snarf2checkedtexi = GUILE_AUTO_COMPILE=0 $(top_builddir)/meta/uninstalled-env guile-tools snarf-check-and-output-texi
dotdoc2texi = cat $(alldotdocfiles) | $(snarf2checkedtexi)
guile.texi: $(alldotdocfiles) guile$(EXEEXT)
@@ -349,29 +364,6 @@ guile-procedures.txt: guile-procedures.texi
endif
-# Stack limit calibration for `make check'. (For why we do this, see
-# the comments in measure-hwm.scm.) We're relying here on a couple of
-# bits of Automake magic.
-#
-# 1. The fact that "libguile" comes before "test-suite" in SUBDIRS in
-# our toplevel Makefile.am. This ensures that the
-# stack-limit-calibration.scm "test" will be run before any of the
-# tests under test-suite.
-#
-# 2. The fact that each test is invoked as $TESTS_ENVIRONMENT $test.
-# This allows us to ensure that the test will be considered to have
-# passed, by using `true' as TESTS_ENVIRONMENT.
-#
-# Why don't we care about the test "actually passing"? Because the
-# important thing about stack-limit-calibration.scm is just that it is
-# generated in the first place, so that other tests under test-suite
-# can use it.
-TESTS = stack-limit-calibration.scm
-TESTS_ENVIRONMENT = true
-
-stack-limit-calibration.scm: measure-hwm.scm guile$(EXEEXT)
- $(preinstguile) -s $(srcdir)/measure-hwm.scm > $@
-
c-tokenize.c: c-tokenize.lex
flex -t $(srcdir)/c-tokenize.lex > $@ || { rm $@; false; }
@@ -426,8 +418,9 @@ MOSTLYCLEANFILES = \
cpp_err_symbols_here cpp_err_symbols_diff cpp_err_symbols_new \
cpp_sig_symbols_here cpp_sig_symbols_diff cpp_sig_symbols_new \
version.h version.h.tmp \
- scmconfig.h scmconfig.h.tmp stack-limit-calibration.scm
+ scmconfig.h scmconfig.h.tmp
-CLEANFILES = libpath.h *.x *.doc guile-procedures.txt guile-procedures.texi guile.texi
+CLEANFILES = libpath.h *.x *.doc guile-procedures.txt guile-procedures.texi guile.texi \
+ vm-i-*.i
MAINTAINERCLEANFILES = c-tokenize.c
diff --git a/libguile/__scm.h b/libguile/__scm.h
index 3672b1c09..29b371d16 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -98,13 +99,10 @@
#define SCM_UNLIKELY(_expr) SCM_EXPECT ((_expr), 0)
/* The SCM_INTERNAL macro makes it possible to explicitly declare a function
- * as having "internal" linkage. */
-#if (defined __GNUC__) && \
- ((__GNUC__ >= 4) || (__GNUC__ == 3 && __GNUC_MINOR__ == 3))
-# define SCM_INTERNAL extern __attribute__ ((__visibility__ ("internal")))
-#else
-# define SCM_INTERNAL extern
-#endif
+ * as having "internal" linkage. However our current tack on this problem is
+ * to use GCC 4's -fvisibility=hidden, making functions internal by default,
+ * and then SCM_API marks them for export. */
+#define SCM_INTERNAL extern
@@ -154,13 +152,14 @@
/* SCM_API is a macro prepended to all function and data definitions
- which should be exported or imported in the resulting dynamic link
- library (DLL) in the Win32 port. */
-
-#if defined (SCM_IMPORT)
-# define SCM_API __declspec (dllimport) extern
-#elif defined (SCM_EXPORT) || defined (DLL_EXPORT)
-# define SCM_API __declspec (dllexport) extern
+ which should be exported from libguile. */
+
+#if BUILDING_LIBGUILE && HAVE_VISIBILITY
+# define SCM_API extern __attribute__((__visibility__("default")))
+#elif BUILDING_LIBGUILE && defined _MSC_VER
+# define SCM_API __declspec(dllexport) extern
+#elif defined _MSC_VER
+# define SCM_API __declspec(dllimport) extern
#else
# define SCM_API extern
#endif
diff --git a/libguile/_scm.h b/libguile/_scm.h
index e40f29bb0..627c51e03 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -3,21 +3,22 @@
#ifndef SCM__SCM_H
#define SCM__SCM_H
-/* Copyright (C) 1995,1996,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001, 2002, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -58,6 +59,7 @@
#endif
#include <errno.h>
+#include <verify.h>
#include "libguile/__scm.h"
/* Include headers for those files central to the implementation. The
@@ -78,20 +80,6 @@
#include "libguile/modules.h"
#include "libguile/inline.h"
-/* SCM_SYSCALL retries system calls that have been interrupted (EINTR).
- However this can be avoided if the operating system can restart
- system calls automatically. We assume this is the case if
- sigaction is available and SA_RESTART is defined; they will be used
- when installing signal handlers.
- */
-
-#ifdef HAVE_RESTARTABLE_SYSCALLS
-#if ! SCM_USE_PTHREAD_THREADS /* However, don't assume SA_RESTART
- works with pthreads... */
-#define SCM_SYSCALL(line) line
-#endif
-#endif
-
#ifndef SCM_SYSCALL
#ifdef vms
# ifndef __GNUC__
@@ -169,6 +157,36 @@
#define scm_from_off64_t scm_from_int64
+/* The endianness marker in objcode. */
+#ifdef WORDS_BIGENDIAN
+# define SCM_OBJCODE_ENDIANNESS "BE"
+#else
+# define SCM_OBJCODE_ENDIANNESS "LE"
+#endif
+
+#define _SCM_CPP_STRINGIFY(x) # x
+#define SCM_CPP_STRINGIFY(x) _SCM_CPP_STRINGIFY (x)
+
+/* The word size marker in objcode. */
+#define SCM_OBJCODE_WORD_SIZE SCM_CPP_STRINGIFY (SIZEOF_VOID_P)
+
+/* Major and minor versions must be single characters. */
+#define SCM_OBJCODE_MAJOR_VERSION 0
+#define SCM_OBJCODE_MINOR_VERSION B
+#define SCM_OBJCODE_MAJOR_VERSION_STRING \
+ SCM_CPP_STRINGIFY(SCM_OBJCODE_MAJOR_VERSION)
+#define SCM_OBJCODE_MINOR_VERSION_STRING \
+ SCM_CPP_STRINGIFY(SCM_OBJCODE_MINOR_VERSION)
+#define SCM_OBJCODE_VERSION_STRING \
+ SCM_OBJCODE_MAJOR_VERSION_STRING "." SCM_OBJCODE_MINOR_VERSION_STRING
+#define SCM_OBJCODE_MACHINE_VERSION_STRING \
+ SCM_OBJCODE_VERSION_STRING "-" SCM_OBJCODE_ENDIANNESS "-" SCM_OBJCODE_WORD_SIZE
+
+/* The objcode magic header. */
+#define SCM_OBJCODE_COOKIE \
+ "GOOF-" SCM_OBJCODE_MACHINE_VERSION_STRING "---"
+
+
#endif /* SCM__SCM_H */
/*
diff --git a/libguile/alist.c b/libguile/alist.c
index ca55b082c..919bd224e 100644
--- a/libguile/alist.c
+++ b/libguile/alist.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/alist.h b/libguile/alist.h
index 76cccba2b..77c565608 100644
--- a/libguile/alist.h
+++ b/libguile/alist.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/arbiters.c b/libguile/arbiters.c
index a3e4d81df..3567c909e 100644
--- a/libguile/arbiters.c
+++ b/libguile/arbiters.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996, 1997, 2000, 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/arbiters.h b/libguile/arbiters.h
index 7a7dfd3fa..214e92a34 100644
--- a/libguile/arbiters.h
+++ b/libguile/arbiters.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/async.c b/libguile/async.c
index 040082fb8..3e5a581c6 100644
--- a/libguile/async.c
+++ b/libguile/async.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -174,7 +175,7 @@ scm_async_click ()
SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0,
(SCM thunk),
"This function is deprecated. You can use @var{thunk} directly\n"
- "instead of explicitely creating an async object.\n")
+ "instead of explicitly creating an async object.\n")
#define FUNC_NAME s_scm_system_async
{
scm_c_issue_deprecation_warning
diff --git a/libguile/async.h b/libguile/async.h
index c01bde031..427d9b4c8 100644
--- a/libguile/async.h
+++ b/libguile/async.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/backtrace.c b/libguile/backtrace.c
index a8afcdf34..83579055f 100644
--- a/libguile/backtrace.c
+++ b/libguile/backtrace.c
@@ -2,18 +2,19 @@
* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
diff --git a/libguile/backtrace.h b/libguile/backtrace.h
index e11cb85de..c0651667c 100644
--- a/libguile/backtrace.h
+++ b/libguile/backtrace.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1996,1998,1999,2000,2001, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/boolean.c b/libguile/boolean.c
index 4b06e04e2..d79bf7979 100644
--- a/libguile/boolean.c
+++ b/libguile/boolean.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995, 1996, 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/boolean.h b/libguile/boolean.h
index 1388c2fdc..5a8379713 100644
--- a/libguile/boolean.h
+++ b/libguile/boolean.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
new file mode 100644
index 000000000..24afd2414
--- /dev/null
+++ b/libguile/bytevectors.c
@@ -0,0 +1,2096 @@
+/* Copyright (C) 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <alloca.h>
+
+#include <gmp.h>
+
+#include "libguile/_scm.h"
+#include "libguile/extensions.h"
+#include "libguile/bytevectors.h"
+#include "libguile/strings.h"
+#include "libguile/validate.h"
+#include "libguile/ieee-754.h"
+#include "libguile/unif.h"
+#include "libguile/srfi-4.h"
+
+#include <byteswap.h>
+#include <striconveh.h>
+#include <uniconv.h>
+
+#ifdef HAVE_LIMITS_H
+# include <limits.h>
+#else
+/* Assuming 32-bit longs. */
+# define ULONG_MAX 4294967295UL
+#endif
+
+#include <string.h>
+
+
+
+/* Utilities. */
+
+/* Convenience macros. These are used by the various templates (macros) that
+ are parameterized by integer signedness. */
+#define INT8_T_signed scm_t_int8
+#define INT8_T_unsigned scm_t_uint8
+#define INT16_T_signed scm_t_int16
+#define INT16_T_unsigned scm_t_uint16
+#define INT32_T_signed scm_t_int32
+#define INT32_T_unsigned scm_t_uint32
+#define is_signed_int8(_x) (((_x) >= -128L) && ((_x) <= 127L))
+#define is_unsigned_int8(_x) ((_x) <= 255UL)
+#define is_signed_int16(_x) (((_x) >= -32768L) && ((_x) <= 32767L))
+#define is_unsigned_int16(_x) ((_x) <= 65535UL)
+#define is_signed_int32(_x) (((_x) >= -2147483648L) && ((_x) <= 2147483647L))
+#define is_unsigned_int32(_x) ((_x) <= 4294967295UL)
+#define SIGNEDNESS_signed 1
+#define SIGNEDNESS_unsigned 0
+
+#define INT_TYPE(_size, _sign) INT ## _size ## _T_ ## _sign
+#define INT_SWAP(_size) bswap_ ## _size
+#define INT_VALID_P(_size, _sign) is_ ## _sign ## _int ## _size
+#define SIGNEDNESS(_sign) SIGNEDNESS_ ## _sign
+
+
+#define INTEGER_ACCESSOR_PROLOGUE(_len, _sign) \
+ size_t c_len, c_index; \
+ _sign char *c_bv; \
+ \
+ SCM_VALIDATE_BYTEVECTOR (1, bv); \
+ c_index = scm_to_uint (index); \
+ \
+ c_len = SCM_BYTEVECTOR_LENGTH (bv); \
+ c_bv = (_sign char *) SCM_BYTEVECTOR_CONTENTS (bv); \
+ \
+ if (SCM_UNLIKELY (c_index + ((_len) >> 3UL) - 1 >= c_len)) \
+ scm_out_of_range (FUNC_NAME, index);
+
+/* Template for fixed-size integer access (only 8, 16 or 32-bit). */
+#define INTEGER_REF(_len, _sign) \
+ SCM result; \
+ \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ SCM_VALIDATE_SYMBOL (3, endianness); \
+ \
+ { \
+ INT_TYPE (_len, _sign) c_result; \
+ \
+ memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
+ if (!scm_is_eq (endianness, scm_i_native_endianness)) \
+ c_result = INT_SWAP (_len) (c_result); \
+ \
+ result = SCM_I_MAKINUM (c_result); \
+ } \
+ \
+ return result;
+
+/* Template for fixed-size integer access using the native endianness. */
+#define INTEGER_NATIVE_REF(_len, _sign) \
+ SCM result; \
+ \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ \
+ { \
+ INT_TYPE (_len, _sign) c_result; \
+ \
+ memcpy (&c_result, &c_bv[c_index], (_len) / 8); \
+ result = SCM_I_MAKINUM (c_result); \
+ } \
+ \
+ return result;
+
+/* Template for fixed-size integer modification (only 8, 16 or 32-bit). */
+#define INTEGER_SET(_len, _sign) \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ SCM_VALIDATE_SYMBOL (3, endianness); \
+ \
+ { \
+ _sign long c_value; \
+ INT_TYPE (_len, _sign) c_value_short; \
+ \
+ if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
+ scm_wrong_type_arg (FUNC_NAME, 3, value); \
+ \
+ c_value = SCM_I_INUM (value); \
+ if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
+ scm_out_of_range (FUNC_NAME, value); \
+ \
+ c_value_short = (INT_TYPE (_len, _sign)) c_value; \
+ if (!scm_is_eq (endianness, scm_i_native_endianness)) \
+ c_value_short = INT_SWAP (_len) (c_value_short); \
+ \
+ memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
+ } \
+ \
+ return SCM_UNSPECIFIED;
+
+/* Template for fixed-size integer modification using the native
+ endianness. */
+#define INTEGER_NATIVE_SET(_len, _sign) \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ \
+ { \
+ _sign long c_value; \
+ INT_TYPE (_len, _sign) c_value_short; \
+ \
+ if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
+ scm_wrong_type_arg (FUNC_NAME, 3, value); \
+ \
+ c_value = SCM_I_INUM (value); \
+ if (SCM_UNLIKELY (!INT_VALID_P (_len, _sign) (c_value))) \
+ scm_out_of_range (FUNC_NAME, value); \
+ \
+ c_value_short = (INT_TYPE (_len, _sign)) c_value; \
+ \
+ memcpy (&c_bv[c_index], &c_value_short, (_len) / 8); \
+ } \
+ \
+ return SCM_UNSPECIFIED;
+
+
+
+/* Bytevector type. */
+
+scm_t_bits scm_tc16_bytevector;
+
+#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
+ SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len))
+#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
+ SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf))
+
+/* The empty bytevector. */
+SCM scm_null_bytevector = SCM_UNSPECIFIED;
+
+
+static inline SCM
+make_bytevector_from_buffer (size_t len, signed char *contents)
+{
+ /* Assuming LEN > SCM_BYTEVECTOR_INLINE_THRESHOLD. */
+ SCM_RETURN_NEWSMOB2 (scm_tc16_bytevector, len, contents);
+}
+
+static inline SCM
+make_bytevector (size_t len)
+{
+ SCM bv;
+
+ if (SCM_UNLIKELY (len == 0))
+ bv = scm_null_bytevector;
+ else
+ {
+ signed char *contents = NULL;
+
+ if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len))
+ contents = (signed char *) scm_gc_malloc (len, SCM_GC_BYTEVECTOR);
+
+ bv = make_bytevector_from_buffer (len, contents);
+ }
+
+ return bv;
+}
+
+/* Return a new bytevector of size LEN octets. */
+SCM
+scm_c_make_bytevector (size_t len)
+{
+ return (make_bytevector (len));
+}
+
+/* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
+ by CONTENTS must have been allocated using `scm_gc_malloc ()'. */
+SCM
+scm_c_take_bytevector (signed char *contents, size_t len)
+{
+ SCM bv;
+
+ if (SCM_UNLIKELY (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len)))
+ {
+ /* Copy CONTENTS into an "in-line" buffer, then free CONTENTS. */
+ signed char *c_bv;
+
+ bv = make_bytevector (len);
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+ memcpy (c_bv, contents, len);
+ scm_gc_free (contents, len, SCM_GC_BYTEVECTOR);
+ }
+ else
+ bv = make_bytevector_from_buffer (len, contents);
+
+ return bv;
+}
+
+/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
+ size) and return BV. */
+SCM
+scm_i_shrink_bytevector (SCM bv, size_t c_new_len)
+{
+ if (!SCM_BYTEVECTOR_INLINE_P (bv))
+ {
+ size_t c_len;
+ signed char *c_bv, *c_new_bv;
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+
+ SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
+
+ if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len))
+ {
+ /* Copy to the in-line buffer and free the current buffer. */
+ c_new_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+ memcpy (c_new_bv, c_bv, c_new_len);
+ scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ }
+ else
+ {
+ /* Resize the existing buffer. */
+ c_new_bv = scm_gc_realloc (c_bv, c_len, c_new_len,
+ SCM_GC_BYTEVECTOR);
+ SCM_BYTEVECTOR_SET_CONTENTS (bv, c_new_bv);
+ }
+ }
+
+ return bv;
+}
+
+int
+scm_is_bytevector (SCM obj)
+{
+ return SCM_SMOB_PREDICATE (scm_tc16_bytevector, obj);
+}
+
+size_t
+scm_c_bytevector_length (SCM bv)
+#define FUNC_NAME "scm_c_bytevector_length"
+{
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+
+ return SCM_BYTEVECTOR_LENGTH (bv);
+}
+#undef FUNC_NAME
+
+scm_t_uint8
+scm_c_bytevector_ref (SCM bv, size_t index)
+#define FUNC_NAME "scm_c_bytevector_ref"
+{
+ size_t c_len;
+ const scm_t_uint8 *c_bv;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ if (SCM_UNLIKELY (index >= c_len))
+ scm_out_of_range (FUNC_NAME, scm_from_size_t (index));
+
+ return c_bv[index];
+}
+#undef FUNC_NAME
+
+void
+scm_c_bytevector_set_x (SCM bv, size_t index, scm_t_uint8 value)
+#define FUNC_NAME "scm_c_bytevector_set_x"
+{
+ size_t c_len;
+ scm_t_uint8 *c_bv;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = (scm_t_uint8 *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ if (SCM_UNLIKELY (index >= c_len))
+ scm_out_of_range (FUNC_NAME, scm_from_size_t (index));
+
+ c_bv[index] = value;
+}
+#undef FUNC_NAME
+
+/* This procedure is used by `scm_c_generalized_vector_set_x ()'. */
+void
+scm_i_bytevector_generalized_set_x (SCM bv, size_t index, SCM value)
+#define FUNC_NAME "scm_i_bytevector_generalized_set_x"
+{
+ scm_c_bytevector_set_x (bv, index, scm_to_uint8 (value));
+}
+#undef FUNC_NAME
+
+static int
+print_bytevector (SCM bv, SCM port, scm_print_state *pstate)
+{
+ unsigned c_len, i;
+ unsigned char *c_bv;
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ scm_puts ("#vu8(", port);
+ for (i = 0; i < c_len; i++)
+ {
+ if (i > 0)
+ scm_putc (' ', port);
+
+ scm_uintprint (c_bv[i], 10, port);
+ }
+
+ scm_putc (')', port);
+
+ /* Make GCC think we use it. */
+ scm_remember_upto_here ((SCM) pstate);
+
+ return 1;
+}
+
+static SCM
+bytevector_equal_p (SCM bv1, SCM bv2)
+{
+ return scm_bytevector_eq_p (bv1, bv2);
+}
+
+static size_t
+free_bytevector (SCM bv)
+{
+
+ if (!SCM_BYTEVECTOR_INLINE_P (bv))
+ {
+ unsigned c_len;
+ signed char *c_bv;
+
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+
+ scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ }
+
+ return 0;
+}
+
+
+
+/* General operations. */
+
+SCM_SYMBOL (scm_sym_big, "big");
+SCM_SYMBOL (scm_sym_little, "little");
+
+SCM scm_endianness_big, scm_endianness_little;
+
+/* Host endianness (a symbol). */
+SCM scm_i_native_endianness = SCM_UNSPECIFIED;
+
+/* Byte-swapping. */
+#ifndef bswap_24
+# define bswap_24(_x) \
+ ((((_x) & 0xff0000) >> 16) | \
+ (((_x) & 0x00ff00)) | \
+ (((_x) & 0x0000ff) << 16))
+#endif
+
+
+SCM_DEFINE (scm_native_endianness, "native-endianness", 0, 0, 0,
+ (void),
+ "Return a symbol denoting the machine's native endianness.")
+#define FUNC_NAME s_scm_native_endianness
+{
+ return scm_i_native_endianness;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_p, "bytevector?", 1, 0, 0,
+ (SCM obj),
+ "Return true if @var{obj} is a bytevector.")
+#define FUNC_NAME s_scm_bytevector_p
+{
+ return scm_from_bool (scm_is_bytevector (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0,
+ (SCM len, SCM fill),
+ "Return a newly allocated bytevector of @var{len} bytes, "
+ "optionally filled with @var{fill}.")
+#define FUNC_NAME s_scm_make_bytevector
+{
+ SCM bv;
+ unsigned c_len;
+ signed char c_fill = '\0';
+
+ SCM_VALIDATE_UINT_COPY (1, len, c_len);
+ if (fill != SCM_UNDEFINED)
+ {
+ int value;
+
+ value = scm_to_int (fill);
+ if (SCM_UNLIKELY ((value < -128) || (value > 255)))
+ scm_out_of_range (FUNC_NAME, fill);
+ c_fill = (signed char) value;
+ }
+
+ bv = make_bytevector (c_len);
+ if (fill != SCM_UNDEFINED)
+ {
+ unsigned i;
+ signed char *contents;
+
+ contents = SCM_BYTEVECTOR_CONTENTS (bv);
+ for (i = 0; i < c_len; i++)
+ contents[i] = c_fill;
+ }
+
+ return bv;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_length, "bytevector-length", 1, 0, 0,
+ (SCM bv),
+ "Return the length (in bytes) of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_length
+{
+ return scm_from_uint (scm_c_bytevector_length (bv));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_eq_p, "bytevector=?", 2, 0, 0,
+ (SCM bv1, SCM bv2),
+ "Return is @var{bv1} equals to @var{bv2}---i.e., if they "
+ "have the same length and contents.")
+#define FUNC_NAME s_scm_bytevector_eq_p
+{
+ SCM result = SCM_BOOL_F;
+ unsigned c_len1, c_len2;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv1);
+ SCM_VALIDATE_BYTEVECTOR (2, bv2);
+
+ c_len1 = SCM_BYTEVECTOR_LENGTH (bv1);
+ c_len2 = SCM_BYTEVECTOR_LENGTH (bv2);
+
+ if (c_len1 == c_len2)
+ {
+ signed char *c_bv1, *c_bv2;
+
+ c_bv1 = SCM_BYTEVECTOR_CONTENTS (bv1);
+ c_bv2 = SCM_BYTEVECTOR_CONTENTS (bv2);
+
+ result = scm_from_bool (!memcmp (c_bv1, c_bv2, c_len1));
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_fill_x, "bytevector-fill!", 2, 0, 0,
+ (SCM bv, SCM fill),
+ "Fill bytevector @var{bv} with @var{fill}, a byte.")
+#define FUNC_NAME s_scm_bytevector_fill_x
+{
+ unsigned c_len, i;
+ signed char *c_bv, c_fill;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+ c_fill = scm_to_int8 (fill);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+
+ for (i = 0; i < c_len; i++)
+ c_bv[i] = c_fill;
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_copy_x, "bytevector-copy!", 5, 0, 0,
+ (SCM source, SCM source_start, SCM target, SCM target_start,
+ SCM len),
+ "Copy @var{len} bytes from @var{source} into @var{target}, "
+ "starting reading from @var{source_start} (a positive index "
+ "within @var{source}) and start writing at "
+ "@var{target_start}.")
+#define FUNC_NAME s_scm_bytevector_copy_x
+{
+ unsigned c_len, c_source_len, c_target_len;
+ unsigned c_source_start, c_target_start;
+ signed char *c_source, *c_target;
+
+ SCM_VALIDATE_BYTEVECTOR (1, source);
+ SCM_VALIDATE_BYTEVECTOR (3, target);
+
+ c_len = scm_to_uint (len);
+ c_source_start = scm_to_uint (source_start);
+ c_target_start = scm_to_uint (target_start);
+
+ c_source = SCM_BYTEVECTOR_CONTENTS (source);
+ c_target = SCM_BYTEVECTOR_CONTENTS (target);
+ c_source_len = SCM_BYTEVECTOR_LENGTH (source);
+ c_target_len = SCM_BYTEVECTOR_LENGTH (target);
+
+ if (SCM_UNLIKELY (c_source_start + c_len > c_source_len))
+ scm_out_of_range (FUNC_NAME, source_start);
+ if (SCM_UNLIKELY (c_target_start + c_len > c_target_len))
+ scm_out_of_range (FUNC_NAME, target_start);
+
+ memcpy (c_target + c_target_start,
+ c_source + c_source_start,
+ c_len);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 0,
+ (SCM bv),
+ "Return a newly allocated copy of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_copy
+{
+ SCM copy;
+ unsigned c_len;
+ signed char *c_bv, *c_copy;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
+
+ copy = make_bytevector (c_len);
+ c_copy = SCM_BYTEVECTOR_CONTENTS (copy);
+ memcpy (c_copy, c_bv, c_len);
+
+ return copy;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_uniform_array_to_bytevector, "uniform-array->bytevector",
+ 1, 0, 0, (SCM array),
+ "Return a newly allocated bytevector whose contents\n"
+ "will be copied from the uniform array @var{array}.")
+#define FUNC_NAME s_scm_uniform_array_to_bytevector
+{
+ SCM contents, ret;
+ size_t len;
+ scm_t_array_handle h;
+ const void *base;
+ size_t sz;
+
+ contents = scm_array_contents (array, SCM_BOOL_T);
+ if (scm_is_false (contents))
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, array, "uniform contiguous array");
+
+ scm_array_get_handle (contents, &h);
+
+ base = scm_array_handle_uniform_elements (&h);
+ len = h.dims->inc * (h.dims->ubnd - h.dims->lbnd + 1);
+ sz = scm_array_handle_uniform_element_size (&h);
+
+ ret = make_bytevector (len * sz);
+ memcpy (SCM_BYTEVECTOR_CONTENTS (ret), base, len * sz);
+
+ scm_array_handle_release (&h);
+
+ return ret;
+}
+#undef FUNC_NAME
+
+
+/* Operations on bytes and octets. */
+
+SCM_DEFINE (scm_bytevector_u8_ref, "bytevector-u8-ref", 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the octet located at @var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_u8_ref
+{
+ INTEGER_NATIVE_REF (8, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s8_ref, "bytevector-s8-ref", 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the byte located at @var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_s8_ref
+{
+ INTEGER_NATIVE_REF (8, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u8_set_x, "bytevector-u8-set!", 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Return the octet located at @var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_u8_set_x
+{
+ INTEGER_NATIVE_SET (8, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s8_set_x, "bytevector-s8-set!", 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Return the octet located at @var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_s8_set_x
+{
+ INTEGER_NATIVE_SET (8, signed);
+}
+#undef FUNC_NAME
+
+#undef OCTET_ACCESSOR_PROLOGUE
+
+
+SCM_DEFINE (scm_bytevector_to_u8_list, "bytevector->u8-list", 1, 0, 0,
+ (SCM bv),
+ "Return a newly allocated list of octets containing the "
+ "contents of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_to_u8_list
+{
+ SCM lst, pair;
+ unsigned c_len, i;
+ unsigned char *c_bv;
+
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ lst = scm_make_list (scm_from_uint (c_len), SCM_UNSPECIFIED);
+ for (i = 0, pair = lst;
+ i < c_len;
+ i++, pair = SCM_CDR (pair))
+ {
+ SCM_SETCAR (pair, SCM_I_MAKINUM (c_bv[i]));
+ }
+
+ return lst;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0,
+ (SCM lst),
+ "Turn @var{lst}, a list of octets, into a bytevector.")
+#define FUNC_NAME s_scm_u8_list_to_bytevector
+{
+ SCM bv, item;
+ long c_len, i;
+ unsigned char *c_bv;
+
+ SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len);
+
+ bv = make_bytevector (c_len);
+ c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ for (i = 0; i < c_len; lst = SCM_CDR (lst), i++)
+ {
+ item = SCM_CAR (lst);
+
+ if (SCM_LIKELY (SCM_I_INUMP (item)))
+ {
+ long c_item;
+
+ c_item = SCM_I_INUM (item);
+ if (SCM_LIKELY ((c_item >= 0) && (c_item < 256)))
+ c_bv[i] = (unsigned char) c_item;
+ else
+ goto type_error;
+ }
+ else
+ goto type_error;
+ }
+
+ return bv;
+
+ type_error:
+ scm_wrong_type_arg (FUNC_NAME, 1, item);
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+/* Compute the two's complement of VALUE (a positive integer) on SIZE octets
+ using (2^(SIZE * 8) - VALUE). */
+static inline void
+twos_complement (mpz_t value, size_t size)
+{
+ unsigned long bit_count;
+
+ /* We expect BIT_COUNT to fit in a unsigned long thanks to the range
+ checking on SIZE performed earlier. */
+ bit_count = (unsigned long) size << 3UL;
+
+ if (SCM_LIKELY (bit_count < sizeof (unsigned long)))
+ mpz_ui_sub (value, 1UL << bit_count, value);
+ else
+ {
+ mpz_t max;
+
+ mpz_init (max);
+ mpz_ui_pow_ui (max, 2, bit_count);
+ mpz_sub (value, max, value);
+ mpz_clear (max);
+ }
+}
+
+static inline SCM
+bytevector_large_ref (const char *c_bv, size_t c_size, int signed_p,
+ SCM endianness)
+{
+ SCM result;
+ mpz_t c_mpz;
+ int c_endianness, negative_p = 0;
+
+ if (signed_p)
+ {
+ if (scm_is_eq (endianness, scm_sym_big))
+ negative_p = c_bv[0] & 0x80;
+ else
+ negative_p = c_bv[c_size - 1] & 0x80;
+ }
+
+ c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
+
+ mpz_init (c_mpz);
+ mpz_import (c_mpz, 1 /* 1 word */, 1 /* word order doesn't matter */,
+ c_size /* word is C_SIZE-byte long */,
+ c_endianness,
+ 0 /* nails */, c_bv);
+
+ if (signed_p && negative_p)
+ {
+ twos_complement (c_mpz, c_size);
+ mpz_neg (c_mpz, c_mpz);
+ }
+
+ result = scm_from_mpz (c_mpz);
+ mpz_clear (c_mpz); /* FIXME: Needed? */
+
+ return result;
+}
+
+static inline int
+bytevector_large_set (char *c_bv, size_t c_size, int signed_p,
+ SCM value, SCM endianness)
+{
+ mpz_t c_mpz;
+ int c_endianness, c_sign, err = 0;
+
+ c_endianness = scm_is_eq (endianness, scm_sym_big) ? 1 : -1;
+
+ mpz_init (c_mpz);
+ scm_to_mpz (value, c_mpz);
+
+ c_sign = mpz_sgn (c_mpz);
+ if (c_sign < 0)
+ {
+ if (SCM_LIKELY (signed_p))
+ {
+ mpz_neg (c_mpz, c_mpz);
+ twos_complement (c_mpz, c_size);
+ }
+ else
+ {
+ err = -1;
+ goto finish;
+ }
+ }
+
+ if (c_sign == 0)
+ /* Zero. */
+ memset (c_bv, 0, c_size);
+ else
+ {
+ size_t word_count, value_size;
+
+ value_size = (mpz_sizeinbase (c_mpz, 2) + (8 * c_size)) / (8 * c_size);
+ if (SCM_UNLIKELY (value_size > c_size))
+ {
+ err = -2;
+ goto finish;
+ }
+
+
+ mpz_export (c_bv, &word_count, 1 /* word order doesn't matter */,
+ c_size, c_endianness,
+ 0 /* nails */, c_mpz);
+ if (SCM_UNLIKELY (word_count != 1))
+ /* Shouldn't happen since we already checked with VALUE_SIZE. */
+ abort ();
+ }
+
+ finish:
+ mpz_clear (c_mpz);
+
+ return err;
+}
+
+#define GENERIC_INTEGER_ACCESSOR_PROLOGUE(_sign) \
+ unsigned long c_len, c_index, c_size; \
+ char *c_bv; \
+ \
+ SCM_VALIDATE_BYTEVECTOR (1, bv); \
+ c_index = scm_to_ulong (index); \
+ c_size = scm_to_ulong (size); \
+ \
+ c_len = SCM_BYTEVECTOR_LENGTH (bv); \
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
+ \
+ /* C_SIZE must have its 3 higher bits set to zero so that \
+ multiplying it by 8 yields a number that fits in an \
+ unsigned long. */ \
+ if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
+ scm_out_of_range (FUNC_NAME, size); \
+ if (SCM_UNLIKELY (c_index + c_size > c_len)) \
+ scm_out_of_range (FUNC_NAME, index);
+
+
+/* Template of an integer reference function. */
+#define GENERIC_INTEGER_REF(_sign) \
+ SCM result; \
+ \
+ if (c_size < 3) \
+ { \
+ int swap; \
+ _sign int value; \
+ \
+ swap = !scm_is_eq (endianness, scm_i_native_endianness); \
+ switch (c_size) \
+ { \
+ case 1: \
+ { \
+ _sign char c_value8; \
+ memcpy (&c_value8, c_bv, 1); \
+ value = c_value8; \
+ } \
+ break; \
+ case 2: \
+ { \
+ INT_TYPE (16, _sign) c_value16; \
+ memcpy (&c_value16, c_bv, 2); \
+ if (swap) \
+ value = (INT_TYPE (16, _sign)) bswap_16 (c_value16); \
+ else \
+ value = c_value16; \
+ } \
+ break; \
+ default: \
+ abort (); \
+ } \
+ \
+ result = SCM_I_MAKINUM ((_sign int) value); \
+ } \
+ else \
+ result = bytevector_large_ref ((char *) c_bv, \
+ c_size, SIGNEDNESS (_sign), \
+ endianness); \
+ \
+ return result;
+
+static inline SCM
+bytevector_signed_ref (const char *c_bv, size_t c_size, SCM endianness)
+{
+ GENERIC_INTEGER_REF (signed);
+}
+
+static inline SCM
+bytevector_unsigned_ref (const char *c_bv, size_t c_size, SCM endianness)
+{
+ GENERIC_INTEGER_REF (unsigned);
+}
+
+
+/* Template of an integer assignment function. */
+#define GENERIC_INTEGER_SET(_sign) \
+ if (c_size < 3) \
+ { \
+ _sign int c_value; \
+ \
+ if (SCM_UNLIKELY (!SCM_I_INUMP (value))) \
+ goto range_error; \
+ \
+ c_value = SCM_I_INUM (value); \
+ switch (c_size) \
+ { \
+ case 1: \
+ if (SCM_LIKELY (INT_VALID_P (8, _sign) (c_value))) \
+ { \
+ _sign char c_value8; \
+ c_value8 = (_sign char) c_value; \
+ memcpy (c_bv, &c_value8, 1); \
+ } \
+ else \
+ goto range_error; \
+ break; \
+ \
+ case 2: \
+ if (SCM_LIKELY (INT_VALID_P (16, _sign) (c_value))) \
+ { \
+ int swap; \
+ INT_TYPE (16, _sign) c_value16; \
+ \
+ swap = !scm_is_eq (endianness, scm_i_native_endianness); \
+ \
+ if (swap) \
+ c_value16 = (INT_TYPE (16, _sign)) bswap_16 (c_value); \
+ else \
+ c_value16 = c_value; \
+ \
+ memcpy (c_bv, &c_value16, 2); \
+ } \
+ else \
+ goto range_error; \
+ break; \
+ \
+ default: \
+ abort (); \
+ } \
+ } \
+ else \
+ { \
+ int err; \
+ \
+ err = bytevector_large_set (c_bv, c_size, \
+ SIGNEDNESS (_sign), \
+ value, endianness); \
+ if (err) \
+ goto range_error; \
+ } \
+ \
+ return; \
+ \
+ range_error: \
+ scm_out_of_range (FUNC_NAME, value); \
+ return;
+
+static inline void
+bytevector_signed_set (char *c_bv, size_t c_size,
+ SCM value, SCM endianness,
+ const char *func_name)
+#define FUNC_NAME func_name
+{
+ GENERIC_INTEGER_SET (signed);
+}
+#undef FUNC_NAME
+
+static inline void
+bytevector_unsigned_set (char *c_bv, size_t c_size,
+ SCM value, SCM endianness,
+ const char *func_name)
+#define FUNC_NAME func_name
+{
+ GENERIC_INTEGER_SET (unsigned);
+}
+#undef FUNC_NAME
+
+#undef GENERIC_INTEGER_SET
+#undef GENERIC_INTEGER_REF
+
+
+SCM_DEFINE (scm_bytevector_uint_ref, "bytevector-uint-ref", 4, 0, 0,
+ (SCM bv, SCM index, SCM endianness, SCM size),
+ "Return the @var{size}-octet long unsigned integer at index "
+ "@var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_uint_ref
+{
+ GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
+
+ return (bytevector_unsigned_ref (&c_bv[c_index], c_size, endianness));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_sint_ref, "bytevector-sint-ref", 4, 0, 0,
+ (SCM bv, SCM index, SCM endianness, SCM size),
+ "Return the @var{size}-octet long unsigned integer at index "
+ "@var{index} in @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_sint_ref
+{
+ GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
+
+ return (bytevector_signed_ref (&c_bv[c_index], c_size, endianness));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_uint_set_x, "bytevector-uint-set!", 5, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
+ "Set the @var{size}-octet long unsigned integer at @var{index} "
+ "to @var{value}.")
+#define FUNC_NAME s_scm_bytevector_uint_set_x
+{
+ GENERIC_INTEGER_ACCESSOR_PROLOGUE (unsigned);
+
+ bytevector_unsigned_set (&c_bv[c_index], c_size, value, endianness,
+ FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_sint_set_x, "bytevector-sint-set!", 5, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness, SCM size),
+ "Set the @var{size}-octet long signed integer at @var{index} "
+ "to @var{value}.")
+#define FUNC_NAME s_scm_bytevector_sint_set_x
+{
+ GENERIC_INTEGER_ACCESSOR_PROLOGUE (signed);
+
+ bytevector_signed_set (&c_bv[c_index], c_size, value, endianness,
+ FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+
+/* Operations on integers of arbitrary size. */
+
+#define INTEGERS_TO_LIST(_sign) \
+ SCM lst, pair; \
+ size_t i, c_len, c_size; \
+ \
+ SCM_VALIDATE_BYTEVECTOR (1, bv); \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ c_size = scm_to_uint (size); \
+ \
+ c_len = SCM_BYTEVECTOR_LENGTH (bv); \
+ if (SCM_UNLIKELY (c_len == 0)) \
+ lst = SCM_EOL; \
+ else if (SCM_UNLIKELY (c_len < c_size)) \
+ scm_out_of_range (FUNC_NAME, size); \
+ else \
+ { \
+ const char *c_bv; \
+ \
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
+ \
+ lst = scm_make_list (scm_from_uint (c_len / c_size), \
+ SCM_UNSPECIFIED); \
+ for (i = 0, pair = lst; \
+ i <= c_len - c_size; \
+ i += c_size, c_bv += c_size, pair = SCM_CDR (pair)) \
+ { \
+ SCM_SETCAR (pair, \
+ bytevector_ ## _sign ## _ref (c_bv, c_size, \
+ endianness)); \
+ } \
+ } \
+ \
+ return lst;
+
+SCM_DEFINE (scm_bytevector_to_sint_list, "bytevector->sint-list",
+ 3, 0, 0,
+ (SCM bv, SCM endianness, SCM size),
+ "Return a list of signed integers of @var{size} octets "
+ "representing the contents of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_to_sint_list
+{
+ INTEGERS_TO_LIST (signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_to_uint_list, "bytevector->uint-list",
+ 3, 0, 0,
+ (SCM bv, SCM endianness, SCM size),
+ "Return a list of unsigned integers of @var{size} octets "
+ "representing the contents of @var{bv}.")
+#define FUNC_NAME s_scm_bytevector_to_uint_list
+{
+ INTEGERS_TO_LIST (unsigned);
+}
+#undef FUNC_NAME
+
+#undef INTEGER_TO_LIST
+
+
+#define INTEGER_LIST_TO_BYTEVECTOR(_sign) \
+ SCM bv; \
+ long c_len; \
+ size_t c_size; \
+ char *c_bv, *c_bv_ptr; \
+ \
+ SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len); \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ c_size = scm_to_uint (size); \
+ \
+ if (SCM_UNLIKELY ((c_size == 0) || (c_size >= (ULONG_MAX >> 3L)))) \
+ scm_out_of_range (FUNC_NAME, size); \
+ \
+ bv = make_bytevector (c_len * c_size); \
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv); \
+ \
+ for (c_bv_ptr = c_bv; \
+ !scm_is_null (lst); \
+ lst = SCM_CDR (lst), c_bv_ptr += c_size) \
+ { \
+ bytevector_ ## _sign ## _set (c_bv_ptr, c_size, \
+ SCM_CAR (lst), endianness, \
+ FUNC_NAME); \
+ } \
+ \
+ return bv;
+
+
+SCM_DEFINE (scm_uint_list_to_bytevector, "uint-list->bytevector",
+ 3, 0, 0,
+ (SCM lst, SCM endianness, SCM size),
+ "Return a bytevector containing the unsigned integers "
+ "listed in @var{lst} and encoded on @var{size} octets "
+ "according to @var{endianness}.")
+#define FUNC_NAME s_scm_uint_list_to_bytevector
+{
+ INTEGER_LIST_TO_BYTEVECTOR (unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_sint_list_to_bytevector, "sint-list->bytevector",
+ 3, 0, 0,
+ (SCM lst, SCM endianness, SCM size),
+ "Return a bytevector containing the signed integers "
+ "listed in @var{lst} and encoded on @var{size} octets "
+ "according to @var{endianness}.")
+#define FUNC_NAME s_scm_sint_list_to_bytevector
+{
+ INTEGER_LIST_TO_BYTEVECTOR (signed);
+}
+#undef FUNC_NAME
+
+#undef INTEGER_LIST_TO_BYTEVECTOR
+
+
+
+/* Operations on 16-bit integers. */
+
+SCM_DEFINE (scm_bytevector_u16_ref, "bytevector-u16-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the unsigned 16-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_u16_ref
+{
+ INTEGER_REF (16, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s16_ref, "bytevector-s16-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the signed 16-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_s16_ref
+{
+ INTEGER_REF (16, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u16_native_ref, "bytevector-u16-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 16-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u16_native_ref
+{
+ INTEGER_NATIVE_REF (16, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s16_native_ref, "bytevector-s16-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 16-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s16_native_ref
+{
+ INTEGER_NATIVE_REF (16, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u16_set_x, "bytevector-u16-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_u16_set_x
+{
+ INTEGER_SET (16, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s16_set_x, "bytevector-s16-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_s16_set_x
+{
+ INTEGER_SET (16, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u16_native_set_x, "bytevector-u16-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the unsigned integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u16_native_set_x
+{
+ INTEGER_NATIVE_SET (16, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s16_native_set_x, "bytevector-s16-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the signed integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s16_native_set_x
+{
+ INTEGER_NATIVE_SET (16, signed);
+}
+#undef FUNC_NAME
+
+
+
+/* Operations on 32-bit integers. */
+
+/* Unfortunately, on 32-bit machines `SCM' is not large enough to hold
+ arbitrary 32-bit integers. Thus we fall back to using the
+ `large_{ref,set}' variants on 32-bit machines. */
+
+#define LARGE_INTEGER_REF(_len, _sign) \
+ INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
+ SCM_VALIDATE_SYMBOL (3, endianness); \
+ \
+ return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
+ SIGNEDNESS (_sign), endianness));
+
+#define LARGE_INTEGER_SET(_len, _sign) \
+ int err; \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ SCM_VALIDATE_SYMBOL (4, endianness); \
+ \
+ err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
+ SIGNEDNESS (_sign), value, endianness); \
+ if (SCM_UNLIKELY (err)) \
+ scm_out_of_range (FUNC_NAME, value); \
+ \
+ return SCM_UNSPECIFIED;
+
+#define LARGE_INTEGER_NATIVE_REF(_len, _sign) \
+ INTEGER_ACCESSOR_PROLOGUE(_len, _sign); \
+ return (bytevector_large_ref ((char *) c_bv + c_index, _len / 8, \
+ SIGNEDNESS (_sign), scm_i_native_endianness));
+
+#define LARGE_INTEGER_NATIVE_SET(_len, _sign) \
+ int err; \
+ INTEGER_ACCESSOR_PROLOGUE (_len, _sign); \
+ \
+ err = bytevector_large_set ((char *) c_bv + c_index, _len / 8, \
+ SIGNEDNESS (_sign), value, \
+ scm_i_native_endianness); \
+ if (SCM_UNLIKELY (err)) \
+ scm_out_of_range (FUNC_NAME, value); \
+ \
+ return SCM_UNSPECIFIED;
+
+
+SCM_DEFINE (scm_bytevector_u32_ref, "bytevector-u32-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the unsigned 32-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_u32_ref
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_REF (32, unsigned);
+#else
+ LARGE_INTEGER_REF (32, unsigned);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s32_ref, "bytevector-s32-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the signed 32-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_s32_ref
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_REF (32, signed);
+#else
+ LARGE_INTEGER_REF (32, signed);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u32_native_ref, "bytevector-u32-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 32-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u32_native_ref
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_NATIVE_REF (32, unsigned);
+#else
+ LARGE_INTEGER_NATIVE_REF (32, unsigned);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s32_native_ref, "bytevector-s32-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 32-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s32_native_ref
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_NATIVE_REF (32, signed);
+#else
+ LARGE_INTEGER_NATIVE_REF (32, signed);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u32_set_x, "bytevector-u32-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_u32_set_x
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_SET (32, unsigned);
+#else
+ LARGE_INTEGER_SET (32, unsigned);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s32_set_x, "bytevector-s32-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_s32_set_x
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_SET (32, signed);
+#else
+ LARGE_INTEGER_SET (32, signed);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u32_native_set_x, "bytevector-u32-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the unsigned integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u32_native_set_x
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_NATIVE_SET (32, unsigned);
+#else
+ LARGE_INTEGER_NATIVE_SET (32, unsigned);
+#endif
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s32_native_set_x, "bytevector-s32-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the signed integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s32_native_set_x
+{
+#if SIZEOF_VOID_P > 4
+ INTEGER_NATIVE_SET (32, signed);
+#else
+ LARGE_INTEGER_NATIVE_SET (32, signed);
+#endif
+}
+#undef FUNC_NAME
+
+
+
+/* Operations on 64-bit integers. */
+
+/* For 64-bit integers, we use only the `large_{ref,set}' variant. */
+
+SCM_DEFINE (scm_bytevector_u64_ref, "bytevector-u64-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the unsigned 64-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_u64_ref
+{
+ LARGE_INTEGER_REF (64, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s64_ref, "bytevector-s64-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the signed 64-bit integer from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_s64_ref
+{
+ LARGE_INTEGER_REF (64, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u64_native_ref, "bytevector-u64-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 64-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u64_native_ref
+{
+ LARGE_INTEGER_NATIVE_REF (64, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s64_native_ref, "bytevector-s64-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the unsigned 64-bit integer from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s64_native_ref
+{
+ LARGE_INTEGER_NATIVE_REF (64, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u64_set_x, "bytevector-u64-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_u64_set_x
+{
+ LARGE_INTEGER_SET (64, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s64_set_x, "bytevector-s64-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_s64_set_x
+{
+ LARGE_INTEGER_SET (64, signed);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_u64_native_set_x, "bytevector-u64-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the unsigned integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_u64_native_set_x
+{
+ LARGE_INTEGER_NATIVE_SET (64, unsigned);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_s64_native_set_x, "bytevector-s64-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the signed integer @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_s64_native_set_x
+{
+ LARGE_INTEGER_NATIVE_SET (64, signed);
+}
+#undef FUNC_NAME
+
+
+
+/* Operations on IEEE-754 numbers. */
+
+/* There are two possible word endians, visible in glibc's <ieee754.h>.
+ However, in R6RS, when the endianness is `little', little endian is
+ assumed for both the byte order and the word order. This is clear from
+ Section 2.1 of R6RS-lib (in response to
+ http://www.r6rs.org/formal-comments/comment-187.txt). */
+
+
+/* Convert to/from a floating-point number with different endianness. This
+ method is probably not the most efficient but it should be portable. */
+
+static inline void
+float_to_foreign_endianness (union scm_ieee754_float *target,
+ float source)
+{
+ union scm_ieee754_float src;
+
+ src.f = source;
+
+#ifdef WORDS_BIGENDIAN
+ /* Assuming little endian for both byte and word order. */
+ target->little_endian.negative = src.big_endian.negative;
+ target->little_endian.exponent = src.big_endian.exponent;
+ target->little_endian.mantissa = src.big_endian.mantissa;
+#else
+ target->big_endian.negative = src.little_endian.negative;
+ target->big_endian.exponent = src.little_endian.exponent;
+ target->big_endian.mantissa = src.little_endian.mantissa;
+#endif
+}
+
+static inline float
+float_from_foreign_endianness (const union scm_ieee754_float *source)
+{
+ union scm_ieee754_float result;
+
+#ifdef WORDS_BIGENDIAN
+ /* Assuming little endian for both byte and word order. */
+ result.big_endian.negative = source->little_endian.negative;
+ result.big_endian.exponent = source->little_endian.exponent;
+ result.big_endian.mantissa = source->little_endian.mantissa;
+#else
+ result.little_endian.negative = source->big_endian.negative;
+ result.little_endian.exponent = source->big_endian.exponent;
+ result.little_endian.mantissa = source->big_endian.mantissa;
+#endif
+
+ return (result.f);
+}
+
+static inline void
+double_to_foreign_endianness (union scm_ieee754_double *target,
+ double source)
+{
+ union scm_ieee754_double src;
+
+ src.d = source;
+
+#ifdef WORDS_BIGENDIAN
+ /* Assuming little endian for both byte and word order. */
+ target->little_little_endian.negative = src.big_endian.negative;
+ target->little_little_endian.exponent = src.big_endian.exponent;
+ target->little_little_endian.mantissa0 = src.big_endian.mantissa0;
+ target->little_little_endian.mantissa1 = src.big_endian.mantissa1;
+#else
+ target->big_endian.negative = src.little_little_endian.negative;
+ target->big_endian.exponent = src.little_little_endian.exponent;
+ target->big_endian.mantissa0 = src.little_little_endian.mantissa0;
+ target->big_endian.mantissa1 = src.little_little_endian.mantissa1;
+#endif
+}
+
+static inline double
+double_from_foreign_endianness (const union scm_ieee754_double *source)
+{
+ union scm_ieee754_double result;
+
+#ifdef WORDS_BIGENDIAN
+ /* Assuming little endian for both byte and word order. */
+ result.big_endian.negative = source->little_little_endian.negative;
+ result.big_endian.exponent = source->little_little_endian.exponent;
+ result.big_endian.mantissa0 = source->little_little_endian.mantissa0;
+ result.big_endian.mantissa1 = source->little_little_endian.mantissa1;
+#else
+ result.little_little_endian.negative = source->big_endian.negative;
+ result.little_little_endian.exponent = source->big_endian.exponent;
+ result.little_little_endian.mantissa0 = source->big_endian.mantissa0;
+ result.little_little_endian.mantissa1 = source->big_endian.mantissa1;
+#endif
+
+ return (result.d);
+}
+
+/* Template macros to abstract over doubles and floats.
+ XXX: Guile can only convert to/from doubles. */
+#define IEEE754_UNION(_c_type) union scm_ieee754_ ## _c_type
+#define IEEE754_TO_SCM(_c_type) scm_from_double
+#define IEEE754_FROM_SCM(_c_type) scm_to_double
+#define IEEE754_FROM_FOREIGN_ENDIANNESS(_c_type) \
+ _c_type ## _from_foreign_endianness
+#define IEEE754_TO_FOREIGN_ENDIANNESS(_c_type) \
+ _c_type ## _to_foreign_endianness
+
+
+/* Templace getters and setters. */
+
+#define IEEE754_ACCESSOR_PROLOGUE(_type) \
+ INTEGER_ACCESSOR_PROLOGUE (sizeof (_type) << 3UL, signed);
+
+#define IEEE754_REF(_type) \
+ _type c_result; \
+ \
+ IEEE754_ACCESSOR_PROLOGUE (_type); \
+ SCM_VALIDATE_SYMBOL (3, endianness); \
+ \
+ if (scm_is_eq (endianness, scm_i_native_endianness)) \
+ memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
+ else \
+ { \
+ IEEE754_UNION (_type) c_raw; \
+ \
+ memcpy (&c_raw, &c_bv[c_index], sizeof (c_raw)); \
+ c_result = \
+ IEEE754_FROM_FOREIGN_ENDIANNESS (_type) (&c_raw); \
+ } \
+ \
+ return (IEEE754_TO_SCM (_type) (c_result));
+
+#define IEEE754_NATIVE_REF(_type) \
+ _type c_result; \
+ \
+ IEEE754_ACCESSOR_PROLOGUE (_type); \
+ \
+ memcpy (&c_result, &c_bv[c_index], sizeof (c_result)); \
+ return (IEEE754_TO_SCM (_type) (c_result));
+
+#define IEEE754_SET(_type) \
+ _type c_value; \
+ \
+ IEEE754_ACCESSOR_PROLOGUE (_type); \
+ SCM_VALIDATE_REAL (3, value); \
+ SCM_VALIDATE_SYMBOL (4, endianness); \
+ c_value = IEEE754_FROM_SCM (_type) (value); \
+ \
+ if (scm_is_eq (endianness, scm_i_native_endianness)) \
+ memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
+ else \
+ { \
+ IEEE754_UNION (_type) c_raw; \
+ \
+ IEEE754_TO_FOREIGN_ENDIANNESS (_type) (&c_raw, c_value); \
+ memcpy (&c_bv[c_index], &c_raw, sizeof (c_raw)); \
+ } \
+ \
+ return SCM_UNSPECIFIED;
+
+#define IEEE754_NATIVE_SET(_type) \
+ _type c_value; \
+ \
+ IEEE754_ACCESSOR_PROLOGUE (_type); \
+ SCM_VALIDATE_REAL (3, value); \
+ c_value = IEEE754_FROM_SCM (_type) (value); \
+ \
+ memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
+ return SCM_UNSPECIFIED;
+
+
+/* Single precision. */
+
+SCM_DEFINE (scm_bytevector_ieee_single_ref,
+ "bytevector-ieee-single-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the IEEE-754 single from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_ieee_single_ref
+{
+ IEEE754_REF (float);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_single_native_ref,
+ "bytevector-ieee-single-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the IEEE-754 single from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_ieee_single_native_ref
+{
+ IEEE754_NATIVE_REF (float);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_single_set_x,
+ "bytevector-ieee-single-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store real @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_ieee_single_set_x
+{
+ IEEE754_SET (float);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_single_native_set_x,
+ "bytevector-ieee-single-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the real @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_ieee_single_native_set_x
+{
+ IEEE754_NATIVE_SET (float);
+}
+#undef FUNC_NAME
+
+
+/* Double precision. */
+
+SCM_DEFINE (scm_bytevector_ieee_double_ref,
+ "bytevector-ieee-double-ref",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM endianness),
+ "Return the IEEE-754 double from @var{bv} at "
+ "@var{index}.")
+#define FUNC_NAME s_scm_bytevector_ieee_double_ref
+{
+ IEEE754_REF (double);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_double_native_ref,
+ "bytevector-ieee-double-native-ref",
+ 2, 0, 0,
+ (SCM bv, SCM index),
+ "Return the IEEE-754 double from @var{bv} at "
+ "@var{index} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_ieee_double_native_ref
+{
+ IEEE754_NATIVE_REF (double);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_double_set_x,
+ "bytevector-ieee-double-set!",
+ 4, 0, 0,
+ (SCM bv, SCM index, SCM value, SCM endianness),
+ "Store real @var{value} in @var{bv} at @var{index} according to "
+ "@var{endianness}.")
+#define FUNC_NAME s_scm_bytevector_ieee_double_set_x
+{
+ IEEE754_SET (double);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_bytevector_ieee_double_native_set_x,
+ "bytevector-ieee-double-native-set!",
+ 3, 0, 0,
+ (SCM bv, SCM index, SCM value),
+ "Store the real @var{value} at index @var{index} "
+ "of @var{bv} using the native endianness.")
+#define FUNC_NAME s_scm_bytevector_ieee_double_native_set_x
+{
+ IEEE754_NATIVE_SET (double);
+}
+#undef FUNC_NAME
+
+
+#undef IEEE754_UNION
+#undef IEEE754_TO_SCM
+#undef IEEE754_FROM_SCM
+#undef IEEE754_FROM_FOREIGN_ENDIANNESS
+#undef IEEE754_TO_FOREIGN_ENDIANNESS
+#undef IEEE754_REF
+#undef IEEE754_NATIVE_REF
+#undef IEEE754_SET
+#undef IEEE754_NATIVE_SET
+
+
+/* Operations on strings. */
+
+
+/* Produce a function that returns the length of a UTF-encoded string. */
+#define UTF_STRLEN_FUNCTION(_utf_width) \
+static inline size_t \
+utf ## _utf_width ## _strlen (const uint ## _utf_width ## _t *str) \
+{ \
+ size_t len = 0; \
+ const uint ## _utf_width ## _t *ptr; \
+ for (ptr = str; \
+ *ptr != 0; \
+ ptr++) \
+ { \
+ len++; \
+ } \
+ \
+ return (len * ((_utf_width) / 8)); \
+}
+
+UTF_STRLEN_FUNCTION (8)
+
+
+/* Return the length (in bytes) of STR, a UTF-(UTF_WIDTH) encoded string. */
+#define UTF_STRLEN(_utf_width, _str) \
+ utf ## _utf_width ## _strlen (_str)
+
+/* Return the "portable" name of the UTF encoding of size UTF_WIDTH and
+ ENDIANNESS (Gnulib's `iconv_open' module guarantees the portability of the
+ encoding name). */
+static inline void
+utf_encoding_name (char *name, size_t utf_width, SCM endianness)
+{
+ strcpy (name, "UTF-");
+ strcat (name, ((utf_width == 8)
+ ? "8"
+ : ((utf_width == 16)
+ ? "16"
+ : ((utf_width == 32)
+ ? "32"
+ : "??"))));
+ strcat (name,
+ ((scm_is_eq (endianness, scm_sym_big))
+ ? "BE"
+ : ((scm_is_eq (endianness, scm_sym_little))
+ ? "LE"
+ : "unknown")));
+}
+
+/* Maximum length of a UTF encoding name. */
+#define MAX_UTF_ENCODING_NAME_LEN 16
+
+/* Produce the body of a `string->utf' function. */
+#define STRING_TO_UTF(_utf_width) \
+ SCM utf; \
+ int err; \
+ char *c_str; \
+ char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
+ char *c_utf = NULL, *c_locale; \
+ size_t c_strlen, c_raw_strlen, c_utf_len = 0; \
+ \
+ SCM_VALIDATE_STRING (1, str); \
+ if (endianness == SCM_UNDEFINED) \
+ endianness = scm_sym_big; \
+ else \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ \
+ c_strlen = scm_c_string_length (str); \
+ c_raw_strlen = c_strlen * ((_utf_width) / 8); \
+ do \
+ { \
+ c_str = (char *) alloca (c_raw_strlen + 1); \
+ c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen); \
+ } \
+ while (c_raw_strlen > c_strlen); \
+ c_str[c_raw_strlen] = '\0'; \
+ \
+ utf_encoding_name (c_utf_name, (_utf_width), endianness); \
+ \
+ c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
+ strcpy (c_locale, locale_charset ()); \
+ \
+ err = mem_iconveh (c_str, c_raw_strlen, \
+ c_locale, c_utf_name, \
+ iconveh_question_mark, NULL, \
+ &c_utf, &c_utf_len); \
+ if (SCM_UNLIKELY (err)) \
+ scm_syserror_msg (FUNC_NAME, "failed to convert string: ~A", \
+ scm_list_1 (str), err); \
+ else \
+ /* C_UTF is null-terminated. */ \
+ utf = scm_c_take_bytevector ((signed char *) c_utf, \
+ c_utf_len); \
+ \
+ return (utf);
+
+
+
+SCM_DEFINE (scm_string_to_utf8, "string->utf8",
+ 1, 0, 0,
+ (SCM str),
+ "Return a newly allocated bytevector that contains the UTF-8 "
+ "encoding of @var{str}.")
+#define FUNC_NAME s_scm_string_to_utf8
+{
+ SCM utf;
+ char *c_str;
+ uint8_t *c_utf;
+ size_t c_strlen, c_raw_strlen;
+
+ SCM_VALIDATE_STRING (1, str);
+
+ c_strlen = scm_c_string_length (str);
+ c_raw_strlen = c_strlen;
+ do
+ {
+ c_str = (char *) alloca (c_raw_strlen + 1);
+ c_raw_strlen = scm_to_locale_stringbuf (str, c_str, c_strlen);
+ }
+ while (c_raw_strlen > c_strlen);
+ c_str[c_raw_strlen] = '\0';
+
+ c_utf = u8_strconv_from_locale (c_str);
+ if (SCM_UNLIKELY (c_utf == NULL))
+ scm_syserror (FUNC_NAME);
+ else
+ /* C_UTF is null-terminated. */
+ utf = scm_c_take_bytevector ((signed char *) c_utf,
+ UTF_STRLEN (8, c_utf));
+
+ return (utf);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_to_utf16, "string->utf16",
+ 1, 1, 0,
+ (SCM str, SCM endianness),
+ "Return a newly allocated bytevector that contains the UTF-16 "
+ "encoding of @var{str}.")
+#define FUNC_NAME s_scm_string_to_utf16
+{
+ STRING_TO_UTF (16);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_string_to_utf32, "string->utf32",
+ 1, 1, 0,
+ (SCM str, SCM endianness),
+ "Return a newly allocated bytevector that contains the UTF-32 "
+ "encoding of @var{str}.")
+#define FUNC_NAME s_scm_string_to_utf32
+{
+ STRING_TO_UTF (32);
+}
+#undef FUNC_NAME
+
+
+/* Produce the body of a function that converts a UTF-encoded bytevector to a
+ string. */
+#define UTF_TO_STRING(_utf_width) \
+ SCM str = SCM_BOOL_F; \
+ int err; \
+ char *c_str = NULL, *c_locale; \
+ char c_utf_name[MAX_UTF_ENCODING_NAME_LEN]; \
+ const char *c_utf; \
+ size_t c_strlen = 0, c_utf_len; \
+ \
+ SCM_VALIDATE_BYTEVECTOR (1, utf); \
+ if (endianness == SCM_UNDEFINED) \
+ endianness = scm_sym_big; \
+ else \
+ SCM_VALIDATE_SYMBOL (2, endianness); \
+ \
+ c_utf_len = SCM_BYTEVECTOR_LENGTH (utf); \
+ c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf); \
+ utf_encoding_name (c_utf_name, (_utf_width), endianness); \
+ \
+ c_locale = (char *) alloca (strlen (locale_charset ()) + 1); \
+ strcpy (c_locale, locale_charset ()); \
+ \
+ err = mem_iconveh (c_utf, c_utf_len, \
+ c_utf_name, c_locale, \
+ iconveh_question_mark, NULL, \
+ &c_str, &c_strlen); \
+ if (SCM_UNLIKELY (err)) \
+ scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A", \
+ scm_list_1 (utf), err); \
+ else \
+ /* C_STR is null-terminated. */ \
+ str = scm_take_locale_stringn (c_str, c_strlen); \
+ \
+ return (str);
+
+
+SCM_DEFINE (scm_utf8_to_string, "utf8->string",
+ 1, 0, 0,
+ (SCM utf),
+ "Return a newly allocate string that contains from the UTF-8-"
+ "encoded contents of bytevector @var{utf}.")
+#define FUNC_NAME s_scm_utf8_to_string
+{
+ SCM str;
+ int err;
+ char *c_str = NULL, *c_locale;
+ const char *c_utf;
+ size_t c_utf_len, c_strlen = 0;
+
+ SCM_VALIDATE_BYTEVECTOR (1, utf);
+
+ c_utf_len = SCM_BYTEVECTOR_LENGTH (utf);
+
+ c_locale = (char *) alloca (strlen (locale_charset ()) + 1);
+ strcpy (c_locale, locale_charset ());
+
+ c_utf = (char *) SCM_BYTEVECTOR_CONTENTS (utf);
+ err = mem_iconveh (c_utf, c_utf_len,
+ "UTF-8", c_locale,
+ iconveh_question_mark, NULL,
+ &c_str, &c_strlen);
+ if (SCM_UNLIKELY (err))
+ scm_syserror_msg (FUNC_NAME, "failed to convert to string: ~A",
+ scm_list_1 (utf), err);
+ else
+ /* C_STR is null-terminated. */
+ str = scm_take_locale_stringn (c_str, c_strlen);
+
+ return (str);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_utf16_to_string, "utf16->string",
+ 1, 1, 0,
+ (SCM utf, SCM endianness),
+ "Return a newly allocate string that contains from the UTF-16-"
+ "encoded contents of bytevector @var{utf}.")
+#define FUNC_NAME s_scm_utf16_to_string
+{
+ UTF_TO_STRING (16);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_utf32_to_string, "utf32->string",
+ 1, 1, 0,
+ (SCM utf, SCM endianness),
+ "Return a newly allocate string that contains from the UTF-32-"
+ "encoded contents of bytevector @var{utf}.")
+#define FUNC_NAME s_scm_utf32_to_string
+{
+ UTF_TO_STRING (32);
+}
+#undef FUNC_NAME
+
+
+
+/* Initialization. */
+
+void
+scm_bootstrap_bytevectors (void)
+{
+ /* The SMOB type must be instantiated here because the
+ generalized-vector API may want to access bytevectors even though
+ `(rnrs bytevector)' hasn't been loaded. */
+ scm_tc16_bytevector = scm_make_smob_type ("bytevector", 0);
+ scm_set_smob_free (scm_tc16_bytevector, free_bytevector);
+ scm_set_smob_print (scm_tc16_bytevector, print_bytevector);
+ scm_set_smob_equalp (scm_tc16_bytevector, bytevector_equal_p);
+
+ scm_null_bytevector =
+ scm_gc_protect_object (make_bytevector_from_buffer (0, NULL));
+
+#ifdef WORDS_BIGENDIAN
+ scm_i_native_endianness = scm_permanent_object (scm_from_locale_symbol ("big"));
+#else
+ scm_i_native_endianness = scm_permanent_object (scm_from_locale_symbol ("little"));
+#endif
+
+ scm_c_register_extension ("libguile", "scm_init_bytevectors",
+ (scm_t_extension_init_func) scm_init_bytevectors,
+ NULL);
+}
+
+void
+scm_init_bytevectors (void)
+{
+#include "libguile/bytevectors.x"
+
+ scm_endianness_big = scm_sym_big;
+ scm_endianness_little = scm_sym_little;
+}
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
new file mode 100644
index 000000000..cb2726251
--- /dev/null
+++ b/libguile/bytevectors.h
@@ -0,0 +1,146 @@
+#ifndef SCM_BYTEVECTORS_H
+#define SCM_BYTEVECTORS_H
+
+/* Copyright (C) 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#include "libguile/__scm.h"
+
+
+/* R6RS bytevectors. */
+
+#define SCM_BYTEVECTOR_LENGTH(_bv) \
+ ((size_t) SCM_SMOB_DATA (_bv))
+#define SCM_BYTEVECTOR_CONTENTS(_bv) \
+ (SCM_BYTEVECTOR_INLINE_P (_bv) \
+ ? (signed char *) SCM_SMOB_OBJECT_2_LOC (_bv) \
+ : (signed char *) SCM_SMOB_DATA_2 (_bv))
+
+
+SCM_API SCM scm_endianness_big;
+SCM_API SCM scm_endianness_little;
+
+SCM_API SCM scm_c_make_bytevector (size_t);
+SCM_API int scm_is_bytevector (SCM);
+SCM_API size_t scm_c_bytevector_length (SCM);
+SCM_API scm_t_uint8 scm_c_bytevector_ref (SCM, size_t);
+SCM_API void scm_c_bytevector_set_x (SCM, size_t, scm_t_uint8);
+
+SCM_API SCM scm_make_bytevector (SCM, SCM);
+SCM_API SCM scm_native_endianness (void);
+SCM_API SCM scm_bytevector_p (SCM);
+SCM_API SCM scm_bytevector_length (SCM);
+SCM_API SCM scm_bytevector_eq_p (SCM, SCM);
+SCM_API SCM scm_bytevector_fill_x (SCM, SCM);
+SCM_API SCM scm_bytevector_copy_x (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_copy (SCM);
+
+SCM_API SCM scm_uniform_array_to_bytevector (SCM);
+
+SCM_API SCM scm_bytevector_to_u8_list (SCM);
+SCM_API SCM scm_u8_list_to_bytevector (SCM);
+SCM_API SCM scm_uint_list_to_bytevector (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_to_uint_list (SCM, SCM, SCM);
+SCM_API SCM scm_sint_list_to_bytevector (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_to_sint_list (SCM, SCM, SCM);
+
+SCM_API SCM scm_bytevector_u16_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_s16_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_u32_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_s32_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_u64_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_s64_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_u8_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_s8_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_uint_ref (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_sint_ref (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u16_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s16_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u32_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s32_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u64_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s64_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u16_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s16_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u32_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s32_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u64_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s64_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u8_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s8_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_uint_set_x (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_sint_set_x (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u16_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s16_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u32_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s32_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_u64_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_s64_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_single_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_single_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_single_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_single_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_double_ref (SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_double_native_ref (SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_double_set_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_bytevector_ieee_double_native_set_x (SCM, SCM, SCM);
+SCM_API SCM scm_string_to_utf8 (SCM);
+SCM_API SCM scm_string_to_utf16 (SCM, SCM);
+SCM_API SCM scm_string_to_utf32 (SCM, SCM);
+SCM_API SCM scm_utf8_to_string (SCM);
+SCM_API SCM scm_utf16_to_string (SCM, SCM);
+SCM_API SCM scm_utf32_to_string (SCM, SCM);
+
+
+
+/* Internal API. */
+
+/* The threshold (in octets) under which bytevectors are stored "in-line",
+ i.e., without allocating memory beside the SMOB itself (a double cell).
+ This optimization is necessary since small bytevectors are expected to be
+ common. */
+#define SCM_BYTEVECTOR_P(_bv) \
+ SCM_SMOB_PREDICATE (scm_tc16_bytevector, _bv)
+#define SCM_BYTEVECTOR_INLINE_THRESHOLD (2 * sizeof (SCM))
+#define SCM_BYTEVECTOR_INLINEABLE_SIZE_P(_size) \
+ ((_size) <= SCM_BYTEVECTOR_INLINE_THRESHOLD)
+#define SCM_BYTEVECTOR_INLINE_P(_bv) \
+ (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (SCM_BYTEVECTOR_LENGTH (_bv)))
+
+/* Hint that is passed to `scm_gc_malloc ()' and friends. */
+#define SCM_GC_BYTEVECTOR "bytevector"
+
+SCM_INTERNAL void scm_bootstrap_bytevectors (void);
+SCM_INTERNAL void scm_init_bytevectors (void);
+
+SCM_INTERNAL scm_t_bits scm_tc16_bytevector;
+SCM_INTERNAL SCM scm_i_native_endianness;
+SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, size_t);
+
+#define scm_c_shrink_bytevector(_bv, _len) \
+ (SCM_BYTEVECTOR_INLINE_P (_bv) \
+ ? (_bv) \
+ : scm_i_shrink_bytevector ((_bv), (_len)))
+
+SCM_INTERNAL SCM scm_i_shrink_bytevector (SCM, size_t);
+SCM_INTERNAL void scm_i_bytevector_generalized_set_x (SCM, size_t, SCM);
+SCM_INTERNAL SCM scm_null_bytevector;
+
+#endif /* SCM_BYTEVECTORS_H */
diff --git a/libguile/chars.c b/libguile/chars.c
index 909e11d57..552a2d9c1 100644
--- a/libguile/chars.c
+++ b/libguile/chars.c
@@ -1,18 +1,19 @@
-/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -23,6 +24,8 @@
#include <ctype.h>
#include <limits.h>
+#include <unicase.h>
+
#include "libguile/_scm.h"
#include "libguile/validate.h"
@@ -54,7 +57,7 @@ SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr,
SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr,
(SCM x, SCM y),
- "Return @code{#t} iff @var{x} is less than @var{y} in the ASCII sequence,\n"
+ "Return @code{#t} iff @var{x} is less than @var{y} in the Unicode sequence,\n"
"else @code{#f}.")
#define FUNC_NAME s_scm_char_less_p
{
@@ -67,7 +70,7 @@ SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr,
SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return @code{#t} iff @var{x} is less than or equal to @var{y} in the\n"
- "ASCII sequence, else @code{#f}.")
+ "Unicode sequence, else @code{#f}.")
#define FUNC_NAME s_scm_char_leq_p
{
SCM_VALIDATE_CHAR (1, x);
@@ -78,7 +81,7 @@ SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr,
SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr,
(SCM x, SCM y),
- "Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n"
+ "Return @code{#t} iff @var{x} is greater than @var{y} in the Unicode\n"
"sequence, else @code{#f}.")
#define FUNC_NAME s_scm_char_gr_p
{
@@ -91,7 +94,7 @@ SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr,
SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n"
- "ASCII sequence, else @code{#f}.")
+ "Unicode sequence, else @code{#f}.")
#define FUNC_NAME s_scm_char_geq_p
{
SCM_VALIDATE_CHAR (1, x);
@@ -103,7 +106,7 @@ SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr,
SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr,
(SCM x, SCM y),
"Return @code{#t} iff @var{x} is the same character as @var{y} ignoring\n"
- "case, else @code{#f}.")
+ "case, else @code{#f}. Case is locale free and not context sensitive.")
#define FUNC_NAME s_scm_char_ci_eq_p
{
SCM_VALIDATE_CHAR (1, x);
@@ -114,8 +117,9 @@ SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr,
SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr,
(SCM x, SCM y),
- "Return @code{#t} iff @var{x} is less than @var{y} in the ASCII sequence\n"
- "ignoring case, else @code{#f}.")
+ "Return @code{#t} iff the Unicode uppercase form of @var{x} is less\n"
+ "than the Unicode uppercase form @var{y} in the Unicode sequence,\n"
+ "else @code{#f}.")
#define FUNC_NAME s_scm_char_ci_less_p
{
SCM_VALIDATE_CHAR (1, x);
@@ -126,8 +130,9 @@ SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr,
SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr,
(SCM x, SCM y),
- "Return @code{#t} iff @var{x} is less than or equal to @var{y} in the\n"
- "ASCII sequence ignoring case, else @code{#f}.")
+ "Return @code{#t} iff the Unicode uppercase form of @var{x} is less\n"
+ "than or equal to the Unicode uppercase form of @var{y} in the\n"
+ "Unicode sequence, else @code{#f}.")
#define FUNC_NAME s_scm_char_ci_leq_p
{
SCM_VALIDATE_CHAR (1, x);
@@ -138,8 +143,9 @@ SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr,
SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr,
(SCM x, SCM y),
- "Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n"
- "sequence ignoring case, else @code{#f}.")
+ "Return @code{#t} iff the Unicode uppercase form of @var{x} is greater\n"
+ "than the Unicode uppercase form of @var{y} in the Unicode\n"
+ "sequence, else @code{#f}.")
#define FUNC_NAME s_scm_char_ci_gr_p
{
SCM_VALIDATE_CHAR (1, x);
@@ -150,8 +156,9 @@ SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr,
SCM_DEFINE1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr,
(SCM x, SCM y),
- "Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n"
- "ASCII sequence ignoring case, else @code{#f}.")
+ "Return @code{#t} iff the Unicode uppercase form of @var{x} is greater\n"
+ "than or equal to the Unicode uppercase form of @var{y} in the\n"
+ "Unicode sequence, else @code{#f}.")
#define FUNC_NAME s_scm_char_ci_geq_p
{
SCM_VALIDATE_CHAR (1, x);
@@ -232,7 +239,7 @@ SCM_DEFINE (scm_char_to_integer, "char->integer", 1, 0, 0,
#define FUNC_NAME s_scm_char_to_integer
{
SCM_VALIDATE_CHAR (1, chr);
- return scm_from_ulong (SCM_CHAR(chr));
+ return scm_from_uint32 (SCM_CHAR(chr));
}
#undef FUNC_NAME
@@ -243,7 +250,15 @@ SCM_DEFINE (scm_integer_to_char, "integer->char", 1, 0, 0,
"Return the character at position @var{n} in the ASCII sequence.")
#define FUNC_NAME s_scm_integer_to_char
{
- return SCM_MAKE_CHAR (scm_to_uchar (n));
+ scm_t_wchar cn;
+
+ cn = scm_to_wchar (n);
+
+ /* Avoid the surrogates. */
+ if (!SCM_IS_UNICODE_CHAR (cn))
+ scm_out_of_range (FUNC_NAME, n);
+
+ return SCM_MAKE_CHAR (cn);
}
#undef FUNC_NAME
@@ -254,7 +269,7 @@ SCM_DEFINE (scm_char_upcase, "char-upcase", 1, 0, 0,
#define FUNC_NAME s_scm_char_upcase
{
SCM_VALIDATE_CHAR (1, chr);
- return SCM_MAKE_CHAR (toupper (SCM_CHAR (chr)));
+ return SCM_MAKE_CHAR (scm_c_upcase (SCM_CHAR (chr)));
}
#undef FUNC_NAME
@@ -265,7 +280,7 @@ SCM_DEFINE (scm_char_downcase, "char-downcase", 1, 0, 0,
#define FUNC_NAME s_scm_char_downcase
{
SCM_VALIDATE_CHAR (1, chr);
- return SCM_MAKE_CHAR (tolower (SCM_CHAR(chr)));
+ return SCM_MAKE_CHAR (scm_c_downcase (SCM_CHAR(chr)));
}
#undef FUNC_NAME
@@ -278,80 +293,121 @@ TODO: change name to scm_i_.. ? --hwn
*/
-int
-scm_c_upcase (unsigned int c)
+scm_t_wchar
+scm_c_upcase (scm_t_wchar c)
{
- if (c <= UCHAR_MAX)
- return toupper (c);
- else
+ if (c > 255)
return c;
+
+ return toupper ((int) c);
}
-int
-scm_c_downcase (unsigned int c)
+scm_t_wchar
+scm_c_downcase (scm_t_wchar c)
{
- if (c <= UCHAR_MAX)
- return tolower (c);
- else
+ if (c > 255)
return c;
+
+ return tolower ((int) c);
}
+
-#ifdef _DCC
-# define ASCII
-#else
-# if (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301'))
-# define EBCDIC
-# endif /* (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) */
-# if (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101'))
-# define ASCII
-# endif /* (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) */
-#endif /* def _DCC */
+/* There are a few sets of character names: R5RS, Guile
+ extensions for control characters, and leftover Guile extensions.
+ They are listed in order of precedence. */
+
+static const char *const scm_r5rs_charnames[] = {
+ "space", "newline"
+};
+
+static const scm_t_uint32 const scm_r5rs_charnums[] = {
+ 0x20, 0x0A
+};
+
+#define SCM_N_R5RS_CHARNAMES (sizeof (scm_r5rs_charnames) / sizeof (char *))
+
+/* The abbreviated names for control characters. */
+static const char *const scm_C0_control_charnames[] = {
+ /* C0 controls */
+ "nul", "soh", "stx", "etx", "eot", "enq", "ack", "bel",
+ "bs", "ht", "lf", "vt", "ff", "cr", "so", "si",
+ "dle", "dc1", "dc2", "dc3", "dc4", "nak", "syn", "etb",
+ "can", "em", "sub", "esc", "fs", "gs", "rs", "us",
+ "sp", "del"
+};
+
+static const scm_t_uint32 const scm_C0_control_charnums[] = {
+ 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07,
+ 0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f,
+ 0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17,
+ 0x18, 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f,
+ 0x20, 0x7f
+};
+
+#define SCM_N_C0_CONTROL_CHARNAMES (sizeof (scm_C0_control_charnames) / sizeof (char *))
+
+static const char *const scm_alt_charnames[] = {
+ "null", "backspace", "tab", "nl", "newline", "np", "page", "return",
+};
+
+static const scm_t_uint32 const scm_alt_charnums[] = {
+ 0x00, 0x08, 0x09, 0x0a, 0x0a, 0x0c, 0x0c, 0x0d
+};
+
+#define SCM_N_ALT_CHARNAMES (sizeof (scm_alt_charnames) / sizeof (char *))
+
+/* Returns the string charname for a character if it exists, or NULL
+ otherwise. */
+const char *
+scm_i_charname (SCM chr)
+{
+ size_t c;
+ scm_t_uint32 i = SCM_CHAR (chr);
+ for (c = 0; c < SCM_N_R5RS_CHARNAMES; c++)
+ if (scm_r5rs_charnums[c] == i)
+ return scm_r5rs_charnames[c];
-#ifdef EBCDIC
-char *const scm_charnames[] =
-{
- "nul", "soh", "stx", "etx", "pf", "ht", "lc", "del",
- 0 , 0 , "smm", "vt", "ff", "cr", "so", "si",
- "dle", "dc1", "dc2", "dc3", "res", "nl", "bs", "il",
- "can", "em", "cc", 0 , "ifs", "igs", "irs", "ius",
- "ds", "sos", "fs", 0 , "byp", "lf", "eob", "pre",
- 0 , 0 , "sm", 0 , 0 , "enq", "ack", "bel",
- 0 , 0 , "syn", 0 , "pn", "rs", "uc", "eot",
- 0 , 0 , 0 , 0 , "dc4", "nak", 0 , "sub",
- "space", scm_s_newline, "tab", "backspace", "return", "page", "null"};
-
-const char scm_charnums[] =
-"\000\001\002\003\004\005\006\007\
-\010\011\012\013\014\015\016\017\
-\020\021\022\023\024\025\026\027\
-\030\031\032\033\034\035\036\037\
-\040\041\042\043\044\045\046\047\
-\050\051\052\053\054\055\056\057\
-\060\061\062\063\064\065\066\067\
-\070\071\072\073\074\075\076\077\
- \n\t\b\r\f\0";
-#endif /* def EBCDIC */
-#ifdef ASCII
-char *const scm_charnames[] =
-{
- "nul","soh","stx","etx","eot","enq","ack","bel",
- "bs", "ht", "newline", "vt", "np", "cr", "so", "si",
- "dle","dc1","dc2","dc3","dc4","nak","syn","etb",
- "can", "em","sub","esc", "fs", "gs", "rs", "us",
- "space", "sp", "nl", "tab", "backspace", "return", "page", "null", "del"};
-const char scm_charnums[] =
-"\000\001\002\003\004\005\006\007\
-\010\011\012\013\014\015\016\017\
-\020\021\022\023\024\025\026\027\
-\030\031\032\033\034\035\036\037\
- \n\t\b\r\f\0\177";
-#endif /* def ASCII */
-
-int scm_n_charnames = sizeof (scm_charnames) / sizeof (char *);
+ for (c = 0; c < SCM_N_C0_CONTROL_CHARNAMES; c++)
+ if (scm_C0_control_charnums[c] == i)
+ return scm_C0_control_charnames[c];
+
+ for (c = 0; c < SCM_N_ALT_CHARNAMES; c++)
+ if (scm_alt_charnums[c] == i)
+ return scm_alt_charnames[i];
+ return NULL;
+}
+
+/* Return a character from a string charname. */
+SCM
+scm_i_charname_to_char (const char *charname, size_t charname_len)
+{
+ size_t c;
+
+ /* The R5RS charnames. These are supposed to be case
+ insensitive. */
+ for (c = 0; c < SCM_N_R5RS_CHARNAMES; c++)
+ if ((strlen (scm_r5rs_charnames[c]) == charname_len)
+ && (!strncasecmp (scm_r5rs_charnames[c], charname, charname_len)))
+ return SCM_MAKE_CHAR (scm_r5rs_charnums[c]);
+
+ /* Then come the controls. These are not case sensitive. */
+ for (c = 0; c < SCM_N_C0_CONTROL_CHARNAMES; c++)
+ if ((strlen (scm_C0_control_charnames[c]) == charname_len)
+ && (!strncasecmp (scm_C0_control_charnames[c], charname, charname_len)))
+ return SCM_MAKE_CHAR (scm_C0_control_charnums[c]);
+
+ /* Lastly are some old names carried over for compatibility. */
+ for (c = 0; c < SCM_N_ALT_CHARNAMES; c++)
+ if ((strlen (scm_alt_charnames[c]) == charname_len)
+ && (!strncasecmp (scm_alt_charnames[c], charname, charname_len)))
+ return SCM_MAKE_CHAR (scm_alt_charnums[c]);
+
+ return SCM_BOOL_F;
+}
diff --git a/libguile/chars.h b/libguile/chars.h
index 97c611af4..51adc21e5 100644
--- a/libguile/chars.h
+++ b/libguile/chars.h
@@ -3,39 +3,44 @@
#ifndef SCM_CHARS_H
#define SCM_CHARS_H
-/* Copyright (C) 1995,1996,2000,2001,2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,2000,2001,2004, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#include "libguile/__scm.h"
+#include "libguile/numbers.h"
/* Immediate Characters
*/
#define SCM_CHARP(x) (SCM_ITAG8(x) == scm_tc8_char)
-#define SCM_CHAR(x) ((unsigned int)SCM_ITAG8_DATA(x))
-#define SCM_MAKE_CHAR(x) SCM_MAKE_ITAG8((scm_t_bits) (unsigned char) (x), scm_tc8_char)
+#define SCM_CHAR(x) ((scm_t_wchar)SCM_ITAG8_DATA(x))
-
+#define SCM_MAKE_CHAR(x) \
+ ((scm_t_int32) (x) < 0 \
+ ? SCM_MAKE_ITAG8 ((scm_t_bits) (unsigned char) (x), scm_tc8_char) \
+ : SCM_MAKE_ITAG8 ((scm_t_bits) (x), scm_tc8_char))
-SCM_API char *const scm_charnames[];
-SCM_API int scm_n_charnames;
-SCM_API const char scm_charnums[];
+#define SCM_CODEPOINT_MAX (0x10ffff)
+#define SCM_IS_UNICODE_CHAR(c) \
+ ((scm_t_wchar) (c) <= 0xd7ff \
+ || ((scm_t_wchar) (c) >= 0xe000 && (scm_t_wchar) (c) <= SCM_CODEPOINT_MAX))
@@ -60,8 +65,11 @@ SCM_API SCM scm_char_to_integer (SCM chr);
SCM_API SCM scm_integer_to_char (SCM n);
SCM_API SCM scm_char_upcase (SCM chr);
SCM_API SCM scm_char_downcase (SCM chr);
-SCM_API int scm_c_upcase (unsigned int c);
-SCM_API int scm_c_downcase (unsigned int c);
+SCM_API scm_t_wchar scm_c_upcase (scm_t_wchar c);
+SCM_API scm_t_wchar scm_c_downcase (scm_t_wchar c);
+SCM_INTERNAL const char *scm_i_charname (SCM chr);
+SCM_INTERNAL SCM scm_i_charname_to_char (const char *charname,
+ size_t charname_len);
SCM_INTERNAL void scm_init_chars (void);
#endif /* SCM_CHARS_H */
diff --git a/libguile/continuations.c b/libguile/continuations.c
index 5c833e687..1957d754f 100644
--- a/libguile/continuations.c
+++ b/libguile/continuations.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1998,2000,2001,2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -85,8 +86,6 @@ scm_make_continuation (int *first)
continuation->root = thread->continuation_root;
continuation->dframe = scm_i_last_debug_frame ();
src = thread->continuation_base;
- SCM_NEWSMOB (cont, scm_tc16_continuation, continuation);
-
#if ! SCM_STACK_GROWS_UP
src -= stack_size;
#endif
@@ -94,6 +93,8 @@ scm_make_continuation (int *first)
memcpy (continuation->stack, src, sizeof (SCM_STACKITEM) * stack_size);
continuation->vm_conts = scm_vm_capture_continuations ();
+ SCM_NEWSMOB (cont, scm_tc16_continuation, continuation);
+
*first = !setjmp (continuation->jmpbuf);
if (*first)
{
diff --git a/libguile/continuations.h b/libguile/continuations.h
index e5fd91f2e..08eec8f54 100644
--- a/libguile/continuations.h
+++ b/libguile/continuations.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/convert.c b/libguile/convert.c
index 700deaa87..d87d72464 100644
--- a/libguile/convert.c
+++ b/libguile/convert.c
@@ -1,18 +1,19 @@
/* Copyright (C) 2002, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/convert.h b/libguile/convert.h
index f834a6b1d..6ce7c2274 100644
--- a/libguile/convert.h
+++ b/libguile/convert.h
@@ -6,18 +6,19 @@
/* Copyright (C) 2002, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/debug-malloc.c b/libguile/debug-malloc.c
index 4d04df5db..fa3612de2 100644
--- a/libguile/debug-malloc.c
+++ b/libguile/debug-malloc.c
@@ -1,18 +1,19 @@
/* Copyright (C) 2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
diff --git a/libguile/debug-malloc.h b/libguile/debug-malloc.h
index 1aa5221c6..7830adbac 100644
--- a/libguile/debug-malloc.h
+++ b/libguile/debug-malloc.h
@@ -6,18 +6,19 @@
/* Copyright (C) 2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/debug.c b/libguile/debug.c
index 62378921b..a214332d8 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -2,18 +2,19 @@
* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -21,6 +22,11 @@
# include <config.h>
#endif
+#ifdef HAVE_GETRLIMIT
+#include <sys/time.h>
+#include <sys/resource.h>
+#endif
+
#include "libguile/_scm.h"
#include "libguile/async.h"
#include "libguile/eval.h"
@@ -303,7 +309,7 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
SCM_VALIDATE_PROC (1, proc);
switch (SCM_TYP7 (proc)) {
case scm_tcs_subrs:
- return SCM_SNAME (proc);
+ return SCM_SUBR_NAME (proc);
default:
{
SCM name = scm_procedure_property (proc, scm_sym_name);
@@ -395,6 +401,21 @@ SCM_DEFINE (scm_procedure_environment, "procedure-environment", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_procedure_module, "procedure-module", 1, 0, 0,
+ (SCM proc),
+ "Return the module that was current when @var{proc} was defined.")
+#define FUNC_NAME s_scm_procedure_module
+{
+ SCM_VALIDATE_PROC (SCM_ARG1, proc);
+
+ if (scm_is_true (scm_program_p (proc)))
+ return scm_program_module (proc);
+ else
+ return scm_env_module (scm_procedure_environment (proc));
+}
+#undef FUNC_NAME
+
+
/* Eval in a local environment. We would like to have the ability to
@@ -513,11 +534,32 @@ SCM_DEFINE (scm_debug_hang, "debug-hang", 0, 1, 0,
#undef FUNC_NAME
#endif
+static void
+init_stack_limit (void)
+{
+#ifdef HAVE_GETRLIMIT
+ struct rlimit lim;
+ if (getrlimit (RLIMIT_STACK, &lim) == 0)
+ {
+ rlim_t bytes = lim.rlim_cur;
+
+ /* set our internal stack limit to 80% of the rlimit. */
+ if (bytes == RLIM_INFINITY)
+ bytes = lim.rlim_max;
+
+ if (bytes != RLIM_INFINITY)
+ SCM_STACK_LIMIT = bytes * 8 / 10 / sizeof (scm_t_bits);
+ }
+ errno = 0;
+#endif
+}
+
void
scm_init_debug ()
{
+ init_stack_limit ();
scm_init_opts (scm_debug_options, scm_debug_opts);
scm_tc16_memoized = scm_make_smob_type ("memoized", 0);
diff --git a/libguile/debug.h b/libguile/debug.h
index 4e94b3c15..20febdb71 100644
--- a/libguile/debug.h
+++ b/libguile/debug.h
@@ -7,18 +7,19 @@
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -140,6 +141,7 @@ SCM_API SCM scm_local_eval (SCM exp, SCM env);
SCM_API SCM scm_reverse_lookup (SCM env, SCM data);
SCM_API SCM scm_sys_start_stack (SCM info_id, SCM thunk);
SCM_API SCM scm_procedure_environment (SCM proc);
+SCM_API SCM scm_procedure_module (SCM proc);
SCM_API SCM scm_procedure_source (SCM proc);
SCM_API SCM scm_procedure_name (SCM proc);
SCM_API SCM scm_memoized_environment (SCM m);
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 979de84e1..57a2f0657 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -5,18 +5,19 @@
/* Copyright (C) 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 9a0862c3e..5b443c761 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -8,18 +8,19 @@
/* Copyright (C) 2003,2004, 2005, 2006, 2007 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#include "libguile/__scm.h"
diff --git a/libguile/deprecation.c b/libguile/deprecation.c
index 338c47c20..af8b93610 100644
--- a/libguile/deprecation.c
+++ b/libguile/deprecation.c
@@ -1,18 +1,19 @@
/* Copyright (C) 2001, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -41,8 +42,6 @@
-#if (SCM_ENABLE_DEPRECATED == 1)
-
struct issued_warning {
struct issued_warning *prev;
const char *message;
@@ -138,8 +137,6 @@ print_deprecation_summary (void)
}
}
-#endif /* SCM_ENABLE_DEPRECATED == 1 */
-
SCM_DEFINE(scm_include_deprecated_features,
"include-deprecated-features", 0, 0, 0,
(),
@@ -157,7 +154,6 @@ SCM_DEFINE(scm_include_deprecated_features,
void
scm_init_deprecation ()
{
-#if (SCM_ENABLE_DEPRECATED == 1)
const char *level = getenv ("GUILE_WARN_DEPRECATED");
if (level == NULL)
level = SCM_WARN_DEPRECATED_DEFAULT;
@@ -170,11 +166,11 @@ scm_init_deprecation ()
SCM_WARN_DEPRECATED = 0;
atexit (print_deprecation_summary);
}
-#endif
#include "libguile/deprecation.x"
}
/*
Local Variables:
c-file-style: "gnu"
- End: */
+ End:
+ */
diff --git a/libguile/deprecation.h b/libguile/deprecation.h
index 78853277b..06027c694 100644
--- a/libguile/deprecation.h
+++ b/libguile/deprecation.h
@@ -3,21 +3,22 @@
#ifndef SCM_DEPRECATION_H
#define SCM_DEPRECATION_H
-/* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -26,20 +27,14 @@
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-/* These functions are _not_ deprecated, but we exclude them along
- with the really deprecated features to be sure that no-one is
- trying to emit deprecation warnings when libguile is supposed to be
- clean of them.
-*/
+/* These functions are a possibly useful part of the API and not only used
+ internally, thus they are exported always, not depending on
+ SCM_ENABLE_DEPRECATED. */
SCM_API void scm_c_issue_deprecation_warning (const char *msg);
SCM_API void scm_c_issue_deprecation_warning_fmt (const char *msg, ...);
SCM_API SCM scm_issue_deprecation_warning (SCM msgs);
-#endif
-
SCM_API SCM scm_include_deprecated_features (void);
SCM_INTERNAL void scm_init_deprecation (void);
diff --git a/libguile/discouraged.c b/libguile/discouraged.c
index 9efd92a00..357cac875 100644
--- a/libguile/discouraged.c
+++ b/libguile/discouraged.c
@@ -5,18 +5,19 @@
/* Copyright (C) 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
diff --git a/libguile/discouraged.h b/libguile/discouraged.h
index 6e537bf1e..1be05f0bc 100644
--- a/libguile/discouraged.h
+++ b/libguile/discouraged.h
@@ -16,18 +16,19 @@
/* Copyright (C) 2004, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#include "libguile/__scm.h"
diff --git a/libguile/dynl.c b/libguile/dynl.c
index 1326b8bd4..dc98e7d17 100644
--- a/libguile/dynl.c
+++ b/libguile/dynl.c
@@ -4,18 +4,19 @@
* 2003, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/dynl.h b/libguile/dynl.h
index 72dc92ea4..eb318ae98 100644
--- a/libguile/dynl.h
+++ b/libguile/dynl.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1996,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/dynwind.c b/libguile/dynwind.c
index 40f94736b..b34f9bef3 100644
--- a/libguile/dynwind.c
+++ b/libguile/dynwind.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/dynwind.h b/libguile/dynwind.h
index dd39dae5a..b178bc429 100644
--- a/libguile/dynwind.h
+++ b/libguile/dynwind.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1998,1999,2000,2003,2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/environments.c b/libguile/environments.c
index 78ccd286d..fd4b88300 100644
--- a/libguile/environments.c
+++ b/libguile/environments.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1999,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/environments.h b/libguile/environments.h
index 2d8765a38..143963254 100644
--- a/libguile/environments.h
+++ b/libguile/environments.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1999,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/eq.c b/libguile/eq.c
index b54a7043a..255c381a0 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/eq.h b/libguile/eq.h
index af6959fe8..1aeb1c496 100644
--- a/libguile/eq.h
+++ b/libguile/eq.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/error.c b/libguile/error.c
index e18db9e82..eb513a74a 100644
--- a/libguile/error.c
+++ b/libguile/error.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/error.h b/libguile/error.h
index 042fb4d14..c777a7f44 100644
--- a/libguile/error.h
+++ b/libguile/error.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/eval.c b/libguile/eval.c
index a1b352d68..445c61f00 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -2,18 +2,19 @@
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -306,6 +307,9 @@ syntax_error (const char* const msg, const SCM form, const SCM expr)
{ if (SCM_UNLIKELY (!(cond))) \
syntax_error (message, form, expr); }
+static void error_unbound_variable (SCM symbol) SCM_NORETURN;
+static void error_defined_variable (SCM symbol) SCM_NORETURN;
+
/* {Ilocs}
@@ -706,6 +710,101 @@ is_system_macro_p (const SCM syntactic_keyword, const SCM form, const SCM env)
return 0;
}
+static SCM
+macroexp (SCM x, SCM env)
+{
+ SCM res, proc, orig_sym;
+
+ /* Don't bother to produce error messages here. We get them when we
+ eventually execute the code for real. */
+
+ macro_tail:
+ orig_sym = SCM_CAR (x);
+ if (!scm_is_symbol (orig_sym))
+ return x;
+
+ {
+ SCM *proc_ptr = scm_lookupcar1 (x, env, 0);
+ if (proc_ptr == NULL)
+ {
+ /* We have lost the race. */
+ goto macro_tail;
+ }
+ proc = *proc_ptr;
+ }
+
+ /* Only handle memoizing macros. `Acros' and `macros' are really
+ special forms and should not be evaluated here. */
+
+ if (!SCM_MACROP (proc)
+ || (SCM_MACRO_TYPE (proc) != 2 && !SCM_BUILTIN_MACRO_P (proc)))
+ return x;
+
+ SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */
+ res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
+
+ if (scm_ilength (res) <= 0)
+ /* Result of expansion is not a list. */
+ return (scm_list_2 (SCM_IM_BEGIN, res));
+ else
+ {
+ /* njrev: Several queries here: (1) I don't see how it can be
+ correct that the SCM_SETCAR 2 lines below this comment needs
+ protection, but the SCM_SETCAR 6 lines above does not, so
+ something here is probably wrong. (2) macroexp() is now only
+ used in one place - scm_m_generalized_set_x - whereas all other
+ macro expansion happens through expand_user_macros. Therefore
+ (2.1) perhaps macroexp() could be eliminated completely now?
+ (2.2) Does expand_user_macros need any critical section
+ protection? */
+
+ SCM_CRITICAL_SECTION_START;
+ SCM_SETCAR (x, SCM_CAR (res));
+ SCM_SETCDR (x, SCM_CDR (res));
+ SCM_CRITICAL_SECTION_END;
+
+ goto macro_tail;
+ }
+}
+
+
+/* Start of the memoizers for the standard R5RS builtin macros. */
+
+static SCM scm_m_quote (SCM xorig, SCM env);
+static SCM scm_m_begin (SCM xorig, SCM env);
+static SCM scm_m_if (SCM xorig, SCM env);
+static SCM scm_m_set_x (SCM xorig, SCM env);
+static SCM scm_m_and (SCM xorig, SCM env);
+static SCM scm_m_or (SCM xorig, SCM env);
+static SCM scm_m_case (SCM xorig, SCM env);
+static SCM scm_m_cond (SCM xorig, SCM env);
+static SCM scm_m_lambda (SCM xorig, SCM env);
+static SCM scm_m_letstar (SCM xorig, SCM env);
+static SCM scm_m_do (SCM xorig, SCM env);
+static SCM scm_m_quasiquote (SCM xorig, SCM env);
+static SCM scm_m_delay (SCM xorig, SCM env);
+static SCM scm_m_generalized_set_x (SCM xorig, SCM env);
+#if 0 /* Futures are disabled, see "futures.h". */
+static SCM scm_m_future (SCM xorig, SCM env);
+#endif
+static SCM scm_m_define (SCM x, SCM env);
+static SCM scm_m_letrec (SCM xorig, SCM env);
+static SCM scm_m_let (SCM xorig, SCM env);
+static SCM scm_m_at (SCM xorig, SCM env);
+static SCM scm_m_atat (SCM xorig, SCM env);
+static SCM scm_m_atslot_ref (SCM xorig, SCM env);
+static SCM scm_m_atslot_set_x (SCM xorig, SCM env);
+static SCM scm_m_apply (SCM xorig, SCM env);
+static SCM scm_m_cont (SCM xorig, SCM env);
+#if SCM_ENABLE_ELISP
+static SCM scm_m_nil_cond (SCM xorig, SCM env);
+static SCM scm_m_atfop (SCM xorig, SCM env);
+#endif /* SCM_ENABLE_ELISP */
+static SCM scm_m_atbind (SCM xorig, SCM env);
+static SCM scm_m_at_call_with_values (SCM xorig, SCM env);
+static SCM scm_m_eval_when (SCM xorig, SCM env);
+
+
static void
m_expand_body (const SCM forms, const SCM env)
{
@@ -828,70 +927,10 @@ m_expand_body (const SCM forms, const SCM env)
}
}
-static SCM
-macroexp (SCM x, SCM env)
-{
- SCM res, proc, orig_sym;
-
- /* Don't bother to produce error messages here. We get them when we
- eventually execute the code for real. */
-
- macro_tail:
- orig_sym = SCM_CAR (x);
- if (!scm_is_symbol (orig_sym))
- return x;
-
- {
- SCM *proc_ptr = scm_lookupcar1 (x, env, 0);
- if (proc_ptr == NULL)
- {
- /* We have lost the race. */
- goto macro_tail;
- }
- proc = *proc_ptr;
- }
-
- /* Only handle memoizing macros. `Acros' and `macros' are really
- special forms and should not be evaluated here. */
-
- if (!SCM_MACROP (proc)
- || (SCM_MACRO_TYPE (proc) != 2 && !SCM_BUILTIN_MACRO_P (proc)))
- return x;
-
- SCM_SETCAR (x, orig_sym); /* Undo memoizing effect of lookupcar */
- res = scm_call_2 (SCM_MACRO_CODE (proc), x, env);
-
- if (scm_ilength (res) <= 0)
- /* Result of expansion is not a list. */
- return (scm_list_2 (SCM_IM_BEGIN, res));
- else
- {
- /* njrev: Several queries here: (1) I don't see how it can be
- correct that the SCM_SETCAR 2 lines below this comment needs
- protection, but the SCM_SETCAR 6 lines above does not, so
- something here is probably wrong. (2) macroexp() is now only
- used in one place - scm_m_generalized_set_x - whereas all other
- macro expansion happens through expand_user_macros. Therefore
- (2.1) perhaps macroexp() could be eliminated completely now?
- (2.2) Does expand_user_macros need any critical section
- protection? */
-
- SCM_CRITICAL_SECTION_START;
- SCM_SETCAR (x, SCM_CAR (res));
- SCM_SETCDR (x, SCM_CDR (res));
- SCM_CRITICAL_SECTION_END;
-
- goto macro_tail;
- }
-}
-
-/* Start of the memoizers for the standard R5RS builtin macros. */
-
-
SCM_SYNTAX (s_and, "and", scm_i_makbimacro, scm_m_and);
SCM_GLOBAL_SYMBOL (scm_sym_and, s_and);
-SCM
+static SCM
scm_m_and (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -921,7 +960,7 @@ unmemoize_and (const SCM expr, const SCM env)
SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
-SCM
+static SCM
scm_m_begin (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -945,7 +984,7 @@ SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case);
SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);
SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
-SCM
+static SCM
scm_m_case (SCM expr, SCM env)
{
SCM clauses;
@@ -1041,7 +1080,7 @@ SCM_SYNTAX (s_cond, "cond", scm_i_makbimacro, scm_m_cond);
SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond);
SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
-SCM
+static SCM
scm_m_cond (SCM expr, SCM env)
{
/* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
@@ -1203,7 +1242,7 @@ canonicalize_define (const SCM expr)
operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
bound. This means that EXPRESSION won't necessarily be able to assign
values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
-SCM
+static SCM
scm_m_define (SCM expr, SCM env)
{
ASSERT_SYNTAX (SCM_TOP_LEVEL (env), s_bad_define, expr);
@@ -1258,7 +1297,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay);
* (delay <expression>) is transformed into (#@delay '() <expression>), where
* the empty list represents the empty parameter list. This representation
* allows for easy creation of the closure during evaluation. */
-SCM
+static SCM
scm_m_delay (SCM expr, SCM env)
{
const SCM new_expr = memoize_as_thunk_prototype (expr, env);
@@ -1301,7 +1340,7 @@ SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
(<body>)
<step1> <step2> ... <stepn>) ;; missing steps replaced by var
*/
-SCM
+static SCM
scm_m_do (SCM expr, SCM env SCM_UNUSED)
{
SCM variables = SCM_EOL;
@@ -1399,7 +1438,7 @@ unmemoize_do (const SCM expr, const SCM env)
SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if);
SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
-SCM
+static SCM
scm_m_if (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -1449,7 +1488,7 @@ c_improper_memq (SCM obj, SCM list)
return scm_is_eq (list, obj);
}
-SCM
+static SCM
scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
{
SCM formals;
@@ -1619,7 +1658,7 @@ memoize_named_let (const SCM expr, const SCM env SCM_UNUSED)
/* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
* i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
-SCM
+static SCM
scm_m_let (SCM expr, SCM env)
{
SCM bindings;
@@ -1693,7 +1732,7 @@ unmemoize_let (const SCM expr, const SCM env)
SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec);
SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
-SCM
+static SCM
scm_m_letrec (SCM expr, SCM env)
{
SCM bindings;
@@ -1744,7 +1783,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
/* (let* ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
* i1 .. in is transformed into the form (#@let* (v1 i1 v2 i2 ...) body). */
-SCM
+static SCM
scm_m_letstar (SCM expr, SCM env SCM_UNUSED)
{
SCM binding_idx;
@@ -1817,7 +1856,7 @@ unmemoize_letstar (const SCM expr, const SCM env)
SCM_SYNTAX (s_or, "or", scm_i_makbimacro, scm_m_or);
SCM_GLOBAL_SYMBOL (scm_sym_or, s_or);
-SCM
+static SCM
scm_m_or (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -1901,7 +1940,7 @@ iqq (SCM form, SCM env, unsigned long int depth)
return form;
}
-SCM
+static SCM
scm_m_quasiquote (SCM expr, SCM env)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -1914,7 +1953,7 @@ scm_m_quasiquote (SCM expr, SCM env)
SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
SCM_GLOBAL_SYMBOL (scm_sym_quote, s_quote);
-SCM
+static SCM
scm_m_quote (SCM expr, SCM env SCM_UNUSED)
{
SCM quotee;
@@ -1943,7 +1982,7 @@ SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x); */
static const char s_set_x[] = "set!";
SCM_GLOBAL_SYMBOL (scm_sym_set_x, s_set_x);
-SCM
+static SCM
scm_m_set_x (SCM expr, SCM env SCM_UNUSED)
{
SCM variable;
@@ -1973,14 +2012,57 @@ unmemoize_set_x (const SCM expr, const SCM env)
}
+
/* Start of the memoizers for non-R5RS builtin macros. */
+SCM_SYNTAX (s_at, "@", scm_makmmacro, scm_m_at);
+SCM_GLOBAL_SYMBOL (scm_sym_at, s_at);
+
+static SCM
+scm_m_at (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM mod, var;
+ ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr)), s_bad_expression, expr);
+
+ mod = scm_resolve_module (scm_cadr (expr));
+ if (scm_is_false (mod))
+ error_unbound_variable (expr);
+ var = scm_module_variable (scm_module_public_interface (mod), scm_caddr (expr));
+ if (scm_is_false (var))
+ error_unbound_variable (expr);
+
+ return var;
+}
+
+SCM_SYNTAX (s_atat, "@@", scm_makmmacro, scm_m_atat);
+SCM_GLOBAL_SYMBOL (scm_sym_atat, s_atat);
+
+static SCM
+scm_m_atat (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM mod, var;
+ ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_is_symbol (scm_caddr (expr)), s_bad_expression, expr);
+
+ mod = scm_resolve_module (scm_cadr (expr));
+ if (scm_is_false (mod))
+ error_unbound_variable (expr);
+ var = scm_module_variable (mod, scm_caddr (expr));
+ if (scm_is_false (var))
+ error_unbound_variable (expr);
+
+ return var;
+}
+
SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply);
SCM_GLOBAL_SYMBOL (scm_sym_atapply, s_atapply);
SCM_GLOBAL_SYMBOL (scm_sym_apply, s_atapply + 1);
-SCM
+static SCM
scm_m_apply (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -2017,7 +2099,7 @@ SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind);
*
* FIXME - also implement `@bind*'.
*/
-SCM
+static SCM
scm_m_atbind (SCM expr, SCM env)
{
SCM bindings;
@@ -2056,7 +2138,7 @@ scm_m_atbind (SCM expr, SCM env)
SCM_SYNTAX(s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);
SCM_GLOBAL_SYMBOL(scm_sym_atcall_cc, s_atcall_cc);
-SCM
+static SCM
scm_m_cont (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -2077,7 +2159,7 @@ unmemoize_atcall_cc (const SCM expr, const SCM env)
SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_at_call_with_values);
SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);
-SCM
+static SCM
scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED)
{
const SCM cdr_expr = SCM_CDR (expr);
@@ -2095,6 +2177,25 @@ unmemoize_at_call_with_values (const SCM expr, const SCM env)
unmemoize_exprs (SCM_CDR (expr), env));
}
+SCM_SYNTAX (s_eval_when, "eval-when", scm_makmmacro, scm_m_eval_when);
+SCM_GLOBAL_SYMBOL (scm_sym_eval_when, s_eval_when);
+SCM_SYMBOL (sym_eval, "eval");
+SCM_SYMBOL (sym_load, "load");
+
+
+static SCM
+scm_m_eval_when (SCM expr, SCM env SCM_UNUSED)
+{
+ ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (scm_cadr (expr)) > 0, s_bad_expression, expr);
+
+ if (scm_is_true (scm_memq (sym_eval, scm_cadr (expr)))
+ || scm_is_true (scm_memq (sym_load, scm_cadr (expr))))
+ return scm_cons (SCM_IM_BEGIN, scm_cddr (expr));
+
+ return scm_list_1 (SCM_IM_BEGIN);
+}
+
#if 0
/* See futures.h for a comment why futures are not enabled.
@@ -2108,7 +2209,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_future, s_future);
* (#@future '() <expression>), where the empty list represents the
* empty parameter list. This representation allows for easy creation
* of the closure during evaluation. */
-SCM
+static SCM
scm_m_future (SCM expr, SCM env)
{
const SCM new_expr = memoize_as_thunk_prototype (expr, env);
@@ -2128,7 +2229,7 @@ unmemoize_future (const SCM expr, const SCM env)
SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x);
SCM_SYMBOL (scm_sym_setter, "setter");
-SCM
+static SCM
scm_m_generalized_set_x (SCM expr, SCM env)
{
SCM target, exp_target;
@@ -2185,9 +2286,11 @@ scm_m_generalized_set_x (SCM expr, SCM env)
* arbitrary modules during the startup phase, the code from goops.c should be
* moved here. */
+SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref);
+SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x);
SCM_SYMBOL (sym_atslot_ref, "@slot-ref");
-SCM
+static SCM
scm_m_atslot_ref (SCM expr, SCM env SCM_UNUSED)
{
SCM slot_nr;
@@ -2220,7 +2323,7 @@ unmemoize_atslot_ref (const SCM expr, const SCM env)
SCM_SYMBOL (sym_atslot_set_x, "@slot-set!");
-SCM
+static SCM
scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED)
{
SCM slot_nr;
@@ -2258,7 +2361,7 @@ SCM_SYNTAX (s_nil_cond, "nil-cond", scm_i_makbimacro, scm_m_nil_cond);
/* nil-cond expressions have the form
* (nil-cond COND VAL COND VAL ... ELSEVAL) */
-SCM
+static SCM
scm_m_nil_cond (SCM expr, SCM env SCM_UNUSED)
{
const long length = scm_ilength (SCM_CDR (expr));
@@ -2281,7 +2384,7 @@ SCM_SYNTAX (s_atfop, "@fop", scm_i_makbimacro, scm_m_atfop);
* if the value of var (across all aliasing) is not a macro, or
* (<un-aliased var> <expr> ...)
* if var is a macro. */
-SCM
+static SCM
scm_m_atfop (SCM expr, SCM env SCM_UNUSED)
{
SCM location;
@@ -2452,20 +2555,11 @@ scm_i_unmemocopy_body (SCM forms, SCM env)
#if (SCM_ENABLE_DEPRECATED == 1)
-/* Deprecated in guile 1.7.0 on 2003-11-09. */
-SCM
-scm_m_expand_body (SCM exprs, SCM env)
-{
- scm_c_issue_deprecation_warning
- ("`scm_m_expand_body' is deprecated.");
- m_expand_body (exprs, env);
- return exprs;
-}
-
+static SCM scm_m_undefine (SCM expr, SCM env);
SCM_SYNTAX (s_undefine, "undefine", scm_makacro, scm_m_undefine);
-SCM
+static SCM
scm_m_undefine (SCM expr, SCM env)
{
SCM variable;
@@ -2489,55 +2583,10 @@ scm_m_undefine (SCM expr, SCM env)
return SCM_UNSPECIFIED;
}
-SCM
-scm_macroexp (SCM x, SCM env)
-{
- scm_c_issue_deprecation_warning
- ("`scm_macroexp' is deprecated.");
- return macroexp (x, env);
-}
-
-#endif
-
+#endif /* SCM_ENABLE_DEPRECATED */
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-SCM
-scm_unmemocar (SCM form, SCM env)
-{
- scm_c_issue_deprecation_warning
- ("`scm_unmemocar' is deprecated.");
-
- if (!scm_is_pair (form))
- return form;
- else
- {
- SCM c = SCM_CAR (form);
- if (SCM_VARIABLEP (c))
- {
- SCM sym = scm_module_reverse_lookup (scm_env_module (env), c);
- if (scm_is_false (sym))
- sym = sym_three_question_marks;
- SCM_SETCAR (form, sym);
- }
- else if (SCM_ILOCP (c))
- {
- unsigned long int ir;
-
- for (ir = SCM_IFRAME (c); ir != 0; --ir)
- env = SCM_CDR (env);
- env = SCM_CAAR (env);
- for (ir = SCM_IDIST (c); ir != 0; --ir)
- env = SCM_CDR (env);
-
- SCM_SETCAR (form, SCM_ICDRP (c) ? env : SCM_CAR (env));
- }
- return form;
- }
-}
-
-#endif
+
/*****************************************************************************/
/*****************************************************************************/
/* The definitions for execution start here. */
@@ -2662,9 +2711,6 @@ scm_ilookup (SCM iloc, SCM env)
SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
-static void error_unbound_variable (SCM symbol) SCM_NORETURN;
-static void error_defined_variable (SCM symbol) SCM_NORETURN;
-
/* Call this for variables that are unfound.
*/
static void
@@ -2967,8 +3013,19 @@ scm_t_option scm_debug_opts[] = {
{ SCM_OPTION_INTEGER, "depth", 20, "Maximal length of printed backtrace." },
{ SCM_OPTION_BOOLEAN, "backtrace", 0, "Show backtrace on error." },
{ SCM_OPTION_BOOLEAN, "debug", 0, "Use the debugging evaluator." },
+ /* This default stack limit will be overridden by debug.c:init_stack_limit(),
+ if we have getrlimit() and the stack limit is not INFINITY. But it is still
+ important, as some systems have both the soft and the hard limits set to
+ INFINITY; in that case we fall back to this value.
- { SCM_OPTION_INTEGER, "stack", 40000, "Stack size limit (measured in words; 0 = no check)." },
+ The situation is aggravated by certain compilers, which can consume
+ "beaucoup de stack", as they say in France.
+
+ See http://thread.gmane.org/gmane.lisp.guile.devel/8599/focus=8662 for
+ more discussion. This setting is 640 KB on 32-bit arches (should be enough
+ for anyone!) or a whoppin' 1280 KB on 64-bit arches.
+ */
+ { SCM_OPTION_INTEGER, "stack", 160000, "Stack size limit (measured in words; 0 = no check)." },
{ SCM_OPTION_SCM, "show-file-name", (unsigned long)SCM_BOOL_T,
"Show file names and line numbers "
"in backtraces when not `#f'. A value of `base' "
@@ -3324,7 +3381,7 @@ call_dsubr_1 (SCM proc, SCM arg1)
return (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
}
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
- SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc)));
+ SCM_ARG1, scm_i_symbol_chars (SCM_SUBR_NAME (proc)));
}
static SCM
@@ -4056,11 +4113,12 @@ SCM_DEFINE (scm_eval, "eval", 2, 0, 0,
scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
if (scm_is_dynamic_state (module_or_state))
scm_dynwind_current_dynamic_state (module_or_state);
- else
+ else if (scm_module_system_booted_p)
{
SCM_VALIDATE_MODULE (2, module_or_state);
scm_dynwind_current_module (module_or_state);
}
+ /* otherwise if the module system isn't booted, ignore the module arg */
res = scm_primitive_eval (exp);
diff --git a/libguile/eval.h b/libguile/eval.h
index 333265263..4467358f5 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -3,22 +3,23 @@
#ifndef SCM_EVAL_H
#define SCM_EVAL_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004,2008
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002,2003,2004,2008,2009
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -94,10 +95,13 @@ SCM_API SCM scm_sym_quasiquote;
SCM_API SCM scm_sym_unquote;
SCM_API SCM scm_sym_uq_splicing;
+SCM_API SCM scm_sym_at;
+SCM_API SCM scm_sym_atat;
SCM_API SCM scm_sym_atapply;
SCM_API SCM scm_sym_atcall_cc;
SCM_API SCM scm_sym_at_call_with_values;
SCM_API SCM scm_sym_delay;
+SCM_API SCM scm_sym_eval_when;
SCM_API SCM scm_sym_arrow;
SCM_API SCM scm_sym_else;
SCM_API SCM scm_sym_apply;
@@ -111,37 +115,6 @@ SCM_API SCM * scm_lookupcar (SCM vloc, SCM genv, int check);
SCM_API SCM scm_eval_car (SCM pair, SCM env);
SCM_API SCM scm_eval_body (SCM code, SCM env);
SCM_API SCM scm_eval_args (SCM i, SCM env, SCM proc);
-SCM_API SCM scm_m_quote (SCM xorig, SCM env);
-SCM_API SCM scm_m_begin (SCM xorig, SCM env);
-SCM_API SCM scm_m_if (SCM xorig, SCM env);
-SCM_API SCM scm_m_set_x (SCM xorig, SCM env);
-SCM_API SCM scm_m_vref (SCM xorig, SCM env);
-SCM_API SCM scm_m_vset (SCM xorig, SCM env);
-SCM_API SCM scm_m_and (SCM xorig, SCM env);
-SCM_API SCM scm_m_or (SCM xorig, SCM env);
-SCM_API SCM scm_m_case (SCM xorig, SCM env);
-SCM_API SCM scm_m_cond (SCM xorig, SCM env);
-SCM_API SCM scm_m_lambda (SCM xorig, SCM env);
-SCM_API SCM scm_m_letstar (SCM xorig, SCM env);
-SCM_API SCM scm_m_do (SCM xorig, SCM env);
-SCM_API SCM scm_m_quasiquote (SCM xorig, SCM env);
-SCM_API SCM scm_m_delay (SCM xorig, SCM env);
-SCM_API SCM scm_m_generalized_set_x (SCM xorig, SCM env);
-SCM_API SCM scm_m_future (SCM xorig, SCM env);
-SCM_API SCM scm_m_define (SCM x, SCM env);
-SCM_API SCM scm_m_letrec (SCM xorig, SCM env);
-SCM_API SCM scm_m_let (SCM xorig, SCM env);
-SCM_API SCM scm_m_apply (SCM xorig, SCM env);
-SCM_API SCM scm_m_cont (SCM xorig, SCM env);
-#if SCM_ENABLE_ELISP
-SCM_API SCM scm_m_nil_cond (SCM xorig, SCM env);
-SCM_API SCM scm_m_atfop (SCM xorig, SCM env);
-#endif /* SCM_ENABLE_ELISP */
-SCM_API SCM scm_m_atbind (SCM xorig, SCM env);
-SCM_API SCM scm_m_atslot_ref (SCM xorig, SCM env);
-SCM_API SCM scm_m_atslot_set_x (SCM xorig, SCM env);
-SCM_API SCM scm_m_atdispatch (SCM xorig, SCM env);
-SCM_API SCM scm_m_at_call_with_values (SCM xorig, SCM env);
SCM_API int scm_badargsp (SCM formals, SCM args);
SCM_API SCM scm_call_0 (SCM proc);
SCM_API SCM scm_call_1 (SCM proc, SCM arg1);
@@ -183,15 +156,6 @@ SCM_INTERNAL void scm_init_eval (void);
#if (SCM_ENABLE_DEPRECATED == 1)
-SCM_API SCM scm_m_undefine (SCM x, SCM env);
-
-/* Deprecated in guile 1.7.0 on 2003-11-09. */
-SCM_API SCM scm_m_expand_body (SCM xorig, SCM env);
-
-/* Deprecated in guile 1.7.0 on 2003-11-16. */
-SCM_API SCM scm_unmemocar (SCM form, SCM env);
-SCM_API SCM scm_macroexp (SCM x, SCM env);
-
/* Deprecated in guile 1.7.0 on 2004-03-29. */
SCM_API SCM scm_ceval (SCM x, SCM env);
SCM_API SCM scm_deval (SCM x, SCM env);
diff --git a/libguile/eval.i.c b/libguile/eval.i.c
index 573a7b5fb..99aa265de 100644
--- a/libguile/eval.i.c
+++ b/libguile/eval.i.c
@@ -4,18 +4,19 @@
* Copyright (C) 2002, 03, 04, 05, 06, 07, 09 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#undef RETURN
@@ -1237,7 +1238,7 @@ dispatch:
}
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
SCM_ARG1,
- scm_i_symbol_chars (SCM_SNAME (proc)));
+ scm_i_symbol_chars (SCM_SUBR_NAME (proc)));
case scm_tc7_cxr:
RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc)));
case scm_tc7_rpsubr:
@@ -1764,7 +1765,7 @@ tail:
RETURN (scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1))));
}
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
- SCM_ARG1, scm_i_symbol_chars (SCM_SNAME (proc)));
+ SCM_ARG1, scm_i_symbol_chars (SCM_SUBR_NAME (proc)));
case scm_tc7_cxr:
if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args)))
scm_wrong_num_args (proc);
diff --git a/libguile/evalext.c b/libguile/evalext.c
index 5ca78066d..19d8f2e02 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -30,49 +31,23 @@
#include "libguile/evalext.h"
SCM_DEFINE (scm_defined_p, "defined?", 1, 1, 0,
- (SCM sym, SCM env),
- "Return @code{#t} if @var{sym} is defined in the lexical "
- "environment @var{env}. When @var{env} is not specified, "
- "look in the top-level environment as defined by the "
- "current module.")
+ (SCM sym, SCM module),
+ "Return @code{#t} if @var{sym} is defined in the module "
+ "@var{module} or the current module when @var{module} is not"
+ "specified.")
#define FUNC_NAME s_scm_defined_p
{
SCM var;
SCM_VALIDATE_SYMBOL (1, sym);
- if (SCM_UNBNDP (env))
- var = scm_sym2var (sym, scm_current_module_lookup_closure (),
- SCM_BOOL_F);
+ if (SCM_UNBNDP (module))
+ module = scm_current_module ();
else
- {
- SCM frames = env;
- register SCM b;
- for (; SCM_NIMP (frames); frames = SCM_CDR (frames))
- {
- SCM_ASSERT (scm_is_pair (frames), env, SCM_ARG2, FUNC_NAME);
- b = SCM_CAR (frames);
- if (scm_is_true (scm_procedure_p (b)))
- break;
- SCM_ASSERT (scm_is_pair (b), env, SCM_ARG2, FUNC_NAME);
- for (b = SCM_CAR (b); SCM_NIMP (b); b = SCM_CDR (b))
- {
- if (!scm_is_pair (b))
- {
- if (scm_is_eq (b, sym))
- return SCM_BOOL_T;
- else
- break;
- }
- if (scm_is_eq (SCM_CAR (b), sym))
- return SCM_BOOL_T;
- }
- }
- var = scm_sym2var (sym,
- SCM_NIMP (frames) ? SCM_CAR (frames) : SCM_BOOL_F,
- SCM_BOOL_F);
- }
-
+ SCM_VALIDATE_MODULE (2, module);
+
+ var = scm_module_variable (module, sym);
+
return (scm_is_false (var) || SCM_UNBNDP (SCM_VARIABLE_REF (var))
? SCM_BOOL_F
: SCM_BOOL_T);
diff --git a/libguile/evalext.h b/libguile/evalext.h
index a6a4a9fdc..fc3f1e617 100644
--- a/libguile/evalext.h
+++ b/libguile/evalext.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1998,1999,2000, 2003, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/extensions.c b/libguile/extensions.c
index 1090b8bd5..54351dd9c 100644
--- a/libguile/extensions.c
+++ b/libguile/extensions.c
@@ -3,18 +3,19 @@
* Copyright (C) 2001, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
@@ -76,6 +77,7 @@ load_extension (SCM lib, SCM init)
{
extension_t *ext;
char *clib, *cinit;
+ int found = 0;
scm_dynwind_begin (0);
@@ -89,10 +91,14 @@ load_extension (SCM lib, SCM init)
&& !strcmp (ext->init, cinit))
{
ext->func (ext->data);
+ found = 1;
break;
}
scm_dynwind_end ();
+
+ if (found)
+ return;
}
/* Dynamically link the library. */
diff --git a/libguile/extensions.h b/libguile/extensions.h
index 596b43ae0..765f9bee1 100644
--- a/libguile/extensions.h
+++ b/libguile/extensions.h
@@ -6,18 +6,19 @@
/* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -26,6 +27,8 @@
+typedef void (*scm_t_extension_init_func)(void*);
+
SCM_API void scm_c_register_extension (const char *lib, const char *init,
void (*func) (void *), void *data);
diff --git a/libguile/feature.c b/libguile/feature.c
index 8283cd6f5..9ef4b658e 100644
--- a/libguile/feature.c
+++ b/libguile/feature.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2004, 2006, 2007 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/feature.h b/libguile/feature.h
index 8c6371e94..d373bc773 100644
--- a/libguile/feature.h
+++ b/libguile/feature.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2007, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/filesys.c b/libguile/filesys.c
index ec33328b1..a2db6996f 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2002, 2004, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -29,6 +30,7 @@
#endif
#include <alloca.h>
+#include <canonicalize.h>
#include <stdio.h>
#include <errno.h>
@@ -580,17 +582,23 @@ static int fstat_Win32 (int fdes, struct stat *buf)
}
#endif /* __MINGW32__ */
-SCM_DEFINE (scm_stat, "stat", 1, 0, 0,
- (SCM object),
+SCM_DEFINE (scm_stat, "stat", 1, 1, 0,
+ (SCM object, SCM exception_on_error),
"Return an object containing various information about the file\n"
"determined by @var{obj}. @var{obj} can be a string containing\n"
"a file name or a port or integer file descriptor which is open\n"
"on a file (in which case @code{fstat} is used as the underlying\n"
"system call).\n"
"\n"
- "The object returned by @code{stat} can be passed as a single\n"
- "parameter to the following procedures, all of which return\n"
- "integers:\n"
+ "If the optional @var{exception_on_error} argument is true, which\n"
+ "is the default, an exception will be raised if the underlying\n"
+ "system call returns an error, for example if the file is not\n"
+ "found or is not readable. Otherwise, an error will cause\n"
+ "@code{stat} to return @code{#f}."
+ "\n"
+ "The object returned by a successful call to @code{stat} can be\n"
+ "passed as a single parameter to the following procedures, all of\n"
+ "which return integers:\n"
"\n"
"@table @code\n"
"@item stat:dev\n"
@@ -678,12 +686,16 @@ SCM_DEFINE (scm_stat, "stat", 1, 0, 0,
if (rv == -1)
{
- int en = errno;
-
- SCM_SYSERROR_MSG ("~A: ~S",
- scm_list_2 (scm_strerror (scm_from_int (en)),
- object),
- en);
+ if (SCM_UNBNDP (exception_on_error) || scm_is_true (exception_on_error))
+ {
+ int en = errno;
+ SCM_SYSERROR_MSG ("~A: ~S",
+ scm_list_2 (scm_strerror (scm_from_int (en)),
+ object),
+ en);
+ }
+ else
+ return SCM_BOOL_F;
}
return scm_stat2scm (&stat_temp);
}
@@ -1650,6 +1662,27 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_canonicalize_path, "canonicalize-path", 1, 0, 0,
+ (SCM path),
+ "Return the canonical path of @var{path}. A canonical path has\n"
+ "no @code{.} or @code{..} components, nor any repeated path\n"
+ "separators (@code{/}) nor symlinks.\n\n"
+ "Raises an error if any component of @var{path} does not exist.")
+#define FUNC_NAME s_scm_canonicalize_path
+{ char *str, *canon;
+
+ SCM_VALIDATE_STRING (1, path);
+
+ str = scm_to_locale_string (path);
+ canon = canonicalize_file_name (str);
+ free (str);
+
+ if (canon)
+ return scm_take_locale_string (canon);
+ else
+ SCM_SYSERROR;
+}
+#undef FUNC_NAME
diff --git a/libguile/filesys.h b/libguile/filesys.h
index a38a5b594..b9a6ca8a6 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -42,7 +43,7 @@ SCM_API SCM scm_open_fdes (SCM path, SCM flags, SCM mode);
SCM_API SCM scm_open (SCM path, SCM flags, SCM mode);
SCM_API SCM scm_close (SCM fd_or_port);
SCM_API SCM scm_close_fdes (SCM fd);
-SCM_API SCM scm_stat (SCM object);
+SCM_API SCM scm_stat (SCM object, SCM exception_on_error);
SCM_API SCM scm_link (SCM oldpath, SCM newpath);
SCM_API SCM scm_rename (SCM oldname, SCM newname);
SCM_API SCM scm_delete_file (SCM str);
@@ -64,6 +65,7 @@ SCM_API SCM scm_lstat (SCM str);
SCM_API SCM scm_copy_file (SCM oldfile, SCM newfile);
SCM_API SCM scm_dirname (SCM filename);
SCM_API SCM scm_basename (SCM filename, SCM suffix);
+SCM_API SCM scm_canonicalize_path (SCM path);
SCM_INTERNAL void scm_init_filesys (void);
diff --git a/libguile/fluids.c b/libguile/fluids.c
index 02eff9f20..75dcccf75 100644
--- a/libguile/fluids.c
+++ b/libguile/fluids.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1996,1997,2000,2001, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
diff --git a/libguile/fluids.h b/libguile/fluids.h
index c88ffa88f..2bfcce52f 100644
--- a/libguile/fluids.h
+++ b/libguile/fluids.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1996,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/fports.c b/libguile/fports.c
index ab4538028..00a727870 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -1,18 +1,19 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -616,8 +617,8 @@ fport_fill_input (SCM port)
}
}
-static off_t_or_off64_t
-fport_seek_or_seek64 (SCM port, off_t_or_off64_t offset, int whence)
+static scm_t_off
+fport_seek (SCM port, scm_t_off offset, int whence)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
scm_t_fport *fp = SCM_FSTREAM (port);
@@ -668,41 +669,8 @@ fport_seek_or_seek64 (SCM port, off_t_or_off64_t offset, int whence)
return result;
}
-/* If we've got largefile and off_t isn't already off64_t then
- fport_seek_or_seek64 needs a range checking wrapper to be fport_seek in
- the port descriptor.
-
- Otherwise if no largefile, or off_t is the same as off64_t (which is the
- case on NetBSD apparently), then fport_seek_or_seek64 is right to be
- fport_seek already. */
-
-#if GUILE_USE_64_CALLS && HAVE_STAT64 && SIZEOF_OFF_T != SIZEOF_OFF64_T
-static off_t
-fport_seek (SCM port, off_t offset, int whence)
-{
- off64_t rv = fport_seek_or_seek64 (port, (off64_t) offset, whence);
- if (rv > OFF_T_MAX || rv < OFF_T_MIN)
- {
- errno = EOVERFLOW;
- scm_syserror ("fport_seek");
- }
- return (off_t) rv;
-
-}
-#else
-#define fport_seek fport_seek_or_seek64
-#endif
-
-/* `how' has been validated and is one of SEEK_SET, SEEK_CUR or SEEK_END */
-SCM
-scm_i_fport_seek (SCM port, SCM offset, int how)
-{
- return scm_from_off_t_or_off64_t
- (fport_seek_or_seek64 (port, scm_to_off_t_or_off64_t (offset), how));
-}
-
static void
-fport_truncate (SCM port, off_t length)
+fport_truncate (SCM port, scm_t_off length)
{
scm_t_fport *fp = SCM_FSTREAM (port);
@@ -710,13 +678,6 @@ fport_truncate (SCM port, off_t length)
scm_syserror ("ftruncate");
}
-int
-scm_i_fport_truncate (SCM port, SCM length)
-{
- scm_t_fport *fp = SCM_FSTREAM (port);
- return ftruncate_or_ftruncate64 (fp->fdes, scm_to_off_t_or_off64_t (length));
-}
-
/* helper for fport_write: try to write data, using multiple system
calls if required. */
#define FUNC_NAME "write_all"
@@ -754,7 +715,7 @@ fport_write (SCM port, const void *data, size_t size)
}
{
- off_t space = pt->write_end - pt->write_pos;
+ scm_t_off space = pt->write_end - pt->write_pos;
if (size <= space)
{
diff --git a/libguile/fports.h b/libguile/fports.h
index c737b1eaa..cbef0f8ec 100644
--- a/libguile/fports.h
+++ b/libguile/fports.h
@@ -3,21 +3,22 @@
#ifndef SCM_FPORTS_H
#define SCM_FPORTS_H
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -58,8 +59,6 @@ SCM_INTERNAL void scm_init_fports (void);
/* internal functions */
SCM_INTERNAL SCM scm_i_fdes_to_port (int fdes, long mode_bits, SCM name);
-SCM_INTERNAL int scm_i_fport_truncate (SCM, SCM);
-SCM_INTERNAL SCM scm_i_fport_seek (SCM, SCM, int);
#endif /* SCM_FPORTS_H */
diff --git a/libguile/frames.c b/libguile/frames.c
index 3452caf5c..caa95f7d9 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -1,49 +1,28 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
#if HAVE_CONFIG_H
# include <config.h>
#endif
+#include <stdlib.h>
#include <string.h>
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "frames.h"
@@ -230,16 +209,6 @@ SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0,
}
#undef FUNC_NAME
-SCM_DEFINE (scm_vm_frame_external_link, "vm-frame-external-link", 1, 0, 0,
- (SCM frame),
- "")
-#define FUNC_NAME s_scm_vm_frame_external_link
-{
- SCM_VALIDATE_VM_FRAME (1, frame);
- return SCM_FRAME_EXTERNAL_LINK (SCM_VM_FRAME_FP (frame));
-}
-#undef FUNC_NAME
-
SCM_DEFINE (scm_vm_frame_stack, "vm-frame-stack", 1, 0, 0,
(SCM frame),
"")
@@ -282,6 +251,8 @@ scm_bootstrap_frames (void)
{
scm_tc16_vm_frame = scm_make_smob_type ("vm-frame", 0);
scm_set_smob_print (scm_tc16_vm_frame, vm_frame_print);
+ scm_c_register_extension ("libguile", "scm_init_frames",
+ (scm_t_extension_init_func)scm_init_frames, NULL);
}
void
diff --git a/libguile/frames.h b/libguile/frames.h
index 836763700..1b3153a3e 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -1,43 +1,20 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+ * *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
#ifndef _SCM_FRAMES_H_
#define _SCM_FRAMES_H_
@@ -53,12 +30,11 @@
/* VM Frame Layout
---------------
- | | <- fp + bp->nargs + bp->nlocs + 4
+ | | <- fp + bp->nargs + bp->nlocs + 3
+------------------+ = SCM_FRAME_UPPER_ADDRESS (fp)
| Return address |
| MV return address|
- | Dynamic link |
- | External link | <- fp + bp->nargs + bp->nlocs
+ | Dynamic link | <- fp + bp->nargs + bp->blocs
| Local variable 1 | = SCM_FRAME_DATA_ADDRESS (fp)
| Local variable 0 | <- fp + bp->nargs
| Argument 1 |
@@ -74,21 +50,20 @@
#define SCM_FRAME_DATA_ADDRESS(fp) \
(fp + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \
+ SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs)
-#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 4)
+#define SCM_FRAME_UPPER_ADDRESS(fp) (SCM_FRAME_DATA_ADDRESS (fp) + 3)
#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 1)
#define SCM_FRAME_BYTE_CAST(x) ((scm_byte_t *) SCM_UNPACK (x))
#define SCM_FRAME_STACK_CAST(x) ((SCM *) SCM_UNPACK (x))
#define SCM_FRAME_RETURN_ADDRESS(fp) \
- (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[3]))
-#define SCM_FRAME_MV_RETURN_ADDRESS(fp) \
(SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[2]))
+#define SCM_FRAME_MV_RETURN_ADDRESS(fp) \
+ (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1]))
#define SCM_FRAME_DYNAMIC_LINK(fp) \
- (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1]))
+ (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0]))
#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \
- ((SCM_FRAME_DATA_ADDRESS (fp)[1])) = (SCM)(dl);
-#define SCM_FRAME_EXTERNAL_LINK(fp) (SCM_FRAME_DATA_ADDRESS (fp)[0])
+ ((SCM_FRAME_DATA_ADDRESS (fp)[0])) = (SCM)(dl);
#define SCM_FRAME_VARIABLE(fp,i) fp[i]
#define SCM_FRAME_PROGRAM(fp) fp[-1]
@@ -97,7 +72,7 @@
* Heap frames
*/
-extern scm_t_bits scm_tc16_vm_frame;
+SCM_API scm_t_bits scm_tc16_vm_frame;
struct scm_vm_frame
{
@@ -118,24 +93,23 @@ struct scm_vm_frame
#define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P)
/* FIXME rename scm_byte_t */
-extern SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
+SCM_API SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp,
scm_byte_t *ip, scm_t_ptrdiff offset);
-extern SCM scm_vm_frame_p (SCM obj);
-extern SCM scm_vm_frame_program (SCM frame);
-extern SCM scm_vm_frame_arguments (SCM frame);
-extern SCM scm_vm_frame_source (SCM frame);
-extern SCM scm_vm_frame_local_ref (SCM frame, SCM index);
-extern SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val);
-extern SCM scm_vm_frame_return_address (SCM frame);
-extern SCM scm_vm_frame_mv_return_address (SCM frame);
-extern SCM scm_vm_frame_dynamic_link (SCM frame);
-extern SCM scm_vm_frame_external_link (SCM frame);
-extern SCM scm_vm_frame_stack (SCM frame);
-
-extern SCM scm_c_vm_frame_prev (SCM frame);
-
-extern void scm_bootstrap_frames (void);
-extern void scm_init_frames (void);
+SCM_API SCM scm_vm_frame_p (SCM obj);
+SCM_API SCM scm_vm_frame_program (SCM frame);
+SCM_API SCM scm_vm_frame_arguments (SCM frame);
+SCM_API SCM scm_vm_frame_source (SCM frame);
+SCM_API SCM scm_vm_frame_local_ref (SCM frame, SCM index);
+SCM_API SCM scm_vm_frame_local_set_x (SCM frame, SCM index, SCM val);
+SCM_API SCM scm_vm_frame_return_address (SCM frame);
+SCM_API SCM scm_vm_frame_mv_return_address (SCM frame);
+SCM_API SCM scm_vm_frame_dynamic_link (SCM frame);
+SCM_API SCM scm_vm_frame_stack (SCM frame);
+
+SCM_API SCM scm_c_vm_frame_prev (SCM frame);
+
+SCM_INTERNAL void scm_bootstrap_frames (void);
+SCM_INTERNAL void scm_init_frames (void);
#endif /* _SCM_FRAMES_H_ */
diff --git a/libguile/futures.c b/libguile/futures.c
index 1bba960b3..b330f4ded 100644
--- a/libguile/futures.c
+++ b/libguile/futures.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/futures.h b/libguile/futures.h
index 95916f33b..5d7712e1a 100644
--- a/libguile/futures.h
+++ b/libguile/futures.h
@@ -6,18 +6,19 @@
/* Copyright (C) 2002, 2003, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c
index 6839ba832..19d68781a 100644
--- a/libguile/gc-malloc.c
+++ b/libguile/gc-malloc.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/gc-segment-table.c b/libguile/gc-segment-table.c
index 3e92c8c5c..75d109c85 100644
--- a/libguile/gc-segment-table.c
+++ b/libguile/gc-segment-table.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
diff --git a/libguile/gc.c b/libguile/gc.c
index 8020c2180..cef9b3f6f 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
/* #define DEBUGINFO */
diff --git a/libguile/gc.h b/libguile/gc.h
index 3603ff7ef..e886bec4b 100644
--- a/libguile/gc.h
+++ b/libguile/gc.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/gdb_interface.h b/libguile/gdb_interface.h
index 5be4d0786..2278fc2c2 100644
--- a/libguile/gdb_interface.h
+++ b/libguile/gdb_interface.h
@@ -5,19 +5,20 @@
/* Simple interpreter interface for GDB, the GNU debugger.
Copyright (C) 1996, 2000, 2001, 2006 Free Software Foundation
- This library is free software; you can redistribute it and/or
- modify it under the terms of the GNU Lesser General Public
- License as published by the Free Software Foundation; either
- version 2.1 of the License, or (at your option) any later version.
-
- This library is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- Lesser General Public License for more details.
-
- You should have received a copy of the GNU Lesser General Public
- License along with this library; if not, write to the Free Software
- Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
The author can be reached at djurfeldt@nada.kth.se
Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN */
diff --git a/libguile/gdbint.c b/libguile/gdbint.c
index 4ec9ad48c..0d55e7de4 100644
--- a/libguile/gdbint.c
+++ b/libguile/gdbint.c
@@ -3,18 +3,19 @@
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
diff --git a/libguile/gdbint.h b/libguile/gdbint.h
index 64b9559c9..d7c6cf31e 100644
--- a/libguile/gdbint.h
+++ b/libguile/gdbint.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1996,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c
index 85ebfaed7..0e897ca8c 100644
--- a/libguile/gen-scmconfig.c
+++ b/libguile/gen-scmconfig.c
@@ -125,6 +125,7 @@
#include <stdio.h>
#include <string.h>
+#include <uniconv.h>
#define pf printf
@@ -279,21 +280,6 @@ main (int argc, char *argv[])
pf ("#define SCM_SIZEOF_LONG_LONG %d\n", SIZEOF_LONG_LONG);
pf ("#define SCM_SIZEOF_UNSIGNED_LONG_LONG %d\n", SIZEOF_UNSIGNED_LONG_LONG);
- pf("\n");
- pf("/* handling for the deprecated long_long and ulong_long types */\n");
- pf("/* If anything suitable is available, it'll be defined here. */\n");
- pf("#if (SCM_ENABLE_DEPRECATED == 1)\n");
- if (SIZEOF_LONG_LONG != 0)
- pf ("typedef long long long_long;\n");
- else if (SIZEOF___INT64 != 0)
- pf ("typedef __int64 long_long;\n");
-
- if (SIZEOF_UNSIGNED_LONG_LONG != 0)
- pf ("typedef unsigned long long ulong_long;\n");
- else if (SIZEOF_UNSIGNED___INT64 != 0)
- pf ("typedef unsigned __int64 ulong_long;\n");
- pf("#endif /* SCM_ENABLE_DEPRECATED == 1 */\n");
-
pf ("\n");
pf ("/* These are always defined. */\n");
pf ("typedef %s scm_t_int8;\n", SCM_I_GSC_T_INT8);
@@ -400,6 +386,24 @@ main (int argc, char *argv[])
pf ("#define SCM_HAVE_READDIR64_R 0 /* 0 or 1 */\n");
#endif
+ /* Arrange so that we have a file offset type that reflects the one
+ used when compiling Guile, regardless of what the application's
+ `_FILE_OFFSET_BITS' says. See
+ http://lists.gnu.org/archive/html/bug-guile/2009-06/msg00018.html
+ for the original bug report.
+
+ Note that we can't define `scm_t_off' in terms of `off_t' or
+ `off64_t' because they may or may not be available depending on
+ how the application that uses Guile is compiled. */
+
+#if defined GUILE_USE_64_CALLS && defined HAVE_STAT64
+ pf ("typedef scm_t_int64 scm_t_off;\n");
+#elif SIZEOF_OFF_T == SIZEOF_INT
+ pf ("typedef int scm_t_off;\n");
+#else
+ pf ("typedef long int scm_t_off;\n");
+#endif
+
#if USE_DLL_IMPORT
pf ("\n");
pf ("/* Define some additional CPP macros on Win32 platforms. */\n");
@@ -421,6 +425,14 @@ main (int argc, char *argv[])
pf ("#define SCM_HAVE_ARRAYS 1 /* always true now */\n");
+ pf ("\n");
+ pf ("/* Constants from uniconv.h. */\n");
+ pf ("#define SCM_ICONVEH_ERROR %d\n", (int) iconveh_error);
+ pf ("#define SCM_ICONVEH_QUESTION_MARK %d\n",
+ (int) iconveh_question_mark);
+ pf ("#define SCM_ICONVEH_ESCAPE_SEQUENCE %d\n",
+ (int) iconveh_escape_sequence);
+
printf ("#endif\n");
return 0;
diff --git a/libguile/gettext.c b/libguile/gettext.c
index e74f9f351..2ae3ae5e4 100644
--- a/libguile/gettext.c
+++ b/libguile/gettext.c
@@ -1,18 +1,19 @@
/* Copyright (C) 2004, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/gettext.h b/libguile/gettext.h
index 8a13307d5..d4576bd6a 100644
--- a/libguile/gettext.h
+++ b/libguile/gettext.h
@@ -6,18 +6,19 @@
/* Copyright (C) 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#include "libguile/__scm.h"
diff --git a/libguile/goops.c b/libguile/goops.c
index 1d9272df6..25b957132 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -2,18 +2,19 @@
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -1253,10 +1254,7 @@ SCM_DEFINE (scm_sys_fast_slot_set_x, "%fast-slot-set!", 3, 0, 0,
#undef FUNC_NAME
-SCM_SYNTAX (s_atslot_ref, "@slot-ref", scm_i_makbimacro, scm_m_atslot_ref);
-SCM_SYNTAX (s_atslot_set_x, "@slot-set!", scm_i_makbimacro, scm_m_atslot_set_x);
-
-
+
/** Utilities **/
/* In the future, this function will return the effective slot
@@ -1859,7 +1857,7 @@ SCM_DEFINE (scm_enable_primitive_generic_x, "enable-primitive-generic!", 0, 0, 1
*SCM_SUBR_GENERIC (subr)
= scm_make (scm_list_3 (scm_class_generic,
k_name,
- SCM_SNAME (subr)));
+ SCM_SUBR_NAME (subr)));
subrs = SCM_CDR (subrs);
}
return SCM_UNSPECIFIED;
@@ -1907,7 +1905,7 @@ scm_c_extend_primitive_generic (SCM extended, SCM extension)
gf = *SCM_SUBR_GENERIC (extended);
gext = scm_call_2 (SCM_VARIABLE_REF (scm_var_make_extended_generic),
gf,
- SCM_SNAME (extension));
+ SCM_SUBR_NAME (extension));
SCM_SET_SUBR_GENERIC (extension, gext);
}
else
diff --git a/libguile/goops.h b/libguile/goops.h
index d43d73642..8d138237a 100644
--- a/libguile/goops.h
+++ b/libguile/goops.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1998,1999,2000,2001,2002,2003, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 2b9a29dd1..3b7315565 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -20,6 +21,8 @@
# include <config.h>
#endif
+#include <alloca.h>
+
#include <stdio.h>
#include <stdarg.h>
@@ -91,7 +94,7 @@ create_gsubr (int define, const char *name,
}
if (define)
- scm_define (SCM_SNAME (subr), subr);
+ scm_define (SCM_SUBR_NAME (subr), subr);
return subr;
}
@@ -146,7 +149,7 @@ create_gsubr_with_generic (int define,
subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr_2, fcn, gf);
create_subr:
if (define)
- scm_define (SCM_SNAME (subr), subr);
+ scm_define (SCM_SUBR_NAME (subr), subr);
return subr;
default:
;
@@ -193,7 +196,7 @@ gsubr_apply_raw (SCM proc, unsigned int argc, const SCM *argv)
if (SCM_UNLIKELY (argc != argc_max))
/* We expect the exact argument count. */
- scm_wrong_num_args (SCM_SNAME (proc));
+ scm_wrong_num_args (SCM_SUBR_NAME (proc));
fcn = SCM_SUBRF (proc);
@@ -226,7 +229,7 @@ gsubr_apply_raw (SCM proc, unsigned int argc, const SCM *argv)
return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
argv[6], argv[7], argv[8], argv[9]);
default:
- scm_misc_error ((char *) SCM_SNAME (proc),
+ scm_misc_error ((char *) SCM_SUBR_NAME (proc),
"gsubr invocation with more than 10 arguments not implemented",
SCM_EOL);
}
@@ -255,7 +258,7 @@ scm_i_gsubr_apply (SCM proc, SCM arg, ...)
argv[argc] = arg;
if (SCM_UNLIKELY (argc < SCM_GSUBR_REQ (type)))
- scm_wrong_num_args (SCM_SNAME (proc));
+ scm_wrong_num_args (SCM_SUBR_NAME (proc));
/* Fill in optional arguments that were not passed. */
while (argc < argc_max)
@@ -293,7 +296,7 @@ scm_i_gsubr_apply_list (SCM self, SCM args)
for (i = 0; i < SCM_GSUBR_REQ (typ); i++) {
if (scm_is_null (args))
- scm_wrong_num_args (SCM_SNAME (self));
+ scm_wrong_num_args (SCM_SUBR_NAME (self));
v[i] = SCM_CAR(args);
args = SCM_CDR(args);
}
@@ -308,7 +311,7 @@ scm_i_gsubr_apply_list (SCM self, SCM args)
if (SCM_GSUBR_REST(typ))
v[i] = args;
else if (!scm_is_null (args))
- scm_wrong_num_args (SCM_SNAME (self));
+ scm_wrong_num_args (SCM_SUBR_NAME (self));
return gsubr_apply_raw (self, n, v);
}
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index 65680a02c..298181b15 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/guardians.c b/libguile/guardians.c
index 73730fc45..580e212d0 100644
--- a/libguile/guardians.c
+++ b/libguile/guardians.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/guardians.h b/libguile/guardians.h
index 295092edf..a23026d6c 100644
--- a/libguile/guardians.h
+++ b/libguile/guardians.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1998,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/guile-doc-snarf.in b/libguile/guile-doc-snarf.in
index 49be29185..a787d5a46 100755
--- a/libguile/guile-doc-snarf.in
+++ b/libguile/guile-doc-snarf.in
@@ -4,19 +4,19 @@
# Copyright (C) 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
#
# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2, or (at your option)
-# any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this software; see the file COPYING. If not, write to
-# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-# Boston, MA 02110-1301 USA
+# it under the terms of the GNU Lesser General Public License as
+# published by the Free Software Foundation; either version 3, or (at
+# your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Lesser General Public License for more details.
+#
+# You should have received a copy of the GNU Lesser General Public
+# License along with this software; see the file COPYING.LESSER. If
+# not, write to the Free Software Foundation, Inc., 51 Franklin
+# Street, Fifth Floor, Boston, MA 02110-1301 USA
fullfilename=$1
diff --git a/libguile/guile-func-name-check.in b/libguile/guile-func-name-check.in
index 7f0114e0b..8b4924e91 100644
--- a/libguile/guile-func-name-check.in
+++ b/libguile/guile-func-name-check.in
@@ -3,19 +3,19 @@
# Copyright (C) 2000, 2001, 2006 Free Software Foundation, Inc.
#
# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2, or (at your option)
-# any later version.
+# it under the terms of the GNU Lesser General Public License as
+# published by the Free Software Foundation; either version 3, or (at
+# your option) any later version.
#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Lesser General Public License for more details.
#
-# You should have received a copy of the GNU General Public License
-# along with this software; see the file COPYING. If not, write to
-# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-# Boston, MA 02110-1301 USA
+# You should have received a copy of the GNU Lesser General Public
+# License along with this software; see the file COPYING.LESSER. If
+# not, write to the Free Software Foundation, Inc., 51 Franklin
+# Street, Fifth Floor, Boston, MA 02110-1301 USA
#
# Written by Greg J. Badros, <gjb@cs.washington.edu>
# 11-Jan-2000
diff --git a/libguile/guile-snarf-docs.in b/libguile/guile-snarf-docs.in
index 9cba3dc56..1e57f2624 100755
--- a/libguile/guile-snarf-docs.in
+++ b/libguile/guile-snarf-docs.in
@@ -4,19 +4,19 @@
# Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
#
# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2, or (at your option)
-# any later version.
+# it under the terms of the GNU Lesser General Public License as
+# published by the Free Software Foundation; either version 3, or (at
+# your option) any later version.
#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Lesser General Public License for more details.
#
-# You should have received a copy of the GNU General Public License
-# along with this software; see the file COPYING. If not, write to
-# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-# Boston, MA 02110-1301 USA
+# You should have received a copy of the GNU Lesser General Public
+# License along with this software; see the file COPYING.LESSER. If
+# not, write to the Free Software Foundation, Inc., 51 Franklin
+# Street, Fifth Floor, Boston, MA 02110-1301 USA
bindir=`dirname $0`
diff --git a/libguile/guile-snarf.awk.in b/libguile/guile-snarf.awk.in
index be3b1236d..8a720a002 100644
--- a/libguile/guile-snarf.awk.in
+++ b/libguile/guile-snarf.awk.in
@@ -1,19 +1,19 @@
# Copyright (C) 1999, 2000, 2001, 2006 Free Software Foundation, Inc.
#
# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2, or (at your option)
-# any later version.
+# it under the terms of the GNU Lesser General Public License as
+# published by the Free Software Foundation; either version 3, or (at
+# your option) any later version.
#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Lesser General Public License for more details.
#
-# You should have received a copy of the GNU General Public License
-# along with this software; see the file COPYING. If not, write to
-# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-# Boston, MA 02110-1301 USA
+# You should have received a copy of the GNU Lesser General Public
+# License along with this software; see the file COPYING.LESSER. If
+# not, write to the Free Software Foundation, Inc., 51 Franklin
+# Street, Fifth Floor, Boston, MA 02110-1301 USA
#
# Written by Greg J. Badros, <gjb@cs.washington.edu>
# 12-Dec-1999
diff --git a/libguile/guile-snarf.in b/libguile/guile-snarf.in
index 617bad822..6a72dd5d5 100644
--- a/libguile/guile-snarf.in
+++ b/libguile/guile-snarf.in
@@ -4,19 +4,19 @@
# Copyright (C) 1996, 97, 98, 99, 2000, 2001, 2002, 2004, 2006, 2008 Free Software Foundation, Inc.
#
# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2, or (at your option)
-# any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this software; see the file COPYING. If not, write to
-# the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-# Boston, MA 02110-1301 USA
+# it under the terms of the GNU Lesser General Public License as
+# published by the Free Software Foundation; either version 3, or (at
+# your option) any later version.
+#
+# This program is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+# Lesser General Public License for more details.
+#
+# You should have received a copy of the GNU Lesser General Public
+# License along with this software; see the file COPYING.LESSER. If
+# not, write to the Free Software Foundation, Inc., 51 Franklin
+# Street, Fifth Floor, Boston, MA 02110-1301 USA
# Commentary:
diff --git a/libguile/guile.c b/libguile/guile.c
index c8341c24f..6da547b75 100644
--- a/libguile/guile.c
+++ b/libguile/guile.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1996,1997,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
/* This is the 'main' function for the `guile' executable. It is not
diff --git a/libguile/hash.c b/libguile/hash.c
index 7a49de6b4..d2fe17706 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/hash.h b/libguile/hash.h
index bbf9b2562..789595b42 100644
--- a/libguile/hash.h
+++ b/libguile/hash.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/hashtab.c b/libguile/hashtab.c
index 50553d295..5c03d281f 100644
--- a/libguile/hashtab.c
+++ b/libguile/hashtab.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/hashtab.h b/libguile/hashtab.h
index 005fd57aa..8f8ebf9ce 100644
--- a/libguile/hashtab.h
+++ b/libguile/hashtab.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/hooks.c b/libguile/hooks.c
index d175be127..c6541fadd 100644
--- a/libguile/hooks.c
+++ b/libguile/hooks.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/hooks.h b/libguile/hooks.h
index 49ea55350..15b57fabb 100644
--- a/libguile/hooks.h
+++ b/libguile/hooks.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/i18n.c b/libguile/i18n.c
index a5e451ceb..fd15227b5 100644
--- a/libguile/i18n.c
+++ b/libguile/i18n.c
@@ -1,18 +1,19 @@
/* Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
diff --git a/libguile/i18n.h b/libguile/i18n.h
index 57f1654a3..df2970b4e 100644
--- a/libguile/i18n.h
+++ b/libguile/i18n.h
@@ -6,18 +6,19 @@
/* Copyright (C) 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#include "libguile/__scm.h"
diff --git a/libguile/ieee-754.h b/libguile/ieee-754.h
new file mode 100644
index 000000000..e345efaae
--- /dev/null
+++ b/libguile/ieee-754.h
@@ -0,0 +1,90 @@
+/* Copyright (C) 1992, 1995, 1996, 1999 Free Software Foundation, Inc.
+ This file is part of the GNU C Library.
+
+ The GNU C Library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public
+ License as published by the Free Software Foundation; either
+ version 2.1 of the License, or (at your option) any later version.
+
+ The GNU C Library is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with the GNU C Library; if not, write to the Free
+ Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
+ 02111-1307 USA. */
+
+#ifndef SCM_IEEE_754_H
+#define SCM_IEEE_754_H 1
+
+/* Based on glibc's <ieee754.h> and modified by Ludovic Courtès to include
+ all possible IEEE-754 double-precision representations. */
+
+
+/* IEEE 754 simple-precision format (32-bit). */
+
+union scm_ieee754_float
+ {
+ float f;
+
+ struct
+ {
+ unsigned int negative:1;
+ unsigned int exponent:8;
+ unsigned int mantissa:23;
+ } big_endian;
+
+ struct
+ {
+ unsigned int mantissa:23;
+ unsigned int exponent:8;
+ unsigned int negative:1;
+ } little_endian;
+ };
+
+
+
+/* IEEE 754 double-precision format (64-bit). */
+
+union scm_ieee754_double
+ {
+ double d;
+
+ struct
+ {
+ /* Big endian. */
+
+ unsigned int negative:1;
+ unsigned int exponent:11;
+ /* Together these comprise the mantissa. */
+ unsigned int mantissa0:20;
+ unsigned int mantissa1:32;
+ } big_endian;
+
+ struct
+ {
+ /* Both byte order and word order are little endian. */
+
+ /* Together these comprise the mantissa. */
+ unsigned int mantissa1:32;
+ unsigned int mantissa0:20;
+ unsigned int exponent:11;
+ unsigned int negative:1;
+ } little_little_endian;
+
+ struct
+ {
+ /* Byte order is little endian but word order is big endian. Not
+ sure this is very wide spread. */
+ unsigned int mantissa0:20;
+ unsigned int exponent:11;
+ unsigned int negative:1;
+ unsigned int mantissa1:32;
+ } little_big_endian;
+
+ };
+
+
+#endif /* SCM_IEEE_754_H */
diff --git a/libguile/init.c b/libguile/init.c
index 3e65f02be..dbb132446 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -37,6 +38,7 @@
#include "libguile/async.h"
#include "libguile/backtrace.h"
#include "libguile/boolean.h"
+#include "libguile/bytevectors.h"
#include "libguile/chars.h"
#include "libguile/continuations.h"
#include "libguile/debug.h"
@@ -282,7 +284,7 @@ scm_load_startup_files ()
/* Load Ice-9. */
if (!scm_ice_9_already_loaded)
{
- scm_primitive_load_path (scm_from_locale_string ("ice-9/boot-9"));
+ scm_c_primitive_load_path ("ice-9/boot-9");
/* Load the init.scm file. */
if (scm_is_true (init_path))
@@ -574,6 +576,7 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_rw ();
scm_init_extensions ();
+ scm_bootstrap_bytevectors ();
scm_bootstrap_vm ();
atexit (cleanup_for_exit);
diff --git a/libguile/init.h b/libguile/init.h
index 3ae27d8cc..7cfae76d5 100644
--- a/libguile/init.h
+++ b/libguile/init.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1997,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/inline.c b/libguile/inline.c
index a0c25003f..79728ff13 100644
--- a/libguile/inline.c
+++ b/libguile/inline.c
@@ -1,18 +1,19 @@
/* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
diff --git a/libguile/inline.h b/libguile/inline.h
index ff8d2d4d1..09ee1429f 100644
--- a/libguile/inline.h
+++ b/libguile/inline.h
@@ -6,18 +6,19 @@
/* Copyright (C) 2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
/* This file is for inline functions. On platforms that don't support
diff --git a/libguile/instructions.c b/libguile/instructions.c
index b33c8d203..04180e5e3 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -1,49 +1,28 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
#if HAVE_CONFIG_H
# include <config.h>
#endif
#include <string.h>
+
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "instructions.h"
@@ -74,7 +53,7 @@ fetch_instruction_table ()
if (SCM_UNLIKELY (!table))
{
- size_t bytes = scm_op_last * sizeof(struct scm_instruction);
+ size_t bytes = SCM_VM_NUM_INSTRUCTIONS * sizeof(struct scm_instruction);
int i;
table = malloc (bytes);
memset (table, 0, bytes);
@@ -84,11 +63,12 @@ fetch_instruction_table ()
#include <libguile/vm-i-scheme.i>
#include <libguile/vm-i-loader.i>
#undef VM_INSTRUCTION_TO_TABLE
- for (i = 0; i < scm_op_last; i++)
+ for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
{
table[i].opcode = i;
if (table[i].name)
- table[i].symname = scm_from_locale_symbol (table[i].name);
+ table[i].symname =
+ scm_permanent_object (scm_from_locale_symbol (table[i].name));
else
table[i].symname = SCM_BOOL_F;
}
@@ -106,12 +86,12 @@ scm_lookup_instruction_by_name (SCM name)
if (SCM_UNLIKELY (SCM_FALSEP (instructions_by_name)))
{
int i;
- instructions_by_name = scm_make_hash_table (SCM_I_MAKINUM (scm_op_last));
- for (i = 0; i < scm_op_last; i++)
+ instructions_by_name = scm_permanent_object
+ (scm_make_hash_table (SCM_I_MAKINUM (SCM_VM_NUM_INSTRUCTIONS)));
+ for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
if (scm_is_true (table[i].symname))
scm_hashq_set_x (instructions_by_name, table[i].symname,
SCM_I_MAKINUM (i));
- instructions_by_name = scm_permanent_object (instructions_by_name);
}
op = scm_hashq_ref (instructions_by_name, name, SCM_UNDEFINED);
@@ -130,10 +110,11 @@ SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0,
#define FUNC_NAME s_scm_instruction_list
{
SCM list = SCM_EOL;
- struct scm_instruction *ip;
- for (ip = fetch_instruction_table (); ip->opcode != scm_op_last; ip++)
- if (ip->name)
- list = scm_cons (ip->symname, list);
+ int i;
+ struct scm_instruction *ip = fetch_instruction_table ();
+ for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++)
+ if (ip[i].name)
+ list = scm_cons (ip[i].symname, list);
return scm_reverse_x (list, SCM_EOL);
}
#undef FUNC_NAME
@@ -202,7 +183,7 @@ SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
SCM_MAKE_VALIDATE (1, op, I_INUMP);
opcode = SCM_I_INUM (op);
- if (opcode < scm_op_last)
+ if (opcode >= 0 && opcode < SCM_VM_NUM_INSTRUCTIONS)
ret = fetch_instruction_table ()[opcode].symname;
if (scm_is_false (ret))
@@ -215,6 +196,9 @@ SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0,
void
scm_bootstrap_instructions (void)
{
+ scm_c_register_extension ("libguile", "scm_init_instructions",
+ (scm_t_extension_init_func)scm_init_instructions,
+ NULL);
}
void
diff --git a/libguile/instructions.h b/libguile/instructions.h
index 4968671b5..a2263228f 100644
--- a/libguile/instructions.h
+++ b/libguile/instructions.h
@@ -1,50 +1,27 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
#ifndef _SCM_INSTRUCTIONS_H_
#define _SCM_INSTRUCTIONS_H_
#include <libguile.h>
-#define SCM_VM_NUM_INSTRUCTIONS (1<<7)
+#define SCM_VM_NUM_INSTRUCTIONS (1<<8)
#define SCM_VM_INSTRUCTION_MASK (SCM_VM_NUM_INSTRUCTIONS-1)
enum scm_opcode {
@@ -54,19 +31,18 @@ enum scm_opcode {
#include <libguile/vm-i-scheme.i>
#include <libguile/vm-i-loader.i>
#undef VM_INSTRUCTION_TO_OPCODE
- scm_op_last = SCM_VM_NUM_INSTRUCTIONS
};
-extern SCM scm_instruction_list (void);
-extern SCM scm_instruction_p (SCM obj);
-extern SCM scm_instruction_length (SCM inst);
-extern SCM scm_instruction_pops (SCM inst);
-extern SCM scm_instruction_pushes (SCM inst);
-extern SCM scm_instruction_to_opcode (SCM inst);
-extern SCM scm_opcode_to_instruction (SCM op);
+SCM_API SCM scm_instruction_list (void);
+SCM_API SCM scm_instruction_p (SCM obj);
+SCM_API SCM scm_instruction_length (SCM inst);
+SCM_API SCM scm_instruction_pops (SCM inst);
+SCM_API SCM scm_instruction_pushes (SCM inst);
+SCM_API SCM scm_instruction_to_opcode (SCM inst);
+SCM_API SCM scm_opcode_to_instruction (SCM op);
-extern void scm_bootstrap_instructions (void);
-extern void scm_init_instructions (void);
+SCM_INTERNAL void scm_bootstrap_instructions (void);
+SCM_INTERNAL void scm_init_instructions (void);
#endif /* _SCM_INSTRUCTIONS_H_ */
diff --git a/libguile/ioext.c b/libguile/ioext.c
index b542664eb..6b0c9b88c 100644
--- a/libguile/ioext.c
+++ b/libguile/ioext.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2003, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/ioext.h b/libguile/ioext.h
index 18289ea3c..1b7b93aaf 100644
--- a/libguile/ioext.h
+++ b/libguile/ioext.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/iselect.h b/libguile/iselect.h
index 5a4b30da6..760d959d8 100644
--- a/libguile/iselect.h
+++ b/libguile/iselect.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1997,1998,2000,2001, 2002, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/keywords.c b/libguile/keywords.c
index 5afa9e9e7..c415ccbab 100644
--- a/libguile/keywords.c
+++ b/libguile/keywords.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/keywords.h b/libguile/keywords.h
index a80e31bff..bfffe5923 100644
--- a/libguile/keywords.h
+++ b/libguile/keywords.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/lang.c b/libguile/lang.c
index 7f3986cec..85da68034 100644
--- a/libguile/lang.c
+++ b/libguile/lang.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1999, 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/lang.h b/libguile/lang.h
index 991e9ca76..47128de57 100644
--- a/libguile/lang.h
+++ b/libguile/lang.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1998, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/libguile.map b/libguile/libguile.map
new file mode 100644
index 000000000..2586e0abf
--- /dev/null
+++ b/libguile/libguile.map
@@ -0,0 +1,44 @@
+# Linker version script for libguile. -*- ld-script -*-
+#
+# Copyright (C) 2009 Free Software Foundation, Inc.
+#
+# This file is part of GUILE.
+#
+# GUILE is free software; you can redistribute it and/or modify it
+# under the terms of the GNU Lesser General Public License as
+# published by the Free Software Foundation; either version 3, or
+# (at your option) any later version.
+#
+# GUILE is distributed in the hope that it will be useful, but
+# WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU Lesser General Public License for more details.
+#
+# You should have received a copy of the GNU Lesser General Public
+# License along with GUILE; see the file COPYING.LESSER. If not,
+# write to the Free Software Foundation, Inc., 51 Franklin Street,
+# Fifth Floor, Boston, MA 02110-1301 USA
+
+GUILE_2.0
+{
+ global:
+ # Note: This includes `scm_i_' symbols declared as `SCM_API' (e.g.,
+ # symbols from `deprecated.c' or symbols used by public inline
+ # functions or macros).
+ scm_*;
+
+ # GDB interface.
+ gdb_options;
+ gdb_language;
+ gdb_result;
+ gdb_output;
+ gdb_output_length;
+ gdb_maybe_valid_type_p;
+ gdb_read;
+ gdb_eval;
+ gdb_print;
+ gdb_binding;
+
+ local:
+ *;
+};
diff --git a/libguile/list.c b/libguile/list.c
index 07b96f5a7..70f527755 100644
--- a/libguile/list.c
+++ b/libguile/list.c
@@ -2,18 +2,19 @@
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/list.h b/libguile/list.h
index 733432d76..427dcb84d 100644
--- a/libguile/list.h
+++ b/libguile/list.h
@@ -7,18 +7,19 @@
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/load.c b/libguile/load.c
index 1a2994f40..505678932 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -1,18 +1,19 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -53,6 +54,10 @@
#include <unistd.h>
#endif /* HAVE_UNISTD_H */
+#ifdef HAVE_PWD_H
+#include <pwd.h>
+#endif /* HAVE_PWD_H */
+
#ifndef R_OK
#define R_OK 4
#endif
@@ -174,9 +179,15 @@ static SCM *scm_loc_load_path;
/* List of extensions we try adding to the filenames. */
static SCM *scm_loc_load_extensions;
-/* Like %load-extensions, but for compiled files. */
+/* Like %load-path and %load-extensions, but for compiled files. */
+static SCM *scm_loc_load_compiled_path;
static SCM *scm_loc_load_compiled_extensions;
+/* Whether we should try to auto-compile. */
+static SCM *scm_loc_load_should_autocompile;
+
+/* The fallback path for autocompilation */
+static SCM *scm_loc_compile_fallback_path;
SCM_DEFINE (scm_parse_path, "parse-path", 1, 1, 0,
(SCM path, SCM tail),
@@ -209,6 +220,7 @@ scm_init_load_path ()
{
char *env;
SCM path = SCM_EOL;
+ SCM cpath = SCM_EOL;
#ifdef SCM_LIBRARY_DIR
env = getenv ("GUILE_SYSTEM_PATH");
@@ -222,13 +234,54 @@ scm_init_load_path ()
path = scm_list_3 (scm_from_locale_string (SCM_SITE_DIR),
scm_from_locale_string (SCM_LIBRARY_DIR),
scm_from_locale_string (SCM_PKGDATA_DIR));
+
+ env = getenv ("GUILE_SYSTEM_COMPILED_PATH");
+ if (env && strcmp (env, "") == 0)
+ /* like above */
+ ;
+ else if (env)
+ cpath = scm_parse_path (scm_from_locale_string (env), cpath);
+ else
+ cpath = scm_cons (scm_from_locale_string (SCM_CCACHE_DIR), cpath);
+
#endif /* SCM_LIBRARY_DIR */
+ {
+ char cachedir[1024];
+ char *e;
+#ifdef HAVE_GETPWENT
+ struct passwd *pwd;
+#endif
+
+#define FALLBACK_DIR \
+ "guile/ccache/" SCM_EFFECTIVE_VERSION "-" SCM_OBJCODE_MACHINE_VERSION_STRING
+
+ if ((e = getenv ("XDG_CACHE_HOME")))
+ snprintf (cachedir, sizeof(cachedir), "%s" FALLBACK_DIR, e);
+ else if ((e = getenv ("HOME")))
+ snprintf (cachedir, sizeof(cachedir), "%s/.cache/" FALLBACK_DIR, e);
+#ifdef HAVE_GETPWENT
+ else if ((pwd = getpwuid (getuid ())) && pwd->pw_dir)
+ snprintf (cachedir, sizeof(cachedir), "%s/.cache/" FALLBACK_DIR,
+ pwd->pw_dir);
+#endif /* HAVE_GETPWENT */
+ else
+ cachedir[0] = 0;
+
+ if (cachedir[0])
+ *scm_loc_compile_fallback_path = scm_from_locale_string (cachedir);
+ }
+
env = getenv ("GUILE_LOAD_PATH");
if (env)
path = scm_parse_path (scm_from_locale_string (env), path);
+ env = getenv ("GUILE_LOAD_COMPILED_PATH");
+ if (env)
+ cpath = scm_parse_path (scm_from_locale_string (env), cpath);
+
*scm_loc_load_path = path;
+ *scm_loc_load_compiled_path = cpath;
}
SCM scm_listofnullstr;
@@ -508,58 +561,191 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0,
#undef FUNC_NAME
-SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0,
- (SCM filename),
+static int
+compiled_is_fresh (SCM full_filename, SCM compiled_filename)
+{
+ char *source, *compiled;
+ struct stat stat_source, stat_compiled;
+ int res;
+
+ source = scm_to_locale_string (full_filename);
+ compiled = scm_to_locale_string (compiled_filename);
+
+ if (stat (source, &stat_source) == 0
+ && stat (compiled, &stat_compiled) == 0
+ && stat_source.st_mtime == stat_compiled.st_mtime)
+ {
+ res = 1;
+ }
+ else
+ {
+ scm_puts (";;; note: source file ", scm_current_error_port ());
+ scm_puts (source, scm_current_error_port ());
+ scm_puts ("\n;;; newer than compiled ", scm_current_error_port ());
+ scm_puts (compiled, scm_current_error_port ());
+ scm_puts ("\n", scm_current_error_port ());
+ res = 0;
+ }
+
+ free (source);
+ free (compiled);
+ return res;
+}
+
+static SCM
+do_try_autocompile (void *data)
+{
+ SCM source = PTR2SCM (data);
+ SCM comp_mod, compile_file;
+
+ scm_puts (";;; compiling ", scm_current_error_port ());
+ scm_display (source, scm_current_error_port ());
+ scm_newline (scm_current_error_port ());
+
+ comp_mod = scm_c_resolve_module ("system base compile");
+ compile_file = scm_module_variable
+ (comp_mod, scm_from_locale_symbol ("compile-file"));
+
+ if (scm_is_true (compile_file))
+ {
+ SCM res = scm_call_1 (scm_variable_ref (compile_file), source);
+ scm_puts (";;; compiled ", scm_current_error_port ());
+ scm_display (res, scm_current_error_port ());
+ scm_newline (scm_current_error_port ());
+ return res;
+ }
+ else
+ {
+ scm_puts (";;; it seems ", scm_current_error_port ());
+ scm_display (source, scm_current_error_port ());
+ scm_puts ("\n;;; is part of the compiler; skipping autocompilation\n",
+ scm_current_error_port ());
+ return SCM_BOOL_F;
+ }
+}
+
+static SCM
+autocompile_catch_handler (void *data, SCM tag, SCM throw_args)
+{
+ SCM source = PTR2SCM (data);
+ scm_puts (";;; WARNING: compilation of ", scm_current_error_port ());
+ scm_display (source, scm_current_error_port ());
+ scm_puts (" failed:\n", scm_current_error_port ());
+ scm_puts (";;; key ", scm_current_error_port ());
+ scm_write (tag, scm_current_error_port ());
+ scm_puts (", throw args ", scm_current_error_port ());
+ scm_write (throw_args, scm_current_error_port ());
+ scm_newline (scm_current_error_port ());
+ return SCM_BOOL_F;
+}
+
+static SCM
+scm_try_autocompile (SCM source)
+{
+ static int message_shown = 0;
+
+ if (scm_is_false (*scm_loc_load_should_autocompile))
+ return SCM_BOOL_F;
+
+ if (!message_shown)
+ {
+ scm_puts (";;; note: autocompilation is enabled, set GUILE_AUTO_COMPILE=0\n"
+ ";;; or pass the --no-autocompile argument to disable.\n",
+ scm_current_error_port ());
+ message_shown = 1;
+ }
+
+ return scm_c_catch (SCM_BOOL_T,
+ do_try_autocompile,
+ SCM2PTR (source),
+ autocompile_catch_handler,
+ SCM2PTR (source),
+ NULL, NULL);
+}
+
+SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 1, 0,
+ (SCM filename, SCM exception_on_not_found),
"Search @var{%load-path} for the file named @var{filename} and\n"
"load it into the top-level environment. If @var{filename} is a\n"
"relative pathname and is not found in the list of search paths,\n"
- "an error is signalled.")
+ "an error is signalled, unless the optional argument\n"
+ "@var{exception_on_not_found} is @code{#f}, in which case\n"
+ "@code{#f} is returned instead.")
#define FUNC_NAME s_scm_primitive_load_path
{
SCM full_filename, compiled_filename;
+ int compiled_is_fallback = 0;
+
+ if (SCM_UNBNDP (exception_on_not_found))
+ exception_on_not_found = SCM_BOOL_T;
full_filename = scm_sys_search_load_path (filename);
- compiled_filename = scm_search_path (*scm_loc_load_path,
+ compiled_filename = scm_search_path (*scm_loc_load_compiled_path,
filename,
*scm_loc_load_compiled_extensions,
SCM_BOOL_T);
-
+
+ if (scm_is_false (compiled_filename)
+ && scm_is_true (full_filename)
+ && scm_is_true (*scm_loc_compile_fallback_path)
+ && scm_is_pair (*scm_loc_load_compiled_extensions)
+ && scm_is_string (scm_car (*scm_loc_load_compiled_extensions)))
+ {
+ SCM fallback = scm_string_append
+ (scm_list_3 (*scm_loc_compile_fallback_path,
+ full_filename,
+ scm_car (*scm_loc_load_compiled_extensions)));
+ if (scm_is_true (scm_stat (fallback, SCM_BOOL_F)))
+ {
+ compiled_filename = fallback;
+ compiled_is_fallback = 1;
+ }
+ }
+
if (scm_is_false (full_filename) && scm_is_false (compiled_filename))
- SCM_MISC_ERROR ("Unable to find file ~S in load path",
- scm_list_1 (filename));
-
- if (scm_is_false (compiled_filename))
- return scm_primitive_load (full_filename);
+ {
+ if (scm_is_true (exception_on_not_found))
+ SCM_MISC_ERROR ("Unable to find file ~S in load path",
+ scm_list_1 (filename));
+ else
+ return SCM_BOOL_F;
+ }
- if (scm_is_false (full_filename))
+ if (scm_is_false (full_filename)
+ || (scm_is_true (compiled_filename)
+ && compiled_is_fresh (full_filename, compiled_filename)))
return scm_load_compiled_with_vm (compiled_filename);
+ /* Perhaps there was the installed .go that was stale, but our fallback is
+ fresh. Let's try that. Duplicating code, but perhaps that's OK. */
+
+ if (!compiled_is_fallback
+ && scm_is_true (*scm_loc_compile_fallback_path)
+ && scm_is_pair (*scm_loc_load_compiled_extensions)
+ && scm_is_string (scm_car (*scm_loc_load_compiled_extensions)))
+ {
+ SCM fallback = scm_string_append
+ (scm_list_3 (*scm_loc_compile_fallback_path,
+ full_filename,
+ scm_car (*scm_loc_load_compiled_extensions)));
+ if (scm_is_true (scm_stat (fallback, SCM_BOOL_F))
+ && compiled_is_fresh (full_filename, fallback))
+ {
+ scm_puts (";;; found fresh local cache at ", scm_current_error_port ());
+ scm_display (fallback, scm_current_error_port ());
+ scm_newline (scm_current_error_port ());
+ return scm_load_compiled_with_vm (compiled_filename);
+ }
+ }
+
+ /* Otherwise, we bottom out here. */
{
- char *source, *compiled;
- struct stat stat_source, stat_compiled;
+ SCM freshly_compiled = scm_try_autocompile (full_filename);
- source = scm_to_locale_string (full_filename);
- compiled = scm_to_locale_string (compiled_filename);
-
- if (stat (source, &stat_source) == 0
- && stat (compiled, &stat_compiled) == 0
- && stat_source.st_mtime <= stat_compiled.st_mtime)
- {
- free (source);
- free (compiled);
- return scm_load_compiled_with_vm (compiled_filename);
- }
+ if (scm_is_true (freshly_compiled))
+ return scm_load_compiled_with_vm (freshly_compiled);
else
- {
- scm_puts (";;; note: source file ", scm_current_error_port ());
- scm_puts (source, scm_current_error_port ());
- scm_puts (" newer than compiled ", scm_current_error_port ());
- scm_puts (compiled, scm_current_error_port ());
- scm_puts ("\n", scm_current_error_port ());
- free (source);
- free (compiled);
- return scm_primitive_load (full_filename);
- }
+ return scm_primitive_load (full_filename);
}
}
#undef FUNC_NAME
@@ -567,7 +753,8 @@ SCM_DEFINE (scm_primitive_load_path, "primitive-load-path", 1, 0, 0,
SCM
scm_c_primitive_load_path (const char *filename)
{
- return scm_primitive_load_path (scm_from_locale_string (filename));
+ return scm_primitive_load_path (scm_from_locale_string (filename),
+ SCM_BOOL_T);
}
@@ -600,11 +787,19 @@ scm_init_load ()
= SCM_VARIABLE_LOC (scm_c_define ("%load-extensions",
scm_list_2 (scm_from_locale_string (".scm"),
scm_nullstr)));
+ scm_loc_load_compiled_path
+ = SCM_VARIABLE_LOC (scm_c_define ("%load-compiled-path", SCM_EOL));
scm_loc_load_compiled_extensions
= SCM_VARIABLE_LOC (scm_c_define ("%load-compiled-extensions",
scm_list_1 (scm_from_locale_string (".go"))));
scm_loc_load_hook = SCM_VARIABLE_LOC (scm_c_define ("%load-hook", SCM_BOOL_F));
+ scm_loc_compile_fallback_path
+ = SCM_VARIABLE_LOC (scm_c_define ("%compile-fallback-path", SCM_BOOL_F));
+
+ scm_loc_load_should_autocompile
+ = SCM_VARIABLE_LOC (scm_c_define ("%load-should-autocompile", SCM_BOOL_F));
+
the_reader = scm_make_fluid ();
scm_fluid_set_x (the_reader, SCM_BOOL_F);
scm_c_define("current-reader", the_reader);
diff --git a/libguile/load.h b/libguile/load.h
index 87f336e1e..d5bc1b066 100644
--- a/libguile/load.h
+++ b/libguile/load.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -33,7 +34,7 @@ SCM_API SCM scm_sys_library_dir (void);
SCM_API SCM scm_sys_site_dir (void);
SCM_API SCM scm_search_path (SCM path, SCM filename, SCM exts, SCM require_exts);
SCM_API SCM scm_sys_search_load_path (SCM filename);
-SCM_API SCM scm_primitive_load_path (SCM filename);
+SCM_API SCM scm_primitive_load_path (SCM filename, SCM exception_on_not_found);
SCM_API SCM scm_c_primitive_load_path (const char *filename);
SCM_INTERNAL void scm_init_load_path (void);
SCM_INTERNAL void scm_init_load (void);
diff --git a/libguile/locale-categories.h b/libguile/locale-categories.h
index cbe9684a3..26b030dc5 100644
--- a/libguile/locale-categories.h
+++ b/libguile/locale-categories.h
@@ -1,18 +1,19 @@
/* Copyright (C) 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
/* A list of all available locale categories, not including `ALL'. */
diff --git a/libguile/macros.c b/libguile/macros.c
index 076b72dbb..3e0942c43 100644
--- a/libguile/macros.c
+++ b/libguile/macros.c
@@ -1,18 +1,19 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -48,10 +49,13 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
|| scm_is_false (scm_printer_apply (SCM_PRINT_CLOSURE,
macro, port, pstate)))
{
+ scm_puts ("#<", port);
+
+ if (SCM_MACRO_TYPE (macro) < 4 && SCM_MACRO_IS_EXTENDED (macro))
+ scm_puts ("extended-", port);
+
if (!SCM_CLOSUREP (code) && !SCM_PROGRAM_P (code))
- scm_puts ("#<primitive-", port);
- else
- scm_puts ("#<", port);
+ scm_puts ("primitive-", port);
if (SCM_MACRO_TYPE (macro) == 0)
scm_puts ("syntax", port);
@@ -63,6 +67,8 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
scm_puts ("macro!", port);
if (SCM_MACRO_TYPE (macro) == 3)
scm_puts ("builtin-macro!", port);
+ if (SCM_MACRO_TYPE (macro) == 4)
+ scm_puts ("syncase-macro", port);
scm_putc (' ', port);
scm_iprin1 (scm_macro_name (macro), port, pstate);
@@ -77,6 +83,14 @@ macro_print (SCM macro, SCM port, scm_print_state *pstate)
scm_iprin1 (src, port, pstate);
}
+ if (SCM_MACRO_IS_EXTENDED (macro))
+ {
+ scm_putc (' ', port);
+ scm_write (SCM_SMOB_OBJECT_2 (macro), port);
+ scm_putc (' ', port);
+ scm_write (SCM_SMOB_OBJECT_3 (macro), port);
+ }
+
scm_putc ('>', port);
}
@@ -164,11 +178,45 @@ SCM_DEFINE (scm_makmacro, "procedure->macro", 1, 0, 0,
#endif
+SCM_DEFINE (scm_make_syncase_macro, "make-syncase-macro", 2, 0, 0,
+ (SCM type, SCM binding),
+ "Return a @dfn{macro} that requires expansion by syntax-case.\n"
+ "While users should not call this function, it is useful to know\n"
+ "that syntax-case macros are represented as Guile primitive macros.")
+#define FUNC_NAME s_scm_make_syncase_macro
+{
+ SCM z;
+ SCM_VALIDATE_SYMBOL (1, type);
+
+ SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_UNPACK (binding), SCM_UNPACK (type),
+ SCM_UNPACK (binding));
+ SCM_SET_SMOB_FLAGS (z, 4 | SCM_F_MACRO_EXTENDED);
+ return z;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_make_extended_syncase_macro, "make-extended-syncase-macro", 3, 0, 0,
+ (SCM m, SCM type, SCM binding),
+ "Extend a core macro @var{m} with a syntax-case binding.")
+#define FUNC_NAME s_scm_make_extended_syncase_macro
+{
+ SCM z;
+ SCM_VALIDATE_SMOB (1, m, macro);
+ SCM_VALIDATE_SYMBOL (2, type);
+
+ SCM_NEWSMOB3 (z, scm_tc16_macro, SCM_SMOB_DATA (m), SCM_UNPACK (type),
+ SCM_UNPACK (binding));
+ SCM_SET_SMOB_FLAGS (z, SCM_SMOB_FLAGS (m) | SCM_F_MACRO_EXTENDED);
+ return z;
+}
+#undef FUNC_NAME
+
+
SCM_DEFINE (scm_macro_p, "macro?", 1, 0, 0,
(SCM obj),
- "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro or a\n"
- "syntax transformer.")
+ "Return @code{#t} if @var{obj} is a regular macro, a memoizing macro, a\n"
+ "syntax transformer, or a syntax-case macro.")
#define FUNC_NAME s_scm_macro_p
{
return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_macro, obj));
@@ -182,14 +230,15 @@ SCM_SYMBOL (scm_sym_macro, "macro");
#endif
SCM_SYMBOL (scm_sym_mmacro, "macro!");
SCM_SYMBOL (scm_sym_bimacro, "builtin-macro!");
+SCM_SYMBOL (scm_sym_syncase_macro, "syncase-macro");
SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
(SCM m),
- "Return one of the symbols @code{syntax}, @code{macro} or\n"
- "@code{macro!}, depending on whether @var{m} is a syntax\n"
- "transformer, a regular macro, or a memoizing macro,\n"
- "respectively. If @var{m} is not a macro, @code{#f} is\n"
- "returned.")
+ "Return one of the symbols @code{syntax}, @code{macro},\n"
+ "@code{macro!}, or @code{syntax-case}, depending on whether\n"
+ "@var{m} is a syntax transformer, a regular macro, a memoizing\n"
+ "macro, or a syntax-case macro, respectively. If @var{m} is\n"
+ "not a macro, @code{#f} is returned.")
#define FUNC_NAME s_scm_macro_type
{
if (!SCM_SMOB_PREDICATE (scm_tc16_macro, m))
@@ -202,6 +251,7 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
#endif
case 2: return scm_sym_mmacro;
case 3: return scm_sym_bimacro;
+ case 4: return scm_sym_syncase_macro;
default: scm_wrong_type_arg (FUNC_NAME, 1, m);
}
}
@@ -214,7 +264,9 @@ SCM_DEFINE (scm_macro_name, "macro-name", 1, 0, 0,
#define FUNC_NAME s_scm_macro_name
{
SCM_VALIDATE_SMOB (1, m, macro);
- return scm_procedure_name (SCM_PACK (SCM_SMOB_DATA (m)));
+ if (scm_is_true (scm_procedure_p (SCM_SMOB_OBJECT (m))))
+ return scm_procedure_name (SCM_SMOB_OBJECT (m));
+ return SCM_BOOL_F;
}
#undef FUNC_NAME
@@ -236,6 +288,34 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_syncase_macro_type, "syncase-macro-type", 1, 0, 0,
+ (SCM m),
+ "Return the type of the macro @var{m}.")
+#define FUNC_NAME s_scm_syncase_macro_type
+{
+ SCM_VALIDATE_SMOB (1, m, macro);
+
+ if (SCM_MACRO_IS_EXTENDED (m))
+ return SCM_SMOB_OBJECT_2 (m);
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_syncase_macro_binding, "syncase-macro-binding", 1, 0, 0,
+ (SCM m),
+ "Return the binding of the macro @var{m}.")
+#define FUNC_NAME s_scm_syncase_macro_binding
+{
+ SCM_VALIDATE_SMOB (1, m, macro);
+
+ if (SCM_MACRO_IS_EXTENDED (m))
+ return SCM_SMOB_OBJECT_3 (m);
+ else
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
SCM
scm_make_synt (const char *name, SCM (*macroizer) (), SCM (*fcn)() )
{
diff --git a/libguile/macros.h b/libguile/macros.h
index e1de77ff9..8ff41c4a4 100644
--- a/libguile/macros.h
+++ b/libguile/macros.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1998,2000,2001,2002,2003, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -29,9 +30,15 @@
#define SCM_ASSYNT(_cond, _msg, _subr) \
if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL);
+#define SCM_MACRO_TYPE_BITS (3)
+#define SCM_MACRO_TYPE_MASK ((1<<SCM_MACRO_TYPE_BITS)-1)
+#define SCM_F_MACRO_EXTENDED (1<<SCM_MACRO_TYPE_BITS)
+
#define SCM_MACROP(x) SCM_SMOB_PREDICATE (scm_tc16_macro, (x))
-#define SCM_MACRO_TYPE(m) SCM_SMOB_FLAGS (m)
+#define SCM_MACRO_TYPE(m) (SCM_SMOB_FLAGS (m) & SCM_MACRO_TYPE_MASK)
+#define SCM_MACRO_IS_EXTENDED(m) (SCM_SMOB_FLAGS (m) & SCM_F_MACRO_EXTENDED)
#define SCM_BUILTIN_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 3)
+#define SCM_SYNCASE_MACRO_P(x) (SCM_MACROP (x) && SCM_MACRO_TYPE (x) == 4)
#define SCM_MACRO_CODE(m) SCM_SMOB_OBJECT (m)
SCM_API scm_t_bits scm_tc16_macro;
@@ -39,10 +46,15 @@ SCM_API scm_t_bits scm_tc16_macro;
SCM_INTERNAL SCM scm_i_makbimacro (SCM code);
SCM_API SCM scm_makmmacro (SCM code);
SCM_API SCM scm_makacro (SCM code);
+SCM_API SCM scm_make_syncase_macro (SCM type, SCM binding);
+SCM_API SCM scm_make_extended_syncase_macro (SCM builtin, SCM type,
+ SCM binding);
SCM_API SCM scm_macro_p (SCM obj);
SCM_API SCM scm_macro_type (SCM m);
SCM_API SCM scm_macro_name (SCM m);
SCM_API SCM scm_macro_transformer (SCM m);
+SCM_API SCM scm_syncase_macro_type (SCM m);
+SCM_API SCM scm_syncase_macro_binding (SCM m);
SCM_API SCM scm_make_synt (const char *name,
SCM (*macroizer) (SCM),
SCM (*fcn) ());
diff --git a/libguile/mallocs.c b/libguile/mallocs.c
index 8fb3ab0ba..6a366aeea 100644
--- a/libguile/mallocs.c
+++ b/libguile/mallocs.c
@@ -2,18 +2,19 @@
* Copyright (C) 1995,1997,1998,2000,2001, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/mallocs.h b/libguile/mallocs.h
index f711ddb94..9c797e9f8 100644
--- a/libguile/mallocs.h
+++ b/libguile/mallocs.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/measure-hwm.scm b/libguile/measure-hwm.scm
deleted file mode 100644
index 53a30d560..000000000
--- a/libguile/measure-hwm.scm
+++ /dev/null
@@ -1,136 +0,0 @@
-;;;; Copyright (C) 2008 Free Software Foundation, Inc.
-;;;;
-;;;; This library is free software; you can redistribute it and/or
-;;;; modify it under the terms of the GNU Lesser General Public
-;;;; License as published by the Free Software Foundation; either
-;;;; version 2.1 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
-;;;;
-
-;;; Commentary:
-
-;;; This code is run during the Guile build, in order to set the stack
-;;; limit to a value that will allow the `make check' tests to pass,
-;;; taking into account the average stack usage on the build platform.
-;;; For more detail, see the text below that gets written out to the
-;;; stack limit calibration file.
-
-;;; Code:
-
-;; Store off Guile's default stack limit.
-(define default-stack-limit (cadr (memq 'stack (debug-options))))
-
-;; Now disable the stack limit, so that we don't get a stack overflow
-;; while running this code!
-(debug-set! stack 0)
-
-;; Define a variable to hold the measured stack high water mark (HWM).
-(define top-repl-hwm-measured 0)
-
-;; Use an evaluator trap to measure the stack size at every
-;; evaluation step, and increase top-repl-hwm-measured if it is less
-;; than the measured stack size.
-(trap-set! enter-frame-handler
- (lambda _
- (let ((stack-size (%get-stack-size)))
- (if (< top-repl-hwm-measured stack-size)
- (set! top-repl-hwm-measured stack-size)))))
-(trap-enable 'enter-frame)
-(trap-enable 'traps)
-
-;; Call (turn-on-debugging) and (top-repl) in order to simulate as
-;; closely as possible what happens - and in particular, how much
-;; stack is used - when a standard Guile REPL is started up.
-;;
-;; `make check' stack overflow errors have been reported in the past
-;; for:
-;;
-;; - test-suite/standalone/test-use-srfi, which runs `guile -q
-;; --use-srfi=...' a few times, with standard input for the REPL
-;; coming from a shell script
-;;
-;; - test-suite/tests/elisp.test, which does not involve the REPL, but
-;; has a lot of `use-modules' calls.
-;;
-;; Stack high water mark (HWM) measurements show that the HWM is
-;; higher in the test-use-srfi case - specifically because of the
-;; complexity of (top-repl) - so that is what we simulate for our
-;; calibration model here.
-(turn-on-debugging)
-(with-output-to-port (%make-void-port "w")
- (lambda ()
- (with-input-from-string "\n" top-repl)))
-
-;; top-repl-hwm-measured now contains the stack HWM that resulted from
-;; running that code.
-
-;; This is the value of top-repl-hwm-measured that we get on a
-;; `canonical' build platform. (See text below for what that means.)
-(define top-repl-hwm-i686-pc-linux-gnu 9461)
-
-;; Using the above results, output code that tests can run in order to
-;; configure the stack limit correctly for the current build platform.
-(format #t "\
-;; Stack limit calibration file.
-;;
-;; This file is automatically generated by Guile when it builds, in
-;; order to set the stack limit to a value that reflects the stack
-;; usage of the build platform (OS + compiler + compilation options),
-;; specifically so that none of Guile's own tests (which are run by
-;; `make check') fail because of a benign stack overflow condition.
-;;
-;; By a `benign' stack overflow condition, we mean one where the test
-;; code is behaving correctly, but exceeds the configured stack limit
-;; because the limit is set too low. A non-benign stack overflow
-;; condition would be if a piece of test code behaved significantly
-;; differently on some platform to how it does normally, and as a
-;; result consumed a lot more stack. Although they seem pretty
-;; unlikely, we would want to catch non-benign conditions like this,
-;; and that is why we don't just do `(debug-set! stack 0)' when
-;; running `make check'.
-;;
-;; Although the primary purpose of this file is to prevent `make
-;; check' from failing without good reason, Guile developers and users
-;; may also find the following information useful, when determining
-;; what stack limit to configure for their own programs.
-
- (let (;; The stack high water mark measured when starting up the
- ;; standard Guile REPL on the current build platform.
- (top-repl-hwm-measured ~a)
-
- ;; The value of top-repl-hwm-measured that we get when building
- ;; Guile on an i686 PC GNU/Linux system, after configuring with
- ;; `./configure --enable-maintainer-mode --with-threads'.
- ;; (Hereafter referred to as the `canonical' build platform.)
- (top-repl-hwm-i686-pc-linux-gnu ~a)
-
- ;; Guile's default stack limit (i.e. the initial, C-coded value
- ;; of the 'stack debug option). In the context of this file,
- ;; the important thing about this number is that we know that
- ;; it allows all of the `make check' tests to pass on the
- ;; canonical build platform.
- (default-stack-limit ~a)
-
- ;; Calibrated stack limit. This is the default stack limit,
- ;; scaled by the factor between top-repl-hwm-i686-pc-linux-gnu
- ;; and top-repl-hwm-measured.
- (calibrated-stack-limit ~a))
-
- ;; Configure the calibrated stack limit.
- (debug-set! stack calibrated-stack-limit))
-"
- top-repl-hwm-measured
- top-repl-hwm-i686-pc-linux-gnu
- default-stack-limit
- ;; Use quotient here to get an integer result, rather than a
- ;; rational.
- (quotient (* default-stack-limit top-repl-hwm-measured)
- top-repl-hwm-i686-pc-linux-gnu))
diff --git a/libguile/modules.c b/libguile/modules.c
index c6b8bbd94..deae23a59 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -418,13 +419,13 @@ SCM_DEFINE (scm_module_local_variable, "module-local-variable", 2, 0, 0,
register SCM b;
- /* SCM_MODULE_TAG is not initialized yet when `boot-9.scm' is being
- evaluated. */
if (scm_module_system_booted_p)
SCM_VALIDATE_MODULE (1, module);
SCM_VALIDATE_SYMBOL (2, sym);
+ if (scm_is_false (module))
+ return scm_hashq_ref (scm_pre_modules_obarray, sym, SCM_UNDEFINED);
/* 1. Check module obarray */
b = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED);
@@ -550,6 +551,21 @@ SCM_DEFINE (scm_standard_interface_eval_closure,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_eval_closure_module,
+ "eval-closure-module", 1, 0, 0,
+ (SCM eval_closure),
+ "Return the module associated with this eval closure.")
+/* the idea is that eval closures are really not the way to do things, they're
+ superfluous given our module system. this function lets mmacros migrate away
+ from eval closures. */
+#define FUNC_NAME s_scm_eval_closure_module
+{
+ SCM_MAKE_VALIDATE_MSG (SCM_ARG1, eval_closure, EVAL_CLOSURE_P,
+ "eval-closure");
+ return SCM_SMOB_OBJECT (eval_closure);
+}
+#undef FUNC_NAME
+
SCM
scm_module_lookup_closure (SCM module)
{
@@ -568,11 +584,20 @@ scm_current_module_lookup_closure ()
return SCM_BOOL_F;
}
+SCM_SYMBOL (sym_sys_pre_modules_transformer, "%pre-modules-transformer");
+
SCM
scm_module_transformer (SCM module)
{
- if (scm_is_false (module))
- return SCM_BOOL_F;
+ if (SCM_UNLIKELY (scm_is_false (module)))
+ { SCM v = scm_hashq_ref (scm_pre_modules_obarray,
+ sym_sys_pre_modules_transformer,
+ SCM_BOOL_F);
+ if (scm_is_false (v))
+ return SCM_BOOL_F;
+ else
+ return SCM_VARIABLE_REF (v);
+ }
else
return SCM_MODULE_TRANSFORMER (module);
}
@@ -580,10 +605,7 @@ scm_module_transformer (SCM module)
SCM
scm_current_module_transformer ()
{
- if (scm_module_system_booted_p)
- return scm_module_transformer (scm_current_module ());
- else
- return SCM_BOOL_F;
+ return scm_module_transformer (scm_current_module ());
}
SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0,
diff --git a/libguile/modules.h b/libguile/modules.h
index 4f42e1888..8108ac3e1 100644
--- a/libguile/modules.h
+++ b/libguile/modules.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1998, 2000, 2001, 2002, 2003, 2006, 2007, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -109,6 +110,7 @@ SCM_API SCM scm_current_module_transformer (void);
SCM_API SCM scm_eval_closure_lookup (SCM eclo, SCM sym, SCM definep);
SCM_API SCM scm_standard_eval_closure (SCM module);
SCM_API SCM scm_standard_interface_eval_closure (SCM module);
+SCM_API SCM scm_eval_closure_module (SCM eval_closure); /* deprecated already */
SCM_API SCM scm_get_pre_modules_obarray (void);
SCM_API SCM scm_lookup_closure_module (SCM proc);
diff --git a/libguile/net_db.c b/libguile/net_db.c
index deb8d381d..4307091f7 100644
--- a/libguile/net_db.c
+++ b/libguile/net_db.c
@@ -1,19 +1,20 @@
/* "net_db.c" network database support
- * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006 Free Software Foundation, Inc.
+ * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -64,6 +65,12 @@
extern int h_errno;
#endif
+#if defined HAVE_HSTRERROR && !HAVE_DECL_HSTRERROR \
+ && !defined __MINGW32__ && !defined __CYGWIN__
+/* Some OSes, such as Tru64 5.1b, lack a declaration for hstrerror(3). */
+extern const char *hstrerror (int);
+#endif
+
SCM_SYMBOL (scm_host_not_found_key, "host-not-found");
diff --git a/libguile/net_db.h b/libguile/net_db.h
index df1f03067..4b6327f27 100644
--- a/libguile/net_db.h
+++ b/libguile/net_db.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/null-threads.c b/libguile/null-threads.c
index 814017564..28eff2c61 100644
--- a/libguile/null-threads.c
+++ b/libguile/null-threads.c
@@ -1,18 +1,19 @@
/* Copyright (C) 2002, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
diff --git a/libguile/null-threads.h b/libguile/null-threads.h
index 5a61dbf50..ec83ab798 100644
--- a/libguile/null-threads.h
+++ b/libguile/null-threads.h
@@ -6,18 +6,19 @@
/* Copyright (C) 2005, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/numbers.c b/libguile/numbers.c
index 7006cccb6..ec4003952 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -1,22 +1,23 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
*
* Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
* and Bellcore. See scm_divide.
*
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -2656,17 +2657,26 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len,
case 'l': case 'L':
case 's': case 'S':
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+
start = idx;
c = mem[idx];
if (c == '-')
{
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+
sign = -1;
c = mem[idx];
}
else if (c == '+')
{
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
+
sign = 1;
c = mem[idx];
}
@@ -2732,6 +2742,10 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
unsigned int idx = *p_idx;
SCM result;
+ /* Start off believing that the number will be exact. This changes
+ to INEXACT if we see a decimal point or a hash. */
+ enum t_exactness x = EXACT;
+
if (idx == len)
return SCM_BOOL_F;
@@ -2743,8 +2757,6 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
if (idx+4 < len && !strncmp (mem+idx, "nan.", 4))
{
- enum t_exactness x = EXACT;
-
/* Cobble up the fractional part. We might want to set the
NaN's mantissa from it. */
idx += 4;
@@ -2763,11 +2775,10 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
return SCM_BOOL_F;
else
result = mem2decimal_from_point (SCM_I_MAKINUM (0), mem, len,
- p_idx, p_exactness);
+ p_idx, &x);
}
else
{
- enum t_exactness x = EXACT;
SCM uinteger;
uinteger = mem2uinteger (mem, len, &idx, radix, &x);
@@ -2781,8 +2792,10 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
SCM divisor;
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
- divisor = mem2uinteger (mem, len, &idx, radix, &x);
+ divisor = mem2uinteger (mem, len, &idx, radix, &x);
if (scm_is_false (divisor))
return SCM_BOOL_F;
@@ -2799,10 +2812,16 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
result = uinteger;
*p_idx = idx;
- if (x == INEXACT)
- *p_exactness = x;
}
+ /* Update *p_exactness if the number just read was inexact. This is
+ important for complex numbers, so that a complex number is
+ treated as inexact overall if either its real or imaginary part
+ is inexact.
+ */
+ if (x == INEXACT)
+ *p_exactness = x;
+
/* When returning an inexact zero, make sure it is represented as a
floating point value so that we can change its sign.
*/
@@ -2897,11 +2916,15 @@ mem2complex (const char* mem, size_t len, unsigned int idx,
if (c == '+')
{
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
sign = 1;
}
else if (c == '-')
{
idx++;
+ if (idx == len)
+ return SCM_BOOL_F;
sign = -1;
}
else
@@ -5353,7 +5376,12 @@ SCM
scm_c_make_polar (double mag, double ang)
{
double s, c;
-#if HAVE_SINCOS
+
+ /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
+ use it on Glibc-based systems that have it (it's a GNU extension). See
+ http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
+ details. */
+#if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
sincos (ang, &s, &c);
#else
s = sin (ang);
@@ -5851,6 +5879,14 @@ scm_i_range_error (SCM bad_val, SCM min, SCM max)
#define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
#include "libguile/conv-uinteger.i.c"
+#define TYPE scm_t_wchar
+#define TYPE_MIN (scm_t_int32)-1
+#define TYPE_MAX (scm_t_int32)0x10ffff
+#define SIZEOF_TYPE 4
+#define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
+#define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
+#include "libguile/conv-integer.i.c"
+
#if SCM_HAVE_T_INT64
#define TYPE scm_t_int64
diff --git a/libguile/numbers.h b/libguile/numbers.h
index e139dac7b..bb72d7ac8 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -3,21 +3,22 @@
#ifndef SCM_NUMBERS_H
#define SCM_NUMBERS_H
-/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -173,6 +174,8 @@ typedef struct scm_t_complex
double imag;
} scm_t_complex;
+typedef scm_t_int32 scm_t_wchar;
+
SCM_API SCM scm_exact_p (SCM x);
@@ -321,6 +324,9 @@ SCM_API SCM scm_from_int32 (scm_t_int32 x);
SCM_API scm_t_uint32 scm_to_uint32 (SCM x);
SCM_API SCM scm_from_uint32 (scm_t_uint32 x);
+SCM_API scm_t_wchar scm_to_wchar (SCM x);
+SCM_API SCM scm_from_wchar (scm_t_wchar x);
+
#if SCM_HAVE_T_INT64
SCM_API scm_t_int64 scm_to_int64 (SCM x);
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 231d2f4b1..33ba296ea 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -1,43 +1,20 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
#if HAVE_CONFIG_H
# include <config.h>
@@ -51,12 +28,14 @@
#include <sys/types.h>
#include <assert.h>
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "programs.h"
#include "objcodes.h"
-/* nb, the length of the header should be a multiple of 8 bytes */
-#define OBJCODE_COOKIE "GOOF-0.5"
+/* SCM_OBJCODE_COOKIE is defined in _scm.h */
+/* The length of the header must be a multiple of 8 bytes. */
+verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0);
/*
@@ -79,25 +58,39 @@ make_objcode_by_mmap (int fd)
if (ret < 0)
SCM_SYSERROR;
- if (st.st_size <= sizeof (struct scm_objcode) + strlen (OBJCODE_COOKIE))
+ if (st.st_size <= sizeof (struct scm_objcode) + strlen (SCM_OBJCODE_COOKIE))
scm_misc_error (FUNC_NAME, "object file too small (~a bytes)",
- SCM_LIST1 (SCM_I_MAKINUM (st.st_size)));
+ scm_list_1 (SCM_I_MAKINUM (st.st_size)));
addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0);
if (addr == MAP_FAILED)
- SCM_SYSERROR;
-
- if (memcmp (addr, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE)))
- SCM_SYSERROR;
-
- data = (struct scm_objcode*)(addr + strlen (OBJCODE_COOKIE));
-
- if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (OBJCODE_COOKIE)))
- scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
- SCM_LIST2 (scm_from_size_t (st.st_size),
- scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
-
- SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (OBJCODE_COOKIE),
+ {
+ (void) close (fd);
+ SCM_SYSERROR;
+ }
+
+ if (memcmp (addr, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE)))
+ {
+ SCM args = scm_list_1 (scm_from_locale_stringn
+ (addr, strlen (SCM_OBJCODE_COOKIE)));
+ (void) close (fd);
+ (void) munmap (addr, st.st_size);
+ scm_misc_error (FUNC_NAME, "bad header on object file: ~s", args);
+ }
+
+ data = (struct scm_objcode*)(addr + strlen (SCM_OBJCODE_COOKIE));
+
+ if (data->len + data->metalen != (st.st_size - sizeof (*data) - strlen (SCM_OBJCODE_COOKIE)))
+ {
+ (void) close (fd);
+ (void) munmap (addr, st.st_size);
+ scm_misc_error (FUNC_NAME, "bad length header (~a, ~a)",
+ scm_list_2 (scm_from_size_t (st.st_size),
+ scm_from_uint32 (sizeof (*data) + data->len
+ + data->metalen)));
+ }
+
+ SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (SCM_OBJCODE_COOKIE),
SCM_PACK (SCM_BOOL_F), fd);
SCM_SET_SMOB_FLAGS (sret, SCM_F_OBJCODE_IS_MMAP);
@@ -108,10 +101,10 @@ make_objcode_by_mmap (int fd)
#undef FUNC_NAME
SCM
-scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr)
+scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr)
#define FUNC_NAME "make-objcode-slice"
{
- struct scm_objcode *data, *parent_data;
+ const struct scm_objcode *data, *parent_data;
SCM ret;
SCM_VALIDATE_OBJCODE (1, parent);
@@ -121,10 +114,16 @@ scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr)
|| ptr >= (parent_data->base + parent_data->len + parent_data->metalen
- sizeof (struct scm_objcode)))
scm_misc_error (FUNC_NAME, "offset out of bounds (~a vs ~a + ~a + ~a)",
- SCM_LIST4 (scm_from_ulong ((unsigned long)ptr),
- scm_from_ulong ((unsigned long)parent_data->base),
- scm_from_uint32 (parent_data->len),
- scm_from_uint32 (parent_data->metalen)));
+ scm_list_4 (scm_from_ulong ((unsigned long)ptr),
+ scm_from_ulong ((unsigned long)parent_data->base),
+ scm_from_uint32 (parent_data->len),
+ scm_from_uint32 (parent_data->metalen)));
+
+#ifdef __GNUC__ /* we need `__alignof__' */
+ /* Make sure bytecode for the objcode-meta is suitable aligned. Failing to
+ do so leads to SIGBUS/SIGSEGV on some arches (e.g., SPARC). */
+ assert ((((scm_t_bits) ptr) & (__alignof__ (struct scm_objcode) - 1UL)) == 0);
+#endif
data = (struct scm_objcode*)ptr;
if (data->base + data->len + data->metalen > parent_data->base + parent_data->len + parent_data->metalen)
@@ -188,8 +187,8 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0,
SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
if (data->len + data->metalen != (size - sizeof (*data)))
scm_misc_error (FUNC_NAME, "bad u8vector size (~a != ~a)",
- SCM_LIST2 (scm_from_size_t (size),
- scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
+ scm_list_2 (scm_from_size_t (size),
+ scm_from_uint32 (sizeof (*data) + data->len + data->metalen)));
assert (increment == 1);
SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_U8VECTOR);
@@ -246,7 +245,7 @@ SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
SCM_VALIDATE_OBJCODE (1, objcode);
SCM_VALIDATE_OUTPUT_PORT (2, port);
- scm_c_write (port, OBJCODE_COOKIE, strlen (OBJCODE_COOKIE));
+ scm_c_write (port, SCM_OBJCODE_COOKIE, strlen (SCM_OBJCODE_COOKIE));
scm_c_write (port, SCM_OBJCODE_DATA (objcode),
sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode));
@@ -259,6 +258,8 @@ void
scm_bootstrap_objcodes (void)
{
scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
+ scm_c_register_extension ("libguile", "scm_init_objcodes",
+ (scm_t_extension_init_func)scm_init_objcodes, NULL);
}
/* Before, we used __BYTE_ORDER, but that is not defined on all
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 222691668..2bb4e6040 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -1,43 +1,20 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
#ifndef _SCM_OBJCODES_H_
#define _SCM_OBJCODES_H_
@@ -48,11 +25,11 @@
struct scm_objcode {
scm_t_uint8 nargs;
scm_t_uint8 nrest;
- scm_t_uint8 nlocs;
- scm_t_uint8 nexts;
+ scm_t_uint16 nlocs;
scm_t_uint32 len; /* the maximum index of base[] */
scm_t_uint32 metalen; /* well, i lie. this many bytes at the end of
base[] for metadata */
+ scm_t_uint32 unused; /* pad so that `base' is 8-byte aligned */
scm_t_uint8 base[0];
};
@@ -60,7 +37,7 @@ struct scm_objcode {
#define SCM_F_OBJCODE_IS_U8VECTOR (1<<1)
#define SCM_F_OBJCODE_IS_SLICE (1<<2)
-extern scm_t_bits scm_tc16_objcode;
+SCM_API scm_t_bits scm_tc16_objcode;
#define SCM_OBJCODE_P(x) (SCM_SMOB_PREDICATE (scm_tc16_objcode, x))
#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_SMOB_DATA (x))
@@ -72,23 +49,22 @@ extern scm_t_bits scm_tc16_objcode;
#define SCM_OBJCODE_NARGS(x) (SCM_OBJCODE_DATA (x)->nargs)
#define SCM_OBJCODE_NREST(x) (SCM_OBJCODE_DATA (x)->nrest)
#define SCM_OBJCODE_NLOCS(x) (SCM_OBJCODE_DATA (x)->nlocs)
-#define SCM_OBJCODE_NEXTS(x) (SCM_OBJCODE_DATA (x)->nexts)
#define SCM_OBJCODE_BASE(x) (SCM_OBJCODE_DATA (x)->base)
#define SCM_OBJCODE_IS_MMAP(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)
#define SCM_OBJCODE_IS_U8VECTOR(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_U8VECTOR)
#define SCM_OBJCODE_IS_SLICE(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE)
-SCM scm_c_make_objcode_slice (SCM parent, scm_t_uint8 *ptr);
-extern SCM scm_load_objcode (SCM file);
-extern SCM scm_objcode_p (SCM obj);
-extern SCM scm_objcode_meta (SCM objcode);
-extern SCM scm_bytecode_to_objcode (SCM bytecode);
-extern SCM scm_objcode_to_bytecode (SCM objcode);
-extern SCM scm_write_objcode (SCM objcode, SCM port);
+SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr);
+SCM_API SCM scm_load_objcode (SCM file);
+SCM_API SCM scm_objcode_p (SCM obj);
+SCM_API SCM scm_objcode_meta (SCM objcode);
+SCM_API SCM scm_bytecode_to_objcode (SCM bytecode);
+SCM_API SCM scm_objcode_to_bytecode (SCM objcode);
+SCM_API SCM scm_write_objcode (SCM objcode, SCM port);
-extern void scm_bootstrap_objcodes (void);
-extern void scm_init_objcodes (void);
+SCM_INTERNAL void scm_bootstrap_objcodes (void);
+SCM_INTERNAL void scm_init_objcodes (void);
#endif /* _SCM_OBJCODES_H_ */
diff --git a/libguile/objects.c b/libguile/objects.c
index 628ddaada..f686c3a00 100644
--- a/libguile/objects.c
+++ b/libguile/objects.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1999,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/objects.h b/libguile/objects.h
index 9b2a0ed5a..914a7ea74 100644
--- a/libguile/objects.h
+++ b/libguile/objects.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1996,1999,2000,2001, 2003, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/objprop.c b/libguile/objprop.c
index 8e9486f54..6dd1da631 100644
--- a/libguile/objprop.c
+++ b/libguile/objprop.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996, 2000, 2001, 2003, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/objprop.h b/libguile/objprop.h
index 7e5365a74..f9a2e945d 100644
--- a/libguile/objprop.h
+++ b/libguile/objprop.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/options.c b/libguile/options.c
index cc3d452e6..ee7001a8c 100644
--- a/libguile/options.c
+++ b/libguile/options.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/options.h b/libguile/options.h
index 4facdce01..8ea960b3c 100644
--- a/libguile/options.h
+++ b/libguile/options.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/pairs.c b/libguile/pairs.c
index cb2d64260..aaaeb110f 100644
--- a/libguile/pairs.c
+++ b/libguile/pairs.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,2000,2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/pairs.h b/libguile/pairs.h
index 61af24efe..a6d44d289 100644
--- a/libguile/pairs.h
+++ b/libguile/pairs.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,2000,2001, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/ports.c b/libguile/ports.c
index 454b51085..2d0e26b39 100644
--- a/libguile/ports.c
+++ b/libguile/ports.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -221,15 +222,14 @@ scm_set_port_close (scm_t_bits tc, int (*close) (SCM))
}
void
-scm_set_port_seek (scm_t_bits tc, off_t (*seek) (SCM port,
- off_t OFFSET,
- int WHENCE))
+scm_set_port_seek (scm_t_bits tc,
+ scm_t_off (*seek) (SCM, scm_t_off, int))
{
scm_ptobs[SCM_TC2PTOBNUM (tc)].seek = seek;
}
void
-scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM port, off_t length))
+scm_set_port_truncate (scm_t_bits tc, void (*truncate) (SCM, scm_t_off))
{
scm_ptobs[SCM_TC2PTOBNUM (tc)].truncate = truncate;
}
@@ -1034,7 +1034,24 @@ scm_fill_input (SCM port)
* This function differs from scm_c_write; it updates port line and
* column. */
-void
+static void
+update_port_lf (scm_t_wchar c, SCM port)
+{
+ if (c == '\a')
+ ; /* Do nothing. */
+ else if (c == '\b')
+ SCM_DECCOL (port);
+ else if (c == '\n')
+ SCM_INCLINE (port);
+ else if (c == '\r')
+ SCM_ZEROCOL (port);
+ else if (c == '\t')
+ SCM_TABCOL (port);
+ else
+ SCM_INCCOL (port);
+}
+
+void
scm_lfwrite (const char *ptr, size_t size, SCM port)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
@@ -1045,30 +1062,54 @@ scm_lfwrite (const char *ptr, size_t size, SCM port)
ptob->write (port, ptr, size);
- for (; size; ptr++, size--) {
- if (*ptr == '\a') {
- }
- else if (*ptr == '\b') {
- SCM_DECCOL(port);
- }
- else if (*ptr == '\n') {
- SCM_INCLINE(port);
- }
- else if (*ptr == '\r') {
- SCM_ZEROCOL(port);
- }
- else if (*ptr == '\t') {
- SCM_TABCOL(port);
- }
- else {
- SCM_INCCOL(port);
+ for (; size; ptr++, size--)
+ update_port_lf ((scm_t_wchar) (unsigned char) *ptr, port);
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_WRITE;
+}
+
+/* Write a scheme string STR to PORT from START inclusive to END
+ exclusive. */
+void
+scm_lfwrite_substr (SCM str, size_t start, size_t end, SCM port)
+{
+ size_t i, size = scm_i_string_length (str);
+ scm_t_port *pt = SCM_PTAB_ENTRY (port);
+ scm_t_ptob_descriptor *ptob = &scm_ptobs[SCM_PTOBNUM (port)];
+ scm_t_wchar p;
+ char *buf;
+ size_t len;
+
+ if (pt->rw_active == SCM_PORT_READ)
+ scm_end_input (port);
+
+ if (end == (size_t) (-1))
+ end = size;
+ size = end - start;
+
+ buf = scm_to_stringn (scm_c_substring (str, start, end), &len,
+ NULL, SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
+ ptob->write (port, buf, len);
+ free (buf);
+
+ for (i = 0; i < size; i++)
+ {
+ p = scm_i_string_ref (str, i + start);
+ update_port_lf (p, port);
}
- }
if (pt->rw_random)
pt->rw_active = SCM_PORT_WRITE;
}
+/* Write a scheme string STR to PORT. */
+void
+scm_lfwrite_str (SCM str, SCM port)
+{
+ scm_lfwrite_substr (str, 0, (size_t) (-1), port);
+}
+
/* scm_c_read
*
* Used by an application to read arbitrary number of bytes from an
@@ -1458,23 +1499,18 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END)
SCM_OUT_OF_RANGE (3, whence);
- if (SCM_OPFPORTP (fd_port))
- {
- /* go direct to fport code to allow 64-bit offsets */
- return scm_i_fport_seek (fd_port, offset, how);
- }
- else if (SCM_OPPORTP (fd_port))
+ if (SCM_OPPORTP (fd_port))
{
scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (fd_port);
- off_t off = scm_to_off_t (offset);
- off_t rv;
+ off_t_or_off64_t off = scm_to_off_t_or_off64_t (offset);
+ off_t_or_off64_t rv;
if (!ptob->seek)
SCM_MISC_ERROR ("port is not seekable",
scm_cons (fd_port, SCM_EOL));
else
rv = ptob->seek (fd_port, off, how);
- return scm_from_off_t (rv);
+ return scm_from_off_t_or_off64_t (rv);
}
else /* file descriptor?. */
{
@@ -1556,14 +1592,9 @@ SCM_DEFINE (scm_truncate_file, "truncate-file", 1, 1, 0,
SCM_SYSCALL (rv = ftruncate_or_ftruncate64 (scm_to_int (object),
c_length));
}
- else if (SCM_OPOUTFPORTP (object))
- {
- /* go direct to fport code to allow 64-bit offsets */
- rv = scm_i_fport_truncate (object, length);
- }
else if (SCM_OPOUTPORTP (object))
{
- off_t c_length = scm_to_off_t (length);
+ off_t_or_off64_t c_length = scm_to_off_t_or_off64_t (length);
scm_t_port *pt = SCM_PTAB_ENTRY (object);
scm_t_ptob_descriptor *ptob = scm_ptobs + SCM_PTOBNUM (object);
diff --git a/libguile/ports.h b/libguile/ports.h
index 5e42a3468..bfe59ae9a 100644
--- a/libguile/ports.h
+++ b/libguile/ports.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -28,8 +29,6 @@
#include "libguile/struct.h"
#include "libguile/threads.h"
-/* Not sure if this is a good idea. We need it for off_t. */
-#include <sys/types.h>
@@ -69,7 +68,7 @@ typedef struct
unsigned char *read_buf; /* buffer start. */
const unsigned char *read_pos;/* the next unread char. */
unsigned char *read_end; /* pointer to last buffered char + 1. */
- off_t read_buf_size; /* size of the buffer. */
+ scm_t_off read_buf_size; /* size of the buffer. */
/* when chars are put back into the buffer, e.g., using peek-char or
unread-string, the read-buffer pointers are switched to cbuf.
@@ -78,7 +77,7 @@ typedef struct
unsigned char *saved_read_buf;
const unsigned char *saved_read_pos;
unsigned char *saved_read_end;
- off_t saved_read_buf_size;
+ scm_t_off saved_read_buf_size;
/* write requests are saved into this buffer at write_pos until it
reaches write_buf + write_buf_size, then the ptob flush is
@@ -87,7 +86,7 @@ typedef struct
unsigned char *write_buf; /* buffer start. */
unsigned char *write_pos; /* pointer to last buffered char + 1. */
unsigned char *write_end; /* pointer to end of buffer + 1. */
- off_t write_buf_size; /* size of the buffer. */
+ scm_t_off write_buf_size; /* size of the buffer. */
unsigned char shortbuf; /* buffer for "unbuffered" streams. */
@@ -156,11 +155,11 @@ SCM_INTERNAL SCM scm_i_port_weak_hash;
#define SCM_REVEALED(x) (SCM_PTAB_ENTRY(x)->revealed)
#define SCM_SETREVEALED(x, s) (SCM_PTAB_ENTRY(x)->revealed = (s))
-#define SCM_INCLINE(port) {SCM_LINUM (port) += 1; SCM_COL (port) = 0;}
-#define SCM_ZEROCOL(port) {SCM_COL (port) = 0;}
-#define SCM_INCCOL(port) {SCM_COL (port) += 1;}
-#define SCM_DECCOL(port) {if (SCM_COL (port) > 0) SCM_COL (port) -= 1;}
-#define SCM_TABCOL(port) {SCM_COL (port) += 8 - SCM_COL (port) % 8;}
+#define SCM_INCLINE(port) do {SCM_LINUM (port) += 1; SCM_COL (port) = 0;} while (0)
+#define SCM_ZEROCOL(port) do {SCM_COL (port) = 0;} while (0)
+#define SCM_INCCOL(port) do {SCM_COL (port) += 1;} while (0)
+#define SCM_DECCOL(port) do {if (SCM_COL (port) > 0) SCM_COL (port) -= 1;} while (0)
+#define SCM_TABCOL(port) do {SCM_COL (port) += 8 - SCM_COL (port) % 8;} while (0)
/* Maximum number of port types. */
#define SCM_I_MAX_PORT_TYPE_COUNT 256
@@ -184,8 +183,8 @@ typedef struct scm_t_ptob_descriptor
int (*fill_input) (SCM port);
int (*input_waiting) (SCM port);
- off_t (*seek) (SCM port, off_t OFFSET, int WHENCE);
- void (*truncate) (SCM port, off_t length);
+ scm_t_off (*seek) (SCM port, scm_t_off OFFSET, int WHENCE);
+ void (*truncate) (SCM port, scm_t_off length);
} scm_t_ptob_descriptor;
@@ -222,12 +221,12 @@ SCM_API void scm_set_port_end_input (scm_t_bits tc,
void (*end_input) (SCM port,
int offset));
SCM_API void scm_set_port_seek (scm_t_bits tc,
- off_t (*seek) (SCM port,
- off_t OFFSET,
- int WHENCE));
+ scm_t_off (*seek) (SCM port,
+ scm_t_off OFFSET,
+ int WHENCE));
SCM_API void scm_set_port_truncate (scm_t_bits tc,
void (*truncate) (SCM port,
- off_t length));
+ scm_t_off length));
SCM_API void scm_set_port_input_waiting (scm_t_bits tc, int (*input_waiting) (SCM));
SCM_API SCM scm_char_ready_p (SCM port);
size_t scm_take_from_input_buffers (SCM port, char *dest, size_t read_len);
@@ -269,6 +268,9 @@ SCM_API SCM scm_read_char (SCM port);
SCM_API size_t scm_c_read (SCM port, void *buffer, size_t size);
SCM_API void scm_c_write (SCM port, const void *buffer, size_t size);
SCM_API void scm_lfwrite (const char *ptr, size_t size, SCM port);
+SCM_INTERNAL void scm_lfwrite_str (SCM str, SCM port);
+SCM_INTERNAL void scm_lfwrite_substr (SCM str, size_t start, size_t end,
+ SCM port);
SCM_API void scm_flush (SCM port);
SCM_API void scm_end_input (SCM port);
SCM_API int scm_fill_input (SCM port);
diff --git a/libguile/posix.c b/libguile/posix.c
index b5082fa0a..8f2990436 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -21,6 +22,7 @@
# include <config.h>
#endif
+#include <stdlib.h>
#include <stdio.h>
#include <errno.h>
@@ -33,6 +35,7 @@
#include "libguile/srfi-13.h"
#include "libguile/srfi-14.h"
#include "libguile/vectors.h"
+#include "libguile/values.h"
#include "libguile/lang.h"
#include "libguile/validate.h"
@@ -99,8 +102,6 @@ extern char *ttyname();
#include <signal.h>
-extern char ** environ;
-
#ifdef HAVE_GRP_H
#include <grp.h>
#endif
@@ -136,13 +137,7 @@ extern char ** environ;
# include <sys/resource.h>
#endif
-#if HAVE_SYS_FILE_H
-# include <sys/file.h>
-#endif
-
-#if HAVE_CRT_EXTERNS_H
-#include <crt_externs.h> /* for Darwin _NSGetEnviron */
-#endif
+#include <sys/file.h> /* from Gnulib */
/* Some Unix systems don't define these. CPP hair is dangerous, but
this seems safe enough... */
@@ -196,13 +191,6 @@ int sethostname (char *name, size_t namelen);
-/* On Apple Darwin in a shared library there's no "environ" to access
- directly, instead the address of that variable must be obtained with
- _NSGetEnviron(). */
-#if HAVE__NSGETENVIRON && defined (PIC)
-#define environ (*_NSGetEnviron())
-#endif
-
/* Two often used patterns
@@ -463,6 +451,179 @@ SCM_DEFINE (scm_setgrent, "setgr", 0, 1, 0,
#endif /* HAVE_GETGRENT */
+#ifdef HAVE_GETRLIMIT
+#ifdef RLIMIT_AS
+SCM_SYMBOL (sym_as, "as");
+#endif
+#ifdef RLIMIT_CORE
+SCM_SYMBOL (sym_core, "core");
+#endif
+#ifdef RLIMIT_CPU
+SCM_SYMBOL (sym_cpu, "cpu");
+#endif
+#ifdef RLIMIT_DATA
+SCM_SYMBOL (sym_data, "data");
+#endif
+#ifdef RLIMIT_FSIZE
+SCM_SYMBOL (sym_fsize, "fsize");
+#endif
+#ifdef RLIMIT_MEMLOCK
+SCM_SYMBOL (sym_memlock, "memlock");
+#endif
+#ifdef RLIMIT_MSGQUEUE
+SCM_SYMBOL (sym_msgqueue, "msgqueue");
+#endif
+#ifdef RLIMIT_NICE
+SCM_SYMBOL (sym_nice, "nice");
+#endif
+#ifdef RLIMIT_NOFILE
+SCM_SYMBOL (sym_nofile, "nofile");
+#endif
+#ifdef RLIMIT_NPROC
+SCM_SYMBOL (sym_nproc, "nproc");
+#endif
+#ifdef RLIMIT_RSS
+SCM_SYMBOL (sym_rss, "rss");
+#endif
+#ifdef RLIMIT_RTPRIO
+SCM_SYMBOL (sym_rtprio, "rtprio");
+#endif
+#ifdef RLIMIT_RTPRIO
+SCM_SYMBOL (sym_rttime, "rttime");
+#endif
+#ifdef RLIMIT_SIGPENDING
+SCM_SYMBOL (sym_sigpending, "sigpending");
+#endif
+#ifdef RLIMIT_STACK
+SCM_SYMBOL (sym_stack, "stack");
+#endif
+
+static int
+scm_to_resource (SCM s, const char *func, int pos)
+{
+ if (scm_is_number (s))
+ return scm_to_int (s);
+
+ SCM_ASSERT_TYPE (scm_is_symbol (s), s, pos, func, "symbol");
+
+#ifdef RLIMIT_AS
+ if (s == sym_as)
+ return RLIMIT_AS;
+#endif
+#ifdef RLIMIT_CORE
+ if (s == sym_core)
+ return RLIMIT_CORE;
+#endif
+#ifdef RLIMIT_CPU
+ if (s == sym_cpu)
+ return RLIMIT_CPU;
+#endif
+#ifdef RLIMIT_DATA
+ if (s == sym_data)
+ return RLIMIT_DATA;
+#endif
+#ifdef RLIMIT_FSIZE
+ if (s == sym_fsize)
+ return RLIMIT_FSIZE;
+#endif
+#ifdef RLIMIT_MEMLOCK
+ if (s == sym_memlock)
+ return RLIMIT_MEMLOCK;
+#endif
+#ifdef RLIMIT_MSGQUEUE
+ if (s == sym_msgqueue)
+ return RLIMIT_MSGQUEUE;
+#endif
+#ifdef RLIMIT_NICE
+ if (s == sym_nice)
+ return RLIMIT_NICE;
+#endif
+#ifdef RLIMIT_NOFILE
+ if (s == sym_nofile)
+ return RLIMIT_NOFILE;
+#endif
+#ifdef RLIMIT_NPROC
+ if (s == sym_nproc)
+ return RLIMIT_NPROC;
+#endif
+#ifdef RLIMIT_RSS
+ if (s == sym_rss)
+ return RLIMIT_RSS;
+#endif
+#ifdef RLIMIT_RTPRIO
+ if (s == sym_rtprio)
+ return RLIMIT_RTPRIO;
+#endif
+#ifdef RLIMIT_RTPRIO
+ if (s == sym_rttime)
+ return RLIMIT_RTPRIO;
+#endif
+#ifdef RLIMIT_SIGPENDING
+ if (s == sym_sigpending)
+ return RLIMIT_SIGPENDING;
+#endif
+#ifdef RLIMIT_STACK
+ if (s == sym_stack)
+ return RLIMIT_STACK;
+#endif
+
+ scm_misc_error (func, "invalid rlimit resource ~A", scm_list_1 (s));
+ return 0;
+}
+
+SCM_DEFINE (scm_getrlimit, "getrlimit", 1, 0, 0,
+ (SCM resource),
+ "Get a resource limit for this process. @var{resource} identifies the resource,\n"
+ "either as an integer or as a symbol. For example, @code{(getrlimit 'stack)}\n"
+ "gets the limits associated with @code{RLIMIT_STACK}.\n\n"
+ "@code{getrlimit} returns two values, the soft and the hard limit. If no\n"
+ "limit is set for the resource in question, the returned limit will be @code{#f}.")
+#define FUNC_NAME s_scm_getrlimit
+{
+ int iresource;
+ struct rlimit lim = { 0, 0 };
+
+ iresource = scm_to_resource (resource, FUNC_NAME, 1);
+
+ if (getrlimit (iresource, &lim) != 0)
+ scm_syserror (FUNC_NAME);
+
+ return scm_values (scm_list_2 ((lim.rlim_cur == RLIM_INFINITY) ? SCM_BOOL_F
+ : scm_from_long (lim.rlim_cur),
+ (lim.rlim_max == RLIM_INFINITY) ? SCM_BOOL_F
+ : scm_from_long (lim.rlim_max)));
+}
+#undef FUNC_NAME
+
+
+#ifdef HAVE_SETRLIMIT
+SCM_DEFINE (scm_setrlimit, "setrlimit", 3, 0, 0,
+ (SCM resource, SCM soft, SCM hard),
+ "Set a resource limit for this process. @var{resource} identifies the resource,\n"
+ "either as an integer or as a symbol. @var{soft} and @var{hard} should be integers,\n"
+ "or @code{#f} to indicate no limit (i.e., @code{RLIM_INFINITY}).\n\n"
+ "For example, @code{(setrlimit 'stack 150000 300000)} sets the @code{RLIMIT_STACK}\n"
+ "limit to 150 kilobytes, with a hard limit of 300 kB.")
+#define FUNC_NAME s_scm_setrlimit
+{
+ int iresource;
+ struct rlimit lim = { 0, 0 };
+
+ iresource = scm_to_resource (resource, FUNC_NAME, 1);
+
+ lim.rlim_cur = (soft == SCM_BOOL_F) ? RLIM_INFINITY : scm_to_long (soft);
+ lim.rlim_max = (hard == SCM_BOOL_F) ? RLIM_INFINITY : scm_to_long (hard);
+
+ if (setrlimit (iresource, &lim) != 0)
+ scm_syserror (FUNC_NAME);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SETRLIMIT */
+#endif /* HAVE_GETRLIMIT */
+
+
SCM_DEFINE (scm_kill, "kill", 2, 0, 0,
(SCM pid, SCM sig),
"Sends a signal to the specified process or group of processes.\n\n"
@@ -1311,98 +1472,13 @@ SCM_DEFINE (scm_putenv, "putenv", 1, 0, 0,
int rv;
char *c_str = scm_to_locale_string (str);
- if (strchr (c_str, '=') == NULL)
- {
- /* We want no "=" in the argument to mean remove the variable from the
- environment, but not all putenv()s understand this, for example
- FreeBSD 4.8 doesn't. Getting it happening everywhere is a bit
- painful. What unsetenv() exists, we use that, of course.
-
- Traditionally putenv("NAME") removes a variable, for example that's
- what we have to do on Solaris 9 (it doesn't have an unsetenv).
-
- But on DOS and on that DOS overlay manager thing called W-whatever,
- putenv("NAME=") must be used (it too doesn't have an unsetenv).
-
- Supposedly on AIX a putenv("NAME") could cause a segfault, but also
- supposedly AIX 5.3 and up has unsetenv() available so should be ok
- with the latter there.
-
- For the moment we hard code the DOS putenv("NAME=") style under
- __MINGW32__ and do the traditional everywhere else. Such
- system-name tests are bad, of course. It'd be possible to use a
- configure test when doing a a native build. For example GNU R has
- such a test (see R_PUTENV_AS_UNSETENV in
- https://svn.r-project.org/R/trunk/m4/R.m4). But when cross
- compiling there'd want to be a guess, one probably based on the
- system name (ie. mingw or not), thus landing back in basically the
- present hard-coded situation. Another possibility for a cross
- build would be to try "NAME" then "NAME=" at runtime, if that's not
- too much like overkill. */
-
-#if HAVE_UNSETENV
- /* when unsetenv() exists then we use it */
- unsetenv (c_str);
- free (c_str);
-#elif defined (__MINGW32__)
- /* otherwise putenv("NAME=") on DOS */
- int e;
- size_t len = strlen (c_str);
- char *ptr = scm_malloc (len + 2);
- strcpy (ptr, c_str);
- strcpy (ptr+len, "=");
- rv = putenv (ptr);
- e = errno; free (ptr); free (c_str); errno = e;
- if (rv < 0)
- SCM_SYSERROR;
-#else
- /* otherwise traditional putenv("NAME") */
- rv = putenv (c_str);
- if (rv < 0)
- SCM_SYSERROR;
-#endif
- }
- else
- {
-#ifdef __MINGW32__
- /* If str is "FOO=", ie. attempting to set an empty string, then
- we need to see if it's been successful. On MINGW, "FOO="
- means remove FOO from the environment. As a workaround, we
- set "FOO= ", ie. a space, and then modify the string returned
- by getenv. It's not enough just to modify the string we set,
- because MINGW putenv copies it. */
-
- {
- size_t len = strlen (c_str);
- if (c_str[len-1] == '=')
- {
- char *ptr = scm_malloc (len+2);
- strcpy (ptr, c_str);
- strcpy (ptr+len, " ");
- rv = putenv (ptr);
- if (rv < 0)
- {
- int eno = errno;
- free (c_str);
- errno = eno;
- SCM_SYSERROR;
- }
- /* truncate to just the name */
- c_str[len-1] = '\0';
- ptr = getenv (c_str);
- if (ptr)
- ptr[0] = '\0';
- return SCM_UNSPECIFIED;
- }
- }
-#endif /* __MINGW32__ */
+ /* Leave C_STR in the environment. */
- /* Leave c_str in the environment. */
+ /* Gnulib's `putenv' module honors the semantics described above. */
+ rv = putenv (c_str);
+ if (rv < 0)
+ SCM_SYSERROR;
- rv = putenv (c_str);
- if (rv < 0)
- SCM_SYSERROR;
- }
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -1668,6 +1744,11 @@ SCM_DEFINE (scm_getlogin, "getlogin", 0, 0, 0,
#endif /* HAVE_GETLOGIN */
#if HAVE_CUSERID
+
+# if !HAVE_DECL_CUSERID
+extern char *cuserid (char *);
+# endif
+
SCM_DEFINE (scm_cuserid, "cuserid", 0, 0, 0,
(void),
"Return a string containing a user name associated with the\n"
@@ -1777,73 +1858,6 @@ SCM_DEFINE (scm_getpass, "getpass", 1, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_GETPASS */
-/* Wrapper function for flock() support under M$-Windows. */
-#ifdef __MINGW32__
-# include <io.h>
-# include <sys/locking.h>
-# include <errno.h>
-# ifndef _LK_UNLCK
- /* Current MinGW package fails to define this. *sigh* */
-# define _LK_UNLCK 0
-# endif
-# define LOCK_EX 1
-# define LOCK_UN 2
-# define LOCK_SH 4
-# define LOCK_NB 8
-
-static int flock (int fd, int operation)
-{
- long pos, len;
- int ret, err;
-
- /* Disable invalid arguments. */
- if (((operation & (LOCK_EX | LOCK_SH)) == (LOCK_EX | LOCK_SH)) ||
- ((operation & (LOCK_EX | LOCK_UN)) == (LOCK_EX | LOCK_UN)) ||
- ((operation & (LOCK_SH | LOCK_UN)) == (LOCK_SH | LOCK_UN)))
- {
- errno = EINVAL;
- return -1;
- }
-
- /* Determine mode of operation and discard unsupported ones. */
- if (operation == (LOCK_NB | LOCK_EX))
- operation = _LK_NBLCK;
- else if (operation & LOCK_UN)
- operation = _LK_UNLCK;
- else if (operation == LOCK_EX)
- operation = _LK_LOCK;
- else
- {
- errno = EINVAL;
- return -1;
- }
-
- /* Save current file pointer and seek to beginning. */
- if ((pos = lseek (fd, 0, SEEK_CUR)) == -1 || (len = filelength (fd)) == -1)
- return -1;
- lseek (fd, 0L, SEEK_SET);
-
- /* Deadlock if necessary. */
- do
- {
- ret = _locking (fd, operation, len);
- }
- while (ret == -1 && errno == EDEADLOCK);
-
- /* Produce meaningful error message. */
- if (errno == EACCES && operation == _LK_NBLCK)
- err = EDEADLOCK;
- else
- err = errno;
-
- /* Return to saved file position pointer. */
- lseek (fd, pos, SEEK_SET);
- errno = err;
- return ret;
-}
-#endif /* __MINGW32__ */
-
-#if HAVE_FLOCK || defined (__MINGW32__)
SCM_DEFINE (scm_flock, "flock", 2, 0, 0,
(SCM file, SCM operation),
"Apply or remove an advisory lock on an open file.\n"
@@ -1887,7 +1901,6 @@ SCM_DEFINE (scm_flock, "flock", 2, 0, 0,
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
-#endif /* HAVE_FLOCK */
#if HAVE_SETHOSTNAME
SCM_DEFINE (scm_sethostname, "sethostname", 1, 0, 0,
diff --git a/libguile/posix.h b/libguile/posix.h
index 34e1fc77f..4d057643c 100644
--- a/libguile/posix.h
+++ b/libguile/posix.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -41,6 +42,8 @@ SCM_API SCM scm_getpwuid (SCM user);
SCM_API SCM scm_setpwent (SCM arg);
SCM_API SCM scm_getgrgid (SCM name);
SCM_API SCM scm_setgrent (SCM arg);
+SCM_API SCM scm_getrlimit (SCM resource);
+SCM_API SCM scm_setrlimit (SCM resource, SCM soft, SCM hard);
SCM_API SCM scm_kill (SCM pid, SCM sig);
SCM_API SCM scm_waitpid (SCM pid, SCM options);
SCM_API SCM scm_status_exit_val (SCM status);
diff --git a/libguile/print.c b/libguile/print.c
index 1852cf19a..7a4aaa3ca 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995-1999,2000,2001, 2002, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -22,6 +23,8 @@
#endif
#include <errno.h>
+#include <uniconv.h>
+#include <unictype.h>
#include "libguile/_scm.h"
#include "libguile/chars.h"
@@ -435,21 +438,33 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc3_imm24:
if (SCM_CHARP (exp))
{
- long i = SCM_CHAR (exp);
+ scm_t_wchar i = SCM_CHAR (exp);
+ const char *name;
if (SCM_WRITINGP (pstate))
{
scm_puts ("#\\", port);
- if ((i >= 0) && (i <= ' ') && scm_charnames[i])
- scm_puts (scm_charnames[i], port);
-#ifndef EBCDIC
- else if (i == '\177')
- scm_puts (scm_charnames[scm_n_charnames - 1], port);
-#endif
- else if (i < 0 || i > '\177')
- scm_intprint (i, 8, port);
- else
- scm_putc (i, port);
+ name = scm_i_charname (exp);
+ if (name != NULL)
+ scm_puts (name, port);
+ else if (uc_is_general_category_withtable (i, UC_CATEGORY_MASK_L
+ | UC_CATEGORY_MASK_M
+ | UC_CATEGORY_MASK_N
+ | UC_CATEGORY_MASK_P
+ | UC_CATEGORY_MASK_S))
+ /* Print the character if is graphic character. */
+ {
+ if (i<256)
+ /* Character is graphic. Print it. */
+ scm_putc (i, port);
+ else
+ /* Character is graphic but unrepresentable in
+ this port's encoding. */
+ scm_intprint (i, 8, port);
+ }
+ else
+ /* Character is a non-graphical character. */
+ scm_intprint (i, 8, port);
}
else
scm_putc (i, port);
@@ -545,55 +560,113 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
break;
}
break;
- case scm_tc7_string:
- if (SCM_WRITINGP (pstate))
- {
- size_t i, j, len;
- const char *data;
-
- scm_putc ('"', port);
- len = scm_i_string_length (exp);
- data = scm_i_string_chars (exp);
- for (i = 0, j = 0; i < len; ++i)
- {
- unsigned char ch = data[i];
- if ((ch < 32 && ch != '\n') || (127 <= ch && ch < 148))
- {
- static char const hex[]="0123456789abcdef";
- char buf[4];
-
- scm_lfwrite (data+j, i-j, port);
- buf[0] = '\\';
- buf[1] = 'x';
- buf[2] = hex [ch / 16];
- buf[3] = hex [ch % 16];
- scm_lfwrite (buf, 4, port);
- data = scm_i_string_chars (exp);
- j = i+1;
- }
- else if (ch == '"' || ch == '\\')
- {
- scm_lfwrite (data+j, i-j, port);
- scm_putc ('\\', port);
- data = scm_i_string_chars (exp);
- j = i;
- }
- }
- scm_lfwrite (data+j, i-j, port);
- scm_putc ('"', port);
- scm_remember_upto_here_1 (exp);
- }
- else
- scm_lfwrite (scm_i_string_chars (exp), scm_i_string_length (exp),
- port);
- scm_remember_upto_here_1 (exp);
- break;
+ case scm_tc7_string:
+ if (SCM_WRITINGP (pstate))
+ {
+ size_t i, j, len;
+ static char const hex[] = "0123456789abcdef";
+ char buf[8];
+
+
+ scm_putc ('"', port);
+ len = scm_i_string_length (exp);
+ for (i = 0; i < len; ++i)
+ {
+ scm_t_wchar ch = scm_i_string_ref (exp, i);
+ int printed = 0;
+
+ if (ch == ' ' || ch == '\n')
+ {
+ scm_putc (ch, port);
+ printed = 1;
+ }
+ else if (ch == '"' || ch == '\\')
+ {
+ scm_putc ('\\', port);
+ scm_i_charprint (ch, port);
+ printed = 1;
+ }
+ else
+ if (uc_is_general_category_withtable
+ (ch,
+ UC_CATEGORY_MASK_L | UC_CATEGORY_MASK_M |
+ UC_CATEGORY_MASK_N | UC_CATEGORY_MASK_P |
+ UC_CATEGORY_MASK_S))
+ {
+ /* Print the character since it is a graphic
+ character. */
+ scm_t_wchar *wbuf;
+ SCM wstr = scm_i_make_wide_string (1, &wbuf);
+ char *buf;
+ size_t len;
+
+ wbuf[0] = ch;
+
+ buf = u32_conv_to_encoding ("ISO-8859-1",
+ iconveh_error,
+ (scm_t_uint32 *) wbuf,
+ 1, NULL, NULL, &len);
+ if (buf != NULL)
+ {
+ /* Character is graphic and representable in
+ this encoding. Print it. */
+ scm_lfwrite_str (wstr, port);
+ free (buf);
+ printed = 1;
+ }
+ }
+
+ if (!printed)
+ {
+ /* Character is graphic but unrepresentable in
+ this port's encoding or is not graphic. */
+ if (ch <= 0xFF)
+ {
+ buf[0] = '\\';
+ buf[1] = 'x';
+ buf[2] = hex[ch / 16];
+ buf[3] = hex[ch % 16];
+ scm_lfwrite (buf, 4, port);
+ }
+ else if (ch <= 0xFFFF)
+ {
+ buf[0] = '\\';
+ buf[1] = 'u';
+ buf[2] = hex[(ch & 0xF000) >> 12];
+ buf[3] = hex[(ch & 0xF00) >> 8];
+ buf[4] = hex[(ch & 0xF0) >> 4];
+ buf[5] = hex[(ch & 0xF)];
+ scm_lfwrite (buf, 6, port);
+ j = i + 1;
+ }
+ else if (ch > 0xFFFF)
+ {
+ buf[0] = '\\';
+ buf[1] = 'U';
+ buf[2] = hex[(ch & 0xF00000) >> 20];
+ buf[3] = hex[(ch & 0xF0000) >> 16];
+ buf[4] = hex[(ch & 0xF000) >> 12];
+ buf[5] = hex[(ch & 0xF00) >> 8];
+ buf[6] = hex[(ch & 0xF0) >> 4];
+ buf[7] = hex[(ch & 0xF)];
+ scm_lfwrite (buf, 8, port);
+ j = i + 1;
+ }
+ }
+ }
+ scm_putc ('"', port);
+ scm_remember_upto_here_1 (exp);
+ }
+ else
+ scm_lfwrite (scm_i_string_chars (exp), scm_i_string_length (exp),
+ port);
+ scm_remember_upto_here_1 (exp);
+ break;
case scm_tc7_symbol:
if (scm_i_symbol_is_interned (exp))
{
scm_print_symbol_name (scm_i_symbol_chars (exp),
- scm_i_symbol_length (exp),
- port);
+ scm_i_symbol_length (exp), port);
scm_remember_upto_here_1 (exp);
}
else
@@ -668,7 +741,7 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
? "#<primitive-generic "
: "#<primitive-procedure ",
port);
- scm_puts (scm_i_symbol_chars (SCM_SNAME (exp)), port);
+ scm_puts (scm_i_symbol_chars (SCM_SUBR_NAME (exp)), port);
scm_putc ('>', port);
break;
@@ -763,6 +836,17 @@ scm_prin1 (SCM exp, SCM port, int writingp)
}
}
+/* Print a character.
+ */
+void
+scm_i_charprint (scm_t_uint32 ch, SCM port)
+{
+ scm_t_wchar *wbuf;
+ SCM wstr = scm_i_make_wide_string (1, &wbuf);
+
+ wbuf[0] = ch;
+ scm_lfwrite_str (wstr, port);
+}
/* Print an integer.
*/
diff --git a/libguile/print.h b/libguile/print.h
index 8974a7554..00648efc1 100644
--- a/libguile/print.h
+++ b/libguile/print.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -76,6 +77,7 @@ SCM_API SCM scm_print_options (SCM setting);
SCM_API SCM scm_make_print_state (void);
SCM_API void scm_free_print_state (SCM print_state);
SCM_INTERNAL SCM scm_i_port_with_print_state (SCM port, SCM print_state);
+SCM_INTERNAL void scm_i_charprint (scm_t_uint32 c, SCM port);
SCM_API void scm_intprint (scm_t_intmax n, int radix, SCM port);
SCM_API void scm_uintprint (scm_t_uintmax n, int radix, SCM port);
SCM_API void scm_ipruk (char *hdr, SCM ptr, SCM port);
diff --git a/libguile/private-gc.h b/libguile/private-gc.h
index b38addebd..38d953f3c 100644
--- a/libguile/private-gc.h
+++ b/libguile/private-gc.h
@@ -1,21 +1,22 @@
/*
* private-gc.h - private declarations for garbage collection.
*
- * Copyright (C) 2002, 03, 04, 05, 06, 07, 08 Free Software Foundation, Inc.
+ * Copyright (C) 2002, 03, 04, 05, 06, 07, 08, 09 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifndef PRIVATE_GC
@@ -103,11 +104,10 @@ typedef enum { return_on_error, abort_on_error } policy_on_error;
gc-mark
*/
-/* this can be used to ensure that set/clear gc marks only happen when
- allowed. */
-int scm_i_marking;
+/* Non-zero while in the mark phase. */
+SCM_INTERNAL int scm_i_marking;
-void scm_mark_all (void);
+SCM_INTERNAL void scm_mark_all (void);
extern long int scm_i_deprecated_memory_return;
extern long int scm_i_find_heap_calls;
diff --git a/libguile/private-options.h b/libguile/private-options.h
index eeaf0c17b..ffb699bee 100644
--- a/libguile/private-options.h
+++ b/libguile/private-options.h
@@ -7,18 +7,19 @@
* Copyright (C) 2007 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifndef PRIVATE_OPTIONS
diff --git a/libguile/procprop.c b/libguile/procprop.c
index db16834c5..df96eaad4 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/procprop.h b/libguile/procprop.h
index bf27dba0a..04cd38442 100644
--- a/libguile/procprop.h
+++ b/libguile/procprop.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1998,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/procs.c b/libguile/procs.c
index c695668e2..b67bfd90b 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -45,15 +46,19 @@ SCM
scm_c_make_subr (const char *name, long type, SCM (*fcn) ())
{
register SCM z;
+ SCM sname;
SCM *meta_info;
meta_info = scm_gc_malloc (2 * sizeof (*meta_info), "subr meta-info");
- meta_info[0] = scm_from_locale_symbol (name);
+ sname = scm_from_locale_symbol (name);
+ meta_info[0] = sname;
meta_info[1] = SCM_EOL; /* properties */
z = scm_double_cell ((scm_t_bits) type, (scm_t_bits) fcn,
0 /* generic */, (scm_t_bits) meta_info);
+ scm_remember_upto_here_1 (sname);
+
return z;
}
@@ -61,7 +66,7 @@ SCM
scm_c_define_subr (const char *name, long type, SCM (*fcn) ())
{
SCM subr = scm_c_make_subr (name, type, fcn);
- scm_define (SCM_SNAME (subr), subr);
+ scm_define (SCM_SUBR_NAME (subr), subr);
return subr;
}
@@ -79,7 +84,7 @@ scm_c_define_subr_with_generic (const char *name,
long type, SCM (*fcn) (), SCM *gf)
{
SCM subr = scm_c_make_subr_with_generic (name, type, fcn, gf);
- scm_define (SCM_SNAME (subr), subr);
+ scm_define (SCM_SUBR_NAME (subr), subr);
return subr;
}
@@ -223,7 +228,7 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0,
lookup */
switch (SCM_TYP7 (procedure)) {
case scm_tcs_subrs:
- name = SCM_SNAME (procedure);
+ name = SCM_SUBR_NAME (procedure);
break;
default:
name = scm_procedure_property (procedure, scm_sym_name);
diff --git a/libguile/procs.h b/libguile/procs.h
index 3ccf1ee33..469b735d9 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -31,7 +32,7 @@
*/
#define SCM_SUBR_META_INFO(x) ((SCM *) SCM_CELL_WORD_3 (x))
-#define SCM_SNAME(x) (SCM_SUBR_META_INFO (x) [0])
+#define SCM_SUBR_NAME(x) (SCM_SUBR_META_INFO (x) [0])
#define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x))
#define SCM_DSUBRF(x) ((double (*)()) SCM_CELL_WORD_1 (x))
#define SCM_SUBR_PROPS(x) (SCM_SUBR_META_INFO (x) [1])
diff --git a/libguile/programs.c b/libguile/programs.c
index 1fcfc54c8..d62a3a085 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -1,49 +1,27 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
#if HAVE_CONFIG_H
# include <config.h>
#endif
#include <string.h>
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "instructions.h"
#include "modules.h"
@@ -58,7 +36,7 @@ scm_t_bits scm_tc16_program;
static SCM write_program = SCM_BOOL_F;
SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
- (SCM objcode, SCM objtable, SCM external),
+ (SCM objcode, SCM objtable, SCM free_variables),
"")
#define FUNC_NAME s_scm_make_program
{
@@ -67,18 +45,12 @@ SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0,
objtable = SCM_BOOL_F;
else if (scm_is_true (objtable))
SCM_VALIDATE_VECTOR (2, objtable);
- if (SCM_UNLIKELY (SCM_UNBNDP (external)))
- external = SCM_EOL;
- else
- /* FIXME: currently this test is quite expensive (can be 2-3% of total
- execution time in programs that make many closures). We could remove it,
- yes, but we'd get much better gains if we used some other method, like
- just capturing the variables that we need instead of all heap-allocated
- variables. Dunno. Keeping the check for now, as it's a user-callable
- function, and inlining the op in the vm's make-closure operation. */
- SCM_VALIDATE_LIST (3, external);
-
- SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, external);
+ if (SCM_UNLIKELY (SCM_UNBNDP (free_variables)))
+ free_variables = SCM_BOOL_F;
+ else if (free_variables != SCM_BOOL_F)
+ SCM_VALIDATE_VECTOR (3, free_variables);
+
+ SCM_RETURN_NEWSMOB3 (scm_tc16_program, objcode, objtable, free_variables);
}
#undef FUNC_NAME
@@ -163,10 +135,9 @@ SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0,
SCM_VALIDATE_PROGRAM (1, program);
p = SCM_PROGRAM_DATA (program);
- return SCM_LIST4 (SCM_I_MAKINUM (p->nargs),
- SCM_I_MAKINUM (p->nrest),
- SCM_I_MAKINUM (p->nlocs),
- SCM_I_MAKINUM (p->nexts));
+ return scm_list_3 (SCM_I_MAKINUM (p->nargs),
+ SCM_I_MAKINUM (p->nrest),
+ SCM_I_MAKINUM (p->nlocs));
}
#undef FUNC_NAME
@@ -203,7 +174,7 @@ SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0,
metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program));
if (scm_is_true (metaobj))
- return scm_make_program (metaobj, SCM_BOOL_F, SCM_EOL);
+ return scm_make_program (metaobj, SCM_BOOL_F, SCM_BOOL_F);
else
return SCM_BOOL_F;
}
@@ -312,26 +283,13 @@ scm_c_program_source (SCM program, size_t ip)
return source; /* (addr . (filename . (line . column))) */
}
-SCM_DEFINE (scm_program_external, "program-external", 1, 0, 0,
+SCM_DEFINE (scm_program_free_variables, "program-free-variables", 1, 0, 0,
(SCM program),
"")
-#define FUNC_NAME s_scm_program_external
-{
- SCM_VALIDATE_PROGRAM (1, program);
- return SCM_PROGRAM_EXTERNALS (program);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_program_external_set_x, "program-external-set!", 2, 0, 0,
- (SCM program, SCM external),
- "Modify the list of closure variables of @var{program} (for "
- "debugging purposes).")
-#define FUNC_NAME s_scm_program_external_set_x
+#define FUNC_NAME s_scm_program_free_variables
{
SCM_VALIDATE_PROGRAM (1, program);
- SCM_VALIDATE_LIST (2, external);
- SCM_PROGRAM_EXTERNALS (program) = external;
- return SCM_UNSPECIFIED;
+ return SCM_PROGRAM_FREE_VARIABLES (program);
}
#undef FUNC_NAME
@@ -357,6 +315,8 @@ scm_bootstrap_programs (void)
scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_1 = program_apply_1;
scm_smobs[SCM_TC2SMOBNUM (scm_tc16_program)].apply_2 = program_apply_2;
scm_set_smob_print (scm_tc16_program, program_print);
+ scm_c_register_extension ("libguile", "scm_init_programs",
+ (scm_t_extension_init_func)scm_init_programs, NULL);
}
void
diff --git a/libguile/programs.h b/libguile/programs.h
index 68a6936a2..040e8ea2c 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -1,43 +1,20 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
#ifndef _SCM_PROGRAMS_H_
#define _SCM_PROGRAMS_H_
@@ -51,39 +28,38 @@
typedef unsigned char scm_byte_t;
-extern scm_t_bits scm_tc16_program;
+SCM_API scm_t_bits scm_tc16_program;
#define SCM_F_PROGRAM_IS_BOOT (1<<0)
#define SCM_PROGRAM_P(x) (SCM_SMOB_PREDICATE (scm_tc16_program, x))
#define SCM_PROGRAM_OBJCODE(x) (SCM_SMOB_OBJECT (x))
#define SCM_PROGRAM_OBJTABLE(x) (SCM_SMOB_OBJECT_2 (x))
-#define SCM_PROGRAM_EXTERNALS(x) (SCM_SMOB_OBJECT_3 (x))
+#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_SMOB_OBJECT_3 (x))
#define SCM_PROGRAM_DATA(x) (SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x)))
#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
#define SCM_PROGRAM_IS_BOOT(x) (SCM_SMOB_FLAGS (x) & SCM_F_PROGRAM_IS_BOOT)
-extern SCM scm_make_program (SCM objcode, SCM objtable, SCM externals);
+SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables);
-extern SCM scm_program_p (SCM obj);
-extern SCM scm_program_base (SCM program);
-extern SCM scm_program_arity (SCM program);
-extern SCM scm_program_meta (SCM program);
-extern SCM scm_program_bindings (SCM program);
-extern SCM scm_program_sources (SCM program);
-extern SCM scm_program_source (SCM program, SCM ip);
-extern SCM scm_program_properties (SCM program);
-extern SCM scm_program_name (SCM program);
-extern SCM scm_program_objects (SCM program);
-extern SCM scm_program_module (SCM program);
-extern SCM scm_program_external (SCM program);
-extern SCM scm_program_external_set_x (SCM program, SCM external);
-extern SCM scm_program_objcode (SCM program);
+SCM_API SCM scm_program_p (SCM obj);
+SCM_API SCM scm_program_base (SCM program);
+SCM_API SCM scm_program_arity (SCM program);
+SCM_API SCM scm_program_meta (SCM program);
+SCM_API SCM scm_program_bindings (SCM program);
+SCM_API SCM scm_program_sources (SCM program);
+SCM_API SCM scm_program_source (SCM program, SCM ip);
+SCM_API SCM scm_program_properties (SCM program);
+SCM_API SCM scm_program_name (SCM program);
+SCM_API SCM scm_program_objects (SCM program);
+SCM_API SCM scm_program_module (SCM program);
+SCM_API SCM scm_program_free_variables (SCM program);
+SCM_API SCM scm_program_objcode (SCM program);
-extern SCM scm_c_program_source (SCM program, size_t ip);
+SCM_API SCM scm_c_program_source (SCM program, size_t ip);
-extern void scm_bootstrap_programs (void);
-extern void scm_init_programs (void);
+SCM_INTERNAL void scm_bootstrap_programs (void);
+SCM_INTERNAL void scm_init_programs (void);
#endif /* _SCM_PROGRAMS_H_ */
diff --git a/libguile/properties.c b/libguile/properties.c
index 321dc9ec4..60ff2ff65 100644
--- a/libguile/properties.c
+++ b/libguile/properties.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/properties.h b/libguile/properties.h
index 54feb01d9..efeaf3a59 100644
--- a/libguile/properties.h
+++ b/libguile/properties.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1998,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/pthread-threads.h b/libguile/pthread-threads.h
index bd6d4854d..4f72a4293 100644
--- a/libguile/pthread-threads.h
+++ b/libguile/pthread-threads.h
@@ -6,18 +6,19 @@
/* Copyright (C) 2002, 2005, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/putenv.c b/libguile/putenv.c
index 0ff33592a..cdc05dd7e 100644
--- a/libguile/putenv.c
+++ b/libguile/putenv.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1991, 2000, 2001, 2004, 2005, 2006 Free Software Foundation, Inc.
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/r6rs-ports.c b/libguile/r6rs-ports.c
new file mode 100644
index 000000000..e3aa99e16
--- /dev/null
+++ b/libguile/r6rs-ports.c
@@ -0,0 +1,1122 @@
+/* Copyright (C) 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#ifdef HAVE_UNISTD_H
+# include <unistd.h>
+#endif
+
+#include <string.h>
+#include <stdio.h>
+#include <assert.h>
+
+#include "libguile/_scm.h"
+#include "libguile/bytevectors.h"
+#include "libguile/chars.h"
+#include "libguile/eval.h"
+#include "libguile/r6rs-ports.h"
+#include "libguile/strings.h"
+#include "libguile/validate.h"
+#include "libguile/values.h"
+#include "libguile/vectors.h"
+
+
+
+/* Unimplemented features. */
+
+
+/* Transoders are currently not implemented since Guile 1.8 is not
+ Unicode-capable. Thus, most of the code here assumes the use of the
+ binary transcoder. */
+static inline void
+transcoders_not_implemented (void)
+{
+ fprintf (stderr, "%s: warning: transcoders not implemented\n",
+ PACKAGE_NAME);
+}
+
+
+/* End-of-file object. */
+
+SCM_DEFINE (scm_eof_object, "eof-object", 0, 0, 0,
+ (void),
+ "Return the end-of-file object.")
+#define FUNC_NAME s_scm_eof_object
+{
+ return (SCM_EOF_VAL);
+}
+#undef FUNC_NAME
+
+
+/* Input ports. */
+
+#ifndef MIN
+# define MIN(a,b) ((a) < (b) ? (a) : (b))
+#endif
+
+/* Bytevector input ports or "bip" for short. */
+static scm_t_bits bytevector_input_port_type = 0;
+
+static inline SCM
+make_bip (SCM bv)
+{
+ SCM port;
+ char *c_bv;
+ unsigned c_len;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
+
+ port = scm_new_port_table_entry (bytevector_input_port_type);
+
+ /* Prevent BV from being GC'd. */
+ SCM_SETSTREAM (port, SCM_UNPACK (bv));
+
+ /* Have the port directly access the bytevector. */
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
+ c_port->read_end = (unsigned char *) c_bv + c_len;
+ c_port->read_buf_size = c_len;
+
+ /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
+ SCM_SET_CELL_TYPE (port, bytevector_input_port_type | mode_bits);
+
+ return port;
+}
+
+static SCM
+bip_mark (SCM port)
+{
+ /* Mark the underlying bytevector. */
+ return (SCM_PACK (SCM_STREAM (port)));
+}
+
+static int
+bip_fill_input (SCM port)
+{
+ int result;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+
+ if (c_port->read_pos >= c_port->read_end)
+ result = EOF;
+ else
+ result = (int) *c_port->read_pos;
+
+ return result;
+}
+
+static scm_t_off
+bip_seek (SCM port, scm_t_off offset, int whence)
+#define FUNC_NAME "bip_seek"
+{
+ scm_t_off c_result = 0;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+
+ switch (whence)
+ {
+ case SEEK_CUR:
+ offset += c_port->read_pos - c_port->read_buf;
+ /* Fall through. */
+
+ case SEEK_SET:
+ if (c_port->read_buf + offset < c_port->read_end)
+ {
+ c_port->read_pos = c_port->read_buf + offset;
+ c_result = offset;
+ }
+ else
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ break;
+
+ case SEEK_END:
+ if (c_port->read_end - offset >= c_port->read_buf)
+ {
+ c_port->read_pos = c_port->read_end - offset;
+ c_result = c_port->read_pos - c_port->read_buf;
+ }
+ else
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ break;
+
+ default:
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "invalid `seek' parameter");
+ }
+
+ return c_result;
+}
+#undef FUNC_NAME
+
+
+/* Instantiate the bytevector input port type. */
+static inline void
+initialize_bytevector_input_ports (void)
+{
+ bytevector_input_port_type =
+ scm_make_port_type ("r6rs-bytevector-input-port", bip_fill_input,
+ NULL);
+
+ scm_set_port_mark (bytevector_input_port_type, bip_mark);
+ scm_set_port_seek (bytevector_input_port_type, bip_seek);
+}
+
+
+SCM_DEFINE (scm_open_bytevector_input_port,
+ "open-bytevector-input-port", 1, 1, 0,
+ (SCM bv, SCM transcoder),
+ "Return an input port whose contents are drawn from "
+ "bytevector @var{bv}.")
+#define FUNC_NAME s_scm_open_bytevector_input_port
+{
+ SCM_VALIDATE_BYTEVECTOR (1, bv);
+ if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder))
+ transcoders_not_implemented ();
+
+ return (make_bip (bv));
+}
+#undef FUNC_NAME
+
+
+/* Custom binary ports. The following routines are shared by input and
+ output custom binary ports. */
+
+#define SCM_CBP_GET_POSITION_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 1)
+#define SCM_CBP_SET_POSITION_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 2)
+#define SCM_CBP_CLOSE_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 3)
+
+static SCM
+cbp_mark (SCM port)
+{
+ /* Mark the underlying method and object vector. */
+ if (SCM_OPENP (port))
+ return SCM_PACK (SCM_STREAM (port));
+ else
+ return SCM_BOOL_F;
+}
+
+static scm_t_off
+cbp_seek (SCM port, scm_t_off offset, int whence)
+#define FUNC_NAME "cbp_seek"
+{
+ SCM result;
+ scm_t_off c_result = 0;
+
+ switch (whence)
+ {
+ case SEEK_CUR:
+ {
+ SCM get_position_proc;
+
+ get_position_proc = SCM_CBP_GET_POSITION_PROC (port);
+ if (SCM_LIKELY (scm_is_true (get_position_proc)))
+ result = scm_call_0 (get_position_proc);
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "R6RS custom binary port does not "
+ "support `port-position'");
+
+ offset += scm_to_int (result);
+ /* Fall through. */
+ }
+
+ case SEEK_SET:
+ {
+ SCM set_position_proc;
+
+ set_position_proc = SCM_CBP_SET_POSITION_PROC (port);
+ if (SCM_LIKELY (scm_is_true (set_position_proc)))
+ result = scm_call_1 (set_position_proc, scm_from_int (offset));
+ else
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "R6RS custom binary port does not "
+ "support `set-port-position!'");
+
+ /* Assuming setting the position succeeded. */
+ c_result = offset;
+ break;
+ }
+
+ default:
+ /* `SEEK_END' cannot be supported. */
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "R6RS custom binary ports do not "
+ "support `SEEK_END'");
+ }
+
+ return c_result;
+}
+#undef FUNC_NAME
+
+static int
+cbp_close (SCM port)
+{
+ SCM close_proc;
+
+ close_proc = SCM_CBP_CLOSE_PROC (port);
+ if (scm_is_true (close_proc))
+ /* Invoke the `close' thunk. */
+ scm_call_0 (close_proc);
+
+ return 1;
+}
+
+
+/* Custom binary input port ("cbip" for short). */
+
+static scm_t_bits custom_binary_input_port_type = 0;
+
+/* Size of the buffer embedded in custom binary input ports. */
+#define CBIP_BUFFER_SIZE 4096
+
+/* Return the bytevector associated with PORT. */
+#define SCM_CBIP_BYTEVECTOR(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 4)
+
+/* Return the various procedures of PORT. */
+#define SCM_CBIP_READ_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
+
+
+static inline SCM
+make_cbip (SCM read_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc)
+{
+ SCM port, bv, method_vector;
+ char *c_bv;
+ unsigned c_len;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | SCM_RDNG;
+
+ /* Use a bytevector as the underlying buffer. */
+ c_len = CBIP_BUFFER_SIZE;
+ bv = scm_c_make_bytevector (c_len);
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ /* Store the various methods and bytevector in a vector. */
+ method_vector = scm_c_make_vector (5, SCM_BOOL_F);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 4, bv);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 0, read_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
+
+ port = scm_new_port_table_entry (custom_binary_input_port_type);
+
+ /* Attach it the method vector. */
+ SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
+
+ /* Have the port directly access the buffer (bytevector). */
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->read_pos = c_port->read_buf = (unsigned char *) c_bv;
+ c_port->read_end = (unsigned char *) c_bv;
+ c_port->read_buf_size = c_len;
+
+ /* Mark PORT as open, readable and unbuffered (hmm, how elegant...). */
+ SCM_SET_CELL_TYPE (port, custom_binary_input_port_type | mode_bits);
+
+ return port;
+}
+
+static int
+cbip_fill_input (SCM port)
+#define FUNC_NAME "cbip_fill_input"
+{
+ int result;
+ scm_t_port *c_port = SCM_PTAB_ENTRY (port);
+
+ again:
+ if (c_port->read_pos >= c_port->read_end)
+ {
+ /* Invoke the user's `read!' procedure. */
+ unsigned c_octets;
+ SCM bv, read_proc, octets;
+
+ /* Use the bytevector associated with PORT as the buffer passed to the
+ `read!' procedure, thereby avoiding additional allocations. */
+ bv = SCM_CBIP_BYTEVECTOR (port);
+ read_proc = SCM_CBIP_READ_PROC (port);
+
+ /* The assumption here is that C_PORT's internal buffer wasn't changed
+ behind our back. */
+ assert (c_port->read_buf ==
+ (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv));
+ assert ((unsigned) c_port->read_buf_size
+ == SCM_BYTEVECTOR_LENGTH (bv));
+
+ octets = scm_call_3 (read_proc, bv, SCM_INUM0,
+ SCM_I_MAKINUM (CBIP_BUFFER_SIZE));
+ c_octets = scm_to_uint (octets);
+
+ c_port->read_pos = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ c_port->read_end = (unsigned char *) c_port->read_pos + c_octets;
+
+ if (c_octets > 0)
+ goto again;
+ else
+ result = EOF;
+ }
+ else
+ result = (int) *c_port->read_pos;
+
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_custom_binary_input_port,
+ "make-custom-binary-input-port", 5, 0, 0,
+ (SCM id, SCM read_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc),
+ "Return a new custom binary input port whose input is drained "
+ "by invoking @var{read_proc} and passing it a bytevector, an "
+ "index where octets should be written, and an octet count.")
+#define FUNC_NAME s_scm_make_custom_binary_input_port
+{
+ SCM_VALIDATE_STRING (1, id);
+ SCM_VALIDATE_PROC (2, read_proc);
+
+ if (!scm_is_false (get_position_proc))
+ SCM_VALIDATE_PROC (3, get_position_proc);
+
+ if (!scm_is_false (set_position_proc))
+ SCM_VALIDATE_PROC (4, set_position_proc);
+
+ if (!scm_is_false (close_proc))
+ SCM_VALIDATE_PROC (5, close_proc);
+
+ return (make_cbip (read_proc, get_position_proc, set_position_proc,
+ close_proc));
+}
+#undef FUNC_NAME
+
+
+/* Instantiate the custom binary input port type. */
+static inline void
+initialize_custom_binary_input_ports (void)
+{
+ custom_binary_input_port_type =
+ scm_make_port_type ("r6rs-custom-binary-input-port",
+ cbip_fill_input, NULL);
+
+ scm_set_port_mark (custom_binary_input_port_type, cbp_mark);
+ scm_set_port_seek (custom_binary_input_port_type, cbp_seek);
+ scm_set_port_close (custom_binary_input_port_type, cbp_close);
+}
+
+
+
+/* Binary input. */
+
+/* We currently don't support specific binary input ports. */
+#define SCM_VALIDATE_BINARY_INPUT_PORT SCM_VALIDATE_OPINPORT
+
+SCM_DEFINE (scm_get_u8, "get-u8", 1, 0, 0,
+ (SCM port),
+ "Read an octet from @var{port}, a binary input port, "
+ "blocking as necessary.")
+#define FUNC_NAME s_scm_get_u8
+{
+ SCM result;
+ int c_result;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ c_result = scm_getc (port);
+ if (c_result == EOF)
+ result = SCM_EOF_VAL;
+ else
+ result = SCM_I_MAKINUM ((unsigned char) c_result);
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_lookahead_u8, "lookahead-u8", 1, 0, 0,
+ (SCM port),
+ "Like @code{get-u8} but does not update @var{port} to "
+ "point past the octet.")
+#define FUNC_NAME s_scm_lookahead_u8
+{
+ SCM result;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ result = scm_peek_char (port);
+ if (SCM_CHARP (result))
+ result = SCM_I_MAKINUM ((signed char) SCM_CHAR (result));
+ else
+ result = SCM_EOF_VAL;
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_bytevector_n, "get-bytevector-n", 2, 0, 0,
+ (SCM port, SCM count),
+ "Read @var{count} octets from @var{port}, blocking as "
+ "necessary and return a bytevector containing the octets "
+ "read. If fewer bytes are available, a bytevector smaller "
+ "than @var{count} is returned.")
+#define FUNC_NAME s_scm_get_bytevector_n
+{
+ SCM result;
+ char *c_bv;
+ unsigned c_count;
+ size_t c_read;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+ c_count = scm_to_uint (count);
+
+ result = scm_c_make_bytevector (c_count);
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (result);
+
+ if (SCM_LIKELY (c_count > 0))
+ /* XXX: `scm_c_read ()' does not update the port position. */
+ c_read = scm_c_read (port, c_bv, c_count);
+ else
+ /* Don't invoke `scm_c_read ()' since it may block. */
+ c_read = 0;
+
+ if ((c_read == 0) && (c_count > 0))
+ {
+ if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
+ result = SCM_EOF_VAL;
+ else
+ result = scm_null_bytevector;
+ }
+ else
+ {
+ if (c_read < c_count)
+ result = scm_c_shrink_bytevector (result, c_read);
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_bytevector_n_x, "get-bytevector-n!", 4, 0, 0,
+ (SCM port, SCM bv, SCM start, SCM count),
+ "Read @var{count} bytes from @var{port} and store them "
+ "in @var{bv} starting at index @var{start}. Return either "
+ "the number of bytes actually read or the end-of-file "
+ "object.")
+#define FUNC_NAME s_scm_get_bytevector_n_x
+{
+ SCM result;
+ char *c_bv;
+ unsigned c_start, c_count, c_len;
+ size_t c_read;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+ SCM_VALIDATE_BYTEVECTOR (2, bv);
+ c_start = scm_to_uint (start);
+ c_count = scm_to_uint (count);
+
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+
+ if (SCM_UNLIKELY (c_start + c_count > c_len))
+ scm_out_of_range (FUNC_NAME, count);
+
+ if (SCM_LIKELY (c_count > 0))
+ c_read = scm_c_read (port, c_bv + c_start, c_count);
+ else
+ /* Don't invoke `scm_c_read ()' since it may block. */
+ c_read = 0;
+
+ if ((c_read == 0) && (c_count > 0))
+ {
+ if (SCM_EOF_OBJECT_P (scm_peek_char (port)))
+ result = SCM_EOF_VAL;
+ else
+ result = SCM_I_MAKINUM (0);
+ }
+ else
+ result = scm_from_size_t (c_read);
+
+ return result;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_get_bytevector_some, "get-bytevector-some", 1, 0, 0,
+ (SCM port),
+ "Read from @var{port}, blocking as necessary, until data "
+ "are available or and end-of-file is reached. Return either "
+ "a new bytevector containing the data read or the "
+ "end-of-file object.")
+#define FUNC_NAME s_scm_get_bytevector_some
+{
+ /* Read at least one byte, unless the end-of-file is already reached, and
+ read while characters are available (buffered). */
+
+ SCM result;
+ char *c_bv;
+ unsigned c_len;
+ size_t c_total;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ c_len = 4096;
+ c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
+ c_total = 0;
+
+ do
+ {
+ int c_chr;
+
+ if (c_total + 1 > c_len)
+ {
+ /* Grow the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
+ SCM_GC_BYTEVECTOR);
+ c_len *= 2;
+ }
+
+ /* We can't use `scm_c_read ()' since it blocks. */
+ c_chr = scm_getc (port);
+ if (c_chr != EOF)
+ {
+ c_bv[c_total] = (char) c_chr;
+ c_total++;
+ }
+ }
+ while ((scm_is_true (scm_char_ready_p (port)))
+ && (!SCM_EOF_OBJECT_P (scm_peek_char (port))));
+
+ if (c_total == 0)
+ {
+ result = SCM_EOF_VAL;
+ scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ }
+ else
+ {
+ if (c_len > c_total)
+ {
+ /* Shrink the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
+ SCM_GC_BYTEVECTOR);
+ c_len = (unsigned) c_total;
+ }
+
+ result = scm_c_take_bytevector ((signed char *) c_bv, c_len);
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_get_bytevector_all, "get-bytevector-all", 1, 0, 0,
+ (SCM port),
+ "Read from @var{port}, blocking as necessary, until "
+ "the end-of-file is reached. Return either "
+ "a new bytevector containing the data read or the "
+ "end-of-file object (if no data were available).")
+#define FUNC_NAME s_scm_get_bytevector_all
+{
+ SCM result;
+ char *c_bv;
+ unsigned c_len, c_count;
+ size_t c_read, c_total;
+
+ SCM_VALIDATE_BINARY_INPUT_PORT (1, port);
+
+ c_len = c_count = 4096;
+ c_bv = (char *) scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
+ c_total = c_read = 0;
+
+ do
+ {
+ if (c_total + c_read > c_len)
+ {
+ /* Grow the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_len * 2,
+ SCM_GC_BYTEVECTOR);
+ c_count = c_len;
+ c_len *= 2;
+ }
+
+ /* `scm_c_read ()' blocks until C_COUNT bytes are available or EOF is
+ reached. */
+ c_read = scm_c_read (port, c_bv + c_total, c_count);
+ c_total += c_read, c_count -= c_read;
+ }
+ while (!SCM_EOF_OBJECT_P (scm_peek_char (port)));
+
+ if (c_total == 0)
+ {
+ result = SCM_EOF_VAL;
+ scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
+ }
+ else
+ {
+ if (c_len > c_total)
+ {
+ /* Shrink the bytevector. */
+ c_bv = (char *) scm_gc_realloc (c_bv, c_len, c_total,
+ SCM_GC_BYTEVECTOR);
+ c_len = (unsigned) c_total;
+ }
+
+ result = scm_c_take_bytevector ((signed char *) c_bv, c_len);
+ }
+
+ return result;
+}
+#undef FUNC_NAME
+
+
+
+/* Binary output. */
+
+/* We currently don't support specific binary input ports. */
+#define SCM_VALIDATE_BINARY_OUTPUT_PORT SCM_VALIDATE_OPOUTPORT
+
+
+SCM_DEFINE (scm_put_u8, "put-u8", 2, 0, 0,
+ (SCM port, SCM octet),
+ "Write @var{octet} to binary port @var{port}.")
+#define FUNC_NAME s_scm_put_u8
+{
+ scm_t_uint8 c_octet;
+
+ SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
+ c_octet = scm_to_uint8 (octet);
+
+ scm_putc ((char) c_octet, port);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_put_bytevector, "put-bytevector", 2, 2, 0,
+ (SCM port, SCM bv, SCM start, SCM count),
+ "Write the contents of @var{bv} to @var{port}, optionally "
+ "starting at index @var{start} and limiting to @var{count} "
+ "octets.")
+#define FUNC_NAME s_scm_put_bytevector
+{
+ char *c_bv;
+ unsigned c_start, c_count, c_len;
+
+ SCM_VALIDATE_BINARY_OUTPUT_PORT (1, port);
+ SCM_VALIDATE_BYTEVECTOR (2, bv);
+
+ c_len = SCM_BYTEVECTOR_LENGTH (bv);
+ c_bv = (char *) SCM_BYTEVECTOR_CONTENTS (bv);
+
+ if (start != SCM_UNDEFINED)
+ {
+ c_start = scm_to_uint (start);
+
+ if (count != SCM_UNDEFINED)
+ {
+ c_count = scm_to_uint (count);
+ if (SCM_UNLIKELY (c_start + c_count > c_len))
+ scm_out_of_range (FUNC_NAME, count);
+ }
+ else
+ {
+ if (SCM_UNLIKELY (c_start >= c_len))
+ scm_out_of_range (FUNC_NAME, start);
+ else
+ c_count = c_len - c_start;
+ }
+ }
+ else
+ c_start = 0, c_count = c_len;
+
+ scm_c_write (port, c_bv + c_start, c_count);
+
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
+
+
+/* Bytevector output port ("bop" for short). */
+
+/* Implementation of "bops".
+
+ Each bop has an internal buffer, of type `scm_t_bop_buffer', attached to
+ it. The procedure returned along with the output port is actually an
+ applicable SMOB. The SMOB holds a reference to the port. When applied,
+ the SMOB swallows the port's internal buffer, turning it into a
+ bytevector, and resets it.
+
+ XXX: Access to a bop's internal buffer is not thread-safe. */
+
+static scm_t_bits bytevector_output_port_type = 0;
+
+SCM_SMOB (bytevector_output_port_procedure,
+ "r6rs-bytevector-output-port-procedure",
+ 0);
+
+#define SCM_GC_BOP "r6rs-bytevector-output-port"
+#define SCM_BOP_BUFFER_INITIAL_SIZE 4096
+
+/* Representation of a bop's internal buffer. */
+typedef struct
+{
+ size_t total_len;
+ size_t len;
+ size_t pos;
+ char *buffer;
+} scm_t_bop_buffer;
+
+
+/* Accessing a bop's buffer. */
+#define SCM_BOP_BUFFER(_port) \
+ ((scm_t_bop_buffer *) SCM_STREAM (_port))
+#define SCM_SET_BOP_BUFFER(_port, _buf) \
+ (SCM_SETSTREAM ((_port), (scm_t_bits) (_buf)))
+
+
+static inline void
+bop_buffer_init (scm_t_bop_buffer *buf)
+{
+ buf->total_len = buf->len = buf->pos = 0;
+ buf->buffer = NULL;
+}
+
+static inline void
+bop_buffer_grow (scm_t_bop_buffer *buf, size_t min_size)
+{
+ char *new_buf;
+ size_t new_size;
+
+ for (new_size = buf->total_len
+ ? buf->total_len : SCM_BOP_BUFFER_INITIAL_SIZE;
+ new_size < min_size;
+ new_size *= 2);
+
+ if (buf->buffer)
+ new_buf = scm_gc_realloc ((void *) buf->buffer, buf->total_len,
+ new_size, SCM_GC_BOP);
+ else
+ new_buf = scm_gc_malloc (new_size, SCM_GC_BOP);
+
+ buf->buffer = new_buf;
+ buf->total_len = new_size;
+}
+
+static inline SCM
+make_bop (void)
+{
+ SCM port, bop_proc;
+ scm_t_port *c_port;
+ scm_t_bop_buffer *buf;
+ const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
+
+ port = scm_new_port_table_entry (bytevector_output_port_type);
+
+ buf = (scm_t_bop_buffer *) scm_gc_malloc (sizeof (* buf), SCM_GC_BOP);
+ bop_buffer_init (buf);
+
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
+ c_port->write_buf_size = 0;
+
+ SCM_SET_BOP_BUFFER (port, buf);
+
+ /* Mark PORT as open and writable. */
+ SCM_SET_CELL_TYPE (port, bytevector_output_port_type | mode_bits);
+
+ /* Make the bop procedure. */
+ SCM_NEWSMOB (bop_proc, bytevector_output_port_procedure,
+ SCM_PACK (port));
+
+ return (scm_values (scm_list_2 (port, bop_proc)));
+}
+
+static size_t
+bop_free (SCM port)
+{
+ /* The port itself is necessarily freed _after_ the bop proc, since the bop
+ proc holds a reference to it. Thus we can safely free the internal
+ buffer when the bop becomes unreferenced. */
+ scm_t_bop_buffer *buf;
+
+ buf = SCM_BOP_BUFFER (port);
+ if (buf->buffer)
+ scm_gc_free (buf->buffer, buf->total_len, SCM_GC_BOP);
+
+ scm_gc_free (buf, sizeof (* buf), SCM_GC_BOP);
+
+ return 0;
+}
+
+/* Write SIZE octets from DATA to PORT. */
+static void
+bop_write (SCM port, const void *data, size_t size)
+{
+ scm_t_bop_buffer *buf;
+
+ buf = SCM_BOP_BUFFER (port);
+
+ if (buf->pos + size > buf->total_len)
+ bop_buffer_grow (buf, buf->pos + size);
+
+ memcpy (buf->buffer + buf->pos, data, size);
+ buf->pos += size;
+ buf->len = (buf->len > buf->pos) ? buf->len : buf->pos;
+}
+
+static scm_t_off
+bop_seek (SCM port, scm_t_off offset, int whence)
+#define FUNC_NAME "bop_seek"
+{
+ scm_t_bop_buffer *buf;
+
+ buf = SCM_BOP_BUFFER (port);
+ switch (whence)
+ {
+ case SEEK_CUR:
+ offset += (scm_t_off) buf->pos;
+ /* Fall through. */
+
+ case SEEK_SET:
+ if (offset < 0 || (unsigned) offset > buf->len)
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ else
+ buf->pos = offset;
+ break;
+
+ case SEEK_END:
+ if (offset < 0 || (unsigned) offset >= buf->len)
+ scm_out_of_range (FUNC_NAME, scm_from_int (offset));
+ else
+ buf->pos = buf->len - (offset + 1);
+ break;
+
+ default:
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, port,
+ "invalid `seek' parameter");
+ }
+
+ return buf->pos;
+}
+#undef FUNC_NAME
+
+/* Fetch data from a bop. */
+SCM_SMOB_APPLY (bytevector_output_port_procedure,
+ bop_proc_apply, 0, 0, 0, (SCM bop_proc))
+{
+ SCM port, bv;
+ scm_t_bop_buffer *buf, result_buf;
+
+ port = SCM_PACK (SCM_SMOB_DATA (bop_proc));
+ buf = SCM_BOP_BUFFER (port);
+
+ result_buf = *buf;
+ bop_buffer_init (buf);
+
+ if (result_buf.len == 0)
+ bv = scm_c_take_bytevector (NULL, 0);
+ else
+ {
+ if (result_buf.total_len > result_buf.len)
+ /* Shrink the buffer. */
+ result_buf.buffer = scm_gc_realloc ((void *) result_buf.buffer,
+ result_buf.total_len,
+ result_buf.len,
+ SCM_GC_BOP);
+
+ bv = scm_c_take_bytevector ((signed char *) result_buf.buffer,
+ result_buf.len);
+ }
+
+ return bv;
+}
+
+SCM_SMOB_MARK (bytevector_output_port_procedure, bop_proc_mark,
+ bop_proc)
+{
+ /* Mark the port associated with BOP_PROC. */
+ return (SCM_PACK (SCM_SMOB_DATA (bop_proc)));
+}
+
+
+SCM_DEFINE (scm_open_bytevector_output_port,
+ "open-bytevector-output-port", 0, 1, 0,
+ (SCM transcoder),
+ "Return two values: an output port and a procedure. The latter "
+ "should be called with zero arguments to obtain a bytevector "
+ "containing the data accumulated by the port.")
+#define FUNC_NAME s_scm_open_bytevector_output_port
+{
+ if (!SCM_UNBNDP (transcoder) && !scm_is_false (transcoder))
+ transcoders_not_implemented ();
+
+ return (make_bop ());
+}
+#undef FUNC_NAME
+
+static inline void
+initialize_bytevector_output_ports (void)
+{
+ bytevector_output_port_type =
+ scm_make_port_type ("r6rs-bytevector-output-port",
+ NULL, bop_write);
+
+ scm_set_port_seek (bytevector_output_port_type, bop_seek);
+ scm_set_port_free (bytevector_output_port_type, bop_free);
+}
+
+
+/* Custom binary output port ("cbop" for short). */
+
+static scm_t_bits custom_binary_output_port_type;
+
+/* Return the various procedures of PORT. */
+#define SCM_CBOP_WRITE_PROC(_port) \
+ SCM_SIMPLE_VECTOR_REF (SCM_PACK (SCM_STREAM (_port)), 0)
+
+
+static inline SCM
+make_cbop (SCM write_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc)
+{
+ SCM port, method_vector;
+ scm_t_port *c_port;
+ const unsigned long mode_bits = SCM_OPN | SCM_WRTNG;
+
+ /* Store the various methods and bytevector in a vector. */
+ method_vector = scm_c_make_vector (4, SCM_BOOL_F);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 0, write_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 1, get_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 2, set_position_proc);
+ SCM_SIMPLE_VECTOR_SET (method_vector, 3, close_proc);
+
+ port = scm_new_port_table_entry (custom_binary_output_port_type);
+
+ /* Attach it the method vector. */
+ SCM_SETSTREAM (port, SCM_UNPACK (method_vector));
+
+ /* Have the port directly access the buffer (bytevector). */
+ c_port = SCM_PTAB_ENTRY (port);
+ c_port->write_buf = c_port->write_pos = c_port->write_end = NULL;
+ c_port->write_buf_size = c_port->read_buf_size = 0;
+
+ /* Mark PORT as open, writable and unbuffered. */
+ SCM_SET_CELL_TYPE (port, custom_binary_output_port_type | mode_bits);
+
+ return port;
+}
+
+/* Write SIZE octets from DATA to PORT. */
+static void
+cbop_write (SCM port, const void *data, size_t size)
+#define FUNC_NAME "cbop_write"
+{
+ long int c_result;
+ size_t c_written;
+ SCM bv, write_proc, result;
+
+ /* XXX: Allocating a new bytevector at each `write' call is inefficient,
+ but necessary since (1) we don't control the lifetime of the buffer
+ pointed to by DATA, and (2) the `write!' procedure could capture the
+ bytevector it is passed. */
+ bv = scm_c_make_bytevector (size);
+ memcpy (SCM_BYTEVECTOR_CONTENTS (bv), data, size);
+
+ write_proc = SCM_CBOP_WRITE_PROC (port);
+
+ /* Since the `write' procedure of Guile's ports has type `void', it must
+ try hard to write exactly SIZE bytes, regardless of how many bytes the
+ sink can handle. */
+ for (c_written = 0;
+ c_written < size;
+ c_written += c_result)
+ {
+ result = scm_call_3 (write_proc, bv,
+ scm_from_size_t (c_written),
+ scm_from_size_t (size - c_written));
+
+ c_result = scm_to_long (result);
+ if (SCM_UNLIKELY (c_result < 0
+ || (size_t) c_result > (size - c_written)))
+ scm_wrong_type_arg_msg (FUNC_NAME, 0, result,
+ "R6RS custom binary output port `write!' "
+ "returned a incorrect integer");
+ }
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_make_custom_binary_output_port,
+ "make-custom-binary-output-port", 5, 0, 0,
+ (SCM id, SCM write_proc, SCM get_position_proc,
+ SCM set_position_proc, SCM close_proc),
+ "Return a new custom binary output port whose output is drained "
+ "by invoking @var{write_proc} and passing it a bytevector, an "
+ "index where octets should be written, and an octet count.")
+#define FUNC_NAME s_scm_make_custom_binary_output_port
+{
+ SCM_VALIDATE_STRING (1, id);
+ SCM_VALIDATE_PROC (2, write_proc);
+
+ if (!scm_is_false (get_position_proc))
+ SCM_VALIDATE_PROC (3, get_position_proc);
+
+ if (!scm_is_false (set_position_proc))
+ SCM_VALIDATE_PROC (4, set_position_proc);
+
+ if (!scm_is_false (close_proc))
+ SCM_VALIDATE_PROC (5, close_proc);
+
+ return (make_cbop (write_proc, get_position_proc, set_position_proc,
+ close_proc));
+}
+#undef FUNC_NAME
+
+
+/* Instantiate the custom binary output port type. */
+static inline void
+initialize_custom_binary_output_ports (void)
+{
+ custom_binary_output_port_type =
+ scm_make_port_type ("r6rs-custom-binary-output-port",
+ NULL, cbop_write);
+
+ scm_set_port_mark (custom_binary_output_port_type, cbp_mark);
+ scm_set_port_seek (custom_binary_output_port_type, cbp_seek);
+ scm_set_port_close (custom_binary_output_port_type, cbp_close);
+}
+
+
+/* Initialization. */
+
+void
+scm_init_r6rs_ports (void)
+{
+#include "libguile/r6rs-ports.x"
+
+ initialize_bytevector_input_ports ();
+ initialize_custom_binary_input_ports ();
+ initialize_bytevector_output_ports ();
+ initialize_custom_binary_output_ports ();
+}
diff --git a/libguile/r6rs-ports.h b/libguile/r6rs-ports.h
new file mode 100644
index 000000000..5e1707a88
--- /dev/null
+++ b/libguile/r6rs-ports.h
@@ -0,0 +1,44 @@
+#ifndef SCM_R6RS_PORTS_H
+#define SCM_R6RS_PORTS_H
+
+/* Copyright (C) 2009 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#include "libguile/__scm.h"
+
+/* R6RS I/O Ports. */
+
+SCM_API SCM scm_eof_object (void);
+SCM_API SCM scm_open_bytevector_input_port (SCM, SCM);
+SCM_API SCM scm_make_custom_binary_input_port (SCM, SCM, SCM, SCM, SCM);
+SCM_API SCM scm_get_u8 (SCM);
+SCM_API SCM scm_lookahead_u8 (SCM);
+SCM_API SCM scm_get_bytevector_n (SCM, SCM);
+SCM_API SCM scm_get_bytevector_n_x (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_get_bytevector_some (SCM);
+SCM_API SCM scm_get_bytevector_all (SCM);
+SCM_API SCM scm_put_u8 (SCM, SCM);
+SCM_API SCM scm_put_bytevector (SCM, SCM, SCM, SCM);
+SCM_API SCM scm_open_bytevector_output_port (SCM);
+SCM_API SCM scm_make_custom_binary_output_port (SCM, SCM, SCM, SCM, SCM);
+
+SCM_API void scm_init_r6rs_ports (void);
+
+#endif /* SCM_R6RS_PORTS_H */
diff --git a/libguile/ramap.c b/libguile/ramap.c
index 1bc4fdd38..e141c18b7 100644
--- a/libguile/ramap.c
+++ b/libguile/ramap.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/ramap.h b/libguile/ramap.h
index 9d870389a..d6cb19166 100644
--- a/libguile/ramap.h
+++ b/libguile/ramap.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1997,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/random.c b/libguile/random.c
index f5f706f85..9f11dabe8 100644
--- a/libguile/random.c
+++ b/libguile/random.c
@@ -1,17 +1,18 @@
/* Copyright (C) 1999,2000,2001, 2003, 2005, 2006 Free Software Foundation, Inc.
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/random.h b/libguile/random.h
index ae44092ab..6cf404f8d 100644
--- a/libguile/random.h
+++ b/libguile/random.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/rdelim.c b/libguile/rdelim.c
index c9cc0164d..04a0944f4 100644
--- a/libguile/rdelim.c
+++ b/libguile/rdelim.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
diff --git a/libguile/rdelim.h b/libguile/rdelim.h
index 17efb4fe5..2e401e4fe 100644
--- a/libguile/rdelim.h
+++ b/libguile/rdelim.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/read.c b/libguile/read.c
index 47b80041e..8efac67af 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -1,19 +1,20 @@
-/* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006, 2007, 2008 Free Software
+/* Copyright (C) 1995,1996,1997,1999,2000,2001,2003, 2004, 2006, 2007, 2008, 2009 Free Software
* Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -28,6 +29,7 @@
#include <string.h>
#include "libguile/_scm.h"
+#include "libguile/bytevectors.h"
#include "libguile/chars.h"
#include "libguile/eval.h"
#include "libguile/unif.h"
@@ -177,11 +179,12 @@ static SCM *scm_read_hash_procedures;
/* An inlinable version of `scm_c_downcase ()'. */
#define CHAR_DOWNCASE(_chr) \
- (((_chr) <= UCHAR_MAX) ? tolower (_chr) : (_chr))
+ (((_chr) <= UCHAR_MAX) ? tolower ((int) (_chr)) : (_chr))
/* Read an SCSH block comment. */
static inline SCM scm_read_scsh_block_comment (int chr, SCM port);
+static SCM scm_read_commented_expression (int chr, SCM port);
/* Read from PORT until a delimiter (e.g., a whitespace) is read. Return
zero if the whole token fits in BUF, non-zero otherwise. */
@@ -257,6 +260,9 @@ flush_ws (SCM port, const char *eoferr)
case '!':
scm_read_scsh_block_comment (c, port);
break;
+ case ';':
+ scm_read_commented_expression (c, port);
+ break;
default:
scm_ungetc (c, port);
return '#';
@@ -381,110 +387,167 @@ scm_read_string (int chr, SCM port)
object (the string returned). */
SCM str = SCM_BOOL_F;
- char c_str[READER_STRING_BUFFER_SIZE];
unsigned c_str_len = 0;
- int c;
+ scm_t_wchar c;
+ str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL);
while ('"' != (c = scm_getc (port)))
{
if (c == EOF)
- str_eof: scm_i_input_error (FUNC_NAME, port,
- "end of file in string constant",
- SCM_EOL);
-
- if (c_str_len + 1 >= sizeof (c_str))
- {
- /* Flush the C buffer onto a Scheme string. */
- SCM addy;
+ {
+ str_eof:
+ scm_i_input_error (FUNC_NAME, port,
+ "end of file in string constant", SCM_EOL);
+ }
- if (str == SCM_BOOL_F)
- str = scm_c_make_string (0, SCM_MAKE_CHAR ('X'));
+ if (c_str_len + 1 >= scm_i_string_length (str))
+ {
+ SCM addy = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL);
- addy = scm_from_locale_stringn (c_str, c_str_len);
- str = scm_string_append_shared (scm_list_2 (str, addy));
-
- c_str_len = 0;
- }
+ str = scm_string_append (scm_list_2 (str, addy));
+ }
if (c == '\\')
- switch (c = scm_getc (port))
- {
- case EOF:
- goto str_eof;
- case '"':
- case '\\':
- break;
+ {
+ switch (c = scm_getc (port))
+ {
+ case EOF:
+ goto str_eof;
+ case '"':
+ case '\\':
+ break;
#if SCM_ENABLE_ELISP
- case '(':
- case ')':
- if (SCM_ESCAPED_PARENS_P)
- break;
- goto bad_escaped;
+ case '(':
+ case ')':
+ if (SCM_ESCAPED_PARENS_P)
+ break;
+ goto bad_escaped;
#endif
- case '\n':
- continue;
- case '0':
- c = '\0';
- break;
- case 'f':
- c = '\f';
- break;
- case 'n':
- c = '\n';
- break;
- case 'r':
- c = '\r';
- break;
- case 't':
- c = '\t';
- break;
- case 'a':
- c = '\007';
- break;
- case 'v':
- c = '\v';
- break;
- case 'x':
- {
- int a, b;
- a = scm_getc (port);
- if (a == EOF) goto str_eof;
- b = scm_getc (port);
- if (b == EOF) goto str_eof;
- if ('0' <= a && a <= '9') a -= '0';
- else if ('A' <= a && a <= 'F') a = a - 'A' + 10;
- else if ('a' <= a && a <= 'f') a = a - 'a' + 10;
- else goto bad_escaped;
- if ('0' <= b && b <= '9') b -= '0';
- else if ('A' <= b && b <= 'F') b = b - 'A' + 10;
- else if ('a' <= b && b <= 'f') b = b - 'a' + 10;
- else goto bad_escaped;
- c = a * 16 + b;
- break;
- }
- default:
- bad_escaped:
- scm_i_input_error (FUNC_NAME, port,
- "illegal character in escape sequence: ~S",
- scm_list_1 (SCM_MAKE_CHAR (c)));
- }
- c_str[c_str_len++] = c;
+ case '\n':
+ continue;
+ case '0':
+ c = '\0';
+ break;
+ case 'f':
+ c = '\f';
+ break;
+ case 'n':
+ c = '\n';
+ break;
+ case 'r':
+ c = '\r';
+ break;
+ case 't':
+ c = '\t';
+ break;
+ case 'a':
+ c = '\007';
+ break;
+ case 'v':
+ c = '\v';
+ break;
+ case 'x':
+ {
+ scm_t_wchar a, b;
+ a = scm_getc (port);
+ if (a == EOF)
+ goto str_eof;
+ b = scm_getc (port);
+ if (b == EOF)
+ goto str_eof;
+ if ('0' <= a && a <= '9')
+ a -= '0';
+ else if ('A' <= a && a <= 'F')
+ a = a - 'A' + 10;
+ else if ('a' <= a && a <= 'f')
+ a = a - 'a' + 10;
+ else
+ {
+ c = a;
+ goto bad_escaped;
+ }
+ if ('0' <= b && b <= '9')
+ b -= '0';
+ else if ('A' <= b && b <= 'F')
+ b = b - 'A' + 10;
+ else if ('a' <= b && b <= 'f')
+ b = b - 'a' + 10;
+ else
+ {
+ c = b;
+ goto bad_escaped;
+ }
+ c = a * 16 + b;
+ break;
+ }
+ case 'u':
+ {
+ scm_t_wchar a;
+ int i;
+ c = 0;
+ for (i = 0; i < 4; i++)
+ {
+ a = scm_getc (port);
+ if (a == EOF)
+ goto str_eof;
+ if ('0' <= a && a <= '9')
+ a -= '0';
+ else if ('A' <= a && a <= 'F')
+ a = a - 'A' + 10;
+ else if ('a' <= a && a <= 'f')
+ a = a - 'a' + 10;
+ else
+ {
+ c = a;
+ goto bad_escaped;
+ }
+ c = c * 16 + a;
+ }
+ break;
+ }
+ case 'U':
+ {
+ scm_t_wchar a;
+ int i;
+ c = 0;
+ for (i = 0; i < 6; i++)
+ {
+ a = scm_getc (port);
+ if (a == EOF)
+ goto str_eof;
+ if ('0' <= a && a <= '9')
+ a -= '0';
+ else if ('A' <= a && a <= 'F')
+ a = a - 'A' + 10;
+ else if ('a' <= a && a <= 'f')
+ a = a - 'a' + 10;
+ else
+ {
+ c = a;
+ goto bad_escaped;
+ }
+ c = c * 16 + a;
+ }
+ break;
+ }
+ default:
+ bad_escaped:
+ scm_i_input_error (FUNC_NAME, port,
+ "illegal character in escape sequence: ~S",
+ scm_list_1 (SCM_MAKE_CHAR (c)));
+ }
+ }
+ str = scm_i_string_start_writing (str);
+ scm_i_string_set_x (str, c_str_len++, c);
+ scm_i_string_stop_writing ();
}
if (c_str_len > 0)
{
- SCM addy;
-
- addy = scm_from_locale_stringn (c_str, c_str_len);
- if (str == SCM_BOOL_F)
- str = addy;
- else
- str = scm_string_append_shared (scm_list_2 (str, addy));
+ return scm_i_substring_copy (str, 0, c_str_len);
}
- else
- str = (str == SCM_BOOL_F) ? scm_nullstr : str;
-
- return str;
+
+ return scm_nullstr;
}
#undef FUNC_NAME
@@ -552,12 +615,21 @@ scm_read_mixed_case_symbol (int chr, SCM port)
if (scm_is_pair (str))
{
+ size_t len;
+
str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL));
- result = scm_string_to_symbol (str);
+ len = scm_c_string_length (str);
/* Per SRFI-88, `:' alone is an identifier, not a keyword. */
- if (postfix && ends_with_colon && (scm_c_string_length (result) > 1))
- result = scm_symbol_to_keyword (result);
+ if (postfix && ends_with_colon && (len > 1))
+ {
+ /* Strip off colon. */
+ str = scm_c_substring (str, 0, len-1);
+ result = scm_string_to_symbol (str);
+ result = scm_symbol_to_keyword (result);
+ }
+ else
+ result = scm_string_to_symbol (str);
}
else
{
@@ -691,6 +763,65 @@ scm_read_quote (int chr, SCM port)
return p;
}
+SCM_SYMBOL (sym_syntax, "syntax");
+SCM_SYMBOL (sym_quasisyntax, "quasisyntax");
+SCM_SYMBOL (sym_unsyntax, "unsyntax");
+SCM_SYMBOL (sym_unsyntax_splicing, "unsyntax-splicing");
+
+static SCM
+scm_read_syntax (int chr, SCM port)
+{
+ SCM p;
+ long line = SCM_LINUM (port);
+ int column = SCM_COL (port) - 1;
+
+ switch (chr)
+ {
+ case '`':
+ p = sym_quasisyntax;
+ break;
+
+ case '\'':
+ p = sym_syntax;
+ break;
+
+ case ',':
+ {
+ int c;
+
+ c = scm_getc (port);
+ if ('@' == c)
+ p = sym_unsyntax_splicing;
+ else
+ {
+ scm_ungetc (c, port);
+ p = sym_unsyntax;
+ }
+ break;
+ }
+
+ default:
+ fprintf (stderr, "%s: unhandled syntax character (%i)\n",
+ "scm_read_syntax", chr);
+ abort ();
+ }
+
+ p = scm_cons2 (p, scm_read_expression (port), SCM_EOL);
+ if (SCM_RECORD_POSITIONS_P)
+ scm_whash_insert (scm_source_whash, p,
+ scm_make_srcprops (line, column,
+ SCM_FILENAME (port),
+ SCM_COPY_SOURCE_P
+ ? (scm_cons2 (SCM_CAR (p),
+ SCM_CAR (SCM_CDR (p)),
+ SCM_EOL))
+ : SCM_UNDEFINED,
+ SCM_EOL));
+
+
+ return p;
+}
+
static inline SCM
scm_read_semicolon_comment (int chr, SCM port)
{
@@ -727,7 +858,7 @@ static SCM
scm_read_character (int chr, SCM port)
#define FUNC_NAME "scm_lreadr"
{
- unsigned c;
+ SCM ch;
char charname[READER_CHAR_NAME_MAX_SIZE];
size_t charname_len;
@@ -760,10 +891,9 @@ scm_read_character (int chr, SCM port)
return SCM_MAKE_CHAR (SCM_I_INUM (p));
}
- for (c = 0; c < scm_n_charnames; c++)
- if (scm_charnames[c]
- && (!strncasecmp (scm_charnames[c], charname, charname_len)))
- return SCM_MAKE_CHAR (scm_charnums[c]);
+ ch = scm_i_charname_to_char (charname, charname_len);
+ if (scm_is_true (ch))
+ return ch;
char_error:
scm_i_input_error (FUNC_NAME, port, "unknown character name ~a",
@@ -810,6 +940,30 @@ scm_read_srfi4_vector (int chr, SCM port)
}
static SCM
+scm_read_bytevector (int chr, SCM port)
+{
+ chr = scm_getc (port);
+ if (chr != 'u')
+ goto syntax;
+
+ chr = scm_getc (port);
+ if (chr != '8')
+ goto syntax;
+
+ chr = scm_getc (port);
+ if (chr != '(')
+ goto syntax;
+
+ return scm_u8_list_to_bytevector (scm_read_sexp (chr, port));
+
+ syntax:
+ scm_i_input_error ("read_bytevector", port,
+ "invalid bytevector prefix",
+ SCM_MAKE_CHAR (chr));
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
scm_read_guile_bit_vector (int chr, SCM port)
{
/* Read the `#*10101'-style read syntax for bit vectors in Guile. This is
@@ -854,6 +1008,20 @@ scm_read_scsh_block_comment (int chr, SCM port)
}
static SCM
+scm_read_commented_expression (int chr, SCM port)
+{
+ int c;
+
+ c = flush_ws (port, (char *) NULL);
+ if (EOF == c)
+ scm_i_input_error ("read_commented_expression", port,
+ "no expression after #; comment", SCM_EOL);
+ scm_ungetc (c, port);
+ scm_read_expression (port);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
scm_read_extended_symbol (int chr, SCM port)
{
/* Guile's extended symbol read syntax looks like this:
@@ -963,6 +1131,8 @@ scm_read_sharp (int chr, SCM port)
case 'f':
/* This one may return either a boolean or an SRFI-4 vector. */
return (scm_read_srfi4_vector (chr, port));
+ case 'v':
+ return (scm_read_bytevector (chr, port));
case '*':
return (scm_read_guile_bit_vector (chr, port));
case 't':
@@ -1014,6 +1184,12 @@ scm_read_sharp (int chr, SCM port)
return (scm_read_extended_symbol (chr, port));
case '!':
return (scm_read_scsh_block_comment (chr, port));
+ case ';':
+ return (scm_read_commented_expression (chr, port));
+ case '`':
+ case '\'':
+ case ',':
+ return (scm_read_syntax (chr, port));
default:
result = scm_read_sharp_extension (chr, port);
if (scm_is_eq (result, SCM_UNSPECIFIED))
diff --git a/libguile/read.h b/libguile/read.h
index 4253622da..20d3f4bf7 100644
--- a/libguile/read.h
+++ b/libguile/read.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/regex-posix.c b/libguile/regex-posix.c
index 187261421..6259f28ae 100644
--- a/libguile/regex-posix.c
+++ b/libguile/regex-posix.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1997, 1998, 1999, 2000, 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/regex-posix.h b/libguile/regex-posix.h
index 2863b0562..8060fe3b7 100644
--- a/libguile/regex-posix.h
+++ b/libguile/regex-posix.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1997,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/root.c b/libguile/root.c
index 0d4ab29e5..83960b5d8 100644
--- a/libguile/root.c
+++ b/libguile/root.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000, 2001, 2002, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/root.h b/libguile/root.h
index a8116c879..676a7b44c 100644
--- a/libguile/root.h
+++ b/libguile/root.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1996,1998,2000,2001, 2002, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/rw.c b/libguile/rw.c
index 3e814740a..a9b4a329a 100644
--- a/libguile/rw.c
+++ b/libguile/rw.c
@@ -1,18 +1,19 @@
-/* Copyright (C) 2001, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2006, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -130,6 +131,7 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0,
don't touch the file descriptor. otherwise the
"return immediately if something is available" rule may
be violated. */
+ str = scm_i_string_start_writing (str);
dest = scm_i_string_writable_chars (str) + offset;
chars_read = scm_take_from_input_buffers (port, dest, read_len);
scm_i_string_stop_writing ();
@@ -139,6 +141,7 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0,
if (chars_read == 0 && read_len > 0) /* don't confuse read_len == 0 with
EOF. */
{
+ str = scm_i_string_start_writing (str);
dest = scm_i_string_writable_chars (str) + offset;
SCM_SYSCALL (chars_read = read (fdes, dest, read_len));
scm_i_string_stop_writing ();
@@ -206,7 +209,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0,
#define FUNC_NAME s_scm_write_string_partial
{
const char *src;
- long write_len;
+ scm_t_off write_len;
int fdes;
{
@@ -231,7 +234,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0,
SCM port = (SCM_UNBNDP (port_or_fdes)?
scm_current_output_port () : port_or_fdes);
scm_t_port *pt;
- off_t space;
+ scm_t_off space;
SCM_VALIDATE_OPFPORT (2, port);
SCM_VALIDATE_OUTPUT_PORT (2, port);
diff --git a/libguile/rw.h b/libguile/rw.h
index b526051fc..d54f1b3ef 100644
--- a/libguile/rw.h
+++ b/libguile/rw.h
@@ -6,18 +6,19 @@
/* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/scmconfig.h.top b/libguile/scmconfig.h.top
index dfc7ba99c..b84660b6c 100644
--- a/libguile/scmconfig.h.top
+++ b/libguile/scmconfig.h.top
@@ -1,16 +1,17 @@
/* Copyright (C) 2003, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/scmsigs.c b/libguile/scmsigs.c
index eb7cec67b..f4772b7a2 100644
--- a/libguile/scmsigs.c
+++ b/libguile/scmsigs.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -305,10 +306,8 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0,
"a scheme procedure has been specified, that procedure will run\n"
"in the given @var{thread}. When no thread has been given, the\n"
"thread that made this call to @code{sigaction} is used.\n"
- "Flags can "
- "optionally be specified for the new handler (@code{SA_RESTART} will\n"
- "always be added if it's available and the system is using restartable\n"
- "system calls.) The return value is a pair with information about the\n"
+ "Flags can optionally be specified for the new handler.\n"
+ "The return value is a pair with information about the\n"
"old handler as described above.\n\n"
"This interface does not provide access to the \"signal blocking\"\n"
"facility. Maybe this is not needed, since the thread support may\n"
@@ -332,14 +331,7 @@ SCM_DEFINE (scm_sigaction_for_thread, "sigaction", 1, 3, 0,
csig = scm_to_signed_integer (signum, 0, NSIG-1);
#if defined(HAVE_SIGACTION)
-#if defined(SA_RESTART) && defined(HAVE_RESTARTABLE_SYSCALLS)
- /* don't allow SA_RESTART to be omitted if HAVE_RESTARTABLE_SYSCALLS
- is defined, since libguile would be likely to produce spurious
- EINTR errors. */
- action.sa_flags = SA_RESTART;
-#else
action.sa_flags = 0;
-#endif
if (!SCM_UNBNDP (flags))
action.sa_flags |= scm_to_int (flags);
sigemptyset (&action.sa_mask);
@@ -712,29 +704,6 @@ scm_init_scmsigs ()
#else
orig_handlers[i] = SIG_ERR;
#endif
-
-#ifdef HAVE_RESTARTABLE_SYSCALLS
- /* If HAVE_RESTARTABLE_SYSCALLS is defined, it's important that
- signals really are restartable. don't rely on the same
- run-time that configure got: reset the default for every signal.
- */
-#ifdef HAVE_SIGINTERRUPT
- siginterrupt (i, 0);
-#elif defined(SA_RESTART)
- {
- struct sigaction action;
-
- sigaction (i, NULL, &action);
- if (!(action.sa_flags & SA_RESTART))
- {
- action.sa_flags |= SA_RESTART;
- sigaction (i, &action, NULL);
- }
- }
-#endif
- /* if neither siginterrupt nor SA_RESTART are available we may
- as well assume that signals are always restartable. */
-#endif
}
scm_c_define ("NSIG", scm_from_long (NSIG));
diff --git a/libguile/scmsigs.h b/libguile/scmsigs.h
index bcbf825d4..fce372849 100644
--- a/libguile/scmsigs.h
+++ b/libguile/scmsigs.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000, 2002, 2006, 2007, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/script.c b/libguile/script.c
index 14691c738..8c4e8ef55 100644
--- a/libguile/script.c
+++ b/libguile/script.c
@@ -1,17 +1,18 @@
/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
/* "script.c" argv tricks for `#!' scripts.
@@ -29,6 +30,7 @@
#include "libguile/eval.h"
#include "libguile/feature.h"
#include "libguile/load.h"
+#include "libguile/private-gc.h" /* scm_getenv_int */
#include "libguile/read.h"
#include "libguile/script.h"
#include "libguile/strings.h"
@@ -376,6 +378,10 @@ scm_shell_usage (int fatal, char *message)
" --no-debug start with normal evaluator\n"
" Default is to enable debugging for interactive\n"
" use, but not for `-s' and `-c'.\n"
+ " --autocompile compile source files automatically\n"
+ " --no-autocompile disable automatic source file compilation\n"
+ " Default is to enable autocompilation of source\n"
+ " files.\n"
" -q inhibit loading of user init file\n"
" --emacs enable Emacs protocol (experimental)\n"
" --use-srfi=LS load SRFI modules for the SRFIs in LS,\n"
@@ -404,6 +410,7 @@ SCM_SYMBOL (sym_quit, "quit");
SCM_SYMBOL (sym_use_srfis, "use-srfis");
SCM_SYMBOL (sym_load_path, "%load-path");
SCM_SYMBOL (sym_set_x, "set!");
+SCM_SYMBOL (sym_sys_load_should_autocompile, "%load-should-autocompile");
SCM_SYMBOL (sym_cons, "cons");
SCM_SYMBOL (sym_at, "@");
SCM_SYMBOL (sym_atat, "@@");
@@ -448,6 +455,8 @@ scm_compile_shell_switches (int argc, char **argv)
int use_emacs_interface = 0;
int turn_on_debugging = 0;
int dont_turn_on_debugging = 0;
+ int turn_on_autocompile = 0;
+ int dont_turn_on_autocompile = 0;
int i;
char *argv0 = guile;
@@ -584,6 +593,18 @@ scm_compile_shell_switches (int argc, char **argv)
turn_on_debugging = 0;
}
+ else if (! strcmp (argv[i], "--autocompile"))
+ {
+ turn_on_autocompile = 1;
+ dont_turn_on_autocompile = 0;
+ }
+
+ else if (! strcmp (argv[i], "--no-autocompile"))
+ {
+ dont_turn_on_autocompile = 1;
+ turn_on_autocompile = 0;
+ }
+
else if (! strcmp (argv[i], "--emacs")) /* use emacs protocol */
use_emacs_interface = 1;
@@ -701,6 +722,16 @@ scm_compile_shell_switches (int argc, char **argv)
tail = scm_cons (scm_cons (sym_load_user_init, SCM_EOL), tail);
}
+ /* If GUILE_AUTO_COMPILE is not set and no args are given, default to
+ autocompilation. */
+ if (turn_on_autocompile || (scm_getenv_int ("GUILE_AUTO_COMPILE", 1)
+ && !dont_turn_on_autocompile))
+ {
+ tail = scm_cons (scm_list_3 (sym_set_x, sym_sys_load_should_autocompile,
+ SCM_BOOL_T),
+ tail);
+ }
+
/* If debugging was requested, or we are interactive and debugging
was not explicitly turned off, turn on debugging. */
if (turn_on_debugging || (interactive && !dont_turn_on_debugging))
diff --git a/libguile/script.h b/libguile/script.h
index 6c02f8d8d..7e3828aa3 100644
--- a/libguile/script.h
+++ b/libguile/script.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1997,1998,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/simpos.c b/libguile/simpos.c
index e4c27b7e7..41af23378 100644
--- a/libguile/simpos.c
+++ b/libguile/simpos.c
@@ -2,18 +2,19 @@
* Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/simpos.h b/libguile/simpos.h
index 6df8bb1d2..b391a28d8 100644
--- a/libguile/simpos.h
+++ b/libguile/simpos.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/smob.c b/libguile/smob.c
index ad33933c3..0598bae33 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/smob.h b/libguile/smob.h
index 6f5033605..d435bacb8 100644
--- a/libguile/smob.h
+++ b/libguile/smob.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/snarf.h b/libguile/snarf.h
index 5c2f18774..03a3edd47 100644
--- a/libguile/snarf.h
+++ b/libguile/snarf.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/socket.c b/libguile/socket.c
index f34b6d49d..2e02e9082 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -1437,6 +1438,7 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0,
fd = SCM_FPORT_FDES (sock);
len = scm_i_string_length (buf);
+ buf = scm_i_string_start_writing (buf);
dest = scm_i_string_writable_chars (buf);
SCM_SYSCALL (rv = recv (fd, dest, len, flg));
scm_i_string_stop_writing ();
@@ -1481,6 +1483,7 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0,
fd = SCM_FPORT_FDES (sock);
len = scm_i_string_length (message);
+ message = scm_i_string_start_writing (message);
src = scm_i_string_writable_chars (message);
SCM_SYSCALL (rv = send (fd, src, len, flg));
scm_i_string_stop_writing ();
@@ -1549,6 +1552,7 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0,
/* recvfrom will not necessarily return an address. usually nothing
is returned for stream sockets. */
+ str = scm_i_string_start_writing (str);
buf = scm_i_string_writable_chars (str);
((struct sockaddr *) &addr)->sa_family = AF_UNSPEC;
SCM_SYSCALL (rv = recvfrom (fd, buf + offset,
diff --git a/libguile/socket.h b/libguile/socket.h
index 133dbf7c6..fcddd780d 100644
--- a/libguile/socket.h
+++ b/libguile/socket.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1997,2000,2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/sort.c b/libguile/sort.c
index 2a7317663..644526eac 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -1,17 +1,18 @@
/* Copyright (C) 1999,2000,2001,2002, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/sort.h b/libguile/sort.h
index 51f292a5c..3ae86c2f3 100644
--- a/libguile/sort.h
+++ b/libguile/sort.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1999,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/srcprop.c b/libguile/srcprop.c
index ee15f641d..2cbf04894 100644
--- a/libguile/srcprop.c
+++ b/libguile/srcprop.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002, 2006, 2008 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/srcprop.h b/libguile/srcprop.h
index a467aa34e..2a27e0409 100644
--- a/libguile/srcprop.h
+++ b/libguile/srcprop.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c
index c8ca78027..781fe6893 100644
--- a/libguile/srfi-13.c
+++ b/libguile/srfi-13.c
@@ -3,18 +3,19 @@
* Copyright (C) 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -548,6 +549,7 @@ SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0,
len = cend - cstart;
SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart);
+ target = scm_i_string_start_writing (target);
ctarget = scm_i_string_writable_chars (target);
memmove (ctarget + ctstart, cstr + cstart, len);
scm_i_string_stop_writing ();
@@ -984,6 +986,7 @@ SCM_DEFINE (scm_substring_fill_x, "string-fill!", 2, 2, 0,
4, end, cend);
SCM_VALIDATE_CHAR_COPY (2, chr, c);
+ str = scm_i_string_start_writing (str);
cstr = scm_i_string_writable_chars (str);
for (k = cstart; k < cend; k++)
cstr[k] = c;
@@ -2375,6 +2378,7 @@ string_upcase_x (SCM v, size_t start, size_t end)
size_t k;
char *dst;
+ v = scm_i_string_start_writing (v);
dst = scm_i_string_writable_chars (v);
for (k = start; k < end; ++k)
dst[k] = scm_c_upcase (dst[k]);
@@ -2441,6 +2445,7 @@ string_downcase_x (SCM v, size_t start, size_t end)
size_t k;
char *dst;
+ v = scm_i_string_start_writing (v);
dst = scm_i_string_writable_chars (v);
for (k = start; k < end; ++k)
dst[k] = scm_c_downcase (dst[k]);
@@ -2510,6 +2515,7 @@ string_titlecase_x (SCM str, size_t start, size_t end)
size_t i;
int in_word = 0;
+ str = scm_i_string_start_writing (str);
sz = (unsigned char *) scm_i_string_writable_chars (str);
for(i = start; i < end; i++)
{
@@ -2634,6 +2640,7 @@ SCM_DEFINE (scm_string_reverse, "string-reverse", 1, 2, 0,
2, start, cstart,
3, end, cend);
result = scm_string_copy (str);
+ result = scm_i_string_start_writing (result);
ctarget = scm_i_string_writable_chars (result);
string_reverse_x (ctarget, cstart, cend);
scm_i_string_stop_writing ();
@@ -2657,6 +2664,7 @@ SCM_DEFINE (scm_string_reverse_x, "string-reverse!", 1, 2, 0,
2, start, cstart,
3, end, cend);
+ str = scm_i_string_start_writing (str);
cstr = scm_i_string_writable_chars (str);
string_reverse_x (cstr, cstart, cend);
scm_i_string_stop_writing ();
@@ -3017,19 +3025,16 @@ SCM_DEFINE (scm_string_for_each, "string-for-each", 2, 2, 0,
"return value is not specified.")
#define FUNC_NAME s_scm_string_for_each
{
- const char *cstr;
size_t cstart, cend;
scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc);
SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME);
- MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s, cstr,
- 3, start, cstart,
- 4, end, cend);
+ MY_VALIDATE_SUBSTRING_SPEC (2, s,
+ 3, start, cstart,
+ 4, end, cend);
while (cstart < cend)
{
- unsigned int c = (unsigned char) cstr[cstart];
- proc_tramp (proc, SCM_MAKE_CHAR (c));
- cstr = scm_i_string_chars (s);
+ proc_tramp (proc, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)));
cstart++;
}
@@ -3161,6 +3166,7 @@ SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0,
SCM_ASSERT_RANGE (1, tstart,
ctstart + (csto - csfrom) <= scm_i_string_length (target));
+ target = scm_i_string_start_writing (target);
p = scm_i_string_writable_chars (target) + ctstart;
cs = scm_i_string_chars (s);
while (csfrom < csto)
@@ -3199,8 +3205,8 @@ SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0,
MY_VALIDATE_SUBSTRING_SPEC (2, s2,
5, start2, cstart2,
6, end2, cend2);
- result = scm_i_make_string (cstart1 + (cend2 - cstart2) +
- scm_i_string_length (s1) - cend1, &p);
+ result = scm_i_make_string ((cstart1 + cend2 - cstart2
+ + scm_i_string_length (s1) - cend1), &p);
cstr1 = scm_i_string_chars (s1);
cstr2 = scm_i_string_chars (s2);
memmove (p, cstr1, cstart1 * sizeof (char));
diff --git a/libguile/srfi-13.h b/libguile/srfi-13.h
index f8221ddc6..478a55d64 100644
--- a/libguile/srfi-13.h
+++ b/libguile/srfi-13.h
@@ -6,18 +6,19 @@
* Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/srfi-14.c b/libguile/srfi-14.c
index fc047c028..0d614f6d9 100644
--- a/libguile/srfi-14.c
+++ b/libguile/srfi-14.c
@@ -3,18 +3,19 @@
* Copyright (C) 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
diff --git a/libguile/srfi-14.h b/libguile/srfi-14.h
index ea8027aac..54e0d329c 100644
--- a/libguile/srfi-14.h
+++ b/libguile/srfi-14.h
@@ -6,18 +6,19 @@
* Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c
index 3e43a4985..b45d4029b 100644
--- a/libguile/srfi-4.c
+++ b/libguile/srfi-4.c
@@ -1,20 +1,21 @@
/* srfi-4.c --- Uniform numeric vector datatypes.
*
- * Copyright (C) 2001, 2004, 2006 Free Software Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2006, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
@@ -28,6 +29,7 @@
#include "libguile/_scm.h"
#include "libguile/__scm.h"
#include "libguile/srfi-4.h"
+#include "libguile/bytevectors.h"
#include "libguile/error.h"
#include "libguile/read.h"
#include "libguile/ports.h"
@@ -580,6 +582,8 @@ scm_i_generalized_vector_type (SCM v)
return scm_sym_b;
else if (scm_is_uniform_vector (v))
return scm_from_locale_symbol (uvec_tags[SCM_UVEC_TYPE(v)]);
+ else if (scm_is_bytevector (v))
+ return scm_from_locale_symbol ("vu8");
else
return SCM_BOOL_F;
}
@@ -721,6 +725,8 @@ scm_array_handle_uniform_element_size (scm_t_array_handle *h)
vec = SCM_I_ARRAY_V (vec);
if (scm_is_uniform_vector (vec))
return uvec_sizes[SCM_UVEC_TYPE(vec)];
+ if (scm_is_bytevector (vec))
+ return 1U;
scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
}
@@ -761,6 +767,8 @@ scm_array_handle_uniform_writable_elements (scm_t_array_handle *h)
char *elts = SCM_UVEC_BASE (vec);
return (void *) (elts + size*h->base);
}
+ if (scm_is_bytevector (vec))
+ return SCM_BYTEVECTOR_CONTENTS (vec);
scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array");
}
diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h
index 3c340d91e..a1a9bafc0 100644
--- a/libguile/srfi-4.h
+++ b/libguile/srfi-4.h
@@ -5,18 +5,19 @@
* Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/stackchk.c b/libguile/stackchk.c
index a53e67629..b14a71259 100644
--- a/libguile/stackchk.c
+++ b/libguile/stackchk.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997, 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/stackchk.h b/libguile/stackchk.h
index 8681f5d46..6aa0fec18 100644
--- a/libguile/stackchk.h
+++ b/libguile/stackchk.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1998,2000, 2003, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/stacks.c b/libguile/stacks.c
index 69fb3406a..45566cafa 100644
--- a/libguile/stacks.c
+++ b/libguile/stacks.c
@@ -2,18 +2,19 @@
* Copyright (C) 1996,1997,2000,2001, 2006, 2007, 2008, 2009 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/stacks.h b/libguile/stacks.h
index 53633bc14..20735eff5 100644
--- a/libguile/stacks.h
+++ b/libguile/stacks.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,2000,2001, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/stime.c b/libguile/stime.c
index 34c8a98fa..a6843377b 100644
--- a/libguile/stime.c
+++ b/libguile/stime.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -77,10 +78,6 @@
# include <sys/timeb.h>
#endif
-#if HAVE_CRT_EXTERNS_H
-#include <crt_externs.h> /* for Darwin _NSGetEnviron */
-#endif
-
#ifndef tzname /* For SGI. */
extern char *tzname[]; /* RS6000 and others reject char **tzname. */
#endif
@@ -98,15 +95,6 @@ extern char *strptime ();
# define timet long
#endif
-extern char ** environ;
-
-/* On Apple Darwin in a shared library there's no "environ" to access
- directly, instead the address of that variable must be obtained with
- _NSGetEnviron(). */
-#if HAVE__NSGETENVIRON && defined (PIC)
-#define environ (*_NSGetEnviron())
-#endif
-
#ifdef HAVE_TIMES
static
diff --git a/libguile/stime.h b/libguile/stime.h
index c64c60ea9..8b70cee62 100644
--- a/libguile/stime.h
+++ b/libguile/stime.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000, 2003, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/strerror.c b/libguile/strerror.c
index c2f20f0c2..0e0e94ee8 100644
--- a/libguile/strerror.c
+++ b/libguile/strerror.c
@@ -1,19 +1,20 @@
/* Turning errno values into English error messages.
Copyright (C) 1985, 86, 87, 88, 93, 94, 95, 2000, 2001, 2006 Free Software Foundation, Inc.
- This library is free software; you can redistribute it and/or
- modify it under the terms of the GNU Lesser General Public
- License as published by the Free Software Foundation; either
- version 2.1 of the License, or (at your option) any later version.
-
- This library is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- Lesser General Public License for more details.
-
- You should have received a copy of the GNU Lesser General Public
- License along with this library; if not, write to the Free Software
- Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ This library is free software; you can redistribute it and/or
+ modify it under the terms of the GNU Lesser General Public License
+ as published by the Free Software Foundation; either version 3 of
+ the License, or (at your option) any later version.
+
+ This library is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ Lesser General Public License for more details.
+
+ You should have received a copy of the GNU Lesser General Public
+ License along with this library; if not, write to the Free Software
+ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ 02110-1301 USA
*/
char *
diff --git a/libguile/strings.c b/libguile/strings.c
index 6e3b0a347..8aa1e6622 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1998,2000,2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -23,6 +24,9 @@
#include <string.h>
#include <stdio.h>
+#include <ctype.h>
+#include <unistr.h>
+#include <uniconv.h>
#include "libguile/_scm.h"
#include "libguile/chars.h"
@@ -41,7 +45,7 @@
*
* XXX - keeping an accurate refcount during GC seems to be quite
* tricky, so we just keep score of whether a stringbuf might be
- * shared, not wether it definitely is.
+ * shared, not whether it definitely is.
*
* The scheme I (mvo) tried to keep an accurate reference count would
* recount all strings that point to a stringbuf during the mark-phase
@@ -58,19 +62,29 @@
* A stringbuf needs to know its length, but only so that it can be
* reported when the stringbuf is freed.
*
- * Stringbufs (and strings) are not stored very compactly: a stringbuf
- * has room for about 2*sizeof(scm_t_bits)-1 bytes additional
- * information. As a compensation, the code below is made more
- * complicated by storing small strings inline in the double cell of a
- * stringbuf. So we have fixstrings and bigstrings...
+ * There are 3 storage strategies for stringbufs: inline, outline, and
+ * wide.
+ *
+ * Inline strings are small 8-bit strings stored within the double
+ * cell itself. Outline strings are larger 8-bit strings with GC
+ * allocated storage. Wide strings are 32-bit strings with allocated
+ * storage.
+ *
+ * There was little value in making wide string inlineable, since
+ * there is only room for three inlined 32-bit characters. Thus wide
+ * stringbufs are never inlined.
*/
#define STRINGBUF_F_SHARED 0x100
#define STRINGBUF_F_INLINE 0x200
+#define STRINGBUF_F_WIDE 0x400 /* If true, strings have UCS-4
+ encoding. Otherwise, strings
+ are Latin-1. */
#define STRINGBUF_TAG scm_tc7_stringbuf
#define STRINGBUF_SHARED(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_SHARED)
#define STRINGBUF_INLINE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_INLINE)
+#define STRINGBUF_WIDE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_WIDE)
#define STRINGBUF_OUTLINE_CHARS(buf) ((char *)SCM_CELL_WORD_1(buf))
#define STRINGBUF_OUTLINE_LENGTH(buf) (SCM_CELL_WORD_2(buf))
@@ -80,6 +94,8 @@
#define STRINGBUF_CHARS(buf) (STRINGBUF_INLINE (buf) \
? STRINGBUF_INLINE_CHARS (buf) \
: STRINGBUF_OUTLINE_CHARS (buf))
+
+#define STRINGBUF_WIDE_CHARS(buf) ((scm_t_wchar *)SCM_CELL_WORD_1(buf))
#define STRINGBUF_LENGTH(buf) (STRINGBUF_INLINE (buf) \
? STRINGBUF_INLINE_LENGTH (buf) \
: STRINGBUF_OUTLINE_LENGTH (buf))
@@ -89,10 +105,12 @@
#define SET_STRINGBUF_SHARED(buf) \
(SCM_SET_CELL_WORD_0 ((buf), SCM_CELL_WORD_0 (buf) | STRINGBUF_F_SHARED))
-#if SCM_DEBUG
+#if SCM_STRING_LENGTH_HISTOGRAM
static size_t lenhist[1001];
#endif
+/* Make a stringbuf with space for LEN 8-bit Latin-1-encoded
+ characters. */
static SCM
make_stringbuf (size_t len)
{
@@ -103,7 +121,7 @@ make_stringbuf (size_t len)
can be dropped.
*/
-#if SCM_DEBUG
+#if SCM_STRING_LENGTH_HISTOGRAM
if (len < 1000)
lenhist[len]++;
else
@@ -124,6 +142,25 @@ make_stringbuf (size_t len)
}
}
+/* Make a stringbuf with space for LEN 32-bit UCS-4-encoded
+ characters. */
+static SCM
+make_wide_stringbuf (size_t len)
+{
+ scm_t_wchar *mem;
+#if SCM_STRING_LENGTH_HISTOGRAM
+ if (len < 1000)
+ lenhist[len]++;
+ else
+ lenhist[1000]++;
+#endif
+
+ mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string");
+ mem[len] = 0;
+ return scm_double_cell (STRINGBUF_TAG | STRINGBUF_F_WIDE, (scm_t_bits) mem,
+ (scm_t_bits) len, (scm_t_bits) 0);
+}
+
/* Return a new stringbuf whose underlying storage consists of the LEN+1
octets pointed to by STR (the last octet is zero). */
SCM
@@ -135,6 +172,49 @@ scm_i_take_stringbufn (char *str, size_t len)
(scm_t_bits) len, (scm_t_bits) 0);
}
+/* Convert a stringbuf containing 8-bit Latin-1-encoded characters to
+ one containing 32-bit UCS-4-encoded characters. */
+static void
+widen_stringbuf (SCM buf)
+{
+ size_t i, len;
+ scm_t_wchar *mem;
+
+ if (STRINGBUF_WIDE (buf))
+ return;
+
+ if (STRINGBUF_INLINE (buf))
+ {
+ len = STRINGBUF_INLINE_LENGTH (buf);
+
+ mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string");
+ for (i = 0; i < len; i++)
+ mem[i] =
+ (scm_t_wchar) (unsigned char) STRINGBUF_INLINE_CHARS (buf)[i];
+ mem[len] = 0;
+
+ SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) ^ STRINGBUF_F_INLINE);
+ SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) | STRINGBUF_F_WIDE);
+ SCM_SET_CELL_WORD_1 (buf, mem);
+ SCM_SET_CELL_WORD_2 (buf, len);
+ }
+ else
+ {
+ len = STRINGBUF_OUTLINE_LENGTH (buf);
+
+ mem = scm_gc_malloc (sizeof (scm_t_wchar) * (len + 1), "string");
+ for (i = 0; i < len; i++)
+ mem[i] =
+ (scm_t_wchar) (unsigned char) STRINGBUF_OUTLINE_CHARS (buf)[i];
+ mem[len] = 0;
+
+ scm_gc_free (STRINGBUF_OUTLINE_CHARS (buf), len + 1, "string");
+
+ SCM_SET_CELL_WORD_0 (buf, SCM_CELL_WORD_0 (buf) | STRINGBUF_F_WIDE);
+ SCM_SET_CELL_WORD_1 (buf, mem);
+ SCM_SET_CELL_WORD_2 (buf, len);
+ }
+}
scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
@@ -168,6 +248,9 @@ scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
#define IS_SH_STRING(str) (SCM_CELL_TYPE(str)==SH_STRING_TAG)
+/* Create a scheme string with space for LEN 8-bit Latin-1-encoded
+ characters. CHARSP, if not NULL, will be set to location of the
+ char array. */
SCM
scm_i_make_string (size_t len, char **charsp)
{
@@ -180,6 +263,21 @@ scm_i_make_string (size_t len, char **charsp)
return res;
}
+/* Create a scheme string with space for LEN 32-bit UCS-4-encoded
+ characters. CHARSP, if not NULL, will be set to location of the
+ character array. */
+SCM
+scm_i_make_wide_string (size_t len, scm_t_wchar **charsp)
+{
+ SCM buf = make_wide_stringbuf (len);
+ SCM res;
+ if (charsp)
+ *charsp = STRINGBUF_WIDE_CHARS (buf);
+ res = scm_double_cell (STRING_TAG, SCM_UNPACK (buf),
+ (scm_t_bits) 0, (scm_t_bits) len);
+ return res;
+}
+
static void
validate_substring_args (SCM str, size_t start, size_t end)
{
@@ -238,12 +336,24 @@ scm_i_substring_copy (SCM str, size_t start, size_t end)
SCM buf, my_buf;
size_t str_start;
get_str_buf_start (&str, &buf, &str_start);
- my_buf = make_stringbuf (len);
- memcpy (STRINGBUF_CHARS (my_buf),
- STRINGBUF_CHARS (buf) + str_start + start, len);
+ if (scm_i_is_narrow_string (str))
+ {
+ my_buf = make_stringbuf (len);
+ memcpy (STRINGBUF_CHARS (my_buf),
+ STRINGBUF_CHARS (buf) + str_start + start, len);
+ }
+ else
+ {
+ my_buf = make_wide_stringbuf (len);
+ u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (my_buf),
+ (scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf) + str_start
+ + start), len);
+ /* Even though this string is wide, the substring may be narrow.
+ Consider adding code to narrow the string. */
+ }
scm_remember_upto_here_1 (buf);
- return scm_double_cell (STRING_TAG, SCM_UNPACK(my_buf),
- (scm_t_bits)0, (scm_t_bits) len);
+ return scm_double_cell (STRING_TAG, SCM_UNPACK (my_buf),
+ (scm_t_bits) 0, (scm_t_bits) len);
}
SCM
@@ -296,23 +406,61 @@ scm_c_substring_shared (SCM str, size_t start, size_t end)
/* Internal accessors
*/
+/* Returns the number of characters in STR. This may be different
+ than the memory size of the string storage. */
size_t
scm_i_string_length (SCM str)
{
return STRING_LENGTH (str);
}
+/* True if the string is 'narrow', meaning it has a 8-bit Latin-1
+ encoding. False if it is 'wide', having a 32-bit UCS-4
+ encoding. */
+int
+scm_i_is_narrow_string (SCM str)
+{
+ return !STRINGBUF_WIDE (STRING_STRINGBUF (str));
+}
+
+/* Returns a pointer to the 8-bit Latin-1 encoded character array of
+ STR. */
const char *
scm_i_string_chars (SCM str)
{
SCM buf;
size_t start;
get_str_buf_start (&str, &buf, &start);
- return STRINGBUF_CHARS (buf) + start;
+ if (scm_i_is_narrow_string (str))
+ return STRINGBUF_CHARS (buf) + start;
+ else
+ scm_misc_error (NULL, "Invalid read access of chars of wide string: ~s",
+ scm_list_1 (str));
+ return NULL;
}
-char *
-scm_i_string_writable_chars (SCM orig_str)
+/* Returns a pointer to the 32-bit UCS-4 encoded character array of
+ STR. */
+const scm_t_wchar *
+scm_i_string_wide_chars (SCM str)
+{
+ SCM buf;
+ size_t start;
+
+ get_str_buf_start (&str, &buf, &start);
+ if (!scm_i_is_narrow_string (str))
+ return STRINGBUF_WIDE_CHARS (buf) + start;
+ else
+ scm_misc_error (NULL, "Invalid read access of chars of narrow string: ~s",
+ scm_list_1 (str));
+}
+
+/* If the buffer in ORIG_STR is shared, copy ORIG_STR's characters to
+ a new string buffer, so that it can be modified without modifying
+ other strings. Also, lock the string mutex. Later, one must call
+ scm_i_string_stop_writing to unlock the mutex. */
+SCM
+scm_i_string_start_writing (SCM orig_str)
{
SCM buf, str = orig_str;
size_t start;
@@ -324,17 +472,28 @@ scm_i_string_writable_chars (SCM orig_str)
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
if (STRINGBUF_SHARED (buf))
{
- /* Clone stringbuf. */
-
+ /* Clone the stringbuf. */
size_t len = STRING_LENGTH (str);
SCM new_buf;
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
- new_buf = make_stringbuf (len);
- memcpy (STRINGBUF_CHARS (new_buf),
- STRINGBUF_CHARS (buf) + STRING_START (str), len);
+ if (scm_i_is_narrow_string (str))
+ {
+ new_buf = make_stringbuf (len);
+ memcpy (STRINGBUF_CHARS (new_buf),
+ STRINGBUF_CHARS (buf) + STRING_START (str), len);
+
+ }
+ else
+ {
+ new_buf = make_wide_stringbuf (len);
+ u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf),
+ (scm_t_uint32 *) (STRINGBUF_WIDE_CHARS (buf)
+ + STRING_START (str)), len);
+ }
+ SET_STRING_STRINGBUF (str, new_buf);
start -= STRING_START (str);
/* FIXME: The following operations are not atomic, so other threads
@@ -350,16 +509,77 @@ scm_i_string_writable_chars (SCM orig_str)
scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
}
+ return orig_str;
+}
- return STRINGBUF_CHARS (buf) + start;
+/* Return a pointer to the 8-bit Latin-1 chars of a string. */
+char *
+scm_i_string_writable_chars (SCM str)
+{
+ SCM buf;
+ size_t start;
+
+ get_str_buf_start (&str, &buf, &start);
+ if (scm_i_is_narrow_string (str))
+ return STRINGBUF_CHARS (buf) + start;
+ else
+ scm_misc_error (NULL, "Invalid write access of chars of wide string: ~s",
+ scm_list_1 (str));
+ return NULL;
}
+/* Return a pointer to the UCS-4 codepoints of a string. */
+static scm_t_wchar *
+scm_i_string_writable_wide_chars (SCM str)
+{
+ SCM buf;
+ size_t start;
+
+ get_str_buf_start (&str, &buf, &start);
+ if (!scm_i_is_narrow_string (str))
+ return STRINGBUF_WIDE_CHARS (buf) + start;
+ else
+ scm_misc_error (NULL, "Invalid read access of chars of narrow string: ~s",
+ scm_list_1 (str));
+}
+
+/* Unlock the string mutex that was locked when
+ scm_i_string_start_writing was called. */
void
scm_i_string_stop_writing (void)
{
scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
}
+/* Return the Xth character of STR as a UCS-4 codepoint. */
+scm_t_wchar
+scm_i_string_ref (SCM str, size_t x)
+{
+ if (scm_i_is_narrow_string (str))
+ return (scm_t_wchar) (unsigned char) (scm_i_string_chars (str)[x]);
+ else
+ return scm_i_string_wide_chars (str)[x];
+}
+
+/* Set the Pth character of STR to UCS-4 codepoint CHR. */
+void
+scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr)
+{
+ if (chr > 0xFF && scm_i_is_narrow_string (str))
+ widen_stringbuf (STRING_STRINGBUF (str));
+
+ if (scm_i_is_narrow_string (str))
+ {
+ char *dst = scm_i_string_writable_chars (str);
+ dst[p] = (char) (unsigned char) chr;
+ }
+ else
+ {
+ scm_t_wchar *dst = scm_i_string_writable_wide_chars (str);
+ dst[p] = chr;
+ }
+}
+
/* Symbols.
Basic symbol creation and accessing is done here, the rest is in
@@ -394,10 +614,21 @@ scm_i_make_symbol (SCM name, scm_t_bits flags,
else
{
/* make new buf. */
- SCM new_buf = make_stringbuf (length);
- memcpy (STRINGBUF_CHARS (new_buf),
- STRINGBUF_CHARS (buf) + start, length);
- buf = new_buf;
+ if (scm_i_is_narrow_string (name))
+ {
+ SCM new_buf = make_stringbuf (length);
+ memcpy (STRINGBUF_CHARS (new_buf),
+ STRINGBUF_CHARS (buf) + start, length);
+ buf = new_buf;
+ }
+ else
+ {
+ SCM new_buf = make_wide_stringbuf (length);
+ u32_cpy ((scm_t_uint32 *) STRINGBUF_WIDE_CHARS (new_buf),
+ (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf) + start,
+ length);
+ buf = new_buf;
+ }
}
return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf),
(scm_t_bits) hash, SCM_UNPACK (props));
@@ -426,6 +657,8 @@ scm_i_c_take_symbol (char *name, size_t len,
(scm_t_bits) hash, SCM_UNPACK (props));
}
+/* Returns the number of characters in SYM. This may be different
+ from the memory size of SYM. */
size_t
scm_i_symbol_length (SCM sym)
{
@@ -442,11 +675,45 @@ scm_c_symbol_length (SCM sym)
}
#undef FUNC_NAME
+/* True if the name of SYM is stored as a Latin-1 encoded string.
+ False if it is stored as a 32-bit UCS-4-encoded string. */
+int
+scm_i_is_narrow_symbol (SCM sym)
+{
+ SCM buf;
+
+ buf = SYMBOL_STRINGBUF (sym);
+ return !STRINGBUF_WIDE (buf);
+}
+
+/* Returns a pointer to the 8-bit Latin-1 encoded character array that
+ contains the name of SYM. */
const char *
scm_i_symbol_chars (SCM sym)
{
- SCM buf = SYMBOL_STRINGBUF (sym);
- return STRINGBUF_CHARS (buf);
+ SCM buf;
+
+ buf = SYMBOL_STRINGBUF (sym);
+ if (!STRINGBUF_WIDE (buf))
+ return STRINGBUF_CHARS (buf);
+ else
+ scm_misc_error (NULL, "Invalid access of chars of a wide symbol ~S",
+ scm_list_1 (sym));
+}
+
+/* Return a pointer to the 32-bit UCS-4-encoded character array of a
+ symbol's name. */
+const scm_t_wchar *
+scm_i_symbol_wide_chars (SCM sym)
+{
+ SCM buf;
+
+ buf = SYMBOL_STRINGBUF (sym);
+ if (STRINGBUF_WIDE (buf))
+ return STRINGBUF_WIDE_CHARS (buf);
+ else
+ scm_misc_error (NULL, "Invalid access of chars of a narrow symbol ~S",
+ scm_list_1 (sym));
}
SCM
@@ -460,64 +727,212 @@ scm_i_symbol_substring (SCM sym, size_t start, size_t end)
(scm_t_bits)start, (scm_t_bits) end - start);
}
+/* Returns the Xth character of symbol SYM as a UCS-4 codepoint. */
+scm_t_wchar
+scm_i_symbol_ref (SCM sym, size_t x)
+{
+ if (scm_i_is_narrow_symbol (sym))
+ return (scm_t_wchar) (unsigned char) (scm_i_symbol_chars (sym)[x]);
+ else
+ return scm_i_symbol_wide_chars (sym)[x];
+}
+
/* Debugging
*/
-#if SCM_DEBUG
-
-SCM scm_sys_string_dump (SCM);
-SCM scm_sys_symbol_dump (SCM);
-SCM scm_sys_stringbuf_hist (void);
-
-SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0,
- (SCM str),
- "")
+SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str),
+ "Returns an association list containing debugging information\n"
+ "for @var{str}. The association list has the following entries."
+ "@table @code\n"
+ "@item string\n"
+ "The string itself.\n"
+ "@item start\n"
+ "The start index of the string into its stringbuf\n"
+ "@item length\n"
+ "The length of the string\n"
+ "@item shared\n"
+ "If this string is a substring, it returns its parent string.\n"
+ "Otherwise, it returns @code{#f}\n"
+ "@item read-only\n"
+ "@code{#t} if the string is read-only\n"
+ "@item stringbuf-chars\n"
+ "A new string containing this string's stringbuf's characters\n"
+ "@item stringbuf-length\n"
+ "The number of characters in this stringbuf\n"
+ "@item stringbuf-shared\n"
+ "@code{#t} if this stringbuf is shared\n"
+ "@item stringbuf-inline\n"
+ "@code{#t} if this stringbuf's characters are stored in the\n"
+ "cell itself, or @code{#f} if they were allocated in memory\n"
+ "@item stringbuf-wide\n"
+ "@code{#t} if this stringbuf's characters are stored in a\n"
+ "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n"
+ "buffer\n"
+ "@end table")
#define FUNC_NAME s_scm_sys_string_dump
{
+ SCM e1, e2, e3, e4, e5, e6, e7, e8, e9, e10;
+ SCM buf;
SCM_VALIDATE_STRING (1, str);
- fprintf (stderr, "%p:\n", str);
- fprintf (stderr, " start: %u\n", STRING_START (str));
- fprintf (stderr, " len: %u\n", STRING_LENGTH (str));
+
+ /* String info */
+ e1 = scm_cons (scm_from_locale_symbol ("string"),
+ str);
+ e2 = scm_cons (scm_from_locale_symbol ("start"),
+ scm_from_size_t (STRING_START (str)));
+ e3 = scm_cons (scm_from_locale_symbol ("length"),
+ scm_from_size_t (STRING_LENGTH (str)));
+
if (IS_SH_STRING (str))
{
- fprintf (stderr, " string: %p\n", SH_STRING_STRING (str));
- fprintf (stderr, "\n");
- scm_sys_string_dump (SH_STRING_STRING (str));
+ e4 = scm_cons (scm_from_locale_symbol ("shared"),
+ SH_STRING_STRING (str));
+ buf = STRING_STRINGBUF (SH_STRING_STRING (str));
}
else
{
- SCM buf = STRING_STRINGBUF (str);
- fprintf (stderr, " buf: %p\n", buf);
- fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
- fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf));
- fprintf (stderr, " flags: %x\n", (SCM_CELL_WORD_0 (buf) & 0x300));
+ e4 = scm_cons (scm_from_locale_symbol ("shared"),
+ SCM_BOOL_F);
+ buf = STRING_STRINGBUF (str);
}
- return SCM_UNSPECIFIED;
+
+ if (IS_RO_STRING (str))
+ e5 = scm_cons (scm_from_locale_symbol ("read-only"),
+ SCM_BOOL_T);
+ else
+ e5 = scm_cons (scm_from_locale_symbol ("read-only"),
+ SCM_BOOL_F);
+
+ /* Stringbuf info */
+ if (!STRINGBUF_WIDE (buf))
+ {
+ size_t len = STRINGBUF_LENGTH (buf);
+ char *cbuf;
+ SCM sbc = scm_i_make_string (len, &cbuf);
+ memcpy (cbuf, STRINGBUF_CHARS (buf), len);
+ e6 = scm_cons (scm_from_locale_symbol ("stringbuf-chars"),
+ sbc);
+ }
+ else
+ {
+ size_t len = STRINGBUF_LENGTH (buf);
+ scm_t_wchar *cbuf;
+ SCM sbc = scm_i_make_wide_string (len, &cbuf);
+ u32_cpy ((scm_t_uint32 *) cbuf,
+ (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf), len);
+ e6 = scm_cons (scm_from_locale_symbol ("stringbuf-chars"),
+ sbc);
+ }
+ e7 = scm_cons (scm_from_locale_symbol ("stringbuf-length"),
+ scm_from_size_t (STRINGBUF_LENGTH (buf)));
+ if (STRINGBUF_SHARED (buf))
+ e8 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"),
+ SCM_BOOL_T);
+ else
+ e8 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"),
+ SCM_BOOL_F);
+ if (STRINGBUF_INLINE (buf))
+ e9 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"),
+ SCM_BOOL_T);
+ else
+ e9 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"),
+ SCM_BOOL_F);
+ if (STRINGBUF_WIDE (buf))
+ e10 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
+ SCM_BOOL_T);
+ else
+ e10 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
+ SCM_BOOL_F);
+
+ return scm_list_n (e1, e2, e3, e4, e5, e6, e7, e8, e9, e10, SCM_UNDEFINED);
}
#undef FUNC_NAME
-SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0,
- (SCM sym),
- "")
+SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym),
+ "Returns an association list containing debugging information\n"
+ "for @var{sym}. The association list has the following entries."
+ "@table @code\n"
+ "@item symbol\n"
+ "The symbol itself\n"
+ "@item hash\n"
+ "Its hash value\n"
+ "@item interned\n"
+ "@code{#t} if it is an interned symbol\n"
+ "@item stringbuf-chars\n"
+ "A new string containing this symbols's stringbuf's characters\n"
+ "@item stringbuf-length\n"
+ "The number of characters in this stringbuf\n"
+ "@item stringbuf-shared\n"
+ "@code{#t} if this stringbuf is shared\n"
+ "@item stringbuf-inline\n"
+ "@code{#t} if this stringbuf's characters are stored in the\n"
+ "cell itself, or @code{#f} if they were allocated in memory\n"
+ "@item stringbuf-wide\n"
+ "@code{#t} if this stringbuf's characters are stored in a\n"
+ "32-bit buffer, or @code{#f} if they are stored in an 8-bit\n"
+ "buffer\n"
+ "@end table")
#define FUNC_NAME s_scm_sys_symbol_dump
{
+ SCM e1, e2, e3, e4, e5, e6, e7, e8;
+ SCM buf;
SCM_VALIDATE_SYMBOL (1, sym);
- fprintf (stderr, "%p:\n", sym);
- fprintf (stderr, " hash: %lu\n", scm_i_symbol_hash (sym));
- {
- SCM buf = SYMBOL_STRINGBUF (sym);
- fprintf (stderr, " buf: %p\n", buf);
- fprintf (stderr, " chars: %p\n", STRINGBUF_CHARS (buf));
- fprintf (stderr, " length: %u\n", STRINGBUF_LENGTH (buf));
- fprintf (stderr, " shared: %u\n", STRINGBUF_SHARED (buf));
- }
- return SCM_UNSPECIFIED;
+ e1 = scm_cons (scm_from_locale_symbol ("symbol"),
+ sym);
+ e2 = scm_cons (scm_from_locale_symbol ("hash"),
+ scm_from_ulong (scm_i_symbol_hash (sym)));
+ e3 = scm_cons (scm_from_locale_symbol ("interned"),
+ scm_symbol_interned_p (sym));
+ buf = SYMBOL_STRINGBUF (sym);
+
+ /* Stringbuf info */
+ if (!STRINGBUF_WIDE (buf))
+ {
+ size_t len = STRINGBUF_LENGTH (buf);
+ char *cbuf;
+ SCM sbc = scm_i_make_string (len, &cbuf);
+ memcpy (cbuf, STRINGBUF_CHARS (buf), len);
+ e4 = scm_cons (scm_from_locale_symbol ("stringbuf-chars"),
+ sbc);
+ }
+ else
+ {
+ size_t len = STRINGBUF_LENGTH (buf);
+ scm_t_wchar *cbuf;
+ SCM sbc = scm_i_make_wide_string (len, &cbuf);
+ u32_cpy ((scm_t_uint32 *) cbuf,
+ (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf), len);
+ e4 = scm_cons (scm_from_locale_symbol ("stringbuf-chars"),
+ sbc);
+ }
+ e5 = scm_cons (scm_from_locale_symbol ("stringbuf-length"),
+ scm_from_size_t (STRINGBUF_LENGTH (buf)));
+ if (STRINGBUF_SHARED (buf))
+ e6 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"),
+ SCM_BOOL_T);
+ else
+ e6 = scm_cons (scm_from_locale_symbol ("stringbuf-shared"),
+ SCM_BOOL_F);
+ if (STRINGBUF_INLINE (buf))
+ e7 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"),
+ SCM_BOOL_T);
+ else
+ e7 = scm_cons (scm_from_locale_symbol ("stringbuf-inline"),
+ SCM_BOOL_F);
+ if (STRINGBUF_WIDE (buf))
+ e8 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
+ SCM_BOOL_T);
+ else
+ e8 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"),
+ SCM_BOOL_F);
+ return scm_list_n (e1, e2, e3, e4, e5, e6, e7, e8, SCM_UNDEFINED);
+
}
#undef FUNC_NAME
-SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0,
- (void),
- "")
+#if SCM_STRING_LENGTH_HISTOGRAM
+
+SCM_DEFINE (scm_sys_stringbuf_hist, "%stringbuf-hist", 0, 0, 0, (void), "")
#define FUNC_NAME s_scm_sys_stringbuf_hist
{
int i;
@@ -553,29 +968,47 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1,
#define FUNC_NAME s_scm_string
{
SCM result;
+ SCM rest;
size_t len;
- char *data;
+ size_t p = 0;
+ long i;
- {
- long i = scm_ilength (chrs);
+ /* Verify that this is a list of chars. */
+ i = scm_ilength (chrs);
+ SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME);
- SCM_ASSERT (i >= 0, chrs, SCM_ARG1, FUNC_NAME);
- len = i;
- }
+ len = (size_t) i;
+ rest = chrs;
- result = scm_i_make_string (len, &data);
- while (len > 0 && scm_is_pair (chrs))
+ while (len > 0 && scm_is_pair (rest))
{
- SCM elt = SCM_CAR (chrs);
-
+ SCM elt = SCM_CAR (rest);
SCM_VALIDATE_CHAR (SCM_ARGn, elt);
- *data++ = SCM_CHAR (elt);
- chrs = SCM_CDR (chrs);
+ rest = SCM_CDR (rest);
+ len--;
+ scm_remember_upto_here_1 (elt);
+ }
+
+ /* Construct a string containing this list of chars. */
+ len = (size_t) i;
+ rest = chrs;
+
+ result = scm_i_make_string (len, NULL);
+ result = scm_i_string_start_writing (result);
+ while (len > 0 && scm_is_pair (rest))
+ {
+ SCM elt = SCM_CAR (rest);
+ scm_i_string_set_x (result, p, SCM_CHAR (elt));
+ p++;
+ rest = SCM_CDR (rest);
len--;
+ scm_remember_upto_here_1 (elt);
}
+ scm_i_string_stop_writing ();
+
if (len > 0)
scm_misc_error (NULL, "list changed while constructing string", SCM_EOL);
- if (!scm_is_null (chrs))
+ if (!scm_is_null (rest))
scm_wrong_type_arg_msg (NULL, 0, chrs, "proper list");
return result;
@@ -598,13 +1031,16 @@ SCM
scm_c_make_string (size_t len, SCM chr)
#define FUNC_NAME NULL
{
- char *dst;
- SCM res = scm_i_make_string (len, &dst);
+ size_t p;
+ SCM res = scm_i_make_string (len, NULL);
if (!SCM_UNBNDP (chr))
{
SCM_VALIDATE_CHAR (0, chr);
- memset (dst, SCM_CHAR (chr), len);
+ res = scm_i_string_start_writing (res);
+ for (p = 0; p < len; p++)
+ scm_i_string_set_x (res, p, SCM_CHAR (chr));
+ scm_i_string_stop_writing ();
}
return res;
@@ -621,6 +1057,20 @@ SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_string_width, "string-width", 1, 0, 0,
+ (SCM string),
+ "Return the bytes used to represent a character in @var{string}."
+ "This will return 1 or 4.")
+#define FUNC_NAME s_scm_string_width
+{
+ SCM_VALIDATE_STRING (1, string);
+ if (!scm_i_is_narrow_string (string))
+ return scm_from_int (4);
+
+ return scm_from_int (1);
+}
+#undef FUNC_NAME
+
size_t
scm_c_string_length (SCM string)
{
@@ -631,8 +1081,8 @@ scm_c_string_length (SCM string)
SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
(SCM str, SCM k),
- "Return character @var{k} of @var{str} using zero-origin\n"
- "indexing. @var{k} must be a valid index of @var{str}.")
+ "Return character @var{k} of @var{str} using zero-origin\n"
+ "indexing. @var{k} must be a valid index of @var{str}.")
#define FUNC_NAME s_scm_string_ref
{
size_t len;
@@ -646,7 +1096,10 @@ SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
else
scm_out_of_range (NULL, k);
- return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]);
+ if (scm_i_is_narrow_string (str))
+ return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]);
+ else
+ return SCM_MAKE_CHAR (scm_i_string_wide_chars (str)[idx]);
}
#undef FUNC_NAME
@@ -655,14 +1108,18 @@ scm_c_string_ref (SCM str, size_t p)
{
if (p >= scm_i_string_length (str))
scm_out_of_range (NULL, scm_from_size_t (p));
- return SCM_MAKE_CHAR (scm_i_string_chars (str)[p]);
+ if (scm_i_is_narrow_string (str))
+ return SCM_MAKE_CHAR (scm_i_string_chars (str)[p]);
+ else
+ return SCM_MAKE_CHAR (scm_i_string_wide_chars (str)[p]);
+
}
SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
(SCM str, SCM k, SCM chr),
- "Store @var{chr} in element @var{k} of @var{str} and return\n"
- "an unspecified value. @var{k} must be a valid index of\n"
- "@var{str}.")
+ "Store @var{chr} in element @var{k} of @var{str} and return\n"
+ "an unspecified value. @var{k} must be a valid index of\n"
+ "@var{str}.")
#define FUNC_NAME s_scm_string_set_x
{
size_t len;
@@ -677,11 +1134,10 @@ SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
scm_out_of_range (NULL, k);
SCM_VALIDATE_CHAR (3, chr);
- {
- char *dst = scm_i_string_writable_chars (str);
- dst[idx] = SCM_CHAR (chr);
- scm_i_string_stop_writing ();
- }
+ str = scm_i_string_start_writing (str);
+ scm_i_string_set_x (str, idx, SCM_CHAR (chr));
+ scm_i_string_stop_writing ();
+
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -691,11 +1147,9 @@ scm_c_string_set_x (SCM str, size_t p, SCM chr)
{
if (p >= scm_i_string_length (str))
scm_out_of_range (NULL, scm_from_size_t (p));
- {
- char *dst = scm_i_string_writable_chars (str);
- dst[p] = SCM_CHAR (chr);
- scm_i_string_stop_writing ();
- }
+ str = scm_i_string_start_writing (str);
+ scm_i_string_set_x (str, p, SCM_CHAR (chr));
+ scm_i_string_stop_writing ();
}
SCM_DEFINE (scm_substring, "substring", 2, 1, 0,
@@ -796,31 +1250,59 @@ SCM_DEFINE (scm_substring_shared, "substring/shared", 2, 1, 0,
SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
(SCM args),
- "Return a newly allocated string whose characters form the\n"
+ "Return a newly allocated string whose characters form the\n"
"concatenation of the given strings, @var{args}.")
#define FUNC_NAME s_scm_string_append
{
SCM res;
- size_t i = 0;
+ size_t len = 0;
+ int wide = 0;
SCM l, s;
- char *data;
+ size_t i;
+ union
+ {
+ char *narrow;
+ scm_t_wchar *wide;
+ } data;
SCM_VALIDATE_REST_ARGUMENT (args);
- for (l = args; !scm_is_null (l); l = SCM_CDR (l))
+ for (l = args; !scm_is_null (l); l = SCM_CDR (l))
{
s = SCM_CAR (l);
SCM_VALIDATE_STRING (SCM_ARGn, s);
- i += scm_i_string_length (s);
+ len += scm_i_string_length (s);
+ if (!scm_i_is_narrow_string (s))
+ wide = 1;
}
- res = scm_i_make_string (i, &data);
- for (l = args; !scm_is_null (l); l = SCM_CDR (l))
+ data.narrow = NULL;
+ if (!wide)
+ res = scm_i_make_string (len, &data.narrow);
+ else
+ res = scm_i_make_wide_string (len, &data.wide);
+
+ for (l = args; !scm_is_null (l); l = SCM_CDR (l))
{
size_t len;
s = SCM_CAR (l);
SCM_VALIDATE_STRING (SCM_ARGn, s);
len = scm_i_string_length (s);
- memcpy (data, scm_i_string_chars (s), len);
- data += len;
+ if (!wide)
+ {
+ memcpy (data.narrow, scm_i_string_chars (s), len);
+ data.narrow += len;
+ }
+ else
+ {
+ if (scm_i_is_narrow_string (s))
+ {
+ for (i = 0; i < scm_i_string_length (s); i++)
+ data.wide[i] = (unsigned char) scm_i_string_chars (s)[i];
+ }
+ else
+ u32_cpy ((scm_t_uint32 *) data.wide,
+ (scm_t_uint32 *) scm_i_string_wide_chars (s), len);
+ data.wide += len;
+ }
scm_remember_upto_here_1 (s);
}
return res;
@@ -839,8 +1321,11 @@ scm_from_locale_stringn (const char *str, size_t len)
SCM res;
char *dst;
- if (len == (size_t)-1)
+ if (len == (size_t) -1)
len = strlen (str);
+ if (len == 0)
+ return scm_nullstr;
+
res = scm_i_make_string (len, &dst);
memcpy (dst, str, len);
return res;
@@ -849,29 +1334,33 @@ scm_from_locale_stringn (const char *str, size_t len)
SCM
scm_from_locale_string (const char *str)
{
+ if (str == NULL)
+ return scm_nullstr;
+
return scm_from_locale_stringn (str, -1);
}
+/* Create a new scheme string from the C string STR. The memory of
+ STR may be used directly as storage for the new string. */
SCM
scm_take_locale_stringn (char *str, size_t len)
{
SCM buf, res;
- if (len == (size_t)-1)
+ if (len == (size_t) -1)
len = strlen (str);
else
{
/* Ensure STR is null terminated. A realloc for 1 extra byte should
often be satisfied from the alignment padding after the block, with
no actual data movement. */
- str = scm_realloc (str, len+1);
+ str = scm_realloc (str, len + 1);
str[len] = '\0';
}
buf = scm_i_take_stringbufn (str, len);
res = scm_double_cell (STRING_TAG,
- SCM_UNPACK (buf),
- (scm_t_bits) 0, (scm_t_bits) len);
+ SCM_UNPACK (buf), (scm_t_bits) 0, (scm_t_bits) len);
return res;
}
@@ -881,33 +1370,144 @@ scm_take_locale_string (char *str)
return scm_take_locale_stringn (str, -1);
}
+/* Change libunistring escapes (\uXXXX and \UXXXXXXXX) to \xXX \uXXXX
+ and \UXXXXXX. */
+static void
+unistring_escapes_to_guile_escapes (char **bufp, size_t *lenp)
+{
+ char *before, *after;
+ size_t i, j;
+
+ before = *bufp;
+ after = *bufp;
+ i = 0;
+ j = 0;
+ while (i < *lenp)
+ {
+ if ((i <= *lenp - 6)
+ && before[i] == '\\'
+ && before[i + 1] == 'u'
+ && before[i + 2] == '0' && before[i + 3] == '0')
+ {
+ /* Convert \u00NN to \xNN */
+ after[j] = '\\';
+ after[j + 1] = 'x';
+ after[j + 2] = tolower ((int) before[i + 4]);
+ after[j + 3] = tolower ((int) before[i + 5]);
+ i += 6;
+ j += 4;
+ }
+ else if ((i <= *lenp - 10)
+ && before[i] == '\\'
+ && before[i + 1] == 'U'
+ && before[i + 2] == '0' && before[i + 3] == '0')
+ {
+ /* Convert \U00NNNNNN to \UNNNNNN */
+ after[j] = '\\';
+ after[j + 1] = 'U';
+ after[j + 2] = tolower ((int) before[i + 4]);
+ after[j + 3] = tolower ((int) before[i + 5]);
+ after[j + 4] = tolower ((int) before[i + 6]);
+ after[j + 5] = tolower ((int) before[i + 7]);
+ after[j + 6] = tolower ((int) before[i + 8]);
+ after[j + 7] = tolower ((int) before[i + 9]);
+ i += 10;
+ j += 8;
+ }
+ else
+ {
+ after[j] = before[i];
+ i++;
+ j++;
+ }
+ }
+ *lenp = j;
+ after = scm_realloc (after, j);
+}
+
char *
-scm_to_locale_stringn (SCM str, size_t *lenp)
+scm_to_locale_stringn (SCM str, size_t * lenp)
{
- char *res;
- size_t len;
+ const char *enc;
+
+ /* In the future, enc will hold the port's encoding. */
+ enc = NULL;
+
+ return scm_to_stringn (str, lenp, enc,
+ SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE);
+}
+
+/* Low-level scheme to C string conversion function. */
+char *
+scm_to_stringn (SCM str, size_t * lenp, const char *encoding,
+ scm_t_string_failed_conversion_handler handler)
+{
+ static const char iso[11] = "ISO-8859-1";
+ char *buf;
+ size_t ilen, len, i;
if (!scm_is_string (str))
scm_wrong_type_arg_msg (NULL, 0, str, "string");
- len = scm_i_string_length (str);
- res = scm_malloc (len + ((lenp==NULL)? 1 : 0));
- memcpy (res, scm_i_string_chars (str), len);
+ ilen = scm_i_string_length (str);
+
+ if (ilen == 0)
+ {
+ buf = scm_malloc (1);
+ buf[0] = '\0';
+ if (lenp)
+ *lenp = 0;
+ return buf;
+ }
+
if (lenp == NULL)
+ for (i = 0; i < ilen; i++)
+ if (scm_i_string_ref (str, i) == '\0')
+ scm_misc_error (NULL,
+ "string contains #\\nul character: ~S",
+ scm_list_1 (str));
+
+ if (scm_i_is_narrow_string (str))
{
- res[len] = '\0';
- if (strlen (res) != len)
- {
- free (res);
- scm_misc_error (NULL,
- "string contains #\\nul character: ~S",
- scm_list_1 (str));
- }
+ if (lenp)
+ {
+ buf = scm_malloc (ilen);
+ memcpy (buf, scm_i_string_chars (str), ilen);
+ *lenp = ilen;
+ return buf;
+ }
+ else
+ {
+ buf = scm_malloc (ilen + 1);
+ memcpy (buf, scm_i_string_chars (str), ilen);
+ buf[ilen] = '\0';
+ return buf;
+ }
}
- else
+
+
+ buf = NULL;
+ len = 0;
+ buf = u32_conv_to_encoding (iso,
+ (enum iconv_ilseq_handler) handler,
+ (scm_t_uint32 *) scm_i_string_wide_chars (str),
+ ilen, NULL, NULL, &len);
+ if (buf == NULL)
+ scm_misc_error (NULL, "cannot convert to output locale ~s: \"~s\"",
+ scm_list_2 (scm_from_locale_string (iso), str));
+
+ if (handler == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE)
+ unistring_escapes_to_guile_escapes (&buf, &len);
+
+ if (lenp)
*lenp = len;
+ else
+ {
+ buf = scm_realloc (buf, len + 1);
+ buf[len] = '\0';
+ }
scm_remember_upto_here_1 (str);
- return res;
+ return buf;
}
char *
@@ -920,18 +1520,21 @@ size_t
scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len)
{
size_t len;
-
+ char *result = NULL;
if (!scm_is_string (str))
scm_wrong_type_arg_msg (NULL, 0, str, "string");
- len = scm_i_string_length (str);
- memcpy (buf, scm_i_string_chars (str), (len > max_len)? max_len : len);
+ result = scm_to_locale_stringn (str, &len);
+
+ memcpy (buf, result, (len > max_len) ? max_len : len);
+ free (result);
+
scm_remember_upto_here_1 (str);
return len;
}
/* converts C scm_array of strings to SCM scm_list of strings. */
/* If argc < 0, a null terminated scm_array is assumed. */
-SCM
+SCM
scm_makfromstrs (int argc, char **argv)
{
int i = argc;
@@ -1032,7 +1635,7 @@ scm_i_deprecated_string_chars (SCM str)
"SCM_STRING_CHARS does not work with shared substrings.",
SCM_EOL);
- /* We explicitely test for read-only strings to produce a better
+ /* We explicitly test for read-only strings to produce a better
error message.
*/
@@ -1043,6 +1646,7 @@ scm_i_deprecated_string_chars (SCM str)
/* The following is still wrong, of course...
*/
+ str = scm_i_string_start_writing (str);
chars = scm_i_string_writable_chars (str);
scm_i_string_stop_writing ();
return chars;
diff --git a/libguile/strings.h b/libguile/strings.h
index e7053257f..c3e3e6ac8 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -3,21 +3,22 @@
#ifndef SCM_STRINGS_H
#define SCM_STRINGS_H
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -45,26 +46,37 @@
Internal, low level interface to the character arrays
- - Use scm_i_string_chars to get a pointer to the byte array of a
- string for reading. Use scm_i_string_length to get the number of
- bytes in that array. The array is not null-terminated.
+ - Use scm_is_narrow_string to determine is the string is narrow or
+ wide.
+
+ - Use scm_i_string_chars or scm_i_string_wide_chars to get a
+ pointer to the byte or scm_t_wchar array of a string for reading.
+ Use scm_i_string_length to get the number of characters in that
+ array. The array is not null-terminated.
- The array is valid as long as the corresponding SCM object is
protected but only until the next SCM_TICK. During such a 'safe
point', strings might change their representation.
- - Use scm_i_string_writable_chars to get the same pointer as with
- scm_i_string_chars, but for reading and writing. This is a
- potentially costly operation since it implements the
- copy-on-write behavior. When done with the writing, call
- scm_i_string_stop_writing. You must do this before the next
- SCM_TICK. (This means, before calling almost any other scm_
- function and you can't allow throws, of course.)
-
- - New strings can be created with scm_i_make_string. This gives
- access to a writable pointer that remains valid as long as nobody
- else makes a copy-on-write substring of the string. Do not call
- scm_i_string_stop_writing for this pointer.
+ - Use scm_i_string_start_writing to get a version of the string
+ ready for reading and writing. This is a potentially costly
+ operation since it implements the copy-on-write behavior. When
+ done with the writing, call scm_i_string_stop_writing. You must
+ do this before the next SCM_TICK. (This means, before calling
+ almost any other scm_ function and you can't allow throws, of
+ course.)
+
+ - New strings can be created with scm_i_make_string or
+ scm_i_make_wide_string. This gives access to a writable pointer
+ that remains valid as long as nobody else makes a copy-on-write
+ substring of the string. Do not call scm_i_string_stop_writing
+ for this pointer.
+
+ - Alternately, scm_i_string_ref and scm_i_string_set_x can be used
+ to read and write strings without worrying about whether the
+ string is narrow or wide. scm_i_string_set_x still needs to be
+ bracketed by scm_i_string_start_writing and
+ scm_i_string_stop_writing.
Legacy interface
@@ -73,13 +85,24 @@
- SCM_STRING_CHARS uses scm_i_string_writable_chars and immediately
calls scm_i_stop_writing, hoping for the best. SCM_STRING_LENGTH
is the same as scm_i_string_length. SCM_STRING_CHARS will throw
- an error for for strings that are not null-terminated.
+ an error for for strings that are not null-terminated. There is
+ no wide version of this interface.
*/
+/* A type indicating what strategy to take when string locale
+ conversion is unsuccessful. */
+typedef enum
+{
+ SCM_FAILED_CONVERSION_ERROR = SCM_ICONVEH_ERROR,
+ SCM_FAILED_CONVERSION_QUESTION_MARK = SCM_ICONVEH_QUESTION_MARK,
+ SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE = SCM_ICONVEH_ESCAPE_SEQUENCE
+} scm_t_string_failed_conversion_handler;
+
SCM_API SCM scm_string_p (SCM x);
SCM_API SCM scm_string (SCM chrs);
SCM_API SCM scm_make_string (SCM k, SCM chr);
SCM_API SCM scm_string_length (SCM str);
+SCM_API SCM scm_string_width (SCM str);
SCM_API SCM scm_string_ref (SCM str, SCM k);
SCM_API SCM scm_string_set_x (SCM str, SCM k, SCM chr);
SCM_API SCM scm_substring (SCM str, SCM start, SCM end);
@@ -105,6 +128,10 @@ SCM_API SCM scm_take_locale_string (char *str);
SCM_API SCM scm_take_locale_stringn (char *str, size_t len);
SCM_API char *scm_to_locale_string (SCM str);
SCM_API char *scm_to_locale_stringn (SCM str, size_t *lenp);
+SCM_INTERNAL char *scm_to_stringn (SCM str, size_t *lenp,
+ const char *encoding,
+ scm_t_string_failed_conversion_handler
+ handler);
SCM_API size_t scm_to_locale_stringbuf (SCM str, char *buf, size_t max_len);
SCM_API SCM scm_makfromstrs (int argc, char **argv);
@@ -112,6 +139,7 @@ SCM_API SCM scm_makfromstrs (int argc, char **argv);
/* internal accessor functions. Arguments must be valid. */
SCM_INTERNAL SCM scm_i_make_string (size_t len, char **datap);
+SCM_INTERNAL SCM scm_i_make_wide_string (size_t len, scm_t_wchar **datap);
SCM_INTERNAL SCM scm_i_substring (SCM str, size_t start, size_t end);
SCM_INTERNAL SCM scm_i_substring_read_only (SCM str, size_t start, size_t end);
SCM_INTERNAL SCM scm_i_substring_shared (SCM str, size_t start, size_t end);
@@ -119,8 +147,12 @@ SCM_INTERNAL SCM scm_i_substring_copy (SCM str, size_t start, size_t end);
SCM_INTERNAL size_t scm_i_string_length (SCM str);
SCM_API /* FIXME: not internal */ const char *scm_i_string_chars (SCM str);
SCM_API /* FIXME: not internal */ char *scm_i_string_writable_chars (SCM str);
+SCM_INTERNAL const scm_t_wchar *scm_i_string_wide_chars (SCM str);
+SCM_INTERNAL SCM scm_i_string_start_writing (SCM str);
SCM_INTERNAL void scm_i_string_stop_writing (void);
-
+SCM_INTERNAL int scm_i_is_narrow_string (SCM str);
+SCM_INTERNAL scm_t_wchar scm_i_string_ref (SCM str, size_t x);
+SCM_INTERNAL void scm_i_string_set_x (SCM str, size_t p, scm_t_wchar chr);
/* internal functions related to symbols. */
SCM_INTERNAL SCM scm_i_make_symbol (SCM name, scm_t_bits flags,
@@ -132,8 +164,11 @@ SCM_INTERNAL SCM
scm_i_c_take_symbol (char *name, size_t len,
scm_t_bits flags, unsigned long hash, SCM props);
SCM_INTERNAL const char *scm_i_symbol_chars (SCM sym);
+SCM_INTERNAL const scm_t_wchar *scm_i_symbol_wide_chars (SCM sym);
SCM_INTERNAL size_t scm_i_symbol_length (SCM sym);
+SCM_INTERNAL int scm_i_is_narrow_symbol (SCM str);
SCM_INTERNAL SCM scm_i_symbol_substring (SCM sym, size_t start, size_t end);
+SCM_INTERNAL scm_t_wchar scm_i_symbol_ref (SCM sym, size_t x);
/* internal utility functions. */
@@ -143,6 +178,14 @@ SCM_INTERNAL void scm_i_get_substring_spec (size_t len,
SCM end, size_t *cend);
SCM_INTERNAL SCM scm_i_take_stringbufn (char *str, size_t len);
+/* Debugging functions */
+
+SCM_API SCM scm_sys_string_dump (SCM);
+SCM_API SCM scm_sys_symbol_dump (SCM);
+#if SCM_STRING_LENGTH_HISTOGRAM
+SCM_API SCM scm_sys_stringbuf_hist (void);
+#endif
+
/* deprecated stuff */
#if SCM_ENABLE_DEPRECATED
diff --git a/libguile/strorder.c b/libguile/strorder.c
index d3ccfcb06..e0a218389 100644
--- a/libguile/strorder.c
+++ b/libguile/strorder.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995, 1996, 1999, 2000, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/strorder.h b/libguile/strorder.h
index 17118634e..2c004e48a 100644
--- a/libguile/strorder.h
+++ b/libguile/strorder.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/strports.c b/libguile/strports.c
index bc3fd7014..5c67bf9a8 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -1,18 +1,19 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001,2002, 2003, 2005, 2006, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -107,7 +108,7 @@ stfill_buffer (SCM port)
/* change the size of a port's string to new_size. this doesn't
change read_buf_size. */
static void
-st_resize_port (scm_t_port *pt, off_t new_size)
+st_resize_port (scm_t_port *pt, scm_t_off new_size)
{
SCM old_stream = SCM_PACK (pt->stream);
const char *src = scm_i_string_chars (old_stream);
@@ -117,7 +118,7 @@ st_resize_port (scm_t_port *pt, off_t new_size)
unsigned long int min_size = min (old_size, new_size);
unsigned long int i;
- off_t index = pt->write_pos - pt->write_buf;
+ scm_t_off index = pt->write_pos - pt->write_buf;
pt->write_buf_size = new_size;
@@ -198,11 +199,11 @@ st_end_input (SCM port, int offset)
pt->rw_active = SCM_PORT_NEITHER;
}
-static off_t
-st_seek (SCM port, off_t offset, int whence)
+static scm_t_off
+st_seek (SCM port, scm_t_off offset, int whence)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
- off_t target;
+ scm_t_off target;
if (pt->rw_active == SCM_PORT_READ && offset == 0 && whence == SEEK_CUR)
/* special case to avoid disturbing the unread-char buffer. */
@@ -271,7 +272,7 @@ st_seek (SCM port, off_t offset, int whence)
}
static void
-st_truncate (SCM port, off_t length)
+st_truncate (SCM port, scm_t_off length)
{
scm_t_port *pt = SCM_PTAB_ENTRY (port);
diff --git a/libguile/strports.h b/libguile/strports.h
index 58ca71f57..3129c03e2 100644
--- a/libguile/strports.h
+++ b/libguile/strports.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,2000,2001,2002, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/struct.c b/libguile/struct.c
index b536bea3b..062b5245d 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1996,1997,1998,1999,2000,2001, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/struct.h b/libguile/struct.h
index cccf429ec..12069b487 100644
--- a/libguile/struct.h
+++ b/libguile/struct.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1997,1999,2000,2001, 2006, 2007, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/symbols.c b/libguile/symbols.c
index a15dfa43c..6faac61ff 100644
--- a/libguile/symbols.c
+++ b/libguile/symbols.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/symbols.h b/libguile/symbols.h
index c2dc18363..e4bc33391 100644
--- a/libguile/symbols.h
+++ b/libguile/symbols.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/tags.h b/libguile/tags.h
index 2f30369d9..329453341 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -7,18 +7,19 @@
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/threads.c b/libguile/threads.c
index fc131790d..250db2cd5 100644
--- a/libguile/threads.c
+++ b/libguile/threads.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -1180,6 +1181,16 @@ SCM_DEFINE (scm_join_thread_timed, "join-thread", 1, 2, 0,
scm_i_pthread_mutex_unlock (&t->admin_mutex);
SCM_TICK;
scm_i_scm_pthread_mutex_lock (&t->admin_mutex);
+
+ /* Check for exit again, since we just released and
+ reacquired the admin mutex, before the next block_self
+ call (which would block forever if t has already
+ exited). */
+ if (t->exited)
+ {
+ res = t->result;
+ break;
+ }
}
}
@@ -1503,6 +1514,7 @@ fat_mutex_unlock (SCM mutex, SCM cond,
{
if (relock)
scm_lock_mutex_timed (mutex, SCM_UNDEFINED, owner);
+ t->block_asyncs--;
break;
}
diff --git a/libguile/threads.h b/libguile/threads.h
index 6eb1c34c5..d48d530a5 100644
--- a/libguile/threads.h
+++ b/libguile/threads.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/throw.c b/libguile/throw.c
index e0dda27cf..b48bea1d1 100644
--- a/libguile/throw.c
+++ b/libguile/throw.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/throw.h b/libguile/throw.h
index 3cd557285..1ed6ba6b1 100644
--- a/libguile/throw.h
+++ b/libguile/throw.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1998,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/unif.c b/libguile/unif.c
index ecf96dfec..20bc2cfbc 100644
--- a/libguile/unif.c
+++ b/libguile/unif.c
@@ -1,18 +1,19 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -46,6 +47,7 @@
#include "libguile/srfi-13.h"
#include "libguile/srfi-4.h"
#include "libguile/vectors.h"
+#include "libguile/bytevectors.h"
#include "libguile/list.h"
#include "libguile/deprecation.h"
#include "libguile/dynwind.h"
@@ -108,6 +110,7 @@ struct {
{ "f64", SCM_UNSPECIFIED, scm_make_f64vector },
{ "c32", SCM_UNSPECIFIED, scm_make_c32vector },
{ "c64", SCM_UNSPECIFIED, scm_make_c64vector },
+ { "vu8", SCM_UNSPECIFIED, scm_make_bytevector },
{ NULL }
};
@@ -313,6 +316,12 @@ bitvector_ref (scm_t_array_handle *h, ssize_t pos)
}
static SCM
+bytevector_ref (scm_t_array_handle *h, ssize_t pos)
+{
+ return scm_from_uint8 (((scm_t_uint8 *) h->elements)[pos]);
+}
+
+static SCM
memoize_ref (scm_t_array_handle *h, ssize_t pos)
{
SCM v = h->array;
@@ -345,6 +354,11 @@ memoize_ref (scm_t_array_handle *h, ssize_t pos)
h->elements = scm_array_handle_bit_elements (h);
h->ref = bitvector_ref;
}
+ else if (scm_is_bytevector (v))
+ {
+ h->elements = scm_array_handle_uniform_elements (h);
+ h->ref = bytevector_ref;
+ }
else
scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
@@ -386,6 +400,17 @@ bitvector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
}
static void
+bytevector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
+{
+ scm_t_uint8 c_value;
+ scm_t_uint8 *elements;
+
+ c_value = scm_to_uint8 (val);
+ elements = (scm_t_uint8 *) h->elements;
+ elements[pos] = (scm_t_uint8) c_value;
+}
+
+static void
memoize_set (scm_t_array_handle *h, ssize_t pos, SCM val)
{
SCM v = h->array;
@@ -419,6 +444,11 @@ memoize_set (scm_t_array_handle *h, ssize_t pos, SCM val)
h->writable_elements = scm_array_handle_bit_writable_elements (h);
h->set = bitvector_set;
}
+ else if (scm_is_bytevector (v))
+ {
+ h->elements = scm_array_handle_uniform_writable_elements (h);
+ h->set = bytevector_set;
+ }
else
scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
@@ -770,6 +800,53 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
}
#undef FUNC_NAME
+SCM
+scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
+ size_t byte_len)
+#define FUNC_NAME "scm_from_contiguous_typed_array"
+{
+ size_t k, rlen = 1;
+ scm_t_array_dim *s;
+ creator_proc *creator;
+ SCM ra;
+ scm_t_array_handle h;
+ void *base;
+ size_t sz;
+
+ creator = type_to_creator (type);
+ ra = scm_i_shap2ra (bounds);
+ SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
+ s = SCM_I_ARRAY_DIMS (ra);
+ k = SCM_I_ARRAY_NDIM (ra);
+
+ while (k--)
+ {
+ s[k].inc = rlen;
+ SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
+ rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
+ }
+ SCM_I_ARRAY_V (ra) = creator (scm_from_size_t (rlen), SCM_UNDEFINED);
+
+
+ scm_array_get_handle (ra, &h);
+ base = scm_array_handle_uniform_writable_elements (&h);
+ sz = scm_array_handle_uniform_element_size (&h);
+ scm_array_handle_release (&h);
+
+ if (byte_len % sz)
+ SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL);
+ if (byte_len / sz != rlen)
+ SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
+
+ memcpy (base, bytes, byte_len);
+
+ if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
+ if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
+ return SCM_I_ARRAY_V (ra);
+ return ra;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
(SCM fill, SCM bounds),
"Create and return an array.")
diff --git a/libguile/unif.h b/libguile/unif.h
index a09bfc921..91d26c861 100644
--- a/libguile/unif.h
+++ b/libguile/unif.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -45,6 +46,9 @@ SCM_API SCM scm_array_p (SCM v, SCM prot);
SCM_API SCM scm_typed_array_p (SCM v, SCM type);
SCM_API SCM scm_make_array (SCM fill, SCM bounds);
SCM_API SCM scm_make_typed_array (SCM type, SCM fill, SCM bounds);
+SCM_API SCM scm_from_contiguous_typed_array (SCM type, SCM bounds,
+ const void *bytes,
+ size_t byte_len);
SCM_API SCM scm_array_rank (SCM ra);
SCM_API size_t scm_c_array_rank (SCM ra);
SCM_API SCM scm_array_dimensions (SCM ra);
diff --git a/libguile/validate.h b/libguile/validate.h
index e05b7dd83..b48bec758 100644
--- a/libguile/validate.h
+++ b/libguile/validate.h
@@ -3,21 +3,22 @@
#ifndef SCM_VALIDATE_H
#define SCM_VALIDATE_H
-/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007 Free Software Foundation, Inc.
+/* Copyright (C) 1999,2000,2001, 2002, 2004, 2006, 2007, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
/* Written by Greg J. Badros <gjb@cs.washington.edu>, Dec-1999 */
@@ -150,6 +151,9 @@
cvar = scm_to_bool (flag); \
} while (0)
+#define SCM_VALIDATE_BYTEVECTOR(_pos, _obj) \
+ SCM_VALIDATE_SMOB ((_pos), (_obj), bytevector)
+
#define SCM_VALIDATE_CHAR(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, CHARP, "character")
#define SCM_VALIDATE_CHAR_COPY(pos, scm, cvar) \
diff --git a/libguile/values.c b/libguile/values.c
index e766edba1..81fdcf851 100644
--- a/libguile/values.c
+++ b/libguile/values.c
@@ -1,18 +1,19 @@
/* Copyright (C) 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
diff --git a/libguile/values.h b/libguile/values.h
index f05ce9f8f..0750aecdc 100644
--- a/libguile/values.h
+++ b/libguile/values.h
@@ -6,18 +6,19 @@
/* Copyright (C) 2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/variable.c b/libguile/variable.c
index 6c39b30ac..a97444c0b 100644
--- a/libguile/variable.c
+++ b/libguile/variable.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/variable.h b/libguile/variable.h
index 3f6398b9c..8faced4ec 100644
--- a/libguile/variable.h
+++ b/libguile/variable.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/vectors.c b/libguile/vectors.c
index c01b3e3b6..255323f25 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -1,18 +1,19 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -30,6 +31,7 @@
#include "libguile/validate.h"
#include "libguile/vectors.h"
#include "libguile/unif.h"
+#include "libguile/bytevectors.h"
#include "libguile/ramap.h"
#include "libguile/srfi-4.h"
#include "libguile/strings.h"
@@ -606,7 +608,7 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0,
}
#undef FUNC_NAME
-
+
/* Generalized vectors. */
int
@@ -615,7 +617,8 @@ scm_is_generalized_vector (SCM obj)
return (scm_is_vector (obj)
|| scm_is_string (obj)
|| scm_is_bitvector (obj)
- || scm_is_uniform_vector (obj));
+ || scm_is_uniform_vector (obj)
+ || scm_is_bytevector (obj));
}
SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0,
@@ -647,6 +650,8 @@ scm_c_generalized_vector_length (SCM v)
return scm_c_bitvector_length (v);
else if (scm_is_uniform_vector (v))
return scm_c_uniform_vector_length (v);
+ else if (scm_is_bytevector (v))
+ return scm_c_bytevector_length (v);
else
scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
}
@@ -671,6 +676,8 @@ scm_c_generalized_vector_ref (SCM v, size_t idx)
return scm_c_bitvector_ref (v, idx);
else if (scm_is_uniform_vector (v))
return scm_c_uniform_vector_ref (v, idx);
+ else if (scm_is_bytevector (v))
+ return scm_from_uint8 (scm_c_bytevector_ref (v, idx));
else
scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
}
@@ -696,6 +703,8 @@ scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val)
scm_c_bitvector_set_x (v, idx, val);
else if (scm_is_uniform_vector (v))
scm_c_uniform_vector_set_x (v, idx, val);
+ else if (scm_is_bytevector (v))
+ scm_i_bytevector_generalized_set_x (v, idx, val);
else
scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
}
diff --git a/libguile/vectors.h b/libguile/vectors.h
index 7a508c77b..7af38d822 100644
--- a/libguile/vectors.h
+++ b/libguile/vectors.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1998,2000,2001,2002,2004,2005, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/version.c b/libguile/version.c
index 6a665c53d..db1bc9f2e 100644
--- a/libguile/version.c
+++ b/libguile/version.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996, 1999, 2000, 2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/version.h.in b/libguile/version.h.in
index b565efd96..394bbdb86 100644
--- a/libguile/version.h.in
+++ b/libguile/version.h.in
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/vm-bootstrap.h b/libguile/vm-bootstrap.h
index beecf0fc2..7ba1a93ba 100644
--- a/libguile/vm-bootstrap.h
+++ b/libguile/vm-bootstrap.h
@@ -1,48 +1,25 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
#ifndef _SCM_VM_BOOTSTRAP_H_
#define _SCM_VM_BOOTSTRAP_H_
-extern void scm_bootstrap_vm (void);
+SCM_INTERNAL void scm_bootstrap_vm (void);
#endif /* _SCM_VM_BOOTSTRAP_H_ */
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 58ed43db6..b0888c1ec 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -1,57 +1,34 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
/* This file is included in vm.c multiple times */
#if (VM_ENGINE == SCM_VM_REGULAR_ENGINE)
#define VM_USE_HOOKS 0 /* Various hooks */
#define VM_USE_CLOCK 0 /* Bogoclock */
-#define VM_CHECK_EXTERNAL 1 /* Check external link */
#define VM_CHECK_OBJECT 1 /* Check object table */
+#define VM_CHECK_FREE_VARIABLES 1 /* Check free variable access */
#define VM_PUSH_DEBUG_FRAMES 0 /* Push frames onto the evaluator debug stack */
#elif (VM_ENGINE == SCM_VM_DEBUG_ENGINE)
#define VM_USE_HOOKS 1
#define VM_USE_CLOCK 1
-#define VM_CHECK_EXTERNAL 1
#define VM_CHECK_OBJECT 1
+#define VM_CHECK_FREE_VARIABLES 1
#define VM_PUSH_DEBUG_FRAMES 1
#else
#error unknown debug engine VM_ENGINE
@@ -70,7 +47,8 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
/* Cache variables */
struct scm_objcode *bp = NULL; /* program base pointer */
- SCM external = SCM_EOL; /* external environment */
+ SCM *free_vars = NULL; /* free variables */
+ size_t free_vars_count = 0; /* length of FREE_VARS */
SCM *objects = NULL; /* constant objects */
size_t object_count = 0; /* length of OBJECTS */
SCM *stack_base = vp->stack_base; /* stack base address */
@@ -175,7 +153,7 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
vm_error_bad_instruction:
err_msg = scm_from_locale_string ("VM: Bad instruction: ~A");
- finish_args = SCM_LIST1 (scm_from_uchar (ip[-1]));
+ finish_args = scm_list_1 (scm_from_uchar (ip[-1]));
goto vm_error;
vm_error_unbound:
@@ -189,7 +167,7 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
vm_error_too_many_args:
err_msg = scm_from_locale_string ("VM: Too many arguments");
- finish_args = SCM_LIST1 (scm_from_int (nargs));
+ finish_args = scm_list_1 (scm_from_int (nargs));
goto vm_error;
vm_error_wrong_num_args:
@@ -202,8 +180,8 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
vm_error_wrong_type_apply:
err_msg = scm_from_locale_string ("VM: Wrong type to apply: ~S "
"[IP offset: ~a]");
- finish_args = SCM_LIST2 (program,
- SCM_I_MAKINUM (ip - bp->base));
+ finish_args = scm_list_2 (program,
+ SCM_I_MAKINUM (ip - bp->base));
goto vm_error;
vm_error_stack_overflow:
@@ -226,6 +204,12 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
/* shouldn't get here */
goto vm_error;
+ vm_error_not_a_bytevector:
+ SYNC_ALL ();
+ scm_wrong_type_arg_msg (FUNC_NAME, 1, finish_args, "bytevector");
+ /* shouldn't get here */
+ goto vm_error;
+
vm_error_no_values:
err_msg = scm_from_locale_string ("VM: 0-valued return");
finish_args = SCM_EOL;
@@ -236,8 +220,8 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
finish_args = SCM_EOL;
goto vm_error;
- vm_error_no_such_module:
- err_msg = scm_from_locale_string ("VM: No such module: ~A");
+ vm_error_bad_wide_string_length:
+ err_msg = scm_from_locale_string ("VM: Bad wide string length: ~S");
goto vm_error;
#if VM_CHECK_IP
@@ -247,16 +231,16 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
goto vm_error;
#endif
-#if VM_CHECK_EXTERNAL
- vm_error_external:
- err_msg = scm_from_locale_string ("VM: Invalid external access");
+#if VM_CHECK_OBJECT
+ vm_error_object:
+ err_msg = scm_from_locale_string ("VM: Invalid object table access");
finish_args = SCM_EOL;
goto vm_error;
#endif
-#if VM_CHECK_OBJECT
- vm_error_object:
- err_msg = scm_from_locale_string ("VM: Invalid object table access");
+#if VM_CHECK_FREE_VARIABLES
+ vm_error_free_variable:
+ err_msg = scm_from_locale_string ("VM: Invalid free variable access");
finish_args = SCM_EOL;
goto vm_error;
#endif
@@ -264,7 +248,8 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
vm_error:
SYNC_ALL ();
- scm_ithrow (sym_vm_error, SCM_LIST3 (sym_vm_run, err_msg, finish_args), 1);
+ scm_ithrow (sym_vm_error, scm_list_3 (sym_vm_run, err_msg, finish_args),
+ 1);
}
abort (); /* never reached */
@@ -272,8 +257,8 @@ VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs)
#undef VM_USE_HOOKS
#undef VM_USE_CLOCK
-#undef VM_CHECK_EXTERNAL
#undef VM_CHECK_OBJECT
+#undef VM_CHECK_FREE_VARIABLE
#undef VM_PUSH_DEBUG_FRAMES
/*
diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h
index 6bb235401..240969c37 100644
--- a/libguile/vm-engine.h
+++ b/libguile/vm-engine.h
@@ -1,43 +1,20 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
/* This file is included in vm_engine.c */
@@ -77,13 +54,9 @@
#endif
#endif
#ifdef __i386__
-/* gcc on lenny actually crashes if we allocate these variables in registers.
- hopefully this is the only one of these. */
-#if !(__GNUC__==4 && __GNUC_MINOR__==1 && __GNUC_PATCHLEVEL__==2)
-#define IP_REG asm("%esi")
-#define SP_REG asm("%edi")
-#define FP_REG
-#endif
+/* too few registers! because of register allocation errors with various gcs,
+ just punt on explicit assignments on i386, hoping that the "register"
+ declaration will be sufficient. */
#endif
#if defined(PPC) || defined(_POWER) || defined(_IBMR2)
#define IP_REG asm("26")
@@ -144,22 +117,36 @@
vp->fp = fp; \
}
+/* FIXME */
+#define ASSERT_VARIABLE(x) \
+ do { if (!SCM_VARIABLEP (x)) { SYNC_REGISTER (); abort(); } \
+ } while (0)
+#define ASSERT_BOUND_VARIABLE(x) \
+ do { ASSERT_VARIABLE (x); \
+ if (SCM_VARIABLE_REF (x) == SCM_UNDEFINED) \
+ { SYNC_REGISTER (); abort(); } \
+ } while (0)
+
#ifdef VM_ENABLE_PARANOID_ASSERTIONS
#define CHECK_IP() \
do { if (ip < bp->base || ip - bp->base > bp->len) abort (); } while (0)
+#define ASSERT_ALIGNED_PROCEDURE() \
+ do { if ((scm_t_bits)bp % 8) abort (); } while (0)
+#define ASSERT_BOUND(x) \
+ do { if ((x) == SCM_UNDEFINED) { SYNC_REGISTER (); abort(); } \
+ } while (0)
#else
#define CHECK_IP()
+#define ASSERT_ALIGNED_PROCEDURE()
+#define ASSERT_BOUND(x)
#endif
-/* Get a local copy of the program's "object table" (i.e. the vector of
- external bindings that are referenced by the program), initialized by
- `load-program'. */
-/* XXX: We could instead use the "simple vector macros", thus not having to
- call `scm_vector_writable_elements ()' and the likes. */
+/* Cache the object table and free variables. */
#define CACHE_PROGRAM() \
{ \
if (bp != SCM_PROGRAM_DATA (program)) { \
bp = SCM_PROGRAM_DATA (program); \
+ ASSERT_ALIGNED_PROCEDURE (); \
if (SCM_I_IS_VECTOR (SCM_PROGRAM_OBJTABLE (program))) { \
objects = SCM_I_VECTOR_WELTS (SCM_PROGRAM_OBJTABLE (program)); \
object_count = SCM_I_VECTOR_LENGTH (SCM_PROGRAM_OBJTABLE (program)); \
@@ -168,6 +155,19 @@
object_count = 0; \
} \
} \
+ { \
+ SCM c = SCM_PROGRAM_FREE_VARIABLES (program); \
+ if (SCM_I_IS_VECTOR (c)) \
+ { \
+ free_vars = SCM_I_VECTOR_WELTS (c); \
+ free_vars_count = SCM_I_VECTOR_LENGTH (c); \
+ } \
+ else \
+ { \
+ free_vars = NULL; \
+ free_vars_count = 0; \
+ } \
+ } \
}
#define SYNC_BEFORE_GC() \
@@ -185,14 +185,6 @@
* Error check
*/
-#undef CHECK_EXTERNAL
-#if VM_CHECK_EXTERNAL
-#define CHECK_EXTERNAL(e) \
- do { if (SCM_UNLIKELY (!SCM_CONSP (e))) goto vm_error_external; } while (0)
-#else
-#define CHECK_EXTERNAL(e)
-#endif
-
/* Accesses to a program's object table. */
#if VM_CHECK_OBJECT
#define CHECK_OBJECT(_num) \
@@ -201,6 +193,13 @@
#define CHECK_OBJECT(_num)
#endif
+#if VM_CHECK_FREE_VARIABLES
+#define CHECK_FREE_VARIABLE(_num) \
+ do { if (SCM_UNLIKELY ((_num) >= free_vars_count)) goto vm_error_free_variable; } while (0)
+#else
+#define CHECK_FREE_VARIABLE(_num)
+#endif
+
/*
* Hooks
@@ -337,6 +336,7 @@ do { \
#define FETCH() (*ip++)
#define FETCH_LENGTH(len) do { len=*ip++; len<<=8; len+=*ip++; len<<=8; len+=*ip++; } while (0)
+#define FETCH_WIDTH(width) do { width=*ip++; } while (0)
#undef CLOCK
#if VM_USE_CLOCK
@@ -399,7 +399,7 @@ do { \
/* New registers */ \
fp = sp - bp->nargs + 1; \
data = SCM_FRAME_DATA_ADDRESS (fp); \
- sp = data + 3; \
+ sp = data + 2; \
CHECK_OVERFLOW (); \
stack_base = sp; \
ip = bp->base; \
@@ -409,23 +409,11 @@ do { \
data[-i] = SCM_UNDEFINED; \
\
/* Set frame data */ \
- data[3] = (SCM)ra; \
- data[2] = 0x0; \
- data[1] = (SCM)dl; \
- \
- /* Postpone initializing external vars, \
- because if the CONS causes a GC, we \
- want the stack marker to see the data \
- array formatted as expected. */ \
- data[0] = SCM_UNDEFINED; \
- external = SCM_PROGRAM_EXTERNALS (fp[-1]); \
- for (i = 0; i < bp->nexts; i++) \
- CONS (external, SCM_UNDEFINED, external); \
- data[0] = external; \
+ data[2] = (SCM)ra; \
+ data[1] = 0x0; \
+ data[0] = (SCM)dl; \
}
-#define CACHE_EXTERNAL() external = fp[bp->nargs + bp->nlocs]
-
/*
Local Variables:
c-file-style: "gnu"
diff --git a/libguile/vm-expand.h b/libguile/vm-expand.h
index 7ad2b9da8..787223d07 100644
--- a/libguile/vm-expand.h
+++ b/libguile/vm-expand.h
@@ -1,43 +1,20 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
#ifndef VM_LABEL
#define VM_LABEL(tag) l_##tag
diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c
index bba4f4b9c..e242ef9bf 100644
--- a/libguile/vm-i-loader.c
+++ b/libguile/vm-i-loader.c
@@ -1,60 +1,26 @@
/* Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
+/* FIXME! Need to check that the fetch is within the current program */
/* This file is included in vm_engine.c */
-VM_DEFINE_LOADER (59, load_unsigned_integer, "load-unsigned-integer")
-{
- size_t len;
-
- FETCH_LENGTH (len);
- if (SCM_LIKELY (len <= 4))
- {
- unsigned int val = 0;
- while (len-- > 0)
- val = (val << 8U) + FETCH ();
- SYNC_REGISTER ();
- PUSH (scm_from_uint (val));
- NEXT;
- }
- else
- SCM_MISC_ERROR ("load-unsigned-integer: not implemented yet", SCM_EOL);
-}
-
-VM_DEFINE_LOADER (60, load_integer, "load-integer")
-{
- size_t len;
-
- FETCH_LENGTH (len);
- if (SCM_LIKELY (len <= 4))
- {
- int val = 0;
- while (len-- > 0)
- val = (val << 8) + FETCH ();
- SYNC_REGISTER ();
- PUSH (scm_from_int (val));
- NEXT;
- }
- else
- SCM_MISC_ERROR ("load-integer: not implemented yet", SCM_EOL);
-}
-
-VM_DEFINE_LOADER (61, load_number, "load-number")
+VM_DEFINE_LOADER (82, load_number, "load-number")
{
size_t len;
@@ -67,38 +33,31 @@ VM_DEFINE_LOADER (61, load_number, "load-number")
NEXT;
}
-VM_DEFINE_LOADER (62, load_string, "load-string")
+VM_DEFINE_LOADER (83, load_string, "load-string")
{
size_t len;
- FETCH_LENGTH (len);
- SYNC_REGISTER ();
- PUSH (scm_from_locale_stringn ((char *)ip, len));
- /* Was: scm_makfromstr (ip, len, 0) */
- ip += len;
- NEXT;
-}
+ char *buf;
-VM_DEFINE_LOADER (63, load_symbol, "load-symbol")
-{
- size_t len;
FETCH_LENGTH (len);
SYNC_REGISTER ();
- PUSH (scm_from_locale_symboln ((char *)ip, len));
+ PUSH (scm_i_make_string (len, &buf));
+ memcpy (buf, (char *) ip, len);
ip += len;
NEXT;
}
-VM_DEFINE_LOADER (64, load_keyword, "load-keyword")
+VM_DEFINE_LOADER (84, load_symbol, "load-symbol")
{
size_t len;
FETCH_LENGTH (len);
SYNC_REGISTER ();
- PUSH (scm_from_locale_keywordn ((char *)ip, len));
+ /* FIXME: should be scm_from_latin1_symboln */
+ PUSH (scm_from_locale_symboln ((const char*)ip, len));
ip += len;
NEXT;
}
-VM_DEFINE_LOADER (65, load_program, "load-program")
+VM_DEFINE_LOADER (86, load_program, "load-program")
{
scm_t_uint32 len;
SCM objs, objcode;
@@ -112,56 +71,50 @@ VM_DEFINE_LOADER (65, load_program, "load-program")
objcode = scm_c_make_objcode_slice (SCM_PROGRAM_OBJCODE (fp[-1]), ip);
len = sizeof (struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
- PUSH (scm_make_program (objcode, objs, SCM_EOL));
+ PUSH (scm_make_program (objcode, objs, SCM_BOOL_F));
ip += len;
NEXT;
}
-VM_DEFINE_INSTRUCTION (66, link_now, "link-now", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (87, link_now, "link-now", 0, 1, 1)
{
SCM what;
POP (what);
SYNC_REGISTER ();
- if (SCM_LIKELY (SCM_SYMBOLP (what)))
- {
- PUSH (scm_lookup (what)); /* might longjmp */
- }
- else
- {
- SCM mod;
- /* compilation of @ or @@
- `what' is a three-element list: (MODNAME SYM INTERFACE?)
- INTERFACE? is #t if we compiled @ or #f if we compiled @@
- */
- mod = scm_resolve_module (SCM_CAR (what));
- if (scm_is_true (SCM_CADDR (what)))
- mod = scm_module_public_interface (mod);
- if (SCM_FALSEP (mod))
- {
- finish_args = SCM_LIST1 (SCM_CAR (what));
- goto vm_error_no_such_module;
- }
- /* might longjmp */
- PUSH (scm_module_lookup (mod, SCM_CADR (what)));
- }
-
+ PUSH (resolve_variable (what, scm_current_module ()));
NEXT;
}
-VM_DEFINE_LOADER (67, define, "define")
+VM_DEFINE_LOADER (89, load_array, "load-array")
{
- SCM sym;
+ SCM type, shape;
size_t len;
-
FETCH_LENGTH (len);
+ POP (shape);
+ POP (type);
SYNC_REGISTER ();
- sym = scm_from_locale_symboln ((char *)ip, len);
+ PUSH (scm_from_contiguous_typed_array (type, shape, ip, len));
ip += len;
+ NEXT;
+}
+
+VM_DEFINE_LOADER (90, load_wide_string, "load-wide-string")
+{
+ size_t len;
+ scm_t_wchar *wbuf;
+
+ FETCH_LENGTH (len);
+ if (SCM_UNLIKELY (len % 4))
+ { finish_args = scm_list_1 (scm_from_size_t (len));
+ goto vm_error_bad_wide_string_length;
+ }
SYNC_REGISTER ();
- PUSH (scm_sym2var (sym, scm_current_module_lookup_closure (), SCM_BOOL_T));
+ PUSH (scm_i_make_wide_string (len / 4, &wbuf));
+ memcpy ((char *) wbuf, (char *) ip, len);
+ ip += len;
NEXT;
}
@@ -170,7 +123,7 @@ VM_DEFINE_LOADER (67, define, "define")
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
(interactive "")
(save-excursion
- (let ((counter 59)) (goto-char (point-min))
+ (let ((counter 79)) (goto-char (point-min))
(while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
(replace-match
(number-to-string (setq counter (1+ counter)))
diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c
index 4af60265e..0cace147d 100644
--- a/libguile/vm-i-scheme.c
+++ b/libguile/vm-i-scheme.c
@@ -1,43 +1,20 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
/* This file is included in vm_engine.c */
@@ -52,43 +29,43 @@
#define RETURN(x) do { *sp = x; NEXT; } while (0)
-VM_DEFINE_FUNCTION (80, not, "not", 1)
+VM_DEFINE_FUNCTION (100, not, "not", 1)
{
ARGS1 (x);
RETURN (SCM_BOOL (SCM_FALSEP (x)));
}
-VM_DEFINE_FUNCTION (81, not_not, "not-not", 1)
+VM_DEFINE_FUNCTION (101, not_not, "not-not", 1)
{
ARGS1 (x);
RETURN (SCM_BOOL (!SCM_FALSEP (x)));
}
-VM_DEFINE_FUNCTION (82, eq, "eq?", 2)
+VM_DEFINE_FUNCTION (102, eq, "eq?", 2)
{
ARGS2 (x, y);
RETURN (SCM_BOOL (SCM_EQ_P (x, y)));
}
-VM_DEFINE_FUNCTION (83, not_eq, "not-eq?", 2)
+VM_DEFINE_FUNCTION (103, not_eq, "not-eq?", 2)
{
ARGS2 (x, y);
RETURN (SCM_BOOL (!SCM_EQ_P (x, y)));
}
-VM_DEFINE_FUNCTION (84, nullp, "null?", 1)
+VM_DEFINE_FUNCTION (104, nullp, "null?", 1)
{
ARGS1 (x);
RETURN (SCM_BOOL (SCM_NULLP (x)));
}
-VM_DEFINE_FUNCTION (85, not_nullp, "not-null?", 1)
+VM_DEFINE_FUNCTION (105, not_nullp, "not-null?", 1)
{
ARGS1 (x);
RETURN (SCM_BOOL (!SCM_NULLP (x)));
}
-VM_DEFINE_FUNCTION (86, eqv, "eqv?", 2)
+VM_DEFINE_FUNCTION (106, eqv, "eqv?", 2)
{
ARGS2 (x, y);
if (SCM_EQ_P (x, y))
@@ -99,7 +76,7 @@ VM_DEFINE_FUNCTION (86, eqv, "eqv?", 2)
RETURN (scm_eqv_p (x, y));
}
-VM_DEFINE_FUNCTION (87, equal, "equal?", 2)
+VM_DEFINE_FUNCTION (107, equal, "equal?", 2)
{
ARGS2 (x, y);
if (SCM_EQ_P (x, y))
@@ -110,13 +87,13 @@ VM_DEFINE_FUNCTION (87, equal, "equal?", 2)
RETURN (scm_equal_p (x, y));
}
-VM_DEFINE_FUNCTION (88, pairp, "pair?", 1)
+VM_DEFINE_FUNCTION (108, pairp, "pair?", 1)
{
ARGS1 (x);
RETURN (SCM_BOOL (SCM_CONSP (x)));
}
-VM_DEFINE_FUNCTION (89, listp, "list?", 1)
+VM_DEFINE_FUNCTION (109, listp, "list?", 1)
{
ARGS1 (x);
RETURN (SCM_BOOL (scm_ilength (x) >= 0));
@@ -127,7 +104,7 @@ VM_DEFINE_FUNCTION (89, listp, "list?", 1)
* Basic data
*/
-VM_DEFINE_FUNCTION (90, cons, "cons", 2)
+VM_DEFINE_FUNCTION (110, cons, "cons", 2)
{
ARGS2 (x, y);
CONS (x, x, y);
@@ -140,34 +117,38 @@ VM_DEFINE_FUNCTION (90, cons, "cons", 2)
goto vm_error_not_a_pair; \
}
-VM_DEFINE_FUNCTION (91, car, "car", 1)
+VM_DEFINE_FUNCTION (111, car, "car", 1)
{
ARGS1 (x);
VM_VALIDATE_CONS (x);
RETURN (SCM_CAR (x));
}
-VM_DEFINE_FUNCTION (92, cdr, "cdr", 1)
+VM_DEFINE_FUNCTION (112, cdr, "cdr", 1)
{
ARGS1 (x);
VM_VALIDATE_CONS (x);
RETURN (SCM_CDR (x));
}
-VM_DEFINE_FUNCTION (93, set_car, "set-car!", 2)
+VM_DEFINE_INSTRUCTION (113, set_car, "set-car!", 0, 2, 0)
{
- ARGS2 (x, y);
+ SCM x, y;
+ POP (y);
+ POP (x);
VM_VALIDATE_CONS (x);
SCM_SETCAR (x, y);
- RETURN (SCM_UNSPECIFIED);
+ NEXT;
}
-VM_DEFINE_FUNCTION (94, set_cdr, "set-cdr!", 2)
+VM_DEFINE_INSTRUCTION (114, set_cdr, "set-cdr!", 0, 2, 0)
{
- ARGS2 (x, y);
+ SCM x, y;
+ POP (y);
+ POP (x);
VM_VALIDATE_CONS (x);
SCM_SETCDR (x, y);
- RETURN (SCM_UNSPECIFIED);
+ NEXT;
}
@@ -185,27 +166,27 @@ VM_DEFINE_FUNCTION (94, set_cdr, "set-cdr!", 2)
RETURN (srel (x, y)); \
}
-VM_DEFINE_FUNCTION (95, ee, "ee?", 2)
+VM_DEFINE_FUNCTION (115, ee, "ee?", 2)
{
REL (==, scm_num_eq_p);
}
-VM_DEFINE_FUNCTION (96, lt, "lt?", 2)
+VM_DEFINE_FUNCTION (116, lt, "lt?", 2)
{
REL (<, scm_less_p);
}
-VM_DEFINE_FUNCTION (97, le, "le?", 2)
+VM_DEFINE_FUNCTION (117, le, "le?", 2)
{
REL (<=, scm_leq_p);
}
-VM_DEFINE_FUNCTION (98, gt, "gt?", 2)
+VM_DEFINE_FUNCTION (118, gt, "gt?", 2)
{
REL (>, scm_gr_p);
}
-VM_DEFINE_FUNCTION (99, ge, "ge?", 2)
+VM_DEFINE_FUNCTION (119, ge, "ge?", 2)
{
REL (>=, scm_geq_p);
}
@@ -221,7 +202,7 @@ VM_DEFINE_FUNCTION (99, ge, "ge?", 2)
ARGS2 (x, y); \
if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \
{ \
- scm_t_bits n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);\
+ scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);\
if (SCM_FIXABLE (n)) \
RETURN (SCM_I_MAKINUM (n)); \
} \
@@ -229,45 +210,71 @@ VM_DEFINE_FUNCTION (99, ge, "ge?", 2)
RETURN (SFUNC (x, y)); \
}
-VM_DEFINE_FUNCTION (100, add, "add", 2)
+VM_DEFINE_FUNCTION (120, add, "add", 2)
{
FUNC2 (+, scm_sum);
}
-VM_DEFINE_FUNCTION (101, sub, "sub", 2)
+VM_DEFINE_FUNCTION (167, add1, "add1", 1)
+{
+ ARGS1 (x);
+ if (SCM_I_INUMP (x))
+ {
+ scm_t_int64 n = SCM_I_INUM (x) + 1;
+ if (SCM_FIXABLE (n))
+ RETURN (SCM_I_MAKINUM (n));
+ }
+ SYNC_REGISTER ();
+ RETURN (scm_sum (x, SCM_I_MAKINUM (1)));
+}
+
+VM_DEFINE_FUNCTION (121, sub, "sub", 2)
{
FUNC2 (-, scm_difference);
}
-VM_DEFINE_FUNCTION (102, mul, "mul", 2)
+VM_DEFINE_FUNCTION (168, sub1, "sub1", 1)
+{
+ ARGS1 (x);
+ if (SCM_I_INUMP (x))
+ {
+ scm_t_int64 n = SCM_I_INUM (x) - 1;
+ if (SCM_FIXABLE (n))
+ RETURN (SCM_I_MAKINUM (n));
+ }
+ SYNC_REGISTER ();
+ RETURN (scm_difference (x, SCM_I_MAKINUM (1)));
+}
+
+VM_DEFINE_FUNCTION (122, mul, "mul", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_product (x, y));
}
-VM_DEFINE_FUNCTION (103, div, "div", 2)
+VM_DEFINE_FUNCTION (123, div, "div", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_divide (x, y));
}
-VM_DEFINE_FUNCTION (104, quo, "quo", 2)
+VM_DEFINE_FUNCTION (124, quo, "quo", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_quotient (x, y));
}
-VM_DEFINE_FUNCTION (105, rem, "rem", 2)
+VM_DEFINE_FUNCTION (125, rem, "rem", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
RETURN (scm_remainder (x, y));
}
-VM_DEFINE_FUNCTION (106, mod, "mod", 2)
+VM_DEFINE_FUNCTION (126, mod, "mod", 2)
{
ARGS2 (x, y);
SYNC_REGISTER ();
@@ -278,7 +285,7 @@ VM_DEFINE_FUNCTION (106, mod, "mod", 2)
/*
* GOOPS support
*/
-VM_DEFINE_FUNCTION (107, slot_ref, "slot-ref", 2)
+VM_DEFINE_FUNCTION (127, slot_ref, "slot-ref", 2)
{
size_t slot;
ARGS2 (instance, idx);
@@ -286,21 +293,277 @@ VM_DEFINE_FUNCTION (107, slot_ref, "slot-ref", 2)
RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot]));
}
-VM_DEFINE_FUNCTION (108, slot_set, "slot-set", 3)
+VM_DEFINE_INSTRUCTION (128, slot_set, "slot-set", 0, 3, 0)
{
+ SCM instance, idx, val;
size_t slot;
- ARGS3 (instance, idx, val);
+ POP (val);
+ POP (idx);
+ POP (instance);
slot = SCM_I_INUM (idx);
SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val);
- RETURN (SCM_UNSPECIFIED);
+ NEXT;
+}
+
+VM_DEFINE_FUNCTION (129, vector_ref, "vector-ref", 2)
+{
+ long i = 0;
+ ARGS2 (vect, idx);
+ if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)
+ && SCM_I_INUMP (idx)
+ && ((i = SCM_I_INUM (idx)) >= 0)
+ && i < SCM_I_VECTOR_LENGTH (vect)))
+ RETURN (SCM_I_VECTOR_ELTS (vect)[i]);
+ else
+ {
+ SYNC_REGISTER ();
+ RETURN (scm_vector_ref (vect, idx));
+ }
}
+VM_DEFINE_INSTRUCTION (130, vector_set, "vector-set", 0, 3, 0)
+{
+ long i = 0;
+ SCM vect, idx, val;
+ POP (val); POP (idx); POP (vect);
+ if (SCM_LIKELY (SCM_I_IS_VECTOR (vect)
+ && SCM_I_INUMP (idx)
+ && ((i = SCM_I_INUM (idx)) >= 0)
+ && i < SCM_I_VECTOR_LENGTH (vect)))
+ SCM_I_VECTOR_WELTS (vect)[i] = val;
+ else
+ {
+ SYNC_REGISTER ();
+ scm_vector_set_x (vect, idx, val);
+ }
+ NEXT;
+}
+
+#define VM_VALIDATE_BYTEVECTOR(x) \
+ if (SCM_UNLIKELY (!SCM_BYTEVECTOR_P (x))) \
+ { finish_args = x; \
+ goto vm_error_not_a_bytevector; \
+ }
+
+#define BV_REF_WITH_ENDIANNESS(stem, fn_stem) \
+{ \
+ SCM endianness; \
+ POP (endianness); \
+ if (scm_is_eq (endianness, scm_i_native_endianness)) \
+ goto VM_LABEL (bv_##stem##_native_ref); \
+ { \
+ ARGS2 (bv, idx); \
+ RETURN (scm_bytevector_##fn_stem##_ref (bv, idx, endianness)); \
+ } \
+}
+
+VM_DEFINE_FUNCTION (131, bv_u16_ref, "bv-u16-ref", 3)
+BV_REF_WITH_ENDIANNESS (u16, u16)
+VM_DEFINE_FUNCTION (132, bv_s16_ref, "bv-s16-ref", 3)
+BV_REF_WITH_ENDIANNESS (s16, s16)
+VM_DEFINE_FUNCTION (133, bv_u32_ref, "bv-u32-ref", 3)
+BV_REF_WITH_ENDIANNESS (u32, u32)
+VM_DEFINE_FUNCTION (134, bv_s32_ref, "bv-s32-ref", 3)
+BV_REF_WITH_ENDIANNESS (s32, s32)
+VM_DEFINE_FUNCTION (135, bv_u64_ref, "bv-u64-ref", 3)
+BV_REF_WITH_ENDIANNESS (u64, u64)
+VM_DEFINE_FUNCTION (136, bv_s64_ref, "bv-s64-ref", 3)
+BV_REF_WITH_ENDIANNESS (s64, s64)
+VM_DEFINE_FUNCTION (137, bv_f32_ref, "bv-f32-ref", 3)
+BV_REF_WITH_ENDIANNESS (f32, ieee_single)
+VM_DEFINE_FUNCTION (138, bv_f64_ref, "bv-f64-ref", 3)
+BV_REF_WITH_ENDIANNESS (f64, ieee_double)
+
+#undef BV_REF_WITH_ENDIANNESS
+
+#define BV_FIXABLE_INT_REF(stem, fn_stem, type, size) \
+{ \
+ long i = 0; \
+ ARGS2 (bv, idx); \
+ VM_VALIDATE_BYTEVECTOR (bv); \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && ((i = SCM_I_INUM (idx)) >= 0) \
+ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (i % size == 0))) \
+ RETURN (SCM_I_MAKINUM (*(scm_t_##type*) \
+ (SCM_BYTEVECTOR_CONTENTS (bv) + i))); \
+ else \
+ RETURN (scm_bytevector_##fn_stem##_ref (bv, idx)); \
+}
+
+#define BV_INT_REF(stem, type, size) \
+{ \
+ long i = 0; \
+ ARGS2 (bv, idx); \
+ VM_VALIDATE_BYTEVECTOR (bv); \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && ((i = SCM_I_INUM (idx)) >= 0) \
+ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (i % size == 0))) \
+ { scm_t_##type x = (*(scm_t_##type*)(SCM_BYTEVECTOR_CONTENTS (bv) + i)); \
+ if (SCM_FIXABLE (x)) \
+ RETURN (SCM_I_MAKINUM (x)); \
+ else \
+ RETURN (scm_from_##type (x)); \
+ } \
+ else \
+ RETURN (scm_bytevector_##stem##_native_ref (bv, idx)); \
+}
+
+#define BV_FLOAT_REF(stem, fn_stem, type, size) \
+{ \
+ long i = 0; \
+ ARGS2 (bv, idx); \
+ VM_VALIDATE_BYTEVECTOR (bv); \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && ((i = SCM_I_INUM (idx)) >= 0) \
+ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (i % size == 0))) \
+ RETURN (scm_from_double ((*(type*)(SCM_BYTEVECTOR_CONTENTS (bv) + i)))); \
+ else \
+ RETURN (scm_bytevector_##fn_stem##_native_ref (bv, idx)); \
+}
+
+VM_DEFINE_FUNCTION (139, bv_u8_ref, "bv-u8-ref", 2)
+BV_FIXABLE_INT_REF (u8, u8, uint8, 1)
+VM_DEFINE_FUNCTION (140, bv_s8_ref, "bv-s8-ref", 2)
+BV_FIXABLE_INT_REF (s8, s8, int8, 1)
+VM_DEFINE_FUNCTION (141, bv_u16_native_ref, "bv-u16-native-ref", 2)
+BV_FIXABLE_INT_REF (u16, u16_native, uint16, 2)
+VM_DEFINE_FUNCTION (142, bv_s16_native_ref, "bv-s16-native-ref", 2)
+BV_FIXABLE_INT_REF (s16, s16_native, int16, 2)
+VM_DEFINE_FUNCTION (143, bv_u32_native_ref, "bv-u32-native-ref", 2)
+/* FIXME: u32 is always a fixnum on 64-bit builds */
+BV_INT_REF (u32, uint32, 4)
+VM_DEFINE_FUNCTION (144, bv_s32_native_ref, "bv-s32-native-ref", 2)
+BV_INT_REF (s32, int32, 4)
+VM_DEFINE_FUNCTION (145, bv_u64_native_ref, "bv-u64-native-ref", 2)
+BV_INT_REF (u64, uint64, 8)
+VM_DEFINE_FUNCTION (146, bv_s64_native_ref, "bv-s64-native-ref", 2)
+BV_INT_REF (s64, int64, 8)
+VM_DEFINE_FUNCTION (147, bv_f32_native_ref, "bv-f32-native-ref", 2)
+BV_FLOAT_REF (f32, ieee_single, float, 4)
+VM_DEFINE_FUNCTION (148, bv_f64_native_ref, "bv-f64-native-ref", 2)
+BV_FLOAT_REF (f64, ieee_double, double, 8)
+
+#undef BV_FIXABLE_INT_REF
+#undef BV_INT_REF
+#undef BV_FLOAT_REF
+
+
+
+#define BV_SET_WITH_ENDIANNESS(stem, fn_stem) \
+{ \
+ SCM endianness; \
+ POP (endianness); \
+ if (scm_is_eq (endianness, scm_i_native_endianness)) \
+ goto VM_LABEL (bv_##stem##_native_set); \
+ { \
+ SCM bv, idx, val; POP (val); POP (idx); POP (bv); \
+ scm_bytevector_##fn_stem##_set_x (bv, idx, val, endianness); \
+ NEXT; \
+ } \
+}
+
+VM_DEFINE_INSTRUCTION (149, bv_u16_set, "bv-u16-set", 0, 4, 0)
+BV_SET_WITH_ENDIANNESS (u16, u16)
+VM_DEFINE_INSTRUCTION (150, bv_s16_set, "bv-s16-set", 0, 4, 0)
+BV_SET_WITH_ENDIANNESS (s16, s16)
+VM_DEFINE_INSTRUCTION (151, bv_u32_set, "bv-u32-set", 0, 4, 0)
+BV_SET_WITH_ENDIANNESS (u32, u32)
+VM_DEFINE_INSTRUCTION (152, bv_s32_set, "bv-s32-set", 0, 4, 0)
+BV_SET_WITH_ENDIANNESS (s32, s32)
+VM_DEFINE_INSTRUCTION (153, bv_u64_set, "bv-u64-set", 0, 4, 0)
+BV_SET_WITH_ENDIANNESS (u64, u64)
+VM_DEFINE_INSTRUCTION (154, bv_s64_set, "bv-s64-set", 0, 4, 0)
+BV_SET_WITH_ENDIANNESS (s64, s64)
+VM_DEFINE_INSTRUCTION (155, bv_f32_set, "bv-f32-set", 0, 4, 0)
+BV_SET_WITH_ENDIANNESS (f32, ieee_single)
+VM_DEFINE_INSTRUCTION (156, bv_f64_set, "bv-f64-set", 0, 4, 0)
+BV_SET_WITH_ENDIANNESS (f64, ieee_double)
+
+#undef BV_SET_WITH_ENDIANNESS
+
+#define BV_FIXABLE_INT_SET(stem, fn_stem, type, min, max, size) \
+{ \
+ long i = 0, j = 0; \
+ SCM bv, idx, val; POP (val); POP (idx); POP (bv); \
+ VM_VALIDATE_BYTEVECTOR (bv); \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && ((i = SCM_I_INUM (idx)) >= 0) \
+ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (i % size == 0) \
+ && (SCM_I_INUMP (val)) \
+ && ((j = SCM_I_INUM (val)) >= min) \
+ && (j <= max))) \
+ *(scm_t_##type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = (scm_t_##type)j; \
+ else \
+ scm_bytevector_##fn_stem##_set_x (bv, idx, val); \
+ NEXT; \
+}
+
+#define BV_INT_SET(stem, type, size) \
+{ \
+ long i = 0; \
+ SCM bv, idx, val; POP (val); POP (idx); POP (bv); \
+ VM_VALIDATE_BYTEVECTOR (bv); \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && ((i = SCM_I_INUM (idx)) >= 0) \
+ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (i % size == 0))) \
+ *(scm_t_##type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = scm_to_##type (val); \
+ else \
+ scm_bytevector_##stem##_native_set_x (bv, idx, val); \
+ NEXT; \
+}
+
+#define BV_FLOAT_SET(stem, fn_stem, type, size) \
+{ \
+ long i = 0; \
+ SCM bv, idx, val; POP (val); POP (idx); POP (bv); \
+ VM_VALIDATE_BYTEVECTOR (bv); \
+ if (SCM_LIKELY (SCM_I_INUMP (idx) \
+ && ((i = SCM_I_INUM (idx)) >= 0) \
+ && (i + size <= SCM_BYTEVECTOR_LENGTH (bv)) \
+ && (i % size == 0))) \
+ *(type*) (SCM_BYTEVECTOR_CONTENTS (bv) + i) = scm_to_double (val); \
+ else \
+ scm_bytevector_##fn_stem##_native_set_x (bv, idx, val); \
+ NEXT; \
+}
+
+VM_DEFINE_INSTRUCTION (157, bv_u8_set, "bv-u8-set", 0, 3, 0)
+BV_FIXABLE_INT_SET (u8, u8, uint8, 0, SCM_T_UINT8_MAX, 1)
+VM_DEFINE_INSTRUCTION (158, bv_s8_set, "bv-s8-set", 0, 3, 0)
+BV_FIXABLE_INT_SET (s8, s8, int8, SCM_T_INT8_MIN, SCM_T_INT8_MAX, 1)
+VM_DEFINE_INSTRUCTION (159, bv_u16_native_set, "bv-u16-native-set", 0, 3, 0)
+BV_FIXABLE_INT_SET (u16, u16_native, uint16, 0, SCM_T_UINT16_MAX, 2)
+VM_DEFINE_INSTRUCTION (160, bv_s16_native_set, "bv-s16-native-set", 0, 3, 0)
+BV_FIXABLE_INT_SET (s16, s16_native, int16, SCM_T_INT16_MIN, SCM_T_INT16_MAX, 2)
+VM_DEFINE_INSTRUCTION (161, bv_u32_native_set, "bv-u32-native-set", 0, 3, 0)
+/* FIXME: u32 is always a fixnum on 64-bit builds */
+BV_INT_SET (u32, uint32, 4)
+VM_DEFINE_INSTRUCTION (162, bv_s32_native_set, "bv-s32-native-set", 0, 3, 0)
+BV_INT_SET (s32, int32, 4)
+VM_DEFINE_INSTRUCTION (163, bv_u64_native_set, "bv-u64-native-set", 0, 3, 0)
+BV_INT_SET (u64, uint64, 8)
+VM_DEFINE_INSTRUCTION (164, bv_s64_native_set, "bv-s64-native-set", 0, 3, 0)
+BV_INT_SET (s64, int64, 8)
+VM_DEFINE_INSTRUCTION (165, bv_f32_native_set, "bv-f32-native-set", 0, 3, 0)
+BV_FLOAT_SET (f32, ieee_single, float, 4)
+VM_DEFINE_INSTRUCTION (166, bv_f64_native_set, "bv-f64-native-set", 0, 3, 0)
+BV_FLOAT_SET (f64, ieee_double, double, 8)
+
+#undef BV_FIXABLE_INT_SET
+#undef BV_INT_SET
+#undef BV_FLOAT_SET
+
/*
(defun renumber-ops ()
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
(interactive "")
(save-excursion
- (let ((counter 79)) (goto-char (point-min))
+ (let ((counter 99)) (goto-char (point-min))
(while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t)
(replace-match
(number-to-string (setq counter (1+ counter)))
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index c1ea1c161..b298c88a6 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1,18 +1,19 @@
/* Copyright (C) 2001,2008,2009 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
@@ -138,13 +139,62 @@ VM_DEFINE_INSTRUCTION (13, make_int16, "make-int16", 2, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (14, make_char8, "make-char8", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (14, make_int64, "make-int64", 8, 0, 1)
{
- PUSH (SCM_MAKE_CHAR (FETCH ()));
+ scm_t_uint64 v = 0;
+ v += FETCH ();
+ v <<= 8; v += FETCH ();
+ v <<= 8; v += FETCH ();
+ v <<= 8; v += FETCH ();
+ v <<= 8; v += FETCH ();
+ v <<= 8; v += FETCH ();
+ v <<= 8; v += FETCH ();
+ v <<= 8; v += FETCH ();
+ PUSH (scm_from_int64 ((scm_t_int64) v));
NEXT;
}
-VM_DEFINE_INSTRUCTION (15, list, "list", 2, -1, 1)
+VM_DEFINE_INSTRUCTION (15, make_uint64, "make-uint64", 8, 0, 1)
+{
+ scm_t_uint64 v = 0;
+ v += FETCH ();
+ v <<= 8; v += FETCH ();
+ v <<= 8; v += FETCH ();
+ v <<= 8; v += FETCH ();
+ v <<= 8; v += FETCH ();
+ v <<= 8; v += FETCH ();
+ v <<= 8; v += FETCH ();
+ v <<= 8; v += FETCH ();
+ PUSH (scm_from_uint64 (v));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (16, make_char8, "make-char8", 1, 0, 1)
+{
+ scm_t_uint8 v = 0;
+ v = FETCH ();
+
+ PUSH (SCM_MAKE_CHAR (v));
+ /* Don't simplify this to PUSH (SCM_MAKE_CHAR (FETCH ())). The
+ contents of SCM_MAKE_CHAR may be evaluated more than once,
+ resulting in a double fetch. */
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (42, make_char32, "make-char32", 4, 0, 1)
+{
+ scm_t_wchar v = 0;
+ v += FETCH ();
+ v <<= 8; v += FETCH ();
+ v <<= 8; v += FETCH ();
+ v <<= 8; v += FETCH ();
+ PUSH (SCM_MAKE_CHAR (v));
+ NEXT;
+}
+
+
+
+VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1)
{
unsigned h = FETCH ();
unsigned l = FETCH ();
@@ -153,7 +203,7 @@ VM_DEFINE_INSTRUCTION (15, list, "list", 2, -1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (16, vector, "vector", 2, -1, 1)
+VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1)
{
unsigned h = FETCH ();
unsigned l = FETCH ();
@@ -171,19 +221,19 @@ VM_DEFINE_INSTRUCTION (16, vector, "vector", 2, -1, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (17, list_mark, "list-mark", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (19, list_mark, "list-mark", 0, 0, 0)
{
POP_LIST_MARK ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (18, cons_mark, "cons-mark", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (20, cons_mark, "cons-mark", 0, 0, 0)
{
POP_CONS_MARK ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (19, vector_mark, "vector-mark", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (21, vector_mark, "vector-mark", 0, 0, 0)
{
POP_LIST_MARK ();
SYNC_REGISTER ();
@@ -191,7 +241,7 @@ VM_DEFINE_INSTRUCTION (19, vector_mark, "vector-mark", 0, 0, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (20, list_break, "list-break", 0, 0, 0)
+VM_DEFINE_INSTRUCTION (22, list_break, "list-break", 0, 0, 0)
{
SCM l;
POP (l);
@@ -217,9 +267,11 @@ VM_DEFINE_INSTRUCTION (20, list_break, "list-break", 0, 0, 0)
#define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o)
#define VARIABLE_BOUNDP(v) (VARIABLE_REF (v) != SCM_UNDEFINED)
+#define FREE_VARIABLE_REF(i) free_vars[i]
+
/* ref */
-VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (23, object_ref, "object-ref", 1, 0, 1)
{
register unsigned objnum = FETCH ();
CHECK_OBJECT (objnum);
@@ -227,33 +279,41 @@ VM_DEFINE_INSTRUCTION (21, object_ref, "object-ref", 1, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (22, local_ref, "local-ref", 1, 0, 1)
+/* FIXME: necessary? elt 255 of the vector could be a vector... */
+VM_DEFINE_INSTRUCTION (24, long_object_ref, "long-object-ref", 2, 0, 1)
+{
+ unsigned int objnum = FETCH ();
+ objnum <<= 8;
+ objnum += FETCH ();
+ CHECK_OBJECT (objnum);
+ PUSH (OBJECT_REF (objnum));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (25, local_ref, "local-ref", 1, 0, 1)
{
PUSH (LOCAL_REF (FETCH ()));
+ ASSERT_BOUND (*sp);
NEXT;
}
-VM_DEFINE_INSTRUCTION (23, external_ref, "external-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (26, long_local_ref, "long-local-ref", 2, 0, 1)
{
- unsigned int i;
- SCM e = external;
- for (i = FETCH (); i; i--)
- {
- CHECK_EXTERNAL(e);
- e = SCM_CDR (e);
- }
- CHECK_EXTERNAL(e);
- PUSH (SCM_CAR (e));
+ unsigned int i = FETCH ();
+ i <<= 8;
+ i += FETCH ();
+ PUSH (LOCAL_REF (i));
+ ASSERT_BOUND (*sp);
NEXT;
}
-VM_DEFINE_INSTRUCTION (24, variable_ref, "variable-ref", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (27, variable_ref, "variable-ref", 0, 0, 1)
{
SCM x = *sp;
if (!VARIABLE_BOUNDP (x))
{
- finish_args = SCM_LIST1 (x);
+ finish_args = scm_list_1 (x);
/* Was: finish_args = SCM_LIST1 (SCM_CAR (x)); */
goto vm_error_unbound;
}
@@ -266,7 +326,7 @@ VM_DEFINE_INSTRUCTION (24, variable_ref, "variable-ref", 0, 0, 1)
NEXT;
}
-VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1)
+VM_DEFINE_INSTRUCTION (28, toplevel_ref, "toplevel-ref", 1, 0, 1)
{
unsigned objnum = FETCH ();
SCM what;
@@ -276,41 +336,37 @@ VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1)
if (!SCM_VARIABLEP (what))
{
SYNC_REGISTER ();
- if (SCM_LIKELY (SCM_SYMBOLP (what)))
- {
- SCM mod = SCM_EOL;
- if (SCM_LIKELY (scm_module_system_booted_p
- && scm_is_true ((mod = scm_program_module (program)))))
- /* might longjmp */
- what = scm_module_lookup (mod, what);
- else
- what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
- }
- else
+ what = resolve_variable (what, scm_program_module (program));
+ if (!VARIABLE_BOUNDP (what))
{
- SCM mod;
- /* compilation of @ or @@
- `what' is a three-element list: (MODNAME SYM INTERFACE?)
- INTERFACE? is #t if we compiled @ or #f if we compiled @@
- */
- mod = scm_resolve_module (SCM_CAR (what));
- if (scm_is_true (SCM_CADDR (what)))
- mod = scm_module_public_interface (mod);
- if (SCM_FALSEP (mod))
- {
- finish_args = SCM_LIST1 (mod);
- goto vm_error_no_such_module;
- }
- /* might longjmp */
- what = scm_module_lookup (mod, SCM_CADR (what));
+ finish_args = scm_list_1 (what);
+ goto vm_error_unbound;
}
-
+ OBJECT_SET (objnum, what);
+ }
+
+ PUSH (VARIABLE_REF (what));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (29, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1)
+{
+ SCM what;
+ unsigned int objnum = FETCH ();
+ objnum <<= 8;
+ objnum += FETCH ();
+ CHECK_OBJECT (objnum);
+ what = OBJECT_REF (objnum);
+
+ if (!SCM_VARIABLEP (what))
+ {
+ SYNC_REGISTER ();
+ what = resolve_variable (what, scm_program_module (program));
if (!VARIABLE_BOUNDP (what))
{
- finish_args = SCM_LIST1 (what);
+ finish_args = scm_list_1 (what);
goto vm_error_unbound;
}
-
OBJECT_SET (objnum, what);
}
@@ -320,36 +376,31 @@ VM_DEFINE_INSTRUCTION (25, toplevel_ref, "toplevel-ref", 1, 0, 1)
/* set */
-VM_DEFINE_INSTRUCTION (26, local_set, "local-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (30, local_set, "local-set", 1, 1, 0)
{
LOCAL_SET (FETCH (), *sp);
DROP ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (27, external_set, "external-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (31, long_local_set, "long-local-set", 2, 1, 0)
{
- unsigned int i;
- SCM e = external;
- for (i = FETCH (); i; i--)
- {
- CHECK_EXTERNAL(e);
- e = SCM_CDR (e);
- }
- CHECK_EXTERNAL(e);
- SCM_SETCAR (e, *sp);
+ unsigned int i = FETCH ();
+ i <<= 8;
+ i += FETCH ();
+ LOCAL_SET (i, *sp);
DROP ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (28, variable_set, "variable-set", 0, 1, 0)
+VM_DEFINE_INSTRUCTION (32, variable_set, "variable-set", 0, 1, 0)
{
VARIABLE_SET (sp[0], sp[-1]);
DROPN (2);
NEXT;
}
-VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
+VM_DEFINE_INSTRUCTION (33, toplevel_set, "toplevel-set", 1, 1, 0)
{
unsigned objnum = FETCH ();
SCM what;
@@ -359,35 +410,7 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
if (!SCM_VARIABLEP (what))
{
SYNC_BEFORE_GC ();
- if (SCM_LIKELY (SCM_SYMBOLP (what)))
- {
- SCM mod = SCM_EOL;
- if (SCM_LIKELY (scm_module_system_booted_p
- && scm_is_true ((mod = scm_program_module (program)))))
- /* might longjmp */
- what = scm_module_lookup (mod, what);
- else
- what = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
- }
- else
- {
- SCM mod;
- /* compilation of @ or @@
- `what' is a three-element list: (MODNAME SYM INTERFACE?)
- INTERFACE? is #t if we compiled @ or #f if we compiled @@
- */
- mod = scm_resolve_module (SCM_CAR (what));
- if (scm_is_true (SCM_CADDR (what)))
- mod = scm_module_public_interface (mod);
- if (SCM_FALSEP (mod))
- {
- finish_args = SCM_LIST1 (what);
- goto vm_error_no_such_module;
- }
- /* might longjmp */
- what = scm_module_lookup (mod, SCM_CADR (what));
- }
-
+ what = resolve_variable (what, scm_program_module (program));
OBJECT_SET (objnum, what);
}
@@ -396,9 +419,24 @@ VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0)
NEXT;
}
-VM_DEFINE_INSTRUCTION (30, externals, "externals", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (34, long_toplevel_set, "long-toplevel-set", 2, 1, 0)
{
- PUSH (external);
+ SCM what;
+ unsigned int objnum = FETCH ();
+ objnum <<= 8;
+ objnum += FETCH ();
+ CHECK_OBJECT (objnum);
+ what = OBJECT_REF (objnum);
+
+ if (!SCM_VARIABLEP (what))
+ {
+ SYNC_BEFORE_GC ();
+ what = resolve_variable (what, scm_program_module (program));
+ OBJECT_SET (objnum, what);
+ }
+
+ VARIABLE_SET (what, *sp);
+ DROP ();
NEXT;
}
@@ -407,7 +445,7 @@ VM_DEFINE_INSTRUCTION (30, externals, "externals", 0, 0, 1)
* branch and jump
*/
-/* offset must be a signed short!!! */
+/* offset must be a signed 16 bit int!!! */
#define FETCH_OFFSET(offset) \
{ \
int h = FETCH (); \
@@ -417,49 +455,51 @@ VM_DEFINE_INSTRUCTION (30, externals, "externals", 0, 0, 1)
#define BR(p) \
{ \
- signed short offset; \
+ scm_t_int16 offset; \
FETCH_OFFSET (offset); \
if (p) \
- ip += offset; \
+ ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8); \
NULLSTACK (1); \
DROP (); \
NEXT; \
}
-VM_DEFINE_INSTRUCTION (31, br, "br", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (35, br, "br", 2, 0, 0)
{
- int h = FETCH ();
- int l = FETCH ();
- ip += (signed short) (h << 8) + l;
+ scm_t_int16 offset;
+ FETCH_OFFSET (offset);
+ ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8);
NEXT;
}
-VM_DEFINE_INSTRUCTION (32, br_if, "br-if", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (36, br_if, "br-if", 2, 0, 0)
{
BR (!SCM_FALSEP (*sp));
}
-VM_DEFINE_INSTRUCTION (33, br_if_not, "br-if-not", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (37, br_if_not, "br-if-not", 2, 0, 0)
{
BR (SCM_FALSEP (*sp));
}
-VM_DEFINE_INSTRUCTION (34, br_if_eq, "br-if-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (38, br_if_eq, "br-if-eq", 2, 0, 0)
{
- BR (SCM_EQ_P (sp[0], sp--[1]));
+ sp--; /* underflow? */
+ BR (SCM_EQ_P (sp[0], sp[1]));
}
-VM_DEFINE_INSTRUCTION (35, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (39, br_if_not_eq, "br-if-not-eq", 2, 0, 0)
{
- BR (!SCM_EQ_P (sp[0], sp--[1]));
+ sp--; /* underflow? */
+ BR (!SCM_EQ_P (sp[0], sp[1]));
}
-VM_DEFINE_INSTRUCTION (36, br_if_null, "br-if-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (40, br_if_null, "br-if-null", 2, 0, 0)
{
BR (SCM_NULLP (*sp));
}
-VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0)
+VM_DEFINE_INSTRUCTION (41, br_if_not_null, "br-if-not-null", 2, 0, 0)
{
BR (!SCM_NULLP (*sp));
}
@@ -469,15 +509,7 @@ VM_DEFINE_INSTRUCTION (37, br_if_not_null, "br-if-not-null", 2, 0, 0)
* Subprogram call
*/
-VM_DEFINE_INSTRUCTION (38, make_closure, "make-closure", 0, 1, 1)
-{
- SYNC_BEFORE_GC ();
- SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp),
- SCM_PROGRAM_OBJTABLE (*sp), external);
- NEXT;
-}
-
-VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (43, call, "call", 1, -1, 1)
{
SCM x;
nargs = FETCH ();
@@ -598,7 +630,7 @@ VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1)
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (44, goto_args, "goto/args", 1, -1, 1)
{
register SCM x;
nargs = FETCH ();
@@ -625,12 +657,6 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
sp -= 2;
NULLSTACK (bp->nargs + 1);
- /* Freshen the externals */
- external = SCM_PROGRAM_EXTERNALS (x);
- for (i = 0; i < bp->nexts; i++)
- CONS (external, SCM_UNDEFINED, external);
- SCM_FRAME_DATA_ADDRESS (fp)[0] = external;
-
/* Init locals to valid SCM values */
for (i = 0; i < bp->nlocs; i++)
LOCAL_SET (i + bp->nargs, SCM_UNDEFINED);
@@ -679,7 +705,7 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
sure we have space for the locals now */
data = SCM_FRAME_DATA_ADDRESS (fp);
ip = bp->base;
- stack_base = data + 3;
+ stack_base = data + 2;
sp = stack_base;
CHECK_OVERFLOW ();
@@ -694,17 +720,9 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
data[-i] = SCM_UNDEFINED;
/* Set frame data */
- data[3] = (SCM)ra;
- data[2] = (SCM)mvra;
- data[1] = (SCM)dl;
-
- /* Postpone initializing external vars, because if the CONS causes a GC,
- we want the stack marker to see the data array formatted as expected. */
- data[0] = SCM_UNDEFINED;
- external = SCM_PROGRAM_EXTERNALS (fp[-1]);
- for (i = 0; i < bp->nexts; i++)
- CONS (external, SCM_UNDEFINED, external);
- data[0] = external;
+ data[2] = (SCM)ra;
+ data[1] = (SCM)mvra;
+ data[0] = (SCM)dl;
ENTER_HOOK ();
APPLY_HOOK ();
@@ -792,7 +810,7 @@ VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1)
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (45, goto_nargs, "goto/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -801,7 +819,7 @@ VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1)
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1)
+VM_DEFINE_INSTRUCTION (46, call_nargs, "call/nargs", 0, 0, 1)
{
SCM x;
POP (x);
@@ -810,13 +828,15 @@ VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
+VM_DEFINE_INSTRUCTION (47, mv_call, "mv-call", 3, -1, 1)
{
SCM x;
- signed short offset;
+ scm_t_int16 offset;
+ scm_t_uint8 *mvra;
nargs = FETCH ();
FETCH_OFFSET (offset);
+ mvra = ip + ((scm_t_ptrdiff)offset) * 8 - ((unsigned long)ip) % 8;
x = sp[-nargs];
@@ -829,7 +849,7 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
CACHE_PROGRAM ();
INIT_ARGS ();
NEW_FRAME ();
- SCM_FRAME_DATA_ADDRESS (fp)[2] = (SCM)(SCM_FRAME_RETURN_ADDRESS (fp) + offset);
+ SCM_FRAME_DATA_ADDRESS (fp)[1] = (SCM)mvra;
ENTER_HOOK ();
APPLY_HOOK ();
NEXT;
@@ -854,7 +874,7 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
len = scm_length (values);
PUSH_LIST (values, SCM_NULLP);
PUSH (len);
- ip += offset;
+ ip = mvra;
}
NEXT;
}
@@ -871,7 +891,7 @@ VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1)
goto vm_error_wrong_type_apply;
}
-VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (48, apply, "apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -890,7 +910,7 @@ VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1)
goto vm_call;
}
-VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1)
+VM_DEFINE_INSTRUCTION (49, goto_apply, "goto/apply", 1, -1, 1)
{
int len;
SCM ls;
@@ -909,7 +929,7 @@ VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1)
goto vm_goto_args;
}
-VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (50, call_cc, "call/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -943,7 +963,7 @@ VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (51, goto_cc, "goto/cc", 0, 1, 1)
{
int first;
SCM proc, cont;
@@ -975,7 +995,7 @@ VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1)
}
}
-VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
+VM_DEFINE_INSTRUCTION (52, return, "return", 0, 1, 1)
{
vm_return:
EXIT_HOOK ();
@@ -988,12 +1008,12 @@ VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
POP (ret);
ASSERT (sp == stack_base);
- ASSERT (stack_base == data + 3);
+ ASSERT (stack_base == data + 2);
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp);
- ip = SCM_FRAME_BYTE_CAST (data[3]);
- fp = SCM_FRAME_STACK_CAST (data[1]);
+ ip = SCM_FRAME_BYTE_CAST (data[2]);
+ fp = SCM_FRAME_STACK_CAST (data[0]);
{
#ifdef VM_ENABLE_STACK_NULLING
int nullcount = stack_base - sp;
@@ -1009,12 +1029,11 @@ VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1)
/* Restore the last program */
program = SCM_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
- CACHE_EXTERNAL ();
CHECK_IP ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (53, return_values, "return/values", 1, -1, -1)
{
/* nvalues declared at top level, because for some reason gcc seems to think
that perhaps it might be used without declaration. Fooey to that, I say. */
@@ -1026,16 +1045,16 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
RETURN_HOOK ();
data = SCM_FRAME_DATA_ADDRESS (fp);
- ASSERT (stack_base == data + 3);
+ ASSERT (stack_base == data + 2);
- /* data[2] is the mv return address */
- if (nvalues != 1 && data[2])
+ /* data[1] is the mv return address */
+ if (nvalues != 1 && data[1])
{
int i;
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = SCM_FRAME_BYTE_CAST (data[2]); /* multiple value ra */
- fp = SCM_FRAME_STACK_CAST (data[1]);
+ ip = SCM_FRAME_BYTE_CAST (data[1]); /* multiple value ra */
+ fp = SCM_FRAME_STACK_CAST (data[0]);
/* Push return values, and the number of values */
for (i = 0; i < nvalues; i++)
@@ -1054,8 +1073,8 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
continuation.) */
/* Restore registers */
sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1;
- ip = SCM_FRAME_BYTE_CAST (data[3]); /* single value ra */
- fp = SCM_FRAME_STACK_CAST (data[1]);
+ ip = SCM_FRAME_BYTE_CAST (data[2]); /* single value ra */
+ fp = SCM_FRAME_STACK_CAST (data[0]);
/* Push first value */
*++sp = stack_base[1];
@@ -1070,12 +1089,11 @@ VM_DEFINE_INSTRUCTION (49, return_values, "return/values", 1, -1, -1)
/* Restore the last program */
program = SCM_FRAME_PROGRAM (fp);
CACHE_PROGRAM ();
- CACHE_EXTERNAL ();
CHECK_IP ();
NEXT;
}
-VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
+VM_DEFINE_INSTRUCTION (54, return_values_star, "return/values*", 1, -1, -1)
{
SCM l;
@@ -1098,7 +1116,7 @@ VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1)
goto vm_return_values;
}
-VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1)
+VM_DEFINE_INSTRUCTION (55, truncate_values, "truncate-values", 2, -1, -1)
{
SCM x;
int nbinds, rest;
@@ -1121,6 +1139,142 @@ VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1)
NEXT;
}
+VM_DEFINE_INSTRUCTION (56, box, "box", 1, 1, 0)
+{
+ SCM val;
+ POP (val);
+ SYNC_BEFORE_GC ();
+ LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val)));
+ NEXT;
+}
+
+/* for letrec:
+ (let ((a *undef*) (b *undef*) ...)
+ (set! a (lambda () (b ...)))
+ ...)
+ */
+VM_DEFINE_INSTRUCTION (57, empty_box, "empty-box", 1, 0, 0)
+{
+ SYNC_BEFORE_GC ();
+ LOCAL_SET (FETCH (),
+ scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (58, local_boxed_ref, "local-boxed-ref", 1, 0, 1)
+{
+ SCM v = LOCAL_REF (FETCH ());
+ ASSERT_BOUND_VARIABLE (v);
+ PUSH (VARIABLE_REF (v));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (59, local_boxed_set, "local-boxed-set", 1, 1, 0)
+{
+ SCM v, val;
+ v = LOCAL_REF (FETCH ());
+ POP (val);
+ ASSERT_VARIABLE (v);
+ VARIABLE_SET (v, val);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (60, free_ref, "free-ref", 1, 0, 1)
+{
+ scm_t_uint8 idx = FETCH ();
+
+ CHECK_FREE_VARIABLE (idx);
+ PUSH (FREE_VARIABLE_REF (idx));
+ NEXT;
+}
+
+/* no free-set -- if a var is assigned, it should be in a box */
+
+VM_DEFINE_INSTRUCTION (61, free_boxed_ref, "free-boxed-ref", 1, 0, 1)
+{
+ SCM v;
+ scm_t_uint8 idx = FETCH ();
+ CHECK_FREE_VARIABLE (idx);
+ v = FREE_VARIABLE_REF (idx);
+ ASSERT_BOUND_VARIABLE (v);
+ PUSH (VARIABLE_REF (v));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (62, free_boxed_set, "free-boxed-set", 1, 1, 0)
+{
+ SCM v, val;
+ scm_t_uint8 idx = FETCH ();
+ POP (val);
+ CHECK_FREE_VARIABLE (idx);
+ v = FREE_VARIABLE_REF (idx);
+ ASSERT_BOUND_VARIABLE (v);
+ VARIABLE_SET (v, val);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (63, make_closure, "make-closure", 0, 2, 1)
+{
+ SCM vect;
+ POP (vect);
+ SYNC_BEFORE_GC ();
+ /* fixme underflow */
+ SCM_NEWSMOB3 (*sp, scm_tc16_program, SCM_PROGRAM_OBJCODE (*sp),
+ SCM_PROGRAM_OBJTABLE (*sp), vect);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (64, make_variable, "make-variable", 0, 0, 1)
+{
+ SYNC_BEFORE_GC ();
+ /* fixme underflow */
+ PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED)));
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (65, fix_closure, "fix-closure", 2, 0, 1)
+{
+ SCM x, vect;
+ unsigned int i = FETCH ();
+ i <<= 8;
+ i += FETCH ();
+ POP (vect);
+ /* FIXME CHECK_LOCAL (i) */
+ x = LOCAL_REF (i);
+ /* FIXME ASSERT_PROGRAM (x); */
+ SCM_SET_CELL_WORD_3 (x, vect);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (66, define, "define", 0, 0, 2)
+{
+ SCM sym, val;
+ POP (sym);
+ POP (val);
+ SYNC_REGISTER ();
+ VARIABLE_SET (scm_sym2var (sym, scm_current_module_lookup_closure (),
+ SCM_BOOL_T),
+ val);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (67, make_keyword, "make-keyword", 0, 1, 1)
+{
+ CHECK_UNDERFLOW ();
+ SYNC_REGISTER ();
+ *sp = scm_symbol_to_keyword (*sp);
+ NEXT;
+}
+
+VM_DEFINE_INSTRUCTION (68, make_symbol, "make-symbol", 0, 1, 1)
+{
+ CHECK_UNDERFLOW ();
+ SYNC_REGISTER ();
+ *sp = scm_string_to_symbol (*sp);
+ NEXT;
+}
+
+
/*
(defun renumber-ops ()
"start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences"
diff --git a/libguile/vm.c b/libguile/vm.c
index e132c8eda..df1ad8850 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -1,50 +1,29 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
+/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
*
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
#if HAVE_CONFIG_H
# include <config.h>
#endif
+#include <stdlib.h>
#include <alloca.h>
#include <string.h>
+#include "_scm.h"
#include "vm-bootstrap.h"
#include "frames.h"
#include "instructions.h"
@@ -185,28 +164,37 @@ static SCM sym_vm_run;
static SCM sym_vm_error;
static SCM sym_debug;
-static SCM make_u8vector (const scm_t_uint8 *bytes, size_t len)
-{
- scm_t_uint8 *new_bytes = scm_gc_malloc (len, "make-u8vector");
- memcpy (new_bytes, bytes, len);
- return scm_take_u8vector (new_bytes, len);
-}
-
static SCM
really_make_boot_program (long nargs)
{
- scm_byte_t bytes[] = {0, 0, 0, 0,
- 0, 0, 0, 0,
- 0, 0, 0, 0,
- scm_op_mv_call, 0, 0, 1, scm_op_make_int8_1, scm_op_halt};
+ SCM u8vec;
+ /* Make sure "bytes" is 64-bit aligned. */
+ scm_t_uint8 text[] = { scm_op_mv_call, 0, 0, 1,
+ scm_op_make_int8_1, scm_op_nop, scm_op_nop, scm_op_nop,
+ scm_op_halt };
+ struct scm_objcode *bp;
SCM ret;
- ((scm_t_uint32*)bytes)[1] = 6; /* set len in current endianness, no meta */
+
if (SCM_UNLIKELY (nargs > 255 || nargs < 0))
abort ();
- bytes[13] = (scm_byte_t)nargs;
- ret = scm_make_program (scm_bytecode_to_objcode (make_u8vector (bytes, sizeof(bytes))),
- SCM_BOOL_F, SCM_EOL);
+ text[1] = (scm_t_uint8)nargs;
+
+ bp = scm_gc_malloc (sizeof (struct scm_objcode) + sizeof (text),
+ "make-u8vector");
+ memcpy (bp->base, text, sizeof (text));
+ bp->nargs = 0;
+ bp->nrest = 0;
+ bp->nlocs = 0;
+ bp->len = sizeof(text);
+ bp->metalen = 0;
+ bp->unused = 0;
+
+ u8vec = scm_take_u8vector ((scm_t_uint8*)bp,
+ sizeof (struct scm_objcode) + sizeof (text));
+ ret = scm_make_program (scm_bytecode_to_objcode (u8vec),
+ SCM_BOOL_F, SCM_BOOL_F);
SCM_SET_SMOB_FLAGS (ret, SCM_F_PROGRAM_IS_BOOT);
+
return ret;
}
#define NUM_BOOT_PROGS 8
@@ -233,7 +221,44 @@ vm_make_boot_program (long nargs)
* VM
*/
-#define VM_DEFAULT_STACK_SIZE (16 * 1024)
+static SCM
+resolve_variable (SCM what, SCM program_module)
+{
+ if (SCM_LIKELY (SCM_SYMBOLP (what)))
+ {
+ if (SCM_LIKELY (scm_module_system_booted_p
+ && scm_is_true (program_module)))
+ /* might longjmp */
+ return scm_module_lookup (program_module, what);
+ else
+ {
+ SCM v = scm_sym2var (what, SCM_BOOL_F, SCM_BOOL_F);
+ if (scm_is_false (v))
+ scm_misc_error (NULL, "unbound variable: ~S", scm_list_1 (what));
+ else
+ return v;
+ }
+ }
+ else
+ {
+ SCM mod;
+ /* compilation of @ or @@
+ `what' is a three-element list: (MODNAME SYM INTERFACE?)
+ INTERFACE? is #t if we compiled @ or #f if we compiled @@
+ */
+ mod = scm_resolve_module (SCM_CAR (what));
+ if (scm_is_true (SCM_CADDR (what)))
+ mod = scm_module_public_interface (mod);
+ if (SCM_FALSEP (mod))
+ scm_misc_error (NULL, "no such module: ~S",
+ scm_list_1 (SCM_CAR (what)));
+ /* might longjmp */
+ return scm_module_lookup (mod, SCM_CADR (what));
+ }
+}
+
+
+#define VM_DEFAULT_STACK_SIZE (64 * 1024)
#define VM_NAME vm_regular_engine
#define FUNC_NAME "vm-regular-engine"
@@ -535,7 +560,7 @@ SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0,
SCM scm_load_compiled_with_vm (SCM file)
{
SCM program = scm_make_program (scm_load_objcode (file),
- SCM_BOOL_F, SCM_EOL);
+ SCM_BOOL_F, SCM_BOOL_F);
return scm_c_vm_run (scm_the_vm (), program, NULL, 0);
}
@@ -566,6 +591,9 @@ scm_bootstrap_vm (void)
sym_vm_error = scm_permanent_object (scm_from_locale_symbol ("vm-error"));
sym_debug = scm_permanent_object (scm_from_locale_symbol ("debug"));
+ scm_c_register_extension ("libguile", "scm_init_vm",
+ (scm_t_extension_init_func)scm_init_vm, NULL);
+
strappage = 1;
}
diff --git a/libguile/vm.h b/libguile/vm.h
index 5c38f9ffa..b079c7aa0 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -1,43 +1,20 @@
/* Copyright (C) 2001 Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
#ifndef _SCM_VM_H_
#define _SCM_VM_H_
@@ -78,37 +55,37 @@ struct scm_vm {
SCM trace_frame; /* a frame being traced */
};
-extern SCM scm_the_vm_fluid;
+SCM_API SCM scm_the_vm_fluid;
#define SCM_VM_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm, x)
#define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_SMOB_DATA (vm))
#define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P)
-extern SCM scm_the_vm ();
-extern SCM scm_make_vm (void);
-extern SCM scm_vm_apply (SCM vm, SCM program, SCM args);
-extern SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
-extern SCM scm_vm_option_ref (SCM vm, SCM key);
-extern SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
-
-extern SCM scm_vm_version (void);
-extern SCM scm_the_vm (void);
-extern SCM scm_vm_p (SCM obj);
-extern SCM scm_vm_ip (SCM vm);
-extern SCM scm_vm_sp (SCM vm);
-extern SCM scm_vm_fp (SCM vm);
-extern SCM scm_vm_boot_hook (SCM vm);
-extern SCM scm_vm_halt_hook (SCM vm);
-extern SCM scm_vm_next_hook (SCM vm);
-extern SCM scm_vm_break_hook (SCM vm);
-extern SCM scm_vm_enter_hook (SCM vm);
-extern SCM scm_vm_apply_hook (SCM vm);
-extern SCM scm_vm_exit_hook (SCM vm);
-extern SCM scm_vm_return_hook (SCM vm);
-extern SCM scm_vm_option (SCM vm, SCM key);
-extern SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
-extern SCM scm_vm_stats (SCM vm);
-extern SCM scm_vm_trace_frame (SCM vm);
+SCM_API SCM scm_the_vm ();
+SCM_API SCM scm_make_vm (void);
+SCM_API SCM scm_vm_apply (SCM vm, SCM program, SCM args);
+SCM_API SCM scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs);
+SCM_API SCM scm_vm_option_ref (SCM vm, SCM key);
+SCM_API SCM scm_vm_option_set_x (SCM vm, SCM key, SCM val);
+
+SCM_API SCM scm_vm_version (void);
+SCM_API SCM scm_the_vm (void);
+SCM_API SCM scm_vm_p (SCM obj);
+SCM_API SCM scm_vm_ip (SCM vm);
+SCM_API SCM scm_vm_sp (SCM vm);
+SCM_API SCM scm_vm_fp (SCM vm);
+SCM_API SCM scm_vm_boot_hook (SCM vm);
+SCM_API SCM scm_vm_halt_hook (SCM vm);
+SCM_API SCM scm_vm_next_hook (SCM vm);
+SCM_API SCM scm_vm_break_hook (SCM vm);
+SCM_API SCM scm_vm_enter_hook (SCM vm);
+SCM_API SCM scm_vm_apply_hook (SCM vm);
+SCM_API SCM scm_vm_exit_hook (SCM vm);
+SCM_API SCM scm_vm_return_hook (SCM vm);
+SCM_API SCM scm_vm_option (SCM vm, SCM key);
+SCM_API SCM scm_set_vm_option_x (SCM vm, SCM key, SCM val);
+SCM_API SCM scm_vm_stats (SCM vm);
+SCM_API SCM scm_vm_trace_frame (SCM vm);
struct scm_vm_cont {
scm_byte_t *ip;
@@ -119,16 +96,16 @@ struct scm_vm_cont {
scm_t_ptrdiff reloc;
};
-extern scm_t_bits scm_tc16_vm_cont;
+SCM_API scm_t_bits scm_tc16_vm_cont;
#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
-extern SCM scm_vm_capture_continuations (void);
-extern void scm_vm_reinstate_continuations (SCM conts);
+SCM_API SCM scm_vm_capture_continuations (void);
+SCM_API void scm_vm_reinstate_continuations (SCM conts);
-extern SCM scm_load_compiled_with_vm (SCM file);
+SCM_API SCM scm_load_compiled_with_vm (SCM file);
-extern void scm_init_vm (void);
+SCM_INTERNAL void scm_init_vm (void);
#endif /* _SCM_VM_H_ */
diff --git a/libguile/vports.c b/libguile/vports.c
index 564f0e73f..cea11c61d 100644
--- a/libguile/vports.c
+++ b/libguile/vports.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/vports.h b/libguile/vports.h
index 365303bc1..ae64dd438 100644
--- a/libguile/vports.h
+++ b/libguile/vports.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,2000, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/weaks.c b/libguile/weaks.c
index 7558e78a6..92fb305cc 100644
--- a/libguile/weaks.c
+++ b/libguile/weaks.c
@@ -1,18 +1,19 @@
/* Copyright (C) 1995,1996,1998,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/weaks.h b/libguile/weaks.h
index 81c17749f..908e27628 100644
--- a/libguile/weaks.h
+++ b/libguile/weaks.h
@@ -6,18 +6,19 @@
/* Copyright (C) 1995,1996,2000,2001, 2003, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/win32-dirent.c b/libguile/win32-dirent.c
index cd7e8bac6..de170c70b 100644
--- a/libguile/win32-dirent.c
+++ b/libguile/win32-dirent.c
@@ -1,18 +1,19 @@
/* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
diff --git a/libguile/win32-dirent.h b/libguile/win32-dirent.h
index 30bc118ea..578db49b9 100644
--- a/libguile/win32-dirent.h
+++ b/libguile/win32-dirent.h
@@ -6,18 +6,19 @@
/* Copyright (C) 2001, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
/* Directory stream type.
diff --git a/libguile/win32-socket.c b/libguile/win32-socket.c
index 54f80a764..e845d886a 100644
--- a/libguile/win32-socket.c
+++ b/libguile/win32-socket.c
@@ -1,18 +1,19 @@
/* Copyright (C) 2001, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
diff --git a/libguile/win32-socket.h b/libguile/win32-socket.h
index 51856051d..4ab9b942a 100644
--- a/libguile/win32-socket.h
+++ b/libguile/win32-socket.h
@@ -6,18 +6,19 @@
/* Copyright (C) 2001, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#include "libguile/__scm.h"
diff --git a/libguile/win32-uname.c b/libguile/win32-uname.c
index d4d737f49..5349f1410 100644
--- a/libguile/win32-uname.c
+++ b/libguile/win32-uname.c
@@ -1,18 +1,19 @@
/* Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#ifdef HAVE_CONFIG_H
diff --git a/libguile/win32-uname.h b/libguile/win32-uname.h
index 8593dc7d9..4b7498133 100644
--- a/libguile/win32-uname.h
+++ b/libguile/win32-uname.h
@@ -6,18 +6,19 @@
/* Copyright (C) 2001, 2006 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public
- * License as published by the Free Software Foundation; either
- * version 2.1 of the License, or (at your option) any later version.
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
*
- * This library is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
*/
#define _UTSNAME_LENGTH 65