diff options
50 files changed, 4478 insertions, 4345 deletions
@@ -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? |