* configure.in: add --disable-arrays option, probably temporary.
* 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.
* 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-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.
** 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
** 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
/* 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
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)
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)
+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
# 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 \
;;; {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"))
\f
;;; {Keywords}
(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")))
-
\f
;;; {Command Line Options}
;;;
+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
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 = \
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
*/
#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
\f
/* {Unsupported Options}
#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;
\f
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:
if ( scm_tc16_array
&& scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp)
return scm_array_equal_p(x, y);
+#endif
}
return SCM_BOOL_F;
}
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:
case scm_tc7_cvect:
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
+#endif
#endif
case scm_tc7_string:
case scm_tc7_substring:
sizeof (scm_contregs)) /
sizeof (SCM_STACKITEM)));
break;
+#ifdef HAVE_ARRAYS
case scm_tc7_bvect:
case scm_tc7_byvect:
case scm_tc7_ivect:
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
-
+#endif
case scm_tc7_string:
SCM_SETGC8MARK (ptr);
break;
scm_must_free (SCM_CHARS (scmptr));
/* SCM_SETCHARS(scmptr, 0);*/
break;
+#ifdef HAVE_ARRAYS
case scm_tc7_bvect:
if SCM_GC8MARKP (scmptr)
goto c8mrkcontinue;
goto c8mrkcontinue;
m += SCM_HUGE_LENGTH (scmptr) * 2 * sizeof (double);
goto freechars;
+#endif
case scm_tc7_substring:
if (SCM_GC8MARKP (scmptr))
goto c8mrkcontinue;
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);
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. */
return makvect (m, n, scm_tc7_dvect);
}
#endif
+#endif
/* data conversion scheme->C */
int
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);
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);
}
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);
m = (long *) malloc (n * sizeof (long));
memcpy (m, SCM_VELTS (obj), n * sizeof (long));
break;
+#endif
default:
scm_wrong_type_arg (0, 0, obj);
}
m[i] = SCM_REALPART (val);
}
break;
+#ifdef HAVE_ARRAYS
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect:
for (i = 0; i < n; ++i)
m[i] = ((double *) SCM_VELTS (obj))[i];
break;
+#endif
#endif
default:
scm_wrong_type_arg (0, 0, obj);
m[i] = SCM_REALPART (val);
}
break;
+#ifdef HAVE_ARRAYS
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect:
m = (double*) malloc (n * sizeof (double));
memcpy (m, SCM_VELTS (obj), n * sizeof (double));
break;
+#endif
#endif
default:
scm_wrong_type_arg (0, 0, obj);
return gh_scm2ulong (scm_vector_length (v));
}
-
+#ifdef HAVE_ARRAYS
/* uniform vector support */
/* returns the length as a C unsigned long integer */
/* sets an individual element in a uniform vector */
/* SCM */
/* gh_list_to_uniform_array ( */
-
+#endif
/* Data lookups between C and Scheme
#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 ();
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:
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:
}
EXIT_NESTED_DATA (pstate);
break;
+#ifdef HAVE_ARRAYS
case scm_tc7_bvect:
case scm_tc7_byvect:
case scm_tc7_svect:
#endif
scm_raprin1 (exp, port, pstate);
break;
+#endif
case scm_tcs_subrs:
scm_puts (SCM_SUBR_GENERIC (exp) && *SCM_SUBR_GENERIC (exp)
? "#<primitive-generic "
#include "ramap.h"
\f
-#ifdef ARRAYS
-
typedef struct
{
char *name;
#include "ramap.x"
scm_add_feature (s_array_for_each);
}
-
-#endif /* ARRAYS */
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)
{
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)
{
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
return SCM_UNSPECIFIED;
}
+#endif /* HAVE_ARRAYS */
+
SCM_PROC (s_random_exp, "random:exp", 0, 1, 0, scm_random_exp);
SCM
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));
return p;
else
goto unkshrp;
+#endif
case '{':
j = scm_read_token (c, tok_buf, port, 1);
{
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);
}
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);
}
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);
SCM_MAKINUM (len));
return sortvec;
}
+#endif
else
return scm_wta (items, (char *) SCM_ARG1, s_sort_x);
} /* scm_sort */
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;
free (temp);
return retvec;
}
+#endif
else
return scm_wta (items, (char *) SCM_ARG1, s_stable_sort);
} /* scm_stable_sort */
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);
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);
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:
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:
* 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
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
return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim);
}
-/* This must be done after scm_init_scl() */
-
void
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 */
\f
-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));
#include "vectors.h"
\f
+/*
+ * 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);
scm_init_vectors ()
{
#include "vectors.x"
+ /*
+ scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x); */
}
\f
+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));
HCoop / bpt / guile.git / commitdiff