summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ChangeLog6
-rw-r--r--NEWS4
-rw-r--r--acconfig.h3
-rw-r--r--configure.in9
-rw-r--r--ice-9/ChangeLog8
-rw-r--r--ice-9/Makefile.am3
-rw-r--r--ice-9/boot-9.scm65
-rw-r--r--libguile/ChangeLog53
-rw-r--r--libguile/Makefile.am7
-rw-r--r--libguile/__scm.h12
-rw-r--r--libguile/eq.c2
-rw-r--r--libguile/eval.c2
-rw-r--r--libguile/gc.c5
-rw-r--r--libguile/gh.h5
-rw-r--r--libguile/gh_data.c16
-rw-r--r--libguile/init.c4
-rw-r--r--libguile/objects.c2
-rw-r--r--libguile/print.c2
-rw-r--r--libguile/ramap.c4
-rw-r--r--libguile/random.c37
-rw-r--r--libguile/read.c2
-rw-r--r--libguile/sort.c10
-rw-r--r--libguile/tag.c8
-rw-r--r--libguile/tags.h14
-rw-r--r--libguile/unif.c121
-rw-r--r--libguile/unif.h2
-rw-r--r--libguile/vectors.c72
-rw-r--r--libguile/vectors.h1
28 files changed, 268 insertions, 211 deletions
diff --git a/ChangeLog b/ChangeLog
index 46b9c10fc..61ace9fa5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+1999-11-19 Gary Houston <ghouston@freewire.co.uk>
+
+ * acconfig.h: add HAVE_ARRAYS.
+
+ * configure.in: add --disable-arrays option, probably temporary.
+
1999-11-17 Gary Houston <ghouston@freewire.co.uk>
* configure.in: check for hstrerror.
diff --git a/NEWS b/NEWS
index fbd02dd5d..bd3efc420 100644
--- a/NEWS
+++ b/NEWS
@@ -34,6 +34,7 @@ appropriately.
** configure has new options to remove support for certain features:
+--disable-arrays omit array and uniform array support
--disable-posix omit posix interfaces
--disable-net omit networking interfaces
--disable-regex omit regular expression interfaces
@@ -131,8 +132,7 @@ instead of 'system-error, since errno is not relevant.
** Certain gethostbyname/gethostbyaddr failures now throw errors with
specific keys instead of 'system-error. The latter is inappropriate
since errno will not have been set. The keys are:
-'dns-host-not-found, 'dns-try-again, 'dns-no-recovery and
-'dns-no-data.
+'host-not-found, 'try-again, 'no-recovery and 'no-data.
** sethostent, setnetent, setprotoent, setservent: now take an
optional argument STAYOPEN, which specifies whether the database
diff --git a/acconfig.h b/acconfig.h
index 64c4f13d0..44f90ec6c 100644
--- a/acconfig.h
+++ b/acconfig.h
@@ -116,6 +116,9 @@
/* Define if the system supports Unix-domain (file-domain) sockets. */
#undef HAVE_UNIX_DOMAIN_SOCKETS
+/* Define this if you want support for arrays and uniform arrays. */
+#undef HAVE_ARRAYS
+
/* This is included as part of a workaround for a autoheader bug. */
#undef HAVE_REGCOMP
diff --git a/configure.in b/configure.in
index 2fcacdc82..da5b01673 100644
--- a/configure.in
+++ b/configure.in
@@ -56,6 +56,10 @@ AC_ARG_ENABLE(debug-freelist,
AC_DEFINE(GUILE_DEBUG_FREELIST)
fi)
+AC_ARG_ENABLE(arrays,
+ [ --disable-arrays omit array and uniform array support],,
+ enable_arrays=yes)
+
AC_ARG_ENABLE(posix,
[ --disable-posix omit posix interfaces],,
enable_posix=yes)
@@ -75,6 +79,11 @@ AC_DEFINE(READER_EXTENSIONS)
dnl files which are destined for separate modules.
+if test "$enable_arrays" = yes; then
+ LIBOBJS="$LIBOBJS ramap.o unif.o"
+ AC_DEFINE(HAVE_ARRAYS)
+fi
+
if test "$enable_posix" = yes; then
LIBOBJS="$LIBOBJS filesys.o posix.o"
AC_DEFINE(HAVE_POSIX)
diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog
index 096ec00c6..540306a8a 100644
--- a/ice-9/ChangeLog
+++ b/ice-9/ChangeLog
@@ -1,3 +1,11 @@
+1999-11-19 Gary Houston <ghouston@freewire.co.uk>
+
+ * Makefile.am (ice9_sources): add arrays.scm.
+
+ * boot-9.scm: load arrays.scm if 'array is provided.
+
+ * arrays.scm: new file with stuff from boot-9.scm.
+
1999-11-18 Gary Houston <ghouston@freewire.co.uk>
* boot-9.scm (read-hash-extend to set up arrays): add 'l' for
diff --git a/ice-9/Makefile.am b/ice-9/Makefile.am
index 802c375d6..5397b781d 100644
--- a/ice-9/Makefile.am
+++ b/ice-9/Makefile.am
@@ -23,7 +23,8 @@ AUTOMAKE_OPTIONS = foreign
# These should be installed and distributed.
ice9_sources = \
- and-let*.scm boot-9.scm calling.scm common-list.scm debug.scm \
+ and-let*.scm arrays.scm boot-9.scm \
+ calling.scm common-list.scm debug.scm \
debugger.scm emacs.scm expect.scm format.scm \
getopt-gnu-style.scm getopt-long.scm hcons.scm lineio.scm \
ls.scm mapping.scm networking.scm \
diff --git a/ice-9/boot-9.scm b/ice-9/boot-9.scm
index c9df7265f..10d586273 100644
--- a/ice-9/boot-9.scm
+++ b/ice-9/boot-9.scm
@@ -301,27 +301,8 @@
;;; {Arrays}
;;;
-(begin
- (define uniform-vector? array?)
- (define make-uniform-vector dimensions->uniform-array)
- ; (define uniform-vector-ref array-ref)
- (define (uniform-vector-set! u i o)
- (uniform-array-set1! u o i))
- (define uniform-vector-fill! array-fill!)
- (define uniform-vector-read! uniform-array-read!)
- (define uniform-vector-write uniform-array-write)
-
- (define (make-array fill . args)
- (dimensions->uniform-array args () fill))
- (define (make-uniform-array prot . args)
- (dimensions->uniform-array args prot))
- (define (list->array ndim lst)
- (list->uniform-array ndim '() lst))
- (define (list->uniform-vector prot lst)
- (list->uniform-array 1 prot lst))
- (define (array-shape a)
- (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
- (array-dimensions a))))
+(if (provided? 'array)
+ (primitive-load-path "ice-9/arrays.scm"))
;;; {Keywords}
@@ -902,48 +883,6 @@
(read-hash-extend #\. (lambda (c port)
(eval (read port))))
-(if (provided? 'array)
- (begin
- (let ((make-array-proc (lambda (template)
- (lambda (c port)
- (read:uniform-vector template port)))))
- (for-each (lambda (char template)
- (read-hash-extend char
- (make-array-proc template)))
- '(#\b #\a #\u #\e #\s #\i #\c #\y #\h #\l)
- '(#t #\a 1 -1 1.0 1/3 0+i #\nul s l)))
- (let ((array-proc (lambda (c port)
- (read:array c port))))
- (for-each (lambda (char) (read-hash-extend char array-proc))
- '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)))))
-
-(define (read:array digit port)
- (define chr0 (char->integer #\0))
- (let ((rank (let readnum ((val (- (char->integer digit) chr0)))
- (if (char-numeric? (peek-char port))
- (readnum (+ (* 10 val)
- (- (char->integer (read-char port)) chr0)))
- val)))
- (prot (if (eq? #\( (peek-char port))
- '()
- (let ((c (read-char port)))
- (case c ((#\b) #t)
- ((#\a) #\a)
- ((#\u) 1)
- ((#\e) -1)
- ((#\s) 1.0)
- ((#\i) 1/3)
- ((#\c) 0+i)
- (else (error "read:array unknown option " c)))))))
- (if (eq? (peek-char port) #\()
- (list->uniform-array rank prot (read port))
- (error "read:array list not found"))))
-
-(define (read:uniform-vector proto port)
- (if (eq? #\( (peek-char port))
- (list->uniform-array 1 proto (read port))
- (error "read:uniform-vector list not found")))
-
;;; {Command Line Options}
;;;
diff --git a/libguile/ChangeLog b/libguile/ChangeLog
index 578fec077..3177ea4b4 100644
--- a/libguile/ChangeLog
+++ b/libguile/ChangeLog
@@ -1,3 +1,56 @@
+1999-11-19 Gary Houston <ghouston@freewire.co.uk>
+
+ * the following changes allow guile to be built with the array
+ "module" omitted. some of this stuff is just tc7 type support,
+ which wouldn't be needed if uniform array types were converted
+ to smobs.
+
+ * tag.c (scm_utag_bvect ... scm_utag_cvect): don't define unless
+ HAVE_ARRAYS.
+ (scm_tag): don't check array types unless HAVE_ARRAYS.
+
+ * sort.c (scm_restricted_vector_sort_x, scm_sorted_p):
+ remove the unused array types.
+ * (scm_stable_sort, scm_sort): don't support vectors if not
+ HAVE_ARRAYS. a bit excessive.
+
+ * random.c (vector_scale, vector_sum_squares,
+ scm_random_solid_sphere_x, scm_random_hollow_sphere_x,
+ scm_random_normal_vector_x): don't define unless HAVE_ARRAYS.
+
+ * gh_data.c (makvect, gh_chars2byvect, gh_shorts2svect,
+ gh_longs2ivect, gh_ulongs2uvect, gh_floats2fvect, gh_doubles2dvect,
+ gh_uniform_vector_length, gh_uniform_vector_ref):
+ don't define unless HAVE_ARRAYS.
+ (gh_scm2chars, gh_scm2shorts, gh_scm2longs, gh_scm2floats,
+ gh_scm2doubles):
+ don't check vector types if not HAVE_ARRAYS.
+
+ * eq.c (scm_equal_p), eval.c (SCM_CEVAL), print.c (scm_iprin1),
+ gc.c (scm_gc_mark, scm_gc_sweep), objects.c (scm_class_of):
+ don't support the array types unless HAVE_ARRAYS is defined.
+
+ * tags.h: make nine tc7 types conditional on HAVE_ARRAYS.
+
+ * read.c (scm_lreadr): don't check for #* unless HAVE_ARRAYS is
+ defined (this should use read-hash-extend).
+
+ * ramap.c, unif.c: don't check whether ARRAYS is defined.
+
+ * vectors.c (scm_vector_set_length_x): moved here from unif.c. call
+ scm_uniform_element_size if HAVE_ARRAYS.
+ vectors.h: prototype too.
+
+ * unif.c (scm_uniform_element_size): new procedure.
+
+ * init.c (scm_boot_guile_1): don't call scm_init_ramap or
+ scm_init_unif unless HAVE_ARRAYS is defined.
+
+ * __scm.h: don't define ARRAYS.
+
+ * Makefile.am (EXTRA_libguile_la_SOURCES): unif.c and ramap.c
+ moved here from libguile_la_SOURCES.
+
1999-11-18 Gary Houston <ghouston@freewire.co.uk>
* socket.c (scm_htons, scm_ntohs, scm_htonl, scm_ntohl): new
diff --git a/libguile/Makefile.am b/libguile/Makefile.am
index ccd61f616..4d8dc2a65 100644
--- a/libguile/Makefile.am
+++ b/libguile/Makefile.am
@@ -42,10 +42,10 @@ libguile_la_SOURCES = \
gh_predicates.c gsubr.c guardians.c hash.c hashtab.c init.c \
ioext.c keywords.c lang.c list.c load.c macros.c mallocs.c \
modules.c numbers.c objects.c objprop.c options.c pairs.c \
- ports.c print.c procprop.c procs.c ramap.c random.c read.c \
+ ports.c print.c procprop.c procs.c random.c read.c \
root.c scmsigs.c script.c simpos.c smob.c sort.c \
srcprop.c stackchk.c stacks.c stime.c strings.c strop.c strorder.c \
- strports.c struct.c symbols.c tag.c throw.c unif.c variable.c \
+ strports.c struct.c symbols.c tag.c throw.c variable.c \
vectors.c version.c vports.c weaks.c
BUILT_SOURCES = \
@@ -65,7 +65,8 @@ BUILT_SOURCES = \
EXTRA_libguile_la_SOURCES = _scm.h \
alloca.c inet_aton.c memmove.c putenv.c strerror.c \
threads.c regex-posix.c iselect.c \
- filesys.c posix.c net_db.c socket.c
+ filesys.c posix.c net_db.c socket.c \
+ ramap.c unif.c
## This is kind of nasty... there are ".c" files that we don't want to
## compile, since they are #included in threads.c. So instead we list
diff --git a/libguile/__scm.h b/libguile/__scm.h
index 1700f9fb1..0494c5286 100644
--- a/libguile/__scm.h
+++ b/libguile/__scm.h
@@ -84,13 +84,6 @@
*/
#undef ENGNOT
-/* Include support for uniform arrays?
- *
- * Possibly some of the initialization code depends on this
- * being defined, but that is a bug and should be fixed.
- */
-#define ARRAYS
-
#undef SCM_CAREFUL_INTS
/* {Unsupported Options}
@@ -111,13 +104,12 @@
#define STACK_CHECKING
#undef NO_CEVAL_STACK_CHECKING
-#undef LONGLONGS
/* Some auto-generated .h files contain unused prototypes
* that need these typedefs.
*/
-typedef long long_long;
-typedef unsigned long ulong_long;
+typedef long long long_long;
+typedef unsigned long long ulong_long;
diff --git a/libguile/eq.c b/libguile/eq.c
index 7e5ee18e1..db08c4013 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -124,6 +124,7 @@ scm_equal_p (x, y)
else
return SCM_BOOL_F;
}
+#ifdef HAVE_ARRAYS
case scm_tc7_bvect: case scm_tc7_uvect: case scm_tc7_ivect:
case scm_tc7_fvect: case scm_tc7_cvect: case scm_tc7_dvect:
case scm_tc7_svect:
@@ -134,6 +135,7 @@ scm_equal_p (x, y)
if ( scm_tc16_array
&& scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp)
return scm_array_equal_p(x, y);
+#endif
}
return SCM_BOOL_F;
}
diff --git a/libguile/eval.c b/libguile/eval.c
index b8cac1181..586c884c2 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -2531,6 +2531,7 @@ dispatch:
scm_listify (proc, SCM_UNDEFINED));
case scm_tc7_vector:
case scm_tc7_wvect:
+#ifdef HAVE_ARRAYS
case scm_tc7_bvect:
case scm_tc7_byvect:
case scm_tc7_svect:
@@ -2542,6 +2543,7 @@ dispatch:
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
+#endif
case scm_tc7_string:
case scm_tc7_substring:
case scm_tc7_smob:
diff --git a/libguile/gc.c b/libguile/gc.c
index 57fbcf5cd..9591e86ce 100644
--- a/libguile/gc.c
+++ b/libguile/gc.c
@@ -746,6 +746,7 @@ gc_mark_nimp:
sizeof (scm_contregs)) /
sizeof (SCM_STACKITEM)));
break;
+#ifdef HAVE_ARRAYS
case scm_tc7_bvect:
case scm_tc7_byvect:
case scm_tc7_ivect:
@@ -757,7 +758,7 @@ gc_mark_nimp:
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
-
+#endif
case scm_tc7_string:
SCM_SETGC8MARK (ptr);
break;
@@ -1168,6 +1169,7 @@ scm_gc_sweep ()
scm_must_free (SCM_CHARS (scmptr));
/* SCM_SETCHARS(scmptr, 0);*/
break;
+#ifdef HAVE_ARRAYS
case scm_tc7_bvect:
if SCM_GC8MARKP (scmptr)
goto c8mrkcontinue;
@@ -1211,6 +1213,7 @@ scm_gc_sweep ()
goto c8mrkcontinue;
m += SCM_HUGE_LENGTH (scmptr) * 2 * sizeof (double);
goto freechars;
+#endif
case scm_tc7_substring:
if (SCM_GC8MARKP (scmptr))
goto c8mrkcontinue;
diff --git a/libguile/gh.h b/libguile/gh.h
index bf9d7d5b1..444942a0d 100644
--- a/libguile/gh.h
+++ b/libguile/gh.h
@@ -108,18 +108,21 @@ SCM gh_str02scm(char *s);
void gh_set_substr(char *src, SCM dst, int start, int len);
SCM gh_symbol2scm(const char *symbol_str);
SCM gh_ints2scm(int *d, int n);
+
+#ifdef HAVE_ARRAYS
SCM gh_chars2byvect(char *d, int n);
SCM gh_shorts2svect(short *d, int n);
SCM gh_longs2ivect(long *d, int n);
SCM gh_ulongs2uvect(unsigned long *d, int n);
-SCM gh_doubles2scm(double *d, int n);
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
SCM gh_floats2fvect(float *d, int n);
#endif
SCM gh_doubles2dvect(double *d, int n);
#endif
+#endif
+SCM gh_doubles2scm(double *d, int n);
/* Scheme to C conversion */
int gh_scm2bool(SCM obj);
diff --git a/libguile/gh_data.c b/libguile/gh_data.c
index 805f03fa3..9c210425c 100644
--- a/libguile/gh_data.c
+++ b/libguile/gh_data.c
@@ -152,6 +152,7 @@ gh_doubles2scm (double *d, int n)
return v;
}
+#ifdef HAVE_ARRAYS
/* Do not use this function for building normal Scheme vectors, unless
you arrange for the elements to be protected from GC while you
initialize the vector. */
@@ -218,6 +219,7 @@ gh_doubles2dvect (double *d, int n)
return makvect (m, n, scm_tc7_dvect);
}
#endif
+#endif
/* data conversion scheme->C */
int
@@ -285,7 +287,9 @@ gh_scm2chars (SCM obj, char *m)
for (i = 0; i < n; ++i)
m[i] = SCM_INUM (SCM_VELTS (obj)[i]);
break;
+#ifdef HAVE_ARRAYS
case scm_tc7_byvect:
+#endif
case scm_tc7_string:
case scm_tc7_substring:
n = SCM_LENGTH (obj);
@@ -331,12 +335,14 @@ gh_scm2shorts (SCM obj, short *m)
for (i = 0; i < n; ++i)
m[i] = SCM_INUM (SCM_VELTS (obj)[i]);
break;
+#ifdef HAVE_ARRAYS
case scm_tc7_svect:
n = SCM_LENGTH (obj);
if (m == 0)
m = (short *) malloc (n * sizeof (short));
memcpy (m, SCM_VELTS (obj), n * sizeof (short));
break;
+#endif
default:
scm_wrong_type_arg (0, 0, obj);
}
@@ -371,6 +377,7 @@ gh_scm2longs (SCM obj, long *m)
m[i] = SCM_INUMP (val) ? SCM_INUM (val) : scm_num2long (val, 0, 0);
}
break;
+#ifdef HAVE_ARRAYS
case scm_tc7_ivect:
case scm_tc7_uvect:
n = SCM_LENGTH (obj);
@@ -378,6 +385,7 @@ gh_scm2longs (SCM obj, long *m)
m = (long *) malloc (n * sizeof (long));
memcpy (m, SCM_VELTS (obj), n * sizeof (long));
break;
+#endif
default:
scm_wrong_type_arg (0, 0, obj);
}
@@ -418,6 +426,7 @@ gh_scm2floats (SCM obj, float *m)
m[i] = SCM_REALPART (val);
}
break;
+#ifdef HAVE_ARRAYS
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect:
@@ -435,6 +444,7 @@ gh_scm2floats (SCM obj, float *m)
m[i] = ((double *) SCM_VELTS (obj))[i];
break;
#endif
+#endif
default:
scm_wrong_type_arg (0, 0, obj);
}
@@ -475,6 +485,7 @@ gh_scm2doubles (SCM obj, double *m)
m[i] = SCM_REALPART (val);
}
break;
+#ifdef HAVE_ARRAYS
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect:
@@ -492,6 +503,7 @@ gh_scm2doubles (SCM obj, double *m)
memcpy (m, SCM_VELTS (obj), n * sizeof (double));
break;
#endif
+#endif
default:
scm_wrong_type_arg (0, 0, obj);
}
@@ -635,7 +647,7 @@ gh_vector_length (SCM v)
return gh_scm2ulong (scm_vector_length (v));
}
-
+#ifdef HAVE_ARRAYS
/* uniform vector support */
/* returns the length as a C unsigned long integer */
@@ -657,7 +669,7 @@ gh_uniform_vector_ref (SCM v, SCM ilist)
/* sets an individual element in a uniform vector */
/* SCM */
/* gh_list_to_uniform_array ( */
-
+#endif
/* Data lookups between C and Scheme
diff --git a/libguile/init.c b/libguile/init.c
index 82e5977b0..127ca8bef 100644
--- a/libguile/init.c
+++ b/libguile/init.c
@@ -523,9 +523,11 @@ scm_boot_guile_1 (base, closure)
#ifdef DEBUG_EXTENSIONS
scm_init_debug (); /* Requires macro smobs */
#endif
- scm_init_ramap ();
scm_init_random ();
+#ifdef HAVE_ARRAYS
+ scm_init_ramap ();
scm_init_unif ();
+#endif
scm_init_simpos ();
scm_init_load_path ();
scm_init_standard_ports ();
diff --git a/libguile/objects.c b/libguile/objects.c
index 5313bc9bf..cd5c2b65c 100644
--- a/libguile/objects.c
+++ b/libguile/objects.c
@@ -116,6 +116,7 @@ scm_class_of (SCM x)
return scm_class_symbol;
case scm_tc7_vector:
case scm_tc7_wvect:
+#ifdef HAVE_ARRAYS
case scm_tc7_bvect:
case scm_tc7_byvect:
case scm_tc7_svect:
@@ -124,6 +125,7 @@ scm_class_of (SCM x)
case scm_tc7_fvect:
case scm_tc7_dvect:
case scm_tc7_cvect:
+#endif
return scm_class_vector;
case scm_tc7_string:
case scm_tc7_substring:
diff --git a/libguile/print.c b/libguile/print.c
index 15ceaf9be..ac19075b7 100644
--- a/libguile/print.c
+++ b/libguile/print.c
@@ -592,6 +592,7 @@ taloop:
}
EXIT_NESTED_DATA (pstate);
break;
+#ifdef HAVE_ARRAYS
case scm_tc7_bvect:
case scm_tc7_byvect:
case scm_tc7_svect:
@@ -605,6 +606,7 @@ taloop:
#endif
scm_raprin1 (exp, port, pstate);
break;
+#endif
case scm_tcs_subrs:
scm_puts (SCM_SUBR_GENERIC (exp) && *SCM_SUBR_GENERIC (exp)
? "#<primitive-generic "
diff --git a/libguile/ramap.c b/libguile/ramap.c
index d0957c964..68ecac65d 100644
--- a/libguile/ramap.c
+++ b/libguile/ramap.c
@@ -55,8 +55,6 @@
#include "ramap.h"
-#ifdef ARRAYS
-
typedef struct
{
char *name;
@@ -2174,5 +2172,3 @@ scm_init_ramap ()
#include "ramap.x"
scm_add_feature (s_array_for_each);
}
-
-#endif /* ARRAYS */
diff --git a/libguile/random.c b/libguile/random.c
index c45a01ea8..de4c6a797 100644
--- a/libguile/random.c
+++ b/libguile/random.c
@@ -411,6 +411,22 @@ scm_random_uniform (SCM state)
return scm_makdbl (scm_c_uniform01 (SCM_RSTATE (state)), 0.0);
}
+SCM_PROC (s_random_normal, "random:normal", 0, 1, 0, scm_random_normal);
+
+SCM
+scm_random_normal (SCM state)
+{
+ if (SCM_UNBNDP (state))
+ state = SCM_CDR (scm_var_random_state);
+ SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state),
+ state,
+ SCM_ARG1,
+ s_random_normal);
+ return scm_makdbl (scm_c_normal01 (SCM_RSTATE (state)), 0.0);
+}
+
+#ifdef HAVE_ARRAYS
+
static void
vector_scale (SCM v, double c)
{
@@ -443,13 +459,13 @@ vector_sum_squares (SCM v)
return sum;
}
-SCM_PROC (s_random_solid_sphere_x, "random:solid-sphere!", 1, 1, 0, scm_random_solid_sphere_x);
-
/* For the uniform distribution on the solid sphere, note that in
* this distribution the length r of the vector has cumulative
* distribution r^n; i.e., u=r^n is uniform [0,1], so r can be
* generated as r=u^(1/n).
*/
+SCM_PROC (s_random_solid_sphere_x, "random:solid-sphere!", 1, 1, 0, scm_random_solid_sphere_x);
+
SCM
scm_random_solid_sphere_x (SCM v, SCM state)
{
@@ -488,21 +504,6 @@ scm_random_hollow_sphere_x (SCM v, SCM state)
vector_scale (v, 1 / sqrt (vector_sum_squares (v)));
return SCM_UNSPECIFIED;
}
-
-SCM_PROC (s_random_normal, "random:normal", 0, 1, 0, scm_random_normal);
-
-SCM
-scm_random_normal (SCM state)
-{
- if (SCM_UNBNDP (state))
- state = SCM_CDR (scm_var_random_state);
- SCM_ASSERT (SCM_NIMP (state) && SCM_RSTATEP (state),
- state,
- SCM_ARG1,
- s_random_normal);
- return scm_makdbl (scm_c_normal01 (SCM_RSTATE (state)), 0.0);
-}
-
SCM_PROC (s_random_normal_vector_x, "random:normal-vector!", 1, 1, 0, scm_random_normal_vector_x);
SCM
@@ -528,6 +529,8 @@ scm_random_normal_vector_x (SCM v, SCM state)
return SCM_UNSPECIFIED;
}
+#endif /* HAVE_ARRAYS */
+
SCM_PROC (s_random_exp, "random:exp", 0, 1, 0, scm_random_exp);
SCM
diff --git a/libguile/read.c b/libguile/read.c
index a26a74dae..51e197d03 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -366,6 +366,7 @@ tryagain_no_flush_ws:
c = scm_flush_ws (port, (char *)NULL);
goto tryagain_no_flush_ws;
+#ifdef HAVE_ARRAYS
case '*':
j = scm_read_token (c, tok_buf, port, 0);
p = scm_istr2bve (SCM_CHARS (*tok_buf) + 1, (long) (j - 1));
@@ -373,6 +374,7 @@ tryagain_no_flush_ws:
return p;
else
goto unkshrp;
+#endif
case '{':
j = scm_read_token (c, tok_buf, port, 1);
diff --git a/libguile/sort.c b/libguile/sort.c
index aab0f842f..382fd7409 100644
--- a/libguile/sort.c
+++ b/libguile/sort.c
@@ -422,10 +422,12 @@ scm_restricted_vector_sort_x (SCM vec, SCM less, SCM startpos, SCM endpos)
{
case scm_tc7_vector: /* the only type we manage is vector */
break;
+#if 0 /* HAVE_ARRAYS */
case scm_tc7_ivect: /* long */
case scm_tc7_uvect: /* unsigned */
case scm_tc7_fvect: /* float */
case scm_tc7_dvect: /* double */
+#endif
default:
scm_wta (vec, (char *) SCM_ARG1, s_restricted_vector_sort_x);
}
@@ -510,10 +512,12 @@ scm_sorted_p (SCM items, SCM less)
return SCM_BOOL_T;
}
break;
+#if 0 /* HAVE_ARRAYS */
case scm_tc7_ivect: /* long */
case scm_tc7_uvect: /* unsigned */
case scm_tc7_fvect: /* float */
case scm_tc7_dvect: /* double */
+#endif
default:
scm_wta (items, (char *) SCM_ARG1, s_sorted_p);
}
@@ -755,6 +759,8 @@ scm_sort (SCM items, SCM less)
items = scm_list_copy (items);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
}
+#ifdef HAVE_ARRAYS
+ /* support ordinary vectors even if arrays not available? */
else if (SCM_VECTORP (items))
{
len = SCM_LENGTH (items);
@@ -766,6 +772,7 @@ scm_sort (SCM items, SCM less)
SCM_MAKINUM (len));
return sortvec;
}
+#endif
else
return scm_wta (items, (char *) SCM_ARG1, s_sort_x);
} /* scm_sort */
@@ -878,6 +885,8 @@ scm_stable_sort (SCM items, SCM less)
items = scm_list_copy (items);
return scm_merge_list_step (&items, scm_cmp_function (less), less, len);
}
+#ifdef HAVE_ARRAYS
+ /* support ordinary vectors even if arrays not available? */
else if (SCM_VECTORP (items))
{
SCM retvec;
@@ -896,6 +905,7 @@ scm_stable_sort (SCM items, SCM less)
free (temp);
return retvec;
}
+#endif
else
return scm_wta (items, (char *) SCM_ARG1, s_stable_sort);
} /* scm_stable_sort */
diff --git a/libguile/tag.c b/libguile/tag.c
index 48e732256..d9ba82d91 100644
--- a/libguile/tag.c
+++ b/libguile/tag.c
@@ -54,6 +54,8 @@ SCM_CONST_LONG (scm_utag_closure, "utag_closure", 3);
SCM_CONST_LONG (scm_utag_symbol, "utag_symbol", 4);
SCM_CONST_LONG (scm_utag_vector, "utag_vector", 5);
SCM_CONST_LONG (scm_utag_wvect, "utag_wvect", 6);
+
+#ifdef HAVE_ARRAYS
SCM_CONST_LONG (scm_utag_bvect, "utag_bvect", 7);
SCM_CONST_LONG (scm_utag_byvect, "utag_byvect", 8);
SCM_CONST_LONG (scm_utag_svect, "utag_svect", 9);
@@ -62,6 +64,8 @@ SCM_CONST_LONG (scm_utag_uvect, "utag_uvect", 11);
SCM_CONST_LONG (scm_utag_fvect, "utag_fvect", 12);
SCM_CONST_LONG (scm_utag_dvect, "utag_dvect", 13);
SCM_CONST_LONG (scm_utag_cvect, "utag_cvect", 14);
+#endif
+
SCM_CONST_LONG (scm_utag_string, "utag_string", 15);
SCM_CONST_LONG (scm_utag_substring, "utag_substring", 17);
SCM_CONST_LONG (scm_utag_asubr, "utag_asubr", 19);
@@ -116,6 +120,8 @@ scm_tag (x)
return SCM_CDR (scm_utag_vector) ;
case scm_tc7_wvect:
return SCM_CDR (scm_utag_wvect) ;
+
+#ifdef HAVE_ARRAYS
case scm_tc7_bvect:
return SCM_CDR (scm_utag_bvect) ;
case scm_tc7_byvect:
@@ -132,6 +138,8 @@ scm_tag (x)
return SCM_CDR (scm_utag_dvect) ;
case scm_tc7_cvect:
return SCM_CDR (scm_utag_cvect) ;
+#endif
+
case scm_tc7_string:
return SCM_CDR (scm_utag_string) ;
case scm_tc7_substring:
diff --git a/libguile/tags.h b/libguile/tags.h
index a9b9acb73..306157888 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -337,20 +337,24 @@ typedef long SCM;
* into structs or smobs. We need back some
* of these 7 bit tags!
*/
-#define scm_tc7_llvect 29
#define scm_tc7_pws 31
-#define scm_tc7_uvect 37
#define scm_tc7_lvector 39
+
+#ifdef HAVE_ARRAYS
+#define scm_tc7_llvect 29
+#define scm_tc7_uvect 37
#define scm_tc7_fvect 45
#define scm_tc7_dvect 47
#define scm_tc7_cvect 53
#define scm_tc7_svect 55
-#define scm_tc7_contin 61
-#define scm_tc7_cclo 63
-#define scm_tc7_rpsubr 69
#define scm_tc7_bvect 71
#define scm_tc7_byvect 77
#define scm_tc7_ivect 79
+#endif
+
+#define scm_tc7_contin 61
+#define scm_tc7_cclo 63
+#define scm_tc7_rpsubr 69
#define scm_tc7_subr_0 85
#define scm_tc7_subr_1 87
#define scm_tc7_cxr 93
diff --git a/libguile/unif.c b/libguile/unif.c
index e1d934c39..d311c54b7 100644
--- a/libguile/unif.c
+++ b/libguile/unif.c
@@ -73,105 +73,58 @@
long scm_tc16_array;
-/*
- * This complicates things too much if allowed on any array.
- * C code can safely call it on arrays known to be used in a single
- * threaded manner.
- *
- * SCM_PROC(s_vector_set_length_x, "vector-set-length!", 2, 0, 0, scm_vector_set_length_x);
- */
-static char s_vector_set_length_x[] = "vector-set-length!";
-
-
-SCM
-scm_vector_set_length_x (vect, len)
- SCM vect;
- SCM len;
+/* return the size of an element in a uniform array or 0 if type not
+ found. */
+scm_sizet
+scm_uniform_element_size (SCM obj)
{
- long l;
- scm_sizet siz;
- scm_sizet sz;
+ scm_sizet result;
- l = SCM_INUM (len);
- SCM_ASRTGO (SCM_NIMP (vect), badarg1);
- switch (SCM_TYP7 (vect))
+ switch (SCM_TYP7 (obj))
{
- default:
- badarg1: scm_wta (vect, (char *) SCM_ARG1, s_vector_set_length_x);
- case scm_tc7_string:
- SCM_ASRTGO (vect != scm_nullstr, badarg1);
- sz = sizeof (char);
- l++;
- break;
- case scm_tc7_vector:
- case scm_tc7_wvect:
- SCM_ASRTGO (vect != scm_nullvect, badarg1);
- sz = sizeof (SCM);
- break;
-#ifdef ARRAYS
case scm_tc7_bvect:
- l = (l + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
case scm_tc7_uvect:
case scm_tc7_ivect:
- sz = sizeof (long);
+ result = sizeof (long);
break;
+
case scm_tc7_byvect:
- sz = sizeof (char);
+ result = sizeof (char);
break;
case scm_tc7_svect:
- sz = sizeof (short);
+ result = sizeof (short);
break;
+
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
- sz = sizeof (long_long);
+ result = sizeof (long_long);
break;
#endif
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect:
- sz = sizeof (float);
+ result = sizeof (float);
break;
#endif
+
case scm_tc7_dvect:
- sz = sizeof (double);
+ result = sizeof (double);
break;
+
case scm_tc7_cvect:
- sz = 2 * sizeof (double);
+ result = 2 * sizeof (double);
break;
#endif
-#endif
+
+ default:
+ result = 0;
}
- SCM_ASSERT (SCM_INUMP (len), len, SCM_ARG2, s_vector_set_length_x);
- if (!l)
- l = 1L;
- siz = l * sz;
- if (siz != l * sz)
- scm_wta (SCM_MAKINUM (l * sz), (char *) SCM_NALLOC, s_vector_set_length_x);
- SCM_REDEFER_INTS;
- SCM_SETCHARS (vect,
- ((char *)
- scm_must_realloc (SCM_CHARS (vect),
- (long) SCM_LENGTH (vect) * sz,
- (long) siz,
- s_vector_set_length_x)));
- if (SCM_VECTORP (vect))
- {
- sz = SCM_LENGTH (vect);
- while (l > sz)
- SCM_VELTS (vect)[--l] = SCM_UNSPECIFIED;
- }
- else if (SCM_STRINGP (vect))
- SCM_CHARS (vect)[l - 1] = 0;
- SCM_SETLENGTH (vect, SCM_INUM (len), SCM_TYP7 (vect));
- SCM_REALLOW_INTS;
- return vect;
+ return result;
}
-#ifdef ARRAYS
-
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
@@ -2568,8 +2521,6 @@ freera (ptr)
return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim);
}
-/* This must be done after scm_init_scl() */
-
void
scm_init_unif ()
{
@@ -2581,33 +2532,3 @@ scm_init_unif ()
scm_add_feature ("array");
#include "unif.x"
}
-
-#else /* ARRAYS */
-
-
-int
-scm_raprin1 (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
-{
- return 0;
-}
-
-
-SCM
-scm_istr2bve (str, len)
- char *str;
- long len;
-{
- return SCM_BOOL_F;
-}
-
-void
-scm_init_unif ()
-{
-#include "unif.x"
- scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x);
-}
-
-#endif /* ARRAYS */
diff --git a/libguile/unif.h b/libguile/unif.h
index 29b2fadce..83b020fbc 100644
--- a/libguile/unif.h
+++ b/libguile/unif.h
@@ -74,7 +74,7 @@ extern long scm_tc16_array;
-extern SCM scm_vector_set_length_x SCM_P ((SCM vect, SCM len));
+extern scm_sizet scm_uniform_element_size (SCM obj);
extern SCM scm_makflo SCM_P ((float x));
extern SCM scm_make_uve SCM_P ((long k, SCM prot));
extern SCM scm_uniform_vector_length SCM_P ((SCM v));
diff --git a/libguile/vectors.c b/libguile/vectors.c
index cdd7a60c9..079e056f2 100644
--- a/libguile/vectors.c
+++ b/libguile/vectors.c
@@ -47,6 +47,76 @@
#include "vectors.h"
+/*
+ * This complicates things too much if allowed on any array.
+ * C code can safely call it on arrays known to be used in a single
+ * threaded manner.
+ *
+ * SCM_PROC(s_vector_set_length_x, "vector-set-length!", 2, 0, 0, scm_vector_set_length_x);
+ */
+static char s_vector_set_length_x[] = "vector-set-length!";
+
+
+SCM
+scm_vector_set_length_x (vect, len)
+ SCM vect;
+ SCM len;
+{
+ long l;
+ scm_sizet siz;
+ scm_sizet sz;
+
+ l = SCM_INUM (len);
+ SCM_ASRTGO (SCM_NIMP (vect), badarg1);
+
+#ifdef HAVE_ARRAYS
+ if (SCM_TYP7 (vect) == scm_tc7_bvect)
+ {
+ l = (l + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
+ }
+ sz = scm_uniform_element_size (vect);
+ if (sz == 0)
+#endif
+ switch (SCM_TYP7 (vect))
+ {
+ default:
+ badarg1: scm_wta (vect, (char *) SCM_ARG1, s_vector_set_length_x);
+ case scm_tc7_string:
+ SCM_ASRTGO (vect != scm_nullstr, badarg1);
+ sz = sizeof (char);
+ l++;
+ break;
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ SCM_ASRTGO (vect != scm_nullvect, badarg1);
+ sz = sizeof (SCM);
+ break;
+ }
+ SCM_ASSERT (SCM_INUMP (len), len, SCM_ARG2, s_vector_set_length_x);
+ if (!l)
+ l = 1L;
+ siz = l * sz;
+ if (siz != l * sz)
+ scm_wta (SCM_MAKINUM (l * sz), (char *) SCM_NALLOC, s_vector_set_length_x);
+ SCM_REDEFER_INTS;
+ SCM_SETCHARS (vect,
+ ((char *)
+ scm_must_realloc (SCM_CHARS (vect),
+ (long) SCM_LENGTH (vect) * sz,
+ (long) siz,
+ s_vector_set_length_x)));
+ if (SCM_VECTORP (vect))
+ {
+ sz = SCM_LENGTH (vect);
+ while (l > sz)
+ SCM_VELTS (vect)[--l] = SCM_UNSPECIFIED;
+ }
+ else if (SCM_STRINGP (vect))
+ SCM_CHARS (vect)[l - 1] = 0;
+ SCM_SETLENGTH (vect, SCM_INUM (len), SCM_TYP7 (vect));
+ SCM_REALLOW_INTS;
+ return vect;
+}
SCM_PROC(s_vector_p, "vector?", 1, 0, 0, scm_vector_p);
@@ -263,5 +333,7 @@ void
scm_init_vectors ()
{
#include "vectors.x"
+ /*
+ scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x); */
}
diff --git a/libguile/vectors.h b/libguile/vectors.h
index b33a592db..b834f9fe9 100644
--- a/libguile/vectors.h
+++ b/libguile/vectors.h
@@ -55,6 +55,7 @@
+extern SCM scm_vector_set_length_x SCM_P ((SCM vect, SCM len));
extern SCM scm_vector_p SCM_P ((SCM x));
extern SCM scm_vector_length SCM_P ((SCM v));
extern SCM scm_vector SCM_P ((SCM l));