diff options
-rw-r--r-- | ChangeLog | 6 | ||||
-rw-r--r-- | NEWS | 4 | ||||
-rw-r--r-- | acconfig.h | 3 | ||||
-rw-r--r-- | configure.in | 9 | ||||
-rw-r--r-- | ice-9/ChangeLog | 8 | ||||
-rw-r--r-- | ice-9/Makefile.am | 3 | ||||
-rw-r--r-- | ice-9/boot-9.scm | 65 | ||||
-rw-r--r-- | libguile/ChangeLog | 53 | ||||
-rw-r--r-- | libguile/Makefile.am | 7 | ||||
-rw-r--r-- | libguile/__scm.h | 12 | ||||
-rw-r--r-- | libguile/eq.c | 2 | ||||
-rw-r--r-- | libguile/eval.c | 2 | ||||
-rw-r--r-- | libguile/gc.c | 5 | ||||
-rw-r--r-- | libguile/gh.h | 5 | ||||
-rw-r--r-- | libguile/gh_data.c | 16 | ||||
-rw-r--r-- | libguile/init.c | 4 | ||||
-rw-r--r-- | libguile/objects.c | 2 | ||||
-rw-r--r-- | libguile/print.c | 2 | ||||
-rw-r--r-- | libguile/ramap.c | 4 | ||||
-rw-r--r-- | libguile/random.c | 37 | ||||
-rw-r--r-- | libguile/read.c | 2 | ||||
-rw-r--r-- | libguile/sort.c | 10 | ||||
-rw-r--r-- | libguile/tag.c | 8 | ||||
-rw-r--r-- | libguile/tags.h | 14 | ||||
-rw-r--r-- | libguile/unif.c | 121 | ||||
-rw-r--r-- | libguile/unif.h | 2 | ||||
-rw-r--r-- | libguile/vectors.c | 72 | ||||
-rw-r--r-- | libguile/vectors.h | 1 |
28 files changed, 268 insertions, 211 deletions
@@ -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. @@ -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)); |