diff options
author | Greg J. Badros <gjb@cs.washington.edu> | 1999-12-12 02:36:16 +0000 |
---|---|---|
committer | Greg J. Badros <gjb@cs.washington.edu> | 1999-12-12 02:36:16 +0000 |
commit | 1bbd0b849f6b90f1ffe57e586e4ee5a884f84a11 (patch) | |
tree | 79120a96365e0fa3324174bfd08d731ca8311d64 /libguile/numbers.c | |
parent | 6e7069385db8cf96dfbe51cf65ace161942a32c9 (diff) | |
download | guile-1bbd0b849f6b90f1ffe57e586e4ee5a884f84a11.tar.gz |
* *.c: Pervasive software-engineering-motivated rewrite of
function headers and argument checking. Switched SCM_PROC,
SCM_PROC1 macros to be GUILE_PROC, GUILE_PROC1 (may change names
later, but was useful to keep old versions around while migrate)
that has docstrings and argument lists embedded in the GUILE_PROC
macro invocations that expand into a function header. Use lots of
new SCM_VALIDATE_* macros to simplify error checking and reduce
tons of redundancy. This is very similar to what I did for Scwm.
Note that none of the extraction of the docstrings, nor software
engineering checks of Scwm is yet added to Guile. I'll work on
that tomorrow, I expect.
* Makefile.am: Added scm_validate.h to modinclude_HEADERS.
* chars.c: Added docstrings for the primitives defined in here.
* snarf.h: Added GUILE_PROC, GUILE_PROC1. Added
SCM_REGISTER_PROC to be like old SCM_PROC, though old SCM_PROC
still remains for now. Changed naming convention for the s_foo
string name of the primitive to be s_scm_foo for ease of use with
the macro.
* scm_validate.h: Lots of new SCM_VALIDATE macros to simplify
argument checking through guile. Maybe some of these should be
folded into the header file for the types they check, but for now
it was easiest to just stick them all in one place.
Diffstat (limited to 'libguile/numbers.c')
-rw-r--r-- | libguile/numbers.c | 667 |
1 files changed, 293 insertions, 374 deletions
diff --git a/libguile/numbers.c b/libguile/numbers.c index 992b3ddb7..8330b37fe 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -38,6 +38,10 @@ * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ + +/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, + gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ + #include <stdio.h> @@ -48,6 +52,7 @@ #include "feature.h" #include "smob.h" +#include "scm_validate.h" #include "numbers.h" #define DIGITS '0':case '1':case '2':case '3':case '4':\ @@ -90,11 +95,10 @@ -SCM_PROC (s_exact_p, "exact?", 1, 0, 0, scm_exact_p); - -SCM -scm_exact_p (x) - SCM x; +GUILE_PROC (scm_exact_p, "exact?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_exact_p { if (SCM_INUMP (x)) return SCM_BOOL_T; @@ -104,42 +108,43 @@ scm_exact_p (x) #endif return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_odd_p, "odd?", 1, 0, 0, scm_odd_p); - -SCM -scm_odd_p (n) - SCM n; +GUILE_PROC (scm_odd_p, "odd?", 1, 0, 0, + (SCM n), +"") +#define FUNC_NAME s_scm_odd_p { #ifdef SCM_BIGDIG if (SCM_NINUMP (n)) { - SCM_ASSERT (SCM_NIMP (n) && SCM_BIGP (n), n, SCM_ARG1, s_odd_p); - return (1 & SCM_BDIGITS (n)[0]) ? SCM_BOOL_T : SCM_BOOL_F; + SCM_VALIDATE_BIGINT(1,n); + return SCM_BOOL(1 & SCM_BDIGITS (n)[0]); } #else - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_odd_p); + SCM_VALIDATE_INT(1,n); #endif - return (4 & (int) n) ? SCM_BOOL_T : SCM_BOOL_F; + return SCM_BOOL(4 & (int) n); } +#undef FUNC_NAME -SCM_PROC (s_even_p, "even?", 1, 0, 0, scm_even_p); - -SCM -scm_even_p (n) - SCM n; +GUILE_PROC (scm_even_p, "even?", 1, 0, 0, + (SCM n), +"") +#define FUNC_NAME s_scm_even_p { #ifdef SCM_BIGDIG if (SCM_NINUMP (n)) { - SCM_ASSERT (SCM_NIMP (n) && SCM_BIGP (n), n, SCM_ARG1, s_even_p); - return (1 & SCM_BDIGITS (n)[0]) ? SCM_BOOL_F : SCM_BOOL_T; + SCM_VALIDATE_BIGINT(1,n); + return SCM_NEGATE_BOOL(1 & SCM_BDIGITS (n)[0]); } #else - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_even_p); + SCM_VALIDATE_INT(1,n); #endif - return (4 & (int) n) ? SCM_BOOL_F : SCM_BOOL_T; + return SCM_NEGATE_BOOL(4 & (int) n); } +#undef FUNC_NAME SCM_GPROC (s_abs, "abs", 1, 0, 0, scm_abs, g_abs); @@ -516,210 +521,217 @@ scm_lcm (n1, n2) #endif #ifndef scm_long2num -SCM_PROC1 (s_logand, "logand", scm_tc7_asubr, scm_logand); - -SCM -scm_logand (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC1 (scm_logand, "logand", scm_tc7_asubr, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logand { + int i1, i2; if (SCM_UNBNDP (n2)) { if (SCM_UNBNDP (n1)) return SCM_MAKINUM (-1); return n1; } - return scm_ulong2num (scm_num2ulong (n1, (char *) SCM_ARG1, s_logand) - & scm_num2ulong (n2, (char *) SCM_ARG2, s_logand)); + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return scm_ulong2num (i1 & i2); } +#undef FUNC_NAME -SCM_PROC1 (s_logior, "logior", scm_tc7_asubr, scm_logior); - -SCM -scm_logior (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC1 (scm_logior, "logior", scm_tc7_asubr, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logior { + int i1, i2; if (SCM_UNBNDP (n2)) { if (SCM_UNBNDP (n1)) return SCM_INUM0; return n1; } - return scm_ulong2num (scm_num2ulong (n1, (char *) SCM_ARG1, s_logior) - | scm_num2ulong (n2, (char *) SCM_ARG2, s_logior)); + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return scm_ulong2num (i1 | i2); } +#undef FUNC_NAME -SCM_PROC1 (s_logxor, "logxor", scm_tc7_asubr, scm_logxor); - -SCM -scm_logxor (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC1 (scm_logxor, "logxor", scm_tc7_asubr, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logxor { + int i1, i2; if (SCM_UNBNDP (n2)) { if (SCM_UNBNDP (n1)) return SCM_INUM0; return n1; } - return scm_ulong2num (scm_num2ulong (n1, (char *) SCM_ARG1, s_logxor) - ^ scm_num2ulong (n2, (char *) SCM_ARG2, s_logxor)); + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return scm_ulong2num (i1 ^ i2); } +#undef FUNC_NAME -SCM_PROC (s_logtest, "logtest", 2, 0, 0, scm_logtest); - -SCM -scm_logtest (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC (scm_logtest, "logtest", 2, 0, 0, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logtest { - return ((scm_num2ulong (n1, (char *) SCM_ARG1, s_logtest) - & scm_num2ulong (n2, (char *) SCM_ARG2, s_logtest)) - ? SCM_BOOL_T : SCM_BOOL_F); + int i1, i2; + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return SCM_BOOL(i1 & i2); } +#undef FUNC_NAME -SCM_PROC (s_logbit_p, "logbit?", 2, 0, 0, scm_logbit_p); - -SCM -scm_logbit_p (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC (scm_logbit_p, "logbit?", 2, 0, 0, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logbit_p { - return (((1 << scm_num2long (n1, (char *) SCM_ARG1, s_logtest)) - & scm_num2ulong (n2, (char *) SCM_ARG2, s_logtest)) - ? SCM_BOOL_T : SCM_BOOL_F); + int i1, i2; + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return SCM_BOOL((1 << i1) & i2); } +#undef FUNC_NAME #else -SCM_PROC1 (s_logand, "logand", scm_tc7_asubr, scm_logand); - -SCM -scm_logand (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC1 (scm_logand, "logand", scm_tc7_asubr, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logand { + int i1, i2; if (SCM_UNBNDP (n2)) { if (SCM_UNBNDP (n1)) return SCM_MAKINUM (-1); return n1; } - return SCM_MAKINUM (SCM_INUM (n1) & SCM_INUM (n2)); + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return SCM_MAKINUM (i1 & i2); } +#undef FUNC_NAME -SCM_PROC1 (s_logior, "logior", scm_tc7_asubr, scm_logior); - -SCM -scm_logior (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC1 (scm_logior, "logior", scm_tc7_asubr, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logior { + int i1, i2; if (SCM_UNBNDP (n2)) { if (SCM_UNBNDP (n1)) return SCM_INUM0; return n1; } - return SCM_MAKINUM (SCM_INUM (n1) | SCM_INUM (n2)); + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return SCM_MAKINUM (i1 | i2); } +#undef FUNC_NAME -SCM_PROC1 (s_logxor, "logxor", scm_tc7_asubr, scm_logxor); - -SCM -scm_logxor (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC1 (scm_logxor, "logxor", scm_tc7_asubr, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logxor { + int i1, i2; if (SCM_UNBNDP (n2)) { if (SCM_UNBNDP (n1)) return SCM_INUM0; return n1; } - return SCM_MAKINUM (SCM_INUM (n1) ^ SCM_INUM (n2)); + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return SCM_MAKINUM (i1 ^ i2); } +#undef FUNC_NAME -SCM_PROC (s_logtest, "logtest", 2, 0, 0, scm_logtest); - -SCM -scm_logtest (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC (scm_logtest, "logtest", 2, 0, 0, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logtest { - SCM_ASSERT (SCM_INUMP (n1), n1, SCM_ARG1, s_logtest); - SCM_ASSERT (SCM_INUMP (n2), n2, SCM_ARG2, s_logtest); - return (SCM_INUM (n1) & SCM_INUM (n2)) ? SCM_BOOL_T : SCM_BOOL_F; + int i1, i2; + SCM_VALIDATE_INT_COPY(1,n1,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return SCM_BOOL(i1 & i2); } +#undef FUNC_NAME -SCM_PROC (s_logbit_p, "logbit?", 2, 0, 0, scm_logbit_p); - -SCM -scm_logbit_p (n1, n2) - SCM n1; - SCM n2; +GUILE_PROC (scm_logbit_p, "logbit?", 2, 0, 0, + (SCM n1, SCM n2), +"") +#define FUNC_NAME s_scm_logbit_p { - SCM_ASSERT (SCM_INUMP (n1) && SCM_INUM (n1) >= 0, n1, SCM_ARG1, s_logbit_p); - SCM_ASSERT (SCM_INUMP (n2), n2, SCM_ARG2, s_logbit_p); - return ((1 << SCM_INUM (n1)) & SCM_INUM (n2)) ? SCM_BOOL_T : SCM_BOOL_F; + int i1, i2; + SCM_VALIDATE_INT_MIN_COPY(1,n1,0,i1); + SCM_VALIDATE_INT_COPY(2,n2,i2); + return SCM_BOOL((1 << i1) & i2); } +#undef FUNC_NAME #endif -SCM_PROC (s_lognot, "lognot", 1, 0, 0, scm_lognot); - -SCM -scm_lognot (n) - SCM n; +GUILE_PROC (scm_lognot, "lognot", 1, 0, 0, + (SCM n), +"") +#define FUNC_NAME s_scm_lognot { - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_lognot); + SCM_VALIDATE_INT(1,n); return scm_difference (SCM_MAKINUM (-1L), n); } +#undef FUNC_NAME -SCM_PROC (s_integer_expt, "integer-expt", 2, 0, 0, scm_integer_expt); - -SCM -scm_integer_expt (z1, z2) - SCM z1; - SCM z2; +GUILE_PROC (scm_integer_expt, "integer-expt", 2, 0, 0, + (SCM z1, SCM z2), +"") +#define FUNC_NAME s_scm_integer_expt { SCM acc = SCM_MAKINUM (1L); + int i2; #ifdef SCM_BIGDIG if (SCM_INUM0 == z1 || acc == z1) return z1; else if (SCM_MAKINUM (-1L) == z1) return SCM_BOOL_F == scm_even_p (z2) ? z1 : acc; #endif - SCM_ASSERT (SCM_INUMP (z2), z2, SCM_ARG2, s_integer_expt); - z2 = SCM_INUM (z2); - if (z2 < 0) + SCM_VALIDATE_INT_COPY(2,z2,i2); + if (i2 < 0) { - z2 = -z2; + i2 = -i2; z1 = scm_divide (z1, SCM_UNDEFINED); } while (1) { - if (0 == z2) + if (0 == i2) return acc; - if (1 == z2) + if (1 == i2) return scm_product (acc, z1); - if (z2 & 1) + if (i2 & 1) acc = scm_product (acc, z1); z1 = scm_product (z1, z1); - z2 >>= 1; + i2 >>= 1; } } +#undef FUNC_NAME -SCM_PROC (s_ash, "ash", 2, 0, 0, scm_ash); - -SCM -scm_ash (n, cnt) - SCM n; - SCM cnt; +GUILE_PROC (scm_ash, "ash", 2, 0, 0, + (SCM n, SCM cnt), +"") +#define FUNC_NAME s_scm_ash { + /* GJB:FIXME:: what is going on here? */ SCM res = SCM_INUM (n); - SCM_ASSERT (SCM_INUMP (cnt), cnt, SCM_ARG2, s_ash); + SCM_VALIDATE_INT(2,cnt); #ifdef SCM_BIGDIG if (cnt < 0) { @@ -733,30 +745,30 @@ scm_ash (n, cnt) else return scm_product (n, scm_integer_expt (SCM_MAKINUM (2), cnt)); #else - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_ash); + SCM_VALIDATE_INT(1,n) cnt = SCM_INUM (cnt); if (cnt < 0) return SCM_MAKINUM (SCM_SRS (res, -cnt)); res = SCM_MAKINUM (res << cnt); if (SCM_INUM (res) >> cnt != SCM_INUM (n)) - scm_num_overflow (s_ash); + scm_num_overflow (FUNC_NAME); return res; #endif } +#undef FUNC_NAME -SCM_PROC (s_bit_extract, "bit-extract", 3, 0, 0, scm_bit_extract); - -SCM -scm_bit_extract (n, start, end) - SCM n; - SCM start; - SCM end; +/* GJB:FIXME: do not use SCMs as integers! */ +GUILE_PROC (scm_bit_extract, "bit-extract", 3, 0, 0, + (SCM n, SCM start, SCM end), +"") +#define FUNC_NAME s_scm_bit_extract { - SCM_ASSERT (SCM_INUMP (start), start, SCM_ARG2, s_bit_extract); - SCM_ASSERT (SCM_INUMP (end), end, SCM_ARG3, s_bit_extract); + SCM_VALIDATE_INT(1,n); + SCM_VALIDATE_INT_MIN(2,start,0); + SCM_VALIDATE_INT_MIN(3,end,0); start = SCM_INUM (start); end = SCM_INUM (end); - SCM_ASSERT (end >= start, SCM_MAKINUM (end), SCM_OUTOFRANGE, s_bit_extract); + SCM_ASSERT (end >= start, SCM_MAKINUM (end), SCM_OUTOFRANGE, FUNC_NAME); #ifdef SCM_BIGDIG if (SCM_NINUMP (n)) return @@ -765,19 +777,20 @@ scm_bit_extract (n, start, end) SCM_MAKINUM (1L)), scm_ash (n, SCM_MAKINUM (-start))); #else - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_bit_extract); + SCM_VALIDATE_INT(1,n); #endif return SCM_MAKINUM ((SCM_INUM (n) >> start) & ((1L << (end - start)) - 1)); } +#undef FUNC_NAME static const char scm_logtab[] = { 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4 }; -SCM_PROC (s_logcount, "logcount", 1, 0, 0, scm_logcount); -SCM -scm_logcount (n) - SCM n; +GUILE_PROC (scm_logcount, "logcount", 1, 0, 0, + (SCM n), +"") +#define FUNC_NAME s_scm_logcount { register unsigned long c = 0; register long nn; @@ -786,7 +799,7 @@ scm_logcount (n) { scm_sizet i; SCM_BIGDIG *ds, d; - SCM_ASSERT (SCM_NIMP (n) && SCM_BIGP (n), n, SCM_ARG1, s_logcount); + SCM_VALIDATE_BIGINT(1,n); if (SCM_BIGSIGN (n)) return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n)); ds = SCM_BDIGITS (n); @@ -796,7 +809,7 @@ scm_logcount (n) return SCM_MAKINUM (c); } #else - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_logcount); + SCM_VALIDATE_INT(1,n); #endif if ((nn = SCM_INUM (n)) < 0) nn = -1 - nn; @@ -804,15 +817,17 @@ scm_logcount (n) c += scm_logtab[15 & nn]; return SCM_MAKINUM (c); } +#undef FUNC_NAME + static const char scm_ilentab[] = { 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4 }; -SCM_PROC (s_integer_length, "integer-length", 1, 0, 0, scm_integer_length); -SCM -scm_integer_length (n) - SCM n; +GUILE_PROC (scm_integer_length, "integer-length", 1, 0, 0, + (SCM n), +"") +#define FUNC_NAME s_scm_integer_length { register unsigned long c = 0; register long nn; @@ -821,7 +836,7 @@ scm_integer_length (n) if (SCM_NINUMP (n)) { SCM_BIGDIG *ds, d; - SCM_ASSERT (SCM_NIMP (n) && SCM_BIGP (n), n, SCM_ARG1, s_integer_length); + SCM_VALIDATE_BIGINT(1,n); if (SCM_BIGSIGN (n)) return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n)); ds = SCM_BDIGITS (n); @@ -834,7 +849,7 @@ scm_integer_length (n) return SCM_MAKINUM (c - 4 + l); } #else - SCM_ASSERT (SCM_INUMP (n), n, SCM_ARG1, s_integer_length); + SCM_VALIDATE_INT(1,n); #endif if ((nn = SCM_INUM (n)) < 0) nn = -1 - nn; @@ -845,15 +860,14 @@ scm_integer_length (n) } return SCM_MAKINUM (c - 4 + l); } +#undef FUNC_NAME #ifdef SCM_BIGDIG static const char s_bignum[] = "bignum"; SCM -scm_mkbig (nlen, sign) - scm_sizet nlen; - int sign; +scm_mkbig (scm_sizet nlen, int sign) { SCM v = nlen; /* Cast to SCM to avoid signed/unsigned comparison warnings. */ @@ -870,9 +884,7 @@ scm_mkbig (nlen, sign) SCM -scm_big2inum (b, l) - SCM b; - scm_sizet l; +scm_big2inum (SCM b, scm_sizet l) { unsigned long num = 0; SCM_BIGDIG *tmp = SCM_BDIGITS (b); @@ -892,9 +904,7 @@ scm_big2inum (b, l) static const char s_adjbig[] = "scm_adjbig"; SCM -scm_adjbig (b, nlen) - SCM b; - scm_sizet nlen; +scm_adjbig (SCM b, scm_sizet nlen) { scm_sizet nsiz = nlen; if (((nsiz << 16) >> 16) != nlen) @@ -918,8 +928,7 @@ scm_adjbig (b, nlen) SCM -scm_normbig (b) - SCM b; +scm_normbig (SCM b) { #ifndef _UNICOS scm_sizet nlen = SCM_NUMDIGS (b); @@ -940,9 +949,7 @@ scm_normbig (b) SCM -scm_copybig (b, sign) - SCM b; - int sign; +scm_copybig (SCM b, int sign) { scm_sizet i = SCM_NUMDIGS (b); SCM ans = scm_mkbig (i, sign); @@ -955,8 +962,7 @@ scm_copybig (b, sign) SCM -scm_long2big (n) - long n; +scm_long2big (long n) { scm_sizet i = 0; SCM_BIGDIG *digits; @@ -975,8 +981,7 @@ scm_long2big (n) #ifdef HAVE_LONG_LONGS SCM -scm_long_long2big (n) - long_long n; +scm_long_long2big (long_long n) { scm_sizet i; SCM_BIGDIG *digits; @@ -1015,8 +1020,7 @@ scm_long_long2big (n) SCM -scm_2ulong2big (np) - unsigned long *np; +scm_2ulong2big (unsigned long *np) { unsigned long n; scm_sizet i; @@ -1044,8 +1048,7 @@ scm_2ulong2big (np) SCM -scm_ulong2big (n) - unsigned long n; +scm_ulong2big (unsigned long n) { scm_sizet i = 0; SCM_BIGDIG *digits; @@ -1062,9 +1065,7 @@ scm_ulong2big (n) int -scm_bigcomp (x, y) - SCM x; - SCM y; +scm_bigcomp (SCM x, SCM y) { int xsign = SCM_BIGSIGN (x); int ysign = SCM_BIGSIGN (y); @@ -1105,8 +1106,7 @@ scm_bigcomp (x, y) long -scm_pseudolong (x) - long x; +scm_pseudolong (long x) { union { @@ -1130,9 +1130,7 @@ scm_pseudolong (x) void -scm_longdigs (x, digs) - long x; - SCM_BIGDIG digs[]; +scm_longdigs (long x, SCM_BIGDIG digs[]) { scm_sizet i = 0; if (x < 0) @@ -1148,12 +1146,7 @@ scm_longdigs (x, digs) SCM -scm_addbig (x, nx, xsgn, bigy, sgny) - SCM_BIGDIG *x; - scm_sizet nx; - int xsgn; - SCM bigy; - int sgny; +scm_addbig (SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny) { /* Assumes nx <= SCM_NUMDIGS(bigy) */ /* Assumes xsgn and sgny scm_equal either 0 or 0x0100 */ @@ -1238,12 +1231,7 @@ scm_addbig (x, nx, xsgn, bigy, sgny) SCM -scm_mulbig (x, nx, y, ny, sgn) - SCM_BIGDIG *x; - scm_sizet nx; - SCM_BIGDIG *y; - scm_sizet ny; - int sgn; +scm_mulbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn) { scm_sizet i = 0, j = nx + ny; unsigned long n = 0; @@ -1299,11 +1287,7 @@ scm_divbigdig (SCM_BIGDIG * ds, SCM -scm_divbigint (x, z, sgn, mode) - SCM x; - long z; - int sgn; - int mode; +scm_divbigint (SCM x, long z, int sgn, int mode) { if (z < 0) z = -z; @@ -1336,13 +1320,7 @@ scm_divbigint (x, z, sgn, mode) SCM -scm_divbigbig (x, nx, y, ny, sgn, modes) - SCM_BIGDIG *x; - scm_sizet nx; - SCM_BIGDIG *y; - scm_sizet ny; - int sgn; - int modes; +scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn, int modes) { /* modes description 0 remainder @@ -1551,12 +1529,8 @@ static const double fx[] = -static scm_sizet idbl2str SCM_P ((double f, char *a)); - static scm_sizet -idbl2str (f, a) - double f; - char *a; +idbl2str (double f, char *a) { int efmt, dpt, d, i, wp = scm_dblprec; scm_sizet ch = 0; @@ -1695,12 +1669,8 @@ idbl2str (f, a) } -static scm_sizet iflo2str SCM_P ((SCM flt, char *str)); - static scm_sizet -iflo2str (flt, str) - SCM flt; - char *str; +iflo2str (SCM flt, char *str) { scm_sizet i; #ifdef SCM_SINGLES @@ -1721,12 +1691,11 @@ iflo2str (flt, str) #endif /* SCM_FLOATS */ /* convert a long to a string (unterminated). returns the number of - characters in the result. */ + characters in the result. + rad is output base + p is destination: worst case (base 2) is SCM_INTBUFLEN */ scm_sizet -scm_iint2str (num, rad, p) - long num; - int rad; /* output base. */ - char *p; /* destination: worst case (base 2) is SCM_INTBUFLEN. */ +scm_iint2str (long num, int rad, char *p) { scm_sizet j = 1; scm_sizet i; @@ -1757,12 +1726,8 @@ scm_iint2str (num, rad, p) #ifdef SCM_BIGDIG -static SCM big2str SCM_P ((SCM b, register unsigned int radix)); - static SCM -big2str (b, radix) - SCM b; - register unsigned int radix; +big2str (SCM b, unsigned int radix) { SCM t = scm_copybig (b, 0); /* sign of temp doesn't matter */ register SCM_BIGDIG *ds = SCM_BDIGITS (t); @@ -1810,21 +1775,13 @@ big2str (b, radix) #endif -SCM_PROC (s_number_to_string, "number->string", 1, 1, 0, scm_number_to_string); - -SCM -scm_number_to_string (x, radix) - SCM x; - SCM radix; +GUILE_PROC (scm_number_to_string, "number->string", 1, 1, 0, + (SCM x, SCM radix), +"") +#define FUNC_NAME s_scm_number_to_string { - if (SCM_UNBNDP (radix)) - radix = SCM_MAKINUM (10L); - else - { - SCM_ASSERT (SCM_INUMP (radix), radix, SCM_ARG2, s_number_to_string); - SCM_ASSERT (SCM_INUM (radix) >= 2, radix, SCM_OUTOFRANGE, - s_number_to_string); - } + int base; + SCM_VALIDATE_INT_MIN_DEF_COPY(2,radix,2,10,base); #ifdef SCM_FLOATS if (SCM_NINUMP (x)) { @@ -1832,12 +1789,12 @@ scm_number_to_string (x, radix) #ifdef SCM_BIGDIG SCM_ASRTGO (SCM_NIMP (x), badx); if (SCM_BIGP (x)) - return big2str (x, (unsigned int) SCM_INUM (radix)); + return big2str (x, (unsigned int) base); #ifndef SCM_RECKLESS if (!(SCM_INEXP (x))) { badx: - scm_wta (x, (char *) SCM_ARG1, s_number_to_string); + scm_wta (x, (char *) SCM_ARG1, FUNC_NAME); } #endif #else @@ -1852,7 +1809,7 @@ scm_number_to_string (x, radix) { SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x), x, SCM_ARG1, s_number_to_string); - return big2str (x, (unsigned int) SCM_INUM (radix)); + return big2str (x, (unsigned int) base); } #else SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_number_to_string); @@ -1862,21 +1819,19 @@ scm_number_to_string (x, radix) char num_buf[SCM_INTBUFLEN]; return scm_makfromstr (num_buf, scm_iint2str (SCM_INUM (x), - (int) SCM_INUM (radix), + base, num_buf), 0); } } +#undef FUNC_NAME /* These print routines are stubbed here so that scm_repl.c doesn't need SCM_FLOATS or SCM_BIGDIGs conditionals */ int -scm_floprint (sexp, port, pstate) - SCM sexp; - SCM port; - scm_print_state *pstate; +scm_floprint (SCM sexp, SCM port, scm_print_state *pstate) { #ifdef SCM_FLOATS char num_buf[SCM_FLOBUFLEN]; @@ -1890,10 +1845,7 @@ scm_floprint (sexp, port, pstate) int -scm_bigprint (exp, port, pstate) - SCM exp; - SCM port; - scm_print_state *pstate; +scm_bigprint (SCM exp, SCM port, scm_print_state *pstate) { #ifdef SCM_BIGDIG exp = big2str (exp, (unsigned int) 10); @@ -1907,13 +1859,8 @@ scm_bigprint (exp, port, pstate) /*** STRINGS -> NUMBERS ***/ -static SCM scm_small_istr2int SCM_P ((char *str, long len, long radix)); - static SCM -scm_small_istr2int (str, len, radix) - char *str; - long len; - long radix; +scm_small_istr2int (char *str, long len, long radix) { register long n = 0, ln; register int c; @@ -1977,10 +1924,7 @@ scm_small_istr2int (str, len, radix) SCM -scm_istr2int (str, len, radix) - char *str; - long len; - long radix; +scm_istr2int (char *str, long len, long radix) { scm_sizet j; register scm_sizet k, blen = 1; @@ -2074,10 +2018,7 @@ scm_istr2int (str, len, radix) #ifdef SCM_FLOATS SCM -scm_istr2flo (str, len, radix) - char *str; - long len; - long radix; +scm_istr2flo (char *str, long len, long radix) { register int c, i = 0; double lead_sgn; @@ -2366,10 +2307,7 @@ scm_istr2flo (str, len, radix) SCM -scm_istring2number (str, len, radix) - char *str; - long len; - long radix; +scm_istring2number (char *str, long len, long radix) { int i = 0; char ex = 0; @@ -2439,37 +2377,27 @@ scm_istring2number (str, len, radix) } -SCM_PROC (s_string_to_number, "string->number", 1, 1, 0, scm_string_to_number); - -SCM -scm_string_to_number (str, radix) - SCM str; - SCM radix; +GUILE_PROC (scm_string_to_number, "string->number", 1, 1, 0, + (SCM str, SCM radix), +"") +#define FUNC_NAME s_scm_string_to_number { SCM answer; - if (SCM_UNBNDP (radix)) - radix = SCM_MAKINUM (10L); - else - { - SCM_ASSERT (SCM_INUMP (radix), radix, SCM_ARG2, s_string_to_number); - SCM_ASSERT (SCM_INUM (radix) >= 2, radix, SCM_OUTOFRANGE, - s_number_to_string); - } - SCM_ASSERT (SCM_NIMP (str) && SCM_ROSTRINGP (str), - str, SCM_ARG1, s_string_to_number); + int base; + SCM_VALIDATE_ROSTRING(1,str); + SCM_VALIDATE_INT_MIN_DEF_COPY(2,radix,2,10,base); answer = scm_istring2number (SCM_ROCHARS (str), SCM_ROLENGTH (str), - SCM_INUM (radix)); + base); return scm_return_first (answer, str); } +#undef FUNC_NAME /*** END strs->nums ***/ #ifdef SCM_FLOATS SCM -scm_makdbl (x, y) - double x; - double y; +scm_makdbl (double x, double y) { SCM z; if ((y == 0.0) && (x == 0.0)) @@ -2505,9 +2433,7 @@ scm_makdbl (x, y) SCM -scm_bigequal (x, y) - SCM x; - SCM y; +scm_bigequal (SCM x, SCM y) { #ifdef SCM_BIGDIG if (0 == scm_bigcomp (x, y)) @@ -2519,9 +2445,7 @@ scm_bigequal (x, y) SCM -scm_floequal (x, y) - SCM x; - SCM y; +scm_floequal (SCM x, SCM y) { #ifdef SCM_FLOATS if (SCM_REALPART (x) != SCM_REALPART (y)) @@ -2535,12 +2459,12 @@ scm_floequal (x, y) -SCM_PROC (s_number_p, "number?", 1, 0, 0, scm_number_p); -SCM_PROC (s_complex_p, "complex?", 1, 0, 0, scm_number_p); +SCM_REGISTER_PROC (s_number_p, "number?", 1, 0, 0, scm_number_p); -SCM -scm_number_p (x) - SCM x; +GUILE_PROC (scm_number_p, "complex?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_number_p { if (SCM_INUMP (x)) return SCM_BOOL_T; @@ -2555,16 +2479,18 @@ scm_number_p (x) #endif return SCM_BOOL_F; } +#undef FUNC_NAME #ifdef SCM_FLOATS -SCM_PROC (s_real_p, "real?", 1, 0, 0, scm_real_p); -SCM_PROC (s_rational_p, "rational?", 1, 0, 0, scm_real_p); +SCM_REGISTER_PROC (s_real_p, "real?", 1, 0, 0, scm_real_p); -SCM -scm_real_p (x) - SCM x; + +GUILE_PROC (scm_real_p, "rational?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_real_p { if (SCM_INUMP (x)) return SCM_BOOL_T; @@ -2578,14 +2504,14 @@ scm_real_p (x) #endif return SCM_BOOL_F; } +#undef FUNC_NAME -SCM_PROC (s_int_p, "integer?", 1, 0, 0, scm_integer_p); - -SCM -scm_integer_p (x) - SCM x; +GUILE_PROC (scm_integer_p, "integer?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_integer_p { double r; if (SCM_INUMP (x)) @@ -2605,16 +2531,16 @@ scm_integer_p (x) return SCM_BOOL_T; return SCM_BOOL_F; } +#undef FUNC_NAME #endif /* SCM_FLOATS */ -SCM_PROC (s_inexact_p, "inexact?", 1, 0, 0, scm_inexact_p); - -SCM -scm_inexact_p (x) - SCM x; +GUILE_PROC (scm_inexact_p, "inexact?", 1, 0, 0, + (SCM x), +"") +#define FUNC_NAME s_scm_inexact_p { #ifdef SCM_FLOATS if (SCM_NIMP (x) && SCM_INEXP (x)) @@ -2622,6 +2548,7 @@ scm_inexact_p (x) #endif return SCM_BOOL_F; } +#undef FUNC_NAME @@ -2840,39 +2767,36 @@ scm_less_p (x, y) } -SCM_PROC1 (s_gr_p, ">", scm_tc7_rpsubr, scm_gr_p); - -SCM -scm_gr_p (x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_gr_p, ">", scm_tc7_rpsubr, + (SCM x, SCM y), +"") +#define FUNC_NAME s_scm_gr_p { return scm_less_p (y, x); } +#undef FUNC_NAME -SCM_PROC1 (s_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p); - -SCM -scm_leq_p (x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_leq_p, "<=", scm_tc7_rpsubr, + (SCM x, SCM y), +"") +#define FUNC_NAME s_scm_leq_p { return SCM_BOOL_NOT (scm_less_p (y, x)); } +#undef FUNC_NAME -SCM_PROC1 (s_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p); - -SCM -scm_geq_p (x, y) - SCM x; - SCM y; +GUILE_PROC1 (scm_geq_p, ">=", scm_tc7_rpsubr, + (SCM x, SCM y), +"") +#define FUNC_NAME s_scm_geq_p { return SCM_BOOL_NOT (scm_less_p (x, y)); } +#undef FUNC_NAME @@ -4269,59 +4193,55 @@ scm_two_doubles (z1, z2, sstring, xy) -SCM_PROC (s_sys_expt, "$expt", 2, 0, 0, scm_sys_expt); - -SCM -scm_sys_expt (z1, z2) - SCM z1; - SCM z2; +GUILE_PROC (scm_sys_expt, "$expt", 2, 0, 0, + (SCM z1, SCM z2), +"") +#define FUNC_NAME s_scm_sys_expt { struct dpair xy; - scm_two_doubles (z1, z2, s_sys_expt, &xy); + scm_two_doubles (z1, z2, FUNC_NAME, &xy); return scm_makdbl (pow (xy.x, xy.y), 0.0); } +#undef FUNC_NAME -SCM_PROC (s_sys_atan2, "$atan2", 2, 0, 0, scm_sys_atan2); - -SCM -scm_sys_atan2 (z1, z2) - SCM z1; - SCM z2; +GUILE_PROC (scm_sys_atan2, "$atan2", 2, 0, 0, + (SCM z1, SCM z2), +"") +#define FUNC_NAME s_scm_sys_atan2 { struct dpair xy; - scm_two_doubles (z1, z2, s_sys_atan2, &xy); + scm_two_doubles (z1, z2, FUNC_NAME, &xy); return scm_makdbl (atan2 (xy.x, xy.y), 0.0); } +#undef FUNC_NAME -SCM_PROC (s_make_rectangular, "make-rectangular", 2, 0, 0, scm_make_rectangular); - -SCM -scm_make_rectangular (z1, z2) - SCM z1; - SCM z2; +GUILE_PROC (scm_make_rectangular, "make-rectangular", 2, 0, 0, + (SCM z1, SCM z2), +"") +#define FUNC_NAME s_scm_make_rectangular { struct dpair xy; - scm_two_doubles (z1, z2, s_make_rectangular, &xy); + scm_two_doubles (z1, z2, FUNC_NAME, &xy); return scm_makdbl (xy.x, xy.y); } +#undef FUNC_NAME -SCM_PROC (s_make_polar, "make-polar", 2, 0, 0, scm_make_polar); - -SCM -scm_make_polar (z1, z2) - SCM z1; - SCM z2; +GUILE_PROC (scm_make_polar, "make-polar", 2, 0, 0, + (SCM z1, SCM z2), +"") +#define FUNC_NAME s_scm_make_polar { struct dpair xy; - scm_two_doubles (z1, z2, s_make_polar, &xy); + scm_two_doubles (z1, z2, FUNC_NAME, &xy); return scm_makdbl (xy.x * cos (xy.y), xy.x * sin (xy.y)); } +#undef FUNC_NAME @@ -4454,11 +4374,10 @@ scm_angle (z) } -SCM_PROC (s_inexact_to_exact, "inexact->exact", 1, 0, 0, scm_inexact_to_exact); - -SCM -scm_inexact_to_exact (z) - SCM z; +GUILE_PROC (scm_inexact_to_exact, "inexact->exact", 1, 0, 0, + (SCM z), +"") +#define FUNC_NAME s_scm_inexact_to_exact { if (SCM_INUMP (z)) return z; @@ -4470,11 +4389,11 @@ scm_inexact_to_exact (z) if (!(SCM_REALP (z))) { badz: - scm_wta (z, (char *) SCM_ARG1, s_inexact_to_exact); + scm_wta (z, (char *) SCM_ARG1, FUNC_NAME); } #endif #else - SCM_ASSERT (SCM_NIMP (z) && SCM_REALP (z), z, SCM_ARG1, s_inexact_to_exact); + SCM_VALIDATE_REAL(1,z); #endif #ifdef SCM_BIGDIG { @@ -4493,6 +4412,7 @@ scm_inexact_to_exact (z) return SCM_MAKINUM ((long) floor (SCM_REALPART (z) + 0.5)); #endif } +#undef FUNC_NAME @@ -4813,7 +4733,6 @@ scm_num2ulong (num, pos, s_caller) #ifdef SCM_FLOATS #ifndef DBL_DIG -static void add1 SCM_P ((double f, double *fsum)); static void add1 (f, fsum) double f, *fsum; |