[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-6-101-gcc
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-6-101-gcc7005b |
|
Date: |
Thu, 07 Jan 2010 22:56:58 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=cc7005bc371ee104c368dbb894eb4f8b7a86d64a
The branch, master has been updated
via cc7005bc371ee104c368dbb894eb4f8b7a86d64a (commit)
via 6c2961a01142c7ba9fc03a410004dd696e9208cd (commit)
via fd12a19a5e59afbd78ca67b1305c70bb1ecb724b (commit)
via 97812f4d38b1077c87e8fde02b1d62da6a1a6a06 (commit)
via f1d19308ade7f7d115be243650270e8a2a38fc38 (commit)
via 2be89ca129e078f7e558d07b93ce89bf9ed13a9d (commit)
via 6f3b0cc29eb1c1dcb2e02058e3db9ab04ca36b42 (commit)
via a6029b97ea84d9e9a13d71b21213b6fd0be41e87 (commit)
via f3056b42cf2ddb52cdd7de013ada33e4aa953ada (commit)
via 6c498233a1c6a75fbfc81471b94bdc89306879c3 (commit)
via 27219b32c740ba55d88697829e05bf58120b86d9 (commit)
via a2689737679cf2553c118a1d96de7c9ddfec62b0 (commit)
via 3dc2afe2b85eb5c7ec784b6ed8b19242e45f6e34 (commit)
via 5c39373f48f9694a16d1486ab073f4ab229e9c55 (commit)
from cf9a806dbd8fc58caafefbb4a5328fac2d322cee (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit cc7005bc371ee104c368dbb894eb4f8b7a86d64a
Author: Andy Wingo <address@hidden>
Date: Wed Jan 6 22:16:57 2010 +0100
remove scm_tc7_gsubr
* libguile/tags.h (scm_tc7_gsubr): Return to the pool of unused tc7s, as
there are no more gsubrs. Yay :)
* libguile/programs.h (SCM_F_PROGRAM_IS_PRIMITIVE):
(SCM_PROGRAM_IS_PRIMITIVE): New flag and accessor.
* libguile/gsubr.c (create_gsubr):
* libguile/snarf.h (SCM_STATIC_PROGRAM): Give subrs a PRIMITIVE flag.
* libguile/smob.h:
* libguile/smob.c (scm_i_smob_arity): New internal procedure. Uses the
old GSUBR type macros, local to the file.
* libguile/procprop.c (scm_i_procedure_arity): Call out to
scm_i_smob_arity, and remove a gsubr case.
* libguile/gc.c (scm_i_tag_name):
* libguile/evalext.c (scm_self_evaluating_p):
* libguile/goops.c (scm_class_of):
* libguile/vm.c (apply_foreign):
* libguile/hash.c (scm_hasher):
* libguile/debug.c (scm_procedure_name):
* libguile/print.c (iprin1): Remove gsubr cases.
* libguile/gsubr.h (SCM_PRIMITIVE_P): Fix to work with the new VM
program regimen.
(SCM_GSUBR_TYPE, SCM_GSUBR_MAKTYPE, SCM_GSUBR_MAX, SCM_GSUBR_REQ)
(SCM_GSUBR_OPT, SCM_GSUBR_REST): Remove these macros, that are no
longer useful.
* libguile/gsubr.c (scm_i_gsubr_apply, scm_i_gsubr_apply_list)
(scm_i_gsubr_apply_array): Remove internal gsubr application
functions.
commit 6c2961a01142c7ba9fc03a410004dd696e9208cd
Author: Andy Wingo <address@hidden>
Date: Wed Jan 6 21:45:48 2010 +0100
fix procedure-name on applicable structs
* libguile/debug.c (scm_procedure_name): Fix for applicable structs.
commit fd12a19a5e59afbd78ca67b1305c70bb1ecb724b
Author: Andy Wingo <address@hidden>
Date: Wed Jan 6 20:11:33 2010 +0100
subrs are now VM trampoline procedures
* libguile/_scm.h: Add foreign.h and programs.h to the private include
list, as snarfing subrs with static allocation now needs access to
some of their enums and macros.
* libguile/gsubr.c (create_gsubr): Instead of creating a tc7_gsubr
object, create a VM program with the call-subr opcode, so that the
representation of subrs is now gsubrs. CPP and elisp, together at
last.
(scm_subr_objcode_trampoline): New function, used by the SCM_DEFINE
snarf macro.
* libguile/gsubr.h (SCM_SUBR_META_INFO, SCM_SUBR_PROPS)
(SCM_SET_SUBR_GENERIC_LOC, SCM_SUBR_ARITY_TO_TYPE): Remove these
macros. They were never deprecated, but hopefully people aren't using
them.
(SCM_SUBRF, SCM_SUBR_NAME, SCM_SUBR_GENERIC, SCM_SET_SUBR_GENERIC):
Update to work on the new subr representation.
* libguile/objcodes.h (SCM_F_OBJCODE_IS_STATIC): New flag, indicates
that the "backing store" of the objcode is statically allocated.
* libguile/procprop.c (scm_sym_name): Define here instead of in gsubr.c.
* libguile/snarf.h (SCM_DEFINE): If we are doing static allocation,
statically allocate the foreign object, the object table, and the
program, and use some SCM_SNARF_INITtery to fix things up.
Unfortunately I have not been able to make this immutable. It might be
possible, though.
(SCM_IMMUTABLE_CELL, SCM_STATIC_DOUBLE_CELL, SCM_IMMUTABLE_FOREIGN):
(SCM_STATIC_SUBR_OBJVECT, SCM_STATIC_PROGRAM): New helper macros.
commit 97812f4d38b1077c87e8fde02b1d62da6a1a6a06
Author: Andy Wingo <address@hidden>
Date: Wed Jan 6 11:09:56 2010 +0100
better scm_subr_p deprecation
* libguile/deprecated.h (scm_subr_p): Dispatch instead to scm_i_subr_p so
we get
link-time and run-time warnings.
* libguile/deprecated.c (scm_i_subr_p): Here we call SCM_PRIMITIVE_P.
commit f1d19308ade7f7d115be243650270e8a2a38fc38
Author: Andy Wingo <address@hidden>
Date: Wed Jan 6 11:06:37 2010 +0100
provide missing prototypes
* libguile/array-map.c:
* libguile/chars.c:
* libguile/eq.c:
* libguile/strorder.c: Provide declarations missing after the
asubrs/rpsubrs ->
gsubr conversion.
commit 2be89ca129e078f7e558d07b93ce89bf9ed13a9d
Author: Andy Wingo <address@hidden>
Date: Tue Jan 5 19:49:18 2010 +0100
boot the VM very early in init.c
* libguile/init.c (scm_i_init_guile): Now that the VM doesn't depend on
smobs, we can boot it before anything.
commit 6f3b0cc29eb1c1dcb2e02058e3db9ab04ca36b42
Author: Andy Wingo <address@hidden>
Date: Tue Jan 5 19:45:56 2010 +0100
tc7 tags for vm-related data
* libguile/tags.h (scm_tc7_frame, scm_tc7_objcode, scm_tc7_vm)
(scm_tc7_vm_cont): Take more tc7s for VM-related data structures.
* libguile/evalext.c (scm_self_evaluating_p):
* libguile/gc.c (scm_i_tag_name):
* libguile/goops.c (scm_class_of, create_standard_classes):
* libguile/print.c (iprin1): Add cases for the new tc7s.
* libguile/frames.c:
* libguile/frames.h:
* libguile/objcodes.c:
* libguile/objcodes.h:
* libguile/vm.c:
* libguile/vm.h: Desmobify.
* libguile/vm.c (scm_vm_apply): Export to Scheme, because VM objects are
no longer applicable.
* module/system/repl/command.scm (profile):
* module/system/vm/trace.scm (vm-trace):
* module/system/vm/vm.scm (vm-load): Call vm-apply to run a program in a
VM instead of treating the VM as applicable.
commit a6029b97ea84d9e9a13d71b21213b6fd0be41e87
Author: Andy Wingo <address@hidden>
Date: Tue Jan 5 18:50:17 2010 +0100
properly integrate vm bootstrapping into init.c
* libguile/Makefile.am (modinclude_HEADERS):
* libguile/vm-bootstrap.h: Remove vm-bootstrap.h.
* libguile/frames.c: No more vm-bootstrap.h.
* libguile/instructions.c (scm_init_instructions):
* libguile/objcodes.c (scm_init_objcodes):
* libguile/programs.c (scm_init_programs): No need to call
scm_bootstrap_vm, init.c does that for us.
* libguile/vm.c (scm_bootstrap_vm): No need call e.g.
scm_bootstrap_frames, init.c does that. Remove a twice-calling guard,
should be unnecessary. Don't define the load-compiled subr here.
* libguile/load.c (scm_init_load): Define the load-compiled subr here.
* libguile/vm.h: Declare scm_bootstrap_vm here.
* libguile/init.c (scm_i_init_guile): Properly integrate VM
bootstrapping into this file.
commit f3056b42cf2ddb52cdd7de013ada33e4aa953ada
Author: Andy Wingo <address@hidden>
Date: Tue Jan 5 18:36:27 2010 +0100
boot bytevectors earlier
* libguile/init.c (scm_i_init_guile): It turns out generalized-vectors
and generalized-arrays don't actually block anyone in the dependency
graph, so punt those back to the end. Bootstrap bytevectors earlier,
though, which don't actually depend on smobs.
commit 6c498233a1c6a75fbfc81471b94bdc89306879c3
Author: Andy Wingo <address@hidden>
Date: Thu Jan 7 23:40:59 2010 +0100
inline srfi-4 vector accessors
* module/language/tree-il/primitives.scm
(*interesting-primitive-names*): Inline srfi-4 vector accessors.
commit 27219b32c740ba55d88697829e05bf58120b86d9
Author: Andy Wingo <address@hidden>
Date: Thu Jan 7 23:30:02 2010 +0100
update uniform vector docs
* doc/ref/api-compound.texi (Uniform Numeric Vectors): Make a subsection
of "Vectors", and link out to SRFI-4, where the main text has been
moved.
* doc/ref/api-data.texi (Bytevectors as Uniform Vectors): New section.
* doc/ref/srfi-modules.texi (SRFI-4): Move body of uniform vector docs
here. Discuss new module separation. Discuss relation to bytevectors.
commit a2689737679cf2553c118a1d96de7c9ddfec62b0
Author: Andy Wingo <address@hidden>
Date: Sun Jul 19 15:35:33 2009 +0200
reimplement srfi-4 vectors on top of bytevectors
* libguile/srfi-4.h:
* libguile/srfi-4.c (scm_make_srfi_4_vector): New function, exported by
(srfi srfi-4 gnu).
* libguile/srfi-4.i.c: Removed.
* module/srfi/srfi-4.scm:
* module/srfi/srfi-4/gnu.scm: Reimplement srfi-4 vectors on top of
bytevectors. The implementation is mostly in Scheme now.
* test-suite/tests/unif.test: Update to use (srfi srfi-4 gnu).
* libguile/bytevectors.c (bytevector_ref_c32, bytevector_ref_c64)
(bytevector_set_c32, bytevector_set_c64): Fix some embarrassing bugs.
Still need to do an upper bounds check.
* libguile/deprecated.h: Remove deprecated array functions:
scm_i_arrayp, scm_i_array_ndim, scm_i_array_mem, scm_i_array_v,
scm_i_array_base, scm_i_array_dims, and the deprecated macros:
SCM_ARRAYP, SCM_ARRAY_NDIM, SCM_ARRAY_CONTP, SCM_ARRAY_MEM,
SCM_ARRAY_V, SCM_ARRAY_BASE, SCM_ARRAY_DIMS.
* libguile/deprecated.c (scm_uniform_vector_read_x)
(scm_uniform_vector_write, scm_uniform_array_read_x)
(scm_uniform_array_write): Newly deprecated functions.
* libguile/generalized-arrays.c (scm_array_type): Remove the bytevector
hack.
* libguile/objcodes.c (scm_bytecode_to_objcode, scm_objcode_to_bytecode):
Rework to operate on bytevectors, as scm_make_u8vector now causes a
module lookup, which can't be done e.g. when loading the VM boot
program for psyntax-pp.go on a fresh bootstrap.
* libguile/objcodes.h (SCM_F_OBJCODE_IS_BYTEVECTOR):
(SCM_OBJCODE_IS_BYTEVECTOR): s/U8VECTOR/BYTEVECTOR/.
* module/ice-9/boot-9.scm (the-scm-module): A terrible hack to pull in
(srfi srfi-4), as the bindings are primarily there now. We'll worry
about this later.
commit 3dc2afe2b85eb5c7ec784b6ed8b19242e45f6e34
Author: Andy Wingo <address@hidden>
Date: Tue Jan 5 17:25:53 2010 +0100
Revert "Remove unused internal bytevector functions."
This reverts commit c4daa519107798d06ae96d2f69dc211fc57cc8a3.
commit 5c39373f48f9694a16d1486ab073f4ab229e9c55
Author: Andy Wingo <address@hidden>
Date: Sat Jul 18 19:08:43 2009 +0200
clean up includes in vectors.[ch]
* libguile/vectors.h:
* libguile/vectors.c: Clean up the includes... mostly.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/api-compound.texi | 498 +---------------
doc/ref/api-data.texi | 10 +-
doc/ref/srfi-modules.texi | 537 +++++++++++++++++-
libguile/Makefile.am | 2 -
libguile/_scm.h | 2 +
libguile/array-map.c | 3 +-
libguile/arrays.c | 144 -----
libguile/arrays.h | 6 -
libguile/bytevectors.c | 35 +-
libguile/bytevectors.h | 4 +
libguile/chars.c | 12 +-
libguile/debug.c | 22 +-
libguile/deprecated.c | 270 +++++++--
libguile/deprecated.h | 14 +-
libguile/eq.c | 6 +-
libguile/evalext.c | 5 +-
libguile/frames.c | 20 +-
libguile/frames.h | 11 +-
libguile/gc.c | 11 +-
libguile/generalized-arrays.c | 7 -
libguile/goops.c | 30 +-
libguile/gsubr.c | 978 ++++++++++++++++++++++++-------
libguile/gsubr.h | 47 +-
libguile/hash.c | 5 +-
libguile/init.c | 27 +-
libguile/instructions.c | 5 +-
libguile/load.c | 4 +
libguile/objcodes.c | 60 +-
libguile/objcodes.h | 24 +-
libguile/print.c | 24 +-
libguile/procprop.c | 22 +-
libguile/procs.c | 10 +-
libguile/programs.c | 3 -
libguile/programs.h | 2 +
libguile/smob.c | 24 +-
libguile/smob.h | 4 +-
libguile/snarf.h | 77 ++-
libguile/srfi-4.c | 1025 +++++++-------------------------
libguile/srfi-4.h | 3 +
libguile/srfi-4.i.c | 207 -------
libguile/strorder.c | 12 +-
libguile/tags.h | 10 +-
libguile/vectors.c | 6 +-
libguile/vectors.h | 1 -
libguile/vm-bootstrap.h | 30 -
libguile/vm.c | 60 +--
libguile/vm.h | 16 +-
module/ice-9/boot-9.scm | 3 +
module/language/tree-il/primitives.scm | 66 ++-
module/srfi/srfi-4.scm | 149 ++++--
module/srfi/srfi-4/gnu.scm | 66 ++-
module/system/repl/command.scm | 4 +-
module/system/vm/trace.scm | 4 +-
module/system/vm/vm.scm | 6 +-
test-suite/tests/unif.test | 6 +-
55 files changed, 2343 insertions(+), 2296 deletions(-)
delete mode 100644 libguile/srfi-4.i.c
delete mode 100644 libguile/vm-bootstrap.h
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi
index 33ccdfe..69ef40d 100644
--- a/doc/ref/api-compound.texi
+++ b/doc/ref/api-compound.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2007, 2009
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005,
2006, 2007, 2009, 2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -22,7 +22,6 @@ values can be looked up within them.
* Pairs:: Scheme's basic building block.
* Lists:: Special list functions supported by Guile.
* Vectors:: One-dimensional arrays of Scheme objects.
-* Uniform Numeric Vectors:: Vectors with elements of a single numeric type.
* Bit Vectors:: Vectors of bits.
* Generalized Vectors:: Treating all vector-like things uniformly.
* Arrays:: Matrices, etc.
@@ -671,6 +670,7 @@ and that most array procedures operate happily on vectors
* Vector Creation:: Dynamic vector creation and validation.
* Vector Accessors:: Accessing and modifying vector contents.
* Vector Accessing from C:: Ways to work with vectors from C.
+* Uniform Numeric Vectors:: Vectors of unboxed numeric values.
@end menu
@@ -959,501 +959,17 @@ scm_array_handle_release (&handle);
@end deftypefn
@node Uniform Numeric Vectors
address@hidden Uniform Numeric Vectors
address@hidden Uniform Numeric Vectors
A uniform numeric vector is a vector whose elements are all of a single
numeric type. Guile offers uniform numeric vectors for signed and
unsigned 8-bit, 16-bit, 32-bit, and 64-bit integers, two sizes of
floating point values, and complex floating-point numbers of these two
-sizes.
-
-Strings could be regarded as uniform vectors of characters,
address@hidden Likewise, bit vectors could be regarded as uniform
-vectors of bits, @xref{Bit Vectors}. Both are sufficiently different
-from uniform numeric vectors that the procedures described here do not
-apply to these two data types. However, both strings and bit vectors
-are generalized vectors, @xref{Generalized Vectors}, and arrays,
address@hidden
-
-Uniform numeric vectors are the special case of one dimensional uniform
-numeric arrays.
-
-Uniform numeric vectors can be useful since they consume less memory
-than the non-uniform, general vectors. Also, since the types they can
-store correspond directly to C types, it is easier to work with them
-efficiently on a low level. Consider image processing as an example,
-where you want to apply a filter to some image. While you could store
-the pixels of an image in a general vector and write a general
-convolution function, things are much more efficient with uniform
-vectors: the convolution function knows that all pixels are unsigned
-8-bit values (say), and can use a very tight inner loop.
-
-That is, when it is written in C. Functions for efficiently working
-with uniform numeric vectors from C are listed at the end of this
-section.
-
-Procedures similar to the vector procedures (@pxref{Vectors}) are
-provided for handling these uniform vectors, but they are distinct
-datatypes and the two cannot be inter-mixed. If you want to work
-primarily with uniform numeric vectors, but want to offer support for
-general vectors as a convenience, you can use one of the
address@hidden functions. They will coerce lists and vectors to
-the given type of uniform vector. Alternatively, you can write two
-versions of your code: one that is fast and works only with uniform
-numeric vectors, and one that works with any kind of vector but is
-slower.
-
-One set of the procedures listed below is a generic one: it works with
-all types of uniform numeric vectors. In addition to that, there is a
-set of procedures for each type that only works with that type. Unless
-you really need to the generality of the first set, it is best to use
-the more specific functions. They might not be that much faster, but
-their use can serve as a kind of declaration and makes it easier to
-optimize later on.
-
-The generic set of procedures uses @code{uniform} in its names, the
-specific ones use the tag from the following table.
-
address@hidden @nicode
address@hidden u8
-unsigned 8-bit integers
-
address@hidden s8
-signed 8-bit integers
-
address@hidden u16
-unsigned 16-bit integers
-
address@hidden s16
-signed 16-bit integers
-
address@hidden u32
-unsigned 32-bit integers
-
address@hidden s32
-signed 32-bit integers
-
address@hidden u64
-unsigned 64-bit integers
-
address@hidden s64
-signed 64-bit integers
-
address@hidden f32
-the C type @code{float}
-
address@hidden f64
-the C type @code{double}
-
address@hidden c32
-complex numbers in rectangular form with the real and imaginary part
-being a @code{float}
-
address@hidden c64
-complex numbers in rectangular form with the real and imaginary part
-being a @code{double}
-
address@hidden table
-
-The external representation (ie.@: read syntax) for these vectors is
-similar to normal Scheme vectors, but with an additional tag from the
-table above indicating the vector's type. For example,
-
address@hidden
-#u16(1 2 3)
-#f64(3.1415 2.71)
address@hidden lisp
-
-Note that the read syntax for floating-point here conflicts with
address@hidden for false. In Standard Scheme one can write @code{(1 #f3)}
-for a three element list @code{(1 #f 3)}, but for Guile @code{(1 #f3)}
-is invalid. @code{(1 #f 3)} is almost certainly what one should write
-anyway to make the intention clear, so this is rarely a problem.
-
address@hidden {Scheme Procedure} uniform-vector? obj
address@hidden {Scheme Procedure} u8vector? obj
address@hidden {Scheme Procedure} s8vector? obj
address@hidden {Scheme Procedure} u16vector? obj
address@hidden {Scheme Procedure} s16vector? obj
address@hidden {Scheme Procedure} u32vector? obj
address@hidden {Scheme Procedure} s32vector? obj
address@hidden {Scheme Procedure} u64vector? obj
address@hidden {Scheme Procedure} s64vector? obj
address@hidden {Scheme Procedure} f32vector? obj
address@hidden {Scheme Procedure} f64vector? obj
address@hidden {Scheme Procedure} c32vector? obj
address@hidden {Scheme Procedure} c64vector? obj
address@hidden {C Function} scm_uniform_vector_p (obj)
address@hidden {C Function} scm_u8vector_p (obj)
address@hidden {C Function} scm_s8vector_p (obj)
address@hidden {C Function} scm_u16vector_p (obj)
address@hidden {C Function} scm_s16vector_p (obj)
address@hidden {C Function} scm_u32vector_p (obj)
address@hidden {C Function} scm_s32vector_p (obj)
address@hidden {C Function} scm_u64vector_p (obj)
address@hidden {C Function} scm_s64vector_p (obj)
address@hidden {C Function} scm_f32vector_p (obj)
address@hidden {C Function} scm_f64vector_p (obj)
address@hidden {C Function} scm_c32vector_p (obj)
address@hidden {C Function} scm_c64vector_p (obj)
-Return @code{#t} if @var{obj} is a homogeneous numeric vector of the
-indicated type.
address@hidden deffn
-
address@hidden {Scheme Procedure} make-u8vector n [value]
address@hidden {Scheme Procedure} make-s8vector n [value]
address@hidden {Scheme Procedure} make-u16vector n [value]
address@hidden {Scheme Procedure} make-s16vector n [value]
address@hidden {Scheme Procedure} make-u32vector n [value]
address@hidden {Scheme Procedure} make-s32vector n [value]
address@hidden {Scheme Procedure} make-u64vector n [value]
address@hidden {Scheme Procedure} make-s64vector n [value]
address@hidden {Scheme Procedure} make-f32vector n [value]
address@hidden {Scheme Procedure} make-f64vector n [value]
address@hidden {Scheme Procedure} make-c32vector n [value]
address@hidden {Scheme Procedure} make-c64vector n [value]
address@hidden {C Function} scm_make_u8vector n [value]
address@hidden {C Function} scm_make_s8vector n [value]
address@hidden {C Function} scm_make_u16vector n [value]
address@hidden {C Function} scm_make_s16vector n [value]
address@hidden {C Function} scm_make_u32vector n [value]
address@hidden {C Function} scm_make_s32vector n [value]
address@hidden {C Function} scm_make_u64vector n [value]
address@hidden {C Function} scm_make_s64vector n [value]
address@hidden {C Function} scm_make_f32vector n [value]
address@hidden {C Function} scm_make_f64vector n [value]
address@hidden {C Function} scm_make_c32vector n [value]
address@hidden {C Function} scm_make_c64vector n [value]
-Return a newly allocated homogeneous numeric vector holding @var{n}
-elements of the indicated type. If @var{value} is given, the vector
-is initialized with that value, otherwise the contents are
-unspecified.
address@hidden deffn
-
address@hidden {Scheme Procedure} u8vector value @dots{}
address@hidden {Scheme Procedure} s8vector value @dots{}
address@hidden {Scheme Procedure} u16vector value @dots{}
address@hidden {Scheme Procedure} s16vector value @dots{}
address@hidden {Scheme Procedure} u32vector value @dots{}
address@hidden {Scheme Procedure} s32vector value @dots{}
address@hidden {Scheme Procedure} u64vector value @dots{}
address@hidden {Scheme Procedure} s64vector value @dots{}
address@hidden {Scheme Procedure} f32vector value @dots{}
address@hidden {Scheme Procedure} f64vector value @dots{}
address@hidden {Scheme Procedure} c32vector value @dots{}
address@hidden {Scheme Procedure} c64vector value @dots{}
address@hidden {C Function} scm_u8vector (values)
address@hidden {C Function} scm_s8vector (values)
address@hidden {C Function} scm_u16vector (values)
address@hidden {C Function} scm_s16vector (values)
address@hidden {C Function} scm_u32vector (values)
address@hidden {C Function} scm_s32vector (values)
address@hidden {C Function} scm_u64vector (values)
address@hidden {C Function} scm_s64vector (values)
address@hidden {C Function} scm_f32vector (values)
address@hidden {C Function} scm_f64vector (values)
address@hidden {C Function} scm_c32vector (values)
address@hidden {C Function} scm_c64vector (values)
-Return a newly allocated homogeneous numeric vector of the indicated
-type, holding the given parameter @var{value}s. The vector length is
-the number of parameters given.
address@hidden deffn
-
address@hidden {Scheme Procedure} uniform-vector-length vec
address@hidden {Scheme Procedure} u8vector-length vec
address@hidden {Scheme Procedure} s8vector-length vec
address@hidden {Scheme Procedure} u16vector-length vec
address@hidden {Scheme Procedure} s16vector-length vec
address@hidden {Scheme Procedure} u32vector-length vec
address@hidden {Scheme Procedure} s32vector-length vec
address@hidden {Scheme Procedure} u64vector-length vec
address@hidden {Scheme Procedure} s64vector-length vec
address@hidden {Scheme Procedure} f32vector-length vec
address@hidden {Scheme Procedure} f64vector-length vec
address@hidden {Scheme Procedure} c32vector-length vec
address@hidden {Scheme Procedure} c64vector-length vec
address@hidden {C Function} scm_uniform_vector_length (vec)
address@hidden {C Function} scm_u8vector_length (vec)
address@hidden {C Function} scm_s8vector_length (vec)
address@hidden {C Function} scm_u16vector_length (vec)
address@hidden {C Function} scm_s16vector_length (vec)
address@hidden {C Function} scm_u32vector_length (vec)
address@hidden {C Function} scm_s32vector_length (vec)
address@hidden {C Function} scm_u64vector_length (vec)
address@hidden {C Function} scm_s64vector_length (vec)
address@hidden {C Function} scm_f32vector_length (vec)
address@hidden {C Function} scm_f64vector_length (vec)
address@hidden {C Function} scm_c32vector_length (vec)
address@hidden {C Function} scm_c64vector_length (vec)
-Return the number of elements in @var{vec}.
address@hidden deffn
-
address@hidden {Scheme Procedure} uniform-vector-ref vec i
address@hidden {Scheme Procedure} u8vector-ref vec i
address@hidden {Scheme Procedure} s8vector-ref vec i
address@hidden {Scheme Procedure} u16vector-ref vec i
address@hidden {Scheme Procedure} s16vector-ref vec i
address@hidden {Scheme Procedure} u32vector-ref vec i
address@hidden {Scheme Procedure} s32vector-ref vec i
address@hidden {Scheme Procedure} u64vector-ref vec i
address@hidden {Scheme Procedure} s64vector-ref vec i
address@hidden {Scheme Procedure} f32vector-ref vec i
address@hidden {Scheme Procedure} f64vector-ref vec i
address@hidden {Scheme Procedure} c32vector-ref vec i
address@hidden {Scheme Procedure} c64vector-ref vec i
address@hidden {C Function} scm_uniform_vector_ref (vec i)
address@hidden {C Function} scm_u8vector_ref (vec i)
address@hidden {C Function} scm_s8vector_ref (vec i)
address@hidden {C Function} scm_u16vector_ref (vec i)
address@hidden {C Function} scm_s16vector_ref (vec i)
address@hidden {C Function} scm_u32vector_ref (vec i)
address@hidden {C Function} scm_s32vector_ref (vec i)
address@hidden {C Function} scm_u64vector_ref (vec i)
address@hidden {C Function} scm_s64vector_ref (vec i)
address@hidden {C Function} scm_f32vector_ref (vec i)
address@hidden {C Function} scm_f64vector_ref (vec i)
address@hidden {C Function} scm_c32vector_ref (vec i)
address@hidden {C Function} scm_c64vector_ref (vec i)
-Return the element at index @var{i} in @var{vec}. The first element
-in @var{vec} is index 0.
address@hidden deffn
-
address@hidden {Scheme Procedure} uniform-vector-set! vec i value
address@hidden {Scheme Procedure} u8vector-set! vec i value
address@hidden {Scheme Procedure} s8vector-set! vec i value
address@hidden {Scheme Procedure} u16vector-set! vec i value
address@hidden {Scheme Procedure} s16vector-set! vec i value
address@hidden {Scheme Procedure} u32vector-set! vec i value
address@hidden {Scheme Procedure} s32vector-set! vec i value
address@hidden {Scheme Procedure} u64vector-set! vec i value
address@hidden {Scheme Procedure} s64vector-set! vec i value
address@hidden {Scheme Procedure} f32vector-set! vec i value
address@hidden {Scheme Procedure} f64vector-set! vec i value
address@hidden {Scheme Procedure} c32vector-set! vec i value
address@hidden {Scheme Procedure} c64vector-set! vec i value
address@hidden {C Function} scm_uniform_vector_set_x (vec i value)
address@hidden {C Function} scm_u8vector_set_x (vec i value)
address@hidden {C Function} scm_s8vector_set_x (vec i value)
address@hidden {C Function} scm_u16vector_set_x (vec i value)
address@hidden {C Function} scm_s16vector_set_x (vec i value)
address@hidden {C Function} scm_u32vector_set_x (vec i value)
address@hidden {C Function} scm_s32vector_set_x (vec i value)
address@hidden {C Function} scm_u64vector_set_x (vec i value)
address@hidden {C Function} scm_s64vector_set_x (vec i value)
address@hidden {C Function} scm_f32vector_set_x (vec i value)
address@hidden {C Function} scm_f64vector_set_x (vec i value)
address@hidden {C Function} scm_c32vector_set_x (vec i value)
address@hidden {C Function} scm_c64vector_set_x (vec i value)
-Set the element at index @var{i} in @var{vec} to @var{value}. The
-first element in @var{vec} is index 0. The return value is
-unspecified.
address@hidden deffn
-
address@hidden {Scheme Procedure} uniform-vector->list vec
address@hidden {Scheme Procedure} u8vector->list vec
address@hidden {Scheme Procedure} s8vector->list vec
address@hidden {Scheme Procedure} u16vector->list vec
address@hidden {Scheme Procedure} s16vector->list vec
address@hidden {Scheme Procedure} u32vector->list vec
address@hidden {Scheme Procedure} s32vector->list vec
address@hidden {Scheme Procedure} u64vector->list vec
address@hidden {Scheme Procedure} s64vector->list vec
address@hidden {Scheme Procedure} f32vector->list vec
address@hidden {Scheme Procedure} f64vector->list vec
address@hidden {Scheme Procedure} c32vector->list vec
address@hidden {Scheme Procedure} c64vector->list vec
address@hidden {C Function} scm_uniform_vector_to_list (vec)
address@hidden {C Function} scm_u8vector_to_list (vec)
address@hidden {C Function} scm_s8vector_to_list (vec)
address@hidden {C Function} scm_u16vector_to_list (vec)
address@hidden {C Function} scm_s16vector_to_list (vec)
address@hidden {C Function} scm_u32vector_to_list (vec)
address@hidden {C Function} scm_s32vector_to_list (vec)
address@hidden {C Function} scm_u64vector_to_list (vec)
address@hidden {C Function} scm_s64vector_to_list (vec)
address@hidden {C Function} scm_f32vector_to_list (vec)
address@hidden {C Function} scm_f64vector_to_list (vec)
address@hidden {C Function} scm_c32vector_to_list (vec)
address@hidden {C Function} scm_c64vector_to_list (vec)
-Return a newly allocated list holding all elements of @var{vec}.
address@hidden deffn
-
address@hidden {Scheme Procedure} list->u8vector lst
address@hidden {Scheme Procedure} list->s8vector lst
address@hidden {Scheme Procedure} list->u16vector lst
address@hidden {Scheme Procedure} list->s16vector lst
address@hidden {Scheme Procedure} list->u32vector lst
address@hidden {Scheme Procedure} list->s32vector lst
address@hidden {Scheme Procedure} list->u64vector lst
address@hidden {Scheme Procedure} list->s64vector lst
address@hidden {Scheme Procedure} list->f32vector lst
address@hidden {Scheme Procedure} list->f64vector lst
address@hidden {Scheme Procedure} list->c32vector lst
address@hidden {Scheme Procedure} list->c64vector lst
address@hidden {C Function} scm_list_to_u8vector (lst)
address@hidden {C Function} scm_list_to_s8vector (lst)
address@hidden {C Function} scm_list_to_u16vector (lst)
address@hidden {C Function} scm_list_to_s16vector (lst)
address@hidden {C Function} scm_list_to_u32vector (lst)
address@hidden {C Function} scm_list_to_s32vector (lst)
address@hidden {C Function} scm_list_to_u64vector (lst)
address@hidden {C Function} scm_list_to_s64vector (lst)
address@hidden {C Function} scm_list_to_f32vector (lst)
address@hidden {C Function} scm_list_to_f64vector (lst)
address@hidden {C Function} scm_list_to_c32vector (lst)
address@hidden {C Function} scm_list_to_c64vector (lst)
-Return a newly allocated homogeneous numeric vector of the indicated type,
-initialized with the elements of the list @var{lst}.
address@hidden deffn
-
address@hidden {Scheme Procedure} any->u8vector obj
address@hidden {Scheme Procedure} any->s8vector obj
address@hidden {Scheme Procedure} any->u16vector obj
address@hidden {Scheme Procedure} any->s16vector obj
address@hidden {Scheme Procedure} any->u32vector obj
address@hidden {Scheme Procedure} any->s32vector obj
address@hidden {Scheme Procedure} any->u64vector obj
address@hidden {Scheme Procedure} any->s64vector obj
address@hidden {Scheme Procedure} any->f32vector obj
address@hidden {Scheme Procedure} any->f64vector obj
address@hidden {Scheme Procedure} any->c32vector obj
address@hidden {Scheme Procedure} any->c64vector obj
address@hidden {C Function} scm_any_to_u8vector (obj)
address@hidden {C Function} scm_any_to_s8vector (obj)
address@hidden {C Function} scm_any_to_u16vector (obj)
address@hidden {C Function} scm_any_to_s16vector (obj)
address@hidden {C Function} scm_any_to_u32vector (obj)
address@hidden {C Function} scm_any_to_s32vector (obj)
address@hidden {C Function} scm_any_to_u64vector (obj)
address@hidden {C Function} scm_any_to_s64vector (obj)
address@hidden {C Function} scm_any_to_f32vector (obj)
address@hidden {C Function} scm_any_to_f64vector (obj)
address@hidden {C Function} scm_any_to_c32vector (obj)
address@hidden {C Function} scm_any_to_c64vector (obj)
-Return a (maybe newly allocated) uniform numeric vector of the indicated
-type, initialized with the elements of @var{obj}, which must be a list,
-a vector, or a uniform vector. When @var{obj} is already a suitable
-uniform numeric vector, it is returned unchanged.
address@hidden deffn
-
address@hidden {C Function} int scm_is_uniform_vector (SCM uvec)
-Return non-zero when @var{uvec} is a uniform numeric vector, zero
-otherwise.
address@hidden deftypefn
-
address@hidden {C Function} SCM scm_take_u8vector (const scm_t_uint8 *data,
size_t len)
address@hidden {C Function} SCM scm_take_s8vector (const scm_t_int8 *data,
size_t len)
address@hidden {C Function} SCM scm_take_u16vector (const scm_t_uint16 *data,
size_t len)
address@hidden {C Function} SCM scm_take_s16vector (const scm_t_int16 *data,
size_t len)
address@hidden {C Function} SCM scm_take_u32vector (const scm_t_uint32 *data,
size_t len)
address@hidden {C Function} SCM scm_take_s32vector (const scm_t_int32 *data,
size_t len)
address@hidden {C Function} SCM scm_take_u64vector (const scm_t_uint64 *data,
size_t len)
address@hidden {C Function} SCM scm_take_s64vector (const scm_t_int64 *data,
size_t len)
address@hidden {C Function} SCM scm_take_f32vector (const float *data, size_t
len)
address@hidden {C Function} SCM scm_take_f64vector (const double *data, size_t
len)
address@hidden {C Function} SCM scm_take_c32vector (const float *data, size_t
len)
address@hidden {C Function} SCM scm_take_c64vector (const double *data, size_t
len)
-Return a new uniform numeric vector of the indicated type and length
-that uses the memory pointed to by @var{data} to store its elements.
-This memory will eventually be freed with @code{free}. The argument
address@hidden specifies the number of elements in @var{data}, not its size
-in bytes.
-
-The @code{c32} and @code{c64} variants take a pointer to a C array of
address@hidden or @code{double}s. The real parts of the complex numbers
-are at even indices in that array, the corresponding imaginary parts are
-at the following odd index.
address@hidden deftypefn
-
address@hidden {C Function} size_t scm_c_uniform_vector_length (SCM uvec)
-Return the number of elements of @var{uvec} as a @code{size_t}.
address@hidden deftypefn
-
address@hidden {C Function} {const void *} scm_uniform_vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_uint8 *} scm_u8vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_int8 *} scm_s8vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_uint16 *} scm_u16vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_int16 *} scm_s16vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_uint32 *} scm_u32vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_int32 *} scm_s32vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_uint64 *} scm_u64vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_int64 *} scm_s64vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const float *} scm_f23vector_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const double *} scm_f64vector_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const float *} scm_c32vector_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const double *} scm_c64vector_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
-Like @code{scm_vector_elements} (@pxref{Vector Accessing from C}), but
-returns a pointer to the elements of a uniform numeric vector of the
-indicated kind.
address@hidden deftypefn
-
address@hidden {C Function} {void *} scm_uniform_vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_uint8 *} scm_u8vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_int8 *} scm_s8vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_uint16 *} scm_u16vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_int16 *} scm_s16vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_uint32 *} scm_u32vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_int32 *} scm_s32vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_uint64 *} scm_u64vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_int64 *} scm_s64vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {float *} scm_f23vector_writable_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {double *} scm_f64vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {float *} scm_c32vector_writable_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {double *} scm_c64vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
-Like @code{scm_vector_writable_elements} (@pxref{Vector Accessing from
-C}), but returns a pointer to the elements of a uniform numeric vector
-of the indicated kind.
address@hidden deftypefn
-
-Uniform numeric vectors can be written to and read from input/output
-ports using the procedures listed below. However, bytevectors may often
-be more convenient for binary input/output since they provide more
-flexibility in the interpretation of raw byte sequences
-(@pxref{Bytevectors}).
-
address@hidden {Scheme Procedure} uniform-array-read! ura [port_or_fd [start
[end]]]
address@hidden {Scheme Procedure} uniform-vector-read! uve [port-or-fdes]
[start] [end]
address@hidden {C Function} scm_uniform_array_read_x (ura, port_or_fd, start,
end)
-Attempt to read all elements of @var{ura}, in lexicographic order, as
-binary objects from @var{port-or-fdes}.
-If an end of file is encountered,
-the objects up to that point are put into @var{ura}
-(starting at the beginning) and the remainder of the array is
-unchanged.
-
-The optional arguments @var{start} and @var{end} allow
-a specified region of a vector (or linearized array) to be read,
-leaving the remainder of the vector unchanged.
-
address@hidden returns the number of objects read.
address@hidden may be omitted, in which case it defaults to the value
-returned by @code{(current-input-port)}.
address@hidden deffn
-
address@hidden {Scheme Procedure} uniform-vector-write uvec [port_or_fd [start
[end]]]
address@hidden {C Function} scm_uniform_vector_write (uvec, port_or_fd, start,
end)
-Write the elements of @var{uvec} as raw bytes to
address@hidden, in the host byte order.
-
-The optional arguments @var{start} (inclusive)
-and @var{end} (exclusive) allow
-a specified region to be written.
-
-When @var{port-or-fdes} is a port, all specified elements
-of @var{uvec} are attempted to be written, potentially blocking
-while waiting for more room.
-When @var{port-or-fd} is an integer, a single call to
-write(2) is made.
-
-An error is signalled when the last element has only
-been partially written in the single call to write(2).
-
-The number of objects actually written is returned.
address@hidden may be
-omitted, in which case it defaults to the value returned by
address@hidden(current-output-port)}.
address@hidden deffn
+sizes. @xref{SRFI-4}, for more information.
+For many purposes, bytevectors work just as well as uniform vectors, and have
+the advantage that they integrate well with binary input and output.
address@hidden, for more information on bytevectors.
@node Bit Vectors
@subsection Bit Vectors
diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi
index 8e797ac..bcde697 100755
--- a/doc/ref/api-data.texi
+++ b/doc/ref/api-data.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2007, 2008, 2009
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2007, 2008, 2009, 2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -3942,6 +3942,7 @@ R6RS (@pxref{R6RS I/O Ports}).
* Bytevectors as Floats:: Interpreting bytes as real numbers.
* Bytevectors as Strings:: Interpreting bytes as Unicode strings.
* Bytevectors as Generalized Vectors:: Guile extension to the bytevector API.
+* Bytevectors as Uniform Vectors:: Bytevectors and SRFI-4.
@end menu
@node Bytevector Endianness
@@ -4338,6 +4339,13 @@ these APIs, bytes are accessed one at a time as 8-bit
unsigned integers:
@end example
address@hidden Bytevectors as Uniform Vectors
address@hidden Accessing Bytevectors with the SRFI-4 API
+
+Bytevectors may also be accessed with the SRFI-4 API. @xref{SRFI-4 and
+Bytevectors}, for more information.
+
+
@node Regular Expressions
@subsection Regular Expressions
@tpindex Regular expressions
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 043490d..d3eafc5 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -1,6 +1,6 @@
@c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual.
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2007, 2008, 2009
address@hidden Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006,
2007, 2008, 2009, 2010
@c Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions.
@@ -1293,8 +1293,539 @@ from separate @code{and} and @code{let*}, or from
@code{cond} with
@subsection SRFI-4 - Homogeneous numeric vector datatypes
@cindex SRFI-4
-The SRFI-4 procedures and data types are always available, @xref{Uniform
-Numeric Vectors}.
+SRFI-4 provides an interface to uniform numeric vectors: vectors whose elements
+are all of a single numeric type. Guile offers uniform numeric vectors for
+signed and unsigned 8-bit, 16-bit, 32-bit, and 64-bit integers, two sizes of
+floating point values, and, as an extension to SRFI-4, complex floating-point
+numbers of these two sizes.
+
+The standard SRFI-4 procedures and data types may be included via loading the
+appropriate module:
+
address@hidden
+(use-modules (srfi srfi-4))
address@hidden example
+
+This module is currently a part of the default Guile environment, but it is a
+good practice to explicitly import the module. In the future, using SRFI-4
+procedures without importing the SRFI-4 module will cause a deprecation message
+to be printed. (Of course, one may call the C functions at any time. Would that
+C had modules!)
+
address@hidden
+* SRFI-4 Overview:: The warp and weft of uniform numeric vectors.
+* SRFI-4 API:: Uniform vectors, from Scheme and from C.
+* SRFI-4 Generic Operations:: The general, operating on the specific.
+* SRFI-4 and Bytevectors:: SRFI-4 vectors are backed by bytevectors.
+* SRFI-4 Extensions:: Guile-specific extensions to the standard.
address@hidden menu
+
address@hidden SRFI-4 Overview
address@hidden SRFI-4 - Overview
+
+Uniform numeric vectors can be useful since they consume less memory
+than the non-uniform, general vectors. Also, since the types they can
+store correspond directly to C types, it is easier to work with them
+efficiently on a low level. Consider image processing as an example,
+where you want to apply a filter to some image. While you could store
+the pixels of an image in a general vector and write a general
+convolution function, things are much more efficient with uniform
+vectors: the convolution function knows that all pixels are unsigned
+8-bit values (say), and can use a very tight inner loop.
+
+This is implemented in Scheme by having the compiler notice calls to the SRFI-4
+accessors, and inline them to appropriate compiled code. From C you have access
+to the raw array; functions for efficiently working with uniform numeric
vectors
+from C are listed at the end of this section.
+
+Uniform numeric vectors are the special case of one dimensional uniform
+numeric arrays.
+
+There are 12 standard kinds of uniform numeric vectors, and they all have their
+own complement of constructors, accessors, and so on. Procedures that operate
on
+a specific kind of uniform numeric vector have a ``tag'' in their name,
+indicating the element type.
+
address@hidden @nicode
address@hidden u8
+unsigned 8-bit integers
+
address@hidden s8
+signed 8-bit integers
+
address@hidden u16
+unsigned 16-bit integers
+
address@hidden s16
+signed 16-bit integers
+
address@hidden u32
+unsigned 32-bit integers
+
address@hidden s32
+signed 32-bit integers
+
address@hidden u64
+unsigned 64-bit integers
+
address@hidden s64
+signed 64-bit integers
+
address@hidden f32
+the C type @code{float}
+
address@hidden f64
+the C type @code{double}
+
address@hidden table
+
+In addition, Guile supports uniform arrays of complex numbers, with the
+nonstandard tags:
+
address@hidden @nicode
+
address@hidden c32
+complex numbers in rectangular form with the real and imaginary part
+being a @code{float}
+
address@hidden c64
+complex numbers in rectangular form with the real and imaginary part
+being a @code{double}
+
address@hidden table
+
+The external representation (ie.@: read syntax) for these vectors is
+similar to normal Scheme vectors, but with an additional tag from the
+tables above indicating the vector's type. For example,
+
address@hidden
+#u16(1 2 3)
+#f64(3.1415 2.71)
address@hidden lisp
+
+Note that the read syntax for floating-point here conflicts with
address@hidden for false. In Standard Scheme one can write @code{(1 #f3)}
+for a three element list @code{(1 #f 3)}, but for Guile @code{(1 #f3)}
+is invalid. @code{(1 #f 3)} is almost certainly what one should write
+anyway to make the intention clear, so this is rarely a problem.
+
+
address@hidden SRFI-4 API
address@hidden SRFI-4 - API
+
+Note that the @nicode{c32} and @nicode{c64} functions are only available from
address@hidden(srfi srfi-4 gnu)}.
+
address@hidden {Scheme Procedure} u8vector? obj
address@hidden {Scheme Procedure} s8vector? obj
address@hidden {Scheme Procedure} u16vector? obj
address@hidden {Scheme Procedure} s16vector? obj
address@hidden {Scheme Procedure} u32vector? obj
address@hidden {Scheme Procedure} s32vector? obj
address@hidden {Scheme Procedure} u64vector? obj
address@hidden {Scheme Procedure} s64vector? obj
address@hidden {Scheme Procedure} f32vector? obj
address@hidden {Scheme Procedure} f64vector? obj
address@hidden {Scheme Procedure} c32vector? obj
address@hidden {Scheme Procedure} c64vector? obj
address@hidden {C Function} scm_u8vector_p (obj)
address@hidden {C Function} scm_s8vector_p (obj)
address@hidden {C Function} scm_u16vector_p (obj)
address@hidden {C Function} scm_s16vector_p (obj)
address@hidden {C Function} scm_u32vector_p (obj)
address@hidden {C Function} scm_s32vector_p (obj)
address@hidden {C Function} scm_u64vector_p (obj)
address@hidden {C Function} scm_s64vector_p (obj)
address@hidden {C Function} scm_f32vector_p (obj)
address@hidden {C Function} scm_f64vector_p (obj)
address@hidden {C Function} scm_c32vector_p (obj)
address@hidden {C Function} scm_c64vector_p (obj)
+Return @code{#t} if @var{obj} is a homogeneous numeric vector of the
+indicated type.
address@hidden deffn
+
address@hidden {Scheme Procedure} make-u8vector n [value]
address@hidden {Scheme Procedure} make-s8vector n [value]
address@hidden {Scheme Procedure} make-u16vector n [value]
address@hidden {Scheme Procedure} make-s16vector n [value]
address@hidden {Scheme Procedure} make-u32vector n [value]
address@hidden {Scheme Procedure} make-s32vector n [value]
address@hidden {Scheme Procedure} make-u64vector n [value]
address@hidden {Scheme Procedure} make-s64vector n [value]
address@hidden {Scheme Procedure} make-f32vector n [value]
address@hidden {Scheme Procedure} make-f64vector n [value]
address@hidden {Scheme Procedure} make-c32vector n [value]
address@hidden {Scheme Procedure} make-c64vector n [value]
address@hidden {C Function} scm_make_u8vector n [value]
address@hidden {C Function} scm_make_s8vector n [value]
address@hidden {C Function} scm_make_u16vector n [value]
address@hidden {C Function} scm_make_s16vector n [value]
address@hidden {C Function} scm_make_u32vector n [value]
address@hidden {C Function} scm_make_s32vector n [value]
address@hidden {C Function} scm_make_u64vector n [value]
address@hidden {C Function} scm_make_s64vector n [value]
address@hidden {C Function} scm_make_f32vector n [value]
address@hidden {C Function} scm_make_f64vector n [value]
address@hidden {C Function} scm_make_c32vector n [value]
address@hidden {C Function} scm_make_c64vector n [value]
+Return a newly allocated homogeneous numeric vector holding @var{n}
+elements of the indicated type. If @var{value} is given, the vector
+is initialized with that value, otherwise the contents are
+unspecified.
address@hidden deffn
+
address@hidden {Scheme Procedure} u8vector value @dots{}
address@hidden {Scheme Procedure} s8vector value @dots{}
address@hidden {Scheme Procedure} u16vector value @dots{}
address@hidden {Scheme Procedure} s16vector value @dots{}
address@hidden {Scheme Procedure} u32vector value @dots{}
address@hidden {Scheme Procedure} s32vector value @dots{}
address@hidden {Scheme Procedure} u64vector value @dots{}
address@hidden {Scheme Procedure} s64vector value @dots{}
address@hidden {Scheme Procedure} f32vector value @dots{}
address@hidden {Scheme Procedure} f64vector value @dots{}
address@hidden {Scheme Procedure} c32vector value @dots{}
address@hidden {Scheme Procedure} c64vector value @dots{}
address@hidden {C Function} scm_u8vector (values)
address@hidden {C Function} scm_s8vector (values)
address@hidden {C Function} scm_u16vector (values)
address@hidden {C Function} scm_s16vector (values)
address@hidden {C Function} scm_u32vector (values)
address@hidden {C Function} scm_s32vector (values)
address@hidden {C Function} scm_u64vector (values)
address@hidden {C Function} scm_s64vector (values)
address@hidden {C Function} scm_f32vector (values)
address@hidden {C Function} scm_f64vector (values)
address@hidden {C Function} scm_c32vector (values)
address@hidden {C Function} scm_c64vector (values)
+Return a newly allocated homogeneous numeric vector of the indicated
+type, holding the given parameter @var{value}s. The vector length is
+the number of parameters given.
address@hidden deffn
+
address@hidden {Scheme Procedure} u8vector-length vec
address@hidden {Scheme Procedure} s8vector-length vec
address@hidden {Scheme Procedure} u16vector-length vec
address@hidden {Scheme Procedure} s16vector-length vec
address@hidden {Scheme Procedure} u32vector-length vec
address@hidden {Scheme Procedure} s32vector-length vec
address@hidden {Scheme Procedure} u64vector-length vec
address@hidden {Scheme Procedure} s64vector-length vec
address@hidden {Scheme Procedure} f32vector-length vec
address@hidden {Scheme Procedure} f64vector-length vec
address@hidden {Scheme Procedure} c32vector-length vec
address@hidden {Scheme Procedure} c64vector-length vec
address@hidden {C Function} scm_u8vector_length (vec)
address@hidden {C Function} scm_s8vector_length (vec)
address@hidden {C Function} scm_u16vector_length (vec)
address@hidden {C Function} scm_s16vector_length (vec)
address@hidden {C Function} scm_u32vector_length (vec)
address@hidden {C Function} scm_s32vector_length (vec)
address@hidden {C Function} scm_u64vector_length (vec)
address@hidden {C Function} scm_s64vector_length (vec)
address@hidden {C Function} scm_f32vector_length (vec)
address@hidden {C Function} scm_f64vector_length (vec)
address@hidden {C Function} scm_c32vector_length (vec)
address@hidden {C Function} scm_c64vector_length (vec)
+Return the number of elements in @var{vec}.
address@hidden deffn
+
address@hidden {Scheme Procedure} u8vector-ref vec i
address@hidden {Scheme Procedure} s8vector-ref vec i
address@hidden {Scheme Procedure} u16vector-ref vec i
address@hidden {Scheme Procedure} s16vector-ref vec i
address@hidden {Scheme Procedure} u32vector-ref vec i
address@hidden {Scheme Procedure} s32vector-ref vec i
address@hidden {Scheme Procedure} u64vector-ref vec i
address@hidden {Scheme Procedure} s64vector-ref vec i
address@hidden {Scheme Procedure} f32vector-ref vec i
address@hidden {Scheme Procedure} f64vector-ref vec i
address@hidden {Scheme Procedure} c32vector-ref vec i
address@hidden {Scheme Procedure} c64vector-ref vec i
address@hidden {C Function} scm_u8vector_ref (vec i)
address@hidden {C Function} scm_s8vector_ref (vec i)
address@hidden {C Function} scm_u16vector_ref (vec i)
address@hidden {C Function} scm_s16vector_ref (vec i)
address@hidden {C Function} scm_u32vector_ref (vec i)
address@hidden {C Function} scm_s32vector_ref (vec i)
address@hidden {C Function} scm_u64vector_ref (vec i)
address@hidden {C Function} scm_s64vector_ref (vec i)
address@hidden {C Function} scm_f32vector_ref (vec i)
address@hidden {C Function} scm_f64vector_ref (vec i)
address@hidden {C Function} scm_c32vector_ref (vec i)
address@hidden {C Function} scm_c64vector_ref (vec i)
+Return the element at index @var{i} in @var{vec}. The first element
+in @var{vec} is index 0.
address@hidden deffn
+
address@hidden {Scheme Procedure} u8vector-set! vec i value
address@hidden {Scheme Procedure} s8vector-set! vec i value
address@hidden {Scheme Procedure} u16vector-set! vec i value
address@hidden {Scheme Procedure} s16vector-set! vec i value
address@hidden {Scheme Procedure} u32vector-set! vec i value
address@hidden {Scheme Procedure} s32vector-set! vec i value
address@hidden {Scheme Procedure} u64vector-set! vec i value
address@hidden {Scheme Procedure} s64vector-set! vec i value
address@hidden {Scheme Procedure} f32vector-set! vec i value
address@hidden {Scheme Procedure} f64vector-set! vec i value
address@hidden {Scheme Procedure} c32vector-set! vec i value
address@hidden {Scheme Procedure} c64vector-set! vec i value
address@hidden {C Function} scm_u8vector_set_x (vec i value)
address@hidden {C Function} scm_s8vector_set_x (vec i value)
address@hidden {C Function} scm_u16vector_set_x (vec i value)
address@hidden {C Function} scm_s16vector_set_x (vec i value)
address@hidden {C Function} scm_u32vector_set_x (vec i value)
address@hidden {C Function} scm_s32vector_set_x (vec i value)
address@hidden {C Function} scm_u64vector_set_x (vec i value)
address@hidden {C Function} scm_s64vector_set_x (vec i value)
address@hidden {C Function} scm_f32vector_set_x (vec i value)
address@hidden {C Function} scm_f64vector_set_x (vec i value)
address@hidden {C Function} scm_c32vector_set_x (vec i value)
address@hidden {C Function} scm_c64vector_set_x (vec i value)
+Set the element at index @var{i} in @var{vec} to @var{value}. The
+first element in @var{vec} is index 0. The return value is
+unspecified.
address@hidden deffn
+
address@hidden {Scheme Procedure} u8vector->list vec
address@hidden {Scheme Procedure} s8vector->list vec
address@hidden {Scheme Procedure} u16vector->list vec
address@hidden {Scheme Procedure} s16vector->list vec
address@hidden {Scheme Procedure} u32vector->list vec
address@hidden {Scheme Procedure} s32vector->list vec
address@hidden {Scheme Procedure} u64vector->list vec
address@hidden {Scheme Procedure} s64vector->list vec
address@hidden {Scheme Procedure} f32vector->list vec
address@hidden {Scheme Procedure} f64vector->list vec
address@hidden {Scheme Procedure} c32vector->list vec
address@hidden {Scheme Procedure} c64vector->list vec
address@hidden {C Function} scm_u8vector_to_list (vec)
address@hidden {C Function} scm_s8vector_to_list (vec)
address@hidden {C Function} scm_u16vector_to_list (vec)
address@hidden {C Function} scm_s16vector_to_list (vec)
address@hidden {C Function} scm_u32vector_to_list (vec)
address@hidden {C Function} scm_s32vector_to_list (vec)
address@hidden {C Function} scm_u64vector_to_list (vec)
address@hidden {C Function} scm_s64vector_to_list (vec)
address@hidden {C Function} scm_f32vector_to_list (vec)
address@hidden {C Function} scm_f64vector_to_list (vec)
address@hidden {C Function} scm_c32vector_to_list (vec)
address@hidden {C Function} scm_c64vector_to_list (vec)
+Return a newly allocated list holding all elements of @var{vec}.
address@hidden deffn
+
address@hidden {Scheme Procedure} list->u8vector lst
address@hidden {Scheme Procedure} list->s8vector lst
address@hidden {Scheme Procedure} list->u16vector lst
address@hidden {Scheme Procedure} list->s16vector lst
address@hidden {Scheme Procedure} list->u32vector lst
address@hidden {Scheme Procedure} list->s32vector lst
address@hidden {Scheme Procedure} list->u64vector lst
address@hidden {Scheme Procedure} list->s64vector lst
address@hidden {Scheme Procedure} list->f32vector lst
address@hidden {Scheme Procedure} list->f64vector lst
address@hidden {Scheme Procedure} list->c32vector lst
address@hidden {Scheme Procedure} list->c64vector lst
address@hidden {C Function} scm_list_to_u8vector (lst)
address@hidden {C Function} scm_list_to_s8vector (lst)
address@hidden {C Function} scm_list_to_u16vector (lst)
address@hidden {C Function} scm_list_to_s16vector (lst)
address@hidden {C Function} scm_list_to_u32vector (lst)
address@hidden {C Function} scm_list_to_s32vector (lst)
address@hidden {C Function} scm_list_to_u64vector (lst)
address@hidden {C Function} scm_list_to_s64vector (lst)
address@hidden {C Function} scm_list_to_f32vector (lst)
address@hidden {C Function} scm_list_to_f64vector (lst)
address@hidden {C Function} scm_list_to_c32vector (lst)
address@hidden {C Function} scm_list_to_c64vector (lst)
+Return a newly allocated homogeneous numeric vector of the indicated type,
+initialized with the elements of the list @var{lst}.
address@hidden deffn
+
address@hidden {C Function} SCM scm_take_u8vector (const scm_t_uint8 *data,
size_t len)
address@hidden {C Function} SCM scm_take_s8vector (const scm_t_int8 *data,
size_t len)
address@hidden {C Function} SCM scm_take_u16vector (const scm_t_uint16 *data,
size_t len)
address@hidden {C Function} SCM scm_take_s16vector (const scm_t_int16 *data,
size_t len)
address@hidden {C Function} SCM scm_take_u32vector (const scm_t_uint32 *data,
size_t len)
address@hidden {C Function} SCM scm_take_s32vector (const scm_t_int32 *data,
size_t len)
address@hidden {C Function} SCM scm_take_u64vector (const scm_t_uint64 *data,
size_t len)
address@hidden {C Function} SCM scm_take_s64vector (const scm_t_int64 *data,
size_t len)
address@hidden {C Function} SCM scm_take_f32vector (const float *data, size_t
len)
address@hidden {C Function} SCM scm_take_f64vector (const double *data, size_t
len)
address@hidden {C Function} SCM scm_take_c32vector (const float *data, size_t
len)
address@hidden {C Function} SCM scm_take_c64vector (const double *data, size_t
len)
+Return a new uniform numeric vector of the indicated type and length
+that uses the memory pointed to by @var{data} to store its elements.
+This memory will eventually be freed with @code{free}. The argument
address@hidden specifies the number of elements in @var{data}, not its size
+in bytes.
+
+The @code{c32} and @code{c64} variants take a pointer to a C array of
address@hidden or @code{double}s. The real parts of the complex numbers
+are at even indices in that array, the corresponding imaginary parts are
+at the following odd index.
address@hidden deftypefn
+
address@hidden {C Function} {const scm_t_uint8 *} scm_u8vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_int8 *} scm_s8vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_uint16 *} scm_u16vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_int16 *} scm_s16vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_uint32 *} scm_u32vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_int32 *} scm_s32vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_uint64 *} scm_u64vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const scm_t_int64 *} scm_s64vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const float *} scm_f23vector_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const double *} scm_f64vector_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const float *} scm_c32vector_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {const double *} scm_c64vector_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+Like @code{scm_vector_elements} (@pxref{Vector Accessing from C}), but
+returns a pointer to the elements of a uniform numeric vector of the
+indicated kind.
address@hidden deftypefn
+
address@hidden {C Function} {scm_t_uint8 *} scm_u8vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_int8 *} scm_s8vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_uint16 *} scm_u16vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_int16 *} scm_s16vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_uint32 *} scm_u32vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_int32 *} scm_s32vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_uint64 *} scm_u64vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {scm_t_int64 *} scm_s64vector_writable_elements
(SCM vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {float *} scm_f23vector_writable_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {double *} scm_f64vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {float *} scm_c32vector_writable_elements (SCM vec,
scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
address@hidden {C Function} {double *} scm_c64vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+Like @code{scm_vector_writable_elements} (@pxref{Vector Accessing from
+C}), but returns a pointer to the elements of a uniform numeric vector
+of the indicated kind.
address@hidden deftypefn
+
address@hidden SRFI-4 Generic Operations
address@hidden SRFI-4 - Generic operations
+
+Guile also provides procedures that operate on all types of uniform numeric
+vectors. In what is probably a bug, these procedures are currently available
in
+the default environment as well; however prudent hackers will make sure to
+import @code{(srfi srfi-4 gnu)} before using these.
+
address@hidden {C Function} int scm_is_uniform_vector (SCM uvec)
+Return non-zero when @var{uvec} is a uniform numeric vector, zero
+otherwise.
address@hidden deftypefn
+
address@hidden {C Function} size_t scm_c_uniform_vector_length (SCM uvec)
+Return the number of elements of @var{uvec} as a @code{size_t}.
address@hidden deftypefn
+
address@hidden {Scheme Procedure} uniform-vector? obj
address@hidden {C Function} scm_uniform_vector_p (obj)
+Return @code{#t} if @var{obj} is a homogeneous numeric vector of the
+indicated type.
address@hidden deffn
+
address@hidden {Scheme Procedure} uniform-vector-length vec
address@hidden {C Function} scm_uniform_vector_length (vec)
+Return the number of elements in @var{vec}.
address@hidden deffn
+
address@hidden {Scheme Procedure} uniform-vector-ref vec i
address@hidden {C Function} scm_uniform_vector_ref (vec i)
+Return the element at index @var{i} in @var{vec}. The first element
+in @var{vec} is index 0.
address@hidden deffn
+
address@hidden {Scheme Procedure} uniform-vector-set! vec i value
address@hidden {C Function} scm_uniform_vector_set_x (vec i value)
+Set the element at index @var{i} in @var{vec} to @var{value}. The
+first element in @var{vec} is index 0. The return value is
+unspecified.
address@hidden deffn
+
address@hidden {Scheme Procedure} uniform-vector->list vec
address@hidden {C Function} scm_uniform_vector_to_list (vec)
+Return a newly allocated list holding all elements of @var{vec}.
address@hidden deffn
+
address@hidden {C Function} {const void *} scm_uniform_vector_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+Like @code{scm_vector_elements} (@pxref{Vector Accessing from C}), but
+returns a pointer to the elements of a uniform numeric vector.
address@hidden deftypefn
+
address@hidden {C Function} {void *} scm_uniform_vector_writable_elements (SCM
vec, scm_t_array_handle *handle, size_t *lenp, ssize_t *incp)
+Like @code{scm_vector_writable_elements} (@pxref{Vector Accessing from
+C}), but returns a pointer to the elements of a uniform numeric vector.
address@hidden deftypefn
+
+Unless you really need to the limited generality of these functions, it is best
+to use the type-specific functions, or the generalized vector accessors.
+
address@hidden SRFI-4 and Bytevectors
address@hidden SRFI-4 - Relation to bytevectors
+
+Guile implements SRFI-4 vectors using bytevectors (@pxref{Bytevectors}). Often
+when you have a numeric vector, you end up wanting to write its bytes
somewhere,
+or have access to the underlying bytes, or read in bytes from somewhere else.
+Bytevectors are very good at this sort of thing. But the SRFI-4 APIs are nicer
+to use when doing number-crunching, because they are addressed by element and
+not by byte.
+
+So as a compromise, Guile allows all bytevector functions to operate on numeric
+vectors. They address the underlying bytes in the native endianness, as one
+would expect.
+
+Following the same reasoning, that it's just bytes underneath, Guile also
allows
+uniform vectors of a given type to be accessed as if they were of any type. One
+can fill a @nicode{u32vector}, and access its elements with
address@hidden One can use @nicode{f64vector-ref} on bytevectors. It's
+all the same to Guile.
+
+In this way, uniform numeric vectors may be written to and read from
+input/output ports using the procedures that operate on bytevectors.
+
address@hidden, for more information.
+
+
address@hidden SRFI-4 Extensions
address@hidden SRFI-4 - Guile extensions
+
+Guile defines some useful extensions to SRFI-4, which are not available in the
+default Guile environment. They may be imported by loading the extensions
+module:
+
address@hidden
+(use-modules (srfi srfi-4 gnu))
address@hidden example
+
address@hidden {Scheme Procedure} any->u8vector obj
address@hidden {Scheme Procedure} any->s8vector obj
address@hidden {Scheme Procedure} any->u16vector obj
address@hidden {Scheme Procedure} any->s16vector obj
address@hidden {Scheme Procedure} any->u32vector obj
address@hidden {Scheme Procedure} any->s32vector obj
address@hidden {Scheme Procedure} any->u64vector obj
address@hidden {Scheme Procedure} any->s64vector obj
address@hidden {Scheme Procedure} any->f32vector obj
address@hidden {Scheme Procedure} any->f64vector obj
address@hidden {Scheme Procedure} any->c32vector obj
address@hidden {Scheme Procedure} any->c64vector obj
address@hidden {C Function} scm_any_to_u8vector (obj)
address@hidden {C Function} scm_any_to_s8vector (obj)
address@hidden {C Function} scm_any_to_u16vector (obj)
address@hidden {C Function} scm_any_to_s16vector (obj)
address@hidden {C Function} scm_any_to_u32vector (obj)
address@hidden {C Function} scm_any_to_s32vector (obj)
address@hidden {C Function} scm_any_to_u64vector (obj)
address@hidden {C Function} scm_any_to_s64vector (obj)
address@hidden {C Function} scm_any_to_f32vector (obj)
address@hidden {C Function} scm_any_to_f64vector (obj)
address@hidden {C Function} scm_any_to_c32vector (obj)
address@hidden {C Function} scm_any_to_c64vector (obj)
+Return a (maybe newly allocated) uniform numeric vector of the indicated
+type, initialized with the elements of @var{obj}, which must be a list,
+a vector, or a uniform vector. When @var{obj} is already a suitable
+uniform numeric vector, it is returned unchanged.
address@hidden deffn
+
@node SRFI-6
@subsection SRFI-6 - Basic String Ports
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index 9bef507..856c87a 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -429,7 +429,6 @@ install-exec-hook:
## working.
noinst_HEADERS = conv-integer.i.c conv-uinteger.i.c \
ieee-754.h \
- srfi-4.i.c \
srfi-14.i.c \
quicksort.i.c \
win32-uname.h win32-dirent.h win32-socket.h \
@@ -570,7 +569,6 @@ modinclude_HEADERS = \
values.h \
variable.h \
vectors.h \
- vm-bootstrap.h \
vm-engine.h \
vm-expand.h \
vm.h \
diff --git a/libguile/_scm.h b/libguile/_scm.h
index c3aa8ff..f80ec83 100644
--- a/libguile/_scm.h
+++ b/libguile/_scm.h
@@ -79,6 +79,8 @@
#include "libguile/boolean.h" /* Everyone wonders about the truth. */
#include "libguile/threads.h" /* You are not alone. */
#include "libguile/snarf.h" /* Everyone snarfs. */
+#include "libguile/foreign.h" /* Snarfing needs the foreign data structures.
*/
+#include "libguile/programs.h" /* ... and program.h. */
#include "libguile/variable.h"
#include "libguile/modules.h"
#include "libguile/inline.h"
diff --git a/libguile/array-map.c b/libguile/array-map.c
index c673b4d..2041d05 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1996,1998,2000,2001,2004,2005, 2006, 2008, 2009, 2010 Free
Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -921,6 +921,7 @@ scm_raequal (SCM ra0, SCM ra1)
return scm_from_bool(raeql (ra0, SCM_BOOL_T, ra1));
}
+static SCM scm_i_array_equal_p (SCM, SCM, SCM);
SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
(SCM ra0, SCM ra1, SCM rest),
"Return @code{#t} iff all arguments are arrays with the same\n"
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 39d1067..db62585 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -570,150 +570,6 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
#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)
{
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 325bb9c..964a1fa 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -46,15 +46,9 @@ 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
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index ac5bc16..45dae1c 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -275,6 +275,13 @@ scm_c_make_bytevector (size_t len)
return make_bytevector (len, SCM_ARRAY_ELEMENT_TYPE_VU8);
}
+/* Return a new bytevector of size LEN elements. */
+SCM
+scm_i_make_typed_bytevector (size_t len, scm_t_array_element_type element_type)
+{
+ return make_bytevector (len, element_type);
+}
+
/* Return a bytevector of size LEN made up of CONTENTS. The area pointed to
by CONTENTS must have been allocated using `scm_gc_malloc ()'. */
SCM
@@ -283,6 +290,13 @@ scm_c_take_bytevector (signed char *contents, size_t len)
return make_bytevector_from_buffer (len, contents,
SCM_ARRAY_ELEMENT_TYPE_VU8);
}
+SCM
+scm_c_take_typed_bytevector (signed char *contents, size_t len,
+ scm_t_array_element_type element_type)
+{
+ return make_bytevector_from_buffer (len, contents, element_type);
+}
+
/* Shrink BV to C_NEW_LEN (which is assumed to be smaller than its current
size) and return the new bytevector (possibly different from BV). */
SCM
@@ -2081,7 +2095,7 @@ 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]);
+ return scm_c_make_rectangular (contents[i/4], contents[i/4 + 1]);
}
static SCM
@@ -2089,7 +2103,7 @@ 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]);
+ return scm_c_make_rectangular (contents[i/8], contents[i/8 + 1]);
}
typedef SCM (*scm_t_bytevector_ref_fn)(SCM, SCM);
@@ -2126,23 +2140,22 @@ bv_handle_ref (scm_t_array_handle *h, size_t index)
return ref_fn (h->array, byte_index);
}
+/* FIXME add checks!!! */
static SCM
bytevector_set_c32 (SCM bv, SCM idx, SCM val)
-{ /* checks are unnecessary here */
- float *contents = (float*)SCM_BYTEVECTOR_CONTENTS (bv);
+{ 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);
+ contents[i/4] = scm_c_real_part (val);
+ contents[i/4 + 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);
+{ 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);
+ contents[i/8] = scm_c_real_part (val);
+ contents[i/8 + 1] = scm_c_imag_part (val);
return SCM_UNSPECIFIED;
}
diff --git a/libguile/bytevectors.h b/libguile/bytevectors.h
index 59db89e..431b7dd 100644
--- a/libguile/bytevectors.h
+++ b/libguile/bytevectors.h
@@ -130,6 +130,10 @@ SCM_API SCM scm_utf32_to_string (SCM, SCM);
/* 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/chars.c b/libguile/chars.c
index 49c1ea3..d2749f4 100644
--- a/libguile/chars.c
+++ b/libguile/chars.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 2009, 2010
Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -44,6 +44,7 @@ SCM_DEFINE (scm_char_p, "char?", 1, 0, 0,
}
#undef FUNC_NAME
+static SCM scm_i_char_eq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_eq_p, "char=?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} if the Unicode code point of @var{x} is equal to
the\n"
@@ -74,6 +75,7 @@ SCM scm_char_eq_p (SCM x, SCM y)
#undef FUNC_NAME
+static SCM scm_i_char_less_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_less_p, "char<?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} iff the code point of @var{x} is less than the
code\n"
@@ -103,6 +105,7 @@ SCM scm_char_less_p (SCM x, SCM y)
}
#undef FUNC_NAME
+static SCM scm_i_char_leq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_leq_p, "char<=?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} if the Unicode code point of @var{x} is less
than or\n"
@@ -132,6 +135,7 @@ SCM scm_char_leq_p (SCM x, SCM y)
}
#undef FUNC_NAME
+static SCM scm_i_char_gr_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_gr_p, "char>?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} if the Unicode code point of @var{x} is greater
than\n"
@@ -161,6 +165,7 @@ SCM scm_char_gr_p (SCM x, SCM y)
}
#undef FUNC_NAME
+static SCM scm_i_char_geq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_geq_p, "char>=?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} if the Unicode code point of @var{x} is greater
than\n"
@@ -197,6 +202,7 @@ SCM scm_char_geq_p (SCM x, SCM y)
implementation would be to use that table and make a char-foldcase
function. */
+static SCM scm_i_char_ci_eq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_ci_eq_p, "char-ci=?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} if the case-folded Unicode code point of @var{x}
is\n"
@@ -226,6 +232,7 @@ SCM scm_char_ci_eq_p (SCM x, SCM y)
}
#undef FUNC_NAME
+static SCM scm_i_char_ci_less_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_ci_less_p, "char-ci<?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} if the case-folded Unicode code point of @var{x}
is\n"
@@ -255,6 +262,7 @@ SCM scm_char_ci_less_p (SCM x, SCM y)
}
#undef FUNC_NAME
+static SCM scm_i_char_ci_leq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_ci_leq_p, "char-ci<=?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} iff the case-folded Unicodd code point of
@var{x} is\n"
@@ -285,6 +293,7 @@ SCM scm_char_ci_leq_p (SCM x, SCM y)
}
#undef FUNC_NAME
+static SCM scm_i_char_ci_gr_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_ci_gr_p, "char-ci>?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} iff the case-folded code point of @var{x} is
greater\n"
@@ -314,6 +323,7 @@ SCM scm_char_ci_gr_p (SCM x, SCM y)
}
#undef FUNC_NAME
+static SCM scm_i_char_ci_geq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_char_ci_geq_p, "char-ci>=?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} iff the case-folded Unicode code point of
@var{x} is\n"
diff --git a/libguile/debug.c b/libguile/debug.c
index 0f83ea0..1c86c76 100644
--- a/libguile/debug.c
+++ b/libguile/debug.c
@@ -1,5 +1,5 @@
/* Debugging extensions for Guile
- * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008,
2009 Free Software Foundation
+ * Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2006, 2008,
2009, 2010 Free Software Foundation
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -35,6 +35,7 @@
#include "libguile/throw.h"
#include "libguile/macros.h"
#include "libguile/smob.h"
+#include "libguile/struct.h"
#include "libguile/procprop.h"
#include "libguile/srcprop.h"
#include "libguile/alist.h"
@@ -136,18 +137,15 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
"Return the name of the procedure @var{proc}")
#define FUNC_NAME s_scm_procedure_name
{
+ SCM name;
+
SCM_VALIDATE_PROC (1, proc);
- switch (SCM_TYP7 (proc)) {
- case scm_tc7_gsubr:
- return SCM_SUBR_NAME (proc);
- default:
- {
- SCM name = scm_procedure_property (proc, scm_sym_name);
- if (scm_is_false (name) && SCM_PROGRAM_P (proc))
- name = scm_program_name (proc);
- return name;
- }
- }
+ while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
+ proc = SCM_STRUCT_PROCEDURE (proc);
+ name = scm_procedure_property (proc, scm_sym_name);
+ if (scm_is_false (name) && SCM_PROGRAM_P (proc))
+ name = scm_program_name (proc);
+ return name;
}
#undef FUNC_NAME
diff --git a/libguile/deprecated.c b/libguile/deprecated.c
index 3a61342..e8cec8a 100644
--- a/libguile/deprecated.c
+++ b/libguile/deprecated.c
@@ -28,6 +28,11 @@
#include "libguile/_scm.h"
#include "libguile/async.h"
+#include "libguile/arrays.h"
+#include "libguile/array-map.h"
+#include "libguile/generalized-arrays.h"
+#include "libguile/bytevectors.h"
+#include "libguile/bitvectors.h"
#include "libguile/deprecated.h"
#include "libguile/discouraged.h"
#include "libguile/deprecation.h"
@@ -36,7 +41,6 @@
#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"
@@ -48,12 +52,14 @@
#include "libguile/ports.h"
#include "libguile/eq.h"
#include "libguile/read.h"
+#include "libguile/r6rs-ports.h"
#include "libguile/strports.h"
#include "libguile/smob.h"
#include "libguile/alist.h"
#include "libguile/keywords.h"
#include "libguile/socket.h"
#include "libguile/feature.h"
+#include "libguile/uniform.h"
#include <math.h>
#include <stdio.h>
@@ -1327,65 +1333,222 @@ scm_vector_equal_p (SCM x, SCM y)
return scm_equal_p (x, y);
}
-int
-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_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"
+ "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
+ "The optional arguments @var{start} (inclusive) and @var{end}\n"
+ "(exclusive) allow a specified region to be read,\n"
+ "leaving the remainder of the vector unchanged.\n\n"
+ "When @var{port-or-fdes} is a port, all specified elements\n"
+ "of @var{uvec} are attempted to be read, potentially blocking\n"
+ "while waiting formore input or end-of-file.\n"
+ "When @var{port-or-fd} is an integer, a single call to\n"
+ "read(2) is made.\n\n"
+ "An error is signalled when the last element has only\n"
+ "been partially filled before reaching end-of-file or in\n"
+ "the single call to read(2).\n\n"
+ "@code{uniform-vector-read!} returns the number of elements\n"
+ "read.\n\n"
+ "@var{port-or-fdes} may be omitted, in which case it defaults\n"
+ "to the value returned by @code{(current-input-port)}.")
+#define FUNC_NAME s_scm_uniform_vector_read_x
+{
+ size_t width;
+ SCM_VALIDATE_BYTEVECTOR (SCM_ARG1, uvec);
-size_t
-scm_i_array_ndim (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_NDIM is deprecated. "
- "Use scm_c_array_rank or scm_array_handle_rank instead.");
- return scm_c_array_rank (a);
-}
+ scm_c_issue_deprecation_warning
+ ("`uniform-vector-read!' is deprecated. Use `get-bytevector-n!' from\n"
+ "`(rnrs io ports)' instead.");
-int
-scm_i_array_contp (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_CONTP is deprecated. Do not use it.");
- return SCM_I_ARRAY_CONTP (a);
-}
+ width = scm_to_size_t (scm_uniform_vector_element_size (uvec));
-scm_t_array *
-scm_i_array_mem (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_MEM is deprecated. Do not use it.");
- return (scm_t_array *)SCM_I_ARRAY_MEM (a);
+ return scm_get_bytevector_n_x (port_or_fd, uvec,
+ scm_from_size_t (scm_to_size_t (start)*width),
+ scm_from_size_t ((scm_to_size_t (end)
+ - scm_to_size_t (start))
+ * width));
}
+#undef FUNC_NAME
-SCM
-scm_i_array_v (SCM a)
-{
- /* We could use scm_shared_array_root here, but it is better to move
- them away from expecting vectors as the basic storage for arrays.
- */
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_V is deprecated. Do not use it.");
- return SCM_I_ARRAY_V (a);
+SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
+ (SCM uvec, SCM port_or_fd, SCM start, SCM end),
+ "Write the elements of @var{uvec} as raw bytes to\n"
+ "@var{port-or-fdes}, in the host byte order.\n\n"
+ "The optional arguments @var{start} (inclusive)\n"
+ "and @var{end} (exclusive) allow\n"
+ "a specified region to be written.\n\n"
+ "When @var{port-or-fdes} is a port, all specified elements\n"
+ "of @var{uvec} are attempted to be written, potentially blocking\n"
+ "while waiting for more room.\n"
+ "When @var{port-or-fd} is an integer, a single call to\n"
+ "write(2) is made.\n\n"
+ "An error is signalled when the last element has only\n"
+ "been partially written in the single call to write(2).\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_vector_write
+{
+ size_t width;
+ SCM_VALIDATE_BYTEVECTOR (SCM_ARG1, uvec);
+ port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
+
+ scm_c_issue_deprecation_warning
+ ("`uniform-vector-write' is deprecated. Use `put-bytevector' from\n"
+ "`(rnrs io ports)' instead.");
+
+ width = scm_to_size_t (scm_uniform_vector_element_size (uvec));
+
+ return scm_put_bytevector (port_or_fd, uvec,
+ scm_from_size_t (scm_to_size_t (start)*width),
+ scm_from_size_t ((scm_to_size_t (end)
+ - scm_to_size_t (start))
+ * width));
}
+#undef FUNC_NAME
-size_t
-scm_i_array_base (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_BASE is deprecated. Do not use it.");
- return SCM_I_ARRAY_BASE (a);
+static 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_size_t (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_t_array_dim *
-scm_i_array_dims (SCM a)
-{
- scm_c_issue_deprecation_warning
- ("SCM_ARRAY_DIMS is deprecated. Use scm_array_handle_dims instead.");
- return SCM_I_ARRAY_DIMS (a);
+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
SCM
scm_i_cur_inp (void)
@@ -1622,6 +1785,13 @@ scm_trampoline_2 (SCM proc)
return scm_call_2;
}
+int
+scm_i_subr_p (SCM x)
+{
+ scm_c_issue_deprecation_warning ("`scm_subr_p' is deprecated. Use
SCM_PRIMITIVE_P instead.");
+ return SCM_PRIMITIVE_P (x);
+}
+
void
scm_i_init_deprecated ()
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index 5b7c9a2..8ecd8b2 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -24,7 +24,6 @@
*/
#include "libguile/__scm.h"
-#include "libguile/arrays.h"
#include "libguile/strings.h"
#include "libguile/eval.h"
@@ -232,7 +231,6 @@ SCM_DEPRECATED SCM scm_gentemp (SCM prefix, SCM obarray);
#define scm_srcprops_chunk scm_t_srcprops_chunk
#define scm_array scm_t_array
#define scm_array_dim scm_t_array_dim
-#define SCM_ARRAY_CONTIGUOUS SCM_ARRAY_FLAG_CONTIGUOUS
#define SCM_FUNC_NAME (scm_makfrom0str (FUNC_NAME))
#define SCM_WTA(pos, scm) \
@@ -485,6 +483,15 @@ SCM_DEPRECATED scm_t_array_dim *scm_i_array_dims (SCM a);
#define SCM_ARRAY_BASE(a) scm_i_array_base(a)
#define SCM_ARRAY_DIMS(a) scm_i_array_dims(a)
+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 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);
+
/* Deprecated because they should not be lvalues and we want people to
use the official interfaces.
*/
@@ -599,7 +606,8 @@ SCM_DEPRECATED scm_t_trampoline_2 scm_trampoline_2 (SCM
proc);
/* Deprecated 2010-01-05, use SCM_PRIMITIVE_P instead */
-#define scm_subr_p(x) (SCM_PRIMITIVE_P (x))
+SCM_DEPRECATED int scm_i_subr_p (SCM x);
+#define scm_subr_p(x) (scm_i_subr_p (x))
diff --git a/libguile/eq.c b/libguile/eq.c
index eaf1acc..6a533da 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009, 2010
Free Software Foundation, 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,6 +48,7 @@
#endif
+static SCM scm_i_eq_p (SCM x, SCM y, SCM rest);
SCM_DEFINE (scm_i_eq_p, "eq?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} if @var{x} and @var{y} are the same object,\n"
@@ -120,6 +121,7 @@ real_eqv (double x, double y)
return !memcmp (&x, &y, sizeof(double)) || (x != x && y != y);
}
+static SCM scm_i_eqv_p (SCM x, SCM y, SCM rest);
#include <stdio.h>
SCM_DEFINE (scm_i_eqv_p, "eqv?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
@@ -212,7 +214,7 @@ SCM scm_eqv_p (SCM x, SCM y)
#undef FUNC_NAME
-SCM scm_i_equal_p (SCM, SCM, SCM);
+static SCM scm_i_equal_p (SCM, SCM, SCM);
SCM_PRIMITIVE_GENERIC (scm_i_equal_p, "equal?", 0, 2, 1,
(SCM x, SCM y, SCM rest),
"Return @code{#t} if @var{x} and @var{y} are the same
type, and\n"
diff --git a/libguile/evalext.c b/libguile/evalext.c
index 32f1f4f..be775a8 100644
--- a/libguile/evalext.c
+++ b/libguile/evalext.c
@@ -81,12 +81,15 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1,
0, 0,
case scm_tc7_hashtable:
case scm_tc7_fluid:
case scm_tc7_dynamic_state:
+ case scm_tc7_frame:
+ case scm_tc7_objcode:
+ case scm_tc7_vm:
+ case scm_tc7_vm_cont:
case scm_tc7_number:
case scm_tc7_string:
case scm_tc7_smob:
case scm_tc7_program:
case scm_tc7_bytevector:
- case scm_tc7_gsubr:
case scm_tcs_struct:
return SCM_BOOL_T;
default:
diff --git a/libguile/frames.c b/libguile/frames.c
index 5077d8e..f8eed86 100644
--- a/libguile/frames.c
+++ b/libguile/frames.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -23,12 +23,9 @@
#include <stdlib.h>
#include <string.h>
#include "_scm.h"
-#include "vm-bootstrap.h"
#include "frames.h"
-scm_t_bits scm_tc16_frame;
-
#define RELOC(frame, val) (val + SCM_VM_FRAME_OFFSET (frame))
SCM
@@ -42,11 +39,11 @@ scm_c_make_frame (SCM stack_holder, SCM *fp, SCM *sp,
p->sp = sp;
p->ip = ip;
p->offset = offset;
- SCM_RETURN_NEWSMOB (scm_tc16_frame, p);
+ return scm_cell (scm_tc7_frame, (scm_t_bits)p);
}
-static int
-frame_print (SCM frame, SCM port, scm_print_state *pstate)
+void
+scm_i_frame_print (SCM frame, SCM port, scm_print_state *pstate)
{
scm_puts ("#<frame ", port);
scm_uintprint (SCM_UNPACK (frame), 16, port);
@@ -54,8 +51,6 @@ frame_print (SCM frame, SCM port, scm_print_state *pstate)
scm_write (scm_frame_procedure (frame), port);
/* don't write args, they can get us into trouble. */
scm_puts (">", port);
-
- return 1;
}
@@ -293,13 +288,6 @@ SCM_DEFINE (scm_frame_previous, "frame-previous", 1, 0, 0,
void
-scm_bootstrap_frames (void)
-{
- scm_tc16_frame = scm_make_smob_type ("frame", 0);
- scm_set_smob_print (scm_tc16_frame, frame_print);
-}
-
-void
scm_init_frames (void)
{
#ifndef SCM_MAGIC_SNARFER
diff --git a/libguile/frames.h b/libguile/frames.h
index 0636fe8..33432eb 100644
--- a/libguile/frames.h
+++ b/libguile/frames.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -87,8 +87,6 @@
* Heap frames
*/
-SCM_API scm_t_bits scm_tc16_frame;
-
struct scm_frame
{
SCM stack_holder;
@@ -98,8 +96,8 @@ struct scm_frame
scm_t_ptrdiff offset;
};
-#define SCM_VM_FRAME_P(x) SCM_SMOB_PREDICATE (scm_tc16_frame, x)
-#define SCM_VM_FRAME_DATA(x) ((struct scm_frame*)SCM_SMOB_DATA (x))
+#define SCM_VM_FRAME_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_frame)
+#define SCM_VM_FRAME_DATA(x) ((struct scm_frame*)SCM_CELL_WORD_1 (x))
#define SCM_VM_FRAME_STACK_HOLDER(f) SCM_VM_FRAME_DATA(f)->stack_holder
#define SCM_VM_FRAME_FP(f) SCM_VM_FRAME_DATA(f)->fp
#define SCM_VM_FRAME_SP(f) SCM_VM_FRAME_DATA(f)->sp
@@ -122,7 +120,8 @@ SCM_API SCM scm_frame_mv_return_address (SCM frame);
SCM_API SCM scm_frame_dynamic_link (SCM frame);
SCM_API SCM scm_frame_previous (SCM frame);
-SCM_INTERNAL void scm_bootstrap_frames (void);
+SCM_INTERNAL void scm_i_frame_print (SCM frame, SCM port,
+ scm_print_state *pstate);
SCM_INTERNAL void scm_init_frames (void);
#endif /* _SCM_FRAMES_H_ */
diff --git a/libguile/gc.c b/libguile/gc.c
index d5943b4..700f3a4 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -756,6 +756,14 @@ scm_i_tag_name (scm_t_bits tag)
return "fluid";
case scm_tc7_dynamic_state:
return "dynamic state";
+ case scm_tc7_frame:
+ return "frame";
+ case scm_tc7_objcode:
+ return "objcode";
+ case scm_tc7_vm:
+ return "vm";
+ case scm_tc7_vm_cont:
+ return "vm continuation";
case scm_tc7_wvect:
return "weak vector";
case scm_tc7_vector:
@@ -789,9 +797,6 @@ scm_i_tag_name (scm_t_bits tag)
case scm_tc7_variable:
return "variable";
break;
- case scm_tc7_gsubr:
- return "gsubr";
- break;
case scm_tc7_port:
return "port";
break;
diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c
index ea5388d..ff05151 100644
--- a/libguile/generalized-arrays.c
+++ b/libguile/generalized-arrays.c
@@ -138,9 +138,6 @@ SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0,
0,
}
#undef FUNC_NAME
-/* HACK*/
-#include "libguile/bytevectors.h"
-
SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
(SCM ra),
"")
@@ -149,10 +146,6 @@ SCM_DEFINE (scm_array_type, "array-type", 1, 0, 0,
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);
diff --git a/libguile/goops.c b/libguile/goops.c
index a703e7a..87ae993 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -162,6 +162,10 @@ static SCM class_foreign;
static SCM class_hashtable;
static SCM class_fluid;
static SCM class_dynamic_state;
+static SCM class_frame;
+static SCM class_objcode;
+static SCM class_vm;
+static SCM class_vm_cont;
/* Port classes. Allocate 3 times the maximum number of port types so that
input ports, output ports, and in/out ports can be stored at different
@@ -223,6 +227,14 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
return class_fluid;
case scm_tc7_dynamic_state:
return class_dynamic_state;
+ case scm_tc7_frame:
+ return class_frame;
+ case scm_tc7_objcode:
+ return class_objcode;
+ case scm_tc7_vm:
+ return class_vm;
+ case scm_tc7_vm_cont:
+ return class_vm_cont;
case scm_tc7_string:
return scm_class_string;
case scm_tc7_number:
@@ -236,13 +248,11 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
case scm_tc16_fraction:
return scm_class_fraction;
}
- case scm_tc7_gsubr:
- if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x))
+ case scm_tc7_program:
+ if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x) && *SCM_SUBR_GENERIC (x))
return scm_class_primitive_generic;
else
return scm_class_procedure;
- case scm_tc7_program:
- return scm_class_procedure;
case scm_tc7_smob:
{
@@ -2033,7 +2043,9 @@ scm_sys_compute_applicable_methods (SCM gf, SCM args)
#undef FUNC_NAME
SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
-SCM_VARIABLE_INIT (var_compute_applicable_methods,
"compute-applicable-methods", scm_c_define_gsubr
(s_sys_compute_applicable_methods, 2, 0, 0,
scm_sys_compute_applicable_methods));
+SCM_VARIABLE_INIT (var_compute_applicable_methods,
"compute-applicable-methods",
+ scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0,
0,
+ scm_sys_compute_applicable_methods));
/******************************************************************************
*
@@ -2402,6 +2414,14 @@ create_standard_classes (void)
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&class_dynamic_state, "<dynamic-state>",
scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_frame, "<frame>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_objcode, "<objcode>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_vm, "<vm>",
+ scm_class_class, scm_class_top, SCM_EOL);
+ make_stdcls (&class_vm_cont, "<vm-continuation>",
+ scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_number, "<number>",
scm_class_class, scm_class_top, SCM_EOL);
make_stdcls (&scm_class_complex, "<complex>",
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 70be51b..f0c6222 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010
Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -21,17 +21,16 @@
# include <config.h>
#endif
-#include <alloca.h>
-
#include <stdio.h>
#include <stdarg.h>
#include "libguile/_scm.h"
-#include "libguile/procprop.h"
-#include "libguile/root.h"
-
#include "libguile/gsubr.h"
-#include "libguile/deprecation.h"
+#include "libguile/foreign.h"
+#include "libguile/instructions.h"
+#include "libguile/objcodes.h"
+#include "libguile/srfi-4.h"
+#include "libguile/programs.h"
#include "libguile/private-options.h"
@@ -43,38 +42,781 @@
/* #define GSUBR_TEST */
-SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
+
+
+/* OK here goes nothing: we're going to define VM assembly trampolines for
+ invoking subrs, along with their meta-information, and then wrap them into
+ statically allocated objcode values. Ready? Right!
+*/
+
+/* There's a maximum of 10 args, so the number of possible combinations is:
+ (REQ-OPT-REST)
+ for 0 args: 1 (000) (1 + 0)
+ for 1 arg: 3 (100, 010, 001) (2 + 1)
+ for 2 args: 5 (200, 110, 020, 101, 011) (3 + 2)
+ for 3 args: 7 (300, 210, 120, 030, 201, 111, 021) (4 + 3)
+ for N args: 2N+1
+
+ and the index at which N args starts:
+ for 0 args: 0
+ for 1 args: 1
+ for 2 args: 4
+ for 3 args: 9
+ for N args: N^2
+
+ One can prove this:
+
+ (1 + 3 + 5 + ... + (2N+1))
+ = ((2N+1)+1)/2 * (N+1)
+ = 2(N+1)/2 * (N+1)
+ = (N+1)^2
+
+ Thus the total sum is 11^2 = 121. Let's just generate all of them as
+ read-only data.
+*/
+
+#ifdef WORDS_BIGENDIAN
+#define OBJCODE_HEADER 0, 0, 0, 16, 0, 0, 0, 40
+#define META_HEADER 0, 0, 0, 32, 0, 0, 0, 0
+#else
+#define OBJCODE_HEADER 16, 0, 0, 0, 40, 0, 0, 0
+#define META_HEADER 32, 0, 0, 0, 0, 0, 0, 0
+#endif
+
+/* A: req; B: opt; C: rest */
+#define A(nreq) \
+ OBJCODE_HEADER, \
+ /* 0 */ scm_op_assert_nargs_ee, 0, nreq, /* assert number of args */ \
+ /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr
pointer */ \
+ /* 5 */ scm_op_subr_call, nreq, /* and call (will return value as well) */ \
+ /* 7 */ scm_op_nop, \
+ /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
+ /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
+ /* 16 */ META (3, 7, nreq, 0, 0)
+
+#define B(nopt) \
+ OBJCODE_HEADER, \
+ /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */ \
+ /* 3 */ scm_op_assert_nargs_ee, 0, nopt, /* assert number of args */ \
+ /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr
pointer */ \
+ /* 8 */ scm_op_subr_call, nopt, /* and call (will return value as well) */ \
+ /* 10 */ scm_op_nop, scm_op_nop, \
+ /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
+ /* 16 */ META (6, 10, 0, nopt, 0)
+
+#define C() \
+ OBJCODE_HEADER, \
+ /* 0 */ scm_op_push_rest, 0, 0, /* cons all args into a list */ \
+ /* 3 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr
pointer */ \
+ /* 5 */ scm_op_subr_call, 1, /* and call (will return value as well) */ \
+ /* 7 */ scm_op_nop, \
+ /* 8 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
+ /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
+ /* 16 */ META (3, 7, 0, 0, 1)
+
+#define AB(nreq, nopt) \
+ OBJCODE_HEADER, \
+ /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \
+ /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */ \
+ /* 6 */ scm_op_assert_nargs_ee, 0, nreq+nopt, /* assert number of args */ \
+ /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr
pointer */ \
+ /* 11 */ scm_op_subr_call, nreq+nopt, /* and call (will return value as
well) */ \
+ /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop, \
+ /* 16 */ META (9, 13, nreq, nopt, 0)
+
+#define AC(nreq) \
+ OBJCODE_HEADER, \
+ /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \
+ /* 3 */ scm_op_push_rest, 0, nreq, /* cons rest list */ \
+ /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr
pointer */ \
+ /* 8 */ scm_op_subr_call, nreq+1, /* and call (will return value as well) */
\
+ /* 10 */ scm_op_nop, scm_op_nop, \
+ /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
+ /* 16 */ META (6, 10, nreq, 0, 1)
+
+#define BC(nopt) \
+ OBJCODE_HEADER, \
+ /* 0 */ scm_op_bind_optionals, 0, nopt, /* bind optionals */ \
+ /* 3 */ scm_op_push_rest, 0, nopt, /* cons rest list */ \
+ /* 6 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr
pointer */ \
+ /* 8 */ scm_op_subr_call, nopt+1, /* and call (will return value as well) */
\
+ /* 10 */ scm_op_nop, scm_op_nop, \
+ /* 12 */ scm_op_nop, scm_op_nop, scm_op_nop, scm_op_nop, \
+ /* 16 */ META (6, 10, 0, nopt, 1)
+
+#define ABC(nreq, nopt) \
+ OBJCODE_HEADER, \
+ /* 0 */ scm_op_assert_nargs_ge, 0, nreq, /* assert number of args */ \
+ /* 3 */ scm_op_bind_optionals, 0, nreq+nopt, /* bind optionals */ \
+ /* 6 */ scm_op_push_rest, 0, nreq+nopt, /* cons rest list */ \
+ /* 9 */ scm_op_object_ref, 0, /* push the foreign object wrapping the subr
pointer */ \
+ /* 11 */ scm_op_subr_call, nreq+nopt+1, /* and call (will return value as
well) */ \
+ /* 13 */ scm_op_nop, scm_op_nop, scm_op_nop, \
+ /* 16 */ META (9, 13, nreq, nopt, 1)
+
+#define META(start, end, nreq, nopt, rest) \
+ META_HEADER, \
+ /* 0 */ scm_op_make_eol, /* bindings */ \
+ /* 1 */ scm_op_make_eol, /* sources */ \
+ /* 2 */ scm_op_make_int8, start, scm_op_make_int8, end, /* arity: from ip N
to ip N */ \
+ /* 6 */ scm_op_make_int8, nreq, /* the arity is N required args */ \
+ /* 8 */ scm_op_make_int8, nopt, /* N optionals */ \
+ /* 10 */ rest ? scm_op_make_true : scm_op_make_false, /* maybe a rest arg */
\
+ /* 11 */ scm_op_list, 0, 5, /* make a list of those 5 vals */ \
+ /* 14 */ scm_op_list, 0, 1, /* and the arities will be a list of that one
list */ \
+ /* 17 */ scm_op_load_symbol, 0, 0, 4, 'n', 'a', 'm', 'e', /* `name' */ \
+ /* 25 */ scm_op_object_ref, 1, /* the name from the object table */ \
+ /* 27 */ scm_op_cons, /* make a pair for the properties */ \
+ /* 28 */ scm_op_list, 0, 4, /* pack bindings, sources, and arities into list
*/ \
+ /* 31 */ scm_op_return /* and return */ \
+ /* 32 */
+
+/*
+ (defun generate-bytecode (n)
+ "Generate bytecode for N arguments"
+ (interactive "p")
+ (insert (format "/\* %d arguments *\/\n " n))
+ (let ((nreq n))
+ (while (<= 0 nreq)
+ (let ((nopt (- n nreq)))
+ (insert
+ (if (< 0 nreq)
+ (if (< 0 nopt)
+ (format "AB(%d,%d), " nreq nopt)
+ (format "A(%d), " nreq))
+ (if (< 0 nopt)
+ (format "B(%d), " nopt)
+ (format "A(0), "))))
+ (setq nreq (1- nreq))))
+ (insert "\n ")
+ (setq nreq (1- n))
+ (while (<= 0 nreq)
+ (let ((nopt (- n nreq 1)))
+ (insert
+ (if (< 0 nreq)
+ (if (< 0 nopt)
+ (format "ABC(%d,%d), " nreq nopt)
+ (format "AC(%d), " nreq))
+ (if (< 0 nopt)
+ (format "BC(%d), " nopt)
+ (format "C(), "))))
+ (setq nreq (1- nreq))))
+ (insert "\n\n ")))
+
+ (defun generate-bytecodes (n)
+ "Generate bytecodes for up to N arguments"
+ (interactive "p")
+ (let ((i 0))
+ (while (<= i n)
+ (generate-bytecode i)
+ (setq i (1+ i)))))
+*/
+static const struct
+{
+ scm_t_uint64 dummy; /* ensure 8-byte alignment; perhaps there's a better way
*/
+ const scm_t_uint8 bytes[121 * (sizeof (struct scm_objcode) + 16
+ + sizeof (struct scm_objcode) + 32)];
+} raw_bytecode = {
+ 0,
+ {
+ /* C-u 1 0 M-x generate-bytecodes RET */
+ /* 0 arguments */
+ A(0),
+
+ /* 1 arguments */
+ A(1), B(1),
+ C(),
+
+ /* 2 arguments */
+ A(2), AB(1,1), B(2),
+ AC(1), BC(1),
+
+ /* 3 arguments */
+ A(3), AB(2,1), AB(1,2), B(3),
+ AC(2), ABC(1,1), BC(2),
+
+ /* 4 arguments */
+ A(4), AB(3,1), AB(2,2), AB(1,3), B(4),
+ AC(3), ABC(2,1), ABC(1,2), BC(3),
+
+ /* 5 arguments */
+ A(5), AB(4,1), AB(3,2), AB(2,3), AB(1,4), B(5),
+ AC(4), ABC(3,1), ABC(2,2), ABC(1,3), BC(4),
+
+ /* 6 arguments */
+ A(6), AB(5,1), AB(4,2), AB(3,3), AB(2,4), AB(1,5), B(6),
+ AC(5), ABC(4,1), ABC(3,2), ABC(2,3), ABC(1,4), BC(5),
+
+ /* 7 arguments */
+ A(7), AB(6,1), AB(5,2), AB(4,3), AB(3,4), AB(2,5), AB(1,6), B(7),
+ AC(6), ABC(5,1), ABC(4,2), ABC(3,3), ABC(2,4), ABC(1,5), BC(6),
+
+ /* 8 arguments */
+ A(8), AB(7,1), AB(6,2), AB(5,3), AB(4,4), AB(3,5), AB(2,6), AB(1,7), B(8),
+ AC(7), ABC(6,1), ABC(5,2), ABC(4,3), ABC(3,4), ABC(2,5), ABC(1,6), BC(7),
+
+ /* 9 arguments */
+ A(9), AB(8,1), AB(7,2), AB(6,3), AB(5,4), AB(4,5), AB(3,6), AB(2,7),
AB(1,8), B(9),
+ AC(8), ABC(7,1), ABC(6,2), ABC(5,3), ABC(4,4), ABC(3,5), ABC(2,6),
ABC(1,7), BC(8),
+
+ /* 10 arguments */
+ A(10), AB(9,1), AB(8,2), AB(7,3), AB(6,4), AB(5,5), AB(4,6), AB(3,7),
AB(2,8), AB(1,9), B(10),
+ AC(9), ABC(8,1), ABC(7,2), ABC(6,3), ABC(5,4), ABC(4,5), ABC(3,6),
ABC(2,7), ABC(1,8), BC(9)
+ }
+};
+
+#undef A
+#undef B
+#undef C
+#undef AB
+#undef AC
+#undef BC
+#undef ABC
+#undef OBJCODE_HEADER
+#undef META_HEADER
+#undef META
+
+/*
+ ;; (nargs * nargs) + nopt + rest * (nargs + 1)
+ (defun generate-objcode-cells-helper (n)
+ "Generate objcode cells for N arguments"
+ (interactive "p")
+ (insert (format " /\* %d arguments *\/\n" n))
+ (let ((nreq n))
+ (while (<= 0 nreq)
+ (let ((nopt (- n nreq)))
+ (insert
+ (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes +
%d) },\n"
+ (* (+ 4 4 16 4 4 32)
+ (+ (* n n) nopt))))
+ (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
+ (setq nreq (1- nreq))))
+ (insert "\n")
+ (setq nreq (1- n))
+ (while (<= 0 nreq)
+ (let ((nopt (- n nreq 1)))
+ (insert
+ (format " { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes +
%d) },\n"
+ (* (+ 4 4 16 4 4 32)
+ (+ (* n n) nopt n 1))))
+ (insert " { SCM_BOOL_F, SCM_PACK (0) },\n")
+ (setq nreq (1- nreq))))
+ (insert "\n")))
+
+ (defun generate-objcode-cells (n)
+ "Generate objcode cells for up to N arguments"
+ (interactive "p")
+ (let ((i 0))
+ (while (<= i n)
+ (generate-objcode-cells-helper i)
+ (setq i (1+ i)))))
+*/
+
+#define STATIC_OBJCODE_TAG \
+ SCM_PACK (scm_tc7_objcode | (SCM_F_OBJCODE_IS_STATIC << 8))
+
+static const struct
+{
+ scm_t_uint64 dummy; /* alignment */
+ scm_t_cell cells[121 * 2]; /* 11*11 double cells */
+} objcode_cells = {
+ 0,
+ /* C-u 1 0 M-x generate-objcode-cells RET */
+ {
+ /* 0 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 0) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+
+ /* 1 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 64) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 128) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 192) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ /* 2 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 256) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 320) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 384) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 448) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 512) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ /* 3 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 576) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 640) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 704) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 768) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 832) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 896) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 960) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ /* 4 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1024) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1088) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1152) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1216) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1280) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1344) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1408) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1472) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1536) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ /* 5 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1600) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1664) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1728) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1792) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1856) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1920) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 1984) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2048) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2112) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2176) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2240) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ /* 6 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2304) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2368) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2432) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2496) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2560) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2624) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2688) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2752) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2816) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2880) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 2944) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3008) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3072) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ /* 7 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3136) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3200) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3264) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3328) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3392) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3456) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3520) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3584) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3648) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3712) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3776) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3840) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3904) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 3968) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4032) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ /* 8 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4096) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4160) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4224) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4288) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4352) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4416) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4480) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4544) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4608) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4672) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4736) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4800) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4864) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4928) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 4992) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5056) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5120) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ /* 9 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5184) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5248) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5312) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5376) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5440) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5504) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5568) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5632) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5696) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5760) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5824) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5888) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 5952) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6016) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6080) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6144) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6208) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6272) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6336) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ /* 10 arguments */
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6400) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6464) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6528) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6592) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6656) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6720) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6784) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6848) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6912) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 6976) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7040) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7104) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7168) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7232) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7296) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7360) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7424) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7488) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7552) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7616) },
+ { SCM_BOOL_F, SCM_PACK (0) },
+ { STATIC_OBJCODE_TAG, SCM_PACK (raw_bytecode.bytes + 7680) },
+ { SCM_BOOL_F, SCM_PACK (0) }
+ }
+};
+
+/*
+ (defun generate-objcode (n)
+ "Generate objcode for N arguments"
+ (interactive "p")
+ (insert (format " /\* %d arguments *\/\n" n))
+ (let ((i (* n n)))
+ (while (< i (* (1+ n) (1+ n)))
+ (insert (format " SCM_PACK (objcode_cells.cells+%d),\n" (* i 2)))
+ (setq i (1+ i)))
+ (insert "\n")))
+
+ (defun generate-objcodes (n)
+ "Generate objcodes for up to N arguments"
+ (interactive "p")
+ (let ((i 0))
+ (while (<= i n)
+ (generate-objcode i)
+ (setq i (1+ i)))))
+*/
+static const SCM scm_subr_objcode_trampolines[121] = {
+ /* C-u 1 0 M-x generate-objcodes RET */
+ /* 0 arguments */
+ SCM_PACK (objcode_cells.cells+0),
+
+ /* 1 arguments */
+ SCM_PACK (objcode_cells.cells+2),
+ SCM_PACK (objcode_cells.cells+4),
+ SCM_PACK (objcode_cells.cells+6),
+
+ /* 2 arguments */
+ SCM_PACK (objcode_cells.cells+8),
+ SCM_PACK (objcode_cells.cells+10),
+ SCM_PACK (objcode_cells.cells+12),
+ SCM_PACK (objcode_cells.cells+14),
+ SCM_PACK (objcode_cells.cells+16),
+
+ /* 3 arguments */
+ SCM_PACK (objcode_cells.cells+18),
+ SCM_PACK (objcode_cells.cells+20),
+ SCM_PACK (objcode_cells.cells+22),
+ SCM_PACK (objcode_cells.cells+24),
+ SCM_PACK (objcode_cells.cells+26),
+ SCM_PACK (objcode_cells.cells+28),
+ SCM_PACK (objcode_cells.cells+30),
+
+ /* 4 arguments */
+ SCM_PACK (objcode_cells.cells+32),
+ SCM_PACK (objcode_cells.cells+34),
+ SCM_PACK (objcode_cells.cells+36),
+ SCM_PACK (objcode_cells.cells+38),
+ SCM_PACK (objcode_cells.cells+40),
+ SCM_PACK (objcode_cells.cells+42),
+ SCM_PACK (objcode_cells.cells+44),
+ SCM_PACK (objcode_cells.cells+46),
+ SCM_PACK (objcode_cells.cells+48),
+
+ /* 5 arguments */
+ SCM_PACK (objcode_cells.cells+50),
+ SCM_PACK (objcode_cells.cells+52),
+ SCM_PACK (objcode_cells.cells+54),
+ SCM_PACK (objcode_cells.cells+56),
+ SCM_PACK (objcode_cells.cells+58),
+ SCM_PACK (objcode_cells.cells+60),
+ SCM_PACK (objcode_cells.cells+62),
+ SCM_PACK (objcode_cells.cells+64),
+ SCM_PACK (objcode_cells.cells+66),
+ SCM_PACK (objcode_cells.cells+68),
+ SCM_PACK (objcode_cells.cells+70),
+
+ /* 6 arguments */
+ SCM_PACK (objcode_cells.cells+72),
+ SCM_PACK (objcode_cells.cells+74),
+ SCM_PACK (objcode_cells.cells+76),
+ SCM_PACK (objcode_cells.cells+78),
+ SCM_PACK (objcode_cells.cells+80),
+ SCM_PACK (objcode_cells.cells+82),
+ SCM_PACK (objcode_cells.cells+84),
+ SCM_PACK (objcode_cells.cells+86),
+ SCM_PACK (objcode_cells.cells+88),
+ SCM_PACK (objcode_cells.cells+90),
+ SCM_PACK (objcode_cells.cells+92),
+ SCM_PACK (objcode_cells.cells+94),
+ SCM_PACK (objcode_cells.cells+96),
+
+ /* 7 arguments */
+ SCM_PACK (objcode_cells.cells+98),
+ SCM_PACK (objcode_cells.cells+100),
+ SCM_PACK (objcode_cells.cells+102),
+ SCM_PACK (objcode_cells.cells+104),
+ SCM_PACK (objcode_cells.cells+106),
+ SCM_PACK (objcode_cells.cells+108),
+ SCM_PACK (objcode_cells.cells+110),
+ SCM_PACK (objcode_cells.cells+112),
+ SCM_PACK (objcode_cells.cells+114),
+ SCM_PACK (objcode_cells.cells+116),
+ SCM_PACK (objcode_cells.cells+118),
+ SCM_PACK (objcode_cells.cells+120),
+ SCM_PACK (objcode_cells.cells+122),
+ SCM_PACK (objcode_cells.cells+124),
+ SCM_PACK (objcode_cells.cells+126),
+
+ /* 8 arguments */
+ SCM_PACK (objcode_cells.cells+128),
+ SCM_PACK (objcode_cells.cells+130),
+ SCM_PACK (objcode_cells.cells+132),
+ SCM_PACK (objcode_cells.cells+134),
+ SCM_PACK (objcode_cells.cells+136),
+ SCM_PACK (objcode_cells.cells+138),
+ SCM_PACK (objcode_cells.cells+140),
+ SCM_PACK (objcode_cells.cells+142),
+ SCM_PACK (objcode_cells.cells+144),
+ SCM_PACK (objcode_cells.cells+146),
+ SCM_PACK (objcode_cells.cells+148),
+ SCM_PACK (objcode_cells.cells+150),
+ SCM_PACK (objcode_cells.cells+152),
+ SCM_PACK (objcode_cells.cells+154),
+ SCM_PACK (objcode_cells.cells+156),
+ SCM_PACK (objcode_cells.cells+158),
+ SCM_PACK (objcode_cells.cells+160),
+
+ /* 9 arguments */
+ SCM_PACK (objcode_cells.cells+162),
+ SCM_PACK (objcode_cells.cells+164),
+ SCM_PACK (objcode_cells.cells+166),
+ SCM_PACK (objcode_cells.cells+168),
+ SCM_PACK (objcode_cells.cells+170),
+ SCM_PACK (objcode_cells.cells+172),
+ SCM_PACK (objcode_cells.cells+174),
+ SCM_PACK (objcode_cells.cells+176),
+ SCM_PACK (objcode_cells.cells+178),
+ SCM_PACK (objcode_cells.cells+180),
+ SCM_PACK (objcode_cells.cells+182),
+ SCM_PACK (objcode_cells.cells+184),
+ SCM_PACK (objcode_cells.cells+186),
+ SCM_PACK (objcode_cells.cells+188),
+ SCM_PACK (objcode_cells.cells+190),
+ SCM_PACK (objcode_cells.cells+192),
+ SCM_PACK (objcode_cells.cells+194),
+ SCM_PACK (objcode_cells.cells+196),
+ SCM_PACK (objcode_cells.cells+198),
+
+ /* 10 arguments */
+ SCM_PACK (objcode_cells.cells+200),
+ SCM_PACK (objcode_cells.cells+202),
+ SCM_PACK (objcode_cells.cells+204),
+ SCM_PACK (objcode_cells.cells+206),
+ SCM_PACK (objcode_cells.cells+208),
+ SCM_PACK (objcode_cells.cells+210),
+ SCM_PACK (objcode_cells.cells+212),
+ SCM_PACK (objcode_cells.cells+214),
+ SCM_PACK (objcode_cells.cells+216),
+ SCM_PACK (objcode_cells.cells+218),
+ SCM_PACK (objcode_cells.cells+220),
+ SCM_PACK (objcode_cells.cells+222),
+ SCM_PACK (objcode_cells.cells+224),
+ SCM_PACK (objcode_cells.cells+226),
+ SCM_PACK (objcode_cells.cells+228),
+ SCM_PACK (objcode_cells.cells+230),
+ SCM_PACK (objcode_cells.cells+232),
+ SCM_PACK (objcode_cells.cells+234),
+ SCM_PACK (objcode_cells.cells+236),
+ SCM_PACK (objcode_cells.cells+238),
+ SCM_PACK (objcode_cells.cells+240)
+};
+
+/* (nargs * nargs) + nopt + rest * (nargs + 1) */
+#define SCM_SUBR_OBJCODE_TRAMPOLINE(nreq,nopt,rest) \
+ scm_subr_objcode_trampolines[(nreq + nopt + rest) * (nreq + nopt + rest) \
+ + nopt + rest * (nreq + nopt + rest + 1)]
+
+SCM
+scm_subr_objcode_trampoline (unsigned int nreq, unsigned int nopt,
+ unsigned int rest)
+{
+ if (SCM_UNLIKELY (rest > 1 || nreq + nopt + rest > 10))
+ scm_out_of_range ("make-subr", scm_from_uint (nreq + nopt + rest));
+
+ return SCM_SUBR_OBJCODE_TRAMPOLINE (nreq, nopt, rest);
+}
static SCM
create_gsubr (int define, const char *name,
- unsigned int req, unsigned int opt, unsigned int rst,
+ unsigned int nreq, unsigned int nopt, unsigned int rest,
SCM (*fcn) (), SCM *generic_loc)
{
- SCM subr;
+ SCM ret;
SCM sname;
- SCM *meta_info;
- unsigned type;
+ SCM table;
+ scm_t_bits flags;
- type = SCM_GSUBR_MAKTYPE (req, opt, rst);
- if (SCM_GSUBR_REQ (type) != req
- || SCM_GSUBR_OPT (type) != opt
- || SCM_GSUBR_REST (type) != rst)
- scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst));
-
- meta_info = scm_gc_malloc (2 * sizeof (*meta_info), "subr meta-info");
+ /* make objtable */
sname = scm_from_locale_symbol (name);
- meta_info[0] = sname;
- meta_info[1] = SCM_EOL; /* properties */
-
- subr = scm_double_cell ((scm_t_bits) scm_tc7_gsubr | (type << 8U),
- (scm_t_bits) fcn,
- (scm_t_bits) generic_loc,
- (scm_t_bits) meta_info);
-
+ table = scm_c_make_vector (generic_loc ? 3 : 2, SCM_UNDEFINED);
+ SCM_SIMPLE_VECTOR_SET (table, 0,
+ scm_c_from_foreign (SCM_FOREIGN_TYPE_POINTER,
+ &fcn, 0, NULL));
+ SCM_SIMPLE_VECTOR_SET (table, 1, sname);
+ if (generic_loc)
+ SCM_SIMPLE_VECTOR_SET (table, 2,
+ scm_c_from_foreign (SCM_FOREIGN_TYPE_POINTER,
+ &generic_loc, 0, NULL));
+
+ /* make program */
+ ret = scm_make_program (scm_subr_objcode_trampoline (nreq, nopt, rest),
+ table, SCM_BOOL_F);
+
+ /* set flags */
+ flags = SCM_F_PROGRAM_IS_PRIMITIVE;
+ flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;
+ SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | flags);
+
+ /* define, if needed */
if (define)
- scm_define (sname, subr);
+ scm_define (sname, ret);
- return subr;
+ /* et voila. */
+ return ret;
}
SCM
@@ -111,184 +853,6 @@ scm_c_define_gsubr_with_generic (const char *name,
return create_gsubr (1, name, req, opt, rst, fcn, gf);
}
-/* Apply PROC, a gsubr, to the ARGC arguments in ARGV. ARGC is expected to
- match the number of arguments of the underlying C function. */
-static SCM
-gsubr_apply_raw (SCM proc, unsigned int argc, const SCM *argv)
-{
- SCM (*fcn) ();
- unsigned int type, argc_max;
-
- type = SCM_GSUBR_TYPE (proc);
- argc_max = SCM_GSUBR_REQ (type) + SCM_GSUBR_OPT (type)
- + SCM_GSUBR_REST (type);
-
- if (SCM_UNLIKELY (argc != argc_max))
- /* We expect the exact argument count. */
- scm_wrong_num_args (SCM_SUBR_NAME (proc));
-
- fcn = SCM_SUBRF (proc);
-
- switch (argc)
- {
- case 0:
- return (*fcn) ();
- case 1:
- return (*fcn) (argv[0]);
- case 2:
- return (*fcn) (argv[0], argv[1]);
- case 3:
- return (*fcn) (argv[0], argv[1], argv[2]);
- case 4:
- return (*fcn) (argv[0], argv[1], argv[2], argv[3]);
- case 5:
- return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4]);
- case 6:
- return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
- case 7:
- return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
- argv[6]);
- case 8:
- return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
- argv[6], argv[7]);
- case 9:
- return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
- argv[6], argv[7], argv[8]);
- case 10:
- return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
- argv[6], argv[7], argv[8], argv[9]);
- default:
- scm_misc_error ((char *) SCM_SUBR_NAME (proc),
- "gsubr invocation with more than 10 arguments not
implemented",
- SCM_EOL);
- }
-
- return SCM_BOOL_F; /* Never reached. */
-}
-
-/* Apply PROC, a gsubr, to the given arguments. Missing optional arguments
- are added, and rest arguments are turned into a list. */
-SCM
-scm_i_gsubr_apply (SCM proc, SCM arg, ...)
-{
- unsigned int type, argc, argc_max;
- SCM *argv;
- va_list arg_list;
-
- type = SCM_GSUBR_TYPE (proc);
- argc_max = SCM_GSUBR_REQ (type) + SCM_GSUBR_OPT (type);
- argv = alloca ((argc_max + SCM_GSUBR_REST (type)) * sizeof (*argv));
-
- va_start (arg_list, arg);
-
- for (argc = 0;
- !SCM_UNBNDP (arg) && argc < argc_max;
- argc++, arg = va_arg (arg_list, SCM))
- argv[argc] = arg;
-
- if (SCM_UNLIKELY (argc < SCM_GSUBR_REQ (type)))
- /* too few args */
- scm_wrong_num_args (SCM_SUBR_NAME (proc));
- if (SCM_UNLIKELY (!SCM_UNBNDP (arg) && !SCM_GSUBR_REST (type)))
- /* too many args */
- scm_wrong_num_args (SCM_SUBR_NAME (proc));
-
- /* Fill in optional arguments that were not passed. */
- while (argc < argc_max)
- argv[argc++] = SCM_UNDEFINED;
-
- if (SCM_GSUBR_REST (type))
- {
- /* Accumulate rest arguments in a list. */
- SCM *rest_loc;
-
- argv[argc_max] = SCM_EOL;
-
- for (rest_loc = &argv[argc_max];
- !SCM_UNBNDP (arg);
- rest_loc = SCM_CDRLOC (*rest_loc), arg = va_arg (arg_list, SCM))
- *rest_loc = scm_cons (arg, SCM_EOL);
-
- argc = argc_max + 1;
- }
-
- va_end (arg_list);
-
- return gsubr_apply_raw (proc, argc, argv);
-}
-
-/* Apply SELF, a gsubr, to the arguments listed in ARGS. Missing optional
- arguments are added, and rest arguments are kept into a list. */
-SCM
-scm_i_gsubr_apply_list (SCM self, SCM args)
-#define FUNC_NAME "scm_i_gsubr_apply"
-{
- SCM v[SCM_GSUBR_MAX];
- unsigned int typ = SCM_GSUBR_TYPE (self);
- long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
-
- for (i = 0; i < SCM_GSUBR_REQ (typ); i++) {
- if (scm_is_null (args))
- scm_wrong_num_args (SCM_SUBR_NAME (self));
- v[i] = SCM_CAR(args);
- args = SCM_CDR(args);
- }
- for (; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++) {
- if (SCM_NIMP (args)) {
- v[i] = SCM_CAR (args);
- args = SCM_CDR(args);
- }
- else
- v[i] = SCM_UNDEFINED;
- }
- if (SCM_GSUBR_REST(typ))
- v[i] = args;
- else if (!scm_is_null (args))
- scm_wrong_num_args (SCM_SUBR_NAME (self));
-
- return gsubr_apply_raw (self, n, v);
-}
-#undef FUNC_NAME
-
-/* Apply SELF, a gsubr, to the arguments in ARGS. Missing optional
- arguments are added, and rest arguments are consed into a list. */
-SCM
-scm_i_gsubr_apply_array (SCM self, SCM *args, int nargs, int headroom)
-#define FUNC_NAME "scm_i_gsubr_apply"
-{
- unsigned int typ = SCM_GSUBR_TYPE (self);
- long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
-
- if (SCM_UNLIKELY (nargs < SCM_GSUBR_REQ (typ)))
- scm_wrong_num_args (SCM_SUBR_NAME (self));
-
- if (SCM_UNLIKELY (headroom < n - nargs))
- {
- /* fallback on apply-list */
- SCM arglist = SCM_EOL;
- while (nargs--)
- arglist = scm_cons (args[nargs], arglist);
- return scm_i_gsubr_apply_list (self, arglist);
- }
-
- for (i = nargs; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++)
- args[i] = SCM_UNDEFINED;
-
- if (SCM_GSUBR_REST(typ))
- {
- SCM rest = SCM_EOL;
- /* fallback on apply-list */
- while (nargs-- >= n)
- rest = scm_cons (args[nargs], rest);
- args[n - 1] = rest;
- }
- else if (nargs > n)
- scm_wrong_num_args (SCM_SUBR_NAME (self));
-
- return gsubr_apply_raw (self, n, args);
-}
-#undef FUNC_NAME
-
#ifdef GSUBR_TEST
/* A silly example, taking 2 required args, 1 optional, and
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index 74a08a2..be83a97 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -3,7 +3,7 @@
#ifndef SCM_GSUBR_H
#define SCM_GSUBR_H
-/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001, 2006, 2008, 2009, 2010 Free
Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -28,42 +28,27 @@
-/* Subrs
- */
-#define SCM_PRIMITIVE_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_gsubr)
-#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PRIMITIVE_P (x) && SCM_SUBR_GENERIC
(x))
+SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq,
+ unsigned int nopt,
+ unsigned int rest);
-#define SCM_SUBR_META_INFO(x) ((SCM *) SCM_CELL_WORD_3 (x))
-#define SCM_SUBR_NAME(x) (SCM_SUBR_META_INFO (x) [0])
-#define SCM_SUBRF(x) ((SCM (*)()) SCM_CELL_WORD_1 (x))
-#define SCM_SUBR_PROPS(x) (SCM_SUBR_META_INFO (x) [1])
-#define SCM_SUBR_GENERIC(x) ((SCM *) SCM_CELL_WORD_2 (x))
-#define SCM_SET_SUBR_GENERIC(x, g) (*((SCM *) SCM_CELL_WORD_2 (x)) = (g))
-#define SCM_SET_SUBR_GENERIC_LOC(x, g) (SCM_SET_CELL_WORD_2 (x, (scm_t_bits)
g))
-/* Return the most suitable subr type for a subr with REQ required arguments,
- OPT optional arguments, and REST (0 or 1) arguments. This has to be in
- sync with `create_gsubr ()'. */
-#define SCM_SUBR_ARITY_TO_TYPE(req, opt, rest) \
- (scm_tc7_gsubr | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))
+/* Subrs
+ */
+#define SCM_PRIMITIVE_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE (x))
+#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PROGRAM_P (x) &&
SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))
-
+#define SCM_SUBRF(x) ((SCM (*)()) (SCM_FOREIGN_OBJECT (SCM_SIMPLE_VECTOR_REF
(SCM_PROGRAM_OBJTABLE (x), 0), void*)))
+#define SCM_SUBR_NAME(x) (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 1))
+#define SCM_SUBR_GENERIC(x) \
+ (SCM_FOREIGN_OBJECT_REF (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x),
2), SCM*))
+#define SCM_SET_SUBR_GENERIC(x, g) \
+ (*SCM_SUBR_GENERIC (x) = (g))
-/* Return an integer describing the arity of GSUBR, a subr of type
- `scm_tc7_gsubr'. The result can be interpreted with `SCM_GSUBR_REQ ()'
- and similar. */
-#define SCM_GSUBR_TYPE(gsubr) (SCM_CELL_TYPE (gsubr) >> 8)
-
-#define SCM_GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8))
-#define SCM_GSUBR_MAX 33
-#define SCM_GSUBR_REQ(x) ((long)(x)&0xf)
-#define SCM_GSUBR_OPT(x) (((long)(x)&0xf0)>>4)
-#define SCM_GSUBR_REST(x) ((long)(x)>>8)
-
SCM_API SCM scm_c_make_gsubr (const char *name,
int req, int opt, int rst, SCM (*fcn) ());
SCM_API SCM scm_c_make_gsubr_with_generic (const char *name,
@@ -75,10 +60,6 @@ SCM_API SCM scm_c_define_gsubr_with_generic (const char
*name,
int req, int opt, int rst,
SCM (*fcn) (), SCM *gf);
-SCM_INTERNAL SCM scm_i_gsubr_apply (SCM proc, SCM arg, ...);
-SCM_INTERNAL SCM scm_i_gsubr_apply_list (SCM proc, SCM args);
-SCM_INTERNAL SCM scm_i_gsubr_apply_array (SCM proc, SCM *args, int nargs,
- int headroom);
SCM_INTERNAL void scm_init_gsubr (void);
#endif /* SCM_GSUBR_H */
diff --git a/libguile/hash.c b/libguile/hash.c
index e56fab0..d2ce575 100644
--- a/libguile/hash.c
+++ b/libguile/hash.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008, 2009
Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008, 2009,
2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -169,8 +169,7 @@ scm_hasher(SCM obj, unsigned long n, size_t d)
else return 1;
case scm_tc7_port:
return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
- /* case scm_tcs_closures: */
- case scm_tc7_gsubr:
+ case scm_tc7_program:
return 262 % n;
}
}
diff --git a/libguile/init.c b/libguile/init.c
index 81db86b..abca490 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -57,6 +57,7 @@
#include "libguile/filesys.h"
#include "libguile/fluids.h"
#include "libguile/fports.h"
+#include "libguile/frames.h"
#include "libguile/gc.h"
#include "libguile/gdbint.h"
#include "libguile/generalized-arrays.h"
@@ -68,6 +69,7 @@
#include "libguile/hooks.h"
#include "libguile/gettext.h"
#include "libguile/i18n.h"
+#include "libguile/instructions.h"
#include "libguile/iselect.h"
#include "libguile/ioext.h"
#include "libguile/keywords.h"
@@ -80,6 +82,7 @@
#include "libguile/modules.h"
#include "libguile/net_db.h"
#include "libguile/numbers.h"
+#include "libguile/objcodes.h"
#include "libguile/objprop.h"
#include "libguile/options.h"
#include "libguile/pairs.h"
@@ -91,6 +94,7 @@
#include "libguile/print.h"
#include "libguile/procprop.h"
#include "libguile/procs.h"
+#include "libguile/programs.h"
#include "libguile/promises.h"
#include "libguile/properties.h"
#include "libguile/array-map.h"
@@ -122,7 +126,7 @@
#include "libguile/variable.h"
#include "libguile/vectors.h"
#include "libguile/version.h"
-#include "libguile/vm-bootstrap.h"
+#include "libguile/vm.h"
#include "libguile/vports.h"
#include "libguile/weaks.h"
#include "libguile/guardians.h"
@@ -443,9 +447,13 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_symbols_prehistory (); /* requires weaks_prehistory */
scm_modules_prehistory ();
scm_init_array_handle ();
- scm_init_generalized_arrays ();
- scm_init_generalized_vectors ();
- scm_init_strings (); /* Requires array-handle,
generalized-vectors */
+ scm_bootstrap_bytevectors (); /* Requires array-handle */
+ scm_bootstrap_instructions ();
+ scm_bootstrap_objcodes ();
+ scm_bootstrap_programs ();
+ scm_bootstrap_vm ();
+
+ scm_init_strings (); /* Requires array-handle */
scm_init_struct (); /* Requires strings */
scm_smob_prehistory ();
scm_init_variable ();
@@ -510,16 +518,15 @@ scm_i_init_guile (SCM_STACKITEM *base)
scm_init_srcprop (); /* requires smob_prehistory */
scm_init_stackchk ();
- scm_init_vectors (); /* Requires array-handle, generalized-vectors */
+ scm_init_generalized_arrays ();
+ scm_init_generalized_vectors ();
+ scm_init_vectors (); /* Requires array-handle, */
scm_init_uniform ();
- scm_init_bitvectors (); /* Requires smob_prehistory, array-handle,
generalized-vectors */
- scm_bootstrap_bytevectors (); /* Requires smob_prehistory, array-handle,
generalized-vectors */
- scm_init_srfi_4 (); /* Requires smob_prehistory, array-handle,
generalized-vectors */
+ scm_init_bitvectors (); /* Requires smob_prehistory, array-handle */
+ scm_init_srfi_4 (); /* Requires smob_prehistory, array-handle */
scm_init_arrays (); /* Requires smob_prehistory, array-handle */
scm_init_array_map ();
- scm_bootstrap_vm (); /* requires smob_prehistory, gc_permanent_object */
-
scm_init_frames (); /* Requires smob_prehistory */
scm_init_stacks (); /* Requires strings, struct, frames */
scm_init_symbols ();
diff --git a/libguile/instructions.c b/libguile/instructions.c
index c8d95cc..4c1f9f1 100644
--- a/libguile/instructions.c
+++ b/libguile/instructions.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -23,7 +23,6 @@
#include <string.h>
#include "_scm.h"
-#include "vm-bootstrap.h"
#include "instructions.h"
struct scm_instruction {
@@ -205,8 +204,6 @@ scm_bootstrap_instructions (void)
void
scm_init_instructions (void)
{
- scm_bootstrap_vm ();
-
#ifndef SCM_MAGIC_SNARFER
#include "libguile/instructions.x"
#endif
diff --git a/libguile/load.c b/libguile/load.c
index 7c2dcfb..abd5b1c 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -908,6 +908,10 @@ scm_init_load ()
scm_fluid_set_x (the_reader, SCM_BOOL_F);
scm_c_define("current-reader", the_reader);
+ scm_c_define ("load-compiled",
+ scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
+ scm_load_compiled_with_vm));
+
init_build_info ();
#include "libguile/load.x"
diff --git a/libguile/objcodes.c b/libguile/objcodes.c
index 87ffaa5..f30d815 100644
--- a/libguile/objcodes.c
+++ b/libguile/objcodes.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -30,7 +30,6 @@
#include <alignof.h>
#include "_scm.h"
-#include "vm-bootstrap.h"
#include "programs.h"
#include "objcodes.h"
@@ -43,8 +42,6 @@ verify (((sizeof (SCM_OBJCODE_COOKIE) - 1) & 7) == 0);
* Objcode type
*/
-scm_t_bits scm_tc16_objcode;
-
static SCM
make_objcode_by_mmap (int fd)
#define FUNC_NAME "make_objcode_by_mmap"
@@ -91,9 +88,10 @@ make_objcode_by_mmap (int fd)
+ data->metalen)));
}
- SCM_NEWSMOB3 (sret, scm_tc16_objcode, addr + strlen (SCM_OBJCODE_COOKIE),
- SCM_PACK (SCM_BOOL_F), fd);
- SCM_SET_SMOB_FLAGS (sret, SCM_F_OBJCODE_IS_MMAP);
+ sret = scm_double_cell (scm_tc7_objcode | (SCM_F_OBJCODE_IS_MMAP<<8),
+ (scm_t_bits)(addr + strlen (SCM_OBJCODE_COOKIE)),
+ SCM_UNPACK (SCM_BOOL_F),
+ (scm_t_bits)fd);
/* FIXME: we leak ourselves and the file descriptor. but then again so does
dlopen(). */
@@ -107,7 +105,6 @@ scm_c_make_objcode_slice (SCM parent, const scm_t_uint8
*ptr)
{
const struct scm_objcode *data, *parent_data;
const scm_t_uint8 *parent_base;
- SCM ret;
SCM_VALIDATE_OBJCODE (1, parent);
parent_data = SCM_OBJCODE_DATA (parent);
@@ -131,9 +128,8 @@ scm_c_make_objcode_slice (SCM parent, const scm_t_uint8
*ptr)
assert (SCM_C_OBJCODE_BASE (data) + data->len + data->metalen
<= parent_base + parent_data->len + parent_data->metalen);
- SCM_NEWSMOB2 (ret, scm_tc16_objcode, data, parent);
- SCM_SET_SMOB_FLAGS (ret, SCM_F_OBJCODE_IS_SLICE);
- return ret;
+ return scm_double_cell (scm_tc7_objcode | (SCM_F_OBJCODE_IS_SLICE<<8),
+ (scm_t_bits)data, SCM_UNPACK (parent), 0);
}
#undef FUNC_NAME
@@ -172,32 +168,27 @@ SCM_DEFINE (scm_bytecode_to_objcode, "bytecode->objcode",
1, 0, 0,
#define FUNC_NAME s_scm_bytecode_to_objcode
{
size_t size;
- ssize_t increment;
- scm_t_array_handle handle;
const scm_t_uint8 *c_bytecode;
struct scm_objcode *data;
- SCM objcode;
- if (scm_is_false (scm_u8vector_p (bytecode)))
+ if (!scm_is_bytevector (bytecode))
scm_wrong_type_arg (FUNC_NAME, 1, bytecode);
- c_bytecode = scm_u8vector_elements (bytecode, &handle, &size, &increment);
+ size = SCM_BYTEVECTOR_LENGTH (bytecode);
+ c_bytecode = (const scm_t_uint8*)SCM_BYTEVECTOR_CONTENTS (bytecode);
+
+ SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
data = (struct scm_objcode*)c_bytecode;
- SCM_NEWSMOB2 (objcode, scm_tc16_objcode, data, bytecode);
- scm_array_handle_release (&handle);
- SCM_ASSERT_RANGE (0, bytecode, size >= sizeof(struct scm_objcode));
if (data->len + data->metalen != (size - sizeof (*data)))
- scm_misc_error (FUNC_NAME, "bad u8vector size (~a != ~a)",
+ scm_misc_error (FUNC_NAME, "bad bytevector size (~a != ~a)",
scm_list_2 (scm_from_size_t (size),
scm_from_uint32 (sizeof (*data) + data->len +
data->metalen)));
- assert (increment == 1);
- SCM_SET_SMOB_FLAGS (objcode, SCM_F_OBJCODE_IS_U8VECTOR);
-
+
/* foolishly, we assume that as long as bytecode is around, that c_bytecode
will be of the same length; perhaps a bad assumption? */
-
- return objcode;
+ return scm_double_cell (scm_tc7_objcode | (SCM_F_OBJCODE_IS_BYTEVECTOR<<8),
+ (scm_t_bits)data, SCM_UNPACK (bytecode), 0);
}
#undef FUNC_NAME
@@ -225,17 +216,17 @@ SCM_DEFINE (scm_objcode_to_bytecode, "objcode->bytecode",
1, 0, 0,
"")
#define FUNC_NAME s_scm_objcode_to_bytecode
{
- scm_t_uint8 *u8vector;
+ scm_t_int8 *s8vector;
scm_t_uint32 len;
SCM_VALIDATE_OBJCODE (1, objcode);
len = sizeof(struct scm_objcode) + SCM_OBJCODE_TOTAL_LEN (objcode);
- u8vector = scm_malloc (len);
- memcpy (u8vector, SCM_OBJCODE_DATA (objcode), len);
+ s8vector = scm_malloc (len);
+ memcpy (s8vector, SCM_OBJCODE_DATA (objcode), len);
- return scm_take_u8vector (u8vector, len);
+ return scm_c_take_bytevector (s8vector, len);
}
#undef FUNC_NAME
@@ -255,11 +246,18 @@ SCM_DEFINE (scm_write_objcode, "write-objcode", 2, 0, 0,
}
#undef FUNC_NAME
+void
+scm_i_objcode_print (SCM objcode, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<objcode ", port);
+ scm_uintprint ((scm_t_bits)SCM_OBJCODE_BASE (objcode), 16, port);
+ scm_puts (">", port);
+}
+
void
scm_bootstrap_objcodes (void)
{
- scm_tc16_objcode = scm_make_smob_type ("objcode", 0);
scm_c_register_extension ("libguile", "scm_init_objcodes",
(scm_t_extension_init_func)scm_init_objcodes,
NULL);
}
@@ -275,8 +273,6 @@ scm_bootstrap_objcodes (void)
void
scm_init_objcodes (void)
{
- scm_bootstrap_vm ();
-
#ifndef SCM_MAGIC_SNARFER
#include "libguile/objcodes.x"
#endif
diff --git a/libguile/objcodes.h b/libguile/objcodes.h
index 4627cfb..2bff9aa 100644
--- a/libguile/objcodes.h
+++ b/libguile/objcodes.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -35,14 +35,13 @@ struct scm_objcode
#define SCM_C_OBJCODE_BASE(obj) \
((scm_t_uint8 *)(obj) + sizeof (struct scm_objcode))
-#define SCM_F_OBJCODE_IS_MMAP (1<<0)
-#define SCM_F_OBJCODE_IS_U8VECTOR (1<<1)
-#define SCM_F_OBJCODE_IS_SLICE (1<<2)
+#define SCM_F_OBJCODE_IS_MMAP (1<<0)
+#define SCM_F_OBJCODE_IS_BYTEVECTOR (1<<1)
+#define SCM_F_OBJCODE_IS_SLICE (1<<2)
+#define SCM_F_OBJCODE_IS_STATIC (1<<3)
-SCM_API scm_t_bits scm_tc16_objcode;
-
-#define SCM_OBJCODE_P(x) (SCM_SMOB_PREDICATE (scm_tc16_objcode, x))
-#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_SMOB_DATA (x))
+#define SCM_OBJCODE_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) ==
scm_tc7_objcode)
+#define SCM_OBJCODE_DATA(x) ((struct scm_objcode *) SCM_CELL_WORD_1 (x))
#define SCM_VALIDATE_OBJCODE(p,x) SCM_MAKE_VALIDATE (p, x, OBJCODE_P)
#define SCM_OBJCODE_LEN(x) (SCM_OBJCODE_DATA (x)->len)
@@ -50,9 +49,10 @@ SCM_API scm_t_bits scm_tc16_objcode;
#define SCM_OBJCODE_TOTAL_LEN(x) (SCM_OBJCODE_LEN (x) + SCM_OBJCODE_META_LEN
(x))
#define SCM_OBJCODE_BASE(x) (SCM_C_OBJCODE_BASE (SCM_OBJCODE_DATA (x)))
-#define SCM_OBJCODE_IS_MMAP(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)
-#define SCM_OBJCODE_IS_U8VECTOR(x) (SCM_SMOB_FLAGS (x) &
SCM_F_OBJCODE_IS_U8VECTOR)
-#define SCM_OBJCODE_IS_SLICE(x) (SCM_SMOB_FLAGS (x) & SCM_F_OBJCODE_IS_SLICE)
+#define SCM_OBJCODE_FLAGS(x) (SCM_CELL_WORD_0 (x) >> 8)
+#define SCM_OBJCODE_IS_MMAP(x) (SCM_OBJCODE_FLAGS (x) & SCM_F_OBJCODE_IS_MMAP)
+#define SCM_OBJCODE_IS_BYTEVECTOR(x) (SCM_OBJCODE_FLAGS (x) &
SCM_F_OBJCODE_IS_BYTEVECTOR)
+#define SCM_OBJCODE_IS_SLICE(x) (SCM_OBJCODE_FLAGS (x) &
SCM_F_OBJCODE_IS_SLICE)
SCM scm_c_make_objcode_slice (SCM parent, const scm_t_uint8 *ptr);
SCM_API SCM scm_load_objcode (SCM file);
@@ -62,6 +62,8 @@ SCM_API SCM scm_bytecode_to_objcode (SCM bytecode);
SCM_API SCM scm_objcode_to_bytecode (SCM objcode);
SCM_API SCM scm_write_objcode (SCM objcode, SCM port);
+SCM_INTERNAL void scm_i_objcode_print (SCM objcode, SCM port,
+ scm_print_state *pstate);
SCM_INTERNAL void scm_bootstrap_objcodes (void);
SCM_INTERNAL void scm_init_objcodes (void);
diff --git a/libguile/print.c b/libguile/print.c
index 6e3d1f4..aef575d 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -45,6 +45,7 @@
#include "libguile/vectors.h"
#include "libguile/lang.h"
#include "libguile/numbers.h"
+#include "libguile/vm.h"
#include "libguile/validate.h"
#include "libguile/print.h"
@@ -720,6 +721,18 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
case scm_tc7_dynamic_state:
scm_i_dynamic_state_print (exp, port, pstate);
break;
+ case scm_tc7_frame:
+ scm_i_frame_print (exp, port, pstate);
+ break;
+ case scm_tc7_objcode:
+ scm_i_objcode_print (exp, port, pstate);
+ break;
+ case scm_tc7_vm:
+ scm_i_vm_print (exp, port, pstate);
+ break;
+ case scm_tc7_vm_cont:
+ scm_i_vm_cont_print (exp, port, pstate);
+ break;
case scm_tc7_wvect:
ENTER_NESTED_DATA (pstate, exp, circref);
if (SCM_IS_WHVEC (exp))
@@ -776,17 +789,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
}
EXIT_NESTED_DATA (pstate);
break;
- case scm_tc7_gsubr:
- {
- SCM name = scm_symbol_to_string (SCM_SUBR_NAME (exp));
- scm_puts (SCM_SUBR_GENERIC (exp)
- ? "#<primitive-generic "
- : "#<primitive-procedure ",
- port);
- scm_lfwrite_str (name, port);
- scm_putc ('>', port);
- break;
- }
case scm_tc7_port:
{
register long i = SCM_PTOBNUM (exp);
diff --git a/libguile/procprop.c b/libguile/procprop.c
index 7cfd2e6..641defc 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,2000,2001,2003,2004, 2006, 2008, 2009, 2010
Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -40,6 +40,7 @@
SCM_GLOBAL_SYMBOL (scm_sym_system_procedure, "system-procedure");
SCM_GLOBAL_SYMBOL (scm_sym_arity, "arity");
+SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
static SCM props;
static scm_i_pthread_mutex_t props_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
@@ -55,24 +56,7 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int
*rest)
case scm_tc7_program:
return scm_i_program_arity (proc, req, opt, rest);
case scm_tc7_smob:
- if (SCM_SMOB_APPLICABLE_P (proc))
- {
- int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type;
- *req = SCM_GSUBR_REQ (type);
- *opt = SCM_GSUBR_OPT (type);
- *rest = SCM_GSUBR_REST (type);
- return 1;
- }
- else
- return 0;
- case scm_tc7_gsubr:
- {
- unsigned int type = SCM_GSUBR_TYPE (proc);
- *req = SCM_GSUBR_REQ (type);
- *opt = SCM_GSUBR_OPT (type);
- *rest = SCM_GSUBR_REST (type);
- return 1;
- }
+ return scm_i_smob_arity (proc, req, opt, rest);
case scm_tcs_struct:
if (!SCM_STRUCT_APPLICABLE_P (proc))
return 0;
diff --git a/libguile/procs.c b/libguile/procs.c
index e940378..10ae885 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -53,7 +53,6 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
if (!((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC)
|| SCM_STRUCT_APPLICABLE_P (obj)))
break;
- case scm_tc7_gsubr:
case scm_tc7_program:
return SCM_BOOL_T;
case scm_tc7_smob:
@@ -125,14 +124,7 @@ SCM_DEFINE (scm_make_procedure_with_setter,
"make-procedure-with-setter", 2, 0,
/* don't use procedure_name, because don't care enough to do a reverse
lookup */
- switch (SCM_TYP7 (procedure)) {
- case scm_tc7_gsubr:
- name = SCM_SUBR_NAME (procedure);
- break;
- default:
- name = scm_procedure_property (procedure, scm_sym_name);
- break;
- }
+ name = scm_procedure_property (procedure, scm_sym_name);
if (scm_is_true (name))
scm_set_procedure_property_x (ret, scm_sym_name, name);
return ret;
diff --git a/libguile/programs.c b/libguile/programs.c
index fdc0c32..d5b3b1a 100644
--- a/libguile/programs.c
+++ b/libguile/programs.c
@@ -22,7 +22,6 @@
#include <string.h>
#include "_scm.h"
-#include "vm-bootstrap.h"
#include "instructions.h"
#include "modules.h"
#include "programs.h"
@@ -338,8 +337,6 @@ scm_bootstrap_programs (void)
void
scm_init_programs (void)
{
- scm_bootstrap_vm ();
-
#ifndef SCM_MAGIC_SNARFER
#include "libguile/programs.x"
#endif
diff --git a/libguile/programs.h b/libguile/programs.h
index 0ae5bfe..61b76a9 100644
--- a/libguile/programs.h
+++ b/libguile/programs.h
@@ -27,6 +27,7 @@
*/
#define SCM_F_PROGRAM_IS_BOOT 0x100
+#define SCM_F_PROGRAM_IS_PRIMITIVE 0x100
#define SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC 0x200
#define SCM_PROGRAM_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_program)
@@ -36,6 +37,7 @@
#define SCM_PROGRAM_DATA(x) (SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x)))
#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
#define SCM_PROGRAM_IS_BOOT(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_BOOT)
+#define SCM_PROGRAM_IS_PRIMITIVE(x) (SCM_CELL_WORD_0 (x) &
SCM_F_PROGRAM_IS_PRIMITIVE)
#define SCM_PROGRAM_IS_PRIMITIVE_GENERIC(x) (SCM_CELL_WORD_0 (x) &
SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC)
SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables);
diff --git a/libguile/smob.c b/libguile/smob.c
index d96a043..037164b 100644
--- a/libguile/smob.c
+++ b/libguile/smob.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010
Free Software Foundation, 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,6 +17,13 @@
*/
+#define SCM_GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8))
+#define SCM_GSUBR_MAX 33
+#define SCM_GSUBR_REQ(x) ((long)(x)&0xf)
+#define SCM_GSUBR_OPT(x) (((long)(x)&0xf0)>>4)
+#define SCM_GSUBR_REST(x) ((long)(x)>>8)
+
+
#ifdef HAVE_CONFIG_H
# include <config.h>
@@ -586,6 +593,21 @@ scm_i_finalize_smob (GC_PTR ptr, GC_PTR data)
free_smob (smob);
}
+int
+scm_i_smob_arity (SCM proc, int *req, int *opt, int *rest)
+{
+ if (SCM_SMOB_APPLICABLE_P (proc))
+ {
+ int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type;
+ *req = SCM_GSUBR_REQ (type);
+ *opt = SCM_GSUBR_OPT (type);
+ *rest = SCM_GSUBR_REST (type);
+ return 1;
+ }
+ else
+ return 0;
+}
+
void
scm_smob_prehistory ()
diff --git a/libguile/smob.h b/libguile/smob.h
index f9b5110..a79c39c 100644
--- a/libguile/smob.h
+++ b/libguile/smob.h
@@ -3,7 +3,7 @@
#ifndef SCM_SMOB_H
#define SCM_SMOB_H
-/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2009, 2010 Free
Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -217,6 +217,8 @@ SCM_API void scm_assert_smob_type (scm_t_bits tag, SCM val);
SCM_API SCM scm_make_smob (scm_t_bits tc);
+SCM_INTERNAL int scm_i_smob_arity (SCM proc, int *req, int *opt, int *rest);
+
SCM_API void scm_smob_prehistory (void);
#endif /* SCM_SMOB_H */
diff --git a/libguile/snarf.h b/libguile/snarf.h
index a00f5b7..717c953 100644
--- a/libguile/snarf.h
+++ b/libguile/snarf.h
@@ -99,22 +99,37 @@ SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ,
OPT, VAR, DOCSTRING)
#ifdef SCM_SUPPORT_STATIC_ALLOCATION
/* Static subr allocation. */
+/* FIXME: how to verify that req + opt + rest < 11, all are positive, etc? */
#define SCM_DEFINE(FNAME, PRIMNAME, REQ, OPT, VAR, ARGLIST, DOCSTRING) \
SCM_SYMBOL (scm_i_paste (FNAME, __name), PRIMNAME); \
-SCM_SNARF_HERE( \
+SCM_SNARF_HERE(
\
static const char scm_i_paste (s_, FNAME) [] = PRIMNAME; \
SCM_API SCM FNAME ARGLIST; \
- SCM_IMMUTABLE_SUBR (scm_i_paste (FNAME, __subr), \
- scm_i_paste (FNAME, __name), \
- REQ, OPT, VAR, &FNAME); \
+ static const scm_t_bits scm_i_paste (FNAME, __subr_ptr) = \
+ (scm_t_bits) &FNAME; /* the subr */ \
+ SCM_IMMUTABLE_FOREIGN (scm_i_paste (FNAME, __subr_foreign), \
+ scm_i_paste (FNAME, __subr_ptr)); \
+ SCM_STATIC_SUBR_OBJVECT (scm_i_paste (FNAME, __raw_objtable), \
+ /* FIXME: directly be the foreign */ \
+ SCM_BOOL_F); \
+ /* FIXME: be immutable. grr */ \
+ SCM_STATIC_PROGRAM (scm_i_paste (FNAME, __subr), \
+ SCM_BOOL_F, \
+ SCM_PACK (&scm_i_paste (FNAME, __raw_objtable)), \
+ SCM_BOOL_F); \
SCM FNAME ARGLIST \
) \
SCM_SNARF_INIT( \
+ /* Initialize the foreign. */ \
+ scm_i_paste (FNAME, __raw_objtable)[2] = scm_i_paste (FNAME,
__subr_foreign); \
/* Initialize the procedure name (an interned symbol). */ \
- scm_i_paste (FNAME, __subr_meta_info)[0] = scm_i_paste (FNAME, __name); \
+ scm_i_paste (FNAME, __raw_objtable)[3] = scm_i_paste (FNAME, __name); \
+ /* Initialize the objcode trampoline. */ \
+ SCM_SET_CELL_OBJECT (scm_i_paste (FNAME, __subr), 1, \
+ scm_subr_objcode_trampoline (REQ, OPT, VAR)); \
\
/* Define the subr. */ \
- scm_c_define (scm_i_paste (s_, FNAME), scm_i_paste (FNAME, __subr)); \
+ scm_define (scm_i_paste (FNAME, __name), scm_i_paste (FNAME, __subr)); \
) \
SCM_SNARF_DOCS(primitive, FNAME, PRIMNAME, ARGLIST, REQ, OPT, VAR, DOCSTRING)
@@ -297,6 +312,15 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req),
(opt), (rest));)
#ifdef SCM_SUPPORT_STATIC_ALLOCATION
+#define SCM_IMMUTABLE_CELL(c_name, car, cdr) \
+ static SCM_ALIGNED (8) SCM_UNUSED const scm_t_cell \
+ c_name ## _raw_scell = \
+ { \
+ SCM_PACK (car), \
+ SCM_PACK (cdr) \
+ }; \
+ static SCM_UNUSED const SCM c_name = SCM_PACK (& c_name ## _raw_scell)
+
#define SCM_IMMUTABLE_DOUBLE_CELL(c_name, car, cbr, ccr, cdr) \
static SCM_ALIGNED (8) SCM_UNUSED const scm_t_cell \
c_name ## _raw_cell [2] = \
@@ -306,6 +330,15 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req),
(opt), (rest));)
}; \
static SCM_UNUSED const SCM c_name = SCM_PACK (& c_name ## _raw_cell)
+#define SCM_STATIC_DOUBLE_CELL(c_name, car, cbr, ccr, cdr) \
+ static SCM_ALIGNED (8) SCM_UNUSED scm_t_cell \
+ c_name ## _raw_cell [2] = \
+ { \
+ { SCM_PACK (car), SCM_PACK (cbr) }, \
+ { SCM_PACK (ccr), SCM_PACK (cdr) } \
+ }; \
+ static SCM_UNUSED SCM c_name = SCM_PACK (& c_name ## _raw_cell)
+
#define SCM_IMMUTABLE_STRINGBUF(c_name, contents) \
static SCM_UNUSED const \
struct \
@@ -330,17 +363,27 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req),
(opt), (rest));)
(scm_t_bits) 0, \
(scm_t_bits) sizeof (contents) - 1)
-#define SCM_IMMUTABLE_SUBR(c_name, name, req, opt, rest, fcn) \
- static SCM_UNUSED SCM scm_i_paste (c_name, _meta_info)[2] = \
- { \
- SCM_BOOL_F, /* The name, initialized at run-time. */ \
- SCM_EOL /* The procedure properties. */ \
- }; \
- SCM_IMMUTABLE_DOUBLE_CELL (c_name, \
- SCM_SUBR_ARITY_TO_TYPE (req, opt, rest), \
- (scm_t_bits) fcn, \
- (scm_t_bits) 0 /* no generic */, \
- (scm_t_bits) & scm_i_paste (c_name, _meta_info));
+#define SCM_IMMUTABLE_FOREIGN(c_name, loc) \
+ SCM_IMMUTABLE_CELL (c_name, \
+ scm_tc7_foreign | (SCM_FOREIGN_TYPE_POINTER << 8), \
+ &loc)
+
+/* for primitive-generics, add a foreign to the end */
+#define SCM_STATIC_SUBR_OBJVECT(c_name, foreign) \
+ static SCM_ALIGNED (8) SCM c_name[4] = \
+ { \
+ SCM_PACK (scm_tc7_vector | (2 << 8)), \
+ SCM_PACK (0), \
+ foreign, \
+ SCM_BOOL_F, /* the name */ \
+ }; \
+
+#define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars) \
+ SCM_STATIC_DOUBLE_CELL (c_name, \
+ scm_tc7_program | (SCM_F_PROGRAM_IS_PRIMITIVE<<8), \
+ (scm_t_bits) objcode, \
+ (scm_t_bits) objtable, \
+ (scm_t_bits) freevars)
#endif /* SCM_SUPPORT_STATIC_ALLOCATION */
diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c
index 7388619..b807046 100644
--- a/libguile/srfi-4.c
+++ b/libguile/srfi-4.c
@@ -1,6 +1,6 @@
/* srfi-4.c --- Uniform numeric vector datatypes.
*
- * Copyright (C) 2001, 2004, 2006, 2009 Free Software Foundation, Inc.
+ * Copyright (C) 2001, 2004, 2006, 2009, 2010 Free Software Foundation,
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,809 +22,199 @@
# include <config.h>
#endif
-#include <string.h>
-#include <errno.h>
-#include <stdio.h>
-
#include "libguile/_scm.h"
#include "libguile/__scm.h"
#include "libguile/bdw-gc.h"
#include "libguile/srfi-4.h"
-#include "libguile/bitvectors.h"
#include "libguile/bytevectors.h"
-#include "libguile/generalized-vectors.h"
-#include "libguile/uniform.h"
#include "libguile/error.h"
#include "libguile/eval.h"
-#include "libguile/read.h"
-#include "libguile/ports.h"
-#include "libguile/chars.h"
-#include "libguile/vectors.h"
-#include "libguile/arrays.h"
-#include "libguile/strings.h"
-#include "libguile/strports.h"
-#include "libguile/dynwind.h"
-#include "libguile/deprecation.h"
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
+#include "libguile/extensions.h"
+#include "libguile/uniform.h"
+#include "libguile/generalized-vectors.h"
+#include "libguile/validate.h"
-#ifdef HAVE_IO_H
-#include <io.h>
-#endif
-/* Smob type code for uniform numeric vectors. */
-int scm_tc16_uvec = 0;
-
-#define SCM_IS_UVEC(obj) SCM_SMOB_PREDICATE (scm_tc16_uvec, (obj))
-
-/* Accessor macros for the three components of a uniform numeric
- vector:
- - The type tag (one of the symbolic constants below).
- - The vector's length (counted in elements).
- - The address of the data area (holding the elements of the
- vector). */
-#define SCM_UVEC_TYPE(u) (SCM_SMOB_DATA_1(u))
-#define SCM_UVEC_LENGTH(u) ((size_t)SCM_SMOB_DATA_2(u))
-#define SCM_UVEC_BASE(u) ((void *)SCM_SMOB_DATA_3(u))
-
-
-/* Symbolic constants encoding the various types of uniform
- numeric vectors. */
-#define SCM_UVEC_U8 0
-#define SCM_UVEC_S8 1
-#define SCM_UVEC_U16 2
-#define SCM_UVEC_S16 3
-#define SCM_UVEC_U32 4
-#define SCM_UVEC_S32 5
-#define SCM_UVEC_U64 6
-#define SCM_UVEC_S64 7
-#define SCM_UVEC_F32 8
-#define SCM_UVEC_F64 9
-#define SCM_UVEC_C32 10
-#define SCM_UVEC_C64 11
-
-
-/* This array maps type tags to the size of the elements. */
-static const int uvec_sizes[12] = {
- 1, 1,
- 2, 2,
- 4, 4,
-#if SCM_HAVE_T_INT64
- 8, 8,
-#else
- sizeof (SCM), sizeof (SCM),
-#endif
- sizeof(float), sizeof(double),
- 2*sizeof(float), 2*sizeof(double)
-};
-
-static const char *uvec_tags[12] = {
- "u8", "s8",
- "u16", "s16",
- "u32", "s32",
- "u64", "s64",
- "f32", "f64",
- "c32", "c64",
-};
-
-static const char *uvec_names[12] = {
- "u8vector", "s8vector",
- "u16vector", "s16vector",
- "u32vector", "s32vector",
- "u64vector", "s64vector",
- "f32vector", "f64vector",
- "c32vector", "c64vector"
-};
-
-/* ================================================================ */
-/* SMOB procedures. */
-/* ================================================================ */
-
-
-/* Smob print hook for uniform vectors. */
-static int
-uvec_print (SCM uvec, SCM port, scm_print_state *pstate)
-{
- union {
- scm_t_uint8 *u8;
- scm_t_int8 *s8;
- scm_t_uint16 *u16;
- scm_t_int16 *s16;
- scm_t_uint32 *u32;
- scm_t_int32 *s32;
-#if SCM_HAVE_T_INT64
- scm_t_uint64 *u64;
- scm_t_int64 *s64;
-#endif
- float *f32;
- double *f64;
- SCM *fake_64;
- } np;
-
- size_t i = 0;
- const size_t uvlen = SCM_UVEC_LENGTH (uvec);
- void *uptr = SCM_UVEC_BASE (uvec);
-
- switch (SCM_UVEC_TYPE (uvec))
- {
- case SCM_UVEC_U8: np.u8 = (scm_t_uint8 *) uptr; break;
- case SCM_UVEC_S8: np.s8 = (scm_t_int8 *) uptr; break;
- case SCM_UVEC_U16: np.u16 = (scm_t_uint16 *) uptr; break;
- case SCM_UVEC_S16: np.s16 = (scm_t_int16 *) uptr; break;
- case SCM_UVEC_U32: np.u32 = (scm_t_uint32 *) uptr; break;
- case SCM_UVEC_S32: np.s32 = (scm_t_int32 *) uptr; break;
-#if SCM_HAVE_T_INT64
- case SCM_UVEC_U64: np.u64 = (scm_t_uint64 *) uptr; break;
- case SCM_UVEC_S64: np.s64 = (scm_t_int64 *) uptr; break;
-#else
- case SCM_UVEC_U64:
- case SCM_UVEC_S64: np.fake_64 = (SCM *) uptr; break;
-#endif
- case SCM_UVEC_F32: np.f32 = (float *) uptr; break;
- case SCM_UVEC_F64: np.f64 = (double *) uptr; break;
- case SCM_UVEC_C32: np.f32 = (float *) uptr; break;
- case SCM_UVEC_C64: np.f64 = (double *) uptr; break;
- default:
- abort (); /* Sanity check. */
- break;
+#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); \
}
- scm_putc ('#', port);
- scm_puts (uvec_tags [SCM_UVEC_TYPE (uvec)], port);
- scm_putc ('(', port);
-
- while (i < uvlen)
- {
- if (i != 0) scm_puts (" ", port);
- switch (SCM_UVEC_TYPE (uvec))
- {
- case SCM_UVEC_U8: scm_uintprint (*np.u8, 10, port); np.u8++; break;
- case SCM_UVEC_S8: scm_intprint (*np.s8, 10, port); np.s8++; break;
- case SCM_UVEC_U16: scm_uintprint (*np.u16, 10, port); np.u16++; break;
- case SCM_UVEC_S16: scm_intprint (*np.s16, 10, port); np.s16++; break;
- case SCM_UVEC_U32: scm_uintprint (*np.u32, 10, port); np.u32++; break;
- case SCM_UVEC_S32: scm_intprint (*np.s32, 10, port); np.s32++; break;
-#if SCM_HAVE_T_INT64
- case SCM_UVEC_U64: scm_uintprint (*np.u64, 10, port); np.u64++; break;
- case SCM_UVEC_S64: scm_intprint (*np.s64, 10, port); np.s64++; break;
-#else
- case SCM_UVEC_U64:
- case SCM_UVEC_S64: scm_iprin1 (*np.fake_64, port, pstate);
- np.fake_64++; break;
-#endif
- case SCM_UVEC_F32: scm_i_print_double (*np.f32, port); np.f32++; break;
- case SCM_UVEC_F64: scm_i_print_double (*np.f64, port); np.f64++; break;
- case SCM_UVEC_C32:
- scm_i_print_complex (np.f32[0], np.f32[1], port);
- np.f32 += 2;
- break;
- case SCM_UVEC_C64:
- scm_i_print_complex (np.f64[0], np.f64[1], port);
- np.f64 += 2;
- break;
- default:
- abort (); /* Sanity check. */
- break;
- }
- i++;
- }
- scm_remember_upto_here_1 (uvec);
- scm_puts (")", port);
- return 1;
-}
-
-const char *
-scm_i_uniform_vector_tag (SCM uvec)
-{
- return uvec_tags[SCM_UVEC_TYPE (uvec)];
-}
-
-static SCM
-uvec_equalp (SCM a, SCM b)
-{
- SCM result = SCM_BOOL_T;
- if (SCM_UVEC_TYPE (a) != SCM_UVEC_TYPE (b))
- result = SCM_BOOL_F;
- else if (SCM_UVEC_LENGTH (a) != SCM_UVEC_LENGTH (b))
- result = SCM_BOOL_F;
-#if SCM_HAVE_T_INT64 == 0
- else if (SCM_UVEC_TYPE (a) == SCM_UVEC_U64
- || SCM_UVEC_TYPE (a) == SCM_UVEC_S64)
- {
- SCM *aptr = (SCM *)SCM_UVEC_BASE (a), *bptr = (SCM *)SCM_UVEC_BASE (b);
- size_t len = SCM_UVEC_LENGTH (a), i;
- for (i = 0; i < len; i++)
- if (scm_is_false (scm_num_eq_p (*aptr++, *bptr++)))
- {
- result = SCM_BOOL_F;
- break;
- }
- }
-#endif
- else if (memcmp (SCM_UVEC_BASE (a), SCM_UVEC_BASE (b),
- SCM_UVEC_LENGTH (a) * uvec_sizes[SCM_UVEC_TYPE(a)]) != 0)
- result = SCM_BOOL_F;
-
- scm_remember_upto_here_2 (a, b);
- return result;
-}
-
-
-/* ================================================================ */
-/* Utility procedures. */
-/* ================================================================ */
-
-static SCM_C_INLINE_KEYWORD int
-is_uvec (int type, SCM obj)
-{
- if (SCM_IS_UVEC (obj))
- return SCM_UVEC_TYPE (obj) == type;
- if (SCM_I_ARRAYP (obj) && SCM_I_ARRAY_NDIM (obj) == 1)
- {
- SCM v = SCM_I_ARRAY_V (obj);
- return SCM_IS_UVEC (v) && SCM_UVEC_TYPE (v) == type;
- }
- return 0;
-}
+#define DEFINE_SCHEME_PROXY001(cname, modname, scmname) \
+ SCM cname (SCM args) \
+ { \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
+ return scm_apply_0 (SCM_VARIABLE_REF (var), args); \
+ }
-static SCM_C_INLINE_KEYWORD SCM
-uvec_p (int type, SCM obj)
-{
- return scm_from_bool (is_uvec (type, obj));
-}
+#define DEFINE_SCHEME_PROXY110(cname, modname, scmname) \
+ SCM cname (SCM arg1, SCM opt1) \
+ { \
+ static SCM var = SCM_BOOL_F; \
+ if (scm_is_false (var)) \
+ var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
+ if (SCM_UNBNDP (opt1)) \
+ return scm_call_1 (SCM_VARIABLE_REF (var), arg1); \
+ else \
+ return scm_call_2 (SCM_VARIABLE_REF (var), arg1, opt1); \
+ }
-static SCM_C_INLINE_KEYWORD void
-uvec_assert (int type, SCM obj)
-{
- if (!is_uvec (type, obj))
- scm_wrong_type_arg_msg (NULL, 0, obj, uvec_names[type]);
-}
+#define DEFINE_SCHEME_PROXY200(cname, modname, scmname) \
+ SCM cname (SCM arg1, SCM arg2) \
+ { \
+ 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_2 (SCM_VARIABLE_REF (var), arg1, arg2); \
+ }
-/* Invoke free(3) on DATA, a user-provided buffer passed to one of the
- `scm_take_' functions. */
-static void
-free_user_data (GC_PTR data, GC_PTR unused)
-{
- free (data);
-}
+#define DEFINE_SCHEME_PROXY300(cname, modname, scmname) \
+ SCM cname (SCM arg1, SCM arg2, SCM arg3) \
+ { \
+ 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_3 (SCM_VARIABLE_REF (var), arg1, arg2, arg3); \
+ }
-static SCM
-take_uvec (int type, void *base, size_t len)
-{
- SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, (scm_t_bits) base);
-}
+#define DEFPROXY100(cname, scmname) \
+ DEFINE_SCHEME_PROXY100 (cname, MOD, scmname)
+#define DEFPROXY110(cname, scmname) \
+ DEFINE_SCHEME_PROXY110 (cname, MOD, scmname)
+#define DEFPROXY001(cname, scmname) \
+ DEFINE_SCHEME_PROXY001 (cname, MOD, scmname)
+#define DEFPROXY200(cname, scmname) \
+ DEFINE_SCHEME_PROXY200 (cname, MOD, scmname)
+#define DEFPROXY300(cname, scmname) \
+ DEFINE_SCHEME_PROXY300 (cname, MOD, scmname)
+
+#define DEFVECT(sym, str, func)\
+
+#define DEFINE_SRFI_4_PROXIES(tag) \
+ DEFPROXY100 (scm_##tag##vector_p, #tag "vector?"); \
+ DEFPROXY110 (scm_make_##tag##vector, "make-" #tag "vector"); \
+ DEFPROXY001 (scm_##tag##vector, #tag "vector"); \
+ DEFPROXY100 (scm_##tag##vector_length, #tag "vector-length"); \
+ DEFPROXY200 (scm_##tag##vector_ref, #tag "vector-ref"); \
+ DEFPROXY300 (scm_##tag##vector_set_x, #tag "vector-set!"); \
+ DEFPROXY100 (scm_list_to_##tag##vector, "list->"#tag "vector"); \
+ DEFPROXY100 (scm_##tag##vector_to_list, #tag "vector->list"); \
-/* Create a new, uninitialized uniform numeric vector of type TYPE
- with space for LEN elements. */
-static SCM
-alloc_uvec (int type, size_t len)
-{
- void *base;
- if (len > SCM_I_SIZE_MAX / uvec_sizes[type])
- scm_out_of_range (NULL, scm_from_size_t (len));
- base = scm_gc_malloc (len * uvec_sizes[type], uvec_names[type]);
-#if SCM_HAVE_T_INT64 == 0
- if (type == SCM_UVEC_U64 || type == SCM_UVEC_S64)
- {
- SCM *ptr = (SCM *)base;
- size_t i;
- for (i = 0; i < len; i++)
- *ptr++ = SCM_UNSPECIFIED;
- }
-#endif
- return take_uvec (type, base, len);
-}
-
-/* GCC doesn't seem to want to optimize unused switch clauses away,
- so we use a big 'if' in the next two functions.
-*/
-
-static SCM_C_INLINE_KEYWORD SCM
-uvec_fast_ref (int type, const void *base, size_t c_idx)
-{
- if (type == SCM_UVEC_U8)
- return scm_from_uint8 (((scm_t_uint8*)base)[c_idx]);
- else if (type == SCM_UVEC_S8)
- return scm_from_int8 (((scm_t_int8*)base)[c_idx]);
- else if (type == SCM_UVEC_U16)
- return scm_from_uint16 (((scm_t_uint16*)base)[c_idx]);
- else if (type == SCM_UVEC_S16)
- return scm_from_int16 (((scm_t_int16*)base)[c_idx]);
- else if (type == SCM_UVEC_U32)
- return scm_from_uint32 (((scm_t_uint32*)base)[c_idx]);
- else if (type == SCM_UVEC_S32)
- return scm_from_int32 (((scm_t_int32*)base)[c_idx]);
-#if SCM_HAVE_T_INT64
- else if (type == SCM_UVEC_U64)
- return scm_from_uint64 (((scm_t_uint64*)base)[c_idx]);
- else if (type == SCM_UVEC_S64)
- return scm_from_int64 (((scm_t_int64*)base)[c_idx]);
-#else
- else if (type == SCM_UVEC_U64)
- return ((SCM *)base)[c_idx];
- else if (type == SCM_UVEC_S64)
- return ((SCM *)base)[c_idx];
-#endif
- else if (type == SCM_UVEC_F32)
- return scm_from_double (((float*)base)[c_idx]);
- else if (type == SCM_UVEC_F64)
- return scm_from_double (((double*)base)[c_idx]);
- else if (type == SCM_UVEC_C32)
- return scm_c_make_rectangular (((float*)base)[2*c_idx],
- ((float*)base)[2*c_idx+1]);
- else if (type == SCM_UVEC_C64)
- return scm_c_make_rectangular (((double*)base)[2*c_idx],
- ((double*)base)[2*c_idx+1]);
- else
- return SCM_BOOL_F;
-}
-
-#if SCM_HAVE_T_INT64 == 0
-static SCM scm_uint64_min, scm_uint64_max;
-static SCM scm_int64_min, scm_int64_max;
-
-static void
-assert_exact_integer_range (SCM val, SCM min, SCM max)
-{
- if (!scm_is_integer (val)
- || scm_is_false (scm_exact_p (val)))
- scm_wrong_type_arg_msg (NULL, 0, val, "exact integer");
- if (scm_is_true (scm_less_p (val, min))
- || scm_is_true (scm_gr_p (val, max)))
- scm_out_of_range (NULL, val);
-}
-#endif
-
-static SCM_C_INLINE_KEYWORD void
-uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val)
-{
- if (type == SCM_UVEC_U8)
- (((scm_t_uint8*)base)[c_idx]) = scm_to_uint8 (val);
- else if (type == SCM_UVEC_S8)
- (((scm_t_int8*)base)[c_idx]) = scm_to_int8 (val);
- else if (type == SCM_UVEC_U16)
- (((scm_t_uint16*)base)[c_idx]) = scm_to_uint16 (val);
- else if (type == SCM_UVEC_S16)
- (((scm_t_int16*)base)[c_idx]) = scm_to_int16 (val);
- else if (type == SCM_UVEC_U32)
- (((scm_t_uint32*)base)[c_idx]) = scm_to_uint32 (val);
- else if (type == SCM_UVEC_S32)
- (((scm_t_int32*)base)[c_idx]) = scm_to_int32 (val);
-#if SCM_HAVE_T_INT64
- else if (type == SCM_UVEC_U64)
- (((scm_t_uint64*)base)[c_idx]) = scm_to_uint64 (val);
- else if (type == SCM_UVEC_S64)
- (((scm_t_int64*)base)[c_idx]) = scm_to_int64 (val);
-#else
- else if (type == SCM_UVEC_U64)
- {
- assert_exact_integer_range (val, scm_uint64_min, scm_uint64_max);
- ((SCM *)base)[c_idx] = val;
- }
- else if (type == SCM_UVEC_S64)
- {
- assert_exact_integer_range (val, scm_int64_min, scm_int64_max);
- ((SCM *)base)[c_idx] = val;
- }
-#endif
- else if (type == SCM_UVEC_F32)
- (((float*)base)[c_idx]) = scm_to_double (val);
- else if (type == SCM_UVEC_F64)
- (((double*)base)[c_idx]) = scm_to_double (val);
- else if (type == SCM_UVEC_C32)
- {
- (((float*)base)[2*c_idx]) = scm_c_real_part (val);
- (((float*)base)[2*c_idx+1]) = scm_c_imag_part (val);
- }
- else if (type == SCM_UVEC_C64)
- {
- (((double*)base)[2*c_idx]) = scm_c_real_part (val);
- (((double*)base)[2*c_idx+1]) = scm_c_imag_part (val);
- }
-}
-
-static SCM_C_INLINE_KEYWORD SCM
-make_uvec (int type, SCM len, SCM fill)
-{
- size_t c_len = scm_to_size_t (len);
- SCM uvec = alloc_uvec (type, c_len);
- if (!SCM_UNBNDP (fill))
- {
- size_t idx;
- void *base = SCM_UVEC_BASE (uvec);
- for (idx = 0; idx < c_len; idx++)
- uvec_fast_set_x (type, base, idx, fill);
- }
- return uvec;
-}
-
-static SCM_C_INLINE_KEYWORD void *
-uvec_writable_elements (int type, SCM uvec, scm_t_array_handle *handle,
- size_t *lenp, ssize_t *incp)
-{
- if (type >= 0)
- {
- SCM v = uvec;
- if (SCM_I_ARRAYP (v))
- v = SCM_I_ARRAY_V (v);
- uvec_assert (type, v);
- }
-
- return scm_uniform_vector_writable_elements (uvec, handle, lenp, incp);
-}
-
-static SCM_C_INLINE_KEYWORD const void *
-uvec_elements (int type, SCM uvec, scm_t_array_handle *handle,
- size_t *lenp, ssize_t *incp)
-{
- return uvec_writable_elements (type, uvec, handle, lenp, incp);
-}
-
-static int
-uvec_type (scm_t_array_handle *h)
-{
- SCM v = h->array;
- if (SCM_I_ARRAYP (v))
- v = SCM_I_ARRAY_V (v);
- return SCM_UVEC_TYPE (v);
-}
-
-static SCM
-uvec_to_list (int type, SCM uvec)
-{
- scm_t_array_handle handle;
- size_t len;
- ssize_t i, inc;
- const void *elts;
- SCM res = SCM_EOL;
-
- elts = uvec_elements (type, uvec, &handle, &len, &inc);
- 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;
-}
-
-static SCM_C_INLINE_KEYWORD SCM
-uvec_length (int type, SCM uvec)
-{
- scm_t_array_handle handle;
- size_t len;
- ssize_t inc;
- uvec_elements (type, uvec, &handle, &len, &inc);
- scm_array_handle_release (&handle);
- return scm_from_size_t (len);
-}
-
-static SCM_C_INLINE_KEYWORD SCM
-uvec_ref (int type, SCM uvec, SCM idx)
-{
- scm_t_array_handle handle;
- size_t i, len;
- ssize_t inc;
- const void *elts;
- SCM res;
-
- elts = uvec_elements (type, uvec, &handle, &len, &inc);
- if (type < 0)
- type = uvec_type (&handle);
- i = scm_to_unsigned_integer (idx, 0, len-1);
- res = uvec_fast_ref (type, elts, i*inc);
- scm_array_handle_release (&handle);
- return res;
-}
-
-static SCM_C_INLINE_KEYWORD SCM
-uvec_set_x (int type, SCM uvec, SCM idx, SCM val)
-{
- scm_t_array_handle handle;
- size_t i, len;
- ssize_t inc;
- void *elts;
-
- elts = uvec_writable_elements (type, uvec, &handle, &len, &inc);
- if (type < 0)
- type = uvec_type (&handle);
- i = scm_to_unsigned_integer (idx, 0, len-1);
- uvec_fast_set_x (type, elts, i*inc, val);
- scm_array_handle_release (&handle);
- return SCM_UNSPECIFIED;
-}
-
-static SCM_C_INLINE_KEYWORD SCM
-list_to_uvec (int type, SCM list)
-{
- SCM uvec;
- void *base;
- long idx;
- long len = scm_ilength (list);
- if (len < 0)
- scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
-
- uvec = alloc_uvec (type, len);
- base = SCM_UVEC_BASE (uvec);
- idx = 0;
- while (scm_is_pair (list) && idx < len)
- {
- uvec_fast_set_x (type, base, idx, SCM_CAR (list));
- list = SCM_CDR (list);
- idx++;
- }
- return uvec;
-}
-
-SCM_SYMBOL (scm_sym_a, "a");
-SCM_SYMBOL (scm_sym_b, "b");
-
-SCM
-scm_i_generalized_vector_type (SCM v)
-{
- if (scm_is_vector (v))
- return SCM_BOOL_T;
- else if (scm_is_string (v))
- return scm_sym_a;
- else if (scm_is_bitvector (v))
- return scm_sym_b;
- else if (scm_is_uniform_vector (v))
- return scm_from_locale_symbol (uvec_tags[SCM_UVEC_TYPE(v)]);
- else if (scm_is_bytevector (v))
- return scm_from_locale_symbol ("vu8");
- else
- return SCM_BOOL_F;
-}
-
-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"
- "raw bytes from @var{port-or-fdes}, using host byte order.\n\n"
- "The optional arguments @var{start} (inclusive) and @var{end}\n"
- "(exclusive) allow a specified region to be read,\n"
- "leaving the remainder of the vector unchanged.\n\n"
- "When @var{port-or-fdes} is a port, all specified elements\n"
- "of @var{uvec} are attempted to be read, potentially blocking\n"
- "while waiting formore input or end-of-file.\n"
- "When @var{port-or-fd} is an integer, a single call to\n"
- "read(2) is made.\n\n"
- "An error is signalled when the last element has only\n"
- "been partially filled before reaching end-of-file or in\n"
- "the single call to read(2).\n\n"
- "@code{uniform-vector-read!} returns the number of elements\n"
- "read.\n\n"
- "@var{port-or-fdes} may be omitted, in which case it defaults\n"
- "to the value returned by @code{(current-input-port)}.")
-#define FUNC_NAME s_scm_uniform_vector_read_x
-{
- scm_t_array_handle handle;
- size_t vlen, sz, ans;
- ssize_t inc;
- size_t cstart, cend;
- size_t remaining, off;
- char *base;
-
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_input_port ();
- else
- SCM_ASSERT (scm_is_integer (port_or_fd)
- || (SCM_OPINPORTP (port_or_fd)),
- port_or_fd, SCM_ARG2, FUNC_NAME);
-
- if (!scm_is_uniform_vector (uvec))
- scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
-
- base = scm_uniform_vector_writable_elements (uvec, &handle, &vlen, &inc);
- sz = scm_array_handle_uniform_element_size (&handle);
-
- if (inc != 1)
- {
- /* XXX - we should of course support non contiguous vectors. */
- scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
- scm_list_1 (uvec));
- }
-
- 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);
- }
-
- remaining = (cend - cstart) * sz;
- off = cstart * sz;
+
+#define ETYPE(TAG) \
+ SCM_ARRAY_ELEMENT_TYPE_##TAG
- if (SCM_NIMP (port_or_fd))
- {
- ans = cend - cstart;
- remaining -= scm_c_read (port_or_fd, base + off, remaining);
- if (remaining % sz != 0)
- SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
- ans -= remaining / sz;
- }
- else /* file descriptor. */
- {
- int fd = scm_to_int (port_or_fd);
- int n;
-
- SCM_SYSCALL (n = read (fd, base + off, remaining));
- if (n == -1)
- SCM_SYSERROR;
- if (n % sz != 0)
- SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
- ans = n / sz;
- }
+#define DEFINE_SRFI_4_C_FUNCS(TAG, tag, ctype) \
+ SCM scm_take_##tag##vector (ctype *data, size_t n) \
+ { \
+ return scm_c_take_typed_bytevector ((scm_t_int8*)data, n, ETYPE (TAG)); \
+ } \
+ const ctype* scm_array_handle_##tag##_elements (scm_t_array_handle *h) \
+ { \
+ if (h->element_type != ETYPE (TAG)) \
+ scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \
+ return h->elements; \
+ } \
+ ctype* scm_array_handle_##tag##_writable_elements (scm_t_array_handle *h) \
+ { \
+ if (h->element_type != ETYPE (TAG)) \
+ scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \
+ return h->writable_elements; \
+ } \
+ const ctype *scm_##tag##vector_elements (SCM uvec, \
+ scm_t_array_handle *h, \
+ size_t *lenp, ssize_t *incp) \
+ { \
+ return scm_##tag##vector_writable_elements (uvec, h, lenp, incp); \
+ } \
+ ctype *scm_##tag##vector_writable_elements (SCM uvec, \
+ scm_t_array_handle *h, \
+ size_t *lenp, ssize_t *incp) \
+ { \
+ scm_uniform_vector_elements (uvec, h, lenp, incp); \
+ if (h->element_type == ETYPE (TAG)) \
+ return ((ctype*)h->writable_elements) + h->base; \
+ /* otherwise... */ \
+ else \
+ { \
+ size_t sfrom, sto, lfrom, lto; \
+ if (h->dims != &h->dim0) \
+ { \
+ h->dim0 = h->dims[0]; \
+ h->dims = &h->dim0; \
+ } \
+ sfrom = scm_i_array_element_type_sizes [h->element_type]; \
+ sto = scm_i_array_element_type_sizes [ETYPE (TAG)]; \
+ lfrom = h->dim0.ubnd - h->dim0.lbnd + 1; \
+ lto = lfrom * sfrom / sto; \
+ if (lto * sto != lfrom * sfrom) \
+ { \
+ scm_array_handle_release (h); \
+ scm_wrong_type_arg (#tag"vector-elements", SCM_ARG1, uvec); \
+ } \
+ h->dim0.ubnd = h->dim0.lbnd + lto; \
+ h->base = h->base * sto / sfrom; \
+ h->element_type = ETYPE (TAG); \
+ return ((ctype*)h->writable_elements) + h->base; \
+ } \
+ }
- scm_array_handle_release (&handle);
- return scm_from_size_t (ans);
-}
-#undef FUNC_NAME
+#define MOD "srfi srfi-4"
-SCM_DEFINE (scm_uniform_vector_write, "uniform-vector-write", 1, 3, 0,
- (SCM uvec, SCM port_or_fd, SCM start, SCM end),
- "Write the elements of @var{uvec} as raw bytes to\n"
- "@var{port-or-fdes}, in the host byte order.\n\n"
- "The optional arguments @var{start} (inclusive)\n"
- "and @var{end} (exclusive) allow\n"
- "a specified region to be written.\n\n"
- "When @var{port-or-fdes} is a port, all specified elements\n"
- "of @var{uvec} are attempted to be written, potentially blocking\n"
- "while waiting for more room.\n"
- "When @var{port-or-fd} is an integer, a single call to\n"
- "write(2) is made.\n\n"
- "An error is signalled when the last element has only\n"
- "been partially written in the single call to write(2).\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_vector_write
-{
- scm_t_array_handle handle;
- size_t vlen, sz, ans;
- ssize_t inc;
- size_t cstart, cend;
- size_t amount, off;
- const char *base;
-
- port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
-
- if (SCM_UNBNDP (port_or_fd))
- port_or_fd = scm_current_output_port ();
- else
- SCM_ASSERT (scm_is_integer (port_or_fd)
- || (SCM_OPOUTPORTP (port_or_fd)),
- port_or_fd, SCM_ARG2, FUNC_NAME);
-
- base = scm_uniform_vector_elements (uvec, &handle, &vlen, &inc);
- sz = scm_array_handle_uniform_element_size (&handle);
-
- if (inc != 1)
- {
- /* XXX - we should of course support non contiguous vectors. */
- scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
- scm_list_1 (uvec));
- }
+DEFINE_SRFI_4_PROXIES (u8);
+DEFINE_SRFI_4_C_FUNCS (U8, u8, scm_t_uint8);
- 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);
- }
+DEFINE_SRFI_4_PROXIES (s8);
+DEFINE_SRFI_4_C_FUNCS (S8, s8, scm_t_int8);
- amount = (cend - cstart) * sz;
- off = cstart * sz;
+DEFINE_SRFI_4_PROXIES (u16);
+DEFINE_SRFI_4_C_FUNCS (U16, u16, scm_t_uint16);
- if (SCM_NIMP (port_or_fd))
- {
- scm_lfwrite (base + off, amount, port_or_fd);
- ans = cend - cstart;
- }
- else /* file descriptor. */
- {
- int fd = scm_to_int (port_or_fd), n;
- SCM_SYSCALL (n = write (fd, base + off, amount));
- if (n == -1)
- SCM_SYSERROR;
- if (n % sz != 0)
- SCM_MISC_ERROR ("last element only written partially", SCM_EOL);
- ans = n / sz;
- }
+DEFINE_SRFI_4_PROXIES (s16);
+DEFINE_SRFI_4_C_FUNCS (S16, s16, scm_t_int16);
- scm_array_handle_release (&handle);
+DEFINE_SRFI_4_PROXIES (u32);
+DEFINE_SRFI_4_C_FUNCS (U32, u32, scm_t_uint32);
- return scm_from_size_t (ans);
-}
-#undef FUNC_NAME
+DEFINE_SRFI_4_PROXIES (s32);
+DEFINE_SRFI_4_C_FUNCS (S32, s32, scm_t_int32);
-/* ================================================================ */
-/* Exported procedures. */
-/* ================================================================ */
-
-#define TYPE SCM_UVEC_U8
-#define TAG u8
-#define CTYPE scm_t_uint8
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_S8
-#define TAG s8
-#define CTYPE scm_t_int8
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_U16
-#define TAG u16
-#define CTYPE scm_t_uint16
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_S16
-#define TAG s16
-#define CTYPE scm_t_int16
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_U32
-#define TAG u32
-#define CTYPE scm_t_uint32
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_S32
-#define TAG s32
-#define CTYPE scm_t_int32
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_U64
-#define TAG u64
-#if SCM_HAVE_T_UINT64
-#define CTYPE scm_t_uint64
+DEFINE_SRFI_4_PROXIES (u64);
+#if SCM_HAVE_T_INT64
+DEFINE_SRFI_4_C_FUNCS (U64, u64, scm_t_uint64);
#endif
-#include "libguile/srfi-4.i.c"
-#define TYPE SCM_UVEC_S64
-#define TAG s64
+DEFINE_SRFI_4_PROXIES (s64);
#if SCM_HAVE_T_INT64
-#define CTYPE scm_t_int64
+DEFINE_SRFI_4_C_FUNCS (S64, s64, scm_t_int64);
#endif
-#include "libguile/srfi-4.i.c"
-
-#define TYPE SCM_UVEC_F32
-#define TAG f32
-#define CTYPE float
-#include "libguile/srfi-4.i.c"
-#define TYPE SCM_UVEC_F64
-#define TAG f64
-#define CTYPE double
-#include "libguile/srfi-4.i.c"
+DEFINE_SRFI_4_PROXIES (f32);
+DEFINE_SRFI_4_C_FUNCS (F32, f32, float);
-#define TYPE SCM_UVEC_C32
-#define TAG c32
-#define CTYPE float
-#include "libguile/srfi-4.i.c"
+DEFINE_SRFI_4_PROXIES (f64);
+DEFINE_SRFI_4_C_FUNCS (F64, f64, double);
-#define TYPE SCM_UVEC_C64
-#define TAG c64
-#define CTYPE double
-#include "libguile/srfi-4.i.c"
+#undef MOD
+#define MOD "srfi srfi-4 gnu"
-#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_SRFI_4_PROXIES (c32);
+DEFINE_SRFI_4_C_FUNCS (C32, c32, float);
-#define DEFPROXY100(cname, scmname) \
- DEFINE_SCHEME_PROXY100 (cname, MOD, scmname)
+DEFINE_SRFI_4_PROXIES (c64);
+DEFINE_SRFI_4_C_FUNCS (C64, c64, double);
#define DEFINE_SRFI_4_GNU_PROXIES(tag) \
DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector")
+#undef MOD
#define MOD "srfi srfi-4 gnu"
DEFINE_SRFI_4_GNU_PROXIES (u8);
DEFINE_SRFI_4_GNU_PROXIES (s8);
@@ -840,68 +230,60 @@ 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,
- u32ref, s32ref,
- u64ref, s64ref,
- f32ref, f64ref,
- c32ref, c64ref
-};
-
-static scm_i_t_array_set uvec_setters[12] = {
- u8set, s8set,
- u16set, s16set,
- u32set, s32set,
- u64set, s64set,
- f32set, f64set,
- c32set, c64set
-};
-
-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)
+SCM_DEFINE (scm_make_srfi_4_vector, "make-srfi-4-vector", 2, 1, 0,
+ (SCM type, SCM len, SCM fill),
+ "Make a srfi-4 vector")
+#define FUNC_NAME s_scm_make_srfi_4_vector
{
- uvec_setters [SCM_UVEC_TYPE(h->array)] (h, index, val);
-}
-
-static void
-uvec_get_handle (SCM v, scm_t_array_handle *h)
-{
- h->array = v;
- h->ndims = 1;
- h->dims = &h->dim0;
- h->dim0.lbnd = 0;
- h->dim0.ubnd = SCM_UVEC_LENGTH (v) - 1;
- h->dim0.inc = 1;
- h->element_type = SCM_UVEC_TYPE (v) + SCM_ARRAY_ELEMENT_TYPE_U8;
- h->elements = h->writable_elements = SCM_UVEC_BASE (v);
+ int i;
+ for (i = 0; i <= SCM_ARRAY_ELEMENT_TYPE_LAST; i++)
+ if (scm_is_eq (type, scm_i_array_element_types[i]))
+ break;
+ if (i > SCM_ARRAY_ELEMENT_TYPE_LAST)
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "vector type");
+ switch (i)
+ {
+ case SCM_ARRAY_ELEMENT_TYPE_U8:
+ case SCM_ARRAY_ELEMENT_TYPE_S8:
+ case SCM_ARRAY_ELEMENT_TYPE_U16:
+ case SCM_ARRAY_ELEMENT_TYPE_S16:
+ case SCM_ARRAY_ELEMENT_TYPE_U32:
+ case SCM_ARRAY_ELEMENT_TYPE_S32:
+ case SCM_ARRAY_ELEMENT_TYPE_U64:
+ case SCM_ARRAY_ELEMENT_TYPE_S64:
+ case SCM_ARRAY_ELEMENT_TYPE_F32:
+ case SCM_ARRAY_ELEMENT_TYPE_F64:
+ case SCM_ARRAY_ELEMENT_TYPE_C32:
+ case SCM_ARRAY_ELEMENT_TYPE_C64:
+ {
+ SCM ret = scm_i_make_typed_bytevector (scm_to_size_t (len), i);
+ if (SCM_UNBNDP (fill))
+ ; /* pass */
+ else if (scm_is_true (scm_zero_p (fill)))
+ memset (SCM_BYTEVECTOR_CONTENTS (ret), 0,
+ SCM_BYTEVECTOR_LENGTH (ret));
+ else
+ {
+ scm_t_array_handle h;
+ size_t len;
+ ssize_t pos, inc;
+ scm_uniform_vector_writable_elements (ret, &h, &len, &inc);
+ for (pos = 0; pos != h.dims[0].ubnd; pos += inc)
+ scm_array_handle_set (&h, pos, fill);
+ scm_array_handle_release (&h);
+ }
+ return ret;
+ }
+ default:
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "uniform vector
type");
+ return SCM_BOOL_F; /* not reached */
+ }
}
-
-SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_tc16_uvec),
- SCM_SMOB_TYPE_MASK,
- uvec_handle_ref, uvec_handle_set,
- uvec_get_handle)
+#undef FUNC_NAME
void
scm_init_srfi_4 (void)
{
- scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
- scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp);
- scm_set_smob_print (scm_tc16_uvec, uvec_print);
-
-#if SCM_HAVE_T_INT64 == 0
- scm_uint64_min = scm_from_int (0);
- scm_uint64_max = scm_c_read_string ("18446744073709551615");
- scm_int64_min = scm_c_read_string ("-9223372036854775808");
- scm_int64_max = 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], \
@@ -921,7 +303,6 @@ scm_init_srfi_4 (void)
REGISTER (c64, C64);
#include "libguile/srfi-4.x"
-
}
/* End of srfi-4.c. */
diff --git a/libguile/srfi-4.h b/libguile/srfi-4.h
index 48001ab..18b1cb1 100644
--- a/libguile/srfi-4.h
+++ b/libguile/srfi-4.h
@@ -23,6 +23,9 @@
#include "libguile/__scm.h"
+SCM_API SCM scm_make_srfi_4_vector (SCM type, SCM len, SCM fill);
+
+
/* Specific procedures.
*/
diff --git a/libguile/srfi-4.i.c b/libguile/srfi-4.i.c
deleted file mode 100644
index 098752e..0000000
--- a/libguile/srfi-4.i.c
+++ /dev/null
@@ -1,207 +0,0 @@
-/* This file defines the procedures related to one type of uniform
- numeric vector. It is included multiple time in srfi-4.c, once for
- each type.
-
- Before inclusion, the following macros must be defined. They are
- undefined at the end of this file to get back to a clean slate for
- the next inclusion.
-
- - TYPE
-
- The type tag of the vector, for example SCM_UVEC_U8
-
- - TAG
-
- The tag name of the vector, for example u8. The tag is used to
- form the function names and is included in the docstrings, for
- example.
-
- - CTYPE
-
- The C type of the elements, for example scm_t_uint8. The code
- below will never do sizeof (CTYPE), thus you can use just 'float'
- for the c32 type, for example.
-
- When CTYPE is not defined, the functions using it are excluded.
-*/
-
-/* The first level does not expand macros in the arguments. */
-#define paste(a1,a2,a3) a1##a2##a3
-#define s_paste(a1,a2,a3) s_##a1##a2##a3
-#define stringify(a) #a
-
-/* But the second level does. */
-#define F(pre,T,suf) paste(pre,T,suf)
-#define s_F(pre,T,suf) s_paste(pre,T,suf)
-#define S(T) stringify(T)
-
-SCM_DEFINE (F(scm_,TAG,vector_p), S(TAG)"vector?", 1, 0, 0,
- (SCM obj),
- "Return @code{#t} if @var{obj} is a vector of type " S(TAG) ",\n"
- "@code{#f} otherwise.")
-#define FUNC_NAME s_F(scm_, TAG, vector_p)
-{
- return uvec_p (TYPE, obj);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (F(scm_make_,TAG,vector), "make-"S(TAG)"vector", 1, 1, 0,
- (SCM len, SCM fill),
- "Return a newly allocated uniform numeric vector which can\n"
- "hold @var{len} elements. If @var{fill} is given, it is used to\n"
- "initialize the elements, otherwise the contents of the vector\n"
- "is unspecified.")
-#define FUNC_NAME s_S(scm_make_,TAG,vector)
-{
- return make_uvec (TYPE, len, fill);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (F(scm_,TAG,vector), S(TAG)"vector", 0, 0, 1,
- (SCM l),
- "Return a newly allocated uniform numeric vector containing\n"
- "all argument values.")
-#define FUNC_NAME s_F(scm_,TAG,vector)
-{
- return list_to_uvec (TYPE, l);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (F(scm_,TAG,vector_length), S(TAG)"vector-length", 1, 0, 0,
- (SCM uvec),
- "Return the number of elements in the uniform numeric vector\n"
- "@var{uvec}.")
-#define FUNC_NAME s_F(scm_,TAG,vector_length)
-{
- return uvec_length (TYPE, uvec);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (F(scm_,TAG,vector_ref), S(TAG)"vector-ref", 2, 0, 0,
- (SCM uvec, SCM index),
- "Return the element at @var{index} in the uniform numeric\n"
- "vector @var{uvec}.")
-#define FUNC_NAME s_F(scm_,TAG,vector_ref)
-{
- return uvec_ref (TYPE, uvec, index);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (F(scm_,TAG,vector_set_x), S(TAG)"vector-set!", 3, 0, 0,
- (SCM uvec, SCM index, SCM value),
- "Set the element at @var{index} in the uniform numeric\n"
- "vector @var{uvec} to @var{value}. The return value is not\n"
- "specified.")
-#define FUNC_NAME s_F(scm_,TAG,vector_set_x)
-{
- return uvec_set_x (TYPE, uvec, index, value);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (F(scm_,TAG,vector_to_list), S(TAG)"vector->list", 1, 0, 0,
- (SCM uvec),
- "Convert the uniform numeric vector @var{uvec} to a list.")
-#define FUNC_NAME s_F(scm_,TAG,vector_to_list)
-{
- return uvec_to_list (TYPE, uvec);
-}
-#undef FUNC_NAME
-
-
-SCM_DEFINE (F(scm_list_to_,TAG,vector), "list->"S(TAG)"vector", 1, 0, 0,
- (SCM l),
- "Convert the list @var{l} to a numeric uniform vector.")
-#define FUNC_NAME s_F(scm_list_to_,TAG,vector)
-{
- return list_to_uvec (TYPE, l);
-}
-#undef FUNC_NAME
-
-#ifdef CTYPE
-
-SCM
-F(scm_take_,TAG,vector) (CTYPE *data, size_t n)
-{
- /* The manual says "Return a new uniform numeric vector [...] that uses the
- memory pointed to by DATA". We *have* to use DATA as the underlying
- storage; thus we must register a finalizer to eventually free(3) it. */
- GC_finalization_proc prev_finalizer;
- GC_PTR prev_finalization_data;
-
- GC_REGISTER_FINALIZER_NO_ORDER (data, free_user_data, 0,
- &prev_finalizer,
- &prev_finalization_data);
-
- return take_uvec (TYPE, data, n);
-}
-
-const CTYPE *
-F(scm_array_handle_,TAG,_elements) (scm_t_array_handle *h)
-{
- return F(scm_array_handle_,TAG,_writable_elements) (h);
-}
-
-CTYPE *
-F(scm_array_handle_,TAG,_writable_elements) (scm_t_array_handle *h)
-{
- SCM vec = h->array;
- if (SCM_I_ARRAYP (vec))
- vec = SCM_I_ARRAY_V (vec);
- uvec_assert (TYPE, vec);
- if (TYPE == SCM_UVEC_C32 || TYPE == SCM_UVEC_C64)
- return ((CTYPE *)SCM_UVEC_BASE (vec)) + 2*h->base;
- else
- return ((CTYPE *)SCM_UVEC_BASE (vec)) + h->base;
-}
-
-const CTYPE *
-F(scm_,TAG,vector_elements) (SCM uvec,
- scm_t_array_handle *h,
- size_t *lenp, ssize_t *incp)
-{
- return F(scm_,TAG,vector_writable_elements) (uvec, h, lenp, incp);
-}
-
-CTYPE *
-F(scm_,TAG,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 F(scm_array_handle_,TAG,_writable_elements) (h);
-}
-
-#endif
-
-static SCM
-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, size_t pos, SCM val)
-{
- uvec_fast_set_x (TYPE, handle->writable_elements, pos, val);
-}
-
-#undef paste
-#undef s_paste
-#undef stringify
-#undef F
-#undef s_F
-#undef S
-
-#undef TYPE
-#undef TAG
-#undef CTYPE
diff --git a/libguile/strorder.c b/libguile/strorder.c
index 0338c65..a51ce17 100644
--- a/libguile/strorder.c
+++ b/libguile/strorder.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995, 1996, 1999, 2000, 2004, 2006, 2008, 2009 Free
Software Foundation, Inc.
+/* Copyright (C) 1995, 1996, 1999, 2000, 2004, 2006, 2008, 2009, 2010 Free
Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -42,6 +42,7 @@ srfi13_cmp (SCM s1, SCM s2, SCM (*cmp) (SCM, SCM, SCM, SCM,
SCM, SCM))
return SCM_BOOL_F;
}
+static SCM scm_i_string_equal_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_equal_p, "string=?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Lexicographic equality predicate; return @code{#t} if the two\n"
@@ -75,6 +76,7 @@ SCM scm_string_equal_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_ci_equal_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_ci_equal_p, "string-ci=?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Case-insensitive string equality predicate; return @code{#t} if\n"
@@ -104,6 +106,7 @@ SCM scm_string_ci_equal_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_less_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_less_p, "string<?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
@@ -131,6 +134,7 @@ SCM scm_string_less_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_leq_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_leq_p, "string<=?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
@@ -158,6 +162,7 @@ SCM scm_string_leq_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_gr_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_gr_p, "string>?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
@@ -185,6 +190,7 @@ SCM scm_string_gr_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_geq_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_geq_p, "string>=?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Lexicographic ordering predicate; return @code{#t} if @var{s1}\n"
@@ -212,6 +218,7 @@ SCM scm_string_geq_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_ci_less_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_ci_less_p, "string-ci<?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Case insensitive lexicographic ordering predicate; return\n"
@@ -240,6 +247,7 @@ SCM scm_string_ci_less_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_ci_leq_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_ci_leq_p, "string-ci<=?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Case insensitive lexicographic ordering predicate; return\n"
@@ -268,6 +276,7 @@ SCM scm_string_ci_leq_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_ci_gr_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_ci_gr_p, "string-ci>?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Case insensitive lexicographic ordering predicate; return\n"
@@ -296,6 +305,7 @@ SCM scm_string_ci_gr_p (SCM s1, SCM s2)
}
#undef FUNC_NAME
+static SCM scm_i_string_ci_geq_p (SCM s1, SCM s2, SCM rest);
SCM_DEFINE (scm_i_string_ci_geq_p, "string-ci>=?", 0, 2, 1,
(SCM s1, SCM s2, SCM rest),
"Case insensitive lexicographic ordering predicate; return\n"
diff --git a/libguile/tags.h b/libguile/tags.h
index a8ecf0f..143a300 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -416,13 +416,13 @@ typedef scm_t_uintptr scm_t_bits;
#define scm_tc7_fluid 37
#define scm_tc7_dynamic_state 45
-#define scm_tc7_unused_4 47
-#define scm_tc7_unused_5 53
-#define scm_tc7_unused_6 55
-#define scm_tc7_unused_7 71
+#define scm_tc7_frame 47
+#define scm_tc7_objcode 53
+#define scm_tc7_vm 55
+#define scm_tc7_vm_cont 71
#define scm_tc7_unused_17 61
-#define scm_tc7_gsubr 63
+#define scm_tc7_unused_21 63
#define scm_tc7_unused_19 69
#define scm_tc7_program 79
#define scm_tc7_unused_9 85
diff --git a/libguile/vectors.c b/libguile/vectors.c
index eabd4c4..6ac5acb 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -30,12 +30,8 @@
#include "libguile/validate.h"
#include "libguile/vectors.h"
+#include "libguile/arrays.h" /* Hit me with the ugly stick */
#include "libguile/generalized-vectors.h"
-#include "libguile/arrays.h"
-#include "libguile/bitvectors.h"
-#include "libguile/bytevectors.h"
-#include "libguile/array-map.h"
-#include "libguile/srfi-4.h"
#include "libguile/strings.h"
#include "libguile/srfi-13.h"
#include "libguile/dynwind.h"
diff --git a/libguile/vectors.h b/libguile/vectors.h
index a74c8a9..7f74519 100644
--- a/libguile/vectors.h
+++ b/libguile/vectors.h
@@ -24,7 +24,6 @@
#include "libguile/__scm.h"
-#include "libguile/arrays.h"
diff --git a/libguile/vm-bootstrap.h b/libguile/vm-bootstrap.h
deleted file mode 100644
index 7ba1a93..0000000
--- a/libguile/vm-bootstrap.h
+++ /dev/null
@@ -1,30 +0,0 @@
-/* Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This library is free software; you can redistribute it and/or
- * modify it under the terms of the GNU Lesser General Public License
- * as published by the Free Software Foundation; either version 3 of
- * the License, or (at your option) any later version.
- *
- * This library is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * Lesser General Public License for more details.
- *
- * You should have received a copy of the GNU Lesser General Public
- * License along with this library; if not, write to the Free Software
- * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
- * 02110-1301 USA
- */
-
-#ifndef _SCM_VM_BOOTSTRAP_H_
-#define _SCM_VM_BOOTSTRAP_H_
-
-SCM_INTERNAL void scm_bootstrap_vm (void);
-
-#endif /* _SCM_VM_BOOTSTRAP_H_ */
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
diff --git a/libguile/vm.c b/libguile/vm.c
index a5b5a55..0da915b 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -28,7 +28,6 @@
#include <gc/gc_mark.h>
#include "_scm.h"
-#include "vm-bootstrap.h"
#include "frames.h"
#include "instructions.h"
#include "objcodes.h"
@@ -72,7 +71,13 @@
* VM Continuation
*/
-scm_t_bits scm_tc16_vm_cont;
+void
+scm_i_vm_cont_print (SCM x, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<vm-continuation ", port);
+ scm_uintprint (SCM_UNPACK (x), 16, port);
+ scm_puts (">", port);
+}
static SCM
capture_vm_cont (struct scm_vm *vp)
@@ -92,7 +97,7 @@ capture_vm_cont (struct scm_vm *vp)
p->fp = vp->fp;
memcpy (p->stack_base, vp->stack_base, p->stack_size * sizeof (SCM));
p->reloc = p->stack_base - vp->stack_base;
- SCM_RETURN_NEWSMOB (scm_tc16_vm_cont, p);
+ return scm_cell (scm_tc7_vm_cont, (scm_t_bits)p);
}
static void
@@ -174,6 +179,14 @@ SCM_SYMBOL (sym_vm_error, "vm-error");
SCM_SYMBOL (sym_keyword_argument_error, "keyword-argument-error");
SCM_SYMBOL (sym_debug, "debug");
+void
+scm_i_vm_print (SCM x, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<vm ", port);
+ scm_uintprint (SCM_UNPACK (x), 16, port);
+ scm_puts (">", port);
+}
+
static SCM
really_make_boot_program (long nargs)
{
@@ -286,8 +299,6 @@ apply_foreign (SCM proc, SCM *args, int nargs, int headroom)
return SCM_SMOB_APPLY_3 (proc, args[0], args[1], arglist);
}
}
- case scm_tc7_gsubr:
- return scm_i_gsubr_apply_array (proc, args, nargs, headroom);
default:
badproc:
scm_wrong_type_arg ("apply", SCM_ARG1, proc);
@@ -316,8 +327,6 @@ apply_foreign (SCM proc, SCM *args, int nargs, int headroom)
static const scm_t_vm_engine vm_engines[] =
{ vm_regular_engine, vm_debug_engine };
-scm_t_bits scm_tc16_vm;
-
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
/* The GC "kind" for the VM stack. */
@@ -332,9 +341,6 @@ make_vm (void)
int i;
struct scm_vm *vp;
- if (!scm_tc16_vm)
- return SCM_BOOL_F; /* not booted yet */
-
vp = scm_gc_malloc (sizeof (struct scm_vm), "vm");
vp->stack_size = VM_DEFAULT_STACK_SIZE;
@@ -365,7 +371,7 @@ make_vm (void)
vp->trace_level = 0;
for (i = 0; i < SCM_VM_NUM_HOOKS; i++)
vp->hooks[i] = SCM_BOOL_F;
- SCM_RETURN_NEWSMOB (scm_tc16_vm, vp);
+ return scm_cell (scm_tc7_vm, (scm_t_bits)vp);
}
#undef FUNC_NAME
@@ -408,9 +414,10 @@ scm_c_vm_run (SCM vm, SCM program, SCM *argv, int nargs)
return vm_engines[vp->engine](vm, program, argv, nargs);
}
-SCM
-scm_vm_apply (SCM vm, SCM program, SCM args)
-#define FUNC_NAME "scm_vm_apply"
+SCM_DEFINE (scm_vm_apply, "vm-apply", 3, 0, 0,
+ (SCM vm, SCM program, SCM args),
+ "")
+#define FUNC_NAME s_scm_vm_apply
{
SCM *argv;
int i, nargs;
@@ -654,30 +661,9 @@ SCM scm_load_compiled_with_vm (SCM file)
void
scm_bootstrap_vm (void)
{
- static int strappage = 0;
-
- if (strappage)
- return;
-
- scm_bootstrap_frames ();
- scm_bootstrap_instructions ();
- scm_bootstrap_objcodes ();
- scm_bootstrap_programs ();
-
- scm_tc16_vm_cont = scm_make_smob_type ("vm-cont", 0);
-
- scm_tc16_vm = scm_make_smob_type ("vm", 0);
- scm_set_smob_apply (scm_tc16_vm, scm_vm_apply, 1, 0, 1);
-
- scm_c_define ("load-compiled",
- scm_c_make_gsubr ("load-compiled/vm", 1, 0, 0,
- scm_load_compiled_with_vm));
-
scm_c_register_extension ("libguile", "scm_init_vm",
(scm_t_extension_init_func)scm_init_vm, NULL);
- strappage = 1;
-
#ifdef VM_ENABLE_PRECISE_STACK_GC_SCAN
vm_stack_gc_kind =
GC_new_kind (GC_new_free_list (),
@@ -690,8 +676,6 @@ scm_bootstrap_vm (void)
void
scm_init_vm (void)
{
- scm_bootstrap_vm ();
-
#ifndef SCM_MAGIC_SNARFER
#include "libguile/vm.x"
#endif
diff --git a/libguile/vm.h b/libguile/vm.h
index f18826e..c121061 100644
--- a/libguile/vm.h
+++ b/libguile/vm.h
@@ -1,4 +1,4 @@
-/* Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@@ -55,8 +55,8 @@ struct scm_vm {
SCM_API SCM scm_the_vm_fluid;
-#define SCM_VM_P(x) SCM_SMOB_PREDICATE (scm_tc16_vm, x)
-#define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_SMOB_DATA (vm))
+#define SCM_VM_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_vm)
+#define SCM_VM_DATA(vm) ((struct scm_vm *) SCM_CELL_WORD_1 (vm))
#define SCM_VALIDATE_VM(pos,x) SCM_MAKE_VALIDATE (pos, x, VM_P)
SCM_API SCM scm_the_vm ();
@@ -95,15 +95,19 @@ struct scm_vm_cont {
scm_t_ptrdiff reloc;
};
-SCM_API scm_t_bits scm_tc16_vm_cont;
-#define SCM_VM_CONT_P(OBJ) SCM_SMOB_PREDICATE (scm_tc16_vm_cont, OBJ)
-#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_SMOB_DATA_1 (CONT))
+#define SCM_VM_CONT_P(OBJ) (SCM_NIMP (OBJ) && SCM_TYP7 (OBJ) ==
scm_tc7_vm_cont)
+#define SCM_VM_CONT_DATA(CONT) ((struct scm_vm_cont *) SCM_CELL_WORD_1 (CONT))
SCM_API SCM scm_vm_capture_continuations (void);
SCM_API void scm_vm_reinstate_continuations (SCM conts);
SCM_API SCM scm_load_compiled_with_vm (SCM file);
+SCM_INTERNAL void scm_i_vm_print (SCM x, SCM port,
+ scm_print_state *pstate);
+SCM_INTERNAL void scm_i_vm_cont_print (SCM x, SCM port,
+ scm_print_state *pstate);
+SCM_INTERNAL void scm_bootstrap_vm (void);
SCM_INTERNAL void scm_init_vm (void);
#endif /* _SCM_VM_H_ */
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 1fe1959..bbffda0 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3562,6 +3562,9 @@ module '(ice-9 q) '(make-q q-length))}."
;; (module-eval-closure (current-module))))
;; (deannotate/source-properties (sc-expand (annotate exp)))))
+;; FIXME:
+(module-use! the-scm-module (resolve-interface '(srfi srfi-4)))
+
(define-module (guile-user)
#:autoload (system base compile) (compile))
diff --git a/module/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index 83eab6f..848aa8d 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -1,6 +1,6 @@
;;; open-coding primitive procedures
-;; Copyright (C) 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -23,6 +23,7 @@
#:use-module (rnrs bytevector)
#:use-module (system base syntax)
#:use-module (language tree-il)
+ #:use-module (srfi srfi-4)
#:use-module (srfi srfi-16)
#:export (resolve-primitives! add-interesting-primitive!
expand-primitives! effect-free-primitive?))
@@ -61,26 +62,31 @@
bytevector-u8-ref bytevector-u8-set!
bytevector-s8-ref bytevector-s8-set!
-
+ u8vector-ref u8vector-set! s8vector-ref s8vector-set!
+
bytevector-u16-ref bytevector-u16-set!
bytevector-u16-native-ref bytevector-u16-native-set!
bytevector-s16-ref bytevector-s16-set!
bytevector-s16-native-ref bytevector-s16-native-set!
+ u16vector-ref u16vector-set! s16vector-ref s16vector-set!
bytevector-u32-ref bytevector-u32-set!
bytevector-u32-native-ref bytevector-u32-native-set!
bytevector-s32-ref bytevector-s32-set!
bytevector-s32-native-ref bytevector-s32-native-set!
+ u32vector-ref u32vector-set! s32vector-ref s32vector-set!
bytevector-u64-ref bytevector-u64-set!
bytevector-u64-native-ref bytevector-u64-native-set!
bytevector-s64-ref bytevector-s64-set!
bytevector-s64-native-ref bytevector-s64-native-set!
+ u64vector-ref u64vector-set! s64vector-ref s64vector-set!
bytevector-ieee-single-ref bytevector-ieee-single-set!
bytevector-ieee-single-native-ref bytevector-ieee-single-native-set!
bytevector-ieee-double-ref bytevector-ieee-double-set!
- bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!))
+ bytevector-ieee-double-native-ref bytevector-ieee-double-native-set!
+ f32vector-ref f32vector-set! f64vector-ref f64vector-set!))
(define (add-interesting-primitive! name)
(hashq-set! *interesting-primitive-vars*
@@ -301,3 +307,57 @@
;; swap args
(define-primitive-expander variable-set! (var val)
(variable-set val var))
+
+(define-primitive-expander u8vector-ref (vec i)
+ (bytevector-u8-ref vec i))
+(define-primitive-expander u8vector-set! (vec i x)
+ (bytevector-u8-set! vec i x))
+(define-primitive-expander s8vector-ref (vec i)
+ (bytevector-s8-ref vec i))
+(define-primitive-expander s8vector-set! (vec i x)
+ (bytevector-s8-set! vec i x))
+
+(define-primitive-expander u16vector-ref (vec i)
+ (bytevector-u16-native-ref vec (* i 2)))
+(define-primitive-expander u16vector-set! (vec i x)
+ (bytevector-u16-native-set! vec (* i 2) x))
+(define-primitive-expander s16vector-ref (vec i)
+ (bytevector-s16-native-ref vec (* i 2)))
+(define-primitive-expander s16vector-set! (vec i x)
+ (bytevector-s16-native-set! vec (* i 2) x))
+
+(define-primitive-expander u32vector-ref (vec i)
+ (bytevector-u32-native-ref vec (* i 4)))
+(define-primitive-expander u32vector-set! (vec i x)
+ (bytevector-u32-native-set! vec (* i 4) x))
+(define-primitive-expander s32vector-ref (vec i)
+ (bytevector-s32-native-ref vec (* i 4)))
+(define-primitive-expander s32vector-set! (vec i x)
+ (bytevector-s32-native-set! vec (* i 4) x))
+
+(define-primitive-expander u64vector-ref (vec i)
+ (bytevector-u64-native-ref vec (* i 8)))
+(define-primitive-expander u64vector-set! (vec i x)
+ (bytevector-u64-native-set! vec (* i 8) x))
+(define-primitive-expander s64vector-ref (vec i)
+ (bytevector-s64-native-ref vec (* i 8)))
+(define-primitive-expander s64vector-set! (vec i x)
+ (bytevector-s64-native-set! vec (* i 8) x))
+
+(define-primitive-expander f32vector-ref (vec i)
+ (bytevector-ieee-single-native-ref vec (* i 4)))
+(define-primitive-expander f32vector-set! (vec i x)
+ (bytevector-ieee-single-native-set! vec (* i 4) x))
+(define-primitive-expander f32vector-ref (vec i)
+ (bytevector-ieee-single-native-ref vec (* i 4)))
+(define-primitive-expander f32vector-set! (vec i x)
+ (bytevector-ieee-single-native-set! vec (* i 4) x))
+
+(define-primitive-expander f64vector-ref (vec i)
+ (bytevector-ieee-double-native-ref vec (* i 8)))
+(define-primitive-expander f64vector-set! (vec i x)
+ (bytevector-ieee-double-native-set! vec (* i 8) x))
+(define-primitive-expander f64vector-ref (vec i)
+ (bytevector-ieee-double-native-ref vec (* i 8)))
+(define-primitive-expander f64vector-set! (vec i x)
+ (bytevector-ieee-double-native-set! vec (* i 8) x))
diff --git a/module/srfi/srfi-4.scm b/module/srfi/srfi-4.scm
index b133f21..8438ba3 100644
--- a/module/srfi/srfi-4.scm
+++ b/module/srfi/srfi-4.scm
@@ -1,6 +1,6 @@
;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes
-;; Copyright (C) 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010 Free Software
Foundation, Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -26,46 +26,111 @@
;;; Code:
-(define-module (srfi srfi-4))
+(define-module (srfi srfi-4)
+ #:use-module (rnrs bytevector)
+ #:export (;; Unsigned 8-bit vectors.
+ u8vector? make-u8vector u8vector u8vector-length u8vector-ref
+ u8vector-set! u8vector->list list->u8vector
+
+ ;; Signed 8-bit vectors.
+ s8vector? make-s8vector s8vector s8vector-length s8vector-ref
+ s8vector-set! s8vector->list list->s8vector
+
+ ;; Unsigned 16-bit vectors.
+ u16vector? make-u16vector u16vector u16vector-length u16vector-ref
+ u16vector-set! u16vector->list list->u16vector
+
+ ;; Signed 16-bit vectors.
+ s16vector? make-s16vector s16vector s16vector-length s16vector-ref
+ s16vector-set! s16vector->list list->s16vector
+
+ ;; Unsigned 32-bit vectors.
+ u32vector? make-u32vector u32vector u32vector-length u32vector-ref
+ u32vector-set! u32vector->list list->u32vector
+
+ ;; Signed 32-bit vectors.
+ s32vector? make-s32vector s32vector s32vector-length s32vector-ref
+ s32vector-set! s32vector->list list->s32vector
+
+ ;; Unsigned 64-bit vectors.
+ u64vector? make-u64vector u64vector u64vector-length u64vector-ref
+ u64vector-set! u64vector->list list->u64vector
+
+ ;; Signed 64-bit vectors.
+ s64vector? make-s64vector s64vector s64vector-length s64vector-ref
+ s64vector-set! s64vector->list list->s64vector
+
+ ;; 32-bit floating point vectors.
+ f32vector? make-f32vector f32vector f32vector-length f32vector-ref
+ f32vector-set! f32vector->list list->f32vector
+
+ ;; 64-bit floating point vectors.
+ f64vector? make-f64vector f64vector f64vector-length f64vector-ref
+ f64vector-set! f64vector->list list->f64vector))
+
+
+;; Need quasisyntax to do this effectively using syntax-case
+(define-macro (define-bytevector-type tag infix size)
+ `(begin
+ (define (,(symbol-append tag 'vector?) obj)
+ (and (uniform-vector? obj)
+ (eq? (uniform-vector-element-type obj) ',tag)))
+ (define (,(symbol-append 'make- tag 'vector) len . fill)
+ (apply make-srfi-4-vector ',tag len fill))
+ (define (,(symbol-append tag 'vector-length) v)
+ (let ((len (* (uniform-vector-length v)
+ (/ ,size (uniform-vector-element-size v)))))
+ (if (integer? len)
+ len
+ (error "fractional length" v ',tag ,size))))
+ (define (,(symbol-append tag 'vector) . elts)
+ (,(symbol-append 'list-> tag 'vector) elts))
+ (define (,(symbol-append 'list-> tag 'vector) elts)
+ (let* ((len (length elts))
+ (v (,(symbol-append 'make- tag 'vector) len)))
+ (let lp ((i 0) (elts elts))
+ (if (and (< i len) (pair? elts))
+ (begin
+ (,(symbol-append tag 'vector-set!) v i (car elts))
+ (lp (1+ i) (cdr elts)))
+ v))))
+ (define (,(symbol-append tag 'vector->list) v)
+ (let lp ((i (1- (,(symbol-append tag 'vector-length) v))) (elts '()))
+ (if (< i 0)
+ elts
+ (lp (1- i) (cons (,(symbol-append tag 'vector-ref) v i) elts)))))
+ (define (,(symbol-append tag 'vector-ref) v i)
+ (,(symbol-append 'bytevector- infix '-ref) v (* i ,size)))
+ (define (,(symbol-append tag 'vector-set!) v i x)
+ (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))
+ (define (,(symbol-append tag 'vector-set!) v i x)
+ (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))))
+
+(define-bytevector-type u8 u8 1)
+(define-bytevector-type s8 s8 1)
+(define-bytevector-type u16 u16-native 2)
+(define-bytevector-type s16 s16-native 2)
+(define-bytevector-type u32 u32-native 4)
+(define-bytevector-type s32 s32-native 4)
+(define-bytevector-type u64 u64-native 8)
+(define-bytevector-type s64 s64-native 8)
+(define-bytevector-type f32 ieee-single-native 4)
+(define-bytevector-type f64 ieee-double-native 8)
+
+(define (bytevector-c32-ref v i)
+ (make-rectangular (bytevector-ieee-single-native-ref v i)
+ (bytevector-ieee-single-native-ref v (+ i 4))))
+(define (bytevector-c32-set! v i x)
+ (bytevector-ieee-single-native-set! v i x)
+ (bytevector-ieee-single-native-set! v (+ i 4) x))
+(define-bytevector-type c32 c32 8)
+
+(define (bytevector-c64-ref v i)
+ (make-rectangular (bytevector-ieee-double-native-ref v i)
+ (bytevector-ieee-double-native-ref v (+ i 8))))
+(define (bytevector-c64-set! v i x)
+ (bytevector-ieee-double-native-set! v i x)
+ (bytevector-ieee-double-native-set! v (+ i 8) x))
+(define-bytevector-type c64 c64 16)
-(re-export
-;;; Unsigned 8-bit vectors.
- u8vector? make-u8vector u8vector u8vector-length u8vector-ref
- u8vector-set! u8vector->list list->u8vector
-;;; Signed 8-bit vectors.
- s8vector? make-s8vector s8vector s8vector-length s8vector-ref
- s8vector-set! s8vector->list list->s8vector
-
-;;; Unsigned 16-bit vectors.
- u16vector? make-u16vector u16vector u16vector-length u16vector-ref
- u16vector-set! u16vector->list list->u16vector
-
-;;; Signed 16-bit vectors.
- s16vector? make-s16vector s16vector s16vector-length s16vector-ref
- s16vector-set! s16vector->list list->s16vector
-
-;;; Unsigned 32-bit vectors.
- u32vector? make-u32vector u32vector u32vector-length u32vector-ref
- u32vector-set! u32vector->list list->u32vector
-
-;;; Signed 32-bit vectors.
- s32vector? make-s32vector s32vector s32vector-length s32vector-ref
- s32vector-set! s32vector->list list->s32vector
-
-;;; Unsigned 64-bit vectors.
- u64vector? make-u64vector u64vector u64vector-length u64vector-ref
- u64vector-set! u64vector->list list->u64vector
-
-;;; Signed 64-bit vectors.
- s64vector? make-s64vector s64vector s64vector-length s64vector-ref
- s64vector-set! s64vector->list list->s64vector
-
-;;; 32-bit floating point vectors.
- f32vector? make-f32vector f32vector f32vector-length f32vector-ref
- f32vector-set! f32vector->list list->f32vector
-
-;;; 64-bit floating point vectors.
- f64vector? make-f64vector f64vector f64vector-length f64vector-ref
- f64vector-set! f64vector->list list->f64vector
- )
diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm
index c5c41ea..ccb1ab1 100644
--- a/module/srfi/srfi-4/gnu.scm
+++ b/module/srfi/srfi-4/gnu.scm
@@ -23,13 +23,77 @@
;;; Code:
(define-module (srfi srfi-4 gnu)
+ #:use-module (rnrs bytevector)
#:use-module (srfi srfi-4)
- #:export (;; Somewhat polymorphic conversions.
+ #:export (;; Complex numbers with 32- and 64-bit components.
+ c32vector? make-c32vector c32vector c32vector-length c32vector-ref
+ c32vector-set! c32vector->list list->c32vector
+
+ c64vector? make-c64vector c64vector c64vector-length c64vector-ref
+ c64vector-set! c64vector->list list->c64vector
+
+ make-srfi-4-vector
+
+ ;; 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 make-srfi-4-vector (@@ (srfi srfi-4) make-srfi-4-vector))
+
+;; Need quasisyntax to do this effectively using syntax-case
+(define-macro (define-bytevector-type tag infix size)
+ `(begin
+ (define (,(symbol-append tag 'vector?) obj)
+ (and (uniform-vector? obj)
+ (eq? (uniform-vector-element-type obj) ',tag)))
+ (define (,(symbol-append 'make- tag 'vector) len . fill)
+ (apply make-srfi-4-vector ',tag len fill))
+ (define (,(symbol-append tag 'vector-length) v)
+ (let ((len (* (uniform-vector-length v)
+ (/ ,size (uniform-vector-element-size v)))))
+ (if (integer? len)
+ len
+ (error "fractional length" v ',tag ,size))))
+ (define (,(symbol-append tag 'vector) . elts)
+ (,(symbol-append 'list-> tag 'vector) elts))
+ (define (,(symbol-append 'list-> tag 'vector) elts)
+ (let* ((len (length elts))
+ (v (,(symbol-append 'make- tag 'vector) len)))
+ (let lp ((i 0) (elts elts))
+ (if (and (< i len) (pair? elts))
+ (begin
+ (,(symbol-append tag 'vector-set!) v i (car elts))
+ (lp (1+ i) (cdr elts)))
+ v))))
+ (define (,(symbol-append tag 'vector->list) v)
+ (let lp ((i (1- (,(symbol-append tag 'vector-length) v))) (elts '()))
+ (if (< i 0)
+ elts
+ (lp (1- i) (cons (,(symbol-append tag 'vector-ref) v i) elts)))))
+ (define (,(symbol-append tag 'vector-ref) v i)
+ (,(symbol-append 'bytevector- infix '-ref) v (* i ,size)))
+ (define (,(symbol-append tag 'vector-set!) v i x)
+ (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))
+ (define (,(symbol-append tag 'vector-set!) v i x)
+ (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))))
+
+(define (bytevector-c32-native-ref v i)
+ (make-rectangular (bytevector-ieee-single-native-ref v i)
+ (bytevector-ieee-single-native-ref v (+ i 4))))
+(define (bytevector-c32-native-set! v i x)
+ (bytevector-ieee-single-native-set! v i x)
+ (bytevector-ieee-single-native-set! v (+ i 4) x))
+(define (bytevector-c64-native-ref v i)
+ (make-rectangular (bytevector-ieee-double-native-ref v i)
+ (bytevector-ieee-double-native-ref v (+ i 8))))
+(define (bytevector-c64-native-set! v i x)
+ (bytevector-ieee-double-native-set! v i x)
+ (bytevector-ieee-double-native-set! v (+ i 8) x))
+(define-bytevector-type c32 c32-native 8)
+(define-bytevector-type c64 c64-native 16)
+
(define-macro (define-any->vector . tags)
`(begin
,@(map (lambda (tag)
diff --git a/module/system/repl/command.scm b/module/system/repl/command.scm
index 5fac6f6..721d2b3 100644
--- a/module/system/repl/command.scm
+++ b/module/system/repl/command.scm
@@ -1,6 +1,6 @@
;;; Repl commands
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -367,7 +367,7 @@ Profile execution."
;; FIXME opts
(let ((vm (repl-vm repl))
(proc (make-program (repl-compile repl (repl-parse repl form)))))
- (with-statprof #:hz 100 (vm proc))))
+ (with-statprof #:hz 100 (vm-apply vm proc '()))))
diff --git a/module/system/vm/trace.scm b/module/system/vm/trace.scm
index c260ab4..330b50f 100644
--- a/module/system/vm/trace.scm
+++ b/module/system/vm/trace.scm
@@ -1,6 +1,6 @@
;;; Guile VM tracer
-;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -28,7 +28,7 @@
(define (vm-trace vm thunk . opts)
(dynamic-wind
(lambda () (apply vm-trace-on! vm opts))
- (lambda () (vm thunk))
+ (lambda () (vm-apply vm thunk '()))
(lambda () (apply vm-trace-off! vm opts))))
(define* (vm-trace-on! vm #:key (calls? #t) (instructions? #f))
diff --git a/module/system/vm/vm.scm b/module/system/vm/vm.scm
index 76bdb57..c6e550b 100644
--- a/module/system/vm/vm.scm
+++ b/module/system/vm/vm.scm
@@ -1,6 +1,6 @@
;;; Guile VM core
-;;; Copyright (C) 2001, 2009 Free Software Foundation, Inc.
+;;; Copyright (C) 2001, 2009, 2010 Free Software Foundation, Inc.
;;;
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -21,7 +21,7 @@
(define-module (system vm vm)
#:use-module (system vm frame)
#:use-module (system vm program)
- #:export (vm? the-vm make-vm vm-version
+ #:export (vm? the-vm make-vm vm-version vm-apply
vm:ip vm:sp vm:fp vm:last-ip
vm-load vm-option set-vm-option! vm-version
@@ -37,4 +37,4 @@
(define (vms:clock stat) (vector-ref stat 1))
(define (vm-load vm objcode)
- (vm (make-program objcode)))
+ (vm-apply vm (make-program objcode) '()))
diff --git a/test-suite/tests/unif.test b/test-suite/tests/unif.test
index 4ac6204..a850dba 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, 2009 Free Software Foundation, Inc.
+;;;; Copyright 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -18,7 +18,9 @@
(define-module (test-suite test-unif)
#:use-module ((system base compile) #:select (compile))
- #:use-module (test-suite lib))
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-4)
+ #:use-module (srfi srfi-4 gnu))
;;;
;;; array?
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-6-101-gcc7005b,
Andy Wingo <=