summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--NEWS156
-rw-r--r--libguile.h9
-rw-r--r--libguile/Makefile.am488
-rw-r--r--libguile/array-handle.c162
-rw-r--r--libguile/array-handle.h129
-rw-r--r--libguile/array-map.c (renamed from libguile/ramap.c)25
-rw-r--r--libguile/array-map.h (renamed from libguile/ramap.h)10
-rw-r--r--libguile/arrays.c1156
-rw-r--r--libguile/arrays.h91
-rw-r--r--libguile/bitvectors.c910
-rw-r--r--libguile/bitvectors.h81
-rw-r--r--libguile/bytevectors.c318
-rw-r--r--libguile/bytevectors.h16
-rw-r--r--libguile/convert.c147
-rw-r--r--libguile/convert.h51
-rw-r--r--libguile/convert.i.c171
-rw-r--r--libguile/deprecated.c3
-rw-r--r--libguile/deprecated.h3
-rw-r--r--libguile/eq.c6
-rw-r--r--libguile/extensions.c5
-rw-r--r--libguile/gc-card.c2
-rw-r--r--libguile/gc-malloc.c4
-rw-r--r--libguile/gc-mark.c2
-rw-r--r--libguile/gc.c4
-rw-r--r--libguile/generalized-arrays.c276
-rw-r--r--libguile/generalized-arrays.h63
-rw-r--r--libguile/generalized-vectors.c201
-rw-r--r--libguile/generalized-vectors.h61
-rw-r--r--libguile/init.c27
-rw-r--r--libguile/inline.h17
-rw-r--r--libguile/print.c1
-rw-r--r--libguile/random.c5
-rw-r--r--libguile/read.c3
-rw-r--r--libguile/socket.c4
-rw-r--r--libguile/sort.c6
-rw-r--r--libguile/srfi-4.c329
-rw-r--r--libguile/srfi-4.h31
-rw-r--r--libguile/srfi-4.i.c15
-rw-r--r--libguile/strings.c31
-rw-r--r--libguile/strports.c2
-rw-r--r--libguile/unif.c3034
-rw-r--r--libguile/unif.h198
-rw-r--r--libguile/uniform.c254
-rw-r--r--libguile/uniform.h77
-rw-r--r--libguile/vectors.c153
-rw-r--r--libguile/vectors.h17
-rw-r--r--module/Makefile.am1
-rw-r--r--module/ice-9/deprecated.scm12
-rw-r--r--module/srfi/srfi-4/gnu.scm52
-rw-r--r--test-suite/tests/unif.test4
50 files changed, 4478 insertions, 4345 deletions
diff --git a/NEWS b/NEWS
index 3cc579be3..0f2d6930d 100644
--- a/NEWS
+++ b/NEWS
@@ -8,100 +8,25 @@ Please send Guile bug reports to bug-guile@gnu.org.
(During the 1.9 series, we will keep an incremental NEWS for the latest
prerelease, and a full NEWS corresponding to 1.8 -> 2.0.)
-Changes in 1.9.2 (since the 1.9.1 prerelease):
+Changes in 1.9.3 (since the 1.9.2 prerelease):
-** VM speed improvements
+** Removed deprecated uniform array procedures: scm_make_uve,
+ scm_array_prototype, scm_list_to_uniform_array,
+ scm_dimensions_to_uniform_array, scm_make_ra, scm_shap2ra, scm_cvref,
+ scm_ra_set_contp, scm_aind, scm_raprin1
-Closures now copy the free variables that they need into a flat vector
-instead of capturing all heap-allocated variables. This speeds up access
-to free variables, avoids unnecessary garbage retention, and allows all
-variables to be allocated on the stack.
+These functions have been deprecated since early 2005.
-Variables which are `set!' are now allocated on the stack, but in
-"boxes". This allows a more uniform local variable allocation
-discipline, and allows faster access to these variables.
+** scm_array_p has one argument, not two
-The VM has new special-case operations, `add1' and `sub1'.
+Use of the second argument produced a deprecation warning, so it is
+unlikely that any code out there actually used this functionality.
-** VM robustness improvements
+** Removed deprecated uniform array procedures:
+ dimensions->uniform-array, list->uniform-array, array-prototype
-The maximum number of live local variables has been increased from 256
-to 65535.
-
-The default VM stack size is 64 kilo-words, up from 16 kilo-words. This
-allows more programs to execute in the default stack space. In the
-future we will probably implement extensible stacks via overflow
-handlers.
-
-Some lingering cases in which the VM could perform unaligned accesses
-have been fixed.
-
-The address range for relative jumps has been expanded from 16-bit
-addresses to 19-bit addresses via 8-byte alignment of jump targets. This
-will probably change to a 24-bit byte-addressable strategy before Guile
-2.0.
-
-** Compiler optimizations
-
-Procedures bound by `letrec' are no longer allocated on the heap,
-subject to a few constraints. In many cases, procedures bound by
-`letrec' and `let' can be rendered inline to their parent function, with
-loop detection for mutually tail-recursive procedures.
-
-Unreferenced variables are now optimized away.
-
-** Compiler robustness
-
-Guile may now warn about unused lexically-bound variables. Pass
-`-Wunused-variable' to `guile-tools compile', or `#:warnings
-(unused-variable)' within the #:opts argument to the `compile' procedure
-from `(system base compile)'.
-
-** Incomplete support for Unicode characters and strings
-
-Preliminary support for Unicode has landed. Characters may be entered in
-octal format via e.g. `#\454', or created via (integer->char 300). A hex
-external representation will probably be introduced at some point.
-
-Internally, strings are now represented either in the `latin-1'
-encoding, one byte per character, or in UTF-32, with four bytes per
-character. Strings manage their own allocation, switching if needed.
-
-Currently no locale conversion is performed. Extended characters may be
-written in a string using the hexadecimal escapes `\xXX', `\uXXXX', or
-`\UXXXXXX', for 8-bit, 16-bit, or 24-bit codepoints, respectively.
-
-This support is obviously incomplete. Many C functions have not yet been
-updated to deal with the new representations. Users are advised to wait
-for the next release for more serious use of Unicode strings.
-
-** `defined?' may accept a module as its second argument
-
-Previously it only accepted internal structures from the evaluator.
-
-** `let-values' is now implemented with a hygienic macro
-
-This could have implications discussed below in the NEWS entry titled,
-"Lexical bindings introduced by hygienic macros may not be referenced by
-nonhygienic macros".
-
-** Global variables `scm_charnames' and `scm_charnums' are removed
-
-These variables contained the names of control characters and were
-used when writing characters. While these were global, they were
-never intended to be public API. They have been replaced with private
-functions.
-
-** EBCDIC support is removed
-
-There was an EBCDIC compile flag that altered some of the character
-processing. It appeared that full EBCDIC support was never completed
-and was unmaintained.
-
-** Packaging changes
-
-Guile now provides `guile-2.0.pc' (used by pkg-config) instead of
-`guile-1.8.pc'.
+Instead, use make-typed-array, list->typed-array, or array-type,
+respectively.
** And of course, the usual collection of bugfixes
@@ -555,6 +480,35 @@ This decision may be revisited before the 2.0 release. Feedback welcome
to guile-devel@gnu.org (subscription required) or bug-guile@gnu.org (no
subscription required).
+** Unicode characters
+
+Unicode characters may be entered in octal format via e.g. `#\454', or
+created via (integer->char 300). A hex external representation will
+probably be introduced at some point.
+
+** Unicode strings
+
+Internally, strings are now represented either in the `latin-1'
+encoding, one byte per character, or in UTF-32, with four bytes per
+character. Strings manage their own allocation, switching if needed.
+
+Currently no locale conversion is performed. Extended characters may be
+written in a string using the hexadecimal escapes `\xXX', `\uXXXX', or
+`\UXXXXXX', for 8-bit, 16-bit, or 24-bit codepoints, respectively.
+
+** Global variables `scm_charnames' and `scm_charnums' are removed
+
+These variables contained the names of control characters and were
+used when writing characters. While these were global, they were
+never intended to be public API. They have been replaced with private
+functions.
+
+** EBCDIC support is removed
+
+There was an EBCDIC compile flag that altered some of the character
+processing. It appeared that full EBCDIC support was never completed
+and was unmaintained.
+
** New macro type: syncase-macro
XXX Need to decide whether to document this for 2.0, probably should:
@@ -588,6 +542,10 @@ These are analogous to %load-path and %load-extensions.
`(make-promise (lambda () foo))' is equivalent to `(delay foo)'.
+** `defined?' may accept a module as its second argument
+
+Previously it only accepted internal structures from the evaluator.
+
** New entry into %guile-build-info: `ccachedir'
** Fix bug in `module-bound?'.
@@ -601,6 +559,12 @@ the variable. This was an error, and was fixed.
As syntax-case is available by default, importing `(ice-9 syncase)' has
no effect, and will trigger a deprecation warning.
+** Removed deprecated uniform array procedures:
+ dimensions->uniform-array, list->uniform-array, array-prototype
+
+Instead, use make-typed-array, list->typed-array, or array-type,
+respectively.
+
* Changes to the C interface
** The GH interface (deprecated in version 1.6, 2001) was removed.
@@ -629,6 +593,18 @@ definition depends on the application's value for `_FILE_OFFSET_BITS'.
** The `long_long' C type, deprecated in 1.8, has been removed
+** Removed deprecated uniform array procedures: scm_make_uve,
+ scm_array_prototype, scm_list_to_uniform_array,
+ scm_dimensions_to_uniform_array, scm_make_ra, scm_shap2ra, scm_cvref,
+ scm_ra_set_contp, scm_aind, scm_raprin1
+
+These functions have been deprecated since early 2005.
+
+** scm_array_p has one argument, not two
+
+Use of the second argument produced a deprecation warning, so it is
+unlikely that any code out there actually used this functionality.
+
* Changes to the distribution
** Guile's license is now LGPLv3+
@@ -656,8 +632,8 @@ to /usr/lib/guile/1.9/ccache. These files are architecture-specific.
** New dependency: GNU libunistring.
-See http://www.gnu.org/software/libunistring/. We hope to merge in
-Unicode support in the next prerelease.
+See http://www.gnu.org/software/libunistring/, for more information. Our
+unicode support uses routines from libunistring.
diff --git a/libguile.h b/libguile.h
index 7b5649b8f..74674d5b9 100644
--- a/libguile.h
+++ b/libguile.h
@@ -31,8 +31,12 @@ extern "C" {
#include "libguile/__scm.h"
#include "libguile/alist.h"
#include "libguile/arbiters.h"
+#include "libguile/array-handle.h"
+#include "libguile/array-map.h"
+#include "libguile/arrays.h"
#include "libguile/async.h"
#include "libguile/boolean.h"
+#include "libguile/bitvectors.h"
#include "libguile/bytevectors.h"
#include "libguile/chars.h"
#include "libguile/continuations.h"
@@ -50,6 +54,8 @@ extern "C" {
#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/guardians.h"
@@ -78,7 +84,6 @@ extern "C" {
#include "libguile/properties.h"
#include "libguile/procs.h"
#include "libguile/r6rs-ports.h"
-#include "libguile/ramap.h"
#include "libguile/random.h"
#include "libguile/read.h"
#include "libguile/root.h"
@@ -101,7 +106,7 @@ extern "C" {
#include "libguile/symbols.h"
#include "libguile/tags.h"
#include "libguile/throw.h"
-#include "libguile/unif.h"
+#include "libguile/uniform.h"
#include "libguile/validate.h"
#include "libguile/values.h"
#include "libguile/variable.h"
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 09be8785f..ab372b6ee 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -105,27 +105,109 @@ guile_LDFLAGS = $(GUILE_CFLAGS)
libguile_la_CFLAGS = $(GUILE_CFLAGS) $(AM_CFLAGS)
-libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
- bytevectors.c chars.c continuations.c \
- convert.c debug.c deprecation.c \
- deprecated.c discouraged.c dynwind.c eq.c error.c \
- eval.c evalext.c extensions.c feature.c fluids.c fports.c \
- futures.c gc.c gc-mark.c gc-segment.c gc-malloc.c gc-card.c \
- gc-freelist.c gc_os_dep.c gdbint.c gettext.c gc-segment-table.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 \
- r6rs-ports.c random.c rdelim.c read.c \
- root.c rw.c scmsigs.c script.c simpos.c smob.c sort.c srcprop.c \
- stackchk.c stacks.c stime.c strings.c srfi-4.c srfi-13.c srfi-14.c \
- strorder.c strports.c struct.c symbols.c threads.c null-threads.c \
- throw.c values.c variable.c vectors.c version.c vports.c weaks.c \
- ramap.c unif.c
-
-# vm-related sources
-libguile_la_SOURCES += frames.c instructions.c objcodes.c programs.c vm.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-card.c \
+ gc-freelist.c \
+ gc-malloc.c \
+ gc-mark.c \
+ gc-segment-table.c \
+ gc-segment.c \
+ gc.c \
+ gc_os_dep.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 = \
@@ -136,48 +218,202 @@ 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 \
- bytevectors.x chars.x \
- continuations.x debug.x deprecation.x deprecated.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.x gc-mark.x \
- gc-segment.x gc-malloc.x gc-card.x gettext.x goops.x \
- gsubr.x guardians.x gc-segment-table.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 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-card.x \
+ gc-malloc.x \
+ gc-mark.x \
+ gc-segment-table.x \
+ gc-segment.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 bytevectors.doc chars.doc \
- continuations.doc debug.doc deprecation.doc \
- deprecated.doc discouraged.doc dynl.doc dynwind.doc \
- eq.doc error.doc eval.doc evalext.doc \
- extensions.doc feature.doc fluids.doc fports.doc futures.doc \
- gc.doc goops.doc gsubr.doc gc-mark.doc gc-segment.doc \
- gc-malloc.doc gc-card.doc gettext.doc gc-segment-table.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 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-card.doc \
+ gc-malloc.doc \
+ gc-mark.doc \
+ gc-segment-table.doc \
+ gc-segment.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@
@@ -208,8 +444,7 @@ 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 \
+noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \
eval.i.c ieee-754.h \
srfi-4.i.c \
quicksort.i.c \
@@ -235,28 +470,119 @@ 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 \
- boolean.h bytevectors.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 r6rs-ports.h regex-posix.h print.h \
- procprop.h procs.h properties.h \
- random.h ramap.h rdelim.h read.h root.h rw.h scmsigs.h validate.h \
- script.h simpos.h smob.h snarf.h socket.h sort.h srcprop.h \
- stackchk.h stacks.h stime.h strings.h srfi-4.h srfi-13.h srfi-14.h \
- 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 += vm-bootstrap.h frames.h instructions.h objcodes.h \
- programs.h vm.h vm-engine.h vm-expand.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
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 e141c18b7..fb9ceea37 100644
--- a/libguile/ramap.c
+++ b/libguile/array-map.c
@@ -1,4 +1,4 @@
-/* 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
@@ -17,10 +17,6 @@
*/
-/*
- HWN:FIXME::
- Someone should rename this to arraymap.c; that would reflect the
- contents better. */
@@ -31,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"
@@ -39,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
@@ -223,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;
@@ -236,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))
@@ -259,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;
@@ -294,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))
@@ -1222,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 d6cb19166..a198099f3 100644
--- a/libguile/ramap.h
+++ b/libguile/array-map.h
@@ -1,9 +1,9 @@
/* 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
@@ -48,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/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/bytevectors.c b/libguile/bytevectors.c
index 24afd2414..9c2b11910 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -31,7 +31,9 @@
#include "libguile/strings.h"
#include "libguile/validate.h"
#include "libguile/ieee-754.h"
-#include "libguile/unif.h"
+#include "libguile/arrays.h"
+#include "libguile/array-handle.h"
+#include "libguile/uniform.h"
#include "libguile/srfi-4.h"
#include <byteswap.h>
@@ -175,47 +177,99 @@
scm_t_bits scm_tc16_bytevector;
-#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
+#define SCM_BYTEVECTOR_INLINE_THRESHOLD (2 * sizeof (SCM))
+#define SCM_BYTEVECTOR_INLINEABLE_SIZE_P(_size) \
+ ((_size) <= SCM_BYTEVECTOR_INLINE_THRESHOLD)
+#define SCM_BYTEVECTOR_SET_LENGTH(_bv, _len) \
SCM_SET_SMOB_DATA ((_bv), (scm_t_bits) (_len))
-#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
+#define SCM_BYTEVECTOR_SET_CONTENTS(_bv, _buf) \
SCM_SET_SMOB_DATA_2 ((_bv), (scm_t_bits) (_buf))
+#define SCM_BYTEVECTOR_SET_INLINE(bv) \
+ SCM_SET_SMOB_FLAGS (bv, SCM_SMOB_FLAGS (bv) | SCM_F_BYTEVECTOR_INLINE)
+#define SCM_BYTEVECTOR_SET_ELEMENT_TYPE(bv, hint) \
+ SCM_SET_SMOB_FLAGS (bv, (SCM_SMOB_FLAGS (bv) & 0xFF) | (hint << 8))
+#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_from_buffer (size_t len, signed char *contents)
+make_bytevector_from_buffer (size_t len, void *contents,
+ scm_t_array_element_type element_type)
{
- /* Assuming LEN > SCM_BYTEVECTOR_INLINE_THRESHOLD. */
- SCM_RETURN_NEWSMOB2 (scm_tc16_bytevector, len, contents);
+ 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 ();
+
+ c_len = len * (scm_i_array_element_type_sizes[element_type] / 8);
+ if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_len))
+ SCM_NEWSMOB2 (ret, scm_tc16_bytevector, c_len, contents);
+ else
+ {
+ SCM_NEWSMOB2 (ret, scm_tc16_bytevector, c_len, NULL);
+ SCM_BYTEVECTOR_SET_INLINE (ret);
+ if (contents)
+ {
+ memcpy (SCM_BYTEVECTOR_CONTENTS (ret), contents, c_len);
+ scm_gc_free (contents, c_len, SCM_GC_BYTEVECTOR);
+ }
+ }
+ SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
+ return ret;
}
static inline SCM
-make_bytevector (size_t len)
+make_bytevector (size_t len, scm_t_array_element_type element_type)
{
- SCM bv;
+ size_t c_len;
- if (SCM_UNLIKELY (len == 0))
- bv = scm_null_bytevector;
+ if (SCM_UNLIKELY (len == 0 && element_type == 0))
+ return scm_null_bytevector;
+ else 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 ();
+
+ c_len = len * (scm_i_array_element_type_sizes[element_type]/8);
+ if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_len))
+ {
+ SCM ret;
+ SCM_NEWSMOB2 (ret, scm_tc16_bytevector, c_len, NULL);
+ SCM_BYTEVECTOR_SET_INLINE (ret);
+ SCM_BYTEVECTOR_SET_ELEMENT_TYPE (ret, element_type);
+ return ret;
+ }
else
{
- signed char *contents = NULL;
-
- if (!SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len))
- contents = (signed char *) scm_gc_malloc (len, SCM_GC_BYTEVECTOR);
-
- bv = make_bytevector_from_buffer (len, contents);
+ void *buf = scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
+ return make_bytevector_from_buffer (len, buf, element_type);
}
-
- return bv;
}
/* Return a new bytevector of size LEN octets. */
SCM
scm_c_make_bytevector (size_t len)
{
- return (make_bytevector (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
@@ -223,22 +277,14 @@ scm_c_make_bytevector (size_t len)
SCM
scm_c_take_bytevector (signed char *contents, size_t len)
{
- SCM bv;
-
- if (SCM_UNLIKELY (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (len)))
- {
- /* Copy CONTENTS into an "in-line" buffer, then free CONTENTS. */
- signed char *c_bv;
-
- bv = make_bytevector (len);
- c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
- memcpy (c_bv, contents, len);
- scm_gc_free (contents, len, SCM_GC_BYTEVECTOR);
- }
- else
- bv = make_bytevector_from_buffer (len, contents);
+ return make_bytevector_from_buffer (len, contents, SCM_ARRAY_ELEMENT_TYPE_VU8);
+}
- return bv;
+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
@@ -246,6 +292,10 @@ scm_c_take_bytevector (signed char *contents, size_t len)
SCM
scm_i_shrink_bytevector (SCM bv, size_t c_new_len)
{
+ if (SCM_UNLIKELY (c_new_len % SCM_BYTEVECTOR_TYPE_SIZE (bv)))
+ /* This would be an internal Guile programming error */
+ abort ();
+
if (!SCM_BYTEVECTOR_INLINE_P (bv))
{
size_t c_len;
@@ -259,6 +309,7 @@ scm_i_shrink_bytevector (SCM bv, size_t c_new_len)
if (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (c_new_len))
{
/* Copy to the in-line buffer and free the current buffer. */
+ SCM_BYTEVECTOR_SET_INLINE (bv);
c_new_bv = SCM_BYTEVECTOR_CONTENTS (bv);
memcpy (c_new_bv, c_bv, c_new_len);
scm_gc_free (c_bv, c_len, SCM_GC_BYTEVECTOR);
@@ -271,6 +322,8 @@ scm_i_shrink_bytevector (SCM bv, size_t c_new_len)
SCM_BYTEVECTOR_SET_CONTENTS (bv, c_new_bv);
}
}
+ else
+ SCM_BYTEVECTOR_SET_LENGTH (bv, c_new_len);
return bv;
}
@@ -329,38 +382,30 @@ scm_c_bytevector_set_x (SCM bv, size_t index, scm_t_uint8 value)
}
#undef FUNC_NAME
-/* This procedure is used by `scm_c_generalized_vector_set_x ()'. */
-void
-scm_i_bytevector_generalized_set_x (SCM bv, size_t index, SCM value)
-#define FUNC_NAME "scm_i_bytevector_generalized_set_x"
-{
- scm_c_bytevector_set_x (bv, index, scm_to_uint8 (value));
-}
-#undef FUNC_NAME
+
+
+
static int
-print_bytevector (SCM bv, SCM port, scm_print_state *pstate)
+print_bytevector (SCM bv, SCM port, scm_print_state *pstate SCM_UNUSED)
{
- unsigned c_len, i;
- unsigned char *c_bv;
-
- c_len = SCM_BYTEVECTOR_LENGTH (bv);
- c_bv = (unsigned char *) SCM_BYTEVECTOR_CONTENTS (bv);
+ ssize_t ubnd, inc, i;
+ scm_t_array_handle h;
+
+ scm_array_get_handle (bv, &h);
- scm_puts ("#vu8(", port);
- for (i = 0; i < c_len; i++)
+ 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_uintprint (c_bv[i], 10, port);
+ scm_write (scm_array_handle_ref (&h, i), port);
}
-
scm_putc (')', port);
- /* Make GCC think we use it. */
- scm_remember_upto_here ((SCM) pstate);
-
return 1;
}
@@ -448,7 +493,7 @@ SCM_DEFINE (scm_make_bytevector, "make-bytevector", 1, 1, 0,
c_fill = (signed char) value;
}
- bv = make_bytevector (c_len);
+ bv = make_bytevector (c_len, SCM_ARRAY_ELEMENT_TYPE_VU8);
if (fill != SCM_UNDEFINED)
{
unsigned i;
@@ -574,7 +619,7 @@ SCM_DEFINE (scm_bytevector_copy, "bytevector-copy", 1, 0, 0,
c_len = SCM_BYTEVECTOR_LENGTH (bv);
c_bv = SCM_BYTEVECTOR_CONTENTS (bv);
- copy = make_bytevector (c_len);
+ copy = make_bytevector (c_len, SCM_BYTEVECTOR_ELEMENT_TYPE (bv));
c_copy = SCM_BYTEVECTOR_CONTENTS (copy);
memcpy (c_copy, c_bv, c_len);
@@ -604,7 +649,7 @@ SCM_DEFINE (scm_uniform_array_to_bytevector, "uniform-array->bytevector",
len = h.dims->inc * (h.dims->ubnd - h.dims->lbnd + 1);
sz = scm_array_handle_uniform_element_size (&h);
- ret = make_bytevector (len * sz);
+ ret = make_bytevector (len * sz, SCM_ARRAY_ELEMENT_TYPE_VU8);
memcpy (SCM_BYTEVECTOR_CONTENTS (ret), base, len * sz);
scm_array_handle_release (&h);
@@ -693,7 +738,7 @@ SCM_DEFINE (scm_u8_list_to_bytevector, "u8-list->bytevector", 1, 0, 0,
SCM_VALIDATE_LIST_COPYLEN (1, lst, c_len);
- bv = make_bytevector (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++)
@@ -1130,7 +1175,7 @@ SCM_DEFINE (scm_bytevector_to_uint_list, "bytevector->uint-list",
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); \
+ 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; \
@@ -1629,6 +1674,12 @@ double_from_foreign_endianness (const union scm_ieee754_double *source)
_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) \
@@ -1665,7 +1716,7 @@ double_from_foreign_endianness (const union scm_ieee754_double *source)
_type c_value; \
\
IEEE754_ACCESSOR_PROLOGUE (_type); \
- SCM_VALIDATE_REAL (3, value); \
+ VALIDATE_REAL (3, value); \
SCM_VALIDATE_SYMBOL (4, endianness); \
c_value = IEEE754_FROM_SCM (_type) (value); \
\
@@ -1685,7 +1736,7 @@ double_from_foreign_endianness (const union scm_ieee754_double *source)
_type c_value; \
\
IEEE754_ACCESSOR_PROLOGUE (_type); \
- SCM_VALIDATE_REAL (3, value); \
+ VALIDATE_REAL (3, value); \
c_value = IEEE754_FROM_SCM (_type) (value); \
\
memcpy (&c_bv[c_index], &c_value, sizeof (c_value)); \
@@ -1896,8 +1947,7 @@ utf_encoding_name (char *name, size_t utf_width, SCM endianness)
scm_list_1 (str), err); \
else \
/* C_UTF is null-terminated. */ \
- utf = scm_c_take_bytevector ((signed char *) c_utf, \
- c_utf_len); \
+ utf = scm_c_take_bytevector ((signed char *) c_utf, c_utf_len); \
\
return (utf);
@@ -2059,6 +2109,127 @@ SCM_DEFINE (scm_utf32_to_string, "utf32->string",
+/* 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
@@ -2073,7 +2244,8 @@ scm_bootstrap_bytevectors (void)
scm_set_smob_equalp (scm_tc16_bytevector, bytevector_equal_p);
scm_null_bytevector =
- scm_gc_protect_object (make_bytevector_from_buffer (0, NULL));
+ scm_gc_protect_object
+ (make_bytevector_from_buffer (0, NULL, SCM_ARRAY_ELEMENT_TYPE_VU8));
#ifdef WORDS_BIGENDIAN
scm_i_native_endianness = scm_permanent_object (scm_from_locale_symbol ("big"));
@@ -2084,6 +2256,20 @@ scm_bootstrap_bytevectors (void)
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_tc16_bytevector;
+ impl.mask = 0xffff;
+ 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
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
index cb2726251..e29fe6d11 100644
--- a/libguile/bytevectors.h
+++ b/libguile/bytevectors.h
@@ -116,17 +116,21 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM);
i.e., without allocating memory beside the SMOB itself (a double cell).
This optimization is necessary since small bytevectors are expected to be
common. */
-#define SCM_BYTEVECTOR_P(_bv) \
+#define SCM_BYTEVECTOR_P(_bv) \
SCM_SMOB_PREDICATE (scm_tc16_bytevector, _bv)
-#define SCM_BYTEVECTOR_INLINE_THRESHOLD (2 * sizeof (SCM))
-#define SCM_BYTEVECTOR_INLINEABLE_SIZE_P(_size) \
- ((_size) <= SCM_BYTEVECTOR_INLINE_THRESHOLD)
-#define SCM_BYTEVECTOR_INLINE_P(_bv) \
- (SCM_BYTEVECTOR_INLINEABLE_SIZE_P (SCM_BYTEVECTOR_LENGTH (_bv)))
+#define SCM_F_BYTEVECTOR_INLINE 0x1
+#define SCM_BYTEVECTOR_INLINE_P(_bv) \
+ (SCM_SMOB_FLAGS (_bv) & SCM_F_BYTEVECTOR_INLINE)
+#define SCM_BYTEVECTOR_ELEMENT_TYPE(_bv) \
+ (SCM_SMOB_FLAGS (_bv) >> 8)
/* 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);
diff --git a/libguile/convert.c b/libguile/convert.c
deleted file mode 100644
index d87d72464..000000000
--- a/libguile/convert.c
+++ /dev/null
@@ -1,147 +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 3 of
- * the License, or (at your option) any 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 6ce7c2274..000000000
--- a/libguile/convert.h
+++ /dev/null
@@ -1,51 +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 3 of
- * the License, or (at your option) any 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/deprecated.c b/libguile/deprecated.c
index 496bc2292..98ca5bdea 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -34,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"
@@ -1313,7 +1314,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
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 5b443c761..ad62a2bad 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -5,7 +5,7 @@
#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
@@ -24,6 +24,7 @@
*/
#include "libguile/__scm.h"
+#include "libguile/arrays.h"
#include "libguile/strings.h"
#if (SCM_ENABLE_DEPRECATED == 1)
diff --git a/libguile/eq.c b/libguile/eq.c
index 255c381a0..11dee2793 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -1,4 +1,4 @@
-/* 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
@@ -22,13 +22,13 @@
#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/struct.h"
diff --git a/libguile/extensions.c b/libguile/extensions.c
index 54351dd9c..d01e9c656 100644
--- a/libguile/extensions.c
+++ b/libguile/extensions.c
@@ -1,6 +1,6 @@
/* 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
@@ -41,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
@@ -157,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/gc-card.c b/libguile/gc-card.c
index af2923396..aa4031238 100644
--- a/libguile/gc-card.c
+++ b/libguile/gc-card.c
@@ -43,7 +43,7 @@
#include "libguile/strings.h"
#include "libguile/struct.h"
#include "libguile/tags.h"
-#include "libguile/unif.h"
+#include "libguile/arrays.h"
#include "libguile/validate.h"
#include "libguile/vectors.h"
#include "libguile/weaks.h"
diff --git a/libguile/gc-malloc.c b/libguile/gc-malloc.c
index 0a7220e21..6e9120e8e 100644
--- a/libguile/gc-malloc.c
+++ b/libguile/gc-malloc.c
@@ -1,4 +1,4 @@
-/* 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
@@ -37,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"
diff --git a/libguile/gc-mark.c b/libguile/gc-mark.c
index bb307b4c0..cc881e8a4 100644
--- a/libguile/gc-mark.c
+++ b/libguile/gc-mark.c
@@ -38,7 +38,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/programs.h"
#include "libguile/ports.h"
diff --git a/libguile/gc.c b/libguile/gc.c
index b7a3bf091..01f5efff0 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -1,4 +1,4 @@
-/* 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
@@ -33,7 +33,7 @@
#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"
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/init.c b/libguile/init.c
index 5ece01fb0..da3bc0af2 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -37,6 +37,7 @@
#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"
@@ -62,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"
@@ -92,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"
@@ -115,7 +118,7 @@
#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"
@@ -125,6 +128,7 @@
#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"
@@ -517,7 +521,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 ();
@@ -531,7 +547,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 ();
@@ -540,8 +555,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 */
@@ -550,7 +563,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 ();
@@ -574,7 +586,6 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_rw ();
scm_init_extensions ();
- scm_bootstrap_bytevectors ();
scm_bootstrap_vm ();
atexit (cleanup_for_exit);
diff --git a/libguile/inline.h b/libguile/inline.h
index cb908581d..f7a216d7d 100644
--- a/libguile/inline.h
+++ b/libguile/inline.h
@@ -3,7 +3,7 @@
#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
@@ -34,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"
@@ -241,7 +242,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 +255,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
diff --git a/libguile/print.c b/libguile/print.c
index 07bff47fd..3ce080c69 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -36,7 +36,6 @@
#include "libguile/read.h"
#include "libguile/weaks.h"
#include "libguile/programs.h"
-#include "libguile/unif.h"
#include "libguile/alist.h"
#include "libguile/struct.h"
#include "libguile/objects.h"
diff --git a/libguile/random.c b/libguile/random.c
index d7a1ffb11..32c770a99 100644
--- a/libguile/random.c
+++ b/libguile/random.c
@@ -1,4 +1,4 @@
-/* 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 3 of
@@ -33,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/read.c b/libguile/read.c
index 8efac67af..a8ec0a86d 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -32,7 +32,8 @@
#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"
diff --git a/libguile/socket.c b/libguile/socket.c
index 2e02e9082..144bb1090 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -1,4 +1,4 @@
-/* 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
@@ -27,7 +27,7 @@
#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"
diff --git a/libguile/sort.c b/libguile/sort.c
index 644526eac..a9e4dda8c 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -1,4 +1,4 @@
-/* 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 3 of
@@ -39,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/srfi-4.c b/libguile/srfi-4.c
index da571b0b8..67894b3e5 100644
--- a/libguile/srfi-4.c
+++ b/libguile/srfi-4.c
@@ -29,13 +29,17 @@
#include "libguile/_scm.h"
#include "libguile/__scm.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"
@@ -496,11 +500,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;
}
@@ -573,29 +574,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");
@@ -616,222 +594,6 @@ scm_i_generalized_vector_type (SCM v)
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)];
- if (scm_is_bytevector (vec))
- return 1U;
- 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);
- }
- if (scm_is_bytevector (vec))
- return SCM_BYTEVECTOR_CONTENTS (vec);
- 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"
@@ -1067,6 +829,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,
@@ -1085,18 +877,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(h->array)] (h, index);
+}
+
+static void
+uvec_handle_set (scm_t_array_handle *h, size_t index, SCM val)
{
- return uvec_reffers[SCM_UVEC_TYPE(uvec)];
+ uvec_setters [SCM_UVEC_TYPE(h->array)] (h, index, val);
}
-scm_i_t_array_set
-scm_i_uniform_vector_set_proc (SCM uvec)
+static void
+uvec_get_handle (SCM v, scm_t_array_handle *h)
{
- return uvec_setters[SCM_UVEC_TYPE(uvec)];
+ 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)
{
@@ -1119,6 +928,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 a1a9bafc0..3a45fd9e0 100644
--- a/libguile/srfi-4.h
+++ b/libguile/srfi-4.h
@@ -2,7 +2,7 @@
#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
@@ -22,35 +22,6 @@
#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..cecd6c638 100644
--- a/libguile/srfi-4.i.c
+++ b/libguile/srfi-4.i.c
@@ -121,17 +121,6 @@ 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
@@ -187,13 +176,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/strings.c b/libguile/strings.c
index c6464de6b..39dab3a38 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -32,6 +32,7 @@
#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"
#include "libguile/dynwind.h"
@@ -1750,6 +1751,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/strports.c b/libguile/strports.c
index 5c67bf9a8..619d9d750 100644
--- a/libguile/strports.c
+++ b/libguile/strports.c
@@ -30,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"
diff --git a/libguile/unif.c b/libguile/unif.c
deleted file mode 100644
index 84b532347..000000000
--- a/libguile/unif.c
+++ /dev/null
@@ -1,3034 +0,0 @@
-/* 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
- */
-
-
-/*
- 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/bytevectors.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 },
- { "vu8", SCM_UNSPECIFIED, scm_make_bytevector },
- { 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
-bytevector_ref (scm_t_array_handle *h, ssize_t pos)
-{
- return scm_from_uint8 (((scm_t_uint8 *) h->elements)[pos]);
-}
-
-static SCM
-memoize_ref (scm_t_array_handle *h, ssize_t pos)
-{
- SCM v = h->array;
-
- 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 if (scm_is_bytevector (v))
- {
- h->elements = scm_array_handle_uniform_elements (h);
- h->ref = bytevector_ref;
- }
- else
- scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
-
- 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
-bytevector_set (scm_t_array_handle *h, ssize_t pos, SCM val)
-{
- scm_t_uint8 c_value;
- scm_t_uint8 *elements;
-
- c_value = scm_to_uint8 (val);
- elements = (scm_t_uint8 *) h->elements;
- elements[pos] = (scm_t_uint8) c_value;
-}
-
-static void
-memoize_set (scm_t_array_handle *h, ssize_t pos, SCM val)
-{
- SCM v = h->array;
-
- 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 if (scm_is_bytevector (v))
- {
- h->elements = scm_array_handle_uniform_writable_elements (h);
- h->set = bytevector_set;
- }
- else
- scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (h->array));
-
- 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
-scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
- size_t byte_len)
-#define FUNC_NAME "scm_from_contiguous_typed_array"
-{
- size_t k, rlen = 1;
- scm_t_array_dim *s;
- creator_proc *creator;
- SCM ra;
- scm_t_array_handle h;
- void *base;
- size_t sz;
-
- creator = type_to_creator (type);
- ra = scm_i_shap2ra (bounds);
- SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
- s = SCM_I_ARRAY_DIMS (ra);
- k = SCM_I_ARRAY_NDIM (ra);
-
- while (k--)
- {
- s[k].inc = rlen;
- SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
- rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
- }
- SCM_I_ARRAY_V (ra) = creator (scm_from_size_t (rlen), SCM_UNDEFINED);
-
-
- scm_array_get_handle (ra, &h);
- base = scm_array_handle_uniform_writable_elements (&h);
- sz = scm_array_handle_uniform_element_size (&h);
- scm_array_handle_release (&h);
-
- if (byte_len % sz)
- SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL);
- if (byte_len / sz != rlen)
- SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
-
- memcpy (base, bytes, byte_len);
-
- if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
- if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
- return SCM_I_ARRAY_V (ra);
- return ra;
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
- (SCM fill, SCM bounds),
- "Create and return an array.")
-#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 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;
-}
-
-
-
-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
-
-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;
-}
-
-#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_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_i_tc16_enclosed_array = scm_make_smob_type ("enclosed-array", 0);
- scm_set_smob_mark (scm_i_tc16_enclosed_array, array_mark);
- scm_set_smob_free (scm_i_tc16_enclosed_array, array_free);
- 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_free (scm_tc16_bitvector, bitvector_free);
- 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 91d26c861..000000000
--- a/libguile/unif.h
+++ /dev/null
@@ -1,198 +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 3 of
- * the License, or (at your option) any 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_from_contiguous_typed_array (SCM type, SCM bounds,
- const void *bytes,
- size_t byte_len);
-SCM_API SCM scm_array_rank (SCM ra);
-SCM_API size_t scm_c_array_rank (SCM ra);
-SCM_API SCM scm_array_dimensions (SCM ra);
-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/vectors.c b/libguile/vectors.c
index 6dc994f55..89b822a76 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -30,9 +30,11 @@
#include "libguile/validate.h"
#include "libguile/vectors.h"
-#include "libguile/unif.h"
+#include "libguile/generalized-vectors.h"
+#include "libguile/arrays.h"
+#include "libguile/bitvectors.h"
#include "libguile/bytevectors.h"
-#include "libguile/ramap.h"
+#include "libguile/array-map.h"
#include "libguile/srfi-4.h"
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
@@ -525,135 +527,42 @@ 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_is_bytevector (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)
+static SCM
+vector_handle_ref (scm_t_array_handle *h, size_t idx)
{
- 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 if (scm_is_bytevector (v))
- return scm_c_bytevector_length (v);
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
+ if (idx > h->dims[0].ubnd)
+ scm_out_of_range ("vector-handle-ref", scm_from_size_t (idx));
+ return ((SCM*)h->elements)[idx];
}
-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
+static void
+vector_handle_set (scm_t_array_handle *h, size_t idx, SCM val)
{
- return scm_from_size_t (scm_c_generalized_vector_length (v));
+ if (idx > h->dims[0].ubnd)
+ scm_out_of_range ("vector-handle-set!", scm_from_size_t (idx));
+ ((SCM*)h->writable_elements)[idx] = val;
}
-#undef FUNC_NAME
-SCM
-scm_c_generalized_vector_ref (SCM v, size_t idx)
+static void
+vector_get_handle (SCM v, scm_t_array_handle *h)
{
- 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 if (scm_is_bytevector (v))
- return scm_from_uint8 (scm_c_bytevector_ref (v, idx));
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
+ 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);
}
-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)
-{
- 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 if (scm_is_bytevector (v))
- scm_i_bytevector_generalized_set_x (v, idx, val);
- else
- scm_wrong_type_arg_msg (NULL, 0, v, "generalized vector");
-}
-
-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
-{
- 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 902e15a63..bc5b41cb9 100644
--- a/libguile/vectors.h
+++ b/libguile/vectors.h
@@ -24,7 +24,7 @@
#include "libguile/__scm.h"
-#include "libguile/unif.h"
+#include "libguile/arrays.h"
@@ -61,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/module/Makefile.am b/module/Makefile.am
index 5ef00be37..d1c2d95ce 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -203,6 +203,7 @@ SRFI_SOURCES = \
srfi/srfi-1.scm \
srfi/srfi-2.scm \
srfi/srfi-4.scm \
+ srfi/srfi-4/gnu.scm \
srfi/srfi-6.scm \
srfi/srfi-8.scm \
srfi/srfi-9.scm \
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index 53fc741c8..c8d762143 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -1,4 +1,4 @@
-;;;; Copyright (C) 2003, 2005, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 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
@@ -169,16 +169,6 @@
;; The strange prototype system for uniform arrays has been
;; deprecated.
-(define uniform-vector-fill! array-fill!)
-
-(define make-uniform-vector dimensions->uniform-array)
-
-(define (make-uniform-array prot . bounds)
- (dimensions->uniform-array bounds prot))
-
-(define (list->uniform-vector prot lst)
- (list->uniform-array 1 prot lst))
-
(define-macro (eval-case . clauses)
(issue-deprecation-warning
"`eval-case' is deprecated. Use `eval-when' instead.")
diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm
new file mode 100644
index 000000000..d3f73b3e9
--- /dev/null
+++ b/module/srfi/srfi-4/gnu.scm
@@ -0,0 +1,52 @@
+;;; Extensions to SRFI-4
+
+;; Copyright (C) 2001, 2002, 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 3 of the License, or (at your option) any 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:
+
+;; Extensions to SRFI-4. Fully documented in the Guile Reference Manual.
+
+;;; Code:
+
+(define-module (srfi srfi-4 gnu)
+ #:use-module (srfi srfi-4)
+ #:export (;; Somewhat polymorphic conversions.
+ any->u8vector any->s8vector any->u16vector any->s16vector
+ any->u32vector any->s32vector any->u64vector any->s64vector
+ any->f32vector any->f64vector any->c32vector any->c64vector))
+
+
+(define-macro (define-any->vector . tags)
+ `(begin
+ ,@(map (lambda (tag)
+ `(define (,(symbol-append 'any-> tag 'vector) obj)
+ (cond ((,(symbol-append tag 'vector?) obj) obj)
+ ((pair? obj) (,(symbol-append 'list-> tag 'vector) obj))
+ ((generalized-vector? obj)
+ (let* ((len (generalized-vector-length obj))
+ (v (,(symbol-append 'make- tag 'vector) len)))
+ (let lp ((i 0))
+ (if (< i len)
+ (begin
+ (,(symbol-append tag 'vector-set!)
+ v i (generalized-vector-ref obj i))
+ (lp (1+ i)))
+ v))))
+ (else (scm-error 'wrong-type-arg #f "" '() (list obj))))))
+ tags)))
+
+(define-any->vector u8 s8 u16 s16 u32 s32 u64 s64 f32 f64 c32 c64)
diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test
index 61dbeb89e..5d584e86e 100644
--- a/test-suite/tests/unif.test
+++ b/test-suite/tests/unif.test
@@ -1,6 +1,6 @@
;;;; unif.test --- tests guile's uniform arrays -*- scheme -*-
;;;;
-;;;; Copyright 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright 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
@@ -17,7 +17,7 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-unif)
- #:use-module (test-suite lib))
+ #:use-module (test-suite lib))
;;;
;;; array?