diff options
-rw-r--r-- | NEWS | 12 | ||||
-rw-r--r-- | libguile/ChangeLog | 19 | ||||
-rw-r--r-- | libguile/gh.h | 11 | ||||
-rw-r--r-- | libguile/gh_data.c | 276 | ||||
-rw-r--r-- | libguile/numbers.c | 38 | ||||
-rw-r--r-- | libguile/numbers.h | 1 | ||||
-rw-r--r-- | libguile/unif.c | 2 |
7 files changed, 289 insertions, 70 deletions
@@ -6,6 +6,18 @@ Please send Guile bug reports to bug-guile@gnu.org. Changes since Guile 1.3: +* Changes to the gh_ interface + +** gh_scm2doubles + +Now takes a second argument which is the result array. If this +pointer is NULL, a new array is malloced (the old behaviour). + +** gh_chars2byvect, gh_shorts2svect, gh_floats2fvect, gh_scm2chars, + gh_scm2shorts, gh_scm2longs, gh_scm2floats + +New functions. + Changes in Guile 1.3 (released Monday, October 19, 1998): diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 8fe29265a..d79d45ba2 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,22 @@ +1998-10-26 Mikael Djurfeldt <mdj@barbara.nada.kth.se> + + * numbers.c (num2long): As a software archeologist, I'm proud of + this finding! :) Preliminary dating suggests an almost 4 year old + remnant from the SCM ancestor. The sample has been removed from + the finding site and is now safely stored in the repository. + + * numbers.h: Removed prototype for num2long. + + * unif.c (scm_array_set_x): Use scm_num2long instead of num2long. + + * gh_data.c (gh_scm2doubles): Make it possible to pass result + array as second arg. + (gh_chars2byvect, gh_shorts2svect, gh_floats2fvect, gh_scm2chars, + gh_scm2shorts, gh_scm2longs, gh_scm2floats): New functions. + * gh.h: Updated and added prototypes. + + * gh_data.c (gh_ints2scm): Handle integers outside INUM limits. + 1998-10-24 Jim Blandy <jimb@zwingli.cygnus.com> * gc.h: Remove all uses of SCM_P. (Thanks to Richard Polton.) diff --git a/libguile/gh.h b/libguile/gh.h index 592a36868..8a4e1caae 100644 --- a/libguile/gh.h +++ b/libguile/gh.h @@ -108,10 +108,15 @@ SCM gh_str02scm(char *s); void gh_set_substr(char *src, SCM dst, int start, int len); SCM gh_symbol2scm(char *symbol_str); SCM gh_ints2scm(int *d, int n); +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 @@ -126,7 +131,11 @@ double gh_scm2double(SCM obj); char *gh_scm2newstr(SCM str, int *lenp); void gh_get_substr(SCM src, char *dst, int start, int len); char *gh_symbol2newstr(SCM sym, int *lenp); -double *gh_scm2doubles(SCM vector); +char *gh_scm2chars(SCM vector, char *result); +short *gh_scm2shorts(SCM vector, short *result); +long *gh_scm2longs(SCM vector, long *result); +float *gh_scm2floats(SCM vector, float *result); +double *gh_scm2doubles(SCM vector, double *result); /* type predicates: tell you if an SCM object has a given type */ int gh_boolean_p(SCM val); diff --git a/libguile/gh_data.c b/libguile/gh_data.c index c625185bd..8a100ecda 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -143,18 +143,42 @@ gh_ints2scm (int *d, int n) { SCM *m; int i; - for (i = 0; i < n; ++i) - SCM_ASSERT (d[i] >= SCM_INUM (LONG_MIN) && d[i] <= SCM_INUM (LONG_MAX), - SCM_MAKINUM (d[i]), - SCM_OUTOFRANGE, - "gh_ints2scm"); m = (SCM*) scm_must_malloc (n * sizeof (SCM), "vector"); for (i = 0; i < n; ++i) - m[i] = SCM_MAKINUM (d[i]); + m[i] = (d[i] >= SCM_MOST_NEGATIVE_FIXNUM + && d[i] <= SCM_MOST_POSITIVE_FIXNUM + ? SCM_MAKINUM (d[i]) + : scm_long2big (d[i])); + return makvect ((char *) m, n, scm_tc7_vector); +} + +SCM +gh_doubles2scm (double *d, int n) +{ + SCM *m = (SCM*) scm_must_malloc (n * sizeof (SCM), "vector"); + int i; + for (i = 0; i < n; ++i) + m[i] = scm_makdbl (d[i], 0.0); return makvect ((char *) m, n, scm_tc7_vector); } SCM +gh_chars2byvect (char *d, int n) +{ + char *m = scm_must_malloc (n * sizeof (char), "vector"); + memcpy (m, d, n * sizeof (char)); + return makvect (m, n, scm_tc7_byvect); +} + +SCM +gh_shorts2svect (short *d, int n) +{ + char *m = scm_must_malloc (n * sizeof (short), "vector"); + memcpy (m, d, n * sizeof (short)); + return makvect (m, n, scm_tc7_svect); +} + +SCM gh_longs2ivect (long *d, int n) { char *m = scm_must_malloc (n * sizeof (long), "vector"); @@ -170,17 +194,17 @@ gh_ulongs2uvect (unsigned long *d, int n) return makvect (m, n, scm_tc7_uvect); } +#ifdef SCM_FLOATS +#ifdef SCM_SINGLES SCM -gh_doubles2scm (double *d, int n) +gh_floats2fvect (float *d, int n) { - SCM *m = (SCM*) scm_must_malloc (n * sizeof (SCM), "vector"); - int i; - for (i = 0; i < n; ++i) - m[i] = scm_makdbl (d[i], 0.0); - return makvect ((char *) m, n, scm_tc7_vector); + char *m = scm_must_malloc (n * sizeof (float), "vector"); + memcpy (m, d, n * sizeof (float)); + return makvect (m, n, scm_tc7_fvect); } +#endif -#ifdef SCM_FLOATS SCM gh_doubles2dvect (double *d, int n) { @@ -223,13 +247,14 @@ gh_scm2char (SCM obj) return SCM_ICHR (obj); } -/* Convert a vector, weak vector or uniform vector into a malloced - array of doubles. */ -double* -gh_scm2doubles (SCM obj) +/* Convert a vector, weak vector, string, substring or uniform vector + into an array of chars. If result array in arg 2 is NULL, malloc a + new one. */ +char * +gh_scm2chars (SCM obj, char *m) { int i, n; - double *m = 0; + long v; SCM val; if (!SCM_NIMP (obj)) scm_wrong_type_arg (0, 0, obj); @@ -238,35 +263,228 @@ gh_scm2doubles (SCM obj) case scm_tc7_vector: case scm_tc7_wvect: n = SCM_LENGTH (obj); - m = (double*) malloc (n * sizeof (double)); for (i = 0; i < n; ++i) { val = SCM_VELTS (obj)[i]; if (SCM_INUMP (val)) - m[i] = SCM_INUM (val); - else if (SCM_NIMP (val) && SCM_REALP (val)) - m[i] = SCM_REALPART (val); + { + v = SCM_INUM (val); + if (v < -128 || v > 255) + scm_out_of_range (0, obj); + } else + scm_wrong_type_arg (0, 0, obj); + } + if (m == 0) + m = (char *) malloc (n * sizeof (char)); + for (i = 0; i < n; ++i) + m[i] = SCM_INUM (SCM_VELTS (obj)[i]); + break; + case scm_tc7_byvect: + case scm_tc7_string: + case scm_tc7_substring: + n = SCM_LENGTH (obj); + if (m == 0) + m = (char *) malloc (n * sizeof (char)); + memcpy (m, SCM_VELTS (obj), n * sizeof (char)); + break; + default: + scm_wrong_type_arg (0, 0, obj); + } + return m; +} + +/* Convert a vector, weak vector or uniform vector into an array of + shorts. If result array in arg 2 is NULL, malloc a new one. */ +short * +gh_scm2shorts (SCM obj, short *m) +{ + int i, n; + long v; + SCM val; + if (!SCM_NIMP (obj)) + scm_wrong_type_arg (0, 0, obj); + switch (SCM_TYP7 (obj)) + { + case scm_tc7_vector: + case scm_tc7_wvect: + n = SCM_LENGTH (obj); + for (i = 0; i < n; ++i) + { + val = SCM_VELTS (obj)[i]; + if (SCM_INUMP (val)) { - free (m); - scm_wrong_type_arg (0, 0, val); + v = SCM_INUM (val); + if (v < -32768 || v > 65535) + scm_out_of_range (0, obj); } + else + scm_wrong_type_arg (0, 0, obj); + } + if (m == 0) + m = (short *) malloc (n * sizeof (short)); + for (i = 0; i < n; ++i) + m[i] = SCM_INUM (SCM_VELTS (obj)[i]); + break; + 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; + default: + scm_wrong_type_arg (0, 0, obj); + } + return m; +} + +/* Convert a vector, weak vector or uniform vector into an array of + longs. If result array in arg 2 is NULL, malloc a new one. */ +long * +gh_scm2longs (SCM obj, long *m) +{ + int i, n; + SCM val; + if (!SCM_NIMP (obj)) + scm_wrong_type_arg (0, 0, obj); + switch (SCM_TYP7 (obj)) + { + case scm_tc7_vector: + case scm_tc7_wvect: + n = SCM_LENGTH (obj); + for (i = 0; i < n; ++i) + { + val = SCM_VELTS (obj)[i]; + if (!SCM_INUMP (val) && !(SCM_NIMP (val) && SCM_BIGP (val))) + scm_wrong_type_arg (0, 0, obj); + } + if (m == 0) + m = (long *) malloc (n * sizeof (long)); + for (i = 0; i < n; ++i) + { + val = SCM_VELTS (obj)[i]; + m[i] = SCM_INUMP (val) ? SCM_INUM (val) : scm_num2long (val, 0, 0); + } + break; + case scm_tc7_ivect: + case scm_tc7_uvect: + n = SCM_LENGTH (obj); + if (m == 0) + m = (long *) malloc (n * sizeof (long)); + memcpy (m, SCM_VELTS (obj), n * sizeof (long)); + break; + default: + scm_wrong_type_arg (0, 0, obj); + } + return m; +} + +/* Convert a vector, weak vector or uniform vector into an array of + floats. If result array in arg 2 is NULL, malloc a new one. */ +float * +gh_scm2floats (SCM obj, float *m) +{ + int i, n; + SCM val; + if (!SCM_NIMP (obj)) + scm_wrong_type_arg (0, 0, obj); + switch (SCM_TYP7 (obj)) + { + case scm_tc7_vector: + case scm_tc7_wvect: + n = SCM_LENGTH (obj); + for (i = 0; i < n; ++i) + { + val = SCM_VELTS (obj)[i]; + if (!SCM_INUMP (val) + && !(SCM_NIMP (val) && (SCM_BIGP (val) || SCM_REALP (val)))) + scm_wrong_type_arg (0, 0, val); + } + if (m == 0) + m = (float *) malloc (n * sizeof (float)); + for (i = 0; i < n; ++i) + { + val = SCM_VELTS (obj)[i]; + if (SCM_INUMP (val)) + m[i] = SCM_INUM (val); + else if (SCM_BIGP (val)) + m[i] = scm_num2long (val, 0, 0); + else + m[i] = SCM_REALPART (val); } break; #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: n = SCM_LENGTH (obj); - m = (double*) malloc (n * sizeof (double)); - for (i = 0; i < n; ++i) - m[i] = ((float*) SCM_VELTS (obj))[i]; + if (m == 0) + m = (float *) malloc (n * sizeof (float)); + memcpy (m, (float *) SCM_VELTS (obj), n * sizeof (float)); break; #endif case scm_tc7_dvect: n = SCM_LENGTH (obj); - m = (double*) malloc (n * sizeof (double)); + if (m == 0) + m = (float*) malloc (n * sizeof (float)); for (i = 0; i < n; ++i) - m[i] = ((double*) SCM_VELTS (obj))[i]; + m[i] = ((double *) SCM_VELTS (obj))[i]; + break; +#endif + default: + scm_wrong_type_arg (0, 0, obj); + } + return m; +} + +/* Convert a vector, weak vector or uniform vector into an array of + doubles. If result array in arg 2 is NULL, malloc a new one. */ +double * +gh_scm2doubles (SCM obj, double *m) +{ + int i, n; + SCM val; + if (!SCM_NIMP (obj)) + scm_wrong_type_arg (0, 0, obj); + switch (SCM_TYP7 (obj)) + { + case scm_tc7_vector: + case scm_tc7_wvect: + n = SCM_LENGTH (obj); + for (i = 0; i < n; ++i) + { + val = SCM_VELTS (obj)[i]; + if (!SCM_INUMP (val) + && !(SCM_NIMP (val) && (SCM_BIGP (val) || SCM_REALP (val)))) + scm_wrong_type_arg (0, 0, val); + } + if (m == 0) + m = (double *) malloc (n * sizeof (double)); + for (i = 0; i < n; ++i) + { + val = SCM_VELTS (obj)[i]; + if (SCM_INUMP (val)) + m[i] = SCM_INUM (val); + else if (SCM_BIGP (val)) + m[i] = scm_num2long (val, 0, 0); + else + m[i] = SCM_REALPART (val); + } + break; +#ifdef SCM_FLOATS +#ifdef SCM_SINGLES + case scm_tc7_fvect: + n = SCM_LENGTH (obj); + if (m == 0) + m = (double *) malloc (n * sizeof (double)); + for (i = 0; i < n; ++i) + m[i] = ((float *) SCM_VELTS (obj))[i]; + break; +#endif + case scm_tc7_dvect: + n = SCM_LENGTH (obj); + if (m == 0) + m = (double*) malloc (n * sizeof (double)); + memcpy (m, SCM_VELTS (obj), n * sizeof (double)); break; #endif default: diff --git a/libguile/numbers.c b/libguile/numbers.c index 6bc7fd7ab..3b35fcca8 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -3617,44 +3617,6 @@ scm_num2long(num, pos, s_caller) - - -long -num2long(num, pos, s_caller) - SCM num; - char *pos; - char *s_caller; -{ - long res; - if SCM_INUMP(num) { - res = SCM_INUM((long)num); - return res; - } - SCM_ASRTGO(SCM_NIMP(num), errout); -#ifdef SCM_FLOATS - if SCM_REALP(num) { - double u = SCM_REALPART(num); - if (((SCM_MOST_NEGATIVE_FIXNUM * 4) <= u) - && (u <= (SCM_MOST_POSITIVE_FIXNUM * 4 + 3))) { - res = u; - return res; - } - } -#endif -#ifdef SCM_BIGDIG - if SCM_BIGP(num) { - scm_sizet l = SCM_NUMDIGS(num); - SCM_ASRTGO(SCM_DIGSPERLONG >= l, errout); - res = 0; - for(;l--;) res = SCM_BIGUP(res) + SCM_BDIGITS(num)[l]; - return res; - } -#endif - errout: scm_wta(num, pos, s_caller); - return SCM_UNSPECIFIED; -} - - #ifdef LONGLONGS long_long diff --git a/libguile/numbers.h b/libguile/numbers.h index e04d5e425..16f72b4c4 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -330,7 +330,6 @@ extern SCM scm_long2num SCM_P ((long sl)); extern SCM scm_long_long2num SCM_P ((long_long sl)); extern SCM scm_ulong2num SCM_P ((unsigned long sl)); extern long scm_num2long SCM_P ((SCM num, char *pos, char *s_caller)); -extern long num2long SCM_P ((SCM num, char *pos, char *s_caller)); extern long_long scm_num2long_long SCM_P ((SCM num, char *pos, char *s_caller)); extern unsigned long scm_num2ulong SCM_P ((SCM num, char *pos, char *s_caller)); extern void scm_init_numbers SCM_P ((void)); diff --git a/libguile/unif.c b/libguile/unif.c index 736723082..23d29e3a5 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1311,7 +1311,7 @@ scm_array_set_x (v, obj, args) case scm_tc7_uvect: SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG2, s_array_set_x); break; case scm_tc7_ivect: - SCM_VELTS(v)[pos] = num2long(obj, (char *)SCM_ARG2, s_array_set_x); break; + SCM_VELTS(v)[pos] = scm_num2long(obj, (char *)SCM_ARG2, s_array_set_x); break; # endif break; |