mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 16:20:17 +02:00
Code Activity

* __scm.h eq.c, eval.c, gc.c, hc.h, gh_data, hash.c, numbers.c,

Browse source 
numbers.h, objects.c, ramap.c, random.c, unif.c, unif.h: Extensive
rewrite of handling of real and complex numbers.
(SCM_FLOATS, SCM_SINGLES): These #ifdef conditionals have been
removed along with the support for floats.  (Float vectors are
still supported.)
This commit is contained in:
Mikael Djurfeldt 2000-03-14 06:43:03 +00:00
parent bc86da5de2
commit 950cc72b8f
8 changed files with 116 additions and 145 deletions
Download patch file Download diff file Expand all files Collapse all files

3
libguile/__scm.h
View file

@ -48,7 +48,7 @@
* These may be defined or undefined. * These may be defined or undefined.
*/ */
/* #define GUILE_DEBUG_FREELIST */ #define GUILE_DEBUG_FREELIST
/* If the compile FLAG `SCM_CAUTIOUS' is #defined then the number of /* If the compile FLAG `SCM_CAUTIOUS' is #defined then the number of
* arguments is always checked for application of closures. If the * arguments is always checked for application of closures. If the
@ -69,7 +69,6 @@
/* All the number support there is. /* All the number support there is.
*/ */
#define SCM_FLOATS
#define BIGNUMS #define BIGNUMS
/* GC should relinquish empty cons-pair arenas. /* GC should relinquish empty cons-pair arenas.

153
libguile/eq.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. /* Copyright (C) 1995,1996,1997,1998, 2000 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by * it under the terms of the GNU General Public License as published by
@ -76,21 +76,39 @@ SCM_DEFINE1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
"immediate integers, characters, and inexact numbers.\n") "immediate integers, characters, and inexact numbers.\n")
#define FUNC_NAME s_scm_eqv_p #define FUNC_NAME s_scm_eqv_p
{ {
if (x==y) return SCM_BOOL_T; if (x == y)
if (SCM_IMP(x)) return SCM_BOOL_F;
if (SCM_IMP(y)) return SCM_BOOL_F;
/* this ensures that types and scm_length are the same. */
if (SCM_CAR(x) != SCM_CAR(y)) return SCM_BOOL_F;
if (SCM_NUMP(x)) {
# ifdef SCM_BIGDIG
if (SCM_BIGP(x)) return SCM_BOOL(0==scm_bigcomp(x, y));
# endif
#ifdef SCM_FLOATS
if (SCM_REALPART(x) != SCM_REALPART(y)) return SCM_BOOL_F;
if (SCM_CPLXP(x) && (SCM_IMAG(x) != SCM_IMAG(y))) return SCM_BOOL_F;
#endif
return SCM_BOOL_T; return SCM_BOOL_T;
} if (SCM_IMP (x))
return SCM_BOOL_F;
if (SCM_IMP (y))
return SCM_BOOL_F;
/* this ensures that types and scm_length are the same. */
if (SCM_CAR (x) != SCM_CAR (y))
{
/* treat mixes of real and complex types specially */
if (SCM_SLOPPY_INEXACTP (x))
{
if (SCM_SLOPPY_REALP (x))
return SCM_BOOL (SCM_SLOPPY_COMPLEXP (y)
&& SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y)
&& 0.0 == SCM_COMPLEX_IMAG (y));
else
return SCM_BOOL (SCM_SLOPPY_REALP (y)
&& SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y)
&& SCM_COMPLEX_IMAG (x) == 0.0);
}
return SCM_BOOL_F;
}
if (SCM_NUMP (x))
{
# ifdef SCM_BIGDIG
if (SCM_BIGP (x))
return SCM_BOOL (0 == scm_bigcomp (x, y));
# endif
if (SCM_REALPART (x) != SCM_REALPART(y)) return SCM_BOOL_F;
if (SCM_CPLXP(x) && (SCM_IMAG(x) != SCM_IMAG(y))) return SCM_BOOL_F;
return SCM_BOOL_T;
}
return SCM_BOOL_F; return SCM_BOOL_F;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -107,48 +125,71 @@ SCM_DEFINE1 (scm_equal_p, "equal?", scm_tc7_rpsubr,
#define FUNC_NAME s_scm_equal_p #define FUNC_NAME s_scm_equal_p
{ {
SCM_CHECK_STACK; SCM_CHECK_STACK;
tailrecurse: SCM_TICK; tailrecurse:
if (x==y) return SCM_BOOL_T; SCM_TICK;
if (SCM_IMP(x)) return SCM_BOOL_F; if (x == y)
if (SCM_IMP(y)) return SCM_BOOL_F; return SCM_BOOL_T;
if (SCM_CONSP(x) && SCM_CONSP(y)) { if (SCM_IMP (x))
if SCM_FALSEP(scm_equal_p(SCM_CAR(x), SCM_CAR(y))) return SCM_BOOL_F; return SCM_BOOL_F;
x = SCM_CDR(x); if (SCM_IMP (y))
y = SCM_CDR(y); return SCM_BOOL_F;
goto tailrecurse; if (SCM_SLOPPY_CONSP (x) && SCM_SLOPPY_CONSP (y))
} {
if (SCM_TYP7S (x) == scm_tc7_string if (SCM_FALSEP (scm_equal_p (SCM_CAR (x), SCM_CAR (y))))
&& SCM_TYP7S (y) == scm_tc7_string)
return scm_string_equal_p (x, y);
/* This ensures that types and scm_length are the same. */
if (SCM_CAR(x) != SCM_CAR(y)) return SCM_BOOL_F;
switch (SCM_TYP7(x)) {
default: return SCM_BOOL_F;
case scm_tc7_vector:
case scm_tc7_wvect:
return scm_vector_equal_p(x, y);
case scm_tc7_smob: {
int i = SCM_SMOBNUM(x);
if (!(i < scm_numsmob)) return SCM_BOOL_F;
if (scm_smobs[i].equalp)
return (scm_smobs[i].equalp)(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:
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
case scm_tc7_byvect:
if ( scm_tc16_array
&& scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp)
return scm_array_equal_p(x, y);
#endif
}
return SCM_BOOL_F; return SCM_BOOL_F;
x = SCM_CDR(x);
y = SCM_CDR(y);
goto tailrecurse;
}
if (SCM_TYP7S (x) == scm_tc7_string && SCM_TYP7S (y) == scm_tc7_string)
return scm_string_equal_p (x, y);
/* This ensures that types and scm_length are the same. */
if (SCM_CAR (x) != SCM_CAR (y))
{
/* treat mixes of real and complex types specially */
if (SCM_SLOPPY_INEXACTP (x))
{
if (SCM_SLOPPY_REALP (x))
return SCM_BOOL (SCM_SLOPPY_COMPLEXP (y)
&& SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y)
&& 0.0 == SCM_COMPLEX_IMAG (y));
else
return SCM_BOOL (SCM_SLOPPY_REALP (y)
&& SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y)
&& SCM_COMPLEX_IMAG (x) == 0.0);
}
return SCM_BOOL_F;
}
switch (SCM_TYP7 (x))
{
default:
return SCM_BOOL_F;
case scm_tc7_vector:
case scm_tc7_wvect:
return scm_vector_equal_p (x, y);
case scm_tc7_smob:
{
int i = SCM_SMOBNUM (x);
if (!(i < scm_numsmob))
return SCM_BOOL_F;
if (scm_smobs[i].equalp)
return (scm_smobs[i].equalp) (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:
#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
case scm_tc7_byvect:
if (scm_tc16_array && scm_smobs[0x0ff & (scm_tc16_array >> 8)].equalp)
return scm_array_equal_p (x, y);
#endif
}
return SCM_BOOL_F;
} }
#undef FUNC_NAME #undef FUNC_NAME

8
libguile/eval.c
View file

@ -1786,11 +1786,7 @@ scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
*/ */
#ifndef DEVAL #ifndef DEVAL
#ifdef SCM_FLOATS
#define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B))))) #define CHECK_EQVISH(A,B) (((A) == (B)) || (SCM_NFALSEP (scm_eqv_p ((A), (B)))))
#else
#define CHECK_EQVISH(A,B) ((A) == (B))
#endif
#endif /* DEVAL */ #endif /* DEVAL */
#define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */ #define BUILTIN_RPASUBR /* Handle rpsubrs and asubrs without calling apply */
@ -2736,7 +2732,6 @@ evapply:
case scm_tc7_subr_1o: case scm_tc7_subr_1o:
RETURN (SCM_SUBRF (proc) (t.arg1)); RETURN (SCM_SUBRF (proc) (t.arg1));
case scm_tc7_cxr: case scm_tc7_cxr:
#ifdef SCM_FLOATS
if (SCM_SUBRF (proc)) if (SCM_SUBRF (proc))
{ {
if (SCM_INUMP (t.arg1)) if (SCM_INUMP (t.arg1))
@ -2759,7 +2754,6 @@ evapply:
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), t.arg1, SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), t.arg1,
SCM_ARG1, SCM_CHARS (SCM_SNAME (proc))); SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
} }
#endif
proc = (SCM) SCM_SNAME (proc); proc = (SCM) SCM_SNAME (proc);
{ {
char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1; char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1;
@ -3332,7 +3326,6 @@ tail:
RETURN (SCM_SUBRF (proc) (arg1)) RETURN (SCM_SUBRF (proc) (arg1))
case scm_tc7_cxr: case scm_tc7_cxr:
SCM_ASRTGO (SCM_NULLP (args), wrongnumargs); SCM_ASRTGO (SCM_NULLP (args), wrongnumargs);
#ifdef SCM_FLOATS
if (SCM_SUBRF (proc)) if (SCM_SUBRF (proc))
{ {
if (SCM_INUMP (arg1)) if (SCM_INUMP (arg1))
@ -3352,7 +3345,6 @@ tail:
SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
SCM_ARG1, SCM_CHARS (SCM_SNAME (proc))); SCM_ARG1, SCM_CHARS (SCM_SNAME (proc)));
} }
#endif
proc = (SCM) SCM_SNAME (proc); proc = (SCM) SCM_SNAME (proc);
{ {
char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1; char *chrs = SCM_CHARS (proc) + SCM_LENGTH (proc) - 1;

11
libguile/hash.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc. /* Copyright (C) 1995,1996,1997, 2000 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by * it under the terms of the GNU General Public License as published by
@ -94,13 +94,12 @@ scm_hasher(SCM obj, unsigned long n, scm_sizet d)
return 263 % n; return 263 % n;
case scm_tc7_smob: case scm_tc7_smob:
switch SCM_TYP16(obj) { switch SCM_TYP16(obj) {
case scm_tcs_bignums: case scm_tc16_big:
return SCM_INUM(scm_modulo(obj, SCM_MAKINUM(n))); return SCM_INUM(scm_modulo(obj, SCM_MAKINUM(n)));
default: default:
return 263 % n; return 263 % n;
#ifdef SCM_FLOATS case scm_tc16_real:
case scm_tc16_flo: {
if SCM_REALP(obj) {
double r = SCM_REALPART(obj); double r = SCM_REALPART(obj);
if (floor(r)==r) { if (floor(r)==r) {
obj = scm_inexact_to_exact (obj); obj = scm_inexact_to_exact (obj);
@ -108,8 +107,8 @@ scm_hasher(SCM obj, unsigned long n, scm_sizet d)
return SCM_INUM(scm_modulo(obj, SCM_MAKINUM(n))); return SCM_INUM(scm_modulo(obj, SCM_MAKINUM(n)));
} }
} }
case scm_tc16_complex:
obj = scm_number_to_string(obj, SCM_MAKINUM(10)); obj = scm_number_to_string(obj, SCM_MAKINUM(10));
#endif
} }
case scm_tcs_symbols: case scm_tcs_symbols:
case scm_tc7_string: case scm_tc7_string:

11
libguile/objects.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995, 1996, 1999 Free Software Foundation, Inc. /* Copyright (C) 1995, 1996, 1999, 2000 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by * it under the terms of the GNU General Public License as published by
@ -158,14 +158,7 @@ scm_class_of (SCM x)
case scm_tc7_smob: case scm_tc7_smob:
{ {
long type = SCM_TYP16 (x); long type = SCM_TYP16 (x);
if (type == scm_tc16_flo) if (type != scm_tc16_port_with_ps)
{
if (SCM_UNPACK_CAR (x) & SCM_IMAG_PART)
return scm_class_complex;
else
return scm_class_real;
}
else if (type != scm_tc16_port_with_ps)
return scm_smob_class[SCM_TC2SMOBNUM (type)]; return scm_smob_class[SCM_TC2SMOBNUM (type)];
x = SCM_PORT_WITH_PS_PORT (x); x = SCM_PORT_WITH_PS_PORT (x);
/* fall through to ports */ /* fall through to ports */

68
libguile/ramap.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1996, 1998 Free Software Foundation, Inc. /* Copyright (C) 1996, 1998, 2000 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by * it under the terms of the GNU General Public License as published by
@ -579,8 +579,6 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore)
break; break;
} }
#endif #endif
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
{ /* scope */ { /* scope */
float f, *ve = (float *) SCM_VELTS (ra); float f, *ve = (float *) SCM_VELTS (ra);
@ -590,7 +588,6 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore)
ve[i] = f; ve[i] = f;
break; break;
} }
#endif /* SCM_SINGLES */
case scm_tc7_dvect: case scm_tc7_dvect:
{ /* scope */ { /* scope */
double f, *ve = (double *) SCM_VELTS (ra); double f, *ve = (double *) SCM_VELTS (ra);
@ -614,7 +611,6 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore)
} }
break; break;
} }
#endif /* SCM_FLOATS */
} }
return 1; return 1;
} }
@ -710,8 +706,6 @@ racp (SCM src, SCM dst)
d[i_d] = s[i_s]; d[i_d] = s[i_s];
break; break;
} }
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
{ {
float *d = (float *) SCM_VELTS (dst); float *d = (float *) SCM_VELTS (dst);
@ -737,7 +731,6 @@ racp (SCM src, SCM dst)
} }
break; break;
} }
#endif /* SCM_SINGLES */
case scm_tc7_dvect: case scm_tc7_dvect:
{ {
double *d = (double *) SCM_VELTS (dst); double *d = (double *) SCM_VELTS (dst);
@ -804,7 +797,6 @@ racp (SCM src, SCM dst)
break; break;
} }
} }
#endif /* SCM_FLOATS */
return 1; return 1;
} }
@ -860,15 +852,12 @@ scm_ra_eqp (SCM ra0, SCM ras)
if (SCM_VELTS (ra1)[i1] != SCM_VELTS (ra2)[i2]) if (SCM_VELTS (ra1)[i1] != SCM_VELTS (ra2)[i2])
SCM_BITVEC_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
break; break;
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (SCM_BITVEC_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
if (((float *) SCM_VELTS (ra1))[i1] != ((float *) SCM_VELTS (ra2))[i2]) if (((float *) SCM_VELTS (ra1))[i1] != ((float *) SCM_VELTS (ra2))[i2])
SCM_BITVEC_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
break; break;
#endif /*SCM_SINGLES*/
case scm_tc7_dvect: case scm_tc7_dvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (SCM_BITVEC_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
@ -882,7 +871,6 @@ scm_ra_eqp (SCM ra0, SCM ras)
((double *) SCM_VELTS (ra1))[2 * i1 + 1] != ((double *) SCM_VELTS (ra2))[2 * i2 + 1]) ((double *) SCM_VELTS (ra1))[2 * i1 + 1] != ((double *) SCM_VELTS (ra2))[2 * i2 + 1])
SCM_BITVEC_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
break; break;
#endif /*SCM_FLOATS*/
} }
return 1; return 1;
} }
@ -924,8 +912,6 @@ ra_compare (SCM ra0,SCM ra1,SCM ra2,int opt)
SCM_BITVEC_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
} }
break; break;
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (SCM_BITVEC_REF(ra0, i0)) if (SCM_BITVEC_REF(ra0, i0))
@ -934,7 +920,6 @@ ra_compare (SCM ra0,SCM ra1,SCM ra2,int opt)
((float *) SCM_VELTS (ra1))[i1] >= ((float *) SCM_VELTS (ra2))[i2]) ((float *) SCM_VELTS (ra1))[i1] >= ((float *) SCM_VELTS (ra2))[i2])
SCM_BITVEC_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
break; break;
#endif /*SCM_SINGLES*/
case scm_tc7_dvect: case scm_tc7_dvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (SCM_BITVEC_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
@ -943,7 +928,6 @@ ra_compare (SCM ra0,SCM ra1,SCM ra2,int opt)
((double *) SCM_VELTS (ra1))[i1] >= ((double *) SCM_VELTS (ra2))[i2]) ((double *) SCM_VELTS (ra1))[i1] >= ((double *) SCM_VELTS (ra2))[i2])
SCM_BITVEC_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
break; break;
#endif /*SCM_FLOATS*/
} }
return 1; return 1;
} }
@ -1004,16 +988,12 @@ scm_ra_sum (SCM ra0, SCM ras)
case scm_tc7_uvect: case scm_tc7_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
BINARY_ELTS_CODE( +=, long); BINARY_ELTS_CODE( +=, long);
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
BINARY_ELTS_CODE( +=, float); BINARY_ELTS_CODE( +=, float);
#endif /* SCM_SINGLES */
case scm_tc7_dvect: case scm_tc7_dvect:
BINARY_ELTS_CODE( +=, double); BINARY_ELTS_CODE( +=, double);
case scm_tc7_cvect: case scm_tc7_cvect:
BINARY_PAIR_ELTS_CODE( +=, double); BINARY_PAIR_ELTS_CODE( +=, double);
#endif /* SCM_FLOATS */
} }
} }
return 1; return 1;
@ -1041,16 +1021,12 @@ scm_ra_difference (SCM ra0, SCM ras)
SCM_MAKINUM (i0)); SCM_MAKINUM (i0));
break; break;
} }
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
UNARY_ELTS_CODE( = -, float); UNARY_ELTS_CODE( = -, float);
#endif /* SCM_SINGLES */
case scm_tc7_dvect: case scm_tc7_dvect:
UNARY_ELTS_CODE( = -, double); UNARY_ELTS_CODE( = -, double);
case scm_tc7_cvect: case scm_tc7_cvect:
UNARY_PAIR_ELTS_CODE( = -, double); UNARY_PAIR_ELTS_CODE( = -, double);
#endif /* SCM_FLOATS */
} }
} }
else else
@ -1068,16 +1044,12 @@ scm_ra_difference (SCM ra0, SCM ras)
scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_MAKINUM (i0)); scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_MAKINUM (i0));
break; break;
} }
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
BINARY_ELTS_CODE( -=, float); BINARY_ELTS_CODE( -=, float);
#endif /* SCM_SINGLES */
case scm_tc7_dvect: case scm_tc7_dvect:
BINARY_ELTS_CODE( -=, double); BINARY_ELTS_CODE( -=, double);
case scm_tc7_cvect: case scm_tc7_cvect:
BINARY_PAIR_ELTS_CODE( -=, double); BINARY_PAIR_ELTS_CODE( -=, double);
#endif /* SCM_FLOATS */
} }
} }
return 1; return 1;
@ -1111,11 +1083,8 @@ scm_ra_product (SCM ra0, SCM ras)
case scm_tc7_uvect: case scm_tc7_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
BINARY_ELTS_CODE( *=, long); BINARY_ELTS_CODE( *=, long);
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
BINARY_ELTS_CODE( *=, float); BINARY_ELTS_CODE( *=, float);
#endif /* SCM_SINGLES */
case scm_tc7_dvect: case scm_tc7_dvect:
BINARY_ELTS_CODE( *=, double); BINARY_ELTS_CODE( *=, double);
case scm_tc7_cvect: case scm_tc7_cvect:
@ -1133,7 +1102,6 @@ scm_ra_product (SCM ra0, SCM ras)
); );
break; break;
} }
#endif /* SCM_FLOATS */
} }
} }
return 1; return 1;
@ -1158,11 +1126,8 @@ scm_ra_divide (SCM ra0, SCM ras)
scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0)); scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
break; break;
} }
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
UNARY_ELTS_CODE( = 1.0 / , float); UNARY_ELTS_CODE( = 1.0 / , float);
#endif /* SCM_SINGLES */
case scm_tc7_dvect: case scm_tc7_dvect:
UNARY_ELTS_CODE( = 1.0 / , double); UNARY_ELTS_CODE( = 1.0 / , double);
case scm_tc7_cvect: case scm_tc7_cvect:
@ -1177,7 +1142,6 @@ scm_ra_divide (SCM ra0, SCM ras)
} }
break; break;
} }
#endif /* SCM_FLOATS */
} }
} }
else else
@ -1195,11 +1159,8 @@ scm_ra_divide (SCM ra0, SCM ras)
scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_MAKINUM (i0)); scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), SCM_MAKINUM (i0));
break; break;
} }
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
BINARY_ELTS_CODE( /=, float); BINARY_ELTS_CODE( /=, float);
#endif /* SCM_SINGLES */
case scm_tc7_dvect: case scm_tc7_dvect:
BINARY_ELTS_CODE( /=, double); BINARY_ELTS_CODE( /=, double);
case scm_tc7_cvect: case scm_tc7_cvect:
@ -1218,7 +1179,6 @@ scm_ra_divide (SCM ra0, SCM ras)
) )
break; break;
} }
#endif /* SCM_FLOATS */
} }
} }
return 1; return 1;
@ -1289,8 +1249,6 @@ ramap_cxr (SCM ra0,SCM proc,SCM ras)
for (; n-- > 0; i0 += inc0, i1 += inc1) for (; n-- > 0; i0 += inc0, i1 += inc1)
scm_array_set_x (ra0, scm_apply (proc, RVREF (ra1, i1, e1), scm_listofnull), SCM_MAKINUM (i0)); scm_array_set_x (ra0, scm_apply (proc, RVREF (ra1, i1, e1), scm_listofnull), SCM_MAKINUM (i0));
break; break;
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
{ {
float *dst = (float *) SCM_VELTS (ra0); float *dst = (float *) SCM_VELTS (ra0);
@ -1310,7 +1268,6 @@ ramap_cxr (SCM ra0,SCM proc,SCM ras)
} }
break; break;
} }
#endif /* SCM_SINGLES */
case scm_tc7_dvect: case scm_tc7_dvect:
{ {
double *dst = (double *) SCM_VELTS (ra0); double *dst = (double *) SCM_VELTS (ra0);
@ -1330,7 +1287,6 @@ ramap_cxr (SCM ra0,SCM proc,SCM ras)
} }
break; break;
} }
#endif /* SCM_FLOATS */
} }
return 1; return 1;
} }
@ -1368,22 +1324,19 @@ ramap_rp (SCM ra0,SCM proc,SCM ras)
SCM_BITVEC_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
} }
break; break;
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
{ {
SCM a1 = scm_makflo (1.0), a2 = scm_makflo (1.0); SCM a1 = scm_make_real (1.0), a2 = scm_make_real (1.0);
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (SCM_BITVEC_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
{ {
SCM_FLO (a1) = ((float *) SCM_VELTS (ra1))[i1]; SCM_REAL_VALUE (a1) = ((float *) SCM_VELTS (ra1))[i1];
SCM_FLO (a2) = ((float *) SCM_VELTS (ra2))[i2]; SCM_REAL_VALUE (a2) = ((float *) SCM_VELTS (ra2))[i2];
if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2))) if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2)))
SCM_BITVEC_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
} }
break; break;
} }
#endif /*SCM_SINGLES*/
case scm_tc7_dvect: case scm_tc7_dvect:
{ {
SCM a1 = scm_makdbl (1.0 / 3.0, 0.0), a2 = scm_makdbl (1.0 / 3.0, 0.0); SCM a1 = scm_makdbl (1.0 / 3.0, 0.0), a2 = scm_makdbl (1.0 / 3.0, 0.0);
@ -1403,16 +1356,15 @@ ramap_rp (SCM ra0,SCM proc,SCM ras)
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (SCM_BITVEC_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
{ {
SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[2 * i1]; SCM_COMPLEX_REAL (a1) = ((double *) SCM_VELTS (ra1))[2 * i1];
SCM_IMAG (a1) = ((double *) SCM_VELTS (ra1))[2 * i1 + 1]; SCM_COMPLEX_IMAG (a1) = ((double *) SCM_VELTS (ra1))[2 * i1 + 1];
SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[2 * i2]; SCM_COMPLEX_REAL (a2) = ((double *) SCM_VELTS (ra2))[2 * i2];
SCM_IMAG (a2) = ((double *) SCM_VELTS (ra2))[2 * i2 + 1]; SCM_COMPLEX_IMAG (a2) = ((double *) SCM_VELTS (ra2))[2 * i2 + 1];
if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2))) if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2)))
SCM_BITVEC_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
} }
break; break;
} }
#endif /*SCM_FLOATS*/
} }
return 1; return 1;
} }
@ -1857,8 +1809,6 @@ raeql_1 (SCM ra0,SCM as_equal,SCM ra1)
return 1; return 1;
} }
#endif #endif
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
{ {
float *v0 = (float *) SCM_VELTS (ra0) + i0; float *v0 = (float *) SCM_VELTS (ra0) + i0;
@ -1868,7 +1818,6 @@ raeql_1 (SCM ra0,SCM as_equal,SCM ra1)
return 0; return 0;
return 1; return 1;
} }
#endif /* SCM_SINGLES */
case scm_tc7_dvect: case scm_tc7_dvect:
{ {
double *v0 = (double *) SCM_VELTS (ra0) + i0; double *v0 = (double *) SCM_VELTS (ra0) + i0;
@ -1891,7 +1840,6 @@ raeql_1 (SCM ra0,SCM as_equal,SCM ra1)
} }
return 1; return 1;
} }
#endif /* SCM_FLOATS */
} }
} }

