From c209c88e54d08a557a297836200e16e20355df02 Mon Sep 17 00:00:00 2001 From: "Greg J. Badros" Date: Thu, 9 Mar 2000 18:58:58 +0000 Subject: [PATCH] *.[ch]: make a distinction between SCM as a generic name for a Scheme object (now a void*), and SCM as 32 bit word for storing tags and immediates (now a long int). Introduced SCM_ASWORD and SCM_ASSCM for conversion. Fixed various dubious code in the process: arbiter.c (use macros), unif.c (scm_array_p), --- libguile/arbiters.c | 14 +- libguile/async.c | 9 +- libguile/boolean.h | 2 +- libguile/debug.c | 4 +- libguile/dynl.c | 4 +- libguile/dynwind.c | 4 +- libguile/eval.c | 80 +- libguile/eval.h | 2 +- libguile/feature.c | 2 +- libguile/feature.h | 2 +- libguile/filesys.c | 2 +- libguile/filesys.h | 2 +- libguile/fluids.c | 2 +- libguile/fluids.h | 4 +- libguile/fports.c | 12 +- libguile/fports.h | 6 +- libguile/gc.c | 39 +- libguile/gc.h | 4 +- libguile/hash.c | 2 +- libguile/keywords.h | 2 +- libguile/macros.c | 2 +- libguile/mallocs.c | 2 +- libguile/numbers.c | 193 ++--- libguile/numbers.h | 19 +- libguile/objects.c | 10 +- libguile/objects.h | 8 +- libguile/options.c | 3 +- libguile/options.h | 5 + libguile/pairs.h | 14 +- libguile/ports.c | 18 +- libguile/ports.h | 14 +- libguile/print.c | 10 +- libguile/print.h | 3 +- libguile/procs.h | 2 +- libguile/ramap.c | 1812 +++++++++++++++++++++---------------------- libguile/read.c | 4 +- libguile/smob.c | 2 +- libguile/smob.h | 2 +- libguile/srcprop.h | 4 +- libguile/stacks.c | 8 +- libguile/stacks.h | 13 +- libguile/strports.c | 4 +- libguile/struct.c | 20 +- libguile/tag.c | 5 +- libguile/tags.h | 71 +- libguile/throw.c | 24 +- libguile/unif.c | 190 +++-- libguile/unif.h | 6 +- libguile/variable.c | 2 +- libguile/variable.h | 2 +- libguile/vectors.h | 10 + libguile/weaks.c | 6 +- libguile/weaks.h | 6 +- 53 files changed, 1351 insertions(+), 1341 deletions(-) diff --git a/libguile/arbiters.c b/libguile/arbiters.c index a121950c1..b3eeb1f30 100644 --- a/libguile/arbiters.c +++ b/libguile/arbiters.c @@ -63,11 +63,15 @@ static long scm_tc16_arbiter; +#define SCM_ARB_LOCKED(arb) (((SCMWORD) SCM_CAR(arb)) & (1L << 16)) +#define SCM_LOCK_ARB(arb) SCM_SETCAR (arb, (SCM) (scm_tc16_arbiter | (1L << 16))); +#define SCM_UNLOCK_ARB(arb) SCM_SETCAR (arb, (SCM) scm_tc16_arbiter); + static int prinarb (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#', port); @@ -91,11 +95,11 @@ SCM_DEFINE (scm_try_arbiter, "try-arbiter", 1, 0, 0, { SCM_VALIDATE_SMOB (1,arb,arbiter); SCM_DEFER_INTS; - if (SCM_CAR (arb) & (1L << 16)) + if (SCM_ARB_LOCKED(arb)) arb = SCM_BOOL_F; else { - SCM_SETCAR (arb, scm_tc16_arbiter | (1L << 16)); + SCM_LOCK_ARB(arb); arb = SCM_BOOL_T; } SCM_ALLOW_INTS; @@ -110,9 +114,9 @@ SCM_DEFINE (scm_release_arbiter, "release-arbiter", 1, 0, 0, #define FUNC_NAME s_scm_release_arbiter { SCM_VALIDATE_SMOB (1,arb,arbiter); - if (!(SCM_CAR (arb) & (1L << 16))) + if (! SCM_ARB_LOCKED(arb)) return SCM_BOOL_F; - SCM_SETCAR (arb, scm_tc16_arbiter); + SCM_UNLOCK_ARB (arb); return SCM_BOOL_T; } #undef FUNC_NAME diff --git a/libguile/async.c b/libguile/async.c index fd3b93152..be35f2949 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -383,9 +383,14 @@ SCM_DEFINE (scm_set_tick_rate, "set-tick-rate", 1, 0, 0, #define FUNC_NAME s_scm_set_tick_rate { unsigned int old_n; + + SCM_VALIDATE_INUM (1,n); + old_n = scm_tick_rate; - scm_desired_tick_rate = SCM_INUM (n); + + + scm_desired_tick_rate = SCM_ASWORD (SCM_INUM (n)); scm_async_rate = 1 + scm_async_rate - scm_async_clock; scm_async_clock = 1; return SCM_MAKINUM (old_n); @@ -403,7 +408,7 @@ SCM_DEFINE (scm_set_switch_rate, "set-switch-rate", 1, 0, 0, unsigned int old_n; SCM_VALIDATE_INUM (1,n); old_n = scm_switch_rate; - scm_desired_switch_rate = SCM_INUM (n); + scm_desired_switch_rate = SCM_ASWORD (SCM_INUM (n)); scm_async_rate = 1 + scm_async_rate - scm_async_clock; scm_async_clock = 1; return SCM_MAKINUM (old_n); diff --git a/libguile/boolean.h b/libguile/boolean.h index b7a575a4a..85008579d 100644 --- a/libguile/boolean.h +++ b/libguile/boolean.h @@ -64,7 +64,7 @@ /* SCM_BOOL_NOT returns the other boolean. * The order of ^s here is important for Borland C++ (!?!?!) */ -#define SCM_BOOL_NOT(x) ((x) ^ (SCM_BOOL_T ^ SCM_BOOL_F)) +#define SCM_BOOL_NOT(x) SCM_ASSCM(SCM_ASWORD(x) ^ (SCM_ASWORD (SCM_BOOL_T) ^ SCM_ASWORD (SCM_BOOL_F))) diff --git a/libguile/debug.c b/libguile/debug.c index 9cbcb52b0..45431ad73 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -275,7 +275,7 @@ SCM_DEFINE (scm_gloc_p, "gloc?", 1, 0, 0, #define FUNC_NAME s_scm_gloc_p { return SCM_BOOL((SCM_MEMOIZEDP (obj) - && (SCM_MEMOIZED_EXP (obj) & 7) == 1)); + && (SCM_ASWORD(SCM_MEMOIZED_EXP (obj)) & 7) == 1)); } #undef FUNC_NAME @@ -559,7 +559,7 @@ static int prindebugobj (SCM obj,SCM port,scm_print_state *pstate) { scm_puts ("#', port); return 1; } diff --git a/libguile/dynl.c b/libguile/dynl.c index 8634e7569..2e739c6bc 100644 --- a/libguile/dynl.c +++ b/libguile/dynl.c @@ -414,7 +414,7 @@ static struct dynl_obj * get_dynl_obj (SCM dobj,const char *subr,int argn) { struct dynl_obj *d; - SCM_ASSERT (SCM_NIMP (dobj) && SCM_CAR (dobj) == scm_tc16_dynamic_obj, + SCM_ASSERT (SCM_NIMP (dobj) && SCM_CARW (dobj) == scm_tc16_dynamic_obj, dobj, argn, subr); d = (struct dynl_obj *)SCM_CDR (dobj); SCM_ASSERT (d->handle != NULL, dobj, argn, subr); @@ -427,7 +427,7 @@ SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0, "otherwise.") #define FUNC_NAME s_scm_dynamic_object_p { - return SCM_BOOL(SCM_NIMP (obj) && SCM_CAR (obj) == scm_tc16_dynamic_obj); + return SCM_BOOL(SCM_NIMP (obj) && SCM_CARW (obj) == scm_tc16_dynamic_obj); } #undef FUNC_NAME diff --git a/libguile/dynwind.c b/libguile/dynwind.c index 0f93efc13..7fd3f6292 100644 --- a/libguile/dynwind.c +++ b/libguile/dynwind.c @@ -145,7 +145,7 @@ typedef struct guardsmem { #define SCM_BEFORE_GUARD(obj) (SCM_GUARDSMEM (obj)->before) #define SCM_AFTER_GUARD(obj) (SCM_GUARDSMEM (obj)->after) #define SCM_GUARD_DATA(obj) (SCM_GUARDSMEM (obj)->data) -#define SCM_GUARDSP(obj) (SCM_NIMP(obj) && (SCM_CAR (obj) == tc16_guards)) +#define SCM_GUARDSP(obj) (SCM_NIMP(obj) && (SCM_CARW (obj) == tc16_guards)) static long tc16_guards; @@ -160,7 +160,7 @@ static int printguards (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#', port); return 1; } diff --git a/libguile/eval.c b/libguile/eval.c index 35ff33d7e..6a494faa5 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -319,7 +319,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check) #endif } #ifdef MEMOIZE_LOCALS - iloc = (~SCM_IDSTMSK) & (iloc + SCM_IFRINC); + iloc = SCM_ASSCM ((~SCM_IDSTMSK) & SCM_ASWORD(iloc + SCM_IFRINC)); #endif } { @@ -409,7 +409,7 @@ scm_unmemocar (SCM form, SCM env) if (SCM_IMP (form)) return form; c = SCM_CAR (form); - if (1 == (c & 7)) + if (1 == (SCM_ASWORD (c) & 7)) SCM_SETCAR (form, SCM_CAR (c - 1)); #ifdef MEMOIZE_LOCALS #ifdef DEBUG_EXTENSIONS @@ -1262,7 +1262,7 @@ scm_macroexp (SCM x, SCM env) if (SCM_IMP (proc) || scm_tc16_macro != SCM_TYP16 (proc) - || (int) (SCM_CAR (proc) >> 16) != 2) + || (int) (SCM_CARW (proc) >> 16) != 2) return x; unmemocar (x, env); @@ -1295,6 +1295,8 @@ scm_macroexp (SCM x, SCM env) * readable style... :) */ +#define SCM_BIT8(x) (127 & SCM_ASWORD (x)) + static SCM unmemocopy (SCM x, SCM env) { @@ -1309,28 +1311,28 @@ unmemocopy (SCM x, SCM env) #endif switch (SCM_TYP7 (x)) { - case (127 & SCM_IM_AND): + case SCM_BIT8(SCM_IM_AND): ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_BEGIN): + case SCM_BIT8(SCM_IM_BEGIN): ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_CASE): + case SCM_BIT8(SCM_IM_CASE): ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_COND): + case SCM_BIT8(SCM_IM_COND): ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_DO): + case SCM_BIT8(SCM_IM_DO): ls = scm_cons (scm_sym_do, SCM_UNSPECIFIED); goto transform; - case (127 & SCM_IM_IF): + case SCM_BIT8(SCM_IM_IF): ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_LET): + case SCM_BIT8(SCM_IM_LET): ls = scm_cons (scm_sym_let, SCM_UNSPECIFIED); goto transform; - case (127 & SCM_IM_LETREC): + case SCM_BIT8(SCM_IM_LETREC): { SCM f, v, e, s; ls = scm_cons (scm_sym_letrec, SCM_UNSPECIFIED); @@ -1378,7 +1380,7 @@ unmemocopy (SCM x, SCM env) } break; } - case (127 & SCM_IM_LETSTAR): + case SCM_BIT8(SCM_IM_LETSTAR): { SCM b, y; x = SCM_CDR (x); @@ -1417,22 +1419,22 @@ unmemocopy (SCM x, SCM env) ls = scm_cons (scm_sym_letstar, z = scm_cons (y, SCM_UNSPECIFIED)); break; } - case (127 & SCM_IM_OR): + case SCM_BIT8(SCM_IM_OR): ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_LAMBDA): + case SCM_BIT8(SCM_IM_LAMBDA): x = SCM_CDR (x); ls = scm_cons (scm_sym_lambda, z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED)); env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env); break; - case (127 & SCM_IM_QUOTE): + case SCM_BIT8(SCM_IM_QUOTE): ls = z = scm_cons (scm_sym_quote, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_SET_X): + case SCM_BIT8(SCM_IM_SET_X): ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED); break; - case (127 & SCM_IM_DEFINE): + case SCM_BIT8(SCM_IM_DEFINE): { SCM n; x = SCM_CDR (x); @@ -1442,7 +1444,7 @@ unmemocopy (SCM x, SCM env) SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAR (SCM_CAR (env)))); break; } - case (127 & SCM_MAKISYM (0)): + case SCM_BIT8(SCM_MAKISYM (0)): z = SCM_CAR (x); if (!SCM_ISYMP (z)) goto unmemo; @@ -1916,7 +1918,7 @@ dispatch: x = scm_cons (x, SCM_UNDEFINED); goto retval; - case (127 & SCM_IM_AND): + case SCM_BIT8(SCM_IM_AND): x = SCM_CDR (x); t.arg1 = x; while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) @@ -1929,7 +1931,7 @@ dispatch: PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto carloop; - case (127 & SCM_IM_BEGIN): + case SCM_BIT8(SCM_IM_BEGIN): cdrxnoap: PREP_APPLY (SCM_UNDEFINED, SCM_EOL); cdrxbegin: @@ -1969,7 +1971,7 @@ dispatch: goto loop; /* tail recurse */ - case (127 & SCM_IM_CASE): + case SCM_BIT8(SCM_IM_CASE): x = SCM_CDR (x); t.arg1 = EVALCAR (x, env); while (SCM_NIMP (x = SCM_CDR (x))) @@ -1996,7 +1998,7 @@ dispatch: RETURN (SCM_UNSPECIFIED) - case (127 & SCM_IM_COND): + case SCM_BIT8(SCM_IM_COND): while (SCM_NIMP (x = SCM_CDR (x))) { proc = SCM_CAR (x); @@ -2024,7 +2026,7 @@ dispatch: RETURN (SCM_UNSPECIFIED) - case (127 & SCM_IM_DO): + case SCM_BIT8(SCM_IM_DO): x = SCM_CDR (x); proc = SCM_CAR (SCM_CDR (x)); /* inits */ t.arg1 = SCM_EOL; /* values */ @@ -2055,7 +2057,7 @@ dispatch: goto begin; - case (127 & SCM_IM_IF): + case SCM_BIT8(SCM_IM_IF): x = SCM_CDR (x); if (SCM_NFALSEP (EVALCAR (x, env))) x = SCM_CDR (x); @@ -2067,7 +2069,7 @@ dispatch: goto carloop; - case (127 & SCM_IM_LET): + case SCM_BIT8(SCM_IM_LET): x = SCM_CDR (x); proc = SCM_CAR (SCM_CDR (x)); t.arg1 = SCM_EOL; @@ -2081,7 +2083,7 @@ dispatch: goto cdrxnoap; - case (127 & SCM_IM_LETREC): + case SCM_BIT8(SCM_IM_LETREC): x = SCM_CDR (x); env = EXTEND_ENV (SCM_CAR (x), scm_undefineds, env); x = SCM_CDR (x); @@ -2096,7 +2098,7 @@ dispatch: goto cdrxnoap; - case (127 & SCM_IM_LETSTAR): + case SCM_BIT8(SCM_IM_LETSTAR): x = SCM_CDR (x); proc = SCM_CAR (x); if (SCM_IMP (proc)) @@ -2113,7 +2115,7 @@ dispatch: while (SCM_NIMP (proc = SCM_CDR (proc))); goto cdrxnoap; - case (127 & SCM_IM_OR): + case SCM_BIT8(SCM_IM_OR): x = SCM_CDR (x); t.arg1 = x; while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) @@ -2129,15 +2131,15 @@ dispatch: goto carloop; - case (127 & SCM_IM_LAMBDA): + case SCM_BIT8(SCM_IM_LAMBDA): RETURN (scm_closure (SCM_CDR (x), env)); - case (127 & SCM_IM_QUOTE): + case SCM_BIT8(SCM_IM_QUOTE): RETURN (SCM_CAR (SCM_CDR (x))); - case (127 & SCM_IM_SET_X): + case SCM_BIT8(SCM_IM_SET_X): x = SCM_CDR (x); proc = SCM_CAR (x); switch (7 & (int) proc) @@ -2163,11 +2165,11 @@ dispatch: #endif - case (127 & SCM_IM_DEFINE): /* only for internal defines */ + case SCM_BIT8(SCM_IM_DEFINE): /* only for internal defines */ scm_misc_error (NULL, "Bad define placement", SCM_EOL); /* new syntactic forms go here. */ - case (127 & SCM_MAKISYM (0)): + case SCM_BIT8(SCM_MAKISYM (0)): proc = SCM_CAR (x); SCM_ASRTGO (SCM_ISYMP (proc), badfun); switch SCM_ISYMNUM (proc) @@ -2297,8 +2299,8 @@ dispatch: if (SCM_NIMP (t.arg1)) do { - i += (SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1))) - [scm_si_hashsets + hashset]); + i += SCM_ASWORD ((SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1)))) + [scm_si_hashsets + hashset]); t.arg1 = SCM_CDR (t.arg1); } while (--j && SCM_NIMP (t.arg1)); @@ -2484,7 +2486,7 @@ dispatch: RETURN (x); #ifdef MEMOIZE_LOCALS - case (127 & SCM_ILOC00): + case SCM_BIT8(SCM_ILOC00): proc = *scm_ilookup (SCM_CAR (x), env); SCM_ASRTGO (SCM_NIMP (proc), badfun); #ifndef SCM_RECKLESS @@ -2546,7 +2548,7 @@ dispatch: #ifdef DEVAL SCM_CLEAR_MACROEXP (debug); #endif - switch ((int) (SCM_CAR (proc) >> 16)) + switch ((int) (SCM_CARW (proc) >> 16)) { case 2: if (scm_ilength (t.arg1) <= 0) @@ -3709,10 +3711,10 @@ SCM_DEFINE (scm_force, "force", 1, 0, 0, #define FUNC_NAME s_scm_force { SCM_VALIDATE_SMOB (1,x,promise); - if (!((1L << 16) & SCM_CAR (x))) + if (!((1L << 16) & SCM_CARW (x))) { SCM ans = scm_apply (SCM_CDR (x), SCM_EOL, SCM_EOL); - if (!((1L << 16) & SCM_CAR (x))) + if (!((1L << 16) & SCM_CARW (x))) { SCM_DEFER_INTS; SCM_SETCDR (x, ans); diff --git a/libguile/eval.h b/libguile/eval.h index 1c05955b5..ddfcc1853 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -83,7 +83,7 @@ extern SCM scm_eval_options_interface (SCM setting); #define SCM_IDSTMSK (-SCM_IDINC) #define SCM_IFRAME(n) ((int)((SCM_ICDR-SCM_IFRINC)>>8) & ((int)(n)>>8)) #define SCM_IDIST(n) (((unsigned long)(n))>>20) -#define SCM_ICDRP(n) (SCM_ICDR & (n)) +#define SCM_ICDRP(n) (SCM_ICDR & SCM_ASWORD(n)) diff --git a/libguile/feature.c b/libguile/feature.c index a6bb4347e..e04eb4d6f 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -142,7 +142,7 @@ print_hook (SCM hook, SCM port, scm_print_state *pstate) } scm_intprint (SCM_HOOK_ARITY (hook), 10, port); scm_putc (' ', port); - scm_intprint (hook, 16, port); + scm_intprint ((int)hook, 16, port); ls = SCM_HOOK_PROCEDURES (hook); while (SCM_NIMP (ls)) { diff --git a/libguile/feature.h b/libguile/feature.h index 8ba59891b..90f9008af 100644 --- a/libguile/feature.h +++ b/libguile/feature.h @@ -50,7 +50,7 @@ #include "libguile/__scm.h" #define SCM_HOOKP(x) (SCM_NIMP(x) && (SCM_TYP16 (x) == scm_tc16_hook)) -#define SCM_HOOK_ARITY(hook) (SCM_CAR (hook) >> 16) +#define SCM_HOOK_ARITY(hook) (SCM_CARW (hook) >> 16) #define SCM_HOOK_NAME(hook) SCM_CADR (hook) #define SCM_HOOK_PROCEDURES(hook) SCM_CDDR (hook) #define SCM_SET_HOOK_PROCEDURES(hook, procs) SCM_SETCDR (SCM_CDR (hook), procs) diff --git a/libguile/filesys.c b/libguile/filesys.c index 6a909d8cc..9bc67dc01 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -751,7 +751,7 @@ scm_dir_print (SCM exp, SCM port, scm_print_state *pstate) if (SCM_CLOSEDP (exp)) scm_puts ("closed: ", port); scm_puts ("directory stream ", port); - scm_intprint (SCM_CDR (exp), 16, port); + scm_intprint ((int)SCM_CDR (exp), 16, port); scm_putc ('>', port); return 1; } diff --git a/libguile/filesys.h b/libguile/filesys.h index d5bb7fbe6..d4d8c9119 100644 --- a/libguile/filesys.h +++ b/libguile/filesys.h @@ -54,7 +54,7 @@ extern long scm_tc16_dir; #define SCM_DIRP(x) (SCM_NIMP(x) && (SCM_TYP16(x)==(scm_tc16_dir))) -#define SCM_OPDIRP(x) (SCM_NIMP(x) && (SCM_CAR(x)==(scm_tc16_dir | SCM_OPN))) +#define SCM_OPDIRP(x) (SCM_NIMP(x) && (SCM_CARW(x)==(scm_tc16_dir | SCM_OPN))) extern SCM scm_chown (SCM object, SCM owner, SCM group); diff --git a/libguile/fluids.c b/libguile/fluids.c index 1254e3a5b..5b1c86363 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -99,7 +99,7 @@ static int print_fluid (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#', port); return 1; } diff --git a/libguile/fluids.h b/libguile/fluids.h index 83ccbbe38..f36da3ff5 100644 --- a/libguile/fluids.h +++ b/libguile/fluids.h @@ -75,8 +75,8 @@ extern long scm_tc16_fluid; -#define SCM_FLUIDP(x) (SCM_NIMP(x) && (SCM_CAR(x) == scm_tc16_fluid)) -#define SCM_FLUID_NUM(x) SCM_CDR(x) +#define SCM_FLUIDP(x) (SCM_NIMP(x) && (SCM_CARW (x) == scm_tc16_fluid)) +#define SCM_FLUID_NUM(x) SCM_ASWORD (SCM_CDR(x)) /* The fastest way to acces/modify the value of a fluid. These macros do no error checking at all. You should only use them when you know diff --git a/libguile/fports.c b/libguile/fports.c index 4d98e1875..fdb2b4527 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -124,9 +124,9 @@ scm_fport_buffer_add (SCM port, int read_size, int write_size) pt->write_end = pt->write_buf + pt->write_buf_size; if (read_size > 0 || write_size > 0) - SCM_SETCAR (port, SCM_CAR (port) & ~SCM_BUF0); + SCM_SETCAR (port, SCM_CARW (port) & ~SCM_BUF0); else - SCM_SETCAR (port, (SCM_CAR (port) | SCM_BUF0)); + SCM_SETCAR (port, (SCM_CARW (port) | SCM_BUF0)); } SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, @@ -180,12 +180,12 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0, if (cmode == _IOLBF) { - SCM_SETCAR (port, SCM_CAR (port) | SCM_BUFLINE); + SCM_SETCAR (port, SCM_CARW (port) | SCM_BUFLINE); cmode = _IOFBF; } else { - SCM_SETCAR (port, SCM_CAR (port) ^ SCM_BUFLINE); + SCM_SETCAR (port, SCM_CARW (port) ^ SCM_BUFLINE); } if (SCM_UNBNDP (size)) @@ -456,7 +456,7 @@ prinfport (SCM exp,SCM port,scm_print_state *pstate) { scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port); scm_putc (' ', port); - scm_intprint (SCM_CDR (exp), 16, port); + scm_intprint (SCM_ASWORD (SCM_CDR (exp)), 16, port); } scm_putc ('>', port); return 1; @@ -610,7 +610,7 @@ fport_write (SCM port, const void *data, size_t size) } /* handle line buffering. */ - if ((SCM_CAR (port) & SCM_BUFLINE) && memchr (data, '\n', size)) + if ((SCM_CARW (port) & SCM_BUFLINE) && memchr (data, '\n', size)) fport_flush (port); } } diff --git a/libguile/fports.h b/libguile/fports.h index d720621f4..c1dbe0667 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -62,9 +62,9 @@ struct scm_fport { #define SCM_FPORT_FDES(x) (SCM_FSTREAM (x)->fdes) #define SCM_FPORTP(x) (SCM_NIMP(x) && (SCM_TYP16S(x)==scm_tc7_port)) -#define SCM_OPFPORTP(x) (SCM_NIMP(x) && (((0xfeff | SCM_OPN) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN))) -#define SCM_OPINFPORTP(x) (SCM_NIMP(x) && (((0xfeff | SCM_OPN | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG))) -#define SCM_OPOUTFPORTP(x) (SCM_NIMP(x) && (((0xfeff | SCM_OPN | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG))) +#define SCM_OPFPORTP(x) (SCM_NIMP(x) && (((0xfeff | SCM_OPN) & SCM_CARW (x))==(scm_tc7_port | SCM_OPN))) +#define SCM_OPINFPORTP(x) (SCM_NIMP(x) && (((0xfeff | SCM_OPN | SCM_RDNG) & SCM_CARW (x))==(scm_tc7_port | SCM_OPN | SCM_RDNG))) +#define SCM_OPOUTFPORTP(x) (SCM_NIMP(x) && (((0xfeff | SCM_OPN | SCM_WRTNG) & SCM_CARW (x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG))) /* test whether fdes supports random access. */ #define SCM_FDES_RANDOM_P(fdes) ((lseek (fdes, 0, SEEK_CUR) == -1) ? 0 : 1) diff --git a/libguile/gc.c b/libguile/gc.c index 4b8cb7ef0..5d3fc5bd9 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -353,11 +353,11 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, int i; int n; SCM heap_segs; - SCM local_scm_mtrigger; - SCM local_scm_mallocated; - SCM local_scm_heap_size; - SCM local_scm_cells_allocated; - SCM local_scm_gc_time_taken; + long int local_scm_mtrigger; + long int local_scm_mallocated; + long int local_scm_heap_size; + long int local_scm_cells_allocated; + long int local_scm_gc_time_taken; SCM answer; SCM_DEFER_INTS; @@ -373,6 +373,7 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0, goto retry; scm_block_gc = 0; + /// ? ?? ? local_scm_mtrigger = scm_mtrigger; local_scm_mallocated = scm_mallocated; local_scm_heap_size = scm_heap_size; @@ -405,7 +406,7 @@ void scm_gc_end () { scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt; - scm_gc_time_taken = scm_gc_time_taken + scm_gc_rt; + scm_gc_time_taken += scm_gc_rt; scm_system_async_mark (scm_gc_async); } @@ -667,7 +668,7 @@ gc_mark_nimp: { SCM vcell; vcell = SCM_CAR (ptr) - 1L; - switch (SCM_CDR (vcell)) + switch (SCM_ASWORD (SCM_CDR (vcell))) { default: scm_gc_mark (vcell); @@ -691,7 +692,7 @@ gc_mark_nimp: that it removes the mark */ mem = (SCM *)SCM_GCCDR (ptr); - if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) + if (SCM_ASWORD (vtable_data[scm_struct_i_flags]) & SCM_STRUCTF_ENTITY) { scm_gc_mark (mem[scm_struct_i_procedure]); scm_gc_mark (mem[scm_struct_i_setter]); @@ -703,8 +704,9 @@ gc_mark_nimp: scm_gc_mark (*mem); if (fields_desc[x] == 'p') { + int j; if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) - for (x = *mem; x; --x) + for (j = (long int) *mem; x; --x) scm_gc_mark (*++mem); else scm_gc_mark (*mem); @@ -922,7 +924,7 @@ scm_mark_locations (SCM_STACKITEM x[], scm_sizet n) register SCM_CELLPTR ptr; while (0 <= --m) - if SCM_CELLP (*(SCM **) & x[m]) + if (SCM_CELLP (*(SCM **) (& x[m]))) { ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & x[m])); i = 0; @@ -987,7 +989,7 @@ scm_cellp (SCM value) register int i, j; register SCM_CELLPTR ptr; - if SCM_CELLP (*(SCM **) & value) + if SCM_CELLP (*(SCM **) (& value)) { ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & value)); i = 0; @@ -1138,7 +1140,7 @@ scm_gc_sweep () SCM vcell; vcell = SCM_CAR (scmptr) - 1L; - if ((SCM_CDR (vcell) == 0) || (SCM_CDR (vcell) == 1)) + if ((SCM_CDR (vcell) == 0) || (SCM_ASWORD (SCM_CDR (vcell)) == 1)) { scm_struct_free_t free = (scm_struct_free_t) ((SCM*) vcell)[scm_struct_i_free]; @@ -1290,7 +1292,7 @@ scm_gc_sweep () case scm_tc16_flo: if SCM_GC8MARKP (scmptr) goto c8mrkcontinue; - switch ((int) (SCM_CAR (scmptr) >> 16)) + switch ((int) (SCM_CARW (scmptr) >> 16)) { case (SCM_IMAG_PART | SCM_REAL_PART) >> 16: m += sizeof (double); @@ -1782,7 +1784,7 @@ SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0, --incar; if ( ((name == SCM_BOOL_T) || (SCM_CAR (incar) == name)) && (SCM_CDR (incar) != 0) - && (SCM_CDR (incar) != 1)) + && (SCM_ASWORD (SCM_CDR (incar)) != 1)) { p->car = name; } @@ -1806,6 +1808,9 @@ scm_remember (SCM *ptr) { /* empty */ } +/* + What the heck is this? --hwn + */ SCM scm_return_first (SCM elt, ...) { @@ -1827,9 +1832,9 @@ scm_permanent_object (SCM obj) even if all other references are dropped, until someone applies scm_unprotect_object to it. This function returns OBJ. - Calls to scm_protect_object nest. For every object O, there is a - counter which scm_protect_object(O) increments and - scm_unprotect_object(O) decrements, if it is greater than zero. If + Calls to scm_protect_object nest. For every object OBJ, there is a + counter which scm_protect_object(OBJ) increments and + scm_unprotect_object(OBJ) decrements, if it is greater than zero. If an object's counter is greater than zero, the garbage collector will not free it. diff --git a/libguile/gc.h b/libguile/gc.h index c06526b02..d971caa89 100644 --- a/libguile/gc.h +++ b/libguile/gc.h @@ -50,12 +50,12 @@ #include "libguile/__scm.h" -#define SCM_FREEP(x) (SCM_NIMP(x) && SCM_CAR(x)==scm_tc_free_cell) +#define SCM_FREEP(x) (SCM_NIMP(x) && SCM_CARW (x)==scm_tc_free_cell) #define SCM_NFREEP(x) (!SCM_FREEP(x)) /* 1. This shouldn't be used on immediates. 2. It thinks that subrs are always unmarked (harmless). */ -#define SCM_MARKEDP(x) ((SCM_CAR(x) & 5) == 5 \ +#define SCM_MARKEDP(x) ((SCM_CARW (x) & 5) == 5 \ ? SCM_GC8MARKP(x) \ : SCM_GCMARKP(x)) #define SCM_NMARKEDP(x) (!SCM_MARKEDP(x)) diff --git a/libguile/hash.c b/libguile/hash.c index ee78c3fa7..6a6c8d08a 100644 --- a/libguile/hash.c +++ b/libguile/hash.c @@ -140,7 +140,7 @@ scm_hasher(SCM obj, unsigned long n, scm_sizet d) if (d) return (scm_hasher(SCM_CAR(obj), n, d/2)+scm_hasher(SCM_CDR(obj), n, d/2)) % n; else return 1; case scm_tc7_port: - return ((SCM_RDNG & SCM_CAR(obj)) ? 260 : 261) % n; + return ((SCM_RDNG & SCM_CARW(obj)) ? 260 : 261) % n; case scm_tcs_closures: case scm_tc7_contin: case scm_tcs_subrs: diff --git a/libguile/keywords.h b/libguile/keywords.h index 3bac1bbf9..b20b5f0a0 100644 --- a/libguile/keywords.h +++ b/libguile/keywords.h @@ -52,7 +52,7 @@ extern int scm_tc16_keyword; -#define SCM_KEYWORDP(X) (SCM_NIMP(X) && (SCM_CAR(X) == scm_tc16_keyword)) +#define SCM_KEYWORDP(X) (SCM_NIMP(X) && (SCM_CARW (X) == scm_tc16_keyword)) #define SCM_KEYWORDSYM(X) (SCM_CDR(X)) diff --git a/libguile/macros.c b/libguile/macros.c index 0db571ddd..6af47c73d 100644 --- a/libguile/macros.c +++ b/libguile/macros.c @@ -134,7 +134,7 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0, { if (!(SCM_NIMP (m) && SCM_TYP16 (m) == scm_tc16_macro)) return SCM_BOOL_F; - switch ((int) (SCM_CAR (m) >> 16)) + switch ((int) (SCM_CARW (m) >> 16)) { case 0: return scm_sym_syntax; case 1: return scm_sym_macro; diff --git a/libguile/mallocs.c b/libguile/mallocs.c index 46c3db6b7..659ce4688 100644 --- a/libguile/mallocs.c +++ b/libguile/mallocs.c @@ -54,7 +54,7 @@ static int prinmalloc (SCM exp,SCM port,scm_print_state *pstate) { scm_puts("#', port); return 1; } diff --git a/libguile/numbers.c b/libguile/numbers.c index cb8afe536..05f26d342 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -151,6 +151,7 @@ SCM_GPROC (s_abs, "abs", 1, 0, 0, scm_abs, g_abs); SCM scm_abs (SCM x) { + long int cx; #ifdef SCM_BIGDIG if (SCM_NINUMP (x)) { @@ -164,14 +165,14 @@ scm_abs (SCM x) #endif if (SCM_INUM (x) >= 0) return x; - x = - SCM_INUM (x); - if (!SCM_POSFIXABLE (x)) + cx = - SCM_INUM (x); + if (!SCM_POSFIXABLE (cx)) #ifdef SCM_BIGDIG - return scm_long2big (x); + return scm_long2big (cx); #else - scm_num_overflow (s_abs); + scm_num_overflow (s_abs); #endif - return SCM_MAKINUM (x); + return SCM_MAKINUM (cx); } SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient); @@ -183,7 +184,6 @@ scm_quotient (SCM x, SCM y) #ifdef SCM_BIGDIG if (SCM_NINUMP (x)) { - long w; SCM_GASSERT2 (SCM_BIGP (x), g_quotient, x, y, SCM_ARG1, s_quotient); if (SCM_NINUMP (y)) @@ -201,24 +201,24 @@ scm_quotient (SCM x, SCM y) z = -z; if (z < SCM_BIGRAD) { - w = scm_copybig (x, SCM_BIGSIGN (x) ? (y > 0) : (y < 0)); - scm_divbigdig (SCM_BDIGITS (w), SCM_NUMDIGS (w), (SCM_BIGDIG) z); - return scm_normbig (w); + SCM sw = scm_copybig (x, SCM_BIGSIGN (x) ? (SCM_ASWORD (y) > 0) : (SCM_ASWORD (y) < 0)); + scm_divbigdig (SCM_BDIGITS (sw), SCM_NUMDIGS (sw), (SCM_BIGDIG) z); + return scm_normbig (sw); } + { /* scope */ #ifndef SCM_DIGSTOOBIG - w = scm_pseudolong (z); + long w = scm_pseudolong (z); return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), (SCM_BIGDIG *) & w, SCM_DIGSPERLONG, SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 2); #else - { SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; scm_longdigs (z, zdigs); return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), zdigs, SCM_DIGSPERLONG, SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 2); - } #endif + } /* end scope */ } if (SCM_NINUMP (y)) { @@ -377,7 +377,7 @@ SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd); SCM scm_gcd (SCM x, SCM y) { - register long u, v, k, t; + long u, v, k, t; if (SCM_UNBNDP (y)) return SCM_UNBNDP (x) ? SCM_INUM0 : x; tailrec: @@ -400,9 +400,11 @@ scm_gcd (SCM x, SCM y) { case -1: swaprec: - t = scm_remainder (x, y); - x = y; - y = t; + { + SCM t = scm_remainder (x, y); + x = y; + y = t; + } goto tailrec; case 0: return x; @@ -419,7 +421,7 @@ scm_gcd (SCM x, SCM y) } if (SCM_NINUMP (y)) { - t = x; + SCM t = x; x = y; y = t; goto big_gcd; @@ -694,7 +696,7 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0, #define FUNC_NAME s_scm_ash { /* GJB:FIXME:: what is going on here? */ - SCM res = SCM_INUM (n); + SCM res = SCM_ASSCM (SCM_INUM (n)); SCM_VALIDATE_INUM (2,cnt); #ifdef SCM_BIGDIG if (cnt < 0) @@ -862,10 +864,11 @@ static const char s_bignum[] = "bignum"; SCM scm_mkbig (scm_sizet nlen, int sign) { - SCM v = nlen; - /* Cast to SCM to avoid signed/unsigned comparison warnings. */ - if (((v << 16) >> 16) != (SCM) nlen) + SCM v; + /* Cast to long int to avoid signed/unsigned comparison warnings. */ + if ((( ((long int)nlen) << 16) >> 16) != (long int) nlen) scm_wta (SCM_MAKINUM (nlen), (char *) SCM_NALLOC, s_bignum); + SCM_NEWCELL (v); SCM_DEFER_INTS; SCM_SETCHARS (v, scm_must_malloc ((long) (nlen * sizeof (SCM_BIGDIG)), @@ -1168,7 +1171,7 @@ scm_addbig (SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny) { num = 1; i = 0; - SCM_SETCAR (z, SCM_CAR (z) ^ 0x0100); + SCM_SETCAR (z, SCM_CARW (z) ^ 0x0100); do { num += (SCM_BIGRAD - 1) - zds[i]; @@ -2864,7 +2867,7 @@ scm_positive_p (SCM x) SCM_GASSERT1 (SCM_INUMP (x), g_positive_p, x, SCM_ARG1, s_positive_p); #endif #endif - return SCM_BOOL(x > SCM_INUM0); + return SCM_BOOL(SCM_INUM(x) > 0); } @@ -2904,7 +2907,7 @@ scm_negative_p (SCM x) SCM_GASSERT1 (SCM_INUMP (x), g_negative_p, x, SCM_ARG1, s_negative_p); #endif #endif - return SCM_BOOL(x < SCM_INUM0); + return SCM_BOOL(SCM_INUM(x) < 0); } @@ -3015,6 +3018,8 @@ scm_max (SCM x, SCM y) } +#define SCM_SWAP(x,y) do { SCM t = x; x = y; y = t; } while (0) + SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min); @@ -3128,6 +3133,10 @@ scm_min (SCM x, SCM y) SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum); +/* + This is sick, sick, sick code. + + */ SCM scm_sum (SCM x, SCM y) { @@ -3141,8 +3150,7 @@ scm_sum (SCM x, SCM y) #ifdef SCM_FLOATS if (SCM_NINUMP (x)) { - SCM t; -#ifdef SCM_BIGDIG +# ifdef SCM_BIGDIG if (!SCM_NIMP (x)) { badx2: @@ -3152,9 +3160,7 @@ scm_sum (SCM x, SCM y) { if (SCM_INUMP (y)) { - t = x; - x = y; - y = t; + SCM_SWAP(x,y); goto intbig; } SCM_ASRTGO (SCM_NIMP (y), bady); @@ -3162,9 +3168,7 @@ scm_sum (SCM x, SCM y) { if (SCM_NUMDIGS (x) > SCM_NUMDIGS (y)) { - t = x; - x = y; - y = t; + SCM_SWAP(x,y); } return scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), SCM_BIGSIGN (x), @@ -3175,24 +3179,19 @@ scm_sum (SCM x, SCM y) return scm_makdbl (scm_big2dbl (x) + SCM_REALPART (y), SCM_CPLXP (y) ? SCM_IMAG (y) : 0.0); } +# endif /* SCM_BIGDIG */ SCM_ASRTGO (SCM_INEXP (x), badx2); -#else - SCM_ASRTGO (SCM_INEXP (x), badx2); -#endif + if (SCM_INUMP (y)) { - t = x; - x = y; - y = t; + SCM_SWAP(x,y); goto intreal; } -#ifdef SCM_BIGDIG +# ifdef SCM_BIGDIG SCM_ASRTGO (SCM_NIMP (y), bady); if (SCM_BIGP (y)) { - t = x; - x = y; - y = t; + SCM_SWAP(x,y); goto bigreal; } else if (!SCM_INEXP (y)) @@ -3200,13 +3199,13 @@ scm_sum (SCM x, SCM y) bady: SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); } -#else +# else /* SCM_BIGDIG */ if (!SCM_INEXP (y)) { bady: SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); } -#endif +# endif /* SCM_BIGDIG */ { double i = 0.0; if (SCM_CPLXP (x)) @@ -3218,54 +3217,46 @@ scm_sum (SCM x, SCM y) } if (SCM_NINUMP (y)) { -#ifdef SCM_BIGDIG +# ifdef SCM_BIGDIG SCM_ASRTGO (SCM_NIMP (y), bady); if (SCM_BIGP (y)) { intbig: { -#ifndef SCM_DIGSTOOBIG +# ifndef SCM_DIGSTOOBIG long z = scm_pseudolong (SCM_INUM (x)); return scm_addbig ((SCM_BIGDIG *) & z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); -#else +# else /* SCM_DIGSTOOBIG */ SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; scm_longdigs (SCM_INUM (x), zdigs); return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); -#endif +# endif /* SCM_DIGSTOOBIG */ } } +# endif /* SCM_BIGDIG */ SCM_ASRTGO (SCM_INEXP (y), bady); -#else - SCM_ASRTGO (SCM_INEXP (y), bady); -#endif intreal: return scm_makdbl (SCM_INUM (x) + SCM_REALPART (y), SCM_CPLXP (y) ? SCM_IMAG (y) : 0.0); } -#else -#ifdef SCM_BIGDIG +#else /* SCM_FLOATS */ +# ifdef SCM_BIGDIG if (SCM_NINUMP (x)) { SCM t; SCM_ASRTGO (SCM_BIGP (x), badx2); if (SCM_INUMP (y)) { - t = x; - x = y; - y = t; + SCM_SWAP(x,y); goto intbig; } SCM_ASRTGO (SCM_BIGP (y), bady); if (SCM_NUMDIGS (x) > SCM_NUMDIGS (y)) - { - t = x; - x = y; - y = t; - } + SCM_SWAP(x,y); return scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), SCM_BIGSIGN (x), y, 0); } @@ -3278,34 +3269,38 @@ scm_sum (SCM x, SCM y) } intbig: { -#ifndef SCM_DIGSTOOBIG +# ifndef SCM_DIGSTOOBIG long z = scm_pseudolong (SCM_INUM (x)); return scm_addbig (&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); -#else +# else SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; scm_longdigs (SCM_INUM (x), zdigs); return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); -#endif +# endif /* SCM_DIGSTOOBIG */ } } -#else +# else /* SCM_BIGDIG */ SCM_ASRTGO (SCM_INUMP (x), badx2); SCM_GASSERT2 (SCM_INUMP (y), g_sum, x, y, SCM_ARGn, s_sum); -#endif -#endif - x = SCM_INUM (x) + SCM_INUM (y); - if (SCM_FIXABLE (x)) - return SCM_MAKINUM (x); +# endif/* SCM_BIGDIG */ +#endif /* SCM_FLOATS */ + + { /* scope */ + long int i = SCM_INUM (x) + SCM_INUM (y); + if (SCM_FIXABLE (i)) + return SCM_MAKINUM (i); #ifdef SCM_BIGDIG - return scm_long2big (x); -#else -#ifdef SCM_FLOATS - return scm_makdbl ((double) x, 0.0); -#else - scm_num_overflow (s_sum); - return SCM_UNSPECIFIED; -#endif -#endif + return scm_long2big (i); +#else /* SCM_BIGDIG */ + +# ifdef SCM_FLOATS + return scm_makdbl ((double) i, 0.0); +# else + scm_num_overflow (s_sum); + return SCM_UNSPECIFIED; +# endif/* SCM_FLOATS */ +#endif /* SCM_BIGDIG */ + } /* end scope */ } @@ -3313,13 +3308,17 @@ scm_sum (SCM x, SCM y) SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference); +/* + HWN:FIXME:: This is sick,sick, sick code. Rewrite me. +*/ SCM scm_difference (SCM x, SCM y) { + long int cx = 0; #ifdef SCM_FLOATS if (SCM_NINUMP (x)) { - if (!(SCM_NIMP (x))) + if (!SCM_NIMP (x)) { if (SCM_UNBNDP (y)) { @@ -3390,7 +3389,7 @@ scm_difference (SCM x, SCM y) } if (SCM_UNBNDP (y)) { - x = -SCM_INUM (x); + cx = -SCM_INUM (x); goto checkx; } if (SCM_NINUMP (y)) @@ -3488,21 +3487,21 @@ scm_difference (SCM x, SCM y) SCM_GASSERT2 (SCM_INUMP (x), g_difference, x, y, SCM_ARG1, s_difference); if (SCM_UNBNDP (y)) { - x = -SCM_INUM (x); + cx = -SCM_INUM (x); goto checkx; } SCM_GASSERT2 (SCM_INUMP (y), g_difference, x, y, SCM_ARGn, s_difference); #endif #endif - x = SCM_INUM (x) - SCM_INUM (y); + cx = SCM_INUM (x) - SCM_INUM (y); checkx: - if (SCM_FIXABLE (x)) - return SCM_MAKINUM (x); + if (SCM_FIXABLE (cx)) + return SCM_MAKINUM (cx); #ifdef SCM_BIGDIG - return scm_long2big (x); + return scm_long2big (cx); #else #ifdef SCM_FLOATS - return scm_makdbl ((double) x, 0.0); + return scm_makdbl ((double) cx, 0.0); #else scm_num_overflow (s_difference); return SCM_UNSPECIFIED; @@ -3742,7 +3741,11 @@ scm_num2dbl (SCM a, const char *why) return scm_big2dbl (a); #endif SCM_ASSERT (0, a, "wrong type argument", why); - return SCM_UNSPECIFIED; + /* + unreachable, hopefully. + */ + return (double) 0.0; /* ugh. */ + /* return SCM_UNSPECIFIED; */ } @@ -3787,10 +3790,9 @@ scm_divide (SCM x, SCM y) #ifdef SCM_BIGDIG if (SCM_BIGP (x)) { - SCM z; if (SCM_INUMP (y)) { - z = SCM_INUM (y); + long int z = SCM_INUM (y); #ifndef SCM_RECKLESS if (!z) scm_num_overflow (s_divide); @@ -3808,10 +3810,11 @@ scm_divide (SCM x, SCM y) : scm_normbig (w)); } #ifndef SCM_DIGSTOOBIG + /*ugh! Does anyone know what this is supposed to do?*/ z = scm_pseudolong (z); - z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), - (SCM_BIGDIG *) & z, SCM_DIGSPERLONG, - SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3); + z = SCM_INUM(scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), + (SCM_BIGDIG *) & z, SCM_DIGSPERLONG, + SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3)); #else { SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; @@ -3821,12 +3824,12 @@ scm_divide (SCM x, SCM y) SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3); } #endif - return z ? z : scm_makdbl (scm_big2dbl (x) / SCM_INUM (y), 0.0); + return z ? SCM_ASSCM (z) : scm_makdbl (scm_big2dbl (x) / SCM_INUM (y), 0.0); } SCM_ASRTGO (SCM_NIMP (y), bady); if (SCM_BIGP (y)) { - z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), + SCM z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), SCM_BDIGITS (y), SCM_NUMDIGS (y), SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 3); return z ? z : scm_makdbl (scm_big2dbl (x) / scm_big2dbl (y), diff --git a/libguile/numbers.h b/libguile/numbers.h index cfc2ba80d..38b25ca8b 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -71,25 +71,26 @@ /* shifts of more than one are done by a library call, single shifts are * performed in registers */ -# define SCM_MAKINUM(x) ((((x)<<1)<<1)+2L) +# define SCM_MAKINUM(x) ((SCM) (((SCM_ASWORD(x)<<1)<<1)+2L)) #else -# define SCM_MAKINUM(x) (((x)<<2)+2L) +# define SCM_MAKINUM(x) ((SCM)((SCM_ASWORD(x)<<2)+2L)) #endif /* def __TURBOC__ */ /* SCM_SRS is signed right shift */ +/* SCM_INUM makes a C int from an SCM immediate number. */ /* Turbo C++ v1.0 has a bug with right shifts of signed longs! * It is believed to be fixed in Turbo C++ v1.01 */ #if (-1==(((-1)<<2)+2)>>2) && (__TURBOC__ != 0x295) -# define SCM_SRS(x, y) ((x)>>y) +# define SCM_SRS(x, y) (SCM_ASWORD (x)>>y) # ifdef __TURBOC__ -# define SCM_INUM(x) (((x)>>1)>>1) +# define SCM_INUM(x) ((SCM_ASWORD(x) >>1) >>1) # else # define SCM_INUM(x) SCM_SRS(x, 2) # endif /* def __TURBOC__ */ #else -# define SCM_SRS(x, y) (((x)<0) ? ~((~(x))>>y) : (x)>>y) +# define SCM_SRS(x, y) ((SCM_ASWORD(x) < 0) ? ~( (~SCM_ASWORD(x)) >>y) : (SCM_ASWORD (x)>>y)) # define SCM_INUM(x) SCM_SRS(x, 2) #endif /* (-1==(((-1)<<2)+2)>>2) && (__TURBOC__ != 0x295) */ @@ -132,15 +133,15 @@ */ #define SCM_INEXP(x) (SCM_NIMP(x) && (SCM_TYP16(x)==scm_tc16_flo)) -#define SCM_CPLXP(x) (SCM_NIMP(x) && (SCM_CAR(x)==scm_tc_dblc)) +#define SCM_CPLXP(x) (SCM_NIMP(x) && (SCM_CARW (x)==scm_tc_dblc)) #define SCM_REAL(x) (*(((scm_dbl *) (SCM2PTR(x)))->real)) #define SCM_IMAG(x) (*((double *)(SCM_CHARS(x)+sizeof(double)))) /* ((&SCM_REAL(x))[1]) */ #ifdef SCM_SINGLES -#define SCM_REALP(x) (SCM_NIMP(x) && ((~SCM_REAL_PART & SCM_CAR(x))==scm_tc_flo)) -#define SCM_SINGP(x) (SCM_NIMP(x) && (SCM_CAR(x)==scm_tc_flo)) +#define SCM_REALP(x) (SCM_NIMP(x) && ((~SCM_REAL_PART & SCM_CARW (x))==scm_tc_flo)) +#define SCM_SINGP(x) (SCM_NIMP(x) && (SCM_CARW (x)==scm_tc_flo)) #define SCM_FLO(x) (((scm_flo *)(SCM2PTR(x)))->num) #define SCM_REALPART(x) (SCM_SINGP(x)?0.0+SCM_FLO(x):SCM_REAL(x)) #else /* SCM_SINGLES */ @@ -216,7 +217,7 @@ #define SCM_BIGP(x) (SCM_NIMP(x) && SCM_TYP16S(x)==scm_tc16_bigpos) #define SCM_BIGSIGN(x) (0x0100 & (int)SCM_CAR(x)) #define SCM_BDIGITS(x) ((SCM_BIGDIG *)(SCM_CDR(x))) -#define SCM_NUMDIGS(x) ((scm_sizet)(SCM_CAR(x)>>16)) +#define SCM_NUMDIGS(x) ((scm_sizet)(SCM_CARW (x)>>16)) #define SCM_SETNUMDIGS(x, v, t) SCM_SETCAR(x, (((v)+0L)<<16)+(t)) diff --git a/libguile/objects.c b/libguile/objects.c index 16a8c0b8c..2d52b0b93 100644 --- a/libguile/objects.c +++ b/libguile/objects.c @@ -157,10 +157,10 @@ scm_class_of (SCM x) case scm_tc7_smob: { - SCM type = SCM_TYP16 (x); + long type = SCM_TYP16 (x); if (type == scm_tc16_flo) { - if (SCM_CAR (x) & SCM_IMAG_PART) + if (SCM_CARW (x) & SCM_IMAG_PART) return scm_class_complex; else return scm_class_real; @@ -171,8 +171,8 @@ scm_class_of (SCM x) /* fall through to ports */ } case scm_tc7_port: - return scm_port_class[(SCM_WRTNG & SCM_CAR (x) - ? (SCM_RDNG & SCM_CAR (x) + return scm_port_class[(SCM_WRTNG & SCM_CARW (x) + ? (SCM_RDNG & SCM_CARW (x) ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x) : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x)) : SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))]; @@ -280,7 +280,7 @@ scm_mcache_lookup_cmethod (SCM cache, SCM args) if (SCM_NIMP (ls)) do { - i += (SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls))) + i += SCM_ASWORD (SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls))) [scm_si_hashsets + hashset]); ls = SCM_CDR (ls); } diff --git a/libguile/objects.h b/libguile/objects.h index 4b8d7b966..a443e7cde 100644 --- a/libguile/objects.h +++ b/libguile/objects.h @@ -67,9 +67,9 @@ * certain class or its subclasses when traversal of the inheritance * graph would be too costly. */ -#define SCM_CLASS_FLAGS(class) (SCM_STRUCT_DATA (class)[scm_struct_i_flags]) +#define SCM_CLASS_FLAGS(class) SCM_ASWORD(SCM_STRUCT_DATA (class)[scm_struct_i_flags]) #define SCM_OBJ_CLASS_FLAGS(obj)\ -(SCM_STRUCT_VTABLE_DATA (obj)[scm_struct_i_flags]) + SCM_ASWORD(SCM_STRUCT_VTABLE_DATA (obj)[scm_struct_i_flags]) #define SCM_SET_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) |= (f)) #define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) &= ~(f)) #define SCM_CLASSF_MASK SCM_STRUCTF_MASK @@ -80,7 +80,7 @@ #define SCM_CLASSF_OPERATOR (1L << 29) #define SCM_I_OPERATORP(obj)\ -((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) != 0) + ((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) != 0) #define SCM_OPERATOR_CLASS(obj)\ ((struct scm_metaclass_operator *) SCM_STRUCT_DATA (obj)) #define SCM_OBJ_OPERATOR_CLASS(obj)\ @@ -89,7 +89,7 @@ #define SCM_OPERATOR_SETTER(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->setter) #define SCM_I_ENTITYP(obj)\ -((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_ENTITY) != 0) + ((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_ENTITY) != 0) #define SCM_ENTITY_PROCEDURE(obj) \ (SCM_STRUCT_DATA (obj)[scm_struct_i_procedure]) #define SCM_ENTITY_SETTER(obj) (SCM_STRUCT_DATA (obj)[scm_struct_i_setter]) diff --git a/libguile/options.c b/libguile/options.c index 750bd9526..ed6ab3c9c 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -186,7 +186,7 @@ scm_options (SCM arg, scm_option options[], int n, const char *s) goto cont; case SCM_OPTION_SCM: new_mode = SCM_CDR (new_mode); - flags[i] = SCM_CAR (new_mode); + flags[i] = SCM_CARW (new_mode); goto cont; } #ifndef SCM_RECKLESS @@ -198,6 +198,7 @@ scm_options (SCM arg, scm_option options[], int n, const char *s) } for (i = 0; i < n; ++i) { + // scm_option doesn't know if its a long or an SCM if (options[i].type == SCM_OPTION_SCM) SCM_SETCDR (protected_objects, scm_cons (flags[i], diff --git a/libguile/options.h b/libguile/options.h index 5ab41c688..5fefab060 100644 --- a/libguile/options.h +++ b/libguile/options.h @@ -55,7 +55,12 @@ typedef struct scm_option { int type; char *name; + + /* + schizophrenic use: both SCM and int + */ unsigned long val; + // SCM val char *doc; } scm_option; diff --git a/libguile/pairs.h b/libguile/pairs.h index 07637b4b9..96e6f42cc 100644 --- a/libguile/pairs.h +++ b/libguile/pairs.h @@ -104,17 +104,17 @@ typedef SCM huge *SCMPTR; #define SCM_CAR(x) (((scm_cell *)(SCM2PTR(x)))->car) #define SCM_CDR(x) (((scm_cell *)(SCM2PTR(x)))->cdr) -#define SCM_GCCDR(x) (~1L & SCM_CDR(x)) -#define SCM_SETCAR(x, v) (SCM_CAR(x) = (SCM)(v)) -#define SCM_SETCDR(x, v) (SCM_CDR(x) = (SCM)(v)) +#define SCM_GCCDR(x) SCM_ASSCM(~1L & SCM_ASWORD (SCM_CDR(x))) +#define SCM_SETCAR(x, v) (SCM_CAR(x) = SCM_ASSCM(v)) +#define SCM_SETCDR(x, v) (SCM_CDR(x) = SCM_ASSCM(v)) #define SCM_CARLOC(x) (&SCM_CAR (x)) #define SCM_CDRLOC(x) (&SCM_CDR (x)) -#define SCM_SETAND_CAR(x, y) (SCM_CAR (x) &= (y)) -#define SCM_SETAND_CDR(x, y) (SCM_CDR (x) &= (y)) -#define SCM_SETOR_CAR(x, y) (SCM_CAR (x) |= (y)) -#define SCM_SETOR_CDR(x, y) (SCM_CDR (x) |= (y)) +#define SCM_SETAND_CAR(x, y) (SCM_CARW (x) &= (y)) +#define SCM_SETAND_CDR(x, y) (SCM_ASWORD (SCM_CDR (x)) &= (y)) +#define SCM_SETOR_CAR(x, y) (SCM_CARW (x) |= (y)) +#define SCM_SETOR_CDR(x, y) (SCM_ASWORD (SCM_CDR (x)) |= (y)) #define SCM_CAAR(OBJ) SCM_CAR (SCM_CAR (OBJ)) #define SCM_CDAR(OBJ) SCM_CDR (SCM_CAR (OBJ)) diff --git a/libguile/ports.c b/libguile/ports.c index 37f527105..f845a4627 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -89,7 +89,7 @@ SCM scm_markstream (SCM ptr) { int openp; - openp = SCM_CAR (ptr) & SCM_OPN; + openp = SCM_CARW (ptr) & SCM_OPN; if (openp) return SCM_STREAM (ptr); else @@ -568,15 +568,15 @@ SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0, port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPPORT (1,port); - if (SCM_CAR (port) & SCM_RDNG) { - if (SCM_CAR (port) & SCM_WRTNG) + if (SCM_CARW (port) & SCM_RDNG) { + if (SCM_CARW (port) & SCM_WRTNG) strcpy (modes, "r+"); else strcpy (modes, "r"); } - else if (SCM_CAR (port) & SCM_WRTNG) + else if (SCM_CARW (port) & SCM_WRTNG) strcpy (modes, "w"); - if (SCM_CAR (port) & SCM_BUF0) + if (SCM_CARW (port) & SCM_BUF0) strcat (modes, "0"); return scm_makfromstr (modes, strlen (modes), 0); } @@ -1252,11 +1252,11 @@ scm_print_port_mode (SCM exp, SCM port) { scm_puts (SCM_CLOSEDP (exp) ? "closed: " - : (SCM_RDNG & SCM_CAR (exp) - ? (SCM_WRTNG & SCM_CAR (exp) + : (SCM_RDNG & SCM_CARW (exp) + ? (SCM_WRTNG & SCM_CARW (exp) ? "input-output: " : "input: ") - : (SCM_WRTNG & SCM_CAR (exp) + : (SCM_WRTNG & SCM_CARW (exp) ? "output: " : "bogus: ")), port); @@ -1272,7 +1272,7 @@ scm_port_print (SCM exp, SCM port, scm_print_state *pstate) scm_print_port_mode (exp, port); scm_puts (type, port); scm_putc (' ', port); - scm_intprint (SCM_CDR (exp), 16, port); + scm_intprint ((int) SCM_CDR (exp), 16, port); scm_putc ('>', port); return 1; } diff --git a/libguile/ports.h b/libguile/ports.h index 32ccf80c1..615d472b9 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -154,12 +154,12 @@ extern int scm_port_table_size; /* Number of ports in scm_port_table. */ #define SCM_BUFLINE (64L<<16) /* Is it line-buffered? */ #define SCM_PORTP(x) (SCM_NIMP(x) && (SCM_TYP7(x)==scm_tc7_port)) -#define SCM_OPPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN))) -#define SCM_OPINPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG))) -#define SCM_OPOUTPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG))) -#define SCM_INPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_RDNG))) -#define SCM_OUTPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_WRTNG))) -#define SCM_OPENP(x) (SCM_NIMP(x) && (SCM_OPN & SCM_CAR(x))) +#define SCM_OPPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN) & SCM_CARW(x))==(scm_tc7_port | SCM_OPN))) +#define SCM_OPINPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN | SCM_RDNG) & SCM_CARW(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG))) +#define SCM_OPOUTPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN | SCM_WRTNG) & SCM_CARW(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG))) +#define SCM_INPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_RDNG) & SCM_CARW(x))==(scm_tc7_port | SCM_RDNG))) +#define SCM_OUTPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_WRTNG) & SCM_CARW(x))==(scm_tc7_port | SCM_WRTNG))) +#define SCM_OPENP(x) (SCM_NIMP(x) && (SCM_OPN & SCM_CARW (x))) #define SCM_CLOSEDP(x) (!SCM_OPENP(x)) #define SCM_PTAB_ENTRY(x) ((scm_port *) SCM_CDR(x)) #define SCM_SETPTAB_ENTRY(x,ent) SCM_SETCDR ((x), (SCM)(ent)) @@ -199,7 +199,7 @@ typedef struct scm_ptob_descriptor } scm_ptob_descriptor; -#define SCM_TC2PTOBNUM(x) (0x0ff & ((x) >> 8)) +#define SCM_TC2PTOBNUM(x) (0x0ff & (SCM_ASWORD(x) >> 8)) #define SCM_PTOBNUM(x) (SCM_TC2PTOBNUM (SCM_CAR (x))) /* SCM_PTOBNAME can be 0 if name is missing */ #define SCM_PTOBNAME(ptobnum) scm_ptobs[ptobnum].name diff --git a/libguile/print.c b/libguile/print.c index 52d8d32de..7329c0276 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -404,11 +404,11 @@ taloop: env = SCM_ENV (SCM_CDR (exp)); scm_puts ("#<", port); } - if (SCM_CAR (exp) & (3L << 16)) + if (SCM_CARW(exp) & (3L << 16)) scm_puts ("macro", port); else scm_puts ("syntax", port); - if (SCM_CAR (exp) & (2L << 16)) + if (SCM_CARW (exp) & (2L << 16)) scm_putc ('!', port); } else @@ -768,13 +768,13 @@ scm_ipruk (char *hdr, SCM ptr, SCM port) if (SCM_CELLP (ptr)) { scm_puts (" (0x", port); - scm_intprint (SCM_CAR (ptr), 16, port); + scm_intprint ((int) SCM_CAR (ptr), 16, port); scm_puts (" . 0x", port); - scm_intprint (SCM_CDR (ptr), 16, port); + scm_intprint ((int) SCM_CDR (ptr), 16, port); scm_puts (") @", port); } scm_puts (" 0x", port); - scm_intprint (ptr, 16, port); + scm_intprint ((int) ptr, 16, port); scm_putc ('>', port); } diff --git a/libguile/print.h b/libguile/print.h index cca9897c1..f15d3303c 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -100,7 +100,8 @@ typedef struct scm_print_state { extern SCM scm_print_state_vtable; -extern SCM scm_tc16_port_with_ps; +// ? scm or long? print.h and print.c disagree +extern long scm_tc16_port_with_ps; extern SCM scm_print_options (SCM setting); SCM scm_make_print_state (void); diff --git a/libguile/procs.h b/libguile/procs.h index 3059bd350..4721884ce 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -84,7 +84,7 @@ typedef struct SCM documentation; } scm_subr_entry; -#define SCM_SUBRNUM(subr) (SCM_CAR (subr) >> 8) +#define SCM_SUBRNUM(subr) (SCM_CARW (subr) >> 8) #define SCM_SET_SUBRNUM(subr, num) \ SCM_SETCAR (subr, (num >> 8) + SCM_TYP7 (subr)) #define SCM_SUBR_ENTRY(x) (scm_subr_table[SCM_SUBRNUM (x)]) diff --git a/libguile/ramap.c b/libguile/ramap.c index 4782264c4..ae084c876 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -42,6 +42,10 @@ /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ +/* + HWN:FIXME:: + Someone should rename this to arraymap.c; that would reflect the + contents better. */ @@ -60,8 +64,6 @@ #include "ramap.h" -#define SCM_RAMAPC(ramap,proc,ra0,lra) do { scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME); } while (0) - typedef struct { char *name; @@ -96,9 +98,6 @@ static ra_iproc ra_asubrs[] = }; -#define BVE_REF(a, i) ((SCM_VELTS(a)[(i)/SCM_LONG_BIT] & (1L<<((i)%SCM_LONG_BIT))) ? 1 : 0) -#define BVE_SET(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] |= (1L<<((i)%SCM_LONG_BIT))) -#define BVE_CLR(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] &= ~(1L<<((i)%SCM_LONG_BIT))) /* Fast, recycling scm_vector ref */ #define RVREF(ra, i, e) (e = scm_cvref(ra, i, e)) @@ -118,12 +117,59 @@ static ra_iproc ra_asubrs[] = /* inds must be a uvect or ivect, no check. */ + +/* + Yes, this is really ugly, but it prevents multiple code + */ +#define BINARY_ELTS_CODE(OPERATOR, type) \ +do { type *v0 = (type*)SCM_VELTS (ra0);\ + type *v1 = (type*)SCM_VELTS (ra1);\ + IVDEP (ra0 != ra1, \ + for (; n-- > 0; i0 += inc0, i1 += inc1) \ + v0[i0] OPERATOR v1[i1];) \ + break; \ +} while (0) + +/* This macro is used for all but binary division and + multiplication of complex numbers -- see the expanded + version in the functions later in this file */ +#define BINARY_PAIR_ELTS_CODE(OPERATOR, type) \ +do { type (*v0)[2] = (type (*)[2]) SCM_VELTS (ra0);\ + type (*v1)[2] = (type (*)[2]) SCM_VELTS (ra1);\ + IVDEP (ra0 != ra1, \ + for (; n-- > 0; i0 += inc0, i1 += inc1) {\ + v0[i0][0] OPERATOR v1[i1][0]; \ + v0[i0][1] OPERATOR v1[i1][1]; \ + }) \ + break; \ +} while (0) + +#define UNARY_ELTS_CODE(OPERATOR, type) \ + do { type *v0 = (type *) SCM_VELTS (ra0);\ + for (; n-- > 0; i0 += inc0) \ + v0[i0] OPERATOR v0[i0];\ + break;\ + } while (0) + + +/* This macro is used for all but unary divison + of complex numbers -- see the expanded version in the + function later in this file. */ +#define UNARY_PAIR_ELTS_CODE(OPERATOR, type) \ + do { type (*v0)[2] = (type (*)[2]) SCM_VELTS (ra0);\ + for (; n-- > 0; i0 += inc0) {\ + v0[i0][0] OPERATOR v0[i0][0];\ + v0[i0][1] OPERATOR v0[i0][1];\ + }\ + break;\ + } while (0) + static scm_sizet cind (SCM ra, SCM inds) { scm_sizet i; int k; - long *ve = SCM_VELTS (inds); + long *ve = (long*) SCM_VELTS (inds); if (!SCM_ARRAYP (ra)) return *ve; i = SCM_ARRAY_BASE (ra); @@ -153,103 +199,103 @@ scm_ra_matchp (SCM ra0, SCM ras) int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */ if (SCM_IMP (ra0)) return 0; switch (SCM_TYP7 (ra0)) - { - default: - return 0; - case scm_tc7_vector: - case scm_tc7_wvect: - case scm_tc7_string: - case scm_tc7_byvect: - case scm_tc7_bvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_svect: + { + default: + return 0; + case scm_tc7_vector: + case scm_tc7_wvect: + case scm_tc7_string: + case scm_tc7_byvect: + case scm_tc7_bvect: + case scm_tc7_uvect: + case scm_tc7_ivect: + case scm_tc7_svect: #ifdef HAVE_LONG_LONGS - case scm_tc7_llvect: + case scm_tc7_llvect: #endif - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - s0->lbnd = 0; - s0->inc = 1; - s0->ubnd = (long) SCM_LENGTH (ra0) - 1; - break; - case scm_tc7_smob: - if (!SCM_ARRAYP (ra0)) - return 0; - ndim = SCM_ARRAY_NDIM (ra0); - s0 = SCM_ARRAY_DIMS (ra0); - bas0 = SCM_ARRAY_BASE (ra0); - break; - } + case scm_tc7_fvect: + case scm_tc7_dvect: + case scm_tc7_cvect: + s0->lbnd = 0; + s0->inc = 1; + s0->ubnd = (long) SCM_LENGTH (ra0) - 1; + break; + case scm_tc7_smob: + if (!SCM_ARRAYP (ra0)) + return 0; + ndim = SCM_ARRAY_NDIM (ra0); + s0 = SCM_ARRAY_DIMS (ra0); + bas0 = SCM_ARRAY_BASE (ra0); + break; + } while (SCM_NIMP (ras)) - { - ra1 = SCM_CAR (ras); - if (SCM_IMP (ra1)) - return 0; - switch SCM_TYP7 - (ra1) - { - default: - return 0; - case scm_tc7_vector: - case scm_tc7_wvect: - case scm_tc7_string: - case scm_tc7_byvect: - case scm_tc7_bvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_svect: + { + ra1 = SCM_CAR (ras); + if (SCM_IMP (ra1)) + return 0; + switch SCM_TYP7 + (ra1) + { + default: + return 0; + case scm_tc7_vector: + case scm_tc7_wvect: + case scm_tc7_string: + case scm_tc7_byvect: + case scm_tc7_bvect: + case scm_tc7_uvect: + case scm_tc7_ivect: + case scm_tc7_svect: #ifdef HAVE_LONG_LONGS - case scm_tc7_llvect: + case scm_tc7_llvect: #endif - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - if (1 != ndim) - return 0; - switch (exact) - { - case 4: - if (0 != bas0) - exact = 3; - case 3: - if (1 != s0->inc) - exact = 2; - case 2: - if ((0 == s0->lbnd) && (s0->ubnd == SCM_LENGTH (ra1) - 1)) - break; - exact = 1; - case 1: - if (s0->lbnd < 0 || s0->ubnd >= SCM_LENGTH (ra1)) - return 0; - } - break; - case scm_tc7_smob: - if (!SCM_ARRAYP (ra1) || ndim != SCM_ARRAY_NDIM (ra1)) - return 0; - s1 = SCM_ARRAY_DIMS (ra1); - if (bas0 != SCM_ARRAY_BASE (ra1)) + case scm_tc7_fvect: + case scm_tc7_dvect: + case scm_tc7_cvect: + if (1 != ndim) + return 0; + switch (exact) + { + case 4: + if (0 != bas0) exact = 3; - for (i = 0; i < ndim; i++) - switch (exact) - { - case 4: - case 3: - if (s0[i].inc != s1[i].inc) - exact = 2; - case 2: - if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd) - break; - exact = 1; - default: - if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd) - return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1); - } - break; + case 3: + if (1 != s0->inc) + exact = 2; + case 2: + if ((0 == s0->lbnd) && (s0->ubnd == SCM_LENGTH (ra1) - 1)) + break; + exact = 1; + case 1: + if (s0->lbnd < 0 || s0->ubnd >= SCM_LENGTH (ra1)) + return 0; } - ras = SCM_CDR (ras); - } + break; + case scm_tc7_smob: + if (!SCM_ARRAYP (ra1) || ndim != SCM_ARRAY_NDIM (ra1)) + return 0; + s1 = SCM_ARRAY_DIMS (ra1); + if (bas0 != SCM_ARRAY_BASE (ra1)) + exact = 3; + for (i = 0; i < ndim; i++) + switch (exact) + { + case 4: + case 3: + if (s0[i].inc != s1[i].inc) + exact = 2; + case 2: + if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd) + break; + exact = 1; + default: + if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd) + return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1); + } + break; + } + ras = SCM_CDR (ras); + } return exact; } @@ -320,97 +366,97 @@ scm_ramapc (int (*cproc)(), SCM data, SCM ra0, SCM lra, const char *what) return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)); case 1: gencase: /* Have to loop over all dimensions. */ - vra0 = scm_make_ra (1); - if (SCM_ARRAYP (ra0)) + vra0 = scm_make_ra (1); + if (SCM_ARRAYP (ra0)) + { + kmax = SCM_ARRAY_NDIM (ra0) - 1; + if (kmax < 0) { - kmax = SCM_ARRAY_NDIM (ra0) - 1; - if (kmax < 0) - { - SCM_ARRAY_DIMS (vra0)->lbnd = 0; - SCM_ARRAY_DIMS (vra0)->ubnd = 0; - SCM_ARRAY_DIMS (vra0)->inc = 1; - } - else - { - SCM_ARRAY_DIMS (vra0)->lbnd = SCM_ARRAY_DIMS (ra0)[kmax].lbnd; - SCM_ARRAY_DIMS (vra0)->ubnd = SCM_ARRAY_DIMS (ra0)[kmax].ubnd; - SCM_ARRAY_DIMS (vra0)->inc = SCM_ARRAY_DIMS (ra0)[kmax].inc; - } - SCM_ARRAY_BASE (vra0) = SCM_ARRAY_BASE (ra0); - SCM_ARRAY_V (vra0) = SCM_ARRAY_V (ra0); + SCM_ARRAY_DIMS (vra0)->lbnd = 0; + SCM_ARRAY_DIMS (vra0)->ubnd = 0; + SCM_ARRAY_DIMS (vra0)->inc = 1; } - else - { - kmax = 0; - SCM_ARRAY_DIMS (vra0)->lbnd = 0; - SCM_ARRAY_DIMS (vra0)->ubnd = SCM_LENGTH (ra0) - 1; - SCM_ARRAY_DIMS (vra0)->inc = 1; - SCM_ARRAY_BASE (vra0) = 0; - SCM_ARRAY_V (vra0) = ra0; - ra0 = vra0; - } - lvra = SCM_EOL; - plvra = &lvra; - for (z = lra; SCM_NIMP (z); z = SCM_CDR (z)) - { - ra1 = SCM_CAR (z); - vra1 = scm_make_ra (1); - SCM_ARRAY_DIMS (vra1)->lbnd = SCM_ARRAY_DIMS (vra0)->lbnd; - SCM_ARRAY_DIMS (vra1)->ubnd = SCM_ARRAY_DIMS (vra0)->ubnd; - if (SCM_ARRAYP (ra1)) - { - if (kmax >= 0) - SCM_ARRAY_DIMS (vra1)->inc = SCM_ARRAY_DIMS (ra1)[kmax].inc; - SCM_ARRAY_V (vra1) = SCM_ARRAY_V (ra1); - } - else - { - SCM_ARRAY_DIMS (vra1)->inc = 1; - SCM_ARRAY_V (vra1) = ra1; - } - *plvra = scm_cons (vra1, SCM_EOL); - plvra = SCM_CDRLOC (*plvra); - } - inds = scm_make_uve (SCM_ARRAY_NDIM (ra0), SCM_MAKINUM (-1L)); - vinds = (long *) SCM_VELTS (inds); - for (k = 0; k <= kmax; k++) - vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd; - k = kmax; - do - { - if (k == kmax) - { - SCM y = lra; - SCM_ARRAY_BASE (vra0) = cind (ra0, inds); - for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y)) - SCM_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), inds); - if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra))) - return 0; - k--; - continue; - } - if (vinds[k] < SCM_ARRAY_DIMS (ra0)[k].ubnd) - { - vinds[k]++; - k++; - continue; - } - vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd - 1; - k--; - } - while (k >= 0); - return 1; + else + { + SCM_ARRAY_DIMS (vra0)->lbnd = SCM_ARRAY_DIMS (ra0)[kmax].lbnd; + SCM_ARRAY_DIMS (vra0)->ubnd = SCM_ARRAY_DIMS (ra0)[kmax].ubnd; + SCM_ARRAY_DIMS (vra0)->inc = SCM_ARRAY_DIMS (ra0)[kmax].inc; + } + SCM_ARRAY_BASE (vra0) = SCM_ARRAY_BASE (ra0); + SCM_ARRAY_V (vra0) = SCM_ARRAY_V (ra0); + } + else + { + kmax = 0; + SCM_ARRAY_DIMS (vra0)->lbnd = 0; + SCM_ARRAY_DIMS (vra0)->ubnd = SCM_LENGTH (ra0) - 1; + SCM_ARRAY_DIMS (vra0)->inc = 1; + SCM_ARRAY_BASE (vra0) = 0; + SCM_ARRAY_V (vra0) = ra0; + ra0 = vra0; + } + lvra = SCM_EOL; + plvra = &lvra; + for (z = lra; SCM_NIMP (z); z = SCM_CDR (z)) + { + ra1 = SCM_CAR (z); + vra1 = scm_make_ra (1); + SCM_ARRAY_DIMS (vra1)->lbnd = SCM_ARRAY_DIMS (vra0)->lbnd; + SCM_ARRAY_DIMS (vra1)->ubnd = SCM_ARRAY_DIMS (vra0)->ubnd; + if (SCM_ARRAYP (ra1)) + { + if (kmax >= 0) + SCM_ARRAY_DIMS (vra1)->inc = SCM_ARRAY_DIMS (ra1)[kmax].inc; + SCM_ARRAY_V (vra1) = SCM_ARRAY_V (ra1); + } + else + { + SCM_ARRAY_DIMS (vra1)->inc = 1; + SCM_ARRAY_V (vra1) = ra1; + } + *plvra = scm_cons (vra1, SCM_EOL); + plvra = SCM_CDRLOC (*plvra); + } + inds = scm_make_uve (SCM_ARRAY_NDIM (ra0), SCM_MAKINUM (-1L)); + vinds = (long *) SCM_VELTS (inds); + for (k = 0; k <= kmax; k++) + vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd; + k = kmax; + do + { + if (k == kmax) + { + SCM y = lra; + SCM_ARRAY_BASE (vra0) = cind (ra0, inds); + for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y)) + SCM_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), inds); + if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra))) + return 0; + k--; + continue; + } + if (vinds[k] < SCM_ARRAY_DIMS (ra0)[k].ubnd) + { + vinds[k]++; + k++; + continue; + } + vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd - 1; + k--; + } + while (k >= 0); + return 1; } } SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0, - (SCM ra, SCM fill), + (SCM ra, SCM fill), "Stores @var{fill} in every element of @var{array}. The value returned\n" "is unspecified.") #define FUNC_NAME s_scm_array_fill_x { - SCM_RAMAPC (scm_array_fill_int, fill, ra, SCM_EOL); + scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, FUNC_NAME); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -575,6 +621,7 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore) #undef FUNC_NAME + static int racp (SCM src, SCM dst) { @@ -586,185 +633,177 @@ racp (SCM src, SCM dst) i_d = SCM_ARRAY_BASE (dst); src = SCM_ARRAY_V (src); dst = SCM_ARRAY_V (dst); + + + /* untested optimization: don't copy if we're we. This allows the + ugly UNICOS macros (IVDEP) to go . + */ + + if (src == dst) + return 1 ; + switch SCM_TYP7 (dst) - { - default: - gencase: - case scm_tc7_vector: - case scm_tc7_wvect: + { + default: + gencase: + case scm_tc7_vector: + case scm_tc7_wvect: - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - scm_array_set_x (dst, scm_cvref (src, i_s, SCM_UNDEFINED), SCM_MAKINUM (i_d)); - break; - case scm_tc7_string: - case scm_tc7_byvect: - if (scm_tc7_string != SCM_TYP7 (dst)) - goto gencase; - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - SCM_CHARS (dst)[i_d] = SCM_CHARS (src)[i_s]; - break; - case scm_tc7_bvect: - if (scm_tc7_bvect != SCM_TYP7 (dst)) - goto gencase; - if (1 == inc_d && 1 == inc_s && i_s % SCM_LONG_BIT == i_d % SCM_LONG_BIT && n >= SCM_LONG_BIT) - { - long *sv = (long *) SCM_VELTS (src); - long *dv = (long *) SCM_VELTS (dst); - sv += i_s / SCM_LONG_BIT; - dv += i_d / SCM_LONG_BIT; - if (i_s % SCM_LONG_BIT) - { /* leading partial word */ - *dv = (*dv & ~(~0L << (i_s % SCM_LONG_BIT))) | (*sv & (~0L << (i_s % SCM_LONG_BIT))); - dv++; - sv++; - n -= SCM_LONG_BIT - (i_s % SCM_LONG_BIT); - } - IVDEP (src != dst, - for (; n >= SCM_LONG_BIT; n -= SCM_LONG_BIT, sv++, dv++) - * dv = *sv;) - if (n) /* trailing partial word */ - *dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n)); - } - else + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + scm_array_set_x (dst, scm_cvref (src, i_s, SCM_UNDEFINED), SCM_MAKINUM (i_d)); + break; + case scm_tc7_string: + case scm_tc7_byvect: + if (scm_tc7_string != SCM_TYP7 (dst)) + goto gencase; + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + SCM_CHARS (dst)[i_d] = SCM_CHARS (src)[i_s]; + break; + case scm_tc7_bvect: + if (scm_tc7_bvect != SCM_TYP7 (dst)) + goto gencase; + if (1 == inc_d && 1 == inc_s && i_s % SCM_LONG_BIT == i_d % SCM_LONG_BIT && n >= SCM_LONG_BIT) + { + long *sv = (long *) SCM_VELTS (src); + long *dv = (long *) SCM_VELTS (dst); + sv += i_s / SCM_LONG_BIT; + dv += i_d / SCM_LONG_BIT; + if (i_s % SCM_LONG_BIT) + { /* leading partial word */ + *dv = (*dv & ~(~0L << (i_s % SCM_LONG_BIT))) | (*sv & (~0L << (i_s % SCM_LONG_BIT))); + dv++; + sv++; + n -= SCM_LONG_BIT - (i_s % SCM_LONG_BIT); + } + for (; n >= SCM_LONG_BIT; n -= SCM_LONG_BIT, sv++, dv++) + * dv = *sv; + if (n) /* trailing partial word */ + *dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n)); + } + else + { + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + if (SCM_BITVEC_REF(src, i_s)) + SCM_BITVEC_SET(dst, i_d); + else + SCM_BITVEC_CLR(dst, i_d); + } + break; + case scm_tc7_uvect: + if (scm_tc7_uvect != SCM_TYP7 (src)) + goto gencase; + else + { + long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src); + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = s[i_s]; + break; + } + case scm_tc7_ivect: + if (scm_tc7_uvect != SCM_TYP7 (src) && scm_tc7_ivect != SCM_TYP7 (src)) + goto gencase; + else + { + long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src); + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = s[i_s]; + break; + } +#ifdef SCM_FLOATS +#ifdef SCM_SINGLES + case scm_tc7_fvect: + { + float *d = (float *) SCM_VELTS (dst); + float *s = (float *) SCM_VELTS (src); + switch SCM_TYP7 + (src) { + default: + goto gencase; + case scm_tc7_ivect: + case scm_tc7_uvect: for (; n-- > 0; i_s += inc_s, i_d += inc_d) - if (SCM_VELTS (src)[i_s / SCM_LONG_BIT] & (1L << (i_s % SCM_LONG_BIT))) - SCM_VELTS (dst)[i_d / SCM_LONG_BIT] |= (1L << (i_d % SCM_LONG_BIT)); - else - SCM_VELTS (dst)[i_d / SCM_LONG_BIT] &= ~(1L << (i_d % SCM_LONG_BIT)); + d[i_d] = ((long *) s)[i_s]; + break; + case scm_tc7_fvect: + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = s[i_s]; + break; + case scm_tc7_dvect: + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = ((double *) s)[i_s]; + break; } break; - case scm_tc7_uvect: - if (scm_tc7_uvect != SCM_TYP7 (src)) - goto gencase; - else + } +#endif /* SCM_SINGLES */ + case scm_tc7_dvect: + { + double *d = (double *) SCM_VELTS (dst); + double *s = (double *) SCM_VELTS (src); + switch SCM_TYP7 + (src) { - long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src); - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = s[i_s];) + default: + goto gencase; + case scm_tc7_ivect: + case scm_tc7_uvect: + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = ((long *) s)[i_s]; + break; + case scm_tc7_fvect: + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = ((float *) s)[i_s]; + break; + case scm_tc7_dvect: + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + d[i_d] = s[i_s]; break; } - case scm_tc7_ivect: - if (scm_tc7_uvect != SCM_TYP7 (src) && scm_tc7_ivect != SCM_TYP7 (src)) - goto gencase; - else + break; + } + case scm_tc7_cvect: + { + double (*d)[2] = (double (*)[2]) SCM_VELTS (dst); + double (*s)[2] = (double (*)[2]) SCM_VELTS (src); + switch SCM_TYP7 + (src) { - long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src); - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = s[i_s];) + default: + goto gencase; + case scm_tc7_ivect: + case scm_tc7_uvect: + for (; n-- > 0; i_s += inc_s, i_d += inc_d) + { + d[i_d][0] = ((long *) s)[i_s]; + d[i_d][1] = 0.0; + } break; - } -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *d = (float *) SCM_VELTS (dst); - float *s = (float *) SCM_VELTS (src); - switch SCM_TYP7 - (src) + case scm_tc7_fvect: + for (; n-- > 0; i_s += inc_s, i_d += inc_d) { - default: - goto gencase; - case scm_tc7_ivect: - case scm_tc7_uvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = ((long *) s)[i_s];) - break; - case scm_tc7_fvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = s[i_s];) - break; - case scm_tc7_dvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = ((double *) s)[i_s];) - break; + d[i_d][0] = ((float *) s)[i_s]; + d[i_d][1] = 0.0; } - break; - } -#endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *d = (double *) SCM_VELTS (dst); - double *s = (double *) SCM_VELTS (src); - switch SCM_TYP7 - (src) + break; + case scm_tc7_dvect: + for (; n-- > 0; i_s += inc_s, i_d += inc_d) { - default: - goto gencase; - case scm_tc7_ivect: - case scm_tc7_uvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = ((long *) s)[i_s];) - break; - case scm_tc7_fvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = ((float *) s)[i_s];) - break; - case scm_tc7_dvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - d[i_d] = s[i_s];) - break; + d[i_d][0] = ((double *) s)[i_s]; + d[i_d][1] = 0.0; } - break; - } - case scm_tc7_cvect: - { - double (*d)[2] = (double (*)[2]) SCM_VELTS (dst); - double (*s)[2] = (double (*)[2]) SCM_VELTS (src); - switch SCM_TYP7 - (src) + break; + case scm_tc7_cvect: + for (; n-- > 0; i_s += inc_s, i_d += inc_d) { - default: - goto gencase; - case scm_tc7_ivect: - case scm_tc7_uvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - { - d[i_d][0] = ((long *) s)[i_s]; - d[i_d][1] = 0.0; - } - ) - break; - case scm_tc7_fvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - { - d[i_d][0] = ((float *) s)[i_s]; - d[i_d][1] = 0.0; - } - ) - break; - case scm_tc7_dvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - { - d[i_d][0] = ((double *) s)[i_s]; - d[i_d][1] = 0.0; - } - ) - break; - case scm_tc7_cvect: - IVDEP (src != dst, - for (; n-- > 0; i_s += inc_s, i_d += inc_d) - { - d[i_d][0] = s[i_s][0]; - d[i_d][1] = s[i_s][1]; - } - ) + d[i_d][0] = s[i_s][0]; + d[i_d][1] = s[i_s][1]; } - break; - } + } + break; } + } #endif /* SCM_FLOATS */ return 1; } @@ -776,14 +815,14 @@ SCM_REGISTER_PROC(s_array_copy_in_order_x, "array-copy-in-order!", 2, 0, 0, scm_ SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0, - (SCM src, SCM dst), + (SCM src, SCM dst), "Copies every element from vector or array @var{source} to the\n" "corresponding element of @var{destination}. @var{destination} must have\n" "the same rank as @var{source}, and be at least as large in each\n" "dimension. The order is unspecified.") #define FUNC_NAME s_scm_array_copy_x { - SCM_RAMAPC (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL)); + scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), FUNC_NAME); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -809,39 +848,39 @@ scm_ra_eqp (SCM ra0, SCM ras) { SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED; for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (BVE_REF (ra0, i0)) - if (SCM_FALSEP(scm_eq_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))) - BVE_CLR (ra0, i0); + if (SCM_BITVEC_REF (ra0, i0)) + if (SCM_FALSEP(scm_eq_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))) + SCM_BITVEC_CLR (ra0, i0); break; } case scm_tc7_uvect: case scm_tc7_ivect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (BVE_REF (ra0, i0)) - if (SCM_VELTS (ra1)[i1] != SCM_VELTS (ra2)[i2]) - BVE_CLR (ra0, i0); + if (SCM_BITVEC_REF (ra0, i0)) + if (SCM_VELTS (ra1)[i1] != SCM_VELTS (ra2)[i2]) + SCM_BITVEC_CLR (ra0, i0); break; #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (BVE_REF (ra0, i0)) - if (((float *) SCM_VELTS (ra1))[i1] != ((float *) SCM_VELTS (ra2))[i2]) - BVE_CLR (ra0, i0); + if (SCM_BITVEC_REF (ra0, i0)) + if (((float *) SCM_VELTS (ra1))[i1] != ((float *) SCM_VELTS (ra2))[i2]) + SCM_BITVEC_CLR (ra0, i0); break; #endif /*SCM_SINGLES*/ case scm_tc7_dvect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (BVE_REF (ra0, i0)) - if (((double *) SCM_VELTS (ra1))[i1] != ((double *) SCM_VELTS (ra2))[i2]) - BVE_CLR (ra0, i0); + if (SCM_BITVEC_REF (ra0, i0)) + if (((double *) SCM_VELTS (ra1))[i1] != ((double *) SCM_VELTS (ra2))[i2]) + SCM_BITVEC_CLR (ra0, i0); break; case scm_tc7_cvect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (BVE_REF (ra0, i0)) - if (((double *) SCM_VELTS (ra1))[2 * i1] != ((double *) SCM_VELTS (ra2))[2 * i2] || - ((double *) SCM_VELTS (ra1))[2 * i1 + 1] != ((double *) SCM_VELTS (ra2))[2 * i2 + 1]) - BVE_CLR (ra0, i0); + if (SCM_BITVEC_REF (ra0, i0)) + if (((double *) SCM_VELTS (ra1))[2 * i1] != ((double *) SCM_VELTS (ra2))[2 * i2] || + ((double *) SCM_VELTS (ra1))[2 * i1 + 1] != ((double *) SCM_VELTS (ra2))[2 * i2 + 1]) + SCM_BITVEC_CLR (ra0, i0); break; #endif /*SCM_FLOATS*/ } @@ -867,42 +906,42 @@ ra_compare (SCM ra0,SCM ra1,SCM ra2,int opt) { SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED; for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (BVE_REF (ra0, i0)) - if (opt ? - SCM_NFALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) : - SCM_FALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))) - BVE_CLR (ra0, i0); + if (SCM_BITVEC_REF (ra0, i0)) + if (opt ? + SCM_NFALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) : + SCM_FALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))) + SCM_BITVEC_CLR (ra0, i0); break; } case scm_tc7_uvect: case scm_tc7_ivect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) { - if (BVE_REF (ra0, i0)) - if (opt ? - SCM_VELTS (ra1)[i1] < SCM_VELTS (ra2)[i2] : - SCM_VELTS (ra1)[i1] >= SCM_VELTS (ra2)[i2]) - BVE_CLR (ra0, i0); + if (SCM_BITVEC_REF (ra0, i0)) + if (opt ? + SCM_VELTS (ra1)[i1] < SCM_VELTS (ra2)[i2] : + SCM_VELTS (ra1)[i1] >= SCM_VELTS (ra2)[i2]) + SCM_BITVEC_CLR (ra0, i0); } break; #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (BVE_REF(ra0, i0)) - if (opt ? - ((float *) SCM_VELTS (ra1))[i1] < ((float *) SCM_VELTS (ra2))[i2] : - ((float *) SCM_VELTS (ra1))[i1] >= ((float *) SCM_VELTS (ra2))[i2]) - BVE_CLR (ra0, i0); + if (SCM_BITVEC_REF(ra0, i0)) + if (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); break; #endif /*SCM_SINGLES*/ case scm_tc7_dvect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (BVE_REF (ra0, i0)) - if (opt ? - ((double *) SCM_VELTS (ra1))[i1] < ((double *) SCM_VELTS (ra2))[i2] : - ((double *) SCM_VELTS (ra1))[i1] >= ((double *) SCM_VELTS (ra2))[i2]) - BVE_CLR (ra0, i0); + if (SCM_BITVEC_REF (ra0, i0)) + if (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); break; #endif /*SCM_FLOATS*/ } @@ -947,68 +986,36 @@ scm_ra_sum (SCM ra0, SCM ras) long inc0 = SCM_ARRAY_DIMS (ra0)->inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NNULLP(ras)) - { - SCM ra1 = SCM_CAR (ras); - scm_sizet i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) + { + SCM ra1 = SCM_CAR (ras); + scm_sizet i1 = SCM_ARRAY_BASE (ra1); + long inc1 = SCM_ARRAY_DIMS (ra1)->inc; + ra1 = SCM_ARRAY_V (ra1); + switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) + { + default: { - default: - { - SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, scm_sum (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), - SCM_MAKINUM (i0)); - break; - } - case scm_tc7_uvect: - case scm_tc7_ivect: - { - long *v0 = SCM_VELTS (ra0); - long *v1 = SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] += v1[i1];) - break; - } + SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; + for (; n-- > 0; i0 += inc0, i1 += inc1) + scm_array_set_x (ra0, scm_sum (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), + SCM_MAKINUM (i0)); + break; + } + case scm_tc7_uvect: + case scm_tc7_ivect: + BINARY_ELTS_CODE( +=, long); #ifdef SCM_FLOATS #ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - float *v1 = (float *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] += v1[i1];) - break; - } + case scm_tc7_fvect: + BINARY_ELTS_CODE( +=, float); #endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - double *v1 = (double *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] += v1[i1];) - break; - } - case scm_tc7_cvect: - { - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); - double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - { - v0[i0][0] += v1[i1][0]; - v0[i0][1] += v1[i1][1]; - } - ); - break; - } + case scm_tc7_dvect: + BINARY_ELTS_CODE( +=, double); + case scm_tc7_cvect: + BINARY_PAIR_ELTS_CODE( +=, double); #endif /* SCM_FLOATS */ - } - } + } + } return 1; } @@ -1022,46 +1029,30 @@ scm_ra_difference (SCM ra0, SCM ras) long inc0 = SCM_ARRAY_DIMS (ra0)->inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) - { - switch (SCM_TYP7 (ra0)) - { - default: - { - SCM e0 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0) - scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0)); - break; - } + { + switch (SCM_TYP7 (ra0)) + { + default: + { + SCM e0 = SCM_UNDEFINED; + for (; n-- > 0; i0 += inc0) + scm_array_set_x (ra0, + scm_difference (RVREF (ra0, i0, e0), SCM_UNDEFINED), + SCM_MAKINUM (i0)); + break; + } #ifdef SCM_FLOATS #ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - v0[i0] = -v0[i0]; - break; - } + case scm_tc7_fvect: + UNARY_ELTS_CODE( = -, float); #endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - v0[i0] = -v0[i0]; - break; - } - case scm_tc7_cvect: - { - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - { - v0[i0][0] = -v0[i0][0]; - v0[i0][1] = -v0[i0][1]; - } - break; - } + case scm_tc7_dvect: + UNARY_ELTS_CODE( = -, double); + case scm_tc7_cvect: + UNARY_PAIR_ELTS_CODE( = -, double); #endif /* SCM_FLOATS */ - } - } + } + } else { SCM ra1 = SCM_CAR (ras); @@ -1080,37 +1071,12 @@ scm_ra_difference (SCM ra0, SCM ras) #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - float *v1 = (float *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] -= v1[i1];) - break; - } + BINARY_ELTS_CODE( -=, float); #endif /* SCM_SINGLES */ case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - double *v1 = (double *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] -= v1[i1];) - break; - } + BINARY_ELTS_CODE( -=, double); case scm_tc7_cvect: - { - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); - double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - { - v0[i0][0] -= v1[i1][0]; - v0[i0][1] -= v1[i1][1]; - } - ) - break; - } + BINARY_PAIR_ELTS_CODE( -=, double); #endif /* SCM_FLOATS */ } } @@ -1127,70 +1093,49 @@ scm_ra_product (SCM ra0, SCM ras) long inc0 = SCM_ARRAY_DIMS (ra0)->inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NNULLP (ras)) - { - SCM ra1 = SCM_CAR (ras); - scm_sizet i1 = SCM_ARRAY_BASE (ra1); - long inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); - switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) + { + SCM ra1 = SCM_CAR (ras); + scm_sizet i1 = SCM_ARRAY_BASE (ra1); + long inc1 = SCM_ARRAY_DIMS (ra1)->inc; + ra1 = SCM_ARRAY_V (ra1); + switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0) + { + default: { - default: - { - SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, scm_product (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), - SCM_MAKINUM (i0)); - break; - } - case scm_tc7_uvect: - case scm_tc7_ivect: - { - long *v0 = SCM_VELTS (ra0); - long *v1 = SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] *= v1[i1];) - break; - } + SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED; + for (; n-- > 0; i0 += inc0, i1 += inc1) + scm_array_set_x (ra0, scm_product (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), + SCM_MAKINUM (i0)); + break; + } + case scm_tc7_uvect: + case scm_tc7_ivect: + BINARY_ELTS_CODE( *=, long); #ifdef SCM_FLOATS #ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - float *v1 = (float *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] *= v1[i1];) - break; - } + case scm_tc7_fvect: + BINARY_ELTS_CODE( *=, float); #endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - double *v1 = (double *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] *= v1[i1];) - break; - } - case scm_tc7_cvect: - { - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); - register double r; - double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - { - r = v0[i0][0] * v1[i1][0] - v0[i0][1] * v1[i1][1]; - v0[i0][1] = v0[i0][0] * v1[i1][1] + v0[i0][1] * v1[i1][0]; - v0[i0][0] = r; - } - ); - break; - } -#endif /* SCM_FLOATS */ + case scm_tc7_dvect: + BINARY_ELTS_CODE( *=, double); + case scm_tc7_cvect: + { + double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); + register double r; + double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1); + IVDEP (ra0 != ra1, + for (; n-- > 0; i0 += inc0, i1 += inc1) + { + r = v0[i0][0] * v1[i1][0] - v0[i0][1] * v1[i1][1]; + v0[i0][1] = v0[i0][0] * v1[i1][1] + v0[i0][1] * v1[i1][0]; + v0[i0][0] = r; + } + ); + break; } - } +#endif /* SCM_FLOATS */ + } + } return 1; } @@ -1203,48 +1148,38 @@ scm_ra_divide (SCM ra0, SCM ras) long inc0 = SCM_ARRAY_DIMS (ra0)->inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) - { - switch (SCM_TYP7 (ra0)) - { - default: - { - SCM e0 = SCM_UNDEFINED; - for (; n-- > 0; i0 += inc0) - scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0)); - break; - } + { + switch (SCM_TYP7 (ra0)) + { + default: + { + SCM e0 = SCM_UNDEFINED; + for (; n-- > 0; i0 += inc0) + scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0)); + break; + } #ifdef SCM_FLOATS #ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - v0[i0] = 1.0 / v0[i0]; - break; - } + case scm_tc7_fvect: + UNARY_ELTS_CODE( = 1.0 / , float); #endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - v0[i0] = 1.0 / v0[i0]; - break; - } - case scm_tc7_cvect: + case scm_tc7_dvect: + UNARY_ELTS_CODE( = 1.0 / , double); + case scm_tc7_cvect: + { + register double d; + double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); + for (; n-- > 0; i0 += inc0) { - register double d; - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); - for (; n-- > 0; i0 += inc0) - { - d = v0[i0][0] * v0[i0][0] + v0[i0][1] * v0[i0][1]; - v0[i0][0] /= d; - v0[i0][1] /= -d; - } - break; + d = v0[i0][0] * v0[i0][0] + v0[i0][1] * v0[i0][1]; + v0[i0][0] /= d; + v0[i0][1] /= -d; } + break; + } #endif /* SCM_FLOATS */ - } - } + } + } else { SCM ra1 = SCM_CAR (ras); @@ -1263,24 +1198,10 @@ scm_ra_divide (SCM ra0, SCM ras) #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0); - float *v1 = (float *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] /= v1[i1];) - break; - } + BINARY_ELTS_CODE( /=, float); #endif /* SCM_SINGLES */ case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0); - double *v1 = (double *) SCM_VELTS (ra1); - IVDEP (ra0 != ra1, - for (; n-- > 0; i0 += inc0, i1 += inc1) - v0[i0] /= v1[i1];) - break; - } + BINARY_ELTS_CODE( /=, double); case scm_tc7_cvect: { register double d, r; @@ -1288,12 +1209,12 @@ scm_ra_divide (SCM ra0, SCM ras) double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1); IVDEP (ra0 != ra1, for (; n-- > 0; i0 += inc0, i1 += inc1) - { - d = v1[i1][0] * v1[i1][0] + v1[i1][1] * v1[i1][1]; - r = (v0[i0][0] * v1[i1][0] + v0[i0][1] * v1[i1][1]) / d; - v0[i0][1] = (v0[i0][1] * v1[i1][0] - v0[i0][0] * v1[i1][1]) / d; - v0[i0][0] = r; - } + { + d = v1[i1][0] * v1[i1][0] + v1[i1][1] * v1[i1][1]; + r = (v0[i0][0] * v1[i1][0] + v0[i0][1] * v1[i1][1]) / d; + v0[i0][1] = (v0[i0][1] * v1[i1][0] - v0[i0][0] * v1[i1][1]) / d; + v0[i0][0] = r; + } ) break; } @@ -1321,8 +1242,8 @@ ramap (SCM ra0,SCM proc,SCM ras) long base = SCM_ARRAY_BASE (ra0) - i * inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) - for (; i <= n; i++) - scm_array_set_x (ra0, scm_apply (proc, SCM_EOL, SCM_EOL), SCM_MAKINUM (i * inc + base)); + for (; i <= n; i++) + scm_array_set_x (ra0, scm_apply (proc, SCM_EOL, SCM_EOL), SCM_MAKINUM (i * inc + base)); else { SCM ra1 = SCM_CAR (ras); @@ -1332,7 +1253,7 @@ ramap (SCM ra0,SCM proc,SCM ras) ra1 = SCM_ARRAY_V (ra1); ras = SCM_CDR (ras); if (SCM_NULLP(ras)) - ras = scm_nullvect; + ras = scm_nullvect; else { ras = scm_vector (ras); @@ -1362,55 +1283,55 @@ ramap_cxr (SCM ra0,SCM proc,SCM ras) ra0 = SCM_ARRAY_V (ra0); ra1 = SCM_ARRAY_V (ra1); switch (SCM_TYP7 (ra0)) - { - default: - gencase: - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, scm_apply (proc, RVREF (ra1, i1, e1), scm_listofnull), SCM_MAKINUM (i0)); - break; + { + default: + gencase: + for (; n-- > 0; i0 += inc0, i1 += inc1) + scm_array_set_x (ra0, scm_apply (proc, RVREF (ra1, i1, e1), scm_listofnull), SCM_MAKINUM (i0)); + break; #ifdef SCM_FLOATS #ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *dst = (float *) SCM_VELTS (ra0); - switch (SCM_TYP7 (ra1)) - { - default: - goto gencase; - case scm_tc7_fvect: - for (; n-- > 0; i0 += inc0, i1 += inc1) - dst[i0] = SCM_DSUBRF (proc) ((double) ((float *) SCM_VELTS (ra1))[i1]); - break; - case scm_tc7_uvect: - case scm_tc7_ivect: - for (; n-- > 0; i0 += inc0, i1 += inc1) - dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]); - break; - } - break; - } + case scm_tc7_fvect: + { + float *dst = (float *) SCM_VELTS (ra0); + switch (SCM_TYP7 (ra1)) + { + default: + goto gencase; + case scm_tc7_fvect: + for (; n-- > 0; i0 += inc0, i1 += inc1) + dst[i0] = SCM_DSUBRF (proc) ((double) ((float *) SCM_VELTS (ra1))[i1]); + break; + case scm_tc7_uvect: + case scm_tc7_ivect: + for (; n-- > 0; i0 += inc0, i1 += inc1) + dst[i0] = SCM_DSUBRF (proc) (SCM_ASWORD (SCM_VELTS (ra1)[i1])); + break; + } + break; + } #endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *dst = (double *) SCM_VELTS (ra0); - switch (SCM_TYP7 (ra1)) - { - default: - goto gencase; - case scm_tc7_dvect: - for (; n-- > 0; i0 += inc0, i1 += inc1) - dst[i0] = SCM_DSUBRF (proc) (((double *) SCM_VELTS (ra1))[i1]); - break; - case scm_tc7_uvect: - case scm_tc7_ivect: - for (; n-- > 0; i0 += inc0, i1 += inc1) - dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]); - break; - } - break; - } -#endif /* SCM_FLOATS */ + case scm_tc7_dvect: + { + double *dst = (double *) SCM_VELTS (ra0); + switch (SCM_TYP7 (ra1)) + { + default: + goto gencase; + case scm_tc7_dvect: + for (; n-- > 0; i0 += inc0, i1 += inc1) + dst[i0] = SCM_DSUBRF (proc) (((double *) SCM_VELTS (ra1))[i1]); + break; + case scm_tc7_uvect: + case scm_tc7_ivect: + for (; n-- > 0; i0 += inc0, i1 += inc1) + dst[i0] = SCM_DSUBRF (proc) (SCM_ASWORD (SCM_VELTS (ra1)[i1])); + break; + } + break; } +#endif /* SCM_FLOATS */ + } return 1; } @@ -1433,19 +1354,19 @@ ramap_rp (SCM ra0,SCM proc,SCM ras) { default: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (BVE_REF (ra0, i0)) - if (SCM_FALSEP (SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))) - BVE_CLR (ra0, i0); + if (SCM_BITVEC_REF (ra0, i0)) + if (SCM_FALSEP (SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))) + SCM_BITVEC_CLR (ra0, i0); break; case scm_tc7_uvect: case scm_tc7_ivect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (BVE_REF (ra0, i0)) - { - if (SCM_FALSEP (SCM_SUBRF (proc) (SCM_MAKINUM (SCM_VELTS (ra1)[i1]), - SCM_MAKINUM (SCM_VELTS (ra2)[i2])))) - BVE_CLR (ra0, i0); - } + if (SCM_BITVEC_REF (ra0, i0)) + { + if (SCM_FALSEP (SCM_SUBRF (proc) (SCM_MAKINUM (SCM_VELTS (ra1)[i1]), + SCM_MAKINUM (SCM_VELTS (ra2)[i2])))) + SCM_BITVEC_CLR (ra0, i0); + } break; #ifdef SCM_FLOATS #ifdef SCM_SINGLES @@ -1453,13 +1374,13 @@ ramap_rp (SCM ra0,SCM proc,SCM ras) { SCM a1 = scm_makflo (1.0), a2 = scm_makflo (1.0); for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (BVE_REF (ra0, i0)) - { - SCM_FLO (a1) = ((float *) SCM_VELTS (ra1))[i1]; - SCM_FLO (a2) = ((float *) SCM_VELTS (ra2))[i2]; - if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2))) - BVE_CLR (ra0, i0); - } + if (SCM_BITVEC_REF (ra0, i0)) + { + SCM_FLO (a1) = ((float *) SCM_VELTS (ra1))[i1]; + SCM_FLO (a2) = ((float *) SCM_VELTS (ra2))[i2]; + if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2))) + SCM_BITVEC_CLR (ra0, i0); + } break; } #endif /*SCM_SINGLES*/ @@ -1467,28 +1388,28 @@ ramap_rp (SCM ra0,SCM proc,SCM ras) { SCM a1 = scm_makdbl (1.0 / 3.0, 0.0), a2 = scm_makdbl (1.0 / 3.0, 0.0); for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (BVE_REF (ra0, i0)) - { - SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[i1]; - SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[i2]; - if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2))) - BVE_CLR (ra0, i0); - } + if (SCM_BITVEC_REF (ra0, i0)) + { + SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[i1]; + SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[i2]; + if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2))) + SCM_BITVEC_CLR (ra0, i0); + } break; } case scm_tc7_cvect: { SCM a1 = scm_makdbl (1.0, 1.0), a2 = scm_makdbl (1.0, 1.0); for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) - if (BVE_REF (ra0, i0)) - { - SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[2 * i1]; - SCM_IMAG (a1) = ((double *) SCM_VELTS (ra1))[2 * i1 + 1]; - SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[2 * i2]; - SCM_IMAG (a2) = ((double *) SCM_VELTS (ra2))[2 * i2 + 1]; - if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2))) - BVE_CLR (ra0, i0); - } + if (SCM_BITVEC_REF (ra0, i0)) + { + SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[2 * i1]; + SCM_IMAG (a1) = ((double *) SCM_VELTS (ra1))[2 * i1 + 1]; + SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[2 * i2]; + SCM_IMAG (a2) = ((double *) SCM_VELTS (ra2))[2 * i2 + 1]; + if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2))) + SCM_BITVEC_CLR (ra0, i0); + } break; } #endif /*SCM_FLOATS*/ @@ -1531,18 +1452,18 @@ ramap_2o (SCM ra0,SCM proc,SCM ras) ra1 = SCM_ARRAY_V (ra1); ras = SCM_CDR (ras); if (SCM_NULLP (ras)) - { - if (scm_tc7_vector == SCM_TYP7 (ra0) - || scm_tc7_wvect == SCM_TYP7 (ra0)) + { + if (scm_tc7_vector == SCM_TYP7 (ra0) + || scm_tc7_wvect == SCM_TYP7 (ra0)) - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), SCM_UNDEFINED), - SCM_MAKINUM (i0)); - else - for (; n-- > 0; i0 += inc0, i1 += inc1) - scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1), SCM_UNDEFINED), - SCM_MAKINUM (i0)); - } + for (; n-- > 0; i0 += inc0, i1 += inc1) + scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), SCM_UNDEFINED), + SCM_MAKINUM (i0)); + else + for (; n-- > 0; i0 += inc0, i1 += inc1) + scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1), SCM_UNDEFINED), + SCM_MAKINUM (i0)); + } else { SCM ra2 = SCM_CAR (ras); @@ -1553,13 +1474,13 @@ ramap_2o (SCM ra0,SCM proc,SCM ras) if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0)) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) scm_array_set_x (ra0, - SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), scm_cvref (ra2, i2, SCM_UNDEFINED)), - SCM_MAKINUM (i0)); + SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), scm_cvref (ra2, i2, SCM_UNDEFINED)), + SCM_MAKINUM (i0)); else for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) scm_array_set_x (ra0, - SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)), - SCM_MAKINUM (i0)); + SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)), + SCM_MAKINUM (i0)); } return 1; } @@ -1575,8 +1496,8 @@ ramap_a (SCM ra0,SCM proc,SCM ras) long inc0 = SCM_ARRAY_DIMS (ra0)->inc; ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) - for (; n-- > 0; i0 += inc0) - scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0)); + for (; n-- > 0; i0 += inc0) + scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0)); else { SCM ra1 = SCM_CAR (ras); @@ -1585,7 +1506,7 @@ ramap_a (SCM ra0,SCM proc,SCM ras) ra1 = SCM_ARRAY_V (ra1); for (; n-- > 0; i0 += inc0, i1 += inc1) scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)), - SCM_MAKINUM (i0)); + SCM_MAKINUM (i0)); } return 1; } @@ -1596,7 +1517,7 @@ SCM_REGISTER_PROC(s_array_map_in_order_x, "array-map-in-order!", 2, 0, 1, scm_ar SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, - (SCM ra0, SCM proc, SCM lra), + (SCM ra0, SCM proc, SCM lra), "@var{array1}, @dots{} must have the same number of dimensions as\n" "@var{array0} and have a range for each index which includes the range\n" "for the corresponding index in @var{array0}. @var{proc} is applied to\n" @@ -1607,98 +1528,98 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, { SCM_VALIDATE_PROC (2,proc); switch (SCM_TYP7 (proc)) + { + default: + gencase: + scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME); + return SCM_UNSPECIFIED; + case scm_tc7_subr_1: + scm_ramapc (ramap_1, proc, ra0, lra, FUNC_NAME); + return SCM_UNSPECIFIED; + case scm_tc7_subr_2: + case scm_tc7_subr_2o: + scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME); + return SCM_UNSPECIFIED; + case scm_tc7_cxr: + if (!SCM_SUBRF (proc)) + goto gencase; + scm_ramapc (ramap_cxr, proc, ra0, lra, FUNC_NAME); + return SCM_UNSPECIFIED; + case scm_tc7_rpsubr: { - default: - gencase: - SCM_RAMAPC (ramap, proc, ra0, lra); - return SCM_UNSPECIFIED; - case scm_tc7_subr_1: - SCM_RAMAPC (ramap_1, proc, ra0, lra); - return SCM_UNSPECIFIED; - case scm_tc7_subr_2: - case scm_tc7_subr_2o: - SCM_RAMAPC (ramap_2o, proc, ra0, lra); - return SCM_UNSPECIFIED; - case scm_tc7_cxr: - if (!SCM_SUBRF (proc)) + ra_iproc *p; + if (SCM_FALSEP (scm_array_p (ra0, SCM_BOOL_T))) goto gencase; - SCM_RAMAPC (ramap_cxr, proc, ra0, lra); + scm_array_fill_x (ra0, SCM_BOOL_T); + for (p = ra_rpsubrs; p->name; p++) + if (proc == p->sproc) + { + while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra))) + { + scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME); + lra = SCM_CDR (lra); + } + return SCM_UNSPECIFIED; + } + while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra))) + { + scm_ramapc (ramap_rp, proc, ra0, lra, FUNC_NAME); + lra = SCM_CDR (lra); + } return SCM_UNSPECIFIED; - case scm_tc7_rpsubr: + } + case scm_tc7_asubr: + if (SCM_NULLP (lra)) + { + SCM prot, fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED); + if (SCM_INUMP(fill)) + { + prot = scm_array_prototype (ra0); + if (SCM_INEXP (prot)) + fill = scm_makdbl ((double) SCM_INUM (fill), 0.0); + } + + scm_array_fill_x (ra0, fill); + } + else { + SCM tail, ra1 = SCM_CAR (lra); + SCM v0 = (SCM_ARRAYP (ra0) ? SCM_ARRAY_V (ra0) : ra0); ra_iproc *p; - if (SCM_FALSEP (scm_array_p (ra0, SCM_BOOL_T))) - goto gencase; - scm_array_fill_x (ra0, SCM_BOOL_T); - for (p = ra_rpsubrs; p->name; p++) + /* Check to see if order might matter. + This might be an argument for a separate + SERIAL-ARRAY-MAP! */ + if (v0 == ra1 || (SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1))) + if (ra0 != ra1 || (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0))) + goto gencase; + for (tail = SCM_CDR (lra); SCM_NNULLP (tail); tail = SCM_CDR (tail)) + { + ra1 = SCM_CAR (tail); + if (v0 == ra1 || (SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1))) + goto gencase; + } + for (p = ra_asubrs; p->name; p++) if (proc == p->sproc) { - while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra))) + if (ra0 != SCM_CAR (lra)) + scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), FUNC_NAME); + lra = SCM_CDR (lra); + while (1) { - SCM_RAMAPC (p->vproc, SCM_UNDEFINED, ra0, lra); + scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME); + if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra))) + return SCM_UNSPECIFIED; lra = SCM_CDR (lra); } - return SCM_UNSPECIFIED; } - while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra))) - { - SCM_RAMAPC (ramap_rp, proc, ra0, lra); - lra = SCM_CDR (lra); - } - return SCM_UNSPECIFIED; + scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME); + lra = SCM_CDR (lra); + if (SCM_NIMP (lra)) + for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra)) + scm_ramapc (ramap_a, proc, ra0, lra, FUNC_NAME); } - case scm_tc7_asubr: - if (SCM_NULLP (lra)) - { - SCM prot, fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED); - if (SCM_INUMP(fill)) - { - prot = scm_array_prototype (ra0); - if (SCM_INEXP (prot)) - fill = scm_makdbl ((double) SCM_INUM (fill), 0.0); - } - - scm_array_fill_x (ra0, fill); - } - else - { - SCM tail, ra1 = SCM_CAR (lra); - SCM v0 = (SCM_ARRAYP (ra0) ? SCM_ARRAY_V (ra0) : ra0); - ra_iproc *p; - /* Check to see if order might matter. - This might be an argument for a separate - SERIAL-ARRAY-MAP! */ - if (v0 == ra1 || (SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1))) - if (ra0 != ra1 || (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0))) - goto gencase; - for (tail = SCM_CDR (lra); SCM_NNULLP (tail); tail = SCM_CDR (tail)) - { - ra1 = SCM_CAR (tail); - if (v0 == ra1 || (SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1))) - goto gencase; - } - for (p = ra_asubrs; p->name; p++) - if (proc == p->sproc) - { - if (ra0 != SCM_CAR (lra)) - SCM_RAMAPC (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL)); - lra = SCM_CDR (lra); - while (1) - { - SCM_RAMAPC (p->vproc, SCM_UNDEFINED, ra0, lra); - if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra))) - return SCM_UNSPECIFIED; - lra = SCM_CDR (lra); - } - } - SCM_RAMAPC (ramap_2o, proc, ra0, lra); - lra = SCM_CDR (lra); - if (SCM_NIMP (lra)) - for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra)) - SCM_RAMAPC (ramap_a, proc, ra0, lra); - } - return SCM_UNSPECIFIED; - } + return SCM_UNSPECIFIED; + } } #undef FUNC_NAME @@ -1712,8 +1633,8 @@ rafe (SCM ra0,SCM proc,SCM ras) long n = SCM_ARRAY_DIMS (ra0)->ubnd; ra0 = SCM_ARRAY_V (ra0); if (SCM_NULLP (ras)) - for (; i <= n; i++, i0 += inc0) - scm_apply (proc, scm_cvref (ra0, i0, SCM_UNDEFINED), scm_listofnull); + for (; i <= n; i++, i0 += inc0) + scm_apply (proc, scm_cvref (ra0, i0, SCM_UNDEFINED), scm_listofnull); else { SCM ra1 = SCM_CAR (ras); @@ -1723,7 +1644,7 @@ rafe (SCM ra0,SCM proc,SCM ras) ra1 = SCM_ARRAY_V (ra1); ras = SCM_CDR (ras); if (SCM_NULLP(ras)) - ras = scm_nullvect; + ras = scm_nullvect; else { ras = scm_vector (ras); @@ -1743,19 +1664,19 @@ rafe (SCM ra0,SCM proc,SCM ras) SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1, - (SCM proc, SCM ra0, SCM lra), + (SCM proc, SCM ra0, SCM lra), "@var{proc} is applied to each tuple of elements of @var{array0} @dots{}\n" "in row-major order. The value returned is unspecified.") #define FUNC_NAME s_scm_array_for_each { SCM_VALIDATE_PROC (1,proc); - SCM_RAMAPC (rafe, proc, ra0, lra); + scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME); return SCM_UNSPECIFIED; } #undef FUNC_NAME SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, - (SCM ra, SCM proc), + (SCM ra, SCM proc), "applies @var{proc} to the indices of each element of @var{array} in\n" "turn, storing the result in the corresponding element. The value\n" "returned and the order of application are unspecified.\n\n" @@ -1811,7 +1732,7 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0, { SCM args = SCM_EOL; SCM inds = scm_make_uve (SCM_ARRAY_NDIM (ra), SCM_MAKINUM (-1L)); - long *vinds = SCM_VELTS (inds); + long *vinds = (long *) SCM_VELTS (inds); int j, k, kmax = SCM_ARRAY_NDIM (ra) - 1; if (kmax < 0) return scm_array_set_x (ra, scm_apply(proc, SCM_EOL, SCM_EOL), @@ -1863,115 +1784,115 @@ raeql_1 (SCM ra0,SCM as_equal,SCM ra1) scm_sizet n = SCM_LENGTH (ra0); ra1 = SCM_CAR (ra1); if (SCM_ARRAYP(ra0)) - { - n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; - i0 = SCM_ARRAY_BASE (ra0); - inc0 = SCM_ARRAY_DIMS (ra0)->inc; - ra0 = SCM_ARRAY_V (ra0); - } + { + n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1; + i0 = SCM_ARRAY_BASE (ra0); + inc0 = SCM_ARRAY_DIMS (ra0)->inc; + ra0 = SCM_ARRAY_V (ra0); + } if (SCM_ARRAYP (ra1)) + { + i1 = SCM_ARRAY_BASE (ra1); + inc1 = SCM_ARRAY_DIMS (ra1)->inc; + ra1 = SCM_ARRAY_V (ra1); + } + switch (SCM_TYP7 (ra0)) + { + case scm_tc7_vector: + case scm_tc7_wvect: + default: + for (; n--; i0 += inc0, i1 += inc1) + { + if (SCM_FALSEP (as_equal)) + { + if (SCM_FALSEP (scm_array_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)))) + return 0; + } + else if (SCM_FALSEP (scm_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)))) + return 0; + } + return 1; + case scm_tc7_string: + case scm_tc7_byvect: { - i1 = SCM_ARRAY_BASE (ra1); - inc1 = SCM_ARRAY_DIMS (ra1)->inc; - ra1 = SCM_ARRAY_V (ra1); + char *v0 = SCM_CHARS (ra0) + i0; + char *v1 = SCM_CHARS (ra1) + i1; + for (; n--; v0 += inc0, v1 += inc1) + if (*v0 != *v1) + return 0; + return 1; } - switch (SCM_TYP7 (ra0)) + case scm_tc7_bvect: + for (; n--; i0 += inc0, i1 += inc1) + if (SCM_BITVEC_REF (ra0, i0) != SCM_BITVEC_REF (ra1, i1)) + return 0; + return 1; + case scm_tc7_uvect: + case scm_tc7_ivect: { - case scm_tc7_vector: - case scm_tc7_wvect: - default: - for (; n--; i0 += inc0, i1 += inc1) - { - if (SCM_FALSEP (as_equal)) - { - if (SCM_FALSEP (scm_array_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)))) - return 0; - } - else if (SCM_FALSEP (scm_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)))) - return 0; - } + long *v0 = (long *) SCM_VELTS (ra0) + i0; + long *v1 = (long *) SCM_VELTS (ra1) + i1; + for (; n--; v0 += inc0, v1 += inc1) + if (*v0 != *v1) + return 0; return 1; - case scm_tc7_string: - case scm_tc7_byvect: - { - char *v0 = SCM_CHARS (ra0) + i0; - char *v1 = SCM_CHARS (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - if (*v0 != *v1) - return 0; - return 1; - } - case scm_tc7_bvect: - for (; n--; i0 += inc0, i1 += inc1) - if (BVE_REF (ra0, i0) != BVE_REF (ra1, i1)) + } + case scm_tc7_svect: + { + short *v0 = (short *) SCM_VELTS (ra0) + i0; + short *v1 = (short *) SCM_VELTS (ra1) + i1; + for (; n--; v0 += inc0, v1 += inc1) + if (*v0 != *v1) return 0; return 1; - case scm_tc7_uvect: - case scm_tc7_ivect: - { - long *v0 = (long *) SCM_VELTS (ra0) + i0; - long *v1 = (long *) SCM_VELTS (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - if (*v0 != *v1) - return 0; - return 1; - } - case scm_tc7_svect: - { - short *v0 = (short *) SCM_VELTS (ra0) + i0; - short *v1 = (short *) SCM_VELTS (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - if (*v0 != *v1) - return 0; - return 1; - } + } #ifdef HAVE_LONG_LONGS - case scm_tc7_llvect: - { - long long *v0 = (long long *) SCM_VELTS (ra0) + i0; - long long *v1 = (long long *) SCM_VELTS (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - if (*v0 != *v1) - return 0; - return 1; - } + case scm_tc7_llvect: + { + long long *v0 = (long long *) SCM_VELTS (ra0) + i0; + long long *v1 = (long long *) SCM_VELTS (ra1) + i1; + for (; n--; v0 += inc0, v1 += inc1) + if (*v0 != *v1) + return 0; + return 1; + } #endif #ifdef SCM_FLOATS #ifdef SCM_SINGLES - case scm_tc7_fvect: - { - float *v0 = (float *) SCM_VELTS (ra0) + i0; - float *v1 = (float *) SCM_VELTS (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - if (*v0 != *v1) - return 0; - return 1; - } + case scm_tc7_fvect: + { + float *v0 = (float *) SCM_VELTS (ra0) + i0; + float *v1 = (float *) SCM_VELTS (ra1) + i1; + for (; n--; v0 += inc0, v1 += inc1) + if (*v0 != *v1) + return 0; + return 1; + } #endif /* SCM_SINGLES */ - case scm_tc7_dvect: - { - double *v0 = (double *) SCM_VELTS (ra0) + i0; - double *v1 = (double *) SCM_VELTS (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - if (*v0 != *v1) + case scm_tc7_dvect: + { + double *v0 = (double *) SCM_VELTS (ra0) + i0; + double *v1 = (double *) SCM_VELTS (ra1) + i1; + for (; n--; v0 += inc0, v1 += inc1) + if (*v0 != *v1) + return 0; + return 1; + } + case scm_tc7_cvect: + { + double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0) + i0; + double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1) + i1; + for (; n--; v0 += inc0, v1 += inc1) + { + if ((*v0)[0] != (*v1)[0]) return 0; - return 1; - } - case scm_tc7_cvect: - { - double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0) + i0; - double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1) + i1; - for (; n--; v0 += inc0, v1 += inc1) - { - if ((*v0)[0] != (*v1)[0]) - return 0; - if ((*v0)[1] != (*v1)[1]) - return 0; - } - return 1; - } -#endif /* SCM_FLOATS */ + if ((*v0)[1] != (*v1)[1]) + return 0; + } + return 1; } +#endif /* SCM_FLOATS */ + } } @@ -1985,12 +1906,12 @@ raeql (SCM ra0,SCM as_equal,SCM ra1) scm_sizet bas0 = 0, bas1 = 0; int k, unroll = 1, vlen = 1, ndim = 1; if (SCM_ARRAYP (ra0)) - { - ndim = SCM_ARRAY_NDIM (ra0); - s0 = SCM_ARRAY_DIMS (ra0); - bas0 = SCM_ARRAY_BASE (ra0); - v0 = SCM_ARRAY_V (ra0); - } + { + ndim = SCM_ARRAY_NDIM (ra0); + s0 = SCM_ARRAY_DIMS (ra0); + bas0 = SCM_ARRAY_BASE (ra0); + v0 = SCM_ARRAY_V (ra0); + } else { s0->inc = 1; @@ -1999,17 +1920,20 @@ raeql (SCM ra0,SCM as_equal,SCM ra1) unroll = 0; } if (SCM_ARRAYP (ra1)) - { - if (ndim != SCM_ARRAY_NDIM (ra1)) - return 0; - s1 = SCM_ARRAY_DIMS (ra1); - bas1 = SCM_ARRAY_BASE (ra1); - v1 = SCM_ARRAY_V (ra1); - } + { + if (ndim != SCM_ARRAY_NDIM (ra1)) + return 0; + s1 = SCM_ARRAY_DIMS (ra1); + bas1 = SCM_ARRAY_BASE (ra1); + v1 = SCM_ARRAY_V (ra1); + } else { + /* + Huh ? Schizophrenic return type. --hwn + */ if (1 != ndim) - return SCM_BOOL_F; + return 0; s1->inc = 1; s1->lbnd = 0; s1->ubnd = SCM_LENGTH (v1) - 1; @@ -2028,7 +1952,7 @@ raeql (SCM ra0,SCM as_equal,SCM ra1) } } if (unroll && bas0 == bas1 && v0 == v1) - return SCM_BOOL_T; + return 1; return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), ""); } @@ -2042,7 +1966,7 @@ scm_raequal (SCM ra0, SCM ra1) #if 0 /* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */ SCM_DEFINE1 (scm_array_equal_p, "array-equal?", scm_tc7_rpsubr, - (SCM ra0, SCM ra1), + (SCM ra0, SCM ra1), "Returns @code{#t} iff all arguments are arrays with the same shape, the\n" "same type, and have corresponding elements which are either\n" "@code{equal?} or @code{array-equal?}. This function differs from\n" @@ -2061,45 +1985,45 @@ SCM scm_array_equal_p (SCM ra0, SCM ra1) { if (SCM_IMP (ra0) || SCM_IMP (ra1)) - callequal:return scm_equal_p (ra0, ra1); + callequal:return scm_equal_p (ra0, ra1); switch (SCM_TYP7(ra0)) - { - default: + { + default: + goto callequal; + case scm_tc7_bvect: + case scm_tc7_string: + case scm_tc7_byvect: + case scm_tc7_uvect: + case scm_tc7_ivect: + case scm_tc7_fvect: + case scm_tc7_dvect: + case scm_tc7_cvect: + case scm_tc7_vector: + case scm_tc7_wvect: + break; + case scm_tc7_smob: + if (!SCM_ARRAYP (ra0)) goto callequal; - case scm_tc7_bvect: - case scm_tc7_string: - case scm_tc7_byvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_vector: - case scm_tc7_wvect: - break; - case scm_tc7_smob: - if (!SCM_ARRAYP (ra0)) - goto callequal; - } + } switch (SCM_TYP7 (ra1)) - { - default: + { + default: + goto callequal; + case scm_tc7_bvect: + case scm_tc7_string: + case scm_tc7_byvect: + case scm_tc7_uvect: + case scm_tc7_ivect: + case scm_tc7_fvect: + case scm_tc7_dvect: + case scm_tc7_cvect: + case scm_tc7_vector: + case scm_tc7_wvect: + break; + case scm_tc7_smob: + if (!SCM_ARRAYP (ra1)) goto callequal; - case scm_tc7_bvect: - case scm_tc7_string: - case scm_tc7_byvect: - case scm_tc7_uvect: - case scm_tc7_ivect: - case scm_tc7_fvect: - case scm_tc7_dvect: - case scm_tc7_cvect: - case scm_tc7_vector: - case scm_tc7_wvect: - break; - case scm_tc7_smob: - if (!SCM_ARRAYP (ra1)) - goto callequal; - } + } return SCM_BOOL(raeql (ra0, SCM_BOOL_F, ra1)); } diff --git a/libguile/read.c b/libguile/read.c index 6f7b7ddf7..f1a51a201 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -70,7 +70,7 @@ scm_option scm_read_opts[] = { "Record positions of source code expressions." }, { SCM_OPTION_BOOLEAN, "case-insensitive", 0, "Convert symbols to lower case."}, - { SCM_OPTION_SCM, "keywords", SCM_BOOL_F, + { SCM_OPTION_SCM, "keywords", SCM_ASWORD (SCM_BOOL_F), "Style of keyword recognition: #f or 'prefix"} }; @@ -489,7 +489,7 @@ tryagain_no_flush_ws: goto tok; case ':': - if (SCM_KEYWORD_STYLE == scm_keyword_prefix) + if (SCM_ASSCM (SCM_KEYWORD_STYLE) == scm_keyword_prefix) { j = scm_read_token ('-', tok_buf, port, 0); p = scm_intern (SCM_CHARS (*tok_buf), j); diff --git a/libguile/smob.c b/libguile/smob.c index 83442c84c..1e4019134 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -116,7 +116,7 @@ scm_smob_print (SCM exp, SCM port, scm_print_state *pstate) scm_puts ("#<", port); scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port); scm_putc (' ', port); - scm_intprint (scm_smobs[n].size ? SCM_CDR (exp) : exp, 16, port); + scm_intprint (SCM_ASWORD (scm_smobs[n].size ? SCM_CDR (exp) : exp), 16, port); scm_putc ('>', port); return 1; } diff --git a/libguile/smob.h b/libguile/smob.h index fd8ccc2b8..e1ba02456 100644 --- a/libguile/smob.h +++ b/libguile/smob.h @@ -87,7 +87,7 @@ do { \ #define SCM_SMOB_DATA(x) SCM_CDR (x) #define SCM_SET_SMOB_DATA(x, data) SCM_SETCDR (x, data) -#define SCM_TC2SMOBNUM(x) (0x0ff & ((x) >> 8)) +#define SCM_TC2SMOBNUM(x) (0x0ff & (SCM_ASWORD(x) >> 8)) #define SCM_SMOBNUM(x) (SCM_TC2SMOBNUM (SCM_CAR (x))) /* SCM_SMOBNAME can be 0 if name is missing */ #define SCM_SMOBNAME(smobnum) scm_smobs[smobnum].name diff --git a/libguile/srcprop.h b/libguile/srcprop.h index 35afdf5bb..4a3a8cca0 100644 --- a/libguile/srcprop.h +++ b/libguile/srcprop.h @@ -96,7 +96,7 @@ typedef struct scm_srcprops_chunk } scm_srcprops_chunk; #define SRCPROPSP(p) (SCM_NIMP(p) && (SCM_TYP16 (p) == scm_tc16_srcprops)) -#define SRCPROPBRK(p) (SCM_BOOL((1L << 16) & SCM_CAR (p))) +#define SRCPROPBRK(p) (SCM_BOOL((1L << 16) & SCM_CARW (p))) #define SRCPROPPOS(p) ((scm_srcprops *) SCM_CDR (p))->pos #define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12) #define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL) @@ -112,7 +112,7 @@ typedef struct scm_srcprops_chunk #define SRCBRKP(x) (SCM_NIMP (t.arg1 = scm_whash_lookup (scm_source_whash, (x)))\ && SRCPROPSP (t.arg1)\ - && (1L << 16) & SCM_CAR (t.arg1)) + && ((1L << 16) & SCM_ASWORD (SCM_CAR (t.arg1)))) #define PROCTRACEP(x) SCM_NFALSEP (scm_procedure_property (x, scm_sym_trace)) diff --git a/libguile/stacks.c b/libguile/stacks.c index 124b830aa..b2f830f8e 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -188,7 +188,7 @@ stack_depth (scm_debug_frame *dframe,long offset,SCM *id,int *maxp) static void read_frame (scm_debug_frame *dframe,long offset,scm_info_frame *iframe) { - SCM flags = SCM_INUM0; + SCMWORD flags = SCM_ASWORD (SCM_INUM0); /* UGh. */ int size; scm_debug_info *info; if (SCM_EVALFRAMEP (*dframe)) @@ -291,7 +291,7 @@ read_frames (scm_debug_frame *dframe,long offset,int n,scm_info_frame *iframes) && !SCM_UNBNDP (info[1].a.proc)) { NEXT_FRAME (iframe, n, quit); - iframe->flags = SCM_INUM0 | SCM_FRAMEF_PROC; + iframe->flags = SCM_ASWORD(SCM_INUM0) | SCM_FRAMEF_PROC; iframe->proc = info[1].a.proc; iframe->args = info[1].a.args; } @@ -303,12 +303,12 @@ read_frames (scm_debug_frame *dframe,long offset,int n,scm_info_frame *iframes) { if (!SCM_UNBNDP (info[1].a.proc)) { - iframe->flags = SCM_INUM0 | SCM_FRAMEF_PROC; + iframe->flags = SCM_ASWORD(SCM_INUM0) | SCM_FRAMEF_PROC; iframe->proc = info[1].a.proc; iframe->args = info[1].a.args; } else - iframe->flags = SCM_INUM0; + iframe->flags = SCM_ASWORD (SCM_INUM0); iframe->source = scm_make_memoized (info[0].e.exp, info[0].e.env); info -= 2; diff --git a/libguile/stacks.h b/libguile/stacks.h index d571584fe..c20671084 100644 --- a/libguile/stacks.h +++ b/libguile/stacks.h @@ -56,7 +56,8 @@ */ typedef struct scm_info_frame { - SCM flags; + //SCM flags; + SCMWORD flags; SCM source; SCM proc; SCM args; @@ -107,11 +108,11 @@ extern SCM scm_stack_type; #define SCM_FRAMEF_EVAL_ARGS (1L << 5) #define SCM_FRAMEF_OVERFLOW (1L << 6) -#define SCM_FRAME_VOID_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_VOID) -#define SCM_FRAME_REAL_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_REAL) -#define SCM_FRAME_PROC_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_PROC) -#define SCM_FRAME_EVAL_ARGS_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_EVAL_ARGS) -#define SCM_FRAME_OVERFLOW_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_OVERFLOW) +#define SCM_FRAME_VOID_P(frame) (SCM_ASWORD (SCM_FRAME_FLAGS (frame)) & SCM_FRAMEF_VOID) +#define SCM_FRAME_REAL_P(frame) (SCM_ASWORD (SCM_FRAME_FLAGS (frame)) & SCM_FRAMEF_REAL) +#define SCM_FRAME_PROC_P(frame) (SCM_ASWORD (SCM_FRAME_FLAGS (frame)) & SCM_FRAMEF_PROC) +#define SCM_FRAME_EVAL_ARGS_P(frame) (SCM_ASWORD (SCM_FRAME_FLAGS (frame)) & SCM_FRAMEF_EVAL_ARGS) +#define SCM_FRAME_OVERFLOW_P(frame) (SCM_ASWORD (SCM_FRAME_FLAGS (frame)) & SCM_FRAMEF_OVERFLOW) diff --git a/libguile/strports.c b/libguile/strports.c index d787ccc17..8c814c8bb 100644 --- a/libguile/strports.c +++ b/libguile/strports.c @@ -83,7 +83,7 @@ stfill_buffer (SCM port) if (pt->read_pos >= pt->read_end) return EOF; else - return scm_return_first (*pt->read_pos, port); + return scm_return_first (*pt->read_pos, port); /* huh? -- hwn*/ } /* change the size of a port's string to new_size. this doesn't @@ -207,7 +207,7 @@ st_seek (SCM port, off_t offset, int whence) if (target >= pt->write_buf_size) { - if (!(SCM_CAR (port) & SCM_WRTNG)) + if (!(SCM_CARW (port) & SCM_WRTNG)) { if (target > pt->write_buf_size) { diff --git a/libguile/struct.c b/libguile/struct.c index 7ad351235..a41ebe3fd 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -173,7 +173,7 @@ scm_struct_init (SCM handle, int tail_elts, SCM inits) { tailp = 1; prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o'; - *mem++ = tail_elts; + *mem++ = SCM_ASSCM (tail_elts); n_fields += tail_elts - 1; if (n_fields == 0) break; @@ -324,7 +324,7 @@ scm_alloc_struct (int n_words, int n_extra, char *who) SCM *p = block + n_extra; /* Adjust it even further so it's aligned on an eight-byte boundary. */ - p = (SCM *) (((SCM) p + 7) & ~7); + p = (SCM *) (((SCMWORD) SCM_ASWORD (p) + 7) & ~7); /* Initialize a few fields as described above. */ p[scm_struct_i_free] = (SCM) scm_struct_free_standard; @@ -345,13 +345,13 @@ scm_sizet scm_struct_free_light (SCM *vtable, SCM *data) { free (data); - return vtable[scm_struct_i_size] & ~SCM_STRUCTF_MASK; + return SCM_ASWORD (vtable[scm_struct_i_size]) & ~SCM_STRUCTF_MASK; } scm_sizet scm_struct_free_standard (SCM *vtable, SCM *data) { - size_t n = ((data[scm_struct_i_n_words] + scm_struct_n_extra_words) + size_t n = ((SCM_ASWORD (data[scm_struct_i_n_words]) + scm_struct_n_extra_words) * sizeof (SCM) + 7); free ((void *) data[scm_struct_i_ptr]); return n; @@ -360,7 +360,7 @@ scm_struct_free_standard (SCM *vtable, SCM *data) scm_sizet scm_struct_free_entity (SCM *vtable, SCM *data) { - size_t n = ((data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words) + size_t n = (SCM_ASWORD(data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words) * sizeof (SCM) + 7); free ((void *) data[scm_struct_i_ptr]); return n; @@ -394,7 +394,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1, tail_elts = SCM_INUM (tail_array_size); SCM_NEWCELL (handle); SCM_DEFER_INTS; - if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY) + if (SCM_ASWORD (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags]) & SCM_STRUCTF_ENTITY) { data = scm_alloc_struct (basic_size + tail_elts, scm_struct_entity_n_extra_words, @@ -520,7 +520,7 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, SCM * data; SCM layout; int p; - int n_fields; + SCMWORD n_fields; unsigned char * fields_desc; unsigned char field_type = 0; @@ -697,7 +697,7 @@ scm_struct_ihashq (SCM obj, unsigned int n) { /* The length of the hash table should be a relative prime it's not necessary to shift down the address. */ - return obj % n; + return SCM_ASWORD (obj) % n; } SCM @@ -755,9 +755,9 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate) else scm_puts ("struct", port); scm_putc (' ', port); - scm_intprint (vtable, 16, port); + scm_intprint ((int) vtable, 16, port); scm_putc (':', port); - scm_intprint (exp, 16, port); + scm_intprint ((int)exp, 16, port); scm_putc ('>', port); } } diff --git a/libguile/tag.c b/libguile/tag.c index 24e6b1802..4de379543 100644 --- a/libguile/tag.c +++ b/libguile/tag.c @@ -105,9 +105,8 @@ SCM_DEFINE (scm_tag, "tag", 1, 0, 0, return SCM_CDR (scm_utag_immediate_char) ; else { - int tag; - tag = SCM_MAKINUM ((x >> 8) & 0xff); - return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_flag_base) ) | (tag << 8)); + SCM tag = SCM_MAKINUM ((SCM_ASWORD (x) >> 8) & 0xff); + return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_flag_base) ) | (SCM_ASWORD (tag) << 8)); } case scm_tc3_cons: diff --git a/libguile/tags.h b/libguile/tags.h index fc21e73f3..1ef20edad 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -54,10 +54,27 @@ + /* In the beginning was the Word: */ -typedef long SCM; +typedef long SCMWORD; +/* + But as external interface, we use void*, which will be checked more strictly for + dubious conversions. + */ +#define VOIDP_TEST +#ifndef VOIDP_TEST +typedef SCMWORD SCM; +#define SCM_ASWORD(x) (x) +#define SCM_ASSCM(x) (x) +#else +typedef void * SCM; +#define SCM_ASWORD(x) ((SCMWORD)(x)) +#define SCM_ASSCM(x) ((SCM)(x)) +#endif +/* SCM_CARW is a convenience for treating the CAR of X as a word */ +#define SCM_CARW(x) SCM_ASWORD (SCM_CAR(x)) /* Cray machines have pointers that are incremented once for each word, @@ -106,7 +123,7 @@ typedef long SCM; * (Not always impossible but it is fair to say that many details of tags * are mutually dependent). */ -#define SCM_IMP(x) (6 & (SCM) (x)) +#define SCM_IMP(x) (6 & SCM_ASWORD(x)) #define SCM_NIMP(x) (!SCM_IMP (x)) /* Here is a summary of tagging in SCM values as they might occur in @@ -264,7 +281,7 @@ typedef long SCM; * stored in the SCM_CAR of a non-immediate object have a 1 in bit 1: */ -#define SCM_SLOPPY_NCONSP(x) (1 & SCM_CAR (x)) +#define SCM_SLOPPY_NCONSP(x) (1 & SCM_CARW (x)) #define SCM_SLOPPY_CONSP(x) (!SCM_SLOPPY_NCONSP(x)) #define SCM_NCONSP(x) (SCM_IMP (x) || SCM_SLOPPY_NCONSP(x)) @@ -286,21 +303,21 @@ typedef long SCM; #define SCM_CELLP(x) (!SCM_NCELLP (x)) -#define SCM_NCELLP(x) ((sizeof (scm_cell) - 1) & (SCM) (x)) +#define SCM_NCELLP(x) ((sizeof (scm_cell) - 1) & (SCMWORD) SCM_ASWORD(x)) /* See numbers.h for macros relating to immediate integers. */ -#define SCM_ITAG3(x) (7 & (SCM) x) -#define SCM_TYP3(x) (7 & SCM_CAR (x)) +#define SCM_ITAG3(x) (7 & SCM_ASWORD(x)) +#define SCM_TYP3(x) (7 & SCM_CARW (x)) #define scm_tc3_cons 0 #define scm_tc3_cons_gloc 1 #define scm_tc3_int_1 2 -#define scm_tc3_closure 3 -#define scm_tc3_imm24 4 -#define scm_tc3_tc7_1 5 -#define scm_tc3_int_2 6 -#define scm_tc3_tc7_2 7 +#define scm_tc3_closure 3 +#define scm_tc3_imm24 4 +#define scm_tc3_tc7_1 5 +#define scm_tc3_int_2 6 +#define scm_tc3_tc7_2 7 /* @@ -308,20 +325,20 @@ typedef long SCM; */ -#define SCM_TYP7(x) (SCM_CAR (x) & 0x7f) -#define SCM_TYP7S(x) (SCM_CAR (x) & (0x7f & ~2)) +#define SCM_TYP7(x) (0x7f & SCM_CARW (x)) +#define SCM_TYP7S(x) ((0x7f & ~2) & SCM_CARW (x)) -#define SCM_TYP16(x) (0xffff & SCM_CAR (x)) -#define SCM_TYP16S(x) (0xfeff & SCM_CAR (x)) -#define SCM_GCTYP16(x) (0xff7f & SCM_CAR (x)) +#define SCM_TYP16(x) (0xffff & SCM_CARW (x)) +#define SCM_TYP16S(x) (0xfeff & SCM_CARW (x)) +#define SCM_GCTYP16(x) (0xff7f & SCM_CARW (x)) /* Testing and Changing GC Marks in Various Standard Positions */ -#define SCM_GCMARKP(x) (1 & SCM_CDR (x)) -#define SCM_GC8MARKP(x) (0x80 & SCM_CAR (x)) +#define SCM_GCMARKP(x) (1 & SCM_ASWORD (SCM_CDR (x))) +#define SCM_GC8MARKP(x) (0x80 & SCM_CARW (x)) #define SCM_SETGCMARK(x) SCM_SETOR_CDR (x, 1) #define SCM_CLRGCMARK(x) SCM_SETAND_CDR (x, ~1L) #define SCM_SETGC8MARK(x) SCM_SETOR_CAR (x, 0x80) @@ -437,9 +454,9 @@ enum scm_tags scm_tc8_iloc = 0xfc }; -#define SCM_ITAG8(X) ((SCM) (X) & 0xff) -#define SCM_MAKE_ITAG8(X, TAG) (((X) << 8) + TAG) -#define SCM_ITAG8_DATA(X) ((X) >> 8) +#define SCM_ITAG8(X) (SCM_ASWORD(X) & 0xff) +#define SCM_MAKE_ITAG8(X, TAG) SCM_ASSCM(((X) << 8) + TAG) +#define SCM_ITAG8_DATA(X) (SCM_ASWORD(X) >> 8) @@ -447,15 +464,15 @@ enum scm_tags */ /* SCM_ISYMP tests for ISPCSYM and ISYM */ -#define SCM_ISYMP(n) ((0x187 & (SCM) (n)) == 4) +#define SCM_ISYMP(n) ((0x187 & SCM_ASWORD(n)) == 4) /* SCM_IFLAGP tests for ISPCSYM, ISYM and IFLAG */ -#define SCM_IFLAGP(n) ((0x87 & (SCM) (n)) == 4) -#define SCM_ISYMNUM(n) ((SCM) ((n) >> 9)) +#define SCM_IFLAGP(n) ((0x87 & SCM_ASWORD(n)) == 4) +#define SCM_ISYMNUM(n) (SCM_ASWORD(n) >> 9) #define SCM_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM (n)]) -#define SCM_MAKSPCSYM(n) (((n) << 9) + ((n) << 3) + 4L) -#define SCM_MAKISYM(n) (((n) << 9) + 0x74L) -#define SCM_MAKIFLAG(n) (((n) << 9) + 0x174L) +#define SCM_MAKSPCSYM(n) SCM_ASSCM(((n) << 9) + ((n) << 3) + 4L) +#define SCM_MAKISYM(n) SCM_ASSCM(((n) << 9) + 0x74L) +#define SCM_MAKIFLAG(n) SCM_ASSCM(((n) << 9) + 0x174L) extern char *scm_isymnames[]; /* defined in print.c */ diff --git a/libguile/throw.c b/libguile/throw.c index e63c01a94..0f21fe79e 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -68,19 +68,20 @@ /* the jump buffer data structure */ static int scm_tc16_jmpbuffer; -#define SCM_JMPBUFP(O) (SCM_NIMP(O) && (SCM_TYP16(O) == scm_tc16_jmpbuffer)) -#define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L)) -#define ACTIVATEJB(O) (SCM_SETOR_CAR (O, (1L << 16L))) -#define DEACTIVATEJB(O) (SCM_SETAND_CAR (O, ~(1L << 16L))) +#define SCM_JMPBUFP(OBJ) (SCM_NIMP(OBJ) && (SCM_TYP16(OBJ) == scm_tc16_jmpbuffer)) + +#define JBACTIVE(OBJ) (SCM_CARW (OBJ) & (1L << 16L)) +#define ACTIVATEJB(OBJ) (SCM_SETOR_CAR (OBJ, (1L << 16L))) +#define DEACTIVATEJB(OBJ) (SCM_SETAND_CAR (OBJ, ~(1L << 16L))) #ifndef DEBUG_EXTENSIONS -#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) ) +#define JBJMPBUF(OBJ) ((jmp_buf*)SCM_CDR (OBJ) ) #define SETJBJMPBUF SCM_SETCDR #else -#define SCM_JBDFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) ) -#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) ) -#define SCM_SETJBDFRAME(O,X) SCM_SETCAR (SCM_CDR (O), (SCM)(X)) -#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X) +#define SCM_JBDFRAME(OBJ) ((scm_debug_frame*)SCM_CAR (SCM_CDR (OBJ)) ) +#define JBJMPBUF(OBJ) ((jmp_buf*)SCM_CDR (SCM_CDR (OBJ)) ) +#define SCM_SETJBDFRAME(OBJ,X) SCM_SETCAR (SCM_CDR (OBJ), (SCM)(X)) +#define SETJBJMPBUF(OBJ,X) SCM_SETCDR(SCM_CDR (OBJ), X) static scm_sizet freejb (SCM jbsmob) @@ -95,7 +96,8 @@ printjb (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#', port); return 1 ; } @@ -274,7 +276,7 @@ make_lazy_catch (struct lazy_catch *c) } #define SCM_LAZY_CATCH_P(obj) \ - (SCM_NIMP (obj) && (SCM_CAR (obj) == tc16_lazy_catch)) + (SCM_NIMP (obj) && (SCM_CARW (obj) == tc16_lazy_catch)) /* Exactly like scm_internal_catch, except: diff --git a/libguile/unif.c b/libguile/unif.c index 32ff7416a..8af679e95 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -42,6 +42,13 @@ /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ +/* + This file has code for arrays in lots of variants (double, integer, + unsigned etc. ). It suffers from hugely repetitive code because + there is similar (but different) code for every variant included. (urg.) + + --hwn +*/ #include @@ -280,10 +287,9 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, enclosed = 0; if (SCM_IMP (v)) return SCM_BOOL_F; -loop: - switch (SCM_TYP7 (v)) + + while (SCM_TYP7 (v) == scm_tc7_smob) { - case scm_tc7_smob: if (!SCM_ARRAYP (v)) return SCM_BOOL_F; if (nprot) @@ -291,45 +297,55 @@ loop: if (enclosed++) return SCM_BOOL_F; v = SCM_ARRAY_V (v); - goto loop; - case scm_tc7_bvect: - return nprot || SCM_BOOL(SCM_BOOL_T==prot); - case scm_tc7_string: - return nprot || SCM_BOOL(SCM_CHARP(prot) && (prot != SCM_MAKE_CHAR('\0'))); - case scm_tc7_byvect: - return nprot || SCM_BOOL(prot == SCM_MAKE_CHAR('\0')); - case scm_tc7_uvect: - return nprot || SCM_BOOL(SCM_INUMP(prot) && SCM_INUM(prot)>0); - case scm_tc7_ivect: - return nprot || SCM_BOOL(SCM_INUMP(prot) && SCM_INUM(prot)<=0); - case scm_tc7_svect: - return ( nprot - || (SCM_SYMBOLP (prot) - && (1 == SCM_LENGTH (prot)) - && ('s' == SCM_CHARS (prot)[0]))); + } + if (nprot) + return SCM_BOOL(nprot); + else + { + int protp = 0; + + switch (SCM_TYP7 (v)) + { + case scm_tc7_bvect: + protp = (SCM_BOOL_T==prot); + case scm_tc7_string: + protp = SCM_ICHRP(prot) && (prot != SCM_MAKICHR('\0')); + case scm_tc7_byvect: + protp = prot == SCM_MAKICHR('\0'); + case scm_tc7_uvect: + protp = SCM_INUMP(prot) && SCM_INUM(prot)>0; + case scm_tc7_ivect: + protp = SCM_INUMP(prot) && SCM_INUM(prot)<=0; + + case scm_tc7_svect: + protp = SCM_SYMBOLP (prot) + && (1 == SCM_LENGTH (prot)) + && ('s' == SCM_CHARS (prot)[0]); #ifdef HAVE_LONG_LONGS - case scm_tc7_llvect: - return ( nprot - || (SCM_SYMBOLP (prot) - && (1 == SCM_LENGTH (prot)) - && ('s' == SCM_CHARS (prot)[0]))); + case scm_tc7_llvect: + protp = SCM_SYMBOLP (prot) + && (1 == SCM_LENGTH (prot)) + && ('s' == SCM_CHARS (prot)[0]); #endif # ifdef SCM_FLOATS # ifdef SCM_SINGLES - case scm_tc7_fvect: - return nprot || SCM_BOOL(SCM_SINGP(prot)); + case scm_tc7_fvect: + protp = SCM_SINGP(prot); # endif - case scm_tc7_dvect: - return nprot || SCM_BOOL(SCM_REALP(prot)); - case scm_tc7_cvect: - return nprot || SCM_BOOL(SCM_CPLXP(prot)); + case scm_tc7_dvect: + protp = SCM_REALP(prot); + case scm_tc7_cvect: + protp = SCM_CPLXP(prot); # endif - case scm_tc7_vector: - case scm_tc7_wvect: - return nprot || SCM_BOOL(SCM_NULLP(prot)); - default:; + case scm_tc7_vector: + case scm_tc7_wvect: + protp = SCM_NULLP(prot); + default: + /* no default */ + ; + } + return SCM_BOOL(protp); } - return SCM_BOOL_F; } #undef FUNC_NAME @@ -1079,8 +1095,11 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, badarg: SCM_WTA (1,v); abort (); - outrng:scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); - wna: scm_wrong_num_args (SCM_FUNC_NAME); + + outrng: + scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); + wna: + scm_wrong_num_args (SCM_FUNC_NAME); case scm_tc7_smob: { /* enclosed */ int k = SCM_ARRAY_NDIM (v); @@ -1096,7 +1115,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, return res; } case scm_tc7_bvect: - if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT))) + if (SCM_BITVEC_REF (v, pos)) return SCM_BOOL_T; else return SCM_BOOL_F; @@ -1110,9 +1129,9 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, return SCM_MAKINUM (SCM_VELTS (v)[pos]); # else case scm_tc7_uvect: - return scm_ulong2num(SCM_VELTS(v)[pos]); + return scm_ulong2num((unsigned long ) SCM_VELTS(v)[pos]); case scm_tc7_ivect: - return scm_long2num(SCM_VELTS(v)[pos]); + return scm_long2num((long) SCM_VELTS(v)[pos]); # endif case scm_tc7_svect: @@ -1151,7 +1170,7 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) default: scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref"); case scm_tc7_bvect: - if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT))) + if (SCM_BITVEC_REF(v,pos)) return SCM_BOOL_T; else return SCM_BOOL_F; @@ -1165,9 +1184,9 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) return SCM_MAKINUM (SCM_VELTS (v)[pos]); # else case scm_tc7_uvect: - return scm_ulong2num(SCM_VELTS(v)[pos]); + return scm_ulong2num((unsigned long) SCM_VELTS(v)[pos]); case scm_tc7_ivect: - return scm_long2num(SCM_VELTS(v)[pos]); + return scm_long2num((long) SCM_VELTS(v)[pos]); # endif case scm_tc7_svect: return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]); @@ -1178,7 +1197,7 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: - if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_flo == SCM_CAR (last))) + if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_flo == SCM_CARW (last))) { SCM_FLO (last) = ((float *) SCM_CDR (v))[pos]; return last; @@ -1187,7 +1206,7 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) #endif case scm_tc7_dvect: #ifdef SCM_SINGLES - if (SCM_NIMP (last) && scm_tc_dblr == SCM_CAR (last)) + if (SCM_NIMP (last) && scm_tc_dblr == SCM_CARW (last)) #else if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_dblr == SCM_CAR (last))) #endif @@ -1197,7 +1216,7 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) } return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0); case scm_tc7_cvect: - if (SCM_NIMP (last) && scm_tc_dblc == SCM_CAR (last)) + if (SCM_NIMP (last) && scm_tc_dblc == SCM_CARW (last)) { SCM_REAL (last) = ((double *) SCM_CDR (v))[2 * pos]; SCM_IMAG (last) = ((double *) SCM_CDR (v))[2 * pos + 1]; @@ -1264,15 +1283,17 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, default: badarg1: SCM_WTA (1,v); abort (); - outrng:scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); - wna: scm_wrong_num_args (SCM_FUNC_NAME); + outrng: + scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); + wna: + scm_wrong_num_args (SCM_FUNC_NAME); case scm_tc7_smob: /* enclosed */ goto badarg1; case scm_tc7_bvect: if (SCM_BOOL_F == obj) - SCM_VELTS (v)[pos / SCM_LONG_BIT] &= ~(1L << (pos % SCM_LONG_BIT)); + SCM_BITVEC_CLR(v,pos); else if (SCM_BOOL_T == obj) - SCM_VELTS (v)[pos / SCM_LONG_BIT] |= (1L << (pos % SCM_LONG_BIT)); + SCM_BITVEC_SET(v,pos); else badobj:SCM_WTA (2,obj); break; @@ -1291,12 +1312,15 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, SCM_ASRTGO (SCM_INUM (obj) >= 0, badobj); /* fall through */ case scm_tc7_ivect: - SCM_ASRTGO(SCM_INUMP(obj), badobj); SCM_VELTS(v)[pos] = SCM_INUM(obj); break; + SCM_ASRTGO(SCM_INUMP(obj), badobj); SCM_VELTS(v)[pos] = SCM_INUM(obj); + break; # else case scm_tc7_uvect: - SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG2, FUNC_NAME); break; + SCM_VELTS(v)[pos] = SCM_ASSCM (scm_num2ulong(obj, (char *)SCM_ARG2, FUNC_NAME)); + break; case scm_tc7_ivect: - SCM_VELTS(v)[pos] = scm_num2long(obj, (char *)SCM_ARG2, FUNC_NAME); break; + SCM_VELTS(v)[pos] = SCM_ASSCM (scm_num2long(obj, (char *)SCM_ARG2, FUNC_NAME)); + break; # endif case scm_tc7_svect: SCM_ASRTGO (SCM_INUMP (obj), badobj); @@ -1727,7 +1751,8 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, #define FUNC_NAME s_scm_bit_count { long i; - register unsigned long cnt = 0, w; + register unsigned long cnt = 0; + register unsigned long w; SCM_VALIDATE_INUM (2,seq); switch SCM_TYP7 (seq) { @@ -1737,7 +1762,7 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, if (0 == SCM_LENGTH (seq)) return SCM_INUM0; i = (SCM_LENGTH (seq) - 1) / SCM_LONG_BIT; - w = SCM_VELTS (seq)[i]; + w = SCM_ASWORD (SCM_VELTS (seq)[i]); if (SCM_FALSEP (item)) w = ~w; w <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (seq) - 1) % SCM_LONG_BIT); @@ -1747,7 +1772,7 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, cnt += cnt_tab[w & 0x0f]; if (0 == i--) return SCM_MAKINUM (cnt); - w = SCM_VELTS (seq)[i]; + w = SCM_ASWORD (SCM_VELTS (seq)[i]); if (SCM_FALSEP (item)) w = ~w; } @@ -1780,7 +1805,7 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, return SCM_MAKINUM (-1L); lenw = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */ i = pos / SCM_LONG_BIT; - w = SCM_VELTS (v)[i]; + w = SCM_ASWORD (SCM_VELTS (v)[i]); if (SCM_FALSEP (item)) w = ~w; xbits = (pos % SCM_LONG_BIT); @@ -1814,7 +1839,7 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, if (++i > lenw) break; pos += SCM_LONG_BIT; - w = SCM_VELTS (v)[i]; + w = SCM_ASWORD (SCM_VELTS (v)[i]); if (SCM_FALSEP (item)) w = ~w; } @@ -1846,22 +1871,22 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, switch SCM_TYP7 (v) { default: - badarg1:SCM_WTA (1,v); + badarg1: SCM_WTA (1,v); case scm_tc7_bvect: vlen = SCM_LENGTH (v); if (SCM_BOOL_F == obj) for (i = SCM_LENGTH (kv); i;) { - k = SCM_VELTS (kv)[--i]; + k = SCM_ASWORD (SCM_VELTS (kv)[--i]); SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); - SCM_VELTS (v)[k / SCM_LONG_BIT] &= ~(1L << (k % SCM_LONG_BIT)); + SCM_BITVEC_CLR(v,k); } else if (SCM_BOOL_T == obj) for (i = SCM_LENGTH (kv); i;) { - k = SCM_VELTS (kv)[--i]; + k = SCM_ASWORD (SCM_VELTS (kv)[--i]); SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); - SCM_VELTS (v)[k / SCM_LONG_BIT] |= (1L << (k % SCM_LONG_BIT)); + SCM_BITVEC_SET(v,k); } else badarg3:SCM_WTA (3,obj); @@ -1871,10 +1896,10 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1); if (SCM_BOOL_F == obj) for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_VELTS (v)[k] &= ~(SCM_VELTS (kv)[k]); + SCM_ASWORD (SCM_VELTS (v)[k]) &= ~ SCM_ASWORD(SCM_VELTS (kv)[k]); else if (SCM_BOOL_T == obj) for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_VELTS (v)[k] |= SCM_VELTS (kv)[k]; + SCM_ASWORD (SCM_VELTS (v)[k]) |= SCM_ASWORD (SCM_VELTS (kv)[k]); else goto badarg3; break; @@ -1895,34 +1920,37 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, { register long i, vlen, count = 0; register unsigned long k; + SCM_ASRTGO (SCM_NIMP (v), badarg1); SCM_ASRTGO (SCM_NIMP (kv), badarg2); switch SCM_TYP7 (kv) { default: - badarg2:SCM_WTA (2,kv); + badarg2: + SCM_WTA (2,kv); case scm_tc7_uvect: switch SCM_TYP7 (v) { default: - badarg1:SCM_WTA (1,v); + badarg1: + SCM_WTA (1,v); case scm_tc7_bvect: vlen = SCM_LENGTH (v); if (SCM_BOOL_F == obj) for (i = SCM_LENGTH (kv); i;) { - k = SCM_VELTS (kv)[--i]; + k = SCM_ASWORD (SCM_VELTS (kv)[--i]); SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); - if (!(SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT)))) + if (!SCM_BITVEC_REF(v,k)) count++; } else if (SCM_BOOL_T == obj) for (i = SCM_LENGTH (kv); i;) { - k = SCM_VELTS (kv)[--i]; + k = SCM_ASWORD (SCM_VELTS (kv)[--i]); SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); - if (SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT))) + if (SCM_BITVEC_REF (v,k)) count++; } else @@ -1934,17 +1962,19 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, if (0 == SCM_LENGTH (v)) return SCM_INUM0; SCM_ASRTGO (SCM_BOOL_T == obj || SCM_BOOL_F == obj, badarg3); - obj = (SCM_BOOL_T == obj); + obj = (SCM_BOOL_T == obj); /* ugh. */ i = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; - k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]); + k = SCM_ASWORD (SCM_VELTS (kv)[i]) & (obj ? SCM_ASWORD (SCM_VELTS (v)[i]) : ~ SCM_ASWORD (SCM_VELTS (v)[i])); k <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (v) - 1) % SCM_LONG_BIT); - while (!0) + while (1) { for (; k; k >>= 4) count += cnt_tab[k & 0x0f]; if (0 == i--) return SCM_MAKINUM (count); - k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]); + + /* urg. repetitive (see above.) */ + k = SCM_ASWORD (SCM_VELTS (kv)[i]) & (obj ? SCM_ASWORD(SCM_VELTS (v)[i]) : ~SCM_ASWORD (SCM_VELTS (v)[i])); } } return SCM_MAKINUM (count); @@ -1965,7 +1995,7 @@ SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0, { case scm_tc7_bvect: for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_VELTS (v)[k] = ~SCM_VELTS (v)[k]; + SCM_ASWORD (SCM_VELTS (v)[k]) = ~SCM_ASWORD(SCM_VELTS (v)[k]); break; default: badarg1:SCM_WTA (1,v); @@ -2329,11 +2359,11 @@ tail: } case scm_tc7_ivect: if (n-- > 0) - scm_intprint (SCM_VELTS (ra)[j], 10, port); + scm_intprint ((int)SCM_VELTS (ra)[j], 10, port); for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); - scm_intprint (SCM_VELTS (ra)[j], 10, port); + scm_intprint ((int)SCM_VELTS (ra)[j], 10, port); } break; @@ -2435,7 +2465,7 @@ tail: scm_putc ('*', port); for (i = 0; i < (SCM_LENGTH (exp)) / SCM_LONG_BIT; i++) { - w = SCM_VELTS (exp)[i]; + SCMWORD w = SCM_ASWORD (SCM_VELTS (exp)[i]); for (j = SCM_LONG_BIT; j; j--) { scm_putc (w & 1 ? '1' : '0', port); @@ -2445,7 +2475,7 @@ tail: j = SCM_LENGTH (exp) % SCM_LONG_BIT; if (j) { - w = SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT]; + w = SCM_ASWORD (SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT]); for (; j; j--) { scm_putc (w & 1 ? '1' : '0', port); diff --git a/libguile/unif.h b/libguile/unif.h index 6d2cdda2a..c14b7b6b8 100644 --- a/libguile/unif.h +++ b/libguile/unif.h @@ -76,10 +76,10 @@ typedef struct scm_array_dim extern long scm_tc16_array; -#define SCM_ARRAYP(a) (SCM_NIMP(a) && (scm_tc16_array==SCM_TYP16(a))) -#define SCM_ARRAY_NDIM(x) ((scm_sizet)(SCM_CAR(x)>>17)) +#define SCM_ARRAYP(a) (SCM_NIMP(a) && (scm_tc16_array == SCM_TYP16(a))) +#define SCM_ARRAY_NDIM(x) ((scm_sizet)(SCM_CARW(x)>>17)) #define SCM_ARRAY_CONTIGUOUS 0x10000 -#define SCM_ARRAY_CONTP(x) (SCM_ARRAY_CONTIGUOUS & (int)SCM_CAR(x)) +#define SCM_ARRAY_CONTP(x) (SCM_ARRAY_CONTIGUOUS & (int)(SCM_CARW(x))) #define SCM_ARRAY_V(a) (((scm_array *)SCM_CDR(a))->v) #define SCM_ARRAY_BASE(a) (((scm_array *)SCM_CDR(a))->base) diff --git a/libguile/variable.c b/libguile/variable.c index c4cb241b6..38c70256f 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -58,7 +58,7 @@ static int prin_var (SCM exp,SCM port,scm_print_state *pstate) { scm_puts ("#