From afe5177e7fb697041dbe8504ccb64c7df1afe2c8 Mon Sep 17 00:00:00 2001 From: Gary Houston Date: Fri, 19 Nov 1999 18:16:19 +0000 Subject: [PATCH] * acconfig.h: add HAVE_ARRAYS. * 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. --- ChangeLog | 6 +++ NEWS | 4 +- acconfig.h | 3 ++ configure.in | 9 ++++ ice-9/ChangeLog | 8 +++ ice-9/Makefile.am | 3 +- ice-9/boot-9.scm | 65 +---------------------- libguile/ChangeLog | 53 +++++++++++++++++++ libguile/Makefile.am | 7 +-- libguile/__scm.h | 12 +---- libguile/eq.c | 2 + libguile/eval.c | 2 + libguile/gc.c | 5 +- libguile/gh.h | 5 +- libguile/gh_data.c | 16 +++++- libguile/init.c | 4 +- libguile/objects.c | 2 + libguile/print.c | 2 + libguile/ramap.c | 4 -- libguile/random.c | 37 +++++++------ libguile/read.c | 2 + libguile/sort.c | 10 ++++ libguile/tag.c | 8 +++ libguile/tags.h | 14 +++-- libguile/unif.c | 121 ++++++++----------------------------------- libguile/unif.h | 2 +- libguile/vectors.c | 72 +++++++++++++++++++++++++ libguile/vectors.h | 1 + 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 + + * acconfig.h: add HAVE_ARRAYS. + + * configure.in: add --disable-arrays option, probably temporary. + 1999-11-17 Gary Houston * 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 + + * 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 * 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 + + * 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 * 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: @@ -2541,6 +2542,7 @@ dispatch: case scm_tc7_cvect: #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: +#endif #endif case scm_tc7_string: case scm_tc7_substring: 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: @@ -434,6 +443,7 @@ gh_scm2floats (SCM obj, float *m) for (i = 0; i < n; ++i) 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: @@ -491,6 +502,7 @@ gh_scm2doubles (SCM obj, double *m) 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); @@ -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) ? "# 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));