4
libguile/random.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1999 Free Software Foundation, Inc. /* Copyright (C) 1999, 2000 Free Software Foundation, Inc.
* This program is free software; you can redistribute it and/or modify * This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by * it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option) * the Free Software Foundation; either version 2, or (at your option)
@ -380,7 +380,7 @@ SCM_DEFINE (scm_random, "random", 1, 1, 0,
if (SCM_REALP (n)) if (SCM_REALP (n))
return scm_makdbl (SCM_REALPART (n) * scm_c_uniform01 (SCM_RSTATE (state)), return scm_makdbl (SCM_REALPART (n) * scm_c_uniform01 (SCM_RSTATE (state)),
0.0); 0.0);
SCM_VALIDATE_SMOB (1,n,bigpos); SCM_VALIDATE_SMOB (1, n, big);
return scm_c_random_bignum (SCM_RSTATE (state), n); return scm_c_random_bignum (SCM_RSTATE (state), n);
} }
#undef FUNC_NAME #undef FUNC_NAME

3
libguile/unif.h
View file

@ -2,7 +2,7 @@
#ifndef UNIFH #ifndef UNIFH
#define UNIFH #define UNIFH
/* Copyright (C) 1995,1996,1997,1999 Free Software Foundation, Inc. /* Copyright (C) 1995,1996,1997,1999, 2000 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by * it under the terms of the GNU General Public License as published by
@ -96,7 +96,6 @@ extern long scm_tc16_array;
extern scm_sizet scm_uniform_element_size (SCM obj); extern scm_sizet scm_uniform_element_size (SCM obj);
extern SCM scm_makflo (float x);
extern SCM scm_make_uve (long k, SCM prot); extern SCM scm_make_uve (long k, SCM prot);
extern SCM scm_uniform_vector_length (SCM v); extern SCM scm_uniform_vector_length (SCM v);
extern SCM scm_array_p (SCM v, SCM prot); extern SCM scm_array_p (SCM v, SCM prot);