diff options
author | Ludovic Courtès <ludo@gnu.org> | 2009-09-02 00:07:27 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2009-09-02 01:37:37 +0200 |
commit | 5f236208d0d864546e59afa0f5a11c9b3ba14b10 (patch) | |
tree | eed5d9203a2633c8efb85c1b36425eab87574299 /libguile | |
parent | f0eb5ae6c173aed35965b0561897fda1d8ff0db1 (diff) | |
parent | d7e7a02a6251c8ed4f76933d9d30baeee3f599c0 (diff) | |
download | guile-5f236208d0d864546e59afa0f5a11c9b3ba14b10.tar.gz |
Merge branch 'boehm-demers-weiser-gc' into bdw-gc-static-alloc
Conflicts:
acinclude.m4
libguile/strings.c
Diffstat (limited to 'libguile')
260 files changed, 28322 insertions, 9449 deletions
diff --git a/libguile/.gitignore b/libguile/.gitignore index 41f7909d2..09f1b06b7 100644 --- a/libguile/.gitignore +++ b/libguile/.gitignore @@ -13,3 +13,4 @@ guile_filter_doc_snarfage libpath.h scmconfig.h version.h +vm-i-*.i diff --git a/libguile/Makefile.am b/libguile/Makefile.am index 9b05f01be..046ce21cc 100644 --- a/libguile/Makefile.am +++ b/libguile/Makefile.am @@ -4,20 +4,20 @@ ## ## 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 @@ -85,7 +85,7 @@ c-tokenize.$(OBJEXT): c-tokenize.c if [ "$(cross_compiling)" = "yes" ]; then \ $(CC_FOR_BUILD) $(DEFS) $(AM_CPPFLAGS) -c -o $@ $<; \ else \ - $(COMPILE) -c -o $@ $<; \ + $(filter-out -Werror,$(COMPILE)) -c -o $@ $<; \ fi ## Override default rule; this should run on BUILD host. @@ -105,21 +105,103 @@ 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 \ - 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 \ - gdbint.c gettext.c goops.c gsubr.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 \ - 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 \ - throw.c values.c variable.c vectors.c version.c vports.c weaks.c \ - ramap.c unif.c +libguile_la_SOURCES = \ + alist.c \ + arbiters.c \ + array-handle.c \ + array-map.c \ + arrays.c \ + async.c \ + backtrace.c \ + boolean.c \ + bitvectors.c \ + bytevectors.c \ + chars.c \ + continuations.c \ + debug.c \ + deprecated.c \ + deprecation.c \ + discouraged.c \ + dynwind.c \ + eq.c \ + error.c \ + eval.c \ + evalext.c \ + extensions.c \ + feature.c \ + fluids.c \ + fports.c \ + frames.c \ + futures.c \ + gc-malloc.c \ + gc.c \ + gdbint.c \ + gettext.c \ + generalized-arrays.c \ + generalized-vectors.c \ + goops.c \ + gsubr.c \ + guardians.c \ + hash.c \ + hashtab.c \ + hooks.c \ + init.c \ + inline.c \ + instructions.c \ + ioext.c \ + keywords.c \ + lang.c \ + list.c \ + load.c \ + macros.c \ + mallocs.c \ + modules.c \ + null-threads.c \ + numbers.c \ + objcodes.c \ + objects.c \ + objprop.c \ + options.c \ + pairs.c \ + ports.c \ + print.c \ + procprop.c \ + procs.c \ + programs.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 \ + srfi-13.c \ + srfi-14.c \ + srfi-4.c \ + stackchk.c \ + stacks.c \ + stime.c \ + strings.c \ + strorder.c \ + strports.c \ + struct.c \ + symbols.c \ + threads.c \ + throw.c \ + uniform.c \ + values.c \ + variable.c \ + vectors.c \ + version.c \ + vm.c \ + vports.c \ + weaks.c libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_SOURCES = i18n.c libguile_i18n_v_@LIBGUILE_I18N_MAJOR@_la_CFLAGS = \ @@ -130,45 +212,205 @@ 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 \ - 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 \ - gettext.x goops.x gsubr.x guardians.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 \ - 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 \ - variable.x vectors.x version.x vports.x weaks.x ramap.x unif.x +DOT_X_FILES = \ + alist.x \ + arbiters.x \ + array-handle.x \ + array-map.x \ + arrays.x \ + async.x \ + backtrace.x \ + boolean.x \ + bitvectors.x \ + bytevectors.x \ + chars.x \ + continuations.x \ + debug.x \ + deprecated.x \ + deprecation.x \ + discouraged.x \ + dynl.x \ + dynwind.x \ + eq.x \ + error.x \ + eval.x \ + evalext.x \ + extensions.x \ + feature.x \ + fluids.x \ + fports.x \ + futures.x \ + gc-malloc.x \ + gc.x \ + gettext.x \ + generalized-arrays.x \ + generalized-vectors.x \ + goops.x \ + gsubr.x \ + guardians.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 \ + 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 \ + srfi-13.x \ + srfi-14.x \ + srfi-4.x \ + stackchk.x \ + stacks.x \ + stime.x \ + strings.x \ + strorder.x \ + strports.x \ + struct.x \ + symbols.x \ + threads.x \ + throw.x \ + uniform.x \ + values.x \ + variable.x \ + vectors.x \ + version.x \ + vports.x \ + weaks.x + +# vm-related snarfs +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 \ - 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 \ - gc.doc goops.doc gsubr.doc \ - gc-malloc.doc gettext.doc guardians.doc hash.doc hashtab.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 \ - 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 \ - strports.doc struct.doc symbols.doc threads.doc throw.doc \ - values.doc variable.doc vectors.doc version.doc vports.doc \ - weaks.doc ramap.doc unif.doc +DOT_DOC_FILES = \ + alist.doc \ + arbiters.doc \ + array-handle.doc \ + array-map.doc \ + arrays.doc \ + async.doc \ + backtrace.doc \ + boolean.doc \ + bitvectors.doc \ + bytevectors.doc \ + chars.doc \ + continuations.doc \ + debug.doc \ + deprecated.doc \ + deprecation.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 \ + gc-malloc.doc \ + gc.doc \ + gettext.doc \ + generalized-arrays.doc \ + generalized-vectors.doc \ + goops.doc \ + gsubr.doc \ + guardians.doc \ + hash.doc \ + hashtab.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 \ + 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 \ + srfi-13.doc \ + srfi-14.doc \ + srfi-4.doc \ + stackchk.doc \ + stacks.doc \ + stime.doc \ + strings.doc \ + strorder.doc \ + strports.doc \ + struct.doc \ + symbols.doc \ + threads.doc \ + throw.doc \ + uniform.doc \ + values.doc \ + variable.doc \ + vectors.doc \ + version.doc \ + vports.doc \ + weaks.doc EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@ +DOT_I_FILES = vm-i-system.i vm-i-scheme.i vm-i-loader.i + +.c.i: + grep '^VM_DEFINE' $< > $@ + BUILT_SOURCES = cpp_err_symbols.c cpp_sig_symbols.c libpath.h \ version.h scmconfig.h \ - $(DOT_X_FILES) $(EXTRA_DOT_X_FILES) + $(DOT_I_FILES) $(DOT_X_FILES) $(EXTRA_DOT_X_FILES) EXTRA_libguile_la_SOURCES = _scm.h \ inet_aton.c memmove.c putenv.c strerror.c \ @@ -188,41 +430,145 @@ install-exec-hook: ## compile, since they are #included. So instead we list them here. ## Perhaps we can deal with them normally once the merge seems to be ## working. -noinst_HEADERS = convert.i.c \ - conv-integer.i.c conv-uinteger.i.c \ - eval.i.c \ - srfi-4.i.c \ +noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \ + eval.i.c ieee-754.h \ + srfi-4.i.c srfi-14.i.c \ quicksort.i.c \ win32-uname.h win32-dirent.h win32-socket.h \ private-gc.h private-options.h +# vm instructions +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 \ - 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 \ - feature.h filesys.h fluids.h fports.h futures.h gc.h \ - gdb_interface.h gdbint.h gettext.h goops.h \ - gsubr.h guardians.h hash.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 \ - 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 \ - strorder.h strports.h struct.h symbols.h tags.h threads.h \ - pthread-threads.h null-threads.h throw.h unif.h values.h \ - variable.h vectors.h vports.h weaks.h +modinclude_HEADERS = \ + __scm.h \ + alist.h \ + arbiters.h \ + array-handle.h \ + array-map.h \ + arrays.h \ + async.h \ + backtrace.h \ + boolean.h \ + bitvectors.h \ + bytevectors.h \ + chars.h \ + continuations.h \ + debug-malloc.h \ + debug.h \ + deprecated.h \ + deprecation.h \ + discouraged.h \ + dynl.h \ + dynwind.h \ + eq.h \ + error.h \ + eval.h \ + evalext.h \ + extensions.h \ + feature.h \ + filesys.h \ + fluids.h \ + fports.h \ + frames.h \ + futures.h \ + gc.h \ + gdb_interface.h \ + gdbint.h \ + gettext.h \ + generalized-arrays.h \ + generalized-vectors.h \ + goops.h \ + gsubr.h \ + guardians.h \ + hash.h \ + hashtab.h \ + hooks.h \ + i18n.h \ + init.h \ + inline.h \ + instructions.h \ + ioext.h \ + iselect.h \ + keywords.h \ + lang.h \ + list.h \ + load.h \ + macros.h \ + mallocs.h \ + modules.h \ + net_db.h \ + null-threads.h \ + numbers.h \ + objcodes.h \ + objects.h \ + objprop.h \ + options.h \ + pairs.h \ + ports.h \ + posix.h \ + print.h \ + procprop.h \ + procs.h \ + programs.h \ + properties.h \ + pthread-threads.h \ + r6rs-ports.h \ + random.h \ + rdelim.h \ + read.h \ + regex-posix.h \ + root.h \ + rw.h \ + scmsigs.h \ + script.h \ + simpos.h \ + smob.h \ + snarf.h \ + socket.h \ + sort.h \ + srcprop.h \ + srfi-13.h \ + srfi-14.h \ + srfi-4.h \ + stackchk.h \ + stacks.h \ + stime.h \ + strings.h \ + strorder.h \ + strports.h \ + struct.h \ + symbols.h \ + tags.h \ + threads.h \ + throw.h \ + validate.h \ + uniform.h \ + values.h \ + variable.h \ + vectors.h \ + vm-bootstrap.h \ + vm-engine.h \ + vm-expand.h \ + vm.h \ + vports.h \ + weaks.h nodist_modinclude_HEADERS = version.h scmconfig.h @@ -237,7 +583,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 unidata_to_charset.pl libguile.map # $(DOT_DOC_FILES) $(EXTRA_DOT_DOC_FILES) \ # guile-procedures.txt guile.texi @@ -259,6 +605,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 @@ -272,12 +620,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@" }, \' \ @@ -307,10 +656,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) @@ -332,29 +679,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; } @@ -409,8 +733,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 a9f05ba46..32b52df51 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 /* The SCM_ALIGNED macro, when defined, can be used to instruct the compiler * to honor the given alignment constraint. */ @@ -164,13 +162,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 @@ -434,19 +433,28 @@ typedef struct { ucontext_t ctx; int fresh; - } jmp_buf; -# define setjmp(JB) \ + } scm_i_jmp_buf; +# define SCM_I_SETJMP(JB) \ ( (JB).fresh = 1, \ getcontext (&((JB).ctx)), \ ((JB).fresh ? ((JB).fresh = 0, 0) : 1) ) -# define longjmp(JB,VAL) scm_ia64_longjmp (&(JB), VAL) - void scm_ia64_longjmp (jmp_buf *, int); +# define SCM_I_LONGJMP(JB,VAL) scm_ia64_longjmp (&(JB), VAL) + void scm_ia64_longjmp (scm_i_jmp_buf *, int); # else /* ndef __ia64__ */ # include <setjmp.h> # endif /* ndef __ia64__ */ # endif /* ndef _CRAY1 */ #endif /* ndef vms */ +/* For any platform where SCM_I_SETJMP hasn't been defined in some + special way above, map SCM_I_SETJMP, SCM_I_LONGJMP and + scm_i_jmp_buf to setjmp, longjmp and jmp_buf. */ +#ifndef SCM_I_SETJMP +#define scm_i_jmp_buf jmp_buf +#define SCM_I_SETJMP setjmp +#define SCM_I_LONGJMP longjmp +#endif + /* James Clark came up with this neat one instruction fix for * continuations on the SPARC. It flushes the register windows so * that all the state of the process is contained in the stack. @@ -567,6 +575,13 @@ SCM_API SCM scm_call_generic_1 (SCM gf, SCM a1); return (SCM_UNPACK (gf) \ ? scm_call_generic_1 ((gf), (a1)) \ : (scm_wrong_type_arg ((subr), (pos), (a1)), SCM_UNSPECIFIED)) + +/* This form is for dispatching a subroutine. */ +#define SCM_WTA_DISPATCH_1_SUBR(subr, a1, pos) \ + return (SCM_UNPACK ((*SCM_SUBR_GENERIC (subr))) \ + ? scm_call_generic_1 ((*SCM_SUBR_GENERIC (subr)), (a1)) \ + : (scm_i_wrong_type_arg_symbol (SCM_SUBR_NAME (subr), (pos), (a1)), SCM_UNSPECIFIED)) + #define SCM_GASSERT1(cond, gf, a1, pos, subr) \ if (SCM_UNLIKELY (!(cond))) \ SCM_WTA_DISPATCH_1((gf), (a1), (pos), (subr)) diff --git a/libguile/_scm.h b/libguile/_scm.h index ff033ded0..9907adf24 100644 --- a/libguile/_scm.h +++ b/libguile/_scm.h @@ -6,18 +6,19 @@ /* 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 @@ -79,20 +81,6 @@ #include "libguile/inline.h" #include "libguile/strings.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__ @@ -170,6 +158,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 D +#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/array-handle.c b/libguile/array-handle.c new file mode 100644 index 000000000..cd5a46698 --- /dev/null +++ b/libguile/array-handle.c @@ -0,0 +1,162 @@ +/* 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 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 "libguile/_scm.h" +#include "libguile/__scm.h" + +#include "libguile/array-handle.h" + + +SCM scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_LAST + 1]; + + +#define ARRAY_IMPLS_N_STATIC_ALLOC 7 +static scm_t_array_implementation array_impls[ARRAY_IMPLS_N_STATIC_ALLOC]; +static int num_array_impls_registered = 0; + + +void +scm_i_register_array_implementation (scm_t_array_implementation *impl) +{ + if (num_array_impls_registered >= ARRAY_IMPLS_N_STATIC_ALLOC) + /* need to increase ARRAY_IMPLS_N_STATIC_ALLOC, buster */ + abort (); + else + array_impls[num_array_impls_registered++] = *impl; +} + +scm_t_array_implementation* +scm_i_array_implementation_for_obj (SCM obj) +{ + int i; + for (i = 0; i < num_array_impls_registered; i++) + if (SCM_NIMP (obj) + && (SCM_CELL_TYPE (obj) & array_impls[i].mask) == array_impls[i].tag) + return &array_impls[i]; + return NULL; +} + +void +scm_array_get_handle (SCM array, scm_t_array_handle *h) +{ + scm_t_array_implementation *impl = scm_i_array_implementation_for_obj (array); + if (!impl) + scm_wrong_type_arg_msg (NULL, 0, array, "array"); + h->array = array; + h->impl = impl; + h->base = 0; + h->ndims = 0; + h->dims = NULL; + h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM; /* have to default to + something... */ + h->elements = NULL; + h->writable_elements = NULL; + h->impl->get_handle (array, h); +} + +ssize_t +scm_array_handle_pos (scm_t_array_handle *h, SCM indices) +{ + scm_t_array_dim *s = scm_array_handle_dims (h); + ssize_t pos = 0, i; + size_t k = scm_array_handle_rank (h); + + while (k > 0 && scm_is_pair (indices)) + { + i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd); + pos += (i - s->lbnd) * s->inc; + k--; + s++; + indices = SCM_CDR (indices); + } + if (k > 0 || !scm_is_null (indices)) + scm_misc_error (NULL, "wrong number of indices, expecting ~a", + scm_list_1 (scm_from_size_t (scm_array_handle_rank (h)))); + return pos; +} + +SCM +scm_array_handle_element_type (scm_t_array_handle *h) +{ + if (h->element_type < 0 || h->element_type > SCM_ARRAY_ELEMENT_TYPE_LAST) + abort (); /* guile programming error */ + return scm_i_array_element_types[h->element_type]; +} + +void +scm_array_handle_release (scm_t_array_handle *h) +{ + /* Nothing to do here until arrays need to be reserved for real. + */ +} + +const SCM * +scm_array_handle_elements (scm_t_array_handle *h) +{ + if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) + scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); + return ((const SCM*)h->elements) + h->base; +} + +SCM * +scm_array_handle_writable_elements (scm_t_array_handle *h) +{ + if (h->element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) + scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); + return ((SCM*)h->elements) + h->base; +} + +void +scm_init_array_handle (void) +{ +#define DEFINE_ARRAY_TYPE(tag, TAG) \ + scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG] \ + = (scm_permanent_object (scm_from_locale_symbol (#tag))) + + scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_SCM] = SCM_BOOL_T; + DEFINE_ARRAY_TYPE (a, CHAR); + DEFINE_ARRAY_TYPE (b, BIT); + DEFINE_ARRAY_TYPE (vu8, VU8); + DEFINE_ARRAY_TYPE (u8, U8); + DEFINE_ARRAY_TYPE (s8, S8); + DEFINE_ARRAY_TYPE (u16, U16); + DEFINE_ARRAY_TYPE (s16, S16); + DEFINE_ARRAY_TYPE (u32, U32); + DEFINE_ARRAY_TYPE (s32, S32); + DEFINE_ARRAY_TYPE (u64, U64); + DEFINE_ARRAY_TYPE (s64, S64); + DEFINE_ARRAY_TYPE (f32, F32); + DEFINE_ARRAY_TYPE (f64, F64); + DEFINE_ARRAY_TYPE (c32, C32); + DEFINE_ARRAY_TYPE (c64, C64); + +#include "libguile/array-handle.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/array-handle.h b/libguile/array-handle.h new file mode 100644 index 000000000..caf9cefbf --- /dev/null +++ b/libguile/array-handle.h @@ -0,0 +1,129 @@ +/* classes: h_files */ + +#ifndef SCM_ARRAY_HANDLE_H +#define SCM_ARRAY_HANDLE_H + +/* Copyright (C) 1995,1996,1997,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 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" + + + +struct scm_t_array_handle; + +typedef SCM (*scm_i_t_array_ref) (struct scm_t_array_handle *, size_t); +typedef void (*scm_i_t_array_set) (struct scm_t_array_handle *, size_t, SCM); + +typedef struct +{ + scm_t_bits tag; + scm_t_bits mask; + scm_i_t_array_ref vref; + scm_i_t_array_set vset; + void (*get_handle)(SCM, struct scm_t_array_handle*); +} scm_t_array_implementation; + +#define SCM_ARRAY_IMPLEMENTATION(tag_,mask_,vref_,vset_,handle_) \ + SCM_SNARF_INIT ({ \ + scm_t_array_implementation impl; \ + impl.tag = tag_; impl.mask = mask_; \ + impl.vref = vref_; impl.vset = vset_; \ + impl.get_handle = handle_; \ + scm_i_register_array_implementation (&impl); \ + }) + + +SCM_INTERNAL void scm_i_register_array_implementation (scm_t_array_implementation *impl); +SCM_INTERNAL scm_t_array_implementation* scm_i_array_implementation_for_obj (SCM obj); + + + + +typedef struct scm_t_array_dim +{ + ssize_t lbnd; + ssize_t ubnd; + ssize_t inc; +} scm_t_array_dim; + +typedef enum { + SCM_ARRAY_ELEMENT_TYPE_SCM = 0, /* SCM values */ + SCM_ARRAY_ELEMENT_TYPE_CHAR = 1, /* characters */ + SCM_ARRAY_ELEMENT_TYPE_BIT = 2, /* packed numeric values */ + SCM_ARRAY_ELEMENT_TYPE_VU8 = 3, + SCM_ARRAY_ELEMENT_TYPE_U8 = 4, + SCM_ARRAY_ELEMENT_TYPE_S8 = 5, + SCM_ARRAY_ELEMENT_TYPE_U16 = 6, + SCM_ARRAY_ELEMENT_TYPE_S16 = 7, + SCM_ARRAY_ELEMENT_TYPE_U32 = 8, + SCM_ARRAY_ELEMENT_TYPE_S32 = 9, + SCM_ARRAY_ELEMENT_TYPE_U64 = 10, + SCM_ARRAY_ELEMENT_TYPE_S64 = 11, + SCM_ARRAY_ELEMENT_TYPE_F32 = 12, + SCM_ARRAY_ELEMENT_TYPE_F64 = 13, + SCM_ARRAY_ELEMENT_TYPE_C32 = 14, + SCM_ARRAY_ELEMENT_TYPE_C64 = 15, + SCM_ARRAY_ELEMENT_TYPE_LAST = 15, +} scm_t_array_element_type; + +SCM_INTERNAL SCM scm_i_array_element_types[]; + + +typedef struct scm_t_array_handle { + SCM array; + scm_t_array_implementation *impl; + /* `Base' is an offset into elements or writable_elements, corresponding to + the first element in the array. It would be nicer just to adjust the + elements/writable_elements pointer, but we can't because that element might + not even be byte-addressable, as is the case with bitvectors. A nicer + solution would be, well, nice. + */ + size_t base; + size_t ndims; /* ndims == the rank of the array */ + scm_t_array_dim *dims; + scm_t_array_dim dim0; + scm_t_array_element_type element_type; + const void *elements; + void *writable_elements; +} scm_t_array_handle; + +#define scm_array_handle_rank(h) ((h)->ndims) +#define scm_array_handle_dims(h) ((h)->dims) + +SCM_API void scm_array_get_handle (SCM array, scm_t_array_handle *h); +SCM_API ssize_t scm_array_handle_pos (scm_t_array_handle *h, SCM indices); +SCM_API SCM scm_array_handle_element_type (scm_t_array_handle *h); +SCM_API void scm_array_handle_release (scm_t_array_handle *h); +SCM_API const SCM* scm_array_handle_elements (scm_t_array_handle *h); +SCM_API SCM* scm_array_handle_writable_elements (scm_t_array_handle *h); + +/* See inline.h for scm_array_handle_ref and scm_array_handle_set */ + +SCM_INTERNAL void scm_init_array_handle (void); + + +#endif /* SCM_ARRAY_HANDLE_H */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/ramap.c b/libguile/array-map.c index 1bc4fdd38..fb9ceea37 100644 --- a/libguile/ramap.c +++ b/libguile/array-map.c @@ -1,25 +1,22 @@ -/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1996,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 */ -/* - HWN:FIXME:: - Someone should rename this to arraymap.c; that would reflect the - contents better. */ @@ -30,7 +27,7 @@ #include "libguile/_scm.h" #include "libguile/strings.h" -#include "libguile/unif.h" +#include "libguile/arrays.h" #include "libguile/smob.h" #include "libguile/chars.h" #include "libguile/eq.h" @@ -38,11 +35,14 @@ #include "libguile/feature.h" #include "libguile/root.h" #include "libguile/vectors.h" +#include "libguile/bitvectors.h" #include "libguile/srfi-4.h" #include "libguile/dynwind.h" +#include "libguile/generalized-arrays.h" +#include "libguile/generalized-vectors.h" #include "libguile/validate.h" -#include "libguile/ramap.h" +#include "libguile/array-map.h" typedef struct @@ -222,7 +222,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) if (!SCM_I_ARRAYP (vra0)) { size_t length = scm_c_generalized_vector_length (vra0); - vra1 = scm_i_make_ra (1, 0); + vra1 = scm_i_make_array (1); SCM_I_ARRAY_BASE (vra1) = 0; SCM_I_ARRAY_DIMS (vra1)->lbnd = 0; SCM_I_ARRAY_DIMS (vra1)->ubnd = length - 1; @@ -235,7 +235,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) for (z = lra; SCM_NIMP (z); z = SCM_CDR (z)) { ra1 = SCM_CAR (z); - vra1 = scm_i_make_ra (1, 0); + vra1 = scm_i_make_array (1); SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd; SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd; if (!SCM_I_ARRAYP (ra1)) @@ -258,7 +258,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)); case 1: gencase: /* Have to loop over all dimensions. */ - vra0 = scm_i_make_ra (1, 0); + vra0 = scm_i_make_array (1); if (SCM_I_ARRAYP (ra0)) { kmax = SCM_I_ARRAY_NDIM (ra0) - 1; @@ -293,7 +293,7 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) for (z = lra; SCM_NIMP (z); z = SCM_CDR (z)) { ra1 = SCM_CAR (z); - vra1 = scm_i_make_ra (1, 0); + vra1 = scm_i_make_array (1); SCM_I_ARRAY_DIMS (vra1)->lbnd = SCM_I_ARRAY_DIMS (vra0)->lbnd; SCM_I_ARRAY_DIMS (vra1)->ubnd = SCM_I_ARRAY_DIMS (vra0)->ubnd; if (SCM_I_ARRAYP (ra1)) @@ -1221,13 +1221,13 @@ init_raprocs (ra_iproc *subra) void -scm_init_ramap () +scm_init_array_map (void) { init_raprocs (ra_rpsubrs); init_raprocs (ra_asubrs); scm_c_define_subr (s_array_equal_p, scm_tc7_rpsubr, scm_array_equal_p); scm_smobs[SCM_TC2SMOBNUM (scm_i_tc16_array)].equalp = scm_raequal; -#include "libguile/ramap.x" +#include "libguile/array-map.x" scm_add_feature (s_scm_array_for_each); } diff --git a/libguile/ramap.h b/libguile/array-map.h index 9d870389a..a198099f3 100644 --- a/libguile/ramap.h +++ b/libguile/array-map.h @@ -1,23 +1,24 @@ /* classes: h_files */ -#ifndef SCM_RAMAP_H -#define SCM_RAMAP_H +#ifndef SCM_ARRAY_MAP_H +#define SCM_ARRAY_MAP_H -/* Copyright (C) 1995,1996,1997,2000, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,2000, 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 */ @@ -47,9 +48,9 @@ SCM_API SCM scm_array_for_each (SCM proc, SCM ra0, SCM lra); SCM_API SCM scm_array_index_map_x (SCM ra, SCM proc); SCM_API SCM scm_raequal (SCM ra0, SCM ra1); SCM_API SCM scm_array_equal_p (SCM ra0, SCM ra1); -SCM_INTERNAL void scm_init_ramap (void); +SCM_INTERNAL void scm_init_array_map (void); -#endif /* SCM_RAMAP_H */ +#endif /* SCM_ARRAY_MAP_H */ /* Local Variables: diff --git a/libguile/arrays.c b/libguile/arrays.c new file mode 100644 index 000000000..2be9ec3f0 --- /dev/null +++ b/libguile/arrays.c @@ -0,0 +1,1156 @@ +/* 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 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 <stdio.h> +#include <errno.h> +#include <string.h> + +#include "libguile/_scm.h" +#include "libguile/__scm.h" +#include "libguile/eq.h" +#include "libguile/chars.h" +#include "libguile/eval.h" +#include "libguile/fports.h" +#include "libguile/smob.h" +#include "libguile/feature.h" +#include "libguile/root.h" +#include "libguile/strings.h" +#include "libguile/srfi-13.h" +#include "libguile/srfi-4.h" +#include "libguile/vectors.h" +#include "libguile/bitvectors.h" +#include "libguile/bytevectors.h" +#include "libguile/list.h" +#include "libguile/dynwind.h" +#include "libguile/read.h" + +#include "libguile/validate.h" +#include "libguile/arrays.h" +#include "libguile/array-map.h" +#include "libguile/generalized-vectors.h" +#include "libguile/generalized-arrays.h" +#include "libguile/uniform.h" + + +scm_t_bits scm_i_tc16_array; +#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \ + (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS)) +#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \ + (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS)) + + +SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, + (SCM ra), + "Return the root vector of a shared array.") +#define FUNC_NAME s_scm_shared_array_root +{ + if (SCM_I_ARRAYP (ra)) + return SCM_I_ARRAY_V (ra); + else if (scm_is_generalized_vector (ra)) + return ra; + scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array"); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0, + (SCM ra), + "Return the root vector index of the first element in the array.") +#define FUNC_NAME s_scm_shared_array_offset +{ + scm_t_array_handle handle; + SCM res; + + scm_array_get_handle (ra, &handle); + res = scm_from_size_t (handle.base); + scm_array_handle_release (&handle); + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, + (SCM ra), + "For each dimension, return the distance between elements in the root vector.") +#define FUNC_NAME s_scm_shared_array_increments +{ + scm_t_array_handle handle; + SCM res = SCM_EOL; + size_t k; + scm_t_array_dim *s; + + scm_array_get_handle (ra, &handle); + k = scm_array_handle_rank (&handle); + s = scm_array_handle_dims (&handle); + while (k--) + res = scm_cons (scm_from_ssize_t (s[k].inc), res); + scm_array_handle_release (&handle); + return res; +} +#undef FUNC_NAME + +SCM +scm_i_make_array (int ndim) +{ + SCM ra; + SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + scm_i_tc16_array, + scm_gc_malloc ((sizeof (scm_i_t_array) + + ndim * sizeof (scm_t_array_dim)), + "array")); + SCM_I_ARRAY_V (ra) = SCM_BOOL_F; + return ra; +} + +static char s_bad_spec[] = "Bad scm_array dimension"; + + +/* Increments will still need to be set. */ + +static SCM +scm_i_shap2ra (SCM args) +{ + scm_t_array_dim *s; + SCM ra, spec, sp; + int ndim = scm_ilength (args); + if (ndim < 0) + scm_misc_error (NULL, s_bad_spec, SCM_EOL); + + ra = scm_i_make_array (ndim); + SCM_I_ARRAY_BASE (ra) = 0; + s = SCM_I_ARRAY_DIMS (ra); + for (; !scm_is_null (args); s++, args = SCM_CDR (args)) + { + spec = SCM_CAR (args); + if (scm_is_integer (spec)) + { + if (scm_to_long (spec) < 0) + scm_misc_error (NULL, s_bad_spec, SCM_EOL); + s->lbnd = 0; + s->ubnd = scm_to_long (spec) - 1; + s->inc = 1; + } + else + { + if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec))) + scm_misc_error (NULL, s_bad_spec, SCM_EOL); + s->lbnd = scm_to_long (SCM_CAR (spec)); + sp = SCM_CDR (spec); + if (!scm_is_pair (sp) + || !scm_is_integer (SCM_CAR (sp)) + || !scm_is_null (SCM_CDR (sp))) + scm_misc_error (NULL, s_bad_spec, SCM_EOL); + s->ubnd = scm_to_long (SCM_CAR (sp)); + s->inc = 1; + } + } + return ra; +} + +SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1, + (SCM type, SCM fill, SCM bounds), + "Create and return an array of type @var{type}.") +#define FUNC_NAME s_scm_make_typed_array +{ + size_t k, rlen = 1; + scm_t_array_dim *s; + SCM ra; + + 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; + } + + if (scm_is_eq (fill, SCM_UNSPECIFIED)) + fill = SCM_UNDEFINED; + + SCM_I_ARRAY_V (ra) = + scm_make_generalized_vector (type, scm_from_size_t (rlen), fill); + + 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 +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; + SCM ra; + scm_t_array_handle h; + void *base; + size_t sz; + + 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) = + scm_make_generalized_vector (type, 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.") +#define FUNC_NAME s_scm_make_array +{ + return scm_make_typed_array (SCM_BOOL_T, fill, bounds); +} +#undef FUNC_NAME + +static void +scm_i_ra_set_contp (SCM ra) +{ + size_t k = SCM_I_ARRAY_NDIM (ra); + if (k) + { + long inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc; + while (k--) + { + if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc) + { + SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra); + return; + } + inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd + - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1); + } + } + SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); +} + + +SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, + (SCM oldra, SCM mapfunc, SCM dims), + "@code{make-shared-array} can be used to create shared subarrays of other\n" + "arrays. The @var{mapper} is a function that translates coordinates in\n" + "the new array into coordinates in the old array. A @var{mapper} must be\n" + "linear, and its range must stay within the bounds of the old array, but\n" + "it can be otherwise arbitrary. A simple example:\n" + "@lisp\n" + "(define fred (make-array #f 8 8))\n" + "(define freds-diagonal\n" + " (make-shared-array fred (lambda (i) (list i i)) 8))\n" + "(array-set! freds-diagonal 'foo 3)\n" + "(array-ref fred 3 3) @result{} foo\n" + "(define freds-center\n" + " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n" + "(array-ref freds-center 0 0) @result{} foo\n" + "@end lisp") +#define FUNC_NAME s_scm_make_shared_array +{ + scm_t_array_handle old_handle; + SCM ra; + SCM inds, indptr; + SCM imap; + size_t k; + ssize_t i; + long old_base, old_min, new_min, old_max, new_max; + scm_t_array_dim *s; + + SCM_VALIDATE_REST_ARGUMENT (dims); + SCM_VALIDATE_PROC (2, mapfunc); + ra = scm_i_shap2ra (dims); + + scm_array_get_handle (oldra, &old_handle); + + if (SCM_I_ARRAYP (oldra)) + { + SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra); + old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra); + s = scm_array_handle_dims (&old_handle); + k = scm_array_handle_rank (&old_handle); + while (k--) + { + if (s[k].inc > 0) + old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; + else + old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; + } + } + else + { + SCM_I_ARRAY_V (ra) = oldra; + old_base = old_min = 0; + old_max = scm_c_generalized_vector_length (oldra) - 1; + } + + inds = SCM_EOL; + s = SCM_I_ARRAY_DIMS (ra); + for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++) + { + inds = scm_cons (scm_from_long (s[k].lbnd), inds); + if (s[k].ubnd < s[k].lbnd) + { + if (1 == SCM_I_ARRAY_NDIM (ra)) + ra = scm_make_generalized_vector (scm_array_type (ra), + SCM_INUM0, SCM_UNDEFINED); + else + SCM_I_ARRAY_V (ra) = + scm_make_generalized_vector (scm_array_type (ra), + SCM_INUM0, SCM_UNDEFINED); + scm_array_handle_release (&old_handle); + return ra; + } + } + + imap = scm_apply_0 (mapfunc, scm_reverse (inds)); + i = scm_array_handle_pos (&old_handle, imap); + SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base; + indptr = inds; + k = SCM_I_ARRAY_NDIM (ra); + while (k--) + { + if (s[k].ubnd > s[k].lbnd) + { + SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1))); + imap = scm_apply_0 (mapfunc, scm_reverse (inds)); + s[k].inc = scm_array_handle_pos (&old_handle, imap) - i; + i += s[k].inc; + if (s[k].inc > 0) + new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; + else + new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; + } + else + s[k].inc = new_max - new_min + 1; /* contiguous by default */ + indptr = SCM_CDR (indptr); + } + + scm_array_handle_release (&old_handle); + + if (old_min > new_min || old_max < new_max) + SCM_MISC_ERROR ("mapping out of range", SCM_EOL); + if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) + { + SCM v = SCM_I_ARRAY_V (ra); + size_t length = scm_c_generalized_vector_length (v); + if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd) + return v; + if (s->ubnd < s->lbnd) + return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0, + SCM_UNDEFINED); + } + scm_i_ra_set_contp (ra); + return ra; +} +#undef FUNC_NAME + + +/* args are RA . DIMS */ +SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, + (SCM ra, SCM args), + "Return an array sharing contents with @var{array}, but with\n" + "dimensions arranged in a different order. There must be one\n" + "@var{dim} argument for each dimension of @var{array}.\n" + "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n" + "and the rank of the array to be returned. Each integer in that\n" + "range must appear at least once in the argument list.\n" + "\n" + "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n" + "dimensions in the array to be returned, their positions in the\n" + "argument list to dimensions of @var{array}. Several @var{dim}s\n" + "may have the same value, in which case the returned array will\n" + "have smaller rank than @var{array}.\n" + "\n" + "@lisp\n" + "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n" + "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n" + "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n" + " #2((a 4) (b 5) (c 6))\n" + "@end lisp") +#define FUNC_NAME s_scm_transpose_array +{ + SCM res, vargs; + scm_t_array_dim *s, *r; + int ndim, i, k; + + SCM_VALIDATE_REST_ARGUMENT (args); + SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME); + + if (scm_is_generalized_vector (ra)) + { + /* Make sure that we are called with a single zero as + arguments. + */ + if (scm_is_null (args) || !scm_is_null (SCM_CDR (args))) + SCM_WRONG_NUM_ARGS (); + SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i); + SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0); + return ra; + } + + if (SCM_I_ARRAYP (ra)) + { + vargs = scm_vector (args); + if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra)) + SCM_WRONG_NUM_ARGS (); + ndim = 0; + for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++) + { + i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k), + 0, SCM_I_ARRAY_NDIM(ra)); + if (ndim < i) + ndim = i; + } + ndim++; + res = scm_i_make_array (ndim); + SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra); + SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra); + for (k = ndim; k--;) + { + SCM_I_ARRAY_DIMS (res)[k].lbnd = 0; + SCM_I_ARRAY_DIMS (res)[k].ubnd = -1; + } + for (k = SCM_I_ARRAY_NDIM (ra); k--;) + { + i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k)); + s = &(SCM_I_ARRAY_DIMS (ra)[k]); + r = &(SCM_I_ARRAY_DIMS (res)[i]); + if (r->ubnd < r->lbnd) + { + r->lbnd = s->lbnd; + r->ubnd = s->ubnd; + r->inc = s->inc; + ndim--; + } + else + { + if (r->ubnd > s->ubnd) + r->ubnd = s->ubnd; + if (r->lbnd < s->lbnd) + { + SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc; + r->lbnd = s->lbnd; + } + r->inc += s->inc; + } + } + if (ndim > 0) + SCM_MISC_ERROR ("bad argument list", SCM_EOL); + scm_i_ra_set_contp (res); + return res; + } + + scm_wrong_type_arg_msg (NULL, 0, ra, "array"); +} +#undef FUNC_NAME + +/* attempts to unroll an array into a one-dimensional array. + returns the unrolled array or #f if it can't be done. */ + /* if strict is not SCM_UNDEFINED, return #f if returned array + wouldn't have contiguous elements. */ +SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, + (SCM ra, SCM strict), + "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n" + "without changing their order (last subscript changing fastest), then\n" + "@code{array-contents} returns that shared array, otherwise it returns\n" + "@code{#f}. All arrays made by @var{make-array} and\n" + "@var{make-uniform-array} may be unrolled, some arrays made by\n" + "@var{make-shared-array} may not be.\n\n" + "If the optional argument @var{strict} is provided, a shared array will\n" + "be returned only if its elements are stored internally contiguous in\n" + "memory.") +#define FUNC_NAME s_scm_array_contents +{ + SCM sra; + + if (scm_is_generalized_vector (ra)) + return ra; + + if (SCM_I_ARRAYP (ra)) + { + size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1; + if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra)) + return SCM_BOOL_F; + for (k = 0; k < ndim; k++) + len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; + if (!SCM_UNBNDP (strict) && scm_is_true (strict)) + { + if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc)) + return SCM_BOOL_F; + if (scm_is_bitvector (SCM_I_ARRAY_V (ra))) + { + if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) || + SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT || + len % SCM_LONG_BIT) + return SCM_BOOL_F; + } + } + + { + SCM v = SCM_I_ARRAY_V (ra); + size_t length = scm_c_generalized_vector_length (v); + if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc) + return v; + } + + sra = scm_i_make_array (1); + SCM_I_ARRAY_DIMS (sra)->lbnd = 0; + SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1; + SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra); + SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra); + SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1); + return sra; + } + else + scm_wrong_type_arg_msg (NULL, 0, ra, "array"); +} +#undef FUNC_NAME + + +SCM +scm_ra2contig (SCM ra, int copy) +{ + SCM ret; + long inc = 1; + size_t k, len = 1; + for (k = SCM_I_ARRAY_NDIM (ra); k--;) + len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; + k = SCM_I_ARRAY_NDIM (ra); + if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k - 1].inc))) + { + if (!scm_is_bitvector (SCM_I_ARRAY_V (ra))) + return ra; + if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) && + 0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT && + 0 == len % SCM_LONG_BIT)) + return ra; + } + ret = scm_i_make_array (k); + SCM_I_ARRAY_BASE (ret) = 0; + while (k--) + { + SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd; + SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd; + SCM_I_ARRAY_DIMS (ret)[k].inc = inc; + inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; + } + SCM_I_ARRAY_V (ret) = scm_make_generalized_vector (scm_array_type (ra), + scm_from_long (inc), + SCM_UNDEFINED); + if (copy) + scm_array_copy_x (ra, ret); + return ret; +} + + + +SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, + (SCM ura, SCM port_or_fd, SCM start, SCM end), + "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n" + "Attempt to read all elements of @var{ura}, in lexicographic order, as\n" + "binary objects from @var{port-or-fdes}.\n" + "If an end of file is encountered,\n" + "the objects up to that point are put into @var{ura}\n" + "(starting at the beginning) and the remainder of the array is\n" + "unchanged.\n\n" + "The optional arguments @var{start} and @var{end} allow\n" + "a specified region of a vector (or linearized array) to be read,\n" + "leaving the remainder of the vector unchanged.\n\n" + "@code{uniform-array-read!} returns the number of objects read.\n" + "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n" + "returned by @code{(current-input-port)}.") +#define FUNC_NAME s_scm_uniform_array_read_x +{ + if (SCM_UNBNDP (port_or_fd)) + port_or_fd = scm_current_input_port (); + + if (scm_is_uniform_vector (ura)) + { + return scm_uniform_vector_read_x (ura, port_or_fd, start, end); + } + else if (SCM_I_ARRAYP (ura)) + { + size_t base, vlen, cstart, cend; + SCM cra, ans; + + cra = scm_ra2contig (ura, 0); + base = SCM_I_ARRAY_BASE (cra); + vlen = SCM_I_ARRAY_DIMS (cra)->inc * + (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1); + + cstart = 0; + cend = vlen; + if (!SCM_UNBNDP (start)) + { + cstart = scm_to_unsigned_integer (start, 0, vlen); + if (!SCM_UNBNDP (end)) + cend = scm_to_unsigned_integer (end, cstart, vlen); + } + + ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd, + scm_from_size_t (base + cstart), + scm_from_size_t (base + cend)); + + if (!scm_is_eq (cra, ura)) + scm_array_copy_x (cra, ura); + return ans; + } + else + scm_wrong_type_arg_msg (NULL, 0, ura, "array"); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, + (SCM ura, SCM port_or_fd, SCM start, SCM end), + "Writes all elements of @var{ura} as binary objects to\n" + "@var{port-or-fdes}.\n\n" + "The optional arguments @var{start}\n" + "and @var{end} allow\n" + "a specified region of a vector (or linearized array) to be written.\n\n" + "The number of objects actually written is returned.\n" + "@var{port-or-fdes} may be\n" + "omitted, in which case it defaults to the value returned by\n" + "@code{(current-output-port)}.") +#define FUNC_NAME s_scm_uniform_array_write +{ + if (SCM_UNBNDP (port_or_fd)) + port_or_fd = scm_current_output_port (); + + if (scm_is_uniform_vector (ura)) + { + return scm_uniform_vector_write (ura, port_or_fd, start, end); + } + else if (SCM_I_ARRAYP (ura)) + { + size_t base, vlen, cstart, cend; + SCM cra, ans; + + cra = scm_ra2contig (ura, 1); + base = SCM_I_ARRAY_BASE (cra); + vlen = SCM_I_ARRAY_DIMS (cra)->inc * + (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1); + + cstart = 0; + cend = vlen; + if (!SCM_UNBNDP (start)) + { + cstart = scm_to_unsigned_integer (start, 0, vlen); + if (!SCM_UNBNDP (end)) + cend = scm_to_unsigned_integer (end, cstart, vlen); + } + + ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd, + scm_from_size_t (base + cstart), + scm_from_size_t (base + cend)); + + return ans; + } + else + scm_wrong_type_arg_msg (NULL, 0, ura, "array"); +} +#undef FUNC_NAME + + +static void +list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k) +{ + if (k == scm_array_handle_rank (handle)) + scm_array_handle_set (handle, pos, lst); + else + { + scm_t_array_dim *dim = scm_array_handle_dims (handle) + k; + ssize_t inc = dim->inc; + size_t len = 1 + dim->ubnd - dim->lbnd, n; + char *errmsg = NULL; + + n = len; + while (n > 0 && scm_is_pair (lst)) + { + list_to_array (SCM_CAR (lst), handle, pos, k + 1); + pos += inc; + lst = SCM_CDR (lst); + n -= 1; + } + if (n != 0) + errmsg = "too few elements for array dimension ~a, need ~a"; + if (!scm_is_null (lst)) + errmsg = "too many elements for array dimension ~a, want ~a"; + if (errmsg) + scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k), + scm_from_size_t (len))); + } +} + + +SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0, + (SCM type, SCM shape, SCM lst), + "Return an array of the type @var{type}\n" + "with elements the same as those of @var{lst}.\n" + "\n" + "The argument @var{shape} determines the number of dimensions\n" + "of the array and their shape. It is either an exact integer,\n" + "giving the\n" + "number of dimensions directly, or a list whose length\n" + "specifies the number of dimensions and each element specified\n" + "the lower and optionally the upper bound of the corresponding\n" + "dimension.\n" + "When the element is list of two elements, these elements\n" + "give the lower and upper bounds. When it is an exact\n" + "integer, it gives only the lower bound.") +#define FUNC_NAME s_scm_list_to_typed_array +{ + SCM row; + SCM ra; + scm_t_array_handle handle; + + row = lst; + if (scm_is_integer (shape)) + { + size_t k = scm_to_size_t (shape); + shape = SCM_EOL; + while (k-- > 0) + { + shape = scm_cons (scm_length (row), shape); + if (k > 0 && !scm_is_null (row)) + row = scm_car (row); + } + } + else + { + SCM shape_spec = shape; + shape = SCM_EOL; + while (1) + { + SCM spec = scm_car (shape_spec); + if (scm_is_pair (spec)) + shape = scm_cons (spec, shape); + else + shape = scm_cons (scm_list_2 (spec, + scm_sum (scm_sum (spec, + scm_length (row)), + scm_from_int (-1))), + shape); + shape_spec = scm_cdr (shape_spec); + if (scm_is_pair (shape_spec)) + { + if (!scm_is_null (row)) + row = scm_car (row); + } + else + break; + } + } + + ra = scm_make_typed_array (type, SCM_UNSPECIFIED, + scm_reverse_x (shape, SCM_EOL)); + + scm_array_get_handle (ra, &handle); + list_to_array (lst, &handle, 0, 0); + scm_array_handle_release (&handle); + + return ra; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0, + (SCM ndim, SCM lst), + "Return an array with elements the same as those of @var{lst}.") +#define FUNC_NAME s_scm_list_to_array +{ + return scm_list_to_typed_array (SCM_BOOL_T, ndim, lst); +} +#undef FUNC_NAME + +/* Print dimension DIM of ARRAY. + */ + +static int +scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos, + SCM port, scm_print_state *pstate) +{ + if (dim == h->ndims) + scm_iprin1 (scm_array_handle_ref (h, pos), port, pstate); + else + { + ssize_t i; + scm_putc ('(', port); + for (i = h->dims[dim].lbnd; i <= h->dims[dim].ubnd; + i++, pos += h->dims[dim].inc) + { + scm_i_print_array_dimension (h, dim+1, pos, port, pstate); + if (i < h->dims[dim].ubnd) + scm_putc (' ', port); + } + scm_putc (')', port); + } + return 1; +} + +/* Print an array. +*/ + +static int +scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) +{ + scm_t_array_handle h; + long i; + int print_lbnds = 0, zero_size = 0, print_lens = 0; + + scm_array_get_handle (array, &h); + + scm_putc ('#', port); + if (h.ndims != 1 || h.dims[0].lbnd != 0) + scm_intprint (h.ndims, 10, port); + if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM) + scm_write (scm_array_handle_element_type (&h), port); + + for (i = 0; i < h.ndims; i++) + { + if (h.dims[i].lbnd != 0) + print_lbnds = 1; + if (h.dims[i].ubnd - h.dims[i].lbnd + 1 == 0) + zero_size = 1; + else if (zero_size) + print_lens = 1; + } + + if (print_lbnds || print_lens) + for (i = 0; i < h.ndims; i++) + { + if (print_lbnds) + { + scm_putc ('@', port); + scm_intprint (h.dims[i].lbnd, 10, port); + } + if (print_lens) + { + scm_putc (':', port); + scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1, + 10, port); + } + } + + if (h.ndims == 0) + { + /* Rank zero arrays, which are really just scalars, are printed + specially. The consequent way would be to print them as + + #0 OBJ + + where OBJ is the printed representation of the scalar, but we + print them instead as + + #0(OBJ) + + to make them look less strange. + + Just printing them as + + OBJ + + would be correct in a way as well, but zero rank arrays are + not really the same as Scheme values since they are boxed and + can be modified with array-set!, say. + */ + scm_putc ('(', port); + scm_i_print_array_dimension (&h, 0, 0, port, pstate); + scm_putc (')', port); + return 1; + } + else + return scm_i_print_array_dimension (&h, 0, 0, port, pstate); +} + +/* Read an array. This function can also read vectors and uniform + vectors. Also, the conflict between '#f' and '#f32' and '#f64' is + handled here. + + C is the first character read after the '#'. +*/ + +static SCM +tag_to_type (const char *tag, SCM port) +{ + if (*tag == '\0') + return SCM_BOOL_T; + else + return scm_from_locale_symbol (tag); +} + +static int +read_decimal_integer (SCM port, int c, ssize_t *resp) +{ + ssize_t sign = 1; + ssize_t res = 0; + int got_it = 0; + + if (c == '-') + { + sign = -1; + c = scm_getc (port); + } + + while ('0' <= c && c <= '9') + { + res = 10*res + c-'0'; + got_it = 1; + c = scm_getc (port); + } + + if (got_it) + *resp = sign * res; + return c; +} + +SCM +scm_i_read_array (SCM port, int c) +{ + ssize_t rank; + int got_rank; + char tag[80]; + int tag_len; + + SCM shape = SCM_BOOL_F, elements; + + /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but + the array code can not deal with zero-length dimensions yet, and + we want to allow zero-length vectors, of course. + */ + if (c == '(') + { + scm_ungetc (c, port); + return scm_vector (scm_read (port)); + } + + /* Disambiguate between '#f' and uniform floating point vectors. + */ + if (c == 'f') + { + c = scm_getc (port); + if (c != '3' && c != '6') + { + if (c != EOF) + scm_ungetc (c, port); + return SCM_BOOL_F; + } + rank = 1; + got_rank = 1; + tag[0] = 'f'; + tag_len = 1; + goto continue_reading_tag; + } + + /* Read rank. + */ + rank = 1; + c = read_decimal_integer (port, c, &rank); + if (rank < 0) + scm_i_input_error (NULL, port, "array rank must be non-negative", + SCM_EOL); + + /* Read tag. + */ + tag_len = 0; + continue_reading_tag: + while (c != EOF && c != '(' && c != '@' && c != ':' && tag_len < 80) + { + tag[tag_len++] = c; + c = scm_getc (port); + } + tag[tag_len] = '\0'; + + /* Read shape. + */ + if (c == '@' || c == ':') + { + shape = SCM_EOL; + + do + { + ssize_t lbnd = 0, len = 0; + SCM s; + + if (c == '@') + { + c = scm_getc (port); + c = read_decimal_integer (port, c, &lbnd); + } + + s = scm_from_ssize_t (lbnd); + + if (c == ':') + { + c = scm_getc (port); + c = read_decimal_integer (port, c, &len); + if (len < 0) + scm_i_input_error (NULL, port, + "array length must be non-negative", + SCM_EOL); + + s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1)); + } + + shape = scm_cons (s, shape); + } while (c == '@' || c == ':'); + + shape = scm_reverse_x (shape, SCM_EOL); + } + + /* Read nested lists of elements. + */ + if (c != '(') + scm_i_input_error (NULL, port, + "missing '(' in vector or array literal", + SCM_EOL); + scm_ungetc (c, port); + elements = scm_read (port); + + if (scm_is_false (shape)) + shape = scm_from_ssize_t (rank); + else if (scm_ilength (shape) != rank) + scm_i_input_error + (NULL, port, + "the number of shape specifications must match the array rank", + SCM_EOL); + + /* Handle special print syntax of rank zero arrays; see + scm_i_print_array for a rationale. + */ + if (rank == 0) + { + if (!scm_is_pair (elements)) + scm_i_input_error (NULL, port, + "too few elements in array literal, need 1", + SCM_EOL); + if (!scm_is_null (SCM_CDR (elements))) + scm_i_input_error (NULL, port, + "too many elements in array literal, want 1", + SCM_EOL); + elements = SCM_CAR (elements); + } + + /* Construct array. + */ + return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements); +} + + +static SCM +array_mark (SCM ptr) +{ + return SCM_I_ARRAY_V (ptr); +} + +static size_t +array_free (SCM ptr) +{ + scm_gc_free (SCM_I_ARRAY_MEM (ptr), + (sizeof (scm_i_t_array) + + SCM_I_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)), + "array"); + return 0; +} + +static SCM +array_handle_ref (scm_t_array_handle *h, size_t pos) +{ + return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h->array), pos); +} + +static void +array_handle_set (scm_t_array_handle *h, size_t pos, SCM val) +{ + scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h->array), pos, val); +} + +/* FIXME: should be handle for vect? maybe not, because of dims */ +static void +array_get_handle (SCM array, scm_t_array_handle *h) +{ + scm_t_array_handle vh; + scm_array_get_handle (SCM_I_ARRAY_V (array), &vh); + h->element_type = vh.element_type; + h->elements = vh.elements; + h->writable_elements = vh.writable_elements; + scm_array_handle_release (&vh); + + h->dims = SCM_I_ARRAY_DIMS (array); + h->ndims = SCM_I_ARRAY_NDIM (array); + h->base = SCM_I_ARRAY_BASE (array); +} + +SCM_ARRAY_IMPLEMENTATION (scm_i_tc16_array, 0xffff, + array_handle_ref, array_handle_set, + array_get_handle); + +void +scm_init_arrays () +{ + scm_i_tc16_array = scm_make_smob_type ("array", 0); + scm_set_smob_mark (scm_i_tc16_array, array_mark); + scm_set_smob_free (scm_i_tc16_array, array_free); + scm_set_smob_print (scm_i_tc16_array, scm_i_print_array); + scm_set_smob_equalp (scm_i_tc16_array, scm_array_equal_p); + + scm_add_feature ("array"); + +#include "libguile/arrays.x" + +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/arrays.h b/libguile/arrays.h new file mode 100644 index 000000000..35e5471bf --- /dev/null +++ b/libguile/arrays.h @@ -0,0 +1,91 @@ +/* classes: h_files */ + +#ifndef SCM_ARRAY_H +#define SCM_ARRAY_H + +/* Copyright (C) 1995,1996,1997,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 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" +#include "libguile/print.h" + + + +/* Multidimensional arrays. Woo hoo! + Also see .... + */ + + +/** Arrays */ + +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_shared_array_root (SCM ra); +SCM_API SCM scm_shared_array_offset (SCM ra); +SCM_API SCM scm_shared_array_increments (SCM ra); +SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims); +SCM_API SCM scm_transpose_array (SCM ra, SCM args); +SCM_API SCM scm_array_contents (SCM ra, SCM strict); +SCM_API SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd, + SCM start, SCM end); +SCM_API SCM scm_uniform_array_write (SCM v, SCM port_or_fd, + SCM start, SCM end); +SCM_API SCM scm_list_to_array (SCM ndim, SCM lst); +SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst); + +SCM_API SCM scm_ra2contig (SCM ra, int copy); + +/* internal. */ + +typedef struct scm_i_t_array +{ + SCM v; /* the contents of the array, e.g., a vector or uniform vector. */ + unsigned long base; +} scm_i_t_array; + +SCM_API scm_t_bits scm_i_tc16_array; + +#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 16) + +#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_i_tc16_array, a) +#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 17)) +#define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0(x) & SCM_I_ARRAY_FLAG_CONTIGUOUS) + +#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_CELL_WORD_1 (a)) +#define SCM_I_ARRAY_V(a) (SCM_I_ARRAY_MEM (a)->v) +#define SCM_I_ARRAY_BASE(a) (SCM_I_ARRAY_MEM (a)->base) +#define SCM_I_ARRAY_DIMS(a) \ + ((scm_t_array_dim *)((char *) SCM_I_ARRAY_MEM (a) + sizeof (scm_i_t_array))) + +SCM_INTERNAL SCM scm_i_make_array (int ndim); +SCM_INTERNAL SCM scm_i_read_array (SCM port, int c); + +SCM_INTERNAL void scm_init_arrays (void); + +#endif /* SCM_ARRAYS_H */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ 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 798ade197..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 @@ -467,8 +468,21 @@ static void display_backtrace_get_file_line (SCM frame, SCM *file, SCM *line) { SCM source = SCM_FRAME_SOURCE (frame); - *file = SCM_MEMOIZEDP (source) ? scm_source_property (source, scm_sym_filename) : SCM_BOOL_F; - *line = (SCM_MEMOIZEDP (source)) ? scm_source_property (source, scm_sym_line) : SCM_BOOL_F; + *file = *line = SCM_BOOL_F; + if (SCM_MEMOIZEDP (source)) + { + *file = scm_source_property (source, scm_sym_filename); + *line = scm_source_property (source, scm_sym_line); + } + else if (scm_is_pair (source) + && scm_is_pair (scm_cdr (source)) + && scm_is_pair (scm_cddr (source)) + && !scm_is_pair (scm_cdddr (source))) + { + /* (addr . (filename . (line . column))), from vm compilation */ + *file = scm_cadr (source); + *line = scm_caddr (source); + } } static void 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/bitvectors.c b/libguile/bitvectors.c new file mode 100644 index 000000000..f1d8473d9 --- /dev/null +++ b/libguile/bitvectors.c @@ -0,0 +1,910 @@ +/* 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 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 <string.h> + +#include "libguile/_scm.h" +#include "libguile/__scm.h" +#include "libguile/smob.h" +#include "libguile/strings.h" +#include "libguile/array-handle.h" +#include "libguile/bitvectors.h" +#include "libguile/arrays.h" +#include "libguile/generalized-vectors.h" +#include "libguile/srfi-4.h" + +/* Bit vectors. Would be nice if they were implemented on top of bytevectors, + * but alack, all we have is this crufty C. + */ + +static scm_t_bits scm_tc16_bitvector; + +#define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj)) +#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj)) +#define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj)) + +static size_t +bitvector_free (SCM vec) +{ + scm_gc_free (BITVECTOR_BITS (vec), + sizeof (scm_t_uint32) * ((BITVECTOR_LENGTH (vec)+31)/32), + "bitvector"); + return 0; +} + +static int +bitvector_print (SCM vec, SCM port, scm_print_state *pstate) +{ + size_t bit_len = BITVECTOR_LENGTH (vec); + size_t word_len = (bit_len+31)/32; + scm_t_uint32 *bits = BITVECTOR_BITS (vec); + size_t i, j; + + scm_puts ("#*", port); + for (i = 0; i < word_len; i++, bit_len -= 32) + { + scm_t_uint32 mask = 1; + for (j = 0; j < 32 && j < bit_len; j++, mask <<= 1) + scm_putc ((bits[i] & mask)? '1' : '0', port); + } + + return 1; +} + +static SCM +bitvector_equalp (SCM vec1, SCM vec2) +{ + size_t bit_len = BITVECTOR_LENGTH (vec1); + size_t word_len = (bit_len + 31) / 32; + scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - bit_len); + scm_t_uint32 *bits1 = BITVECTOR_BITS (vec1); + scm_t_uint32 *bits2 = BITVECTOR_BITS (vec2); + + /* compare lengths */ + if (BITVECTOR_LENGTH (vec2) != bit_len) + return SCM_BOOL_F; + /* avoid underflow in word_len-1 below. */ + if (bit_len == 0) + return SCM_BOOL_T; + /* compare full words */ + if (memcmp (bits1, bits2, sizeof (scm_t_uint32) * (word_len-1))) + return SCM_BOOL_F; + /* compare partial last words */ + if ((bits1[word_len-1] & last_mask) != (bits2[word_len-1] & last_mask)) + return SCM_BOOL_F; + return SCM_BOOL_T; +} + +int +scm_is_bitvector (SCM vec) +{ + return IS_BITVECTOR (vec); +} + +SCM_DEFINE (scm_bitvector_p, "bitvector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} when @var{obj} is a bitvector, else\n" + "return @code{#f}.") +#define FUNC_NAME s_scm_bitvector_p +{ + return scm_from_bool (scm_is_bitvector (obj)); +} +#undef FUNC_NAME + +SCM +scm_c_make_bitvector (size_t len, SCM fill) +{ + size_t word_len = (len + 31) / 32; + scm_t_uint32 *bits; + SCM res; + + bits = scm_gc_malloc (sizeof (scm_t_uint32) * word_len, + "bitvector"); + SCM_NEWSMOB2 (res, scm_tc16_bitvector, bits, len); + + if (!SCM_UNBNDP (fill)) + scm_bitvector_fill_x (res, fill); + + return res; +} + +SCM_DEFINE (scm_make_bitvector, "make-bitvector", 1, 1, 0, + (SCM len, SCM fill), + "Create a new bitvector of length @var{len} and\n" + "optionally initialize all elements to @var{fill}.") +#define FUNC_NAME s_scm_make_bitvector +{ + return scm_c_make_bitvector (scm_to_size_t (len), fill); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bitvector, "bitvector", 0, 0, 1, + (SCM bits), + "Create a new bitvector with the arguments as elements.") +#define FUNC_NAME s_scm_bitvector +{ + return scm_list_to_bitvector (bits); +} +#undef FUNC_NAME + +size_t +scm_c_bitvector_length (SCM vec) +{ + scm_assert_smob_type (scm_tc16_bitvector, vec); + return BITVECTOR_LENGTH (vec); +} + +SCM_DEFINE (scm_bitvector_length, "bitvector-length", 1, 0, 0, + (SCM vec), + "Return the length of the bitvector @var{vec}.") +#define FUNC_NAME s_scm_bitvector_length +{ + return scm_from_size_t (scm_c_bitvector_length (vec)); +} +#undef FUNC_NAME + +const scm_t_uint32 * +scm_array_handle_bit_elements (scm_t_array_handle *h) +{ + return scm_array_handle_bit_writable_elements (h); +} + +scm_t_uint32 * +scm_array_handle_bit_writable_elements (scm_t_array_handle *h) +{ + SCM vec = h->array; + if (SCM_I_ARRAYP (vec)) + vec = SCM_I_ARRAY_V (vec); + if (IS_BITVECTOR (vec)) + return BITVECTOR_BITS (vec) + h->base/32; + scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array"); +} + +size_t +scm_array_handle_bit_elements_offset (scm_t_array_handle *h) +{ + return h->base % 32; +} + +const scm_t_uint32 * +scm_bitvector_elements (SCM vec, + scm_t_array_handle *h, + size_t *offp, + size_t *lenp, + ssize_t *incp) +{ + return scm_bitvector_writable_elements (vec, h, offp, lenp, incp); +} + + +scm_t_uint32 * +scm_bitvector_writable_elements (SCM vec, + scm_t_array_handle *h, + size_t *offp, + size_t *lenp, + ssize_t *incp) +{ + scm_generalized_vector_get_handle (vec, h); + if (offp) + { + scm_t_array_dim *dim = scm_array_handle_dims (h); + *offp = scm_array_handle_bit_elements_offset (h); + *lenp = dim->ubnd - dim->lbnd + 1; + *incp = dim->inc; + } + return scm_array_handle_bit_writable_elements (h); +} + +SCM +scm_c_bitvector_ref (SCM vec, size_t idx) +{ + scm_t_array_handle handle; + const scm_t_uint32 *bits; + + if (IS_BITVECTOR (vec)) + { + if (idx >= BITVECTOR_LENGTH (vec)) + scm_out_of_range (NULL, scm_from_size_t (idx)); + bits = BITVECTOR_BITS(vec); + return scm_from_bool (bits[idx/32] & (1L << (idx%32))); + } + else + { + SCM res; + size_t len, off; + ssize_t inc; + + bits = scm_bitvector_elements (vec, &handle, &off, &len, &inc); + if (idx >= len) + scm_out_of_range (NULL, scm_from_size_t (idx)); + idx = idx*inc + off; + res = scm_from_bool (bits[idx/32] & (1L << (idx%32))); + scm_array_handle_release (&handle); + return res; + } +} + +SCM_DEFINE (scm_bitvector_ref, "bitvector-ref", 2, 0, 0, + (SCM vec, SCM idx), + "Return the element at index @var{idx} of the bitvector\n" + "@var{vec}.") +#define FUNC_NAME s_scm_bitvector_ref +{ + return scm_c_bitvector_ref (vec, scm_to_size_t (idx)); +} +#undef FUNC_NAME + +void +scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val) +{ + scm_t_array_handle handle; + scm_t_uint32 *bits, mask; + + if (IS_BITVECTOR (vec)) + { + if (idx >= BITVECTOR_LENGTH (vec)) + scm_out_of_range (NULL, scm_from_size_t (idx)); + bits = BITVECTOR_BITS(vec); + } + else + { + size_t len, off; + ssize_t inc; + + bits = scm_bitvector_writable_elements (vec, &handle, &off, &len, &inc); + if (idx >= len) + scm_out_of_range (NULL, scm_from_size_t (idx)); + idx = idx*inc + off; + } + + mask = 1L << (idx%32); + if (scm_is_true (val)) + bits[idx/32] |= mask; + else + bits[idx/32] &= ~mask; + + if (!IS_BITVECTOR (vec)) + scm_array_handle_release (&handle); +} + +SCM_DEFINE (scm_bitvector_set_x, "bitvector-set!", 3, 0, 0, + (SCM vec, SCM idx, SCM val), + "Set the element at index @var{idx} of the bitvector\n" + "@var{vec} when @var{val} is true, else clear it.") +#define FUNC_NAME s_scm_bitvector_set_x +{ + scm_c_bitvector_set_x (vec, scm_to_size_t (idx), val); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bitvector_fill_x, "bitvector-fill!", 2, 0, 0, + (SCM vec, SCM val), + "Set all elements of the bitvector\n" + "@var{vec} when @var{val} is true, else clear them.") +#define FUNC_NAME s_scm_bitvector_fill_x +{ + scm_t_array_handle handle; + size_t off, len; + ssize_t inc; + scm_t_uint32 *bits; + + bits = scm_bitvector_writable_elements (vec, &handle, + &off, &len, &inc); + + if (off == 0 && inc == 1 && len > 0) + { + /* the usual case + */ + size_t word_len = (len + 31) / 32; + scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len); + + if (scm_is_true (val)) + { + memset (bits, 0xFF, sizeof(scm_t_uint32)*(word_len-1)); + bits[word_len-1] |= last_mask; + } + else + { + memset (bits, 0x00, sizeof(scm_t_uint32)*(word_len-1)); + bits[word_len-1] &= ~last_mask; + } + } + else + { + size_t i; + for (i = 0; i < len; i++) + scm_array_handle_set (&handle, i*inc, val); + } + + scm_array_handle_release (&handle); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_list_to_bitvector, "list->bitvector", 1, 0, 0, + (SCM list), + "Return a new bitvector initialized with the elements\n" + "of @var{list}.") +#define FUNC_NAME s_scm_list_to_bitvector +{ + size_t bit_len = scm_to_size_t (scm_length (list)); + SCM vec = scm_c_make_bitvector (bit_len, SCM_UNDEFINED); + size_t word_len = (bit_len+31)/32; + scm_t_array_handle handle; + scm_t_uint32 *bits = scm_bitvector_writable_elements (vec, &handle, + NULL, NULL, NULL); + size_t i, j; + + for (i = 0; i < word_len && scm_is_pair (list); i++, bit_len -= 32) + { + scm_t_uint32 mask = 1; + bits[i] = 0; + for (j = 0; j < 32 && j < bit_len; + j++, mask <<= 1, list = SCM_CDR (list)) + if (scm_is_true (SCM_CAR (list))) + bits[i] |= mask; + } + + scm_array_handle_release (&handle); + + return vec; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bitvector_to_list, "bitvector->list", 1, 0, 0, + (SCM vec), + "Return a new list initialized with the elements\n" + "of the bitvector @var{vec}.") +#define FUNC_NAME s_scm_bitvector_to_list +{ + scm_t_array_handle handle; + size_t off, len; + ssize_t inc; + scm_t_uint32 *bits; + SCM res = SCM_EOL; + + bits = scm_bitvector_writable_elements (vec, &handle, + &off, &len, &inc); + + if (off == 0 && inc == 1) + { + /* the usual case + */ + size_t word_len = (len + 31) / 32; + size_t i, j; + + for (i = 0; i < word_len; i++, len -= 32) + { + scm_t_uint32 mask = 1; + for (j = 0; j < 32 && j < len; j++, mask <<= 1) + res = scm_cons ((bits[i] & mask)? SCM_BOOL_T : SCM_BOOL_F, res); + } + } + else + { + size_t i; + for (i = 0; i < len; i++) + res = scm_cons (scm_array_handle_ref (&handle, i*inc), res); + } + + scm_array_handle_release (&handle); + + return scm_reverse_x (res, SCM_EOL); +} +#undef FUNC_NAME + +/* From mmix-arith.w by Knuth. + + Here's a fun way to count the number of bits in a tetrabyte. + + [This classical trick is called the ``Gillies--Miller method for + sideways addition'' in {\sl The Preparation of Programs for an + Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second + edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of + the tricks used here were suggested by Balbir Singh, Peter + Rossmanith, and Stefan Schwoon.] +*/ + +static size_t +count_ones (scm_t_uint32 x) +{ + x=x-((x>>1)&0x55555555); + x=(x&0x33333333)+((x>>2)&0x33333333); + x=(x+(x>>4))&0x0f0f0f0f; + x=x+(x>>8); + return (x+(x>>16)) & 0xff; +} + +SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, + (SCM b, SCM bitvector), + "Return the number of occurrences of the boolean @var{b} in\n" + "@var{bitvector}.") +#define FUNC_NAME s_scm_bit_count +{ + scm_t_array_handle handle; + size_t off, len; + ssize_t inc; + scm_t_uint32 *bits; + int bit = scm_to_bool (b); + size_t count = 0; + + bits = scm_bitvector_writable_elements (bitvector, &handle, + &off, &len, &inc); + + if (off == 0 && inc == 1 && len > 0) + { + /* the usual case + */ + size_t word_len = (len + 31) / 32; + scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len); + size_t i; + + for (i = 0; i < word_len-1; i++) + count += count_ones (bits[i]); + count += count_ones (bits[i] & last_mask); + } + else + { + size_t i; + for (i = 0; i < len; i++) + if (scm_is_true (scm_array_handle_ref (&handle, i*inc))) + count++; + } + + scm_array_handle_release (&handle); + + return scm_from_size_t (bit? count : len-count); +} +#undef FUNC_NAME + +/* returns 32 for x == 0. +*/ +static size_t +find_first_one (scm_t_uint32 x) +{ + size_t pos = 0; + /* do a binary search in x. */ + if ((x & 0xFFFF) == 0) + x >>= 16, pos += 16; + if ((x & 0xFF) == 0) + x >>= 8, pos += 8; + if ((x & 0xF) == 0) + x >>= 4, pos += 4; + if ((x & 0x3) == 0) + x >>= 2, pos += 2; + if ((x & 0x1) == 0) + pos += 1; + return pos; +} + +SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, + (SCM item, SCM v, SCM k), + "Return the index of the first occurrance of @var{item} in bit\n" + "vector @var{v}, starting from @var{k}. If there is no\n" + "@var{item} entry between @var{k} and the end of\n" + "@var{bitvector}, then return @code{#f}. For example,\n" + "\n" + "@example\n" + "(bit-position #t #*000101 0) @result{} 3\n" + "(bit-position #f #*0001111 3) @result{} #f\n" + "@end example") +#define FUNC_NAME s_scm_bit_position +{ + scm_t_array_handle handle; + size_t off, len, first_bit; + ssize_t inc; + const scm_t_uint32 *bits; + int bit = scm_to_bool (item); + SCM res = SCM_BOOL_F; + + bits = scm_bitvector_elements (v, &handle, &off, &len, &inc); + first_bit = scm_to_unsigned_integer (k, 0, len); + + if (off == 0 && inc == 1 && len > 0) + { + size_t i, word_len = (len + 31) / 32; + scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len); + size_t first_word = first_bit / 32; + scm_t_uint32 first_mask = + ((scm_t_uint32)-1) << (first_bit - 32*first_word); + scm_t_uint32 w; + + for (i = first_word; i < word_len; i++) + { + w = (bit? bits[i] : ~bits[i]); + if (i == first_word) + w &= first_mask; + if (i == word_len-1) + w &= last_mask; + if (w) + { + res = scm_from_size_t (32*i + find_first_one (w)); + break; + } + } + } + else + { + size_t i; + for (i = first_bit; i < len; i++) + { + SCM elt = scm_array_handle_ref (&handle, i*inc); + if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt))) + { + res = scm_from_size_t (i); + break; + } + } + } + + scm_array_handle_release (&handle); + + return res; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, + (SCM v, SCM kv, SCM obj), + "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n" + "selecting the entries to change. The return value is\n" + "unspecified.\n" + "\n" + "If @var{kv} is a bit vector, then those entries where it has\n" + "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n" + "@var{kv} and @var{v} must be the same length. When @var{obj}\n" + "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n" + "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n" + "\n" + "@example\n" + "(define bv #*01000010)\n" + "(bit-set*! bv #*10010001 #t)\n" + "bv\n" + "@result{} #*11010011\n" + "@end example\n" + "\n" + "If @var{kv} is a u32vector, then its elements are\n" + "indices into @var{v} which are set to @var{obj}.\n" + "\n" + "@example\n" + "(define bv #*01000010)\n" + "(bit-set*! bv #u32(5 2 7) #t)\n" + "bv\n" + "@result{} #*01100111\n" + "@end example") +#define FUNC_NAME s_scm_bit_set_star_x +{ + scm_t_array_handle v_handle; + size_t v_off, v_len; + ssize_t v_inc; + scm_t_uint32 *v_bits; + int bit; + + /* Validate that OBJ is a boolean so this is done even if we don't + need BIT. + */ + bit = scm_to_bool (obj); + + v_bits = scm_bitvector_writable_elements (v, &v_handle, + &v_off, &v_len, &v_inc); + + if (scm_is_bitvector (kv)) + { + scm_t_array_handle kv_handle; + size_t kv_off, kv_len; + ssize_t kv_inc; + const scm_t_uint32 *kv_bits; + + kv_bits = scm_bitvector_elements (v, &kv_handle, + &kv_off, &kv_len, &kv_inc); + + if (v_len != kv_len) + scm_misc_error (NULL, + "bit vectors must have equal length", + SCM_EOL); + + if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0) + { + size_t word_len = (kv_len + 31) / 32; + scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len); + size_t i; + + if (bit == 0) + { + for (i = 0; i < word_len-1; i++) + v_bits[i] &= ~kv_bits[i]; + v_bits[i] &= ~(kv_bits[i] & last_mask); + } + else + { + for (i = 0; i < word_len-1; i++) + v_bits[i] |= kv_bits[i]; + v_bits[i] |= kv_bits[i] & last_mask; + } + } + else + { + size_t i; + for (i = 0; i < kv_len; i++) + if (scm_is_true (scm_array_handle_ref (&kv_handle, i*kv_inc))) + scm_array_handle_set (&v_handle, i*v_inc, obj); + } + + scm_array_handle_release (&kv_handle); + + } + else if (scm_is_true (scm_u32vector_p (kv))) + { + scm_t_array_handle kv_handle; + size_t i, kv_len; + ssize_t kv_inc; + const scm_t_uint32 *kv_elts; + + kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc); + for (i = 0; i < kv_len; i++, kv_elts += kv_inc) + scm_array_handle_set (&v_handle, (*kv_elts)*v_inc, obj); + + scm_array_handle_release (&kv_handle); + } + else + scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector"); + + scm_array_handle_release (&v_handle); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, + (SCM v, SCM kv, SCM obj), + "Return a count of how many entries in bit vector @var{v} are\n" + "equal to @var{obj}, with @var{kv} selecting the entries to\n" + "consider.\n" + "\n" + "If @var{kv} is a bit vector, then those entries where it has\n" + "@code{#t} are the ones in @var{v} which are considered.\n" + "@var{kv} and @var{v} must be the same length.\n" + "\n" + "If @var{kv} is a u32vector, then it contains\n" + "the indexes in @var{v} to consider.\n" + "\n" + "For example,\n" + "\n" + "@example\n" + "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n" + "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n" + "@end example") +#define FUNC_NAME s_scm_bit_count_star +{ + scm_t_array_handle v_handle; + size_t v_off, v_len; + ssize_t v_inc; + const scm_t_uint32 *v_bits; + size_t count = 0; + int bit; + + /* Validate that OBJ is a boolean so this is done even if we don't + need BIT. + */ + bit = scm_to_bool (obj); + + v_bits = scm_bitvector_elements (v, &v_handle, + &v_off, &v_len, &v_inc); + + if (scm_is_bitvector (kv)) + { + scm_t_array_handle kv_handle; + size_t kv_off, kv_len; + ssize_t kv_inc; + const scm_t_uint32 *kv_bits; + + kv_bits = scm_bitvector_elements (v, &kv_handle, + &kv_off, &kv_len, &kv_inc); + + if (v_len != kv_len) + scm_misc_error (NULL, + "bit vectors must have equal length", + SCM_EOL); + + if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0) + { + size_t i, word_len = (kv_len + 31) / 32; + scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len); + scm_t_uint32 xor_mask = bit? 0 : ((scm_t_uint32)-1); + + for (i = 0; i < word_len-1; i++) + count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i]); + count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i] & last_mask); + } + else + { + size_t i; + for (i = 0; i < kv_len; i++) + if (scm_is_true (scm_array_handle_ref (&kv_handle, i))) + { + SCM elt = scm_array_handle_ref (&v_handle, i*v_inc); + if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt))) + count++; + } + } + + scm_array_handle_release (&kv_handle); + + } + else if (scm_is_true (scm_u32vector_p (kv))) + { + scm_t_array_handle kv_handle; + size_t i, kv_len; + ssize_t kv_inc; + const scm_t_uint32 *kv_elts; + + kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc); + for (i = 0; i < kv_len; i++, kv_elts += kv_inc) + { + SCM elt = scm_array_handle_ref (&v_handle, (*kv_elts)*v_inc); + if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt))) + count++; + } + + scm_array_handle_release (&kv_handle); + } + else + scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector"); + + scm_array_handle_release (&v_handle); + + return scm_from_size_t (count); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0, + (SCM v), + "Modify the bit vector @var{v} by replacing each element with\n" + "its negation.") +#define FUNC_NAME s_scm_bit_invert_x +{ + scm_t_array_handle handle; + size_t off, len; + ssize_t inc; + scm_t_uint32 *bits; + + bits = scm_bitvector_writable_elements (v, &handle, &off, &len, &inc); + + if (off == 0 && inc == 1 && len > 0) + { + size_t word_len = (len + 31) / 32; + scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len); + size_t i; + + for (i = 0; i < word_len-1; i++) + bits[i] = ~bits[i]; + bits[i] = bits[i] ^ last_mask; + } + else + { + size_t i; + for (i = 0; i < len; i++) + scm_array_handle_set (&handle, i*inc, + scm_not (scm_array_handle_ref (&handle, i*inc))); + } + + scm_array_handle_release (&handle); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +SCM +scm_istr2bve (SCM str) +{ + scm_t_array_handle handle; + size_t len = scm_i_string_length (str); + SCM vec = scm_c_make_bitvector (len, SCM_UNDEFINED); + SCM res = vec; + + scm_t_uint32 mask; + size_t k, j; + const char *c_str; + scm_t_uint32 *data; + + data = scm_bitvector_writable_elements (vec, &handle, NULL, NULL, NULL); + c_str = scm_i_string_chars (str); + + for (k = 0; k < (len + 31) / 32; k++) + { + data[k] = 0L; + j = len - k * 32; + if (j > 32) + j = 32; + for (mask = 1L; j--; mask <<= 1) + switch (*c_str++) + { + case '0': + break; + case '1': + data[k] |= mask; + break; + default: + res = SCM_BOOL_F; + goto exit; + } + } + + exit: + scm_array_handle_release (&handle); + scm_remember_upto_here_1 (str); + return res; +} + +/* FIXME: h->array should be h->vector */ +static SCM +bitvector_handle_ref (scm_t_array_handle *h, size_t pos) +{ + return scm_c_bitvector_ref (h->array, pos); +} + +static void +bitvector_handle_set (scm_t_array_handle *h, size_t pos, SCM val) +{ + scm_c_bitvector_set_x (h->array, pos, val); +} + +static void +bitvector_get_handle (SCM bv, scm_t_array_handle *h) +{ + h->array = bv; + h->ndims = 1; + h->dims = &h->dim0; + h->dim0.lbnd = 0; + h->dim0.ubnd = BITVECTOR_LENGTH (bv) - 1; + h->dim0.inc = 1; + h->element_type = SCM_ARRAY_ELEMENT_TYPE_BIT; + h->elements = h->writable_elements = BITVECTOR_BITS (bv); +} + +SCM_ARRAY_IMPLEMENTATION (scm_tc16_bitvector, 0xffff, + bitvector_handle_ref, bitvector_handle_set, + bitvector_get_handle); +SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_BIT, scm_make_bitvector); + +void +scm_init_bitvectors () +{ + scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0); + scm_set_smob_free (scm_tc16_bitvector, bitvector_free); + scm_set_smob_print (scm_tc16_bitvector, bitvector_print); + scm_set_smob_equalp (scm_tc16_bitvector, bitvector_equalp); + +#include "libguile/bitvectors.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/bitvectors.h b/libguile/bitvectors.h new file mode 100644 index 000000000..b6cf38357 --- /dev/null +++ b/libguile/bitvectors.h @@ -0,0 +1,81 @@ +/* classes: h_files */ + +#ifndef SCM_BITVECTORS_H +#define SCM_BITVECTORS_H + +/* Copyright (C) 1995,1996,1997,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 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" +#include "libguile/array-handle.h" + + + +/* Bitvectors. Exciting stuff, maybe! + */ + + +/** Bit vectors */ + +SCM_API SCM scm_bitvector_p (SCM vec); +SCM_API SCM scm_bitvector (SCM bits); +SCM_API SCM scm_make_bitvector (SCM len, SCM fill); +SCM_API SCM scm_bitvector_length (SCM vec); +SCM_API SCM scm_bitvector_ref (SCM vec, SCM idx); +SCM_API SCM scm_bitvector_set_x (SCM vec, SCM idx, SCM val); +SCM_API SCM scm_list_to_bitvector (SCM list); +SCM_API SCM scm_bitvector_to_list (SCM vec); +SCM_API SCM scm_bitvector_fill_x (SCM vec, SCM val); + +SCM_API SCM scm_bit_count (SCM item, SCM seq); +SCM_API SCM scm_bit_position (SCM item, SCM v, SCM k); +SCM_API SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj); +SCM_API SCM scm_bit_count_star (SCM v, SCM kv, SCM obj); +SCM_API SCM scm_bit_invert_x (SCM v); +SCM_API SCM scm_istr2bve (SCM str); + +SCM_API int scm_is_bitvector (SCM obj); +SCM_API SCM scm_c_make_bitvector (size_t len, SCM fill); +SCM_API size_t scm_c_bitvector_length (SCM vec); +SCM_API SCM scm_c_bitvector_ref (SCM vec, size_t idx); +SCM_API void scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val); +SCM_API const scm_t_uint32 *scm_array_handle_bit_elements (scm_t_array_handle *h); +SCM_API scm_t_uint32 *scm_array_handle_bit_writable_elements (scm_t_array_handle *h); +SCM_API size_t scm_array_handle_bit_elements_offset (scm_t_array_handle *h); +SCM_API const scm_t_uint32 *scm_bitvector_elements (SCM vec, + scm_t_array_handle *h, + size_t *offp, + size_t *lenp, + ssize_t *incp); +SCM_API scm_t_uint32 *scm_bitvector_writable_elements (SCM vec, + scm_t_array_handle *h, + size_t *offp, + size_t *lenp, + ssize_t *incp); + +SCM_INTERNAL void scm_init_bitvectors (void); + +#endif /* SCM_BITVECTORS_H */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/boehm-gc.h b/libguile/boehm-gc.h index ab842bc1b..9a92d08b2 100644 --- a/libguile/boehm-gc.h +++ b/libguile/boehm-gc.h @@ -20,9 +20,9 @@ /* Correct header inclusion. */ -#include "libguile/gen-scmconfig.h" +#include "libguile/scmconfig.h" -#ifdef SCM_I_GSC_USE_PTHREAD_THREADS +#ifdef SCM_USE_PTHREAD_THREADS /* When pthreads are used, let `libgc' know about it and redirect allocation calls such as `GC_MALLOC ()' to (contention-free, faster) thread-local 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..4246f0111 --- /dev/null +++ b/libguile/bytevectors.c @@ -0,0 +1,2250 @@ +/* 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/arrays.h" +#include "libguile/array-handle.h" +#include "libguile/uniform.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. */ + +#define SCM_BYTEVECTOR_HEADER_BYTES \ + (SCM_BYTEVECTOR_HEADER_SIZE * sizeof (SCM)) + +#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \ + SCM_SET_CELL_WORD_1 ((_bv), (scm_t_bits) (_len)) + +#define SCM_BYTEVECTOR_SET_ELEMENT_TYPE(bv, hint) \ + SCM_SET_BYTEVECTOR_FLAGS ((bv), (hint)) +#define SCM_BYTEVECTOR_TYPE_SIZE(var) \ + (scm_i_array_element_type_sizes[SCM_BYTEVECTOR_ELEMENT_TYPE (var)]/8) +#define SCM_BYTEVECTOR_TYPED_LENGTH(var) \ + SCM_BYTEVECTOR_LENGTH (var) / SCM_BYTEVECTOR_TYPE_SIZE (var) + +/* The empty bytevector. */ +SCM scm_null_bytevector = SCM_UNSPECIFIED; + + +static inline SCM +make_bytevector (size_t len, scm_t_array_element_type element_type) +{ + SCM ret; + size_t c_len; + + if (SCM_UNLIKELY (element_type > SCM_ARRAY_ELEMENT_TYPE_LAST + || scm_i_array_element_type_sizes[element_type] < 8 + || len >= (SCM_I_SIZE_MAX + / (scm_i_array_element_type_sizes[element_type]/8)))) + /* This would be an internal Guile programming error */ + abort (); + + if (SCM_UNLIKELY (len == 0 && element_type == SCM_ARRAY_ELEMENT_TYPE_VU8 + && SCM_BYTEVECTOR_P (scm_null_bytevector))) + ret = scm_null_bytevector; + else + { + c_len = len * (scm_i_array_element_type_sizes[element_type] / 8); + + ret = PTR2SCM (scm_gc_malloc_pointerless (SCM_BYTEVECTOR_HEADER_BYTES + c_len, + SCM_GC_BYTEVECTOR)); + + SCM_SET_CELL_TYPE (ret, scm_tc7_bytevector); + SCM_BYTEVECTOR_SET_LENGTH (ret, c_len); + SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type); + } + + return ret; +} + +/* Return a bytevector of LEN elements of type ELEMENT_TYPE, with element + values taken from CONTENTS. */ +static inline SCM +make_bytevector_from_buffer (size_t len, void *contents, + scm_t_array_element_type element_type) +{ + SCM ret; + + /* We actually never reuse storage from CONTENTS. Hans Boehm says in + <gc/gc.h> that realloc(3) "shouldn't have been invented" and he may well + be right. */ + ret = make_bytevector (len, element_type); + + if (len > 0) + { + size_t c_len; + + c_len = len * (scm_i_array_element_type_sizes[element_type] / 8); + memcpy (SCM_BYTEVECTOR_CONTENTS (ret), + contents, + c_len); + + scm_gc_free (contents, c_len, SCM_GC_BYTEVECTOR); + } + + return ret; +} + + +/* Return a new bytevector of size LEN octets. */ +SCM +scm_c_make_bytevector (size_t len) +{ + return make_bytevector (len, SCM_ARRAY_ELEMENT_TYPE_VU8); +} + +/* Return a new bytevector of size LEN elements. */ +SCM +scm_i_make_typed_bytevector (size_t len, scm_t_array_element_type element_type) +{ + return make_bytevector (len, element_type); +} + +/* 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) +{ + return make_bytevector_from_buffer (len, contents, SCM_ARRAY_ELEMENT_TYPE_VU8); +} + +SCM +scm_c_take_typed_bytevector (signed char *contents, size_t len, + scm_t_array_element_type element_type) +{ + return make_bytevector_from_buffer (len, contents, element_type); +} + +/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current + size) and return the new bytevector (possibly different from BV). */ +SCM +scm_c_shrink_bytevector (SCM bv, size_t c_new_len) +{ + SCM new_bv; + size_t c_len; + + if (SCM_UNLIKELY (c_new_len % SCM_BYTEVECTOR_TYPE_SIZE (bv))) + /* This would be an internal Guile programming error */ + abort (); + + c_len = SCM_BYTEVECTOR_LENGTH (bv); + if (SCM_UNLIKELY (c_new_len > c_len)) + abort (); + + SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len); + + /* Resize the existing buffer. */ + new_bv = PTR2SCM (scm_gc_realloc (SCM2PTR (bv), + c_len + SCM_BYTEVECTOR_HEADER_BYTES, + c_new_len + SCM_BYTEVECTOR_HEADER_BYTES, + SCM_GC_BYTEVECTOR)); + + return new_bv; +} + +int +scm_is_bytevector (SCM obj) +{ + return SCM_BYTEVECTOR_P (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 + + + +int +scm_i_print_bytevector (SCM bv, SCM port, scm_print_state *pstate SCM_UNUSED) +{ + ssize_t ubnd, inc, i; + scm_t_array_handle h; + + scm_array_get_handle (bv, &h); + + scm_putc ('#', port); + scm_write (scm_array_handle_element_type (&h), port); + scm_putc ('(', port); + for (i = h.dims[0].lbnd, ubnd = h.dims[0].ubnd, inc = h.dims[0].inc; + i <= ubnd; i += inc) + { + if (i > 0) + scm_putc (' ', port); + scm_write (scm_array_handle_ref (&h, i), port); + } + scm_putc (')', port); + + return 1; +} + + +/* 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, SCM_ARRAY_ELEMENT_TYPE_VU8); + 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, SCM_BYTEVECTOR_ELEMENT_TYPE (bv)); + 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, SCM_ARRAY_ELEMENT_TYPE_VU8); + 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, SCM_ARRAY_ELEMENT_TYPE_VU8); + 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, SCM_ARRAY_ELEMENT_TYPE_VU8); \ + 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 + + +/* FIXME: SCM_VALIDATE_REAL rejects integers, etc. grrr */ +#define VALIDATE_REAL(pos, v) \ + do { \ + SCM_ASSERT_TYPE (scm_is_true (scm_rational_p (v)), v, pos, FUNC_NAME, "real"); \ + } while (0) + +/* 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); \ + 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); \ + 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. It is malloc(3)-allocated, so we cannot \ + use `scm_c_take_bytevector ()'. */ \ + scm_dynwind_begin (0); \ + scm_dynwind_free (c_utf); \ + \ + utf = make_bytevector (c_utf_len, \ + SCM_ARRAY_ELEMENT_TYPE_VU8); \ + memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, \ + c_utf_len); \ + \ + scm_dynwind_end (); \ + } \ + \ + 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. It is malloc(3)-allocated, so we cannot + use `scm_c_take_bytevector ()'. */ + scm_dynwind_begin (0); + scm_dynwind_free (c_utf); + + utf = make_bytevector (UTF_STRLEN (8, c_utf), + SCM_ARRAY_ELEMENT_TYPE_VU8); + memcpy (SCM_BYTEVECTOR_CONTENTS (utf), c_utf, + UTF_STRLEN (8, c_utf)); + + scm_dynwind_end (); + } + + 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 + + + +/* Bytevectors as generalized vectors & arrays. */ + + +static SCM +bytevector_ref_c32 (SCM bv, SCM idx) +{ /* FIXME add some checks */ + const float *contents = (const float*)SCM_BYTEVECTOR_CONTENTS (bv); + size_t i = scm_to_size_t (idx); + return scm_c_make_rectangular (contents[i/8], contents[i/8 + 1]); +} + +static SCM +bytevector_ref_c64 (SCM bv, SCM idx) +{ /* FIXME add some checks */ + const double *contents = (const double*)SCM_BYTEVECTOR_CONTENTS (bv); + size_t i = scm_to_size_t (idx); + return scm_c_make_rectangular (contents[i/16], contents[i/16 + 1]); +} + +typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM); + +const scm_t_bytevector_ref_fn bytevector_ref_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = +{ + NULL, /* SCM */ + NULL, /* CHAR */ + NULL, /* BIT */ + scm_bytevector_u8_ref, /* VU8 */ + scm_bytevector_u8_ref, /* U8 */ + scm_bytevector_s8_ref, + scm_bytevector_u16_native_ref, + scm_bytevector_s16_native_ref, + scm_bytevector_u32_native_ref, + scm_bytevector_s32_native_ref, + scm_bytevector_u64_native_ref, + scm_bytevector_s64_native_ref, + scm_bytevector_ieee_single_native_ref, + scm_bytevector_ieee_double_native_ref, + bytevector_ref_c32, + bytevector_ref_c64 +}; + +static SCM +bv_handle_ref (scm_t_array_handle *h, size_t index) +{ + SCM byte_index; + scm_t_bytevector_ref_fn ref_fn; + + ref_fn = bytevector_ref_fns[h->element_type]; + byte_index = + scm_from_size_t (index * scm_array_handle_uniform_element_size (h)); + return ref_fn (h->array, byte_index); +} + +static SCM +bytevector_set_c32 (SCM bv, SCM idx, SCM val) +{ /* checks are unnecessary here */ + float *contents = (float*)SCM_BYTEVECTOR_CONTENTS (bv); + size_t i = scm_to_size_t (idx); + contents[i/8] = scm_c_real_part (val); + contents[i/8 + 1] = scm_c_imag_part (val); + return SCM_UNSPECIFIED; +} + +static SCM +bytevector_set_c64 (SCM bv, SCM idx, SCM val) +{ /* checks are unnecessary here */ + double *contents = (double*)SCM_BYTEVECTOR_CONTENTS (bv); + size_t i = scm_to_size_t (idx); + contents[i/16] = scm_c_real_part (val); + contents[i/16 + 1] = scm_c_imag_part (val); + return SCM_UNSPECIFIED; +} + +typedef SCM (*scm_t_bytevector_set_fn)(SCM, SCM, SCM); + +const scm_t_bytevector_set_fn bytevector_set_fns[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = +{ + NULL, /* SCM */ + NULL, /* CHAR */ + NULL, /* BIT */ + scm_bytevector_u8_set_x, /* VU8 */ + scm_bytevector_u8_set_x, /* U8 */ + scm_bytevector_s8_set_x, + scm_bytevector_u16_native_set_x, + scm_bytevector_s16_native_set_x, + scm_bytevector_u32_native_set_x, + scm_bytevector_s32_native_set_x, + scm_bytevector_u64_native_set_x, + scm_bytevector_s64_native_set_x, + scm_bytevector_ieee_single_native_set_x, + scm_bytevector_ieee_double_native_set_x, + bytevector_set_c32, + bytevector_set_c64 +}; + +static void +bv_handle_set_x (scm_t_array_handle *h, size_t index, SCM val) +{ + SCM byte_index; + scm_t_bytevector_set_fn set_fn; + + set_fn = bytevector_set_fns[h->element_type]; + byte_index = + scm_from_size_t (index * scm_array_handle_uniform_element_size (h)); + set_fn (h->array, byte_index, val); +} + +static void +bytevector_get_handle (SCM v, scm_t_array_handle *h) +{ + h->array = v; + h->ndims = 1; + h->dims = &h->dim0; + h->dim0.lbnd = 0; + h->dim0.ubnd = SCM_BYTEVECTOR_TYPED_LENGTH (v) - 1; + h->dim0.inc = 1; + h->element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (v); + h->elements = h->writable_elements = SCM_BYTEVECTOR_CONTENTS (v); +} + + +/* Initialization. */ + +void +scm_bootstrap_bytevectors (void) +{ + /* This must be instantiated here because the generalized-vector API may + want to access bytevectors even though `(rnrs bytevector)' hasn't been + loaded. */ + scm_null_bytevector = + scm_gc_protect_object (make_bytevector (0, SCM_ARRAY_ELEMENT_TYPE_VU8)); + +#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); + + { + scm_t_array_implementation impl; + + impl.tag = scm_tc7_bytevector; + impl.mask = 0x7f; + impl.vref = bv_handle_ref; + impl.vset = bv_handle_set_x; + impl.get_handle = bytevector_get_handle; + scm_i_register_array_implementation (&impl); + scm_i_register_vector_constructor + (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_VU8], + scm_make_bytevector); + } +} + +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..506312638 --- /dev/null +++ b/libguile/bytevectors.h @@ -0,0 +1,148 @@ +#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. */ + +/* The size in words of the bytevector header (type tag, flags, and + length). */ +#define SCM_BYTEVECTOR_HEADER_SIZE 2U + +#define SCM_BYTEVECTOR_LENGTH(_bv) \ + ((size_t) SCM_CELL_WORD_1 (_bv)) +#define SCM_BYTEVECTOR_CONTENTS(_bv) \ + ((signed char *) SCM_CELL_OBJECT_LOC ((_bv), \ + SCM_BYTEVECTOR_HEADER_SIZE)) + + +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. */ + +#define SCM_BYTEVECTOR_P(x) \ + (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_bytevector) +#define SCM_BYTEVECTOR_FLAGS(_bv) \ + (SCM_CELL_TYPE (_bv) >> 7UL) +#define SCM_SET_BYTEVECTOR_FLAGS(_bv, _f) \ + SCM_SET_CELL_TYPE ((_bv), \ + scm_tc7_bytevector | ((scm_t_bits)(_f) << 7UL)) + +#define SCM_BYTEVECTOR_ELEMENT_TYPE(_bv) \ + (SCM_BYTEVECTOR_FLAGS (_bv)) + +/* Hint that is passed to `scm_gc_malloc ()' and friends. */ +#define SCM_GC_BYTEVECTOR "bytevector" + +SCM_INTERNAL SCM scm_i_make_typed_bytevector (size_t, scm_t_array_element_type); +SCM_INTERNAL SCM scm_c_take_typed_bytevector (signed char *, size_t, + scm_t_array_element_type); + +SCM_INTERNAL void scm_bootstrap_bytevectors (void); +SCM_INTERNAL void scm_init_bytevectors (void); + +SCM_INTERNAL SCM scm_i_native_endianness; +SCM_INTERNAL SCM scm_c_take_bytevector (signed char *, size_t); + +SCM_INTERNAL int scm_i_print_bytevector (SCM, SCM, scm_print_state *); + +SCM_INTERNAL SCM scm_c_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..c7cb09c47 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,115 @@ 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 - return c; + return uc_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 - return c; + return uc_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..85b16739a 100644 --- a/libguile/chars.h +++ b/libguile/chars.h @@ -3,39 +3,54 @@ #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" +#ifndef SCM_T_WCHAR_DEFINED +typedef scm_t_int32 scm_t_wchar; +#define SCM_T_WCHAR_DEFINED +#endif /* SCM_T_WCHAR_DEFINED */ + /* 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)) - +/* SCM_MAKE_CHAR maps signed chars (-128 to 127) and unsigned chars (0 + to 255) to Latin-1 codepoints (0 to 255) while allowing higher + codepoints (256 to 1114111) to pass through unchanged. + + This macro evaluates x twice, which may lead to side effects if not + used properly. */ +#define SCM_MAKE_CHAR(x) \ + ((x) <= 1 \ + ? 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 +75,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 e8ee4db82..aa1fb334e 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 */ @@ -35,6 +36,7 @@ #include "libguile/dynwind.h" #include "libguile/values.h" #include "libguile/eval.h" +#include "libguile/vm.h" #include "libguile/validate.h" #include "libguile/continuations.h" @@ -84,15 +86,16 @@ 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 continuation->offset = continuation->stack - src; 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); + *first = !SCM_I_SETJMP (continuation->jmpbuf); if (*first) { #ifdef __ia64__ @@ -169,6 +172,7 @@ copy_stack (void *data) copy_stack_data *d = (copy_stack_data *)data; memcpy (d->dst, d->continuation->stack, sizeof (SCM_STACKITEM) * d->continuation->num_stack_items); + scm_vm_reinstate_continuations (d->continuation->vm_conts); #ifdef __ia64__ SCM_I_CURRENT_THREAD->pending_rbs_continuation = d->continuation; #endif @@ -189,12 +193,12 @@ copy_stack_and_call (scm_t_contregs *continuation, SCM val, scm_i_set_last_debug_frame (continuation->dframe); continuation->throw_value = val; - longjmp (continuation->jmpbuf, 1); + SCM_I_LONGJMP (continuation->jmpbuf, 1); } #ifdef __ia64__ void -scm_ia64_longjmp (jmp_buf *JB, int VAL) +scm_ia64_longjmp (scm_i_jmp_buf *JB, int VAL) { scm_i_thread *t = SCM_I_CURRENT_THREAD; diff --git a/libguile/continuations.h b/libguile/continuations.h index 1a648dd28..82cf178b0 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 */ @@ -43,7 +44,7 @@ SCM_API scm_t_bits scm_tc16_continuation; typedef struct { SCM throw_value; - jmp_buf jmpbuf; + scm_i_jmp_buf jmpbuf; SCM dynenv; #ifdef __ia64__ void *backing_store; @@ -51,6 +52,7 @@ typedef struct #endif /* __ia64__ */ size_t num_stack_items; /* size of the saved stack. */ SCM root; /* continuation root identifier. */ + SCM vm_conts; /* vm continuations (they use separate stacks) */ /* The offset from the live stack location to this copy. This is used to adjust pointers from within the copied stack to the stack diff --git a/libguile/conv-uinteger.i.c b/libguile/conv-uinteger.i.c index ff0d28012..52f49f772 100644 --- a/libguile/conv-uinteger.i.c +++ b/libguile/conv-uinteger.i.c @@ -53,10 +53,17 @@ SCM_TO_TYPE_PROTO (SCM val) #if SIZEOF_TYPE != 0 && SIZEOF_TYPE > SCM_SIZEOF_LONG return n; #else - if (n >= TYPE_MIN && n <= TYPE_MAX) - return n; - else - goto out_of_range; + +#if TYPE_MIN == 0 + if (n <= TYPE_MAX) + return n; +#else /* TYPE_MIN != 0 */ + if (n >= TYPE_MIN && n <= TYPE_MAX) + return n; +#endif /* TYPE_MIN != 0 */ + else + goto out_of_range; + #endif } else @@ -76,10 +83,16 @@ SCM_TO_TYPE_PROTO (SCM val) mpz_export (&n, &count, 1, sizeof (TYPE), 0, 0, SCM_I_BIG_MPZ (val)); +#if TYPE_MIN == 0 + if (n <= TYPE_MAX) + return n; +#else /* TYPE_MIN != 0 */ if (n >= TYPE_MIN && n <= TYPE_MAX) return n; - else - goto out_of_range; +#endif /* TYPE_MIN != 0 */ + else + goto out_of_range; + } } else diff --git a/libguile/convert.c b/libguile/convert.c deleted file mode 100644 index 700deaa87..000000000 --- a/libguile/convert.c +++ /dev/null @@ -1,146 +0,0 @@ -/* 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. - * - * 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 "libguile/_scm.h" -#include "libguile/validate.h" -#include "libguile/strings.h" -#include "libguile/vectors.h" -#include "libguile/pairs.h" -#include "libguile/unif.h" -#include "libguile/srfi-4.h" - -#include "libguile/convert.h" - -#ifdef HAVE_STRING_H -#include <string.h> -#endif - -/* char *scm_c_scm2chars (SCM obj, char *dst); - SCM scm_c_chars2scm (const char *src, long n); - SCM scm_c_chars2byvect (const char *src, long n); -*/ - -#define CTYPE char -#define FROM_CTYPE scm_from_char -#define SCM2CTYPES scm_c_scm2chars -#define CTYPES2SCM scm_c_chars2scm -#define CTYPES2UVECT scm_c_chars2byvect -#if CHAR_MIN == 0 -/* 'char' is unsigned. */ -#define UVEC_TAG u8 -#define UVEC_CTYPE scm_t_uint8 -#else -/* 'char' is signed. */ -#define UVEC_TAG s8 -#define UVEC_CTYPE scm_t_int8 -#endif -#include "libguile/convert.i.c" - -/* short *scm_c_scm2shorts (SCM obj, short *dst); - SCM scm_c_shorts2scm (const short *src, long n); - SCM scm_c_shorts2svect (const short *src, long n); -*/ - -#define CTYPE short -#define FROM_CTYPE scm_from_short -#define SCM2CTYPES scm_c_scm2shorts -#define CTYPES2SCM scm_c_shorts2scm -#define CTYPES2UVECT scm_c_shorts2svect -#define UVEC_TAG s16 -#define UVEC_CTYPE scm_t_int16 -#include "libguile/convert.i.c" - -/* int *scm_c_scm2ints (SCM obj, int *dst); - SCM scm_c_ints2scm (const int *src, long n); - SCM scm_c_ints2ivect (const int *src, long n); - SCM scm_c_uints2uvect (const unsigned int *src, long n); -*/ - -#define CTYPE int -#define FROM_CTYPE scm_from_int -#define SCM2CTYPES scm_c_scm2ints -#define CTYPES2SCM scm_c_ints2scm -#define CTYPES2UVECT scm_c_ints2ivect -#define UVEC_TAG s32 -#define UVEC_CTYPE scm_t_int32 - -#define CTYPES2UVECT_2 scm_c_uints2uvect -#define CTYPE_2 unsigned int -#define UVEC_TAG_2 u32 -#define UVEC_CTYPE_2 scm_t_uint32 - -#include "libguile/convert.i.c" - -/* long *scm_c_scm2longs (SCM obj, long *dst); - SCM scm_c_longs2scm (const long *src, long n); - SCM scm_c_longs2ivect (const long *src, long n); - SCM scm_c_ulongs2uvect (const unsigned long *src, long n); -*/ - -#define CTYPE long -#define FROM_CTYPE scm_from_long -#define SCM2CTYPES scm_c_scm2longs -#define CTYPES2SCM scm_c_longs2scm -#define CTYPES2UVECT scm_c_longs2ivect -#define UVEC_TAG s32 -#define UVEC_CTYPE scm_t_int32 - -#define CTYPES2UVECT_2 scm_c_ulongs2uvect -#define CTYPE_2 unsigned int -#define UVEC_TAG_2 u32 -#define UVEC_CTYPE_2 scm_t_uint32 - -#include "libguile/convert.i.c" - -/* float *scm_c_scm2floats (SCM obj, float *dst); - SCM scm_c_floats2scm (const float *src, long n); - SCM scm_c_floats2fvect (const float *src, long n); -*/ - -#define CTYPE float -#define FROM_CTYPE scm_from_double -#define SCM2CTYPES scm_c_scm2floats -#define CTYPES2SCM scm_c_floats2scm -#define CTYPES2UVECT scm_c_floats2fvect -#define UVEC_TAG f32 -#define UVEC_CTYPE float -#include "libguile/convert.i.c" - -/* double *scm_c_scm2doubles (SCM obj, double *dst); - SCM scm_c_doubles2scm (const double *src, long n); - SCM scm_c_doubles2dvect (const double *src, long n); -*/ - -#define CTYPE double -#define FROM_CTYPE scm_from_double -#define SCM2CTYPES scm_c_scm2doubles -#define CTYPES2SCM scm_c_doubles2scm -#define CTYPES2UVECT scm_c_doubles2dvect -#define UVEC_TAG f64 -#define UVEC_CTYPE double -#include "libguile/convert.i.c" - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/convert.h b/libguile/convert.h deleted file mode 100644 index f834a6b1d..000000000 --- a/libguile/convert.h +++ /dev/null @@ -1,50 +0,0 @@ -/* classes: h_files */ - -#ifndef SCM_CONVERT_H -#define SCM_CONVERT_H - -/* 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. - * - * 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" - -SCM_API char *scm_c_scm2chars (SCM obj, char *dst); -SCM_API short *scm_c_scm2shorts (SCM obj, short *dst); -SCM_API int *scm_c_scm2ints (SCM obj, int *dst); -SCM_API long *scm_c_scm2longs (SCM obj, long *dst); -SCM_API float *scm_c_scm2floats (SCM obj, float *dst); -SCM_API double *scm_c_scm2doubles (SCM obj, double *dst); - -SCM_API SCM scm_c_chars2scm (const char *src, long n); -SCM_API SCM scm_c_shorts2scm (const short *src, long n); -SCM_API SCM scm_c_ints2scm (const int *src, long n); -SCM_API SCM scm_c_longs2scm (const long *src, long n); -SCM_API SCM scm_c_floats2scm (const float *src, long n); -SCM_API SCM scm_c_doubles2scm (const double *src, long n); - -SCM_API SCM scm_c_chars2byvect (const char *src, long n); -SCM_API SCM scm_c_shorts2svect (const short *src, long n); -SCM_API SCM scm_c_ints2ivect (const int *src, long n); -SCM_API SCM scm_c_uints2uvect (const unsigned int *src, long n); -SCM_API SCM scm_c_longs2ivect (const long *src, long n); -SCM_API SCM scm_c_ulongs2uvect (const unsigned long *src, long n); -SCM_API SCM scm_c_floats2fvect (const float *src, long n); -SCM_API SCM scm_c_doubles2dvect (const double *src, long n); - -#endif /* SCM_CONVERT_H */ diff --git a/libguile/convert.i.c b/libguile/convert.i.c deleted file mode 100644 index 4e73bf970..000000000 --- a/libguile/convert.i.c +++ /dev/null @@ -1,171 +0,0 @@ -/* this file is #include'd (x times) by convert.c */ - -/* You need to define the following macros before including this - template. They are undefined at the end of this file to give a - clean slate for the next inclusion. - - - CTYPE - - The type of an element of the C array, for example 'char'. - - - FROM_CTYPE - - The function that converts a CTYPE to a SCM, for example - scm_from_char. - - - UVEC_TAG - - The tag of a suitable uniform vector that can hold the CTYPE, for - example 's8'. - - - UVEC_CTYPE - - The C type of an element of the uniform vector, for example - scm_t_int8. - - - SCM2CTYPES - - The name of the 'SCM-to-C' function, for example scm_c_scm2chars. - - - CTYPES2SCM - - The name of the 'C-to-SCM' function, for example, scm_c_chars2scm. - - - CTYPES2UVECT - - The name of the 'C-to-uniform-vector' function, for example - scm_c_chars2byvect. It will create a uniform vector of kind - UVEC_TAG. - - - CTYPES2UVECT_2 - - The name of a second 'C-to-uniform-vector' function. Leave - undefined if you want only one such function. - - - CTYPE_2 - - UVEC_TAG_2 - - UVEC_CTYPE_2 - - The tag and C type of the second kind of uniform vector, for use - with the function described above. - -*/ - -/* The first level does not expand macros in the arguments. */ -#define paste(a1,a2,a3) a1##a2##a3 -#define stringify(a) #a - -/* But the second level does. */ -#define F(pre,T,suf) paste(pre,T,suf) -#define S(T) stringify(T) - -/* Convert a vector, list or uniform vector into a C array. If the - result array in argument 2 is NULL, malloc() a new one. -*/ - -CTYPE * -SCM2CTYPES (SCM obj, CTYPE *data) -{ - scm_t_array_handle handle; - size_t i, len; - ssize_t inc; - const UVEC_CTYPE *uvec_elements; - - obj = F(scm_any_to_,UVEC_TAG,vector) (obj); - uvec_elements = F(scm_,UVEC_TAG,vector_elements) (obj, &handle, &len, &inc); - - if (data == NULL) - data = scm_malloc (len * sizeof (CTYPE)); - for (i = 0; i < len; i++, uvec_elements += inc) - data[i] = uvec_elements[i]; - - scm_array_handle_release (&handle); - - return data; -} - -/* Converts a C array into a vector. */ - -SCM -CTYPES2SCM (const CTYPE *data, long n) -{ - long i; - SCM v; - - v = scm_c_make_vector (n, SCM_UNSPECIFIED); - - for (i = 0; i < n; i++) - SCM_SIMPLE_VECTOR_SET (v, i, FROM_CTYPE (data[i])); - - return v; -} - -/* Converts a C array into a uniform vector. */ - -SCM -CTYPES2UVECT (const CTYPE *data, long n) -{ - scm_t_array_handle handle; - long i; - SCM uvec; - UVEC_CTYPE *uvec_elements; - - uvec = F(scm_make_,UVEC_TAG,vector) (scm_from_long (n), SCM_UNDEFINED); - uvec_elements = F(scm_,UVEC_TAG,vector_writable_elements) (uvec, &handle, - NULL, NULL); - for (i = 0; i < n; i++) - uvec_elements[i] = data[i]; - - scm_array_handle_release (&handle); - - return uvec; -} - -#ifdef CTYPE2UVECT_2 - -SCM -CTYPES2UVECT_2 (const CTYPE_2 *data, long n) -{ - scm_t_array_handle handle; - long i; - SCM uvec; - UVEC_CTYPE_2 *uvec_elements; - - uvec = F(scm_make_,UVEC_TAG_2,vector) (scm_from_long (n), SCM_UNDEFINED); - uvec_elements = F(scm_,UVEC_TAG_2,vector_writable_elements) (uvec, &handle, - NULL, NULL); - - for (i = 0; i < n; i++) - uvec_elements[i] = data[i]; - - scm_array_handle_release (&handle); - - return uvec; -} - -#endif - -#undef paste -#undef stringify -#undef F -#undef S - -#undef CTYPE -#undef FROM_CTYPE -#undef UVEC_TAG -#undef UVEC_CTYPE -#undef SCM2CTYPES -#undef CTYPES2SCM -#undef CTYPES2UVECT -#ifdef CTYPES2UVECT_2 -#undef CTYPES2UVECT_2 -#undef CTYPE_2 -#undef UVEC_TAG_2 -#undef UVEC_CTYPE_2 -#endif - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ 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 a8ccdf8d3..5b42dddd9 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" @@ -42,6 +48,7 @@ #include "libguile/root.h" #include "libguile/fluids.h" #include "libguile/objects.h" +#include "libguile/programs.h" #include "libguile/validate.h" #include "libguile/debug.h" @@ -72,7 +79,9 @@ SCM_DEFINE (scm_debug_options, "debug-options-interface", 0, 1, 0, SCM_OUT_OF_RANGE (1, setting); } SCM_RESET_DEBUG_MODE; +#ifdef STACK_CHECKING scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P; +#endif scm_debug_eframe_size = 2 * SCM_N_FRAMES; scm_dynwind_end (); @@ -300,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); @@ -312,6 +321,8 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0, #endif if (scm_is_false (name) && SCM_CLOSUREP (proc)) name = scm_reverse_lookup (SCM_ENV (proc), proc); + if (scm_is_false (name) && SCM_PROGRAM_P (proc)) + name = scm_program_name (proc); return name; } } @@ -352,6 +363,7 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0, if (!SCM_SMOB_DESCRIPTOR (proc).apply) break; case scm_tcs_subrs: + case scm_tc7_program: procprop: /* It would indeed be a nice thing if we supplied source even for built in procedures! */ @@ -390,6 +402,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 @@ -440,8 +467,10 @@ scm_reverse_lookup (SCM env, SCM data) return SCM_BOOL_F; } -SCM -scm_start_stack (SCM id, SCM exp, SCM env) +SCM_DEFINE (scm_sys_start_stack, "%start-stack", 2, 0, 0, + (SCM id, SCM thunk), + "Call @var{thunk} on an evaluator stack tagged with @var{id}.") +#define FUNC_NAME s_scm_sys_start_stack { SCM answer; scm_t_debug_frame vframe; @@ -451,27 +480,12 @@ scm_start_stack (SCM id, SCM exp, SCM env) vframe.vect = &vframe_vect_body; vframe.vect[0].id = id; scm_i_set_last_debug_frame (&vframe); - answer = scm_i_eval (exp, env); + answer = scm_call_0 (thunk); scm_i_set_last_debug_frame (vframe.prev); return answer; } - -SCM_SYNTAX(s_start_stack, "start-stack", scm_makacro, scm_m_start_stack); - -static SCM -scm_m_start_stack (SCM exp, SCM env) -#define FUNC_NAME s_start_stack -{ - exp = SCM_CDR (exp); - if (!scm_is_pair (exp) - || !scm_is_pair (SCM_CDR (exp)) - || !scm_is_null (SCM_CDDR (exp))) - SCM_WRONG_NUM_ARGS (); - return scm_start_stack (scm_eval_car (exp, env), SCM_CADR (exp), env); -} #undef FUNC_NAME - /* {Debug Objects} * * The debugging evaluator throws these on frame traps. @@ -521,11 +535,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 607716230..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 */ @@ -138,8 +139,9 @@ SCM_API scm_t_bits scm_tc16_memoized; SCM_API SCM scm_debug_object_p (SCM obj); SCM_API SCM scm_local_eval (SCM exp, SCM env); SCM_API SCM scm_reverse_lookup (SCM env, SCM data); -SCM_API SCM scm_start_stack (SCM info_id, SCM exp, SCM env); +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..d0669969c 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -2,21 +2,22 @@ deprecate something, move it here when that is feasible. */ -/* Copyright (C) 2003, 2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 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 */ #ifdef HAVE_CONFIG_H @@ -33,6 +34,7 @@ #include "libguile/strings.h" #include "libguile/srfi-13.h" #include "libguile/modules.h" +#include "libguile/generalized-arrays.h" #include "libguile/eval.h" #include "libguile/smob.h" #include "libguile/procprop.h" @@ -748,17 +750,13 @@ scm_sym2ovcell (SCM sym, SCM obarray) return (SYMBOL . SCM_UNDEFINED). */ -SCM -scm_intern_obarray_soft (const char *name,size_t len,SCM obarray,unsigned int softness) +static SCM +intern_obarray_soft (SCM symbol, SCM obarray, unsigned int softness) { - SCM symbol = scm_from_locale_symboln (name, len); size_t raw_hash = scm_i_symbol_hash (symbol); size_t hash; SCM lsym; - scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. " - "Use hashtables instead."); - if (scm_is_false (obarray)) { if (softness) @@ -794,6 +792,18 @@ scm_intern_obarray_soft (const char *name,size_t len,SCM obarray,unsigned int so } +SCM +scm_intern_obarray_soft (const char *name, size_t len, SCM obarray, + unsigned int softness) +{ + SCM symbol = scm_from_locale_symboln (name, len); + + scm_c_issue_deprecation_warning ("`scm_intern_obarray_soft' is deprecated. " + "Use hashtables instead."); + + return intern_obarray_soft (symbol, obarray, softness); +} + SCM scm_intern_obarray (const char *name,size_t len,SCM obarray) { @@ -849,10 +859,7 @@ SCM_DEFINE (scm_string_to_obarray_symbol, "string->obarray-symbol", 2, 1, 0, else if (scm_is_eq (o, SCM_BOOL_T)) o = SCM_BOOL_F; - vcell = scm_intern_obarray_soft (scm_i_string_chars (s), - scm_i_string_length (s), - o, - softness); + vcell = intern_obarray_soft (scm_string_to_symbol (s), o, softness); if (scm_is_false (vcell)) return vcell; answer = SCM_CAR (vcell); @@ -1069,7 +1076,8 @@ SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, { char buf[MAX_PREFIX_LENGTH + SCM_INTBUFLEN]; char *name = buf; - int len, n_digits; + int n_digits; + size_t len; scm_c_issue_deprecation_warning ("`gentemp' is deprecated. " "Use `gensym' instead."); @@ -1083,9 +1091,8 @@ SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, { SCM_VALIDATE_STRING (1, prefix); len = scm_i_string_length (prefix); - if (len > MAX_PREFIX_LENGTH) - name = SCM_MUST_MALLOC (MAX_PREFIX_LENGTH + SCM_INTBUFLEN); - strncpy (name, scm_i_string_chars (prefix), len); + name = scm_to_locale_stringn (prefix, &len); + name = scm_realloc (name, len + SCM_INTBUFLEN); } if (SCM_UNBNDP (obarray)) @@ -1107,7 +1114,7 @@ SCM_DEFINE (scm_gentemp, "gentemp", 0, 2, 0, obarray, 0); if (name != buf) - scm_must_free (name); + free (name); return SCM_CAR (vcell); } } @@ -1308,7 +1315,7 @@ scm_i_arrayp (SCM a) { scm_c_issue_deprecation_warning ("SCM_ARRAYP is deprecated. Use scm_is_array instead."); - return SCM_I_ARRAYP(a) || SCM_I_ENCLOSED_ARRAYP(a); + return SCM_I_ARRAYP(a); } size_t @@ -1496,6 +1503,29 @@ SCM_DEFINE (scm_destroy_guardian_x, "destroy-guardian!", 1, 0, 0, } #undef FUNC_NAME + +/* GC-related things. */ + +unsigned long scm_mallocated, scm_mtrigger; +size_t scm_max_segment_size; + +#if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST) +SCM +scm_map_free_list (void) +{ + return SCM_EOL; +} +#endif + +#if defined (GUILE_DEBUG_FREELIST) +SCM +scm_gc_set_debug_check_freelist_x (SCM flag) +{ + return SCM_UNSPECIFIED; +} +#endif + + void scm_i_init_deprecated () { diff --git a/libguile/deprecated.h b/libguile/deprecated.h index 9a0862c3e..f428f7de8 100644 --- a/libguile/deprecated.h +++ b/libguile/deprecated.h @@ -5,24 +5,26 @@ #ifndef SCM_DEPRECATED_H #define SCM_DEPRECATED_H -/* Copyright (C) 2003,2004, 2005, 2006, 2007 Free Software Foundation, Inc. +/* Copyright (C) 2003,2004, 2005, 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 */ #include "libguile/__scm.h" +#include "libguile/arrays.h" #include "libguile/strings.h" #if (SCM_ENABLE_DEPRECATED == 1) @@ -116,8 +118,8 @@ SCM_API SCM scm_unprotect_object (SCM obj); (SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) & (y)))) #define SCM_SETOR_CDR(x, y)\ (SCM_SETCDR ((x), SCM_PACK (SCM_UNPACK (SCM_CDR (x)) | (y)))) -#define SCM_FREEP(x) (SCM_FREE_CELL_P (x)) -#define SCM_NFREEP(x) (!SCM_FREE_CELL_P (x)) +#define SCM_FREEP(x) (0) +#define SCM_NFREEP(x) (1) #define SCM_GC8MARKP(x) SCM_GC_MARK_P (x) #define SCM_SETGC8MARK(x) SCM_SET_GC_MARK (x) #define SCM_CLRGC8MARK(x) SCM_CLEAR_GC_MARK (x) @@ -581,6 +583,25 @@ SCM_API SCM scm_destroy_guardian_x (SCM guardian); SCM_API SCM scm_guardian_greedy_p (SCM guardian); SCM_API SCM scm_guardian_destroyed_p (SCM guardian); + +/* GC-related things deprecated with the move to BDW-GC starting from 1.9.3 + (2009-09-15). */ + +SCM_API unsigned long scm_mallocated; +SCM_API unsigned long scm_mtrigger; + +SCM_API size_t scm_max_segment_size; + +#if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST) +SCM_API SCM scm_map_free_list (void); +#endif + +#if defined (GUILE_DEBUG_FREELIST) +SCM_API SCM scm_gc_set_debug_check_freelist_x (SCM flag); +#endif + + + void scm_i_init_deprecated (void); #endif 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..262142890 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 @@ -264,7 +265,7 @@ SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", SCM dash_string, non_dash_symbol; SCM_ASSERT (scm_is_symbol (symbol) - && ('-' == scm_i_symbol_chars(symbol)[0]), + && (scm_i_symbol_ref (symbol, 0) == '-'), symbol, SCM_ARG1, FUNC_NAME); dash_string = scm_symbol_to_string (symbol); 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 39ff47f79..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 */ @@ -315,7 +316,7 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data) if (SCM_VARIABLEP (SCM_CAR (wind_key))) scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); } - else if (SCM_TYP3 (wind_key) == scm_tc3_closure) + else if (scm_is_true (scm_thunk_p (wind_key))) scm_call_0 (wind_key); } } @@ -351,7 +352,7 @@ scm_i_dowinds (SCM to, long delta, void (*turn_func) (void *), void *data) if (SCM_VARIABLEP (SCM_CAR (wind_key))) scm_swap_bindings (wind_key, SCM_CDR (wind_elt)); } - else if (SCM_TYP3 (wind_key) == scm_tc3_closure) + else if (scm_is_true (scm_thunk_p (wind_key))) scm_call_0 (SCM_CDR (wind_elt)); } } 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..fadd75620 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. +/* 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 */ @@ -21,14 +22,15 @@ #endif #include "libguile/_scm.h" -#include "libguile/ramap.h" +#include "libguile/array-map.h" #include "libguile/stackchk.h" #include "libguile/strorder.h" #include "libguile/async.h" #include "libguile/root.h" #include "libguile/smob.h" -#include "libguile/unif.h" +#include "libguile/arrays.h" #include "libguile/vectors.h" +#include "libguile/bytevectors.h" #include "libguile/struct.h" #include "libguile/goops.h" @@ -238,6 +240,8 @@ SCM_PRIMITIVE_GENERIC_1 (scm_equal_p, "equal?", scm_tc7_rpsubr, } if (SCM_TYP7 (x) == scm_tc7_string && SCM_TYP7 (y) == scm_tc7_string) return scm_string_equal_p (x, y); + if (SCM_TYP7 (x) == scm_tc7_bytevector && SCM_TYP7 (y) == scm_tc7_bytevector) + return scm_bytevector_eq_p (x, y); if (SCM_TYP7 (x) == scm_tc7_smob && SCM_TYP16 (x) == SCM_TYP16 (y)) { int i = SCM_SMOBNUM (x); 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..bcbcd9cd1 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 */ @@ -232,6 +233,19 @@ scm_wrong_type_arg (const char *subr, int pos, SCM bad_value) } void +scm_i_wrong_type_arg_symbol (SCM symbol, int pos, SCM bad_value) +{ + scm_error_scm (scm_arg_type_key, + scm_symbol_to_string (symbol), + (pos == 0) ? scm_from_locale_string ("Wrong type: ~S") + : scm_from_locale_string ("Wrong type argument in position ~A: ~S"), + (pos == 0) ? scm_list_1 (bad_value) + : scm_list_2 (scm_from_int (pos), bad_value), + scm_list_1 (bad_value)); + scm_remember_upto_here_2 (symbol, bad_value); +} + +void scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *szMessage) { SCM msg = scm_from_locale_string (szMessage); diff --git a/libguile/error.h b/libguile/error.h index 042fb4d14..8cc68b752 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 */ @@ -52,6 +53,8 @@ SCM_API void scm_wrong_num_args (SCM proc) SCM_NORETURN; SCM_API void scm_error_num_args_subr (const char* subr) SCM_NORETURN; SCM_API void scm_wrong_type_arg (const char *subr, int pos, SCM bad_value) SCM_NORETURN; +SCM_INTERNAL void scm_i_wrong_type_arg_symbol (SCM symbol, int pos, + SCM bad_value) SCM_NORETURN; SCM_API void scm_wrong_type_arg_msg (const char *subr, int pos, SCM bad_value, const char *sz) SCM_NORETURN; SCM_API void scm_memory_error (const char *subr) SCM_NORETURN; diff --git a/libguile/eval.c b/libguile/eval.c index 18cd3b11f..e58c05410 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 */ @@ -52,6 +53,7 @@ #include "libguile/ports.h" #include "libguile/print.h" #include "libguile/procprop.h" +#include "libguile/programs.h" #include "libguile/root.h" #include "libguile/smob.h" #include "libguile/srcprop.h" @@ -62,6 +64,7 @@ #include "libguile/validate.h" #include "libguile/values.h" #include "libguile/vectors.h" +#include "libguile/vm.h" #include "libguile/eval.h" #include "libguile/private-options.h" @@ -304,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} @@ -704,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) { @@ -826,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_GLOBAL_SYMBOL (scm_sym_and, "and"); -SCM +static SCM scm_m_and (SCM expr, SCM env SCM_UNUSED) { const SCM cdr_expr = SCM_CDR (expr); @@ -917,9 +958,9 @@ 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_GLOBAL_SYMBOL (scm_sym_begin, "begin"); -SCM +static SCM scm_m_begin (SCM expr, SCM env SCM_UNUSED) { const SCM cdr_expr = SCM_CDR (expr); @@ -940,10 +981,10 @@ unmemoize_begin (const SCM expr, const SCM env) SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case); -SCM_GLOBAL_SYMBOL (scm_sym_case, s_case); +SCM_GLOBAL_SYMBOL (scm_sym_case, "case"); SCM_GLOBAL_SYMBOL (scm_sym_else, "else"); -SCM +static SCM scm_m_case (SCM expr, SCM env) { SCM clauses; @@ -1036,10 +1077,10 @@ unmemoize_case (const SCM expr, const SCM env) SCM_SYNTAX (s_cond, "cond", scm_i_makbimacro, scm_m_cond); -SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond); +SCM_GLOBAL_SYMBOL (scm_sym_cond, "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. */ @@ -1139,7 +1180,7 @@ unmemoize_cond (const SCM expr, const SCM env) SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define); -SCM_GLOBAL_SYMBOL (scm_sym_define, s_define); +SCM_GLOBAL_SYMBOL (scm_sym_define, "define"); /* Guile provides an extension to R5RS' define syntax to represent function * currying in a compact way. With this extension, it is allowed to write @@ -1201,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); @@ -1250,13 +1291,13 @@ memoize_as_thunk_prototype (const SCM expr, const SCM env SCM_UNUSED) SCM_SYNTAX (s_delay, "delay", scm_i_makbimacro, scm_m_delay); -SCM_GLOBAL_SYMBOL (scm_sym_delay, s_delay); +SCM_GLOBAL_SYMBOL (scm_sym_delay, "delay"); /* Promises are implemented as closures with an empty parameter list. Thus, * (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); @@ -1279,7 +1320,7 @@ unmemoize_delay (const SCM expr, const SCM env) SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do); -SCM_GLOBAL_SYMBOL(scm_sym_do, s_do); +SCM_GLOBAL_SYMBOL(scm_sym_do, "do"); /* DO gets the most radically altered syntax. The order of the vars is * reversed here. During the evaluation this allows for simple consing of the @@ -1299,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; @@ -1395,9 +1436,9 @@ 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_GLOBAL_SYMBOL (scm_sym_if, "if"); -SCM +static SCM scm_m_if (SCM expr, SCM env SCM_UNUSED) { const SCM cdr_expr = SCM_CDR (expr); @@ -1429,7 +1470,7 @@ unmemoize_if (const SCM expr, const SCM env) SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda); -SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda); +SCM_GLOBAL_SYMBOL (scm_sym_lambda, "lambda"); /* A helper function for memoize_lambda to support checking for duplicate * formal arguments: Return true if OBJ is `eq?' to one of the elements of @@ -1447,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; @@ -1577,7 +1618,7 @@ transform_bindings ( SCM_SYNTAX(s_let, "let", scm_i_makbimacro, scm_m_let); -SCM_GLOBAL_SYMBOL(scm_sym_let, s_let); +SCM_GLOBAL_SYMBOL(scm_sym_let, "let"); /* This function is a helper function for memoize_let. It transforms * (let name ((var init) ...) body ...) into @@ -1617,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; @@ -1689,9 +1730,9 @@ 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_GLOBAL_SYMBOL(scm_sym_letrec, "letrec"); -SCM +static SCM scm_m_letrec (SCM expr, SCM env) { SCM bindings; @@ -1738,11 +1779,11 @@ unmemoize_letrec (const SCM expr, const SCM env) SCM_SYNTAX (s_letstar, "let*", scm_i_makbimacro, scm_m_letstar); -SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar); +SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*"); /* (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; @@ -1813,9 +1854,9 @@ 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_GLOBAL_SYMBOL (scm_sym_or, "or"); -SCM +static SCM scm_m_or (SCM expr, SCM env SCM_UNUSED) { const SCM cdr_expr = SCM_CDR (expr); @@ -1843,7 +1884,7 @@ unmemoize_or (const SCM expr, const SCM env) SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote); -SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote); +SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote"); SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote"); SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing"); @@ -1899,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); @@ -1910,9 +1951,9 @@ 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_GLOBAL_SYMBOL (scm_sym_quote, "quote"); -SCM +static SCM scm_m_quote (SCM expr, SCM env SCM_UNUSED) { SCM quotee; @@ -1938,10 +1979,9 @@ unmemoize_quote (const SCM expr, const SCM env SCM_UNUSED) /* Will go into the RnRS module when Guile is factorized. 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_GLOBAL_SYMBOL (scm_sym_set_x, "set!"); -SCM +static SCM scm_m_set_x (SCM expr, SCM env SCM_UNUSED) { SCM variable; @@ -1971,14 +2011,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, "@"); + +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, "@@"); + +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_GLOBAL_SYMBOL (scm_sym_atapply, "@apply"); +SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply"); -SCM +static SCM scm_m_apply (SCM expr, SCM env SCM_UNUSED) { const SCM cdr_expr = SCM_CDR (expr); @@ -2015,7 +2098,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; @@ -2052,9 +2135,9 @@ 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_GLOBAL_SYMBOL(scm_sym_atcall_cc, "@call-with-current-continuation"); -SCM +static SCM scm_m_cont (SCM expr, SCM env SCM_UNUSED) { const SCM cdr_expr = SCM_CDR (expr); @@ -2073,9 +2156,9 @@ 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_GLOBAL_SYMBOL(scm_sym_at_call_with_values, "@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); @@ -2093,20 +2176,39 @@ 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, "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. */ SCM_SYNTAX (s_future, "future", scm_i_makbimacro, scm_m_future); -SCM_GLOBAL_SYMBOL (scm_sym_future, s_future); +SCM_GLOBAL_SYMBOL (scm_sym_future, "future"); /* Like promises, futures are implemented as closures with an empty * parameter list. Thus, (future <expression>) is transformed into * (#@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); @@ -2126,7 +2228,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; @@ -2183,9 +2285,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; @@ -2218,7 +2322,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; @@ -2256,7 +2360,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)); @@ -2279,7 +2383,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; @@ -2450,20 +2554,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; @@ -2487,55 +2582,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 - - -#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 /* SCM_ENABLE_DEPRECATED */ -#endif + /*****************************************************************************/ /*****************************************************************************/ /* The definitions for execution start here. */ @@ -2660,9 +2710,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 @@ -2965,8 +3012,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", 20000, "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' " @@ -3050,32 +3108,56 @@ SCM_DEFINE (scm_evaluator_traps, "evaluator-traps-interface", 0, 1, 0, SCM scm_call_0 (SCM proc) { - return scm_apply (proc, SCM_EOL, SCM_EOL); + if (SCM_PROGRAM_P (proc)) + return scm_c_vm_run (scm_the_vm (), proc, NULL, 0); + else + return scm_apply (proc, SCM_EOL, SCM_EOL); } SCM scm_call_1 (SCM proc, SCM arg1) { - return scm_apply (proc, arg1, scm_listofnull); + if (SCM_PROGRAM_P (proc)) + return scm_c_vm_run (scm_the_vm (), proc, &arg1, 1); + else + return scm_apply (proc, arg1, scm_listofnull); } SCM scm_call_2 (SCM proc, SCM arg1, SCM arg2) { - return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull)); + if (SCM_PROGRAM_P (proc)) + { + SCM args[] = { arg1, arg2 }; + return scm_c_vm_run (scm_the_vm (), proc, args, 2); + } + else + return scm_apply (proc, arg1, scm_cons (arg2, scm_listofnull)); } SCM scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3) { - return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull)); + if (SCM_PROGRAM_P (proc)) + { + SCM args[] = { arg1, arg2, arg3 }; + return scm_c_vm_run (scm_the_vm (), proc, args, 3); + } + else + return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, scm_listofnull)); } SCM scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4) { - return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, - scm_cons (arg4, scm_listofnull))); + if (SCM_PROGRAM_P (proc)) + { + SCM args[] = { arg1, arg2, arg3, arg4 }; + return scm_c_vm_run (scm_the_vm (), proc, args, 4); + } + else + return scm_apply (proc, arg1, scm_cons2 (arg2, arg3, + scm_cons (arg4, scm_listofnull))); } /* Simple procedure applies @@ -3245,6 +3327,7 @@ scm_trampoline_0 (SCM proc) case scm_tc7_rpsubr: case scm_tc7_gsubr: case scm_tc7_pws: + case scm_tc7_program: trampoline = scm_call_0; break; default: @@ -3297,8 +3380,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_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1); } static SCM @@ -3371,6 +3453,7 @@ scm_trampoline_1 (SCM proc) case scm_tc7_rpsubr: case scm_tc7_gsubr: case scm_tc7_pws: + case scm_tc7_program: trampoline = scm_call_1; break; default: @@ -3465,6 +3548,7 @@ scm_trampoline_2 (SCM proc) break; case scm_tc7_gsubr: case scm_tc7_pws: + case scm_tc7_program: trampoline = scm_call_2; break; default: @@ -3663,13 +3747,23 @@ scm_closure (SCM code, SCM env) scm_t_bits scm_tc16_promise; -SCM -scm_makprom (SCM code) -{ +SCM_DEFINE (scm_make_promise, "make-promise", 1, 0, 0, + (SCM thunk), + "Create a new promise object.\n\n" + "@code{make-promise} is a procedural form of @code{delay}.\n" + "These two expressions are equivalent:\n" + "@lisp\n" + "(delay @var{exp})\n" + "(make-promise (lambda () @var{exp}))\n" + "@end lisp\n") +#define FUNC_NAME s_scm_make_promise +{ + SCM_VALIDATE_THUNK (1, thunk); SCM_RETURN_NEWSMOB2 (scm_tc16_promise, - SCM_UNPACK (code), + SCM_UNPACK (thunk), scm_make_recursive_mutex ()); } +#undef FUNC_NAME static int @@ -4020,11 +4114,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 bf6279b82..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); @@ -162,7 +135,7 @@ SCM_API SCM scm_dapply (SCM proc, SCM arg1, SCM args); SCM_API SCM scm_map (SCM proc, SCM arg1, SCM args); SCM_API SCM scm_for_each (SCM proc, SCM arg1, SCM args); SCM_API SCM scm_closure (SCM code, SCM env); -SCM_API SCM scm_makprom (SCM code); +SCM_API SCM scm_make_promise (SCM thunk); SCM_API SCM scm_force (SCM x); SCM_API SCM scm_promise_p (SCM x); SCM_API SCM scm_cons_source (SCM xorig, SCM x, SCM y); @@ -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 ae666d415..25abf6cb9 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 @@ -732,7 +733,7 @@ dispatch: case (ISYMNUM (SCM_IM_DELAY)): - RETURN (scm_makprom (scm_closure (SCM_CDR (x), env))); + RETURN (scm_make_promise (scm_closure (SCM_CDR (x), env))); #if 0 /* See futures.h for a comment why futures are not enabled. @@ -855,9 +856,12 @@ dispatch: args = SCM_CDR (args); z = SCM_CDR (z); } - /* Fewer arguments than specifiers => CAR != ENV */ - if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z))) - goto apply_cmethod; + /* Fewer arguments than specifiers => CAR != CLASS */ + if (!scm_is_pair (z)) + goto apply_vm_cmethod; + else if (!SCM_CLASSP (SCM_CAR (z)) + && !scm_is_symbol (SCM_CAR (z))) + goto apply_memoized_cmethod; next_method: hash_value = (hash_value + 1) & mask; } while (hash_value != cache_end_pos); @@ -865,13 +869,21 @@ dispatch: /* No appropriate method was found in the cache. */ z = scm_memoize_method (x, arg1); - apply_cmethod: /* inputs: z, arg1 */ - { - SCM formals = SCM_CMETHOD_FORMALS (z); - env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z)); - x = SCM_CMETHOD_BODY (z); - goto nontoplevel_begin; - } + if (scm_is_pair (z)) + goto apply_memoized_cmethod; + + apply_vm_cmethod: + proc = z; + PREP_APPLY (proc, arg1); + goto apply_proc; + + apply_memoized_cmethod: /* inputs: z, arg1 */ + { + SCM formals = SCM_CMETHOD_FORMALS (z); + env = SCM_EXTEND_ENV (formals, arg1, SCM_CMETHOD_ENV (z)); + x = SCM_CMETHOD_BODY (z); + goto nontoplevel_begin; + } } } @@ -1120,6 +1132,8 @@ dispatch: RETURN (SCM_BOOL_T); case scm_tc7_asubr: RETURN (SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED)); + case scm_tc7_program: + RETURN (scm_c_vm_run (scm_the_vm (), proc, NULL, 0)); case scm_tc7_smob: if (!SCM_SMOB_APPLICABLE_P (proc)) goto badfun; @@ -1224,13 +1238,13 @@ dispatch: { 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_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1); case scm_tc7_cxr: RETURN (scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc))); case scm_tc7_rpsubr: RETURN (SCM_BOOL_T); + case scm_tc7_program: + RETURN (scm_c_vm_run (scm_the_vm (), proc, &arg1, 1)); case scm_tc7_asubr: RETURN (SCM_SUBRF (proc) (arg1, SCM_UNDEFINED)); case scm_tc7_lsubr: @@ -1341,6 +1355,12 @@ dispatch: case scm_tc7_rpsubr: case scm_tc7_asubr: RETURN (SCM_SUBRF (proc) (arg1, arg2)); + case scm_tc7_program: + { SCM args[2]; + args[0] = arg1; + args[1] = arg2; + RETURN (scm_c_vm_run (scm_the_vm (), proc, args, 2)); + } case scm_tc7_smob: if (!SCM_SMOB_APPLICABLE_P (proc)) goto badfun; @@ -1480,6 +1500,8 @@ dispatch: SCM_CDDR (debug.info->a.args))); case scm_tc7_gsubr: RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args)); + case scm_tc7_program: + RETURN (scm_vm_apply (scm_the_vm (), proc, debug.info->a.args)); case scm_tc7_pws: proc = SCM_PROCEDURE (proc); debug.info->a.proc = proc; @@ -1551,6 +1573,11 @@ dispatch: scm_cons2 (arg1, arg2, scm_ceval_args (x, env, proc)))); + case scm_tc7_program: + RETURN (scm_vm_apply + (scm_the_vm (), proc, + scm_cons (arg1, scm_cons (arg2, + scm_ceval_args (x, env, proc))))); case scm_tc7_pws: proc = SCM_PROCEDURE (proc); if (!SCM_CLOSUREP (proc)) @@ -1752,8 +1779,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_WTA_DISPATCH_1_SUBR (proc, arg1, SCM_ARG1); case scm_tc7_cxr: if (SCM_UNLIKELY (SCM_UNBNDP (arg1) || !scm_is_null (args))) scm_wrong_num_args (proc); @@ -1786,6 +1812,11 @@ tail: args = SCM_CDR (args); } RETURN (arg1); + case scm_tc7_program: + if (SCM_UNBNDP (arg1)) + RETURN (scm_c_vm_run (scm_the_vm (), proc, NULL, 0)); + else + RETURN (scm_vm_apply (scm_the_vm (), proc, scm_cons (arg1, args))); case scm_tc7_rpsubr: if (scm_is_null (args)) RETURN (SCM_BOOL_T); diff --git a/libguile/evalext.c b/libguile/evalext.c index 5ca78066d..78b666f65 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); @@ -107,6 +82,8 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0, case scm_tc7_string: case scm_tc7_smob: case scm_tc7_pws: + case scm_tc7_program: + case scm_tc7_bytevector: case scm_tcs_subrs: case scm_tcs_struct: return 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..d01e9c656 100644 --- a/libguile/extensions.c +++ b/libguile/extensions.c @@ -1,20 +1,21 @@ /* extensions.c - registering and loading extensions. * - * 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 */ #ifdef HAVE_CONFIG_H @@ -40,7 +41,7 @@ typedef struct extension_t void *data; } extension_t; -static extension_t *registered_extensions; +static extension_t *registered_extensions = NULL; /* Register a LIB/INIT pair for use by `scm_load_extension'. LIB is allowed to be NULL and then only INIT is used to identify the @@ -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. */ @@ -151,7 +157,6 @@ SCM_DEFINE (scm_load_extension, "load-extension", 2, 0, 0, void scm_init_extensions () { - registered_extensions = NULL; #include "libguile/extensions.x" } 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..c602f6735 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); } @@ -1561,31 +1573,39 @@ SCM_DEFINE (scm_dirname, "dirname", 1, 0, 0, "component, @code{.} is returned.") #define FUNC_NAME s_scm_dirname { - const char *s; long int i; unsigned long int len; SCM_VALIDATE_STRING (1, filename); - s = scm_i_string_chars (filename); len = scm_i_string_length (filename); i = len - 1; #ifdef __MINGW32__ - while (i >= 0 && (s[i] == '/' || s[i] == '\\')) --i; - while (i >= 0 && (s[i] != '/' && s[i] != '\\')) --i; - while (i >= 0 && (s[i] == '/' || s[i] == '\\')) --i; + while (i >= 0 && (scm_i_string_ref (filename, i) == '/' + || scm_i_string_ref (filename, i) == '\\')) + --i; + while (i >= 0 && (scm_i_string_ref (filename, i) != '/' + && scm_i_string_ref (filename, i) != '\\')) + --i; + while (i >= 0 && (scm_i_string_ref (filename, i) == '/' + || scm_i_string_ref (filename, i) == '\\')) + --i; #else - while (i >= 0 && s[i] == '/') --i; - while (i >= 0 && s[i] != '/') --i; - while (i >= 0 && s[i] == '/') --i; + while (i >= 0 && scm_i_string_ref (filename, i) == '/') + --i; + while (i >= 0 && scm_i_string_ref (filename, i) != '/') + --i; + while (i >= 0 && scm_i_string_ref (filename, i) == '/') + --i; #endif /* ndef __MINGW32__ */ if (i < 0) { #ifdef __MINGW32__ - if (len > 0 && (s[0] == '/' || s[0] == '\\')) + if (len > 0 && (scm_i_string_ref (filename, 0) == '/' + || scm_i_string_ref (filename, 0) == '\\')) #else - if (len > 0 && s[0] == '/') + if (len > 0 && scm_i_string_ref (filename, 0) == '/') #endif /* ndef __MINGW32__ */ return scm_c_substring (filename, 0, 1); else @@ -1604,11 +1624,9 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0, "@var{basename}, it is removed also.") #define FUNC_NAME s_scm_basename { - const char *f, *s = 0; int i, j, len, end; SCM_VALIDATE_STRING (1, filename); - f = scm_i_string_chars (filename); len = scm_i_string_length (filename); if (SCM_UNBNDP (suffix)) @@ -1616,32 +1634,44 @@ SCM_DEFINE (scm_basename, "basename", 1, 1, 0, else { SCM_VALIDATE_STRING (2, suffix); - s = scm_i_string_chars (suffix); j = scm_i_string_length (suffix) - 1; } i = len - 1; #ifdef __MINGW32__ - while (i >= 0 && (f[i] == '/' || f[i] == '\\')) --i; + while (i >= 0 && (scm_i_string_ref (filename, i) == '/' + || scm_i_string_ref (filename, i) == '\\')) + --i; #else - while (i >= 0 && f[i] == '/') --i; + while (i >= 0 && scm_i_string_ref (filename, i) == '/') + --i; #endif /* ndef __MINGW32__ */ end = i; - while (i >= 0 && j >= 0 && f[i] == s[j]) --i, --j; + while (i >= 0 && j >= 0 + && (scm_i_string_ref (filename, i) + == scm_i_string_ref (suffix, j))) + { + --i; + --j; + } if (j == -1) end = i; #ifdef __MINGW32__ - while (i >= 0 && f[i] != '/' && f[i] != '\\') --i; + while (i >= 0 && (scm_i_string_ref (filename, i) != '/' + && scm_i_string_ref (filename, i) != '\\')) + --i; #else - while (i >= 0 && f[i] != '/') --i; + while (i >= 0 && scm_i_string_ref (filename, i) != '/') + --i; #endif /* ndef __MINGW32__ */ if (i == end) { #ifdef __MINGW32__ - if (len > 0 && (f[0] == '/' || f[0] == '\\')) + if (len > 0 && (scm_i_string_ref (filename, 0) == '/' + || scm_i_string_ref (filename, 0) == '\\')) #else - if (len > 0 && f[0] == '/') + if (len > 0 && scm_i_string_ref (filename, 0) == '/') #endif /* ndef __MINGW32__ */ - return scm_c_substring (filename, 0, 1); + return scm_c_substring (filename, 0, 1); else return scm_dot_string; } @@ -1650,6 +1680,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..5d374950f 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 */ @@ -593,7 +594,7 @@ static void fport_flush (SCM port); /* fill a port's read-buffer with a single read. returns the first char or EOF if end of file. */ -static int +static scm_t_wchar fport_fill_input (SCM port) { long count; @@ -607,7 +608,7 @@ fport_fill_input (SCM port) if (count == -1) scm_syserror ("fport_fill_input"); if (count == 0) - return EOF; + return (scm_t_wchar) EOF; else { pt->read_pos = pt->read_buf; @@ -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 new file mode 100644 index 000000000..a6835fbb4 --- /dev/null +++ b/libguile/frames.c @@ -0,0 +1,272 @@ +/* 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 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 + */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#include <stdlib.h> +#include <string.h> +#include "_scm.h" +#include "vm-bootstrap.h" +#include "frames.h" + + +scm_t_bits scm_tc16_vm_frame; + +#define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame)) + +SCM +scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp, + scm_t_uint8 *ip, scm_t_ptrdiff offset) +{ + struct scm_vm_frame *p = scm_gc_malloc (sizeof (struct scm_vm_frame), + "vmframe"); + p->stack_holder = stack_holder; + p->fp = fp; + p->sp = sp; + p->ip = ip; + p->offset = offset; + SCM_RETURN_NEWSMOB (scm_tc16_vm_frame, p); +} + +static int +vm_frame_print (SCM frame, SCM port, scm_print_state *pstate) +{ + scm_puts ("#<vm-frame ", port); + scm_uintprint (SCM_UNPACK (frame), 16, port); + scm_putc (' ', port); + scm_write (scm_vm_frame_program (frame), port); + /* don't write args, they can get us into trouble. */ + scm_puts (">", port); + + return 1; +} + + +/* Scheme interface */ + +SCM_DEFINE (scm_vm_frame_p, "vm-frame?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_vm_frame_p +{ + return SCM_BOOL (SCM_VM_FRAME_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_frame_program, "vm-frame-program", 1, 0, 0, + (SCM frame), + "") +#define FUNC_NAME s_scm_vm_frame_program +{ + SCM_VALIDATE_VM_FRAME (1, frame); + return SCM_FRAME_PROGRAM (SCM_VM_FRAME_FP (frame)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_frame_arguments, "vm-frame-arguments", 1, 0, 0, + (SCM frame), + "") +#define FUNC_NAME s_scm_vm_frame_arguments +{ + SCM *fp; + int i; + struct scm_objcode *bp; + SCM ret; + + SCM_VALIDATE_VM_FRAME (1, frame); + + fp = SCM_VM_FRAME_FP (frame); + bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp)); + + if (!bp->nargs) + return SCM_EOL; + else if (bp->nrest) + ret = SCM_FRAME_VARIABLE (fp, bp->nargs - 1); + else + ret = scm_cons (SCM_FRAME_VARIABLE (fp, bp->nargs - 1), SCM_EOL); + + for (i = bp->nargs - 2; i >= 0; i--) + ret = scm_cons (SCM_FRAME_VARIABLE (fp, i), ret); + + return ret; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_frame_source, "vm-frame-source", 1, 0, 0, + (SCM frame), + "") +#define FUNC_NAME s_scm_vm_frame_source +{ + SCM *fp; + struct scm_objcode *bp; + + SCM_VALIDATE_VM_FRAME (1, frame); + + fp = SCM_VM_FRAME_FP (frame); + bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp)); + + return scm_c_program_source (SCM_FRAME_PROGRAM (fp), + SCM_VM_FRAME_IP (frame) - bp->base); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_frame_local_ref, "vm-frame-local-ref", 2, 0, 0, + (SCM frame, SCM index), + "") +#define FUNC_NAME s_scm_vm_frame_local_ref +{ + SCM *fp; + unsigned int i; + struct scm_objcode *bp; + + SCM_VALIDATE_VM_FRAME (1, frame); + + fp = SCM_VM_FRAME_FP (frame); + bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp)); + + SCM_VALIDATE_UINT_COPY (2, index, i); + SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs); + + return SCM_FRAME_VARIABLE (fp, i); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_frame_local_set_x, "vm-frame-local-set!", 3, 0, 0, + (SCM frame, SCM index, SCM val), + "") +#define FUNC_NAME s_scm_vm_frame_local_set_x +{ + SCM *fp; + unsigned int i; + struct scm_objcode *bp; + + SCM_VALIDATE_VM_FRAME (1, frame); + + fp = SCM_VM_FRAME_FP (frame); + bp = SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp)); + + SCM_VALIDATE_UINT_COPY (2, index, i); + SCM_ASSERT_RANGE (2, index, i < bp->nargs + bp->nlocs); + + SCM_FRAME_VARIABLE (fp, i) = val; + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_frame_return_address, "vm-frame-return-address", 1, 0, 0, + (SCM frame), + "") +#define FUNC_NAME s_scm_vm_frame_return_address +{ + SCM_VALIDATE_VM_FRAME (1, frame); + return scm_from_ulong ((unsigned long) + (SCM_FRAME_RETURN_ADDRESS + (SCM_VM_FRAME_FP (frame)))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_frame_mv_return_address, "vm-frame-mv-return-address", 1, 0, 0, + (SCM frame), + "") +#define FUNC_NAME s_scm_vm_frame_mv_return_address +{ + SCM_VALIDATE_VM_FRAME (1, frame); + return scm_from_ulong ((unsigned long) + (SCM_FRAME_MV_RETURN_ADDRESS + (SCM_VM_FRAME_FP (frame)))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_frame_dynamic_link, "vm-frame-dynamic-link", 1, 0, 0, + (SCM frame), + "") +#define FUNC_NAME s_scm_vm_frame_dynamic_link +{ + SCM_VALIDATE_VM_FRAME (1, frame); + /* fixme: munge fp if holder is a continuation */ + return scm_from_ulong + ((unsigned long) + RELOC (frame, + SCM_FRAME_DYNAMIC_LINK (SCM_VM_FRAME_FP (frame)))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_frame_stack, "vm-frame-stack", 1, 0, 0, + (SCM frame), + "") +#define FUNC_NAME s_scm_vm_frame_stack +{ + SCM *top, *bottom, ret = SCM_EOL; + + SCM_VALIDATE_VM_FRAME (1, frame); + + top = SCM_VM_FRAME_SP (frame); + bottom = SCM_FRAME_UPPER_ADDRESS (SCM_VM_FRAME_FP (frame)); + while (bottom <= top) + ret = scm_cons (*bottom++, ret); + + return ret; +} +#undef FUNC_NAME + +extern SCM +scm_c_vm_frame_prev (SCM frame) +{ + SCM *this_fp, *new_fp, *new_sp; + this_fp = SCM_VM_FRAME_FP (frame); + new_fp = SCM_FRAME_DYNAMIC_LINK (this_fp); + if (new_fp) + { new_fp = RELOC (frame, new_fp); + new_sp = SCM_FRAME_LOWER_ADDRESS (this_fp) - 1; + return scm_c_make_vm_frame (SCM_VM_FRAME_STACK_HOLDER (frame), + new_fp, new_sp, + SCM_FRAME_RETURN_ADDRESS (this_fp), + SCM_VM_FRAME_OFFSET (frame)); + } + else + return SCM_BOOL_F; +} + + +void +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 +scm_init_frames (void) +{ + scm_bootstrap_vm (); + +#ifndef SCM_MAGIC_SNARFER +#include "libguile/frames.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/frames.h b/libguile/frames.h new file mode 100644 index 000000000..0165924a7 --- /dev/null +++ b/libguile/frames.h @@ -0,0 +1,126 @@ +/* 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 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_FRAMES_H_ +#define _SCM_FRAMES_H_ + +#include <libguile.h> +#include "programs.h" + + +/* + * VM frames + */ + +/* VM Frame Layout + --------------- + + | ... | + | Intermed. val. 0 | <- fp + bp->nargs + bp->nlocs = SCM_FRAME_UPPER_ADDRESS (fp) + +==================+ + | Local variable 1 | + | Local variable 0 | <- fp + bp->nargs + | Argument 1 | + | Argument 0 | <- fp + | Program | <- fp - 1 + +------------------+ + | Return address | + | MV return address| + | Dynamic link | <- fp - 4 = SCM_FRAME_DATA_ADDRESS (fp) = SCM_FRAME_LOWER_ADDRESS (fp) + +==================+ + | | + + As can be inferred from this drawing, it is assumed that + `sizeof (SCM *) == sizeof (SCM)', since pointers (the `link' parts) are + assumed to be as long as SCM objects. */ + +#define SCM_FRAME_DATA_ADDRESS(fp) (fp - 4) +#define SCM_FRAME_UPPER_ADDRESS(fp) \ + (fp \ + + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nargs \ + + SCM_PROGRAM_DATA (SCM_FRAME_PROGRAM (fp))->nlocs) +#define SCM_FRAME_LOWER_ADDRESS(fp) (fp - 4) + +#define SCM_FRAME_BYTE_CAST(x) ((scm_t_uint8 *) 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)[2])) +#define SCM_FRAME_SET_RETURN_ADDRESS(fp, ra) \ + ((SCM_FRAME_DATA_ADDRESS (fp)[2])) = (SCM)(ra); +#define SCM_FRAME_MV_RETURN_ADDRESS(fp) \ + (SCM_FRAME_BYTE_CAST (SCM_FRAME_DATA_ADDRESS (fp)[1])) +#define SCM_FRAME_SET_MV_RETURN_ADDRESS(fp, mvra) \ + ((SCM_FRAME_DATA_ADDRESS (fp)[1])) = (SCM)(mvra); +#define SCM_FRAME_DYNAMIC_LINK(fp) \ + (SCM_FRAME_STACK_CAST (SCM_FRAME_DATA_ADDRESS (fp)[0])) +#define SCM_FRAME_SET_DYNAMIC_LINK(fp, dl) \ + ((SCM_FRAME_DATA_ADDRESS (fp)[0])) = (SCM)(dl); +#define SCM_FRAME_VARIABLE(fp,i) fp[i] +#define SCM_FRAME_PROGRAM(fp) fp[-1] + + +/* + * Heap frames + */ + +SCM_API scm_t_bits scm_tc16_vm_frame; + +struct scm_vm_frame +{ + SCM stack_holder; + SCM *fp; + SCM *sp; + scm_t_uint8 *ip; + scm_t_ptrdiff offset; +}; + +#define SCM_VM_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm_frame, x) +#define SCM_VM_FRAME_DATA(x) ((struct scm_vm_frame*)SCM_SMOB_DATA (x)) +#define SCM_VM_FRAME_STACK_HOLDER(f) SCM_VM_FRAME_DATA(f)->stack_holder +#define SCM_VM_FRAME_FP(f) SCM_VM_FRAME_DATA(f)->fp +#define SCM_VM_FRAME_SP(f) SCM_VM_FRAME_DATA(f)->sp +#define SCM_VM_FRAME_IP(f) SCM_VM_FRAME_DATA(f)->ip +#define SCM_VM_FRAME_OFFSET(f) SCM_VM_FRAME_DATA(f)->offset +#define SCM_VALIDATE_VM_FRAME(p,x) SCM_MAKE_VALIDATE (p, x, VM_FRAME_P) + +SCM_API SCM scm_c_make_vm_frame (SCM stack_holder, SCM *fp, SCM *sp, + scm_t_uint8 *ip, scm_t_ptrdiff offset); +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_ */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ 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..e48d2cfd1 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. +/* Copyright (C) 1995,1996,1997,1998,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 */ @@ -36,7 +37,7 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include "libguile/stackchk.h" #include "libguile/struct.h" #include "libguile/smob.h" -#include "libguile/unif.h" +#include "libguile/arrays.h" #include "libguile/async.h" #include "libguile/ports.h" #include "libguile/root.h" @@ -77,25 +78,6 @@ extern unsigned long * __libc_ia64_register_backing_store_base; /* #define DEBUGINFO */ -static int scm_i_minyield_malloc; - -void -scm_gc_init_malloc (void) -{ - scm_mtrigger = scm_getenv_int ("GUILE_INIT_MALLOC_LIMIT", - SCM_DEFAULT_INIT_MALLOC_LIMIT); - scm_i_minyield_malloc = scm_getenv_int ("GUILE_MIN_YIELD_MALLOC", - SCM_DEFAULT_MALLOC_MINYIELD); - - if (scm_i_minyield_malloc >= 100) - scm_i_minyield_malloc = 99; - if (scm_i_minyield_malloc < 1) - scm_i_minyield_malloc = 1; - - if (scm_mtrigger < 0) - scm_mtrigger = SCM_DEFAULT_INIT_MALLOC_LIMIT; -} - /* Function for non-cell memory management. diff --git a/libguile/gc-segment-table.c b/libguile/gc-segment-table.c deleted file mode 100644 index 3e92c8c5c..000000000 --- a/libguile/gc-segment-table.c +++ /dev/null @@ -1,299 +0,0 @@ -/* 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. - * - * 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 <assert.h> -#include <stdio.h> -#include <string.h> - -#include "libguile/_scm.h" -#include "libguile/pairs.h" -#include "libguile/gc.h" -#include "libguile/private-gc.h" - - -/* - Heap segment table. - - The table is sorted by the address of the data itself. This makes - for easy lookups. This is not portable: according to ANSI C, - pointers can only be compared within the same object (i.e. the same - block of malloced memory.). For machines with weird architectures, - this should be revised. - - (Apparently, for this reason 1.6 and earlier had macros for pointer - comparison. ) - - perhaps it is worthwhile to remove the 2nd level of indirection in - the table, but this certainly makes for cleaner code. -*/ -scm_t_heap_segment **scm_i_heap_segment_table; -size_t scm_i_heap_segment_table_size; -static scm_t_cell *lowest_cell; -static scm_t_cell *highest_cell; - - -/* - RETURN: index of inserted segment. - */ -int -scm_i_insert_segment (scm_t_heap_segment *seg) -{ - size_t size = (scm_i_heap_segment_table_size + 1) * sizeof (scm_t_heap_segment *); - SCM_SYSCALL (scm_i_heap_segment_table - = ((scm_t_heap_segment **) - realloc ((char *)scm_i_heap_segment_table, size))); - - /* - We can't alloc 4 more bytes. This is hopeless. - */ - if (!scm_i_heap_segment_table) - { - fprintf (stderr, "scm_i_get_new_heap_segment: Could not grow heap segment table.\n"); - abort (); - } - - if (!lowest_cell) - { - lowest_cell = seg->bounds[0]; - highest_cell = seg->bounds[1]; - } - else - { - lowest_cell = SCM_MIN (lowest_cell, seg->bounds[0]); - highest_cell = SCM_MAX (highest_cell, seg->bounds[1]); - } - - - { - int i = 0; - int j = 0; - - while (i < scm_i_heap_segment_table_size - && scm_i_heap_segment_table[i]->bounds[0] <= seg->bounds[0]) - i++; - - /* - We insert a new entry; if that happens to be before the - "current" segment of a freelist, we must move the freelist index - as well. - */ - if (scm_i_master_freelist.heap_segment_idx >= i) - scm_i_master_freelist.heap_segment_idx ++; - if (scm_i_master_freelist2.heap_segment_idx >= i) - scm_i_master_freelist2.heap_segment_idx ++; - - for (j = scm_i_heap_segment_table_size; j > i; --j) - scm_i_heap_segment_table[j] = scm_i_heap_segment_table[j - 1]; - - scm_i_heap_segment_table[i] = seg; - scm_i_heap_segment_table_size ++; - - return i; - } -} - - -/* - Determine whether the given value does actually represent a cell in - some heap segment. If this is the case, the number of the heap - segment is returned. Otherwise, -1 is returned. Binary search is - used to determine the heap segment that contains the cell. - - I think this function is too long to be inlined. --hwn -*/ - -int -scm_i_find_heap_segment_containing_object (SCM obj) -{ - if (!CELL_P (obj)) - return -1; - - scm_i_find_heap_calls ++; - if ((scm_t_cell *) obj < lowest_cell || (scm_t_cell *) obj >= highest_cell) - return -1; - - { - scm_t_cell *ptr = SCM2PTR (obj); - unsigned int i = 0; - unsigned int j = scm_i_heap_segment_table_size - 1; - - if (ptr < scm_i_heap_segment_table[i]->bounds[0]) - return -1; - else if (scm_i_heap_segment_table[j]->bounds[1] <= ptr) - return -1; - else - { - while (i < j) - { - if (ptr < scm_i_heap_segment_table[i]->bounds[1]) - { - break; - } - else if (scm_i_heap_segment_table[j]->bounds[0] <= ptr) - { - i = j; - break; - } - else - { - unsigned long int k = (i + j) / 2; - - if (k == i) - return -1; - else if (ptr < scm_i_heap_segment_table[k]->bounds[1]) - { - j = k; - ++i; - if (ptr < scm_i_heap_segment_table[i]->bounds[0]) - return -1; - } - else if (scm_i_heap_segment_table[k]->bounds[0] <= ptr) - { - i = k; - --j; - if (scm_i_heap_segment_table[j]->bounds[1] <= ptr) - return -1; - } - } - } - - if (!SCM_DOUBLECELL_ALIGNED_P (obj) && scm_i_heap_segment_table[i]->span == 2) - return -1; - else if (SCM_GC_IN_CARD_HEADERP (ptr)) - return -1; - else - return i; - } - } -} - - -int -scm_i_marked_count (void) -{ - int i = 0; - int c = 0; - for (; i < scm_i_heap_segment_table_size; i++) - { - c += scm_i_heap_segment_marked_count (scm_i_heap_segment_table[i]); - } - return c; -} - - -SCM -scm_i_sweep_some_segments (scm_t_cell_type_statistics *freelist, - scm_t_sweep_statistics *sweep_stats) -{ - int i = freelist->heap_segment_idx; - SCM collected = SCM_EOL; - - if (i == -1) /* huh? --hwn */ - i++; - - for (; - i < scm_i_heap_segment_table_size; i++) - { - if (scm_i_heap_segment_table[i]->freelist != freelist) - continue; - - collected = scm_i_sweep_some_cards (scm_i_heap_segment_table[i], - sweep_stats, - DEFAULT_SWEEP_AMOUNT); - - if (collected != SCM_EOL) /* Don't increment i */ - break; - } - - freelist->heap_segment_idx = i; - - return collected; -} - -void -scm_i_reset_segments (void) -{ - int i = 0; - for (; i < scm_i_heap_segment_table_size; i++) - { - scm_t_heap_segment *seg = scm_i_heap_segment_table[i]; - seg->next_free_card = seg->bounds[0]; - } -} - - - - -/* - Return a hashtab with counts of live objects, with tags as keys. - */ -SCM -scm_i_all_segments_statistics (SCM tab) -{ - int i = 0; - for (; i < scm_i_heap_segment_table_size; i++) - { - scm_t_heap_segment *seg = scm_i_heap_segment_table[i]; - scm_i_heap_segment_statistics (seg, tab); - } - - return tab; -} - - -unsigned long* -scm_i_segment_table_info (int* size) -{ - *size = scm_i_heap_segment_table_size; - unsigned long *bounds = malloc (sizeof (unsigned long) * *size * 2); - int i; - if (!bounds) - abort (); - for (i = *size; i-- > 0; ) - { - bounds[2*i] = (unsigned long)scm_i_heap_segment_table[i]->bounds[0]; - bounds[2*i+1] = (unsigned long)scm_i_heap_segment_table[i]->bounds[1]; - } - return bounds; -} - - -void -scm_i_sweep_all_segments (char const *reason, - scm_t_sweep_statistics *sweep_stats) -{ - unsigned i= 0; - for (i = 0; i < scm_i_heap_segment_table_size; i++) - { - scm_i_sweep_segment (scm_i_heap_segment_table[i], sweep_stats); - } -} - - -void -scm_i_clear_mark_space (void) -{ - int i = 0; - for (; i < scm_i_heap_segment_table_size; i++) - { - scm_i_clear_segment_mark_space (scm_i_heap_segment_table[i]); - } -} diff --git a/libguile/gc.c b/libguile/gc.c index bb39efd91..d3c53c748 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 Free Software Foundation, Inc. +/* 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 */ @@ -39,7 +40,7 @@ extern unsigned long * __libc_ia64_register_backing_store_base; #include "libguile/stackchk.h" #include "libguile/struct.h" #include "libguile/smob.h" -#include "libguile/unif.h" +#include "libguile/arrays.h" #include "libguile/async.h" #include "libguile/ports.h" #include "libguile/root.h" @@ -106,13 +107,6 @@ int scm_i_cell_validation_already_running ; void scm_i_expensive_validation_check (SCM cell) { - if (!scm_in_heap_p (cell)) - { - fprintf (stderr, "scm_assert_cell_valid: this object does not live in the heap: %lux\n", - (unsigned long) SCM_UNPACK (cell)); - abort (); - } - /* If desired, perform additional garbage collections after a user * defined number of cell accesses. */ @@ -214,17 +208,10 @@ scm_t_c_hook scm_after_sweep_c_hook; scm_t_c_hook scm_after_gc_c_hook; -/* scm_mtrigger - * is the number of bytes of malloc allocation needed to trigger gc. - */ -unsigned long scm_mtrigger; - /* GC Statistics Keeping */ -unsigned long scm_mallocated = 0; unsigned long scm_gc_ports_collected = 0; - static unsigned long protected_obj_count = 0; @@ -679,8 +666,6 @@ scm_init_storage () while (j) scm_sys_protects[--j] = SCM_BOOL_F; - j = SCM_HEAP_SEG_SIZE; - #if 0 /* We can't have a cleanup handler since we have no thread to run it in. */ @@ -769,15 +754,10 @@ scm_i_tag_name (scm_t_bits tag) { if (tag >= 255) { - if (tag == scm_tc_free_cell) - return "free cell"; - - { - int k = 0xff & (tag >> 8); - return (scm_smobs[k].name); - } + int k = 0xff & (tag >> 8); + return (scm_smobs[k].name); } - + switch (tag) /* 7 bits */ { case scm_tcs_struct: diff --git a/libguile/gc.h b/libguile/gc.h index 4692a4935..40dab2ff5 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -3,21 +3,22 @@ #ifndef SCM_GC_H #define SCM_GC_H -/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2002, 2003, 2004, 2006, 2007, 2008 Free Software Foundation, Inc. +/* 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 */ @@ -115,15 +116,6 @@ typedef struct scm_t_cell #define SCM_CELL_TYPE(x) SCM_CELL_WORD_0 (x) #define SCM_SET_CELL_TYPE(x, t) SCM_SET_CELL_WORD_0 ((x), (t)) -/* Freelists consist of linked cells where the type entry holds the value - * scm_tc_free_cell and the second entry holds a pointer to the next cell of - * the freelist. Due to this structure, freelist cells are not cons cells - * and thus may not be accessed using SCM_CAR and SCM_CDR. */ - -#define SCM_FREE_CELL_CDR(x) \ - (SCM_GC_CELL_OBJECT ((x), 1)) -#define SCM_SET_FREE_CELL_CDR(x, v) \ - (SCM_GC_SET_CELL_OBJECT ((x), 1, (v))) #if (SCM_DEBUG_CELL_ACCESSES == 1) /* Set this to != 0 if every cell that is accessed shall be checked: @@ -160,17 +152,7 @@ SCM_API size_t scm_default_max_segment_size; #define scm_default_max_segment_size deprecated #endif - -SCM_API size_t scm_max_segment_size; - -#define SCM_SET_FREELIST_LOC(key,ptr) scm_i_pthread_setspecific ((key), (ptr)) -#define SCM_FREELIST_LOC(key) ((SCM *) scm_i_pthread_getspecific (key)) -SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist; -SCM_API struct scm_t_cell_type_statistics scm_i_master_freelist2; - -SCM_API unsigned long scm_mallocated; SCM_API unsigned long scm_gc_ports_collected; -SCM_API unsigned long scm_mtrigger; SCM_API SCM scm_after_gc_hook; @@ -180,18 +162,6 @@ SCM_API scm_t_c_hook scm_before_sweep_c_hook; SCM_API scm_t_c_hook scm_after_sweep_c_hook; SCM_API scm_t_c_hook scm_after_gc_c_hook; -#if defined (GUILE_DEBUG) || defined (GUILE_DEBUG_FREELIST) -#if (SCM_ENABLE_DEPRECATED == 1) -SCM scm_map_free_list (void); -#else -#define scm_map_free_list deprecated -#define scm_free_list_length deprecated -#endif -#endif - -#if (SCM_ENABLE_DEPRECATED == 1) && defined (GUILE_DEBUG_FREELIST) -SCM_API SCM scm_gc_set_debug_check_freelist_x (SCM flag); -#endif #if (SCM_DEBUG_CELL_ACCESSES == 1) @@ -210,7 +180,6 @@ SCM_API SCM scm_gc_live_object_stats (void); SCM_API SCM scm_gc (void); SCM_API void scm_i_gc (const char *what); SCM_API void scm_gc_mark (SCM p); -SCM_API int scm_in_heap_p (SCM value); SCM_API void scm_gc_sweep (void); SCM_API void *scm_malloc (size_t size); 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/generalized-arrays.c b/libguile/generalized-arrays.c new file mode 100644 index 000000000..6394405dd --- /dev/null +++ b/libguile/generalized-arrays.c @@ -0,0 +1,276 @@ +/* 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 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 <stdio.h> +#include <errno.h> +#include <string.h> + +#include "libguile/_scm.h" +#include "libguile/__scm.h" +#include "libguile/array-handle.h" +#include "libguile/generalized-arrays.h" + + +int +scm_is_array (SCM obj) +{ + return scm_i_array_implementation_for_obj (obj) ? 1 : 0; +} + +SCM_DEFINE (scm_array_p, "array?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n" + "not.") +#define FUNC_NAME s_scm_array_p +{ + return scm_from_bool (scm_is_array (obj)); +} +#undef FUNC_NAME + +int +scm_is_typed_array (SCM obj, SCM type) +{ + int ret = 0; + if (scm_i_array_implementation_for_obj (obj)) + { + scm_t_array_handle h; + + scm_array_get_handle (obj, &h); + ret = scm_is_eq (scm_array_handle_element_type (&h), type); + scm_array_handle_release (&h); + } + + return ret; +} + +SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0, + (SCM obj, SCM type), + "Return @code{#t} if the @var{obj} is an array of type\n" + "@var{type}, and @code{#f} if not.") +#define FUNC_NAME s_scm_typed_array_p +{ + return scm_from_bool (scm_is_typed_array (obj, type)); +} +#undef FUNC_NAME + +size_t +scm_c_array_rank (SCM array) +{ + scm_t_array_handle handle; + size_t res; + + scm_array_get_handle (array, &handle); + res = scm_array_handle_rank (&handle); + scm_array_handle_release (&handle); + return res; +} + +SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, + (SCM array), + "Return the number of dimensions of the array @var{array.}\n") +#define FUNC_NAME s_scm_array_rank +{ + return scm_from_size_t (scm_c_array_rank (array)); +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, + (SCM ra), + "@code{array-dimensions} is similar to @code{array-shape} but replaces\n" + "elements with a @code{0} minimum with one greater than the maximum. So:\n" + "@lisp\n" + "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n" + "@end lisp") +#define FUNC_NAME s_scm_array_dimensions +{ + scm_t_array_handle handle; + scm_t_array_dim *s; + SCM res = SCM_EOL; + size_t k; + + scm_array_get_handle (ra, &handle); + s = scm_array_handle_dims (&handle); + k = scm_array_handle_rank (&handle); + + while (k--) + res = scm_cons (s[k].lbnd + ? scm_cons2 (scm_from_ssize_t (s[k].lbnd), + scm_from_ssize_t (s[k].ubnd), + SCM_EOL) + : scm_from_ssize_t (1 + s[k].ubnd), + res); + + scm_array_handle_release (&handle); + return res; +} +#undef FUNC_NAME + +/* HACK*/ +#include "libguile/bytevectors.h" + +SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0, + (SCM ra), + "") +#define FUNC_NAME s_scm_array_type +{ + scm_t_array_handle h; + SCM type; + + /* a hack, until srfi-4 and bytevectors are reunited */ + if (scm_is_bytevector (ra)) + return scm_from_locale_symbol ("vu8"); + + scm_array_get_handle (ra, &h); + type = scm_array_handle_element_type (&h); + scm_array_handle_release (&h); + + return type; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, + (SCM ra, SCM args), + "Return @code{#t} if its arguments would be acceptable to\n" + "@code{array-ref}.") +#define FUNC_NAME s_scm_array_in_bounds_p +{ + SCM res = SCM_BOOL_T; + size_t k, ndim; + scm_t_array_dim *s; + scm_t_array_handle handle; + + SCM_VALIDATE_REST_ARGUMENT (args); + + scm_array_get_handle (ra, &handle); + s = scm_array_handle_dims (&handle); + ndim = scm_array_handle_rank (&handle); + + for (k = 0; k < ndim; k++) + { + long ind; + + if (!scm_is_pair (args)) + SCM_WRONG_NUM_ARGS (); + ind = scm_to_long (SCM_CAR (args)); + args = SCM_CDR (args); + + if (ind < s[k].lbnd || ind > s[k].ubnd) + { + res = SCM_BOOL_F; + /* We do not stop the checking after finding a violation + since we want to validate the type-correctness and + number of arguments in any case. + */ + } + } + + scm_array_handle_release (&handle); + return res; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1, + (SCM v, SCM args), + "Return the element at the @code{(index1, index2)} element in\n" + "@var{array}.") +#define FUNC_NAME s_scm_array_ref +{ + scm_t_array_handle handle; + SCM res; + + scm_array_get_handle (v, &handle); + res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args)); + scm_array_handle_release (&handle); + return res; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, + (SCM v, SCM obj, SCM args), + "Set the element at the @code{(index1, index2)} element in @var{array} to\n" + "@var{new-value}. The value returned by array-set! is unspecified.") +#define FUNC_NAME s_scm_array_set_x +{ + scm_t_array_handle handle; + + scm_array_get_handle (v, &handle); + scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj); + scm_array_handle_release (&handle); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +static SCM +array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos) +{ + if (dim == scm_array_handle_rank (h)) + return scm_array_handle_ref (h, pos); + else + { + SCM res = SCM_EOL; + long inc; + size_t i, lbnd; + + i = h->dims[dim].ubnd; + lbnd = h->dims[dim].lbnd; + inc = h->dims[dim].inc; + pos += (i - h->dims[dim].ubnd) * inc; + + for (; i >= lbnd; i--, pos -= inc) + res = scm_cons (array_to_list (h, dim + 1, pos), res); + return res; + } +} + +SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, + (SCM array), + "FIXME description a list consisting of all the elements, in order, of\n" + "@var{array}.") +#define FUNC_NAME s_scm_array_to_list +{ + scm_t_array_handle h; + SCM res; + + scm_array_get_handle (array, &h); + res = array_to_list (&h, 0, 0); + scm_array_handle_release (&h); + + return res; +} +#undef FUNC_NAME + +void +scm_init_generalized_arrays () +{ +#include "libguile/generalized-arrays.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/generalized-arrays.h b/libguile/generalized-arrays.h new file mode 100644 index 000000000..cc7214e8b --- /dev/null +++ b/libguile/generalized-arrays.h @@ -0,0 +1,63 @@ +/* classes: h_files */ + +#ifndef SCM_GENERALIZED_ARRAYS_H +#define SCM_GENERALIZED_ARRAYS_H + +/* Copyright (C) 1995,1996,1997,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 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" +#include "libguile/array-handle.h" + + + +/* These functions operate on all kinds of arrays that Guile knows about. + */ + + +/** Arrays */ + +SCM_API int scm_is_array (SCM obj); +SCM_API SCM scm_array_p (SCM v); + +SCM_API int scm_is_typed_array (SCM obj, SCM type); +SCM_API SCM scm_typed_array_p (SCM v, SCM type); + +SCM_API size_t scm_c_array_rank (SCM ra); +SCM_API SCM scm_array_rank (SCM ra); + +SCM_API SCM scm_array_dimensions (SCM ra); +SCM_API SCM scm_array_type (SCM ra); +SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args); + +SCM_API SCM scm_array_ref (SCM v, SCM args); +SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args); +SCM_API SCM scm_array_to_list (SCM v); + +SCM_INTERNAL void scm_init_generalized_arrays (void); + + +#endif /* SCM_GENERALIZED_ARRAYS_H */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c new file mode 100644 index 000000000..2d437a475 --- /dev/null +++ b/libguile/generalized-vectors.c @@ -0,0 +1,201 @@ +/* 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 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 "libguile/_scm.h" +#include "libguile/__scm.h" + +#include "libguile/array-handle.h" +#include "libguile/generalized-arrays.h" +#include "libguile/generalized-vectors.h" + + +struct scm_t_vector_ctor +{ + SCM tag; + SCM (*ctor)(SCM, SCM); +}; + +#define VECTOR_CTORS_N_STATIC_ALLOC 20 +static struct scm_t_vector_ctor vector_ctors[VECTOR_CTORS_N_STATIC_ALLOC]; +static int num_vector_ctors_registered = 0; + +void +scm_i_register_vector_constructor (SCM type, SCM (*ctor)(SCM, SCM)) +{ + if (num_vector_ctors_registered >= VECTOR_CTORS_N_STATIC_ALLOC) + /* need to increase VECTOR_CTORS_N_STATIC_ALLOC, buster */ + abort (); + else + { + vector_ctors[num_vector_ctors_registered].tag = type; + vector_ctors[num_vector_ctors_registered].ctor = ctor; + num_vector_ctors_registered++; + } +} + +SCM_DEFINE (scm_make_generalized_vector, "make-generalized-vector", 2, 1, 0, + (SCM type, SCM len, SCM fill), + "Make a generalized vector") +#define FUNC_NAME s_scm_make_generalized_vector +{ + int i; + for (i = 0; i < num_vector_ctors_registered; i++) + if (vector_ctors[i].tag == type) + return vector_ctors[i].ctor(len, fill); + scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "array type"); +} +#undef FUNC_NAME + +int +scm_is_generalized_vector (SCM obj) +{ + int ret = 0; + if (scm_is_array (obj)) + { + scm_t_array_handle h; + scm_array_get_handle (obj, &h); + ret = scm_array_handle_rank (&h) == 1; + scm_array_handle_release (&h); + } + return ret; +} + +SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a vector, string,\n" + "bitvector, or uniform numeric vector.") +#define FUNC_NAME s_scm_generalized_vector_p +{ + return scm_from_bool (scm_is_generalized_vector (obj)); +} +#undef FUNC_NAME + +#define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \ + scm_generalized_vector_get_handle (val, handle) + + +void +scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h) +{ + scm_array_get_handle (vec, h); + if (scm_array_handle_rank (h) != 1) + { + scm_array_handle_release (h); + scm_wrong_type_arg_msg (NULL, 0, vec, "vector"); + } +} + +size_t +scm_c_generalized_vector_length (SCM v) +{ + scm_t_array_handle h; + size_t ret; + scm_generalized_vector_get_handle (v, &h); + ret = h.dims[0].ubnd - h.dims[0].lbnd + 1; + scm_array_handle_release (&h); + return ret; +} + +SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0, 0, + (SCM v), + "Return the length of the generalized vector @var{v}.") +#define FUNC_NAME s_scm_generalized_vector_length +{ + return scm_from_size_t (scm_c_generalized_vector_length (v)); +} +#undef FUNC_NAME + +SCM +scm_c_generalized_vector_ref (SCM v, size_t idx) +{ + scm_t_array_handle h; + SCM ret; + scm_generalized_vector_get_handle (v, &h); + ret = h.impl->vref (&h, idx); + scm_array_handle_release (&h); + return ret; +} + +SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0, + (SCM v, SCM idx), + "Return the element at index @var{idx} of the\n" + "generalized vector @var{v}.") +#define FUNC_NAME s_scm_generalized_vector_ref +{ + return scm_c_generalized_vector_ref (v, scm_to_size_t (idx)); +} +#undef FUNC_NAME + +void +scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val) +{ + scm_t_array_handle h; + scm_generalized_vector_get_handle (v, &h); + h.impl->vset (&h, idx, val); + scm_array_handle_release (&h); +} + +SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0, + (SCM v, SCM idx, SCM val), + "Set the element at index @var{idx} of the\n" + "generalized vector @var{v} to @var{val}.") +#define FUNC_NAME s_scm_generalized_vector_set_x +{ + scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0, + (SCM v), + "Return a new list whose elements are the elements of the\n" + "generalized vector @var{v}.") +#define FUNC_NAME s_scm_generalized_vector_to_list +{ + SCM ret = SCM_EOL; + ssize_t pos, i = 0; + scm_t_array_handle h; + scm_generalized_vector_get_handle (v, &h); + // FIXME CHECKME + for (pos = h.dims[0].ubnd, i = (h.dims[0].ubnd - h.dims[0].lbnd + 1); + i >= 0; + pos += h.dims[0].inc) + ret = scm_cons (h.impl->vref (&h, pos), ret); + scm_array_handle_release (&h); + return ret; +} +#undef FUNC_NAME + +void +scm_init_generalized_vectors () +{ +#include "libguile/generalized-vectors.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/generalized-vectors.h b/libguile/generalized-vectors.h new file mode 100644 index 000000000..71b58d291 --- /dev/null +++ b/libguile/generalized-vectors.h @@ -0,0 +1,61 @@ +/* classes: h_files */ + +#ifndef SCM_GENERALIZED_VECTORS_H +#define SCM_GENERALIZED_VECTORS_H + +/* Copyright (C) 1995,1996,1997,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 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" +#include "libguile/array-handle.h" + + + +/* Generalized vectors */ + +SCM_API SCM scm_generalized_vector_p (SCM v); +SCM_API SCM scm_generalized_vector_length (SCM v); +SCM_API SCM scm_generalized_vector_ref (SCM v, SCM idx); +SCM_API SCM scm_generalized_vector_set_x (SCM v, SCM idx, SCM val); +SCM_API SCM scm_generalized_vector_to_list (SCM v); + +SCM_API int scm_is_generalized_vector (SCM obj); +SCM_API size_t scm_c_generalized_vector_length (SCM v); +SCM_API SCM scm_c_generalized_vector_ref (SCM v, size_t idx); +SCM_API void scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val); +SCM_API void scm_generalized_vector_get_handle (SCM vec, + scm_t_array_handle *h); + +SCM_API SCM scm_make_generalized_vector (SCM type, SCM len, SCM fill); +SCM_INTERNAL void scm_i_register_vector_constructor (SCM type, SCM (*ctor)(SCM, SCM)); + +#define SCM_VECTOR_IMPLEMENTATION(type, ctor) \ + SCM_SNARF_INIT (scm_i_register_vector_constructor \ + (scm_i_array_element_types[type], ctor)) + +SCM_INTERNAL void scm_init_generalized_vectors (void); + +#endif /* SCM_GENERALIZED_VECTORS_H */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ 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 bbeb58433..4616fa240 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 */ @@ -59,24 +60,32 @@ #define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers) -#define DEFVAR(v, val) \ -{ scm_eval (scm_list_3 (scm_sym_define_public, (v), (val)), \ - scm_module_goops); } -/* Temporary hack until we get the new module system */ -/*fixme* Should optimize by keeping track of the variable object itself */ -#define GETVAR(v) (SCM_VARIABLE_REF (scm_call_2 (scm_goops_lookup_closure, \ - (v), SCM_BOOL_F))) - -/* Fixme: Should use already interned symbols */ - -#define CALL_GF1(name, a) (scm_call_1 (GETVAR (scm_from_locale_symbol (name)), \ - a)) -#define CALL_GF2(name, a, b) (scm_call_2 (GETVAR (scm_from_locale_symbol (name)), \ - a, b)) -#define CALL_GF3(name, a, b, c) (scm_call_3 (GETVAR (scm_from_locale_symbol (name)), \ - a, b, c)) -#define CALL_GF4(name, a, b, c, d) (scm_call_4 (GETVAR (scm_from_locale_symbol (name)), \ - a, b, c, d)) +/* this file is a mess. in theory, though, we shouldn't have many SCM references + -- most of the references should be to vars. */ + +static SCM var_slot_unbound = SCM_BOOL_F; +static SCM var_slot_missing = SCM_BOOL_F; +static SCM var_compute_cpl = SCM_BOOL_F; +static SCM var_no_applicable_method = SCM_BOOL_F; +static SCM var_memoize_method_x = SCM_BOOL_F; +static SCM var_change_class = SCM_BOOL_F; + +SCM_SYMBOL (sym_slot_unbound, "slot-unbound"); +SCM_SYMBOL (sym_slot_missing, "slot-missing"); +SCM_SYMBOL (sym_compute_cpl, "compute-cpl"); +SCM_SYMBOL (sym_no_applicable_method, "no-applicable-method"); +SCM_SYMBOL (sym_memoize_method_x, "memoize-method!"); +SCM_SYMBOL (sym_change_class, "change-class"); + +SCM_VARIABLE (scm_var_make_extended_generic, "make-extended-generic"); + + +/* FIXME, exports should come from the scm file only */ +#define DEFVAR(v, val) \ + { scm_module_define (scm_module_goops, (v), (val)); \ + scm_module_export (scm_module_goops, scm_list_1 ((v))); \ + } + /* Class redefinition protocol: @@ -119,8 +128,6 @@ static int goops_loaded_p = 0; static scm_t_rstate *goops_rstate; -static SCM scm_goops_lookup_closure; - /* These variables are filled in by the object system when loaded. */ SCM scm_class_boolean, scm_class_char, scm_class_pair; SCM scm_class_procedure, scm_class_string, scm_class_symbol; @@ -169,6 +176,8 @@ static SCM scm_unbound_p (SCM obj); static SCM scm_assert_bound (SCM value, SCM obj); static SCM scm_at_assert_bound_ref (SCM obj, SCM index); static SCM scm_sys_goops_loaded (void); +static SCM scm_make_extended_class_from_symbol (SCM type_name_sym, + int applicablep); /* This function is used for efficient type dispatch. */ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, @@ -234,6 +243,7 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, else return scm_class_procedure; case scm_tc7_gsubr: + case scm_tc7_program: return scm_class_procedure; case scm_tc7_pws: return scm_class_procedure_with_setter; @@ -273,9 +283,9 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0, else { SCM name = SCM_STRUCT_TABLE_NAME (SCM_CDR (handle)); - SCM class = scm_make_extended_class (scm_is_true (name) - ? scm_i_symbol_chars (name) - : 0, + SCM class = scm_make_extended_class_from_symbol (scm_is_true (name) + ? name + : scm_nullstr, SCM_I_OPERATORP (x)); SCM_SET_STRUCT_TABLE_CLASS (SCM_CDR (handle), class); return class; @@ -346,7 +356,7 @@ static SCM compute_cpl (SCM class) { if (goops_loaded_p) - return CALL_GF1 ("compute-cpl", class); + return scm_call_1 (SCM_VARIABLE_REF (var_compute_cpl), class); else { SCM supers = SCM_SLOT (class, scm_si_direct_supers); @@ -588,13 +598,10 @@ SCM_DEFINE (scm_sys_initialize_object, "%initialize-object", 2, 0, 0, { slot_value = get_slot_value (class, obj, SCM_CAR (get_n_set)); if (SCM_GOOPS_UNBOUNDP (slot_value)) - { - SCM env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, SCM_ENV (tmp)); - set_slot_value (class, - obj, - SCM_CAR (get_n_set), - scm_eval_body (SCM_CLOSURE_BODY (tmp), env)); - } + set_slot_value (class, + obj, + SCM_CAR (get_n_set), + scm_call_0 (tmp)); } } } @@ -1195,7 +1202,7 @@ SCM_DEFINE (scm_assert_bound, "assert-bound", 2, 0, 0, #define FUNC_NAME s_scm_assert_bound { if (SCM_GOOPS_UNBOUNDP (value)) - return CALL_GF1 ("slot-unbound", obj); + return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound), obj); return value; } #undef FUNC_NAME @@ -1208,7 +1215,7 @@ SCM_DEFINE (scm_at_assert_bound_ref, "@assert-bound-ref", 2, 0, 0, { SCM value = SCM_SLOT (obj, scm_to_int (index)); if (SCM_GOOPS_UNBOUNDP (value)) - return CALL_GF1 ("slot-unbound", obj); + return scm_call_1 (SCM_VARIABLE_REF (var_slot_unbound), obj); return value; } #undef FUNC_NAME @@ -1250,10 +1257,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 @@ -1296,7 +1300,7 @@ get_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef) code = SCM_CAR (access); if (!SCM_CLOSUREP (code)) - return SCM_SUBRF (code) (obj); + return scm_call_1 (code, obj); env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code), scm_list_1 (obj), SCM_ENV (code)); @@ -1313,7 +1317,7 @@ get_slot_value_using_name (SCM class, SCM obj, SCM slot_name) if (scm_is_true (slotdef)) return get_slot_value (class, obj, slotdef); else - return CALL_GF3 ("slot-missing", class, obj, slot_name); + return scm_call_3 (SCM_VARIABLE_REF (var_slot_missing), class, obj, slot_name); } static SCM @@ -1339,7 +1343,7 @@ set_slot_value (SCM class SCM_UNUSED, SCM obj, SCM slotdef, SCM value) code = SCM_CADR (access); if (!SCM_CLOSUREP (code)) - SCM_SUBRF (code) (obj, value); + scm_call_2 (code, obj, value); else { env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code), @@ -1360,7 +1364,7 @@ set_slot_value_using_name (SCM class, SCM obj, SCM slot_name, SCM value) if (scm_is_true (slotdef)) return set_slot_value (class, obj, slotdef, value); else - return CALL_GF4 ("slot-missing", class, obj, slot_name, value); + return scm_call_4 (SCM_VARIABLE_REF (var_slot_missing), class, obj, slot_name, value); } static SCM @@ -1390,7 +1394,7 @@ SCM_DEFINE (scm_slot_ref_using_class, "slot-ref-using-class", 3, 0, 0, res = get_slot_value_using_name (class, obj, slot_name); if (SCM_GOOPS_UNBOUNDP (res)) - return CALL_GF3 ("slot-unbound", class, obj, slot_name); + return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, slot_name); return res; } #undef FUNC_NAME @@ -1453,7 +1457,7 @@ SCM_DEFINE (scm_slot_ref, "slot-ref", 2, 0, 0, res = get_slot_value_using_name (class, obj, slot_name); if (SCM_GOOPS_UNBOUNDP (res)) - return CALL_GF3 ("slot-unbound", class, obj, slot_name); + return scm_call_3 (SCM_VARIABLE_REF (var_slot_unbound), class, obj, slot_name); return res; } #undef FUNC_NAME @@ -1522,11 +1526,11 @@ wrap_init (SCM class, SCM *m, long n) { long i; scm_t_bits slayout = SCM_STRUCT_DATA (class)[scm_vtable_index_layout]; - const char *layout = scm_i_symbol_chars (SCM_PACK (slayout)); + SCM layout = SCM_PACK (slayout); /* Set all SCM-holding slots to unbound */ for (i = 0; i < n; i++) - if (layout[i*2] == 'p') + if (scm_i_symbol_ref (layout, i*2) == 'p') m[i] = SCM_GOOPS_UNBOUND; else m[i] = 0; @@ -1742,7 +1746,7 @@ SCM_SYMBOL (scm_sym_change_class, "change-class"); static SCM purgatory (void *args) { - return scm_apply_0 (GETVAR (scm_sym_change_class), + return scm_apply_0 (SCM_VARIABLE_REF (var_change_class), SCM_PACK ((scm_t_bits) args)); } @@ -1856,7 +1860,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; @@ -1904,7 +1908,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 @@ -2143,7 +2147,7 @@ scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p) { if (find_method_p) return SCM_BOOL_F; - CALL_GF2 ("no-applicable-method", gf, save); + scm_call_2 (SCM_VARIABLE_REF (var_no_applicable_method), gf, save); /* if we are here, it's because no-applicable-method hasn't signaled an error */ return SCM_BOOL_F; } @@ -2200,8 +2204,13 @@ call_memoize_method (void *a) SCM cmethod = scm_mcache_lookup_cmethod (x, SCM_CDDR (args)); if (scm_is_true (cmethod)) return cmethod; - /*fixme* Use scm_apply */ - return CALL_GF3 ("memoize-method!", gf, SCM_CDDR (args), x); + + if (SCM_UNLIKELY (scm_is_false (var_memoize_method_x))) + var_memoize_method_x = + scm_permanent_object + (scm_module_variable (scm_module_goops, sym_memoize_method_x)); + + return scm_call_3 (SCM_VARIABLE_REF (var_memoize_method_x), gf, SCM_CDDR (args), x); } SCM @@ -2229,6 +2238,9 @@ scm_memoize_method (SCM x, SCM args) SCM_KEYWORD (k_setter, "setter"); SCM_KEYWORD (k_specializers, "specializers"); SCM_KEYWORD (k_procedure, "procedure"); +SCM_KEYWORD (k_formals, "formals"); +SCM_KEYWORD (k_body, "body"); +SCM_KEYWORD (k_make_procedure, "make-procedure"); SCM_KEYWORD (k_dsupers, "dsupers"); SCM_KEYWORD (k_slots, "slots"); SCM_KEYWORD (k_gf, "generic-function"); @@ -2292,9 +2304,27 @@ SCM_DEFINE (scm_make, "make", 0, 0, 1, scm_i_get_keyword (k_procedure, args, len - 1, - SCM_EOL, + SCM_BOOL_F, FUNC_NAME)); SCM_SET_SLOT (z, scm_si_code_table, SCM_EOL); + SCM_SET_SLOT (z, scm_si_formals, + scm_i_get_keyword (k_formals, + args, + len - 1, + SCM_EOL, + FUNC_NAME)); + SCM_SET_SLOT (z, scm_si_body, + scm_i_get_keyword (k_body, + args, + len - 1, + SCM_EOL, + FUNC_NAME)); + SCM_SET_SLOT (z, scm_si_make_procedure, + scm_i_get_keyword (k_make_procedure, + args, + len - 1, + SCM_BOOL_F, + FUNC_NAME)); } else { @@ -2434,10 +2464,14 @@ static void create_standard_classes (void) { SCM slots; - SCM method_slots = scm_list_4 (scm_from_locale_symbol ("generic-function"), + SCM method_slots = scm_list_n (scm_from_locale_symbol ("generic-function"), scm_from_locale_symbol ("specializers"), sym_procedure, - scm_from_locale_symbol ("code-table")); + scm_from_locale_symbol ("code-table"), + scm_from_locale_symbol ("formals"), + scm_from_locale_symbol ("body"), + scm_from_locale_symbol ("make-procedure"), + SCM_UNDEFINED); SCM amethod_slots = scm_list_1 (scm_list_3 (scm_from_locale_symbol ("slot-definition"), k_init_keyword, k_slot_definition)); @@ -2646,7 +2680,35 @@ make_class_from_template (char const *template, char const *type_name, SCM super /* Only define name if doesn't already exist. */ if (!SCM_GOOPS_UNBOUNDP (name) - && scm_is_false (scm_call_2 (scm_goops_lookup_closure, name, SCM_BOOL_F))) + && scm_is_false (scm_module_variable (scm_module_goops, name))) + DEFVAR (name, class); + return class; +} + +static SCM +make_class_from_symbol (SCM type_name_sym, SCM supers, int applicablep) +{ + SCM class, name; + if (type_name_sym != SCM_BOOL_F) + { + name = scm_string_append (scm_list_3 (scm_from_locale_string ("<"), + scm_symbol_to_string (type_name_sym), + scm_from_locale_string (">"))); + name = scm_string_to_symbol (name); + } + else + name = SCM_GOOPS_UNBOUND; + + class = scm_permanent_object (scm_basic_make_class (applicablep + ? scm_class_procedure_class + : scm_class_class, + name, + supers, + SCM_EOL)); + + /* Only define name if doesn't already exist. */ + if (!SCM_GOOPS_UNBOUNDP (name) + && scm_is_false (scm_module_variable (scm_module_goops, name))) DEFVAR (name, class); return class; } @@ -2662,6 +2724,16 @@ scm_make_extended_class (char const *type_name, int applicablep) applicablep); } +static SCM +scm_make_extended_class_from_symbol (SCM type_name_sym, int applicablep) +{ + return make_class_from_symbol (type_name_sym, + scm_list_1 (applicablep + ? scm_class_applicable + : scm_class_top), + applicablep); +} + void scm_i_inherit_applicable (SCM c) { @@ -2754,11 +2826,16 @@ static SCM make_struct_class (void *closure SCM_UNUSED, SCM vtable, SCM data, SCM prev SCM_UNUSED) { - if (scm_is_true (SCM_STRUCT_TABLE_NAME (data))) - SCM_SET_STRUCT_TABLE_CLASS (data, - scm_make_extended_class - (scm_i_symbol_chars (SCM_STRUCT_TABLE_NAME (data)), - SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR)); + SCM sym = SCM_STRUCT_TABLE_NAME (data); + if (scm_is_true (sym)) + { + int applicablep = SCM_CLASS_FLAGS (vtable) & SCM_CLASSF_OPERATOR; + + SCM_SET_STRUCT_TABLE_CLASS (data, + scm_make_extended_class_from_symbol (sym, applicablep)); + } + + scm_remember_upto_here_2 (data, vtable); return SCM_UNSPECIFIED; } @@ -2978,8 +3055,23 @@ SCM_DEFINE (scm_sys_goops_loaded, "%goops-loaded", 0, 0, 0, { goops_loaded_p = 1; var_compute_applicable_methods = - scm_sym2var (sym_compute_applicable_methods, scm_goops_lookup_closure, - SCM_BOOL_F); + scm_permanent_object + (scm_module_variable (scm_module_goops, sym_compute_applicable_methods)); + var_slot_unbound = + scm_permanent_object + (scm_module_variable (scm_module_goops, sym_slot_unbound)); + var_slot_missing = + scm_permanent_object + (scm_module_variable (scm_module_goops, sym_slot_missing)); + var_compute_cpl = + scm_permanent_object + (scm_module_variable (scm_module_goops, sym_compute_cpl)); + var_no_applicable_method = + scm_permanent_object + (scm_module_variable (scm_module_goops, sym_no_applicable_method)); + var_change_class = + scm_permanent_object + (scm_module_variable (scm_module_goops, sym_change_class)); setup_extended_primitive_generics (); return SCM_UNSPECIFIED; } @@ -2991,12 +3083,10 @@ SCM scm_init_goops_builtins (void) { scm_module_goops = scm_current_module (); - scm_goops_lookup_closure = scm_module_lookup_closure (scm_module_goops); /* Not really necessary right now, but who knows... */ scm_permanent_object (scm_module_goops); - scm_permanent_object (scm_goops_lookup_closure); scm_components = scm_permanent_object (scm_make_weak_key_hash_table (scm_from_int (37))); diff --git a/libguile/goops.h b/libguile/goops.h index 0dc0cd238..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 */ @@ -149,9 +150,11 @@ typedef struct scm_t_method { #define scm_si_generic_function 0 /* offset of gf slot in a <method> */ #define scm_si_specializers 1 /* offset of spec. slot in a <method> */ - #define scm_si_procedure 2 /* offset of proc. slot in a <method> */ #define scm_si_code_table 3 /* offset of code. slot in a <method> */ +#define scm_si_formals 4 /* offset of form. slot in a <method> */ +#define scm_si_body 5 /* offset of body slot in a <method> */ +#define scm_si_make_procedure 6 /* offset of makep.slot in a <method> */ /* C interface */ SCM_API SCM scm_class_boolean; 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 4d79f43bf..043b3ed0d 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, 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., 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..e6e38ba50 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 */ @@ -49,6 +50,20 @@ scm_string_hash (const unsigned char *str, size_t len) return h; } +unsigned long +scm_i_string_hash (SCM str) +{ + size_t len = scm_i_string_length (str); + size_t i = 0; + + unsigned long h = 0; + while (len-- > 0) + h = (unsigned long) scm_i_string_ref (str, i++) + h * 37; + + scm_remember_upto_here_1 (str); + return h; +} + /* Dirk:FIXME:: why downcase for characters? (2x: scm_hasher, scm_ihashv) */ /* Dirk:FIXME:: scm_hasher could be made static. */ @@ -114,8 +129,7 @@ scm_hasher(SCM obj, unsigned long n, size_t d) case scm_tc7_string: { unsigned long hash = - scm_string_hash ((const unsigned char *) scm_i_string_chars (obj), - scm_i_string_length (obj)) % n; + scm_i_string_hash (obj) % n; scm_remember_upto_here_1 (obj); return hash; } diff --git a/libguile/hash.h b/libguile/hash.h index bbf9b2562..2ebc05352 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 */ @@ -27,6 +28,7 @@ SCM_API unsigned long scm_string_hash (const unsigned char *str, size_t len); +SCM_INTERNAL unsigned long scm_i_string_hash (SCM str); SCM_API unsigned long scm_hasher (SCM obj, unsigned long n, size_t d); SCM_API unsigned long scm_ihashq (SCM obj, unsigned long n); SCM_API SCM scm_hashq (SCM obj, SCM n); 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 8cacf5f8d..fd15227b5 100644 --- a/libguile/i18n.c +++ b/libguile/i18n.c @@ -1,18 +1,19 @@ -/* Copyright (C) 2006, 2007, 2008 Free Software Foundation, Inc. +/* 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 @@ -229,26 +230,6 @@ SCM_SMOB_FREE (scm_tc16_locale_smob_type, smob_locale_free, locale) return 0; } -#ifndef USE_GNU_LOCALE_API -static SCM -smob_locale_mark (SCM locale) -{ - register SCM dependency; - - if (!scm_is_eq (locale, SCM_VARIABLE_REF (scm_global_locale))) - { - scm_t_locale c_locale; - - c_locale = (scm_t_locale) SCM_SMOB_DATA (locale); - dependency = (c_locale->base_locale); - } - else - dependency = SCM_BOOL_F; - - return dependency; -} -#endif - static void inline scm_locale_error (const char *, int) SCM_NORETURN; @@ -1721,10 +1702,6 @@ scm_init_i18n () #include "libguile/i18n.x" -#ifndef USE_GNU_LOCALE_API - scm_set_smob_mark (scm_tc16_locale_smob_type, smob_locale_mark); -#endif - /* Initialize the global locale object with a special `locale' SMOB. */ SCM_NEWSMOB (global_locale_smob, scm_tc16_locale_smob_type, NULL); SCM_VARIABLE_SET (scm_global_locale, global_locale_smob); 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 56c34c8bc..940d515f6 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 */ @@ -36,7 +37,9 @@ #include "libguile/arbiters.h" #include "libguile/async.h" #include "libguile/backtrace.h" +#include "libguile/bitvectors.h" #include "libguile/boolean.h" +#include "libguile/bytevectors.h" #include "libguile/chars.h" #include "libguile/continuations.h" #include "libguile/debug.h" @@ -60,6 +63,8 @@ #include "libguile/futures.h" #include "libguile/gc.h" #include "libguile/gdbint.h" +#include "libguile/generalized-arrays.h" +#include "libguile/generalized-vectors.h" #include "libguile/goops.h" #include "libguile/gsubr.h" #include "libguile/hash.h" @@ -90,7 +95,7 @@ #include "libguile/procprop.h" #include "libguile/procs.h" #include "libguile/properties.h" -#include "libguile/ramap.h" +#include "libguile/array-map.h" #include "libguile/random.h" #include "libguile/rdelim.h" #include "libguile/read.h" @@ -113,15 +118,17 @@ #include "libguile/struct.h" #include "libguile/symbols.h" #include "libguile/throw.h" -#include "libguile/unif.h" +#include "libguile/arrays.h" #include "libguile/values.h" #include "libguile/variable.h" #include "libguile/vectors.h" #include "libguile/version.h" +#include "libguile/vm-bootstrap.h" #include "libguile/vports.h" #include "libguile/weaks.h" #include "libguile/guardians.h" #include "libguile/extensions.h" +#include "libguile/uniform.h" #include "libguile/srfi-4.h" #include "libguile/discouraged.h" #include "libguile/deprecated.h" @@ -281,7 +288,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")); + scm_c_primitive_load_path ("ice-9/boot-9"); /* Load the init.scm file. */ if (scm_is_true (init_path)) @@ -516,7 +523,19 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_sort (); scm_init_srcprop (); scm_init_stackchk (); - scm_init_strings (); + + scm_init_array_handle (); + scm_init_generalized_arrays (); + scm_init_generalized_vectors (); + scm_init_vectors (); + scm_init_uniform (); + scm_init_bitvectors (); + scm_bootstrap_bytevectors (); + scm_init_srfi_4 (); + scm_init_arrays (); + scm_init_array_map (); + + scm_init_strings (); /* Requires array-handle */ scm_init_struct (); /* Requires strings */ scm_init_stacks (); /* Requires strings, struct */ scm_init_symbols (); @@ -530,7 +549,6 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_srfi_13 (); scm_init_srfi_14 (); scm_init_throw (); - scm_init_vectors (); scm_init_version (); scm_init_weaks (); scm_init_guardians (); @@ -539,8 +557,6 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_evalext (); scm_init_debug (); /* Requires macro smobs */ scm_init_random (); - scm_init_ramap (); - scm_init_unif (); scm_init_simpos (); scm_init_load_path (); scm_init_standard_ports (); /* Requires fports */ @@ -549,7 +565,6 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_lang (); #endif /* SCM_ENABLE_ELISP */ scm_init_script (); - scm_init_srfi_4 (); scm_init_goops (); @@ -573,6 +588,8 @@ scm_i_init_guile (SCM_STACKITEM *base) scm_init_rw (); scm_init_extensions (); + scm_bootstrap_vm (); + atexit (cleanup_for_exit); scm_load_startup_files (); } 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..49431697f 100644 --- a/libguile/inline.h +++ b/libguile/inline.h @@ -3,21 +3,22 @@ #ifndef SCM_INLINE_H #define SCM_INLINE_H -/* Copyright (C) 2001, 2002, 2003, 2004, 2006, 2008 Free Software Foundation, Inc. +/* Copyright (C) 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 */ /* This file is for inline functions. On platforms that don't support @@ -33,8 +34,9 @@ #include "libguile/pairs.h" #include "libguile/gc.h" #include "libguile/threads.h" -#include "libguile/unif.h" +#include "libguile/array-handle.h" #include "libguile/ports.h" +#include "libguile/numbers.h" #include "libguile/error.h" @@ -91,7 +93,7 @@ SCM_API void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM val); SCM_API int scm_is_pair (SCM x); -SCM_API int scm_getc (SCM port); +SCM_API int scm_get_byte_or_eof (SCM port); SCM_API void scm_putc (char c, SCM port); SCM_API void scm_puts (const char *str_data, SCM port); @@ -241,7 +243,11 @@ SCM_C_EXTERN_INLINE SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t p) { - return h->ref (h, p); + if (SCM_UNLIKELY (p < 0 && -p > h->base)) + /* catch overflow */ + scm_out_of_range (NULL, scm_from_ssize_t (p)); + /* perhaps should catch overflow here too */ + return h->impl->vref (h, h->base + p); } #ifndef SCM_INLINE_C_INCLUDING_INLINE_H @@ -250,7 +256,11 @@ SCM_C_EXTERN_INLINE void scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v) { - h->set (h, p, v); + if (SCM_UNLIKELY (p < 0 && -p > h->base)) + /* catch overflow */ + scm_out_of_range (NULL, scm_from_ssize_t (p)); + /* perhaps should catch overflow here too */ + h->impl->vset (h, h->base + p, v); } #ifndef SCM_INLINE_C_INCLUDING_INLINE_H @@ -290,7 +300,7 @@ scm_is_pair (SCM x) SCM_C_EXTERN_INLINE #endif int -scm_getc (SCM port) +scm_get_byte_or_eof (SCM port) { int c; scm_t_port *pt = SCM_PTAB_ENTRY (port); @@ -310,27 +320,6 @@ scm_getc (SCM port) c = *(pt->read_pos++); - switch (c) - { - case '\a': - break; - case '\b': - SCM_DECCOL (port); - break; - case '\n': - SCM_INCLINE (port); - break; - case '\r': - SCM_ZEROCOL (port); - break; - case '\t': - SCM_TABCOL (port); - break; - default: - SCM_INCCOL (port); - break; - } - return c; } diff --git a/libguile/instructions.c b/libguile/instructions.c new file mode 100644 index 000000000..04180e5e3 --- /dev/null +++ b/libguile/instructions.c @@ -0,0 +1,218 @@ +/* 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 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 + */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#include <string.h> + +#include "_scm.h" +#include "vm-bootstrap.h" +#include "instructions.h" + +struct scm_instruction { + enum scm_opcode opcode; /* opcode */ + const char *name; /* instruction name */ + signed char len; /* Instruction length. This may be -1 for + the loader (see the `VM_LOADER' + macro). */ + signed char npop; /* The number of values popped. This may be + -1 for insns like `call' which can take + any number of arguments. */ + char npush; /* the number of values pushed */ + SCM symname; /* filled in later */ +}; + +#define SCM_VALIDATE_LOOKUP_INSTRUCTION(pos, var, cvar) \ + do { \ + cvar = scm_lookup_instruction_by_name (var); \ + SCM_ASSERT_TYPE (cvar, var, pos, FUNC_NAME, "INSTRUCTION_P"); \ + } while (0) + + +static struct scm_instruction* +fetch_instruction_table () +{ + static struct scm_instruction *table = NULL; + + if (SCM_UNLIKELY (!table)) + { + size_t bytes = SCM_VM_NUM_INSTRUCTIONS * sizeof(struct scm_instruction); + int i; + table = malloc (bytes); + memset (table, 0, bytes); +#define VM_INSTRUCTION_TO_TABLE 1 +#include <libguile/vm-expand.h> +#include <libguile/vm-i-system.i> +#include <libguile/vm-i-scheme.i> +#include <libguile/vm-i-loader.i> +#undef VM_INSTRUCTION_TO_TABLE + for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++) + { + table[i].opcode = i; + if (table[i].name) + table[i].symname = + scm_permanent_object (scm_from_locale_symbol (table[i].name)); + else + table[i].symname = SCM_BOOL_F; + } + } + return table; +} + +static struct scm_instruction * +scm_lookup_instruction_by_name (SCM name) +{ + static SCM instructions_by_name = SCM_BOOL_F; + struct scm_instruction *table = fetch_instruction_table (); + SCM op; + + if (SCM_UNLIKELY (SCM_FALSEP (instructions_by_name))) + { + int 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)); + } + + op = scm_hashq_ref (instructions_by_name, name, SCM_UNDEFINED); + if (SCM_I_INUMP (op)) + return &table[SCM_I_INUM (op)]; + + return NULL; +} + + +/* Scheme interface */ + +SCM_DEFINE (scm_instruction_list, "instruction-list", 0, 0, 0, + (void), + "") +#define FUNC_NAME s_scm_instruction_list +{ + SCM list = SCM_EOL; + 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 + +SCM_DEFINE (scm_instruction_p, "instruction?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_instruction_p +{ + return SCM_BOOL (scm_lookup_instruction_by_name (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_length, "instruction-length", 1, 0, 0, + (SCM inst), + "") +#define FUNC_NAME s_scm_instruction_length +{ + struct scm_instruction *ip; + SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip); + return SCM_I_MAKINUM (ip->len); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_pops, "instruction-pops", 1, 0, 0, + (SCM inst), + "") +#define FUNC_NAME s_scm_instruction_pops +{ + struct scm_instruction *ip; + SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip); + return SCM_I_MAKINUM (ip->npop); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_pushes, "instruction-pushes", 1, 0, 0, + (SCM inst), + "") +#define FUNC_NAME s_scm_instruction_pushes +{ + struct scm_instruction *ip; + SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip); + return SCM_I_MAKINUM (ip->npush); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_instruction_to_opcode, "instruction->opcode", 1, 0, 0, + (SCM inst), + "") +#define FUNC_NAME s_scm_instruction_to_opcode +{ + struct scm_instruction *ip; + SCM_VALIDATE_LOOKUP_INSTRUCTION (1, inst, ip); + return SCM_I_MAKINUM (ip->opcode); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_opcode_to_instruction, "opcode->instruction", 1, 0, 0, + (SCM op), + "") +#define FUNC_NAME s_scm_opcode_to_instruction +{ + int opcode; + SCM ret = SCM_BOOL_F; + + SCM_MAKE_VALIDATE (1, op, I_INUMP); + opcode = SCM_I_INUM (op); + + if (opcode >= 0 && opcode < SCM_VM_NUM_INSTRUCTIONS) + ret = fetch_instruction_table ()[opcode].symname; + + if (scm_is_false (ret)) + scm_wrong_type_arg_msg (FUNC_NAME, 1, op, "INSTRUCTION_P"); + + return ret; +} +#undef FUNC_NAME + +void +scm_bootstrap_instructions (void) +{ + scm_c_register_extension ("libguile", "scm_init_instructions", + (scm_t_extension_init_func)scm_init_instructions, + NULL); +} + +void +scm_init_instructions (void) +{ + scm_bootstrap_vm (); + +#ifndef SCM_MAGIC_SNARFER +#include "libguile/instructions.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/instructions.h b/libguile/instructions.h new file mode 100644 index 000000000..a2263228f --- /dev/null +++ b/libguile/instructions.h @@ -0,0 +1,53 @@ +/* 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 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_INSTRUCTIONS_H_ +#define _SCM_INSTRUCTIONS_H_ + +#include <libguile.h> + +#define SCM_VM_NUM_INSTRUCTIONS (1<<8) +#define SCM_VM_INSTRUCTION_MASK (SCM_VM_NUM_INSTRUCTIONS-1) + +enum scm_opcode { +#define VM_INSTRUCTION_TO_OPCODE 1 +#include <libguile/vm-expand.h> +#include <libguile/vm-i-system.i> +#include <libguile/vm-i-scheme.i> +#include <libguile/vm-i-loader.i> +#undef VM_INSTRUCTION_TO_OPCODE +}; + +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); + +SCM_INTERNAL void scm_bootstrap_instructions (void); +SCM_INTERNAL void scm_init_instructions (void); + +#endif /* _SCM_INSTRUCTIONS_H_ */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ 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 155bdbdab..fa25b0f84 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 */ @@ -44,6 +45,8 @@ #include "libguile/load.h" #include "libguile/fluids.h" +#include "libguile/vm.h" /* for load-compiled/vm */ + #include <sys/types.h> #include <sys/stat.h> @@ -51,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 @@ -78,6 +85,7 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, #define FUNC_NAME s_scm_primitive_load { SCM hook = *scm_loc_load_hook; + char *encoding; SCM_VALIDATE_STRING (1, filename); if (scm_is_true (hook) && scm_is_false (scm_procedure_p (hook))) SCM_MISC_ERROR ("value of %load-hook is neither a procedure nor #f", @@ -90,7 +98,15 @@ SCM_DEFINE (scm_primitive_load, "primitive-load", 1, 0, 0, SCM port = scm_open_file (filename, scm_from_locale_string ("r")); scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); scm_i_dynwind_current_load_port (port); - + encoding = scm_scan_for_encoding (port); + if (encoding) + { + scm_i_set_port_encoding_x (port, encoding); + free (encoding); + } + else + /* The file has no encoding declaraed. We'll presume Latin-1. */ + scm_i_set_port_encoding_x (port, NULL); while (1) { SCM reader, form; @@ -172,6 +188,15 @@ static SCM *scm_loc_load_path; /* List of extensions we try adding to the filenames. */ static SCM *scm_loc_load_extensions; +/* 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), @@ -204,18 +229,68 @@ scm_init_load_path () { char *env; SCM path = SCM_EOL; + SCM cpath = SCM_EOL; #ifdef SCM_LIBRARY_DIR - 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_PATH"); + if (env && strcmp (env, "") == 0) + /* special-case interpret system-path=="" as meaning no system path instead + of '("") */ + ; + else if (env) + path = scm_parse_path (scm_from_locale_string (env), path); + else + 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; @@ -291,14 +366,33 @@ stringbuf_cat (struct stringbuf *buf, char *str) } +static int +scm_c_string_has_an_ext (char *str, size_t len, SCM extensions) +{ + for (; !scm_is_null (extensions); extensions = SCM_CDR (extensions)) + { + char *ext; + size_t extlen; + int match; + ext = scm_to_locale_string (SCM_CAR (extensions)); + extlen = strlen (ext); + match = (len > extlen && str[len - extlen - 1] == '.' + && strncmp (str + (len - extlen), ext, extlen) == 0); + free (ext); + if (match) + return 1; + } + return 0; +} + /* Search PATH for a directory containing a file named FILENAME. The file must be readable, and not a directory. If we find one, return its full filename; otherwise, return #f. If FILENAME is absolute, return it unchanged. If given, EXTENSIONS is a list of strings; for each directory in PATH, we search for FILENAME concatenated with each EXTENSION. */ -SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, - (SCM path, SCM filename, SCM extensions), +SCM_DEFINE (scm_search_path, "search-path", 2, 2, 0, + (SCM path, SCM filename, SCM extensions, SCM require_exts), "Search @var{path} for a directory containing a file named\n" "@var{filename}. The file must be readable, and not a directory.\n" "If we find one, return its full filename; otherwise, return\n" @@ -316,6 +410,9 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, if (SCM_UNBNDP (extensions)) extensions = SCM_EOL; + if (SCM_UNBNDP (require_exts)) + require_exts = SCM_BOOL_F; + scm_dynwind_begin (0); filename_chars = scm_to_locale_string (filename); @@ -334,8 +431,14 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, if (filename_len >= 1 && filename_chars[0] == '/') #endif { + SCM res = filename; + if (scm_is_true (require_exts) && + !scm_c_string_has_an_ext (filename_chars, filename_len, + extensions)) + res = SCM_BOOL_F; + scm_dynwind_end (); - return filename; + return res; } /* If FILENAME has an extension, don't try to add EXTENSIONS to it. */ @@ -348,6 +451,15 @@ SCM_DEFINE (scm_search_path, "search-path", 2, 1, 0, { if (*endp == '.') { + if (scm_is_true (require_exts) && + !scm_c_string_has_an_ext (filename_chars, filename_len, + extensions)) + { + /* This filename has an extension, but not one of the right + ones... */ + scm_dynwind_end (); + return SCM_BOOL_F; + } /* This filename already has an extension, so cancel the list of extensions. */ extensions = SCM_EOL; @@ -453,35 +565,214 @@ SCM_DEFINE (scm_sys_search_load_path, "%search-load-path", 1, 0, 0, SCM_MISC_ERROR ("%load-path is not a proper list", SCM_EOL); if (scm_ilength (exts) < 0) SCM_MISC_ERROR ("%load-extension list is not a proper list", SCM_EOL); - return scm_search_path (path, filename, exts); + return scm_search_path (path, filename, exts, SCM_UNDEFINED); } #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; +} + +SCM_DEFINE (scm_sys_warn_autocompilation_enabled, "%warn-autocompilation-enabled", 0, 0, 0, + (void), "") +#define FUNC_NAME s_scm_sys_warn_autocompilation_enabled +{ + static int message_shown = 0; + + 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_UNSPECIFIED; +} +#undef FUNC_NAME + +static SCM +scm_try_autocompile (SCM source) +{ + if (scm_is_false (*scm_loc_load_should_autocompile)) + return SCM_BOOL_F; + + scm_sys_warn_autocompilation_enabled (); + 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; + 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_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)) + { + 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)) - SCM_MISC_ERROR ("Unable to find file ~S in load path", - scm_list_1 (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); - return scm_primitive_load (full_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. */ + { + SCM freshly_compiled = scm_try_autocompile (full_filename); + + if (scm_is_true (freshly_compiled)) + return scm_load_compiled_with_vm (freshly_compiled); + else + return scm_primitive_load (full_filename); + } } #undef FUNC_NAME 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); } @@ -514,8 +805,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 57cc7e8ac..1a1a86528 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 */ @@ -31,10 +32,11 @@ SCM_API SCM scm_c_primitive_load (const char *filename); SCM_API SCM scm_sys_package_data_dir (void); 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_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 SCM scm_sys_warn_autocompilation_enabled (void); 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 e8899f5a0..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 */ @@ -31,6 +32,7 @@ #include "libguile/deprecation.h" #include "libguile/validate.h" +#include "libguile/programs.h" #include "libguile/macros.h" #include "libguile/private-options.h" @@ -47,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))) { - if (!SCM_CLOSUREP (code)) - scm_puts ("#<primitive-", port); - else - scm_puts ("#<", port); + 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); if (SCM_MACRO_TYPE (macro) == 0) scm_puts ("syntax", port); @@ -62,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); @@ -76,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); } @@ -163,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)); @@ -181,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)) @@ -201,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); } } @@ -213,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 @@ -223,9 +276,43 @@ SCM_DEFINE (scm_macro_transformer, "macro-transformer", 1, 0, 0, "Return the transformer of the macro @var{m}.") #define FUNC_NAME s_scm_macro_transformer { + SCM data; + + SCM_VALIDATE_SMOB (1, m, macro); + data = SCM_PACK (SCM_SMOB_DATA (m)); + + if (SCM_CLOSUREP (data) || SCM_PROGRAM_P (data)) + return data; + else + return SCM_BOOL_F; +} +#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); - return ((SCM_CLOSUREP (SCM_PACK (SCM_SMOB_DATA (m)))) ? - SCM_PACK(SCM_SMOB_DATA (m)) : SCM_BOOL_F); + + if (SCM_MACRO_IS_EXTENDED (m)) + return SCM_SMOB_OBJECT_3 (m); + else + return SCM_BOOL_F; } #undef FUNC_NAME 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 04527a529..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 */ @@ -345,6 +346,8 @@ resolve_duplicate_binding (SCM module, SCM sym, return result; } +SCM scm_pre_modules_obarray; + /* Lookup SYM as an imported variable of MODULE. */ static inline SCM module_imported_variable (SCM module, SCM sym) @@ -416,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); @@ -471,6 +474,9 @@ SCM_DEFINE (scm_module_variable, "module-variable", 2, 0, 0, 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 */ var = scm_hashq_ref (SCM_MODULE_OBARRAY (module), sym, SCM_UNDEFINED); if (SCM_BOUND_THING_P (var)) @@ -545,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) { @@ -563,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); } @@ -575,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, @@ -624,6 +651,25 @@ SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0, } #undef FUNC_NAME +SCM_SYMBOL (sym_sys_module_public_interface, "%module-public-interface"); + +SCM_DEFINE (scm_module_public_interface, "module-public-interface", 1, 0, 0, + (SCM module), + "Return the public interface of @var{module}.\n\n" + "If @var{module} has no public interface, @code{#f} is returned.") +#define FUNC_NAME s_scm_module_public_interface +{ + SCM var; + + SCM_VALIDATE_MODULE (1, module); + var = scm_module_local_variable (module, sym_sys_module_public_interface); + if (scm_is_true (var)) + return SCM_VARIABLE_REF (var); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + /* scm_sym2var * * looks up the variable bound to SYM according to PROC. PROC should be @@ -637,8 +683,6 @@ SCM_DEFINE (scm_module_import_interface, "module-import-interface", 2, 0, 0, * the scm_pre_modules_obarray (a `eq' hash table). */ -SCM scm_pre_modules_obarray; - SCM scm_sym2var (SCM sym, SCM proc, SCM definep) #define FUNC_NAME "scm_sym2var" diff --git a/libguile/modules.h b/libguile/modules.h index afac9f4e4..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 */ @@ -100,6 +101,7 @@ SCM_API void scm_c_export (const char *name, ...); SCM_API SCM scm_sym2var (SCM sym, SCM thunk, SCM definep); +SCM_API SCM scm_module_public_interface (SCM module); SCM_API SCM scm_module_import_interface (SCM module, SCM sym); SCM_API SCM scm_module_lookup_closure (SCM module); SCM_API SCM scm_module_transformer (SCM module); @@ -108,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..20fda02da 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 */ @@ -45,8 +46,9 @@ #endif #include <math.h> -#include <ctype.h> #include <string.h> +#include <unicase.h> +#include <unictype.h> #if HAVE_COMPLEX_H #include <complex.h> @@ -2436,7 +2438,7 @@ scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED) { SCM str; str = scm_number_to_string (sexp, SCM_UNDEFINED); - scm_lfwrite (scm_i_string_chars (str), scm_i_string_length (str), port); + scm_lfwrite_str (str, port); scm_remember_upto_here_1 (str); return !0; } @@ -2483,13 +2485,13 @@ enum t_exactness {NO_EXACTNESS, INEXACT, EXACT}; /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */ /* In non ASCII-style encodings the following macro might not work. */ -#define XDIGIT2UINT(d) \ - (isdigit ((int) (unsigned char) d) \ - ? (d) - '0' \ - : tolower ((int) (unsigned char) d) - 'a' + 10) +#define XDIGIT2UINT(d) \ + (uc_is_property_decimal_digit ((int) (unsigned char) d) \ + ? (d) - '0' \ + : uc_tolower ((int) (unsigned char) d) - 'a' + 10) static SCM -mem2uinteger (const char* mem, size_t len, unsigned int *p_idx, +mem2uinteger (SCM mem, unsigned int *p_idx, unsigned int radix, enum t_exactness *p_exactness) { unsigned int idx = *p_idx; @@ -2499,12 +2501,13 @@ mem2uinteger (const char* mem, size_t len, unsigned int *p_idx, unsigned int digit_value; SCM result; char c; + size_t len = scm_i_string_length (mem); if (idx == len) return SCM_BOOL_F; - c = mem[idx]; - if (!isxdigit ((int) (unsigned char) c)) + c = scm_i_string_ref (mem, idx); + if (!uc_is_property_ascii_hex_digit ((scm_t_uint32) c)) return SCM_BOOL_F; digit_value = XDIGIT2UINT (c); if (digit_value >= radix) @@ -2514,8 +2517,8 @@ mem2uinteger (const char* mem, size_t len, unsigned int *p_idx, result = SCM_I_MAKINUM (digit_value); while (idx != len) { - char c = mem[idx]; - if (isxdigit ((int) (unsigned char) c)) + scm_t_wchar c = scm_i_string_ref (mem, idx); + if (uc_is_property_ascii_hex_digit ((scm_t_uint32) c)) { if (hash_seen) break; @@ -2568,20 +2571,20 @@ mem2uinteger (const char* mem, size_t len, unsigned int *p_idx, * has already been seen in the digits before the point. */ -/* In non ASCII-style encodings the following macro might not work. */ -#define DIGIT2UINT(d) ((d) - '0') +#define DIGIT2UINT(d) (uc_numeric_value(d).numerator) static SCM -mem2decimal_from_point (SCM result, const char* mem, size_t len, +mem2decimal_from_point (SCM result, SCM mem, unsigned int *p_idx, enum t_exactness *p_exactness) { unsigned int idx = *p_idx; enum t_exactness x = *p_exactness; + size_t len = scm_i_string_length (mem); if (idx == len) return result; - if (mem[idx] == '.') + if (scm_i_string_ref (mem, idx) == '.') { scm_t_bits shift = 1; scm_t_bits add = 0; @@ -2591,8 +2594,8 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, idx++; while (idx != len) { - char c = mem[idx]; - if (isdigit ((int) (unsigned char) c)) + scm_t_wchar c = scm_i_string_ref (mem, idx); + if (uc_is_property_decimal_digit ((scm_t_uint32) c)) { if (x == INEXACT) return SCM_BOOL_F; @@ -2642,13 +2645,13 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, { int sign = 1; unsigned int start; - char c; + scm_t_wchar c; int exponent; SCM e; /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */ - switch (mem[idx]) + switch (scm_i_string_ref (mem, idx)) { case 'd': case 'D': case 'e': case 'E': @@ -2656,32 +2659,41 @@ 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]; + c = scm_i_string_ref (mem, idx); if (c == '-') { idx++; + if (idx == len) + return SCM_BOOL_F; + sign = -1; - c = mem[idx]; + c = scm_i_string_ref (mem, idx); } else if (c == '+') { idx++; + if (idx == len) + return SCM_BOOL_F; + sign = 1; - c = mem[idx]; + c = scm_i_string_ref (mem, idx); } else sign = 1; - if (!isdigit ((int) (unsigned char) c)) + if (!uc_is_property_decimal_digit ((scm_t_uint32) c)) return SCM_BOOL_F; idx++; exponent = DIGIT2UINT (c); while (idx != len) { - char c = mem[idx]; - if (isdigit ((int) (unsigned char) c)) + scm_t_wchar c = scm_i_string_ref (mem, idx); + if (uc_is_property_decimal_digit ((scm_t_uint32) c)) { idx++; if (exponent <= SCM_MAXEXP) @@ -2694,7 +2706,7 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, if (exponent > SCM_MAXEXP) { size_t exp_len = idx - start; - SCM exp_string = scm_from_locale_stringn (&mem[start], exp_len); + SCM exp_string = scm_i_substring_copy (mem, start, start + exp_len); SCM exp_num = scm_string_to_number (exp_string, SCM_UNDEFINED); scm_out_of_range ("string->number", exp_num); } @@ -2726,63 +2738,67 @@ mem2decimal_from_point (SCM result, const char* mem, size_t len, /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */ static SCM -mem2ureal (const char* mem, size_t len, unsigned int *p_idx, +mem2ureal (SCM mem, unsigned int *p_idx, unsigned int radix, enum t_exactness *p_exactness) { unsigned int idx = *p_idx; SCM result; + size_t len = scm_i_string_length (mem); + + /* 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; - if (idx+5 <= len && !strncmp (mem+idx, "inf.0", 5)) + if (idx+5 <= len && !scm_i_string_strcmp (mem, idx, "inf.0")) { *p_idx = idx+5; return scm_inf (); } - if (idx+4 < len && !strncmp (mem+idx, "nan.", 4)) + if (idx+4 < len && !scm_i_string_strcmp (mem, idx, "nan.")) { - enum t_exactness x = EXACT; - /* Cobble up the fractional part. We might want to set the NaN's mantissa from it. */ idx += 4; - mem2uinteger (mem, len, &idx, 10, &x); + mem2uinteger (mem, &idx, 10, &x); *p_idx = idx; return scm_nan (); } - if (mem[idx] == '.') + if (scm_i_string_ref (mem, idx) == '.') { if (radix != 10) return SCM_BOOL_F; else if (idx + 1 == len) return SCM_BOOL_F; - else if (!isdigit ((int) (unsigned char) mem[idx + 1])) + else if (!uc_is_property_decimal_digit ((scm_t_uint32) scm_i_string_ref (mem, idx+1))) return SCM_BOOL_F; else - result = mem2decimal_from_point (SCM_I_MAKINUM (0), mem, len, - p_idx, p_exactness); + result = mem2decimal_from_point (SCM_I_MAKINUM (0), mem, + p_idx, &x); } else { - enum t_exactness x = EXACT; SCM uinteger; - uinteger = mem2uinteger (mem, len, &idx, radix, &x); + uinteger = mem2uinteger (mem, &idx, radix, &x); if (scm_is_false (uinteger)) return SCM_BOOL_F; if (idx == len) result = uinteger; - else if (mem[idx] == '/') + else if (scm_i_string_ref (mem, idx) == '/') { SCM divisor; idx++; + if (idx == len) + return SCM_BOOL_F; - divisor = mem2uinteger (mem, len, &idx, radix, &x); + divisor = mem2uinteger (mem, &idx, radix, &x); if (scm_is_false (divisor)) return SCM_BOOL_F; @@ -2791,7 +2807,7 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, } else if (radix == 10) { - result = mem2decimal_from_point (uinteger, mem, len, &idx, &x); + result = mem2decimal_from_point (uinteger, mem, &idx, &x); if (scm_is_false (result)) return SCM_BOOL_F; } @@ -2799,10 +2815,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. */ @@ -2816,17 +2838,18 @@ mem2ureal (const char* mem, size_t len, unsigned int *p_idx, /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */ static SCM -mem2complex (const char* mem, size_t len, unsigned int idx, +mem2complex (SCM mem, unsigned int idx, unsigned int radix, enum t_exactness *p_exactness) { - char c; + scm_t_wchar c; int sign = 0; SCM ureal; + size_t len = scm_i_string_length (mem); if (idx == len) return SCM_BOOL_F; - c = mem[idx]; + c = scm_i_string_ref (mem, idx); if (c == '+') { idx++; @@ -2841,7 +2864,7 @@ mem2complex (const char* mem, size_t len, unsigned int idx, if (idx == len) return SCM_BOOL_F; - ureal = mem2ureal (mem, len, &idx, radix, p_exactness); + ureal = mem2ureal (mem, &idx, radix, p_exactness); if (scm_is_false (ureal)) { /* input must be either +i or -i */ @@ -2849,7 +2872,8 @@ mem2complex (const char* mem, size_t len, unsigned int idx, if (sign == 0) return SCM_BOOL_F; - if (mem[idx] == 'i' || mem[idx] == 'I') + if (scm_i_string_ref (mem, idx) == 'i' + || scm_i_string_ref (mem, idx) == 'I') { idx++; if (idx != len) @@ -2868,7 +2892,7 @@ mem2complex (const char* mem, size_t len, unsigned int idx, if (idx == len) return ureal; - c = mem[idx]; + c = scm_i_string_ref (mem, idx); switch (c) { case 'i': case 'I': @@ -2893,21 +2917,25 @@ mem2complex (const char* mem, size_t len, unsigned int idx, SCM angle; SCM result; - c = mem[idx]; + c = scm_i_string_ref (mem, 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 sign = 1; - angle = mem2ureal (mem, len, &idx, radix, p_exactness); + angle = mem2ureal (mem, &idx, radix, p_exactness); if (scm_is_false (angle)) return SCM_BOOL_F; if (idx != len) @@ -2929,7 +2957,7 @@ mem2complex (const char* mem, size_t len, unsigned int idx, else { int sign = (c == '+') ? 1 : -1; - SCM imag = mem2ureal (mem, len, &idx, radix, p_exactness); + SCM imag = mem2ureal (mem, &idx, radix, p_exactness); if (scm_is_false (imag)) imag = SCM_I_MAKINUM (sign); @@ -2938,7 +2966,8 @@ mem2complex (const char* mem, size_t len, unsigned int idx, if (idx == len) return SCM_BOOL_F; - if (mem[idx] != 'i' && mem[idx] != 'I') + if (scm_i_string_ref (mem, idx) != 'i' + && scm_i_string_ref (mem, idx) != 'I') return SCM_BOOL_F; idx++; @@ -2959,19 +2988,19 @@ mem2complex (const char* mem, size_t len, unsigned int idx, enum t_radix {NO_RADIX=0, DUAL=2, OCT=8, DEC=10, HEX=16}; SCM -scm_c_locale_stringn_to_number (const char* mem, size_t len, - unsigned int default_radix) +scm_i_string_to_number (SCM mem, unsigned int default_radix) { unsigned int idx = 0; unsigned int radix = NO_RADIX; enum t_exactness forced_x = NO_EXACTNESS; enum t_exactness implicit_x = EXACT; SCM result; + size_t len = scm_i_string_length (mem); /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */ - while (idx + 2 < len && mem[idx] == '#') + while (idx + 2 < len && scm_i_string_ref (mem, idx) == '#') { - switch (mem[idx + 1]) + switch (scm_i_string_ref (mem, idx + 1)) { case 'b': case 'B': if (radix != NO_RADIX) @@ -3011,9 +3040,9 @@ scm_c_locale_stringn_to_number (const char* mem, size_t len, /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */ if (radix == NO_RADIX) - result = mem2complex (mem, len, idx, default_radix, &implicit_x); + result = mem2complex (mem, idx, default_radix, &implicit_x); else - result = mem2complex (mem, len, idx, (unsigned int) radix, &implicit_x); + result = mem2complex (mem, idx, (unsigned int) radix, &implicit_x); if (scm_is_false (result)) return SCM_BOOL_F; @@ -3044,6 +3073,15 @@ scm_c_locale_stringn_to_number (const char* mem, size_t len, } } +SCM +scm_c_locale_stringn_to_number (const char* mem, size_t len, + unsigned int default_radix) +{ + SCM str = scm_from_locale_stringn (mem, len); + + return scm_i_string_to_number (str, default_radix); +} + SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, (SCM string, SCM radix), @@ -3066,9 +3104,7 @@ SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0, else base = scm_to_unsigned_integer (radix, 2, INT_MAX); - answer = scm_c_locale_stringn_to_number (scm_i_string_chars (string), - scm_i_string_length (string), - base); + answer = scm_i_string_to_number (string, base); scm_remember_upto_here_1 (string); return answer; } @@ -5353,7 +5389,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 +5892,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..9597afb8d 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 */ @@ -27,6 +28,11 @@ #include "libguile/__scm.h" #include "libguile/print.h" +#ifndef SCM_T_WCHAR_DEFINED +typedef scm_t_int32 scm_t_wchar; +#define SCM_T_WCHAR_DEFINED +#endif /* SCM_T_WCHAR_DEFINED */ + #if SCM_HAVE_FLOATINGPOINT_H # include <floatingpoint.h> #endif @@ -173,6 +179,7 @@ typedef struct scm_t_complex double imag; } scm_t_complex; + SCM_API SCM scm_exact_p (SCM x); @@ -209,6 +216,7 @@ SCM_API int scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate); SCM_API int scm_bigprint (SCM exp, SCM port, scm_print_state *pstate); SCM_API SCM scm_c_locale_stringn_to_number (const char *mem, size_t len, unsigned int radix); +SCM_INTERNAL SCM scm_i_string_to_number (SCM str, unsigned int radix); SCM_API SCM scm_string_to_number (SCM str, SCM radix); SCM_API SCM scm_bigequal (SCM x, SCM y); SCM_API SCM scm_real_equalp (SCM x, SCM y); @@ -321,6 +329,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 new file mode 100644 index 000000000..be3423271 --- /dev/null +++ b/libguile/objcodes.c @@ -0,0 +1,290 @@ +/* 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 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 + */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#include <string.h> +#include <fcntl.h> +#include <unistd.h> +#include <sys/mman.h> +#include <sys/stat.h> +#include <sys/types.h> +#include <assert.h> + +#include "_scm.h" +#include "vm-bootstrap.h" +#include "programs.h" +#include "objcodes.h" + +/* 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); + + +/* + * Objcode type + */ + +scm_t_bits scm_tc16_objcode; + +static SCM +make_objcode_by_mmap (int fd) +#define FUNC_NAME "make_objcode_by_mmap" +{ + int ret; + char *addr; + struct stat st; + SCM sret = SCM_BOOL_F; + struct scm_objcode *data; + + ret = fstat (fd, &st); + if (ret < 0) + SCM_SYSERROR; + + if (st.st_size <= sizeof (struct scm_objcode) + strlen (SCM_OBJCODE_COOKIE)) + scm_misc_error (FUNC_NAME, "object file too small (~a bytes)", + 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) + { + (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); + + /* FIXME: we leak ourselves and the file descriptor. but then again so does + dlopen(). */ + return scm_permanent_object (sret); +} +#undef FUNC_NAME + +SCM +scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr) +#define FUNC_NAME "make-objcode-slice" +{ + const struct scm_objcode *data, *parent_data; + SCM ret; + + SCM_VALIDATE_OBJCODE (1, parent); + parent_data = SCM_OBJCODE_DATA (parent); + + if (ptr < parent_data->base + || 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_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) + abort (); + + SCM_NEWSMOB2 (ret, scm_tc16_objcode, data, parent); + SCM_SET_SMOB_FLAGS (ret, SCM_F_OBJCODE_IS_SLICE); + return ret; +} +#undef FUNC_NAME + + +/* + * Scheme interface + */ + +SCM_DEFINE (scm_objcode_p, "objcode?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_objcode_p +{ + return SCM_BOOL (SCM_OBJCODE_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_objcode_meta, "objcode-meta", 1, 0, 0, + (SCM objcode), + "") +#define FUNC_NAME s_scm_objcode_meta +{ + SCM_VALIDATE_OBJCODE (1, objcode); + + if (SCM_OBJCODE_META_LEN (objcode) == 0) + return SCM_BOOL_F; + else + return scm_c_make_objcode_slice (objcode, (SCM_OBJCODE_BASE (objcode) + + SCM_OBJCODE_LEN (objcode))); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode", 1, 0, 0, + (SCM bytecode), + "") +#define FUNC_NAME s_scm_bytecode_to_objcode +{ + size_t size; + ssize_t increment; + scm_t_array_handle handle; + const scm_t_uint8 *c_bytecode; + struct scm_objcode *data; + SCM objcode; + + if (scm_is_false (scm_u8vector_p (bytecode))) + scm_wrong_type_arg (FUNC_NAME, 1, bytecode); + + c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment); + data = (struct scm_objcode*)c_bytecode; + SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode); + scm_array_handle_release (&handle); + + 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_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); + + /* foolishly, we assume that as long as bytecode is around, that c_bytecode + will be of the same length; perhaps a bad assumption? */ + + return objcode; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_load_objcode, "load-objcode", 1, 0, 0, + (SCM file), + "") +#define FUNC_NAME s_scm_load_objcode +{ + int fd; + char *c_file; + + SCM_VALIDATE_STRING (1, file); + + c_file = scm_to_locale_string (file); + fd = open (c_file, O_RDONLY); + free (c_file); + if (fd < 0) SCM_SYSERROR; + + return make_objcode_by_mmap (fd); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode", 1, 0, 0, + (SCM objcode), + "") +#define FUNC_NAME s_scm_objcode_to_bytecode +{ + scm_t_uint8 *u8vector; + scm_t_uint32 len; + + SCM_VALIDATE_OBJCODE (1, objcode); + + len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode); + + u8vector = scm_malloc (len); + memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len); + + return scm_take_u8vector (u8vector, len); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0, + (SCM objcode, SCM port), + "") +#define FUNC_NAME s_scm_write_objcode +{ + SCM_VALIDATE_OBJCODE (1, objcode); + SCM_VALIDATE_OUTPUT_PORT (2, port); + + 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)); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +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 + systems. So punt and use automake, PDP endianness be damned. */ +#ifdef WORDS_BIGENDIAN +#define SCM_BYTE_ORDER 4321 +#else +#define SCM_BYTE_ORDER 1234 +#endif + +void +scm_init_objcodes (void) +{ + scm_bootstrap_vm (); + +#ifndef SCM_MAGIC_SNARFER +#include "libguile/objcodes.x" +#endif + + scm_c_define ("word-size", scm_from_size_t (sizeof(SCM))); + scm_c_define ("byte-order", scm_from_uint16 (SCM_BYTE_ORDER)); +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/objcodes.h b/libguile/objcodes.h new file mode 100644 index 000000000..2bb4e6040 --- /dev/null +++ b/libguile/objcodes.h @@ -0,0 +1,75 @@ +/* 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 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_OBJCODES_H_ +#define _SCM_OBJCODES_H_ + +#include <libguile.h> + +/* objcode data should be directly mappable to this C structure. */ +struct scm_objcode { + scm_t_uint8 nargs; + scm_t_uint8 nrest; + 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]; +}; + +#define SCM_F_OBJCODE_IS_MMAP (1<<0) +#define SCM_F_OBJCODE_IS_U8VECTOR (1<<1) +#define SCM_F_OBJCODE_IS_SLICE (1<<2) + +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)) +#define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P) + +#define SCM_OBJCODE_LEN(x) (SCM_OBJCODE_DATA (x)->len) +#define SCM_OBJCODE_META_LEN(x) (SCM_OBJCODE_DATA (x)->metalen) +#define SCM_OBJCODE_TOTAL_LEN(x) (SCM_OBJCODE_LEN (x) + SCM_OBJCODE_META_LEN (x)) +#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_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, 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); + +SCM_INTERNAL void scm_bootstrap_objcodes (void); +SCM_INTERNAL void scm_init_objcodes (void); + +#endif /* _SCM_OBJCODES_H_ */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/objects.c b/libguile/objects.c index 0b2c3be74..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 */ @@ -39,6 +40,8 @@ #include "libguile/ports.h" #include "libguile/strings.h" #include "libguile/vectors.h" +#include "libguile/programs.h" +#include "libguile/vm.h" #include "libguile/validate.h" #include "libguile/objects.h" @@ -138,8 +141,9 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) z = SCM_CDR (z); } while (j-- && !scm_is_null (ls)); - /* Fewer arguments than specifiers => CAR != ENV */ - if (scm_is_null (SCM_CAR (z)) || scm_is_pair (SCM_CAR (z))) + /* Fewer arguments than specifiers => CAR != CLASS or `no-method' */ + if (!scm_is_pair (z) + || (!SCM_CLASSP (SCM_CAR (z)) && !scm_is_symbol (SCM_CAR (z)))) return z; next_method: i = (i + 1) & mask; @@ -161,10 +165,15 @@ SCM scm_apply_generic (SCM gf, SCM args) { SCM cmethod = scm_mcache_compute_cmethod (SCM_ENTITY_PROCEDURE (gf), args); - return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)), - SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)), - args, - SCM_CMETHOD_ENV (cmethod))); + if (SCM_PROGRAM_P (cmethod)) + return scm_vm_apply (scm_the_vm (), cmethod, args); + else if (scm_is_pair (cmethod)) + return scm_eval_body (SCM_CDR (SCM_CMETHOD_CODE (cmethod)), + SCM_EXTEND_ENV (SCM_CAR (SCM_CMETHOD_CODE (cmethod)), + args, + SCM_CMETHOD_ENV (cmethod))); + else + return scm_apply (cmethod, args, SCM_EOL); } SCM 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..e3d2b0da6 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 */ @@ -29,6 +30,9 @@ #include <errno.h> #include <fcntl.h> /* for chsize on mingw */ #include <assert.h> +#include <uniconv.h> +#include <unistr.h> +#include <striconveh.h> #include <assert.h> @@ -52,6 +56,7 @@ #include "libguile/vectors.h" #include "libguile/weaks.h" #include "libguile/fluids.h" +#include "libguile/eq.h" #ifdef HAVE_STRING_H #include <string.h> @@ -221,15 +226,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; } @@ -358,10 +362,10 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0, /* Standard ports --- current input, output, error, and more(!). */ -static SCM cur_inport_fluid; -static SCM cur_outport_fluid; -static SCM cur_errport_fluid; -static SCM cur_loadport_fluid; +static SCM cur_inport_fluid = 0; +static SCM cur_outport_fluid = 0; +static SCM cur_errport_fluid = 0; +static SCM cur_loadport_fluid = 0; SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0, (), @@ -370,7 +374,10 @@ SCM_DEFINE (scm_current_input_port, "current-input-port", 0, 0, 0, "returns the @dfn{standard input} in Unix and C terminology.") #define FUNC_NAME s_scm_current_input_port { - return scm_fluid_ref (cur_inport_fluid); + if (cur_inport_fluid) + return scm_fluid_ref (cur_inport_fluid); + else + return SCM_BOOL_F; } #undef FUNC_NAME @@ -382,7 +389,10 @@ SCM_DEFINE (scm_current_output_port, "current-output-port", 0, 0, 0, "Unix and C terminology.") #define FUNC_NAME s_scm_current_output_port { - return scm_fluid_ref (cur_outport_fluid); + if (cur_outport_fluid) + return scm_fluid_ref (cur_outport_fluid); + else + return SCM_BOOL_F; } #undef FUNC_NAME @@ -392,7 +402,10 @@ SCM_DEFINE (scm_current_error_port, "current-error-port", 0, 0, 0, "@dfn{standard error} in Unix and C terminology).") #define FUNC_NAME s_scm_current_error_port { - return scm_fluid_ref (cur_errport_fluid); + if (cur_errport_fluid) + return scm_fluid_ref (cur_errport_fluid); + else + return SCM_BOOL_F; } #undef FUNC_NAME @@ -570,10 +583,18 @@ scm_new_port_table_entry (scm_t_bits tag) SCM z = scm_cons (SCM_EOL, SCM_EOL); scm_t_port *entry = (scm_t_port *) scm_gc_calloc (sizeof (scm_t_port), "port"); + const char *enc; entry->file_name = SCM_BOOL_F; entry->rw_active = SCM_PORT_NEITHER; entry->port = z; + /* Initialize this port with the thread's current default + encoding. */ + if ((enc = scm_i_get_port_encoding (SCM_BOOL_F)) == NULL) + entry->encoding = NULL; + else + entry->encoding = strdup (enc); + entry->ilseq_handler = scm_i_get_conversion_strategy (SCM_BOOL_F); SCM_SET_CELL_TYPE (z, tag); SCM_SETPTAB_ENTRY (z, entry); @@ -614,6 +635,11 @@ scm_i_remove_port (SCM port) scm_t_port *p = SCM_PTAB_ENTRY (port); if (p->putback_buf) scm_gc_free (p->putback_buf, p->putback_buf_size, "putback buffer"); + if (p->encoding) + { + free (p->encoding); + p->encoding = NULL; + } scm_gc_free (p, sizeof (scm_t_port), "port"); SCM_SETPTAB_ENTRY (port, 0); @@ -697,21 +723,22 @@ SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0, */ static long -scm_i_mode_bits_n (const char *modes, size_t n) +scm_i_mode_bits_n (SCM modes) { return (SCM_OPN - | (memchr (modes, 'r', n) || memchr (modes, '+', n) ? SCM_RDNG : 0) - | ( memchr (modes, 'w', n) - || memchr (modes, 'a', n) - || memchr (modes, '+', n) ? SCM_WRTNG : 0) - | (memchr (modes, '0', n) ? SCM_BUF0 : 0) - | (memchr (modes, 'l', n) ? SCM_BUFLINE : 0)); + | (scm_i_string_contains_char (modes, 'r') + || scm_i_string_contains_char (modes, '+') ? SCM_RDNG : 0) + | (scm_i_string_contains_char (modes, 'w') + || scm_i_string_contains_char (modes, 'a') + || scm_i_string_contains_char (modes, '+') ? SCM_WRTNG : 0) + | (scm_i_string_contains_char (modes, '0') ? SCM_BUF0 : 0) + | (scm_i_string_contains_char (modes, 'l') ? SCM_BUFLINE : 0)); } long scm_mode_bits (char *modes) { - return scm_i_mode_bits_n (modes, strlen (modes)); + return scm_i_mode_bits (scm_from_locale_string (modes)); } long @@ -722,8 +749,7 @@ scm_i_mode_bits (SCM modes) if (!scm_is_string (modes)) scm_wrong_type_arg_msg (NULL, 0, modes, "string"); - bits = scm_i_mode_bits_n (scm_i_string_chars (modes), - scm_i_string_length (modes)); + bits = scm_i_mode_bits_n (modes); scm_remember_upto_here_1 (modes); return bits; } @@ -994,7 +1020,7 @@ SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0, "characters are available, the end-of-file object is returned.") #define FUNC_NAME s_scm_read_char { - int c; + scm_t_wchar c; if (SCM_UNBNDP (port)) port = scm_current_input_port (); SCM_VALIDATE_OPINPORT (1, port); @@ -1005,6 +1031,133 @@ SCM_DEFINE (scm_read_char, "read-char", 0, 1, 0, } #undef FUNC_NAME +#define SCM_MBCHAR_BUF_SIZE (4) + +/* Get one codepoint from a file, using the port's encoding. */ +scm_t_wchar +scm_getc (SCM port) +{ + int c; + unsigned int bufcount = 0; + char buf[SCM_MBCHAR_BUF_SIZE]; + scm_t_wchar codepoint = 0; + scm_t_uint32 *u32; + size_t u32len; + scm_t_port *pt = SCM_PTAB_ENTRY (port); + + c = scm_get_byte_or_eof (port); + if (c == EOF) + return (scm_t_wchar) EOF; + + buf[0] = c; + bufcount++; + + if (pt->encoding == NULL) + { + /* The encoding is Latin-1: bytes are characters. */ + codepoint = (unsigned char) buf[0]; + goto success; + } + + for (;;) + { + u32 = u32_conv_from_encoding (pt->encoding, + (enum iconv_ilseq_handler) pt->ilseq_handler, + buf, bufcount, NULL, NULL, &u32len); + if (u32 == NULL || u32len == 0) + { + if (errno == ENOMEM) + scm_memory_error ("Input decoding"); + + /* Otherwise errno is EILSEQ or EINVAL, so perhaps more + bytes are needed. Keep looping. */ + } + else + { + /* Complete codepoint found. */ + codepoint = u32[0]; + free (u32); + goto success; + } + + if (bufcount == SCM_MBCHAR_BUF_SIZE) + { + /* We've read several bytes and didn't find a good + codepoint. Give up. */ + goto failure; + } + + c = scm_get_byte_or_eof (port); + + if (c == EOF) + { + /* EOF before a complete character was read. Push it all + back and return EOF. */ + while (bufcount > 0) + { + /* FIXME: this will probably cause errors in the port column. */ + scm_unget_byte (buf[bufcount-1], port); + bufcount --; + } + return EOF; + } + + if (c == '\n') + { + /* It is always invalid to have EOL in the middle of a + multibyte character. */ + scm_unget_byte ('\n', port); + goto failure; + } + + buf[bufcount++] = c; + } + + success: + switch (codepoint) + { + case '\a': + break; + case '\b': + SCM_DECCOL (port); + break; + case '\n': + SCM_INCLINE (port); + break; + case '\r': + SCM_ZEROCOL (port); + break; + case '\t': + SCM_TABCOL (port); + break; + default: + SCM_INCCOL (port); + break; + } + + return codepoint; + + failure: + { + char *err_buf; + SCM err_str = scm_i_make_string (bufcount, &err_buf); + memcpy (err_buf, buf, bufcount); + + if (errno == EILSEQ) + scm_misc_error (NULL, "input encoding error for ~s: ~s", + scm_list_2 (scm_from_locale_string (scm_i_get_port_encoding (port)), + err_str)); + else + scm_misc_error (NULL, "input encoding error (invalid) for ~s: ~s\n", + scm_list_2 (scm_from_locale_string (scm_i_get_port_encoding (port)), + err_str)); + } + + /* Never gets here. */ + return 0; +} + + /* this should only be called when the read buffer is empty. it tries to refill the read buffer. it returns the first char from the port, which is either EOF or *(pt->read_pos). */ @@ -1034,7 +1187,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,25 +1215,74 @@ 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); + 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; + + /* Note that making a substring will likely take the + stringbuf_write_mutex. So, one shouldn't use scm_lfwrite_substr + if the stringbuf write mutex may still be held elsewhere. */ + buf = scm_to_stringn (scm_c_substring (str, start, end), &len, + pt->encoding, pt->ilseq_handler); + 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); } - else { - SCM_INCCOL(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) +{ + 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); + + buf = scm_to_stringn (str, &len, + pt->encoding, pt->ilseq_handler); + ptob->write (port, buf, len); + free (buf); + + for (i = 0; i < size; i++) + { + p = scm_i_string_ref (str, i); + update_port_lf (p, port); } - } if (pt->rw_random) pt->rw_active = SCM_PORT_WRITE; @@ -1257,8 +1476,8 @@ scm_end_input (SCM port) void -scm_ungetc (int c, SCM port) -#define FUNC_NAME "scm_ungetc" +scm_unget_byte (int c, SCM port) +#define FUNC_NAME "scm_unget_byte" { scm_t_port *pt = SCM_PTAB_ENTRY (port); @@ -1319,6 +1538,25 @@ scm_ungetc (int c, SCM port) if (pt->rw_random) pt->rw_active = SCM_PORT_READ; +} +#undef FUNC_NAME + +void +scm_ungetc (scm_t_wchar c, SCM port) +#define FUNC_NAME "scm_ungetc" +{ + scm_t_port *pt = SCM_PTAB_ENTRY (port); + scm_t_wchar *wbuf; + SCM str = scm_i_make_wide_string (1, &wbuf); + char *buf; + size_t len; + int i; + + wbuf[0] = c; + buf = scm_to_stringn (str, &len, pt->encoding, pt->ilseq_handler); + + for (i = len - 1; i >= 0; i--) + scm_unget_byte (buf[i], port); if (c == '\n') { @@ -1365,7 +1603,7 @@ SCM_DEFINE (scm_peek_char, "peek-char", 0, 1, 0, "to @code{read-char} would have hung.") #define FUNC_NAME s_scm_peek_char { - int c, column; + scm_t_wchar c, column; if (SCM_UNBNDP (port)) port = scm_current_input_port (); else @@ -1411,13 +1649,17 @@ SCM_DEFINE (scm_unread_string, "unread-string", 2, 0, 0, "@var{port} is not supplied, the current-input-port is used.") #define FUNC_NAME s_scm_unread_string { + int n; SCM_VALIDATE_STRING (1, str); if (SCM_UNBNDP (port)) port = scm_current_input_port (); else SCM_VALIDATE_OPINPORT (2, port); - scm_ungets (scm_i_string_chars (str), scm_i_string_length (str), port); + n = scm_i_string_length (str); + + while (n--) + scm_ungetc (scm_i_string_ref (str, n), port); return str; } @@ -1458,23 +1700,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 +1793,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); @@ -1682,6 +1914,328 @@ SCM_DEFINE (scm_set_port_filename_x, "set-port-filename!", 2, 0, 0, } #undef FUNC_NAME +/* The default port encoding for this locale. New ports will have this + encoding. If it is a string, that is the encoding. If it #f, it + is in the native (Latin-1) encoding. */ +SCM_GLOBAL_VARIABLE (scm_port_encoding_var, "%port-encoding"); +static int scm_port_encoding_init = 0; + +/* Return a C string representation of the current encoding. */ +const char * +scm_i_get_port_encoding (SCM port) +{ + SCM encoding; + + if (scm_is_false (port)) + { + if (!scm_port_encoding_init) + return NULL; + else if (!scm_is_fluid (SCM_VARIABLE_REF (scm_port_encoding_var))) + return NULL; + else + { + encoding = scm_fluid_ref (SCM_VARIABLE_REF (scm_port_encoding_var)); + if (!scm_is_string (encoding)) + return NULL; + else + return scm_i_string_chars (encoding); + } + } + else + { + scm_t_port *pt; + pt = SCM_PTAB_ENTRY (port); + if (pt->encoding) + return pt->encoding; + else + return NULL; + } +} + +/* Returns ENC is if is a recognized encoding. If it isn't, it tries + to find an alias of ENC that is valid. Otherwise, it returns + NULL. */ +static const char * +find_valid_encoding (const char *enc) +{ + int isvalid = 0; + const char str[] = " "; + scm_t_uint32 *u32; + size_t u32len; + + u32 = u32_conv_from_encoding (enc, iconveh_error, str, 1, + NULL, NULL, &u32len); + isvalid = (u32 != NULL); + free (u32); + + if (isvalid) + return enc; + + return NULL; +} + +void +scm_i_set_port_encoding_x (SCM port, const char *enc) +{ + const char *valid_enc; + scm_t_port *pt; + + /* Null is shorthand for the native, Latin-1 encoding. */ + if (enc == NULL) + valid_enc = NULL; + else + { + valid_enc = find_valid_encoding (enc); + if (valid_enc == NULL) + { + SCM err; + err = scm_from_locale_string (enc); + scm_misc_error (NULL, "invalid or unknown character encoding ~s", + scm_list_1 (err)); + } + } + + if (scm_is_false (port)) + { + /* Set the default encoding for future ports. */ + if (!scm_port_encoding_init + || !scm_is_fluid (SCM_VARIABLE_REF (scm_port_encoding_var))) + scm_misc_error (NULL, "tried to set port encoding fluid before it is initialized", + SCM_EOL); + + if (valid_enc == NULL + || !strcmp (valid_enc, "ASCII") + || !strcmp (valid_enc, "ANSI_X3.4-1968") + || !strcmp (valid_enc, "ISO-8859-1")) + scm_fluid_set_x (SCM_VARIABLE_REF (scm_port_encoding_var), SCM_BOOL_F); + else + scm_fluid_set_x (SCM_VARIABLE_REF (scm_port_encoding_var), + scm_from_locale_string (valid_enc)); + } + else + { + /* Set the character encoding for this port. */ + pt = SCM_PTAB_ENTRY (port); + if (pt->encoding) + free (pt->encoding); + if (valid_enc == NULL) + pt->encoding = NULL; + else + pt->encoding = strdup (valid_enc); + } +} + +SCM_DEFINE (scm_port_encoding, "port-encoding", 1, 0, 0, + (SCM port), + "Returns, as a string, the character encoding that @var{port}\n" + "uses to interpret its input and output.\n") +#define FUNC_NAME s_scm_port_encoding +{ + scm_t_port *pt; + const char *enc; + + SCM_VALIDATE_PORT (1, port); + + pt = SCM_PTAB_ENTRY (port); + enc = scm_i_get_port_encoding (port); + if (enc) + return scm_from_locale_string (pt->encoding); + else + return scm_from_locale_string ("NONE"); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_set_port_encoding_x, "set-port-encoding!", 2, 0, 0, + (SCM port, SCM enc), + "Sets the character encoding that will be used to interpret all\n" + "port I/O. New ports are created with the encoding\n" + "appropriate for the current locale if @code{setlocale} has \n" + "been called or ISO-8859-1 otherwise\n" + "and this procedure can be used to modify that encoding.\n") + +#define FUNC_NAME s_scm_set_port_encoding_x +{ + char *enc_str; + const char *valid_enc_str; + + SCM_VALIDATE_PORT (1, port); + SCM_VALIDATE_STRING (2, enc); + + enc_str = scm_to_locale_string (enc); + valid_enc_str = find_valid_encoding (enc_str); + if (valid_enc_str == NULL) + { + free (enc_str); + scm_misc_error (FUNC_NAME, "invalid or unknown character encoding ~s", + scm_list_1 (enc)); + } + else + { + scm_i_set_port_encoding_x (port, valid_enc_str); + free (enc_str); + } + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + +/* This determines how conversions handle unconvertible characters. */ +SCM_GLOBAL_VARIABLE (scm_conversion_strategy, "%port-conversion-strategy"); +static int scm_conversion_strategy_init = 0; + +scm_t_string_failed_conversion_handler +scm_i_get_conversion_strategy (SCM port) +{ + SCM encoding; + + if (scm_is_false (port)) + { + if (!scm_conversion_strategy_init + || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy))) + return SCM_FAILED_CONVERSION_QUESTION_MARK; + else + { + encoding = scm_fluid_ref (SCM_VARIABLE_REF (scm_conversion_strategy)); + if (scm_is_false (encoding)) + return SCM_FAILED_CONVERSION_QUESTION_MARK; + else + return (scm_t_string_failed_conversion_handler) scm_to_int (encoding); + } + } + else + { + scm_t_port *pt; + pt = SCM_PTAB_ENTRY (port); + return pt->ilseq_handler; + } + +} + +void +scm_i_set_conversion_strategy_x (SCM port, + scm_t_string_failed_conversion_handler handler) +{ + SCM strategy; + scm_t_port *pt; + + strategy = scm_from_int ((int) handler); + + if (scm_is_false (port)) + { + /* Set the default encoding for future ports. */ + if (!scm_conversion_strategy + || !scm_is_fluid (SCM_VARIABLE_REF (scm_conversion_strategy))) + scm_misc_error (NULL, "tried to set conversion strategy fluid before it is initialized", + SCM_EOL); + scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy), strategy); + } + else + { + /* Set the character encoding for this port. */ + pt = SCM_PTAB_ENTRY (port); + pt->ilseq_handler = handler; + } +} + +SCM_DEFINE (scm_port_conversion_strategy, "port-conversion-strategy", + 1, 0, 0, (SCM port), + "Returns the behavior of the port when handling a character that\n" + "is not representable in the port's current encoding.\n" + "It returns the symbol @code{error} if unrepresentable characters\n" + "should cause exceptions, @code{substitute} if the port should\n" + "try to replace unrepresentable characters with question marks or\n" + "approximate characters, or @code{escape} if unrepresentable\n" + "characters should be converted to string escapes.\n" + "\n" + "If @var{port} is @code{#f}, then the current default behavior\n" + "will be returned. New ports will have this default behavior\n" + "when they are created.\n") +#define FUNC_NAME s_scm_port_conversion_strategy +{ + scm_t_string_failed_conversion_handler h; + + SCM_VALIDATE_OPPORT (1, port); + + if (!scm_is_false (port)) + { + SCM_VALIDATE_OPPORT (1, port); + } + + h = scm_i_get_conversion_strategy (port); + if (h == SCM_FAILED_CONVERSION_ERROR) + return scm_from_locale_symbol ("error"); + else if (h == SCM_FAILED_CONVERSION_QUESTION_MARK) + return scm_from_locale_symbol ("substitute"); + else if (h == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE) + return scm_from_locale_symbol ("escape"); + else + abort (); + + /* Never gets here. */ + return SCM_UNDEFINED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_set_port_conversion_strategy_x, "set-port-conversion-strategy!", + 2, 0, 0, + (SCM port, SCM sym), + "Sets the behavior of the interpreter when outputting a character\n" + "that is not representable in the port's current encoding.\n" + "@var{sym} can be either @code{'error}, @code{'substitute}, or\n" + "@code{'escape}. If it is @code{'error}, an error will be thrown\n" + "when an unconvertible character is encountered. If it is\n" + "@code{'substitute}, then unconvertible characters will \n" + "be replaced with approximate characters, or with question marks\n" + "if no approximately correct character is available.\n" + "If it is @code{'escape},\n" + "it will appear as a hex escape when output.\n" + "\n" + "If @var{port} is an open port, the conversion error behavior\n" + "is set for that port. If it is @code{#f}, it is set as the\n" + "default behavior for any future ports that get created in\n" + "this thread.\n") +#define FUNC_NAME s_scm_set_port_conversion_strategy_x +{ + SCM err; + SCM qm; + SCM esc; + + if (!scm_is_false (port)) + { + SCM_VALIDATE_OPPORT (1, port); + } + + err = scm_from_locale_symbol ("error"); + if (scm_is_true (scm_eqv_p (sym, err))) + { + scm_i_set_conversion_strategy_x (port, SCM_FAILED_CONVERSION_ERROR); + return SCM_UNSPECIFIED; + } + + qm = scm_from_locale_symbol ("substitute"); + if (scm_is_true (scm_eqv_p (sym, qm))) + { + scm_i_set_conversion_strategy_x (port, + SCM_FAILED_CONVERSION_QUESTION_MARK); + return SCM_UNSPECIFIED; + } + + esc = scm_from_locale_symbol ("escape"); + if (scm_is_true (scm_eqv_p (sym, esc))) + { + scm_i_set_conversion_strategy_x (port, + SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE); + return SCM_UNSPECIFIED; + } + + SCM_MISC_ERROR ("unknown conversion behavior ~s", scm_list_1 (sym)); + + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + + + void scm_print_port_mode (SCM exp, SCM port) { @@ -1792,8 +2346,17 @@ scm_init_ports () cur_loadport_fluid = scm_permanent_object (scm_make_fluid ()); scm_i_port_weak_hash = scm_permanent_object (scm_make_weak_key_hash_table (SCM_I_MAKINUM(31))); - #include "libguile/ports.x" + + SCM_VARIABLE_SET (scm_port_encoding_var, scm_make_fluid ()); + scm_fluid_set_x (SCM_VARIABLE_REF (scm_port_encoding_var), SCM_BOOL_F); + scm_port_encoding_init = 1; + + SCM_VARIABLE_SET (scm_conversion_strategy, scm_make_fluid ()); + scm_fluid_set_x (SCM_VARIABLE_REF (scm_conversion_strategy), + scm_from_int ((int) SCM_FAILED_CONVERSION_QUESTION_MARK)); + scm_conversion_strategy_init = 1; + } /* diff --git a/libguile/ports.h b/libguile/ports.h index 5e42a3468..0f46e7f51 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 */ @@ -27,9 +28,7 @@ #include "libguile/print.h" #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> +#include "libguile/strings.h" @@ -57,6 +56,10 @@ typedef struct long line_number; /* debugging support. */ int column_number; /* debugging support. */ + /* Character encoding support */ + char *encoding; + scm_t_string_failed_conversion_handler ilseq_handler; + /* port buffers. the buffer(s) are set up for all ports. in the case of string ports, the buffer is the string itself. in the case of unbuffered file ports, the buffer is a @@ -69,7 +72,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 +81,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 +90,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 +159,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 +187,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 +225,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); @@ -266,13 +269,18 @@ SCM_API SCM scm_eof_object_p (SCM x); SCM_API SCM scm_force_output (SCM port); SCM_API SCM scm_flush_all_ports (void); SCM_API SCM scm_read_char (SCM port); +SCM_API scm_t_wchar scm_getc (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); -SCM_API void scm_ungetc (int c, SCM port); +SCM_INTERNAL void scm_unget_byte (int c, SCM port); +SCM_API void scm_ungetc (scm_t_wchar c, SCM port); SCM_API void scm_ungets (const char *s, int n, SCM port); SCM_API SCM scm_peek_char (SCM port); SCM_API SCM scm_unread_char (SCM cobj, SCM port); @@ -285,6 +293,15 @@ SCM_API SCM scm_port_column (SCM port); SCM_API SCM scm_set_port_column_x (SCM port, SCM line); SCM_API SCM scm_port_filename (SCM port); SCM_API SCM scm_set_port_filename_x (SCM port, SCM filename); +SCM_INTERNAL const char *scm_i_get_port_encoding (SCM port); +SCM_INTERNAL void scm_i_set_port_encoding_x (SCM port, const char *str); +SCM_API SCM scm_port_encoding (SCM port); +SCM_API SCM scm_set_port_encoding_x (SCM port, SCM encoding); +SCM_INTERNAL scm_t_string_failed_conversion_handler scm_i_get_conversion_strategy (SCM port); +SCM_INTERNAL void scm_i_set_conversion_strategy_x (SCM port, + scm_t_string_failed_conversion_handler h); +SCM_API SCM scm_port_conversion_strategy (SCM port); +SCM_API SCM scm_set_port_conversion_strategy_x (SCM port, SCM behavior); SCM_API int scm_port_print (SCM exp, SCM port, scm_print_state *); SCM_API void scm_print_port_mode (SCM exp, SCM port); SCM_API void scm_ports_prehistory (void); @@ -292,7 +309,6 @@ SCM_API SCM scm_void_port (char * mode_str); SCM_API SCM scm_sys_make_void_port (SCM mode); SCM_INTERNAL void scm_init_ports (void); - #if SCM_ENABLE_DEPRECATED==1 SCM_API scm_t_port * scm_add_to_port_table (SCM port); #endif diff --git a/libguile/posix.c b/libguile/posix.c index b5082fa0a..75469531c 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,8 +22,10 @@ # include <config.h> #endif +#include <stdlib.h> #include <stdio.h> #include <errno.h> +#include <uniconv.h> #include "libguile/_scm.h" #include "libguile/dynwind.h" @@ -33,6 +36,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 +103,6 @@ extern char *ttyname(); #include <signal.h> -extern char ** environ; - #ifdef HAVE_GRP_H #include <grp.h> #endif @@ -136,13 +138,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 +192,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 +452,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 +1473,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 @@ -1425,12 +1502,17 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, "Otherwise the specified locale category is set to the string\n" "@var{locale} and the new value is returned as a\n" "system-dependent string. If @var{locale} is an empty string,\n" - "the locale will be set using environment variables.") + "the locale will be set using environment variables.\n" + "\n" + "When the locale is changed, the character encoding of the new\n" + "locale (UTF-8, ISO-8859-1, etc.) is used for the current\n" + "input, output, and error ports\n") #define FUNC_NAME s_scm_setlocale { int c_category; char *clocale; char *rv; + const char *enc; scm_dynwind_begin (0); @@ -1459,15 +1541,47 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0, SCM_SYSERROR; } - /* Recompute the standard SRFI-14 character sets in a locale-dependent - (actually charset-dependent) way. */ - scm_srfi_14_compute_char_sets (); + enc = locale_charset (); + /* Set the default encoding for new ports. */ + scm_i_set_port_encoding_x (SCM_BOOL_F, enc); + /* Set the encoding for the stdio ports. */ + scm_i_set_port_encoding_x (scm_current_input_port (), enc); + scm_i_set_port_encoding_x (scm_current_output_port (), enc); + scm_i_set_port_encoding_x (scm_current_error_port (), enc); scm_dynwind_end (); return scm_from_locale_string (rv); } #undef FUNC_NAME #endif /* HAVE_SETLOCALE */ +SCM_DEFINE (scm_setbinary, "setbinary", 0, 0, 0, + (void), + "Sets the encoding for the current input, output, and error\n" + "ports to ISO-8859-1. That character encoding allows\n" + "ports to operate on binary data.\n" + "\n" + "It also sets the default encoding for newly created ports\n" + "to ISO-8859-1.\n" + "\n" + "The previous default encoding for new ports is returned\n") +#define FUNC_NAME s_scm_setbinary +{ + const char *enc = scm_i_get_port_encoding (SCM_BOOL_F); + + /* Set the default encoding for new ports. */ + scm_i_set_port_encoding_x (SCM_BOOL_F, NULL); + /* Set the encoding for the stdio ports. */ + scm_i_set_port_encoding_x (scm_current_input_port (), NULL); + scm_i_set_port_encoding_x (scm_current_output_port (), NULL); + scm_i_set_port_encoding_x (scm_current_error_port (), NULL); + + if (enc) + return scm_from_locale_string (enc); + + return scm_from_locale_string ("ISO-8859-1"); +} +#undef FUNC_NAME + #ifdef HAVE_MKNOD SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0, @@ -1668,6 +1782,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 +1896,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 +1939,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..2d93300b8 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); @@ -71,6 +74,7 @@ SCM_API SCM scm_access (SCM path, SCM how); SCM_API SCM scm_getpid (void); SCM_API SCM scm_putenv (SCM str); SCM_API SCM scm_setlocale (SCM category, SCM locale); +SCM_API SCM scm_setbinary (void); SCM_API SCM scm_mknod (SCM path, SCM type, SCM perms, SCM dev); SCM_API SCM scm_nice (SCM incr); SCM_API SCM scm_sync (void); diff --git a/libguile/print.c b/libguile/print.c index 1852cf19a..3bb6cb167 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" @@ -32,7 +35,7 @@ #include "libguile/procprop.h" #include "libguile/read.h" #include "libguile/weaks.h" -#include "libguile/unif.h" +#include "libguile/programs.h" #include "libguile/alist.h" #include "libguile/struct.h" #include "libguile/objects.h" @@ -291,13 +294,12 @@ print_circref (SCM port, scm_print_state *pstate, SCM ref) /* Print the name of a symbol. */ static int -quote_keywordish_symbol (const char *str, size_t len) +quote_keywordish_symbol (SCM symbol) { SCM option; - /* LEN is guaranteed to be > 0. - */ - if (str[0] != ':' && str[len-1] != ':') + if (scm_i_symbol_ref (symbol, 0) != ':' + && scm_i_symbol_ref (symbol, scm_i_symbol_length (symbol) - 1) != ':') return 0; option = SCM_PRINT_KEYWORD_STYLE; @@ -309,7 +311,7 @@ quote_keywordish_symbol (const char *str, size_t len) } void -scm_print_symbol_name (const char *str, size_t len, SCM port) +scm_i_print_symbol_name (SCM str, SCM port) { /* This points to the first character that has not yet been written to the * port. */ @@ -330,18 +332,20 @@ scm_print_symbol_name (const char *str, size_t len, SCM port) * simpler and faster. */ int maybe_weird = 0; size_t mw_pos = 0; + size_t len = scm_i_symbol_length (str); + scm_t_wchar str0 = scm_i_symbol_ref (str, 0); - if (len == 0 || str[0] == '\'' || str[0] == '`' || str[0] == ',' - || quote_keywordish_symbol (str, len) - || (str[0] == '.' && len == 1) - || scm_is_true (scm_c_locale_stringn_to_number (str, len, 10))) + if (len == 0 || str0 == '\'' || str0 == '`' || str0 == ',' + || quote_keywordish_symbol (str) + || (str0 == '.' && len == 1) + || scm_is_true (scm_i_string_to_number (scm_symbol_to_string (str), 10))) { scm_lfwrite ("#{", 2, port); weird = 1; } for (end = pos; end < len; ++end) - switch (str[end]) + switch (scm_i_symbol_ref (str, end)) { #ifdef BRACKETS_AS_PARENS case '[': @@ -366,11 +370,11 @@ scm_print_symbol_name (const char *str, size_t len, SCM port) weird = 1; } if (pos < end) - scm_lfwrite (str + pos, end - pos, port); + scm_lfwrite_substr (scm_symbol_to_string (str), pos, end, port); { char buf[2]; buf[0] = '\\'; - buf[1] = str[end]; + buf[1] = (char) (unsigned char) scm_i_symbol_ref (str, end); scm_lfwrite (buf, 2, port); } pos = end + 1; @@ -388,11 +392,18 @@ scm_print_symbol_name (const char *str, size_t len, SCM port) break; } if (pos < end) - scm_lfwrite (str + pos, end - pos, port); + scm_lfwrite_substr (scm_symbol_to_string (str), pos, end, port); if (weird) scm_lfwrite ("}#", 2, port); } +void +scm_print_symbol_name (const char *str, size_t len, SCM port) +{ + SCM symbol = scm_from_locale_symboln (str, len); + return scm_i_print_symbol_name (symbol, port); +} + /* Print generally. Handles both write and display according to PSTATE. */ SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write); @@ -435,24 +446,66 @@ 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. */ + { + scm_t_wchar *wbuf; + SCM wstr = scm_i_make_wide_string (1, &wbuf); + char *buf; + size_t len; + const char *enc; + + enc = scm_i_get_port_encoding (port); + wbuf[0] = i; + if (enc == NULL) + { + if (i <= 0xFF) + /* Character is graphic and Latin-1. Print it */ + scm_lfwrite_str (wstr, port); + else + /* Character is graphic but unrepresentable in + this port's encoding. */ + scm_intprint (i, 8, port); + } + else + { + buf = u32_conv_to_encoding (enc, + iconveh_error, + (scm_t_uint32 *) wbuf, + 1, + NULL, + NULL, &len); + if (buf != NULL) + { + /* Character is graphic. Print it. */ + scm_lfwrite_str (wstr, port); + free (buf); + } + 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); + scm_i_charprint (i, port); } else if (SCM_IFLAGP (exp) && ((size_t) SCM_IFLAGNUM (exp) < (sizeof iflagnames / sizeof (char *)))) @@ -545,63 +598,128 @@ 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; + + if (scm_i_get_port_encoding (port)) + { + wstr = scm_i_make_wide_string (1, &wbuf); + wbuf[0] = ch; + buf = u32_conv_to_encoding (scm_i_get_port_encoding (port), + 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; + } + } + else + if (ch <= 0xFF) + { + scm_putc (ch, port); + 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_str (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_print_symbol_name (exp, port); scm_remember_upto_here_1 (exp); } else { scm_puts ("#<uninterned-symbol ", port); - scm_print_symbol_name (scm_i_symbol_chars (exp), - scm_i_symbol_length (exp), - port); + scm_i_print_symbol_name (exp, port); scm_putc (' ', port); scm_uintprint (SCM_UNPACK (exp), 16, port); scm_putc ('>', port); @@ -610,6 +728,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) case scm_tc7_variable: scm_i_variable_print (exp, port, pstate); break; + case scm_tc7_program: + scm_i_program_print (exp, port, pstate); + break; case scm_tc7_wvect: ENTER_NESTED_DATA (pstate, exp, circref); if (SCM_IS_WHVEC (exp)) @@ -618,6 +739,9 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) scm_puts ("#w(", port); goto common_vector_printer; + case scm_tc7_bytevector: + scm_i_print_bytevector (exp, port, pstate); + break; case scm_tc7_vector: ENTER_NESTED_DATA (pstate, exp, circref); scm_puts ("#(", port); @@ -664,14 +788,16 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate) EXIT_NESTED_DATA (pstate); break; case scm_tcs_subrs: - scm_puts (SCM_SUBR_GENERIC (exp) - ? "#<primitive-generic " - : "#<primitive-procedure ", - port); - scm_puts (scm_i_symbol_chars (SCM_SNAME (exp)), port); - scm_putc ('>', port); - break; - + { + SCM name = scm_symbol_to_string (SCM_SUBR_NAME (exp)); + scm_puts (SCM_SUBR_GENERIC (exp) + ? "#<primitive-generic " + : "#<primitive-procedure ", + port); + scm_lfwrite_str (name, port); + scm_putc ('>', port); + break; + } case scm_tc7_pws: scm_puts ("#<procedure-with-setter", port); { @@ -763,6 +889,17 @@ scm_prin1 (SCM exp, SCM port, int writingp) } } +/* Print a character. + */ +void +scm_i_charprint (scm_t_wchar 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. */ @@ -977,9 +1114,7 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, SCM port, answer = SCM_UNSPECIFIED; int fReturnString = 0; int writingp; - const char *start; - const char *end; - const char *p; + size_t start, p, end; if (scm_is_eq (destination, SCM_BOOL_T)) { @@ -1002,15 +1137,16 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, SCM_VALIDATE_STRING (2, message); SCM_VALIDATE_REST_ARGUMENT (args); - start = scm_i_string_chars (message); - end = start + scm_i_string_length (message); + p = 0; + start = 0; + end = scm_i_string_length (message); for (p = start; p != end; ++p) - if (*p == '~') + if (scm_i_string_ref (message, p) == '~') { if (++p == end) break; - switch (*p) + switch (scm_i_string_ref (message, p)) { case 'A': case 'a': writingp = 0; @@ -1019,33 +1155,33 @@ SCM_DEFINE (scm_simple_format, "simple-format", 2, 0, 1, writingp = 1; break; case '~': - scm_lfwrite (start, p - start, port); + scm_lfwrite_substr (message, start, p, port); start = p + 1; continue; case '%': - scm_lfwrite (start, p - start - 1, port); + scm_lfwrite_substr (message, start, p - 1, port); scm_newline (port); start = p + 1; continue; default: SCM_MISC_ERROR ("FORMAT: Unsupported format option ~~~A - use (ice-9 format) instead", - scm_list_1 (SCM_MAKE_CHAR (*p))); + scm_list_1 (SCM_MAKE_CHAR (scm_i_string_ref (message, p)))); } if (!scm_is_pair (args)) SCM_MISC_ERROR ("FORMAT: Missing argument for ~~~A", - scm_list_1 (SCM_MAKE_CHAR (*p))); + scm_list_1 (SCM_MAKE_CHAR (scm_i_string_ref (message, p)))); - scm_lfwrite (start, p - start - 1, port); + scm_lfwrite_substr (message, start, p - 1, port); /* we pass destination here */ scm_prin1 (SCM_CAR (args), destination, writingp); args = SCM_CDR (args); start = p + 1; } - scm_lfwrite (start, p - start, port); + scm_lfwrite_substr (message, start, p, port); if (!scm_is_eq (args, SCM_EOL)) SCM_MISC_ERROR ("FORMAT: ~A superfluous arguments", scm_list_1 (scm_length (args))); diff --git a/libguile/print.h b/libguile/print.h index 8974a7554..ae2aaef54 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -6,24 +6,26 @@ /* 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 */ #include "libguile/__scm.h" +#include "libguile/chars.h" #include "libguile/options.h" @@ -76,10 +78,12 @@ 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_wchar 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); SCM_API void scm_iprlist (char *hdr, SCM exp, int tlr, SCM port, scm_print_state *pstate); +SCM_INTERNAL void scm_i_print_symbol_name (SCM sym, SCM port); SCM_API void scm_print_symbol_name (const char *str, size_t len, SCM port); SCM_API void scm_prin1 (SCM exp, SCM port, int writingp); SCM_API void scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate); diff --git a/libguile/private-gc.h b/libguile/private-gc.h index b38addebd..42514c1e2 100644 --- a/libguile/private-gc.h +++ b/libguile/private-gc.h @@ -1,25 +1,26 @@ /* * 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 -#define PRIVATE_GC +#ifndef SCM_PRIVATE_GC +#define SCM_PRIVATE_GC #include "_scm.h" @@ -31,54 +32,15 @@ * Each heap cell is 8 bytes on a 32 bit machine and 16 bytes on a * 64 bit machine. The units of the _SIZE parameters are bytes. * Cons pairs and object headers occupy one heap cell. - * - * SCM_MIN_HEAP_SEG_SIZE is minimum size of heap to accept when more heap - * is needed. */ -/* - * Heap size 45000 and 40% min yield gives quick startup and no extra - * heap allocation. Having higher values on min yield may lead to - * large heaps, especially if code behaviour is varying its - * maximum consumption between different freelists. - */ - -/* - These values used to be global C variables. However, they're also - available through the environment, and having a double interface is - confusing. Now they're #defines --hwn. - */ - -#define SCM_DEFAULT_INIT_HEAP_SIZE_1 256*1024 -#define SCM_DEFAULT_MIN_YIELD_1 40 #define SCM_DEFAULT_INIT_HEAP_SIZE_2 32*1024 -/* - How many cells to collect during one sweep call. This is the pool - size of each thread. - */ -#define DEFAULT_SWEEP_AMOUNT 512 - -/* The following value may seem large, but note that if we get to GC at - * all, this means that we have a numerically intensive application - */ -#define SCM_DEFAULT_MIN_YIELD_2 40 - -#define SCM_DEFAULT_MAX_SEGMENT_SIZE (20*1024*1024L) - -#define SCM_MIN_HEAP_SEG_SIZE (8 * SCM_GC_SIZEOF_CARD) -#define SCM_HEAP_SEG_SIZE (16384L * sizeof (scm_t_cell)) - #define SCM_DOUBLECELL_ALIGNED_P(x) (((2 * sizeof (scm_t_cell) - 1) & SCM_UNPACK (x)) == 0) -#define SCM_GC_CARD_BVEC_SIZE_IN_LONGS \ - ((SCM_GC_CARD_N_CELLS + SCM_C_BVEC_LONG_BITS - 1) / SCM_C_BVEC_LONG_BITS) -#define SCM_GC_IN_CARD_HEADERP(x) \ - (scm_t_cell *) (x) < SCM_GC_CELL_CARD (x) + SCM_GC_CARD_N_HEADER_CELLS - -int scm_getenv_int (const char *var, int def); +SCM_INTERNAL int scm_getenv_int (const char *var, int def); typedef enum { return_on_error, abort_on_error } policy_on_error; @@ -99,29 +61,6 @@ typedef enum { return_on_error, abort_on_error } policy_on_error; */ #define CELL_P(x) ((SCM_UNPACK(x) & (sizeof(scm_t_cell)-1)) == scm_tc3_cons) -/* - gc-mark - */ - -/* this can be used to ensure that set/clear gc marks only happen when - allowed. */ -int scm_i_marking; - -void scm_mark_all (void); - -extern long int scm_i_deprecated_memory_return; -extern long int scm_i_find_heap_calls; - SCM_INTERNAL char const *scm_i_tag_name (scm_t_bits tag); /* MOVEME */ - -/* - global init funcs. - */ -void scm_gc_init_malloc (void); -void scm_gc_init_freelist (void); -void scm_gc_init_segments (void); -void scm_gc_init_mark (void); - - #endif 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..5054291b1 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 */ @@ -32,6 +33,7 @@ #include "libguile/root.h" #include "libguile/vectors.h" #include "libguile/hashtab.h" +#include "libguile/programs.h" #include "libguile/validate.h" #include "libguile/procprop.h" @@ -71,6 +73,11 @@ scm_i_procedure_arity (SCM proc) case scm_tc7_lsubr: r = 1; break; + case scm_tc7_program: + a += SCM_PROGRAM_DATA (proc)->nargs; + r = SCM_PROGRAM_DATA (proc)->nrest; + a -= r; + break; case scm_tc7_lsubr_2: a += 2; r = 1; 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 56bb0bb14..40d6231bb 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 */ @@ -31,6 +32,9 @@ #include "libguile/validate.h" #include "libguile/procs.h" +#include "libguile/procprop.h" +#include "libguile/objcodes.h" +#include "libguile/programs.h" @@ -42,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; } @@ -58,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; } @@ -76,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; } @@ -95,6 +103,7 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0, case scm_tcs_closures: case scm_tcs_subrs: case scm_tc7_pws: + case scm_tc7_program: return SCM_BOOL_T; case scm_tc7_smob: return scm_from_bool (SCM_SMOB_DESCRIPTOR (obj).apply); @@ -134,11 +143,17 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0, return SCM_BOOL_T; case scm_tc7_gsubr: return scm_from_bool (SCM_GSUBR_REQ (SCM_GSUBR_TYPE (obj)) == 0); + case scm_tc7_program: + return scm_from_bool (SCM_PROGRAM_DATA (obj)->nargs == 0 + || (SCM_PROGRAM_DATA (obj)->nargs == 1 + && SCM_PROGRAM_DATA (obj)->nrest)); case scm_tc7_pws: obj = SCM_PROCEDURE (obj); goto again; default: - ; + if (SCM_PROGRAM_P (obj) && SCM_PROGRAM_DATA (obj)->nargs == 0) + return SCM_BOOL_T; + /* otherwise fall through */ } } return SCM_BOOL_F; @@ -160,6 +175,8 @@ scm_subr_p (SCM obj) return 0; } +SCM_SYMBOL (sym_documentation, "documentation"); + SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, (SCM proc), "Return the documentation string associated with @code{proc}. By\n" @@ -171,6 +188,8 @@ SCM_DEFINE (scm_procedure_documentation, "procedure-documentation", 1, 0, 0, SCM code; SCM_ASSERT (scm_is_true (scm_procedure_p (proc)), proc, SCM_ARG1, FUNC_NAME); + if (SCM_PROGRAM_P (proc)) + return scm_assq_ref (scm_program_properties (proc), sym_documentation); switch (SCM_TYP7 (proc)) { case scm_tcs_closures: @@ -208,11 +227,25 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0, "with the associated setter @var{setter}.") #define FUNC_NAME s_scm_make_procedure_with_setter { + SCM name, ret; SCM_VALIDATE_PROC (1, procedure); SCM_VALIDATE_PROC (2, setter); - return scm_double_cell (scm_tc7_pws, - SCM_UNPACK (procedure), - SCM_UNPACK (setter), 0); + ret = scm_double_cell (scm_tc7_pws, + SCM_UNPACK (procedure), + SCM_UNPACK (setter), 0); + /* don't use procedure_name, because don't care enough to do a reverse + lookup */ + switch (SCM_TYP7 (procedure)) { + case scm_tcs_subrs: + name = SCM_SUBR_NAME (procedure); + break; + default: + name = scm_procedure_property (procedure, scm_sym_name); + break; + } + if (scm_is_true (name)) + scm_set_procedure_property_x (ret, scm_sym_name, name); + return ret; } #undef FUNC_NAME diff --git a/libguile/procs.h b/libguile/procs.h index 18857c62e..7e445ad11 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 new file mode 100644 index 000000000..b2bf80674 --- /dev/null +++ b/libguile/programs.c @@ -0,0 +1,307 @@ +/* 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 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 + */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#include <string.h> +#include "_scm.h" +#include "vm-bootstrap.h" +#include "instructions.h" +#include "modules.h" +#include "programs.h" +#include "procprop.h" // scm_sym_name +#include "srcprop.h" // scm_sym_filename +#include "vm.h" + + +static SCM write_program = SCM_BOOL_F; + +SCM_DEFINE (scm_make_program, "make-program", 1, 2, 0, + (SCM objcode, SCM objtable, SCM free_variables), + "") +#define FUNC_NAME s_scm_make_program +{ + SCM_VALIDATE_OBJCODE (1, objcode); + if (SCM_UNLIKELY (SCM_UNBNDP (objtable))) + objtable = SCM_BOOL_F; + else if (scm_is_true (objtable)) + SCM_VALIDATE_VECTOR (2, objtable); + 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); + + return scm_double_cell (scm_tc7_program, (scm_t_bits)objcode, + (scm_t_bits)objtable, (scm_t_bits)free_variables); +} +#undef FUNC_NAME + +void +scm_i_program_print (SCM program, SCM port, scm_print_state *pstate) +{ + static int print_error = 0; + + if (SCM_FALSEP (write_program) && scm_module_system_booted_p) + write_program = scm_module_local_variable + (scm_c_resolve_module ("system vm program"), + scm_from_locale_symbol ("write-program")); + + if (SCM_FALSEP (write_program) || print_error) + { + scm_puts ("#<program ", port); + scm_uintprint (SCM_CELL_WORD_1 (program), 16, port); + scm_putc ('>', port); + } + else + { + print_error = 1; + scm_call_2 (SCM_VARIABLE_REF (write_program), program, port); + print_error = 0; + } +} + + +/* + * Scheme interface + */ + +SCM_DEFINE (scm_program_p, "program?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_program_p +{ + return SCM_BOOL (SCM_PROGRAM_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_base, "program-base", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_base +{ + SCM_VALIDATE_PROGRAM (1, program); + + return scm_from_ulong ((unsigned long) SCM_PROGRAM_DATA (program)->base); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_arity, "program-arity", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_arity +{ + struct scm_objcode *p; + + SCM_VALIDATE_PROGRAM (1, program); + + p = SCM_PROGRAM_DATA (program); + return scm_list_3 (SCM_I_MAKINUM (p->nargs), + SCM_I_MAKINUM (p->nrest), + SCM_I_MAKINUM (p->nlocs)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_objects, "program-objects", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_objects +{ + SCM_VALIDATE_PROGRAM (1, program); + return SCM_PROGRAM_OBJTABLE (program); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_module, "program-module", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_module +{ + SCM objs; + SCM_VALIDATE_PROGRAM (1, program); + objs = SCM_PROGRAM_OBJTABLE (program); + return scm_is_true (objs) ? scm_c_vector_ref (objs, 0) : SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_meta, "program-meta", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_meta +{ + SCM metaobj; + + SCM_VALIDATE_PROGRAM (1, program); + + metaobj = scm_objcode_meta (SCM_PROGRAM_OBJCODE (program)); + if (scm_is_true (metaobj)) + return scm_make_program (metaobj, SCM_BOOL_F, SCM_BOOL_F); + else + return SCM_BOOL_F; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_bindings, "program-bindings", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_bindings +{ + SCM meta; + + SCM_VALIDATE_PROGRAM (1, program); + + meta = scm_program_meta (program); + if (scm_is_false (meta)) + return SCM_BOOL_F; + + return scm_car (scm_call_0 (meta)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_sources, "program-sources", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_sources +{ + SCM meta, sources, ret, filename; + + SCM_VALIDATE_PROGRAM (1, program); + + meta = scm_program_meta (program); + if (scm_is_false (meta)) + return SCM_EOL; + + filename = SCM_BOOL_F; + ret = SCM_EOL; + for (sources = scm_cadr (scm_call_0 (meta)); !scm_is_null (sources); + sources = scm_cdr (sources)) + { + SCM x = scm_car (sources); + if (scm_is_pair (x)) + { + if (scm_is_number (scm_car (x))) + { + SCM addr = scm_car (x); + ret = scm_acons (addr, scm_cons (filename, scm_cdr (x)), + ret); + } + else if (scm_is_eq (scm_car (x), scm_sym_filename)) + filename = scm_cdr (x); + } + } + return scm_reverse_x (ret, SCM_UNDEFINED); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_properties, "program-properties", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_properties +{ + SCM meta; + + SCM_VALIDATE_PROGRAM (1, program); + + meta = scm_program_meta (program); + if (scm_is_false (meta)) + return SCM_EOL; + + return scm_cddr (scm_call_0 (meta)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_name, "program-name", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_name +{ + SCM_VALIDATE_PROGRAM (1, program); + return scm_assq_ref (scm_program_properties (program), scm_sym_name); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_source, "program-source", 2, 0, 0, + (SCM program, SCM ip), + "") +#define FUNC_NAME s_scm_program_source +{ + SCM_VALIDATE_PROGRAM (1, program); + return scm_c_program_source (program, scm_to_size_t (ip)); +} +#undef FUNC_NAME + +extern SCM +scm_c_program_source (SCM program, size_t ip) +{ + SCM sources, source = SCM_BOOL_F; + + for (sources = scm_program_sources (program); + !scm_is_null (sources) + && scm_to_size_t (scm_caar (sources)) <= ip; + sources = scm_cdr (sources)) + source = scm_car (sources); + + return source; /* (addr . (filename . (line . column))) */ +} + +SCM_DEFINE (scm_program_free_variables, "program-free-variables", 1, 0, 0, + (SCM program), + "") +#define FUNC_NAME s_scm_program_free_variables +{ + SCM_VALIDATE_PROGRAM (1, program); + return SCM_PROGRAM_FREE_VARIABLES (program); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_program_objcode, "program-objcode", 1, 0, 0, + (SCM program), + "Return a @var{program}'s object code.") +#define FUNC_NAME s_scm_program_objcode +{ + SCM_VALIDATE_PROGRAM (1, program); + + return SCM_PROGRAM_OBJCODE (program); +} +#undef FUNC_NAME + + + +void +scm_bootstrap_programs (void) +{ + scm_c_register_extension ("libguile", "scm_init_programs", + (scm_t_extension_init_func)scm_init_programs, NULL); +} + +void +scm_init_programs (void) +{ + scm_bootstrap_vm (); + +#ifndef SCM_MAGIC_SNARFER +#include "libguile/programs.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/programs.h b/libguile/programs.h new file mode 100644 index 000000000..d52631fbb --- /dev/null +++ b/libguile/programs.h @@ -0,0 +1,68 @@ +/* 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 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_PROGRAMS_H_ +#define _SCM_PROGRAMS_H_ + +#include <libguile.h> +#include <libguile/objcodes.h> + +/* + * Programs + */ + +#define SCM_F_PROGRAM_IS_BOOT (1<<16) + +#define SCM_PROGRAM_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_program) +#define SCM_PROGRAM_OBJCODE(x) (SCM_CELL_OBJECT_1 (x)) +#define SCM_PROGRAM_OBJTABLE(x) (SCM_CELL_OBJECT_2 (x)) +#define SCM_PROGRAM_FREE_VARIABLES(x) (SCM_CELL_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_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_BOOT) + +SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables); + +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); + +SCM_API SCM scm_c_program_source (SCM program, size_t ip); + +SCM_INTERNAL void scm_i_program_print (SCM program, SCM port, + scm_print_state *pstate); +SCM_INTERNAL void scm_bootstrap_programs (void); +SCM_INTERNAL void scm_init_programs (void); + +#endif /* _SCM_PROGRAMS_H_ */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ 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..6ad320af4 --- /dev/null +++ b/libguile/r6rs-ports.c @@ -0,0 +1,1076 @@ +/* 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 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_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_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_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_pointerless (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_pointerless (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_pointerless (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))); +} + +/* 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_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); +} + + +/* 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_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/random.c b/libguile/random.c index f5f706f85..281d43aa8 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. +/* Copyright (C) 1999,2000,2001, 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 */ @@ -32,9 +33,10 @@ #include "libguile/numbers.h" #include "libguile/feature.h" #include "libguile/strings.h" -#include "libguile/unif.h" +#include "libguile/arrays.h" #include "libguile/srfi-4.h" #include "libguile/vectors.h" +#include "libguile/generalized-vectors.h" #include "libguile/validate.h" #include "libguile/random.h" 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..1f46e5bf0 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 @@ -58,12 +59,10 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, size_t j; size_t cstart; size_t cend; - int c; - const char *cdelims; + scm_t_wchar c; size_t num_delims; SCM_VALIDATE_STRING (1, delims); - cdelims = scm_i_string_chars (delims); num_delims = scm_i_string_length (delims); SCM_VALIDATE_STRING (2, str); @@ -82,7 +81,7 @@ SCM_DEFINE (scm_read_delimited_x, "%read-delimited!", 3, 3, 0, c = scm_getc (port); for (k = 0; k < num_delims; k++) { - if (cdelims[k] == c) + if (scm_i_string_ref (delims, k) == c) { if (scm_is_false (gobble)) scm_ungetc (c, port); 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..d91c868e1 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 */ @@ -26,11 +27,15 @@ #include <stdio.h> #include <ctype.h> #include <string.h> +#include <unistd.h> +#include <unicase.h> #include "libguile/_scm.h" +#include "libguile/bytevectors.h" #include "libguile/chars.h" #include "libguile/eval.h" -#include "libguile/unif.h" +#include "libguile/arrays.h" +#include "libguile/bitvectors.h" #include "libguile/keywords.h" #include "libguile/alist.h" #include "libguile/srcprop.h" @@ -175,52 +180,76 @@ static SCM *scm_read_hash_procedures; (((_chr) == 'e') || ((_chr) == 's') || ((_chr) == 'f') \ || ((_chr) == 'd') || ((_chr) == 'l')) -/* An inlinable version of `scm_c_downcase ()'. */ -#define CHAR_DOWNCASE(_chr) \ - (((_chr) <= UCHAR_MAX) ? tolower (_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. */ static inline int -read_token (SCM port, char *buf, size_t buf_size, size_t *read) +read_token (SCM port, SCM buf, size_t *read) { + scm_t_wchar chr; *read = 0; - while (*read < buf_size) + buf = scm_i_string_start_writing (buf); + while (*read < scm_i_string_length (buf)) { - int chr; - chr = scm_getc (port); - chr = (SCM_CASE_INSENSITIVE_P ? CHAR_DOWNCASE (chr) : chr); if (chr == EOF) - return 0; - else if (CHAR_IS_DELIMITER (chr)) { - scm_ungetc (chr, port); + scm_i_string_stop_writing (); return 0; } - else + + chr = (SCM_CASE_INSENSITIVE_P ? uc_tolower (chr) : chr); + + if (CHAR_IS_DELIMITER (chr)) { - *buf = (char) chr; - buf++, (*read)++; + scm_i_string_stop_writing (); + scm_ungetc (chr, port); + return 0; } + + scm_i_string_set_x (buf, *read, chr); + (*read)++; } + scm_i_string_stop_writing (); return 1; } +static SCM +read_complete_token (SCM port, size_t *read) +{ + SCM buffer, str = SCM_EOL; + size_t len; + int overflow; + + buffer = scm_i_make_string (READER_BUFFER_SIZE, NULL); + overflow = read_token (port, buffer, read); + if (!overflow) + return scm_i_substring (buffer, 0, *read); + + str = scm_string_copy (buffer); + do + { + overflow = read_token (port, buffer, &len); + str = scm_string_append (scm_list_2 (str, buffer)); + *read += len; + } + while (overflow); + + return scm_i_substring (str, 0, *read); +} /* Skip whitespace from PORT and return the first non-whitespace character read. Raise an error on end-of-file. */ static int flush_ws (SCM port, const char *eoferr) { - register int c; + register scm_t_wchar c; while (1) switch (c = scm_getc (port)) { @@ -257,6 +286,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 '#'; @@ -286,7 +318,7 @@ static SCM recsexpr (SCM obj, long line, int column, SCM filename); static SCM -scm_read_sexp (int chr, SCM port) +scm_read_sexp (scm_t_wchar chr, SCM port) #define FUNC_NAME "scm_i_lreadparen" { register int c; @@ -381,207 +413,218 @@ 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; - - if (str == SCM_BOOL_F) - str = scm_c_make_string (0, SCM_MAKE_CHAR ('X')); + { + str_eof: + scm_i_input_error (FUNC_NAME, port, + "end of file in string constant", SCM_EOL); + } - addy = scm_from_locale_stringn (c_str, c_str_len); - str = scm_string_append_shared (scm_list_2 (str, addy)); + if (c_str_len + 1 >= scm_i_string_length (str)) + { + SCM addy = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL); - 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 static SCM -scm_read_number (int chr, SCM port) +scm_read_number (scm_t_wchar chr, SCM port) { - SCM result, str = SCM_EOL; - char buffer[READER_BUFFER_SIZE]; + SCM result; + SCM buffer; size_t read; - int overflow = 0; scm_ungetc (chr, port); - do - { - overflow = read_token (port, buffer, sizeof (buffer), &read); - - if ((overflow) || (scm_is_pair (str))) - str = scm_cons (scm_from_locale_stringn (buffer, read), str); - } - while (overflow); - - if (scm_is_pair (str)) - { - /* The slow path. */ - - str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL)); - result = scm_string_to_number (str, SCM_UNDEFINED); - if (!scm_is_true (result)) - /* Return a symbol instead of a number. */ - result = scm_string_to_symbol (str); - } - else - { - result = scm_c_locale_stringn_to_number (buffer, read, 10); - if (!scm_is_true (result)) - /* Return a symbol instead of a number. */ - result = scm_from_locale_symboln (buffer, read); - } + buffer = read_complete_token (port, &read); + result = scm_string_to_number (buffer, SCM_UNDEFINED); + if (!scm_is_true (result)) + /* Return a symbol instead of a number. */ + result = scm_string_to_symbol (buffer); return result; } static SCM -scm_read_mixed_case_symbol (int chr, SCM port) +scm_read_mixed_case_symbol (scm_t_wchar chr, SCM port) { - SCM result, str = SCM_EOL; - int overflow = 0, ends_with_colon = 0; - char buffer[READER_BUFFER_SIZE]; + SCM result; + int ends_with_colon = 0; + SCM buffer; size_t read = 0; int postfix = scm_is_eq (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_postfix); scm_ungetc (chr, port); - do - { - overflow = read_token (port, buffer, sizeof (buffer), &read); - - if (read > 0) - ends_with_colon = (buffer[read - 1] == ':'); - - if ((overflow) || (scm_is_pair (str))) - str = scm_cons (scm_from_locale_stringn (buffer, read), str); - } - while (overflow); - - if (scm_is_pair (str)) - { - str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL)); - result = scm_string_to_symbol (str); + buffer = read_complete_token (port, &read); + if (read > 0) + ends_with_colon = scm_i_string_ref (buffer, read - 1) == ':'; - /* 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 && (read > 1)) + result = scm_symbol_to_keyword (scm_string_to_symbol (scm_i_substring (buffer, 0, read - 1))); else - { - /* For symbols smaller than `sizeof (buffer)', we don't need to recur - to Scheme strings. Therefore, we only create one Scheme object (a - symbol) per symbol read. */ - if (postfix && ends_with_colon && (read > 1)) - result = scm_from_locale_keywordn (buffer, read - 1); - else - result = scm_from_locale_symboln (buffer, read); - } + result = scm_string_to_symbol (buffer); return result; } static SCM -scm_read_number_and_radix (int chr, SCM port) +scm_read_number_and_radix (scm_t_wchar chr, SCM port) #define FUNC_NAME "scm_lreadr" { - SCM result, str = SCM_EOL; + SCM result; size_t read; - char buffer[READER_BUFFER_SIZE]; + SCM buffer = scm_i_make_string (READER_BUFFER_SIZE, NULL); unsigned int radix; - int overflow = 0; switch (chr) { @@ -611,22 +654,8 @@ scm_read_number_and_radix (int chr, SCM port) radix = 10; } - do - { - overflow = read_token (port, buffer, sizeof (buffer), &read); - - if ((overflow) || (scm_is_pair (str))) - str = scm_cons (scm_from_locale_stringn (buffer, read), str); - } - while (overflow); - - if (scm_is_pair (str)) - { - str = scm_string_concatenate (scm_reverse_x (str, SCM_EOL)); - result = scm_string_to_number (str, scm_from_uint (radix)); - } - else - result = scm_c_locale_stringn_to_number (buffer, read, radix); + buffer = read_complete_token (port, &read); + result = scm_string_to_number (buffer, scm_from_uint (radix)); if (scm_is_true (result)) return result; @@ -656,7 +685,7 @@ scm_read_quote (int chr, SCM port) case ',': { - int c; + scm_t_wchar c; c = scm_getc (port); if ('@' == c) @@ -691,12 +720,74 @@ 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) { int c; - for (c = scm_getc (port); + /* We use the get_byte here because there is no need to get the + locale correct with comment input. This presumes that newline + always represents itself no matter what the encoding is. */ + for (c = scm_get_byte_or_eof (port); (c != EOF) && (c != '\n'); c = scm_getc (port)); @@ -724,14 +815,18 @@ scm_read_boolean (int chr, SCM port) } static SCM -scm_read_character (int chr, SCM port) +scm_read_character (scm_t_wchar chr, SCM port) #define FUNC_NAME "scm_lreadr" { - unsigned c; - char charname[READER_CHAR_NAME_MAX_SIZE]; + SCM charname = scm_i_make_string (READER_CHAR_NAME_MAX_SIZE, NULL); size_t charname_len; + scm_t_wchar cp; + int overflow; - if (read_token (port, charname, sizeof (charname), &charname_len)) + overflow = read_token (port, charname, &charname_len); + charname = scm_c_substring (charname, 0, charname_len); + + if (overflow) goto char_error; if (charname_len == 0) @@ -746,29 +841,34 @@ scm_read_character (int chr, SCM port) } if (charname_len == 1) - return SCM_MAKE_CHAR (charname[0]); + return SCM_MAKE_CHAR (scm_i_string_ref (charname, 0)); - if (*charname >= '0' && *charname < '8') + cp = scm_i_string_ref (charname, 0); + if (cp >= '0' && cp < '8') { /* Dirk:FIXME:: This type of character syntax is not R5RS * compliant. Further, it should be verified that the constant * does only consist of octal digits. Finally, it should be * checked whether the resulting fixnum is in the range of * characters. */ - SCM p = scm_c_locale_stringn_to_number (charname, charname_len, 8); + SCM p = scm_string_to_number (charname, scm_from_uint (8)); if (SCM_I_INUMP (p)) 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]); + /* The names of characters should never have non-Latin1 + characters. */ + if (scm_i_is_narrow_string (charname) + || scm_i_try_narrow_string (charname)) + { SCM ch = scm_i_charname_to_char (scm_i_string_chars (charname), + charname_len); + if (scm_is_true (ch)) + return ch; + } char_error: scm_i_input_error (FUNC_NAME, port, "unknown character name ~a", - scm_list_1 (scm_from_locale_stringn (charname, - charname_len))); + scm_list_1 (charname)); return SCM_UNSPECIFIED; } @@ -810,7 +910,31 @@ scm_read_srfi4_vector (int chr, SCM port) } static SCM -scm_read_guile_bit_vector (int chr, SCM port) +scm_read_bytevector (scm_t_wchar 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 (scm_t_wchar chr, SCM port) { /* Read the `#*10101'-style read syntax for bit vectors in Guile. This is terribly inefficient but who cares? */ @@ -830,13 +954,17 @@ scm_read_guile_bit_vector (int chr, SCM port) } static inline SCM -scm_read_scsh_block_comment (int chr, SCM port) +scm_read_scsh_block_comment (scm_t_wchar chr, SCM port) { int bang_seen = 0; + /* We can use the get_byte here because there is no need to get the + locale correct when reading comments. This presumes that + hash and exclamation points always represent themselves no + matter what the source encoding is.*/ for (;;) { - int c = scm_getc (port); + int c = scm_get_byte_or_eof (port); if (c == EOF) scm_i_input_error ("skip_block_comment", port, @@ -854,19 +982,32 @@ scm_read_scsh_block_comment (int chr, SCM port) } static SCM -scm_read_extended_symbol (int chr, SCM port) +scm_read_commented_expression (scm_t_wchar chr, SCM port) +{ + scm_t_wchar 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 (scm_t_wchar chr, SCM port) { /* Guile's extended symbol read syntax looks like this: #{This is all a symbol name}# So here, CHR is expected to be `{'. */ - SCM result; int saw_brace = 0, finished = 0; size_t len = 0; - char buf[1024]; + SCM buf = scm_i_make_string (1024, NULL); - result = scm_c_make_string (0, SCM_MAKE_CHAR ('X')); + buf = scm_i_string_start_writing (buf); while ((chr = scm_getc (port)) != EOF) { @@ -880,32 +1021,30 @@ scm_read_extended_symbol (int chr, SCM port) else { saw_brace = 0; - buf[len++] = '}'; - buf[len++] = chr; + scm_i_string_set_x (buf, len++, '}'); + scm_i_string_set_x (buf, len++, chr); } } else if (chr == '}') saw_brace = 1; else - buf[len++] = chr; + scm_i_string_set_x (buf, len++, chr); - if (len >= sizeof (buf) - 2) + if (len >= scm_i_string_length (buf) - 2) { - scm_string_append (scm_list_2 (result, - scm_from_locale_stringn (buf, len))); + scm_i_string_stop_writing (); + SCM addy = scm_i_make_string (1024, NULL); + buf = scm_string_append (scm_list_2 (buf, addy)); len = 0; + buf = scm_i_string_start_writing (buf); } if (finished) break; } + scm_i_string_stop_writing (); - if (len) - result = scm_string_append (scm_list_2 - (result, - scm_from_locale_stringn (buf, len))); - - return (scm_string_to_symbol (result)); + return (scm_string_to_symbol (scm_c_substring (buf, 0, len))); } @@ -941,7 +1080,7 @@ scm_read_sharp_extension (int chr, SCM port) /* The reader for the sharp `#' character. It basically dispatches reads among the above token readers. */ static SCM -scm_read_sharp (int chr, SCM port) +scm_read_sharp (scm_t_wchar chr, SCM port) #define FUNC_NAME "scm_lreadr" { SCM result; @@ -963,6 +1102,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': @@ -991,7 +1132,7 @@ scm_read_sharp (int chr, SCM port) { /* When next char is '(', it really is an old-style uniform array. */ - int next_c = scm_getc (port); + scm_t_wchar next_c = scm_getc (port); if (next_c != EOF) scm_ungetc (next_c, port); if (next_c == '(') @@ -1014,6 +1155,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)) @@ -1033,7 +1180,7 @@ scm_read_expression (SCM port) { while (1) { - register int chr; + register scm_t_wchar chr; chr = scm_getc (port); @@ -1244,6 +1391,127 @@ scm_get_hash_procedure (int c) } } +#define SCM_ENCODING_SEARCH_SIZE (500) + +/* Search the first few hundred characters of a file for + an emacs-like coding declaration. */ +char * +scm_scan_for_encoding (SCM port) +{ + char header[SCM_ENCODING_SEARCH_SIZE+1]; + size_t bytes_read; + char *encoding = NULL; + int utf8_bom = 0; + char *pos; + int i; + int in_comment; + + bytes_read = scm_c_read (port, header, SCM_ENCODING_SEARCH_SIZE); + scm_seek (port, scm_from_int (0), scm_from_int (SEEK_SET)); + + if (bytes_read > 3 + && header[0] == '\xef' && header[1] == '\xbb' && header[2] == '\xbf') + utf8_bom = 1; + + /* search past "coding[:=]" */ + pos = header; + while (1) + { + if ((pos = strstr(pos, "coding")) == NULL) + return NULL; + + pos += strlen("coding"); + if (pos - header >= SCM_ENCODING_SEARCH_SIZE || + (*pos == ':' || *pos == '=')) + { + pos ++; + break; + } + } + + /* skip spaces */ + while (pos - header <= SCM_ENCODING_SEARCH_SIZE && + (*pos == ' ' || *pos == '\t')) + pos ++; + + /* grab the next token */ + i = 0; + while (pos + i - header <= SCM_ENCODING_SEARCH_SIZE + && (isalnum(pos[i]) || pos[i] == '_' || pos[i] == '-' || pos[i] == '.')) + i++; + + if (i == 0) + return NULL; + + encoding = scm_malloc (i+1); + memcpy (encoding, pos, i); + encoding[i] ='\0'; + for (i = 0; i < strlen (encoding); i++) + encoding[i] = toupper ((int) encoding[i]); + + /* push backwards to make sure we were in a comment */ + in_comment = 0; + while (pos - i - header > 0) + { + if (*(pos - i) == '\n') + { + /* This wasn't in a semicolon comment. Check for a + hash-bang comment. */ + char *beg = strstr (header, "#!"); + char *end = strstr (header, "!#"); + if (beg < pos && pos < end) + in_comment = 1; + break; + } + if (*(pos - i) == ';') + { + in_comment = 1; + break; + } + i ++; + } + if (!in_comment) + { + /* This wasn't in a comment */ + free (encoding); + return NULL; + } + if (utf8_bom && strcmp(encoding, "UTF-8")) + scm_misc_error (NULL, + "the port input declares the encoding ~s but is encoded as UTF-8", + scm_list_1 (scm_from_locale_string (encoding))); + + return encoding; +} + +SCM_DEFINE (scm_file_encoding, "file-encoding", 1, 0, 0, + (SCM port), + "Scans the port for an EMACS-like character coding declaration\n" + "near the top of the contents of a port with random-acessible contents.\n" + "The coding declaration is of the form\n" + "@code{coding: XXXXX} and must appear in a scheme comment.\n" + "\n" + "Returns a string containing the character encoding of the file\n" + "if a declaration was found, or @code{#f} otherwise.\n") +#define FUNC_NAME s_scm_file_encoding +{ + char *enc; + SCM s_enc; + + enc = scm_scan_for_encoding (port); + if (enc == NULL) + return SCM_BOOL_F; + else + { + s_enc = scm_from_locale_string (enc); + free (enc); + return s_enc; + } + + return SCM_BOOL_F; +} +#undef FUNC_NAME + void scm_init_read () { diff --git a/libguile/read.h b/libguile/read.h index 4253622da..7bc4a0ba4 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 */ @@ -55,6 +56,8 @@ SCM_API SCM scm_read_options (SCM setting); SCM_API SCM scm_read (SCM port); SCM_API size_t scm_read_token (int ic, SCM * tok_buf, SCM port, int weird); SCM_API SCM scm_read_hash_extend (SCM chr, SCM proc); +SCM_INTERNAL char *scm_scan_for_encoding (SCM port); +SCM_API SCM scm_file_encoding (SCM port); SCM_INTERNAL void scm_i_input_error (const char *func, SCM port, const char *message, SCM arg) 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..d9b36c574 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. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 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 */ @@ -147,32 +148,6 @@ take_signal (int signum) #endif } -typedef struct { - ssize_t res; - int fd; - char *buf; - size_t n; -} read_without_guile_data; - -static void * -do_read_without_guile (void *raw_data) -{ - read_without_guile_data *data = (read_without_guile_data *)raw_data; - data->res = read (data->fd, data->buf, data->n); - return NULL; -} - -static ssize_t -read_without_guile (int fd, char *buf, size_t n) -{ - read_without_guile_data data; - data.fd = fd; - data.buf = buf; - data.n = n; - scm_without_guile (do_read_without_guile, &data); - return data.res; -} - static SCM signal_delivery_thread (void *data) { @@ -186,7 +161,7 @@ signal_delivery_thread (void *data) while (1) { - n = read_without_guile (signal_pipe[0], &sigbyte, 1); + n = read (signal_pipe[0], &sigbyte, 1); sig = sigbyte; if (n == 1 && sig >= 0 && sig < NSIG) { @@ -305,10 +280,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 +305,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 +678,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..86bb22f47 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 */ @@ -470,35 +471,13 @@ scm_make_smob (scm_t_bits tc) SCM_RETURN_NEWSMOB (tc, data); } - -/* {Initialization for the type of free cells} - */ - -static int -free_print (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED) -{ - char buf[100]; - sprintf (buf, "#<freed cell %p; GC missed a reference>", - (void *) SCM_UNPACK (exp)); - scm_puts (buf, port); - -#if (SCM_DEBUG_CELL_ACCESSES == 1) - if (scm_debug_cell_accesses_p) - abort(); -#endif - - - return 1; -} /* Marking SMOBs using user-supplied mark procedures. */ -/* The freelist and GC kind used for SMOB types that provide a custom mark - procedure. */ -static void **smob_freelist = NULL; -static int smob_gc_kind = 0; +/* The GC kind used for SMOB types that provide a custom mark procedure. */ +static int smob_gc_kind; /* The generic SMOB mark procedure that gets called for SMOBs allocated with @@ -633,10 +612,8 @@ void scm_smob_prehistory () { long i; - scm_t_bits tc; - smob_freelist = GC_new_free_list (); - smob_gc_kind = GC_new_kind ((void **)smob_freelist, + smob_gc_kind = GC_new_kind (GC_new_free_list (), GC_MAKE_PROC (GC_new_proc (smob_mark), 0), 0, /* Clear new objects. As of version 7.1, libgc @@ -659,10 +636,6 @@ scm_smob_prehistory () scm_smobs[i].apply_3 = 0; scm_smobs[i].gsubr_type = 0; } - - /* WARNING: This scm_make_smob_type call must be done first. */ - tc = scm_make_smob_type ("free", 0); - scm_set_smob_print (tc, free_print); } /* 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 c3113e1a7..9eaccf60c 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, 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 */ @@ -345,19 +346,27 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));) }; \ static SCM_UNUSED const SCM c_name = SCM_PACK (& c_name ## _raw_cell) -#define SCM_IMMUTABLE_STRINGBUF(c_name, contents) \ - SCM_IMMUTABLE_DOUBLE_CELL (c_name, \ - scm_tc7_stringbuf | SCM_I_STRINGBUF_F_SHARED, \ - (scm_t_bits) (contents), \ - (scm_t_bits) sizeof (contents) - 1, \ - (scm_t_bits) 0) +#define SCM_IMMUTABLE_STRINGBUF(c_name, contents) \ + static SCM_UNUSED const \ + struct \ + { \ + scm_t_bits word_0; \ + scm_t_bits word_1; \ + const char buffer[sizeof (contents)]; \ + } \ + c_name = \ + { \ + scm_tc7_stringbuf | SCM_I_STRINGBUF_F_SHARED, \ + sizeof (contents) - 1, \ + contents \ + } #define SCM_IMMUTABLE_STRING(c_name, contents) \ SCM_IMMUTABLE_STRINGBUF (scm_i_paste (c_name, _stringbuf), contents); \ SCM_IMMUTABLE_DOUBLE_CELL (c_name, \ scm_tc7_ro_string, \ (scm_t_bits) &scm_i_paste (c_name, \ - _stringbuf_raw_cell), \ + _stringbuf), \ (scm_t_bits) 0, \ (scm_t_bits) sizeof (contents) - 1) diff --git a/libguile/socket.c b/libguile/socket.c index f34b6d49d..3a81ed9d0 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. +/* Copyright (C) 1996,1997,1998,2000,2001, 2002, 2003, 2004, 2005, 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 */ @@ -26,12 +27,13 @@ #include <gmp.h> #include "libguile/_scm.h" -#include "libguile/unif.h" +#include "libguile/arrays.h" #include "libguile/feature.h" #include "libguile/fports.h" #include "libguile/strings.h" #include "libguile/vectors.h" #include "libguile/dynwind.h" +#include "libguile/srfi-13.h" #include "libguile/validate.h" #include "libguile/socket.h" @@ -1413,6 +1415,8 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0, "protocols, if a packet larger than this limit is encountered\n" "then some data\n" "will be irrevocably lost.\n\n" + "The data is assumed to be binary, and there is no decoding of\n" + "of locale-encoded strings.\n\n" "The optional @var{flags} argument is a value or\n" "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n" "The value returned is the number of bytes read from the\n" @@ -1427,6 +1431,7 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0, int flg; char *dest; size_t len; + SCM msg; SCM_VALIDATE_OPFPORT (1, sock); SCM_VALIDATE_STRING (2, buf); @@ -1436,15 +1441,16 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0, flg = scm_to_int (flags); fd = SCM_FPORT_FDES (sock); - len = scm_i_string_length (buf); - dest = scm_i_string_writable_chars (buf); + len = scm_i_string_length (buf); + msg = scm_i_make_string (len, &dest); SCM_SYSCALL (rv = recv (fd, dest, len, flg)); - scm_i_string_stop_writing (); + scm_string_copy_x (buf, scm_from_int (0), + msg, scm_from_int (0), scm_from_size_t (len)); if (rv == -1) SCM_SYSERROR; - scm_remember_upto_here_1 (buf); + scm_remember_upto_here_2 (buf, msg); return scm_from_int (rv); } #undef FUNC_NAME @@ -1462,18 +1468,28 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0, "bitwise OR of MSG_OOB, MSG_PEEK, MSG_DONTROUTE etc.\n\n" "Note that the data is written directly to the socket\n" "file descriptor:\n" - "any unflushed buffered port data is ignored.") + "any unflushed buffered port data is ignored.\n\n" + "This operation is defined only for strings containing codepoints\n" + "zero to 255.") #define FUNC_NAME s_scm_send { int rv; int fd; int flg; - const char *src; + char *src; size_t len; sock = SCM_COERCE_OUTPORT (sock); SCM_VALIDATE_OPFPORT (1, sock); SCM_VALIDATE_STRING (2, message); + + /* If the string is wide, see if it can be coerced into + a narrow string. */ + if (!scm_i_is_narrow_string (message) + || scm_i_try_narrow_string (message)) + SCM_MISC_ERROR ("the message string is not 8-bit: ~s", + scm_list_1 (message)); + if (SCM_UNBNDP (flags)) flg = 0; else @@ -1481,6 +1497,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 +1566,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, @@ -1588,7 +1606,9 @@ SCM_DEFINE (scm_sendto, "sendto", 3, 1, 1, "set to be non-blocking.\n" "Note that the data is written directly to the socket\n" "file descriptor:\n" - "any unflushed buffered port data is ignored.") + "any unflushed buffered port data is ignored.\n" + "This operation is defined only for strings containing codepoints\n" + "zero to 255.") #define FUNC_NAME s_scm_sendto { int rv; 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..a9e4dda8c 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. +/* Copyright (C) 1999,2000,2001,2002, 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 */ @@ -38,8 +39,8 @@ #include "libguile/_scm.h" #include "libguile/eval.h" -#include "libguile/unif.h" -#include "libguile/ramap.h" +#include "libguile/arrays.h" +#include "libguile/array-map.h" #include "libguile/feature.h" #include "libguile/vectors.h" #include "libguile/lang.h" 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..77430bd82 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 */ @@ -68,7 +69,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint"); * car = tag * cbr = pos * ccr = copy - * cdr = plist + * cdr = alist */ #define SRCPROPSP(p) (SCM_SMOB_PREDICATE (scm_tc16_srcprops, (p))) @@ -77,7 +78,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint"); #define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12) #define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL) #define SRCPROPCOPY(p) (SCM_CELL_OBJECT(p,2)) -#define SRCPROPPLIST(p) (SCM_CELL_OBJECT_3(p)) +#define SRCPROPALIST(p) (SCM_CELL_OBJECT_3(p)) #define SETSRCPROPBRK(p) \ (SCM_SET_SMOB_FLAGS ((p), \ SCM_SMOB_FLAGS (p) | SCM_SOURCE_PROPERTY_FLAG_BREAK)) @@ -89,9 +90,11 @@ SCM_GLOBAL_SYMBOL (scm_sym_breakpoint, "breakpoint"); #define SETSRCPROPLINE(p, l) SETSRCPROPPOS (p, l, SRCPROPCOL (p)) #define SETSRCPROPCOL(p, c) SETSRCPROPPOS (p, SRCPROPLINE (p), c) #define SETSRCPROPCOPY(p, c) (SCM_SET_CELL_WORD(p, 2, c)) -#define SETSRCPROPPLIST(p, l) (SCM_SET_CELL_WORD(p, 3, l)) +#define SETSRCPROPALIST(p, l) (SCM_SET_CELL_WORD(p, 3, l)) +static SCM scm_srcprops_to_alist (SCM obj); + scm_t_bits scm_tc16_srcprops; @@ -101,7 +104,7 @@ srcprops_print (SCM obj, SCM port, scm_print_state *pstate) int writingp = SCM_WRITINGP (pstate); scm_puts ("#<srcprops ", port); SCM_SET_WRITINGP (pstate, 1); - scm_iprin1 (scm_srcprops_to_plist (obj), port, pstate); + scm_iprin1 (scm_srcprops_to_alist (obj), port, pstate); SCM_SET_WRITINGP (pstate, writingp); scm_putc ('>', port); return 1; @@ -117,57 +120,57 @@ scm_c_source_property_breakpoint_p (SCM form) /* - * We remember the last file name settings, so we can share that plist + * We remember the last file name settings, so we can share that alist * entry. This works because scm_set_source_property_x does not use - * assoc-set! for modifying the plist. + * assoc-set! for modifying the alist. * * This variable contains a protected cons, whose cdr is the cached - * plist + * alist */ -static SCM scm_last_plist_filename; +static SCM scm_last_alist_filename; SCM -scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM plist) +scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM alist) { if (!SCM_UNBNDP (filename)) { - SCM old_plist = plist; + SCM old_alist = alist; /* have to extract the acons, and operate on that, for thread safety. */ - SCM last_acons = SCM_CDR (scm_last_plist_filename); - if (old_plist == SCM_EOL + SCM last_acons = SCM_CDR (scm_last_alist_filename); + if (old_alist == SCM_EOL && SCM_CDAR (last_acons) == filename) { - plist = last_acons; + alist = last_acons; } else { - plist = scm_acons (scm_sym_filename, filename, plist); - if (old_plist == SCM_EOL) - SCM_SETCDR (scm_last_plist_filename, plist); + alist = scm_acons (scm_sym_filename, filename, alist); + if (old_alist == SCM_EOL) + SCM_SETCDR (scm_last_alist_filename, alist); } } SCM_RETURN_NEWSMOB3 (scm_tc16_srcprops, SRCPROPMAKPOS (line, col), copy, - plist); + alist); } -SCM -scm_srcprops_to_plist (SCM obj) +static SCM +scm_srcprops_to_alist (SCM obj) { - SCM plist = SRCPROPPLIST (obj); + SCM alist = SRCPROPALIST (obj); if (!SCM_UNBNDP (SRCPROPCOPY (obj))) - plist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), plist); - plist = scm_acons (scm_sym_column, scm_from_int (SRCPROPCOL (obj)), plist); - plist = scm_acons (scm_sym_line, scm_from_int (SRCPROPLINE (obj)), plist); - plist = scm_acons (scm_sym_breakpoint, scm_from_bool (SRCPROPBRK (obj)), plist); - return plist; + alist = scm_acons (scm_sym_copy, SRCPROPCOPY (obj), alist); + alist = scm_acons (scm_sym_column, scm_from_int (SRCPROPCOL (obj)), alist); + alist = scm_acons (scm_sym_line, scm_from_int (SRCPROPLINE (obj)), alist); + alist = scm_acons (scm_sym_breakpoint, scm_from_bool (SRCPROPBRK (obj)), alist); + return alist; } SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0, @@ -183,7 +186,7 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0, SCM_WRONG_TYPE_ARG (1, obj); p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); if (SRCPROPSP (p)) - return scm_srcprops_to_plist (p); + return scm_srcprops_to_alist (p); else /* list from set-source-properties!, or SCM_EOL for not found */ return p; @@ -193,20 +196,83 @@ SCM_DEFINE (scm_source_properties, "source-properties", 1, 0, 0, /* Perhaps this procedure should look through an alist and try to make a srcprops-object...? */ SCM_DEFINE (scm_set_source_properties_x, "set-source-properties!", 2, 0, 0, - (SCM obj, SCM plist), - "Install the association list @var{plist} as the source property\n" + (SCM obj, SCM alist), + "Install the association list @var{alist} as the source property\n" "list for @var{obj}.") #define FUNC_NAME s_scm_set_source_properties_x { SCM handle; + long line = 0, col = 0; + SCM fname = SCM_UNDEFINED, copy = SCM_UNDEFINED, breakpoint = SCM_BOOL_F; + SCM others = SCM_EOL; + SCM *others_cdrloc = &others; + int need_srcprops = 0; + SCM tail, key; + SCM_VALIDATE_NIM (1, obj); if (SCM_MEMOIZEDP (obj)) obj = SCM_MEMOIZED_EXP (obj); else if (!scm_is_pair (obj)) SCM_WRONG_TYPE_ARG(1, obj); - handle = scm_hashq_create_handle_x (scm_source_whash, obj, plist); - return plist; + tail = alist; + while (!scm_is_null (tail)) + { + key = SCM_CAAR (tail); + if (scm_is_eq (key, scm_sym_line)) + { + line = scm_to_long (SCM_CDAR (tail)); + need_srcprops = 1; + } + else if (scm_is_eq (key, scm_sym_column)) + { + col = scm_to_long (SCM_CDAR (tail)); + need_srcprops = 1; + } + else if (scm_is_eq (key, scm_sym_filename)) + { + fname = SCM_CDAR (tail); + need_srcprops = 1; + } + else if (scm_is_eq (key, scm_sym_copy)) + { + copy = SCM_CDAR (tail); + need_srcprops = 1; + } + else if (scm_is_eq (key, scm_sym_breakpoint)) + { + breakpoint = SCM_CDAR (tail); + need_srcprops = 1; + } + else + { + /* Do we allocate here, or clobber the caller's alist? + + Source properties aren't supposed to be used for anything + except the special properties above, so the mainline case + is that we never execute this else branch, and hence it + doesn't matter much. + + We choose allocation here, as that seems safer. + */ + *others_cdrloc = scm_cons (scm_cons (key, SCM_CDAR (tail)), + SCM_EOL); + others_cdrloc = SCM_CDRLOC (*others_cdrloc); + } + tail = SCM_CDR (tail); + } + if (need_srcprops) + { + alist = scm_make_srcprops (line, col, fname, copy, others); + if (scm_is_true (breakpoint)) + SETSRCPROPBRK (alist); + } + else + alist = others; + + handle = scm_hashq_create_handle_x (scm_source_whash, obj, alist); + SCM_SETCDR (handle, alist); + return alist; } #undef FUNC_NAME @@ -224,15 +290,15 @@ SCM_DEFINE (scm_source_property, "source-property", 2, 0, 0, SCM_WRONG_TYPE_ARG (1, obj); p = scm_hashq_ref (scm_source_whash, obj, SCM_EOL); if (!SRCPROPSP (p)) - goto plist; + goto alist; if (scm_is_eq (scm_sym_breakpoint, key)) p = scm_from_bool (SRCPROPBRK (p)); else if (scm_is_eq (scm_sym_line, key)) p = scm_from_int (SRCPROPLINE (p)); else if (scm_is_eq (scm_sym_column, key)) p = scm_from_int (SRCPROPCOL (p)); else if (scm_is_eq (scm_sym_copy, key)) p = SRCPROPCOPY (p); else { - p = SRCPROPPLIST (p); - plist: + p = SRCPROPALIST (p); + alist: p = scm_assoc (key, p); return (SCM_NIMP (p) ? SCM_CDR (p) : SCM_BOOL_F); } @@ -308,7 +374,7 @@ SCM_DEFINE (scm_set_source_property_x, "set-source-property!", 3, 0, 0, else { if (SRCPROPSP (p)) - SETSRCPROPPLIST (p, scm_acons (key, datum, SRCPROPPLIST (p))); + SETSRCPROPALIST (p, scm_acons (key, datum, SRCPROPALIST (p))); else SCM_WHASHSET (scm_source_whash, h, scm_acons (key, datum, p)); } @@ -326,7 +392,7 @@ scm_init_srcprop () scm_source_whash = scm_make_weak_key_hash_table (scm_from_int (2047)); scm_c_define ("source-whash", scm_source_whash); - scm_last_plist_filename + scm_last_alist_filename = scm_permanent_object (scm_cons (SCM_EOL, scm_acons (SCM_EOL, SCM_EOL, SCM_EOL))); diff --git a/libguile/srcprop.h b/libguile/srcprop.h index a467aa34e..89063bed4 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 */ @@ -63,13 +64,11 @@ SCM_API SCM scm_sym_breakpoint; SCM_API int scm_c_source_property_breakpoint_p (SCM form); -SCM_API SCM scm_srcprops_to_plist (SCM obj); SCM_API SCM scm_make_srcprops (long line, int col, SCM fname, SCM copy, SCM plist); SCM_API SCM scm_source_property (SCM obj, SCM key); SCM_API SCM scm_set_source_property_x (SCM obj, SCM key, SCM datum); SCM_API SCM scm_source_properties (SCM obj); SCM_API SCM scm_set_source_properties_x (SCM obj, SCM props); -SCM_API void scm_finish_srcprop (void); SCM_INTERNAL void scm_init_srcprop (void); #if SCM_ENABLE_DEPRECATED == 1 diff --git a/libguile/srfi-13.c b/libguile/srfi-13.c index c8ca78027..4faa377d0 100644 --- a/libguile/srfi-13.c +++ b/libguile/srfi-13.c @@ -1,20 +1,21 @@ /* srfi-13.c --- SRFI-13 procedures for Guile * - * Copyright (C) 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc. + * Copyright (C) 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 */ @@ -23,41 +24,14 @@ #endif #include <string.h> -#include <ctype.h> +#include <unicase.h> +#include <unictype.h> #include "libguile.h" #include "libguile/srfi-13.h" #include "libguile/srfi-14.h" -/* SCM_VALIDATE_SUBSTRING_SPEC_COPY is deprecated since it encourages - messing with the internal representation of strings. We define our - own version since we use it so much and are messing with Guile - internals anyway. -*/ - -#define MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, c_str, \ - pos_start, start, c_start, \ - pos_end, end, c_end) \ - do { \ - SCM_VALIDATE_STRING (pos_str, str); \ - c_str = scm_i_string_chars (str); \ - scm_i_get_substring_spec (scm_i_string_length (str), \ - start, &c_start, end, &c_end); \ - } while (0) - -/* Expecting "unsigned char *c_str" */ -#define MY_VALIDATE_SUBSTRING_SPEC_UCOPY(pos_str, str, c_str, \ - pos_start, start, c_start, \ - pos_end, end, c_end) \ - do { \ - const char *signed_c_str; \ - MY_VALIDATE_SUBSTRING_SPEC_COPY(pos_str, str, signed_c_str, \ - pos_start, start, c_start, \ - pos_end, end, c_end); \ - c_str = (unsigned char *) signed_c_str; \ - } while (0) - #define MY_VALIDATE_SUBSTRING_SPEC(pos_str, str, \ pos_start, start, c_start, \ pos_end, end, c_end) \ @@ -67,6 +41,18 @@ start, &c_start, end, &c_end); \ } while (0) +#define MY_SUBF_VALIDATE_SUBSTRING_SPEC(fname, pos_str, str, \ + pos_start, start, c_start, \ + pos_end, end, c_end) \ + do { \ + SCM_ASSERT_TYPE (scm_is_string (str), str, pos_str, fname, "string"); \ + scm_i_get_substring_spec (scm_i_string_length (str), \ + start, &c_start, end, &c_end); \ + } while (0) + +#define REF_IN_CHARSET(s, i, cs) \ + (scm_is_true (scm_char_set_contains_p ((cs), SCM_MAKE_CHAR (scm_i_string_ref (s, i))))) + SCM_DEFINE (scm_string_null_p, "string-null?", 1, 0, 0, (SCM str), "Return @code{#t} if @var{str}'s length is zero, and\n" @@ -110,25 +96,28 @@ SCM_DEFINE (scm_string_any, "string-any-c-code", 2, 2, 0, "@var{end}) then the return is @code{#f}.\n") #define FUNC_NAME s_scm_string_any { - const char *cstr; size_t cstart, cend; SCM res = SCM_BOOL_F; - 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); if (SCM_CHARP (char_pred)) { - res = (memchr (cstr+cstart, (int) SCM_CHAR (char_pred), - cend-cstart) == NULL - ? SCM_BOOL_F : SCM_BOOL_T); + size_t i; + for (i = cstart; i < cend; i ++) + if (scm_i_string_ref (s, i) == SCM_CHAR (char_pred)) + { + res = SCM_BOOL_T; + break; + } } else if (SCM_CHARSETP (char_pred)) { size_t i; for (i = cstart; i < cend; i++) - if (SCM_CHARSET_GET (char_pred, cstr[i])) + if (REF_IN_CHARSET (s, i, char_pred)) { res = SCM_BOOL_T; break; @@ -141,10 +130,10 @@ SCM_DEFINE (scm_string_any, "string-any-c-code", 2, 2, 0, while (cstart < cend) { - res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart])); + res = pred_tramp (char_pred, + SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); if (scm_is_true (res)) break; - cstr = scm_i_string_chars (s); cstart++; } } @@ -175,19 +164,17 @@ SCM_DEFINE (scm_string_every, "string-every-c-code", 2, 2, 0, "@var{end}) then the return is @code{#t}.\n") #define FUNC_NAME s_scm_string_every { - const char *cstr; size_t cstart, cend; SCM res = SCM_BOOL_T; - 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); if (SCM_CHARP (char_pred)) { - char cchr = SCM_CHAR (char_pred); size_t i; for (i = cstart; i < cend; i++) - if (cstr[i] != cchr) + if (scm_i_string_ref (s, i) != SCM_CHAR (char_pred)) { res = SCM_BOOL_F; break; @@ -197,7 +184,7 @@ SCM_DEFINE (scm_string_every, "string-every-c-code", 2, 2, 0, { size_t i; for (i = cstart; i < cend; i++) - if (!SCM_CHARSET_GET (char_pred, cstr[i])) + if (!REF_IN_CHARSET (s, i, char_pred)) { res = SCM_BOOL_F; break; @@ -210,10 +197,10 @@ SCM_DEFINE (scm_string_every, "string-every-c-code", 2, 2, 0, while (cstart < cend) { - res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart])); + res = pred_tramp (char_pred, + SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); if (scm_is_false (res)) break; - cstr = scm_i_string_chars (s); cstart++; } } @@ -235,28 +222,49 @@ SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0, size_t clen, i; SCM res; SCM ch; - char *p; scm_t_trampoline_1 proc_tramp; proc_tramp = scm_trampoline_1 (proc); SCM_ASSERT (proc_tramp, proc, SCM_ARG1, FUNC_NAME); + SCM_ASSERT_RANGE (2, len, scm_to_int (len) >= 0); clen = scm_to_size_t (len); - SCM_ASSERT_RANGE (2, len, clen >= 0); - res = scm_i_make_string (clen, &p); - i = 0; - while (i < clen) - { - /* The RES string remains untouched since nobody knows about it - yet. No need to refetch P. - */ - ch = proc_tramp (proc, scm_from_size_t (i)); - if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); - *p++ = SCM_CHAR (ch); - i++; - } + { + /* This function is more complicated than necessary for the sake + of speed. */ + scm_t_wchar *buf = scm_malloc (clen * sizeof (scm_t_wchar)); + int wide = 0; + i = 0; + while (i < clen) + { + ch = proc_tramp (proc, scm_from_size_t (i)); + if (!SCM_CHARP (ch)) + { + SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); + } + if (SCM_CHAR (ch) > 255) + wide = 1; + buf[i] = SCM_CHAR (ch); + i++; + } + if (wide) + { + scm_t_wchar *wbuf = NULL; + res = scm_i_make_wide_string (clen, &wbuf); + memcpy (wbuf, buf, clen * sizeof (scm_t_wchar)); + free (buf); + } + else + { + char *nbuf = NULL; + res = scm_i_make_string (clen, &nbuf); + for (i = 0; i < clen; i ++) + nbuf[i] = (unsigned char) buf[i]; + free (buf); + } + } + return res; } #undef FUNC_NAME @@ -267,18 +275,34 @@ SCM_DEFINE (scm_substring_to_list, "string->list", 1, 2, 0, "Convert the string @var{str} into a list of characters.") #define FUNC_NAME s_scm_substring_to_list { - const char *cstr; size_t cstart, cend; + int narrow; SCM result = SCM_EOL; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); - while (cstart < cend) + MY_VALIDATE_SUBSTRING_SPEC (1, str, + 2, start, cstart, + 3, end, cend); + + /* This explicit narrow/wide logic (instead of just using + scm_i_string_ref) is for speed optimizaion. */ + narrow = scm_i_is_narrow_string (str); + if (narrow) { - cend--; - result = scm_cons (SCM_MAKE_CHAR (cstr[cend]), result); - cstr = scm_i_string_chars (str); + const char *buf = scm_i_string_chars (str); + while (cstart < cend) + { + cend--; + result = scm_cons (SCM_MAKE_CHAR (buf[cend]), result); + } + } + else + { + const scm_t_wchar *buf = scm_i_string_wide_chars (str); + while (cstart < cend) + { + cend--; + result = scm_cons (SCM_MAKE_CHAR (buf[cend]), result); + } } scm_remember_upto_here_1 (str); return result; @@ -307,7 +331,7 @@ SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0, #define FUNC_NAME s_scm_reverse_list_to_string { SCM result; - long i = scm_ilength (chrs); + long i = scm_ilength (chrs), j; char *data; if (i < 0) @@ -315,18 +339,27 @@ SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0, result = scm_i_make_string (i, &data); { - - data += i; - while (i > 0 && scm_is_pair (chrs)) + SCM rest; + rest = chrs; + j = 0; + while (j < i && scm_is_pair (rest)) { - SCM elt = SCM_CAR (chrs); - - SCM_VALIDATE_CHAR (SCM_ARGn, elt); - data--; - *data = SCM_CHAR (elt); - chrs = SCM_CDR (chrs); - i--; + SCM elt = SCM_CAR (rest); + SCM_VALIDATE_CHAR (SCM_ARGn, elt); + j++; + rest = SCM_CDR (rest); + } + rest = chrs; + j = i; + result = scm_i_string_start_writing (result); + while (j > 0 && scm_is_pair (rest)) + { + SCM elt = SCM_CAR (rest); + scm_i_string_set_x (result, j-1, SCM_CHAR (elt)); + rest = SCM_CDR (rest); + j--; } + scm_i_string_stop_writing (); } return result; @@ -339,18 +372,6 @@ SCM_SYMBOL (scm_sym_strict_infix, "strict-infix"); SCM_SYMBOL (scm_sym_suffix, "suffix"); SCM_SYMBOL (scm_sym_prefix, "prefix"); -static void -append_string (char **sp, size_t *lp, SCM str) -{ - size_t len; - len = scm_c_string_length (str); - if (len > *lp) - len = *lp; - memcpy (*sp, scm_i_string_chars (str), len); - *lp -= len; - *sp += len; -} - SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, (SCM ls, SCM delimiter, SCM grammar), "Append the string in the string list @var{ls}, using the string\n" @@ -381,8 +402,6 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, SCM result; int gram = GRAM_INFIX; size_t del_len = 0; - size_t len = 0; - char *p; long strings = scm_ilength (ls); /* Validate the string list. */ @@ -396,7 +415,10 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, del_len = 1; } else - del_len = scm_c_string_length (delimiter); + { + SCM_VALIDATE_STRING (2, delimiter); + del_len = scm_i_string_length (delimiter); + } /* Validate the grammar symbol and remember the grammar. */ if (SCM_UNBNDP (grammar)) @@ -412,33 +434,12 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, else SCM_WRONG_TYPE_ARG (3, grammar); - /* Check grammar constraints and calculate the space required for - the delimiter(s). */ - switch (gram) - { - case GRAM_INFIX: - if (!scm_is_null (ls)) - len = (strings > 0) ? ((strings - 1) * del_len) : 0; - break; - case GRAM_STRICT_INFIX: - if (strings == 0) - SCM_MISC_ERROR ("strict-infix grammar requires non-empty list", - SCM_EOL); - len = (strings - 1) * del_len; - break; - default: - len = strings * del_len; - break; - } - - tmp = ls; - while (scm_is_pair (tmp)) - { - len += scm_c_string_length (SCM_CAR (tmp)); - tmp = SCM_CDR (tmp); - } + /* Check grammar constraints. */ + if (strings == 0 && gram == GRAM_STRICT_INFIX) + SCM_MISC_ERROR ("strict-infix grammar requires non-empty list", + SCM_EOL); - result = scm_i_make_string (len, &p); + result = scm_i_make_string (0, NULL); tmp = ls; switch (gram) @@ -447,18 +448,18 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, case GRAM_STRICT_INFIX: while (scm_is_pair (tmp)) { - append_string (&p, &len, SCM_CAR (tmp)); + result = scm_string_append (scm_list_2 (result, SCM_CAR (tmp))); if (!scm_is_null (SCM_CDR (tmp)) && del_len > 0) - append_string (&p, &len, delimiter); + result = scm_string_append (scm_list_2 (result, delimiter)); tmp = SCM_CDR (tmp); } break; case GRAM_SUFFIX: while (scm_is_pair (tmp)) { - append_string (&p, &len, SCM_CAR (tmp)); + result = scm_string_append (scm_list_2 (result, SCM_CAR (tmp))); if (del_len > 0) - append_string (&p, &len, delimiter); + result = scm_string_append (scm_list_2 (result, delimiter)); tmp = SCM_CDR (tmp); } break; @@ -466,8 +467,8 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0, while (scm_is_pair (tmp)) { if (del_len > 0) - append_string (&p, &len, delimiter); - append_string (&p, &len, SCM_CAR (tmp)); + result = scm_string_append (scm_list_2 (result, delimiter)); + result = scm_string_append (scm_list_2 (result, SCM_CAR (tmp))); tmp = SCM_CDR (tmp); } break; @@ -507,20 +508,22 @@ SCM_DEFINE (scm_srfi13_substring_copy, "string-copy", 1, 2, 0, "@var{str} which is copied.") #define FUNC_NAME s_scm_srfi13_substring_copy { - const char *cstr; size_t cstart, cend; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); - return scm_c_substring_copy (str, cstart, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, str, + 2, start, cstart, + 3, end, cend); + return scm_i_substring_copy (str, cstart, cend); } #undef FUNC_NAME SCM scm_string_copy (SCM str) { - return scm_c_substring (str, 0, scm_c_string_length (str)); + if (!scm_is_string (str)) + scm_wrong_type_arg ("scm_string_copy", 0, str); + + return scm_i_substring (str, 0, scm_i_string_length (str)); } SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0, @@ -534,22 +537,24 @@ SCM_DEFINE (scm_string_copy_x, "string-copy!", 3, 2, 0, "string.") #define FUNC_NAME s_scm_string_copy_x { - const char *cstr; - char *ctarget; - size_t cstart, cend, ctstart, dummy, len; + size_t cstart, cend, ctstart, dummy, len, i; SCM sdummy = SCM_UNDEFINED; MY_VALIDATE_SUBSTRING_SPEC (1, target, 2, tstart, ctstart, 2, sdummy, dummy); - MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, - 4, start, cstart, - 5, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (3, s, + 4, start, cstart, + 5, end, cend); len = cend - cstart; SCM_ASSERT_RANGE (3, s, len <= scm_i_string_length (target) - ctstart); - ctarget = scm_i_string_writable_chars (target); - memmove (ctarget + ctstart, cstr + cstart, len); + target = scm_i_string_start_writing (target); + for (i = 0; i < cend - cstart; i++) + { + scm_i_string_set_x (target, ctstart + i, + scm_i_string_ref (s, cstart + i)); + } scm_i_string_stop_writing (); scm_remember_upto_here_1 (target); @@ -620,7 +625,6 @@ SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0, "string is longer than @var{len}, it is truncated on the right.") #define FUNC_NAME s_scm_string_pad { - char cchr; size_t cstart, cend, clen; MY_VALIDATE_SUBSTRING_SPEC (1, s, @@ -629,23 +633,19 @@ SCM_DEFINE (scm_string_pad, "string-pad", 2, 3, 0, clen = scm_to_size_t (len); if (SCM_UNBNDP (chr)) - cchr = ' '; + chr = SCM_MAKE_CHAR (' '); else { SCM_VALIDATE_CHAR (3, chr); - cchr = SCM_CHAR (chr); } if (clen < (cend - cstart)) - return scm_c_substring (s, cend - clen, cend); + return scm_i_substring (s, cend - clen, cend); else { SCM result; - char *dst; - - result = scm_i_make_string (clen, &dst); - memset (dst, cchr, (clen - (cend - cstart))); - memmove (dst + clen - (cend - cstart), - scm_i_string_chars (s) + cstart, cend - cstart); + result = (scm_string_append + (scm_list_2 (scm_c_make_string (clen - (cend - cstart), chr), + scm_i_substring (s, cstart, cend)))); return result; } } @@ -660,7 +660,6 @@ SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0, "string is longer than @var{len}, it is truncated on the left.") #define FUNC_NAME s_scm_string_pad_right { - char cchr; size_t cstart, cend, clen; MY_VALIDATE_SUBSTRING_SPEC (1, s, @@ -669,22 +668,21 @@ SCM_DEFINE (scm_string_pad_right, "string-pad-right", 2, 3, 0, clen = scm_to_size_t (len); if (SCM_UNBNDP (chr)) - cchr = ' '; + chr = SCM_MAKE_CHAR (' '); else { SCM_VALIDATE_CHAR (3, chr); - cchr = SCM_CHAR (chr); } if (clen < (cend - cstart)) - return scm_c_substring (s, cstart, cstart + clen); + return scm_i_substring (s, cstart, cstart + clen); else { SCM result; - char *dst; - result = scm_i_make_string (clen, &dst); - memset (dst + (cend - cstart), cchr, clen - (cend - cstart)); - memmove (dst, scm_i_string_chars (s) + cstart, cend - cstart); + result = (scm_string_append + (scm_list_2 (scm_i_substring (s, cstart, cend), + scm_c_make_string (clen - (cend - cstart), chr)))); + return result; } } @@ -713,27 +711,25 @@ SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0, "trimmed.") #define FUNC_NAME s_scm_string_trim { - const char *cstr; size_t cstart, cend; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, s, + 3, start, cstart, + 4, end, cend); if (SCM_UNBNDP (char_pred)) { while (cstart < cend) { - if (!isspace((int) (unsigned char) cstr[cstart])) + if (!uc_is_c_whitespace (scm_i_string_ref (s, cstart))) break; cstart++; } } else if (SCM_CHARP (char_pred)) { - char chr = SCM_CHAR (char_pred); while (cstart < cend) { - if (chr != cstr[cstart]) + if (scm_i_string_ref (s, cstart) != SCM_CHAR (char_pred)) break; cstart++; } @@ -742,7 +738,7 @@ SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0, { while (cstart < cend) { - if (!SCM_CHARSET_GET (char_pred, cstr[cstart])) + if (!REF_IN_CHARSET (s, cstart, char_pred)) break; cstart++; } @@ -756,21 +752,20 @@ SCM_DEFINE (scm_string_trim, "string-trim", 1, 3, 0, { SCM res; - res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart])); + res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); if (scm_is_false (res)) break; - cstr = scm_i_string_chars (s); cstart++; } } - return scm_c_substring (s, cstart, cend); + return scm_i_substring (s, cstart, cend); } #undef FUNC_NAME SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0, (SCM s, SCM char_pred, SCM start, SCM end), - "Trim @var{s} by skipping over all characters on the rightt\n" + "Trim @var{s} by skipping over all characters on the right\n" "that satisfy the parameter @var{char_pred}:\n" "\n" "@itemize @bullet\n" @@ -791,27 +786,25 @@ SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0, "trimmed.") #define FUNC_NAME s_scm_string_trim_right { - const char *cstr; size_t cstart, cend; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, s, + 3, start, cstart, + 4, end, cend); if (SCM_UNBNDP (char_pred)) { while (cstart < cend) { - if (!isspace((int) (unsigned char) cstr[cend - 1])) + if (!uc_is_c_whitespace (scm_i_string_ref (s, cend - 1))) break; cend--; } } else if (SCM_CHARP (char_pred)) { - char chr = SCM_CHAR (char_pred); while (cstart < cend) { - if (chr != cstr[cend - 1]) + if (scm_i_string_ref (s, cend - 1) != SCM_CHAR (char_pred)) break; cend--; } @@ -820,7 +813,7 @@ SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0, { while (cstart < cend) { - if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1])) + if (!REF_IN_CHARSET (s, cend-1, char_pred)) break; cend--; } @@ -834,14 +827,13 @@ SCM_DEFINE (scm_string_trim_right, "string-trim-right", 1, 3, 0, { SCM res; - res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend - 1])); + res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1))); if (scm_is_false (res)) break; - cstr = scm_i_string_chars (s); cend--; } } - return scm_c_substring (s, cstart, cend); + return scm_i_substring (s, cstart, cend); } #undef FUNC_NAME @@ -869,39 +861,37 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0, "trimmed.") #define FUNC_NAME s_scm_string_trim_both { - const char *cstr; size_t cstart, cend; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, s, + 3, start, cstart, + 4, end, cend); if (SCM_UNBNDP (char_pred)) { while (cstart < cend) { - if (!isspace((int) (unsigned char) cstr[cstart])) + if (!uc_is_c_whitespace (scm_i_string_ref (s, cstart))) break; cstart++; } while (cstart < cend) { - if (!isspace((int) (unsigned char) cstr[cend - 1])) + if (!uc_is_c_whitespace (scm_i_string_ref (s, cend - 1))) break; cend--; } } else if (SCM_CHARP (char_pred)) { - char chr = SCM_CHAR (char_pred); while (cstart < cend) { - if (chr != cstr[cstart]) + if (scm_i_string_ref (s, cstart) != SCM_CHAR(char_pred)) break; cstart++; } while (cstart < cend) { - if (chr != cstr[cend - 1]) + if (scm_i_string_ref (s, cend - 1) != SCM_CHAR (char_pred)) break; cend--; } @@ -910,13 +900,13 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0, { while (cstart < cend) { - if (!SCM_CHARSET_GET (char_pred, cstr[cstart])) + if (!REF_IN_CHARSET (s, cstart, char_pred)) break; cstart++; } while (cstart < cend) { - if (!SCM_CHARSET_GET (char_pred, cstr[cend - 1])) + if (!REF_IN_CHARSET (s, cend-1, char_pred)) break; cend--; } @@ -930,24 +920,22 @@ SCM_DEFINE (scm_string_trim_both, "string-trim-both", 1, 3, 0, { SCM res; - res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart])); + res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); if (scm_is_false (res)) break; - cstr = scm_i_string_chars (s); cstart++; } while (cstart < cend) { SCM res; - res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend - 1])); + res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend - 1))); if (scm_is_false (res)) break; - cstr = scm_i_string_chars (s); cend--; } } - return scm_c_substring (s, cstart, cend); + return scm_i_substring (s, cstart, cend); } #undef FUNC_NAME @@ -958,9 +946,7 @@ SCM_DEFINE (scm_substring_fill_x, "string-fill!", 2, 2, 0, "returns an unspecified value.") #define FUNC_NAME s_scm_substring_fill_x { - char *cstr; size_t cstart, cend; - int c; size_t k; /* Older versions of Guile provided the function @@ -982,13 +968,13 @@ SCM_DEFINE (scm_substring_fill_x, "string-fill!", 2, 2, 0, MY_VALIDATE_SUBSTRING_SPEC (1, str, 3, start, cstart, 4, end, cend); - SCM_VALIDATE_CHAR_COPY (2, chr, c); + SCM_VALIDATE_CHAR (2, chr); + - cstr = scm_i_string_writable_chars (str); + str = scm_i_string_start_writing (str); for (k = cstart; k < cend; k++) - cstr[k] = c; + scm_i_string_set_x (str, k, SCM_CHAR (chr)); scm_i_string_stop_writing (); - scm_remember_upto_here_1 (str); return SCM_UNSPECIFIED; } @@ -1010,28 +996,29 @@ SCM_DEFINE (scm_string_compare, "string-compare", 5, 4, 0, "@var{i} is the first position that does not match.") #define FUNC_NAME s_scm_string_compare { - const unsigned char *cstr1, *cstr2; size_t cstart1, cend1, cstart2, cend2; SCM proc; - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1, - 6, start1, cstart1, - 7, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2, - 8, start2, cstart2, - 9, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC (1, s1, + 6, start1, cstart1, + 7, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC (2, s2, + 8, start2, cstart2, + 9, end2, cend2); SCM_VALIDATE_PROC (3, proc_lt); SCM_VALIDATE_PROC (4, proc_eq); SCM_VALIDATE_PROC (5, proc_gt); while (cstart1 < cend1 && cstart2 < cend2) { - if (cstr1[cstart1] < cstr2[cstart2]) + if (scm_i_string_ref (s1, cstart1) + < scm_i_string_ref (s2, cstart2)) { proc = proc_lt; goto ret; } - else if (cstr1[cstart1] > cstr2[cstart2]) + else if (scm_i_string_ref (s1, cstart1) + > scm_i_string_ref (s2, cstart2)) { proc = proc_gt; goto ret; @@ -1060,33 +1047,33 @@ SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0, "equal to, or greater than @var{s2}. The mismatch index is the\n" "largest index @var{i} such that for every 0 <= @var{j} <\n" "@var{i}, @var{s1}[@var{j}] = @var{s2}[@var{j}] -- that is,\n" - "@var{i} is the first position that does not match. The\n" - "character comparison is done case-insensitively.") + "@var{i} is the first position where the lowercased letters \n" + "do not match.\n") #define FUNC_NAME s_scm_string_compare_ci { - const unsigned char *cstr1, *cstr2; size_t cstart1, cend1, cstart2, cend2; SCM proc; - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1, - 6, start1, cstart1, - 7, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2, - 8, start2, cstart2, - 9, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC (1, s1, + 6, start1, cstart1, + 7, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC (2, s2, + 8, start2, cstart2, + 9, end2, cend2); SCM_VALIDATE_PROC (3, proc_lt); SCM_VALIDATE_PROC (4, proc_eq); SCM_VALIDATE_PROC (5, proc_gt); while (cstart1 < cend1 && cstart2 < cend2) { - if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) + if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1))) + < uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2)))) { proc = proc_lt; goto ret; } - else if (scm_c_downcase (cstr1[cstart1]) - > scm_c_downcase (cstr2[cstart2])) + else if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1))) + > uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2)))) { proc = proc_gt; goto ret; @@ -1108,42 +1095,83 @@ SCM_DEFINE (scm_string_compare_ci, "string-compare-ci", 5, 4, 0, } #undef FUNC_NAME - -SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0, - (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), - "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n" - "value otherwise.") -#define FUNC_NAME s_scm_string_eq +/* This function compares two substrings, S1 from START1 to END1 and + S2 from START2 to END2, possibly case insensitively, and returns + one of the parameters LESSTHAN, GREATERTHAN, LONGER, SHORTER, or + EQUAL depending if S1 is less than S2, greater than S2, longer, + shorter, or equal. */ +static SCM +compare_strings (const char *fname, int case_insensitive, + SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2, + SCM lessthan, SCM greaterthan, SCM longer, SCM shorter, SCM equal) { - const char *cstr1, *cstr2; size_t cstart1, cend1, cstart2, cend2; + SCM ret; + scm_t_wchar a, b; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, + MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname, 1, s1, 3, start1, cstart1, 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, + MY_SUBF_VALIDATE_SUBSTRING_SPEC (fname, 2, s2, 5, start2, cstart2, 6, end2, cend2); - if ((cend1 - cstart1) != (cend2 - cstart2)) - goto false; - - while (cstart1 < cend1) + while (cstart1 < cend1 && cstart2 < cend2) { - if (cstr1[cstart1] < cstr2[cstart2]) - goto false; - else if (cstr1[cstart1] > cstr2[cstart2]) - goto false; + if (case_insensitive) + { + a = uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1))); + b = uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2))); + } + else + { + a = scm_i_string_ref (s1, cstart1); + b = scm_i_string_ref (s2, cstart2); + } + if (a < b) + { + ret = lessthan; + goto done; + } + else if (a > b) + { + ret = greaterthan; + goto done; + } cstart1++; cstart2++; } - - scm_remember_upto_here_2 (s1, s2); - return scm_from_size_t (cstart1); + if (cstart1 < cend1) + { + ret = longer; + goto done; + } + else if (cstart2 < cend2) + { + ret = shorter; + goto done; + } + else + { + ret = equal; + goto done; + } - false: + done: scm_remember_upto_here_2 (s1, s2); - return SCM_BOOL_F; + return ret; +} + + +SCM_DEFINE (scm_string_eq, "string=", 2, 4, 0, + (SCM s1, SCM s2, SCM start1, SCM end1, SCM start2, SCM end2), + "Return @code{#f} if @var{s1} and @var{s2} are not equal, a true\n" + "value otherwise.") +#define FUNC_NAME s_scm_string_eq +{ + return compare_strings (FUNC_NAME, 0, + s1, s2, start1, end1, start2, end2, + SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_T); } #undef FUNC_NAME @@ -1154,39 +1182,9 @@ SCM_DEFINE (scm_string_neq, "string<>", 2, 4, 0, "value otherwise.") #define FUNC_NAME s_scm_string_neq { - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (cstr1[cstart1] < cstr2[cstart2]) - goto true; - else if (cstr1[cstart1] > cstr2[cstart2]) - goto true; - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - goto true; - else if (cstart2 < cend2) - goto true; - else - goto false; - - true: - scm_remember_upto_here_2 (s1, s2); - return scm_from_size_t (cstart1); - - false: - scm_remember_upto_here_2 (s1, s2); - return SCM_BOOL_F; + return compare_strings (FUNC_NAME, 0, + s1, s2, start1, end1, start2, end2, + SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_F); } #undef FUNC_NAME @@ -1197,39 +1195,9 @@ SCM_DEFINE (scm_string_lt, "string<", 2, 4, 0, "true value otherwise.") #define FUNC_NAME s_scm_string_lt { - const unsigned char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (cstr1[cstart1] < cstr2[cstart2]) - goto true; - else if (cstr1[cstart1] > cstr2[cstart2]) - goto false; - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - goto false; - else if (cstart2 < cend2) - goto true; - else - goto false; - - true: - scm_remember_upto_here_2 (s1, s2); - return scm_from_size_t (cstart1); - - false: - scm_remember_upto_here_2 (s1, s2); - return SCM_BOOL_F; + return compare_strings (FUNC_NAME, 0, + s1, s2, start1, end1, start2, end2, + SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_F); } #undef FUNC_NAME @@ -1240,39 +1208,9 @@ SCM_DEFINE (scm_string_gt, "string>", 2, 4, 0, "true value otherwise.") #define FUNC_NAME s_scm_string_gt { - const unsigned char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (cstr1[cstart1] < cstr2[cstart2]) - goto false; - else if (cstr1[cstart1] > cstr2[cstart2]) - goto true; - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - goto true; - else if (cstart2 < cend2) - goto false; - else - goto false; - - true: - scm_remember_upto_here_2 (s1, s2); - return scm_from_size_t (cstart1); - - false: - scm_remember_upto_here_2 (s1, s2); - return SCM_BOOL_F; + return compare_strings (FUNC_NAME, 0, + s1, s2, start1, end1, start2, end2, + SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F); } #undef FUNC_NAME @@ -1283,39 +1221,9 @@ SCM_DEFINE (scm_string_le, "string<=", 2, 4, 0, "value otherwise.") #define FUNC_NAME s_scm_string_le { - const unsigned char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (cstr1[cstart1] < cstr2[cstart2]) - goto true; - else if (cstr1[cstart1] > cstr2[cstart2]) - goto false; - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - goto false; - else if (cstart2 < cend2) - goto true; - else - goto true; - - true: - scm_remember_upto_here_2 (s1, s2); - return scm_from_size_t (cstart1); - - false: - scm_remember_upto_here_2 (s1, s2); - return SCM_BOOL_F; + return compare_strings (FUNC_NAME, 0, + s1, s2, start1, end1, start2, end2, + SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T); } #undef FUNC_NAME @@ -1326,39 +1234,9 @@ SCM_DEFINE (scm_string_ge, "string>=", 2, 4, 0, "otherwise.") #define FUNC_NAME s_scm_string_ge { - const unsigned char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (cstr1[cstart1] < cstr2[cstart2]) - goto false; - else if (cstr1[cstart1] > cstr2[cstart2]) - goto true; - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - goto true; - else if (cstart2 < cend2) - goto false; - else - goto true; - - true: - scm_remember_upto_here_2 (s1, s2); - return scm_from_size_t (cstart1); - - false: - scm_remember_upto_here_2 (s1, s2); - return SCM_BOOL_F; + return compare_strings (FUNC_NAME, 0, + s1, s2, start1, end1, start2, end2, + SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_T); } #undef FUNC_NAME @@ -1370,39 +1248,9 @@ SCM_DEFINE (scm_string_ci_eq, "string-ci=", 2, 4, 0, "case-insensitively.") #define FUNC_NAME s_scm_string_ci_eq { - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - goto false; - else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - goto false; - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - goto false; - else if (cstart2 < cend2) - goto false; - else - goto true; - - true: - scm_remember_upto_here_2 (s1, s2); - return scm_from_size_t (cstart1); - - false: - scm_remember_upto_here_2 (s1, s2); - return SCM_BOOL_F; + return compare_strings (FUNC_NAME, 1, + s1, s2, start1, end1, start2, end2, + SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_F, SCM_BOOL_T); } #undef FUNC_NAME @@ -1414,39 +1262,9 @@ SCM_DEFINE (scm_string_ci_neq, "string-ci<>", 2, 4, 0, "case-insensitively.") #define FUNC_NAME s_scm_string_ci_neq { - const char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - goto true; - else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - goto true; - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - goto true; - else if (cstart2 < cend2) - goto true; - else - goto false; - - true: - scm_remember_upto_here_2 (s1, s2); - return scm_from_size_t (cstart1); - - false: - scm_remember_upto_here_2 (s1, s2); - return SCM_BOOL_F; + return compare_strings (FUNC_NAME, 1, + s1, s2, start1, end1, start2, end2, + SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_T, SCM_BOOL_F); } #undef FUNC_NAME @@ -1458,39 +1276,9 @@ SCM_DEFINE (scm_string_ci_lt, "string-ci<", 2, 4, 0, "case-insensitively.") #define FUNC_NAME s_scm_string_ci_lt { - const unsigned char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - goto true; - else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - goto false; - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - goto false; - else if (cstart2 < cend2) - goto true; - else - goto false; - - true: - scm_remember_upto_here_2 (s1, s2); - return scm_from_size_t (cstart1); - - false: - scm_remember_upto_here_2 (s1, s2); - return SCM_BOOL_F; + return compare_strings (FUNC_NAME, 1, + s1, s2, start1, end1, start2, end2, + SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_F); } #undef FUNC_NAME @@ -1502,39 +1290,9 @@ SCM_DEFINE (scm_string_ci_gt, "string-ci>", 2, 4, 0, "case-insensitively.") #define FUNC_NAME s_scm_string_ci_gt { - const unsigned char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - goto false; - else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - goto true; - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - goto true; - else if (cstart2 < cend2) - goto false; - else - goto false; - - true: - scm_remember_upto_here_2 (s1, s2); - return scm_from_size_t (cstart1); - - false: - scm_remember_upto_here_2 (s1, s2); - return SCM_BOOL_F; + return compare_strings (FUNC_NAME, 1, + s1, s2, start1, end1, start2, end2, + SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F); } #undef FUNC_NAME @@ -1546,39 +1304,9 @@ SCM_DEFINE (scm_string_ci_le, "string-ci<=", 2, 4, 0, "case-insensitively.") #define FUNC_NAME s_scm_string_ci_le { - const unsigned char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - goto true; - else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - goto false; - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - goto false; - else if (cstart2 < cend2) - goto true; - else - goto true; - - true: - scm_remember_upto_here_2 (s1, s2); - return scm_from_size_t (cstart1); - - false: - scm_remember_upto_here_2 (s1, s2); - return SCM_BOOL_F; + return compare_strings (FUNC_NAME, 1, + s1, s2, start1, end1, start2, end2, + SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T); } #undef FUNC_NAME @@ -1590,39 +1318,9 @@ SCM_DEFINE (scm_string_ci_ge, "string-ci>=", 2, 4, 0, "case-insensitively.") #define FUNC_NAME s_scm_string_ci_ge { - const unsigned char *cstr1, *cstr2; - size_t cstart1, cend1, cstart2, cend2; - - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_UCOPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); - - while (cstart1 < cend1 && cstart2 < cend2) - { - if (scm_c_downcase (cstr1[cstart1]) < scm_c_downcase (cstr2[cstart2])) - goto false; - else if (scm_c_downcase (cstr1[cstart1]) > scm_c_downcase (cstr2[cstart2])) - goto true; - cstart1++; - cstart2++; - } - if (cstart1 < cend1) - goto true; - else if (cstart2 < cend2) - goto false; - else - goto true; - - true: - scm_remember_upto_here_2 (s1, s2); - return scm_from_size_t (cstart1); - - false: - scm_remember_upto_here_2 (s1, s2); - return SCM_BOOL_F; + return compare_strings (FUNC_NAME, 1, + s1, s2, start1, end1, start2, end2, + SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_F, SCM_BOOL_T, SCM_BOOL_T); } #undef FUNC_NAME @@ -1664,19 +1362,20 @@ SCM_DEFINE (scm_string_prefix_length, "string-prefix-length", 2, 4, 0, "strings.") #define FUNC_NAME s_scm_string_prefix_length { - const char *cstr1, *cstr2; size_t cstart1, cend1, cstart2, cend2; size_t len = 0; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC (1, s1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC (2, s2, + 5, start2, cstart2, + 6, end2, cend2); + while (cstart1 < cend1 && cstart2 < cend2) { - if (cstr1[cstart1] != cstr2[cstart2]) + if (scm_i_string_ref (s1, cstart1) + != scm_i_string_ref (s2, cstart2)) goto ret; len++; cstart1++; @@ -1696,19 +1395,19 @@ SCM_DEFINE (scm_string_prefix_length_ci, "string-prefix-length-ci", 2, 4, 0, "strings, ignoring character case.") #define FUNC_NAME s_scm_string_prefix_length_ci { - const char *cstr1, *cstr2; size_t cstart1, cend1, cstart2, cend2; size_t len = 0; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC (1, s1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC (2, s2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { - if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2])) + if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1))) + != uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2)))) goto ret; len++; cstart1++; @@ -1728,21 +1427,21 @@ SCM_DEFINE (scm_string_suffix_length, "string-suffix-length", 2, 4, 0, "strings.") #define FUNC_NAME s_scm_string_suffix_length { - const char *cstr1, *cstr2; size_t cstart1, cend1, cstart2, cend2; size_t len = 0; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC (1, s1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC (2, s2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { cend1--; cend2--; - if (cstr1[cend1] != cstr2[cend2]) + if (scm_i_string_ref (s1, cend1) + != scm_i_string_ref (s2, cend2)) goto ret; len++; } @@ -1760,21 +1459,21 @@ SCM_DEFINE (scm_string_suffix_length_ci, "string-suffix-length-ci", 2, 4, 0, "strings, ignoring character case.") #define FUNC_NAME s_scm_string_suffix_length_ci { - const char *cstr1, *cstr2; size_t cstart1, cend1, cstart2, cend2; size_t len = 0; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC (1, s1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC (2, s2, + 5, start2, cstart2, + 6, end2, cend2); while (cstart1 < cend1 && cstart2 < cend2) { cend1--; cend2--; - if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2])) + if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cend1))) + != uc_tolower (uc_toupper (scm_i_string_ref (s2, cend2)))) goto ret; len++; } @@ -1791,20 +1490,20 @@ SCM_DEFINE (scm_string_prefix_p, "string-prefix?", 2, 4, 0, "Is @var{s1} a prefix of @var{s2}?") #define FUNC_NAME s_scm_string_prefix_p { - const char *cstr1, *cstr2; size_t cstart1, cend1, cstart2, cend2; size_t len = 0, len1; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC (1, s1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC (2, s2, + 5, start2, cstart2, + 6, end2, cend2); len1 = cend1 - cstart1; while (cstart1 < cend1 && cstart2 < cend2) { - if (cstr1[cstart1] != cstr2[cstart2]) + if (scm_i_string_ref (s1, cstart1) + != scm_i_string_ref (s2, cstart2)) goto ret; len++; cstart1++; @@ -1823,20 +1522,21 @@ SCM_DEFINE (scm_string_prefix_ci_p, "string-prefix-ci?", 2, 4, 0, "Is @var{s1} a prefix of @var{s2}, ignoring character case?") #define FUNC_NAME s_scm_string_prefix_ci_p { - const char *cstr1, *cstr2; size_t cstart1, cend1, cstart2, cend2; size_t len = 0, len1; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC (1, s1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC (2, s2, + 5, start2, cstart2, + 6, end2, cend2); len1 = cend1 - cstart1; while (cstart1 < cend1 && cstart2 < cend2) { - if (scm_c_downcase (cstr1[cstart1]) != scm_c_downcase (cstr2[cstart2])) + scm_t_wchar a = uc_tolower (uc_toupper (scm_i_string_ref (s1, cstart1))); + scm_t_wchar b = uc_tolower (uc_toupper (scm_i_string_ref (s2, cstart2))); + if (a != b) goto ret; len++; cstart1++; @@ -1855,22 +1555,22 @@ SCM_DEFINE (scm_string_suffix_p, "string-suffix?", 2, 4, 0, "Is @var{s1} a suffix of @var{s2}?") #define FUNC_NAME s_scm_string_suffix_p { - const char *cstr1, *cstr2; size_t cstart1, cend1, cstart2, cend2; size_t len = 0, len1; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC (1, s1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC (2, s2, + 5, start2, cstart2, + 6, end2, cend2); len1 = cend1 - cstart1; while (cstart1 < cend1 && cstart2 < cend2) { cend1--; cend2--; - if (cstr1[cend1] != cstr2[cend2]) + if (scm_i_string_ref (s1, cend1) + != scm_i_string_ref (s2, cend2)) goto ret; len++; } @@ -1887,22 +1587,22 @@ SCM_DEFINE (scm_string_suffix_ci_p, "string-suffix-ci?", 2, 4, 0, "Is @var{s1} a suffix of @var{s2}, ignoring character case?") #define FUNC_NAME s_scm_string_suffix_ci_p { - const char *cstr1, *cstr2; size_t cstart1, cend1, cstart2, cend2; size_t len = 0, len1; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cstr1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cstr2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC (1, s1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC (2, s2, + 5, start2, cstart2, + 6, end2, cend2); len1 = cend1 - cstart1; while (cstart1 < cend1 && cstart2 < cend2) { cend1--; cend2--; - if (scm_c_downcase (cstr1[cend1]) != scm_c_downcase (cstr2[cend2])) + if (uc_tolower (uc_toupper (scm_i_string_ref (s1, cend1))) + != uc_tolower (uc_toupper (scm_i_string_ref (s2, cend2)))) goto ret; len++; } @@ -1931,18 +1631,16 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, "@end itemize") #define FUNC_NAME s_scm_string_index { - const char *cstr; size_t cstart, cend; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, s, + 3, start, cstart, + 4, end, cend); if (SCM_CHARP (char_pred)) { - char cchr = SCM_CHAR (char_pred); while (cstart < cend) { - if (cchr == cstr[cstart]) + if (scm_i_string_ref (s, cstart) == SCM_CHAR (char_pred)) goto found; cstart++; } @@ -1951,7 +1649,7 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, { while (cstart < cend) { - if (SCM_CHARSET_GET (char_pred, cstr[cstart])) + if (REF_IN_CHARSET (s, cstart, char_pred)) goto found; cstart++; } @@ -1964,10 +1662,9 @@ SCM_DEFINE (scm_string_index, "string-index", 2, 2, 0, while (cstart < cend) { SCM res; - res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart])); + res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); if (scm_is_true (res)) goto found; - cstr = scm_i_string_chars (s); cstart++; } } @@ -1998,19 +1695,17 @@ SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0, "@end itemize") #define FUNC_NAME s_scm_string_index_right { - const char *cstr; size_t cstart, cend; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, s, + 3, start, cstart, + 4, end, cend); if (SCM_CHARP (char_pred)) { - char cchr = SCM_CHAR (char_pred); while (cstart < cend) { cend--; - if (cchr == cstr[cend]) + if (scm_i_string_ref (s, cend) == SCM_CHAR (char_pred)) goto found; } } @@ -2019,7 +1714,7 @@ SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0, while (cstart < cend) { cend--; - if (SCM_CHARSET_GET (char_pred, cstr[cend])) + if (REF_IN_CHARSET (s, cend, char_pred)) goto found; } } @@ -2032,10 +1727,9 @@ SCM_DEFINE (scm_string_index_right, "string-index-right", 2, 2, 0, { SCM res; cend--; - res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend])); + res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend))); if (scm_is_true (res)) goto found; - cstr = scm_i_string_chars (s); } } @@ -2087,18 +1781,16 @@ SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0, "@end itemize") #define FUNC_NAME s_scm_string_skip { - const char *cstr; size_t cstart, cend; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, s, + 3, start, cstart, + 4, end, cend); if (SCM_CHARP (char_pred)) { - char cchr = SCM_CHAR (char_pred); while (cstart < cend) { - if (cchr != cstr[cstart]) + if (scm_i_string_ref (s, cstart) != SCM_CHAR (char_pred)) goto found; cstart++; } @@ -2107,7 +1799,7 @@ SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0, { while (cstart < cend) { - if (!SCM_CHARSET_GET (char_pred, cstr[cstart])) + if (!REF_IN_CHARSET (s, cstart, char_pred)) goto found; cstart++; } @@ -2120,10 +1812,9 @@ SCM_DEFINE (scm_string_skip, "string-skip", 2, 2, 0, while (cstart < cend) { SCM res; - res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart])); + res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); if (scm_is_false (res)) goto found; - cstr = scm_i_string_chars (s); cstart++; } } @@ -2156,19 +1847,17 @@ SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0, "@end itemize") #define FUNC_NAME s_scm_string_skip_right { - const char *cstr; size_t cstart, cend; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, s, + 3, start, cstart, + 4, end, cend); if (SCM_CHARP (char_pred)) { - char cchr = SCM_CHAR (char_pred); while (cstart < cend) { cend--; - if (cchr != cstr[cend]) + if (scm_i_string_ref (s, cend) != SCM_CHAR (char_pred)) goto found; } } @@ -2177,7 +1866,7 @@ SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0, while (cstart < cend) { cend--; - if (!SCM_CHARSET_GET (char_pred, cstr[cend])) + if (!REF_IN_CHARSET (s, cend, char_pred)) goto found; } } @@ -2190,10 +1879,9 @@ SCM_DEFINE (scm_string_skip_right, "string-skip-right", 2, 2, 0, { SCM res; cend--; - res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cend])); + res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cend))); if (scm_is_false (res)) goto found; - cstr = scm_i_string_chars (s); } } @@ -2225,19 +1913,17 @@ SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0, "@end itemize") #define FUNC_NAME s_scm_string_count { - const char *cstr; size_t cstart, cend; size_t count = 0; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, s, + 3, start, cstart, + 4, end, cend); if (SCM_CHARP (char_pred)) { - char cchr = SCM_CHAR (char_pred); while (cstart < cend) { - if (cchr == cstr[cstart]) + if (scm_i_string_ref (s, cstart) == SCM_CHAR(char_pred)) count++; cstart++; } @@ -2246,7 +1932,7 @@ SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0, { while (cstart < cend) { - if (SCM_CHARSET_GET (char_pred, cstr[cstart])) + if (REF_IN_CHARSET (s, cstart, char_pred)) count++; cstart++; } @@ -2259,10 +1945,9 @@ SCM_DEFINE (scm_string_count, "string-count", 2, 2, 0, while (cstart < cend) { SCM res; - res = pred_tramp (char_pred, SCM_MAKE_CHAR (cstr[cstart])); + res = pred_tramp (char_pred, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart))); if (scm_is_true (res)) count++; - cstr = scm_i_string_chars (s); cstart++; } } @@ -2284,23 +1969,25 @@ SCM_DEFINE (scm_string_contains, "string-contains", 2, 4, 0, "indicated substrings.") #define FUNC_NAME s_scm_string_contains { - const char *cs1, * cs2; size_t cstart1, cend1, cstart2, cend2; size_t len2, i, j; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC (1, s1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC (2, s2, + 5, start2, cstart2, + 6, end2, cend2); len2 = cend2 - cstart2; if (cend1 - cstart1 >= len2) while (cstart1 <= cend1 - len2) { i = cstart1; j = cstart2; - while (i < cend1 && j < cend2 && cs1[i] == cs2[j]) + while (i < cend1 + && j < cend2 + && (scm_i_string_ref (s1, i) + == scm_i_string_ref (s2, j))) { i++; j++; @@ -2331,24 +2018,25 @@ SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0, "case-insensitively.") #define FUNC_NAME s_scm_string_contains_ci { - const char *cs1, * cs2; size_t cstart1, cend1, cstart2, cend2; size_t len2, i, j; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s1, cs1, - 3, start1, cstart1, - 4, end1, cend1); - MY_VALIDATE_SUBSTRING_SPEC_COPY (2, s2, cs2, - 5, start2, cstart2, - 6, end2, cend2); + MY_VALIDATE_SUBSTRING_SPEC (1, s1, + 3, start1, cstart1, + 4, end1, cend1); + MY_VALIDATE_SUBSTRING_SPEC (2, s2, + 5, start2, cstart2, + 6, end2, cend2); len2 = cend2 - cstart2; if (cend1 - cstart1 >= len2) while (cstart1 <= cend1 - len2) { i = cstart1; j = cstart2; - while (i < cend1 && j < cend2 && - scm_c_downcase (cs1[i]) == scm_c_downcase (cs2[j])) + while (i < cend1 + && j < cend2 + && (uc_tolower (uc_toupper (scm_i_string_ref (s1, i))) + == uc_tolower (uc_toupper (scm_i_string_ref (s2, j))))) { i++; j++; @@ -2367,17 +2055,15 @@ SCM_DEFINE (scm_string_contains_ci, "string-contains-ci", 2, 4, 0, #undef FUNC_NAME -/* Helper function for the string uppercase conversion functions. - * No argument checking is performed. */ +/* Helper function for the string uppercase conversion functions. */ static SCM string_upcase_x (SCM v, size_t start, size_t end) { size_t k; - char *dst; - dst = scm_i_string_writable_chars (v); + v = scm_i_string_start_writing (v); for (k = start; k < end; ++k) - dst[k] = scm_c_upcase (dst[k]); + scm_i_string_set_x (v, k, uc_toupper (scm_i_string_ref (v, k))); scm_i_string_stop_writing (); scm_remember_upto_here_1 (v); @@ -2396,12 +2082,11 @@ SCM_DEFINE (scm_substring_upcase_x, "string-upcase!", 1, 2, 0, "@end lisp") #define FUNC_NAME s_scm_substring_upcase_x { - const char *cstr; size_t cstart, cend; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, str, + 2, start, cstart, + 3, end, cend); return string_upcase_x (str, cstart, cend); } #undef FUNC_NAME @@ -2417,12 +2102,11 @@ SCM_DEFINE (scm_substring_upcase, "string-upcase", 1, 2, 0, "Upcase every character in @code{str}.") #define FUNC_NAME s_scm_substring_upcase { - const char *cstr; size_t cstart, cend; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, str, + 2, start, cstart, + 3, end, cend); return string_upcase_x (scm_string_copy (str), cstart, cend); } #undef FUNC_NAME @@ -2439,11 +2123,10 @@ static SCM string_downcase_x (SCM v, size_t start, size_t end) { size_t k; - char *dst; - dst = scm_i_string_writable_chars (v); + v = scm_i_string_start_writing (v); for (k = start; k < end; ++k) - dst[k] = scm_c_downcase (dst[k]); + scm_i_string_set_x (v, k, uc_tolower (scm_i_string_ref (v, k))); scm_i_string_stop_writing (); scm_remember_upto_here_1 (v); @@ -2464,12 +2147,11 @@ SCM_DEFINE (scm_substring_downcase_x, "string-downcase!", 1, 2, 0, "@end lisp") #define FUNC_NAME s_scm_substring_downcase_x { - const char *cstr; size_t cstart, cend; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, str, + 2, start, cstart, + 3, end, cend); return string_downcase_x (str, cstart, cend); } #undef FUNC_NAME @@ -2485,12 +2167,11 @@ SCM_DEFINE (scm_substring_downcase, "string-downcase", 1, 2, 0, "Downcase every character in @var{str}.") #define FUNC_NAME s_scm_substring_downcase { - const char *cstr; size_t cstart, cend; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, str, + 2, start, cstart, + 3, end, cend); return string_downcase_x (scm_string_copy (str), cstart, cend); } #undef FUNC_NAME @@ -2506,23 +2187,24 @@ scm_string_downcase (SCM str) static SCM string_titlecase_x (SCM str, size_t start, size_t end) { - unsigned char *sz; + SCM ch; size_t i; int in_word = 0; - sz = (unsigned char *) scm_i_string_writable_chars (str); + str = scm_i_string_start_writing (str); for(i = start; i < end; i++) { - if (scm_is_true (scm_char_alphabetic_p (SCM_MAKE_CHAR (sz[i])))) + ch = SCM_MAKE_CHAR (scm_i_string_ref (str, i)); + if (scm_is_true (scm_char_alphabetic_p (ch))) { if (!in_word) { - sz[i] = scm_c_upcase(sz[i]); + scm_i_string_set_x (str, i, uc_toupper (SCM_CHAR (ch))); in_word = 1; } else { - sz[i] = scm_c_downcase(sz[i]); + scm_i_string_set_x (str, i, uc_tolower (SCM_CHAR (ch))); } } else @@ -2541,12 +2223,11 @@ SCM_DEFINE (scm_string_titlecase_x, "string-titlecase!", 1, 2, 0, "@var{str}.") #define FUNC_NAME s_scm_string_titlecase_x { - const char *cstr; size_t cstart, cend; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, str, + 2, start, cstart, + 3, end, cend); return string_titlecase_x (str, cstart, cend); } #undef FUNC_NAME @@ -2557,12 +2238,11 @@ SCM_DEFINE (scm_string_titlecase, "string-titlecase", 1, 2, 0, "Titlecase every first character in a word in @var{str}.") #define FUNC_NAME s_scm_string_titlecase { - const char *cstr; size_t cstart, cend; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, str, + 2, start, cstart, + 3, end, cend); return string_titlecase_x (scm_string_copy (str), cstart, cend); } #undef FUNC_NAME @@ -2599,22 +2279,24 @@ SCM_DEFINE (scm_string_capitalize, "string-capitalize", 1, 0, 0, /* Reverse the portion of @var{str} between str[cstart] (including) and str[cend] excluding. */ static void -string_reverse_x (char * str, size_t cstart, size_t cend) +string_reverse_x (SCM str, size_t cstart, size_t cend) { - char tmp; + SCM tmp; + str = scm_i_string_start_writing (str); if (cend > 0) { cend--; while (cstart < cend) { - tmp = str[cstart]; - str[cstart] = str[cend]; - str[cend] = tmp; + tmp = SCM_MAKE_CHAR (scm_i_string_ref (str, cstart)); + scm_i_string_set_x (str, cstart, scm_i_string_ref (str, cend)); + scm_i_string_set_x (str, cend, SCM_CHAR (tmp)); cstart++; cend--; } } + scm_i_string_stop_writing (); } @@ -2625,18 +2307,14 @@ SCM_DEFINE (scm_string_reverse, "string-reverse", 1, 2, 0, "operate on.") #define FUNC_NAME s_scm_string_reverse { - const char *cstr; - char *ctarget; size_t cstart, cend; SCM result; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, str, cstr, - 2, start, cstart, - 3, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, str, + 2, start, cstart, + 3, end, cend); result = scm_string_copy (str); - ctarget = scm_i_string_writable_chars (result); - string_reverse_x (ctarget, cstart, cend); - scm_i_string_stop_writing (); + string_reverse_x (result, cstart, cend); scm_remember_upto_here_1 (str); return result; } @@ -2650,16 +2328,13 @@ SCM_DEFINE (scm_string_reverse_x, "string-reverse!", 1, 2, 0, "operate on. The return value is unspecified.") #define FUNC_NAME s_scm_string_reverse_x { - char *cstr; size_t cstart, cend; MY_VALIDATE_SUBSTRING_SPEC (1, str, 2, start, cstart, 3, end, cend); - cstr = scm_i_string_writable_chars (str); - string_reverse_x (cstr, cstart, cend); - scm_i_string_stop_writing (); + string_reverse_x (str, cstart, cend); scm_remember_upto_here_1 (str); return SCM_UNSPECIFIED; } @@ -2685,7 +2360,9 @@ SCM_DEFINE (scm_string_append_shared, "string-append/shared", 0, 0, 1, for (l = rest; scm_is_pair (l); l = SCM_CDR (l)) { s = SCM_CAR (l); - if (scm_c_string_length (s) != 0) + if (!scm_is_string (s)) + scm_wrong_type_arg (FUNC_NAME, 0, s); + if (scm_i_string_length (s) != 0) { if (seen_nonempty) /* two or more non-empty strings, need full concat */ @@ -2772,7 +2449,7 @@ SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0, "string elements is not specified.") #define FUNC_NAME s_scm_string_map { - char *p; + size_t p; size_t cstart, cend; SCM result; scm_t_trampoline_1 proc_tramp = scm_trampoline_1 (proc); @@ -2781,15 +2458,20 @@ SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0, MY_VALIDATE_SUBSTRING_SPEC (2, s, 3, start, cstart, 4, end, cend); - result = scm_i_make_string (cend - cstart, &p); + result = scm_i_make_string (cend - cstart, NULL); + p = 0; while (cstart < cend) { SCM ch = proc_tramp (proc, scm_c_string_ref (s, cstart)); if (!SCM_CHARP (ch)) SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); cstart++; - *p++ = SCM_CHAR (ch); + result = scm_i_string_start_writing (result); + scm_i_string_set_x (result, p, SCM_CHAR (ch)); + scm_i_string_stop_writing (); + p++; } + return result; } #undef FUNC_NAME @@ -2815,7 +2497,9 @@ SCM_DEFINE (scm_string_map_x, "string-map!", 2, 2, 0, SCM ch = proc_tramp (proc, scm_c_string_ref (s, cstart)); if (!SCM_CHARP (ch)) SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); - scm_c_string_set_x (s, cstart, ch); + s = scm_i_string_start_writing (s); + scm_i_string_set_x (s, cstart, SCM_CHAR (ch)); + scm_i_string_stop_writing (); cstart++; } return SCM_UNSPECIFIED; @@ -2831,20 +2515,17 @@ SCM_DEFINE (scm_string_fold, "string-fold", 3, 2, 0, "result of @var{kons}' application.") #define FUNC_NAME s_scm_string_fold { - const char *cstr; size_t cstart, cend; SCM result; SCM_VALIDATE_PROC (1, kons); - MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, - 4, start, cstart, - 5, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (3, s, + 4, start, cstart, + 5, end, cend); result = knil; while (cstart < cend) { - unsigned int c = (unsigned char) cstr[cstart]; - result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result); - cstr = scm_i_string_chars (s); + result = scm_call_2 (kons, SCM_MAKE_CHAR (scm_i_string_ref (s, cstart)), result); cstart++; } @@ -2862,20 +2543,17 @@ SCM_DEFINE (scm_string_fold_right, "string-fold-right", 3, 2, 0, "result of @var{kons}' application.") #define FUNC_NAME s_scm_string_fold_right { - const char *cstr; size_t cstart, cend; SCM result; SCM_VALIDATE_PROC (1, kons); - MY_VALIDATE_SUBSTRING_SPEC_COPY (3, s, cstr, - 4, start, cstart, - 5, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (3, s, + 4, start, cstart, + 5, end, cend); result = knil; while (cstart < cend) { - unsigned int c = (unsigned char) cstr[cend - 1]; - result = scm_call_2 (kons, SCM_MAKE_CHAR (c), result); - cstr = scm_i_string_chars (s); + result = scm_call_2 (kons, SCM_MAKE_CHAR (scm_i_string_ref (s, cend-1)), result); cend--; } @@ -2926,12 +2604,15 @@ SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0, while (scm_is_false (res)) { SCM str; - char *ptr; + size_t i = 0; SCM ch = scm_call_1 (f, seed); if (!SCM_CHARP (ch)) SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); - str = scm_i_make_string (1, &ptr); - *ptr = SCM_CHAR (ch); + str = scm_i_make_string (1, NULL); + str = scm_i_string_start_writing (str); + scm_i_string_set_x (str, i, SCM_CHAR (ch)); + scm_i_string_stop_writing (); + i++; ans = scm_string_append (scm_list_2 (ans, str)); seed = scm_call_1 (g, seed); @@ -2989,12 +2670,15 @@ SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0, while (scm_is_false (res)) { SCM str; - char *ptr; + size_t i = 0; SCM ch = scm_call_1 (f, seed); if (!SCM_CHARP (ch)) SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); - str = scm_i_make_string (1, &ptr); - *ptr = SCM_CHAR (ch); + str = scm_i_make_string (1, NULL); + str = scm_i_string_start_writing (str); + scm_i_string_set_x (str, i, SCM_CHAR (ch)); + scm_i_string_stop_writing (); + i++; ans = scm_string_append (scm_list_2 (str, ans)); seed = scm_call_1 (g, seed); @@ -3017,19 +2701,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++; } @@ -3091,8 +2772,7 @@ SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0, "defaults to @var{from} + (@var{end} - @var{start}).") #define FUNC_NAME s_scm_xsubstring { - const char *cs; - char *p; + size_t p; size_t cstart, cend; int cfrom, cto; SCM result; @@ -3109,19 +2789,22 @@ SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0, if (cstart == cend && cfrom != cto) SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL); - result = scm_i_make_string (cto - cfrom, &p); + result = scm_i_make_string (cto - cfrom, NULL); + result = scm_i_string_start_writing (result); - cs = scm_i_string_chars (s); + p = 0; while (cfrom < cto) { size_t t = ((cfrom < 0) ? -cfrom : cfrom) % (cend - cstart); if (cfrom < 0) - *p = cs[(cend - cstart) - t]; + scm_i_string_set_x (result, p, + scm_i_string_ref (s, (cend - cstart) - t)); else - *p = cs[t]; + scm_i_string_set_x (result, p, scm_i_string_ref (s, t)); cfrom++; p++; } + scm_i_string_stop_writing (); scm_remember_upto_here_1 (s); return result; @@ -3138,8 +2821,7 @@ SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0, "cannot copy a string on top of itself.") #define FUNC_NAME s_scm_string_xcopy_x { - char *p; - const char *cs; + size_t p; size_t ctstart, cstart, cend; int csfrom, csto; SCM dummy = SCM_UNDEFINED; @@ -3161,15 +2843,15 @@ SCM_DEFINE (scm_string_xcopy_x, "string-xcopy!", 4, 3, 0, SCM_ASSERT_RANGE (1, tstart, ctstart + (csto - csfrom) <= scm_i_string_length (target)); - p = scm_i_string_writable_chars (target) + ctstart; - cs = scm_i_string_chars (s); + p = 0; + target = scm_i_string_start_writing (target); while (csfrom < csto) { size_t t = ((csfrom < 0) ? -csfrom : csfrom) % (cend - cstart); if (csfrom < 0) - *p = cs[(cend - cstart) - t]; + scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, (cend - cstart) - t)); else - *p = cs[t]; + scm_i_string_set_x (target, p + cstart, scm_i_string_ref (s, t)); csfrom++; p++; } @@ -3188,8 +2870,6 @@ SCM_DEFINE (scm_string_replace, "string-replace", 2, 4, 0, "@var{start2} @dots{} @var{end2} from @var{s2}.") #define FUNC_NAME s_scm_string_replace { - const char *cstr1, *cstr2; - char *p; size_t cstart1, cend1, cstart2, cend2; SCM result; @@ -3199,16 +2879,10 @@ 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); - cstr1 = scm_i_string_chars (s1); - cstr2 = scm_i_string_chars (s2); - memmove (p, cstr1, cstart1 * sizeof (char)); - memmove (p + cstart1, cstr2 + cstart2, (cend2 - cstart2) * sizeof (char)); - memmove (p + cstart1 + (cend2 - cstart2), - cstr1 + cend1, - (scm_i_string_length (s1) - cend1) * sizeof (char)); - scm_remember_upto_here_2 (s1, s2); + return (scm_string_append + (scm_list_3 (scm_i_substring (s1, 0, cstart1), + scm_i_substring (s2, cstart2, cend2), + scm_i_substring (s1, cend1, scm_i_string_length (s1))))); return result; } #undef FUNC_NAME @@ -3225,13 +2899,12 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0, "of @var{s}.") #define FUNC_NAME s_scm_string_tokenize { - const char *cstr; size_t cstart, cend; SCM result = SCM_EOL; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, s, + 3, start, cstart, + 4, end, cend); if (SCM_UNBNDP (token_set)) token_set = scm_char_set_graphic; @@ -3244,7 +2917,7 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0, { while (cstart < cend) { - if (SCM_CHARSET_GET (token_set, cstr[cend - 1])) + if (REF_IN_CHARSET (s, cend-1, token_set)) break; cend--; } @@ -3253,12 +2926,11 @@ SCM_DEFINE (scm_string_tokenize, "string-tokenize", 1, 3, 0, idx = cend; while (cstart < cend) { - if (!SCM_CHARSET_GET (token_set, cstr[cend - 1])) + if (!REF_IN_CHARSET (s, cend-1, token_set)) break; cend--; } - result = scm_cons (scm_c_substring (s, cend, idx), result); - cstr = scm_i_string_chars (s); + result = scm_cons (scm_i_substring (s, cend, idx), result); } } else @@ -3292,27 +2964,45 @@ SCM_DEFINE (scm_string_split, "string-split", 2, 0, 0, #define FUNC_NAME s_scm_string_split { long idx, last_idx; - const char * p; - char ch; + int narrow; SCM res = SCM_EOL; SCM_VALIDATE_STRING (1, str); SCM_VALIDATE_CHAR (2, chr); - + + /* This is explicit wide/narrow logic (instead of using + scm_i_string_ref) is a speed optimization. */ idx = scm_i_string_length (str); - p = scm_i_string_chars (str); - ch = SCM_CHAR (chr); - while (idx >= 0) - { - last_idx = idx; - while (idx > 0 && p[idx - 1] != ch) - idx--; - if (idx >= 0) - { - res = scm_cons (scm_c_substring (str, idx, last_idx), res); - p = scm_i_string_chars (str); - idx--; - } + narrow = scm_i_is_narrow_string (str); + if (narrow) + { + const char *buf = scm_i_string_chars (str); + while (idx >= 0) + { + last_idx = idx; + while (idx > 0 && buf[idx-1] != (char) SCM_CHAR(chr)) + idx--; + if (idx >= 0) + { + res = scm_cons (scm_i_substring (str, idx, last_idx), res); + idx--; + } + } + } + else + { + const scm_t_wchar *buf = scm_i_string_wide_chars (str); + while (idx >= 0) + { + last_idx = idx; + while (idx > 0 && buf[idx-1] != SCM_CHAR(chr)) + idx--; + if (idx >= 0) + { + res = scm_cons (scm_i_substring (str, idx, last_idx), res); + idx--; + } + } } scm_remember_upto_here_1 (str); return res; @@ -3331,14 +3021,13 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, "membership.") #define FUNC_NAME s_scm_string_filter { - const char *cstr; size_t cstart, cend; SCM result; size_t idx; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, s, + 3, start, cstart, + 4, end, cend); /* The explicit loops below stripping leading and trailing non-matches mean we can return a substring if those are the only deletions, making @@ -3347,22 +3036,19 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, if (SCM_CHARP (char_pred)) { size_t count; - char chr; - - chr = SCM_CHAR (char_pred); /* strip leading non-matches by incrementing cstart */ - while (cstart < cend && cstr[cstart] != chr) + while (cstart < cend && scm_i_string_ref (s, cstart) != SCM_CHAR (char_pred)) cstart++; /* strip trailing non-matches by decrementing cend */ - while (cend > cstart && cstr[cend-1] != chr) + while (cend > cstart && scm_i_string_ref (s, cend-1) != SCM_CHAR (char_pred)) cend--; /* count chars to keep */ count = 0; for (idx = cstart; idx < cend; idx++) - if (cstr[idx] == chr) + if (scm_i_string_ref (s, idx) == SCM_CHAR (char_pred)) count++; if (count == cend - cstart) @@ -3380,17 +3066,17 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, size_t count; /* strip leading non-matches by incrementing cstart */ - while (cstart < cend && ! SCM_CHARSET_GET (char_pred, cstr[cstart])) + while (cstart < cend && ! REF_IN_CHARSET (s, cstart, char_pred)) cstart++; /* strip trailing non-matches by decrementing cend */ - while (cend > cstart && ! SCM_CHARSET_GET (char_pred, cstr[cend-1])) + while (cend > cstart && ! REF_IN_CHARSET (s, cend-1, char_pred)) cend--; /* count chars to be kept */ count = 0; for (idx = cstart; idx < cend; idx++) - if (SCM_CHARSET_GET (char_pred, cstr[idx])) + if (REF_IN_CHARSET (s, idx, char_pred)) count++; /* if whole of start to end kept then return substring */ @@ -3398,21 +3084,23 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, goto result_substring; else { - char *dst; - result = scm_i_make_string (count, &dst); - cstr = scm_i_string_chars (s); + size_t dst = 0; + result = scm_i_make_string (count, NULL); + result = scm_i_string_start_writing (result); /* decrement "count" in this loop as well as using idx, so that if another thread is simultaneously changing "s" there's no chance it'll make us copy more than count characters */ for (idx = cstart; idx < cend && count != 0; idx++) { - if (SCM_CHARSET_GET (char_pred, cstr[idx])) + if (REF_IN_CHARSET (s, idx, char_pred)) { - *dst++ = cstr[idx]; + scm_i_string_set_x (result, dst, scm_i_string_ref (s, idx)); + dst ++; count--; } } + scm_i_string_stop_writing (); } } else @@ -3425,11 +3113,10 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0, while (idx < cend) { SCM res, ch; - ch = SCM_MAKE_CHAR (cstr[idx]); + ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx)); res = pred_tramp (char_pred, ch); if (scm_is_true (res)) ls = scm_cons (ch, ls); - cstr = scm_i_string_chars (s); idx++; } result = scm_reverse_list_to_string (ls); @@ -3451,14 +3138,13 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, "membership.") #define FUNC_NAME s_scm_string_delete { - const char *cstr; size_t cstart, cend; SCM result; size_t idx; - MY_VALIDATE_SUBSTRING_SPEC_COPY (1, s, cstr, - 3, start, cstart, - 4, end, cend); + MY_VALIDATE_SUBSTRING_SPEC (1, s, + 3, start, cstart, + 4, end, cend); /* The explicit loops below stripping leading and trailing matches mean we can return a substring if those are the only deletions, making @@ -3467,22 +3153,19 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, if (SCM_CHARP (char_pred)) { size_t count; - char chr; - - chr = SCM_CHAR (char_pred); /* strip leading matches by incrementing cstart */ - while (cstart < cend && cstr[cstart] == chr) + while (cstart < cend && scm_i_string_ref (s, cstart) == SCM_CHAR(char_pred)) cstart++; /* strip trailing matches by decrementing cend */ - while (cend > cstart && cstr[cend-1] == chr) + while (cend > cstart && scm_i_string_ref (s, cend-1) == SCM_CHAR (char_pred)) cend--; /* count chars to be kept */ count = 0; for (idx = cstart; idx < cend; idx++) - if (cstr[idx] != chr) + if (scm_i_string_ref (s, idx) != SCM_CHAR (char_pred)) count++; if (count == cend - cstart) @@ -3494,22 +3177,24 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, } else { + int i = 0; /* new string for retained portion */ - char *dst; - result = scm_i_make_string (count, &dst); - cstr = scm_i_string_chars (s); - + result = scm_i_make_string (count, NULL); + result = scm_i_string_start_writing (result); /* decrement "count" in this loop as well as using idx, so that if another thread is simultaneously changing "s" there's no chance it'll make us copy more than count characters */ for (idx = cstart; idx < cend && count != 0; idx++) { - if (cstr[idx] != chr) + scm_t_wchar c = scm_i_string_ref (s, idx); + if (c != SCM_CHAR (char_pred)) { - *dst++ = cstr[idx]; + scm_i_string_set_x (result, i, c); + i++; count--; } } + scm_i_string_stop_writing (); } } else if (SCM_CHARSETP (char_pred)) @@ -3517,39 +3202,41 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, size_t count; /* strip leading matches by incrementing cstart */ - while (cstart < cend && SCM_CHARSET_GET (char_pred, cstr[cstart])) + while (cstart < cend && REF_IN_CHARSET (s, cstart, char_pred)) cstart++; /* strip trailing matches by decrementing cend */ - while (cend > cstart && SCM_CHARSET_GET (char_pred, cstr[cend-1])) + while (cend > cstart && REF_IN_CHARSET (s, cend-1, char_pred)) cend--; /* count chars to be kept */ count = 0; for (idx = cstart; idx < cend; idx++) - if (! SCM_CHARSET_GET (char_pred, cstr[idx])) + if (!REF_IN_CHARSET (s, idx, char_pred)) count++; if (count == cend - cstart) goto result_substring; else { + size_t i = 0; /* new string for retained portion */ - char *dst; - result = scm_i_make_string (count, &dst); - cstr = scm_i_string_chars (s); + result = scm_i_make_string (count, NULL); + result = scm_i_string_start_writing (result); /* decrement "count" in this loop as well as using idx, so that if another thread is simultaneously changing "s" there's no chance it'll make us copy more than count characters */ for (idx = cstart; idx < cend && count != 0; idx++) { - if (! SCM_CHARSET_GET (char_pred, cstr[idx])) + if (!REF_IN_CHARSET (s, idx, char_pred)) { - *dst++ = cstr[idx]; + scm_i_string_set_x (result, i, scm_i_string_ref (s, idx)); + i++; count--; } } + scm_i_string_stop_writing (); } } else @@ -3561,11 +3248,10 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0, idx = cstart; while (idx < cend) { - SCM res, ch = SCM_MAKE_CHAR (cstr[idx]); + SCM res, ch = SCM_MAKE_CHAR (scm_i_string_ref (s, idx)); res = pred_tramp (char_pred, ch); if (scm_is_false (res)) ls = scm_cons (ch, ls); - cstr = scm_i_string_chars (s); idx++; } result = scm_reverse_list_to_string (ls); 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..7c0013193 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 @@ -23,59 +24,511 @@ #include <string.h> -#include <ctype.h> +#include <unictype.h> #include "libguile.h" #include "libguile/srfi-14.h" +#include "libguile/strings.h" +/* Include the pre-computed standard charset data. */ +#include "libguile/srfi-14.i.c" -#define SCM_CHARSET_SET(cs, idx) \ - (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] |= \ - (1L << ((idx) % SCM_BITS_PER_LONG))) +#define SCM_CHARSET_DATA(charset) ((scm_t_char_set *) SCM_SMOB_DATA (charset)) -#define SCM_CHARSET_UNSET(cs, idx) \ - (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] &= \ - (~(1L << ((idx) % SCM_BITS_PER_LONG)))) - -#define BYTES_PER_CHARSET (SCM_CHARSET_SIZE / 8) -#define LONGS_PER_CHARSET (SCM_CHARSET_SIZE / SCM_BITS_PER_LONG) +#define SCM_CHARSET_SET(cs, idx) \ + scm_i_charset_set (SCM_CHARSET_DATA (cs), idx) +#define SCM_CHARSET_UNSET(cs, idx) \ + scm_i_charset_unset (SCM_CHARSET_DATA (cs), idx) /* Smob type code for character sets. */ int scm_tc16_charset = 0; +int scm_tc16_charset_cursor = 0; + +/* True if N exists in charset CS. */ +int +scm_i_charset_get (scm_t_char_set *cs, scm_t_wchar n) +{ + size_t i; + + i = 0; + while (i < cs->len) + { + if (cs->ranges[i].lo <= n && n <= cs->ranges[i].hi) + return 1; + i++; + } + + return 0; +} + +/* Put N into charset CS. */ +void +scm_i_charset_set (scm_t_char_set *cs, scm_t_wchar n) +{ + size_t i; + size_t len; + + len = cs->len; + + i = 0; + while (i < len) + { + /* Already in this range */ + if (cs->ranges[i].lo <= n && n <= cs->ranges[i].hi) + { + return; + } + + if (n == cs->ranges[i].lo - 1) + { + /* This char is one below the current range. */ + if (i > 0 && cs->ranges[i - 1].hi + 1 == n) + { + /* It is also one above the previous range, so combine them. */ + cs->ranges[i - 1].hi = cs->ranges[i].hi; + if (i < len - 1) + memmove (cs->ranges + i, cs->ranges + (i + 1), + sizeof (scm_t_char_range) * (len - i - 1)); + cs->ranges = scm_gc_realloc (cs->ranges, + sizeof (scm_t_char_range) * len, + sizeof (scm_t_char_range) * (len - + 1), + "character-set"); + cs->len = len - 1; + return; + } + else + { + /* Expand the range down by one. */ + cs->ranges[i].lo = n; + return; + } + } + else if (n == cs->ranges[i].hi + 1) + { + /* This char is one above the current range. */ + if (i < len - 1 && cs->ranges[i + 1].lo - 1 == n) + { + /* It is also one below the next range, so combine them. */ + cs->ranges[i].hi = cs->ranges[i + 1].hi; + if (i < len - 2) + memmove (cs->ranges + (i + 1), cs->ranges + (i + 2), + sizeof (scm_t_char_range) * (len - i - 2)); + cs->ranges = scm_gc_realloc (cs->ranges, + sizeof (scm_t_char_range) * len, + sizeof (scm_t_char_range) * (len - + 1), + "character-set"); + cs->len = len - 1; + return; + } + else + { + /* Expand the range up by one. */ + cs->ranges[i].hi = n; + return; + } + } + else if (n < cs->ranges[i].lo - 1) + { + /* This is a new range below the current one. */ + cs->ranges = scm_gc_realloc (cs->ranges, + sizeof (scm_t_char_range) * len, + sizeof (scm_t_char_range) * (len + 1), + "character-set"); + memmove (cs->ranges + (i + 1), cs->ranges + i, + sizeof (scm_t_char_range) * (len - i)); + cs->ranges[i].lo = n; + cs->ranges[i].hi = n; + cs->len = len + 1; + return; + } + + i++; + } + + /* This is a new range above all previous ranges. */ + if (len == 0) + { + cs->ranges = scm_gc_malloc (sizeof (scm_t_char_range), "character-set"); + } + else + { + cs->ranges = scm_gc_realloc (cs->ranges, + sizeof (scm_t_char_range) * len, + sizeof (scm_t_char_range) * (len + 1), + "character-set"); + } + cs->ranges[len].lo = n; + cs->ranges[len].hi = n; + cs->len = len + 1; + + return; +} + +/* If N is in charset CS, remove it. */ +void +scm_i_charset_unset (scm_t_char_set *cs, scm_t_wchar n) +{ + size_t i; + size_t len; + + len = cs->len; + + i = 0; + while (i < len) + { + if (n < cs->ranges[i].lo) + /* Not in this set. */ + return; + + if (n == cs->ranges[i].lo && n == cs->ranges[i].hi) + { + /* Remove this one-character range. */ + if (len == 1) + { + scm_gc_free (cs->ranges, + sizeof (scm_t_char_range) * cs->len, + "character-set"); + cs->ranges = NULL; + cs->len = 0; + return; + } + else if (i < len - 1) + { + memmove (cs->ranges + i, cs->ranges + (i + 1), + sizeof (scm_t_char_range) * (len - i - 1)); + cs->ranges = scm_gc_realloc (cs->ranges, + sizeof (scm_t_char_range) * len, + sizeof (scm_t_char_range) * (len - + 1), + "character-set"); + cs->len = len - 1; + return; + } + else if (i == len - 1) + { + cs->ranges = scm_gc_realloc (cs->ranges, + sizeof (scm_t_char_range) * len, + sizeof (scm_t_char_range) * (len - + 1), + "character-set"); + cs->len = len - 1; + return; + } + } + else if (n == cs->ranges[i].lo) + { + /* Shrink this range from the left. */ + cs->ranges[i].lo = n + 1; + return; + } + else if (n == cs->ranges[i].hi) + { + /* Shrink this range from the right. */ + cs->ranges[i].hi = n - 1; + return; + } + else if (n > cs->ranges[i].lo && n < cs->ranges[i].hi) + { + /* Split this range into two pieces. */ + cs->ranges = scm_gc_realloc (cs->ranges, + sizeof (scm_t_char_range) * len, + sizeof (scm_t_char_range) * (len + 1), + "character-set"); + if (i < len - 1) + memmove (cs->ranges + (i + 2), cs->ranges + (i + 1), + sizeof (scm_t_char_range) * (len - i - 1)); + cs->ranges[i + 1].hi = cs->ranges[i].hi; + cs->ranges[i + 1].lo = n + 1; + cs->ranges[i].hi = n - 1; + cs->len = len + 1; + return; + } + + i++; + } + + /* This value is above all ranges, so do nothing here. */ + return; +} + +static int +charsets_equal (scm_t_char_set *a, scm_t_char_set *b) +{ + if (a->len != b->len) + return 0; + + if (memcmp (a->ranges, b->ranges, sizeof (scm_t_char_range) * a->len) != 0) + return 0; + + return 1; +} + +/* Return true if every character in A is also in B. */ +static int +charsets_leq (scm_t_char_set *a, scm_t_char_set *b) +{ + size_t i = 0, j = 0; + scm_t_wchar alo, ahi; + + if (a->len == 0) + return 1; + if (b->len == 0) + return 0; + while (i < a->len) + { + alo = a->ranges[i].lo; + ahi = a->ranges[i].hi; + while (b->ranges[j].hi < alo) + { + if (j < b->len - 1) + j++; + else + return 0; + } + if (alo < b->ranges[j].lo || ahi > b->ranges[j].hi) + return 0; + i++; + } + + return 1; +} + +/* Merge B into A. */ +static void +charsets_union (scm_t_char_set *a, scm_t_char_set *b) +{ + size_t i = 0; + scm_t_wchar blo, bhi, n; + + if (b->len == 0) + return; + + if (a->len == 0) + { + a->len = b->len; + a->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * b->len, + "character-set"); + memcpy (a->ranges, b->ranges, sizeof (scm_t_char_range) * b->len); + return; + } + + /* This needs optimization. */ + while (i < b->len) + { + blo = b->ranges[i].lo; + bhi = b->ranges[i].hi; + for (n = blo; n <= bhi; n++) + scm_i_charset_set (a, n); + + i++; + } + + return; +} + +/* Remove elements not both in A and B from A. */ +static void +charsets_intersection (scm_t_char_set *a, scm_t_char_set *b) +{ + size_t i = 0; + scm_t_wchar blo, bhi, n; + scm_t_char_set *c; + + if (a->len == 0) + return; + + if (b->len == 0) + { + scm_gc_free (a->ranges, sizeof (scm_t_char_range) * a->len, + "character-set"); + a->len = 0; + return; + } + + c = (scm_t_char_set *) scm_malloc (sizeof (scm_t_char_set)); + c->len = 0; + c->ranges = NULL; + + while (i < b->len) + { + blo = b->ranges[i].lo; + bhi = b->ranges[i].hi; + for (n = blo; n <= bhi; n++) + if (scm_i_charset_get (a, n)) + scm_i_charset_set (c, n); + i++; + } + scm_gc_free (a->ranges, sizeof (scm_t_char_range) * a->len, + "character-set"); + + a->len = c->len; + if (c->len != 0) + a->ranges = c->ranges; + else + a->ranges = NULL; + free (c); + return; +} + +/* Make P the compelement of Q. */ +static void +charsets_complement (scm_t_char_set *p, scm_t_char_set *q) +{ + int k, idx; + + if (q->len == 0) + { + /* Fill with all valid codepoints. */ + p->len = 2; + p->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * 2, + "character-set"); + p->ranges[0].lo = 0; + p->ranges[0].hi = 0xd7ff; + p->ranges[1].lo = 0xe000; + p->ranges[1].hi = SCM_CODEPOINT_MAX; + return; + } + + if (p->len > 0) + scm_gc_free (p->ranges, sizeof (scm_t_char_set) * p->len, + "character-set"); + + p->len = 0; + if (q->ranges[0].lo > 0) + p->len++; + if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_MAX) + p->len++; + p->len += q->len - 1; + p->ranges = + (scm_t_char_range *) scm_gc_malloc (sizeof (scm_t_char_range) * p->len, + "character-set"); + idx = 0; + if (q->ranges[0].lo > 0) + { + p->ranges[idx].lo = 0; + p->ranges[idx++].hi = q->ranges[0].lo - 1; + } + for (k = 1; k < q->len; k++) + { + p->ranges[idx].lo = q->ranges[k - 1].hi + 1; + p->ranges[idx++].hi = q->ranges[k].lo - 1; + } + if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_MAX) + { + p->ranges[idx].lo = q->ranges[q->len - 1].hi + 1; + p->ranges[idx].hi = SCM_CODEPOINT_MAX; + } + return; +} + +/* Replace A with elements only found in one of A or B. */ +static void +charsets_xor (scm_t_char_set *a, scm_t_char_set *b) +{ + size_t i = 0; + scm_t_wchar blo, bhi, n; + + if (b->len == 0) + { + return; + } + if (a->len == 0) + { + a->ranges = + (scm_t_char_range *) scm_gc_malloc (sizeof (scm_t_char_range) * + b->len, "character-set"); + a->len = b->len; + memcpy (a->ranges, b->ranges, sizeof (scm_t_char_range) * a->len); + return; + } + + while (i < b->len) + { + blo = b->ranges[i].lo; + bhi = b->ranges[i].hi; + for (n = blo; n <= bhi; n++) + { + if (scm_i_charset_get (a, n)) + scm_i_charset_unset (a, n); + else + scm_i_charset_set (a, n); + } + + i++; + } + return; +} /* Smob print hook for character sets. */ static int charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED) { - int i; + size_t i; int first = 1; + scm_t_char_set *p; + const size_t max_ranges_to_print = 50; + + p = SCM_CHARSET_DATA (charset); scm_puts ("#<charset {", port); - for (i = 0; i < SCM_CHARSET_SIZE; i++) - if (SCM_CHARSET_GET (charset, i)) - { - if (first) - first = 0; - else - scm_puts (" ", port); - scm_write (SCM_MAKE_CHAR (i), port); - } + for (i = 0; i < p->len; i++) + { + if (first) + first = 0; + else + scm_puts (" ", port); + scm_write (SCM_MAKE_CHAR (p->ranges[i].lo), port); + if (p->ranges[i].lo != p->ranges[i].hi) + { + scm_puts ("..", port); + scm_write (SCM_MAKE_CHAR (p->ranges[i].hi), port); + } + if (i >= max_ranges_to_print) + { + /* Too many to print here. Quit early. */ + scm_puts (" ...", port); + break; + } + } scm_puts ("}>", port); return 1; } +/* Smob print hook for character sets cursors. */ +static int +charset_cursor_print (SCM cursor, SCM port, + scm_print_state *pstate SCM_UNUSED) +{ + scm_t_char_set_cursor *cur; + + cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor); + + scm_puts ("#<charset-cursor ", port); + if (cur->range == (size_t) (-1)) + scm_puts ("(empty)", port); + else + { + scm_write (scm_from_size_t (cur->range), port); + scm_puts (":", port); + scm_write (scm_from_int32 (cur->n), port); + } + scm_puts (">", port); + return 1; +} /* Create a new, empty character set. */ static SCM -make_char_set (const char * func_name) +make_char_set (const char *func_name) { - long * p; + scm_t_char_set *p; - p = scm_gc_malloc (BYTES_PER_CHARSET, "character-set"); - memset (p, 0, BYTES_PER_CHARSET); + p = scm_gc_malloc (sizeof (scm_t_char_set), "character-set"); + memset (p, 0, sizeof (scm_t_char_set)); SCM_RETURN_NEWSMOB (scm_tc16_charset, p); } @@ -97,22 +550,22 @@ SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1, #define FUNC_NAME s_scm_char_set_eq { int argnum = 1; - long *cs1_data = NULL; + scm_t_char_set *cs1_data = NULL; SCM_VALIDATE_REST_ARGUMENT (char_sets); while (!scm_is_null (char_sets)) { SCM csi = SCM_CAR (char_sets); - long *csi_data; + scm_t_char_set *csi_data; SCM_VALIDATE_SMOB (argnum, csi, charset); argnum++; - csi_data = (long *) SCM_SMOB_DATA (csi); + csi_data = SCM_CHARSET_DATA (csi); if (cs1_data == NULL) - cs1_data = csi_data; - else if (memcmp (cs1_data, csi_data, BYTES_PER_CHARSET) != 0) - return SCM_BOOL_F; + cs1_data = csi_data; + else if (!charsets_equal (cs1_data, csi_data)) + return SCM_BOOL_F; char_sets = SCM_CDR (char_sets); } return SCM_BOOL_T; @@ -127,28 +580,23 @@ SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1, #define FUNC_NAME s_scm_char_set_leq { int argnum = 1; - long *prev_data = NULL; + scm_t_char_set *prev_data = NULL; SCM_VALIDATE_REST_ARGUMENT (char_sets); while (!scm_is_null (char_sets)) { SCM csi = SCM_CAR (char_sets); - long *csi_data; + scm_t_char_set *csi_data; SCM_VALIDATE_SMOB (argnum, csi, charset); argnum++; - csi_data = (long *) SCM_SMOB_DATA (csi); + csi_data = SCM_CHARSET_DATA (csi); if (prev_data) - { - int k; - - for (k = 0; k < LONGS_PER_CHARSET; k++) - { - if ((prev_data[k] & csi_data[k]) != prev_data[k]) - return SCM_BOOL_F; - } - } + { + if (!charsets_leq (prev_data, csi_data)) + return SCM_BOOL_F; + } prev_data = csi_data; char_sets = SCM_CDR (char_sets); } @@ -166,9 +614,10 @@ SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, { const unsigned long default_bnd = 871; unsigned long bnd; - long * p; + scm_t_char_set *p; unsigned long val = 0; int k; + scm_t_wchar c; SCM_VALIDATE_SMOB (1, cs, charset); @@ -178,14 +627,14 @@ SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, { bnd = scm_to_ulong (bound); if (bnd == 0) - bnd = default_bnd; + bnd = default_bnd; } - p = (long *) SCM_SMOB_DATA (cs); - for (k = 0; k < LONGS_PER_CHARSET; k++) + p = SCM_CHARSET_DATA (cs); + for (k = 0; k < p->len; k++) { - if (p[k] != 0) - val = p[k] + (val << 1); + for (c = p->ranges[k].lo; c <= p->ranges[k].hi; c++) + val = c + (val << 1); } return scm_from_ulong (val % bnd); } @@ -193,89 +642,150 @@ SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, SCM_DEFINE (scm_char_set_cursor, "char-set-cursor", 1, 0, 0, - (SCM cs), - "Return a cursor into the character set @var{cs}.") + (SCM cs), "Return a cursor into the character set @var{cs}.") #define FUNC_NAME s_scm_char_set_cursor { - int idx; + scm_t_char_set *cs_data; + scm_t_char_set_cursor *cur_data; SCM_VALIDATE_SMOB (1, cs, charset); - for (idx = 0; idx < SCM_CHARSET_SIZE; idx++) + cs_data = SCM_CHARSET_DATA (cs); + cur_data = + (scm_t_char_set_cursor *) scm_gc_malloc (sizeof (scm_t_char_set_cursor), + "charset-cursor"); + if (cs_data->len == 0) { - if (SCM_CHARSET_GET (cs, idx)) - break; + cur_data->range = (size_t) (-1); + cur_data->n = 0; } - return SCM_I_MAKINUM (idx); + else + { + cur_data->range = 0; + cur_data->n = cs_data->ranges[0].lo; + } + SCM_RETURN_NEWSMOB (scm_tc16_charset_cursor, cur_data); } #undef FUNC_NAME SCM_DEFINE (scm_char_set_ref, "char-set-ref", 2, 0, 0, - (SCM cs, SCM cursor), - "Return the character at the current cursor position\n" - "@var{cursor} in the character set @var{cs}. It is an error to\n" - "pass a cursor for which @code{end-of-char-set?} returns true.") + (SCM cs, SCM cursor), + "Return the character at the current cursor position\n" + "@var{cursor} in the character set @var{cs}. It is an error to\n" + "pass a cursor for which @code{end-of-char-set?} returns true.") #define FUNC_NAME s_scm_char_set_ref { - size_t ccursor = scm_to_size_t (cursor); + scm_t_char_set *cs_data; + scm_t_char_set_cursor *cur_data; + size_t i; + SCM_VALIDATE_SMOB (1, cs, charset); + SCM_VALIDATE_SMOB (2, cursor, charset_cursor); - if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) + cs_data = SCM_CHARSET_DATA (cs); + cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor); + + /* Validate that this cursor is still true. */ + i = cur_data->range; + if (i == (size_t) (-1) + || i >= cs_data->len + || cur_data->n < cs_data->ranges[i].lo + || cur_data->n > cs_data->ranges[i].hi) SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor)); - return SCM_MAKE_CHAR (ccursor); + return SCM_MAKE_CHAR (cur_data->n); } #undef FUNC_NAME SCM_DEFINE (scm_char_set_cursor_next, "char-set-cursor-next", 2, 0, 0, - (SCM cs, SCM cursor), - "Advance the character set cursor @var{cursor} to the next\n" - "character in the character set @var{cs}. It is an error if the\n" - "cursor given satisfies @code{end-of-char-set?}.") + (SCM cs, SCM cursor), + "Advance the character set cursor @var{cursor} to the next\n" + "character in the character set @var{cs}. It is an error if the\n" + "cursor given satisfies @code{end-of-char-set?}.") #define FUNC_NAME s_scm_char_set_cursor_next { - size_t ccursor = scm_to_size_t (cursor); + scm_t_char_set *cs_data; + scm_t_char_set_cursor *cur_data; + size_t i; + SCM_VALIDATE_SMOB (1, cs, charset); + SCM_VALIDATE_SMOB (2, cursor, charset_cursor); + + cs_data = SCM_CHARSET_DATA (cs); + cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor); - if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) + /* Validate that this cursor is still true. */ + i = cur_data->range; + if (i == (size_t) (-1) + || i >= cs_data->len + || cur_data->n < cs_data->ranges[i].lo + || cur_data->n > cs_data->ranges[i].hi) SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor)); - for (ccursor++; ccursor < SCM_CHARSET_SIZE; ccursor++) + /* Increment the cursor. */ + if (cur_data->n == cs_data->ranges[i].hi) { - if (SCM_CHARSET_GET (cs, ccursor)) - break; + if (i + 1 < cs_data->len) + { + cur_data->range = i + 1; + cur_data->n = cs_data->ranges[i + 1].lo; + } + else + { + /* This is the end of the road. */ + cur_data->range = (size_t) (-1); + cur_data->n = 0; + } } - return SCM_I_MAKINUM (ccursor); + else + { + cur_data->n = cur_data->n + 1; + } + + return cursor; } #undef FUNC_NAME SCM_DEFINE (scm_end_of_char_set_p, "end-of-char-set?", 1, 0, 0, - (SCM cursor), - "Return @code{#t} if @var{cursor} has reached the end of a\n" - "character set, @code{#f} otherwise.") + (SCM cursor), + "Return @code{#t} if @var{cursor} has reached the end of a\n" + "character set, @code{#f} otherwise.") #define FUNC_NAME s_scm_end_of_char_set_p { - size_t ccursor = scm_to_size_t (cursor); - return scm_from_bool (ccursor >= SCM_CHARSET_SIZE); + scm_t_char_set_cursor *cur_data; + SCM_VALIDATE_SMOB (1, cursor, charset_cursor); + + cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor); + if (cur_data->range == (size_t) (-1)) + return SCM_BOOL_T; + + return SCM_BOOL_F; } #undef FUNC_NAME SCM_DEFINE (scm_char_set_fold, "char-set-fold", 3, 0, 0, - (SCM kons, SCM knil, SCM cs), - "Fold the procedure @var{kons} over the character set @var{cs},\n" - "initializing it with @var{knil}.") + (SCM kons, SCM knil, SCM cs), + "Fold the procedure @var{kons} over the character set @var{cs},\n" + "initializing it with @var{knil}.") #define FUNC_NAME s_scm_char_set_fold { + scm_t_char_set *cs_data; int k; + scm_t_wchar n; SCM_VALIDATE_PROC (1, kons); SCM_VALIDATE_SMOB (3, cs, charset); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) + cs_data = SCM_CHARSET_DATA (cs); + + if (cs_data->len == 0) + return knil; + + for (k = 0; k < cs_data->len; k++) + for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++) { - knil = scm_call_2 (kons, SCM_MAKE_CHAR (k), knil); + knil = scm_call_2 (kons, SCM_MAKE_CHAR (n), knil); } return knil; } @@ -365,19 +875,29 @@ SCM_DEFINE (scm_char_set_unfold_x, "char-set-unfold!", 5, 0, 0, SCM_DEFINE (scm_char_set_for_each, "char-set-for-each", 2, 0, 0, - (SCM proc, SCM cs), - "Apply @var{proc} to every character in the character set\n" - "@var{cs}. The return value is not specified.") + (SCM proc, SCM cs), + "Apply @var{proc} to every character in the character set\n" + "@var{cs}. The return value is not specified.") #define FUNC_NAME s_scm_char_set_for_each { + scm_t_char_set *cs_data; int k; + scm_t_wchar n; SCM_VALIDATE_PROC (1, proc); SCM_VALIDATE_SMOB (2, cs, charset); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) - scm_call_1 (proc, SCM_MAKE_CHAR (k)); + cs_data = SCM_CHARSET_DATA (cs); + + if (cs_data->len == 0) + return SCM_UNSPECIFIED; + + for (k = 0; k < cs_data->len; k++) + for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++) + { + scm_call_1 (proc, SCM_MAKE_CHAR (n)); + } + return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -391,18 +911,26 @@ SCM_DEFINE (scm_char_set_map, "char-set-map", 2, 0, 0, { SCM result; int k; + scm_t_char_set *cs_data; + scm_t_wchar n; SCM_VALIDATE_PROC (1, proc); SCM_VALIDATE_SMOB (2, cs, charset); result = make_char_set (FUNC_NAME); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) + cs_data = SCM_CHARSET_DATA (cs); + + if (cs_data->len == 0) + return result; + + for (k = 0; k < cs_data->len; k++) + for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++) { - SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (k)); - if (!SCM_CHARP (ch)) - SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); - SCM_CHARSET_SET (result, SCM_CHAR (ch)); + SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (n)); + if (!SCM_CHARP (ch)) + SCM_MISC_ERROR ("procedure ~S returned non-char", + scm_list_1 (proc)); + SCM_CHARSET_SET (result, SCM_CHAR (ch)); } return result; } @@ -416,15 +944,23 @@ SCM_DEFINE (scm_char_set_copy, "char-set-copy", 1, 0, 0, #define FUNC_NAME s_scm_char_set_copy { SCM ret; - long * p1, * p2; - int k; + scm_t_char_set *p1, *p2; SCM_VALIDATE_SMOB (1, cs, charset); ret = make_char_set (FUNC_NAME); - p1 = (long *) SCM_SMOB_DATA (cs); - p2 = (long *) SCM_SMOB_DATA (ret); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p2[k] = p1[k]; + p1 = SCM_CHARSET_DATA (cs); + p2 = SCM_CHARSET_DATA (ret); + p2->len = p1->len; + + if (p1->len == 0) + p2->ranges = NULL; + else + { + p2->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * p1->len, + "character-set"); + memcpy (p2->ranges, p1->ranges, sizeof (scm_t_char_range) * p1->len); + } + return ret; } #undef FUNC_NAME @@ -436,20 +972,18 @@ SCM_DEFINE (scm_char_set, "char-set", 0, 0, 1, #define FUNC_NAME s_scm_char_set { SCM cs; - long * p; int argnum = 1; SCM_VALIDATE_REST_ARGUMENT (rest); cs = make_char_set (FUNC_NAME); - p = (long *) SCM_SMOB_DATA (cs); while (!scm_is_null (rest)) { - int c; + scm_t_wchar c; SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c); argnum++; rest = SCM_CDR (rest); - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + SCM_CHARSET_SET (cs, c); } return cs; } @@ -464,7 +998,6 @@ SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0, #define FUNC_NAME s_scm_list_to_char_set { SCM cs; - long * p; SCM_VALIDATE_LIST (1, list); if (SCM_UNBNDP (base_cs)) @@ -474,16 +1007,16 @@ SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0, SCM_VALIDATE_SMOB (2, base_cs, charset); cs = scm_char_set_copy (base_cs); } - p = (long *) SCM_SMOB_DATA (cs); while (!scm_is_null (list)) { SCM chr = SCM_CAR (list); - int c; + scm_t_wchar c; SCM_VALIDATE_CHAR_COPY (0, chr, c); list = SCM_CDR (list); - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + + SCM_CHARSET_SET (cs, c); } return cs; } @@ -491,26 +1024,23 @@ SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0, SCM_DEFINE (scm_list_to_char_set_x, "list->char-set!", 2, 0, 0, - (SCM list, SCM base_cs), - "Convert the character list @var{list} to a character set. The\n" - "characters are added to @var{base_cs} and @var{base_cs} is\n" - "returned.") + (SCM list, SCM base_cs), + "Convert the character list @var{list} to a character set. The\n" + "characters are added to @var{base_cs} and @var{base_cs} is\n" + "returned.") #define FUNC_NAME s_scm_list_to_char_set_x { - long * p; - SCM_VALIDATE_LIST (1, list); SCM_VALIDATE_SMOB (2, base_cs, charset); - p = (long *) SCM_SMOB_DATA (base_cs); while (!scm_is_null (list)) { SCM chr = SCM_CAR (list); - int c; + scm_t_wchar c; SCM_VALIDATE_CHAR_COPY (0, chr, c); list = SCM_CDR (list); - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + SCM_CHARSET_SET (base_cs, c); } return base_cs; } @@ -525,8 +1055,6 @@ SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0, #define FUNC_NAME s_scm_string_to_char_set { SCM cs; - long * p; - const char * s; size_t k = 0, len; SCM_VALIDATE_STRING (1, str); @@ -537,13 +1065,11 @@ SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0, SCM_VALIDATE_SMOB (2, base_cs, charset); cs = scm_char_set_copy (base_cs); } - p = (long *) SCM_SMOB_DATA (cs); - s = scm_i_string_chars (str); len = scm_i_string_length (str); while (k < len) { - int c = s[k++]; - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + scm_t_wchar c = scm_i_string_ref (str, k++); + SCM_CHARSET_SET (cs, c); } scm_remember_upto_here_1 (str); return cs; @@ -552,25 +1078,21 @@ SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0, SCM_DEFINE (scm_string_to_char_set_x, "string->char-set!", 2, 0, 0, - (SCM str, SCM base_cs), - "Convert the string @var{str} to a character set. The\n" - "characters from the string are added to @var{base_cs}, and\n" - "@var{base_cs} is returned.") + (SCM str, SCM base_cs), + "Convert the string @var{str} to a character set. The\n" + "characters from the string are added to @var{base_cs}, and\n" + "@var{base_cs} is returned.") #define FUNC_NAME s_scm_string_to_char_set_x { - long * p; - const char * s; size_t k = 0, len; SCM_VALIDATE_STRING (1, str); SCM_VALIDATE_SMOB (2, base_cs, charset); - p = (long *) SCM_SMOB_DATA (base_cs); - s = scm_i_string_chars (str); len = scm_i_string_length (str); while (k < len) { - int c = s[k++]; - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + scm_t_wchar c = scm_i_string_ref (str, k++); + SCM_CHARSET_SET (base_cs, c); } scm_remember_upto_here_1 (str); return base_cs; @@ -587,7 +1109,8 @@ SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0, { SCM ret; int k; - long * p; + scm_t_wchar n; + scm_t_char_set *p; SCM_VALIDATE_PROC (1, pred); SCM_VALIDATE_SMOB (2, cs, charset); @@ -598,17 +1121,20 @@ SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0, } else ret = make_char_set (FUNC_NAME); - p = (long *) SCM_SMOB_DATA (ret); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - { - if (SCM_CHARSET_GET (cs, k)) - { - SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); - if (scm_is_true (res)) - p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG); - } - } + p = SCM_CHARSET_DATA (cs); + + if (p->len == 0) + return ret; + + for (k = 0; k < p->len; k++) + for (n = p->ranges[k].lo; n <= p->ranges[k].hi; n++) + { + SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n)); + + if (scm_is_true (res)) + SCM_CHARSET_SET (ret, n); + } return ret; } #undef FUNC_NAME @@ -622,22 +1148,24 @@ SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0, #define FUNC_NAME s_scm_char_set_filter_x { int k; - long * p; + scm_t_wchar n; + scm_t_char_set *p; SCM_VALIDATE_PROC (1, pred); SCM_VALIDATE_SMOB (2, cs, charset); SCM_VALIDATE_SMOB (3, base_cs, charset); - p = (long *) SCM_SMOB_DATA (base_cs); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - { - if (SCM_CHARSET_GET (cs, k)) - { - SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); + p = SCM_CHARSET_DATA (cs); + if (p->len == 0) + return base_cs; - if (scm_is_true (res)) - p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG); - } - } + for (k = 0; k < p->len; k++) + for (n = p->ranges[k].lo; n <= p->ranges[k].hi; n++) + { + SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); + + if (scm_is_true (res)) + SCM_CHARSET_SET (base_cs, n); + } return base_cs; } #undef FUNC_NAME @@ -661,7 +1189,6 @@ SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0, { SCM cs; size_t clower, cupper; - long * p; clower = scm_to_size_t (lower); cupper = scm_to_size_t (upper); @@ -669,15 +1196,15 @@ SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0, if (!SCM_UNBNDP (error)) { if (scm_is_true (error)) - { - SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE); - SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE); - } + { + SCM_ASSERT_RANGE (1, lower, SCM_IS_UNICODE_CHAR (clower)); + SCM_ASSERT_RANGE (2, upper, SCM_IS_UNICODE_CHAR (cupper)); + } } - if (clower > SCM_CHARSET_SIZE) - clower = SCM_CHARSET_SIZE; - if (cupper > SCM_CHARSET_SIZE) - cupper = SCM_CHARSET_SIZE; + if (clower > 0x10FFFF) + clower = 0x10FFFF; + if (cupper > 0x10FFFF) + cupper = 0x10FFFF; if (SCM_UNBNDP (base_cs)) cs = make_char_set (FUNC_NAME); else @@ -685,10 +1212,11 @@ SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0, SCM_VALIDATE_SMOB (4, base_cs, charset); cs = scm_char_set_copy (base_cs); } - p = (long *) SCM_SMOB_DATA (cs); + /* It not be difficult to write a more optimized version of the + following. */ while (clower < cupper) { - p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG); + SCM_CHARSET_SET (cs, clower); clower++; } return cs; @@ -713,24 +1241,24 @@ SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0, #define FUNC_NAME s_scm_ucs_range_to_char_set_x { size_t clower, cupper; - long * p; clower = scm_to_size_t (lower); cupper = scm_to_size_t (upper); SCM_ASSERT_RANGE (2, upper, cupper >= clower); if (scm_is_true (error)) { - SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE); - SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE); + SCM_ASSERT_RANGE (1, lower, SCM_IS_UNICODE_CHAR (clower)); + SCM_ASSERT_RANGE (2, upper, SCM_IS_UNICODE_CHAR (cupper)); } - if (clower > SCM_CHARSET_SIZE) - clower = SCM_CHARSET_SIZE; - if (cupper > SCM_CHARSET_SIZE) - cupper = SCM_CHARSET_SIZE; - p = (long *) SCM_SMOB_DATA (base_cs); + if (clower > SCM_CODEPOINT_MAX) + clower = SCM_CODEPOINT_MAX; + if (cupper > SCM_CODEPOINT_MAX) + cupper = SCM_CODEPOINT_MAX; + while (clower < cupper) { - p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG); + if (SCM_IS_UNICODE_CHAR (clower)) + SCM_CHARSET_SET (base_cs, clower); clower++; } return base_cs; @@ -759,12 +1287,18 @@ SCM_DEFINE (scm_char_set_size, "char-set-size", 1, 0, 0, #define FUNC_NAME s_scm_char_set_size { int k, count = 0; + scm_t_char_set *cs_data; SCM_VALIDATE_SMOB (1, cs, charset); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) - count++; - return SCM_I_MAKINUM (count); + cs_data = SCM_CHARSET_DATA (cs); + + if (cs_data->len == 0) + return scm_from_int (0); + + for (k = 0; k < cs_data->len; k++) + count += cs_data->ranges[k].hi - cs_data->ranges[k].lo + 1; + + return scm_from_int (count); } #undef FUNC_NAME @@ -776,16 +1310,21 @@ SCM_DEFINE (scm_char_set_count, "char-set-count", 2, 0, 0, #define FUNC_NAME s_scm_char_set_count { int k, count = 0; + scm_t_wchar n; + scm_t_char_set *cs_data; SCM_VALIDATE_PROC (1, pred); SCM_VALIDATE_SMOB (2, cs, charset); + cs_data = SCM_CHARSET_DATA (cs); + if (cs_data->len == 0) + return scm_from_int (0); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) + for (k = 0; k < cs_data->len; k++) + for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++) { - SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); - if (scm_is_true (res)) - count++; + SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n)); + if (scm_is_true (res)) + count++; } return SCM_I_MAKINUM (count); } @@ -799,12 +1338,18 @@ SCM_DEFINE (scm_char_set_to_list, "char-set->list", 1, 0, 0, #define FUNC_NAME s_scm_char_set_to_list { int k; + scm_t_wchar n; SCM result = SCM_EOL; + scm_t_char_set *p; SCM_VALIDATE_SMOB (1, cs, charset); - for (k = SCM_CHARSET_SIZE; k > 0; k--) - if (SCM_CHARSET_GET (cs, k - 1)) - result = scm_cons (SCM_MAKE_CHAR (k - 1), result); + p = SCM_CHARSET_DATA (cs); + if (p->len == 0) + return SCM_EOL; + + for (k = p->len - 1; k >= 0; k--) + for (n = p->ranges[k].hi; n >= p->ranges[k].lo; n--) + result = scm_cons (SCM_MAKE_CHAR (n), result); return result; } #undef FUNC_NAME @@ -820,17 +1365,35 @@ SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0, int k; int count = 0; int idx = 0; + int wide = 0; SCM result; - char * p; + scm_t_wchar n; + scm_t_char_set *cs_data; + char *buf; + scm_t_wchar *wbuf; SCM_VALIDATE_SMOB (1, cs, charset); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) - count++; - result = scm_i_make_string (count, &p); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) - p[idx++] = k; + cs_data = SCM_CHARSET_DATA (cs); + if (cs_data->len == 0) + return scm_nullstr; + + if (cs_data->ranges[cs_data->len - 1].hi > 255) + wide = 1; + + count = scm_to_int (scm_char_set_size (cs)); + if (wide) + result = scm_i_make_wide_string (count, &wbuf); + else + result = scm_i_make_string (count, &buf); + + for (k = 0; k < cs_data->len; k++) + for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++) + { + if (wide) + wbuf[idx++] = n; + else + buf[idx++] = n; + } return result; } #undef FUNC_NAME @@ -856,19 +1419,25 @@ SCM_DEFINE (scm_char_set_every, "char-set-every", 2, 0, 0, #define FUNC_NAME s_scm_char_set_every { int k; + scm_t_wchar n; SCM res = SCM_BOOL_T; + scm_t_char_set *cs_data; SCM_VALIDATE_PROC (1, pred); SCM_VALIDATE_SMOB (2, cs, charset); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) + cs_data = SCM_CHARSET_DATA (cs); + if (cs_data->len == 0) + return SCM_BOOL_T; + + for (k = 0; k < cs_data->len; k++) + for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++) { - res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); - if (scm_is_false (res)) - return res; + res = scm_call_1 (pred, SCM_MAKE_CHAR (n)); + if (scm_is_false (res)) + return res; } - return res; + return SCM_BOOL_T; } #undef FUNC_NAME @@ -880,16 +1449,20 @@ SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0, #define FUNC_NAME s_scm_char_set_any { int k; + scm_t_wchar n; + scm_t_char_set *cs_data; SCM_VALIDATE_PROC (1, pred); SCM_VALIDATE_SMOB (2, cs, charset); - for (k = 0; k < SCM_CHARSET_SIZE; k++) - if (SCM_CHARSET_GET (cs, k)) + cs_data = (scm_t_char_set *) cs; + + for (k = 0; k < cs_data->len; k++) + for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++) { - SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); - if (scm_is_true (res)) - return res; + SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n)); + if (scm_is_true (res)) + return res; } return SCM_BOOL_F; } @@ -897,27 +1470,24 @@ SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0, SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1, - (SCM cs, SCM rest), - "Add all character arguments to the first argument, which must\n" - "be a character set.") + (SCM cs, SCM rest), + "Add all character arguments to the first argument, which must\n" + "be a character set.") #define FUNC_NAME s_scm_char_set_adjoin { - long * p; - SCM_VALIDATE_SMOB (1, cs, charset); SCM_VALIDATE_REST_ARGUMENT (rest); cs = scm_char_set_copy (cs); - p = (long *) SCM_SMOB_DATA (cs); while (!scm_is_null (rest)) { SCM chr = SCM_CAR (rest); - int c; + scm_t_wchar c; SCM_VALIDATE_CHAR_COPY (1, chr, c); rest = SCM_CDR (rest); - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + SCM_CHARSET_SET (cs, c); } return cs; } @@ -925,27 +1495,24 @@ SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1, SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1, - (SCM cs, SCM rest), - "Delete all character arguments from the first argument, which\n" - "must be a character set.") + (SCM cs, SCM rest), + "Delete all character arguments from the first argument, which\n" + "must be a character set.") #define FUNC_NAME s_scm_char_set_delete { - long * p; - SCM_VALIDATE_SMOB (1, cs, charset); SCM_VALIDATE_REST_ARGUMENT (rest); cs = scm_char_set_copy (cs); - p = (long *) SCM_SMOB_DATA (cs); while (!scm_is_null (rest)) { SCM chr = SCM_CAR (rest); - int c; + scm_t_wchar c; SCM_VALIDATE_CHAR_COPY (1, chr, c); rest = SCM_CDR (rest); - p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG)); + SCM_CHARSET_UNSET (cs, c); } return cs; } @@ -953,26 +1520,23 @@ SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1, SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1, - (SCM cs, SCM rest), - "Add all character arguments to the first argument, which must\n" - "be a character set.") + (SCM cs, SCM rest), + "Add all character arguments to the first argument, which must\n" + "be a character set.") #define FUNC_NAME s_scm_char_set_adjoin_x { - long * p; - SCM_VALIDATE_SMOB (1, cs, charset); SCM_VALIDATE_REST_ARGUMENT (rest); - p = (long *) SCM_SMOB_DATA (cs); while (!scm_is_null (rest)) { SCM chr = SCM_CAR (rest); - int c; + scm_t_wchar c; SCM_VALIDATE_CHAR_COPY (1, chr, c); rest = SCM_CDR (rest); - p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); + SCM_CHARSET_SET (cs, c); } return cs; } @@ -980,26 +1544,23 @@ SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1, SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1, - (SCM cs, SCM rest), - "Delete all character arguments from the first argument, which\n" - "must be a character set.") + (SCM cs, SCM rest), + "Delete all character arguments from the first argument, which\n" + "must be a character set.") #define FUNC_NAME s_scm_char_set_delete_x { - long * p; - SCM_VALIDATE_SMOB (1, cs, charset); SCM_VALIDATE_REST_ARGUMENT (rest); - p = (long *) SCM_SMOB_DATA (cs); while (!scm_is_null (rest)) { SCM chr = SCM_CAR (rest); - int c; + scm_t_wchar c; SCM_VALIDATE_CHAR_COPY (1, chr, c); rest = SCM_CDR (rest); - p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG)); + SCM_CHARSET_UNSET (cs, c); } return cs; } @@ -1007,21 +1568,19 @@ SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1, SCM_DEFINE (scm_char_set_complement, "char-set-complement", 1, 0, 0, - (SCM cs), - "Return the complement of the character set @var{cs}.") + (SCM cs), "Return the complement of the character set @var{cs}.") #define FUNC_NAME s_scm_char_set_complement { - int k; SCM res; - long * p, * q; + scm_t_char_set *p, *q; SCM_VALIDATE_SMOB (1, cs, charset); res = make_char_set (FUNC_NAME); - p = (long *) SCM_SMOB_DATA (res); - q = (long *) SCM_SMOB_DATA (cs); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] = ~q[k]; + p = SCM_CHARSET_DATA (res); + q = SCM_CHARSET_DATA (cs); + + charsets_complement (p, q); return res; } #undef FUNC_NAME @@ -1034,22 +1593,21 @@ SCM_DEFINE (scm_char_set_union, "char-set-union", 0, 0, 1, { int c = 1; SCM res; - long * p; + scm_t_char_set *p; SCM_VALIDATE_REST_ARGUMENT (rest); res = make_char_set (FUNC_NAME); - p = (long *) SCM_SMOB_DATA (res); + p = SCM_CHARSET_DATA (res); while (!scm_is_null (rest)) { - int k; SCM cs = SCM_CAR (rest); SCM_VALIDATE_SMOB (c, cs, charset); c++; rest = SCM_CDR (rest); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] |= ((long *) SCM_SMOB_DATA (cs))[k]; + + charsets_union (p, (scm_t_char_set *) SCM_SMOB_DATA (cs)); } return res; } @@ -1069,26 +1627,24 @@ SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 0, 0, 1, res = make_char_set (FUNC_NAME); else { - long *p; + scm_t_char_set *p; int argnum = 2; res = scm_char_set_copy (SCM_CAR (rest)); - p = (long *) SCM_SMOB_DATA (res); + p = SCM_CHARSET_DATA (res); rest = SCM_CDR (rest); while (scm_is_pair (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - long *cs_data; - - SCM_VALIDATE_SMOB (argnum, cs, charset); - argnum++; - cs_data = (long *) SCM_SMOB_DATA (cs); - rest = SCM_CDR (rest); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] &= cs_data[k]; - } + { + SCM cs = SCM_CAR (rest); + scm_t_char_set *cs_data; + + SCM_VALIDATE_SMOB (argnum, cs, charset); + argnum++; + cs_data = SCM_CHARSET_DATA (cs); + rest = SCM_CDR (rest); + charsets_intersection (p, cs_data); + } } return res; @@ -1102,24 +1658,25 @@ SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1, #define FUNC_NAME s_scm_char_set_difference { int c = 2; - SCM res; - long * p; + SCM res, compl; + scm_t_char_set *p, *q; SCM_VALIDATE_SMOB (1, cs1, charset); SCM_VALIDATE_REST_ARGUMENT (rest); res = scm_char_set_copy (cs1); - p = (long *) SCM_SMOB_DATA (res); + p = SCM_CHARSET_DATA (res); + compl = make_char_set (FUNC_NAME); + q = SCM_CHARSET_DATA (compl); while (!scm_is_null (rest)) { - int k; SCM cs = SCM_CAR (rest); SCM_VALIDATE_SMOB (c, cs, charset); c++; rest = SCM_CDR (rest); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; + charsets_complement (q, SCM_CHARSET_DATA (cs)); + charsets_intersection (p, q); } return res; } @@ -1140,26 +1697,24 @@ SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1, else { int argnum = 2; - long * p; + scm_t_char_set *p; res = scm_char_set_copy (SCM_CAR (rest)); - p = (long *) SCM_SMOB_DATA (res); + p = SCM_CHARSET_DATA (res); rest = SCM_CDR (rest); while (scm_is_pair (rest)) - { - SCM cs = SCM_CAR (rest); - long *cs_data; - int k; - - SCM_VALIDATE_SMOB (argnum, cs, charset); - argnum++; - cs_data = (long *) SCM_SMOB_DATA (cs); - rest = SCM_CDR (rest); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] ^= cs_data[k]; - } + { + SCM cs = SCM_CAR (rest); + scm_t_char_set *cs_data; + + SCM_VALIDATE_SMOB (argnum, cs, charset); + argnum++; + cs_data = SCM_CHARSET_DATA (cs); + rest = SCM_CDR (rest); + + charsets_xor (p, cs_data); + } } return res; } @@ -1174,30 +1729,26 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1 { int c = 2; SCM res1, res2; - long * p, * q; + scm_t_char_set *p, *q; SCM_VALIDATE_SMOB (1, cs1, charset); SCM_VALIDATE_REST_ARGUMENT (rest); res1 = scm_char_set_copy (cs1); res2 = make_char_set (FUNC_NAME); - p = (long *) SCM_SMOB_DATA (res1); - q = (long *) SCM_SMOB_DATA (res2); + p = SCM_CHARSET_DATA (res1); + q = SCM_CHARSET_DATA (res2); while (!scm_is_null (rest)) { - int k; SCM cs = SCM_CAR (rest); - long *r; + scm_t_char_set *r; SCM_VALIDATE_SMOB (c, cs, charset); c++; - r = (long *) SCM_SMOB_DATA (cs); + r = SCM_CHARSET_DATA (cs); - for (k = 0; k < LONGS_PER_CHARSET; k++) - { - q[k] |= p[k] & r[k]; - p[k] &= ~r[k]; - } + charsets_union (q, r); + charsets_intersection (p, r); rest = SCM_CDR (rest); } return scm_values (scm_list_2 (res1, res2)); @@ -1206,101 +1757,53 @@ SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1 SCM_DEFINE (scm_char_set_complement_x, "char-set-complement!", 1, 0, 0, - (SCM cs), - "Return the complement of the character set @var{cs}.") + (SCM cs), "Return the complement of the character set @var{cs}.") #define FUNC_NAME s_scm_char_set_complement_x { - int k; - long * p; - SCM_VALIDATE_SMOB (1, cs, charset); - p = (long *) SCM_SMOB_DATA (cs); - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] = ~p[k]; + cs = scm_char_set_complement (cs); return cs; } #undef FUNC_NAME SCM_DEFINE (scm_char_set_union_x, "char-set-union!", 1, 0, 1, - (SCM cs1, SCM rest), - "Return the union of all argument character sets.") + (SCM cs1, SCM rest), + "Return the union of all argument character sets.") #define FUNC_NAME s_scm_char_set_union_x { - int c = 2; - long * p; - SCM_VALIDATE_SMOB (1, cs1, charset); SCM_VALIDATE_REST_ARGUMENT (rest); - p = (long *) SCM_SMOB_DATA (cs1); - while (!scm_is_null (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - rest = SCM_CDR (rest); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] |= ((long *) SCM_SMOB_DATA (cs))[k]; - } + cs1 = scm_char_set_union (scm_cons (cs1, rest)); return cs1; } #undef FUNC_NAME SCM_DEFINE (scm_char_set_intersection_x, "char-set-intersection!", 1, 0, 1, - (SCM cs1, SCM rest), - "Return the intersection of all argument character sets.") + (SCM cs1, SCM rest), + "Return the intersection of all argument character sets.") #define FUNC_NAME s_scm_char_set_intersection_x { - int c = 2; - long * p; - SCM_VALIDATE_SMOB (1, cs1, charset); SCM_VALIDATE_REST_ARGUMENT (rest); - p = (long *) SCM_SMOB_DATA (cs1); - while (!scm_is_null (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - rest = SCM_CDR (rest); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; - } + cs1 = scm_char_set_intersection (scm_cons (cs1, rest)); return cs1; } #undef FUNC_NAME SCM_DEFINE (scm_char_set_difference_x, "char-set-difference!", 1, 0, 1, - (SCM cs1, SCM rest), - "Return the difference of all argument character sets.") + (SCM cs1, SCM rest), + "Return the difference of all argument character sets.") #define FUNC_NAME s_scm_char_set_difference_x { - int c = 2; - long * p; - SCM_VALIDATE_SMOB (1, cs1, charset); SCM_VALIDATE_REST_ARGUMENT (rest); - p = (long *) SCM_SMOB_DATA (cs1); - while (!scm_is_null (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - rest = SCM_CDR (rest); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; - } + cs1 = scm_char_set_difference (cs1, rest); return cs1; } #undef FUNC_NAME @@ -1315,86 +1818,32 @@ SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1, (define a (char-set #\a)) (char-set-xor a a a) -> char set #\a (char-set-xor! a a a) -> char set #\a - */ + */ return scm_char_set_xor (scm_cons (cs1, rest)); - -#if 0 - /* this would give (char-set-xor! a a a) -> empty char set. */ - int c = 2; - long * p; - - SCM_VALIDATE_SMOB (1, cs1, charset); - SCM_VALIDATE_REST_ARGUMENT (rest); - - p = (long *) SCM_SMOB_DATA (cs1); - while (!scm_is_null (rest)) - { - int k; - SCM cs = SCM_CAR (rest); - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - rest = SCM_CDR (rest); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k]; - } - return cs1; -#endif } #undef FUNC_NAME -SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!", 2, 0, 1, - (SCM cs1, SCM cs2, SCM rest), - "Return the difference and the intersection of all argument\n" - "character sets.") +SCM_DEFINE (scm_char_set_diff_plus_intersection_x, + "char-set-diff+intersection!", 2, 0, 1, (SCM cs1, SCM cs2, + SCM rest), + "Return the difference and the intersection of all argument\n" + "character sets.") #define FUNC_NAME s_scm_char_set_diff_plus_intersection_x { - int c = 3; - long * p, * q; - int k; + SCM diff, intersect; - SCM_VALIDATE_SMOB (1, cs1, charset); - SCM_VALIDATE_SMOB (2, cs2, charset); - SCM_VALIDATE_REST_ARGUMENT (rest); - - p = (long *) SCM_SMOB_DATA (cs1); - q = (long *) SCM_SMOB_DATA (cs2); - if (p == q) - { - /* (char-set-diff+intersection! a a ...): can't share storage, - but we know the answer without checking for further - arguments. */ - return scm_values (scm_list_2 (make_char_set (FUNC_NAME), cs1)); - } - for (k = 0; k < LONGS_PER_CHARSET; k++) - { - long t = p[k]; - - p[k] &= ~q[k]; - q[k] = t & q[k]; - } - while (!scm_is_null (rest)) - { - SCM cs = SCM_CAR (rest); - long *r; - - SCM_VALIDATE_SMOB (c, cs, charset); - c++; - r = (long *) SCM_SMOB_DATA (cs); - - for (k = 0; k < LONGS_PER_CHARSET; k++) - { - q[k] |= p[k] & r[k]; - p[k] &= ~r[k]; - } - rest = SCM_CDR (rest); - } + diff = scm_char_set_difference (cs1, scm_cons (cs2, rest)); + intersect = + scm_char_set_intersection (scm_cons (cs1, scm_cons (cs2, rest))); + cs1 = diff; + cs2 = intersect; return scm_values (scm_list_2 (cs1, cs2)); } #undef FUNC_NAME + /* Standard character sets. */ SCM scm_char_set_lower_case; @@ -1418,146 +1867,77 @@ SCM scm_char_set_full; /* Create an empty character set and return it after binding it to NAME. */ static inline SCM -define_charset (const char *name) +define_charset (const char *name, const scm_t_char_set *p) { - SCM cs = make_char_set (NULL); + SCM cs; + + SCM_NEWSMOB (cs, scm_tc16_charset, p); scm_c_define (name, cs); return scm_permanent_object (cs); } -/* Membership predicates for the various char sets. - - XXX: The `punctuation' and `symbol' char sets have no direct equivalent in - <ctype.h>. Thus, the predicates below yield correct results for ASCII, - but they do not provide the result described by the SRFI for Latin-1. The - correct Latin-1 result could only be obtained by hard-coding the - characters listed by the SRFI, but the problem would remain for other - 8-bit charsets. - - Similarly, character 0xA0 in Latin-1 (unbreakable space, `#\0240') should - be part of `char-set:blank'. However, glibc's current (2006/09) Latin-1 - locales (which use the ISO 14652 "i18n" FDCC-set) do not consider it - `blank' so it ends up in `char-set:punctuation'. */ -#ifdef HAVE_ISBLANK -# define CSET_BLANK_PRED(c) (isblank (c)) -#else -# define CSET_BLANK_PRED(c) \ - (((c) == ' ') || ((c) == '\t')) -#endif - -#define CSET_SYMBOL_PRED(c) \ - (((c) != '\0') && (strchr ("$+<=>^`|~", (c)) != NULL)) -#define CSET_PUNCT_PRED(c) \ - ((ispunct (c)) && (!CSET_SYMBOL_PRED (c))) - -#define CSET_LOWER_PRED(c) (islower (c)) -#define CSET_UPPER_PRED(c) (isupper (c)) -#define CSET_LETTER_PRED(c) (isalpha (c)) -#define CSET_DIGIT_PRED(c) (isdigit (c)) -#define CSET_WHITESPACE_PRED(c) (isspace (c)) -#define CSET_CONTROL_PRED(c) (iscntrl (c)) -#define CSET_HEX_DIGIT_PRED(c) (isxdigit (c)) -#define CSET_ASCII_PRED(c) (isascii (c)) - -/* Some char sets are explicitly defined by the SRFI as a union of other char - sets so we try to follow this closely. */ - -#define CSET_LETTER_AND_DIGIT_PRED(c) \ - (CSET_LETTER_PRED (c) || CSET_DIGIT_PRED (c)) - -#define CSET_GRAPHIC_PRED(c) \ - (CSET_LETTER_PRED (c) || CSET_DIGIT_PRED (c) \ - || CSET_PUNCT_PRED (c) || CSET_SYMBOL_PRED (c)) - -#define CSET_PRINTING_PRED(c) \ - (CSET_GRAPHIC_PRED (c) || CSET_WHITESPACE_PRED (c)) - -/* False and true predicates. */ -#define CSET_TRUE_PRED(c) (1) -#define CSET_FALSE_PRED(c) (0) - - -/* Compute the contents of all the standard character sets. Computation may - need to be re-done at `setlocale'-time because some char sets (e.g., - `char-set:letter') need to reflect the character set supported by Guile. - - For instance, at startup time, the "C" locale is used, thus Guile supports - only ASCII; therefore, `char-set:letter' only contains English letters. - The user can change this by invoking `setlocale' and specifying a locale - with an 8-bit charset, thereby augmenting some of the SRFI-14 standard - character sets. - - This works because some of the predicates used below to construct - character sets (e.g., `isalpha(3)') are locale-dependent (so - charset-dependent, though generally not language-dependent). For details, - please see the `guile-devel' mailing list archive of September 2006. */ -void -scm_srfi_14_compute_char_sets (void) +#ifdef SCM_CHARSET_DEBUG +SCM_DEFINE (scm_debug_char_set, "debug-char-set", 1, 0, 0, + (SCM charset), + "Print out the internal C structure of @var{charset}.\n") +#define FUNC_NAME s_scm_debug_char_set { -#define UPDATE_CSET(c, cset, pred) \ - do \ - { \ - if (pred (c)) \ - SCM_CHARSET_SET ((cset), (c)); \ - else \ - SCM_CHARSET_UNSET ((cset), (c)); \ - } \ - while (0) - - register int ch; - - for (ch = 0; ch < 256; ch++) + int i; + scm_t_char_set *cs = SCM_CHARSET_DATA (charset); + fprintf (stderr, "cs %p\n", cs); + fprintf (stderr, "len %d\n", cs->len); + fprintf (stderr, "arr %p\n", cs->ranges); + for (i = 0; i < cs->len; i++) { - UPDATE_CSET (ch, scm_char_set_upper_case, CSET_UPPER_PRED); - UPDATE_CSET (ch, scm_char_set_lower_case, CSET_LOWER_PRED); - UPDATE_CSET (ch, scm_char_set_title_case, CSET_FALSE_PRED); - UPDATE_CSET (ch, scm_char_set_letter, CSET_LETTER_PRED); - UPDATE_CSET (ch, scm_char_set_digit, CSET_DIGIT_PRED); - UPDATE_CSET (ch, scm_char_set_letter_and_digit, - CSET_LETTER_AND_DIGIT_PRED); - UPDATE_CSET (ch, scm_char_set_graphic, CSET_GRAPHIC_PRED); - UPDATE_CSET (ch, scm_char_set_printing, CSET_PRINTING_PRED); - UPDATE_CSET (ch, scm_char_set_whitespace, CSET_WHITESPACE_PRED); - UPDATE_CSET (ch, scm_char_set_iso_control, CSET_CONTROL_PRED); - UPDATE_CSET (ch, scm_char_set_punctuation, CSET_PUNCT_PRED); - UPDATE_CSET (ch, scm_char_set_symbol, CSET_SYMBOL_PRED); - UPDATE_CSET (ch, scm_char_set_hex_digit, CSET_HEX_DIGIT_PRED); - UPDATE_CSET (ch, scm_char_set_blank, CSET_BLANK_PRED); - UPDATE_CSET (ch, scm_char_set_ascii, CSET_ASCII_PRED); - UPDATE_CSET (ch, scm_char_set_empty, CSET_FALSE_PRED); - UPDATE_CSET (ch, scm_char_set_full, CSET_TRUE_PRED); + if (cs->ranges[i].lo == cs->ranges[i].hi) + fprintf (stderr, "%04x\n", cs->ranges[i].lo); + else + fprintf (stderr, "%04x..%04x\t[%d]\n", + cs->ranges[i].lo, + cs->ranges[i].hi, cs->ranges[i].hi - cs->ranges[i].lo + 1); } - -#undef UPDATE_CSET + printf ("\n"); + return SCM_UNSPECIFIED; } - +#undef FUNC_NAME +#endif /* SCM_CHARSET_DEBUG */ + + void scm_init_srfi_14 (void) { - scm_tc16_charset = scm_make_smob_type ("character-set", - BYTES_PER_CHARSET); + scm_tc16_charset = scm_make_smob_type ("character-set", 0); scm_set_smob_print (scm_tc16_charset, charset_print); - scm_char_set_upper_case = define_charset ("char-set:upper-case"); - scm_char_set_lower_case = define_charset ("char-set:lower-case"); - scm_char_set_title_case = define_charset ("char-set:title-case"); - scm_char_set_letter = define_charset ("char-set:letter"); - scm_char_set_digit = define_charset ("char-set:digit"); - scm_char_set_letter_and_digit = define_charset ("char-set:letter+digit"); - scm_char_set_graphic = define_charset ("char-set:graphic"); - scm_char_set_printing = define_charset ("char-set:printing"); - scm_char_set_whitespace = define_charset ("char-set:whitespace"); - scm_char_set_iso_control = define_charset ("char-set:iso-control"); - scm_char_set_punctuation = define_charset ("char-set:punctuation"); - scm_char_set_symbol = define_charset ("char-set:symbol"); - scm_char_set_hex_digit = define_charset ("char-set:hex-digit"); - scm_char_set_blank = define_charset ("char-set:blank"); - scm_char_set_ascii = define_charset ("char-set:ascii"); - scm_char_set_empty = define_charset ("char-set:empty"); - scm_char_set_full = define_charset ("char-set:full"); - - scm_srfi_14_compute_char_sets (); + scm_tc16_charset_cursor = scm_make_smob_type ("char-set-cursor", 0); + scm_set_smob_print (scm_tc16_charset_cursor, charset_cursor_print); + + scm_char_set_upper_case = + define_charset ("char-set:upper-case", &cs_upper_case); + scm_char_set_lower_case = + define_charset ("char-set:lower-case", &cs_lower_case); + scm_char_set_title_case = + define_charset ("char-set:title-case", &cs_title_case); + scm_char_set_letter = define_charset ("char-set:letter", &cs_letter); + scm_char_set_digit = define_charset ("char-set:digit", &cs_digit); + scm_char_set_letter_and_digit = + define_charset ("char-set:letter+digit", &cs_letter_plus_digit); + scm_char_set_graphic = define_charset ("char-set:graphic", &cs_graphic); + scm_char_set_printing = define_charset ("char-set:printing", &cs_printing); + scm_char_set_whitespace = + define_charset ("char-set:whitespace", &cs_whitespace); + scm_char_set_iso_control = + define_charset ("char-set:iso-control", &cs_iso_control); + scm_char_set_punctuation = + define_charset ("char-set:punctuation", &cs_punctuation); + scm_char_set_symbol = define_charset ("char-set:symbol", &cs_symbol); + scm_char_set_hex_digit = + define_charset ("char-set:hex-digit", &cs_hex_digit); + scm_char_set_blank = define_charset ("char-set:blank", &cs_blank); + scm_char_set_ascii = define_charset ("char-set:ascii", &cs_ascii); + scm_char_set_empty = define_charset ("char-set:empty", &cs_empty); + scm_char_set_full = define_charset ("char-set:full", &cs_full); #include "libguile/srfi-14.x" } diff --git a/libguile/srfi-14.h b/libguile/srfi-14.h index ea8027aac..1b9c29518 100644 --- a/libguile/srfi-14.h +++ b/libguile/srfi-14.h @@ -6,39 +6,52 @@ * 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 */ #include "libguile/__scm.h" -#define SCM_CHARSET_SIZE 256 +typedef struct +{ + scm_t_wchar lo; + scm_t_wchar hi; +} scm_t_char_range; -/* We expect 8-bit bytes here. Should be no problem in the year - 2001. */ -#ifndef SCM_BITS_PER_LONG -# define SCM_BITS_PER_LONG (sizeof (long) * 8) -#endif +typedef struct +{ + size_t len; + scm_t_char_range *ranges; +} scm_t_char_set; -#define SCM_CHARSET_GET(cs, idx) (((long *) SCM_SMOB_DATA (cs))\ - [((unsigned char) (idx)) / SCM_BITS_PER_LONG] &\ - (1L << (((unsigned char) (idx)) % SCM_BITS_PER_LONG))) +typedef struct +{ + size_t range; + scm_t_wchar n; +} scm_t_char_set_cursor; + +#define SCM_CHARSET_GET(cs,idx) \ + scm_i_charset_get((scm_t_char_set *)SCM_SMOB_DATA(cs),idx) #define SCM_CHARSETP(x) (!SCM_IMP (x) && (SCM_TYP16 (x) == scm_tc16_charset)) /* Smob type code for character sets. */ SCM_API int scm_tc16_charset; +SCM_INTERNAL int scm_i_charset_get (scm_t_char_set *cs, scm_t_wchar n); +SCM_INTERNAL void scm_i_charset_set (scm_t_char_set *cs, scm_t_wchar n); +SCM_INTERNAL void scm_i_charset_unset (scm_t_char_set *cs, scm_t_wchar n); SCM_API SCM scm_char_set_p (SCM obj); SCM_API SCM scm_char_set_eq (SCM char_sets); @@ -87,6 +100,9 @@ SCM_API SCM scm_char_set_intersection_x (SCM cs1, SCM rest); SCM_API SCM scm_char_set_difference_x (SCM cs1, SCM rest); SCM_API SCM scm_char_set_xor_x (SCM cs1, SCM rest); SCM_API SCM scm_char_set_diff_plus_intersection_x (SCM cs1, SCM cs2, SCM rest); +#if SCM_CHARSET_DEBUG +SCM_API SCM scm_debug_char_set (SCM cs); +#endif /* SCM_CHARSET_DEBUG */ SCM_API SCM scm_char_set_lower_case; SCM_API SCM scm_char_set_upper_case; @@ -106,7 +122,6 @@ SCM_API SCM scm_char_set_ascii; SCM_API SCM scm_char_set_empty; SCM_API SCM scm_char_set_full; -SCM_INTERNAL void scm_srfi_14_compute_char_sets (void); SCM_INTERNAL void scm_init_srfi_14 (void); #endif /* SCM_SRFI_14_H */ diff --git a/libguile/srfi-14.i.c b/libguile/srfi-14.i.c new file mode 100644 index 000000000..5ef21f333 --- /dev/null +++ b/libguile/srfi-14.i.c @@ -0,0 +1,7150 @@ +/* srfi-14.i.c -- standard SRFI-14 character set data */ + +/* This file is #include'd by srfi-14.c. */ + +/* This file was generated from http://unicode.org/Public/UNIDATA/UnicodeData.txt + with the unidata_to_charset.pl script. */ + +scm_t_char_range cs_lower_case_ranges[] = { + {0x0061, 0x007a} + , + {0x00b5, 0x00b5} + , + {0x00df, 0x00f6} + , + {0x00f8, 0x00ff} + , + {0x0101, 0x0101} + , + {0x0103, 0x0103} + , + {0x0105, 0x0105} + , + {0x0107, 0x0107} + , + {0x0109, 0x0109} + , + {0x010b, 0x010b} + , + {0x010d, 0x010d} + , + {0x010f, 0x010f} + , + {0x0111, 0x0111} + , + {0x0113, 0x0113} + , + {0x0115, 0x0115} + , + {0x0117, 0x0117} + , + {0x0119, 0x0119} + , + {0x011b, 0x011b} + , + {0x011d, 0x011d} + , + {0x011f, 0x011f} + , + {0x0121, 0x0121} + , + {0x0123, 0x0123} + , + {0x0125, 0x0125} + , + {0x0127, 0x0127} + , + {0x0129, 0x0129} + , + {0x012b, 0x012b} + , + {0x012d, 0x012d} + , + {0x012f, 0x012f} + , + {0x0131, 0x0131} + , + {0x0133, 0x0133} + , + {0x0135, 0x0135} + , + {0x0137, 0x0138} + , + {0x013a, 0x013a} + , + {0x013c, 0x013c} + , + {0x013e, 0x013e} + , + {0x0140, 0x0140} + , + {0x0142, 0x0142} + , + {0x0144, 0x0144} + , + {0x0146, 0x0146} + , + {0x0148, 0x0149} + , + {0x014b, 0x014b} + , + {0x014d, 0x014d} + , + {0x014f, 0x014f} + , + {0x0151, 0x0151} + , + {0x0153, 0x0153} + , + {0x0155, 0x0155} + , + {0x0157, 0x0157} + , + {0x0159, 0x0159} + , + {0x015b, 0x015b} + , + {0x015d, 0x015d} + , + {0x015f, 0x015f} + , + {0x0161, 0x0161} + , + {0x0163, 0x0163} + , + {0x0165, 0x0165} + , + {0x0167, 0x0167} + , + {0x0169, 0x0169} + , + {0x016b, 0x016b} + , + {0x016d, 0x016d} + , + {0x016f, 0x016f} + , + {0x0171, 0x0171} + , + {0x0173, 0x0173} + , + {0x0175, 0x0175} + , + {0x0177, 0x0177} + , + {0x017a, 0x017a} + , + {0x017c, 0x017c} + , + {0x017e, 0x0180} + , + {0x0183, 0x0183} + , + {0x0185, 0x0185} + , + {0x0188, 0x0188} + , + {0x018c, 0x018d} + , + {0x0192, 0x0192} + , + {0x0195, 0x0195} + , + {0x0199, 0x019b} + , + {0x019e, 0x019e} + , + {0x01a1, 0x01a1} + , + {0x01a3, 0x01a3} + , + {0x01a5, 0x01a5} + , + {0x01a8, 0x01a8} + , + {0x01ab, 0x01ab} + , + {0x01ad, 0x01ad} + , + {0x01b0, 0x01b0} + , + {0x01b4, 0x01b4} + , + {0x01b6, 0x01b6} + , + {0x01b9, 0x01ba} + , + {0x01bd, 0x01bd} + , + {0x01bf, 0x01bf} + , + {0x01c6, 0x01c6} + , + {0x01c9, 0x01c9} + , + {0x01cc, 0x01cc} + , + {0x01ce, 0x01ce} + , + {0x01d0, 0x01d0} + , + {0x01d2, 0x01d2} + , + {0x01d4, 0x01d4} + , + {0x01d6, 0x01d6} + , + {0x01d8, 0x01d8} + , + {0x01da, 0x01da} + , + {0x01dc, 0x01dd} + , + {0x01df, 0x01df} + , + {0x01e1, 0x01e1} + , + {0x01e3, 0x01e3} + , + {0x01e5, 0x01e5} + , + {0x01e7, 0x01e7} + , + {0x01e9, 0x01e9} + , + {0x01eb, 0x01eb} + , + {0x01ed, 0x01ed} + , + {0x01ef, 0x01f0} + , + {0x01f3, 0x01f3} + , + {0x01f5, 0x01f5} + , + {0x01f9, 0x01f9} + , + {0x01fb, 0x01fb} + , + {0x01fd, 0x01fd} + , + {0x01ff, 0x01ff} + , + {0x0201, 0x0201} + , + {0x0203, 0x0203} + , + {0x0205, 0x0205} + , + {0x0207, 0x0207} + , + {0x0209, 0x0209} + , + {0x020b, 0x020b} + , + {0x020d, 0x020d} + , + {0x020f, 0x020f} + , + {0x0211, 0x0211} + , + {0x0213, 0x0213} + , + {0x0215, 0x0215} + , + {0x0217, 0x0217} + , + {0x0219, 0x0219} + , + {0x021b, 0x021b} + , + {0x021d, 0x021d} + , + {0x021f, 0x021f} + , + {0x0221, 0x0221} + , + {0x0223, 0x0223} + , + {0x0225, 0x0225} + , + {0x0227, 0x0227} + , + {0x0229, 0x0229} + , + {0x022b, 0x022b} + , + {0x022d, 0x022d} + , + {0x022f, 0x022f} + , + {0x0231, 0x0231} + , + {0x0233, 0x0239} + , + {0x023c, 0x023c} + , + {0x023f, 0x0240} + , + {0x0242, 0x0242} + , + {0x0247, 0x0247} + , + {0x0249, 0x0249} + , + {0x024b, 0x024b} + , + {0x024d, 0x024d} + , + {0x024f, 0x0261} + , + {0x0263, 0x0269} + , + {0x026b, 0x0273} + , + {0x0275, 0x0275} + , + {0x0277, 0x0280} + , + {0x0282, 0x028e} + , + {0x0290, 0x0293} + , + {0x029a, 0x029a} + , + {0x029d, 0x029e} + , + {0x02a0, 0x02a0} + , + {0x02a3, 0x02ab} + , + {0x02ae, 0x02af} + , + {0x0345, 0x0345} + , + {0x0363, 0x036f} + , + {0x0371, 0x0371} + , + {0x0373, 0x0373} + , + {0x0377, 0x0377} + , + {0x037b, 0x037d} + , + {0x0390, 0x0390} + , + {0x03ac, 0x03ce} + , + {0x03d0, 0x03d1} + , + {0x03d5, 0x03d7} + , + {0x03d9, 0x03d9} + , + {0x03db, 0x03db} + , + {0x03dd, 0x03dd} + , + {0x03df, 0x03df} + , + {0x03e1, 0x03e1} + , + {0x03e3, 0x03e3} + , + {0x03e5, 0x03e5} + , + {0x03e7, 0x03e7} + , + {0x03e9, 0x03e9} + , + {0x03eb, 0x03eb} + , + {0x03ed, 0x03ed} + , + {0x03ef, 0x03f2} + , + {0x03f5, 0x03f5} + , + {0x03f8, 0x03f8} + , + {0x03fb, 0x03fb} + , + {0x0430, 0x045f} + , + {0x0461, 0x0461} + , + {0x0463, 0x0463} + , + {0x0465, 0x0465} + , + {0x0467, 0x0467} + , + {0x0469, 0x0469} + , + {0x046b, 0x046b} + , + {0x046d, 0x046d} + , + {0x046f, 0x046f} + , + {0x0471, 0x0471} + , + {0x0473, 0x0473} + , + {0x0475, 0x0475} + , + {0x0477, 0x0477} + , + {0x0479, 0x0479} + , + {0x047b, 0x047b} + , + {0x047d, 0x047d} + , + {0x047f, 0x047f} + , + {0x0481, 0x0481} + , + {0x048b, 0x048b} + , + {0x048d, 0x048d} + , + {0x048f, 0x048f} + , + {0x0491, 0x0491} + , + {0x0493, 0x0493} + , + {0x0495, 0x0495} + , + {0x0497, 0x0497} + , + {0x0499, 0x0499} + , + {0x049b, 0x049b} + , + {0x049d, 0x049d} + , + {0x049f, 0x049f} + , + {0x04a1, 0x04a1} + , + {0x04a3, 0x04a3} + , + {0x04a5, 0x04a5} + , + {0x04a7, 0x04a7} + , + {0x04a9, 0x04a9} + , + {0x04ab, 0x04ab} + , + {0x04ad, 0x04ad} + , + {0x04af, 0x04af} + , + {0x04b1, 0x04b1} + , + {0x04b3, 0x04b3} + , + {0x04b5, 0x04b5} + , + {0x04b7, 0x04b7} + , + {0x04b9, 0x04b9} + , + {0x04bb, 0x04bb} + , + {0x04bd, 0x04bd} + , + {0x04bf, 0x04bf} + , + {0x04c2, 0x04c2} + , + {0x04c4, 0x04c4} + , + {0x04c6, 0x04c6} + , + {0x04c8, 0x04c8} + , + {0x04ca, 0x04ca} + , + {0x04cc, 0x04cc} + , + {0x04ce, 0x04cf} + , + {0x04d1, 0x04d1} + , + {0x04d3, 0x04d3} + , + {0x04d5, 0x04d5} + , + {0x04d7, 0x04d7} + , + {0x04d9, 0x04d9} + , + {0x04db, 0x04db} + , + {0x04dd, 0x04dd} + , + {0x04df, 0x04df} + , + {0x04e1, 0x04e1} + , + {0x04e3, 0x04e3} + , + {0x04e5, 0x04e5} + , + {0x04e7, 0x04e7} + , + {0x04e9, 0x04e9} + , + {0x04eb, 0x04eb} + , + {0x04ed, 0x04ed} + , + {0x04ef, 0x04ef} + , + {0x04f1, 0x04f1} + , + {0x04f3, 0x04f3} + , + {0x04f5, 0x04f5} + , + {0x04f7, 0x04f7} + , + {0x04f9, 0x04f9} + , + {0x04fb, 0x04fb} + , + {0x04fd, 0x04fd} + , + {0x04ff, 0x04ff} + , + {0x0501, 0x0501} + , + {0x0503, 0x0503} + , + {0x0505, 0x0505} + , + {0x0507, 0x0507} + , + {0x0509, 0x0509} + , + {0x050b, 0x050b} + , + {0x050d, 0x050d} + , + {0x050f, 0x050f} + , + {0x0511, 0x0511} + , + {0x0513, 0x0513} + , + {0x0515, 0x0515} + , + {0x0517, 0x0517} + , + {0x0519, 0x0519} + , + {0x051b, 0x051b} + , + {0x051d, 0x051d} + , + {0x051f, 0x051f} + , + {0x0521, 0x0521} + , + {0x0523, 0x0523} + , + {0x0561, 0x0587} + , + {0x1930, 0x1938} + , + {0x1d02, 0x1d02} + , + {0x1d08, 0x1d09} + , + {0x1d11, 0x1d14} + , + {0x1d16, 0x1d17} + , + {0x1d1d, 0x1d1f} + , + {0x1d62, 0x1d77} + , + {0x1d79, 0x1d7a} + , + {0x1d7c, 0x1d7d} + , + {0x1d7f, 0x1d9a} + , + {0x1dca, 0x1dca} + , + {0x1dd3, 0x1dda} + , + {0x1ddc, 0x1ddd} + , + {0x1de0, 0x1de0} + , + {0x1de3, 0x1de6} + , + {0x1e01, 0x1e01} + , + {0x1e03, 0x1e03} + , + {0x1e05, 0x1e05} + , + {0x1e07, 0x1e07} + , + {0x1e09, 0x1e09} + , + {0x1e0b, 0x1e0b} + , + {0x1e0d, 0x1e0d} + , + {0x1e0f, 0x1e0f} + , + {0x1e11, 0x1e11} + , + {0x1e13, 0x1e13} + , + {0x1e15, 0x1e15} + , + {0x1e17, 0x1e17} + , + {0x1e19, 0x1e19} + , + {0x1e1b, 0x1e1b} + , + {0x1e1d, 0x1e1d} + , + {0x1e1f, 0x1e1f} + , + {0x1e21, 0x1e21} + , + {0x1e23, 0x1e23} + , + {0x1e25, 0x1e25} + , + {0x1e27, 0x1e27} + , + {0x1e29, 0x1e29} + , + {0x1e2b, 0x1e2b} + , + {0x1e2d, 0x1e2d} + , + {0x1e2f, 0x1e2f} + , + {0x1e31, 0x1e31} + , + {0x1e33, 0x1e33} + , + {0x1e35, 0x1e35} + , + {0x1e37, 0x1e37} + , + {0x1e39, 0x1e39} + , + {0x1e3b, 0x1e3b} + , + {0x1e3d, 0x1e3d} + , + {0x1e3f, 0x1e3f} + , + {0x1e41, 0x1e41} + , + {0x1e43, 0x1e43} + , + {0x1e45, 0x1e45} + , + {0x1e47, 0x1e47} + , + {0x1e49, 0x1e49} + , + {0x1e4b, 0x1e4b} + , + {0x1e4d, 0x1e4d} + , + {0x1e4f, 0x1e4f} + , + {0x1e51, 0x1e51} + , + {0x1e53, 0x1e53} + , + {0x1e55, 0x1e55} + , + {0x1e57, 0x1e57} + , + {0x1e59, 0x1e59} + , + {0x1e5b, 0x1e5b} + , + {0x1e5d, 0x1e5d} + , + {0x1e5f, 0x1e5f} + , + {0x1e61, 0x1e61} + , + {0x1e63, 0x1e63} + , + {0x1e65, 0x1e65} + , + {0x1e67, 0x1e67} + , + {0x1e69, 0x1e69} + , + {0x1e6b, 0x1e6b} + , + {0x1e6d, 0x1e6d} + , + {0x1e6f, 0x1e6f} + , + {0x1e71, 0x1e71} + , + {0x1e73, 0x1e73} + , + {0x1e75, 0x1e75} + , + {0x1e77, 0x1e77} + , + {0x1e79, 0x1e79} + , + {0x1e7b, 0x1e7b} + , + {0x1e7d, 0x1e7d} + , + {0x1e7f, 0x1e7f} + , + {0x1e81, 0x1e81} + , + {0x1e83, 0x1e83} + , + {0x1e85, 0x1e85} + , + {0x1e87, 0x1e87} + , + {0x1e89, 0x1e89} + , + {0x1e8b, 0x1e8b} + , + {0x1e8d, 0x1e8d} + , + {0x1e8f, 0x1e8f} + , + {0x1e91, 0x1e91} + , + {0x1e93, 0x1e93} + , + {0x1e95, 0x1e9d} + , + {0x1e9f, 0x1e9f} + , + {0x1ea1, 0x1ea1} + , + {0x1ea3, 0x1ea3} + , + {0x1ea5, 0x1ea5} + , + {0x1ea7, 0x1ea7} + , + {0x1ea9, 0x1ea9} + , + {0x1eab, 0x1eab} + , + {0x1ead, 0x1ead} + , + {0x1eaf, 0x1eaf} + , + {0x1eb1, 0x1eb1} + , + {0x1eb3, 0x1eb3} + , + {0x1eb5, 0x1eb5} + , + {0x1eb7, 0x1eb7} + , + {0x1eb9, 0x1eb9} + , + {0x1ebb, 0x1ebb} + , + {0x1ebd, 0x1ebd} + , + {0x1ebf, 0x1ebf} + , + {0x1ec1, 0x1ec1} + , + {0x1ec3, 0x1ec3} + , + {0x1ec5, 0x1ec5} + , + {0x1ec7, 0x1ec7} + , + {0x1ec9, 0x1ec9} + , + {0x1ecb, 0x1ecb} + , + {0x1ecd, 0x1ecd} + , + {0x1ecf, 0x1ecf} + , + {0x1ed1, 0x1ed1} + , + {0x1ed3, 0x1ed3} + , + {0x1ed5, 0x1ed5} + , + {0x1ed7, 0x1ed7} + , + {0x1ed9, 0x1ed9} + , + {0x1edb, 0x1edb} + , + {0x1edd, 0x1edd} + , + {0x1edf, 0x1edf} + , + {0x1ee1, 0x1ee1} + , + {0x1ee3, 0x1ee3} + , + {0x1ee5, 0x1ee5} + , + {0x1ee7, 0x1ee7} + , + {0x1ee9, 0x1ee9} + , + {0x1eeb, 0x1eeb} + , + {0x1eed, 0x1eed} + , + {0x1eef, 0x1eef} + , + {0x1ef1, 0x1ef1} + , + {0x1ef3, 0x1ef3} + , + {0x1ef5, 0x1ef5} + , + {0x1ef7, 0x1ef7} + , + {0x1ef9, 0x1ef9} + , + {0x1efb, 0x1efb} + , + {0x1efd, 0x1efd} + , + {0x1eff, 0x1f07} + , + {0x1f10, 0x1f15} + , + {0x1f20, 0x1f27} + , + {0x1f30, 0x1f37} + , + {0x1f40, 0x1f45} + , + {0x1f50, 0x1f57} + , + {0x1f60, 0x1f67} + , + {0x1f70, 0x1f7d} + , + {0x1f80, 0x1f87} + , + {0x1f90, 0x1f97} + , + {0x1fa0, 0x1fa7} + , + {0x1fb0, 0x1fb4} + , + {0x1fb6, 0x1fb7} + , + {0x1fbe, 0x1fbe} + , + {0x1fc2, 0x1fc4} + , + {0x1fc6, 0x1fc7} + , + {0x1fd0, 0x1fd3} + , + {0x1fd6, 0x1fd7} + , + {0x1fe0, 0x1fe7} + , + {0x1ff2, 0x1ff4} + , + {0x1ff6, 0x1ff7} + , + {0xa641, 0xa641} + , + {0xa643, 0xa643} + , + {0xa645, 0xa645} + , + {0xa647, 0xa647} + , + {0xa649, 0xa649} + , + {0xa64b, 0xa64b} + , + {0xa64d, 0xa64d} + , + {0xa64f, 0xa64f} + , + {0xa651, 0xa651} + , + {0xa653, 0xa653} + , + {0xa655, 0xa655} + , + {0xa657, 0xa657} + , + {0xa659, 0xa659} + , + {0xa65b, 0xa65b} + , + {0xa65d, 0xa65d} + , + {0xa65f, 0xa65f} + , + {0xa663, 0xa663} + , + {0xa665, 0xa665} + , + {0xa667, 0xa667} + , + {0xa669, 0xa669} + , + {0xa66b, 0xa66b} + , + {0xa66d, 0xa66d} + , + {0xa681, 0xa681} + , + {0xa683, 0xa683} + , + {0xa685, 0xa685} + , + {0xa687, 0xa687} + , + {0xa689, 0xa689} + , + {0xa68b, 0xa68b} + , + {0xa68d, 0xa68d} + , + {0xa68f, 0xa68f} + , + {0xa691, 0xa691} + , + {0xa693, 0xa693} + , + {0xa695, 0xa695} + , + {0xa697, 0xa697} + , + {0xa723, 0xa723} + , + {0xa725, 0xa725} + , + {0xa727, 0xa727} + , + {0xa729, 0xa729} + , + {0xa72b, 0xa72b} + , + {0xa72d, 0xa72d} + , + {0xa72f, 0xa72f} + , + {0xa733, 0xa733} + , + {0xa735, 0xa735} + , + {0xa737, 0xa737} + , + {0xa739, 0xa739} + , + {0xa73b, 0xa73b} + , + {0xa73d, 0xa73d} + , + {0xa73f, 0xa73f} + , + {0xa741, 0xa741} + , + {0xa743, 0xa743} + , + {0xa745, 0xa745} + , + {0xa747, 0xa747} + , + {0xa749, 0xa749} + , + {0xa74b, 0xa74b} + , + {0xa74d, 0xa74d} + , + {0xa74f, 0xa74f} + , + {0xa751, 0xa751} + , + {0xa753, 0xa753} + , + {0xa755, 0xa755} + , + {0xa757, 0xa757} + , + {0xa759, 0xa759} + , + {0xa75b, 0xa75b} + , + {0xa75d, 0xa75d} + , + {0xa75f, 0xa75f} + , + {0xa761, 0xa761} + , + {0xa763, 0xa763} + , + {0xa765, 0xa765} + , + {0xa767, 0xa767} + , + {0xa769, 0xa769} + , + {0xa76b, 0xa76b} + , + {0xa76d, 0xa76d} + , + {0xa76f, 0xa76f} + , + {0xa771, 0xa775} + , + {0xa777, 0xa778} + , + {0xa77a, 0xa77a} + , + {0xa77c, 0xa77c} + , + {0xa77f, 0xa77f} + , + {0xa781, 0xa781} + , + {0xa783, 0xa783} + , + {0xa785, 0xa785} + , + {0xa787, 0xa787} + , + {0xa78c, 0xa78c} + , + {0xfb00, 0xfb06} + , + {0xfb13, 0xfb17} + , + {0xff41, 0xff5a} + , + {0x10428, 0x1044f} + , + {0xe0061, 0xe007a} +}; + +scm_t_char_set cs_lower_case = { + 523, + cs_lower_case_ranges +}; + +scm_t_char_range cs_upper_case_ranges[] = { + {0x0041, 0x005a} + , + {0x00c0, 0x00d6} + , + {0x00d8, 0x00de} + , + {0x0100, 0x0100} + , + {0x0102, 0x0102} + , + {0x0104, 0x0104} + , + {0x0106, 0x0106} + , + {0x0108, 0x0108} + , + {0x010a, 0x010a} + , + {0x010c, 0x010c} + , + {0x010e, 0x010e} + , + {0x0110, 0x0110} + , + {0x0112, 0x0112} + , + {0x0114, 0x0114} + , + {0x0116, 0x0116} + , + {0x0118, 0x0118} + , + {0x011a, 0x011a} + , + {0x011c, 0x011c} + , + {0x011e, 0x011e} + , + {0x0120, 0x0120} + , + {0x0122, 0x0122} + , + {0x0124, 0x0124} + , + {0x0126, 0x0126} + , + {0x0128, 0x0128} + , + {0x012a, 0x012a} + , + {0x012c, 0x012c} + , + {0x012e, 0x012e} + , + {0x0130, 0x0130} + , + {0x0132, 0x0132} + , + {0x0134, 0x0134} + , + {0x0136, 0x0136} + , + {0x0139, 0x0139} + , + {0x013b, 0x013b} + , + {0x013d, 0x013d} + , + {0x013f, 0x013f} + , + {0x0141, 0x0141} + , + {0x0143, 0x0143} + , + {0x0145, 0x0145} + , + {0x0147, 0x0147} + , + {0x014a, 0x014a} + , + {0x014c, 0x014c} + , + {0x014e, 0x014e} + , + {0x0150, 0x0150} + , + {0x0152, 0x0152} + , + {0x0154, 0x0154} + , + {0x0156, 0x0156} + , + {0x0158, 0x0158} + , + {0x015a, 0x015a} + , + {0x015c, 0x015c} + , + {0x015e, 0x015e} + , + {0x0160, 0x0160} + , + {0x0162, 0x0162} + , + {0x0164, 0x0164} + , + {0x0166, 0x0166} + , + {0x0168, 0x0168} + , + {0x016a, 0x016a} + , + {0x016c, 0x016c} + , + {0x016e, 0x016e} + , + {0x0170, 0x0170} + , + {0x0172, 0x0172} + , + {0x0174, 0x0174} + , + {0x0176, 0x0176} + , + {0x0178, 0x0179} + , + {0x017b, 0x017b} + , + {0x017d, 0x017d} + , + {0x0181, 0x0182} + , + {0x0184, 0x0184} + , + {0x0186, 0x0187} + , + {0x0189, 0x018b} + , + {0x018e, 0x0191} + , + {0x0193, 0x0194} + , + {0x0196, 0x0198} + , + {0x019c, 0x019d} + , + {0x019f, 0x01a0} + , + {0x01a2, 0x01a2} + , + {0x01a4, 0x01a4} + , + {0x01a6, 0x01a7} + , + {0x01a9, 0x01a9} + , + {0x01ac, 0x01ac} + , + {0x01ae, 0x01af} + , + {0x01b1, 0x01b3} + , + {0x01b5, 0x01b5} + , + {0x01b7, 0x01b8} + , + {0x01bc, 0x01bc} + , + {0x01c4, 0x01c4} + , + {0x01c7, 0x01c7} + , + {0x01ca, 0x01ca} + , + {0x01cd, 0x01cd} + , + {0x01cf, 0x01cf} + , + {0x01d1, 0x01d1} + , + {0x01d3, 0x01d3} + , + {0x01d5, 0x01d5} + , + {0x01d7, 0x01d7} + , + {0x01d9, 0x01d9} + , + {0x01db, 0x01db} + , + {0x01de, 0x01de} + , + {0x01e0, 0x01e0} + , + {0x01e2, 0x01e2} + , + {0x01e4, 0x01e4} + , + {0x01e6, 0x01e6} + , + {0x01e8, 0x01e8} + , + {0x01ea, 0x01ea} + , + {0x01ec, 0x01ec} + , + {0x01ee, 0x01ee} + , + {0x01f1, 0x01f1} + , + {0x01f4, 0x01f4} + , + {0x01f6, 0x01f8} + , + {0x01fa, 0x01fa} + , + {0x01fc, 0x01fc} + , + {0x01fe, 0x01fe} + , + {0x0200, 0x0200} + , + {0x0202, 0x0202} + , + {0x0204, 0x0204} + , + {0x0206, 0x0206} + , + {0x0208, 0x0208} + , + {0x020a, 0x020a} + , + {0x020c, 0x020c} + , + {0x020e, 0x020e} + , + {0x0210, 0x0210} + , + {0x0212, 0x0212} + , + {0x0214, 0x0214} + , + {0x0216, 0x0216} + , + {0x0218, 0x0218} + , + {0x021a, 0x021a} + , + {0x021c, 0x021c} + , + {0x021e, 0x021e} + , + {0x0220, 0x0220} + , + {0x0222, 0x0222} + , + {0x0224, 0x0224} + , + {0x0226, 0x0226} + , + {0x0228, 0x0228} + , + {0x022a, 0x022a} + , + {0x022c, 0x022c} + , + {0x022e, 0x022e} + , + {0x0230, 0x0230} + , + {0x0232, 0x0232} + , + {0x023a, 0x023b} + , + {0x023d, 0x023e} + , + {0x0241, 0x0241} + , + {0x0243, 0x0246} + , + {0x0248, 0x0248} + , + {0x024a, 0x024a} + , + {0x024c, 0x024c} + , + {0x024e, 0x024e} + , + {0x0370, 0x0370} + , + {0x0372, 0x0372} + , + {0x0376, 0x0376} + , + {0x0386, 0x0386} + , + {0x0388, 0x038a} + , + {0x038c, 0x038c} + , + {0x038e, 0x038f} + , + {0x0391, 0x03a1} + , + {0x03a3, 0x03ab} + , + {0x03cf, 0x03cf} + , + {0x03d8, 0x03d8} + , + {0x03da, 0x03da} + , + {0x03dc, 0x03dc} + , + {0x03de, 0x03de} + , + {0x03e0, 0x03e0} + , + {0x03e2, 0x03e2} + , + {0x03e4, 0x03e4} + , + {0x03e6, 0x03e6} + , + {0x03e8, 0x03e8} + , + {0x03ea, 0x03ea} + , + {0x03ec, 0x03ec} + , + {0x03ee, 0x03ee} + , + {0x03f4, 0x03f4} + , + {0x03f7, 0x03f7} + , + {0x03f9, 0x03fa} + , + {0x03fd, 0x042f} + , + {0x0460, 0x0460} + , + {0x0462, 0x0462} + , + {0x0464, 0x0464} + , + {0x0466, 0x0466} + , + {0x0468, 0x0468} + , + {0x046a, 0x046a} + , + {0x046c, 0x046c} + , + {0x046e, 0x046e} + , + {0x0470, 0x0470} + , + {0x0472, 0x0472} + , + {0x0474, 0x0474} + , + {0x0476, 0x0476} + , + {0x0478, 0x0478} + , + {0x047a, 0x047a} + , + {0x047c, 0x047c} + , + {0x047e, 0x047e} + , + {0x0480, 0x0480} + , + {0x048a, 0x048a} + , + {0x048c, 0x048c} + , + {0x048e, 0x048e} + , + {0x0490, 0x0490} + , + {0x0492, 0x0492} + , + {0x0494, 0x0494} + , + {0x0496, 0x0496} + , + {0x0498, 0x0498} + , + {0x049a, 0x049a} + , + {0x049c, 0x049c} + , + {0x049e, 0x049e} + , + {0x04a0, 0x04a0} + , + {0x04a2, 0x04a2} + , + {0x04a4, 0x04a4} + , + {0x04a6, 0x04a6} + , + {0x04a8, 0x04a8} + , + {0x04aa, 0x04aa} + , + {0x04ac, 0x04ac} + , + {0x04ae, 0x04ae} + , + {0x04b0, 0x04b0} + , + {0x04b2, 0x04b2} + , + {0x04b4, 0x04b4} + , + {0x04b6, 0x04b6} + , + {0x04b8, 0x04b8} + , + {0x04ba, 0x04ba} + , + {0x04bc, 0x04bc} + , + {0x04be, 0x04be} + , + {0x04c0, 0x04c1} + , + {0x04c3, 0x04c3} + , + {0x04c5, 0x04c5} + , + {0x04c7, 0x04c7} + , + {0x04c9, 0x04c9} + , + {0x04cb, 0x04cb} + , + {0x04cd, 0x04cd} + , + {0x04d0, 0x04d0} + , + {0x04d2, 0x04d2} + , + {0x04d4, 0x04d4} + , + {0x04d6, 0x04d6} + , + {0x04d8, 0x04d8} + , + {0x04da, 0x04da} + , + {0x04dc, 0x04dc} + , + {0x04de, 0x04de} + , + {0x04e0, 0x04e0} + , + {0x04e2, 0x04e2} + , + {0x04e4, 0x04e4} + , + {0x04e6, 0x04e6} + , + {0x04e8, 0x04e8} + , + {0x04ea, 0x04ea} + , + {0x04ec, 0x04ec} + , + {0x04ee, 0x04ee} + , + {0x04f0, 0x04f0} + , + {0x04f2, 0x04f2} + , + {0x04f4, 0x04f4} + , + {0x04f6, 0x04f6} + , + {0x04f8, 0x04f8} + , + {0x04fa, 0x04fa} + , + {0x04fc, 0x04fc} + , + {0x04fe, 0x04fe} + , + {0x0500, 0x0500} + , + {0x0502, 0x0502} + , + {0x0504, 0x0504} + , + {0x0506, 0x0506} + , + {0x0508, 0x0508} + , + {0x050a, 0x050a} + , + {0x050c, 0x050c} + , + {0x050e, 0x050e} + , + {0x0510, 0x0510} + , + {0x0512, 0x0512} + , + {0x0514, 0x0514} + , + {0x0516, 0x0516} + , + {0x0518, 0x0518} + , + {0x051a, 0x051a} + , + {0x051c, 0x051c} + , + {0x051e, 0x051e} + , + {0x0520, 0x0520} + , + {0x0522, 0x0522} + , + {0x0531, 0x0556} + , + {0x10a0, 0x10c5} + , + {0x1d7b, 0x1d7b} + , + {0x1d7e, 0x1d7e} + , + {0x1e00, 0x1e00} + , + {0x1e02, 0x1e02} + , + {0x1e04, 0x1e04} + , + {0x1e06, 0x1e06} + , + {0x1e08, 0x1e08} + , + {0x1e0a, 0x1e0a} + , + {0x1e0c, 0x1e0c} + , + {0x1e0e, 0x1e0e} + , + {0x1e10, 0x1e10} + , + {0x1e12, 0x1e12} + , + {0x1e14, 0x1e14} + , + {0x1e16, 0x1e16} + , + {0x1e18, 0x1e18} + , + {0x1e1a, 0x1e1a} + , + {0x1e1c, 0x1e1c} + , + {0x1e1e, 0x1e1e} + , + {0x1e20, 0x1e20} + , + {0x1e22, 0x1e22} + , + {0x1e24, 0x1e24} + , + {0x1e26, 0x1e26} + , + {0x1e28, 0x1e28} + , + {0x1e2a, 0x1e2a} + , + {0x1e2c, 0x1e2c} + , + {0x1e2e, 0x1e2e} + , + {0x1e30, 0x1e30} + , + {0x1e32, 0x1e32} + , + {0x1e34, 0x1e34} + , + {0x1e36, 0x1e36} + , + {0x1e38, 0x1e38} + , + {0x1e3a, 0x1e3a} + , + {0x1e3c, 0x1e3c} + , + {0x1e3e, 0x1e3e} + , + {0x1e40, 0x1e40} + , + {0x1e42, 0x1e42} + , + {0x1e44, 0x1e44} + , + {0x1e46, 0x1e46} + , + {0x1e48, 0x1e48} + , + {0x1e4a, 0x1e4a} + , + {0x1e4c, 0x1e4c} + , + {0x1e4e, 0x1e4e} + , + {0x1e50, 0x1e50} + , + {0x1e52, 0x1e52} + , + {0x1e54, 0x1e54} + , + {0x1e56, 0x1e56} + , + {0x1e58, 0x1e58} + , + {0x1e5a, 0x1e5a} + , + {0x1e5c, 0x1e5c} + , + {0x1e5e, 0x1e5e} + , + {0x1e60, 0x1e60} + , + {0x1e62, 0x1e62} + , + {0x1e64, 0x1e64} + , + {0x1e66, 0x1e66} + , + {0x1e68, 0x1e68} + , + {0x1e6a, 0x1e6a} + , + {0x1e6c, 0x1e6c} + , + {0x1e6e, 0x1e6e} + , + {0x1e70, 0x1e70} + , + {0x1e72, 0x1e72} + , + {0x1e74, 0x1e74} + , + {0x1e76, 0x1e76} + , + {0x1e78, 0x1e78} + , + {0x1e7a, 0x1e7a} + , + {0x1e7c, 0x1e7c} + , + {0x1e7e, 0x1e7e} + , + {0x1e80, 0x1e80} + , + {0x1e82, 0x1e82} + , + {0x1e84, 0x1e84} + , + {0x1e86, 0x1e86} + , + {0x1e88, 0x1e88} + , + {0x1e8a, 0x1e8a} + , + {0x1e8c, 0x1e8c} + , + {0x1e8e, 0x1e8e} + , + {0x1e90, 0x1e90} + , + {0x1e92, 0x1e92} + , + {0x1e94, 0x1e94} + , + {0x1e9e, 0x1e9e} + , + {0x1ea0, 0x1ea0} + , + {0x1ea2, 0x1ea2} + , + {0x1ea4, 0x1ea4} + , + {0x1ea6, 0x1ea6} + , + {0x1ea8, 0x1ea8} + , + {0x1eaa, 0x1eaa} + , + {0x1eac, 0x1eac} + , + {0x1eae, 0x1eae} + , + {0x1eb0, 0x1eb0} + , + {0x1eb2, 0x1eb2} + , + {0x1eb4, 0x1eb4} + , + {0x1eb6, 0x1eb6} + , + {0x1eb8, 0x1eb8} + , + {0x1eba, 0x1eba} + , + {0x1ebc, 0x1ebc} + , + {0x1ebe, 0x1ebe} + , + {0x1ec0, 0x1ec0} + , + {0x1ec2, 0x1ec2} + , + {0x1ec4, 0x1ec4} + , + {0x1ec6, 0x1ec6} + , + {0x1ec8, 0x1ec8} + , + {0x1eca, 0x1eca} + , + {0x1ecc, 0x1ecc} + , + {0x1ece, 0x1ece} + , + {0x1ed0, 0x1ed0} + , + {0x1ed2, 0x1ed2} + , + {0x1ed4, 0x1ed4} + , + {0x1ed6, 0x1ed6} + , + {0x1ed8, 0x1ed8} + , + {0x1eda, 0x1eda} + , + {0x1edc, 0x1edc} + , + {0x1ede, 0x1ede} + , + {0x1ee0, 0x1ee0} + , + {0x1ee2, 0x1ee2} + , + {0x1ee4, 0x1ee4} + , + {0x1ee6, 0x1ee6} + , + {0x1ee8, 0x1ee8} + , + {0x1eea, 0x1eea} + , + {0x1eec, 0x1eec} + , + {0x1eee, 0x1eee} + , + {0x1ef0, 0x1ef0} + , + {0x1ef2, 0x1ef2} + , + {0x1ef4, 0x1ef4} + , + {0x1ef6, 0x1ef6} + , + {0x1ef8, 0x1ef8} + , + {0x1efa, 0x1efa} + , + {0x1efc, 0x1efc} + , + {0x1efe, 0x1efe} + , + {0x1f08, 0x1f0f} + , + {0x1f18, 0x1f1d} + , + {0x1f28, 0x1f2f} + , + {0x1f38, 0x1f3f} + , + {0x1f48, 0x1f4d} + , + {0x1f59, 0x1f59} + , + {0x1f5b, 0x1f5b} + , + {0x1f5d, 0x1f5d} + , + {0x1f5f, 0x1f5f} + , + {0x1f68, 0x1f6f} + , + {0x1f88, 0x1f8f} + , + {0x1f98, 0x1f9f} + , + {0x1fa8, 0x1faf} + , + {0x1fb8, 0x1fbc} + , + {0x1fc8, 0x1fcc} + , + {0x1fd8, 0x1fdb} + , + {0x1fe8, 0x1fec} + , + {0x1ff8, 0x1ffc} + , + {0xa640, 0xa640} + , + {0xa642, 0xa642} + , + {0xa644, 0xa644} + , + {0xa646, 0xa646} + , + {0xa648, 0xa648} + , + {0xa64a, 0xa64a} + , + {0xa64c, 0xa64c} + , + {0xa64e, 0xa64e} + , + {0xa650, 0xa650} + , + {0xa652, 0xa652} + , + {0xa654, 0xa654} + , + {0xa656, 0xa656} + , + {0xa658, 0xa658} + , + {0xa65a, 0xa65a} + , + {0xa65c, 0xa65c} + , + {0xa65e, 0xa65e} + , + {0xa662, 0xa662} + , + {0xa664, 0xa664} + , + {0xa666, 0xa666} + , + {0xa668, 0xa668} + , + {0xa66a, 0xa66a} + , + {0xa66c, 0xa66c} + , + {0xa680, 0xa680} + , + {0xa682, 0xa682} + , + {0xa684, 0xa684} + , + {0xa686, 0xa686} + , + {0xa688, 0xa688} + , + {0xa68a, 0xa68a} + , + {0xa68c, 0xa68c} + , + {0xa68e, 0xa68e} + , + {0xa690, 0xa690} + , + {0xa692, 0xa692} + , + {0xa694, 0xa694} + , + {0xa696, 0xa696} + , + {0xa722, 0xa722} + , + {0xa724, 0xa724} + , + {0xa726, 0xa726} + , + {0xa728, 0xa728} + , + {0xa72a, 0xa72a} + , + {0xa72c, 0xa72c} + , + {0xa72e, 0xa72e} + , + {0xa732, 0xa732} + , + {0xa734, 0xa734} + , + {0xa736, 0xa736} + , + {0xa738, 0xa738} + , + {0xa73a, 0xa73a} + , + {0xa73c, 0xa73c} + , + {0xa73e, 0xa73e} + , + {0xa740, 0xa740} + , + {0xa742, 0xa742} + , + {0xa744, 0xa744} + , + {0xa746, 0xa746} + , + {0xa748, 0xa748} + , + {0xa74a, 0xa74a} + , + {0xa74c, 0xa74c} + , + {0xa74e, 0xa74e} + , + {0xa750, 0xa750} + , + {0xa752, 0xa752} + , + {0xa754, 0xa754} + , + {0xa756, 0xa756} + , + {0xa758, 0xa758} + , + {0xa75a, 0xa75a} + , + {0xa75c, 0xa75c} + , + {0xa75e, 0xa75e} + , + {0xa760, 0xa760} + , + {0xa762, 0xa762} + , + {0xa764, 0xa764} + , + {0xa766, 0xa766} + , + {0xa768, 0xa768} + , + {0xa76a, 0xa76a} + , + {0xa76c, 0xa76c} + , + {0xa76e, 0xa76e} + , + {0xa779, 0xa779} + , + {0xa77b, 0xa77b} + , + {0xa77d, 0xa77e} + , + {0xa780, 0xa780} + , + {0xa782, 0xa782} + , + {0xa784, 0xa784} + , + {0xa786, 0xa786} + , + {0xa78b, 0xa78b} + , + {0xff21, 0xff3a} + , + {0x10400, 0x10427} + , + {0xe0041, 0xe005a} +}; + +scm_t_char_set cs_upper_case = { + 492, + cs_upper_case_ranges +}; + +scm_t_char_range cs_title_case_ranges[] = { + {0x01c5, 0x01c5} + , + {0x01c8, 0x01c8} + , + {0x01cb, 0x01cb} + , + {0x01f2, 0x01f2} + , + {0x1f88, 0x1f8f} + , + {0x1f98, 0x1f9f} + , + {0x1fa8, 0x1faf} + , + {0x1fbc, 0x1fbc} + , + {0x1fcc, 0x1fcc} + , + {0x1ffc, 0x1ffc} +}; + +scm_t_char_set cs_title_case = { + 10, + cs_title_case_ranges +}; + +scm_t_char_range cs_letter_ranges[] = { + {0x0041, 0x005a} + , + {0x0061, 0x007a} + , + {0x00aa, 0x00aa} + , + {0x00b5, 0x00b5} + , + {0x00ba, 0x00ba} + , + {0x00c0, 0x00d6} + , + {0x00d8, 0x00f6} + , + {0x00f8, 0x02c1} + , + {0x02c6, 0x02d1} + , + {0x02e0, 0x02e4} + , + {0x02ec, 0x02ec} + , + {0x02ee, 0x02ee} + , + {0x0370, 0x0374} + , + {0x0376, 0x0377} + , + {0x037a, 0x037d} + , + {0x0386, 0x0386} + , + {0x0388, 0x038a} + , + {0x038c, 0x038c} + , + {0x038e, 0x03a1} + , + {0x03a3, 0x03f5} + , + {0x03f7, 0x0481} + , + {0x048a, 0x0523} + , + {0x0531, 0x0556} + , + {0x0559, 0x0559} + , + {0x0561, 0x0587} + , + {0x05d0, 0x05ea} + , + {0x05f0, 0x05f2} + , + {0x0621, 0x064a} + , + {0x066e, 0x066f} + , + {0x0671, 0x06d3} + , + {0x06d5, 0x06d5} + , + {0x06e5, 0x06e6} + , + {0x06ee, 0x06ef} + , + {0x06fa, 0x06fc} + , + {0x06ff, 0x06ff} + , + {0x0710, 0x0710} + , + {0x0712, 0x072f} + , + {0x074d, 0x07a5} + , + {0x07b1, 0x07b1} + , + {0x07ca, 0x07ea} + , + {0x07f4, 0x07f5} + , + {0x07fa, 0x07fa} + , + {0x0904, 0x0939} + , + {0x093d, 0x093d} + , + {0x0950, 0x0950} + , + {0x0958, 0x0961} + , + {0x0971, 0x0972} + , + {0x097b, 0x097f} + , + {0x0985, 0x098c} + , + {0x098f, 0x0990} + , + {0x0993, 0x09a8} + , + {0x09aa, 0x09b0} + , + {0x09b2, 0x09b2} + , + {0x09b6, 0x09b9} + , + {0x09bd, 0x09bd} + , + {0x09ce, 0x09ce} + , + {0x09dc, 0x09dd} + , + {0x09df, 0x09e1} + , + {0x09f0, 0x09f1} + , + {0x0a05, 0x0a0a} + , + {0x0a0f, 0x0a10} + , + {0x0a13, 0x0a28} + , + {0x0a2a, 0x0a30} + , + {0x0a32, 0x0a33} + , + {0x0a35, 0x0a36} + , + {0x0a38, 0x0a39} + , + {0x0a59, 0x0a5c} + , + {0x0a5e, 0x0a5e} + , + {0x0a72, 0x0a74} + , + {0x0a85, 0x0a8d} + , + {0x0a8f, 0x0a91} + , + {0x0a93, 0x0aa8} + , + {0x0aaa, 0x0ab0} + , + {0x0ab2, 0x0ab3} + , + {0x0ab5, 0x0ab9} + , + {0x0abd, 0x0abd} + , + {0x0ad0, 0x0ad0} + , + {0x0ae0, 0x0ae1} + , + {0x0b05, 0x0b0c} + , + {0x0b0f, 0x0b10} + , + {0x0b13, 0x0b28} + , + {0x0b2a, 0x0b30} + , + {0x0b32, 0x0b33} + , + {0x0b35, 0x0b39} + , + {0x0b3d, 0x0b3d} + , + {0x0b5c, 0x0b5d} + , + {0x0b5f, 0x0b61} + , + {0x0b71, 0x0b71} + , + {0x0b83, 0x0b83} + , + {0x0b85, 0x0b8a} + , + {0x0b8e, 0x0b90} + , + {0x0b92, 0x0b95} + , + {0x0b99, 0x0b9a} + , + {0x0b9c, 0x0b9c} + , + {0x0b9e, 0x0b9f} + , + {0x0ba3, 0x0ba4} + , + {0x0ba8, 0x0baa} + , + {0x0bae, 0x0bb9} + , + {0x0bd0, 0x0bd0} + , + {0x0c05, 0x0c0c} + , + {0x0c0e, 0x0c10} + , + {0x0c12, 0x0c28} + , + {0x0c2a, 0x0c33} + , + {0x0c35, 0x0c39} + , + {0x0c3d, 0x0c3d} + , + {0x0c58, 0x0c59} + , + {0x0c60, 0x0c61} + , + {0x0c85, 0x0c8c} + , + {0x0c8e, 0x0c90} + , + {0x0c92, 0x0ca8} + , + {0x0caa, 0x0cb3} + , + {0x0cb5, 0x0cb9} + , + {0x0cbd, 0x0cbd} + , + {0x0cde, 0x0cde} + , + {0x0ce0, 0x0ce1} + , + {0x0d05, 0x0d0c} + , + {0x0d0e, 0x0d10} + , + {0x0d12, 0x0d28} + , + {0x0d2a, 0x0d39} + , + {0x0d3d, 0x0d3d} + , + {0x0d60, 0x0d61} + , + {0x0d7a, 0x0d7f} + , + {0x0d85, 0x0d96} + , + {0x0d9a, 0x0db1} + , + {0x0db3, 0x0dbb} + , + {0x0dbd, 0x0dbd} + , + {0x0dc0, 0x0dc6} + , + {0x0e01, 0x0e30} + , + {0x0e32, 0x0e33} + , + {0x0e40, 0x0e46} + , + {0x0e81, 0x0e82} + , + {0x0e84, 0x0e84} + , + {0x0e87, 0x0e88} + , + {0x0e8a, 0x0e8a} + , + {0x0e8d, 0x0e8d} + , + {0x0e94, 0x0e97} + , + {0x0e99, 0x0e9f} + , + {0x0ea1, 0x0ea3} + , + {0x0ea5, 0x0ea5} + , + {0x0ea7, 0x0ea7} + , + {0x0eaa, 0x0eab} + , + {0x0ead, 0x0eb0} + , + {0x0eb2, 0x0eb3} + , + {0x0ebd, 0x0ebd} + , + {0x0ec0, 0x0ec4} + , + {0x0ec6, 0x0ec6} + , + {0x0edc, 0x0edd} + , + {0x0f00, 0x0f00} + , + {0x0f40, 0x0f47} + , + {0x0f49, 0x0f6c} + , + {0x0f88, 0x0f8b} + , + {0x1000, 0x102a} + , + {0x103f, 0x103f} + , + {0x1050, 0x1055} + , + {0x105a, 0x105d} + , + {0x1061, 0x1061} + , + {0x1065, 0x1066} + , + {0x106e, 0x1070} + , + {0x1075, 0x1081} + , + {0x108e, 0x108e} + , + {0x10a0, 0x10c5} + , + {0x10d0, 0x10fa} + , + {0x10fc, 0x10fc} + , + {0x1100, 0x1159} + , + {0x115f, 0x11a2} + , + {0x11a8, 0x11f9} + , + {0x1200, 0x1248} + , + {0x124a, 0x124d} + , + {0x1250, 0x1256} + , + {0x1258, 0x1258} + , + {0x125a, 0x125d} + , + {0x1260, 0x1288} + , + {0x128a, 0x128d} + , + {0x1290, 0x12b0} + , + {0x12b2, 0x12b5} + , + {0x12b8, 0x12be} + , + {0x12c0, 0x12c0} + , + {0x12c2, 0x12c5} + , + {0x12c8, 0x12d6} + , + {0x12d8, 0x1310} + , + {0x1312, 0x1315} + , + {0x1318, 0x135a} + , + {0x1380, 0x138f} + , + {0x13a0, 0x13f4} + , + {0x1401, 0x166c} + , + {0x166f, 0x1676} + , + {0x1681, 0x169a} + , + {0x16a0, 0x16ea} + , + {0x1700, 0x170c} + , + {0x170e, 0x1711} + , + {0x1720, 0x1731} + , + {0x1740, 0x1751} + , + {0x1760, 0x176c} + , + {0x176e, 0x1770} + , + {0x1780, 0x17b3} + , + {0x17d7, 0x17d7} + , + {0x17dc, 0x17dc} + , + {0x1820, 0x1877} + , + {0x1880, 0x18a8} + , + {0x18aa, 0x18aa} + , + {0x1900, 0x191c} + , + {0x1950, 0x196d} + , + {0x1970, 0x1974} + , + {0x1980, 0x19a9} + , + {0x19c1, 0x19c7} + , + {0x1a00, 0x1a16} + , + {0x1b05, 0x1b33} + , + {0x1b45, 0x1b4b} + , + {0x1b83, 0x1ba0} + , + {0x1bae, 0x1baf} + , + {0x1c00, 0x1c23} + , + {0x1c4d, 0x1c4f} + , + {0x1c5a, 0x1c7d} + , + {0x1d00, 0x1dbf} + , + {0x1e00, 0x1f15} + , + {0x1f18, 0x1f1d} + , + {0x1f20, 0x1f45} + , + {0x1f48, 0x1f4d} + , + {0x1f50, 0x1f57} + , + {0x1f59, 0x1f59} + , + {0x1f5b, 0x1f5b} + , + {0x1f5d, 0x1f5d} + , + {0x1f5f, 0x1f7d} + , + {0x1f80, 0x1fb4} + , + {0x1fb6, 0x1fbc} + , + {0x1fbe, 0x1fbe} + , + {0x1fc2, 0x1fc4} + , + {0x1fc6, 0x1fcc} + , + {0x1fd0, 0x1fd3} + , + {0x1fd6, 0x1fdb} + , + {0x1fe0, 0x1fec} + , + {0x1ff2, 0x1ff4} + , + {0x1ff6, 0x1ffc} + , + {0x2071, 0x2071} + , + {0x207f, 0x207f} + , + {0x2090, 0x2094} + , + {0x2102, 0x2102} + , + {0x2107, 0x2107} + , + {0x210a, 0x2113} + , + {0x2115, 0x2115} + , + {0x2119, 0x211d} + , + {0x2124, 0x2124} + , + {0x2126, 0x2126} + , + {0x2128, 0x2128} + , + {0x212a, 0x212d} + , + {0x212f, 0x2139} + , + {0x213c, 0x213f} + , + {0x2145, 0x2149} + , + {0x214e, 0x214e} + , + {0x2183, 0x2184} + , + {0x2c00, 0x2c2e} + , + {0x2c30, 0x2c5e} + , + {0x2c60, 0x2c6f} + , + {0x2c71, 0x2c7d} + , + {0x2c80, 0x2ce4} + , + {0x2d00, 0x2d25} + , + {0x2d30, 0x2d65} + , + {0x2d6f, 0x2d6f} + , + {0x2d80, 0x2d96} + , + {0x2da0, 0x2da6} + , + {0x2da8, 0x2dae} + , + {0x2db0, 0x2db6} + , + {0x2db8, 0x2dbe} + , + {0x2dc0, 0x2dc6} + , + {0x2dc8, 0x2dce} + , + {0x2dd0, 0x2dd6} + , + {0x2dd8, 0x2dde} + , + {0x2e2f, 0x2e2f} + , + {0x3005, 0x3006} + , + {0x3031, 0x3035} + , + {0x303b, 0x303c} + , + {0x3041, 0x3096} + , + {0x309d, 0x309f} + , + {0x30a1, 0x30fa} + , + {0x30fc, 0x30ff} + , + {0x3105, 0x312d} + , + {0x3131, 0x318e} + , + {0x31a0, 0x31b7} + , + {0x31f0, 0x31ff} + , + {0x3400, 0x4db5} + , + {0x4e00, 0x9fc3} + , + {0xa000, 0xa48c} + , + {0xa500, 0xa60c} + , + {0xa610, 0xa61f} + , + {0xa62a, 0xa62b} + , + {0xa640, 0xa65f} + , + {0xa662, 0xa66e} + , + {0xa67f, 0xa697} + , + {0xa717, 0xa71f} + , + {0xa722, 0xa788} + , + {0xa78b, 0xa78c} + , + {0xa7fb, 0xa801} + , + {0xa803, 0xa805} + , + {0xa807, 0xa80a} + , + {0xa80c, 0xa822} + , + {0xa840, 0xa873} + , + {0xa882, 0xa8b3} + , + {0xa90a, 0xa925} + , + {0xa930, 0xa946} + , + {0xaa00, 0xaa28} + , + {0xaa40, 0xaa42} + , + {0xaa44, 0xaa4b} + , + {0xac00, 0xd7a3} + , + {0xf900, 0xfa2d} + , + {0xfa30, 0xfa6a} + , + {0xfa70, 0xfad9} + , + {0xfb00, 0xfb06} + , + {0xfb13, 0xfb17} + , + {0xfb1d, 0xfb1d} + , + {0xfb1f, 0xfb28} + , + {0xfb2a, 0xfb36} + , + {0xfb38, 0xfb3c} + , + {0xfb3e, 0xfb3e} + , + {0xfb40, 0xfb41} + , + {0xfb43, 0xfb44} + , + {0xfb46, 0xfbb1} + , + {0xfbd3, 0xfd3d} + , + {0xfd50, 0xfd8f} + , + {0xfd92, 0xfdc7} + , + {0xfdf0, 0xfdfb} + , + {0xfe70, 0xfe74} + , + {0xfe76, 0xfefc} + , + {0xff21, 0xff3a} + , + {0xff41, 0xff5a} + , + {0xff66, 0xffbe} + , + {0xffc2, 0xffc7} + , + {0xffca, 0xffcf} + , + {0xffd2, 0xffd7} + , + {0xffda, 0xffdc} + , + {0x10000, 0x1000b} + , + {0x1000d, 0x10026} + , + {0x10028, 0x1003a} + , + {0x1003c, 0x1003d} + , + {0x1003f, 0x1004d} + , + {0x10050, 0x1005d} + , + {0x10080, 0x100fa} + , + {0x10280, 0x1029c} + , + {0x102a0, 0x102d0} + , + {0x10300, 0x1031e} + , + {0x10330, 0x10340} + , + {0x10342, 0x10349} + , + {0x10380, 0x1039d} + , + {0x103a0, 0x103c3} + , + {0x103c8, 0x103cf} + , + {0x10400, 0x1049d} + , + {0x10800, 0x10805} + , + {0x10808, 0x10808} + , + {0x1080a, 0x10835} + , + {0x10837, 0x10838} + , + {0x1083c, 0x1083c} + , + {0x1083f, 0x1083f} + , + {0x10900, 0x10915} + , + {0x10920, 0x10939} + , + {0x10a00, 0x10a00} + , + {0x10a10, 0x10a13} + , + {0x10a15, 0x10a17} + , + {0x10a19, 0x10a33} + , + {0x12000, 0x1236e} + , + {0x1d400, 0x1d454} + , + {0x1d456, 0x1d49c} + , + {0x1d49e, 0x1d49f} + , + {0x1d4a2, 0x1d4a2} + , + {0x1d4a5, 0x1d4a6} + , + {0x1d4a9, 0x1d4ac} + , + {0x1d4ae, 0x1d4b9} + , + {0x1d4bb, 0x1d4bb} + , + {0x1d4bd, 0x1d4c3} + , + {0x1d4c5, 0x1d505} + , + {0x1d507, 0x1d50a} + , + {0x1d50d, 0x1d514} + , + {0x1d516, 0x1d51c} + , + {0x1d51e, 0x1d539} + , + {0x1d53b, 0x1d53e} + , + {0x1d540, 0x1d544} + , + {0x1d546, 0x1d546} + , + {0x1d54a, 0x1d550} + , + {0x1d552, 0x1d6a5} + , + {0x1d6a8, 0x1d6c0} + , + {0x1d6c2, 0x1d6da} + , + {0x1d6dc, 0x1d6fa} + , + {0x1d6fc, 0x1d714} + , + {0x1d716, 0x1d734} + , + {0x1d736, 0x1d74e} + , + {0x1d750, 0x1d76e} + , + {0x1d770, 0x1d788} + , + {0x1d78a, 0x1d7a8} + , + {0x1d7aa, 0x1d7c2} + , + {0x1d7c4, 0x1d7cb} + , + {0x20000, 0x2a6d6} + , + {0x2f800, 0x2fa1d} +}; + +scm_t_char_set cs_letter = { + 390, + cs_letter_ranges +}; + +scm_t_char_range cs_digit_ranges[] = { + {0x0030, 0x0039} + , + {0x0660, 0x0669} + , + {0x06f0, 0x06f9} + , + {0x07c0, 0x07c9} + , + {0x0966, 0x096f} + , + {0x09e6, 0x09ef} + , + {0x0a66, 0x0a6f} + , + {0x0ae6, 0x0aef} + , + {0x0b66, 0x0b6f} + , + {0x0be6, 0x0bef} + , + {0x0c66, 0x0c6f} + , + {0x0ce6, 0x0cef} + , + {0x0d66, 0x0d6f} + , + {0x0e50, 0x0e59} + , + {0x0ed0, 0x0ed9} + , + {0x0f20, 0x0f29} + , + {0x1040, 0x1049} + , + {0x1090, 0x1099} + , + {0x17e0, 0x17e9} + , + {0x1810, 0x1819} + , + {0x1946, 0x194f} + , + {0x19d0, 0x19d9} + , + {0x1b50, 0x1b59} + , + {0x1bb0, 0x1bb9} + , + {0x1c40, 0x1c49} + , + {0x1c50, 0x1c59} + , + {0xa620, 0xa629} + , + {0xa8d0, 0xa8d9} + , + {0xa900, 0xa909} + , + {0xaa50, 0xaa59} + , + {0xff10, 0xff19} + , + {0x104a0, 0x104a9} + , + {0x1d7ce, 0x1d7ff} +}; + +scm_t_char_set cs_digit = { + 33, + cs_digit_ranges +}; + +scm_t_char_range cs_hex_digit_ranges[] = { + {0x0030, 0x0039} + , + {0x0041, 0x0046} + , + {0x0061, 0x0066} +}; + +scm_t_char_set cs_hex_digit = { + 3, + cs_hex_digit_ranges +}; + +scm_t_char_range cs_letter_plus_digit_ranges[] = { + {0x0030, 0x0039} + , + {0x0041, 0x005a} + , + {0x0061, 0x007a} + , + {0x00aa, 0x00aa} + , + {0x00b5, 0x00b5} + , + {0x00ba, 0x00ba} + , + {0x00c0, 0x00d6} + , + {0x00d8, 0x00f6} + , + {0x00f8, 0x02c1} + , + {0x02c6, 0x02d1} + , + {0x02e0, 0x02e4} + , + {0x02ec, 0x02ec} + , + {0x02ee, 0x02ee} + , + {0x0370, 0x0374} + , + {0x0376, 0x0377} + , + {0x037a, 0x037d} + , + {0x0386, 0x0386} + , + {0x0388, 0x038a} + , + {0x038c, 0x038c} + , + {0x038e, 0x03a1} + , + {0x03a3, 0x03f5} + , + {0x03f7, 0x0481} + , + {0x048a, 0x0523} + , + {0x0531, 0x0556} + , + {0x0559, 0x0559} + , + {0x0561, 0x0587} + , + {0x05d0, 0x05ea} + , + {0x05f0, 0x05f2} + , + {0x0621, 0x064a} + , + {0x0660, 0x0669} + , + {0x066e, 0x066f} + , + {0x0671, 0x06d3} + , + {0x06d5, 0x06d5} + , + {0x06e5, 0x06e6} + , + {0x06ee, 0x06fc} + , + {0x06ff, 0x06ff} + , + {0x0710, 0x0710} + , + {0x0712, 0x072f} + , + {0x074d, 0x07a5} + , + {0x07b1, 0x07b1} + , + {0x07c0, 0x07ea} + , + {0x07f4, 0x07f5} + , + {0x07fa, 0x07fa} + , + {0x0904, 0x0939} + , + {0x093d, 0x093d} + , + {0x0950, 0x0950} + , + {0x0958, 0x0961} + , + {0x0966, 0x096f} + , + {0x0971, 0x0972} + , + {0x097b, 0x097f} + , + {0x0985, 0x098c} + , + {0x098f, 0x0990} + , + {0x0993, 0x09a8} + , + {0x09aa, 0x09b0} + , + {0x09b2, 0x09b2} + , + {0x09b6, 0x09b9} + , + {0x09bd, 0x09bd} + , + {0x09ce, 0x09ce} + , + {0x09dc, 0x09dd} + , + {0x09df, 0x09e1} + , + {0x09e6, 0x09f1} + , + {0x0a05, 0x0a0a} + , + {0x0a0f, 0x0a10} + , + {0x0a13, 0x0a28} + , + {0x0a2a, 0x0a30} + , + {0x0a32, 0x0a33} + , + {0x0a35, 0x0a36} + , + {0x0a38, 0x0a39} + , + {0x0a59, 0x0a5c} + , + {0x0a5e, 0x0a5e} + , + {0x0a66, 0x0a6f} + , + {0x0a72, 0x0a74} + , + {0x0a85, 0x0a8d} + , + {0x0a8f, 0x0a91} + , + {0x0a93, 0x0aa8} + , + {0x0aaa, 0x0ab0} + , + {0x0ab2, 0x0ab3} + , + {0x0ab5, 0x0ab9} + , + {0x0abd, 0x0abd} + , + {0x0ad0, 0x0ad0} + , + {0x0ae0, 0x0ae1} + , + {0x0ae6, 0x0aef} + , + {0x0b05, 0x0b0c} + , + {0x0b0f, 0x0b10} + , + {0x0b13, 0x0b28} + , + {0x0b2a, 0x0b30} + , + {0x0b32, 0x0b33} + , + {0x0b35, 0x0b39} + , + {0x0b3d, 0x0b3d} + , + {0x0b5c, 0x0b5d} + , + {0x0b5f, 0x0b61} + , + {0x0b66, 0x0b6f} + , + {0x0b71, 0x0b71} + , + {0x0b83, 0x0b83} + , + {0x0b85, 0x0b8a} + , + {0x0b8e, 0x0b90} + , + {0x0b92, 0x0b95} + , + {0x0b99, 0x0b9a} + , + {0x0b9c, 0x0b9c} + , + {0x0b9e, 0x0b9f} + , + {0x0ba3, 0x0ba4} + , + {0x0ba8, 0x0baa} + , + {0x0bae, 0x0bb9} + , + {0x0bd0, 0x0bd0} + , + {0x0be6, 0x0bef} + , + {0x0c05, 0x0c0c} + , + {0x0c0e, 0x0c10} + , + {0x0c12, 0x0c28} + , + {0x0c2a, 0x0c33} + , + {0x0c35, 0x0c39} + , + {0x0c3d, 0x0c3d} + , + {0x0c58, 0x0c59} + , + {0x0c60, 0x0c61} + , + {0x0c66, 0x0c6f} + , + {0x0c85, 0x0c8c} + , + {0x0c8e, 0x0c90} + , + {0x0c92, 0x0ca8} + , + {0x0caa, 0x0cb3} + , + {0x0cb5, 0x0cb9} + , + {0x0cbd, 0x0cbd} + , + {0x0cde, 0x0cde} + , + {0x0ce0, 0x0ce1} + , + {0x0ce6, 0x0cef} + , + {0x0d05, 0x0d0c} + , + {0x0d0e, 0x0d10} + , + {0x0d12, 0x0d28} + , + {0x0d2a, 0x0d39} + , + {0x0d3d, 0x0d3d} + , + {0x0d60, 0x0d61} + , + {0x0d66, 0x0d6f} + , + {0x0d7a, 0x0d7f} + , + {0x0d85, 0x0d96} + , + {0x0d9a, 0x0db1} + , + {0x0db3, 0x0dbb} + , + {0x0dbd, 0x0dbd} + , + {0x0dc0, 0x0dc6} + , + {0x0e01, 0x0e30} + , + {0x0e32, 0x0e33} + , + {0x0e40, 0x0e46} + , + {0x0e50, 0x0e59} + , + {0x0e81, 0x0e82} + , + {0x0e84, 0x0e84} + , + {0x0e87, 0x0e88} + , + {0x0e8a, 0x0e8a} + , + {0x0e8d, 0x0e8d} + , + {0x0e94, 0x0e97} + , + {0x0e99, 0x0e9f} + , + {0x0ea1, 0x0ea3} + , + {0x0ea5, 0x0ea5} + , + {0x0ea7, 0x0ea7} + , + {0x0eaa, 0x0eab} + , + {0x0ead, 0x0eb0} + , + {0x0eb2, 0x0eb3} + , + {0x0ebd, 0x0ebd} + , + {0x0ec0, 0x0ec4} + , + {0x0ec6, 0x0ec6} + , + {0x0ed0, 0x0ed9} + , + {0x0edc, 0x0edd} + , + {0x0f00, 0x0f00} + , + {0x0f20, 0x0f29} + , + {0x0f40, 0x0f47} + , + {0x0f49, 0x0f6c} + , + {0x0f88, 0x0f8b} + , + {0x1000, 0x102a} + , + {0x103f, 0x1049} + , + {0x1050, 0x1055} + , + {0x105a, 0x105d} + , + {0x1061, 0x1061} + , + {0x1065, 0x1066} + , + {0x106e, 0x1070} + , + {0x1075, 0x1081} + , + {0x108e, 0x108e} + , + {0x1090, 0x1099} + , + {0x10a0, 0x10c5} + , + {0x10d0, 0x10fa} + , + {0x10fc, 0x10fc} + , + {0x1100, 0x1159} + , + {0x115f, 0x11a2} + , + {0x11a8, 0x11f9} + , + {0x1200, 0x1248} + , + {0x124a, 0x124d} + , + {0x1250, 0x1256} + , + {0x1258, 0x1258} + , + {0x125a, 0x125d} + , + {0x1260, 0x1288} + , + {0x128a, 0x128d} + , + {0x1290, 0x12b0} + , + {0x12b2, 0x12b5} + , + {0x12b8, 0x12be} + , + {0x12c0, 0x12c0} + , + {0x12c2, 0x12c5} + , + {0x12c8, 0x12d6} + , + {0x12d8, 0x1310} + , + {0x1312, 0x1315} + , + {0x1318, 0x135a} + , + {0x1380, 0x138f} + , + {0x13a0, 0x13f4} + , + {0x1401, 0x166c} + , + {0x166f, 0x1676} + , + {0x1681, 0x169a} + , + {0x16a0, 0x16ea} + , + {0x1700, 0x170c} + , + {0x170e, 0x1711} + , + {0x1720, 0x1731} + , + {0x1740, 0x1751} + , + {0x1760, 0x176c} + , + {0x176e, 0x1770} + , + {0x1780, 0x17b3} + , + {0x17d7, 0x17d7} + , + {0x17dc, 0x17dc} + , + {0x17e0, 0x17e9} + , + {0x1810, 0x1819} + , + {0x1820, 0x1877} + , + {0x1880, 0x18a8} + , + {0x18aa, 0x18aa} + , + {0x1900, 0x191c} + , + {0x1946, 0x196d} + , + {0x1970, 0x1974} + , + {0x1980, 0x19a9} + , + {0x19c1, 0x19c7} + , + {0x19d0, 0x19d9} + , + {0x1a00, 0x1a16} + , + {0x1b05, 0x1b33} + , + {0x1b45, 0x1b4b} + , + {0x1b50, 0x1b59} + , + {0x1b83, 0x1ba0} + , + {0x1bae, 0x1bb9} + , + {0x1c00, 0x1c23} + , + {0x1c40, 0x1c49} + , + {0x1c4d, 0x1c7d} + , + {0x1d00, 0x1dbf} + , + {0x1e00, 0x1f15} + , + {0x1f18, 0x1f1d} + , + {0x1f20, 0x1f45} + , + {0x1f48, 0x1f4d} + , + {0x1f50, 0x1f57} + , + {0x1f59, 0x1f59} + , + {0x1f5b, 0x1f5b} + , + {0x1f5d, 0x1f5d} + , + {0x1f5f, 0x1f7d} + , + {0x1f80, 0x1fb4} + , + {0x1fb6, 0x1fbc} + , + {0x1fbe, 0x1fbe} + , + {0x1fc2, 0x1fc4} + , + {0x1fc6, 0x1fcc} + , + {0x1fd0, 0x1fd3} + , + {0x1fd6, 0x1fdb} + , + {0x1fe0, 0x1fec} + , + {0x1ff2, 0x1ff4} + , + {0x1ff6, 0x1ffc} + , + {0x2071, 0x2071} + , + {0x207f, 0x207f} + , + {0x2090, 0x2094} + , + {0x2102, 0x2102} + , + {0x2107, 0x2107} + , + {0x210a, 0x2113} + , + {0x2115, 0x2115} + , + {0x2119, 0x211d} + , + {0x2124, 0x2124} + , + {0x2126, 0x2126} + , + {0x2128, 0x2128} + , + {0x212a, 0x212d} + , + {0x212f, 0x2139} + , + {0x213c, 0x213f} + , + {0x2145, 0x2149} + , + {0x214e, 0x214e} + , + {0x2183, 0x2184} + , + {0x2c00, 0x2c2e} + , + {0x2c30, 0x2c5e} + , + {0x2c60, 0x2c6f} + , + {0x2c71, 0x2c7d} + , + {0x2c80, 0x2ce4} + , + {0x2d00, 0x2d25} + , + {0x2d30, 0x2d65} + , + {0x2d6f, 0x2d6f} + , + {0x2d80, 0x2d96} + , + {0x2da0, 0x2da6} + , + {0x2da8, 0x2dae} + , + {0x2db0, 0x2db6} + , + {0x2db8, 0x2dbe} + , + {0x2dc0, 0x2dc6} + , + {0x2dc8, 0x2dce} + , + {0x2dd0, 0x2dd6} + , + {0x2dd8, 0x2dde} + , + {0x2e2f, 0x2e2f} + , + {0x3005, 0x3006} + , + {0x3031, 0x3035} + , + {0x303b, 0x303c} + , + {0x3041, 0x3096} + , + {0x309d, 0x309f} + , + {0x30a1, 0x30fa} + , + {0x30fc, 0x30ff} + , + {0x3105, 0x312d} + , + {0x3131, 0x318e} + , + {0x31a0, 0x31b7} + , + {0x31f0, 0x31ff} + , + {0x3400, 0x4db5} + , + {0x4e00, 0x9fc3} + , + {0xa000, 0xa48c} + , + {0xa500, 0xa60c} + , + {0xa610, 0xa62b} + , + {0xa640, 0xa65f} + , + {0xa662, 0xa66e} + , + {0xa67f, 0xa697} + , + {0xa717, 0xa71f} + , + {0xa722, 0xa788} + , + {0xa78b, 0xa78c} + , + {0xa7fb, 0xa801} + , + {0xa803, 0xa805} + , + {0xa807, 0xa80a} + , + {0xa80c, 0xa822} + , + {0xa840, 0xa873} + , + {0xa882, 0xa8b3} + , + {0xa8d0, 0xa8d9} + , + {0xa900, 0xa925} + , + {0xa930, 0xa946} + , + {0xaa00, 0xaa28} + , + {0xaa40, 0xaa42} + , + {0xaa44, 0xaa4b} + , + {0xaa50, 0xaa59} + , + {0xac00, 0xd7a3} + , + {0xf900, 0xfa2d} + , + {0xfa30, 0xfa6a} + , + {0xfa70, 0xfad9} + , + {0xfb00, 0xfb06} + , + {0xfb13, 0xfb17} + , + {0xfb1d, 0xfb1d} + , + {0xfb1f, 0xfb28} + , + {0xfb2a, 0xfb36} + , + {0xfb38, 0xfb3c} + , + {0xfb3e, 0xfb3e} + , + {0xfb40, 0xfb41} + , + {0xfb43, 0xfb44} + , + {0xfb46, 0xfbb1} + , + {0xfbd3, 0xfd3d} + , + {0xfd50, 0xfd8f} + , + {0xfd92, 0xfdc7} + , + {0xfdf0, 0xfdfb} + , + {0xfe70, 0xfe74} + , + {0xfe76, 0xfefc} + , + {0xff10, 0xff19} + , + {0xff21, 0xff3a} + , + {0xff41, 0xff5a} + , + {0xff66, 0xffbe} + , + {0xffc2, 0xffc7} + , + {0xffca, 0xffcf} + , + {0xffd2, 0xffd7} + , + {0xffda, 0xffdc} + , + {0x10000, 0x1000b} + , + {0x1000d, 0x10026} + , + {0x10028, 0x1003a} + , + {0x1003c, 0x1003d} + , + {0x1003f, 0x1004d} + , + {0x10050, 0x1005d} + , + {0x10080, 0x100fa} + , + {0x10280, 0x1029c} + , + {0x102a0, 0x102d0} + , + {0x10300, 0x1031e} + , + {0x10330, 0x10340} + , + {0x10342, 0x10349} + , + {0x10380, 0x1039d} + , + {0x103a0, 0x103c3} + , + {0x103c8, 0x103cf} + , + {0x10400, 0x1049d} + , + {0x104a0, 0x104a9} + , + {0x10800, 0x10805} + , + {0x10808, 0x10808} + , + {0x1080a, 0x10835} + , + {0x10837, 0x10838} + , + {0x1083c, 0x1083c} + , + {0x1083f, 0x1083f} + , + {0x10900, 0x10915} + , + {0x10920, 0x10939} + , + {0x10a00, 0x10a00} + , + {0x10a10, 0x10a13} + , + {0x10a15, 0x10a17} + , + {0x10a19, 0x10a33} + , + {0x12000, 0x1236e} + , + {0x1d400, 0x1d454} + , + {0x1d456, 0x1d49c} + , + {0x1d49e, 0x1d49f} + , + {0x1d4a2, 0x1d4a2} + , + {0x1d4a5, 0x1d4a6} + , + {0x1d4a9, 0x1d4ac} + , + {0x1d4ae, 0x1d4b9} + , + {0x1d4bb, 0x1d4bb} + , + {0x1d4bd, 0x1d4c3} + , + {0x1d4c5, 0x1d505} + , + {0x1d507, 0x1d50a} + , + {0x1d50d, 0x1d514} + , + {0x1d516, 0x1d51c} + , + {0x1d51e, 0x1d539} + , + {0x1d53b, 0x1d53e} + , + {0x1d540, 0x1d544} + , + {0x1d546, 0x1d546} + , + {0x1d54a, 0x1d550} + , + {0x1d552, 0x1d6a5} + , + {0x1d6a8, 0x1d6c0} + , + {0x1d6c2, 0x1d6da} + , + {0x1d6dc, 0x1d6fa} + , + {0x1d6fc, 0x1d714} + , + {0x1d716, 0x1d734} + , + {0x1d736, 0x1d74e} + , + {0x1d750, 0x1d76e} + , + {0x1d770, 0x1d788} + , + {0x1d78a, 0x1d7a8} + , + {0x1d7aa, 0x1d7c2} + , + {0x1d7c4, 0x1d7cb} + , + {0x1d7ce, 0x1d7ff} + , + {0x20000, 0x2a6d6} + , + {0x2f800, 0x2fa1d} +}; + +scm_t_char_set cs_letter_plus_digit = { + 411, + cs_letter_plus_digit_ranges +}; + +scm_t_char_range cs_graphic_ranges[] = { + {0x0021, 0x007e} + , + {0x00a1, 0x00ac} + , + {0x00ae, 0x0377} + , + {0x037a, 0x037e} + , + {0x0384, 0x038a} + , + {0x038c, 0x038c} + , + {0x038e, 0x03a1} + , + {0x03a3, 0x0523} + , + {0x0531, 0x0556} + , + {0x0559, 0x055f} + , + {0x0561, 0x0587} + , + {0x0589, 0x058a} + , + {0x0591, 0x05c7} + , + {0x05d0, 0x05ea} + , + {0x05f0, 0x05f4} + , + {0x0606, 0x061b} + , + {0x061e, 0x061f} + , + {0x0621, 0x065e} + , + {0x0660, 0x06dc} + , + {0x06de, 0x070d} + , + {0x0710, 0x074a} + , + {0x074d, 0x07b1} + , + {0x07c0, 0x07fa} + , + {0x0901, 0x0939} + , + {0x093c, 0x094d} + , + {0x0950, 0x0954} + , + {0x0958, 0x0972} + , + {0x097b, 0x097f} + , + {0x0981, 0x0983} + , + {0x0985, 0x098c} + , + {0x098f, 0x0990} + , + {0x0993, 0x09a8} + , + {0x09aa, 0x09b0} + , + {0x09b2, 0x09b2} + , + {0x09b6, 0x09b9} + , + {0x09bc, 0x09c4} + , + {0x09c7, 0x09c8} + , + {0x09cb, 0x09ce} + , + {0x09d7, 0x09d7} + , + {0x09dc, 0x09dd} + , + {0x09df, 0x09e3} + , + {0x09e6, 0x09fa} + , + {0x0a01, 0x0a03} + , + {0x0a05, 0x0a0a} + , + {0x0a0f, 0x0a10} + , + {0x0a13, 0x0a28} + , + {0x0a2a, 0x0a30} + , + {0x0a32, 0x0a33} + , + {0x0a35, 0x0a36} + , + {0x0a38, 0x0a39} + , + {0x0a3c, 0x0a3c} + , + {0x0a3e, 0x0a42} + , + {0x0a47, 0x0a48} + , + {0x0a4b, 0x0a4d} + , + {0x0a51, 0x0a51} + , + {0x0a59, 0x0a5c} + , + {0x0a5e, 0x0a5e} + , + {0x0a66, 0x0a75} + , + {0x0a81, 0x0a83} + , + {0x0a85, 0x0a8d} + , + {0x0a8f, 0x0a91} + , + {0x0a93, 0x0aa8} + , + {0x0aaa, 0x0ab0} + , + {0x0ab2, 0x0ab3} + , + {0x0ab5, 0x0ab9} + , + {0x0abc, 0x0ac5} + , + {0x0ac7, 0x0ac9} + , + {0x0acb, 0x0acd} + , + {0x0ad0, 0x0ad0} + , + {0x0ae0, 0x0ae3} + , + {0x0ae6, 0x0aef} + , + {0x0af1, 0x0af1} + , + {0x0b01, 0x0b03} + , + {0x0b05, 0x0b0c} + , + {0x0b0f, 0x0b10} + , + {0x0b13, 0x0b28} + , + {0x0b2a, 0x0b30} + , + {0x0b32, 0x0b33} + , + {0x0b35, 0x0b39} + , + {0x0b3c, 0x0b44} + , + {0x0b47, 0x0b48} + , + {0x0b4b, 0x0b4d} + , + {0x0b56, 0x0b57} + , + {0x0b5c, 0x0b5d} + , + {0x0b5f, 0x0b63} + , + {0x0b66, 0x0b71} + , + {0x0b82, 0x0b83} + , + {0x0b85, 0x0b8a} + , + {0x0b8e, 0x0b90} + , + {0x0b92, 0x0b95} + , + {0x0b99, 0x0b9a} + , + {0x0b9c, 0x0b9c} + , + {0x0b9e, 0x0b9f} + , + {0x0ba3, 0x0ba4} + , + {0x0ba8, 0x0baa} + , + {0x0bae, 0x0bb9} + , + {0x0bbe, 0x0bc2} + , + {0x0bc6, 0x0bc8} + , + {0x0bca, 0x0bcd} + , + {0x0bd0, 0x0bd0} + , + {0x0bd7, 0x0bd7} + , + {0x0be6, 0x0bfa} + , + {0x0c01, 0x0c03} + , + {0x0c05, 0x0c0c} + , + {0x0c0e, 0x0c10} + , + {0x0c12, 0x0c28} + , + {0x0c2a, 0x0c33} + , + {0x0c35, 0x0c39} + , + {0x0c3d, 0x0c44} + , + {0x0c46, 0x0c48} + , + {0x0c4a, 0x0c4d} + , + {0x0c55, 0x0c56} + , + {0x0c58, 0x0c59} + , + {0x0c60, 0x0c63} + , + {0x0c66, 0x0c6f} + , + {0x0c78, 0x0c7f} + , + {0x0c82, 0x0c83} + , + {0x0c85, 0x0c8c} + , + {0x0c8e, 0x0c90} + , + {0x0c92, 0x0ca8} + , + {0x0caa, 0x0cb3} + , + {0x0cb5, 0x0cb9} + , + {0x0cbc, 0x0cc4} + , + {0x0cc6, 0x0cc8} + , + {0x0cca, 0x0ccd} + , + {0x0cd5, 0x0cd6} + , + {0x0cde, 0x0cde} + , + {0x0ce0, 0x0ce3} + , + {0x0ce6, 0x0cef} + , + {0x0cf1, 0x0cf2} + , + {0x0d02, 0x0d03} + , + {0x0d05, 0x0d0c} + , + {0x0d0e, 0x0d10} + , + {0x0d12, 0x0d28} + , + {0x0d2a, 0x0d39} + , + {0x0d3d, 0x0d44} + , + {0x0d46, 0x0d48} + , + {0x0d4a, 0x0d4d} + , + {0x0d57, 0x0d57} + , + {0x0d60, 0x0d63} + , + {0x0d66, 0x0d75} + , + {0x0d79, 0x0d7f} + , + {0x0d82, 0x0d83} + , + {0x0d85, 0x0d96} + , + {0x0d9a, 0x0db1} + , + {0x0db3, 0x0dbb} + , + {0x0dbd, 0x0dbd} + , + {0x0dc0, 0x0dc6} + , + {0x0dca, 0x0dca} + , + {0x0dcf, 0x0dd4} + , + {0x0dd6, 0x0dd6} + , + {0x0dd8, 0x0ddf} + , + {0x0df2, 0x0df4} + , + {0x0e01, 0x0e3a} + , + {0x0e3f, 0x0e5b} + , + {0x0e81, 0x0e82} + , + {0x0e84, 0x0e84} + , + {0x0e87, 0x0e88} + , + {0x0e8a, 0x0e8a} + , + {0x0e8d, 0x0e8d} + , + {0x0e94, 0x0e97} + , + {0x0e99, 0x0e9f} + , + {0x0ea1, 0x0ea3} + , + {0x0ea5, 0x0ea5} + , + {0x0ea7, 0x0ea7} + , + {0x0eaa, 0x0eab} + , + {0x0ead, 0x0eb9} + , + {0x0ebb, 0x0ebd} + , + {0x0ec0, 0x0ec4} + , + {0x0ec6, 0x0ec6} + , + {0x0ec8, 0x0ecd} + , + {0x0ed0, 0x0ed9} + , + {0x0edc, 0x0edd} + , + {0x0f00, 0x0f47} + , + {0x0f49, 0x0f6c} + , + {0x0f71, 0x0f8b} + , + {0x0f90, 0x0f97} + , + {0x0f99, 0x0fbc} + , + {0x0fbe, 0x0fcc} + , + {0x0fce, 0x0fd4} + , + {0x1000, 0x1099} + , + {0x109e, 0x10c5} + , + {0x10d0, 0x10fc} + , + {0x1100, 0x1159} + , + {0x115f, 0x11a2} + , + {0x11a8, 0x11f9} + , + {0x1200, 0x1248} + , + {0x124a, 0x124d} + , + {0x1250, 0x1256} + , + {0x1258, 0x1258} + , + {0x125a, 0x125d} + , + {0x1260, 0x1288} + , + {0x128a, 0x128d} + , + {0x1290, 0x12b0} + , + {0x12b2, 0x12b5} + , + {0x12b8, 0x12be} + , + {0x12c0, 0x12c0} + , + {0x12c2, 0x12c5} + , + {0x12c8, 0x12d6} + , + {0x12d8, 0x1310} + , + {0x1312, 0x1315} + , + {0x1318, 0x135a} + , + {0x135f, 0x137c} + , + {0x1380, 0x1399} + , + {0x13a0, 0x13f4} + , + {0x1401, 0x1676} + , + {0x1681, 0x169c} + , + {0x16a0, 0x16f0} + , + {0x1700, 0x170c} + , + {0x170e, 0x1714} + , + {0x1720, 0x1736} + , + {0x1740, 0x1753} + , + {0x1760, 0x176c} + , + {0x176e, 0x1770} + , + {0x1772, 0x1773} + , + {0x1780, 0x17b3} + , + {0x17b6, 0x17dd} + , + {0x17e0, 0x17e9} + , + {0x17f0, 0x17f9} + , + {0x1800, 0x180d} + , + {0x1810, 0x1819} + , + {0x1820, 0x1877} + , + {0x1880, 0x18aa} + , + {0x1900, 0x191c} + , + {0x1920, 0x192b} + , + {0x1930, 0x193b} + , + {0x1940, 0x1940} + , + {0x1944, 0x196d} + , + {0x1970, 0x1974} + , + {0x1980, 0x19a9} + , + {0x19b0, 0x19c9} + , + {0x19d0, 0x19d9} + , + {0x19de, 0x1a1b} + , + {0x1a1e, 0x1a1f} + , + {0x1b00, 0x1b4b} + , + {0x1b50, 0x1b7c} + , + {0x1b80, 0x1baa} + , + {0x1bae, 0x1bb9} + , + {0x1c00, 0x1c37} + , + {0x1c3b, 0x1c49} + , + {0x1c4d, 0x1c7f} + , + {0x1d00, 0x1de6} + , + {0x1dfe, 0x1f15} + , + {0x1f18, 0x1f1d} + , + {0x1f20, 0x1f45} + , + {0x1f48, 0x1f4d} + , + {0x1f50, 0x1f57} + , + {0x1f59, 0x1f59} + , + {0x1f5b, 0x1f5b} + , + {0x1f5d, 0x1f5d} + , + {0x1f5f, 0x1f7d} + , + {0x1f80, 0x1fb4} + , + {0x1fb6, 0x1fc4} + , + {0x1fc6, 0x1fd3} + , + {0x1fd6, 0x1fdb} + , + {0x1fdd, 0x1fef} + , + {0x1ff2, 0x1ff4} + , + {0x1ff6, 0x1ffe} + , + {0x2010, 0x2027} + , + {0x2030, 0x205e} + , + {0x2070, 0x2071} + , + {0x2074, 0x208e} + , + {0x2090, 0x2094} + , + {0x20a0, 0x20b5} + , + {0x20d0, 0x20f0} + , + {0x2100, 0x214f} + , + {0x2153, 0x2188} + , + {0x2190, 0x23e7} + , + {0x2400, 0x2426} + , + {0x2440, 0x244a} + , + {0x2460, 0x269d} + , + {0x26a0, 0x26bc} + , + {0x26c0, 0x26c3} + , + {0x2701, 0x2704} + , + {0x2706, 0x2709} + , + {0x270c, 0x2727} + , + {0x2729, 0x274b} + , + {0x274d, 0x274d} + , + {0x274f, 0x2752} + , + {0x2756, 0x2756} + , + {0x2758, 0x275e} + , + {0x2761, 0x2794} + , + {0x2798, 0x27af} + , + {0x27b1, 0x27be} + , + {0x27c0, 0x27ca} + , + {0x27cc, 0x27cc} + , + {0x27d0, 0x2b4c} + , + {0x2b50, 0x2b54} + , + {0x2c00, 0x2c2e} + , + {0x2c30, 0x2c5e} + , + {0x2c60, 0x2c6f} + , + {0x2c71, 0x2c7d} + , + {0x2c80, 0x2cea} + , + {0x2cf9, 0x2d25} + , + {0x2d30, 0x2d65} + , + {0x2d6f, 0x2d6f} + , + {0x2d80, 0x2d96} + , + {0x2da0, 0x2da6} + , + {0x2da8, 0x2dae} + , + {0x2db0, 0x2db6} + , + {0x2db8, 0x2dbe} + , + {0x2dc0, 0x2dc6} + , + {0x2dc8, 0x2dce} + , + {0x2dd0, 0x2dd6} + , + {0x2dd8, 0x2dde} + , + {0x2de0, 0x2e30} + , + {0x2e80, 0x2e99} + , + {0x2e9b, 0x2ef3} + , + {0x2f00, 0x2fd5} + , + {0x2ff0, 0x2ffb} + , + {0x3001, 0x303f} + , + {0x3041, 0x3096} + , + {0x3099, 0x30ff} + , + {0x3105, 0x312d} + , + {0x3131, 0x318e} + , + {0x3190, 0x31b7} + , + {0x31c0, 0x31e3} + , + {0x31f0, 0x321e} + , + {0x3220, 0x3243} + , + {0x3250, 0x32fe} + , + {0x3300, 0x4db5} + , + {0x4dc0, 0x9fc3} + , + {0xa000, 0xa48c} + , + {0xa490, 0xa4c6} + , + {0xa500, 0xa62b} + , + {0xa640, 0xa65f} + , + {0xa662, 0xa673} + , + {0xa67c, 0xa697} + , + {0xa700, 0xa78c} + , + {0xa7fb, 0xa82b} + , + {0xa840, 0xa877} + , + {0xa880, 0xa8c4} + , + {0xa8ce, 0xa8d9} + , + {0xa900, 0xa953} + , + {0xa95f, 0xa95f} + , + {0xaa00, 0xaa36} + , + {0xaa40, 0xaa4d} + , + {0xaa50, 0xaa59} + , + {0xaa5c, 0xaa5f} + , + {0xac00, 0xd7a3} + , + {0xf900, 0xfa2d} + , + {0xfa30, 0xfa6a} + , + {0xfa70, 0xfad9} + , + {0xfb00, 0xfb06} + , + {0xfb13, 0xfb17} + , + {0xfb1d, 0xfb36} + , + {0xfb38, 0xfb3c} + , + {0xfb3e, 0xfb3e} + , + {0xfb40, 0xfb41} + , + {0xfb43, 0xfb44} + , + {0xfb46, 0xfbb1} + , + {0xfbd3, 0xfd3f} + , + {0xfd50, 0xfd8f} + , + {0xfd92, 0xfdc7} + , + {0xfdf0, 0xfdfd} + , + {0xfe00, 0xfe19} + , + {0xfe20, 0xfe26} + , + {0xfe30, 0xfe52} + , + {0xfe54, 0xfe66} + , + {0xfe68, 0xfe6b} + , + {0xfe70, 0xfe74} + , + {0xfe76, 0xfefc} + , + {0xff01, 0xffbe} + , + {0xffc2, 0xffc7} + , + {0xffca, 0xffcf} + , + {0xffd2, 0xffd7} + , + {0xffda, 0xffdc} + , + {0xffe0, 0xffe6} + , + {0xffe8, 0xffee} + , + {0xfffc, 0xfffd} + , + {0x10000, 0x1000b} + , + {0x1000d, 0x10026} + , + {0x10028, 0x1003a} + , + {0x1003c, 0x1003d} + , + {0x1003f, 0x1004d} + , + {0x10050, 0x1005d} + , + {0x10080, 0x100fa} + , + {0x10100, 0x10102} + , + {0x10107, 0x10133} + , + {0x10137, 0x1018a} + , + {0x10190, 0x1019b} + , + {0x101d0, 0x101fd} + , + {0x10280, 0x1029c} + , + {0x102a0, 0x102d0} + , + {0x10300, 0x1031e} + , + {0x10320, 0x10323} + , + {0x10330, 0x1034a} + , + {0x10380, 0x1039d} + , + {0x1039f, 0x103c3} + , + {0x103c8, 0x103d5} + , + {0x10400, 0x1049d} + , + {0x104a0, 0x104a9} + , + {0x10800, 0x10805} + , + {0x10808, 0x10808} + , + {0x1080a, 0x10835} + , + {0x10837, 0x10838} + , + {0x1083c, 0x1083c} + , + {0x1083f, 0x1083f} + , + {0x10900, 0x10919} + , + {0x1091f, 0x10939} + , + {0x1093f, 0x1093f} + , + {0x10a00, 0x10a03} + , + {0x10a05, 0x10a06} + , + {0x10a0c, 0x10a13} + , + {0x10a15, 0x10a17} + , + {0x10a19, 0x10a33} + , + {0x10a38, 0x10a3a} + , + {0x10a3f, 0x10a47} + , + {0x10a50, 0x10a58} + , + {0x12000, 0x1236e} + , + {0x12400, 0x12462} + , + {0x12470, 0x12473} + , + {0x1d000, 0x1d0f5} + , + {0x1d100, 0x1d126} + , + {0x1d129, 0x1d172} + , + {0x1d17b, 0x1d1dd} + , + {0x1d200, 0x1d245} + , + {0x1d300, 0x1d356} + , + {0x1d360, 0x1d371} + , + {0x1d400, 0x1d454} + , + {0x1d456, 0x1d49c} + , + {0x1d49e, 0x1d49f} + , + {0x1d4a2, 0x1d4a2} + , + {0x1d4a5, 0x1d4a6} + , + {0x1d4a9, 0x1d4ac} + , + {0x1d4ae, 0x1d4b9} + , + {0x1d4bb, 0x1d4bb} + , + {0x1d4bd, 0x1d4c3} + , + {0x1d4c5, 0x1d505} + , + {0x1d507, 0x1d50a} + , + {0x1d50d, 0x1d514} + , + {0x1d516, 0x1d51c} + , + {0x1d51e, 0x1d539} + , + {0x1d53b, 0x1d53e} + , + {0x1d540, 0x1d544} + , + {0x1d546, 0x1d546} + , + {0x1d54a, 0x1d550} + , + {0x1d552, 0x1d6a5} + , + {0x1d6a8, 0x1d7cb} + , + {0x1d7ce, 0x1d7ff} + , + {0x1f000, 0x1f02b} + , + {0x1f030, 0x1f093} + , + {0x20000, 0x2a6d6} + , + {0x2f800, 0x2fa1d} + , + {0xe0100, 0xe01ef} +}; + +scm_t_char_set cs_graphic = { + 445, + cs_graphic_ranges +}; + +scm_t_char_range cs_whitespace_ranges[] = { + {0x0009, 0x000d} + , + {0x0020, 0x0020} + , + {0x00a0, 0x00a0} + , + {0x1680, 0x1680} + , + {0x180e, 0x180e} + , + {0x2000, 0x200a} + , + {0x2028, 0x2029} + , + {0x202f, 0x202f} + , + {0x205f, 0x205f} + , + {0x3000, 0x3000} +}; + +scm_t_char_set cs_whitespace = { + 10, + cs_whitespace_ranges +}; + +scm_t_char_range cs_printing_ranges[] = { + {0x0009, 0x000d} + , + {0x0020, 0x007e} + , + {0x00a0, 0x00ac} + , + {0x00ae, 0x0377} + , + {0x037a, 0x037e} + , + {0x0384, 0x038a} + , + {0x038c, 0x038c} + , + {0x038e, 0x03a1} + , + {0x03a3, 0x0523} + , + {0x0531, 0x0556} + , + {0x0559, 0x055f} + , + {0x0561, 0x0587} + , + {0x0589, 0x058a} + , + {0x0591, 0x05c7} + , + {0x05d0, 0x05ea} + , + {0x05f0, 0x05f4} + , + {0x0606, 0x061b} + , + {0x061e, 0x061f} + , + {0x0621, 0x065e} + , + {0x0660, 0x06dc} + , + {0x06de, 0x070d} + , + {0x0710, 0x074a} + , + {0x074d, 0x07b1} + , + {0x07c0, 0x07fa} + , + {0x0901, 0x0939} + , + {0x093c, 0x094d} + , + {0x0950, 0x0954} + , + {0x0958, 0x0972} + , + {0x097b, 0x097f} + , + {0x0981, 0x0983} + , + {0x0985, 0x098c} + , + {0x098f, 0x0990} + , + {0x0993, 0x09a8} + , + {0x09aa, 0x09b0} + , + {0x09b2, 0x09b2} + , + {0x09b6, 0x09b9} + , + {0x09bc, 0x09c4} + , + {0x09c7, 0x09c8} + , + {0x09cb, 0x09ce} + , + {0x09d7, 0x09d7} + , + {0x09dc, 0x09dd} + , + {0x09df, 0x09e3} + , + {0x09e6, 0x09fa} + , + {0x0a01, 0x0a03} + , + {0x0a05, 0x0a0a} + , + {0x0a0f, 0x0a10} + , + {0x0a13, 0x0a28} + , + {0x0a2a, 0x0a30} + , + {0x0a32, 0x0a33} + , + {0x0a35, 0x0a36} + , + {0x0a38, 0x0a39} + , + {0x0a3c, 0x0a3c} + , + {0x0a3e, 0x0a42} + , + {0x0a47, 0x0a48} + , + {0x0a4b, 0x0a4d} + , + {0x0a51, 0x0a51} + , + {0x0a59, 0x0a5c} + , + {0x0a5e, 0x0a5e} + , + {0x0a66, 0x0a75} + , + {0x0a81, 0x0a83} + , + {0x0a85, 0x0a8d} + , + {0x0a8f, 0x0a91} + , + {0x0a93, 0x0aa8} + , + {0x0aaa, 0x0ab0} + , + {0x0ab2, 0x0ab3} + , + {0x0ab5, 0x0ab9} + , + {0x0abc, 0x0ac5} + , + {0x0ac7, 0x0ac9} + , + {0x0acb, 0x0acd} + , + {0x0ad0, 0x0ad0} + , + {0x0ae0, 0x0ae3} + , + {0x0ae6, 0x0aef} + , + {0x0af1, 0x0af1} + , + {0x0b01, 0x0b03} + , + {0x0b05, 0x0b0c} + , + {0x0b0f, 0x0b10} + , + {0x0b13, 0x0b28} + , + {0x0b2a, 0x0b30} + , + {0x0b32, 0x0b33} + , + {0x0b35, 0x0b39} + , + {0x0b3c, 0x0b44} + , + {0x0b47, 0x0b48} + , + {0x0b4b, 0x0b4d} + , + {0x0b56, 0x0b57} + , + {0x0b5c, 0x0b5d} + , + {0x0b5f, 0x0b63} + , + {0x0b66, 0x0b71} + , + {0x0b82, 0x0b83} + , + {0x0b85, 0x0b8a} + , + {0x0b8e, 0x0b90} + , + {0x0b92, 0x0b95} + , + {0x0b99, 0x0b9a} + , + {0x0b9c, 0x0b9c} + , + {0x0b9e, 0x0b9f} + , + {0x0ba3, 0x0ba4} + , + {0x0ba8, 0x0baa} + , + {0x0bae, 0x0bb9} + , + {0x0bbe, 0x0bc2} + , + {0x0bc6, 0x0bc8} + , + {0x0bca, 0x0bcd} + , + {0x0bd0, 0x0bd0} + , + {0x0bd7, 0x0bd7} + , + {0x0be6, 0x0bfa} + , + {0x0c01, 0x0c03} + , + {0x0c05, 0x0c0c} + , + {0x0c0e, 0x0c10} + , + {0x0c12, 0x0c28} + , + {0x0c2a, 0x0c33} + , + {0x0c35, 0x0c39} + , + {0x0c3d, 0x0c44} + , + {0x0c46, 0x0c48} + , + {0x0c4a, 0x0c4d} + , + {0x0c55, 0x0c56} + , + {0x0c58, 0x0c59} + , + {0x0c60, 0x0c63} + , + {0x0c66, 0x0c6f} + , + {0x0c78, 0x0c7f} + , + {0x0c82, 0x0c83} + , + {0x0c85, 0x0c8c} + , + {0x0c8e, 0x0c90} + , + {0x0c92, 0x0ca8} + , + {0x0caa, 0x0cb3} + , + {0x0cb5, 0x0cb9} + , + {0x0cbc, 0x0cc4} + , + {0x0cc6, 0x0cc8} + , + {0x0cca, 0x0ccd} + , + {0x0cd5, 0x0cd6} + , + {0x0cde, 0x0cde} + , + {0x0ce0, 0x0ce3} + , + {0x0ce6, 0x0cef} + , + {0x0cf1, 0x0cf2} + , + {0x0d02, 0x0d03} + , + {0x0d05, 0x0d0c} + , + {0x0d0e, 0x0d10} + , + {0x0d12, 0x0d28} + , + {0x0d2a, 0x0d39} + , + {0x0d3d, 0x0d44} + , + {0x0d46, 0x0d48} + , + {0x0d4a, 0x0d4d} + , + {0x0d57, 0x0d57} + , + {0x0d60, 0x0d63} + , + {0x0d66, 0x0d75} + , + {0x0d79, 0x0d7f} + , + {0x0d82, 0x0d83} + , + {0x0d85, 0x0d96} + , + {0x0d9a, 0x0db1} + , + {0x0db3, 0x0dbb} + , + {0x0dbd, 0x0dbd} + , + {0x0dc0, 0x0dc6} + , + {0x0dca, 0x0dca} + , + {0x0dcf, 0x0dd4} + , + {0x0dd6, 0x0dd6} + , + {0x0dd8, 0x0ddf} + , + {0x0df2, 0x0df4} + , + {0x0e01, 0x0e3a} + , + {0x0e3f, 0x0e5b} + , + {0x0e81, 0x0e82} + , + {0x0e84, 0x0e84} + , + {0x0e87, 0x0e88} + , + {0x0e8a, 0x0e8a} + , + {0x0e8d, 0x0e8d} + , + {0x0e94, 0x0e97} + , + {0x0e99, 0x0e9f} + , + {0x0ea1, 0x0ea3} + , + {0x0ea5, 0x0ea5} + , + {0x0ea7, 0x0ea7} + , + {0x0eaa, 0x0eab} + , + {0x0ead, 0x0eb9} + , + {0x0ebb, 0x0ebd} + , + {0x0ec0, 0x0ec4} + , + {0x0ec6, 0x0ec6} + , + {0x0ec8, 0x0ecd} + , + {0x0ed0, 0x0ed9} + , + {0x0edc, 0x0edd} + , + {0x0f00, 0x0f47} + , + {0x0f49, 0x0f6c} + , + {0x0f71, 0x0f8b} + , + {0x0f90, 0x0f97} + , + {0x0f99, 0x0fbc} + , + {0x0fbe, 0x0fcc} + , + {0x0fce, 0x0fd4} + , + {0x1000, 0x1099} + , + {0x109e, 0x10c5} + , + {0x10d0, 0x10fc} + , + {0x1100, 0x1159} + , + {0x115f, 0x11a2} + , + {0x11a8, 0x11f9} + , + {0x1200, 0x1248} + , + {0x124a, 0x124d} + , + {0x1250, 0x1256} + , + {0x1258, 0x1258} + , + {0x125a, 0x125d} + , + {0x1260, 0x1288} + , + {0x128a, 0x128d} + , + {0x1290, 0x12b0} + , + {0x12b2, 0x12b5} + , + {0x12b8, 0x12be} + , + {0x12c0, 0x12c0} + , + {0x12c2, 0x12c5} + , + {0x12c8, 0x12d6} + , + {0x12d8, 0x1310} + , + {0x1312, 0x1315} + , + {0x1318, 0x135a} + , + {0x135f, 0x137c} + , + {0x1380, 0x1399} + , + {0x13a0, 0x13f4} + , + {0x1401, 0x1676} + , + {0x1680, 0x169c} + , + {0x16a0, 0x16f0} + , + {0x1700, 0x170c} + , + {0x170e, 0x1714} + , + {0x1720, 0x1736} + , + {0x1740, 0x1753} + , + {0x1760, 0x176c} + , + {0x176e, 0x1770} + , + {0x1772, 0x1773} + , + {0x1780, 0x17b3} + , + {0x17b6, 0x17dd} + , + {0x17e0, 0x17e9} + , + {0x17f0, 0x17f9} + , + {0x1800, 0x180e} + , + {0x1810, 0x1819} + , + {0x1820, 0x1877} + , + {0x1880, 0x18aa} + , + {0x1900, 0x191c} + , + {0x1920, 0x192b} + , + {0x1930, 0x193b} + , + {0x1940, 0x1940} + , + {0x1944, 0x196d} + , + {0x1970, 0x1974} + , + {0x1980, 0x19a9} + , + {0x19b0, 0x19c9} + , + {0x19d0, 0x19d9} + , + {0x19de, 0x1a1b} + , + {0x1a1e, 0x1a1f} + , + {0x1b00, 0x1b4b} + , + {0x1b50, 0x1b7c} + , + {0x1b80, 0x1baa} + , + {0x1bae, 0x1bb9} + , + {0x1c00, 0x1c37} + , + {0x1c3b, 0x1c49} + , + {0x1c4d, 0x1c7f} + , + {0x1d00, 0x1de6} + , + {0x1dfe, 0x1f15} + , + {0x1f18, 0x1f1d} + , + {0x1f20, 0x1f45} + , + {0x1f48, 0x1f4d} + , + {0x1f50, 0x1f57} + , + {0x1f59, 0x1f59} + , + {0x1f5b, 0x1f5b} + , + {0x1f5d, 0x1f5d} + , + {0x1f5f, 0x1f7d} + , + {0x1f80, 0x1fb4} + , + {0x1fb6, 0x1fc4} + , + {0x1fc6, 0x1fd3} + , + {0x1fd6, 0x1fdb} + , + {0x1fdd, 0x1fef} + , + {0x1ff2, 0x1ff4} + , + {0x1ff6, 0x1ffe} + , + {0x2000, 0x200a} + , + {0x2010, 0x2029} + , + {0x202f, 0x205f} + , + {0x2070, 0x2071} + , + {0x2074, 0x208e} + , + {0x2090, 0x2094} + , + {0x20a0, 0x20b5} + , + {0x20d0, 0x20f0} + , + {0x2100, 0x214f} + , + {0x2153, 0x2188} + , + {0x2190, 0x23e7} + , + {0x2400, 0x2426} + , + {0x2440, 0x244a} + , + {0x2460, 0x269d} + , + {0x26a0, 0x26bc} + , + {0x26c0, 0x26c3} + , + {0x2701, 0x2704} + , + {0x2706, 0x2709} + , + {0x270c, 0x2727} + , + {0x2729, 0x274b} + , + {0x274d, 0x274d} + , + {0x274f, 0x2752} + , + {0x2756, 0x2756} + , + {0x2758, 0x275e} + , + {0x2761, 0x2794} + , + {0x2798, 0x27af} + , + {0x27b1, 0x27be} + , + {0x27c0, 0x27ca} + , + {0x27cc, 0x27cc} + , + {0x27d0, 0x2b4c} + , + {0x2b50, 0x2b54} + , + {0x2c00, 0x2c2e} + , + {0x2c30, 0x2c5e} + , + {0x2c60, 0x2c6f} + , + {0x2c71, 0x2c7d} + , + {0x2c80, 0x2cea} + , + {0x2cf9, 0x2d25} + , + {0x2d30, 0x2d65} + , + {0x2d6f, 0x2d6f} + , + {0x2d80, 0x2d96} + , + {0x2da0, 0x2da6} + , + {0x2da8, 0x2dae} + , + {0x2db0, 0x2db6} + , + {0x2db8, 0x2dbe} + , + {0x2dc0, 0x2dc6} + , + {0x2dc8, 0x2dce} + , + {0x2dd0, 0x2dd6} + , + {0x2dd8, 0x2dde} + , + {0x2de0, 0x2e30} + , + {0x2e80, 0x2e99} + , + {0x2e9b, 0x2ef3} + , + {0x2f00, 0x2fd5} + , + {0x2ff0, 0x2ffb} + , + {0x3000, 0x303f} + , + {0x3041, 0x3096} + , + {0x3099, 0x30ff} + , + {0x3105, 0x312d} + , + {0x3131, 0x318e} + , + {0x3190, 0x31b7} + , + {0x31c0, 0x31e3} + , + {0x31f0, 0x321e} + , + {0x3220, 0x3243} + , + {0x3250, 0x32fe} + , + {0x3300, 0x4db5} + , + {0x4dc0, 0x9fc3} + , + {0xa000, 0xa48c} + , + {0xa490, 0xa4c6} + , + {0xa500, 0xa62b} + , + {0xa640, 0xa65f} + , + {0xa662, 0xa673} + , + {0xa67c, 0xa697} + , + {0xa700, 0xa78c} + , + {0xa7fb, 0xa82b} + , + {0xa840, 0xa877} + , + {0xa880, 0xa8c4} + , + {0xa8ce, 0xa8d9} + , + {0xa900, 0xa953} + , + {0xa95f, 0xa95f} + , + {0xaa00, 0xaa36} + , + {0xaa40, 0xaa4d} + , + {0xaa50, 0xaa59} + , + {0xaa5c, 0xaa5f} + , + {0xac00, 0xd7a3} + , + {0xf900, 0xfa2d} + , + {0xfa30, 0xfa6a} + , + {0xfa70, 0xfad9} + , + {0xfb00, 0xfb06} + , + {0xfb13, 0xfb17} + , + {0xfb1d, 0xfb36} + , + {0xfb38, 0xfb3c} + , + {0xfb3e, 0xfb3e} + , + {0xfb40, 0xfb41} + , + {0xfb43, 0xfb44} + , + {0xfb46, 0xfbb1} + , + {0xfbd3, 0xfd3f} + , + {0xfd50, 0xfd8f} + , + {0xfd92, 0xfdc7} + , + {0xfdf0, 0xfdfd} + , + {0xfe00, 0xfe19} + , + {0xfe20, 0xfe26} + , + {0xfe30, 0xfe52} + , + {0xfe54, 0xfe66} + , + {0xfe68, 0xfe6b} + , + {0xfe70, 0xfe74} + , + {0xfe76, 0xfefc} + , + {0xff01, 0xffbe} + , + {0xffc2, 0xffc7} + , + {0xffca, 0xffcf} + , + {0xffd2, 0xffd7} + , + {0xffda, 0xffdc} + , + {0xffe0, 0xffe6} + , + {0xffe8, 0xffee} + , + {0xfffc, 0xfffd} + , + {0x10000, 0x1000b} + , + {0x1000d, 0x10026} + , + {0x10028, 0x1003a} + , + {0x1003c, 0x1003d} + , + {0x1003f, 0x1004d} + , + {0x10050, 0x1005d} + , + {0x10080, 0x100fa} + , + {0x10100, 0x10102} + , + {0x10107, 0x10133} + , + {0x10137, 0x1018a} + , + {0x10190, 0x1019b} + , + {0x101d0, 0x101fd} + , + {0x10280, 0x1029c} + , + {0x102a0, 0x102d0} + , + {0x10300, 0x1031e} + , + {0x10320, 0x10323} + , + {0x10330, 0x1034a} + , + {0x10380, 0x1039d} + , + {0x1039f, 0x103c3} + , + {0x103c8, 0x103d5} + , + {0x10400, 0x1049d} + , + {0x104a0, 0x104a9} + , + {0x10800, 0x10805} + , + {0x10808, 0x10808} + , + {0x1080a, 0x10835} + , + {0x10837, 0x10838} + , + {0x1083c, 0x1083c} + , + {0x1083f, 0x1083f} + , + {0x10900, 0x10919} + , + {0x1091f, 0x10939} + , + {0x1093f, 0x1093f} + , + {0x10a00, 0x10a03} + , + {0x10a05, 0x10a06} + , + {0x10a0c, 0x10a13} + , + {0x10a15, 0x10a17} + , + {0x10a19, 0x10a33} + , + {0x10a38, 0x10a3a} + , + {0x10a3f, 0x10a47} + , + {0x10a50, 0x10a58} + , + {0x12000, 0x1236e} + , + {0x12400, 0x12462} + , + {0x12470, 0x12473} + , + {0x1d000, 0x1d0f5} + , + {0x1d100, 0x1d126} + , + {0x1d129, 0x1d172} + , + {0x1d17b, 0x1d1dd} + , + {0x1d200, 0x1d245} + , + {0x1d300, 0x1d356} + , + {0x1d360, 0x1d371} + , + {0x1d400, 0x1d454} + , + {0x1d456, 0x1d49c} + , + {0x1d49e, 0x1d49f} + , + {0x1d4a2, 0x1d4a2} + , + {0x1d4a5, 0x1d4a6} + , + {0x1d4a9, 0x1d4ac} + , + {0x1d4ae, 0x1d4b9} + , + {0x1d4bb, 0x1d4bb} + , + {0x1d4bd, 0x1d4c3} + , + {0x1d4c5, 0x1d505} + , + {0x1d507, 0x1d50a} + , + {0x1d50d, 0x1d514} + , + {0x1d516, 0x1d51c} + , + {0x1d51e, 0x1d539} + , + {0x1d53b, 0x1d53e} + , + {0x1d540, 0x1d544} + , + {0x1d546, 0x1d546} + , + {0x1d54a, 0x1d550} + , + {0x1d552, 0x1d6a5} + , + {0x1d6a8, 0x1d7cb} + , + {0x1d7ce, 0x1d7ff} + , + {0x1f000, 0x1f02b} + , + {0x1f030, 0x1f093} + , + {0x20000, 0x2a6d6} + , + {0x2f800, 0x2fa1d} + , + {0xe0100, 0xe01ef} +}; + +scm_t_char_set cs_printing = { + 447, + cs_printing_ranges +}; + +scm_t_char_range cs_iso_control_ranges[] = { + {0x0000, 0x001f} + , + {0x007f, 0x009f} +}; + +scm_t_char_set cs_iso_control = { + 2, + cs_iso_control_ranges +}; + +scm_t_char_range cs_punctuation_ranges[] = { + {0x0021, 0x0023} + , + {0x0025, 0x002a} + , + {0x002c, 0x002f} + , + {0x003a, 0x003b} + , + {0x003f, 0x0040} + , + {0x005b, 0x005d} + , + {0x005f, 0x005f} + , + {0x007b, 0x007b} + , + {0x007d, 0x007d} + , + {0x00a1, 0x00a1} + , + {0x00ab, 0x00ab} + , + {0x00b7, 0x00b7} + , + {0x00bb, 0x00bb} + , + {0x00bf, 0x00bf} + , + {0x037e, 0x037e} + , + {0x0387, 0x0387} + , + {0x055a, 0x055f} + , + {0x0589, 0x058a} + , + {0x05be, 0x05be} + , + {0x05c0, 0x05c0} + , + {0x05c3, 0x05c3} + , + {0x05c6, 0x05c6} + , + {0x05f3, 0x05f4} + , + {0x0609, 0x060a} + , + {0x060c, 0x060d} + , + {0x061b, 0x061b} + , + {0x061e, 0x061f} + , + {0x066a, 0x066d} + , + {0x06d4, 0x06d4} + , + {0x0700, 0x070d} + , + {0x07f7, 0x07f9} + , + {0x0964, 0x0965} + , + {0x0970, 0x0970} + , + {0x0df4, 0x0df4} + , + {0x0e4f, 0x0e4f} + , + {0x0e5a, 0x0e5b} + , + {0x0f04, 0x0f12} + , + {0x0f3a, 0x0f3d} + , + {0x0f85, 0x0f85} + , + {0x0fd0, 0x0fd4} + , + {0x104a, 0x104f} + , + {0x10fb, 0x10fb} + , + {0x1361, 0x1368} + , + {0x166d, 0x166e} + , + {0x169b, 0x169c} + , + {0x16eb, 0x16ed} + , + {0x1735, 0x1736} + , + {0x17d4, 0x17d6} + , + {0x17d8, 0x17da} + , + {0x1800, 0x180a} + , + {0x1944, 0x1945} + , + {0x19de, 0x19df} + , + {0x1a1e, 0x1a1f} + , + {0x1b5a, 0x1b60} + , + {0x1c3b, 0x1c3f} + , + {0x1c7e, 0x1c7f} + , + {0x2010, 0x2027} + , + {0x2030, 0x2043} + , + {0x2045, 0x2051} + , + {0x2053, 0x205e} + , + {0x207d, 0x207e} + , + {0x208d, 0x208e} + , + {0x2329, 0x232a} + , + {0x2768, 0x2775} + , + {0x27c5, 0x27c6} + , + {0x27e6, 0x27ef} + , + {0x2983, 0x2998} + , + {0x29d8, 0x29db} + , + {0x29fc, 0x29fd} + , + {0x2cf9, 0x2cfc} + , + {0x2cfe, 0x2cff} + , + {0x2e00, 0x2e2e} + , + {0x2e30, 0x2e30} + , + {0x3001, 0x3003} + , + {0x3008, 0x3011} + , + {0x3014, 0x301f} + , + {0x3030, 0x3030} + , + {0x303d, 0x303d} + , + {0x30a0, 0x30a0} + , + {0x30fb, 0x30fb} + , + {0xa60d, 0xa60f} + , + {0xa673, 0xa673} + , + {0xa67e, 0xa67e} + , + {0xa874, 0xa877} + , + {0xa8ce, 0xa8cf} + , + {0xa92e, 0xa92f} + , + {0xa95f, 0xa95f} + , + {0xaa5c, 0xaa5f} + , + {0xfd3e, 0xfd3f} + , + {0xfe10, 0xfe19} + , + {0xfe30, 0xfe52} + , + {0xfe54, 0xfe61} + , + {0xfe63, 0xfe63} + , + {0xfe68, 0xfe68} + , + {0xfe6a, 0xfe6b} + , + {0xff01, 0xff03} + , + {0xff05, 0xff0a} + , + {0xff0c, 0xff0f} + , + {0xff1a, 0xff1b} + , + {0xff1f, 0xff20} + , + {0xff3b, 0xff3d} + , + {0xff3f, 0xff3f} + , + {0xff5b, 0xff5b} + , + {0xff5d, 0xff5d} + , + {0xff5f, 0xff65} + , + {0x10100, 0x10101} + , + {0x1039f, 0x1039f} + , + {0x103d0, 0x103d0} + , + {0x1091f, 0x1091f} + , + {0x1093f, 0x1093f} + , + {0x10a50, 0x10a58} + , + {0x12470, 0x12473} +}; + +scm_t_char_set cs_punctuation = { + 112, + cs_punctuation_ranges +}; + +scm_t_char_range cs_symbol_ranges[] = { + {0x0024, 0x0024} + , + {0x002b, 0x002b} + , + {0x003c, 0x003e} + , + {0x005e, 0x005e} + , + {0x0060, 0x0060} + , + {0x007c, 0x007c} + , + {0x007e, 0x007e} + , + {0x00a2, 0x00a9} + , + {0x00ac, 0x00ac} + , + {0x00ae, 0x00b1} + , + {0x00b4, 0x00b4} + , + {0x00b6, 0x00b6} + , + {0x00b8, 0x00b8} + , + {0x00d7, 0x00d7} + , + {0x00f7, 0x00f7} + , + {0x02c2, 0x02c5} + , + {0x02d2, 0x02df} + , + {0x02e5, 0x02eb} + , + {0x02ed, 0x02ed} + , + {0x02ef, 0x02ff} + , + {0x0375, 0x0375} + , + {0x0384, 0x0385} + , + {0x03f6, 0x03f6} + , + {0x0482, 0x0482} + , + {0x0606, 0x0608} + , + {0x060b, 0x060b} + , + {0x060e, 0x060f} + , + {0x06e9, 0x06e9} + , + {0x06fd, 0x06fe} + , + {0x07f6, 0x07f6} + , + {0x09f2, 0x09f3} + , + {0x09fa, 0x09fa} + , + {0x0af1, 0x0af1} + , + {0x0b70, 0x0b70} + , + {0x0bf3, 0x0bfa} + , + {0x0c7f, 0x0c7f} + , + {0x0cf1, 0x0cf2} + , + {0x0d79, 0x0d79} + , + {0x0e3f, 0x0e3f} + , + {0x0f01, 0x0f03} + , + {0x0f13, 0x0f17} + , + {0x0f1a, 0x0f1f} + , + {0x0f34, 0x0f34} + , + {0x0f36, 0x0f36} + , + {0x0f38, 0x0f38} + , + {0x0fbe, 0x0fc5} + , + {0x0fc7, 0x0fcc} + , + {0x0fce, 0x0fcf} + , + {0x109e, 0x109f} + , + {0x1360, 0x1360} + , + {0x1390, 0x1399} + , + {0x17db, 0x17db} + , + {0x1940, 0x1940} + , + {0x19e0, 0x19ff} + , + {0x1b61, 0x1b6a} + , + {0x1b74, 0x1b7c} + , + {0x1fbd, 0x1fbd} + , + {0x1fbf, 0x1fc1} + , + {0x1fcd, 0x1fcf} + , + {0x1fdd, 0x1fdf} + , + {0x1fed, 0x1fef} + , + {0x1ffd, 0x1ffe} + , + {0x2044, 0x2044} + , + {0x2052, 0x2052} + , + {0x207a, 0x207c} + , + {0x208a, 0x208c} + , + {0x20a0, 0x20b5} + , + {0x2100, 0x2101} + , + {0x2103, 0x2106} + , + {0x2108, 0x2109} + , + {0x2114, 0x2114} + , + {0x2116, 0x2118} + , + {0x211e, 0x2123} + , + {0x2125, 0x2125} + , + {0x2127, 0x2127} + , + {0x2129, 0x2129} + , + {0x212e, 0x212e} + , + {0x213a, 0x213b} + , + {0x2140, 0x2144} + , + {0x214a, 0x214d} + , + {0x214f, 0x214f} + , + {0x2190, 0x2328} + , + {0x232b, 0x23e7} + , + {0x2400, 0x2426} + , + {0x2440, 0x244a} + , + {0x249c, 0x24e9} + , + {0x2500, 0x269d} + , + {0x26a0, 0x26bc} + , + {0x26c0, 0x26c3} + , + {0x2701, 0x2704} + , + {0x2706, 0x2709} + , + {0x270c, 0x2727} + , + {0x2729, 0x274b} + , + {0x274d, 0x274d} + , + {0x274f, 0x2752} + , + {0x2756, 0x2756} + , + {0x2758, 0x275e} + , + {0x2761, 0x2767} + , + {0x2794, 0x2794} + , + {0x2798, 0x27af} + , + {0x27b1, 0x27be} + , + {0x27c0, 0x27c4} + , + {0x27c7, 0x27ca} + , + {0x27cc, 0x27cc} + , + {0x27d0, 0x27e5} + , + {0x27f0, 0x2982} + , + {0x2999, 0x29d7} + , + {0x29dc, 0x29fb} + , + {0x29fe, 0x2b4c} + , + {0x2b50, 0x2b54} + , + {0x2ce5, 0x2cea} + , + {0x2e80, 0x2e99} + , + {0x2e9b, 0x2ef3} + , + {0x2f00, 0x2fd5} + , + {0x2ff0, 0x2ffb} + , + {0x3004, 0x3004} + , + {0x3012, 0x3013} + , + {0x3020, 0x3020} + , + {0x3036, 0x3037} + , + {0x303e, 0x303f} + , + {0x309b, 0x309c} + , + {0x3190, 0x3191} + , + {0x3196, 0x319f} + , + {0x31c0, 0x31e3} + , + {0x3200, 0x321e} + , + {0x322a, 0x3243} + , + {0x3250, 0x3250} + , + {0x3260, 0x327f} + , + {0x328a, 0x32b0} + , + {0x32c0, 0x32fe} + , + {0x3300, 0x33ff} + , + {0x4dc0, 0x4dff} + , + {0xa490, 0xa4c6} + , + {0xa700, 0xa716} + , + {0xa720, 0xa721} + , + {0xa789, 0xa78a} + , + {0xa828, 0xa82b} + , + {0xfb29, 0xfb29} + , + {0xfdfc, 0xfdfd} + , + {0xfe62, 0xfe62} + , + {0xfe64, 0xfe66} + , + {0xfe69, 0xfe69} + , + {0xff04, 0xff04} + , + {0xff0b, 0xff0b} + , + {0xff1c, 0xff1e} + , + {0xff3e, 0xff3e} + , + {0xff40, 0xff40} + , + {0xff5c, 0xff5c} + , + {0xff5e, 0xff5e} + , + {0xffe0, 0xffe6} + , + {0xffe8, 0xffee} + , + {0xfffc, 0xfffd} + , + {0x10102, 0x10102} + , + {0x10137, 0x1013f} + , + {0x10179, 0x10189} + , + {0x10190, 0x1019b} + , + {0x101d0, 0x101fc} + , + {0x1d000, 0x1d0f5} + , + {0x1d100, 0x1d126} + , + {0x1d129, 0x1d164} + , + {0x1d16a, 0x1d16c} + , + {0x1d183, 0x1d184} + , + {0x1d18c, 0x1d1a9} + , + {0x1d1ae, 0x1d1dd} + , + {0x1d200, 0x1d241} + , + {0x1d245, 0x1d245} + , + {0x1d300, 0x1d356} + , + {0x1d6c1, 0x1d6c1} + , + {0x1d6db, 0x1d6db} + , + {0x1d6fb, 0x1d6fb} + , + {0x1d715, 0x1d715} + , + {0x1d735, 0x1d735} + , + {0x1d74f, 0x1d74f} + , + {0x1d76f, 0x1d76f} + , + {0x1d789, 0x1d789} + , + {0x1d7a9, 0x1d7a9} + , + {0x1d7c3, 0x1d7c3} + , + {0x1f000, 0x1f02b} + , + {0x1f030, 0x1f093} +}; + +scm_t_char_set cs_symbol = { + 179, + cs_symbol_ranges +}; + +scm_t_char_range cs_blank_ranges[] = { + {0x0009, 0x0009} + , + {0x0020, 0x0020} + , + {0x00a0, 0x00a0} + , + {0x1680, 0x1680} + , + {0x180e, 0x180e} + , + {0x2000, 0x200a} + , + {0x202f, 0x202f} + , + {0x205f, 0x205f} + , + {0x3000, 0x3000} +}; + +scm_t_char_set cs_blank = { + 9, + cs_blank_ranges +}; + +scm_t_char_range cs_ascii_ranges[] = { + {0x0000, 0x007f} +}; + +scm_t_char_set cs_ascii = { + 0, + cs_ascii_ranges +}; + +scm_t_char_range cs_empty_ranges[] = { +}; + +scm_t_char_set cs_empty = { + 0, + cs_empty_ranges +}; + +scm_t_char_range cs_full_ranges[] = { + {0x0000, 0x0377} + , + {0x037a, 0x037e} + , + {0x0384, 0x038a} + , + {0x038c, 0x038c} + , + {0x038e, 0x03a1} + , + {0x03a3, 0x0523} + , + {0x0531, 0x0556} + , + {0x0559, 0x055f} + , + {0x0561, 0x0587} + , + {0x0589, 0x058a} + , + {0x0591, 0x05c7} + , + {0x05d0, 0x05ea} + , + {0x05f0, 0x05f4} + , + {0x0600, 0x0603} + , + {0x0606, 0x061b} + , + {0x061e, 0x061f} + , + {0x0621, 0x065e} + , + {0x0660, 0x070d} + , + {0x070f, 0x074a} + , + {0x074d, 0x07b1} + , + {0x07c0, 0x07fa} + , + {0x0901, 0x0939} + , + {0x093c, 0x094d} + , + {0x0950, 0x0954} + , + {0x0958, 0x0972} + , + {0x097b, 0x097f} + , + {0x0981, 0x0983} + , + {0x0985, 0x098c} + , + {0x098f, 0x0990} + , + {0x0993, 0x09a8} + , + {0x09aa, 0x09b0} + , + {0x09b2, 0x09b2} + , + {0x09b6, 0x09b9} + , + {0x09bc, 0x09c4} + , + {0x09c7, 0x09c8} + , + {0x09cb, 0x09ce} + , + {0x09d7, 0x09d7} + , + {0x09dc, 0x09dd} + , + {0x09df, 0x09e3} + , + {0x09e6, 0x09fa} + , + {0x0a01, 0x0a03} + , + {0x0a05, 0x0a0a} + , + {0x0a0f, 0x0a10} + , + {0x0a13, 0x0a28} + , + {0x0a2a, 0x0a30} + , + {0x0a32, 0x0a33} + , + {0x0a35, 0x0a36} + , + {0x0a38, 0x0a39} + , + {0x0a3c, 0x0a3c} + , + {0x0a3e, 0x0a42} + , + {0x0a47, 0x0a48} + , + {0x0a4b, 0x0a4d} + , + {0x0a51, 0x0a51} + , + {0x0a59, 0x0a5c} + , + {0x0a5e, 0x0a5e} + , + {0x0a66, 0x0a75} + , + {0x0a81, 0x0a83} + , + {0x0a85, 0x0a8d} + , + {0x0a8f, 0x0a91} + , + {0x0a93, 0x0aa8} + , + {0x0aaa, 0x0ab0} + , + {0x0ab2, 0x0ab3} + , + {0x0ab5, 0x0ab9} + , + {0x0abc, 0x0ac5} + , + {0x0ac7, 0x0ac9} + , + {0x0acb, 0x0acd} + , + {0x0ad0, 0x0ad0} + , + {0x0ae0, 0x0ae3} + , + {0x0ae6, 0x0aef} + , + {0x0af1, 0x0af1} + , + {0x0b01, 0x0b03} + , + {0x0b05, 0x0b0c} + , + {0x0b0f, 0x0b10} + , + {0x0b13, 0x0b28} + , + {0x0b2a, 0x0b30} + , + {0x0b32, 0x0b33} + , + {0x0b35, 0x0b39} + , + {0x0b3c, 0x0b44} + , + {0x0b47, 0x0b48} + , + {0x0b4b, 0x0b4d} + , + {0x0b56, 0x0b57} + , + {0x0b5c, 0x0b5d} + , + {0x0b5f, 0x0b63} + , + {0x0b66, 0x0b71} + , + {0x0b82, 0x0b83} + , + {0x0b85, 0x0b8a} + , + {0x0b8e, 0x0b90} + , + {0x0b92, 0x0b95} + , + {0x0b99, 0x0b9a} + , + {0x0b9c, 0x0b9c} + , + {0x0b9e, 0x0b9f} + , + {0x0ba3, 0x0ba4} + , + {0x0ba8, 0x0baa} + , + {0x0bae, 0x0bb9} + , + {0x0bbe, 0x0bc2} + , + {0x0bc6, 0x0bc8} + , + {0x0bca, 0x0bcd} + , + {0x0bd0, 0x0bd0} + , + {0x0bd7, 0x0bd7} + , + {0x0be6, 0x0bfa} + , + {0x0c01, 0x0c03} + , + {0x0c05, 0x0c0c} + , + {0x0c0e, 0x0c10} + , + {0x0c12, 0x0c28} + , + {0x0c2a, 0x0c33} + , + {0x0c35, 0x0c39} + , + {0x0c3d, 0x0c44} + , + {0x0c46, 0x0c48} + , + {0x0c4a, 0x0c4d} + , + {0x0c55, 0x0c56} + , + {0x0c58, 0x0c59} + , + {0x0c60, 0x0c63} + , + {0x0c66, 0x0c6f} + , + {0x0c78, 0x0c7f} + , + {0x0c82, 0x0c83} + , + {0x0c85, 0x0c8c} + , + {0x0c8e, 0x0c90} + , + {0x0c92, 0x0ca8} + , + {0x0caa, 0x0cb3} + , + {0x0cb5, 0x0cb9} + , + {0x0cbc, 0x0cc4} + , + {0x0cc6, 0x0cc8} + , + {0x0cca, 0x0ccd} + , + {0x0cd5, 0x0cd6} + , + {0x0cde, 0x0cde} + , + {0x0ce0, 0x0ce3} + , + {0x0ce6, 0x0cef} + , + {0x0cf1, 0x0cf2} + , + {0x0d02, 0x0d03} + , + {0x0d05, 0x0d0c} + , + {0x0d0e, 0x0d10} + , + {0x0d12, 0x0d28} + , + {0x0d2a, 0x0d39} + , + {0x0d3d, 0x0d44} + , + {0x0d46, 0x0d48} + , + {0x0d4a, 0x0d4d} + , + {0x0d57, 0x0d57} + , + {0x0d60, 0x0d63} + , + {0x0d66, 0x0d75} + , + {0x0d79, 0x0d7f} + , + {0x0d82, 0x0d83} + , + {0x0d85, 0x0d96} + , + {0x0d9a, 0x0db1} + , + {0x0db3, 0x0dbb} + , + {0x0dbd, 0x0dbd} + , + {0x0dc0, 0x0dc6} + , + {0x0dca, 0x0dca} + , + {0x0dcf, 0x0dd4} + , + {0x0dd6, 0x0dd6} + , + {0x0dd8, 0x0ddf} + , + {0x0df2, 0x0df4} + , + {0x0e01, 0x0e3a} + , + {0x0e3f, 0x0e5b} + , + {0x0e81, 0x0e82} + , + {0x0e84, 0x0e84} + , + {0x0e87, 0x0e88} + , + {0x0e8a, 0x0e8a} + , + {0x0e8d, 0x0e8d} + , + {0x0e94, 0x0e97} + , + {0x0e99, 0x0e9f} + , + {0x0ea1, 0x0ea3} + , + {0x0ea5, 0x0ea5} + , + {0x0ea7, 0x0ea7} + , + {0x0eaa, 0x0eab} + , + {0x0ead, 0x0eb9} + , + {0x0ebb, 0x0ebd} + , + {0x0ec0, 0x0ec4} + , + {0x0ec6, 0x0ec6} + , + {0x0ec8, 0x0ecd} + , + {0x0ed0, 0x0ed9} + , + {0x0edc, 0x0edd} + , + {0x0f00, 0x0f47} + , + {0x0f49, 0x0f6c} + , + {0x0f71, 0x0f8b} + , + {0x0f90, 0x0f97} + , + {0x0f99, 0x0fbc} + , + {0x0fbe, 0x0fcc} + , + {0x0fce, 0x0fd4} + , + {0x1000, 0x1099} + , + {0x109e, 0x10c5} + , + {0x10d0, 0x10fc} + , + {0x1100, 0x1159} + , + {0x115f, 0x11a2} + , + {0x11a8, 0x11f9} + , + {0x1200, 0x1248} + , + {0x124a, 0x124d} + , + {0x1250, 0x1256} + , + {0x1258, 0x1258} + , + {0x125a, 0x125d} + , + {0x1260, 0x1288} + , + {0x128a, 0x128d} + , + {0x1290, 0x12b0} + , + {0x12b2, 0x12b5} + , + {0x12b8, 0x12be} + , + {0x12c0, 0x12c0} + , + {0x12c2, 0x12c5} + , + {0x12c8, 0x12d6} + , + {0x12d8, 0x1310} + , + {0x1312, 0x1315} + , + {0x1318, 0x135a} + , + {0x135f, 0x137c} + , + {0x1380, 0x1399} + , + {0x13a0, 0x13f4} + , + {0x1401, 0x1676} + , + {0x1680, 0x169c} + , + {0x16a0, 0x16f0} + , + {0x1700, 0x170c} + , + {0x170e, 0x1714} + , + {0x1720, 0x1736} + , + {0x1740, 0x1753} + , + {0x1760, 0x176c} + , + {0x176e, 0x1770} + , + {0x1772, 0x1773} + , + {0x1780, 0x17dd} + , + {0x17e0, 0x17e9} + , + {0x17f0, 0x17f9} + , + {0x1800, 0x180e} + , + {0x1810, 0x1819} + , + {0x1820, 0x1877} + , + {0x1880, 0x18aa} + , + {0x1900, 0x191c} + , + {0x1920, 0x192b} + , + {0x1930, 0x193b} + , + {0x1940, 0x1940} + , + {0x1944, 0x196d} + , + {0x1970, 0x1974} + , + {0x1980, 0x19a9} + , + {0x19b0, 0x19c9} + , + {0x19d0, 0x19d9} + , + {0x19de, 0x1a1b} + , + {0x1a1e, 0x1a1f} + , + {0x1b00, 0x1b4b} + , + {0x1b50, 0x1b7c} + , + {0x1b80, 0x1baa} + , + {0x1bae, 0x1bb9} + , + {0x1c00, 0x1c37} + , + {0x1c3b, 0x1c49} + , + {0x1c4d, 0x1c7f} + , + {0x1d00, 0x1de6} + , + {0x1dfe, 0x1f15} + , + {0x1f18, 0x1f1d} + , + {0x1f20, 0x1f45} + , + {0x1f48, 0x1f4d} + , + {0x1f50, 0x1f57} + , + {0x1f59, 0x1f59} + , + {0x1f5b, 0x1f5b} + , + {0x1f5d, 0x1f5d} + , + {0x1f5f, 0x1f7d} + , + {0x1f80, 0x1fb4} + , + {0x1fb6, 0x1fc4} + , + {0x1fc6, 0x1fd3} + , + {0x1fd6, 0x1fdb} + , + {0x1fdd, 0x1fef} + , + {0x1ff2, 0x1ff4} + , + {0x1ff6, 0x1ffe} + , + {0x2000, 0x2064} + , + {0x206a, 0x2071} + , + {0x2074, 0x208e} + , + {0x2090, 0x2094} + , + {0x20a0, 0x20b5} + , + {0x20d0, 0x20f0} + , + {0x2100, 0x214f} + , + {0x2153, 0x2188} + , + {0x2190, 0x23e7} + , + {0x2400, 0x2426} + , + {0x2440, 0x244a} + , + {0x2460, 0x269d} + , + {0x26a0, 0x26bc} + , + {0x26c0, 0x26c3} + , + {0x2701, 0x2704} + , + {0x2706, 0x2709} + , + {0x270c, 0x2727} + , + {0x2729, 0x274b} + , + {0x274d, 0x274d} + , + {0x274f, 0x2752} + , + {0x2756, 0x2756} + , + {0x2758, 0x275e} + , + {0x2761, 0x2794} + , + {0x2798, 0x27af} + , + {0x27b1, 0x27be} + , + {0x27c0, 0x27ca} + , + {0x27cc, 0x27cc} + , + {0x27d0, 0x2b4c} + , + {0x2b50, 0x2b54} + , + {0x2c00, 0x2c2e} + , + {0x2c30, 0x2c5e} + , + {0x2c60, 0x2c6f} + , + {0x2c71, 0x2c7d} + , + {0x2c80, 0x2cea} + , + {0x2cf9, 0x2d25} + , + {0x2d30, 0x2d65} + , + {0x2d6f, 0x2d6f} + , + {0x2d80, 0x2d96} + , + {0x2da0, 0x2da6} + , + {0x2da8, 0x2dae} + , + {0x2db0, 0x2db6} + , + {0x2db8, 0x2dbe} + , + {0x2dc0, 0x2dc6} + , + {0x2dc8, 0x2dce} + , + {0x2dd0, 0x2dd6} + , + {0x2dd8, 0x2dde} + , + {0x2de0, 0x2e30} + , + {0x2e80, 0x2e99} + , + {0x2e9b, 0x2ef3} + , + {0x2f00, 0x2fd5} + , + {0x2ff0, 0x2ffb} + , + {0x3000, 0x303f} + , + {0x3041, 0x3096} + , + {0x3099, 0x30ff} + , + {0x3105, 0x312d} + , + {0x3131, 0x318e} + , + {0x3190, 0x31b7} + , + {0x31c0, 0x31e3} + , + {0x31f0, 0x321e} + , + {0x3220, 0x3243} + , + {0x3250, 0x32fe} + , + {0x3300, 0x4db5} + , + {0x4dc0, 0x9fc3} + , + {0xa000, 0xa48c} + , + {0xa490, 0xa4c6} + , + {0xa500, 0xa62b} + , + {0xa640, 0xa65f} + , + {0xa662, 0xa673} + , + {0xa67c, 0xa697} + , + {0xa700, 0xa78c} + , + {0xa7fb, 0xa82b} + , + {0xa840, 0xa877} + , + {0xa880, 0xa8c4} + , + {0xa8ce, 0xa8d9} + , + {0xa900, 0xa953} + , + {0xa95f, 0xa95f} + , + {0xaa00, 0xaa36} + , + {0xaa40, 0xaa4d} + , + {0xaa50, 0xaa59} + , + {0xaa5c, 0xaa5f} + , + {0xac00, 0xd7a3} + , + {0xd800, 0xfa2d} + , + {0xfa30, 0xfa6a} + , + {0xfa70, 0xfad9} + , + {0xfb00, 0xfb06} + , + {0xfb13, 0xfb17} + , + {0xfb1d, 0xfb36} + , + {0xfb38, 0xfb3c} + , + {0xfb3e, 0xfb3e} + , + {0xfb40, 0xfb41} + , + {0xfb43, 0xfb44} + , + {0xfb46, 0xfbb1} + , + {0xfbd3, 0xfd3f} + , + {0xfd50, 0xfd8f} + , + {0xfd92, 0xfdc7} + , + {0xfdf0, 0xfdfd} + , + {0xfe00, 0xfe19} + , + {0xfe20, 0xfe26} + , + {0xfe30, 0xfe52} + , + {0xfe54, 0xfe66} + , + {0xfe68, 0xfe6b} + , + {0xfe70, 0xfe74} + , + {0xfe76, 0xfefc} + , + {0xfeff, 0xfeff} + , + {0xff01, 0xffbe} + , + {0xffc2, 0xffc7} + , + {0xffca, 0xffcf} + , + {0xffd2, 0xffd7} + , + {0xffda, 0xffdc} + , + {0xffe0, 0xffe6} + , + {0xffe8, 0xffee} + , + {0xfff9, 0xfffd} + , + {0x10000, 0x1000b} + , + {0x1000d, 0x10026} + , + {0x10028, 0x1003a} + , + {0x1003c, 0x1003d} + , + {0x1003f, 0x1004d} + , + {0x10050, 0x1005d} + , + {0x10080, 0x100fa} + , + {0x10100, 0x10102} + , + {0x10107, 0x10133} + , + {0x10137, 0x1018a} + , + {0x10190, 0x1019b} + , + {0x101d0, 0x101fd} + , + {0x10280, 0x1029c} + , + {0x102a0, 0x102d0} + , + {0x10300, 0x1031e} + , + {0x10320, 0x10323} + , + {0x10330, 0x1034a} + , + {0x10380, 0x1039d} + , + {0x1039f, 0x103c3} + , + {0x103c8, 0x103d5} + , + {0x10400, 0x1049d} + , + {0x104a0, 0x104a9} + , + {0x10800, 0x10805} + , + {0x10808, 0x10808} + , + {0x1080a, 0x10835} + , + {0x10837, 0x10838} + , + {0x1083c, 0x1083c} + , + {0x1083f, 0x1083f} + , + {0x10900, 0x10919} + , + {0x1091f, 0x10939} + , + {0x1093f, 0x1093f} + , + {0x10a00, 0x10a03} + , + {0x10a05, 0x10a06} + , + {0x10a0c, 0x10a13} + , + {0x10a15, 0x10a17} + , + {0x10a19, 0x10a33} + , + {0x10a38, 0x10a3a} + , + {0x10a3f, 0x10a47} + , + {0x10a50, 0x10a58} + , + {0x12000, 0x1236e} + , + {0x12400, 0x12462} + , + {0x12470, 0x12473} + , + {0x1d000, 0x1d0f5} + , + {0x1d100, 0x1d126} + , + {0x1d129, 0x1d1dd} + , + {0x1d200, 0x1d245} + , + {0x1d300, 0x1d356} + , + {0x1d360, 0x1d371} + , + {0x1d400, 0x1d454} + , + {0x1d456, 0x1d49c} + , + {0x1d49e, 0x1d49f} + , + {0x1d4a2, 0x1d4a2} + , + {0x1d4a5, 0x1d4a6} + , + {0x1d4a9, 0x1d4ac} + , + {0x1d4ae, 0x1d4b9} + , + {0x1d4bb, 0x1d4bb} + , + {0x1d4bd, 0x1d4c3} + , + {0x1d4c5, 0x1d505} + , + {0x1d507, 0x1d50a} + , + {0x1d50d, 0x1d514} + , + {0x1d516, 0x1d51c} + , + {0x1d51e, 0x1d539} + , + {0x1d53b, 0x1d53e} + , + {0x1d540, 0x1d544} + , + {0x1d546, 0x1d546} + , + {0x1d54a, 0x1d550} + , + {0x1d552, 0x1d6a5} + , + {0x1d6a8, 0x1d7cb} + , + {0x1d7ce, 0x1d7ff} + , + {0x1f000, 0x1f02b} + , + {0x1f030, 0x1f093} + , + {0x20000, 0x2a6d6} + , + {0x2f800, 0x2fa1d} + , + {0xe0001, 0xe0001} + , + {0xe0020, 0xe007f} + , + {0xe0100, 0xe01ef} + , + {0xf0000, 0xffffd} + , + {0x100000, 0x10fffd} +}; + +scm_t_char_set cs_full = { + 445, + cs_full_ranges +}; diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index 3e43a4985..302414364 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 @@ -27,13 +28,19 @@ #include "libguile/_scm.h" #include "libguile/__scm.h" +#include "libguile/boehm-gc.h" #include "libguile/srfi-4.h" +#include "libguile/bitvectors.h" +#include "libguile/bytevectors.h" +#include "libguile/generalized-vectors.h" +#include "libguile/uniform.h" #include "libguile/error.h" +#include "libguile/eval.h" #include "libguile/read.h" #include "libguile/ports.h" #include "libguile/chars.h" #include "libguile/vectors.h" -#include "libguile/unif.h" +#include "libguile/arrays.h" #include "libguile/strings.h" #include "libguile/strports.h" #include "libguile/dynwind.h" @@ -275,6 +282,14 @@ uvec_assert (int type, SCM obj) scm_wrong_type_arg_msg (NULL, 0, obj, uvec_names[type]); } +/* Invoke free(3) on DATA, a user-provided buffer passed to one of the + `scm_take_' functions. */ +static void +free_user_data (GC_PTR data, GC_PTR unused) +{ + free (data); +} + static SCM take_uvec (int type, void *base, size_t len) { @@ -466,11 +481,8 @@ uvec_to_list (int type, SCM uvec) SCM res = SCM_EOL; elts = uvec_elements (type, uvec, &handle, &len, &inc); - for (i = len*inc; i > 0;) - { - i -= inc; - res = scm_cons (scm_array_handle_ref (&handle, i), res); - } + for (i = len - 1; i >= 0; i--) + res = scm_cons (scm_array_handle_ref (&handle, i*inc), res); scm_array_handle_release (&handle); return res; } @@ -543,29 +555,6 @@ list_to_uvec (int type, SCM list) return uvec; } -static SCM -coerce_to_uvec (int type, SCM obj) -{ - if (is_uvec (type, obj)) - return obj; - else if (scm_is_pair (obj)) - return list_to_uvec (type, obj); - else if (scm_is_generalized_vector (obj)) - { - scm_t_array_handle handle; - size_t len = scm_c_generalized_vector_length (obj), i; - SCM uvec = alloc_uvec (type, len); - scm_array_get_handle (uvec, &handle); - for (i = 0; i < len; i++) - scm_array_handle_set (&handle, i, - scm_c_generalized_vector_ref (obj, i)); - scm_array_handle_release (&handle); - return uvec; - } - else - scm_wrong_type_arg_msg (NULL, 0, obj, "list or generalized vector"); -} - SCM_SYMBOL (scm_sym_a, "a"); SCM_SYMBOL (scm_sym_b, "b"); @@ -580,222 +569,12 @@ 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; } -int -scm_is_uniform_vector (SCM obj) -{ - if (SCM_IS_UVEC (obj)) - return 1; - if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1) - { - SCM v = SCM_I_ARRAY_V (obj); - return SCM_IS_UVEC (v); - } - return 0; -} - -size_t -scm_c_uniform_vector_length (SCM uvec) -{ - /* scm_generalized_vector_get_handle will ultimately call us to get - the length of uniform vectors, so we can't use uvec_elements for - naked vectors. - */ - - if (SCM_IS_UVEC (uvec)) - return SCM_UVEC_LENGTH (uvec); - else - { - scm_t_array_handle handle; - size_t len; - ssize_t inc; - uvec_elements (-1, uvec, &handle, &len, &inc); - scm_array_handle_release (&handle); - return len; - } -} - -SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a uniform vector.") -#define FUNC_NAME s_scm_uniform_vector_p -{ - return scm_from_bool (scm_is_uniform_vector (obj)); -} -#undef FUNC_NAME - -SCM -scm_c_uniform_vector_ref (SCM v, size_t idx) -{ - scm_t_array_handle handle; - size_t len; - ssize_t inc; - SCM res; - - uvec_elements (-1, v, &handle, &len, &inc); - if (idx >= len) - scm_out_of_range (NULL, scm_from_size_t (idx)); - res = scm_array_handle_ref (&handle, idx*inc); - scm_array_handle_release (&handle); - return res; -} - -SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, - (SCM v, SCM idx), - "Return the element at index @var{idx} of the\n" - "homogenous numeric vector @var{v}.") -#define FUNC_NAME s_scm_uniform_vector_ref -{ -#if SCM_ENABLE_DEPRECATED - /* Support old argument convention. - */ - if (scm_is_pair (idx)) - { - scm_c_issue_deprecation_warning - ("Using a list as the index to uniform-vector-ref is deprecated."); - if (!scm_is_null (SCM_CDR (idx))) - scm_wrong_num_args (NULL); - idx = SCM_CAR (idx); - } -#endif - - return scm_c_uniform_vector_ref (v, scm_to_size_t (idx)); -} -#undef FUNC_NAME - -void -scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val) -{ - scm_t_array_handle handle; - size_t len; - ssize_t inc; - - uvec_writable_elements (-1, v, &handle, &len, &inc); - if (idx >= len) - scm_out_of_range (NULL, scm_from_size_t (idx)); - scm_array_handle_set (&handle, idx*inc, val); - scm_array_handle_release (&handle); -} - -SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0, - (SCM v, SCM idx, SCM val), - "Set the element at index @var{idx} of the\n" - "homogenous numeric vector @var{v} to @var{val}.") -#define FUNC_NAME s_scm_uniform_vector_set_x -{ -#if SCM_ENABLE_DEPRECATED - /* Support old argument convention. - */ - if (scm_is_pair (idx)) - { - scm_c_issue_deprecation_warning - ("Using a list as the index to uniform-vector-set! is deprecated."); - if (!scm_is_null (SCM_CDR (idx))) - scm_wrong_num_args (NULL); - idx = SCM_CAR (idx); - } -#endif - - scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0, - (SCM uvec), - "Convert the uniform numeric vector @var{uvec} to a list.") -#define FUNC_NAME s_scm_uniform_vector_to_list -{ - return uvec_to_list (-1, uvec); -} -#undef FUNC_NAME - -size_t -scm_array_handle_uniform_element_size (scm_t_array_handle *h) -{ - SCM vec = h->array; - if (SCM_I_ARRAYP (vec)) - vec = SCM_I_ARRAY_V (vec); - if (scm_is_uniform_vector (vec)) - return uvec_sizes[SCM_UVEC_TYPE(vec)]; - scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array"); -} - -#if SCM_ENABLE_DEPRECATED - -/* return the size of an element in a uniform array or 0 if type not - found. */ -size_t -scm_uniform_element_size (SCM obj) -{ - scm_c_issue_deprecation_warning - ("scm_uniform_element_size is deprecated. " - "Use scm_array_handle_uniform_element_size instead."); - - if (SCM_IS_UVEC (obj)) - return uvec_sizes[SCM_UVEC_TYPE(obj)]; - else - return 0; -} - -#endif - -const void * -scm_array_handle_uniform_elements (scm_t_array_handle *h) -{ - return scm_array_handle_uniform_writable_elements (h); -} - -void * -scm_array_handle_uniform_writable_elements (scm_t_array_handle *h) -{ - SCM vec = h->array; - if (SCM_I_ARRAYP (vec)) - vec = SCM_I_ARRAY_V (vec); - if (SCM_IS_UVEC (vec)) - { - size_t size = uvec_sizes[SCM_UVEC_TYPE(vec)]; - char *elts = SCM_UVEC_BASE (vec); - return (void *) (elts + size*h->base); - } - scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array"); -} - -const void * -scm_uniform_vector_elements (SCM uvec, - scm_t_array_handle *h, - size_t *lenp, ssize_t *incp) -{ - return scm_uniform_vector_writable_elements (uvec, h, lenp, incp); -} - -void * -scm_uniform_vector_writable_elements (SCM uvec, - scm_t_array_handle *h, - size_t *lenp, ssize_t *incp) -{ - scm_generalized_vector_get_handle (uvec, h); - if (lenp) - { - scm_t_array_dim *dim = scm_array_handle_dims (h); - *lenp = dim->ubnd - dim->lbnd + 1; - *incp = dim->inc; - } - return scm_array_handle_uniform_writable_elements (h); -} - -SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, - (SCM v), - "Return the number of elements in the uniform vector @var{v}.") -#define FUNC_NAME s_scm_uniform_vector_length -{ - return uvec_length (-1, v); -} -#undef FUNC_NAME - SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0, (SCM uvec, SCM port_or_fd, SCM start, SCM end), "Fill the elements of @var{uvec} by reading\n" @@ -1031,6 +810,36 @@ SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0, #define CTYPE double #include "libguile/srfi-4.i.c" +#define DEFINE_SCHEME_PROXY100(cname, modname, scmname) \ + SCM cname (SCM arg1) \ + { \ + static SCM var = SCM_BOOL_F; \ + if (scm_is_false (var)) \ + var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \ + return scm_call_1 (SCM_VARIABLE_REF (var), arg1); \ + } + +#define DEFPROXY100(cname, scmname) \ + DEFINE_SCHEME_PROXY100 (cname, MOD, scmname) + +#define DEFINE_SRFI_4_GNU_PROXIES(tag) \ + DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector") + +#define MOD "srfi srfi-4 gnu" +DEFINE_SRFI_4_GNU_PROXIES (u8); +DEFINE_SRFI_4_GNU_PROXIES (s8); +DEFINE_SRFI_4_GNU_PROXIES (u16); +DEFINE_SRFI_4_GNU_PROXIES (s16); +DEFINE_SRFI_4_GNU_PROXIES (u32); +DEFINE_SRFI_4_GNU_PROXIES (s32); +DEFINE_SRFI_4_GNU_PROXIES (u64); +DEFINE_SRFI_4_GNU_PROXIES (s64); +DEFINE_SRFI_4_GNU_PROXIES (f32); +DEFINE_SRFI_4_GNU_PROXIES (f64); +DEFINE_SRFI_4_GNU_PROXIES (c32); +DEFINE_SRFI_4_GNU_PROXIES (c64); + + static scm_i_t_array_ref uvec_reffers[12] = { u8ref, s8ref, u16ref, s16ref, @@ -1049,18 +858,35 @@ static scm_i_t_array_set uvec_setters[12] = { c32set, c64set }; -scm_i_t_array_ref -scm_i_uniform_vector_ref_proc (SCM uvec) +static SCM +uvec_handle_ref (scm_t_array_handle *h, size_t index) { - return uvec_reffers[SCM_UVEC_TYPE(uvec)]; + return uvec_reffers [SCM_UVEC_TYPE(h->array)] (h, index); } -scm_i_t_array_set -scm_i_uniform_vector_set_proc (SCM uvec) +static void +uvec_handle_set (scm_t_array_handle *h, size_t index, SCM val) { - return uvec_setters[SCM_UVEC_TYPE(uvec)]; + uvec_setters [SCM_UVEC_TYPE(h->array)] (h, index, val); } +static void +uvec_get_handle (SCM v, scm_t_array_handle *h) +{ + h->array = v; + h->ndims = 1; + h->dims = &h->dim0; + h->dim0.lbnd = 0; + h->dim0.ubnd = SCM_UVEC_LENGTH (v) - 1; + h->dim0.inc = 1; + h->element_type = SCM_UVEC_TYPE (v) + SCM_ARRAY_ELEMENT_TYPE_U8; + h->elements = h->writable_elements = SCM_UVEC_BASE (v); +} + +SCM_ARRAY_IMPLEMENTATION (scm_tc16_uvec, 0xffff, + uvec_handle_ref, uvec_handle_set, + uvec_get_handle); + void scm_init_srfi_4 (void) { @@ -1079,6 +905,24 @@ scm_init_srfi_4 (void) scm_permanent_object (scm_c_read_string ("9223372036854775807")); #endif +#define REGISTER(tag, TAG) \ + scm_i_register_vector_constructor \ + (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG], \ + scm_make_##tag##vector) + + REGISTER (u8, U8); + REGISTER (s8, S8); + REGISTER (u16, U16); + REGISTER (s16, S16); + REGISTER (u32, U32); + REGISTER (s32, S32); + REGISTER (u64, U64); + REGISTER (s64, S64); + REGISTER (f32, F32); + REGISTER (f64, F64); + REGISTER (c32, C32); + REGISTER (c64, C64); + #include "libguile/srfi-4.x" } diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h index 3c340d91e..3a45fd9e0 100644 --- a/libguile/srfi-4.h +++ b/libguile/srfi-4.h @@ -2,54 +2,26 @@ #define SCM_SRFI_4_H /* srfi-4.c --- Homogeneous numeric vector datatypes. * - * Copyright (C) 2001, 2004, 2006, 2008 Free Software Foundation, Inc. + * Copyright (C) 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/unif.h" - -/* Generic procedures. - */ - -SCM_API SCM scm_uniform_vector_p (SCM v); -SCM_API SCM scm_uniform_vector_length (SCM v); -SCM_API SCM scm_uniform_vector_ref (SCM v, SCM idx); -SCM_API SCM scm_uniform_vector_set_x (SCM v, SCM idx, SCM val); -SCM_API SCM scm_uniform_vector_to_list (SCM v); -SCM_API SCM scm_uniform_vector_read_x (SCM v, SCM port_or_fd, - SCM start, SCM end); -SCM_API SCM scm_uniform_vector_write (SCM v, SCM port_or_fd, - SCM start, SCM end); - -SCM_API int scm_is_uniform_vector (SCM obj); -SCM_API size_t scm_c_uniform_vector_length (SCM v); -SCM_API SCM scm_c_uniform_vector_ref (SCM v, size_t idx); -SCM_API void scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val); -SCM_API size_t scm_array_handle_uniform_element_size (scm_t_array_handle *h); -SCM_API const void *scm_array_handle_uniform_elements (scm_t_array_handle *h); -SCM_API void *scm_array_handle_uniform_writable_elements (scm_t_array_handle *h); -SCM_API const void *scm_uniform_vector_elements (SCM uvec, - scm_t_array_handle *h, - size_t *lenp, ssize_t *incp); -SCM_API void *scm_uniform_vector_writable_elements (SCM uvec, - scm_t_array_handle *h, - size_t *lenp, - ssize_t *incp); /* Specific procedures. */ diff --git a/libguile/srfi-4.i.c b/libguile/srfi-4.i.c index 58a52c1d8..098752ef2 100644 --- a/libguile/srfi-4.i.c +++ b/libguile/srfi-4.i.c @@ -121,24 +121,21 @@ SCM_DEFINE (F(scm_list_to_,TAG,vector), "list->"S(TAG)"vector", 1, 0, 0, } #undef FUNC_NAME -SCM_DEFINE (F(scm_any_to_,TAG,vector), "any->"S(TAG)"vector", 1, 0, 0, - (SCM obj), - "Convert @var{obj}, which can be a list, vector, or\n" - "uniform vector, to a numeric uniform vector of\n" - "type " S(TAG)".") -#define FUNC_NAME s_F(scm_any_to_,TAG,vector) -{ - return coerce_to_uvec (TYPE, obj); -} -#undef FUNC_NAME - #ifdef CTYPE SCM F(scm_take_,TAG,vector) (CTYPE *data, size_t n) { - scm_gc_register_collectable_memory ((void *)data, n*uvec_sizes[TYPE], - uvec_names[TYPE]); + /* The manual says "Return a new uniform numeric vector [...] that uses the + memory pointed to by DATA". We *have* to use DATA as the underlying + storage; thus we must register a finalizer to eventually free(3) it. */ + GC_finalization_proc prev_finalizer; + GC_PTR prev_finalization_data; + + GC_REGISTER_FINALIZER_NO_ORDER (data, free_user_data, 0, + &prev_finalizer, + &prev_finalization_data); + return take_uvec (TYPE, data, n); } @@ -187,13 +184,13 @@ F(scm_,TAG,vector_writable_elements) (SCM uvec, #endif static SCM -F(,TAG,ref) (scm_t_array_handle *handle, ssize_t pos) +F(,TAG,ref) (scm_t_array_handle *handle, size_t pos) { return uvec_fast_ref (TYPE, handle->elements, pos); } static void -F(,TAG,set) (scm_t_array_handle *handle, ssize_t pos, SCM val) +F(,TAG,set) (scm_t_array_handle *handle, size_t pos, SCM val) { uvec_fast_set_x (TYPE, handle->writable_elements, pos, val); } 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 86597fa0b..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 */ @@ -32,6 +33,8 @@ #include "libguile/modules.h" #include "libguile/root.h" #include "libguile/strings.h" +#include "libguile/vm.h" /* to capture vm stacks */ +#include "libguile/frames.h" /* vm frames */ #include "libguile/validate.h" #include "libguile/stacks.h" @@ -123,19 +126,17 @@ #define RELOC_FRAME(ptr, offset) \ ((scm_t_debug_frame *) ((SCM_STACKITEM *) (ptr) + (offset))) - /* Count number of debug info frames on a stack, beginning with * DFRAME. OFFSET is used for relocation of pointers when the stack * is read from a continuation. */ -static scm_t_bits -stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, - SCM *id, int *maxp) +static long +stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, SCM vmframe, + SCM *id) { long n; - long max_depth = SCM_BACKTRACE_MAXDEPTH; for (n = 0; - dframe && !SCM_VOIDFRAMEP (*dframe) && n < max_depth; + dframe && !SCM_VOIDFRAMEP (*dframe); dframe = RELOC_FRAME (dframe->prev, offset)) { if (SCM_EVALFRAMEP (*dframe)) @@ -148,15 +149,39 @@ stack_depth (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, if ((((info - vect) & 1) == 0) && SCM_OVERFLOWP (*dframe) && !SCM_UNBNDP (info[1].a.proc)) - ++n; + ++n; } + else if (SCM_APPLYFRAMEP (*dframe)) + { + scm_t_debug_info *vect = RELOC_INFO (dframe->vect, offset); + if (SCM_PROGRAM_P (vect[0].a.proc)) + { + if (!SCM_PROGRAM_IS_BOOT (vect[0].a.proc)) + /* Programs can end up in the debug stack via deval; but we just + ignore those, because we know that the debugging VM engine + pushes one dframe per invocation, with the boot program as + the proc, so we only count those. */ + continue; + /* count vmframe back to previous boot frame */ + for (; scm_is_true (vmframe); vmframe = scm_c_vm_frame_prev (vmframe)) + { + if (!SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe))) + ++n; + else + { /* skip boot frame, cut out of the vm backtrace */ + vmframe = scm_c_vm_frame_prev (vmframe); + break; + } + } + } + else + ++n; /* increment for non-program apply frame */ + } else ++n; } if (dframe && SCM_VOIDFRAMEP (*dframe)) *id = RELOC_INFO(dframe->vect, offset)[0].id; - else if (dframe) - *maxp = 1; return n; } @@ -234,7 +259,7 @@ do { \ static scm_t_bits read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, - long n, scm_t_info_frame *iframes) + SCM vmframe, long n, scm_t_info_frame *iframes) { scm_t_info_frame *iframe = iframes; scm_t_debug_info *info, *vect; @@ -293,10 +318,39 @@ read_frames (scm_t_debug_frame *dframe, scm_t_ptrdiff offset, NEXT_FRAME (iframe, n, quit); } } + else if (SCM_PROGRAM_P (iframe->proc)) + { + if (!SCM_PROGRAM_IS_BOOT (iframe->proc)) + /* Programs can end up in the debug stack via deval; but we just + ignore those, because we know that the debugging VM engine + pushes one dframe per invocation, with the boot program as + the proc, so we only count those. */ + continue; + for (; scm_is_true (vmframe); + vmframe = scm_c_vm_frame_prev (vmframe)) + { + if (SCM_PROGRAM_IS_BOOT (scm_vm_frame_program (vmframe))) + { /* skip boot frame, back to interpreted frames */ + vmframe = scm_c_vm_frame_prev (vmframe); + break; + } + else + { + /* Oh dear, oh dear, oh dear. */ + iframe->flags = SCM_UNPACK (SCM_INUM0) | SCM_FRAMEF_PROC; + iframe->source = scm_vm_frame_source (vmframe); + iframe->proc = scm_vm_frame_program (vmframe); + iframe->args = scm_vm_frame_arguments (vmframe); + ++iframe; + if (--n == 0) + goto quit; + } + } + } else - { - NEXT_FRAME (iframe, n, quit); - } + { + NEXT_FRAME (iframe, n, quit); + } quit: if (iframe > iframes) (iframe - 1) -> flags |= SCM_FRAMEF_REAL; @@ -428,6 +482,7 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, int maxp; scm_t_debug_frame *dframe; scm_t_info_frame *iframe; + SCM vmframe; long offset = 0; SCM stack, id; SCM inner_cut, outer_cut; @@ -436,17 +491,37 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, scm_make_stack was given. */ if (scm_is_eq (obj, SCM_BOOL_T)) { + struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ()); dframe = scm_i_last_debug_frame (); + vmframe = scm_c_make_vm_frame (scm_the_vm (), vp->fp, vp->sp, vp->ip, 0); } else if (SCM_DEBUGOBJP (obj)) { dframe = SCM_DEBUGOBJ_FRAME (obj); + vmframe = SCM_BOOL_F; + } + else if (SCM_VM_FRAME_P (obj)) + { + dframe = NULL; + vmframe = obj; } else if (SCM_CONTINUATIONP (obj)) { scm_t_contregs *cont = SCM_CONTREGS (obj); offset = cont->offset; dframe = RELOC_FRAME (cont->dframe, offset); + if (!scm_is_null (cont->vm_conts)) + { SCM vm_cont; + struct scm_vm_cont *data; + vm_cont = scm_cdr (scm_car (cont->vm_conts)); + data = SCM_VM_CONT_DATA (vm_cont); + vmframe = scm_c_make_vm_frame (vm_cont, + data->fp + data->reloc, + data->sp + data->reloc, + data->ip, + data->reloc); + } else + vmframe = SCM_BOOL_F; } else { @@ -459,7 +534,8 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, (SCM_BACKTRACE_MAXDEPTH). */ id = SCM_BOOL_F; maxp = 0; - n = stack_depth (dframe, offset, &id, &maxp); + n = stack_depth (dframe, offset, vmframe, &id); + /* FIXME: redo maxp? */ size = n * SCM_FRAME_N_SLOTS; /* Make the stack object. */ @@ -467,10 +543,15 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, SCM_STACK (stack) -> id = id; iframe = &SCM_STACK (stack) -> tail[0]; SCM_STACK (stack) -> frames = iframe; + SCM_STACK (stack) -> length = n; /* Translate the current chain of stack frames into debugging information. */ - n = read_frames (dframe, offset, n, iframe); - SCM_STACK (stack) -> length = n; + n = read_frames (dframe, offset, vmframe, n, iframe); + if (n != SCM_STACK (stack)->length) + { + scm_puts ("warning: stack count incorrect!\n", scm_current_error_port ()); + SCM_STACK (stack)->length = n; + } /* Narrow the stack according to the arguments given to scm_make_stack. */ SCM_VALIDATE_REST_ARGUMENT (args); @@ -497,12 +578,11 @@ SCM_DEFINE (scm_make_stack, "make-stack", 1, 0, 1, n = SCM_STACK (stack) -> length; } + if (n > 0 && maxp) + iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW; + if (n > 0) - { - if (maxp) - iframe[n - 1].flags |= SCM_FRAMEF_OVERFLOW; - return stack; - } + return stack; else return SCM_BOOL_F; } 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..54022c296 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 */ @@ -45,6 +46,7 @@ #include <stdio.h> #include <errno.h> #include <strftime.h> +#include <unistr.h> #include "libguile/_scm.h" #include "libguile/async.h" @@ -52,6 +54,7 @@ #include "libguile/strings.h" #include "libguile/vectors.h" #include "libguile/dynwind.h" +#include "libguile/strings.h" #include "libguile/validate.h" #include "libguile/stime.h" @@ -77,10 +80,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 +97,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 @@ -636,18 +626,20 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, { struct tm t; - char *tbuf; + scm_t_uint8 *tbuf; int size = 50; - const char *fmt; - char *myfmt; + scm_t_uint8 *fmt; + scm_t_uint8 *myfmt; int len; SCM result; SCM_VALIDATE_STRING (1, format); bdtime2c (stime, &t, SCM_ARG2, FUNC_NAME); - fmt = scm_i_string_chars (format); - len = scm_i_string_length (format); + /* Convert string to UTF-8 so that non-ASCII characters in the + format are passed through unchanged. */ + fmt = scm_i_to_utf8_string (format); + len = strlen ((const char *) fmt); /* Ugly hack: strftime can return 0 if its buffer is too small, but some valid time strings (e.g. "%p") can sometimes produce @@ -655,9 +647,11 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, character to the format string, so that valid returns are always nonzero. */ myfmt = scm_malloc (len+2); - *myfmt = 'x'; - strncpy(myfmt+1, fmt, len); - myfmt[len+1] = 0; + *myfmt = (scm_t_uint8) 'x'; + strncpy ((char *) myfmt + 1, (const char *) fmt, len); + myfmt[len + 1] = 0; + scm_remember_upto_here_1 (format); + free (fmt); tbuf = scm_malloc (size); { @@ -692,7 +686,8 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, /* Use `nstrftime ()' from Gnulib, which supports all GNU extensions supported by glibc. */ - while ((len = nstrftime (tbuf, size, myfmt, &t, 0, 0)) == 0) + while ((len = nstrftime ((char *) tbuf, size, + (const char *) myfmt, &t, 0, 0)) == 0) { free (tbuf); size *= 2; @@ -708,7 +703,7 @@ SCM_DEFINE (scm_strftime, "strftime", 2, 0, 0, #endif } - result = scm_from_locale_stringn (tbuf + 1, len - 1); + result = scm_i_from_utf8_string ((const scm_t_uint8 *) tbuf + 1); free (tbuf); free (myfmt); #if HAVE_STRUCT_TM_TM_ZONE @@ -734,14 +729,17 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, #define FUNC_NAME s_scm_strptime { struct tm t; - const char *fmt, *str, *rest; + scm_t_uint8 *fmt, *str, *rest; + size_t used_len; long zoff; SCM_VALIDATE_STRING (1, format); SCM_VALIDATE_STRING (2, string); - fmt = scm_i_string_chars (format); - str = scm_i_string_chars (string); + /* Convert strings to UTF-8 so that non-ASCII characters are passed + through unchanged. */ + fmt = scm_i_to_utf8_string (format); + str = scm_i_to_utf8_string (string); /* initialize the struct tm */ #define tm_init(field) t.field = 0 @@ -763,7 +761,8 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, fields, hence the use of SCM_CRITICAL_SECTION_START. */ t.tm_isdst = -1; SCM_CRITICAL_SECTION_START; - rest = strptime (str, fmt, &t); + rest = (scm_t_uint8 *) strptime ((const char *) str, + (const char *) fmt, &t); SCM_CRITICAL_SECTION_END; if (rest == NULL) { @@ -771,6 +770,9 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, instance it doesn't. Force a sensible value for our error message. */ errno = EINVAL; + scm_remember_upto_here_2 (format, string); + free (str); + free (fmt); SCM_SYSERROR; } @@ -782,8 +784,14 @@ SCM_DEFINE (scm_strptime, "strptime", 2, 0, 0, zoff = 0; #endif + /* Compute the number of UTF-8 characters. */ + used_len = u8_strnlen (str, rest-str); + scm_remember_upto_here_2 (format, string); + free (str); + free (fmt); + return scm_cons (filltime (&t, zoff, NULL), - scm_from_signed_integer (rest - str)); + scm_from_signed_integer (used_len)); } #undef FUNC_NAME #endif /* HAVE_STRPTIME */ 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 1839c6ac0..03ead8138 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,11 +24,17 @@ #include <string.h> #include <stdio.h> +#include <ctype.h> +#include <unistr.h> +#include <uniconv.h> + +#include "striconveh.h" #include "libguile/_scm.h" #include "libguile/chars.h" #include "libguile/root.h" #include "libguile/strings.h" +#include "libguile/generalized-vectors.h" #include "libguile/deprecation.h" #include "libguile/validate.h" @@ -41,7 +48,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 @@ -54,37 +61,30 @@ * cow-strings, but it failed randomly with more than 10 threads, say. * I couldn't figure out what went wrong, so I used the conservative * approach implemented below. - * - * 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 2 storage strategies for stringbufs: 8-bit and wide. 8-bit + * strings are ISO-8859-1-encoded strings; wide strings are 32-bit (UCS-4) + * strings. */ +/* The size in words of the stringbuf header (type tag + size). */ +#define STRINGBUF_HEADER_SIZE 2U + +#define STRINGBUF_HEADER_BYTES (STRINGBUF_HEADER_SIZE * sizeof (SCM)) + #define STRINGBUF_F_SHARED SCM_I_STRINGBUF_F_SHARED -#define STRINGBUF_F_INLINE SCM_I_STRINGBUF_F_INLINE +#define STRINGBUF_F_WIDE SCM_I_STRINGBUF_F_WIDE #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_OUTLINE_CHARS(buf) ((char *)SCM_CELL_WORD_1(buf)) -#define STRINGBUF_OUTLINE_LENGTH(buf) (SCM_CELL_WORD_2(buf)) -#define STRINGBUF_INLINE_CHARS(buf) ((char *)SCM_CELL_OBJECT_LOC(buf,1)) -#define STRINGBUF_INLINE_LENGTH(buf) (((size_t)SCM_CELL_WORD_0(buf))>>16) +#define STRINGBUF_WIDE(buf) (SCM_CELL_WORD_0(buf) & STRINGBUF_F_WIDE) -#define STRINGBUF_CHARS(buf) (STRINGBUF_INLINE (buf) \ - ? STRINGBUF_INLINE_CHARS (buf) \ - : STRINGBUF_OUTLINE_CHARS (buf)) -#define STRINGBUF_LENGTH(buf) (STRINGBUF_INLINE (buf) \ - ? STRINGBUF_INLINE_LENGTH (buf) \ - : STRINGBUF_OUTLINE_LENGTH (buf)) +#define STRINGBUF_CHARS(buf) ((unsigned char *) \ + SCM_CELL_OBJECT_LOC (buf, \ + STRINGBUF_HEADER_SIZE)) +#define STRINGBUF_LENGTH(buf) (SCM_CELL_WORD_1 (buf)) -#define STRINGBUF_MAX_INLINE_LEN (3*sizeof(scm_t_bits)) +#define STRINGBUF_WIDE_CHARS(buf) ((scm_t_wchar *) STRINGBUF_CHARS (buf)) #define SET_STRINGBUF_SHARED(buf) \ do \ @@ -96,10 +96,12 @@ } \ while (0) -#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) { @@ -110,41 +112,117 @@ make_stringbuf (size_t len) can be dropped. */ -#if SCM_DEBUG + SCM buf; + +#if SCM_STRING_LENGTH_HISTOGRAM if (len < 1000) lenhist[len]++; else lenhist[1000]++; #endif - if (len <= STRINGBUF_MAX_INLINE_LEN-1) - { - return scm_double_cell (STRINGBUF_TAG | STRINGBUF_F_INLINE | (len << 16), - 0, 0, 0); - } + buf = PTR2SCM (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + len + 1, + "string")); + + SCM_SET_CELL_TYPE (buf, STRINGBUF_TAG); + SCM_SET_CELL_WORD_1 (buf, (scm_t_bits) len); + + STRINGBUF_CHARS (buf)[len] = 0; + + return buf; +} + +/* Make a stringbuf with space for LEN 32-bit UCS-4-encoded + characters. */ +static SCM +make_wide_stringbuf (size_t len) +{ + SCM buf; + size_t raw_len; + +#if SCM_STRING_LENGTH_HISTOGRAM + if (len < 1000) + lenhist[len]++; + else + lenhist[1000]++; +#endif + + raw_len = (len + 1) * sizeof (scm_t_wchar); + buf = PTR2SCM (scm_gc_malloc_pointerless (STRINGBUF_HEADER_BYTES + raw_len, + "string")); + + SCM_SET_CELL_TYPE (buf, STRINGBUF_TAG | STRINGBUF_F_WIDE); + SCM_SET_CELL_WORD_1 (buf, (scm_t_bits) len); + + STRINGBUF_WIDE_CHARS (buf)[len] = 0; + + return buf; +} + +/* Return a UCS-4-encoded stringbuf containing the (possibly Latin-1-encoded) + characters from BUF. */ +static SCM +wide_stringbuf (SCM buf) +{ + SCM new_buf; + + if (STRINGBUF_WIDE (buf)) + new_buf = buf; else { - char *mem = scm_gc_malloc_pointerless (len + 1, "string"); - mem[len] = '\0'; - return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) mem, - (scm_t_bits) len, (scm_t_bits) 0); + size_t i, len; + scm_t_wchar *mem; + + len = STRINGBUF_LENGTH (buf); + + new_buf = make_wide_stringbuf (len); + + mem = STRINGBUF_WIDE_CHARS (new_buf); + for (i = 0; i < len; i++) + mem[i] = (scm_t_wchar) STRINGBUF_CHARS (buf)[i]; + mem[len] = 0; } + + return new_buf; } -/* Return a new stringbuf whose underlying storage consists of the LEN+1 - octets pointed to by STR (the last octet is zero). */ -SCM -scm_i_take_stringbufn (char *str, size_t len) +/* Return a Latin-1-encoded stringbuf containing the (possibly UCS-4-encoded) + characters from BUF, if possible. */ +static SCM +narrow_stringbuf (SCM buf) { - scm_gc_register_collectable_memory (str, len + 1, "stringbuf"); + SCM new_buf; - return scm_double_cell (STRINGBUF_TAG, (scm_t_bits) str, - (scm_t_bits) len, (scm_t_bits) 0); -} + if (!STRINGBUF_WIDE (buf)) + new_buf = buf; + else + { + size_t i, len; + scm_t_wchar *wmem; + unsigned char *mem; + + len = STRINGBUF_LENGTH (buf); + wmem = STRINGBUF_WIDE_CHARS (buf); + + for (i = 0; i < len; i++) + if (wmem[i] > 0xFF) + /* BUF cannot be narrowed. */ + return buf; + + new_buf = make_stringbuf (len); + mem = STRINGBUF_CHARS (new_buf); + for (i = 0; i < len; i++) + mem[i] = (unsigned char) wmem[i]; + mem[len] = 0; + } + + return new_buf; +} scm_i_pthread_mutex_t stringbuf_write_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER; + /* Copy-on-write strings. */ @@ -175,18 +253,36 @@ 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) { SCM buf = make_stringbuf (len); SCM res; if (charsp) - *charsp = STRINGBUF_CHARS (buf); + *charsp = (char *) STRINGBUF_CHARS (buf); res = scm_double_cell (STRING_TAG, SCM_UNPACK(buf), (scm_t_bits)0, (scm_t_bits) len); 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) { @@ -245,12 +341,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 @@ -303,23 +411,73 @@ 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)); +} + +/* Try to coerce a string to be narrow. It if is narrow already, do + nothing. If it is wide, shrink it to narrow if none of its + characters are above 0xFF. Return true if the string is narrow or + was made to be narrow. */ +int +scm_i_try_narrow_string (SCM str) +{ + SET_STRING_STRINGBUF (str, narrow_stringbuf (STRING_STRINGBUF (str))); + + return scm_i_is_narrow_string (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 (const char *) 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 (const scm_t_wchar *) 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; @@ -331,17 +489,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 @@ -357,18 +526,134 @@ scm_i_string_writable_chars (SCM orig_str) scm_i_pthread_mutex_lock (&stringbuf_write_mutex); } + return orig_str; +} + +/* 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 (char *) 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 STRINGBUF_CHARS (buf) + start; +/* 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 write 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]; +} + +/* Returns index+1 of the first char in STR that matches C, or + 0 if the char is not found. */ +int +scm_i_string_contains_char (SCM str, char ch) +{ + size_t i; + size_t len = scm_i_string_length (str); + + i = 0; + if (scm_i_is_narrow_string (str)) + { + while (i < len) + { + if (scm_i_string_chars (str)[i] == ch) + return i+1; + i++; + } + } + else + { + while (i < len) + { + if (scm_i_string_wide_chars (str)[i] + == (unsigned char) ch) + return i+1; + i++; + } + } + return 0; +} + +int +scm_i_string_strcmp (SCM sstr, size_t start_x, const char *cstr) +{ + if (scm_i_is_narrow_string (sstr)) + { + const char *a = scm_i_string_chars (sstr) + start_x; + const char *b = cstr; + return strncmp (a, b, strlen(b)); + } + else + { + size_t i; + const scm_t_wchar *a = scm_i_string_wide_chars (sstr) + start_x; + const char *b = cstr; + for (i = 0; i < strlen (b); i++) + { + if (a[i] != (unsigned char) b[i]) + return 1; + } + } + return 0; +} + +/* 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)) + SET_STRING_STRINGBUF (str, wide_stringbuf (STRING_STRINGBUF (str))); + + if (scm_i_is_narrow_string (str)) + { + char *dst = scm_i_string_writable_chars (str); + dst[p] = 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 symbols.[hc]. This has been done to keep stringbufs and the internals of strings and string-like objects confined to this file. @@ -401,10 +686,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)); @@ -421,18 +717,8 @@ scm_i_c_make_symbol (const char *name, size_t len, (scm_t_bits) hash, SCM_UNPACK (props)); } -/* Return a new symbol that uses the LEN bytes pointed to by NAME as its - underlying storage. */ -SCM -scm_i_c_take_symbol (char *name, size_t len, - scm_t_bits flags, unsigned long hash, SCM props) -{ - SCM buf = scm_i_take_stringbufn (name, len); - - return scm_double_cell (scm_tc7_symbol | flags, SCM_UNPACK (buf), - (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) { @@ -449,11 +735,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 (const char *) 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 (const scm_t_wchar *) STRINGBUF_WIDE_CHARS (buf); + else + scm_misc_error (NULL, "Invalid access of chars of a narrow symbol ~S", + scm_list_1 (sym)); } SCM @@ -467,64 +787,194 @@ 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-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; + 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_WIDE (buf)) + e9 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"), + SCM_BOOL_T); + else + e9 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"), + SCM_BOOL_F); + + return scm_list_n (e1, e2, e3, e4, e5, e6, e7, e8, e9, 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-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; + 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_WIDE (buf)) + e7 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"), + SCM_BOOL_T); + else + e7 = scm_cons (scm_from_locale_symbol ("stringbuf-wide"), + SCM_BOOL_F); + return scm_list_n (e1, e2, e3, e4, e5, e6, e7, 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; @@ -559,30 +1009,70 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1, "@var{chrs}.") #define FUNC_NAME s_scm_string { - SCM result; + SCM result = SCM_BOOL_F; + SCM rest; size_t len; - char *data; + size_t p = 0; + long i; + int wide = 0; - { - 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); + if (SCM_CHAR (elt) > 0xFF) + wide = 1; + 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; + + if (wide == 0) + { + result = scm_i_make_string (len, NULL); + result = scm_i_string_start_writing (result); + char *buf = scm_i_string_writable_chars (result); + while (len > 0 && scm_is_pair (rest)) + { + SCM elt = SCM_CAR (rest); + buf[p] = (unsigned char) SCM_CHAR (elt); + p++; + rest = SCM_CDR (rest); + len--; + scm_remember_upto_here_1 (elt); + } + } + else + { + result = scm_i_make_wide_string (len, NULL); + result = scm_i_string_start_writing (result); + scm_t_wchar *buf = scm_i_string_writable_wide_chars (result); + while (len > 0 && scm_is_pair (rest)) + { + SCM elt = SCM_CAR (rest); + buf[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; @@ -605,13 +1095,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; @@ -628,6 +1121,20 @@ SCM_DEFINE (scm_string_length, "string-length", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_string_bytes_per_char, "string-bytes-per-char", 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_bytes_per_char +{ + 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) { @@ -638,8 +1145,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; @@ -653,7 +1160,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 @@ -662,14 +1172,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; @@ -684,11 +1198,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 @@ -698,11 +1211,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, @@ -803,31 +1314,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; @@ -840,45 +1379,137 @@ scm_is_string (SCM obj) return IS_STRING (obj); } +static SCM +scm_from_stringn (const char *str, size_t len, const char *encoding, + scm_t_string_failed_conversion_handler handler) +{ + size_t u32len, i; + scm_t_wchar *u32; + int wide = 0; + SCM res; + + if (encoding == NULL) + { + /* If encoding is null, use Latin-1. */ + char *buf; + res = scm_i_make_string (len, &buf); + memcpy (buf, str, len); + return res; + } + + u32len = 0; + u32 = (scm_t_wchar *) u32_conv_from_encoding (encoding, + (enum iconv_ilseq_handler) + handler, + str, len, + NULL, + NULL, &u32len); + + if (u32 == NULL) + { + if (errno == ENOMEM) + scm_memory_error ("locale string conversion"); + else + { + /* There are invalid sequences in the input string. */ + SCM errstr; + char *dst; + errstr = scm_i_make_string (len, &dst); + memcpy (dst, str, len); + scm_misc_error (NULL, "input locale conversion error from ~s: ~s", + scm_list_2 (scm_from_locale_string (encoding), + errstr)); + scm_remember_upto_here_1 (errstr); + } + } + + i = 0; + while (i < u32len) + if (u32[i++] > 0xFF) + { + wide = 1; + break; + } + + if (!wide) + { + char *dst; + res = scm_i_make_string (u32len, &dst); + for (i = 0; i < u32len; i ++) + dst[i] = (unsigned char) u32[i]; + dst[u32len] = '\0'; + } + else + { + scm_t_wchar *wdst; + res = scm_i_make_wide_string (u32len, &wdst); + u32_cpy ((scm_t_uint32 *) wdst, (scm_t_uint32 *) u32, u32len); + wdst[u32len] = 0; + } + + free (u32); + return res; +} + SCM scm_from_locale_stringn (const char *str, size_t len) { - SCM res; - char *dst; + const char *enc; + scm_t_string_failed_conversion_handler hndl; + SCM inport; + scm_t_port *pt; - if (len == (size_t)-1) + if (len == (size_t) -1) len = strlen (str); - res = scm_i_make_string (len, &dst); - memcpy (dst, str, len); - return res; + if (len == 0) + return scm_nullstr; + + inport = scm_current_input_port (); + if (!SCM_UNBNDP (inport) && SCM_OPINPORTP (inport)) + { + pt = SCM_PTAB_ENTRY (inport); + enc = pt->encoding; + hndl = pt->ilseq_handler; + } + else + { + enc = NULL; + hndl = SCM_FAILED_CONVERSION_ERROR; + } + + return scm_from_stringn (str, len, enc, hndl); } SCM scm_from_locale_string (const char *str) { + if (str == NULL) + return scm_nullstr; + return scm_from_locale_stringn (str, -1); } SCM +scm_i_from_utf8_string (const scm_t_uint8 *str) +{ + return scm_from_stringn ((const char *) str, + strlen ((char *) str), "UTF-8", + SCM_FAILED_CONVERSION_ERROR); +} + +/* Create a new scheme string from the C string STR. The memory of + STR may be used directly as storage for the new string. */ +/* FIXME: GC-wise, the only way to use the memory area pointed to by STR + would be to register a finalizer to eventually free(3) STR, which isn't + worth it. Should we just deprecate the `scm_take_' functions? */ +SCM scm_take_locale_stringn (char *str, size_t len) { - SCM buf, res; + SCM res; - 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[len] = '\0'; - } + res = scm_from_locale_stringn (str, len); + free (str); - buf = scm_i_take_stringbufn (str, len); - res = scm_double_cell (STRING_TAG, - SCM_UNPACK (buf), - (scm_t_bits) 0, (scm_t_bits) len); return res; } @@ -888,33 +1519,180 @@ 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; + SCM outport; + scm_t_port *pt; + const char *enc; + + outport = scm_current_output_port (); + if (!SCM_UNBNDP (outport) && SCM_OPOUTPORTP (outport)) + { + pt = SCM_PTAB_ENTRY (outport); + enc = pt->encoding; + } + else + enc = NULL; + + return scm_to_stringn (str, lenp, + enc, + scm_i_get_conversion_strategy (SCM_BOOL_F)); +} + +/* 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) +{ + char *buf; + size_t ilen, len, i; + int ret; + const char *enc; 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) && (encoding == NULL)) { - res[len] = '\0'; - if (strlen (res) != len) - { - free (res); - scm_misc_error (NULL, - "string contains #\\nul character: ~S", - scm_list_1 (str)); - } + /* If using native Latin-1 encoding, just copy the string + contents. */ + 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; + } + } + + + buf = NULL; + len = 0; + enc = encoding; + if (enc == NULL) + enc = "ISO-8859-1"; + if (scm_i_is_narrow_string (str)) + { + ret = mem_iconveh (scm_i_string_chars (str), ilen, + "ISO-8859-1", enc, + (enum iconv_ilseq_handler) handler, NULL, + &buf, &len); + + if (ret == 0 && handler == SCM_FAILED_CONVERSION_ESCAPE_SEQUENCE) + unistring_escapes_to_guile_escapes (&buf, &len); + + if (ret != 0) + { + scm_misc_error (NULL, "cannot convert to output locale ~s: \"~s\"", + scm_list_2 (scm_from_locale_string (enc), + str)); + } } else + { + buf = u32_conv_to_encoding (enc, + (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 (enc), + str)); + } + } + 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 * @@ -923,22 +1701,33 @@ scm_to_locale_string (SCM str) return scm_to_locale_stringn (str, NULL); } +scm_t_uint8 * +scm_i_to_utf8_string (SCM str) +{ + char *u8str; + u8str = scm_to_stringn (str, NULL, "UTF-8", SCM_FAILED_CONVERSION_ERROR); + return (scm_t_uint8 *) u8str; +} + 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; @@ -1039,7 +1828,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. */ @@ -1050,6 +1839,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; @@ -1065,6 +1855,36 @@ scm_i_deprecated_string_length (SCM str) #endif +static SCM +string_handle_ref (scm_t_array_handle *h, size_t index) +{ + return scm_c_string_ref (h->array, index); +} + +static void +string_handle_set (scm_t_array_handle *h, size_t index, SCM val) +{ + scm_c_string_set_x (h->array, index, val); +} + +static void +string_get_handle (SCM v, scm_t_array_handle *h) +{ + h->array = v; + h->ndims = 1; + h->dims = &h->dim0; + h->dim0.lbnd = 0; + h->dim0.ubnd = scm_c_string_length (v) - 1; + h->dim0.inc = 1; + h->element_type = SCM_ARRAY_ELEMENT_TYPE_CHAR; + h->elements = h->writable_elements = NULL; +} + +SCM_ARRAY_IMPLEMENTATION (scm_tc7_string, 0x7f & ~2, + string_handle_ref, string_handle_set, + string_get_handle); +SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR, scm_make_string); + void scm_init_strings () { diff --git a/libguile/strings.h b/libguile/strings.h index 2dabde1d6..910d51ee6 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -6,18 +6,19 @@ /* 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_bytes_per_char (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); @@ -101,10 +124,16 @@ SCM_API SCM scm_c_substring_copy (SCM str, size_t start, size_t end); SCM_API int scm_is_string (SCM x); SCM_API SCM scm_from_locale_string (const char *str); SCM_API SCM scm_from_locale_stringn (const char *str, size_t len); +SCM_INTERNAL SCM scm_i_from_utf8_string (const scm_t_uint8 *str); 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_INTERNAL scm_t_uint8 *scm_i_to_utf8_string (SCM str); 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); @@ -115,14 +144,15 @@ SCM_API SCM scm_makfromstrs (int argc, char **argv); /* Type tag for read-only strings. */ #define scm_tc7_ro_string (scm_tc7_string + 0x200) -/* Flags for shared and inline strings. */ +/* Flags for shared and wide strings. */ #define SCM_I_STRINGBUF_F_SHARED 0x100 -#define SCM_I_STRINGBUF_F_INLINE 0x200 +#define SCM_I_STRINGBUF_F_WIDE 0x400 /* 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); @@ -130,8 +160,14 @@ 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 int scm_i_string_contains_char (SCM str, char c); +SCM_INTERNAL int scm_i_string_strcmp (SCM sstr, size_t start_x, const char *cstr); +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, @@ -139,12 +175,13 @@ SCM_INTERNAL SCM scm_i_make_symbol (SCM name, scm_t_bits flags, SCM_INTERNAL SCM scm_i_c_make_symbol (const char *name, size_t len, scm_t_bits flags, unsigned long hash, SCM props); -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 int scm_i_try_narrow_string (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. */ @@ -152,7 +189,14 @@ SCM_INTERNAL char **scm_i_allocate_string_pointers (SCM list); SCM_INTERNAL void scm_i_get_substring_spec (size_t len, SCM start, size_t *cstart, 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 */ 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..490a15f8b 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 */ @@ -29,7 +30,7 @@ #include <unistd.h> #endif -#include "libguile/unif.h" +#include "libguile/arrays.h" #include "libguile/eval.h" #include "libguile/ports.h" #include "libguile/read.h" @@ -38,6 +39,7 @@ #include "libguile/modules.h" #include "libguile/validate.h" #include "libguile/deprecation.h" +#include "libguile/srfi-4.h" #include "libguile/strports.h" @@ -107,7 +109,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 +119,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 +200,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 +273,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); @@ -288,42 +290,33 @@ st_truncate (SCM port, off_t length) } SCM -scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) +scm_i_mkstrport (SCM pos, const char *locale_str, size_t str_len, long modes, const char *caller) { - SCM z; + SCM z, str; scm_t_port *pt; - size_t str_len, c_pos; - - SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller); + size_t c_pos; + char *buf; + + /* Because ports are inherently 8-bit, strings need to be converted + to a locale representation for storage. But, since string ports + rely on string functionality for their memory management, we need + to create a new string that has the 8-bit locale representation + of the underlying string. This violates the guideline that the + internal encoding of characters in strings is in unicode + codepoints. */ + str = scm_i_make_string (str_len, &buf); + memcpy (buf, locale_str, str_len); - str_len = scm_i_string_length (str); c_pos = scm_to_unsigned_integer (pos, 0, str_len); if (!((modes & SCM_WRTNG) || (modes & SCM_RDNG))) scm_misc_error ("scm_mkstrport", "port must read or write", SCM_EOL); - /* XXX - - Make a new string to isolate us from changes to the original. - This is done so that we can rely on scm_i_string_chars to stay in - place even across SCM_TICKs. - - Additionally, when we are going to write to the string, we make a - copy so that we can write to it without having to use - scm_i_string_writable_chars. - */ - - if (modes & SCM_WRTNG) - str = scm_c_substring_copy (str, 0, str_len); - else - str = scm_c_substring (str, 0, str_len); - scm_i_scm_pthread_mutex_lock (&scm_i_port_table_mutex); z = scm_new_port_table_entry (scm_tc16_strport); pt = SCM_PTAB_ENTRY(z); SCM_SETSTREAM (z, SCM_UNPACK (str)); SCM_SET_CELL_TYPE(z, scm_tc16_strport|modes); - /* see above why we can use scm_i_string_chars here. */ pt->write_buf = pt->read_buf = (unsigned char *) scm_i_string_chars (str); pt->read_pos = pt->write_pos = pt->read_buf + c_pos; pt->write_buf_size = pt->read_buf_size = str_len; @@ -339,22 +332,60 @@ scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) return z; } +SCM +scm_mkstrport (SCM pos, SCM str, long modes, const char *caller) +{ + SCM z; + size_t str_len; + char *buf; + + SCM_ASSERT (scm_is_string (str), str, SCM_ARG1, caller); + + /* Because ports are inherently 8-bit, strings need to be converted + to a locale representation for storage. But, since string ports + rely on string functionality for their memory management, we need + to create a new string that has the 8-bit locale representation + of the underlying string. This violates the guideline that the + internal encoding of characters in strings is in unicode + codepoints. */ + buf = scm_to_locale_stringn (str, &str_len); + z = scm_i_mkstrport (pos, buf, str_len, modes, caller); + free (buf); + return z; +} + /* create a new string from a string port's buffer. */ SCM scm_strport_to_string (SCM port) { scm_t_port *pt = SCM_PTAB_ENTRY (port); SCM str; - char *dst; if (pt->rw_active == SCM_PORT_WRITE) st_flush (port); - str = scm_i_make_string (pt->read_buf_size, &dst); - memcpy (dst, (char *) pt->read_buf, pt->read_buf_size); + str = scm_from_locale_stringn ((char *)pt->read_buf, pt->read_buf_size); scm_remember_upto_here_1 (port); return str; } +/* Create a vector containing the locale representation of the string in the + port's buffer. */ +SCM scm_strport_to_locale_u8vector (SCM port) +{ + scm_t_port *pt = SCM_PTAB_ENTRY (port); + SCM vec; + char *buf; + + if (pt->rw_active == SCM_PORT_WRITE) + st_flush (port); + + buf = scm_malloc (pt->read_buf_size); + memcpy (buf, pt->read_buf, pt->read_buf_size); + vec = scm_take_u8vector ((unsigned char *) buf, pt->read_buf_size); + scm_remember_upto_here_1 (port); + return vec; +} + SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0, (SCM obj, SCM printer), "Return a Scheme string obtained by printing @var{obj}.\n" @@ -379,6 +410,25 @@ SCM_DEFINE (scm_object_to_string, "object->string", 1, 1, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_call_with_output_locale_u8vector, "call-with-output-locale-u8vector", 1, 0, 0, + (SCM proc), + "Calls the one-argument procedure @var{proc} with a newly created output\n" + "port. When the function returns, a vector containing the bytes of a\n" + "locale representation of the characters written into the port is returned\n") +#define FUNC_NAME s_scm_call_with_output_locale_u8vector +{ + SCM p; + + p = scm_mkstrport (SCM_INUM0, + scm_make_string (SCM_INUM0, SCM_UNDEFINED), + SCM_OPN | SCM_WRTNG, + FUNC_NAME); + scm_call_1 (proc, p); + + return scm_get_output_locale_u8vector (p); +} +#undef FUNC_NAME + SCM_DEFINE (scm_call_with_output_string, "call-with-output-string", 1, 0, 0, (SCM proc), "Calls the one-argument procedure @var{proc} with a newly created output\n" @@ -423,6 +473,27 @@ SCM_DEFINE (scm_open_input_string, "open-input-string", 1, 0, 0, } #undef FUNC_NAME +SCM_DEFINE (scm_open_input_locale_u8vector, "open-input-locale-u8vector", 1, 0, 0, + (SCM vec), + "Take a u8vector containing the bytes of a string encoded in the\n" + "current locale and return an input port that delivers characters\n" + "from the string. The port can be closed by\n" + "@code{close-input-port}, though its storage will be reclaimed\n" + "by the garbage collector if it becomes inaccessible.") +#define FUNC_NAME s_scm_open_input_locale_u8vector +{ + scm_t_array_handle hnd; + ssize_t inc; + size_t len; + const scm_t_uint8 *buf; + + buf = scm_u8vector_elements (vec, &hnd, &len, &inc); + SCM p = scm_i_mkstrport(SCM_INUM0, (const char *) buf, len, SCM_OPN | SCM_RDNG, FUNC_NAME); + scm_array_handle_release (&hnd); + return p; +} +#undef FUNC_NAME + SCM_DEFINE (scm_open_output_string, "open-output-string", 0, 0, 0, (void), "Return an output port that will accumulate characters for\n" @@ -455,11 +526,26 @@ SCM_DEFINE (scm_get_output_string, "get-output-string", 1, 0, 0, #undef FUNC_NAME +SCM_DEFINE (scm_get_output_locale_u8vector, "get-output-locale-u8vector", 1, 0, 0, + (SCM port), + "Given an output port created by @code{open-output-string},\n" + "return a u8 vector containing the characters of the string\n" + "encoded in the current locale.") +#define FUNC_NAME s_scm_get_output_locale_u8vector +{ + SCM_VALIDATE_OPOUTSTRPORT (1, port); + return scm_strport_to_locale_u8vector (port); +} +#undef FUNC_NAME + + /* Given a null-terminated string EXPR containing a Scheme expression read it, and return it as an SCM value. */ SCM scm_c_read_string (const char *expr) { + /* FIXME: the c string gets packed into a string, only to get + immediately unpacked in scm_mkstrport. */ SCM port = scm_mkstrport (SCM_INUM0, scm_from_locale_string (expr), SCM_OPN | SCM_RDNG, diff --git a/libguile/strports.h b/libguile/strports.h index 58ca71f57..b2ded01f1 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 */ @@ -43,13 +44,19 @@ SCM_API scm_t_bits scm_tc16_strport; SCM_API SCM scm_mkstrport (SCM pos, SCM str, long modes, const char * caller); +SCM_INTERNAL SCM scm_i_mkstrport (SCM pos, const char *locale_str, size_t str_len, + long modes, const char *caller); SCM_API SCM scm_strport_to_string (SCM port); +SCM_API SCM scm_strport_to_locale_u8vector (SCM port); SCM_API SCM scm_object_to_string (SCM obj, SCM printer); SCM_API SCM scm_call_with_output_string (SCM proc); +SCM_API SCM scm_call_with_output_locale_u8vector (SCM proc); SCM_API SCM scm_call_with_input_string (SCM str, SCM proc); SCM_API SCM scm_open_input_string (SCM str); +SCM_API SCM scm_open_input_locale_u8vector (SCM str); SCM_API SCM scm_open_output_string (void); SCM_API SCM scm_get_output_string (SCM port); +SCM_API SCM scm_get_output_locale_u8vector (SCM port); SCM_API SCM scm_c_read_string (const char *expr); SCM_API SCM scm_c_eval_string (const char *expr); SCM_API SCM scm_c_eval_string_in_module (const char *expr, SCM module); diff --git a/libguile/struct.c b/libguile/struct.c index b536bea3b..b7e72a719 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. +/* Copyright (C) 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 */ @@ -29,6 +30,7 @@ #include "libguile/hashtab.h" #include "libguile/ports.h" #include "libguile/strings.h" +#include "libguile/srfi-13.h" #include "libguile/validate.h" #include "libguile/struct.h" @@ -62,9 +64,9 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, { SCM new_sym; SCM_VALIDATE_STRING (1, fields); + scm_t_wchar c; { /* scope */ - const char * field_desc; size_t len; int x; @@ -73,11 +75,9 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, SCM_MISC_ERROR ("odd length field specification: ~S", scm_list_1 (fields)); - field_desc = scm_i_string_chars (fields); - for (x = 0; x < len; x += 2) { - switch (field_desc[x]) + switch (c = scm_i_string_ref (fields, x)) { case 'u': case 'p': @@ -89,13 +89,13 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, break; default: SCM_MISC_ERROR ("unrecognized field type: ~S", - scm_list_1 (SCM_MAKE_CHAR (field_desc[x]))); + scm_list_1 (SCM_MAKE_CHAR (c))); } - switch (field_desc[x + 1]) + switch (c = scm_i_string_ref (fields, x + 1)) { case 'w': - if (field_desc[x] == 's') + if (scm_i_string_ref (fields, x) == 's') SCM_MISC_ERROR ("self fields not writable", SCM_EOL); case 'r': case 'o': @@ -103,7 +103,7 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, case 'R': case 'W': case 'O': - if (field_desc[x] == 's') + if (scm_i_string_ref (fields, x) == 's') SCM_MISC_ERROR ("self fields not allowed in tail array", SCM_EOL); if (x != len - 2) @@ -112,12 +112,12 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, break; default: SCM_MISC_ERROR ("unrecognized ref specification: ~S", - scm_list_1 (SCM_MAKE_CHAR (field_desc[x + 1]))); + scm_list_1 (SCM_MAKE_CHAR (c))); } #if 0 - if (field_desc[x] == 'd') + if (scm_i_string_ref (fields, x, 'd')) { - if (field_desc[x + 2] != '-') + if (!scm_i_string_ref (fields, x+2, '-')) SCM_MISC_ERROR ("missing dash field at position ~A", scm_list_1 (scm_from_int (x / 2))); x += 2; @@ -139,18 +139,18 @@ SCM_DEFINE (scm_make_struct_layout, "make-struct-layout", 1, 0, 0, static void scm_struct_init (SCM handle, SCM layout, scm_t_bits * mem, int tail_elts, SCM inits) { - unsigned const char *fields_desc = - (unsigned const char *) scm_i_symbol_chars (layout) - 2; - unsigned char prot = 0; + scm_t_wchar prot = 0; int n_fields = scm_i_symbol_length (layout) / 2; int tailp = 0; + int i; + i = -2; while (n_fields) { if (!tailp) { - fields_desc += 2; - prot = fields_desc[1]; + i += 2; + prot = scm_i_symbol_ref (layout, i+1); if (SCM_LAYOUT_TAILP (prot)) { tailp = 1; @@ -161,8 +161,7 @@ scm_struct_init (SCM handle, SCM layout, scm_t_bits * mem, int tail_elts, SCM in break; } } - - switch (*fields_desc) + switch (scm_i_symbol_ref (layout, i)) { #if 0 case 'i': @@ -238,7 +237,8 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, { SCM layout; scm_t_bits * mem; - int tmp; + SCM tmp; + size_t len; if (!SCM_STRUCTP (x)) return SCM_BOOL_F; @@ -249,11 +249,14 @@ SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0, < scm_i_string_length (required_vtable_fields)) return SCM_BOOL_F; - tmp = strncmp (scm_i_symbol_chars (layout), - scm_i_string_chars (required_vtable_fields), - scm_i_string_length (required_vtable_fields)); - scm_remember_upto_here_1 (required_vtable_fields); - if (tmp) + len = scm_i_string_length (required_vtable_fields); + tmp = scm_string_eq (scm_symbol_to_string (layout), + required_vtable_fields, + scm_from_size_t (0), + scm_from_size_t (len), + scm_from_size_t (0), + scm_from_size_t (len)); + if (scm_is_false (tmp)) return SCM_BOOL_F; mem = SCM_STRUCT_DATA (x); @@ -337,7 +340,7 @@ struct_finalizer_trampoline (GC_PTR ptr, GC_PTR unused_data) scm_t_struct_free free_struct_data = ((scm_t_struct_free) vtable_data[scm_struct_i_free]); - SCM_SET_CELL_TYPE (obj, scm_tc_free_cell); + SCM_SET_CELL_TYPE (obj, scm_tc3_struct); #if 0 /* A sanity check. However, this check can fail if the free function @@ -620,8 +623,7 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, size_t layout_len; size_t p; scm_t_bits n_fields; - const char *fields_desc; - char field_type = 0; + scm_t_wchar field_type = 0; SCM_VALIDATE_STRUCT (1, handle); @@ -630,7 +632,6 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, data = SCM_STRUCT_DATA (handle); p = scm_to_size_t (pos); - fields_desc = scm_i_symbol_chars (layout); layout_len = scm_i_symbol_length (layout); if (SCM_STRUCT_VTABLE_FLAGS (handle) & SCM_STRUCTF_LIGHT) /* no extra words */ @@ -642,9 +643,9 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, if (p * 2 < layout_len) { - char ref; - field_type = fields_desc[p * 2]; - ref = fields_desc[p * 2 + 1]; + scm_t_wchar ref; + field_type = scm_i_symbol_ref (layout, p * 2); + ref = scm_i_symbol_ref (layout, p * 2 + 1); if ((ref != 'r') && (ref != 'w')) { if ((ref == 'R') || (ref == 'W')) @@ -653,8 +654,8 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos)); } } - else if (fields_desc[layout_len - 1] != 'O') - field_type = fields_desc[layout_len - 2]; + else if (scm_i_symbol_ref (layout, layout_len - 1) != 'O') + field_type = scm_i_symbol_ref(layout, layout_len - 2); else SCM_MISC_ERROR ("ref denied for field ~A", scm_list_1 (pos)); @@ -702,8 +703,7 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, size_t layout_len; size_t p; int n_fields; - const char *fields_desc; - char field_type = 0; + scm_t_wchar field_type = 0; SCM_VALIDATE_STRUCT (1, handle); @@ -711,7 +711,6 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, data = SCM_STRUCT_DATA (handle); p = scm_to_size_t (pos); - fields_desc = scm_i_symbol_chars (layout); layout_len = scm_i_symbol_length (layout); if (SCM_STRUCT_VTABLE_FLAGS (handle) & SCM_STRUCTF_LIGHT) /* no extra words */ @@ -724,13 +723,13 @@ SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0, if (p * 2 < layout_len) { char set_x; - field_type = fields_desc[p * 2]; - set_x = fields_desc [p * 2 + 1]; + field_type = scm_i_symbol_ref (layout, p * 2); + set_x = scm_i_symbol_ref (layout, p * 2 + 1); if (set_x != 'w') SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos)); } - else if (fields_desc[layout_len - 1] == 'W') - field_type = fields_desc[layout_len - 2]; + else if (scm_i_symbol_ref (layout, layout_len - 1) == 'W') + field_type = scm_i_symbol_ref (layout, layout_len - 2); else SCM_MISC_ERROR ("set! denied for field ~A", scm_list_1 (pos)); 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 0814942d4..c77749f11 100644 --- a/libguile/symbols.c +++ b/libguile/symbols.c @@ -1,18 +1,19 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2003, 2004, 2006 Free Software Foundation, Inc. +/* 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 */ @@ -88,15 +89,17 @@ scm_i_hash_symbol (SCM obj, unsigned long n, void *closure) } static SCM -lookup_interned_symbol (const char *name, size_t len, - unsigned long raw_hash) +lookup_interned_symbol (SCM name, unsigned long raw_hash) { /* Try to find the symbol in the symbols table */ SCM result = SCM_BOOL_F; SCM bucket, elt, previous_elt; + size_t len; unsigned long hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols); + len = scm_i_string_length (name); bucket = SCM_HASHTABLE_BUCKET (symbols, hash); + for (elt = bucket, previous_elt = SCM_BOOL_F; !scm_is_null (elt); previous_elt = elt, elt = SCM_CDR (elt)) @@ -129,15 +132,32 @@ lookup_interned_symbol (const char *name, size_t len, if (scm_i_symbol_hash (sym) == raw_hash && scm_i_symbol_length (sym) == len) { - const char *chrs = scm_i_symbol_chars (sym); - size_t i = len; - - while (i != 0) - { - --i; - if (name[i] != chrs[i]) - goto next_symbol; - } + size_t i = len; + + /* Slightly faster path for comparing narrow to narrow. */ + if (scm_i_is_narrow_string (name) && scm_i_is_narrow_symbol (sym)) + { + const char *chrs = scm_i_symbol_chars (sym); + const char *str = scm_i_string_chars (name); + + while (i != 0) + { + --i; + if (str[i] != chrs[i]) + goto next_symbol; + } + } + else + { + /* Somewhat slower path for comparing narrow to wide or + wide to wide. */ + while (i != 0) + { + --i; + if (scm_i_string_ref (name, i) != scm_i_symbol_ref (sym, i)) + goto next_symbol; + } + } /* We found it. */ result = sym; @@ -154,69 +174,47 @@ lookup_interned_symbol (const char *name, size_t len, return result; } -static SCM -scm_i_c_mem2symbol (const char *name, size_t len) +/* Intern SYMBOL, an uninterned symbol. */ +static void +intern_symbol (SCM symbol) { - SCM symbol; - size_t raw_hash = scm_string_hash ((const unsigned char *) name, len); - size_t hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols); - - symbol = lookup_interned_symbol (name, len, raw_hash); - if (symbol != SCM_BOOL_F) - return symbol; - - { - /* The symbol was not found - create it. */ - SCM symbol = scm_i_c_make_symbol (name, len, 0, raw_hash, - scm_cons (SCM_BOOL_F, SCM_EOL)); - - SCM slot = SCM_HASHTABLE_BUCKET (symbols, hash); - SCM cell = scm_weak_car_pair (symbol, SCM_UNDEFINED); - SCM_SET_HASHTABLE_BUCKET (symbols, hash, scm_cons (cell, slot)); - SCM_HASHTABLE_INCREMENT (symbols); - if (SCM_HASHTABLE_N_ITEMS (symbols) > SCM_HASHTABLE_UPPER (symbols)) - scm_i_rehash (symbols, scm_i_hash_symbol, 0, "scm_mem2symbol"); - - return symbol; - } + SCM slot, cell; + unsigned long hash; + + hash = scm_i_symbol_hash (symbol) % SCM_HASHTABLE_N_BUCKETS (symbols); + slot = SCM_HASHTABLE_BUCKET (symbols, hash); + cell = scm_cons (symbol, SCM_UNDEFINED); + + SCM_SET_HASHTABLE_BUCKET (symbols, hash, scm_cons (cell, slot)); + SCM_HASHTABLE_INCREMENT (symbols); + + if (SCM_HASHTABLE_N_ITEMS (symbols) > SCM_HASHTABLE_UPPER (symbols)) + scm_i_rehash (symbols, scm_i_hash_symbol, 0, "intern_symbol"); } static SCM -scm_i_mem2symbol (SCM str) +scm_i_str2symbol (SCM str) { SCM symbol; - const char *name = scm_i_string_chars (str); - size_t len = scm_i_string_length (str); - size_t raw_hash = scm_string_hash ((const unsigned char *) name, len); - size_t hash = raw_hash % SCM_HASHTABLE_N_BUCKETS (symbols); - - symbol = lookup_interned_symbol (name, len, raw_hash); - if (symbol != SCM_BOOL_F) - return symbol; - - { - /* The symbol was not found - create it. */ - SCM symbol = scm_i_make_symbol (str, 0, raw_hash, - scm_cons (SCM_BOOL_F, SCM_EOL)); - - SCM slot = SCM_HASHTABLE_BUCKET (symbols, hash); - SCM cell = scm_weak_car_pair (symbol, SCM_UNDEFINED); - SCM_SET_HASHTABLE_BUCKET (symbols, hash, scm_cons (cell, slot)); - SCM_HASHTABLE_INCREMENT (symbols); - if (SCM_HASHTABLE_N_ITEMS (symbols) > SCM_HASHTABLE_UPPER (symbols)) - scm_i_rehash (symbols, scm_i_hash_symbol, 0, "scm_mem2symbol"); - - return symbol; - } + size_t raw_hash = scm_i_string_hash (str); + + symbol = lookup_interned_symbol (str, raw_hash); + if (scm_is_false (symbol)) + { + /* The symbol was not found, create it. */ + symbol = scm_i_make_symbol (str, 0, raw_hash, + scm_cons (SCM_BOOL_F, SCM_EOL)); + intern_symbol (symbol); + } + + return symbol; } static SCM -scm_i_mem2uninterned_symbol (SCM str) +scm_i_str2uninterned_symbol (SCM str) { - const char *name = scm_i_string_chars (str); - size_t len = scm_i_string_length (str); - size_t raw_hash = scm_string_hash ((const unsigned char *) name, len); + size_t raw_hash = scm_i_string_hash (str); return scm_i_make_symbol (str, SCM_I_F_SYMBOL_UNINTERNED, raw_hash, scm_cons (SCM_BOOL_F, SCM_EOL)); @@ -251,7 +249,7 @@ SCM_DEFINE (scm_make_symbol, "make-symbol", 1, 0, 0, #define FUNC_NAME s_scm_make_symbol { SCM_VALIDATE_STRING (1, name); - return scm_i_mem2uninterned_symbol (name); + return scm_i_str2uninterned_symbol (name); } #undef FUNC_NAME @@ -313,7 +311,7 @@ SCM_DEFINE (scm_string_to_symbol, "string->symbol", 1, 0, 0, #define FUNC_NAME s_scm_string_to_symbol { SCM_VALIDATE_STRING (1, string); - return scm_i_mem2symbol (string); + return scm_i_str2symbol (string); } #undef FUNC_NAME @@ -420,44 +418,23 @@ SCM_DEFINE (scm_symbol_pset_x, "symbol-pset!", 2, 0, 0, SCM scm_from_locale_symbol (const char *sym) { - return scm_i_c_mem2symbol (sym, strlen (sym)); + return scm_from_locale_symboln (sym, -1); } SCM scm_from_locale_symboln (const char *sym, size_t len) { - return scm_i_c_mem2symbol (sym, len); + SCM str = scm_from_locale_stringn (sym, len); + return scm_i_str2symbol (str); } SCM scm_take_locale_symboln (char *sym, size_t len) { - SCM res; - unsigned long raw_hash; - - if (len == (size_t)-1) - len = strlen (sym); - 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. */ - sym = scm_realloc (sym, len+1); - sym[len] = '\0'; - } - - raw_hash = scm_string_hash ((unsigned char *)sym, len); - res = lookup_interned_symbol (sym, len, raw_hash); - if (res != SCM_BOOL_F) - { - free (sym); - return res; - } - - res = scm_i_c_take_symbol (sym, len, 0, raw_hash, - scm_cons (SCM_BOOL_F, SCM_EOL)); + SCM str; - return res; + str = scm_take_locale_stringn (sym, len); + return scm_i_str2symbol (str); } SCM 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 666d5c8dc..146f2a59c 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 */ @@ -373,10 +374,6 @@ typedef unsigned long scm_t_bits; * tc16 (for tc7==scm_tc7_smob): * The largest part of the space of smob types is not subdivided in a * predefined way, since smobs can be added arbitrarily by user C code. - * However, while Guile also defines a number of smob types throughout, - * there is one smob type, namely scm_tc_free_cell, for which Guile assumes - * that it is declared first and thus gets a known-in-advance tc16-code. - * The reason of requiring a fixed tc16-code for this type is performance. */ @@ -437,6 +434,7 @@ typedef unsigned long scm_t_bits; #define scm_tc7_string 21 #define scm_tc7_number 23 #define scm_tc7_stringbuf 39 +#define scm_tc7_bytevector 77 /* Many of the following should be turned * into structs or smobs. We need back some @@ -451,12 +449,11 @@ typedef unsigned long scm_t_bits; #define scm_tc7_unused_5 53 #define scm_tc7_unused_6 55 #define scm_tc7_unused_7 71 -#define scm_tc7_unused_8 77 -#define scm_tc7_unused_9 79 #define scm_tc7_dsubr 61 #define scm_tc7_gsubr 63 #define scm_tc7_rpsubr 69 +#define scm_tc7_program 79 #define scm_tc7_subr_0 85 #define scm_tc7_subr_1 87 #define scm_tc7_cxr 93 @@ -483,12 +480,6 @@ typedef unsigned long scm_t_bits; #define SCM_TYP16_PREDICATE(tag, x) (!SCM_IMP (x) && SCM_TYP16 (x) == (tag)) -/* Here is the first smob subtype. */ - -/* scm_tc_free_cell is the 0th smob type. We place this in free cells to tell - * the conservative marker not to trace it. */ -#define scm_tc_free_cell (scm_tc7_smob + 0 * 256L) - /* {Immediate Values} diff --git a/libguile/threads.c b/libguile/threads.c index 8ba25f7dc..f440bf59d 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. +/* Copyright (C) 1995,1996,1997,1998,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 */ @@ -298,7 +299,7 @@ unblock_from_queue (SCM queue) var 't' // save registers. SCM_FLUSH_REGISTER_WINDOWS; // sparc only - setjmp (t->regs); // here's most of the magic + SCM_I_SETJMP (t->regs); // here's most of the magic ... and returns. @@ -352,7 +353,7 @@ unblock_from_queue (SCM queue) t->top = SCM_STACK_PTR (&t); // save registers. SCM_FLUSH_REGISTER_WINDOWS; - setjmp (t->regs); + SCM_I_SETJMP (t->regs); res = func(data); scm_enter_guile (t); @@ -403,7 +404,7 @@ suspend (void) t->top = SCM_STACK_PTR (&t); /* save registers. */ SCM_FLUSH_REGISTER_WINDOWS; - setjmp (t->regs); + SCM_I_SETJMP (t->regs); return t; } @@ -499,6 +500,7 @@ guilify_self_2 (SCM parent) t->continuation_root = scm_cons (t->handle, SCM_EOL); t->continuation_base = t->base; + t->vm = SCM_BOOL_F; if (scm_is_true (parent)) t->dynamic_state = scm_make_dynamic_state (parent); @@ -1179,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; + } } } @@ -1502,6 +1514,7 @@ fat_mutex_unlock (SCM mutex, SCM cond, { if (relock) scm_lock_mutex_timed (mutex, SCM_UNDEFINED, owner); + t->block_asyncs--; break; } @@ -2055,6 +2068,49 @@ scm_init_thread_procs () #include "libguile/threads.x" } + +/* IA64-specific things. */ + +#ifdef __ia64__ +# ifdef __hpux +# include <sys/param.h> +# include <sys/pstat.h> +void * +scm_ia64_register_backing_store_base (void) +{ + struct pst_vm_status vm_status; + int i = 0; + while (pstat_getprocvm (&vm_status, sizeof (vm_status), 0, i++) == 1) + if (vm_status.pst_type == PS_RSESTACK) + return (void *) vm_status.pst_vaddr; + abort (); +} +void * +scm_ia64_ar_bsp (const void *ctx) +{ + uint64_t bsp; + __uc_get_ar_bsp (ctx, &bsp); + return (void *) bsp; +} +# endif /* hpux */ +# ifdef linux +# include <ucontext.h> +void * +scm_ia64_register_backing_store_base (void) +{ + extern void *__libc_ia64_register_backing_store_base; + return __libc_ia64_register_backing_store_base; +} +void * +scm_ia64_ar_bsp (const void *opaque) +{ + const ucontext_t *ctx = opaque; + return (void *) ctx->uc_mcontext.sc_ar_bsp; +} +# endif /* linux */ +#endif /* __ia64__ */ + + /* Local Variables: c-file-style: "gnu" diff --git a/libguile/threads.h b/libguile/threads.h index 59c7c2c60..55102df17 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 */ @@ -107,9 +108,10 @@ typedef struct scm_i_thread { SCM_STACKITEM *continuation_base; /* For keeping track of the stack and registers. */ + SCM vm; SCM_STACKITEM *base; SCM_STACKITEM *top; - jmp_buf regs; + scm_i_jmp_buf regs; #ifdef __ia64__ void *register_backing_store_base; scm_t_contregs *pending_rbs_continuation; diff --git a/libguile/throw.c b/libguile/throw.c index ae538e25e..cf6ea4a49 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 */ @@ -22,6 +23,7 @@ #endif #include <stdio.h> +#include <unistdio.h> #include "libguile/_scm.h" #include "libguile/async.h" #include "libguile/smob.h" @@ -41,6 +43,7 @@ #include "libguile/throw.h" #include "libguile/init.h" #include "libguile/strings.h" +#include "libguile/vm.h" #include "libguile/private-options.h" @@ -57,7 +60,7 @@ static scm_t_bits tc16_jmpbuffer; #define DEACTIVATEJB(x) \ (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L)))) -#define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ)) +#define JBJMPBUF(OBJ) ((scm_i_jmp_buf *) SCM_CELL_WORD_1 (OBJ)) #define SETJBJMPBUF(x, v) (SCM_SET_CELL_WORD_1 ((x), (scm_t_bits) (v))) #define SCM_JBDFRAME(x) ((scm_t_debug_frame *) SCM_CELL_WORD_2 (x)) #define SCM_SETJBDFRAME(x, v) (SCM_SET_CELL_WORD_2 ((x), (scm_t_bits) (v))) @@ -79,7 +82,7 @@ make_jmpbuf (void) { SCM answer; SCM_NEWSMOB2 (answer, tc16_jmpbuffer, 0, 0); - SETJBJMPBUF(answer, (jmp_buf *)0); + SETJBJMPBUF(answer, (scm_i_jmp_buf *)0); DEACTIVATEJB(answer); return answer; } @@ -89,7 +92,7 @@ make_jmpbuf (void) struct jmp_buf_and_retval /* use only on the stack, in scm_catch */ { - jmp_buf buf; /* must be first */ + scm_i_jmp_buf buf; /* must be first */ SCM throw_tag; SCM retval; }; @@ -169,8 +172,17 @@ scm_c_catch (SCM tag, struct jmp_buf_and_retval jbr; SCM jmpbuf; SCM answer; + SCM vm; + SCM *sp = NULL, *fp = NULL; /* to reset the vm */ struct pre_unwind_data pre_unwind; + vm = scm_the_vm (); + if (SCM_NFALSEP (vm)) + { + sp = SCM_VM_DATA (vm)->sp; + fp = SCM_VM_DATA (vm)->fp; + } + jmpbuf = make_jmpbuf (); answer = SCM_EOL; scm_i_set_dynwinds (scm_acons (tag, jmpbuf, scm_i_dynwinds ())); @@ -183,7 +195,7 @@ scm_c_catch (SCM tag, pre_unwind.lazy_catch_p = 0; SCM_SETJBPREUNWIND(jmpbuf, &pre_unwind); - if (setjmp (jbr.buf)) + if (SCM_I_SETJMP (jbr.buf)) { SCM throw_tag; SCM throw_args; @@ -199,6 +211,30 @@ scm_c_catch (SCM tag, throw_tag = jbr.throw_tag; jbr.throw_tag = SCM_EOL; jbr.retval = SCM_EOL; + if (SCM_NFALSEP (vm)) + { + SCM_VM_DATA (vm)->sp = sp; + SCM_VM_DATA (vm)->fp = fp; +#ifdef VM_ENABLE_STACK_NULLING + /* see vm.c -- you'll have to enable this manually */ + memset (sp + 1, 0, + (SCM_VM_DATA (vm)->stack_size + - (sp + 1 - SCM_VM_DATA (vm)->stack_base)) * sizeof(SCM)); +#endif + } + else if (SCM_NFALSEP ((vm = scm_the_vm ()))) + { + /* oof, it's possible this catch was called before the vm was + booted... yick. anyway, try to reset the vm stack. */ + SCM_VM_DATA (vm)->sp = SCM_VM_DATA (vm)->stack_base - 1; + SCM_VM_DATA (vm)->fp = NULL; +#ifdef VM_ENABLE_STACK_NULLING + /* see vm.c -- you'll have to enable this manually */ + memset (SCM_VM_DATA (vm)->stack_base, 0, + SCM_VM_DATA (vm)->stack_size * sizeof(SCM)); +#endif + } + answer = handler (handler_data, throw_tag, throw_args); } else @@ -709,8 +745,12 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED) */ fprintf (stderr, "throw from within critical section.\n"); if (scm_is_symbol (key)) - fprintf (stderr, "error key: %s\n", scm_i_symbol_chars (key)); - + { + if (scm_i_is_narrow_symbol (key)) + fprintf (stderr, "error key: %s\n", scm_i_symbol_chars (key)); + else + ulc_fprintf (stderr, "error key: %llU\n", scm_i_symbol_wide_chars (key)); + } for (; scm_is_pair (s); s = scm_cdr (s), i++) { @@ -849,7 +889,7 @@ scm_ithrow (SCM key, SCM args, int noreturn SCM_UNUSED) jbr->throw_tag = key; jbr->retval = args; scm_i_set_last_debug_frame (SCM_JBDFRAME (jmpbuf)); - longjmp (*JBJMPBUF (jmpbuf), 1); + SCM_I_LONGJMP (*JBJMPBUF (jmpbuf), 1); } /* Otherwise, it's some random piece of junk. */ 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/unidata_to_charset.pl b/libguile/unidata_to_charset.pl new file mode 100755 index 000000000..6871e67ee --- /dev/null +++ b/libguile/unidata_to_charset.pl @@ -0,0 +1,399 @@ +#!/usr/bin/perl +# unidata_to_charset.pl --- Compute SRFI-14 charsets from UnicodeData.txt +# +# 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 + +open(my $in, "<", "UnicodeData.txt") or die "Can't open UnicodeData.txt: $!"; +open(my $out, ">", "srfi-14.i.c") or die "Can't open srfi-14.i.c: $!"; + +# For Unicode, we follow Java's specification: a character is +# lowercase if +# * it is not in the range [U+2000,U+2FFF], and +# * the Unicode attribute table does not give a lowercase mapping +# for it, and +# * at least one of the following is true: +# o the Unicode attribute table gives a mapping to uppercase +# for the character, or +# o the name for the character in the Unicode attribute table +# contains the words "SMALL LETTER" or "SMALL LIGATURE". + +sub lower_case { + my($codepoint, $name, $category, $uppercase, $lowercase)= @_; + if (($codepoint < 0x2000 || $codepoint > 0x2FFF) + && (!defined($lowercase) || $lowercase eq "") + && ((defined($uppercase) && $uppercase ne "") + || ($name =~ /(SMALL LETTER|SMALL LIGATURE)/))) { + return 1; + } else { + return 0; + } +} + +# For Unicode, we follow Java's specification: a character is +# uppercase if +# * it is not in the range [U+2000,U+2FFF], and +# * the Unicode attribute table does not give an uppercase mapping +# for it (this excludes titlecase characters), and +# * at least one of the following is true: +# o the Unicode attribute table gives a mapping to lowercase +# for the character, or +# o the name for the character in the Unicode attribute table +# contains the words "CAPITAL LETTER" or "CAPITAL LIGATURE". + +sub upper_case { + my($codepoint, $name, $category, $uppercase, $lowercase)= @_; + if (($codepoint < 0x2000 || $codepoint > 0x2FFF) + && (!defined($uppercase) || $uppercase eq "") + && ((defined($lowercase) && $lowercase ne "") + || ($name =~ /(CAPITAL LETTER|CAPITAL LIGATURE)/))) { + return 1; + } else { + return 0; + } +} + +# A character is titlecase if it has the category Lt in the character +# attribute database. + +sub title_case { + my($codepoint, $name, $category, $uppercase, $lowercase)= @_; + if (defined($category) && $category eq "Lt") { + return 1; + } else { + return 0; + } +} + +# A letter is any character with one of the letter categories (Lu, Ll, +# Lt, Lm, Lo) in the Unicode character database. + +sub letter { + my($codepoint, $name, $category, $uppercase, $lowercase)= @_; + if (defined($category) && ($category eq "Lu" + || $category eq "Ll" + || $category eq "Lt" + || $category eq "Lm" + || $category eq "Lo")) { + return 1; + } else { + return 0; + } +} + +# A character is a digit if it has the category Nd in the character +# attribute database. In Latin-1 and ASCII, the only such characters +# are 0123456789. In Unicode, there are other digit characters in +# other code blocks, such as Gujarati digits and Tibetan digits. + +sub digit { + my($codepoint, $name, $category, $uppercase, $lowercase)= @_; + if (defined($category) && $category eq "Nd") { + return 1; + } else { + return 0; + } +} + +# The only hex digits are 0123456789abcdefABCDEF. + +sub hex_digit { + my($codepoint, $name, $category, $uppercase, $lowercase)= @_; + if (($codepoint >= 0x30 && $codepoint <= 0x39) + || ($codepoint >= 0x41 && $codepoint <= 0x46) + || ($codepoint >= 0x61 && $codepoint <= 0x66)) { + return 1; + } else { + return 0; + } +} + +# The union of char-set:letter and char-set:digit. + +sub letter_plus_digit { + my($codepoint, $name, $category, $uppercase, $lowercase)= @_; + if (letter($codepoint, $name, $category, $uppercase, $lowercase) + || digit($codepoint, $name, $category, $uppercase, $lowercase)) { + return 1; + } else { + return 0; + } +} + +# Characters that would 'use ink' when printed +sub graphic { + my($codepoint, $name, $category, $uppercase, $lowercase)= @_; + if ($category =~ (/L|M|N|P|S/)) { + return 1; + } else { + return 0; + } +} + +# A whitespace character is either +# * a character with one of the space, line, or paragraph separator +# categories (Zs, Zl or Zp) of the Unicode character database. +# * U+0009 Horizontal tabulation (\t control-I) +# * U+000A Line feed (\n control-J) +# * U+000B Vertical tabulation (\v control-K) +# * U+000C Form feed (\f control-L) +# * U+000D Carriage return (\r control-M) + +sub whitespace { + my($codepoint, $name, $category, $uppercase, $lowercase)= @_; + if ($category =~ (/Zs|Zl|Zp/) + || $codepoint == 0x9 + || $codepoint == 0xA + || $codepoint == 0xB + || $codepoint == 0xC + || $codepoint == 0xD) { + return 1; + } else { + return 0; + } +} + +# A printing character is one that would occupy space when printed, +# i.e., a graphic character or a space character. char-set:printing is +# the union of char-set:whitespace and char-set:graphic. + +sub printing { + my($codepoint, $name, $category, $uppercase, $lowercase)= @_; + if (whitespace($codepoint, $name, $category, $uppercase, $lowercase) + || graphic($codepoint, $name, $category, $uppercase, $lowercase)) { + return 1; + } else { + return 0; + } +} + +# The ISO control characters are the Unicode/Latin-1 characters in the +# ranges [U+0000,U+001F] and [U+007F,U+009F]. + +sub iso_control { + my($codepoint, $name, $category, $uppercase, $lowercase)= @_; + if (($codepoint >= 0x00 && $codepoint <= 0x1F) + || ($codepoint >= 0x7F && $codepoint <= 0x9F)) { + return 1; + } else { + return 0; + } +} + +# A punctuation character is any character that has one of the +# punctuation categories in the Unicode character database (Pc, Pd, +# Ps, Pe, Pi, Pf, or Po.) + +# Note that srfi-14 gives conflicting requirements!! It claims that +# only the Unicode punctuation is necessary, but, explicitly calls out +# the soft hyphen character (U+00AD) as punctution. Current versions +# of Unicode consider U+00AD to be a formatting character, not +# punctuation. + +sub punctuation { + my($codepoint, $name, $category, $uppercase, $lowercase)= @_; + if ($category =~ (/P/)) { + return 1; + } else { + return 0; + } +} + +# A symbol is any character that has one of the symbol categories in +# the Unicode character database (Sm, Sc, Sk, or So). + +sub symbol { + my($codepoint, $name, $category, $uppercase, $lowercase)= @_; + if ($category =~ (/S/)) { + return 1; + } else { + return 0; + } +} + +# Blank chars are horizontal whitespace. A blank character is either +# * a character with the space separator category (Zs) in the +# Unicode character database. +# * U+0009 Horizontal tabulation (\t control-I) +sub blank { + my($codepoint, $name, $category, $uppercase, $lowercase)= @_; + if ($category =~ (/Zs/) + || $codepoint == 0x9) { + return 1; + } else { + return 0; + } +} + +# ASCII +sub ascii { + my($codepoint, $name, $category, $uppercase, $lowercase)= @_; + if ($codepoint <= 0x7F) { + return 1; + } else { + return 0; + } +} + +# Empty +sub empty { + my($codepoint, $name, $category, $uppercase, $lowercase)= @_; + return 0; +} + +# Full -- All characters. +sub full { + my($codepoint, $name, $category, $uppercase, $lowercase)= @_; + return 1; +} + + +# The procedure generates the two C structures necessary to describe a +# given category. +sub compute { + my($f) = @_; + my $start = -1; + my $end = -1; + my $len = 0; + my @rstart = (-1); + my @rend = (-1); + + seek($in, 0, 0) or die "Can't seek to beginning of file: $!"; + + print "$f\n"; + + while (<$in>) { + # Parse the 14 column, semicolon-delimited UnicodeData.txt + # file + chomp; + my(@fields) = split(/;/); + + # The codepoint: an integer + my $codepoint = hex($fields[0]); + + # If this is a character range, the last character in this + # range + my $codepoint_end = $codepoint; + + # The name of the character + my $name = $fields[1]; + + # A two-character category code, such as Ll (lower-case + # letter) + my $category = $fields[2]; + + # The codepoint of the uppercase version of this char + my $uppercase = $fields[12]; + + # The codepoint of the lowercase version of this char + my $lowercase = $fields[13]; + + my $pass = &$f($codepoint,$name,$category,$uppercase,$lowercase); + if ($pass == 1) { + + # Some pairs of lines in UnicodeData.txt delimit ranges of + # characters. + if ($name =~ /First/) { + $line = <$in>; + die $! if $!; + $codepoint_end = hex( (split(/;/, $line))[0] ); + } + + # Compute ranges of characters [start:end] that meet the + # criteria. Store the ranges. + if ($start == -1) { + $start = $codepoint; + $end = $codepoint_end; + } elsif ($end + 1 == $codepoint) { + $end = $codepoint_end; + } else { + $rstart[$len] = $start; + $rend[$len] = $end; + $len++; + $start = $codepoint; + $end = $codepoint_end; + } + } + } + + # Extra logic to ensure that the last range is included + if ($start != -1) { + if ($len > 0 && $rstart[@rstart-1] != $start) { + $rstart[$len] = $start; + $rend[$len] = $end; + $len++; + } elsif ($len == 0) { + $rstart[0] = $start; + $rend[0] = $end; + } + } + + # Print the C struct that contains the range list. + print $out "scm_t_char_range cs_" . $f . "_ranges[] = {\n"; + if ($rstart[0] != -1) { + for (my $i=0; $i<@rstart-1; $i++) { + printf $out " {0x%04x, 0x%04x},\n", $rstart[$i], $rend[$i]; + } + printf $out " {0x%04x, 0x%04x}\n", $rstart[@rstart-1], $rend[@rstart-1]; + } + print $out "};\n\n"; + + # Print the C struct that contains the range list length and + # pointer to the range list. + print $out "scm_t_char_set cs_${f} = {\n"; + print $out " $len,\n"; + print $out " cs_" . $f . "_ranges\n"; + print $out "};\n\n"; +} + +# Write a bit of a header +print $out "/* srfi-14.i.c -- standard SRFI-14 character set data */\n\n"; +print $out "/* This file is #include'd by srfi-14.c. */\n\n"; +print $out "/* This file was generated from\n" +print $out " http://unicode.org/Public/UNIDATA/UnicodeData.txt\n"; +print $out " with the unidata_to_charset.pl script. */\n\n"; + +# Write the C structs for each SRFI-14 charset +compute "lower_case"; +compute "upper_case"; +compute "title_case"; +compute "letter"; +compute "digit"; +compute "hex_digit"; +compute "letter_plus_digit"; +compute "graphic"; +compute "whitespace"; +compute "printing"; +compute "iso_control"; +compute "punctuation"; +compute "symbol"; +compute "blank"; +compute "ascii"; +compute "empty"; +compute "full"; + +close $in; +close $out; + +exec ('indent srfi-14.i.c') or print STDERR "call to 'indent' failed: $!"; + +# And we're done. + + + + + + diff --git a/libguile/unif.c b/libguile/unif.c deleted file mode 100644 index ecf96dfec..000000000 --- a/libguile/unif.c +++ /dev/null @@ -1,2929 +0,0 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,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. - * - * 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 file has code for arrays in lots of variants (double, integer, - unsigned etc. ). It suffers from hugely repetitive code because - there is similar (but different) code for every variant included. (urg.) - - --hwn -*/ - - -#ifdef HAVE_CONFIG_H -# include <config.h> -#endif - -#include <stdio.h> -#include <errno.h> -#include <string.h> - -#include "libguile/_scm.h" -#include "libguile/__scm.h" -#include "libguile/eq.h" -#include "libguile/chars.h" -#include "libguile/eval.h" -#include "libguile/fports.h" -#include "libguile/smob.h" -#include "libguile/feature.h" -#include "libguile/root.h" -#include "libguile/strings.h" -#include "libguile/srfi-13.h" -#include "libguile/srfi-4.h" -#include "libguile/vectors.h" -#include "libguile/list.h" -#include "libguile/deprecation.h" -#include "libguile/dynwind.h" - -#include "libguile/validate.h" -#include "libguile/unif.h" -#include "libguile/ramap.h" -#include "libguile/print.h" -#include "libguile/read.h" - -#ifdef HAVE_UNISTD_H -#include <unistd.h> -#endif - -#ifdef HAVE_IO_H -#include <io.h> -#endif - - -/* The set of uniform scm_vector types is: - * Vector of: Called: Replaced by: - * unsigned char string - * char byvect s8 or u8, depending on signedness of 'char' - * boolean bvect - * signed long ivect s32 - * unsigned long uvect u32 - * float fvect f32 - * double dvect d32 - * complex double cvect c64 - * short svect s16 - * long long llvect s64 - */ - -scm_t_bits scm_i_tc16_array; -scm_t_bits scm_i_tc16_enclosed_array; - -#define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \ - (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS)) -#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \ - (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS)) - -typedef SCM creator_proc (SCM len, SCM fill); - -struct { - char *type_name; - SCM type; - creator_proc *creator; -} type_creator_table[] = { - { "a", SCM_UNSPECIFIED, scm_make_string }, - { "b", SCM_UNSPECIFIED, scm_make_bitvector }, - { "u8", SCM_UNSPECIFIED, scm_make_u8vector }, - { "s8", SCM_UNSPECIFIED, scm_make_s8vector }, - { "u16", SCM_UNSPECIFIED, scm_make_u16vector }, - { "s16", SCM_UNSPECIFIED, scm_make_s16vector }, - { "u32", SCM_UNSPECIFIED, scm_make_u32vector }, - { "s32", SCM_UNSPECIFIED, scm_make_s32vector }, - { "u64", SCM_UNSPECIFIED, scm_make_u64vector }, - { "s64", SCM_UNSPECIFIED, scm_make_s64vector }, - { "f32", SCM_UNSPECIFIED, scm_make_f32vector }, - { "f64", SCM_UNSPECIFIED, scm_make_f64vector }, - { "c32", SCM_UNSPECIFIED, scm_make_c32vector }, - { "c64", SCM_UNSPECIFIED, scm_make_c64vector }, - { NULL } -}; - -static void -init_type_creator_table () -{ - int i; - for (i = 0; type_creator_table[i].type_name; i++) - { - SCM sym = scm_from_locale_symbol (type_creator_table[i].type_name); - type_creator_table[i].type = scm_permanent_object (sym); - } -} - -static creator_proc * -type_to_creator (SCM type) -{ - int i; - - if (scm_is_eq (type, SCM_BOOL_T)) - return scm_make_vector; - for (i = 0; type_creator_table[i].type_name; i++) - if (scm_is_eq (type, type_creator_table[i].type)) - return type_creator_table[i].creator; - - scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (type)); -} - -static SCM -make_typed_vector (SCM type, size_t len) -{ - creator_proc *creator = type_to_creator (type); - return creator (scm_from_size_t (len), SCM_UNDEFINED); -} - -#if SCM_ENABLE_DEPRECATED - -SCM_SYMBOL (scm_sym_s, "s"); -SCM_SYMBOL (scm_sym_l, "l"); - -static int -singp (SCM obj) -{ - if (!SCM_REALP (obj)) - return 0; - else - { - double x = SCM_REAL_VALUE (obj); - float fx = x; - return (- SCM_FLTMAX < x) && (x < SCM_FLTMAX) && (fx == x); - } -} - -SCM_API int scm_i_inump (SCM obj); -SCM_API scm_t_signed_bits scm_i_inum (SCM obj); - -static SCM -prototype_to_type (SCM proto) -{ - const char *type_name; - - if (scm_is_eq (proto, SCM_BOOL_T)) - type_name = "b"; - else if (scm_is_eq (proto, SCM_MAKE_CHAR (0))) - type_name = "s8"; - else if (SCM_CHARP (proto)) - type_name = "a"; - else if (scm_i_inump (proto)) - { - if (scm_i_inum (proto) > 0) - type_name = "u32"; - else - type_name = "s32"; - } - else if (scm_is_eq (proto, scm_sym_s)) - type_name = "s16"; - else if (scm_is_eq (proto, scm_sym_l)) - type_name = "s64"; - else if (SCM_REALP (proto) - || scm_is_true (scm_eqv_p (proto, - scm_divide (scm_from_int (1), - scm_from_int (3))))) - { - if (singp (proto)) - type_name = "f32"; - else - type_name = "f64"; - } - else if (SCM_COMPLEXP (proto)) - type_name = "c64"; - else if (scm_is_null (proto)) - type_name = NULL; - else - type_name = NULL; - - if (type_name) - return scm_from_locale_symbol (type_name); - else - return SCM_BOOL_T; -} - -static SCM -scm_i_get_old_prototype (SCM uvec) -{ - if (scm_is_bitvector (uvec)) - return SCM_BOOL_T; - else if (scm_is_string (uvec)) - return SCM_MAKE_CHAR ('a'); - else if (scm_is_true (scm_s8vector_p (uvec))) - return SCM_MAKE_CHAR ('\0'); - else if (scm_is_true (scm_s16vector_p (uvec))) - return scm_sym_s; - else if (scm_is_true (scm_u32vector_p (uvec))) - return scm_from_int (1); - else if (scm_is_true (scm_s32vector_p (uvec))) - return scm_from_int (-1); - else if (scm_is_true (scm_s64vector_p (uvec))) - return scm_sym_l; - else if (scm_is_true (scm_f32vector_p (uvec))) - return scm_from_double (1.0); - else if (scm_is_true (scm_f64vector_p (uvec))) - return scm_divide (scm_from_int (1), scm_from_int (3)); - else if (scm_is_true (scm_c64vector_p (uvec))) - return scm_c_make_rectangular (0, 1); - else if (scm_is_vector (uvec)) - return SCM_EOL; - else - scm_misc_error (NULL, "~a has no prototype", scm_list_1 (uvec)); -} - -SCM -scm_make_uve (long k, SCM prot) -#define FUNC_NAME "scm_make_uve" -{ - scm_c_issue_deprecation_warning - ("`scm_make_uve' is deprecated, see the manual for alternatives."); - - return make_typed_vector (prototype_to_type (prot), k); -} -#undef FUNC_NAME - -#endif - -int -scm_is_array (SCM obj) -{ - return (SCM_I_ENCLOSED_ARRAYP (obj) - || SCM_I_ARRAYP (obj) - || scm_is_generalized_vector (obj)); -} - -int -scm_is_typed_array (SCM obj, SCM type) -{ - if (SCM_I_ENCLOSED_ARRAYP (obj)) - { - /* Enclosed arrays are arrays but are not of any type. - */ - return 0; - } - - /* Get storage vector. - */ - if (SCM_I_ARRAYP (obj)) - obj = SCM_I_ARRAY_V (obj); - - /* It must be a generalized vector (which includes vectors, strings, etc). - */ - if (!scm_is_generalized_vector (obj)) - return 0; - - return scm_is_eq (type, scm_i_generalized_vector_type (obj)); -} - -static SCM -enclosed_ref (scm_t_array_handle *h, ssize_t pos) -{ - return scm_i_cvref (SCM_I_ARRAY_V (h->array), pos + h->base, 1); -} - -static SCM -vector_ref (scm_t_array_handle *h, ssize_t pos) -{ - return ((const SCM *)h->elements)[pos]; -} - -static SCM -string_ref (scm_t_array_handle *h, ssize_t pos) -{ - pos += h->base; - if (SCM_I_ARRAYP (h->array)) - return scm_c_string_ref (SCM_I_ARRAY_V (h->array), pos); - else - return scm_c_string_ref (h->array, pos); -} - -static SCM -bitvector_ref (scm_t_array_handle *h, ssize_t pos) -{ - pos += scm_array_handle_bit_elements_offset (h); - return - scm_from_bool (((scm_t_uint32 *)h->elements)[pos/32] & (1l << (pos % 32))); -} - -static SCM -memoize_ref (scm_t_array_handle *h, ssize_t pos) -{ - SCM v = h->array; - - if (SCM_I_ENCLOSED_ARRAYP (v)) - { - h->ref = enclosed_ref; - return enclosed_ref (h, pos); - } - - if (SCM_I_ARRAYP (v)) - v = SCM_I_ARRAY_V (v); - - if (scm_is_vector (v)) - { - h->elements = scm_array_handle_elements (h); - h->ref = vector_ref; - } - else if (scm_is_uniform_vector (v)) - { - h->elements = scm_array_handle_uniform_elements (h); - h->ref = scm_i_uniform_vector_ref_proc (v); - } - else if (scm_is_string (v)) - { - h->ref = string_ref; - } - else if (scm_is_bitvector (v)) - { - h->elements = scm_array_handle_bit_elements (h); - h->ref = bitvector_ref; - } - else - scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array)); - - return h->ref (h, pos); -} - -static void -enclosed_set (scm_t_array_handle *h, ssize_t pos, SCM val) -{ - scm_wrong_type_arg_msg (NULL, 0, h->array, "non-enclosed array"); -} - -static void -vector_set (scm_t_array_handle *h, ssize_t pos, SCM val) -{ - ((SCM *)h->writable_elements)[pos] = val; -} - -static void -string_set (scm_t_array_handle *h, ssize_t pos, SCM val) -{ - pos += h->base; - if (SCM_I_ARRAYP (h->array)) - scm_c_string_set_x (SCM_I_ARRAY_V (h->array), pos, val); - else - scm_c_string_set_x (h->array, pos, val); -} - -static void -bitvector_set (scm_t_array_handle *h, ssize_t pos, SCM val) -{ - scm_t_uint32 mask; - pos += scm_array_handle_bit_elements_offset (h); - mask = 1l << (pos % 32); - if (scm_to_bool (val)) - ((scm_t_uint32 *)h->writable_elements)[pos/32] |= mask; - else - ((scm_t_uint32 *)h->writable_elements)[pos/32] &= ~mask; -} - -static void -memoize_set (scm_t_array_handle *h, ssize_t pos, SCM val) -{ - SCM v = h->array; - - if (SCM_I_ENCLOSED_ARRAYP (v)) - { - h->set = enclosed_set; - enclosed_set (h, pos, val); - return; - } - - if (SCM_I_ARRAYP (v)) - v = SCM_I_ARRAY_V (v); - - if (scm_is_vector (v)) - { - h->writable_elements = scm_array_handle_writable_elements (h); - h->set = vector_set; - } - else if (scm_is_uniform_vector (v)) - { - h->writable_elements = scm_array_handle_uniform_writable_elements (h); - h->set = scm_i_uniform_vector_set_proc (v); - } - else if (scm_is_string (v)) - { - h->set = string_set; - } - else if (scm_is_bitvector (v)) - { - h->writable_elements = scm_array_handle_bit_writable_elements (h); - h->set = bitvector_set; - } - else - scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array)); - - h->set (h, pos, val); -} - -void -scm_array_get_handle (SCM array, scm_t_array_handle *h) -{ - h->array = array; - h->ref = memoize_ref; - h->set = memoize_set; - - if (SCM_I_ARRAYP (array) || SCM_I_ENCLOSED_ARRAYP (array)) - { - h->dims = SCM_I_ARRAY_DIMS (array); - h->base = SCM_I_ARRAY_BASE (array); - } - else if (scm_is_generalized_vector (array)) - { - h->dim0.lbnd = 0; - h->dim0.ubnd = scm_c_generalized_vector_length (array) - 1; - h->dim0.inc = 1; - h->dims = &h->dim0; - h->base = 0; - } - else - scm_wrong_type_arg_msg (NULL, 0, array, "array"); -} - -void -scm_array_handle_release (scm_t_array_handle *h) -{ - /* Nothing to do here until arrays need to be reserved for real. - */ -} - -size_t -scm_array_handle_rank (scm_t_array_handle *h) -{ - if (SCM_I_ARRAYP (h->array) || SCM_I_ENCLOSED_ARRAYP (h->array)) - return SCM_I_ARRAY_NDIM (h->array); - else - return 1; -} - -scm_t_array_dim * -scm_array_handle_dims (scm_t_array_handle *h) -{ - return h->dims; -} - -const SCM * -scm_array_handle_elements (scm_t_array_handle *h) -{ - SCM vec = h->array; - if (SCM_I_ARRAYP (vec)) - vec = SCM_I_ARRAY_V (vec); - if (SCM_I_IS_VECTOR (vec)) - return SCM_I_VECTOR_ELTS (vec) + h->base; - scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); -} - -SCM * -scm_array_handle_writable_elements (scm_t_array_handle *h) -{ - SCM vec = h->array; - if (SCM_I_ARRAYP (vec)) - vec = SCM_I_ARRAY_V (vec); - if (SCM_I_IS_VECTOR (vec)) - return SCM_I_VECTOR_WELTS (vec) + h->base; - scm_wrong_type_arg_msg (NULL, 0, h->array, "non-uniform array"); -} - -#if SCM_ENABLE_DEPRECATED - -SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, - (SCM obj, SCM prot), - "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n" - "not.") -#define FUNC_NAME s_scm_array_p -{ - if (!SCM_UNBNDP (prot)) - { - scm_c_issue_deprecation_warning - ("Using prototypes with `array?' is deprecated." - " Use `typed-array?' instead."); - - return scm_typed_array_p (obj, prototype_to_type (prot)); - } - else - return scm_from_bool (scm_is_array (obj)); -} -#undef FUNC_NAME - -#else /* !SCM_ENABLE_DEPRECATED */ - -/* We keep the old 2-argument C prototype for a while although the old - PROT argument is always ignored now. C code should probably use - scm_is_array or scm_is_typed_array anyway. -*/ - -static SCM scm_i_array_p (SCM obj); - -SCM_DEFINE (scm_i_array_p, "array?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n" - "not.") -#define FUNC_NAME s_scm_i_array_p -{ - return scm_from_bool (scm_is_array (obj)); -} -#undef FUNC_NAME - -SCM -scm_array_p (SCM obj, SCM prot) -{ - return scm_from_bool (scm_is_array (obj)); -} - -#endif /* !SCM_ENABLE_DEPRECATED */ - - -SCM_DEFINE (scm_typed_array_p, "typed-array?", 2, 0, 0, - (SCM obj, SCM type), - "Return @code{#t} if the @var{obj} is an array of type\n" - "@var{type}, and @code{#f} if not.") -#define FUNC_NAME s_scm_typed_array_p -{ - return scm_from_bool (scm_is_typed_array (obj, type)); -} -#undef FUNC_NAME - -size_t -scm_c_array_rank (SCM array) -{ - scm_t_array_handle handle; - size_t res; - - scm_array_get_handle (array, &handle); - res = scm_array_handle_rank (&handle); - scm_array_handle_release (&handle); - return res; -} - -SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0, - (SCM array), - "Return the number of dimensions of the array @var{array.}\n") -#define FUNC_NAME s_scm_array_rank -{ - return scm_from_size_t (scm_c_array_rank (array)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0, - (SCM ra), - "@code{array-dimensions} is similar to @code{array-shape} but replaces\n" - "elements with a @code{0} minimum with one greater than the maximum. So:\n" - "@lisp\n" - "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n" - "@end lisp") -#define FUNC_NAME s_scm_array_dimensions -{ - scm_t_array_handle handle; - scm_t_array_dim *s; - SCM res = SCM_EOL; - size_t k; - - scm_array_get_handle (ra, &handle); - s = scm_array_handle_dims (&handle); - k = scm_array_handle_rank (&handle); - - while (k--) - res = scm_cons (s[k].lbnd - ? scm_cons2 (scm_from_ssize_t (s[k].lbnd), - scm_from_ssize_t (s[k].ubnd), - SCM_EOL) - : scm_from_ssize_t (1 + s[k].ubnd), - res); - - scm_array_handle_release (&handle); - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, - (SCM ra), - "Return the root vector of a shared array.") -#define FUNC_NAME s_scm_shared_array_root -{ - if (SCM_I_ARRAYP (ra) || SCM_I_ENCLOSED_ARRAYP (ra)) - return SCM_I_ARRAY_V (ra); - else if (scm_is_generalized_vector (ra)) - return ra; - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0, - (SCM ra), - "Return the root vector index of the first element in the array.") -#define FUNC_NAME s_scm_shared_array_offset -{ - scm_t_array_handle handle; - SCM res; - - scm_array_get_handle (ra, &handle); - res = scm_from_size_t (handle.base); - scm_array_handle_release (&handle); - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0, - (SCM ra), - "For each dimension, return the distance between elements in the root vector.") -#define FUNC_NAME s_scm_shared_array_increments -{ - scm_t_array_handle handle; - SCM res = SCM_EOL; - size_t k; - scm_t_array_dim *s; - - scm_array_get_handle (ra, &handle); - k = scm_array_handle_rank (&handle); - s = scm_array_handle_dims (&handle); - while (k--) - res = scm_cons (scm_from_ssize_t (s[k].inc), res); - scm_array_handle_release (&handle); - return res; -} -#undef FUNC_NAME - -ssize_t -scm_array_handle_pos (scm_t_array_handle *h, SCM indices) -{ - scm_t_array_dim *s = scm_array_handle_dims (h); - ssize_t pos = 0, i; - size_t k = scm_array_handle_rank (h); - - while (k > 0 && scm_is_pair (indices)) - { - i = scm_to_signed_integer (SCM_CAR (indices), s->lbnd, s->ubnd); - pos += (i - s->lbnd) * s->inc; - k--; - s++; - indices = SCM_CDR (indices); - } - if (k > 0 || !scm_is_null (indices)) - scm_misc_error (NULL, "wrong number of indices, expecting ~a", - scm_list_1 (scm_from_size_t (scm_array_handle_rank (h)))); - return pos; -} - -SCM -scm_i_make_ra (int ndim, int enclosed) -{ - scm_t_bits tag = enclosed? scm_i_tc16_enclosed_array : scm_i_tc16_array; - SCM ra; - SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + tag, - scm_gc_malloc ((sizeof (scm_i_t_array) + - ndim * sizeof (scm_t_array_dim)), - "array")); - SCM_I_ARRAY_V (ra) = SCM_BOOL_F; - return ra; -} - -static char s_bad_spec[] = "Bad scm_array dimension"; - - -/* Increments will still need to be set. */ - -static SCM -scm_i_shap2ra (SCM args) -{ - scm_t_array_dim *s; - SCM ra, spec, sp; - int ndim = scm_ilength (args); - if (ndim < 0) - scm_misc_error (NULL, s_bad_spec, SCM_EOL); - - ra = scm_i_make_ra (ndim, 0); - SCM_I_ARRAY_BASE (ra) = 0; - s = SCM_I_ARRAY_DIMS (ra); - for (; !scm_is_null (args); s++, args = SCM_CDR (args)) - { - spec = SCM_CAR (args); - if (scm_is_integer (spec)) - { - if (scm_to_long (spec) < 0) - scm_misc_error (NULL, s_bad_spec, SCM_EOL); - s->lbnd = 0; - s->ubnd = scm_to_long (spec) - 1; - s->inc = 1; - } - else - { - if (!scm_is_pair (spec) || !scm_is_integer (SCM_CAR (spec))) - scm_misc_error (NULL, s_bad_spec, SCM_EOL); - s->lbnd = scm_to_long (SCM_CAR (spec)); - sp = SCM_CDR (spec); - if (!scm_is_pair (sp) - || !scm_is_integer (SCM_CAR (sp)) - || !scm_is_null (SCM_CDR (sp))) - scm_misc_error (NULL, s_bad_spec, SCM_EOL); - s->ubnd = scm_to_long (SCM_CAR (sp)); - s->inc = 1; - } - } - return ra; -} - -SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1, - (SCM type, SCM fill, SCM bounds), - "Create and return an array of type @var{type}.") -#define FUNC_NAME s_scm_make_typed_array -{ - size_t k, rlen = 1; - scm_t_array_dim *s; - creator_proc *creator; - SCM ra; - - 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; - } - - if (scm_is_eq (fill, SCM_UNSPECIFIED)) - fill = SCM_UNDEFINED; - - SCM_I_ARRAY_V (ra) = creator (scm_from_size_t (rlen), fill); - - 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.") -#define FUNC_NAME s_scm_make_array -{ - return scm_make_typed_array (SCM_BOOL_T, fill, bounds); -} -#undef FUNC_NAME - -#if SCM_ENABLE_DEPRECATED - -SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0, - (SCM dims, SCM prot, SCM fill), - "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n" - "Create and return a uniform array or vector of type\n" - "corresponding to @var{prototype} with dimensions @var{dims} or\n" - "length @var{length}. If @var{fill} is supplied, it's used to\n" - "fill the array, otherwise @var{prototype} is used.") -#define FUNC_NAME s_scm_dimensions_to_uniform_array -{ - scm_c_issue_deprecation_warning - ("`dimensions->uniform-array' is deprecated. " - "Use `make-typed-array' instead."); - - if (scm_is_integer (dims)) - dims = scm_list_1 (dims); - - if (SCM_UNBNDP (fill)) - { - /* Using #\nul as the prototype yields a s8 array, but numeric - arrays can't store characters, so we have to special case this. - */ - if (scm_is_eq (prot, SCM_MAKE_CHAR (0))) - fill = scm_from_int (0); - else - fill = prot; - } - - return scm_make_typed_array (prototype_to_type (prot), fill, dims); -} -#undef FUNC_NAME - -#endif - -static void -scm_i_ra_set_contp (SCM ra) -{ - size_t k = SCM_I_ARRAY_NDIM (ra); - if (k) - { - long inc = SCM_I_ARRAY_DIMS (ra)[k - 1].inc; - while (k--) - { - if (inc != SCM_I_ARRAY_DIMS (ra)[k].inc) - { - SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra); - return; - } - inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd - - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1); - } - } - SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra); -} - - -SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1, - (SCM oldra, SCM mapfunc, SCM dims), - "@code{make-shared-array} can be used to create shared subarrays of other\n" - "arrays. The @var{mapper} is a function that translates coordinates in\n" - "the new array into coordinates in the old array. A @var{mapper} must be\n" - "linear, and its range must stay within the bounds of the old array, but\n" - "it can be otherwise arbitrary. A simple example:\n" - "@lisp\n" - "(define fred (make-array #f 8 8))\n" - "(define freds-diagonal\n" - " (make-shared-array fred (lambda (i) (list i i)) 8))\n" - "(array-set! freds-diagonal 'foo 3)\n" - "(array-ref fred 3 3) @result{} foo\n" - "(define freds-center\n" - " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n" - "(array-ref freds-center 0 0) @result{} foo\n" - "@end lisp") -#define FUNC_NAME s_scm_make_shared_array -{ - scm_t_array_handle old_handle; - SCM ra; - SCM inds, indptr; - SCM imap; - size_t k; - ssize_t i; - long old_base, old_min, new_min, old_max, new_max; - scm_t_array_dim *s; - - SCM_VALIDATE_REST_ARGUMENT (dims); - SCM_VALIDATE_PROC (2, mapfunc); - ra = scm_i_shap2ra (dims); - - scm_array_get_handle (oldra, &old_handle); - - if (SCM_I_ARRAYP (oldra)) - { - SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra); - old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra); - s = scm_array_handle_dims (&old_handle); - k = scm_array_handle_rank (&old_handle); - while (k--) - { - if (s[k].inc > 0) - old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; - else - old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; - } - } - else - { - SCM_I_ARRAY_V (ra) = oldra; - old_base = old_min = 0; - old_max = scm_c_generalized_vector_length (oldra) - 1; - } - - inds = SCM_EOL; - s = SCM_I_ARRAY_DIMS (ra); - for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++) - { - inds = scm_cons (scm_from_long (s[k].lbnd), inds); - if (s[k].ubnd < s[k].lbnd) - { - if (1 == SCM_I_ARRAY_NDIM (ra)) - ra = make_typed_vector (scm_array_type (ra), 0); - else - SCM_I_ARRAY_V (ra) = make_typed_vector (scm_array_type (ra), 0); - scm_array_handle_release (&old_handle); - return ra; - } - } - - imap = scm_apply_0 (mapfunc, scm_reverse (inds)); - i = scm_array_handle_pos (&old_handle, imap); - SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base; - indptr = inds; - k = SCM_I_ARRAY_NDIM (ra); - while (k--) - { - if (s[k].ubnd > s[k].lbnd) - { - SCM_SETCAR (indptr, scm_sum (SCM_CAR (indptr), scm_from_int (1))); - imap = scm_apply_0 (mapfunc, scm_reverse (inds)); - s[k].inc = scm_array_handle_pos (&old_handle, imap) - i; - i += s[k].inc; - if (s[k].inc > 0) - new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc; - else - new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc; - } - else - s[k].inc = new_max - new_min + 1; /* contiguous by default */ - indptr = SCM_CDR (indptr); - } - - scm_array_handle_release (&old_handle); - - if (old_min > new_min || old_max < new_max) - SCM_MISC_ERROR ("mapping out of range", SCM_EOL); - if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra)) - { - SCM v = SCM_I_ARRAY_V (ra); - size_t length = scm_c_generalized_vector_length (v); - if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd) - return v; - if (s->ubnd < s->lbnd) - return make_typed_vector (scm_array_type (ra), 0); - } - scm_i_ra_set_contp (ra); - return ra; -} -#undef FUNC_NAME - - -/* args are RA . DIMS */ -SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1, - (SCM ra, SCM args), - "Return an array sharing contents with @var{array}, but with\n" - "dimensions arranged in a different order. There must be one\n" - "@var{dim} argument for each dimension of @var{array}.\n" - "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n" - "and the rank of the array to be returned. Each integer in that\n" - "range must appear at least once in the argument list.\n" - "\n" - "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n" - "dimensions in the array to be returned, their positions in the\n" - "argument list to dimensions of @var{array}. Several @var{dim}s\n" - "may have the same value, in which case the returned array will\n" - "have smaller rank than @var{array}.\n" - "\n" - "@lisp\n" - "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n" - "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n" - "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n" - " #2((a 4) (b 5) (c 6))\n" - "@end lisp") -#define FUNC_NAME s_scm_transpose_array -{ - SCM res, vargs; - scm_t_array_dim *s, *r; - int ndim, i, k; - - SCM_VALIDATE_REST_ARGUMENT (args); - SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME); - - if (scm_is_generalized_vector (ra)) - { - /* Make sure that we are called with a single zero as - arguments. - */ - if (scm_is_null (args) || !scm_is_null (SCM_CDR (args))) - SCM_WRONG_NUM_ARGS (); - SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i); - SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0); - return ra; - } - - if (SCM_I_ARRAYP (ra) || SCM_I_ENCLOSED_ARRAYP (ra)) - { - vargs = scm_vector (args); - if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra)) - SCM_WRONG_NUM_ARGS (); - ndim = 0; - for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++) - { - i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k), - 0, SCM_I_ARRAY_NDIM(ra)); - if (ndim < i) - ndim = i; - } - ndim++; - res = scm_i_make_ra (ndim, 0); - SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra); - SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra); - for (k = ndim; k--;) - { - SCM_I_ARRAY_DIMS (res)[k].lbnd = 0; - SCM_I_ARRAY_DIMS (res)[k].ubnd = -1; - } - for (k = SCM_I_ARRAY_NDIM (ra); k--;) - { - i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k)); - s = &(SCM_I_ARRAY_DIMS (ra)[k]); - r = &(SCM_I_ARRAY_DIMS (res)[i]); - if (r->ubnd < r->lbnd) - { - r->lbnd = s->lbnd; - r->ubnd = s->ubnd; - r->inc = s->inc; - ndim--; - } - else - { - if (r->ubnd > s->ubnd) - r->ubnd = s->ubnd; - if (r->lbnd < s->lbnd) - { - SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc; - r->lbnd = s->lbnd; - } - r->inc += s->inc; - } - } - if (ndim > 0) - SCM_MISC_ERROR ("bad argument list", SCM_EOL); - scm_i_ra_set_contp (res); - return res; - } - - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); -} -#undef FUNC_NAME - -/* args are RA . AXES */ -SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1, - (SCM ra, SCM axes), - "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n" - "the rank of @var{array}. @var{enclose-array} returns an array\n" - "resembling an array of shared arrays. The dimensions of each shared\n" - "array are the same as the @var{dim}th dimensions of the original array,\n" - "the dimensions of the outer array are the same as those of the original\n" - "array that did not match a @var{dim}.\n\n" - "An enclosed array is not a general Scheme array. Its elements may not\n" - "be set using @code{array-set!}. Two references to the same element of\n" - "an enclosed array will be @code{equal?} but will not in general be\n" - "@code{eq?}. The value returned by @var{array-prototype} when given an\n" - "enclosed array is unspecified.\n\n" - "examples:\n" - "@lisp\n" - "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n" - " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n" - "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n" - " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n" - "@end lisp") -#define FUNC_NAME s_scm_enclose_array -{ - SCM axv, res, ra_inr; - const char *c_axv; - scm_t_array_dim vdim, *s = &vdim; - int ndim, j, k, ninr, noutr; - - SCM_VALIDATE_REST_ARGUMENT (axes); - if (scm_is_null (axes)) - axes = scm_cons ((SCM_I_ARRAYP (ra) ? scm_from_size_t (SCM_I_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL); - ninr = scm_ilength (axes); - if (ninr < 0) - SCM_WRONG_NUM_ARGS (); - ra_inr = scm_i_make_ra (ninr, 0); - - if (scm_is_generalized_vector (ra)) - { - s->lbnd = 0; - s->ubnd = scm_c_generalized_vector_length (ra) - 1; - s->inc = 1; - SCM_I_ARRAY_V (ra_inr) = ra; - SCM_I_ARRAY_BASE (ra_inr) = 0; - ndim = 1; - } - else if (SCM_I_ARRAYP (ra)) - { - s = SCM_I_ARRAY_DIMS (ra); - SCM_I_ARRAY_V (ra_inr) = SCM_I_ARRAY_V (ra); - SCM_I_ARRAY_BASE (ra_inr) = SCM_I_ARRAY_BASE (ra); - ndim = SCM_I_ARRAY_NDIM (ra); - } - else - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); - - noutr = ndim - ninr; - if (noutr < 0) - SCM_WRONG_NUM_ARGS (); - axv = scm_make_string (scm_from_int (ndim), SCM_MAKE_CHAR (0)); - res = scm_i_make_ra (noutr, 1); - SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra_inr); - SCM_I_ARRAY_V (res) = ra_inr; - for (k = 0; k < ninr; k++, axes = SCM_CDR (axes)) - { - if (!scm_is_integer (SCM_CAR (axes))) - SCM_MISC_ERROR ("bad axis", SCM_EOL); - j = scm_to_int (SCM_CAR (axes)); - SCM_I_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd; - SCM_I_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd; - SCM_I_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc; - scm_c_string_set_x (axv, j, SCM_MAKE_CHAR (1)); - } - c_axv = scm_i_string_chars (axv); - for (j = 0, k = 0; k < noutr; k++, j++) - { - while (c_axv[j]) - j++; - SCM_I_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd; - SCM_I_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd; - SCM_I_ARRAY_DIMS (res)[k].inc = s[j].inc; - } - scm_remember_upto_here_1 (axv); - scm_i_ra_set_contp (ra_inr); - scm_i_ra_set_contp (res); - return res; -} -#undef FUNC_NAME - - - -SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1, - (SCM v, SCM args), - "Return @code{#t} if its arguments would be acceptable to\n" - "@code{array-ref}.") -#define FUNC_NAME s_scm_array_in_bounds_p -{ - SCM res = SCM_BOOL_T; - - SCM_VALIDATE_REST_ARGUMENT (args); - - if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v)) - { - size_t k, ndim = SCM_I_ARRAY_NDIM (v); - scm_t_array_dim *s = SCM_I_ARRAY_DIMS (v); - - for (k = 0; k < ndim; k++) - { - long ind; - - if (!scm_is_pair (args)) - SCM_WRONG_NUM_ARGS (); - ind = scm_to_long (SCM_CAR (args)); - args = SCM_CDR (args); - - if (ind < s[k].lbnd || ind > s[k].ubnd) - { - res = SCM_BOOL_F; - /* We do not stop the checking after finding a violation - since we want to validate the type-correctness and - number of arguments in any case. - */ - } - } - } - else if (scm_is_generalized_vector (v)) - { - /* Since real arrays have been covered above, all generalized - vectors are guaranteed to be zero-origin here. - */ - - long ind; - - if (!scm_is_pair (args)) - SCM_WRONG_NUM_ARGS (); - ind = scm_to_long (SCM_CAR (args)); - args = SCM_CDR (args); - res = scm_from_bool (ind >= 0 - && ind < scm_c_generalized_vector_length (v)); - } - else - scm_wrong_type_arg_msg (NULL, 0, v, "array"); - - if (!scm_is_null (args)) - SCM_WRONG_NUM_ARGS (); - - return res; -} -#undef FUNC_NAME - -SCM -scm_i_cvref (SCM v, size_t pos, int enclosed) -{ - if (enclosed) - { - int k = SCM_I_ARRAY_NDIM (v); - SCM res = scm_i_make_ra (k, 0); - SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (v); - SCM_I_ARRAY_BASE (res) = pos; - while (k--) - { - SCM_I_ARRAY_DIMS (res)[k].ubnd = SCM_I_ARRAY_DIMS (v)[k].ubnd; - SCM_I_ARRAY_DIMS (res)[k].lbnd = SCM_I_ARRAY_DIMS (v)[k].lbnd; - SCM_I_ARRAY_DIMS (res)[k].inc = SCM_I_ARRAY_DIMS (v)[k].inc; - } - return res; - } - else - return scm_c_generalized_vector_ref (v, pos); -} - -SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1, - (SCM v, SCM args), - "Return the element at the @code{(index1, index2)} element in\n" - "@var{array}.") -#define FUNC_NAME s_scm_array_ref -{ - scm_t_array_handle handle; - SCM res; - - scm_array_get_handle (v, &handle); - res = scm_array_handle_ref (&handle, scm_array_handle_pos (&handle, args)); - scm_array_handle_release (&handle); - return res; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, - (SCM v, SCM obj, SCM args), - "Set the element at the @code{(index1, index2)} element in @var{array} to\n" - "@var{new-value}. The value returned by array-set! is unspecified.") -#define FUNC_NAME s_scm_array_set_x -{ - scm_t_array_handle handle; - - scm_array_get_handle (v, &handle); - scm_array_handle_set (&handle, scm_array_handle_pos (&handle, args), obj); - scm_array_handle_release (&handle); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -/* attempts to unroll an array into a one-dimensional array. - returns the unrolled array or #f if it can't be done. */ - /* if strict is not SCM_UNDEFINED, return #f if returned array - wouldn't have contiguous elements. */ -SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0, - (SCM ra, SCM strict), - "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n" - "without changing their order (last subscript changing fastest), then\n" - "@code{array-contents} returns that shared array, otherwise it returns\n" - "@code{#f}. All arrays made by @var{make-array} and\n" - "@var{make-uniform-array} may be unrolled, some arrays made by\n" - "@var{make-shared-array} may not be.\n\n" - "If the optional argument @var{strict} is provided, a shared array will\n" - "be returned only if its elements are stored internally contiguous in\n" - "memory.") -#define FUNC_NAME s_scm_array_contents -{ - SCM sra; - - if (scm_is_generalized_vector (ra)) - return ra; - - if (SCM_I_ARRAYP (ra)) - { - size_t k, ndim = SCM_I_ARRAY_NDIM (ra), len = 1; - if (!SCM_I_ARRAYP (ra) || !SCM_I_ARRAY_CONTP (ra)) - return SCM_BOOL_F; - for (k = 0; k < ndim; k++) - len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; - if (!SCM_UNBNDP (strict)) - { - if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc)) - return SCM_BOOL_F; - if (scm_is_bitvector (SCM_I_ARRAY_V (ra))) - { - if (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) || - SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT || - len % SCM_LONG_BIT) - return SCM_BOOL_F; - } - } - - { - SCM v = SCM_I_ARRAY_V (ra); - size_t length = scm_c_generalized_vector_length (v); - if ((len == length) && 0 == SCM_I_ARRAY_BASE (ra) && SCM_I_ARRAY_DIMS (ra)->inc) - return v; - } - - sra = scm_i_make_ra (1, 0); - SCM_I_ARRAY_DIMS (sra)->lbnd = 0; - SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1; - SCM_I_ARRAY_V (sra) = SCM_I_ARRAY_V (ra); - SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra); - SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1); - return sra; - } - else if (SCM_I_ENCLOSED_ARRAYP (ra)) - scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array"); - else - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); -} -#undef FUNC_NAME - - -SCM -scm_ra2contig (SCM ra, int copy) -{ - SCM ret; - long inc = 1; - size_t k, len = 1; - for (k = SCM_I_ARRAY_NDIM (ra); k--;) - len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; - k = SCM_I_ARRAY_NDIM (ra); - if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k - 1].inc))) - { - if (!scm_is_bitvector (SCM_I_ARRAY_V (ra))) - return ra; - if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) && - 0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT && - 0 == len % SCM_LONG_BIT)) - return ra; - } - ret = scm_i_make_ra (k, 0); - SCM_I_ARRAY_BASE (ret) = 0; - while (k--) - { - SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd; - SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd; - SCM_I_ARRAY_DIMS (ret)[k].inc = inc; - inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1; - } - SCM_I_ARRAY_V (ret) = make_typed_vector (scm_array_type (ra), inc); - if (copy) - scm_array_copy_x (ra, ret); - return ret; -} - - - -SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, - (SCM ura, SCM port_or_fd, SCM start, SCM end), - "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n" - "Attempt to read all elements of @var{ura}, in lexicographic order, as\n" - "binary objects from @var{port-or-fdes}.\n" - "If an end of file is encountered,\n" - "the objects up to that point are put into @var{ura}\n" - "(starting at the beginning) and the remainder of the array is\n" - "unchanged.\n\n" - "The optional arguments @var{start} and @var{end} allow\n" - "a specified region of a vector (or linearized array) to be read,\n" - "leaving the remainder of the vector unchanged.\n\n" - "@code{uniform-array-read!} returns the number of objects read.\n" - "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n" - "returned by @code{(current-input-port)}.") -#define FUNC_NAME s_scm_uniform_array_read_x -{ - if (SCM_UNBNDP (port_or_fd)) - port_or_fd = scm_current_input_port (); - - if (scm_is_uniform_vector (ura)) - { - return scm_uniform_vector_read_x (ura, port_or_fd, start, end); - } - else if (SCM_I_ARRAYP (ura)) - { - size_t base, vlen, cstart, cend; - SCM cra, ans; - - cra = scm_ra2contig (ura, 0); - base = SCM_I_ARRAY_BASE (cra); - vlen = SCM_I_ARRAY_DIMS (cra)->inc * - (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1); - - cstart = 0; - cend = vlen; - if (!SCM_UNBNDP (start)) - { - cstart = scm_to_unsigned_integer (start, 0, vlen); - if (!SCM_UNBNDP (end)) - cend = scm_to_unsigned_integer (end, cstart, vlen); - } - - ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd, - scm_from_size_t (base + cstart), - scm_from_size_t (base + cend)); - - if (!scm_is_eq (cra, ura)) - scm_array_copy_x (cra, ura); - return ans; - } - else if (SCM_I_ENCLOSED_ARRAYP (ura)) - scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array"); - else - scm_wrong_type_arg_msg (NULL, 0, ura, "array"); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0, - (SCM ura, SCM port_or_fd, SCM start, SCM end), - "Writes all elements of @var{ura} as binary objects to\n" - "@var{port-or-fdes}.\n\n" - "The optional arguments @var{start}\n" - "and @var{end} allow\n" - "a specified region of a vector (or linearized array) to be written.\n\n" - "The number of objects actually written is returned.\n" - "@var{port-or-fdes} may be\n" - "omitted, in which case it defaults to the value returned by\n" - "@code{(current-output-port)}.") -#define FUNC_NAME s_scm_uniform_array_write -{ - if (SCM_UNBNDP (port_or_fd)) - port_or_fd = scm_current_output_port (); - - if (scm_is_uniform_vector (ura)) - { - return scm_uniform_vector_write (ura, port_or_fd, start, end); - } - else if (SCM_I_ARRAYP (ura)) - { - size_t base, vlen, cstart, cend; - SCM cra, ans; - - cra = scm_ra2contig (ura, 1); - base = SCM_I_ARRAY_BASE (cra); - vlen = SCM_I_ARRAY_DIMS (cra)->inc * - (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1); - - cstart = 0; - cend = vlen; - if (!SCM_UNBNDP (start)) - { - cstart = scm_to_unsigned_integer (start, 0, vlen); - if (!SCM_UNBNDP (end)) - cend = scm_to_unsigned_integer (end, cstart, vlen); - } - - ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd, - scm_from_size_t (base + cstart), - scm_from_size_t (base + cend)); - - return ans; - } - else if (SCM_I_ENCLOSED_ARRAYP (ura)) - scm_wrong_type_arg_msg (NULL, 0, ura, "non-enclosed array"); - else - scm_wrong_type_arg_msg (NULL, 0, ura, "array"); -} -#undef FUNC_NAME - - -/** Bit vectors */ - -static scm_t_bits scm_tc16_bitvector; - -#define IS_BITVECTOR(obj) SCM_SMOB_PREDICATE(scm_tc16_bitvector,(obj)) -#define BITVECTOR_BITS(obj) ((scm_t_uint32 *)SCM_SMOB_DATA(obj)) -#define BITVECTOR_LENGTH(obj) ((size_t)SCM_SMOB_DATA_2(obj)) - - -static int -bitvector_print (SCM vec, SCM port, scm_print_state *pstate) -{ - size_t bit_len = BITVECTOR_LENGTH (vec); - size_t word_len = (bit_len+31)/32; - scm_t_uint32 *bits = BITVECTOR_BITS (vec); - size_t i, j; - - scm_puts ("#*", port); - for (i = 0; i < word_len; i++, bit_len -= 32) - { - scm_t_uint32 mask = 1; - for (j = 0; j < 32 && j < bit_len; j++, mask <<= 1) - scm_putc ((bits[i] & mask)? '1' : '0', port); - } - - return 1; -} - -static SCM -bitvector_equalp (SCM vec1, SCM vec2) -{ - size_t bit_len = BITVECTOR_LENGTH (vec1); - size_t word_len = (bit_len + 31) / 32; - scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - bit_len); - scm_t_uint32 *bits1 = BITVECTOR_BITS (vec1); - scm_t_uint32 *bits2 = BITVECTOR_BITS (vec2); - - /* compare lengths */ - if (BITVECTOR_LENGTH (vec2) != bit_len) - return SCM_BOOL_F; - /* avoid underflow in word_len-1 below. */ - if (bit_len == 0) - return SCM_BOOL_T; - /* compare full words */ - if (memcmp (bits1, bits2, sizeof (scm_t_uint32) * (word_len-1))) - return SCM_BOOL_F; - /* compare partial last words */ - if ((bits1[word_len-1] & last_mask) != (bits2[word_len-1] & last_mask)) - return SCM_BOOL_F; - return SCM_BOOL_T; -} - -int -scm_is_bitvector (SCM vec) -{ - return IS_BITVECTOR (vec); -} - -SCM_DEFINE (scm_bitvector_p, "bitvector?", 1, 0, 0, - (SCM obj), - "Return @code{#t} when @var{obj} is a bitvector, else\n" - "return @code{#f}.") -#define FUNC_NAME s_scm_bitvector_p -{ - return scm_from_bool (scm_is_bitvector (obj)); -} -#undef FUNC_NAME - -SCM -scm_c_make_bitvector (size_t len, SCM fill) -{ - size_t word_len = (len + 31) / 32; - scm_t_uint32 *bits; - SCM res; - - bits = scm_gc_malloc (sizeof (scm_t_uint32) * word_len, - "bitvector"); - SCM_NEWSMOB2 (res, scm_tc16_bitvector, bits, len); - - if (!SCM_UNBNDP (fill)) - scm_bitvector_fill_x (res, fill); - - return res; -} - -SCM_DEFINE (scm_make_bitvector, "make-bitvector", 1, 1, 0, - (SCM len, SCM fill), - "Create a new bitvector of length @var{len} and\n" - "optionally initialize all elements to @var{fill}.") -#define FUNC_NAME s_scm_make_bitvector -{ - return scm_c_make_bitvector (scm_to_size_t (len), fill); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bitvector, "bitvector", 0, 0, 1, - (SCM bits), - "Create a new bitvector with the arguments as elements.") -#define FUNC_NAME s_scm_bitvector -{ - return scm_list_to_bitvector (bits); -} -#undef FUNC_NAME - -size_t -scm_c_bitvector_length (SCM vec) -{ - scm_assert_smob_type (scm_tc16_bitvector, vec); - return BITVECTOR_LENGTH (vec); -} - -SCM_DEFINE (scm_bitvector_length, "bitvector-length", 1, 0, 0, - (SCM vec), - "Return the length of the bitvector @var{vec}.") -#define FUNC_NAME s_scm_bitvector_length -{ - return scm_from_size_t (scm_c_bitvector_length (vec)); -} -#undef FUNC_NAME - -const scm_t_uint32 * -scm_array_handle_bit_elements (scm_t_array_handle *h) -{ - return scm_array_handle_bit_writable_elements (h); -} - -scm_t_uint32 * -scm_array_handle_bit_writable_elements (scm_t_array_handle *h) -{ - SCM vec = h->array; - if (SCM_I_ARRAYP (vec)) - vec = SCM_I_ARRAY_V (vec); - if (IS_BITVECTOR (vec)) - return BITVECTOR_BITS (vec) + h->base/32; - scm_wrong_type_arg_msg (NULL, 0, h->array, "bit array"); -} - -size_t -scm_array_handle_bit_elements_offset (scm_t_array_handle *h) -{ - return h->base % 32; -} - -const scm_t_uint32 * -scm_bitvector_elements (SCM vec, - scm_t_array_handle *h, - size_t *offp, - size_t *lenp, - ssize_t *incp) -{ - return scm_bitvector_writable_elements (vec, h, offp, lenp, incp); -} - - -scm_t_uint32 * -scm_bitvector_writable_elements (SCM vec, - scm_t_array_handle *h, - size_t *offp, - size_t *lenp, - ssize_t *incp) -{ - scm_generalized_vector_get_handle (vec, h); - if (offp) - { - scm_t_array_dim *dim = scm_array_handle_dims (h); - *offp = scm_array_handle_bit_elements_offset (h); - *lenp = dim->ubnd - dim->lbnd + 1; - *incp = dim->inc; - } - return scm_array_handle_bit_writable_elements (h); -} - -SCM -scm_c_bitvector_ref (SCM vec, size_t idx) -{ - scm_t_array_handle handle; - const scm_t_uint32 *bits; - - if (IS_BITVECTOR (vec)) - { - if (idx >= BITVECTOR_LENGTH (vec)) - scm_out_of_range (NULL, scm_from_size_t (idx)); - bits = BITVECTOR_BITS(vec); - return scm_from_bool (bits[idx/32] & (1L << (idx%32))); - } - else - { - SCM res; - size_t len, off; - ssize_t inc; - - bits = scm_bitvector_elements (vec, &handle, &off, &len, &inc); - if (idx >= len) - scm_out_of_range (NULL, scm_from_size_t (idx)); - idx = idx*inc + off; - res = scm_from_bool (bits[idx/32] & (1L << (idx%32))); - scm_array_handle_release (&handle); - return res; - } -} - -SCM_DEFINE (scm_bitvector_ref, "bitvector-ref", 2, 0, 0, - (SCM vec, SCM idx), - "Return the element at index @var{idx} of the bitvector\n" - "@var{vec}.") -#define FUNC_NAME s_scm_bitvector_ref -{ - return scm_c_bitvector_ref (vec, scm_to_size_t (idx)); -} -#undef FUNC_NAME - -void -scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val) -{ - scm_t_array_handle handle; - scm_t_uint32 *bits, mask; - - if (IS_BITVECTOR (vec)) - { - if (idx >= BITVECTOR_LENGTH (vec)) - scm_out_of_range (NULL, scm_from_size_t (idx)); - bits = BITVECTOR_BITS(vec); - } - else - { - size_t len, off; - ssize_t inc; - - bits = scm_bitvector_writable_elements (vec, &handle, &off, &len, &inc); - if (idx >= len) - scm_out_of_range (NULL, scm_from_size_t (idx)); - idx = idx*inc + off; - } - - mask = 1L << (idx%32); - if (scm_is_true (val)) - bits[idx/32] |= mask; - else - bits[idx/32] &= ~mask; - - if (!IS_BITVECTOR (vec)) - scm_array_handle_release (&handle); -} - -SCM_DEFINE (scm_bitvector_set_x, "bitvector-set!", 3, 0, 0, - (SCM vec, SCM idx, SCM val), - "Set the element at index @var{idx} of the bitvector\n" - "@var{vec} when @var{val} is true, else clear it.") -#define FUNC_NAME s_scm_bitvector_set_x -{ - scm_c_bitvector_set_x (vec, scm_to_size_t (idx), val); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bitvector_fill_x, "bitvector-fill!", 2, 0, 0, - (SCM vec, SCM val), - "Set all elements of the bitvector\n" - "@var{vec} when @var{val} is true, else clear them.") -#define FUNC_NAME s_scm_bitvector_fill_x -{ - scm_t_array_handle handle; - size_t off, len; - ssize_t inc; - scm_t_uint32 *bits; - - bits = scm_bitvector_writable_elements (vec, &handle, - &off, &len, &inc); - - if (off == 0 && inc == 1 && len > 0) - { - /* the usual case - */ - size_t word_len = (len + 31) / 32; - scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len); - - if (scm_is_true (val)) - { - memset (bits, 0xFF, sizeof(scm_t_uint32)*(word_len-1)); - bits[word_len-1] |= last_mask; - } - else - { - memset (bits, 0x00, sizeof(scm_t_uint32)*(word_len-1)); - bits[word_len-1] &= ~last_mask; - } - } - else - { - size_t i; - for (i = 0; i < len; i++) - scm_array_handle_set (&handle, i*inc, val); - } - - scm_array_handle_release (&handle); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_list_to_bitvector, "list->bitvector", 1, 0, 0, - (SCM list), - "Return a new bitvector initialized with the elements\n" - "of @var{list}.") -#define FUNC_NAME s_scm_list_to_bitvector -{ - size_t bit_len = scm_to_size_t (scm_length (list)); - SCM vec = scm_c_make_bitvector (bit_len, SCM_UNDEFINED); - size_t word_len = (bit_len+31)/32; - scm_t_array_handle handle; - scm_t_uint32 *bits = scm_bitvector_writable_elements (vec, &handle, - NULL, NULL, NULL); - size_t i, j; - - for (i = 0; i < word_len && scm_is_pair (list); i++, bit_len -= 32) - { - scm_t_uint32 mask = 1; - bits[i] = 0; - for (j = 0; j < 32 && j < bit_len; - j++, mask <<= 1, list = SCM_CDR (list)) - if (scm_is_true (SCM_CAR (list))) - bits[i] |= mask; - } - - scm_array_handle_release (&handle); - - return vec; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bitvector_to_list, "bitvector->list", 1, 0, 0, - (SCM vec), - "Return a new list initialized with the elements\n" - "of the bitvector @var{vec}.") -#define FUNC_NAME s_scm_bitvector_to_list -{ - scm_t_array_handle handle; - size_t off, len; - ssize_t inc; - scm_t_uint32 *bits; - SCM res = SCM_EOL; - - bits = scm_bitvector_writable_elements (vec, &handle, - &off, &len, &inc); - - if (off == 0 && inc == 1) - { - /* the usual case - */ - size_t word_len = (len + 31) / 32; - size_t i, j; - - for (i = 0; i < word_len; i++, len -= 32) - { - scm_t_uint32 mask = 1; - for (j = 0; j < 32 && j < len; j++, mask <<= 1) - res = scm_cons ((bits[i] & mask)? SCM_BOOL_T : SCM_BOOL_F, res); - } - } - else - { - size_t i; - for (i = 0; i < len; i++) - res = scm_cons (scm_array_handle_ref (&handle, i*inc), res); - } - - scm_array_handle_release (&handle); - - return scm_reverse_x (res, SCM_EOL); -} -#undef FUNC_NAME - -/* From mmix-arith.w by Knuth. - - Here's a fun way to count the number of bits in a tetrabyte. - - [This classical trick is called the ``Gillies--Miller method for - sideways addition'' in {\sl The Preparation of Programs for an - Electronic Digital Computer\/} by Wilkes, Wheeler, and Gill, second - edition (Reading, Mass.:\ Addison--Wesley, 1957), 191--193. Some of - the tricks used here were suggested by Balbir Singh, Peter - Rossmanith, and Stefan Schwoon.] -*/ - -static size_t -count_ones (scm_t_uint32 x) -{ - x=x-((x>>1)&0x55555555); - x=(x&0x33333333)+((x>>2)&0x33333333); - x=(x+(x>>4))&0x0f0f0f0f; - x=x+(x>>8); - return (x+(x>>16)) & 0xff; -} - -SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, - (SCM b, SCM bitvector), - "Return the number of occurrences of the boolean @var{b} in\n" - "@var{bitvector}.") -#define FUNC_NAME s_scm_bit_count -{ - scm_t_array_handle handle; - size_t off, len; - ssize_t inc; - scm_t_uint32 *bits; - int bit = scm_to_bool (b); - size_t count = 0; - - bits = scm_bitvector_writable_elements (bitvector, &handle, - &off, &len, &inc); - - if (off == 0 && inc == 1 && len > 0) - { - /* the usual case - */ - size_t word_len = (len + 31) / 32; - scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len); - size_t i; - - for (i = 0; i < word_len-1; i++) - count += count_ones (bits[i]); - count += count_ones (bits[i] & last_mask); - } - else - { - size_t i; - for (i = 0; i < len; i++) - if (scm_is_true (scm_array_handle_ref (&handle, i*inc))) - count++; - } - - scm_array_handle_release (&handle); - - return scm_from_size_t (bit? count : len-count); -} -#undef FUNC_NAME - -/* returns 32 for x == 0. -*/ -static size_t -find_first_one (scm_t_uint32 x) -{ - size_t pos = 0; - /* do a binary search in x. */ - if ((x & 0xFFFF) == 0) - x >>= 16, pos += 16; - if ((x & 0xFF) == 0) - x >>= 8, pos += 8; - if ((x & 0xF) == 0) - x >>= 4, pos += 4; - if ((x & 0x3) == 0) - x >>= 2, pos += 2; - if ((x & 0x1) == 0) - pos += 1; - return pos; -} - -SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, - (SCM item, SCM v, SCM k), - "Return the index of the first occurrance of @var{item} in bit\n" - "vector @var{v}, starting from @var{k}. If there is no\n" - "@var{item} entry between @var{k} and the end of\n" - "@var{bitvector}, then return @code{#f}. For example,\n" - "\n" - "@example\n" - "(bit-position #t #*000101 0) @result{} 3\n" - "(bit-position #f #*0001111 3) @result{} #f\n" - "@end example") -#define FUNC_NAME s_scm_bit_position -{ - scm_t_array_handle handle; - size_t off, len, first_bit; - ssize_t inc; - const scm_t_uint32 *bits; - int bit = scm_to_bool (item); - SCM res = SCM_BOOL_F; - - bits = scm_bitvector_elements (v, &handle, &off, &len, &inc); - first_bit = scm_to_unsigned_integer (k, 0, len); - - if (off == 0 && inc == 1 && len > 0) - { - size_t i, word_len = (len + 31) / 32; - scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len); - size_t first_word = first_bit / 32; - scm_t_uint32 first_mask = - ((scm_t_uint32)-1) << (first_bit - 32*first_word); - scm_t_uint32 w; - - for (i = first_word; i < word_len; i++) - { - w = (bit? bits[i] : ~bits[i]); - if (i == first_word) - w &= first_mask; - if (i == word_len-1) - w &= last_mask; - if (w) - { - res = scm_from_size_t (32*i + find_first_one (w)); - break; - } - } - } - else - { - size_t i; - for (i = first_bit; i < len; i++) - { - SCM elt = scm_array_handle_ref (&handle, i*inc); - if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt))) - { - res = scm_from_size_t (i); - break; - } - } - } - - scm_array_handle_release (&handle); - - return res; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, - (SCM v, SCM kv, SCM obj), - "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n" - "selecting the entries to change. The return value is\n" - "unspecified.\n" - "\n" - "If @var{kv} is a bit vector, then those entries where it has\n" - "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n" - "@var{kv} and @var{v} must be the same length. When @var{obj}\n" - "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n" - "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n" - "\n" - "@example\n" - "(define bv #*01000010)\n" - "(bit-set*! bv #*10010001 #t)\n" - "bv\n" - "@result{} #*11010011\n" - "@end example\n" - "\n" - "If @var{kv} is a u32vector, then its elements are\n" - "indices into @var{v} which are set to @var{obj}.\n" - "\n" - "@example\n" - "(define bv #*01000010)\n" - "(bit-set*! bv #u32(5 2 7) #t)\n" - "bv\n" - "@result{} #*01100111\n" - "@end example") -#define FUNC_NAME s_scm_bit_set_star_x -{ - scm_t_array_handle v_handle; - size_t v_off, v_len; - ssize_t v_inc; - scm_t_uint32 *v_bits; - int bit; - - /* Validate that OBJ is a boolean so this is done even if we don't - need BIT. - */ - bit = scm_to_bool (obj); - - v_bits = scm_bitvector_writable_elements (v, &v_handle, - &v_off, &v_len, &v_inc); - - if (scm_is_bitvector (kv)) - { - scm_t_array_handle kv_handle; - size_t kv_off, kv_len; - ssize_t kv_inc; - const scm_t_uint32 *kv_bits; - - kv_bits = scm_bitvector_elements (v, &kv_handle, - &kv_off, &kv_len, &kv_inc); - - if (v_len != kv_len) - scm_misc_error (NULL, - "bit vectors must have equal length", - SCM_EOL); - - if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0) - { - size_t word_len = (kv_len + 31) / 32; - scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len); - size_t i; - - if (bit == 0) - { - for (i = 0; i < word_len-1; i++) - v_bits[i] &= ~kv_bits[i]; - v_bits[i] &= ~(kv_bits[i] & last_mask); - } - else - { - for (i = 0; i < word_len-1; i++) - v_bits[i] |= kv_bits[i]; - v_bits[i] |= kv_bits[i] & last_mask; - } - } - else - { - size_t i; - for (i = 0; i < kv_len; i++) - if (scm_is_true (scm_array_handle_ref (&kv_handle, i*kv_inc))) - scm_array_handle_set (&v_handle, i*v_inc, obj); - } - - scm_array_handle_release (&kv_handle); - - } - else if (scm_is_true (scm_u32vector_p (kv))) - { - scm_t_array_handle kv_handle; - size_t i, kv_len; - ssize_t kv_inc; - const scm_t_uint32 *kv_elts; - - kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc); - for (i = 0; i < kv_len; i++, kv_elts += kv_inc) - scm_array_handle_set (&v_handle, (*kv_elts)*v_inc, obj); - - scm_array_handle_release (&kv_handle); - } - else - scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector"); - - scm_array_handle_release (&v_handle); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, - (SCM v, SCM kv, SCM obj), - "Return a count of how many entries in bit vector @var{v} are\n" - "equal to @var{obj}, with @var{kv} selecting the entries to\n" - "consider.\n" - "\n" - "If @var{kv} is a bit vector, then those entries where it has\n" - "@code{#t} are the ones in @var{v} which are considered.\n" - "@var{kv} and @var{v} must be the same length.\n" - "\n" - "If @var{kv} is a u32vector, then it contains\n" - "the indexes in @var{v} to consider.\n" - "\n" - "For example,\n" - "\n" - "@example\n" - "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n" - "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n" - "@end example") -#define FUNC_NAME s_scm_bit_count_star -{ - scm_t_array_handle v_handle; - size_t v_off, v_len; - ssize_t v_inc; - const scm_t_uint32 *v_bits; - size_t count = 0; - int bit; - - /* Validate that OBJ is a boolean so this is done even if we don't - need BIT. - */ - bit = scm_to_bool (obj); - - v_bits = scm_bitvector_elements (v, &v_handle, - &v_off, &v_len, &v_inc); - - if (scm_is_bitvector (kv)) - { - scm_t_array_handle kv_handle; - size_t kv_off, kv_len; - ssize_t kv_inc; - const scm_t_uint32 *kv_bits; - - kv_bits = scm_bitvector_elements (v, &kv_handle, - &kv_off, &kv_len, &kv_inc); - - if (v_len != kv_len) - scm_misc_error (NULL, - "bit vectors must have equal length", - SCM_EOL); - - if (v_off == 0 && v_inc == 1 && kv_off == 0 && kv_inc == 1 && kv_len > 0) - { - size_t i, word_len = (kv_len + 31) / 32; - scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - kv_len); - scm_t_uint32 xor_mask = bit? 0 : ((scm_t_uint32)-1); - - for (i = 0; i < word_len-1; i++) - count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i]); - count += count_ones ((v_bits[i]^xor_mask) & kv_bits[i] & last_mask); - } - else - { - size_t i; - for (i = 0; i < kv_len; i++) - if (scm_is_true (scm_array_handle_ref (&kv_handle, i))) - { - SCM elt = scm_array_handle_ref (&v_handle, i*v_inc); - if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt))) - count++; - } - } - - scm_array_handle_release (&kv_handle); - - } - else if (scm_is_true (scm_u32vector_p (kv))) - { - scm_t_array_handle kv_handle; - size_t i, kv_len; - ssize_t kv_inc; - const scm_t_uint32 *kv_elts; - - kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc); - for (i = 0; i < kv_len; i++, kv_elts += kv_inc) - { - SCM elt = scm_array_handle_ref (&v_handle, (*kv_elts)*v_inc); - if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt))) - count++; - } - - scm_array_handle_release (&kv_handle); - } - else - scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector"); - - scm_array_handle_release (&v_handle); - - return scm_from_size_t (count); -} -#undef FUNC_NAME - -SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0, - (SCM v), - "Modify the bit vector @var{v} by replacing each element with\n" - "its negation.") -#define FUNC_NAME s_scm_bit_invert_x -{ - scm_t_array_handle handle; - size_t off, len; - ssize_t inc; - scm_t_uint32 *bits; - - bits = scm_bitvector_writable_elements (v, &handle, &off, &len, &inc); - - if (off == 0 && inc == 1 && len > 0) - { - size_t word_len = (len + 31) / 32; - scm_t_uint32 last_mask = ((scm_t_uint32)-1) >> (32*word_len - len); - size_t i; - - for (i = 0; i < word_len-1; i++) - bits[i] = ~bits[i]; - bits[i] = bits[i] ^ last_mask; - } - else - { - size_t i; - for (i = 0; i < len; i++) - scm_array_handle_set (&handle, i*inc, - scm_not (scm_array_handle_ref (&handle, i*inc))); - } - - scm_array_handle_release (&handle); - - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM -scm_istr2bve (SCM str) -{ - scm_t_array_handle handle; - size_t len = scm_i_string_length (str); - SCM vec = scm_c_make_bitvector (len, SCM_UNDEFINED); - SCM res = vec; - - scm_t_uint32 mask; - size_t k, j; - const char *c_str; - scm_t_uint32 *data; - - data = scm_bitvector_writable_elements (vec, &handle, NULL, NULL, NULL); - c_str = scm_i_string_chars (str); - - for (k = 0; k < (len + 31) / 32; k++) - { - data[k] = 0L; - j = len - k * 32; - if (j > 32) - j = 32; - for (mask = 1L; j--; mask <<= 1) - switch (*c_str++) - { - case '0': - break; - case '1': - data[k] |= mask; - break; - default: - res = SCM_BOOL_F; - goto exit; - } - } - - exit: - scm_array_handle_release (&handle); - scm_remember_upto_here_1 (str); - return res; -} - - - -static SCM -ra2l (SCM ra, unsigned long base, unsigned long k) -{ - SCM res = SCM_EOL; - long inc; - size_t i; - int enclosed = SCM_I_ENCLOSED_ARRAYP (ra); - - if (k == SCM_I_ARRAY_NDIM (ra)) - return scm_i_cvref (SCM_I_ARRAY_V (ra), base, enclosed); - - inc = SCM_I_ARRAY_DIMS (ra)[k].inc; - if (SCM_I_ARRAY_DIMS (ra)[k].ubnd < SCM_I_ARRAY_DIMS (ra)[k].lbnd) - return SCM_EOL; - i = base + (1 + SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd) * inc; - do - { - i -= inc; - res = scm_cons (ra2l (ra, i, k + 1), res); - } - while (i != base); - return res; -} - - -SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, - (SCM v), - "Return a list consisting of all the elements, in order, of\n" - "@var{array}.") -#define FUNC_NAME s_scm_array_to_list -{ - if (scm_is_generalized_vector (v)) - return scm_generalized_vector_to_list (v); - else if (SCM_I_ARRAYP (v) || SCM_I_ENCLOSED_ARRAYP (v)) - return ra2l (v, SCM_I_ARRAY_BASE (v), 0); - - scm_wrong_type_arg_msg (NULL, 0, v, "array"); -} -#undef FUNC_NAME - - -static void l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k); - -SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0, - (SCM type, SCM shape, SCM lst), - "Return an array of the type @var{type}\n" - "with elements the same as those of @var{lst}.\n" - "\n" - "The argument @var{shape} determines the number of dimensions\n" - "of the array and their shape. It is either an exact integer,\n" - "giving the\n" - "number of dimensions directly, or a list whose length\n" - "specifies the number of dimensions and each element specified\n" - "the lower and optionally the upper bound of the corresponding\n" - "dimension.\n" - "When the element is list of two elements, these elements\n" - "give the lower and upper bounds. When it is an exact\n" - "integer, it gives only the lower bound.") -#define FUNC_NAME s_scm_list_to_typed_array -{ - SCM row; - SCM ra; - scm_t_array_handle handle; - - row = lst; - if (scm_is_integer (shape)) - { - size_t k = scm_to_size_t (shape); - shape = SCM_EOL; - while (k-- > 0) - { - shape = scm_cons (scm_length (row), shape); - if (k > 0 && !scm_is_null (row)) - row = scm_car (row); - } - } - else - { - SCM shape_spec = shape; - shape = SCM_EOL; - while (1) - { - SCM spec = scm_car (shape_spec); - if (scm_is_pair (spec)) - shape = scm_cons (spec, shape); - else - shape = scm_cons (scm_list_2 (spec, - scm_sum (scm_sum (spec, - scm_length (row)), - scm_from_int (-1))), - shape); - shape_spec = scm_cdr (shape_spec); - if (scm_is_pair (shape_spec)) - { - if (!scm_is_null (row)) - row = scm_car (row); - } - else - break; - } - } - - ra = scm_make_typed_array (type, SCM_UNSPECIFIED, - scm_reverse_x (shape, SCM_EOL)); - - scm_array_get_handle (ra, &handle); - l2ra (lst, &handle, 0, 0); - scm_array_handle_release (&handle); - - return ra; -} -#undef FUNC_NAME - -SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0, - (SCM ndim, SCM lst), - "Return an array with elements the same as those of @var{lst}.") -#define FUNC_NAME s_scm_list_to_array -{ - return scm_list_to_typed_array (SCM_BOOL_T, ndim, lst); -} -#undef FUNC_NAME - -static void -l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k) -{ - if (k == scm_array_handle_rank (handle)) - scm_array_handle_set (handle, pos, lst); - else - { - scm_t_array_dim *dim = scm_array_handle_dims (handle) + k; - ssize_t inc = dim->inc; - size_t len = 1 + dim->ubnd - dim->lbnd, n; - char *errmsg = NULL; - - n = len; - while (n > 0 && scm_is_pair (lst)) - { - l2ra (SCM_CAR (lst), handle, pos, k + 1); - pos += inc; - lst = SCM_CDR (lst); - n -= 1; - } - if (n != 0) - errmsg = "too few elements for array dimension ~a, need ~a"; - if (!scm_is_null (lst)) - errmsg = "too many elements for array dimension ~a, want ~a"; - if (errmsg) - scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k), - scm_from_size_t (len))); - } -} - -#if SCM_ENABLE_DEPRECATED - -SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0, - (SCM ndim, SCM prot, SCM lst), - "Return a uniform array of the type indicated by prototype\n" - "@var{prot} with elements the same as those of @var{lst}.\n" - "Elements must be of the appropriate type, no coercions are\n" - "done.\n" - "\n" - "The argument @var{ndim} determines the number of dimensions\n" - "of the array. It is either an exact integer, giving the\n" - "number directly, or a list of exact integers, whose length\n" - "specifies the number of dimensions and each element is the\n" - "lower index bound of its dimension.") -#define FUNC_NAME s_scm_list_to_uniform_array -{ - return scm_list_to_typed_array (prototype_to_type (prot), ndim, lst); -} -#undef FUNC_NAME - -#endif - -/* Print dimension DIM of ARRAY. - */ - -static int -scm_i_print_array_dimension (SCM array, int dim, int base, int enclosed, - SCM port, scm_print_state *pstate) -{ - scm_t_array_dim *dim_spec = SCM_I_ARRAY_DIMS (array) + dim; - long idx; - - scm_putc ('(', port); - - for (idx = dim_spec->lbnd; idx <= dim_spec->ubnd; idx++) - { - if (dim < SCM_I_ARRAY_NDIM(array)-1) - scm_i_print_array_dimension (array, dim+1, base, enclosed, - port, pstate); - else - scm_iprin1 (scm_i_cvref (SCM_I_ARRAY_V (array), base, enclosed), - port, pstate); - if (idx < dim_spec->ubnd) - scm_putc (' ', port); - base += dim_spec->inc; - } - - scm_putc (')', port); - return 1; -} - -/* Print an array. (Only for strict arrays, not for generalized vectors.) -*/ - -static int -scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) -{ - long ndim = SCM_I_ARRAY_NDIM (array); - scm_t_array_dim *dim_specs = SCM_I_ARRAY_DIMS (array); - SCM v = SCM_I_ARRAY_V (array); - unsigned long base = SCM_I_ARRAY_BASE (array); - long i; - int print_lbnds = 0, zero_size = 0, print_lens = 0; - - scm_putc ('#', port); - if (ndim != 1 || dim_specs[0].lbnd != 0) - scm_intprint (ndim, 10, port); - if (scm_is_uniform_vector (v)) - scm_puts (scm_i_uniform_vector_tag (v), port); - else if (scm_is_bitvector (v)) - scm_puts ("b", port); - else if (scm_is_string (v)) - scm_puts ("a", port); - else if (!scm_is_vector (v)) - scm_puts ("?", port); - - for (i = 0; i < ndim; i++) - { - if (dim_specs[i].lbnd != 0) - print_lbnds = 1; - if (dim_specs[i].ubnd - dim_specs[i].lbnd + 1 == 0) - zero_size = 1; - else if (zero_size) - print_lens = 1; - } - - if (print_lbnds || print_lens) - for (i = 0; i < ndim; i++) - { - if (print_lbnds) - { - scm_putc ('@', port); - scm_intprint (dim_specs[i].lbnd, 10, port); - } - if (print_lens) - { - scm_putc (':', port); - scm_intprint (dim_specs[i].ubnd - dim_specs[i].lbnd + 1, - 10, port); - } - } - - if (ndim == 0) - { - /* Rank zero arrays, which are really just scalars, are printed - specially. The consequent way would be to print them as - - #0 OBJ - - where OBJ is the printed representation of the scalar, but we - print them instead as - - #0(OBJ) - - to make them look less strange. - - Just printing them as - - OBJ - - would be correct in a way as well, but zero rank arrays are - not really the same as Scheme values since they are boxed and - can be modified with array-set!, say. - */ - scm_putc ('(', port); - scm_iprin1 (scm_i_cvref (v, base, 0), port, pstate); - scm_putc (')', port); - return 1; - } - else - return scm_i_print_array_dimension (array, 0, base, 0, port, pstate); -} - -static int -scm_i_print_enclosed_array (SCM array, SCM port, scm_print_state *pstate) -{ - size_t base; - - scm_putc ('#', port); - base = SCM_I_ARRAY_BASE (array); - scm_puts ("<enclosed-array ", port); - scm_i_print_array_dimension (array, 0, base, 1, port, pstate); - scm_putc ('>', port); - return 1; -} - -/* Read an array. This function can also read vectors and uniform - vectors. Also, the conflict between '#f' and '#f32' and '#f64' is - handled here. - - C is the first character read after the '#'. -*/ - -static SCM -tag_to_type (const char *tag, SCM port) -{ -#if SCM_ENABLE_DEPRECATED - { - /* Recognize the old syntax. - */ - const char *instead; - switch (tag[0]) - { - case 'u': - instead = "u32"; - break; - case 'e': - instead = "s32"; - break; - case 's': - instead = "f32"; - break; - case 'i': - instead = "f64"; - break; - case 'y': - instead = "s8"; - break; - case 'h': - instead = "s16"; - break; - case 'l': - instead = "s64"; - break; - case 'c': - instead = "c64"; - break; - default: - instead = NULL; - break; - } - - if (instead && tag[1] == '\0') - { - scm_c_issue_deprecation_warning_fmt - ("The tag '%c' is deprecated for uniform vectors. " - "Use '%s' instead.", tag[0], instead); - return scm_from_locale_symbol (instead); - } - } -#endif - - if (*tag == '\0') - return SCM_BOOL_T; - else - return scm_from_locale_symbol (tag); -} - -static int -read_decimal_integer (SCM port, int c, ssize_t *resp) -{ - ssize_t sign = 1; - ssize_t res = 0; - int got_it = 0; - - if (c == '-') - { - sign = -1; - c = scm_getc (port); - } - - while ('0' <= c && c <= '9') - { - res = 10*res + c-'0'; - got_it = 1; - c = scm_getc (port); - } - - if (got_it) - *resp = sign * res; - return c; -} - -SCM -scm_i_read_array (SCM port, int c) -{ - ssize_t rank; - int got_rank; - char tag[80]; - int tag_len; - - SCM shape = SCM_BOOL_F, elements; - - /* XXX - shortcut for ordinary vectors. Shouldn't be necessary but - the array code can not deal with zero-length dimensions yet, and - we want to allow zero-length vectors, of course. - */ - if (c == '(') - { - scm_ungetc (c, port); - return scm_vector (scm_read (port)); - } - - /* Disambiguate between '#f' and uniform floating point vectors. - */ - if (c == 'f') - { - c = scm_getc (port); - if (c != '3' && c != '6') - { - if (c != EOF) - scm_ungetc (c, port); - return SCM_BOOL_F; - } - rank = 1; - got_rank = 1; - tag[0] = 'f'; - tag_len = 1; - goto continue_reading_tag; - } - - /* Read rank. - */ - rank = 1; - c = read_decimal_integer (port, c, &rank); - if (rank < 0) - scm_i_input_error (NULL, port, "array rank must be non-negative", - SCM_EOL); - - /* Read tag. - */ - tag_len = 0; - continue_reading_tag: - while (c != EOF && c != '(' && c != '@' && c != ':' && tag_len < 80) - { - tag[tag_len++] = c; - c = scm_getc (port); - } - tag[tag_len] = '\0'; - - /* Read shape. - */ - if (c == '@' || c == ':') - { - shape = SCM_EOL; - - do - { - ssize_t lbnd = 0, len = 0; - SCM s; - - if (c == '@') - { - c = scm_getc (port); - c = read_decimal_integer (port, c, &lbnd); - } - - s = scm_from_ssize_t (lbnd); - - if (c == ':') - { - c = scm_getc (port); - c = read_decimal_integer (port, c, &len); - if (len < 0) - scm_i_input_error (NULL, port, - "array length must be non-negative", - SCM_EOL); - - s = scm_list_2 (s, scm_from_ssize_t (lbnd+len-1)); - } - - shape = scm_cons (s, shape); - } while (c == '@' || c == ':'); - - shape = scm_reverse_x (shape, SCM_EOL); - } - - /* Read nested lists of elements. - */ - if (c != '(') - scm_i_input_error (NULL, port, - "missing '(' in vector or array literal", - SCM_EOL); - scm_ungetc (c, port); - elements = scm_read (port); - - if (scm_is_false (shape)) - shape = scm_from_ssize_t (rank); - else if (scm_ilength (shape) != rank) - scm_i_input_error - (NULL, port, - "the number of shape specifications must match the array rank", - SCM_EOL); - - /* Handle special print syntax of rank zero arrays; see - scm_i_print_array for a rationale. - */ - if (rank == 0) - { - if (!scm_is_pair (elements)) - scm_i_input_error (NULL, port, - "too few elements in array literal, need 1", - SCM_EOL); - if (!scm_is_null (SCM_CDR (elements))) - scm_i_input_error (NULL, port, - "too many elements in array literal, want 1", - SCM_EOL); - elements = SCM_CAR (elements); - } - - /* Construct array. - */ - return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements); -} - -SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0, - (SCM ra), - "") -#define FUNC_NAME s_scm_array_type -{ - if (SCM_I_ARRAYP (ra)) - return scm_i_generalized_vector_type (SCM_I_ARRAY_V (ra)); - else if (scm_is_generalized_vector (ra)) - return scm_i_generalized_vector_type (ra); - else if (SCM_I_ENCLOSED_ARRAYP (ra)) - scm_wrong_type_arg_msg (NULL, 0, ra, "non-enclosed array"); - else - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); -} -#undef FUNC_NAME - -#if SCM_ENABLE_DEPRECATED - -SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0, - (SCM ra), - "Return an object that would produce an array of the same type\n" - "as @var{array}, if used as the @var{prototype} for\n" - "@code{make-uniform-array}.") -#define FUNC_NAME s_scm_array_prototype -{ - if (SCM_I_ARRAYP (ra)) - return scm_i_get_old_prototype (SCM_I_ARRAY_V (ra)); - else if (scm_is_generalized_vector (ra)) - return scm_i_get_old_prototype (ra); - else if (SCM_I_ENCLOSED_ARRAYP (ra)) - return SCM_UNSPECIFIED; - else - scm_wrong_type_arg_msg (NULL, 0, ra, "array"); -} -#undef FUNC_NAME - -#endif - - -#if SCM_ENABLE_DEPRECATED - -SCM -scm_make_ra (int ndim) -{ - scm_c_issue_deprecation_warning - ("scm_make_ra is deprecated. Use scm_make_array or similar instead."); - return scm_i_make_ra (ndim, 0); -} - -SCM -scm_shap2ra (SCM args, const char *what) -{ - scm_c_issue_deprecation_warning - ("scm_shap2ra is deprecated. Use scm_make_array or similar instead."); - return scm_i_shap2ra (args); -} - -SCM -scm_cvref (SCM v, unsigned long pos, SCM last) -{ - scm_c_issue_deprecation_warning - ("scm_cvref is deprecated. Use scm_c_generalized_vector_ref instead."); - return scm_c_generalized_vector_ref (v, pos); -} - -void -scm_ra_set_contp (SCM ra) -{ - scm_c_issue_deprecation_warning - ("scm_ra_set_contp is deprecated. There should be no need for it."); - scm_i_ra_set_contp (ra); -} - -long -scm_aind (SCM ra, SCM args, const char *what) -{ - scm_t_array_handle handle; - ssize_t pos; - - scm_c_issue_deprecation_warning - ("scm_aind is deprecated. Use scm_array_handle_pos instead."); - - if (scm_is_integer (args)) - args = scm_list_1 (args); - - scm_array_get_handle (ra, &handle); - pos = scm_array_handle_pos (&handle, args) + SCM_I_ARRAY_BASE (ra); - scm_array_handle_release (&handle); - return pos; -} - -int -scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate) -{ - scm_c_issue_deprecation_warning - ("scm_raprin1 is deprecated. Use scm_display or scm_write instead."); - - scm_iprin1 (exp, port, pstate); - return 1; -} - -#endif - -void -scm_init_unif () -{ - scm_i_tc16_array = scm_make_smob_type ("array", 0); - scm_set_smob_print (scm_i_tc16_array, scm_i_print_array); - scm_set_smob_equalp (scm_i_tc16_array, scm_array_equal_p); - - scm_i_tc16_enclosed_array = scm_make_smob_type ("enclosed-array", 0); - scm_set_smob_print (scm_i_tc16_enclosed_array, scm_i_print_enclosed_array); - scm_set_smob_equalp (scm_i_tc16_enclosed_array, scm_array_equal_p); - - scm_add_feature ("array"); - - scm_tc16_bitvector = scm_make_smob_type ("bitvector", 0); - scm_set_smob_print (scm_tc16_bitvector, bitvector_print); - scm_set_smob_equalp (scm_tc16_bitvector, bitvector_equalp); - - init_type_creator_table (); - -#include "libguile/unif.x" - -} - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/unif.h b/libguile/unif.h deleted file mode 100644 index a09bfc921..000000000 --- a/libguile/unif.h +++ /dev/null @@ -1,194 +0,0 @@ -/* classes: h_files */ - -#ifndef SCM_UNIF_H -#define SCM_UNIF_H - -/* 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. - * - * 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" -#include "libguile/print.h" - - - -/* This file contains the definitions for arrays and bit vectors. - Uniform numeric vectors are now in srfi-4.c. -*/ - - -/** Arrays */ - -typedef struct scm_t_array_dim -{ - ssize_t lbnd; - ssize_t ubnd; - ssize_t inc; -} scm_t_array_dim; - -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_array_rank (SCM ra); -SCM_API size_t scm_c_array_rank (SCM ra); -SCM_API SCM scm_array_dimensions (SCM ra); -SCM_API SCM scm_shared_array_root (SCM ra); -SCM_API SCM scm_shared_array_offset (SCM ra); -SCM_API SCM scm_shared_array_increments (SCM ra); -SCM_API SCM scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims); -SCM_API SCM scm_transpose_array (SCM ra, SCM args); -SCM_API SCM scm_enclose_array (SCM ra, SCM axes); -SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args); -SCM_API SCM scm_array_ref (SCM v, SCM args); -SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args); -SCM_API SCM scm_array_contents (SCM ra, SCM strict); -SCM_API SCM scm_uniform_array_read_x (SCM ra, SCM port_or_fd, - SCM start, SCM end); -SCM_API SCM scm_uniform_array_write (SCM v, SCM port_or_fd, - SCM start, SCM end); -SCM_API SCM scm_array_to_list (SCM v); -SCM_API SCM scm_list_to_array (SCM ndim, SCM lst); -SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst); -SCM_API SCM scm_array_type (SCM ra); - -SCM_API int scm_is_array (SCM obj); -SCM_API int scm_is_typed_array (SCM obj, SCM type); - -SCM_API SCM scm_ra2contig (SCM ra, int copy); - -struct scm_t_array_handle; - -typedef SCM (*scm_i_t_array_ref) (struct scm_t_array_handle *, ssize_t); -typedef void (*scm_i_t_array_set) (struct scm_t_array_handle *, ssize_t, SCM); - -typedef struct scm_t_array_handle { - SCM array; - size_t base; - scm_t_array_dim *dims; - scm_t_array_dim dim0; - scm_i_t_array_ref ref; - scm_i_t_array_set set; - const void *elements; - void *writable_elements; -} scm_t_array_handle; - -SCM_API void scm_array_get_handle (SCM array, scm_t_array_handle *h); -SCM_API size_t scm_array_handle_rank (scm_t_array_handle *h); -SCM_API scm_t_array_dim *scm_array_handle_dims (scm_t_array_handle *h); -SCM_API ssize_t scm_array_handle_pos (scm_t_array_handle *h, SCM indices); -SCM_API const SCM *scm_array_handle_elements (scm_t_array_handle *h); -SCM_API SCM *scm_array_handle_writable_elements (scm_t_array_handle *h); -SCM_API void scm_array_handle_release (scm_t_array_handle *h); - -/* See inline.h for scm_array_handle_ref and scm_array_handle_set */ - - -/** Bit vectors */ - -SCM_API SCM scm_bitvector_p (SCM vec); -SCM_API SCM scm_bitvector (SCM bits); -SCM_API SCM scm_make_bitvector (SCM len, SCM fill); -SCM_API SCM scm_bitvector_length (SCM vec); -SCM_API SCM scm_bitvector_ref (SCM vec, SCM idx); -SCM_API SCM scm_bitvector_set_x (SCM vec, SCM idx, SCM val); -SCM_API SCM scm_list_to_bitvector (SCM list); -SCM_API SCM scm_bitvector_to_list (SCM vec); -SCM_API SCM scm_bitvector_fill_x (SCM vec, SCM val); - -SCM_API SCM scm_bit_count (SCM item, SCM seq); -SCM_API SCM scm_bit_position (SCM item, SCM v, SCM k); -SCM_API SCM scm_bit_set_star_x (SCM v, SCM kv, SCM obj); -SCM_API SCM scm_bit_count_star (SCM v, SCM kv, SCM obj); -SCM_API SCM scm_bit_invert_x (SCM v); -SCM_API SCM scm_istr2bve (SCM str); - -SCM_API int scm_is_bitvector (SCM obj); -SCM_API SCM scm_c_make_bitvector (size_t len, SCM fill); -SCM_API size_t scm_c_bitvector_length (SCM vec); -SCM_API SCM scm_c_bitvector_ref (SCM vec, size_t idx); -SCM_API void scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val); -SCM_API const scm_t_uint32 *scm_array_handle_bit_elements (scm_t_array_handle *h); -SCM_API scm_t_uint32 *scm_array_handle_bit_writable_elements (scm_t_array_handle *h); -SCM_API size_t scm_array_handle_bit_elements_offset (scm_t_array_handle *h); -SCM_API const scm_t_uint32 *scm_bitvector_elements (SCM vec, - scm_t_array_handle *h, - size_t *offp, - size_t *lenp, - ssize_t *incp); -SCM_API scm_t_uint32 *scm_bitvector_writable_elements (SCM vec, - scm_t_array_handle *h, - size_t *offp, - size_t *lenp, - ssize_t *incp); - -/* internal. */ - -typedef struct scm_i_t_array -{ - SCM v; /* the contents of the array, e.g., a vector or uniform vector. */ - unsigned long base; -} scm_i_t_array; - -SCM_API scm_t_bits scm_i_tc16_array; -SCM_API scm_t_bits scm_i_tc16_enclosed_array; - -#define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 16) - -#define SCM_I_ARRAYP(a) SCM_TYP16_PREDICATE (scm_i_tc16_array, a) -#define SCM_I_ENCLOSED_ARRAYP(a) \ - SCM_TYP16_PREDICATE (scm_i_tc16_enclosed_array, a) -#define SCM_I_ARRAY_NDIM(x) ((size_t) (SCM_CELL_WORD_0 (x) >> 17)) -#define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0(x) & SCM_I_ARRAY_FLAG_CONTIGUOUS) - -#define SCM_I_ARRAY_MEM(a) ((scm_i_t_array *) SCM_CELL_WORD_1 (a)) -#define SCM_I_ARRAY_V(a) (SCM_I_ARRAY_MEM (a)->v) -#define SCM_I_ARRAY_BASE(a) (SCM_I_ARRAY_MEM (a)->base) -#define SCM_I_ARRAY_DIMS(a) \ - ((scm_t_array_dim *)((char *) SCM_I_ARRAY_MEM (a) + sizeof (scm_i_t_array))) - -SCM_INTERNAL SCM scm_i_make_ra (int ndim, int enclosed); -SCM_INTERNAL SCM scm_i_cvref (SCM v, size_t p, int enclosed); -SCM_INTERNAL SCM scm_i_read_array (SCM port, int c); - -/* deprecated. */ - -#if SCM_ENABLE_DEPRECATED - -SCM_API SCM scm_make_uve (long k, SCM prot); -SCM_API SCM scm_array_prototype (SCM ra); -SCM_API SCM scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst); -SCM_API SCM scm_dimensions_to_uniform_array (SCM dims, SCM prot, SCM fill); -SCM_API SCM scm_make_ra (int ndim); -SCM_API SCM scm_shap2ra (SCM args, const char *what); -SCM_API SCM scm_cvref (SCM v, unsigned long pos, SCM last); -SCM_API void scm_ra_set_contp (SCM ra); -SCM_API long scm_aind (SCM ra, SCM args, const char *what); -SCM_API int scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate); - -#endif - -SCM_INTERNAL void scm_init_unif (void); - -#endif /* SCM_UNIF_H */ - -/* - Local Variables: - c-file-style: "gnu" - End: -*/ diff --git a/libguile/uniform.c b/libguile/uniform.c new file mode 100644 index 000000000..28125da8b --- /dev/null +++ b/libguile/uniform.c @@ -0,0 +1,254 @@ +/* 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 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 <assert.h> + +#include "libguile/_scm.h" +#include "libguile/__scm.h" + +#include "libguile/uniform.h" + + +const size_t scm_i_array_element_type_sizes[SCM_ARRAY_ELEMENT_TYPE_LAST + 1] = { + 0, + 0, + 1, + 8, + 8, 8, + 16, 16, + 32, 32, + 64, 64, + 32, 64, + 64, 128 +}; + +/* FIXME: return bit size instead of byte size? */ +size_t +scm_array_handle_uniform_element_size (scm_t_array_handle *h) +{ + size_t ret = scm_i_array_element_type_sizes[h->element_type]; + if (ret && ret % 8 == 0) + return ret / 8; + else + scm_wrong_type_arg_msg (NULL, 0, h->array, "uniform array"); +} + +const void * +scm_array_handle_uniform_elements (scm_t_array_handle *h) +{ + return scm_array_handle_uniform_writable_elements (h); +} + +void * +scm_array_handle_uniform_writable_elements (scm_t_array_handle *h) +{ + size_t esize; + scm_t_uint8 *ret; + + esize = scm_array_handle_uniform_element_size (h); + ret = ((scm_t_uint8*) h->writable_elements) + h->base * esize; + return ret; +} + +int +scm_is_uniform_vector (SCM obj) +{ + scm_t_array_handle h; + int ret = 0; + + if (scm_is_generalized_vector (obj)) + { + scm_generalized_vector_get_handle (obj, &h); + ret = SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED (h.element_type); + scm_array_handle_release (&h); + } + return ret; +} + +size_t +scm_c_uniform_vector_length (SCM uvec) +{ + scm_t_array_handle h; + size_t len; + ssize_t inc; + + scm_uniform_vector_elements (uvec, &h, &len, &inc); + scm_array_handle_release (&h); + return len; +} + +SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0, + (SCM obj), + "Return @code{#t} if @var{obj} is a uniform vector.") +#define FUNC_NAME s_scm_uniform_vector_p +{ + return scm_from_bool (scm_is_uniform_vector (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_uniform_vector_element_type, "uniform-vector-element-type", 1, 0, 0, + (SCM v), + "Return the number of elements in the uniform vector, @var{v}.") +#define FUNC_NAME s_scm_uniform_vector_element_type +{ + scm_t_array_handle h; + size_t len; + ssize_t inc; + SCM ret; + scm_uniform_vector_elements (v, &h, &len, &inc); + ret = scm_array_handle_element_type (&h); + scm_array_handle_release (&h); + return ret; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_uniform_vector_element_size, "uniform-vector-element-size", 1, 0, 0, + (SCM v), + "Return the number of bytes allocated to each element in the\n" + "uniform vector, @var{v}.") +#define FUNC_NAME s_scm_uniform_vector_element_size +{ + scm_t_array_handle h; + size_t len; + ssize_t inc; + SCM ret; + scm_uniform_vector_elements (v, &h, &len, &inc); + ret = scm_from_size_t (scm_array_handle_uniform_element_size (&h)); + scm_array_handle_release (&h); + return ret; +} +#undef FUNC_NAME + +SCM +scm_c_uniform_vector_ref (SCM v, size_t idx) +{ + SCM ret; + scm_t_array_handle h; + size_t len; + ssize_t inc; + + scm_uniform_vector_elements (v, &h, &len, &inc); + ret = scm_array_handle_ref (&h, idx*inc); + scm_array_handle_release (&h); + return ret; +} + +SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, + (SCM v, SCM idx), + "Return the element at index @var{idx} of the\n" + "homogenous numeric vector @var{v}.") +#define FUNC_NAME s_scm_uniform_vector_ref +{ + return scm_c_uniform_vector_ref (v, scm_to_size_t (idx)); +} +#undef FUNC_NAME + +void +scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val) +{ + scm_t_array_handle h; + size_t len; + ssize_t inc; + + scm_uniform_vector_elements (v, &h, &len, &inc); + scm_array_handle_set (&h, idx*inc, val); + scm_array_handle_release (&h); +} + +SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0, + (SCM v, SCM idx, SCM val), + "Set the element at index @var{idx} of the\n" + "homogenous numeric vector @var{v} to @var{val}.") +#define FUNC_NAME s_scm_uniform_vector_set_x +{ + scm_c_uniform_vector_set_x (v, scm_to_size_t (idx), val); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0, + (SCM uvec), + "Convert the uniform numeric vector @var{uvec} to a list.") +#define FUNC_NAME s_scm_uniform_vector_to_list +{ + SCM ret; + scm_t_array_handle h; + size_t len; + ssize_t inc; + + scm_uniform_vector_elements (uvec, &h, &len, &inc); + ret = scm_generalized_vector_to_list (uvec); + scm_array_handle_release (&h); + return ret; +} +#undef FUNC_NAME + +const void * +scm_uniform_vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp) +{ + return scm_uniform_vector_writable_elements (uvec, h, lenp, incp); +} + +void * +scm_uniform_vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp) +{ + void *ret; + scm_generalized_vector_get_handle (uvec, h); + /* FIXME nonlocal exit */ + ret = scm_array_handle_uniform_writable_elements (h); + if (lenp) + { + scm_t_array_dim *dim = scm_array_handle_dims (h); + *lenp = dim->ubnd - dim->lbnd + 1; + *incp = dim->inc; + } + return ret; +} + +SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, + (SCM v), + "Return the number of elements in the uniform vector @var{v}.") +#define FUNC_NAME s_scm_uniform_vector_length +{ + return scm_from_size_t (scm_c_uniform_vector_length (v)); +} +#undef FUNC_NAME + + +void +scm_init_uniform (void) +{ +#include "libguile/uniform.x" +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/uniform.h b/libguile/uniform.h new file mode 100644 index 000000000..b1f396594 --- /dev/null +++ b/libguile/uniform.h @@ -0,0 +1,77 @@ +/* classes: h_files */ + +#ifndef SCM_UNIFORM_H +#define SCM_UNIFORM_H + +/* Copyright (C) 1995,1996,1997,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 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" +#include "libguile/generalized-vectors.h" + + + +/* + * Uniform vectors contain unboxed values. They are not necessarily contiguous. + */ + +SCM_INTERNAL const size_t scm_i_array_element_type_sizes[]; +#define SCM_ARRAY_ELEMENT_TYPE_IS_UNBOXED(t) \ + (scm_i_array_element_type_sizes[(t)] != 0) + +/* returns type size in bits */ +SCM_API size_t scm_array_handle_uniform_element_size (scm_t_array_handle *h); + +SCM_API const void *scm_array_handle_uniform_elements (scm_t_array_handle *h); +SCM_API void *scm_array_handle_uniform_writable_elements (scm_t_array_handle *h); + +SCM_API SCM scm_uniform_vector_p (SCM v); +SCM_API SCM scm_uniform_vector_length (SCM v); +SCM_API SCM scm_uniform_vector_element_type (SCM v); +SCM_API SCM scm_uniform_vector_element_size (SCM v); +SCM_API SCM scm_uniform_vector_ref (SCM v, SCM idx); +SCM_API SCM scm_uniform_vector_set_x (SCM v, SCM idx, SCM val); +SCM_API SCM scm_uniform_vector_to_list (SCM v); +SCM_API SCM scm_uniform_vector_read_x (SCM v, SCM port_or_fd, + SCM start, SCM end); +SCM_API SCM scm_uniform_vector_write (SCM v, SCM port_or_fd, + SCM start, SCM end); + +SCM_API int scm_is_uniform_vector (SCM obj); +SCM_API size_t scm_c_uniform_vector_length (SCM v); +SCM_API SCM scm_c_uniform_vector_ref (SCM v, size_t idx); +SCM_API void scm_c_uniform_vector_set_x (SCM v, size_t idx, SCM val); +SCM_API const void *scm_uniform_vector_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, ssize_t *incp); +SCM_API void *scm_uniform_vector_writable_elements (SCM uvec, + scm_t_array_handle *h, + size_t *lenp, + ssize_t *incp); + +SCM_INTERNAL void scm_init_uniform (void); + +#endif /* SCM_UNIFORM_H */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/validate.h b/libguile/validate.h index 365db3693..8c7946902 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,10 @@ cvar = scm_to_bool (flag); \ } while (0) +#define SCM_VALIDATE_BYTEVECTOR(_pos, _obj) \ + SCM_ASSERT_TYPE (SCM_BYTEVECTOR_P (_obj), (_obj), (_pos), \ + FUNC_NAME, "bytevector") + #define SCM_VALIDATE_CHAR(pos, scm) SCM_MAKE_VALIDATE_MSG (pos, scm, CHARP, "character") #define SCM_VALIDATE_CHAR_COPY(pos, scm, cvar) \ @@ -378,7 +383,7 @@ #define SCM_VALIDATE_VECTOR_LEN(pos, v, len) \ do { \ - SCM_ASSERT (SCM_VECTORP (v) && len == SCM_VECTOR_LENGTH (v), v, pos, FUNC_NAME); \ + SCM_ASSERT (scm_is_vector (v) && len == scm_c_vector_length (v), v, pos, FUNC_NAME); \ } while (0) 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 cc4c04f7b..5e710505a 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -1,18 +1,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 */ @@ -29,8 +30,11 @@ #include "libguile/validate.h" #include "libguile/vectors.h" -#include "libguile/unif.h" -#include "libguile/ramap.h" +#include "libguile/generalized-vectors.h" +#include "libguile/arrays.h" +#include "libguile/bitvectors.h" +#include "libguile/bytevectors.h" +#include "libguile/array-map.h" #include "libguile/srfi-4.h" #include "libguile/strings.h" #include "libguile/srfi-13.h" @@ -606,129 +610,43 @@ SCM_DEFINE (scm_vector_move_right_x, "vector-move-right!", 5, 0, 0, } #undef FUNC_NAME - -/* Generalized vectors. */ - -int -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_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0, - (SCM obj), - "Return @code{#t} if @var{obj} is a vector, string,\n" - "bitvector, or uniform numeric vector.") -#define FUNC_NAME s_scm_generalized_vector_p -{ - return scm_from_bool (scm_is_generalized_vector (obj)); -} -#undef FUNC_NAME - -void -scm_generalized_vector_get_handle (SCM vec, scm_t_array_handle *h) -{ - scm_array_get_handle (vec, h); - if (scm_array_handle_rank (h) != 1) - scm_wrong_type_arg_msg (NULL, 0, vec, "vector"); -} - -size_t -scm_c_generalized_vector_length (SCM v) -{ - if (scm_is_vector (v)) - return scm_c_vector_length (v); - else if (scm_is_string (v)) - return scm_c_string_length (v); - else if (scm_is_bitvector (v)) - return scm_c_bitvector_length (v); - else if (scm_is_uniform_vector (v)) - return scm_c_uniform_vector_length (v); - else - scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector"); -} - -SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0, 0, - (SCM v), - "Return the length of the generalized vector @var{v}.") -#define FUNC_NAME s_scm_generalized_vector_length -{ - return scm_from_size_t (scm_c_generalized_vector_length (v)); -} -#undef FUNC_NAME - -SCM -scm_c_generalized_vector_ref (SCM v, size_t idx) -{ - if (scm_is_vector (v)) - return scm_c_vector_ref (v, idx); - else if (scm_is_string (v)) - return scm_c_string_ref (v, idx); - else if (scm_is_bitvector (v)) - return scm_c_bitvector_ref (v, idx); - else if (scm_is_uniform_vector (v)) - return scm_c_uniform_vector_ref (v, idx); - else - scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector"); -} - -SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0, - (SCM v, SCM idx), - "Return the element at index @var{idx} of the\n" - "generalized vector @var{v}.") -#define FUNC_NAME s_scm_generalized_vector_ref + +static SCM +vector_handle_ref (scm_t_array_handle *h, size_t idx) { - return scm_c_generalized_vector_ref (v, scm_to_size_t (idx)); + if (idx > h->dims[0].ubnd) + scm_out_of_range ("vector-handle-ref", scm_from_size_t (idx)); + return ((SCM*)h->elements)[idx]; } -#undef FUNC_NAME -void -scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val) +static void +vector_handle_set (scm_t_array_handle *h, size_t idx, SCM val) { - if (scm_is_vector (v)) - scm_c_vector_set_x (v, idx, val); - else if (scm_is_string (v)) - scm_c_string_set_x (v, idx, val); - else if (scm_is_bitvector (v)) - 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 - scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector"); + if (idx > h->dims[0].ubnd) + scm_out_of_range ("vector-handle-set!", scm_from_size_t (idx)); + ((SCM*)h->writable_elements)[idx] = val; } -SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0, - (SCM v, SCM idx, SCM val), - "Set the element at index @var{idx} of the\n" - "generalized vector @var{v} to @var{val}.") -#define FUNC_NAME s_scm_generalized_vector_set_x +static void +vector_get_handle (SCM v, scm_t_array_handle *h) { - scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val); - return SCM_UNSPECIFIED; + h->array = v; + h->ndims = 1; + h->dims = &h->dim0; + h->dim0.lbnd = 0; + h->dim0.ubnd = SCM_I_VECTOR_LENGTH (v) - 1; + h->dim0.inc = 1; + h->element_type = SCM_ARRAY_ELEMENT_TYPE_SCM; + h->elements = h->writable_elements = SCM_I_VECTOR_WELTS (v); } -#undef FUNC_NAME -SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0, - (SCM v), - "Return a new list whose elements are the elements of the\n" - "generalized vector @var{v}.") -#define FUNC_NAME s_scm_generalized_vector_to_list -{ - if (scm_is_vector (v)) - return scm_vector_to_list (v); - else if (scm_is_string (v)) - return scm_string_to_list (v); - else if (scm_is_bitvector (v)) - return scm_bitvector_to_list (v); - else if (scm_is_uniform_vector (v)) - return scm_uniform_vector_to_list (v); - else - scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector"); -} -#undef FUNC_NAME +SCM_ARRAY_IMPLEMENTATION (scm_tc7_vector, 0x7f & ~2, + vector_handle_ref, vector_handle_set, + vector_get_handle); +SCM_ARRAY_IMPLEMENTATION (scm_tc7_wvect, 0x7f & ~2, + vector_handle_ref, vector_handle_set, + vector_get_handle); +SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_SCM, scm_make_vector); void diff --git a/libguile/vectors.h b/libguile/vectors.h index 7a508c77b..0e2cb6e8f 100644 --- a/libguile/vectors.h +++ b/libguile/vectors.h @@ -6,24 +6,25 @@ /* 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 */ #include "libguile/__scm.h" -#include "libguile/unif.h" +#include "libguile/arrays.h" @@ -60,21 +61,6 @@ SCM_API SCM *scm_vector_writable_elements (SCM vec, #define SCM_SIMPLE_VECTOR_REF(x,idx) ((SCM_I_VECTOR_ELTS(x))[idx]) #define SCM_SIMPLE_VECTOR_SET(x,idx,val) ((SCM_I_VECTOR_WELTS(x))[idx]=(val)) -/* Generalized vectors */ - -SCM_API SCM scm_generalized_vector_p (SCM v); -SCM_API SCM scm_generalized_vector_length (SCM v); -SCM_API SCM scm_generalized_vector_ref (SCM v, SCM idx); -SCM_API SCM scm_generalized_vector_set_x (SCM v, SCM idx, SCM val); -SCM_API SCM scm_generalized_vector_to_list (SCM v); - -SCM_API int scm_is_generalized_vector (SCM obj); -SCM_API size_t scm_c_generalized_vector_length (SCM v); -SCM_API SCM scm_c_generalized_vector_ref (SCM v, size_t idx); -SCM_API void scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val); -SCM_API void scm_generalized_vector_get_handle (SCM vec, - scm_t_array_handle *h); - /* Internals */ #define SCM_I_IS_VECTOR(x) (!SCM_IMP(x) && (SCM_TYP7S(x)==scm_tc7_vector)) 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 new file mode 100644 index 000000000..7ba1a93ba --- /dev/null +++ b/libguile/vm-bootstrap.h @@ -0,0 +1,30 @@ +/* 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 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_ + +SCM_INTERNAL void scm_bootstrap_vm (void); + +#endif /* _SCM_VM_BOOTSTRAP_H_ */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c new file mode 100644 index 000000000..b373cd017 --- /dev/null +++ b/libguile/vm-engine.c @@ -0,0 +1,273 @@ +/* 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 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 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_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_OBJECT 1 +#define VM_CHECK_FREE_VARIABLES 1 +#define VM_PUSH_DEBUG_FRAMES 1 +#else +#error unknown debug engine VM_ENGINE +#endif + +#include "vm-engine.h" + + +static SCM +VM_NAME (struct scm_vm *vp, SCM program, SCM *argv, int nargs) +{ + /* VM registers */ + register scm_t_uint8 *ip IP_REG; /* instruction pointer */ + register SCM *sp SP_REG; /* stack pointer */ + register SCM *fp FP_REG; /* frame pointer */ + + /* Cache variables */ + struct scm_objcode *bp = NULL; /* program base pointer */ + 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 */ + SCM *stack_limit = vp->stack_limit; /* stack limit address */ + + /* Internal variables */ + int nvalues = 0; + long start_time = scm_c_get_internal_run_time (); + SCM finish_args; /* used both for returns: both in error + and normal situations */ +#if VM_USE_HOOKS + SCM hook_args = SCM_EOL; +#endif + +#ifdef HAVE_LABELS_AS_VALUES + static void **jump_table = NULL; +#endif + +#if VM_PUSH_DEBUG_FRAMES + scm_t_debug_frame debug; + scm_t_debug_info debug_vect_body; + debug.status = SCM_VOIDFRAME; +#endif + +#ifdef HAVE_LABELS_AS_VALUES + if (SCM_UNLIKELY (!jump_table)) + { + int i; + jump_table = malloc (SCM_VM_NUM_INSTRUCTIONS * sizeof(void*)); + for (i = 0; i < SCM_VM_NUM_INSTRUCTIONS; i++) + jump_table[i] = &&vm_error_bad_instruction; +#define VM_INSTRUCTION_TO_LABEL 1 +#include <libguile/vm-expand.h> +#include <libguile/vm-i-system.i> +#include <libguile/vm-i-scheme.i> +#include <libguile/vm-i-loader.i> +#undef VM_INSTRUCTION_TO_LABEL + } +#endif + + /* Initialization */ + { + SCM prog = program; + + /* Boot program */ + program = vm_make_boot_program (nargs); + +#if VM_PUSH_DEBUG_FRAMES + debug.prev = scm_i_last_debug_frame (); + debug.status = SCM_APPLYFRAME; + debug.vect = &debug_vect_body; + debug.vect[0].a.proc = program; /* the boot program */ + debug.vect[0].a.args = SCM_EOL; + scm_i_set_last_debug_frame (&debug); +#endif + + /* Initial frame */ + CACHE_REGISTER (); + PUSH ((SCM)fp); /* dynamic link */ + PUSH (0); /* ra */ + PUSH (0); /* mvra */ + CACHE_PROGRAM (); + PUSH (program); + fp = sp + 1; + INIT_FRAME (); + /* MV-call frame, function & arguments */ + PUSH ((SCM)fp); /* dynamic link */ + PUSH (0); /* ra */ + PUSH (0); /* mvra */ + PUSH (prog); + if (SCM_UNLIKELY (sp + nargs >= stack_limit)) + goto vm_error_too_many_args; + while (nargs--) + PUSH (*argv++); + } + + /* Let's go! */ + BOOT_HOOK (); + NEXT; + +#ifndef HAVE_LABELS_AS_VALUES + vm_start: + switch ((*ip++) & SCM_VM_INSTRUCTION_MASK) { +#endif + +#include "vm-expand.h" +#include "vm-i-system.c" +#include "vm-i-scheme.c" +#include "vm-i-loader.c" + +#ifndef HAVE_LABELS_AS_VALUES + default: + goto vm_error_bad_instruction; + } +#endif + + + vm_done: + SYNC_ALL (); +#if VM_PUSH_DEBUG_FRAMES + scm_i_set_last_debug_frame (debug.prev); +#endif + return finish_args; + + /* Errors */ + { + SCM err_msg; + + vm_error_bad_instruction: + err_msg = scm_from_locale_string ("VM: Bad instruction: ~s"); + finish_args = scm_list_1 (scm_from_uchar (ip[-1])); + goto vm_error; + + vm_error_unbound: + err_msg = scm_from_locale_string ("VM: Unbound variable: ~s"); + goto vm_error; + + vm_error_wrong_type_arg: + err_msg = scm_from_locale_string ("VM: Wrong type argument"); + finish_args = SCM_EOL; + goto vm_error; + + vm_error_too_many_args: + err_msg = scm_from_locale_string ("VM: Too many arguments"); + finish_args = scm_list_1 (scm_from_int (nargs)); + goto vm_error; + + vm_error_wrong_num_args: + /* nargs and program are valid */ + SYNC_ALL (); + scm_wrong_num_args (program); + /* shouldn't get here */ + goto vm_error; + + vm_error_wrong_type_apply: + SYNC_ALL (); + scm_error (scm_misc_error_key, FUNC_NAME, "Wrong type to apply: ~S", + scm_list_1 (program), SCM_BOOL_F); + goto vm_error; + + vm_error_stack_overflow: + err_msg = scm_from_locale_string ("VM: Stack overflow"); + finish_args = SCM_EOL; + goto vm_error; + + vm_error_stack_underflow: + err_msg = scm_from_locale_string ("VM: Stack underflow"); + finish_args = SCM_EOL; + goto vm_error; + + vm_error_improper_list: + err_msg = scm_from_locale_string ("Expected a proper list, but got object with tail ~s"); + goto vm_error; + + vm_error_not_a_pair: + SYNC_ALL (); + scm_wrong_type_arg_msg (FUNC_NAME, 1, finish_args, "pair"); + /* 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 ("Zero values returned to single-valued continuation"); + finish_args = SCM_EOL; + goto vm_error; + + vm_error_not_enough_values: + err_msg = scm_from_locale_string ("Too few values returned to continuation"); + finish_args = SCM_EOL; + goto vm_error; + + 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 + vm_error_invalid_address: + err_msg = scm_from_locale_string ("VM: Invalid program address"); + 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"); + finish_args = SCM_EOL; + goto vm_error; +#endif + +#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 + + vm_error: + SYNC_ALL (); + + scm_ithrow (sym_vm_error, scm_list_3 (sym_vm_run, err_msg, finish_args), + 1); + } + + abort (); /* never reached */ +} + +#undef VM_USE_HOOKS +#undef VM_USE_CLOCK +#undef VM_CHECK_OBJECT +#undef VM_CHECK_FREE_VARIABLE +#undef VM_PUSH_DEBUG_FRAMES + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm-engine.h b/libguile/vm-engine.h new file mode 100644 index 000000000..3c1bbf681 --- /dev/null +++ b/libguile/vm-engine.h @@ -0,0 +1,416 @@ +/* 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 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 file is included in vm_engine.c */ + + +/* + * Registers + */ + +/* Register optimization. [ stolen from librep/src/lispmach.h,v 1.3 ] + + Some compilers underestimate the use of the local variables representing + the abstract machine registers, and don't put them in hardware registers, + which slows down the interpreter considerably. + For GCC, I have hand-assigned hardware registers for several architectures. +*/ + +#ifdef __GNUC__ +#ifdef __mips__ +#define IP_REG asm("$16") +#define SP_REG asm("$17") +#define FP_REG asm("$18") +#endif +#ifdef __sparc__ +#define IP_REG asm("%l0") +#define SP_REG asm("%l1") +#define FP_REG asm("%l2") +#endif +#ifdef __alpha__ +#ifdef __CRAY__ +#define IP_REG asm("r9") +#define SP_REG asm("r10") +#define FP_REG asm("r11") +#else +#define IP_REG asm("$9") +#define SP_REG asm("$10") +#define FP_REG asm("$11") +#endif +#endif +#ifdef __i386__ +/* 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") +#define SP_REG asm("27") +#define FP_REG asm("28") +#endif +#ifdef __hppa__ +#define IP_REG asm("%r18") +#define SP_REG asm("%r17") +#define FP_REG asm("%r16") +#endif +#ifdef __mc68000__ +#define IP_REG asm("a5") +#define SP_REG asm("a4") +#define FP_REG +#endif +#ifdef __arm__ +#define IP_REG asm("r9") +#define SP_REG asm("r8") +#define FP_REG asm("r7") +#endif +#endif + +#ifndef IP_REG +#define IP_REG +#endif +#ifndef SP_REG +#define SP_REG +#endif +#ifndef FP_REG +#define FP_REG +#endif + + +/* + * Cache/Sync + */ + +#ifdef VM_ENABLE_ASSERTIONS +# define ASSERT(condition) if (SCM_UNLIKELY (!(condition))) abort() +#else +# define ASSERT(condition) +#endif + + +#define CACHE_REGISTER() \ +{ \ + ip = vp->ip; \ + sp = vp->sp; \ + fp = vp->fp; \ + stack_base = fp ? SCM_FRAME_UPPER_ADDRESS (fp) - 1 : vp->stack_base; \ +} + +#define SYNC_REGISTER() \ +{ \ + vp->ip = ip; \ + vp->sp = sp; \ + 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 + +/* 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)); \ + } else { \ + objects = NULL; \ + 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() \ +{ \ + SYNC_REGISTER (); \ +} + +#define SYNC_ALL() \ +{ \ + SYNC_REGISTER (); \ +} + + +/* + * Error check + */ + +/* Accesses to a program's object table. */ +#if VM_CHECK_OBJECT +#define CHECK_OBJECT(_num) \ + do { if (SCM_UNLIKELY ((_num) >= object_count)) goto vm_error_object; } while (0) +#else +#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 + */ + +#undef RUN_HOOK +#if VM_USE_HOOKS +#define RUN_HOOK(h) \ +{ \ + if (SCM_UNLIKELY (!SCM_FALSEP (vp->hooks[h])))\ + { \ + SYNC_REGISTER (); \ + vm_dispatch_hook (vp, vp->hooks[h], hook_args); \ + CACHE_REGISTER (); \ + } \ +} +#else +#define RUN_HOOK(h) +#endif + +#define BOOT_HOOK() RUN_HOOK (SCM_VM_BOOT_HOOK) +#define HALT_HOOK() RUN_HOOK (SCM_VM_HALT_HOOK) +#define NEXT_HOOK() RUN_HOOK (SCM_VM_NEXT_HOOK) +#define BREAK_HOOK() RUN_HOOK (SCM_VM_BREAK_HOOK) +#define ENTER_HOOK() RUN_HOOK (SCM_VM_ENTER_HOOK) +#define APPLY_HOOK() RUN_HOOK (SCM_VM_APPLY_HOOK) +#define EXIT_HOOK() RUN_HOOK (SCM_VM_EXIT_HOOK) +#define RETURN_HOOK() RUN_HOOK (SCM_VM_RETURN_HOOK) + + +/* + * Stack operation + */ + +#ifdef VM_ENABLE_STACK_NULLING +# define CHECK_STACK_LEAKN(_n) ASSERT (!sp[_n]); +# define CHECK_STACK_LEAK() CHECK_STACK_LEAKN(1) +# define NULLSTACK(_n) { int __x = _n; CHECK_STACK_LEAKN (_n+1); while (__x > 0) sp[__x--] = NULL; } +/* If you have a nonlocal exit in a pre-wind proc while invoking a continuation + inside a dynwind (phew!), the stack is fully rewound but vm_reset_stack for + that continuation doesn't have a chance to run. It's not important on a + semantic level, but it does mess up our stack nulling -- so this macro is to + fix that. */ +# define NULLSTACK_FOR_NONLOCAL_EXIT() if (vp->sp > sp) NULLSTACK (vp->sp - sp); +#else +# define CHECK_STACK_LEAKN(_n) +# define CHECK_STACK_LEAK() +# define NULLSTACK(_n) +# define NULLSTACK_FOR_NONLOCAL_EXIT() +#endif + +#define CHECK_OVERFLOW() \ + if (sp >= stack_limit) \ + goto vm_error_stack_overflow + +#define CHECK_UNDERFLOW() \ + if (sp < stack_base) \ + goto vm_error_stack_underflow; + +#define PUSH(x) do { sp++; CHECK_OVERFLOW (); *sp = x; } while (0) +#define DROP() do { sp--; CHECK_UNDERFLOW (); NULLSTACK (1); } while (0) +#define DROPN(_n) do { sp -= (_n); CHECK_UNDERFLOW (); NULLSTACK (_n); } while (0) +#define POP(x) do { x = *sp; DROP (); } while (0) + +/* A fast CONS. This has to be fast since its used, for instance, by + POP_LIST when fetching a function's argument list. Note: `scm_cell' is an + inlined function in Guile 1.7. Unfortunately, it calls + `scm_gc_for_newcell ()' which is _not_ inlined and allocated cells on the + heap. XXX */ +#define CONS(x,y,z) \ +{ \ + SYNC_BEFORE_GC (); \ + x = scm_cell (SCM_UNPACK (y), SCM_UNPACK (z)); \ +} + +/* Pop the N objects on top of the stack and push a list that contains + them. */ +#define POP_LIST(n) \ +do \ +{ \ + int i; \ + SCM l = SCM_EOL, x; \ + for (i = n; i; i--) \ + { \ + POP (x); \ + CONS (l, x, l); \ + } \ + PUSH (l); \ +} while (0) + +/* The opposite: push all of the elements in L onto the list. */ +#define PUSH_LIST(l, NILP) \ +do \ +{ \ + for (; scm_is_pair (l); l = SCM_CDR (l)) \ + PUSH (SCM_CAR (l)); \ + if (SCM_UNLIKELY (!NILP (l))) { \ + finish_args = scm_list_1 (l); \ + goto vm_error_improper_list; \ + } \ +} while (0) + + +#define POP_LIST_MARK() \ +do { \ + SCM o; \ + SCM l = SCM_EOL; \ + POP (o); \ + while (!SCM_UNBNDP (o)) \ + { \ + CONS (l, o, l); \ + POP (o); \ + } \ + PUSH (l); \ +} while (0) + +#define POP_CONS_MARK() \ +do { \ + SCM o, l; \ + POP (l); \ + POP (o); \ + while (!SCM_UNBNDP (o)) \ + { \ + CONS (l, o, l); \ + POP (o); \ + } \ + PUSH (l); \ +} while (0) + + +/* + * Instruction operation + */ + +#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 +#define CLOCK(n) vp->clock += n +#else +#define CLOCK(n) +#endif + +#undef NEXT_JUMP +#ifdef HAVE_LABELS_AS_VALUES +#define NEXT_JUMP() goto *jump_table[FETCH () & SCM_VM_INSTRUCTION_MASK] +#else +#define NEXT_JUMP() goto vm_start +#endif + +#define NEXT \ +{ \ + CLOCK (1); \ + NEXT_HOOK (); \ + CHECK_STACK_LEAK (); \ + NEXT_JUMP (); \ +} + + +/* + * Stack frame + */ + +#define INIT_ARGS() \ +{ \ + if (SCM_UNLIKELY (bp->nrest)) \ + { \ + int n = nargs - (bp->nargs - 1); \ + if (n < 0) \ + goto vm_error_wrong_num_args; \ + /* NB, can cause GC while setting up the \ + stack frame */ \ + POP_LIST (n); \ + } \ + else \ + { \ + if (SCM_UNLIKELY (nargs != bp->nargs)) \ + goto vm_error_wrong_num_args; \ + } \ +} + +/* See frames.h for the layout of stack frames */ +/* When this is called, bp points to the new program data, + and the arguments are already on the stack */ +#define INIT_FRAME() \ +{ \ + int i; \ + \ + /* New registers */ \ + sp += bp->nlocs; \ + CHECK_OVERFLOW (); \ + stack_base = sp; \ + ip = bp->base; \ + \ + /* Init local variables */ \ + for (i=bp->nlocs; i;) \ + sp[-(--i)] = SCM_UNDEFINED; \ +} + +#define DROP_FRAME() \ + { \ + sp -= 3; \ + NULLSTACK (3); \ + CHECK_UNDERFLOW (); \ + } + + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm-expand.h b/libguile/vm-expand.h new file mode 100644 index 000000000..787223d07 --- /dev/null +++ b/libguile/vm-expand.h @@ -0,0 +1,79 @@ +/* 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 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 VM_LABEL +#define VM_LABEL(tag) l_##tag +#define VM_OPCODE(tag) scm_op_##tag + +#ifdef HAVE_LABELS_AS_VALUES +#define VM_TAG(tag) VM_LABEL(tag): +#define VM_ADDR(tag) &&VM_LABEL(tag) +#else /* not HAVE_LABELS_AS_VALUES */ +#define VM_TAG(tag) case VM_OPCODE(tag): +#define VM_ADDR(tag) NULL +#endif /* not HAVE_LABELS_AS_VALUES */ +#endif /* VM_LABEL */ + +#undef VM_DEFINE_FUNCTION +#undef VM_DEFINE_LOADER +#define VM_DEFINE_FUNCTION(code,tag,name,nargs) \ + VM_DEFINE_INSTRUCTION(code,tag,name,0,nargs,1) +#define VM_DEFINE_LOADER(code,tag,name) \ + VM_DEFINE_INSTRUCTION(code,tag,name,-1,0,1) + +#undef VM_DEFINE_INSTRUCTION +/* + * These will go to scm_instruction_table in instructions.c + */ +#ifdef VM_INSTRUCTION_TO_TABLE +#define VM_DEFINE_INSTRUCTION(code_,tag_,name_,len_,npop_,npush_) \ + table[VM_OPCODE (tag_)].opcode = code_; \ + table[VM_OPCODE (tag_)].name = name_; \ + table[VM_OPCODE (tag_)].len = len_; \ + table[VM_OPCODE (tag_)].npop = npop_; \ + table[VM_OPCODE (tag_)].npush = npush_; + +#else +#ifdef VM_INSTRUCTION_TO_LABEL +/* + * These will go to jump_table in vm_engine.c + */ +#define VM_DEFINE_INSTRUCTION(code,tag,name,len,npop,npush) jump_table[code] = VM_ADDR (tag); + +#else +#ifdef VM_INSTRUCTION_TO_OPCODE +/* + * These will go to scm_opcode in instructions.h + */ +#define VM_DEFINE_INSTRUCTION(code,tag,name,len,npop,npush) VM_OPCODE (tag) = code, + +#else /* Otherwise */ +/* + * These are directly included in vm_engine.c + */ +#define VM_DEFINE_INSTRUCTION(code,tag,name,len,npop,npush) VM_TAG (tag) + +#endif /* VM_INSTRUCTION_TO_OPCODE */ +#endif /* VM_INSTRUCTION_TO_LABEL */ +#endif /* VM_INSTRUCTION_TO_TABLE */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm-i-loader.c b/libguile/vm-i-loader.c new file mode 100644 index 000000000..e242ef9bf --- /dev/null +++ b/libguile/vm-i-loader.c @@ -0,0 +1,137 @@ +/* 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 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 + */ + +/* FIXME! Need to check that the fetch is within the current program */ + +/* This file is included in vm_engine.c */ + +VM_DEFINE_LOADER (82, load_number, "load-number") +{ + size_t len; + + FETCH_LENGTH (len); + SYNC_REGISTER (); + PUSH (scm_string_to_number (scm_from_locale_stringn ((char *)ip, len), + SCM_UNDEFINED /* radix = 10 */)); + /* Was: scm_istring2number (ip, len, 10)); */ + ip += len; + NEXT; +} + +VM_DEFINE_LOADER (83, load_string, "load-string") +{ + size_t len; + char *buf; + + FETCH_LENGTH (len); + SYNC_REGISTER (); + PUSH (scm_i_make_string (len, &buf)); + memcpy (buf, (char *) ip, len); + ip += len; + NEXT; +} + +VM_DEFINE_LOADER (84, load_symbol, "load-symbol") +{ + size_t len; + FETCH_LENGTH (len); + SYNC_REGISTER (); + /* FIXME: should be scm_from_latin1_symboln */ + PUSH (scm_from_locale_symboln ((const char*)ip, len)); + ip += len; + NEXT; +} + +VM_DEFINE_LOADER (86, load_program, "load-program") +{ + scm_t_uint32 len; + SCM objs, objcode; + + POP (objs); + SYNC_REGISTER (); + + if (scm_is_vector (objs) && scm_is_false (scm_c_vector_ref (objs, 0))) + scm_c_vector_set_x (objs, 0, scm_current_module ()); + + 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_BOOL_F)); + + ip += len; + + NEXT; +} + +VM_DEFINE_INSTRUCTION (87, link_now, "link-now", 0, 1, 1) +{ + SCM what; + POP (what); + SYNC_REGISTER (); + PUSH (resolve_variable (what, scm_current_module ())); + NEXT; +} + +VM_DEFINE_LOADER (89, load_array, "load-array") +{ + SCM type, shape; + size_t len; + FETCH_LENGTH (len); + POP (shape); + POP (type); + SYNC_REGISTER (); + 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_i_make_wide_string (len / 4, &wbuf)); + memcpy ((char *) wbuf, (char *) ip, len); + ip += len; + NEXT; +} + +/* +(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)) + (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t) + (replace-match + (number-to-string (setq counter (1+ counter))) + t t nil 1))))) +*/ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm-i-scheme.c b/libguile/vm-i-scheme.c new file mode 100644 index 000000000..0cace147d --- /dev/null +++ b/libguile/vm-i-scheme.c @@ -0,0 +1,577 @@ +/* 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 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 file is included in vm_engine.c */ + + +/* + * Predicates + */ + +#define ARGS1(a1) SCM a1 = sp[0]; +#define ARGS2(a1,a2) SCM a1 = sp[-1], a2 = sp[0]; sp--; NULLSTACK (1); +#define ARGS3(a1,a2,a3) SCM a1 = sp[-2], a2 = sp[-1], a3 = sp[0]; sp -= 2; NULLSTACK (2); + +#define RETURN(x) do { *sp = x; NEXT; } while (0) + +VM_DEFINE_FUNCTION (100, not, "not", 1) +{ + ARGS1 (x); + RETURN (SCM_BOOL (SCM_FALSEP (x))); +} + +VM_DEFINE_FUNCTION (101, not_not, "not-not", 1) +{ + ARGS1 (x); + RETURN (SCM_BOOL (!SCM_FALSEP (x))); +} + +VM_DEFINE_FUNCTION (102, eq, "eq?", 2) +{ + ARGS2 (x, y); + RETURN (SCM_BOOL (SCM_EQ_P (x, y))); +} + +VM_DEFINE_FUNCTION (103, not_eq, "not-eq?", 2) +{ + ARGS2 (x, y); + RETURN (SCM_BOOL (!SCM_EQ_P (x, y))); +} + +VM_DEFINE_FUNCTION (104, nullp, "null?", 1) +{ + ARGS1 (x); + RETURN (SCM_BOOL (SCM_NULLP (x))); +} + +VM_DEFINE_FUNCTION (105, not_nullp, "not-null?", 1) +{ + ARGS1 (x); + RETURN (SCM_BOOL (!SCM_NULLP (x))); +} + +VM_DEFINE_FUNCTION (106, eqv, "eqv?", 2) +{ + ARGS2 (x, y); + if (SCM_EQ_P (x, y)) + RETURN (SCM_BOOL_T); + if (SCM_IMP (x) || SCM_IMP (y)) + RETURN (SCM_BOOL_F); + SYNC_REGISTER (); + RETURN (scm_eqv_p (x, y)); +} + +VM_DEFINE_FUNCTION (107, equal, "equal?", 2) +{ + ARGS2 (x, y); + if (SCM_EQ_P (x, y)) + RETURN (SCM_BOOL_T); + if (SCM_IMP (x) || SCM_IMP (y)) + RETURN (SCM_BOOL_F); + SYNC_REGISTER (); + RETURN (scm_equal_p (x, y)); +} + +VM_DEFINE_FUNCTION (108, pairp, "pair?", 1) +{ + ARGS1 (x); + RETURN (SCM_BOOL (SCM_CONSP (x))); +} + +VM_DEFINE_FUNCTION (109, listp, "list?", 1) +{ + ARGS1 (x); + RETURN (SCM_BOOL (scm_ilength (x) >= 0)); +} + + +/* + * Basic data + */ + +VM_DEFINE_FUNCTION (110, cons, "cons", 2) +{ + ARGS2 (x, y); + CONS (x, x, y); + RETURN (x); +} + +#define VM_VALIDATE_CONS(x) \ + if (SCM_UNLIKELY (!scm_is_pair (x))) \ + { finish_args = x; \ + goto vm_error_not_a_pair; \ + } + +VM_DEFINE_FUNCTION (111, car, "car", 1) +{ + ARGS1 (x); + VM_VALIDATE_CONS (x); + RETURN (SCM_CAR (x)); +} + +VM_DEFINE_FUNCTION (112, cdr, "cdr", 1) +{ + ARGS1 (x); + VM_VALIDATE_CONS (x); + RETURN (SCM_CDR (x)); +} + +VM_DEFINE_INSTRUCTION (113, set_car, "set-car!", 0, 2, 0) +{ + SCM x, y; + POP (y); + POP (x); + VM_VALIDATE_CONS (x); + SCM_SETCAR (x, y); + NEXT; +} + +VM_DEFINE_INSTRUCTION (114, set_cdr, "set-cdr!", 0, 2, 0) +{ + SCM x, y; + POP (y); + POP (x); + VM_VALIDATE_CONS (x); + SCM_SETCDR (x, y); + NEXT; +} + + +/* + * Numeric relational tests + */ + +#undef REL +#define REL(crel,srel) \ +{ \ + ARGS2 (x, y); \ + if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \ + RETURN (SCM_BOOL (SCM_I_INUM (x) crel SCM_I_INUM (y))); \ + SYNC_REGISTER (); \ + RETURN (srel (x, y)); \ +} + +VM_DEFINE_FUNCTION (115, ee, "ee?", 2) +{ + REL (==, scm_num_eq_p); +} + +VM_DEFINE_FUNCTION (116, lt, "lt?", 2) +{ + REL (<, scm_less_p); +} + +VM_DEFINE_FUNCTION (117, le, "le?", 2) +{ + REL (<=, scm_leq_p); +} + +VM_DEFINE_FUNCTION (118, gt, "gt?", 2) +{ + REL (>, scm_gr_p); +} + +VM_DEFINE_FUNCTION (119, ge, "ge?", 2) +{ + REL (>=, scm_geq_p); +} + + +/* + * Numeric functions + */ + +#undef FUNC2 +#define FUNC2(CFUNC,SFUNC) \ +{ \ + ARGS2 (x, y); \ + if (SCM_I_INUMP (x) && SCM_I_INUMP (y)) \ + { \ + scm_t_int64 n = SCM_I_INUM (x) CFUNC SCM_I_INUM (y);\ + if (SCM_FIXABLE (n)) \ + RETURN (SCM_I_MAKINUM (n)); \ + } \ + SYNC_REGISTER (); \ + RETURN (SFUNC (x, y)); \ +} + +VM_DEFINE_FUNCTION (120, add, "add", 2) +{ + FUNC2 (+, scm_sum); +} + +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 (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 (123, div, "div", 2) +{ + ARGS2 (x, y); + SYNC_REGISTER (); + RETURN (scm_divide (x, y)); +} + +VM_DEFINE_FUNCTION (124, quo, "quo", 2) +{ + ARGS2 (x, y); + SYNC_REGISTER (); + RETURN (scm_quotient (x, y)); +} + +VM_DEFINE_FUNCTION (125, rem, "rem", 2) +{ + ARGS2 (x, y); + SYNC_REGISTER (); + RETURN (scm_remainder (x, y)); +} + +VM_DEFINE_FUNCTION (126, mod, "mod", 2) +{ + ARGS2 (x, y); + SYNC_REGISTER (); + RETURN (scm_modulo (x, y)); +} + + +/* + * GOOPS support + */ +VM_DEFINE_FUNCTION (127, slot_ref, "slot-ref", 2) +{ + size_t slot; + ARGS2 (instance, idx); + slot = SCM_I_INUM (idx); + RETURN (SCM_PACK (SCM_STRUCT_DATA (instance) [slot])); +} + +VM_DEFINE_INSTRUCTION (128, slot_set, "slot-set", 0, 3, 0) +{ + SCM instance, idx, val; + size_t slot; + POP (val); + POP (idx); + POP (instance); + slot = SCM_I_INUM (idx); + SCM_STRUCT_DATA (instance) [slot] = SCM_UNPACK (val); + 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 99)) (goto-char (point-min)) + (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t) + (replace-match + (number-to-string (setq counter (1+ counter))) + t t nil 1))))) +*/ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c new file mode 100644 index 000000000..0662f8188 --- /dev/null +++ b/libguile/vm-i-system.c @@ -0,0 +1,1106 @@ +/* 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 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 + */ + + +/* This file is included in vm_engine.c */ + + +/* + * Basic operations + */ + +VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0) +{ + NEXT; +} + +VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0) +{ + vp->time += scm_c_get_internal_run_time () - start_time; + HALT_HOOK (); + nvalues = SCM_I_INUM (*sp--); + NULLSTACK (1); + if (nvalues == 1) + POP (finish_args); + else + { + POP_LIST (nvalues); + POP (finish_args); + SYNC_REGISTER (); + finish_args = scm_values (finish_args); + } + + { + ASSERT (sp == stack_base); + ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1); + + /* Restore registers */ + sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; + ip = NULL; + fp = SCM_FRAME_DYNAMIC_LINK (fp); + NULLSTACK (stack_base - sp); + } + + goto vm_done; +} + +VM_DEFINE_INSTRUCTION (2, break, "break", 0, 0, 0) +{ + BREAK_HOOK (); + NEXT; +} + +VM_DEFINE_INSTRUCTION (3, drop, "drop", 0, 1, 0) +{ + DROP (); + NEXT; +} + +VM_DEFINE_INSTRUCTION (4, dup, "dup", 0, 0, 1) +{ + SCM x = *sp; + PUSH (x); + NEXT; +} + + +/* + * Object creation + */ + +VM_DEFINE_INSTRUCTION (5, void, "void", 0, 0, 1) +{ + PUSH (SCM_UNSPECIFIED); + NEXT; +} + +VM_DEFINE_INSTRUCTION (6, make_true, "make-true", 0, 0, 1) +{ + PUSH (SCM_BOOL_T); + NEXT; +} + +VM_DEFINE_INSTRUCTION (7, make_false, "make-false", 0, 0, 1) +{ + PUSH (SCM_BOOL_F); + NEXT; +} + +VM_DEFINE_INSTRUCTION (8, make_eol, "make-eol", 0, 0, 1) +{ + PUSH (SCM_EOL); + NEXT; +} + +VM_DEFINE_INSTRUCTION (9, make_int8, "make-int8", 1, 0, 1) +{ + PUSH (SCM_I_MAKINUM ((signed char) FETCH ())); + NEXT; +} + +VM_DEFINE_INSTRUCTION (10, make_int8_0, "make-int8:0", 0, 0, 1) +{ + PUSH (SCM_INUM0); + NEXT; +} + +VM_DEFINE_INSTRUCTION (11, make_int8_1, "make-int8:1", 0, 0, 1) +{ + PUSH (SCM_I_MAKINUM (1)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (12, make_int16, "make-int16", 2, 0, 1) +{ + int h = FETCH (); + int l = FETCH (); + PUSH (SCM_I_MAKINUM ((signed short) (h << 8) + l)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (13, make_int64, "make-int64", 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_int64 ((scm_t_int64) v)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (14, 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 (15, 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 (16, 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 (); + unsigned len = ((h << 8) + l); + POP_LIST (len); + NEXT; +} + +VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1) +{ + unsigned h = FETCH (); + unsigned l = FETCH (); + unsigned len = ((h << 8) + l); + SCM vect; + + SYNC_REGISTER (); + sp++; sp -= len; + CHECK_UNDERFLOW (); + vect = scm_make_vector (scm_from_uint (len), SCM_BOOL_F); + memcpy (SCM_I_VECTOR_WELTS(vect), sp, sizeof(SCM) * len); + NULLSTACK (len); + *sp = vect; + + NEXT; +} + + +/* + * Variable access + */ + +#define OBJECT_REF(i) objects[i] +#define OBJECT_SET(i,o) objects[i] = o + +#define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i) +#define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = o + +/* For the variable operations, we _must_ obviously avoid function calls to + `scm_variable_ref ()', `scm_variable_bound_p ()' and friends which do + nothing more than the corresponding macros. */ +#define VARIABLE_REF(v) SCM_VARIABLE_REF (v) +#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 (19, object_ref, "object-ref", 1, 0, 1) +{ + register unsigned objnum = FETCH (); + CHECK_OBJECT (objnum); + PUSH (OBJECT_REF (objnum)); + NEXT; +} + +/* FIXME: necessary? elt 255 of the vector could be a vector... */ +VM_DEFINE_INSTRUCTION (20, 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 (21, local_ref, "local-ref", 1, 0, 1) +{ + PUSH (LOCAL_REF (FETCH ())); + ASSERT_BOUND (*sp); + NEXT; +} + +VM_DEFINE_INSTRUCTION (22, long_local_ref, "long-local-ref", 2, 0, 1) +{ + unsigned int i = FETCH (); + i <<= 8; + i += FETCH (); + PUSH (LOCAL_REF (i)); + ASSERT_BOUND (*sp); + NEXT; +} + +VM_DEFINE_INSTRUCTION (23, variable_ref, "variable-ref", 0, 0, 1) +{ + SCM x = *sp; + + if (!VARIABLE_BOUNDP (x)) + { + finish_args = scm_list_1 (x); + /* Was: finish_args = SCM_LIST1 (SCM_CAR (x)); */ + goto vm_error_unbound; + } + else + { + SCM o = VARIABLE_REF (x); + *sp = o; + } + + NEXT; +} + +VM_DEFINE_INSTRUCTION (24, toplevel_ref, "toplevel-ref", 1, 0, 1) +{ + unsigned objnum = FETCH (); + SCM what; + 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_list_1 (what); + goto vm_error_unbound; + } + OBJECT_SET (objnum, what); + } + + PUSH (VARIABLE_REF (what)); + NEXT; +} + +VM_DEFINE_INSTRUCTION (25, 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_list_1 (what); + goto vm_error_unbound; + } + OBJECT_SET (objnum, what); + } + + PUSH (VARIABLE_REF (what)); + NEXT; +} + +/* set */ + +VM_DEFINE_INSTRUCTION (26, local_set, "local-set", 1, 1, 0) +{ + LOCAL_SET (FETCH (), *sp); + DROP (); + NEXT; +} + +VM_DEFINE_INSTRUCTION (27, long_local_set, "long-local-set", 2, 1, 0) +{ + 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) +{ + VARIABLE_SET (sp[0], sp[-1]); + DROPN (2); + NEXT; +} + +VM_DEFINE_INSTRUCTION (29, toplevel_set, "toplevel-set", 1, 1, 0) +{ + unsigned objnum = FETCH (); + SCM what; + 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; +} + +VM_DEFINE_INSTRUCTION (30, long_toplevel_set, "long-toplevel-set", 2, 1, 0) +{ + 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; +} + + +/* + * branch and jump + */ + +/* offset must be a signed 16 bit int!!! */ +#define FETCH_OFFSET(offset) \ +{ \ + int h = FETCH (); \ + int l = FETCH (); \ + offset = (h << 8) + l; \ +} + +#define BR(p) \ +{ \ + scm_t_int16 offset; \ + FETCH_OFFSET (offset); \ + if (p) \ + ip += ((scm_t_ptrdiff)offset) * 8 - (((unsigned long)ip) % 8); \ + NULLSTACK (1); \ + DROP (); \ + NEXT; \ +} + +VM_DEFINE_INSTRUCTION (31, br, "br", 2, 0, 0) +{ + 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) +{ + BR (!SCM_FALSEP (*sp)); +} + +VM_DEFINE_INSTRUCTION (33, 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) +{ + 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) +{ + sp--; /* underflow? */ + BR (!SCM_EQ_P (sp[0], sp[1])); +} + +VM_DEFINE_INSTRUCTION (36, 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) +{ + BR (!SCM_NULLP (*sp)); +} + + +/* + * Subprogram call + */ + +VM_DEFINE_INSTRUCTION (38, new_frame, "new-frame", 0, 0, 3) +{ + PUSH ((SCM)fp); /* dynamic link */ + PUSH (0); /* mvra */ + PUSH (0); /* ra */ + NEXT; +} + +VM_DEFINE_INSTRUCTION (39, call, "call", 1, -1, 1) +{ + SCM x; + nargs = FETCH (); + + vm_call: + x = sp[-nargs]; + + SYNC_REGISTER (); + SCM_TICK; /* allow interrupt here */ + + /* + * Subprogram call + */ + if (SCM_PROGRAM_P (x)) + { + program = x; + CACHE_PROGRAM (); + INIT_ARGS (); + fp = sp - bp->nargs + 1; + ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); + ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); + SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); + SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0); + INIT_FRAME (); + ENTER_HOOK (); + APPLY_HOOK (); + NEXT; + } + /* + * Other interpreted or compiled call + */ + if (!SCM_FALSEP (scm_procedure_p (x))) + { + SCM args; + /* At this point, the stack contains the frame, the procedure and each one + of its arguments. */ + POP_LIST (nargs); + POP (args); + DROP (); /* drop the procedure */ + DROP_FRAME (); + + SYNC_REGISTER (); + PUSH (scm_apply (x, args, SCM_EOL)); + NULLSTACK_FOR_NONLOCAL_EXIT (); + if (SCM_UNLIKELY (SCM_VALUESP (*sp))) + { + /* truncate values */ + SCM values; + POP (values); + values = scm_struct_ref (values, SCM_INUM0); + if (scm_is_null (values)) + goto vm_error_not_enough_values; + PUSH (SCM_CAR (values)); + } + NEXT; + } + + program = x; + goto vm_error_wrong_type_apply; +} + +VM_DEFINE_INSTRUCTION (40, goto_args, "goto/args", 1, -1, 1) +{ + register SCM x; + nargs = FETCH (); + vm_goto_args: + x = sp[-nargs]; + + SYNC_REGISTER (); + SCM_TICK; /* allow interrupt here */ + + /* + * Tail call + */ + if (SCM_PROGRAM_P (x)) + { + int i; +#ifdef VM_ENABLE_STACK_NULLING + SCM *old_sp; +#endif + + EXIT_HOOK (); + + /* switch programs */ + program = x; + CACHE_PROGRAM (); + INIT_ARGS (); + +#ifdef VM_ENABLE_STACK_NULLING + old_sp = sp; + CHECK_STACK_LEAK (); +#endif + + /* delay shuffling the new program+args down so that if INIT_ARGS had to + cons up a rest arg, going into GC, the stack still made sense */ + for (i = -1, sp = sp - bp->nargs + 1; i < bp->nargs; i++) + fp[i] = sp[i]; + sp = fp + i - 1; + + NULLSTACK (old_sp - sp); + + INIT_FRAME (); + + ENTER_HOOK (); + APPLY_HOOK (); + NEXT; + } + + /* + * Other interpreted or compiled call + */ + if (!SCM_FALSEP (scm_procedure_p (x))) + { + SCM args; + POP_LIST (nargs); + POP (args); + + SYNC_REGISTER (); + *sp = scm_apply (x, args, SCM_EOL); + NULLSTACK_FOR_NONLOCAL_EXIT (); + + if (SCM_UNLIKELY (SCM_VALUESP (*sp))) + { + /* multiple values returned to continuation */ + SCM values; + POP (values); + values = scm_struct_ref (values, SCM_INUM0); + nvalues = scm_ilength (values); + PUSH_LIST (values, SCM_NULLP); + goto vm_return_values; + } + else + goto vm_return; + } + + program = x; + + goto vm_error_wrong_type_apply; +} + +VM_DEFINE_INSTRUCTION (41, goto_nargs, "goto/nargs", 0, 0, 1) +{ + SCM x; + POP (x); + nargs = scm_to_int (x); + /* FIXME: should truncate values? */ + goto vm_goto_args; +} + +VM_DEFINE_INSTRUCTION (42, call_nargs, "call/nargs", 0, 0, 1) +{ + SCM x; + POP (x); + nargs = scm_to_int (x); + /* FIXME: should truncate values? */ + goto vm_call; +} + +VM_DEFINE_INSTRUCTION (43, mv_call, "mv-call", 3, -1, 1) +{ + SCM x; + 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]; + + /* + * Subprogram call + */ + if (SCM_PROGRAM_P (x)) + { + program = x; + CACHE_PROGRAM (); + INIT_ARGS (); + fp = sp - bp->nargs + 1; + ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); + ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); + SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); + SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra); + INIT_FRAME (); + ENTER_HOOK (); + APPLY_HOOK (); + NEXT; + } + /* + * Other interpreted or compiled call + */ + if (!SCM_FALSEP (scm_procedure_p (x))) + { + SCM args; + /* At this point, the stack contains the procedure and each one of its + arguments. */ + POP_LIST (nargs); + POP (args); + DROP (); /* drop the procedure */ + DROP_FRAME (); + + SYNC_REGISTER (); + PUSH (scm_apply (x, args, SCM_EOL)); + NULLSTACK_FOR_NONLOCAL_EXIT (); + if (SCM_VALUESP (*sp)) + { + SCM values, len; + POP (values); + values = scm_struct_ref (values, SCM_INUM0); + len = scm_length (values); + PUSH_LIST (values, SCM_NULLP); + PUSH (len); + ip = mvra; + } + NEXT; + } + + program = x; + goto vm_error_wrong_type_apply; +} + +VM_DEFINE_INSTRUCTION (44, apply, "apply", 1, -1, 1) +{ + int len; + SCM ls; + POP (ls); + + nargs = FETCH (); + ASSERT (nargs >= 2); + + len = scm_ilength (ls); + if (len < 0) + goto vm_error_wrong_type_arg; + + PUSH_LIST (ls, SCM_NULL_OR_NIL_P); + + nargs += len - 2; + goto vm_call; +} + +VM_DEFINE_INSTRUCTION (45, goto_apply, "goto/apply", 1, -1, 1) +{ + int len; + SCM ls; + POP (ls); + + nargs = FETCH (); + ASSERT (nargs >= 2); + + len = scm_ilength (ls); + if (len < 0) + goto vm_error_wrong_type_arg; + + PUSH_LIST (ls, SCM_NULL_OR_NIL_P); + + nargs += len - 2; + goto vm_goto_args; +} + +VM_DEFINE_INSTRUCTION (46, call_cc, "call/cc", 0, 1, 1) +{ + int first; + SCM proc, cont; + POP (proc); + SYNC_ALL (); + cont = scm_make_continuation (&first); + if (first) + { + PUSH ((SCM)fp); /* dynamic link */ + PUSH (0); /* mvra */ + PUSH (0); /* ra */ + PUSH (proc); + PUSH (cont); + nargs = 1; + goto vm_call; + } + ASSERT (sp == vp->sp); + ASSERT (fp == vp->fp); + else if (SCM_VALUESP (cont)) + { + /* multiple values returned to continuation */ + SCM values; + values = scm_struct_ref (cont, SCM_INUM0); + if (SCM_NULLP (values)) + goto vm_error_no_values; + /* non-tail context does not accept multiple values? */ + PUSH (SCM_CAR (values)); + NEXT; + } + else + { + PUSH (cont); + NEXT; + } +} + +VM_DEFINE_INSTRUCTION (47, goto_cc, "goto/cc", 0, 1, 1) +{ + int first; + SCM proc, cont; + POP (proc); + SYNC_ALL (); + cont = scm_make_continuation (&first); + ASSERT (sp == vp->sp); + ASSERT (fp == vp->fp); + if (first) + { + PUSH (proc); + PUSH (cont); + nargs = 1; + goto vm_goto_args; + } + else if (SCM_VALUESP (cont)) + { + /* multiple values returned to continuation */ + SCM values; + values = scm_struct_ref (cont, SCM_INUM0); + nvalues = scm_ilength (values); + PUSH_LIST (values, SCM_NULLP); + goto vm_return_values; + } + else + { + PUSH (cont); + goto vm_return; + } +} + +VM_DEFINE_INSTRUCTION (48, return, "return", 0, 1, 1) +{ + vm_return: + EXIT_HOOK (); + RETURN_HOOK (); + SYNC_REGISTER (); + SCM_TICK; /* allow interrupt here */ + { + SCM ret; + + POP (ret); + ASSERT (sp == stack_base); + ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1); + + /* Restore registers */ + sp = SCM_FRAME_LOWER_ADDRESS (fp); + ip = SCM_FRAME_RETURN_ADDRESS (fp); + fp = SCM_FRAME_DYNAMIC_LINK (fp); + { +#ifdef VM_ENABLE_STACK_NULLING + int nullcount = stack_base - sp; +#endif + stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1; + NULLSTACK (nullcount); + } + + /* Set return value (sp is already pushed) */ + *sp = ret; + } + + /* Restore the last program */ + program = SCM_FRAME_PROGRAM (fp); + CACHE_PROGRAM (); + CHECK_IP (); + NEXT; +} + +VM_DEFINE_INSTRUCTION (49, 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. */ + nvalues = FETCH (); + vm_return_values: + EXIT_HOOK (); + RETURN_HOOK (); + + ASSERT (stack_base == SCM_FRAME_UPPER_ADDRESS (fp) - 1); + + /* data[1] is the mv return address */ + if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp)) + { + int i; + /* Restore registers */ + sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; + ip = SCM_FRAME_MV_RETURN_ADDRESS (fp); + fp = SCM_FRAME_DYNAMIC_LINK (fp); + + /* Push return values, and the number of values */ + for (i = 0; i < nvalues; i++) + *++sp = stack_base[1+i]; + *++sp = SCM_I_MAKINUM (nvalues); + + /* Finally set new stack_base */ + NULLSTACK (stack_base - sp + nvalues + 1); + stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1; + } + else if (nvalues >= 1) + { + /* Multiple values for a single-valued continuation -- here's where I + break with guile tradition and try and do something sensible. (Also, + this block handles the single-valued return to an mv + continuation.) */ + /* Restore registers */ + sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; + ip = SCM_FRAME_RETURN_ADDRESS (fp); + fp = SCM_FRAME_DYNAMIC_LINK (fp); + + /* Push first value */ + *++sp = stack_base[1]; + + /* Finally set new stack_base */ + NULLSTACK (stack_base - sp + nvalues + 1); + stack_base = SCM_FRAME_UPPER_ADDRESS (fp) - 1; + } + else + goto vm_error_no_values; + + /* Restore the last program */ + program = SCM_FRAME_PROGRAM (fp); + CACHE_PROGRAM (); + CHECK_IP (); + NEXT; +} + +VM_DEFINE_INSTRUCTION (50, return_values_star, "return/values*", 1, -1, -1) +{ + SCM l; + + nvalues = FETCH (); + ASSERT (nvalues >= 1); + + nvalues--; + POP (l); + while (SCM_CONSP (l)) + { + PUSH (SCM_CAR (l)); + l = SCM_CDR (l); + nvalues++; + } + if (SCM_UNLIKELY (!SCM_NULL_OR_NIL_P (l))) { + finish_args = scm_list_1 (l); + goto vm_error_improper_list; + } + + goto vm_return_values; +} + +VM_DEFINE_INSTRUCTION (51, truncate_values, "truncate-values", 2, -1, -1) +{ + SCM x; + int nbinds, rest; + POP (x); + nvalues = scm_to_int (x); + nbinds = FETCH (); + rest = FETCH (); + + if (rest) + nbinds--; + + if (nvalues < nbinds) + goto vm_error_not_enough_values; + + if (rest) + POP_LIST (nvalues - nbinds); + else + DROPN (nvalues - nbinds); + + NEXT; +} + +VM_DEFINE_INSTRUCTION (52, 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 (53, 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 (54, 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 (55, 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 (56, 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 (57, 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 (58, 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 (59, make_closure, "make-closure", 0, 2, 1) +{ + SCM vect; + POP (vect); + SYNC_BEFORE_GC (); + /* fixme underflow */ + *sp = scm_double_cell (scm_tc7_program, (scm_t_bits)SCM_PROGRAM_OBJCODE (*sp), + (scm_t_bits)SCM_PROGRAM_OBJTABLE (*sp), (scm_t_bits)vect); + NEXT; +} + +VM_DEFINE_INSTRUCTION (60, 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 (61, 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 (62, 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 (63, make_keyword, "make-keyword", 0, 1, 1) +{ + CHECK_UNDERFLOW (); + SYNC_REGISTER (); + *sp = scm_symbol_to_keyword (*sp); + NEXT; +} + +VM_DEFINE_INSTRUCTION (64, 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" + (interactive "") + (save-excursion + (let ((counter -1)) (goto-char (point-min)) + (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t) + (replace-match + (number-to-string (setq counter (1+ counter))) + t t nil 1))))) +*/ +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm.c b/libguile/vm.c new file mode 100644 index 000000000..95aaa4fe4 --- /dev/null +++ b/libguile/vm.c @@ -0,0 +1,683 @@ +/* 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 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 + */ + +#if HAVE_CONFIG_H +# include <config.h> +#endif + +#include <stdlib.h> +#include <alloca.h> +#include <string.h> +#include <assert.h> + +#include "libguile/boehm-gc.h" +#include <gc/gc_mark.h> + +#include "_scm.h" +#include "vm-bootstrap.h" +#include "frames.h" +#include "instructions.h" +#include "objcodes.h" +#include "programs.h" +#include "lang.h" /* NULL_OR_NIL_P */ +#include "vm.h" + +/* I sometimes use this for debugging. */ +#define vm_puts(OBJ) \ +{ \ + scm_display (OBJ, scm_current_error_port ()); \ + scm_newline (scm_current_error_port ()); \ +} + +/* The VM has a number of internal assertions that shouldn't normally be + necessary, but might be if you think you found a bug in the VM. */ +#define VM_ENABLE_ASSERTIONS + +/* We can add a mode that ensures that all stack items above the stack pointer + are NULL. This is useful for checking the internal consistency of the VM's + assumptions and its operators, but isn't necessary for normal operation. It + will ensure that assertions are enabled. Slows down the VM by about 30%. */ +/* NB! If you enable this, search for NULLING in throw.c */ +/* #define VM_ENABLE_STACK_NULLING */ + +/* #define VM_ENABLE_PARANOID_ASSERTIONS */ + +#if defined (VM_ENABLE_STACK_NULLING) && !defined (VM_ENABLE_ASSERTIONS) +#define VM_ENABLE_ASSERTIONS +#endif + +/* When defined, arrange so that the GC doesn't scan the VM stack beyond its + current SP. This should help avoid excess data retention. See + http://thread.gmane.org/gmane.comp.programming.garbage-collection.boehmgc/3001 + for a discussion. */ +#define VM_ENABLE_PRECISE_STACK_GC_SCAN + + + +/* + * VM Continuation + */ + +scm_t_bits scm_tc16_vm_cont; + +static SCM +capture_vm_cont (struct scm_vm *vp) +{ + struct scm_vm_cont *p = scm_gc_malloc (sizeof (*p), "capture_vm_cont"); + p->stack_size = vp->sp - vp->stack_base + 1; + p->stack_base = scm_gc_malloc (p->stack_size * sizeof (SCM), + "capture_vm_cont"); +#ifdef VM_ENABLE_STACK_NULLING + if (vp->sp >= vp->stack_base) + if (!vp->sp[0] || vp->sp[1]) + abort (); + memset (p->stack_base, 0, p->stack_size * sizeof (SCM)); +#endif + p->ip = vp->ip; + p->sp = vp->sp; + p->fp = vp->fp; + memcpy (p->stack_base, vp->stack_base, p->stack_size * sizeof (SCM)); + p->reloc = p->stack_base - vp->stack_base; + SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p); +} + +static void +reinstate_vm_cont (struct scm_vm *vp, SCM cont) +{ + struct scm_vm_cont *p = SCM_VM_CONT_DATA (cont); + if (vp->stack_size < p->stack_size) + { + /* puts ("FIXME: Need to expand"); */ + abort (); + } +#ifdef VM_ENABLE_STACK_NULLING + { + scm_t_ptrdiff nzero = (vp->sp - p->sp); + if (nzero > 0) + memset (vp->stack_base + p->stack_size, 0, nzero * sizeof (SCM)); + /* actually nzero should always be negative, because vm_reset_stack will + unwind the stack to some point *below* this continuation */ + } +#endif + vp->ip = p->ip; + vp->sp = p->sp; + vp->fp = p->fp; + memcpy (vp->stack_base, p->stack_base, p->stack_size * sizeof (SCM)); +} + +/* In theory, a number of vm instances can be active in the call trace, and we + only want to reify the continuations of those in the current continuation + root. I don't see a nice way to do this -- ideally it would involve dynwinds, + and previous values of the *the-vm* fluid within the current continuation + root. But we don't have access to continuation roots in the dynwind stack. + So, just punt for now -- take the current value of *the-vm*. + + While I'm on the topic, ideally we could avoid copying the C stack if the + continuation root is inside VM code, and call/cc was invoked within that same + call to vm_run; but that's currently not implemented. + */ +SCM +scm_vm_capture_continuations (void) +{ + SCM vm = scm_the_vm (); + return scm_acons (vm, capture_vm_cont (SCM_VM_DATA (vm)), SCM_EOL); +} + +void +scm_vm_reinstate_continuations (SCM conts) +{ + for (; conts != SCM_EOL; conts = SCM_CDR (conts)) + reinstate_vm_cont (SCM_VM_DATA (SCM_CAAR (conts)), SCM_CDAR (conts)); +} + +static void enfalsen_frame (void *p) +{ + struct scm_vm *vp = p; + vp->trace_frame = SCM_BOOL_F; +} + +static void +vm_dispatch_hook (struct scm_vm *vp, SCM hook, SCM hook_args) +{ + if (!SCM_FALSEP (vp->trace_frame)) + return; + + scm_dynwind_begin (0); + // FIXME, stack holder should be the vm + vp->trace_frame = scm_c_make_vm_frame (SCM_BOOL_F, vp->fp, vp->sp, vp->ip, 0); + scm_dynwind_unwind_handler (enfalsen_frame, vp, SCM_F_WIND_EXPLICITLY); + + scm_c_run_hook (hook, hook_args); + + scm_dynwind_end (); +} + + +/* + * VM Internal functions + */ + +static SCM sym_vm_run; +static SCM sym_vm_error; +static SCM sym_debug; + +static SCM +really_make_boot_program (long nargs) +{ + SCM u8vec; + 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; + + if (SCM_UNLIKELY (nargs > 255 || nargs < 0)) + abort (); + text[1] = (scm_t_uint8)nargs; + + bp = scm_malloc (sizeof (struct scm_objcode) + sizeof (text)); + 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 +static SCM +vm_make_boot_program (long nargs) +{ + static SCM programs[NUM_BOOT_PROGS] = { 0, }; + + if (SCM_UNLIKELY (!programs[0])) + { + int i; + for (i = 0; i < NUM_BOOT_PROGS; i++) + programs[i] = scm_permanent_object (really_make_boot_program (i)); + } + + if (SCM_LIKELY (nargs < NUM_BOOT_PROGS)) + return programs[nargs]; + else + return really_make_boot_program (nargs); +} + + +/* + * VM + */ + +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" +#define VM_ENGINE SCM_VM_REGULAR_ENGINE +#include "vm-engine.c" +#undef VM_NAME +#undef FUNC_NAME +#undef VM_ENGINE + +#define VM_NAME vm_debug_engine +#define FUNC_NAME "vm-debug-engine" +#define VM_ENGINE SCM_VM_DEBUG_ENGINE +#include "vm-engine.c" +#undef VM_NAME +#undef FUNC_NAME +#undef VM_ENGINE + +static const scm_t_vm_engine vm_engines[] = + { vm_regular_engine, vm_debug_engine }; + +scm_t_bits scm_tc16_vm; + +#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN + +/* The GC "kind" for the VM stack. */ +static int vm_stack_gc_kind; + +#endif + +static SCM +make_vm (void) +#define FUNC_NAME "make_vm" +{ + int i; + + if (!scm_tc16_vm) + return SCM_BOOL_F; /* not booted yet */ + + struct scm_vm *vp = scm_gc_malloc (sizeof (struct scm_vm), "vm"); + + vp->stack_size = VM_DEFAULT_STACK_SIZE; + +#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN + vp->stack_base = GC_generic_malloc (vp->stack_size * sizeof (SCM), + vm_stack_gc_kind); + + /* Keep a pointer to VP so that `vm_stack_mark ()' can know what the stack + top is. */ + *vp->stack_base = PTR2SCM (vp); + vp->stack_base++; + vp->stack_size--; +#else + vp->stack_base = scm_gc_malloc (vp->stack_size * sizeof (SCM), + "stack-base"); +#endif + +#ifdef VM_ENABLE_STACK_NULLING + memset (vp->stack_base, 0, vp->stack_size * sizeof (SCM)); +#endif + vp->stack_limit = vp->stack_base + vp->stack_size; + vp->ip = NULL; + vp->sp = vp->stack_base - 1; + vp->fp = NULL; + vp->engine = SCM_VM_DEBUG_ENGINE; + vp->time = 0; + vp->clock = 0; + vp->options = SCM_EOL; + for (i = 0; i < SCM_VM_NUM_HOOKS; i++) + vp->hooks[i] = SCM_BOOL_F; + vp->trace_frame = SCM_BOOL_F; + SCM_RETURN_NEWSMOB (scm_tc16_vm, vp); +} +#undef FUNC_NAME + +#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN + +/* Mark the VM stack region between its base and its current top. */ +static struct GC_ms_entry * +vm_stack_mark (GC_word *addr, struct GC_ms_entry *mark_stack_ptr, + struct GC_ms_entry *mark_stack_limit, GC_word env) +{ + GC_word *word; + const struct scm_vm *vm; + + /* The first word of the VM stack should contain a pointer to the + corresponding VM. */ + vm = * ((struct scm_vm **) addr); + + if ((SCM *) addr != vm->stack_base - 1 + || vm->stack_limit - vm->stack_base != vm->stack_size) + /* ADDR must be a pointer to a free-list element, which we must ignore + (see warning in <gc/gc_mark.h>). */ + return mark_stack_ptr; + + for (word = (GC_word *) vm->stack_base; word <= (GC_word *) vm->sp; word++) + mark_stack_ptr = GC_MARK_AND_PUSH ((* (GC_word **) word), + mark_stack_ptr, mark_stack_limit, + NULL); + + return mark_stack_ptr; +} + +#endif /* VM_ENABLE_PRECISE_STACK_GC_SCAN */ + + +SCM +scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs) +{ + struct scm_vm *vp = SCM_VM_DATA (vm); + return vm_engines[vp->engine](vp, program, argv, nargs); +} + +SCM +scm_vm_apply (SCM vm, SCM program, SCM args) +#define FUNC_NAME "scm_vm_apply" +{ + SCM *argv; + int i, nargs; + + SCM_VALIDATE_VM (1, vm); + SCM_VALIDATE_PROGRAM (2, program); + + nargs = scm_ilength (args); + if (SCM_UNLIKELY (nargs < 0)) + scm_wrong_type_arg_msg (FUNC_NAME, 3, args, "list"); + + argv = alloca(nargs * sizeof(SCM)); + for (i = 0; i < nargs; i++) + { + argv[i] = SCM_CAR (args); + args = SCM_CDR (args); + } + + return scm_c_vm_run (vm, program, argv, nargs); +} +#undef FUNC_NAME + +/* Scheme interface */ + +SCM_DEFINE (scm_vm_version, "vm-version", 0, 0, 0, + (void), + "") +#define FUNC_NAME s_scm_vm_version +{ + return scm_from_locale_string (PACKAGE_VERSION); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_the_vm, "the-vm", 0, 0, 0, + (void), + "") +#define FUNC_NAME s_scm_the_vm +{ + scm_i_thread *t = SCM_I_CURRENT_THREAD; + + if (SCM_UNLIKELY (SCM_FALSEP ((t->vm)))) + t->vm = make_vm (); + + return t->vm; +} +#undef FUNC_NAME + + +SCM_DEFINE (scm_vm_p, "vm?", 1, 0, 0, + (SCM obj), + "") +#define FUNC_NAME s_scm_vm_p +{ + return SCM_BOOL (SCM_VM_P (obj)); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_make_vm, "make-vm", 0, 0, 0, + (void), + "") +#define FUNC_NAME s_scm_make_vm, +{ + return make_vm (); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_ip, "vm:ip", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_ip +{ + SCM_VALIDATE_VM (1, vm); + return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->ip); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_sp, "vm:sp", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_sp +{ + SCM_VALIDATE_VM (1, vm); + return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->sp); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_fp, "vm:fp", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_fp +{ + SCM_VALIDATE_VM (1, vm); + return scm_from_ulong ((unsigned long) SCM_VM_DATA (vm)->fp); +} +#undef FUNC_NAME + +#define VM_DEFINE_HOOK(n) \ +{ \ + struct scm_vm *vp; \ + SCM_VALIDATE_VM (1, vm); \ + vp = SCM_VM_DATA (vm); \ + if (SCM_FALSEP (vp->hooks[n])) \ + vp->hooks[n] = scm_make_hook (SCM_I_MAKINUM (1)); \ + return vp->hooks[n]; \ +} + +SCM_DEFINE (scm_vm_boot_hook, "vm-boot-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_boot_hook +{ + VM_DEFINE_HOOK (SCM_VM_BOOT_HOOK); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_halt_hook, "vm-halt-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_halt_hook +{ + VM_DEFINE_HOOK (SCM_VM_HALT_HOOK); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_next_hook, "vm-next-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_next_hook +{ + VM_DEFINE_HOOK (SCM_VM_NEXT_HOOK); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_break_hook, "vm-break-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_break_hook +{ + VM_DEFINE_HOOK (SCM_VM_BREAK_HOOK); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_enter_hook, "vm-enter-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_enter_hook +{ + VM_DEFINE_HOOK (SCM_VM_ENTER_HOOK); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_apply_hook, "vm-apply-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_apply_hook +{ + VM_DEFINE_HOOK (SCM_VM_APPLY_HOOK); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_exit_hook, "vm-exit-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_exit_hook +{ + VM_DEFINE_HOOK (SCM_VM_EXIT_HOOK); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_return_hook, "vm-return-hook", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_return_hook +{ + VM_DEFINE_HOOK (SCM_VM_RETURN_HOOK); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_option, "vm-option", 2, 0, 0, + (SCM vm, SCM key), + "") +#define FUNC_NAME s_scm_vm_option +{ + SCM_VALIDATE_VM (1, vm); + return scm_assq_ref (SCM_VM_DATA (vm)->options, key); +} +#undef FUNC_NAME + +SCM_DEFINE (scm_set_vm_option_x, "set-vm-option!", 3, 0, 0, + (SCM vm, SCM key, SCM val), + "") +#define FUNC_NAME s_scm_set_vm_option_x +{ + SCM_VALIDATE_VM (1, vm); + SCM_VM_DATA (vm)->options + = scm_assq_set_x (SCM_VM_DATA (vm)->options, key, val); + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_stats, "vm-stats", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_stats +{ + SCM stats; + + SCM_VALIDATE_VM (1, vm); + + stats = scm_make_vector (SCM_I_MAKINUM (2), SCM_UNSPECIFIED); + scm_vector_set_x (stats, SCM_I_MAKINUM (0), + scm_from_ulong (SCM_VM_DATA (vm)->time)); + scm_vector_set_x (stats, SCM_I_MAKINUM (1), + scm_from_ulong (SCM_VM_DATA (vm)->clock)); + + return stats; +} +#undef FUNC_NAME + +SCM_DEFINE (scm_vm_trace_frame, "vm-trace-frame", 1, 0, 0, + (SCM vm), + "") +#define FUNC_NAME s_scm_vm_trace_frame +{ + SCM_VALIDATE_VM (1, vm); + return SCM_VM_DATA (vm)->trace_frame; +} +#undef FUNC_NAME + + +/* + * Initialize + */ + +SCM scm_load_compiled_with_vm (SCM file) +{ + SCM program = scm_make_program (scm_load_objcode (file), + SCM_BOOL_F, SCM_BOOL_F); + + return scm_c_vm_run (scm_the_vm (), program, NULL, 0); +} + +void +scm_bootstrap_vm (void) +{ + static int strappage = 0; + + if (strappage) + return; + + scm_bootstrap_frames (); + scm_bootstrap_instructions (); + scm_bootstrap_objcodes (); + scm_bootstrap_programs (); + + scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0); + + scm_tc16_vm = scm_make_smob_type ("vm", 0); + scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1); + + scm_c_define ("load-compiled", + scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0, + scm_load_compiled_with_vm)); + + sym_vm_run = scm_permanent_object (scm_from_locale_symbol ("vm-run")); + 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; + +#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN + vm_stack_gc_kind = + GC_new_kind (GC_new_free_list (), + GC_MAKE_PROC (GC_new_proc (vm_stack_mark), 0), + 0, 1); + +#endif +} + +void +scm_init_vm (void) +{ + scm_bootstrap_vm (); + +#ifndef SCM_MAGIC_SNARFER +#include "libguile/vm.x" +#endif +} + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ diff --git a/libguile/vm.h b/libguile/vm.h new file mode 100644 index 000000000..eace1cb69 --- /dev/null +++ b/libguile/vm.h @@ -0,0 +1,116 @@ +/* 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 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_H_ +#define _SCM_VM_H_ + +#include <libguile.h> +#include <libguile/programs.h> + +#define SCM_VM_BOOT_HOOK 0 +#define SCM_VM_HALT_HOOK 1 +#define SCM_VM_NEXT_HOOK 2 +#define SCM_VM_BREAK_HOOK 3 +#define SCM_VM_ENTER_HOOK 4 +#define SCM_VM_APPLY_HOOK 5 +#define SCM_VM_EXIT_HOOK 6 +#define SCM_VM_RETURN_HOOK 7 +#define SCM_VM_NUM_HOOKS 8 + +struct scm_vm; + +typedef SCM (*scm_t_vm_engine) (struct scm_vm *vp, SCM program, SCM *argv, int nargs); + +#define SCM_VM_REGULAR_ENGINE 0 +#define SCM_VM_DEBUG_ENGINE 1 +#define SCM_VM_NUM_ENGINES 2 + +struct scm_vm { + scm_t_uint8 *ip; /* instruction pointer */ + SCM *sp; /* stack pointer */ + SCM *fp; /* frame pointer */ + size_t stack_size; /* stack size */ + SCM *stack_base; /* stack base address */ + SCM *stack_limit; /* stack limit address */ + int engine; /* which vm engine we're using */ + SCM hooks[SCM_VM_NUM_HOOKS]; /* hooks */ + SCM options; /* options */ + unsigned long time; /* time spent */ + unsigned long clock; /* bogos clock */ + SCM trace_frame; /* a frame being traced */ +}; + +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) + +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_t_uint8 *ip; + SCM *sp; + SCM *fp; + scm_t_ptrdiff stack_size; + SCM *stack_base; + scm_t_ptrdiff reloc; +}; + +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)) + +SCM_API SCM scm_vm_capture_continuations (void); +SCM_API void scm_vm_reinstate_continuations (SCM conts); + +SCM_API SCM scm_load_compiled_with_vm (SCM file); + +SCM_INTERNAL void scm_init_vm (void); + +#endif /* _SCM_VM_H_ */ + +/* + Local Variables: + c-file-style: "gnu" + End: +*/ 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 6af4d6722..4719980a7 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -1,18 +1,19 @@ /* Copyright (C) 1995,1996,1998,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/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 |