mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-01 04:10:18 +02:00
Code Activity

*.[ch]: make a distinction between SCM as a generic

Browse source 
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),
This commit is contained in:
Greg J. Badros 2000-03-09 18:58:58 +00:00
parent df8bb2dc39
commit c209c88e54
53 changed files with 1371 additions and 1361 deletions
Download patch file Download diff file Expand all files Collapse all files

14
libguile/arbiters.c
View file

@ -63,11 +63,15 @@
static long scm_tc16_arbiter; 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 static int
prinarb (SCM exp, SCM port, scm_print_state *pstate) prinarb (SCM exp, SCM port, scm_print_state *pstate)
{ {
scm_puts ("#<arbiter ", port); scm_puts ("#<arbiter ", port);
if (SCM_CAR (exp) & (1L << 16)) if (SCM_ARB_LOCKED (exp))
scm_puts ("locked ", port); scm_puts ("locked ", port);
scm_iprin1 (SCM_CDR (exp), port, pstate); scm_iprin1 (SCM_CDR (exp), port, pstate);
scm_putc ('>', port); scm_putc ('>', port);
@ -91,11 +95,11 @@ SCM_DEFINE (scm_try_arbiter, "try-arbiter", 1, 0, 0,
{ {
SCM_VALIDATE_SMOB (1,arb,arbiter); SCM_VALIDATE_SMOB (1,arb,arbiter);
SCM_DEFER_INTS; SCM_DEFER_INTS;
if (SCM_CAR (arb) & (1L << 16)) if (SCM_ARB_LOCKED(arb))
arb = SCM_BOOL_F; arb = SCM_BOOL_F;
else else
{ {
SCM_SETCAR (arb, scm_tc16_arbiter | (1L << 16)); SCM_LOCK_ARB(arb);
arb = SCM_BOOL_T; arb = SCM_BOOL_T;
} }
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
@ -110,9 +114,9 @@ SCM_DEFINE (scm_release_arbiter, "release-arbiter", 1, 0, 0,
#define FUNC_NAME s_scm_release_arbiter #define FUNC_NAME s_scm_release_arbiter
{ {
SCM_VALIDATE_SMOB (1,arb,arbiter); SCM_VALIDATE_SMOB (1,arb,arbiter);
if (!(SCM_CAR (arb) & (1L << 16))) if (! SCM_ARB_LOCKED(arb))
return SCM_BOOL_F; return SCM_BOOL_F;
SCM_SETCAR (arb, scm_tc16_arbiter); SCM_UNLOCK_ARB (arb);
return SCM_BOOL_T; return SCM_BOOL_T;
} }
#undef FUNC_NAME #undef FUNC_NAME

9
libguile/async.c
View file

@ -383,9 +383,14 @@ SCM_DEFINE (scm_set_tick_rate, "set-tick-rate", 1, 0, 0,
#define FUNC_NAME s_scm_set_tick_rate #define FUNC_NAME s_scm_set_tick_rate
{ {
unsigned int old_n; unsigned int old_n;
SCM_VALIDATE_INUM (1,n); SCM_VALIDATE_INUM (1,n);
old_n = scm_tick_rate; 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_rate = 1 + scm_async_rate - scm_async_clock;
scm_async_clock = 1; scm_async_clock = 1;
return SCM_MAKINUM (old_n); 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; unsigned int old_n;
SCM_VALIDATE_INUM (1,n); SCM_VALIDATE_INUM (1,n);
old_n = scm_switch_rate; 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_rate = 1 + scm_async_rate - scm_async_clock;
scm_async_clock = 1; scm_async_clock = 1;
return SCM_MAKINUM (old_n); return SCM_MAKINUM (old_n);

2
libguile/boolean.h
View file

@ -64,7 +64,7 @@
/* SCM_BOOL_NOT returns the other boolean. /* SCM_BOOL_NOT returns the other boolean.
* The order of ^s here is important for Borland C++ (!?!?!) * 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)))

4
libguile/debug.c
View file

@ -275,7 +275,7 @@ SCM_DEFINE (scm_gloc_p, "gloc?", 1, 0, 0,
#define FUNC_NAME s_scm_gloc_p #define FUNC_NAME s_scm_gloc_p
{ {
return SCM_BOOL((SCM_MEMOIZEDP (obj) return SCM_BOOL((SCM_MEMOIZEDP (obj)
&& (SCM_MEMOIZED_EXP (obj) & 7) == 1)); && (SCM_ASWORD(SCM_MEMOIZED_EXP (obj)) & 7) == 1));
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -559,7 +559,7 @@ static int
prindebugobj (SCM obj,SCM port,scm_print_state *pstate) prindebugobj (SCM obj,SCM port,scm_print_state *pstate)
{ {
scm_puts ("#<debug-object ", port); scm_puts ("#<debug-object ", port);
scm_intprint (SCM_DEBUGOBJ_FRAME (obj), 16, port); scm_intprint ((int) SCM_DEBUGOBJ_FRAME (obj), 16, port);
scm_putc ('>', port); scm_putc ('>', port);
return 1; return 1;
} }

4
libguile/dynl.c
View file

@ -414,7 +414,7 @@ static struct dynl_obj *
get_dynl_obj (SCM dobj,const char *subr,int argn) get_dynl_obj (SCM dobj,const char *subr,int argn)
{ {
struct dynl_obj *d; 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); dobj, argn, subr);
d = (struct dynl_obj *)SCM_CDR (dobj); d = (struct dynl_obj *)SCM_CDR (dobj);
SCM_ASSERT (d->handle != NULL, dobj, argn, subr); SCM_ASSERT (d->handle != NULL, dobj, argn, subr);
@ -427,7 +427,7 @@ SCM_DEFINE (scm_dynamic_object_p, "dynamic-object?", 1, 0, 0,
"otherwise.") "otherwise.")
#define FUNC_NAME s_scm_dynamic_object_p #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 #undef FUNC_NAME

4
libguile/dynwind.c
View file

@ -145,7 +145,7 @@ typedef struct guardsmem {
#define SCM_BEFORE_GUARD(obj) (SCM_GUARDSMEM (obj)->before) #define SCM_BEFORE_GUARD(obj) (SCM_GUARDSMEM (obj)->before)
#define SCM_AFTER_GUARD(obj) (SCM_GUARDSMEM (obj)->after) #define SCM_AFTER_GUARD(obj) (SCM_GUARDSMEM (obj)->after)
#define SCM_GUARD_DATA(obj) (SCM_GUARDSMEM (obj)->data) #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; static long tc16_guards;
@ -160,7 +160,7 @@ static int
printguards (SCM exp, SCM port, scm_print_state *pstate) printguards (SCM exp, SCM port, scm_print_state *pstate)
{ {
scm_puts ("#<guards ", port); scm_puts ("#<guards ", port);
scm_intprint (SCM_CDR (exp), 16, port); scm_intprint (SCM_ASWORD (SCM_CDR (exp)), 16, port);
scm_putc ('>', port); scm_putc ('>', port);
return 1; return 1;
} }

78
libguile/eval.c
View file

@ -319,7 +319,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check)
#endif #endif
} }
#ifdef MEMOIZE_LOCALS #ifdef MEMOIZE_LOCALS
iloc = (~SCM_IDSTMSK) & (iloc + SCM_IFRINC); iloc = SCM_ASSCM ((~SCM_IDSTMSK) & SCM_ASWORD(iloc + SCM_IFRINC));
#endif #endif
} }
{ {
@ -409,7 +409,7 @@ scm_unmemocar (SCM form, SCM env)
if (SCM_IMP (form)) if (SCM_IMP (form))
return form; return form;
c = SCM_CAR (form); c = SCM_CAR (form);
if (1 == (c & 7)) if (1 == (SCM_ASWORD (c) & 7))
SCM_SETCAR (form, SCM_CAR (c - 1)); SCM_SETCAR (form, SCM_CAR (c - 1));
#ifdef MEMOIZE_LOCALS #ifdef MEMOIZE_LOCALS
#ifdef DEBUG_EXTENSIONS #ifdef DEBUG_EXTENSIONS
@ -1262,7 +1262,7 @@ scm_macroexp (SCM x, SCM env)
if (SCM_IMP (proc) if (SCM_IMP (proc)
|| scm_tc16_macro != SCM_TYP16 (proc) || scm_tc16_macro != SCM_TYP16 (proc)
|| (int) (SCM_CAR (proc) >> 16) != 2) || (int) (SCM_CARW (proc) >> 16) != 2)
return x; return x;
unmemocar (x, env); unmemocar (x, env);
@ -1295,6 +1295,8 @@ scm_macroexp (SCM x, SCM env)
* readable style... :) * readable style... :)
*/ */
#define SCM_BIT8(x) (127 & SCM_ASWORD (x))
static SCM static SCM
unmemocopy (SCM x, SCM env) unmemocopy (SCM x, SCM env)
{ {
@ -1309,28 +1311,28 @@ unmemocopy (SCM x, SCM env)
#endif #endif
switch (SCM_TYP7 (x)) switch (SCM_TYP7 (x))
{ {
case (127 & SCM_IM_AND): case SCM_BIT8(SCM_IM_AND):
ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED); ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED);
break; break;
case (127 & SCM_IM_BEGIN): case SCM_BIT8(SCM_IM_BEGIN):
ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED); ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED);
break; break;
case (127 & SCM_IM_CASE): case SCM_BIT8(SCM_IM_CASE):
ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED); ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED);
break; break;
case (127 & SCM_IM_COND): case SCM_BIT8(SCM_IM_COND):
ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED); ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED);
break; break;
case (127 & SCM_IM_DO): case SCM_BIT8(SCM_IM_DO):
ls = scm_cons (scm_sym_do, SCM_UNSPECIFIED); ls = scm_cons (scm_sym_do, SCM_UNSPECIFIED);
goto transform; goto transform;
case (127 & SCM_IM_IF): case SCM_BIT8(SCM_IM_IF):
ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED); ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED);
break; break;
case (127 & SCM_IM_LET): case SCM_BIT8(SCM_IM_LET):
ls = scm_cons (scm_sym_let, SCM_UNSPECIFIED); ls = scm_cons (scm_sym_let, SCM_UNSPECIFIED);
goto transform; goto transform;
case (127 & SCM_IM_LETREC): case SCM_BIT8(SCM_IM_LETREC):
{ {
SCM f, v, e, s; SCM f, v, e, s;
ls = scm_cons (scm_sym_letrec, SCM_UNSPECIFIED); ls = scm_cons (scm_sym_letrec, SCM_UNSPECIFIED);
@ -1378,7 +1380,7 @@ unmemocopy (SCM x, SCM env)
} }
break; break;
} }
case (127 & SCM_IM_LETSTAR): case SCM_BIT8(SCM_IM_LETSTAR):
{ {
SCM b, y; SCM b, y;
x = SCM_CDR (x); 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)); ls = scm_cons (scm_sym_letstar, z = scm_cons (y, SCM_UNSPECIFIED));
break; break;
} }
case (127 & SCM_IM_OR): case SCM_BIT8(SCM_IM_OR):
ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED); ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED);
break; break;
case (127 & SCM_IM_LAMBDA): case SCM_BIT8(SCM_IM_LAMBDA):
x = SCM_CDR (x); x = SCM_CDR (x);
ls = scm_cons (scm_sym_lambda, ls = scm_cons (scm_sym_lambda,
z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED)); z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED));
env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env); env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
break; break;
case (127 & SCM_IM_QUOTE): case SCM_BIT8(SCM_IM_QUOTE):
ls = z = scm_cons (scm_sym_quote, SCM_UNSPECIFIED); ls = z = scm_cons (scm_sym_quote, SCM_UNSPECIFIED);
break; break;
case (127 & SCM_IM_SET_X): case SCM_BIT8(SCM_IM_SET_X):
ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED); ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED);
break; break;
case (127 & SCM_IM_DEFINE): case SCM_BIT8(SCM_IM_DEFINE):
{ {
SCM n; SCM n;
x = SCM_CDR (x); 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)))); SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAR (SCM_CAR (env))));
break; break;
} }
case (127 & SCM_MAKISYM (0)): case SCM_BIT8(SCM_MAKISYM (0)):
z = SCM_CAR (x); z = SCM_CAR (x);
if (!SCM_ISYMP (z)) if (!SCM_ISYMP (z))
goto unmemo; goto unmemo;
@ -1916,7 +1918,7 @@ dispatch:
x = scm_cons (x, SCM_UNDEFINED); x = scm_cons (x, SCM_UNDEFINED);
goto retval; goto retval;
case (127 & SCM_IM_AND): case SCM_BIT8(SCM_IM_AND):
x = SCM_CDR (x); x = SCM_CDR (x);
t.arg1 = x; t.arg1 = x;
while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
@ -1929,7 +1931,7 @@ dispatch:
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop; goto carloop;
case (127 & SCM_IM_BEGIN): case SCM_BIT8(SCM_IM_BEGIN):
cdrxnoap: cdrxnoap:
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
cdrxbegin: cdrxbegin:
@ -1969,7 +1971,7 @@ dispatch:
goto loop; /* tail recurse */ goto loop; /* tail recurse */
case (127 & SCM_IM_CASE): case SCM_BIT8(SCM_IM_CASE):
x = SCM_CDR (x); x = SCM_CDR (x);
t.arg1 = EVALCAR (x, env); t.arg1 = EVALCAR (x, env);
while (SCM_NIMP (x = SCM_CDR (x))) while (SCM_NIMP (x = SCM_CDR (x)))
@ -1996,7 +1998,7 @@ dispatch:
RETURN (SCM_UNSPECIFIED) RETURN (SCM_UNSPECIFIED)
case (127 & SCM_IM_COND): case SCM_BIT8(SCM_IM_COND):
while (SCM_NIMP (x = SCM_CDR (x))) while (SCM_NIMP (x = SCM_CDR (x)))
{ {
proc = SCM_CAR (x); proc = SCM_CAR (x);
@ -2024,7 +2026,7 @@ dispatch:
RETURN (SCM_UNSPECIFIED) RETURN (SCM_UNSPECIFIED)
case (127 & SCM_IM_DO): case SCM_BIT8(SCM_IM_DO):
x = SCM_CDR (x); x = SCM_CDR (x);
proc = SCM_CAR (SCM_CDR (x)); /* inits */ proc = SCM_CAR (SCM_CDR (x)); /* inits */
t.arg1 = SCM_EOL; /* values */ t.arg1 = SCM_EOL; /* values */
@ -2055,7 +2057,7 @@ dispatch:
goto begin; goto begin;
case (127 & SCM_IM_IF): case SCM_BIT8(SCM_IM_IF):
x = SCM_CDR (x); x = SCM_CDR (x);
if (SCM_NFALSEP (EVALCAR (x, env))) if (SCM_NFALSEP (EVALCAR (x, env)))
x = SCM_CDR (x); x = SCM_CDR (x);
@ -2067,7 +2069,7 @@ dispatch:
goto carloop; goto carloop;
case (127 & SCM_IM_LET): case SCM_BIT8(SCM_IM_LET):
x = SCM_CDR (x); x = SCM_CDR (x);
proc = SCM_CAR (SCM_CDR (x)); proc = SCM_CAR (SCM_CDR (x));
t.arg1 = SCM_EOL; t.arg1 = SCM_EOL;
@ -2081,7 +2083,7 @@ dispatch:
goto cdrxnoap; goto cdrxnoap;
case (127 & SCM_IM_LETREC): case SCM_BIT8(SCM_IM_LETREC):
x = SCM_CDR (x); x = SCM_CDR (x);
env = EXTEND_ENV (SCM_CAR (x), scm_undefineds, env); env = EXTEND_ENV (SCM_CAR (x), scm_undefineds, env);
x = SCM_CDR (x); x = SCM_CDR (x);
@ -2096,7 +2098,7 @@ dispatch:
goto cdrxnoap; goto cdrxnoap;
case (127 & SCM_IM_LETSTAR): case SCM_BIT8(SCM_IM_LETSTAR):
x = SCM_CDR (x); x = SCM_CDR (x);
proc = SCM_CAR (x); proc = SCM_CAR (x);
if (SCM_IMP (proc)) if (SCM_IMP (proc))
@ -2113,7 +2115,7 @@ dispatch:
while (SCM_NIMP (proc = SCM_CDR (proc))); while (SCM_NIMP (proc = SCM_CDR (proc)));
goto cdrxnoap; goto cdrxnoap;
case (127 & SCM_IM_OR): case SCM_BIT8(SCM_IM_OR):
x = SCM_CDR (x); x = SCM_CDR (x);
t.arg1 = x; t.arg1 = x;
while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
@ -2129,15 +2131,15 @@ dispatch:
goto carloop; goto carloop;
case (127 & SCM_IM_LAMBDA): case SCM_BIT8(SCM_IM_LAMBDA):
RETURN (scm_closure (SCM_CDR (x), env)); RETURN (scm_closure (SCM_CDR (x), env));
case (127 & SCM_IM_QUOTE): case SCM_BIT8(SCM_IM_QUOTE):
RETURN (SCM_CAR (SCM_CDR (x))); RETURN (SCM_CAR (SCM_CDR (x)));
case (127 & SCM_IM_SET_X): case SCM_BIT8(SCM_IM_SET_X):
x = SCM_CDR (x); x = SCM_CDR (x);
proc = SCM_CAR (x); proc = SCM_CAR (x);
switch (7 & (int) proc) switch (7 & (int) proc)
@ -2163,11 +2165,11 @@ dispatch:
#endif #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); scm_misc_error (NULL, "Bad define placement", SCM_EOL);
/* new syntactic forms go here. */ /* new syntactic forms go here. */
case (127 & SCM_MAKISYM (0)): case SCM_BIT8(SCM_MAKISYM (0)):
proc = SCM_CAR (x); proc = SCM_CAR (x);
SCM_ASRTGO (SCM_ISYMP (proc), badfun); SCM_ASRTGO (SCM_ISYMP (proc), badfun);
switch SCM_ISYMNUM (proc) switch SCM_ISYMNUM (proc)
@ -2297,7 +2299,7 @@ dispatch:
if (SCM_NIMP (t.arg1)) if (SCM_NIMP (t.arg1))
do do
{ {
i += (SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1))) i += SCM_ASWORD ((SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1))))
[scm_si_hashsets + hashset]); [scm_si_hashsets + hashset]);
t.arg1 = SCM_CDR (t.arg1); t.arg1 = SCM_CDR (t.arg1);
} }
@ -2484,7 +2486,7 @@ dispatch:
RETURN (x); RETURN (x);
#ifdef MEMOIZE_LOCALS #ifdef MEMOIZE_LOCALS
case (127 & SCM_ILOC00): case SCM_BIT8(SCM_ILOC00):
proc = *scm_ilookup (SCM_CAR (x), env); proc = *scm_ilookup (SCM_CAR (x), env);
SCM_ASRTGO (SCM_NIMP (proc), badfun); SCM_ASRTGO (SCM_NIMP (proc), badfun);
#ifndef SCM_RECKLESS #ifndef SCM_RECKLESS
@ -2546,7 +2548,7 @@ dispatch:
#ifdef DEVAL #ifdef DEVAL
SCM_CLEAR_MACROEXP (debug); SCM_CLEAR_MACROEXP (debug);
#endif #endif
switch ((int) (SCM_CAR (proc) >> 16)) switch ((int) (SCM_CARW (proc) >> 16))
{ {
case 2: case 2:
if (scm_ilength (t.arg1) <= 0) if (scm_ilength (t.arg1) <= 0)
@ -3709,10 +3711,10 @@ SCM_DEFINE (scm_force, "force", 1, 0, 0,
#define FUNC_NAME s_scm_force #define FUNC_NAME s_scm_force
{ {
SCM_VALIDATE_SMOB (1,x,promise); 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); 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_DEFER_INTS;
SCM_SETCDR (x, ans); SCM_SETCDR (x, ans);

2
libguile/eval.h
View file

@ -83,7 +83,7 @@ extern SCM scm_eval_options_interface (SCM setting);
#define SCM_IDSTMSK (-SCM_IDINC) #define SCM_IDSTMSK (-SCM_IDINC)
#define SCM_IFRAME(n) ((int)((SCM_ICDR-SCM_IFRINC)>>8) & ((int)(n)>>8)) #define SCM_IFRAME(n) ((int)((SCM_ICDR-SCM_IFRINC)>>8) & ((int)(n)>>8))
#define SCM_IDIST(n) (((unsigned long)(n))>>20) #define SCM_IDIST(n) (((unsigned long)(n))>>20)
#define SCM_ICDRP(n) (SCM_ICDR & (n)) #define SCM_ICDRP(n) (SCM_ICDR & SCM_ASWORD(n))

2
libguile/feature.c
View file

@ -142,7 +142,7 @@ print_hook (SCM hook, SCM port, scm_print_state *pstate)
} }
scm_intprint (SCM_HOOK_ARITY (hook), 10, port); scm_intprint (SCM_HOOK_ARITY (hook), 10, port);
scm_putc (' ', port); scm_putc (' ', port);
scm_intprint (hook, 16, port); scm_intprint ((int)hook, 16, port);
ls = SCM_HOOK_PROCEDURES (hook); ls = SCM_HOOK_PROCEDURES (hook);
while (SCM_NIMP (ls)) while (SCM_NIMP (ls))
{ {

2
libguile/feature.h
View file

@ -50,7 +50,7 @@
#include "libguile/__scm.h" #include "libguile/__scm.h"
#define SCM_HOOKP(x) (SCM_NIMP(x) && (SCM_TYP16 (x) == scm_tc16_hook)) #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_NAME(hook) SCM_CADR (hook)
#define SCM_HOOK_PROCEDURES(hook) SCM_CDDR (hook) #define SCM_HOOK_PROCEDURES(hook) SCM_CDDR (hook)
#define SCM_SET_HOOK_PROCEDURES(hook, procs) SCM_SETCDR (SCM_CDR (hook), procs) #define SCM_SET_HOOK_PROCEDURES(hook, procs) SCM_SETCDR (SCM_CDR (hook), procs)

2
libguile/filesys.c
View file

@ -751,7 +751,7 @@ scm_dir_print (SCM exp, SCM port, scm_print_state *pstate)
if (SCM_CLOSEDP (exp)) if (SCM_CLOSEDP (exp))
scm_puts ("closed: ", port); scm_puts ("closed: ", port);
scm_puts ("directory stream ", port); scm_puts ("directory stream ", port);
scm_intprint (SCM_CDR (exp), 16, port); scm_intprint ((int)SCM_CDR (exp), 16, port);
scm_putc ('>', port); scm_putc ('>', port);
return 1; return 1;
} }

2
libguile/filesys.h
View file

@ -54,7 +54,7 @@
extern long scm_tc16_dir; extern long scm_tc16_dir;
#define SCM_DIRP(x) (SCM_NIMP(x) && (SCM_TYP16(x)==(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); extern SCM scm_chown (SCM object, SCM owner, SCM group);

2
libguile/fluids.c
View file

@ -99,7 +99,7 @@ static int
print_fluid (SCM exp, SCM port, scm_print_state *pstate) print_fluid (SCM exp, SCM port, scm_print_state *pstate)
{ {
scm_puts ("#<fluid ", port); scm_puts ("#<fluid ", port);
scm_intprint (SCM_FLUID_NUM (exp), 10, port); scm_intprint ((int) SCM_FLUID_NUM (exp), 10, port);
scm_putc ('>', port); scm_putc ('>', port);
return 1; return 1;
} }

4
libguile/fluids.h
View file

@ -75,8 +75,8 @@
extern long scm_tc16_fluid; extern long scm_tc16_fluid;
#define SCM_FLUIDP(x) (SCM_NIMP(x) && (SCM_CAR(x) == scm_tc16_fluid)) #define SCM_FLUIDP(x) (SCM_NIMP(x) && (SCM_CARW (x) == scm_tc16_fluid))
#define SCM_FLUID_NUM(x) SCM_CDR(x) #define SCM_FLUID_NUM(x) SCM_ASWORD (SCM_CDR(x))
/* The fastest way to acces/modify the value of a fluid. These macros /* 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 do no error checking at all. You should only use them when you know

12
libguile/fports.c
View file

@ -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; pt->write_end = pt->write_buf + pt->write_buf_size;
if (read_size > 0 || write_size > 0) if (read_size > 0 || write_size > 0)
SCM_SETCAR (port, SCM_CAR (port) & ~SCM_BUF0); SCM_SETCAR (port, SCM_CARW (port) & ~SCM_BUF0);
else 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, SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
@ -180,12 +180,12 @@ SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
if (cmode == _IOLBF) if (cmode == _IOLBF)
{ {
SCM_SETCAR (port, SCM_CAR (port) | SCM_BUFLINE); SCM_SETCAR (port, SCM_CARW (port) | SCM_BUFLINE);
cmode = _IOFBF; cmode = _IOFBF;
} }
else else
{ {
SCM_SETCAR (port, SCM_CAR (port) ^ SCM_BUFLINE); SCM_SETCAR (port, SCM_CARW (port) ^ SCM_BUFLINE);
} }
if (SCM_UNBNDP (size)) 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_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
scm_putc (' ', port); scm_putc (' ', port);
scm_intprint (SCM_CDR (exp), 16, port); scm_intprint (SCM_ASWORD (SCM_CDR (exp)), 16, port);
} }
scm_putc ('>', port); scm_putc ('>', port);
return 1; return 1;
@ -610,7 +610,7 @@ fport_write (SCM port, const void *data, size_t size)
} }
/* handle line buffering. */ /* 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); fport_flush (port);
} }
} }

6
libguile/fports.h
View file

@ -62,9 +62,9 @@ struct scm_fport {
#define SCM_FPORT_FDES(x) (SCM_FSTREAM (x)->fdes) #define SCM_FPORT_FDES(x) (SCM_FSTREAM (x)->fdes)
#define SCM_FPORTP(x) (SCM_NIMP(x) && (SCM_TYP16S(x)==scm_tc7_port)) #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_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_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG))) #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_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG))) #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. */ /* test whether fdes supports random access. */
#define SCM_FDES_RANDOM_P(fdes) ((lseek (fdes, 0, SEEK_CUR) == -1) ? 0 : 1) #define SCM_FDES_RANDOM_P(fdes) ((lseek (fdes, 0, SEEK_CUR) == -1) ? 0 : 1)

39
libguile/gc.c
View file

@ -353,11 +353,11 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
int i; int i;
int n; int n;
SCM heap_segs; SCM heap_segs;
SCM local_scm_mtrigger; long int local_scm_mtrigger;
SCM local_scm_mallocated; long int local_scm_mallocated;
SCM local_scm_heap_size; long int local_scm_heap_size;
SCM local_scm_cells_allocated; long int local_scm_cells_allocated;
SCM local_scm_gc_time_taken; long int local_scm_gc_time_taken;
SCM answer; SCM answer;
SCM_DEFER_INTS; SCM_DEFER_INTS;
@ -373,6 +373,7 @@ SCM_DEFINE (scm_gc_stats, "gc-stats", 0, 0, 0,
goto retry; goto retry;
scm_block_gc = 0; scm_block_gc = 0;
/// ? ?? ?
local_scm_mtrigger = scm_mtrigger; local_scm_mtrigger = scm_mtrigger;
local_scm_mallocated = scm_mallocated; local_scm_mallocated = scm_mallocated;
local_scm_heap_size = scm_heap_size; local_scm_heap_size = scm_heap_size;
@ -405,7 +406,7 @@ void
scm_gc_end () scm_gc_end ()
{ {
scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt; 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); scm_system_async_mark (scm_gc_async);
} }
@ -667,7 +668,7 @@ gc_mark_nimp:
{ {
SCM vcell; SCM vcell;
vcell = SCM_CAR (ptr) - 1L; vcell = SCM_CAR (ptr) - 1L;
switch (SCM_CDR (vcell)) switch (SCM_ASWORD (SCM_CDR (vcell)))
{ {
default: default:
scm_gc_mark (vcell); scm_gc_mark (vcell);
@ -691,7 +692,7 @@ gc_mark_nimp:
that it removes the mark */ that it removes the mark */
mem = (SCM *)SCM_GCCDR (ptr); 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_procedure]);
scm_gc_mark (mem[scm_struct_i_setter]); scm_gc_mark (mem[scm_struct_i_setter]);
@ -703,8 +704,9 @@ gc_mark_nimp:
scm_gc_mark (*mem); scm_gc_mark (*mem);
if (fields_desc[x] == 'p') if (fields_desc[x] == 'p')
{ {
int j;
if (SCM_LAYOUT_TAILP (fields_desc[x + 1])) if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
for (x = *mem; x; --x) for (j = (long int) *mem; x; --x)
scm_gc_mark (*++mem); scm_gc_mark (*++mem);
else else
scm_gc_mark (*mem); scm_gc_mark (*mem);
@ -922,7 +924,7 @@ scm_mark_locations (SCM_STACKITEM x[], scm_sizet n)
register SCM_CELLPTR ptr; register SCM_CELLPTR ptr;
while (0 <= --m) while (0 <= --m)
if SCM_CELLP (*(SCM **) & x[m]) if (SCM_CELLP (*(SCM **) (& x[m])))
{ {
ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & x[m])); ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & x[m]));
i = 0; i = 0;
@ -987,7 +989,7 @@ scm_cellp (SCM value)
register int i, j; register int i, j;
register SCM_CELLPTR ptr; register SCM_CELLPTR ptr;
if SCM_CELLP (*(SCM **) & value) if SCM_CELLP (*(SCM **) (& value))
{ {
ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & value)); ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & value));
i = 0; i = 0;
@ -1138,7 +1140,7 @@ scm_gc_sweep ()
SCM vcell; SCM vcell;
vcell = SCM_CAR (scmptr) - 1L; 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 free
= (scm_struct_free_t) ((SCM*) vcell)[scm_struct_i_free]; = (scm_struct_free_t) ((SCM*) vcell)[scm_struct_i_free];
@ -1290,7 +1292,7 @@ scm_gc_sweep ()
case scm_tc16_flo: case scm_tc16_flo:
if SCM_GC8MARKP (scmptr) if SCM_GC8MARKP (scmptr)
goto c8mrkcontinue; goto c8mrkcontinue;
switch ((int) (SCM_CAR (scmptr) >> 16)) switch ((int) (SCM_CARW (scmptr) >> 16))
{ {
case (SCM_IMAG_PART | SCM_REAL_PART) >> 16: case (SCM_IMAG_PART | SCM_REAL_PART) >> 16:
m += sizeof (double); m += sizeof (double);
@ -1782,7 +1784,7 @@ SCM_DEFINE (scm_unhash_name, "unhash-name", 1, 0, 0,
--incar; --incar;
if ( ((name == SCM_BOOL_T) || (SCM_CAR (incar) == name)) if ( ((name == SCM_BOOL_T) || (SCM_CAR (incar) == name))
&& (SCM_CDR (incar) != 0) && (SCM_CDR (incar) != 0)
&& (SCM_CDR (incar) != 1)) && (SCM_ASWORD (SCM_CDR (incar)) != 1))
{ {
p->car = name; p->car = name;
} }
@ -1806,6 +1808,9 @@ scm_remember (SCM *ptr)
{ /* empty */ } { /* empty */ }
/*
What the heck is this? --hwn
*/
SCM SCM
scm_return_first (SCM elt, ...) scm_return_first (SCM elt, ...)
{ {
@ -1827,9 +1832,9 @@ scm_permanent_object (SCM obj)
even if all other references are dropped, until someone applies even if all other references are dropped, until someone applies
scm_unprotect_object to it. This function returns OBJ. scm_unprotect_object to it. This function returns OBJ.
Calls to scm_protect_object nest. For every object O, there is a Calls to scm_protect_object nest. For every object OBJ, there is a
counter which scm_protect_object(O) increments and counter which scm_protect_object(OBJ) increments and
scm_unprotect_object(O) decrements, if it is greater than zero. If scm_unprotect_object(OBJ) decrements, if it is greater than zero. If
an object's counter is greater than zero, the garbage collector an object's counter is greater than zero, the garbage collector
will not free it. will not free it.

4
libguile/gc.h
View file

@ -50,12 +50,12 @@
#include "libguile/__scm.h" #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)) #define SCM_NFREEP(x) (!SCM_FREEP(x))
/* 1. This shouldn't be used on immediates. /* 1. This shouldn't be used on immediates.
2. It thinks that subrs are always unmarked (harmless). */ 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_GC8MARKP(x) \
: SCM_GCMARKP(x)) : SCM_GCMARKP(x))
#define SCM_NMARKEDP(x) (!SCM_MARKEDP(x)) #define SCM_NMARKEDP(x) (!SCM_MARKEDP(x))

2
libguile/hash.c
View file

@ -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; if (d) return (scm_hasher(SCM_CAR(obj), n, d/2)+scm_hasher(SCM_CDR(obj), n, d/2)) % n;
else return 1; else return 1;
case scm_tc7_port: 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_tcs_closures:
case scm_tc7_contin: case scm_tc7_contin:
case scm_tcs_subrs: case scm_tcs_subrs:

2
libguile/keywords.h
View file

@ -52,7 +52,7 @@
extern int scm_tc16_keyword; 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)) #define SCM_KEYWORDSYM(X) (SCM_CDR(X))

2
libguile/macros.c
View file

@ -134,7 +134,7 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
{ {
if (!(SCM_NIMP (m) && SCM_TYP16 (m) == scm_tc16_macro)) if (!(SCM_NIMP (m) && SCM_TYP16 (m) == scm_tc16_macro))
return SCM_BOOL_F; return SCM_BOOL_F;
switch ((int) (SCM_CAR (m) >> 16)) switch ((int) (SCM_CARW (m) >> 16))
{ {
case 0: return scm_sym_syntax; case 0: return scm_sym_syntax;
case 1: return scm_sym_macro; case 1: return scm_sym_macro;

2
libguile/mallocs.c
View file

@ -54,7 +54,7 @@ static int
prinmalloc (SCM exp,SCM port,scm_print_state *pstate) prinmalloc (SCM exp,SCM port,scm_print_state *pstate)
{ {
scm_puts("#<malloc ", port); scm_puts("#<malloc ", port);
scm_intprint(SCM_CDR(exp), 16, port); scm_intprint((int) SCM_CDR(exp), 16, port);
scm_putc('>', port); scm_putc('>', port);
return 1; return 1;
} }

181
libguile/numbers.c
View file

@ -151,6 +151,7 @@ SCM_GPROC (s_abs, "abs", 1, 0, 0, scm_abs, g_abs);
SCM SCM
scm_abs (SCM x) scm_abs (SCM x)
{ {
long int cx;
#ifdef SCM_BIGDIG #ifdef SCM_BIGDIG
if (SCM_NINUMP (x)) if (SCM_NINUMP (x))
{ {
@ -164,14 +165,14 @@ scm_abs (SCM x)
#endif #endif
if (SCM_INUM (x) >= 0) if (SCM_INUM (x) >= 0)
return x; return x;
x = - SCM_INUM (x); cx = - SCM_INUM (x);
if (!SCM_POSFIXABLE (x)) if (!SCM_POSFIXABLE (cx))
#ifdef SCM_BIGDIG #ifdef SCM_BIGDIG
return scm_long2big (x); return scm_long2big (cx);
#else #else
scm_num_overflow (s_abs); scm_num_overflow (s_abs);
#endif #endif
return SCM_MAKINUM (x); return SCM_MAKINUM (cx);
} }
SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient); 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 #ifdef SCM_BIGDIG
if (SCM_NINUMP (x)) if (SCM_NINUMP (x))
{ {
long w;
SCM_GASSERT2 (SCM_BIGP (x), SCM_GASSERT2 (SCM_BIGP (x),
g_quotient, x, y, SCM_ARG1, s_quotient); g_quotient, x, y, SCM_ARG1, s_quotient);
if (SCM_NINUMP (y)) if (SCM_NINUMP (y))
@ -201,24 +201,24 @@ scm_quotient (SCM x, SCM y)
z = -z; z = -z;
if (z < SCM_BIGRAD) if (z < SCM_BIGRAD)
{ {
w = scm_copybig (x, SCM_BIGSIGN (x) ? (y > 0) : (y < 0)); SCM sw = scm_copybig (x, SCM_BIGSIGN (x) ? (SCM_ASWORD (y) > 0) : (SCM_ASWORD (y) < 0));
scm_divbigdig (SCM_BDIGITS (w), SCM_NUMDIGS (w), (SCM_BIGDIG) z); scm_divbigdig (SCM_BDIGITS (sw), SCM_NUMDIGS (sw), (SCM_BIGDIG) z);
return scm_normbig (w); return scm_normbig (sw);
} }
{ /* scope */
#ifndef SCM_DIGSTOOBIG #ifndef SCM_DIGSTOOBIG
w = scm_pseudolong (z); long w = scm_pseudolong (z);
return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
(SCM_BIGDIG *) & w, SCM_DIGSPERLONG, (SCM_BIGDIG *) & w, SCM_DIGSPERLONG,
SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 2); SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 2);
#else #else
{
SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
scm_longdigs (z, zdigs); scm_longdigs (z, zdigs);
return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
zdigs, SCM_DIGSPERLONG, zdigs, SCM_DIGSPERLONG,
SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 2); SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 2);
}
#endif #endif
} /* end scope */
} }
if (SCM_NINUMP (y)) if (SCM_NINUMP (y))
{ {
@ -377,7 +377,7 @@ SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd);
SCM SCM
scm_gcd (SCM x, SCM y) scm_gcd (SCM x, SCM y)
{ {
register long u, v, k, t; long u, v, k, t;
if (SCM_UNBNDP (y)) if (SCM_UNBNDP (y))
return SCM_UNBNDP (x) ? SCM_INUM0 : x; return SCM_UNBNDP (x) ? SCM_INUM0 : x;
tailrec: tailrec:
@ -400,9 +400,11 @@ scm_gcd (SCM x, SCM y)
{ {
case -1: case -1:
swaprec: swaprec:
t = scm_remainder (x, y); {
SCM t = scm_remainder (x, y);
x = y; x = y;
y = t; y = t;
}
goto tailrec; goto tailrec;
case 0: case 0:
return x; return x;
@ -419,7 +421,7 @@ scm_gcd (SCM x, SCM y)
} }
if (SCM_NINUMP (y)) if (SCM_NINUMP (y))
{ {
t = x; SCM t = x;
x = y; x = y;
y = t; y = t;
goto big_gcd; goto big_gcd;
@ -694,7 +696,7 @@ SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
#define FUNC_NAME s_scm_ash #define FUNC_NAME s_scm_ash
{ {
/* GJB:FIXME:: what is going on here? */ /* GJB:FIXME:: what is going on here? */
SCM res = SCM_INUM (n); SCM res = SCM_ASSCM (SCM_INUM (n));
SCM_VALIDATE_INUM (2,cnt); SCM_VALIDATE_INUM (2,cnt);
#ifdef SCM_BIGDIG #ifdef SCM_BIGDIG
if (cnt < 0) if (cnt < 0)
@ -862,10 +864,11 @@ static const char s_bignum[] = "bignum";
SCM SCM
scm_mkbig (scm_sizet nlen, int sign) scm_mkbig (scm_sizet nlen, int sign)
{ {
SCM v = nlen; SCM v;
/* Cast to SCM to avoid signed/unsigned comparison warnings. */ /* Cast to long int to avoid signed/unsigned comparison warnings. */
if (((v << 16) >> 16) != (SCM) nlen) if ((( ((long int)nlen) << 16) >> 16) != (long int) nlen)
scm_wta (SCM_MAKINUM (nlen), (char *) SCM_NALLOC, s_bignum); scm_wta (SCM_MAKINUM (nlen), (char *) SCM_NALLOC, s_bignum);
SCM_NEWCELL (v); SCM_NEWCELL (v);
SCM_DEFER_INTS; SCM_DEFER_INTS;
SCM_SETCHARS (v, scm_must_malloc ((long) (nlen * sizeof (SCM_BIGDIG)), 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; num = 1;
i = 0; i = 0;
SCM_SETCAR (z, SCM_CAR (z) ^ 0x0100); SCM_SETCAR (z, SCM_CARW (z) ^ 0x0100);
do do
{ {
num += (SCM_BIGRAD - 1) - zds[i]; 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); SCM_GASSERT1 (SCM_INUMP (x), g_positive_p, x, SCM_ARG1, s_positive_p);
#endif #endif
#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); SCM_GASSERT1 (SCM_INUMP (x), g_negative_p, x, SCM_ARG1, s_negative_p);
#endif #endif
#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); 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); SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum);
/*
This is sick, sick, sick code.
*/
SCM SCM
scm_sum (SCM x, SCM y) scm_sum (SCM x, SCM y)
{ {
@ -3141,8 +3150,7 @@ scm_sum (SCM x, SCM y)
#ifdef SCM_FLOATS #ifdef SCM_FLOATS
if (SCM_NINUMP (x)) if (SCM_NINUMP (x))
{ {
SCM t; # ifdef SCM_BIGDIG
#ifdef SCM_BIGDIG
if (!SCM_NIMP (x)) if (!SCM_NIMP (x))
{ {
badx2: badx2:
@ -3152,9 +3160,7 @@ scm_sum (SCM x, SCM y)
{ {
if (SCM_INUMP (y)) if (SCM_INUMP (y))
{ {
t = x; SCM_SWAP(x,y);
x = y;
y = t;
goto intbig; goto intbig;
} }
SCM_ASRTGO (SCM_NIMP (y), bady); SCM_ASRTGO (SCM_NIMP (y), bady);
@ -3162,9 +3168,7 @@ scm_sum (SCM x, SCM y)
{ {
if (SCM_NUMDIGS (x) > SCM_NUMDIGS (y)) if (SCM_NUMDIGS (x) > SCM_NUMDIGS (y))
{ {
t = x; SCM_SWAP(x,y);
x = y;
y = t;
} }
return scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), return scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
SCM_BIGSIGN (x), SCM_BIGSIGN (x),
@ -3175,24 +3179,19 @@ scm_sum (SCM x, SCM y)
return scm_makdbl (scm_big2dbl (x) + SCM_REALPART (y), return scm_makdbl (scm_big2dbl (x) + SCM_REALPART (y),
SCM_CPLXP (y) ? SCM_IMAG (y) : 0.0); SCM_CPLXP (y) ? SCM_IMAG (y) : 0.0);
} }
# endif /* SCM_BIGDIG */
SCM_ASRTGO (SCM_INEXP (x), badx2); SCM_ASRTGO (SCM_INEXP (x), badx2);
#else
SCM_ASRTGO (SCM_INEXP (x), badx2);
#endif
if (SCM_INUMP (y)) if (SCM_INUMP (y))
{ {
t = x; SCM_SWAP(x,y);
x = y;
y = t;
goto intreal; goto intreal;
} }
#ifdef SCM_BIGDIG # ifdef SCM_BIGDIG
SCM_ASRTGO (SCM_NIMP (y), bady); SCM_ASRTGO (SCM_NIMP (y), bady);
if (SCM_BIGP (y)) if (SCM_BIGP (y))
{ {
t = x; SCM_SWAP(x,y);
x = y;
y = t;
goto bigreal; goto bigreal;
} }
else if (!SCM_INEXP (y)) else if (!SCM_INEXP (y))
@ -3200,13 +3199,13 @@ scm_sum (SCM x, SCM y)
bady: bady:
SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
} }
#else # else /* SCM_BIGDIG */
if (!SCM_INEXP (y)) if (!SCM_INEXP (y))
{ {
bady: bady:
SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
} }
#endif # endif /* SCM_BIGDIG */
{ {
double i = 0.0; double i = 0.0;
if (SCM_CPLXP (x)) if (SCM_CPLXP (x))
@ -3218,54 +3217,46 @@ scm_sum (SCM x, SCM y)
} }
if (SCM_NINUMP (y)) if (SCM_NINUMP (y))
{ {
#ifdef SCM_BIGDIG # ifdef SCM_BIGDIG
SCM_ASRTGO (SCM_NIMP (y), bady); SCM_ASRTGO (SCM_NIMP (y), bady);
if (SCM_BIGP (y)) if (SCM_BIGP (y))
{ {
intbig: intbig:
{ {
#ifndef SCM_DIGSTOOBIG # ifndef SCM_DIGSTOOBIG
long z = scm_pseudolong (SCM_INUM (x)); long z = scm_pseudolong (SCM_INUM (x));
return scm_addbig ((SCM_BIGDIG *) & z, return scm_addbig ((SCM_BIGDIG *) & z,
SCM_DIGSPERLONG, SCM_DIGSPERLONG,
(x < 0) ? 0x0100 : 0, (x < 0) ? 0x0100 : 0,
y, 0); y, 0);
#else # else /* SCM_DIGSTOOBIG */
SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
scm_longdigs (SCM_INUM (x), zdigs); scm_longdigs (SCM_INUM (x), zdigs);
return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0,
y, 0); y, 0);
#endif # endif /* SCM_DIGSTOOBIG */
} }
} }
# endif /* SCM_BIGDIG */
SCM_ASRTGO (SCM_INEXP (y), bady); SCM_ASRTGO (SCM_INEXP (y), bady);
#else
SCM_ASRTGO (SCM_INEXP (y), bady);
#endif
intreal: intreal:
return scm_makdbl (SCM_INUM (x) + SCM_REALPART (y), return scm_makdbl (SCM_INUM (x) + SCM_REALPART (y),
SCM_CPLXP (y) ? SCM_IMAG (y) : 0.0); SCM_CPLXP (y) ? SCM_IMAG (y) : 0.0);
} }
#else #else /* SCM_FLOATS */
#ifdef SCM_BIGDIG # ifdef SCM_BIGDIG
if (SCM_NINUMP (x)) if (SCM_NINUMP (x))
{ {
SCM t; SCM t;
SCM_ASRTGO (SCM_BIGP (x), badx2); SCM_ASRTGO (SCM_BIGP (x), badx2);
if (SCM_INUMP (y)) if (SCM_INUMP (y))
{ {
t = x; SCM_SWAP(x,y);
x = y;
y = t;
goto intbig; goto intbig;
} }
SCM_ASRTGO (SCM_BIGP (y), bady); SCM_ASRTGO (SCM_BIGP (y), bady);
if (SCM_NUMDIGS (x) > SCM_NUMDIGS (y)) if (SCM_NUMDIGS (x) > SCM_NUMDIGS (y))
{ SCM_SWAP(x,y);
t = x;
x = y;
y = t;
}
return scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), SCM_BIGSIGN (x), return scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), SCM_BIGSIGN (x),
y, 0); y, 0);
} }
@ -3278,34 +3269,38 @@ scm_sum (SCM x, SCM y)
} }
intbig: intbig:
{ {
#ifndef SCM_DIGSTOOBIG # ifndef SCM_DIGSTOOBIG
long z = scm_pseudolong (SCM_INUM (x)); long z = scm_pseudolong (SCM_INUM (x));
return scm_addbig (&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); return scm_addbig (&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
#else # else
SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
scm_longdigs (SCM_INUM (x), zdigs); scm_longdigs (SCM_INUM (x), zdigs);
return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); 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_ASRTGO (SCM_INUMP (x), badx2);
SCM_GASSERT2 (SCM_INUMP (y), g_sum, x, y, SCM_ARGn, s_sum); SCM_GASSERT2 (SCM_INUMP (y), g_sum, x, y, SCM_ARGn, s_sum);
#endif # endif/* SCM_BIGDIG */
#endif #endif /* SCM_FLOATS */
x = SCM_INUM (x) + SCM_INUM (y);
if (SCM_FIXABLE (x)) { /* scope */
return SCM_MAKINUM (x); long int i = SCM_INUM (x) + SCM_INUM (y);
if (SCM_FIXABLE (i))
return SCM_MAKINUM (i);
#ifdef SCM_BIGDIG #ifdef SCM_BIGDIG
return scm_long2big (x); return scm_long2big (i);
#else #else /* SCM_BIGDIG */
#ifdef SCM_FLOATS
return scm_makdbl ((double) x, 0.0); # ifdef SCM_FLOATS
#else return scm_makdbl ((double) i, 0.0);
# else
scm_num_overflow (s_sum); scm_num_overflow (s_sum);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
#endif # endif/* SCM_FLOATS */
#endif #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); SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference);
/*
HWN:FIXME:: This is sick,sick, sick code. Rewrite me.
*/
SCM SCM
scm_difference (SCM x, SCM y) scm_difference (SCM x, SCM y)
{ {
long int cx = 0;
#ifdef SCM_FLOATS #ifdef SCM_FLOATS
if (SCM_NINUMP (x)) if (SCM_NINUMP (x))
{ {
if (!(SCM_NIMP (x))) if (!SCM_NIMP (x))
{ {
if (SCM_UNBNDP (y)) if (SCM_UNBNDP (y))
{ {
@ -3390,7 +3389,7 @@ scm_difference (SCM x, SCM y)
} }
if (SCM_UNBNDP (y)) if (SCM_UNBNDP (y))
{ {
x = -SCM_INUM (x); cx = -SCM_INUM (x);
goto checkx; goto checkx;
} }
if (SCM_NINUMP (y)) 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); SCM_GASSERT2 (SCM_INUMP (x), g_difference, x, y, SCM_ARG1, s_difference);
if (SCM_UNBNDP (y)) if (SCM_UNBNDP (y))
{ {
x = -SCM_INUM (x); cx = -SCM_INUM (x);
goto checkx; goto checkx;
} }
SCM_GASSERT2 (SCM_INUMP (y), g_difference, x, y, SCM_ARGn, s_difference); SCM_GASSERT2 (SCM_INUMP (y), g_difference, x, y, SCM_ARGn, s_difference);
#endif #endif
#endif #endif
x = SCM_INUM (x) - SCM_INUM (y); cx = SCM_INUM (x) - SCM_INUM (y);
checkx: checkx:
if (SCM_FIXABLE (x)) if (SCM_FIXABLE (cx))
return SCM_MAKINUM (x); return SCM_MAKINUM (cx);
#ifdef SCM_BIGDIG #ifdef SCM_BIGDIG
return scm_long2big (x); return scm_long2big (cx);
#else #else
#ifdef SCM_FLOATS #ifdef SCM_FLOATS
return scm_makdbl ((double) x, 0.0); return scm_makdbl ((double) cx, 0.0);
#else #else
scm_num_overflow (s_difference); scm_num_overflow (s_difference);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
@ -3742,7 +3741,11 @@ scm_num2dbl (SCM a, const char *why)
return scm_big2dbl (a); return scm_big2dbl (a);
#endif #endif
SCM_ASSERT (0, a, "wrong type argument", why); 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 #ifdef SCM_BIGDIG
if (SCM_BIGP (x)) if (SCM_BIGP (x))
{ {
SCM z;
if (SCM_INUMP (y)) if (SCM_INUMP (y))
{ {
z = SCM_INUM (y); long int z = SCM_INUM (y);
#ifndef SCM_RECKLESS #ifndef SCM_RECKLESS
if (!z) if (!z)
scm_num_overflow (s_divide); scm_num_overflow (s_divide);
@ -3808,10 +3810,11 @@ scm_divide (SCM x, SCM y)
: scm_normbig (w)); : scm_normbig (w));
} }
#ifndef SCM_DIGSTOOBIG #ifndef SCM_DIGSTOOBIG
/*ugh! Does anyone know what this is supposed to do?*/
z = scm_pseudolong (z); z = scm_pseudolong (z);
z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), z = SCM_INUM(scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
(SCM_BIGDIG *) & z, SCM_DIGSPERLONG, (SCM_BIGDIG *) & z, SCM_DIGSPERLONG,
SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3); SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3));
#else #else
{ {
SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
@ -3821,12 +3824,12 @@ scm_divide (SCM x, SCM y)
SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3); SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3);
} }
#endif #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); SCM_ASRTGO (SCM_NIMP (y), bady);
if (SCM_BIGP (y)) 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_BDIGITS (y), SCM_NUMDIGS (y),
SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 3); SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 3);
return z ? z : scm_makdbl (scm_big2dbl (x) / scm_big2dbl (y), return z ? z : scm_makdbl (scm_big2dbl (x) / scm_big2dbl (y),

19
libguile/numbers.h
View file

@ -71,25 +71,26 @@
/* shifts of more than one are done by a library call, single shifts are /* shifts of more than one are done by a library call, single shifts are
* performed in registers * performed in registers
*/ */
# define SCM_MAKINUM(x) ((((x)<<1)<<1)+2L) # define SCM_MAKINUM(x) ((SCM) (((SCM_ASWORD(x)<<1)<<1)+2L))
#else #else
# define SCM_MAKINUM(x) (((x)<<2)+2L) # define SCM_MAKINUM(x) ((SCM)((SCM_ASWORD(x)<<2)+2L))
#endif /* def __TURBOC__ */ #endif /* def __TURBOC__ */
/* SCM_SRS is signed right shift */ /* 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! /* Turbo C++ v1.0 has a bug with right shifts of signed longs!
* It is believed to be fixed in Turbo C++ v1.01 * It is believed to be fixed in Turbo C++ v1.01
*/ */
#if (-1==(((-1)<<2)+2)>>2) && (__TURBOC__ != 0x295) #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__ # ifdef __TURBOC__
# define SCM_INUM(x) (((x)>>1)>>1) # define SCM_INUM(x) ((SCM_ASWORD(x) >>1) >>1)
# else # else
# define SCM_INUM(x) SCM_SRS(x, 2) # define SCM_INUM(x) SCM_SRS(x, 2)
# endif /* def __TURBOC__ */ # endif /* def __TURBOC__ */
#else #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) # define SCM_INUM(x) SCM_SRS(x, 2)
#endif /* (-1==(((-1)<<2)+2)>>2) && (__TURBOC__ != 0x295) */ #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_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_REAL(x) (*(((scm_dbl *) (SCM2PTR(x)))->real))
#define SCM_IMAG(x) (*((double *)(SCM_CHARS(x)+sizeof(double)))) #define SCM_IMAG(x) (*((double *)(SCM_CHARS(x)+sizeof(double))))
/* ((&SCM_REAL(x))[1]) */ /* ((&SCM_REAL(x))[1]) */
#ifdef SCM_SINGLES #ifdef SCM_SINGLES
#define SCM_REALP(x) (SCM_NIMP(x) && ((~SCM_REAL_PART & 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_CAR(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_FLO(x) (((scm_flo *)(SCM2PTR(x)))->num)
#define SCM_REALPART(x) (SCM_SINGP(x)?0.0+SCM_FLO(x):SCM_REAL(x)) #define SCM_REALPART(x) (SCM_SINGP(x)?0.0+SCM_FLO(x):SCM_REAL(x))
#else /* SCM_SINGLES */ #else /* SCM_SINGLES */
@ -216,7 +217,7 @@
#define SCM_BIGP(x) (SCM_NIMP(x) && SCM_TYP16S(x)==scm_tc16_bigpos) #define SCM_BIGP(x) (SCM_NIMP(x) && SCM_TYP16S(x)==scm_tc16_bigpos)
#define SCM_BIGSIGN(x) (0x0100 & (int)SCM_CAR(x)) #define SCM_BIGSIGN(x) (0x0100 & (int)SCM_CAR(x))
#define SCM_BDIGITS(x) ((SCM_BIGDIG *)(SCM_CDR(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)) #define SCM_SETNUMDIGS(x, v, t) SCM_SETCAR(x, (((v)+0L)<<16)+(t))

10
libguile/objects.c
View file

@ -157,10 +157,10 @@ scm_class_of (SCM x)
case scm_tc7_smob: case scm_tc7_smob:
{ {
SCM type = SCM_TYP16 (x); long type = SCM_TYP16 (x);
if (type == scm_tc16_flo) if (type == scm_tc16_flo)
{ {
if (SCM_CAR (x) & SCM_IMAG_PART) if (SCM_CARW (x) & SCM_IMAG_PART)
return scm_class_complex; return scm_class_complex;
else else
return scm_class_real; return scm_class_real;
@ -171,8 +171,8 @@ scm_class_of (SCM x)
/* fall through to ports */ /* fall through to ports */
} }
case scm_tc7_port: case scm_tc7_port:
return scm_port_class[(SCM_WRTNG & SCM_CAR (x) return scm_port_class[(SCM_WRTNG & SCM_CARW (x)
? (SCM_RDNG & SCM_CAR (x) ? (SCM_RDNG & SCM_CARW (x)
? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x) ? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x)
: SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x)) : SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x))
: SCM_IN_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)) if (SCM_NIMP (ls))
do 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]); [scm_si_hashsets + hashset]);
ls = SCM_CDR (ls); ls = SCM_CDR (ls);
} }

8
libguile/objects.h
View file

@ -67,9 +67,9 @@
* certain class or its subclasses when traversal of the inheritance * certain class or its subclasses when traversal of the inheritance
* graph would be too costly. * 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)\ #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_SET_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) |= (f))
#define SCM_CLEAR_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 #define SCM_CLASSF_MASK SCM_STRUCTF_MASK
@ -80,7 +80,7 @@
#define SCM_CLASSF_OPERATOR (1L << 29) #define SCM_CLASSF_OPERATOR (1L << 29)
#define SCM_I_OPERATORP(obj)\ #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)\ #define SCM_OPERATOR_CLASS(obj)\
((struct scm_metaclass_operator *) SCM_STRUCT_DATA (obj)) ((struct scm_metaclass_operator *) SCM_STRUCT_DATA (obj))
#define SCM_OBJ_OPERATOR_CLASS(obj)\ #define SCM_OBJ_OPERATOR_CLASS(obj)\
@ -89,7 +89,7 @@
#define SCM_OPERATOR_SETTER(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->setter) #define SCM_OPERATOR_SETTER(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->setter)
#define SCM_I_ENTITYP(obj)\ #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) \ #define SCM_ENTITY_PROCEDURE(obj) \
(SCM_STRUCT_DATA (obj)[scm_struct_i_procedure]) (SCM_STRUCT_DATA (obj)[scm_struct_i_procedure])
#define SCM_ENTITY_SETTER(obj) (SCM_STRUCT_DATA (obj)[scm_struct_i_setter]) #define SCM_ENTITY_SETTER(obj) (SCM_STRUCT_DATA (obj)[scm_struct_i_setter])

3
libguile/options.c
View file

@ -186,7 +186,7 @@ scm_options (SCM arg, scm_option options[], int n, const char *s)
goto cont; goto cont;
case SCM_OPTION_SCM: case SCM_OPTION_SCM:
new_mode = SCM_CDR (new_mode); new_mode = SCM_CDR (new_mode);
flags[i] = SCM_CAR (new_mode); flags[i] = SCM_CARW (new_mode);
goto cont; goto cont;
} }
#ifndef SCM_RECKLESS #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) 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) if (options[i].type == SCM_OPTION_SCM)
SCM_SETCDR (protected_objects, SCM_SETCDR (protected_objects,
scm_cons (flags[i], scm_cons (flags[i],

5
libguile/options.h
View file

@ -55,7 +55,12 @@ typedef struct scm_option
{ {
int type; int type;
char *name; char *name;
/*
schizophrenic use: both SCM and int
*/
unsigned long val; unsigned long val;
// SCM val
char *doc; char *doc;
} scm_option; } scm_option;

14
libguile/pairs.h
View file

@ -104,17 +104,17 @@ typedef SCM huge *SCMPTR;
#define SCM_CAR(x) (((scm_cell *)(SCM2PTR(x)))->car) #define SCM_CAR(x) (((scm_cell *)(SCM2PTR(x)))->car)
#define SCM_CDR(x) (((scm_cell *)(SCM2PTR(x)))->cdr) #define SCM_CDR(x) (((scm_cell *)(SCM2PTR(x)))->cdr)
#define SCM_GCCDR(x) (~1L & SCM_CDR(x)) #define SCM_GCCDR(x) SCM_ASSCM(~1L & SCM_ASWORD (SCM_CDR(x)))
#define SCM_SETCAR(x, v) (SCM_CAR(x) = (SCM)(v)) #define SCM_SETCAR(x, v) (SCM_CAR(x) = SCM_ASSCM(v))
#define SCM_SETCDR(x, v) (SCM_CDR(x) = (SCM)(v)) #define SCM_SETCDR(x, v) (SCM_CDR(x) = SCM_ASSCM(v))
#define SCM_CARLOC(x) (&SCM_CAR (x)) #define SCM_CARLOC(x) (&SCM_CAR (x))
#define SCM_CDRLOC(x) (&SCM_CDR (x)) #define SCM_CDRLOC(x) (&SCM_CDR (x))
#define SCM_SETAND_CAR(x, y) (SCM_CAR (x) &= (y)) #define SCM_SETAND_CAR(x, y) (SCM_CARW (x) &= (y))
#define SCM_SETAND_CDR(x, y) (SCM_CDR (x) &= (y)) #define SCM_SETAND_CDR(x, y) (SCM_ASWORD (SCM_CDR (x)) &= (y))
#define SCM_SETOR_CAR(x, y) (SCM_CAR (x) |= (y)) #define SCM_SETOR_CAR(x, y) (SCM_CARW (x) |= (y))
#define SCM_SETOR_CDR(x, y) (SCM_CDR (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_CAAR(OBJ) SCM_CAR (SCM_CAR (OBJ))
#define SCM_CDAR(OBJ) SCM_CDR (SCM_CAR (OBJ)) #define SCM_CDAR(OBJ) SCM_CDR (SCM_CAR (OBJ))

18
libguile/ports.c
View file

@ -89,7 +89,7 @@ SCM
scm_markstream (SCM ptr) scm_markstream (SCM ptr)
{ {
int openp; int openp;
openp = SCM_CAR (ptr) & SCM_OPN; openp = SCM_CARW (ptr) & SCM_OPN;
if (openp) if (openp)
return SCM_STREAM (ptr); return SCM_STREAM (ptr);
else else
@ -568,15 +568,15 @@ SCM_DEFINE (scm_port_mode, "port-mode", 1, 0, 0,
port = SCM_COERCE_OUTPORT (port); port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPPORT (1,port); SCM_VALIDATE_OPPORT (1,port);
if (SCM_CAR (port) & SCM_RDNG) { if (SCM_CARW (port) & SCM_RDNG) {
if (SCM_CAR (port) & SCM_WRTNG) if (SCM_CARW (port) & SCM_WRTNG)
strcpy (modes, "r+"); strcpy (modes, "r+");
else else
strcpy (modes, "r"); strcpy (modes, "r");
} }
else if (SCM_CAR (port) & SCM_WRTNG) else if (SCM_CARW (port) & SCM_WRTNG)
strcpy (modes, "w"); strcpy (modes, "w");
if (SCM_CAR (port) & SCM_BUF0) if (SCM_CARW (port) & SCM_BUF0)
strcat (modes, "0"); strcat (modes, "0");
return scm_makfromstr (modes, strlen (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) scm_puts (SCM_CLOSEDP (exp)
? "closed: " ? "closed: "
: (SCM_RDNG & SCM_CAR (exp) : (SCM_RDNG & SCM_CARW (exp)
? (SCM_WRTNG & SCM_CAR (exp) ? (SCM_WRTNG & SCM_CARW (exp)
? "input-output: " ? "input-output: "
: "input: ") : "input: ")
: (SCM_WRTNG & SCM_CAR (exp) : (SCM_WRTNG & SCM_CARW (exp)
? "output: " ? "output: "
: "bogus: ")), : "bogus: ")),
port); port);
@ -1272,7 +1272,7 @@ scm_port_print (SCM exp, SCM port, scm_print_state *pstate)
scm_print_port_mode (exp, port); scm_print_port_mode (exp, port);
scm_puts (type, port); scm_puts (type, port);
scm_putc (' ', port); scm_putc (' ', port);
scm_intprint (SCM_CDR (exp), 16, port); scm_intprint ((int) SCM_CDR (exp), 16, port);
scm_putc ('>', port); scm_putc ('>', port);
return 1; return 1;
} }

14
libguile/ports.h
View file

@ -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_BUFLINE (64L<<16) /* Is it line-buffered? */
#define SCM_PORTP(x) (SCM_NIMP(x) && (SCM_TYP7(x)==scm_tc7_port)) #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_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_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG))) #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_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG))) #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_CAR(x))==(scm_tc7_port | SCM_RDNG))) #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_CAR(x))==(scm_tc7_port | SCM_WRTNG))) #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_CAR(x))) #define SCM_OPENP(x) (SCM_NIMP(x) && (SCM_OPN & SCM_CARW (x)))
#define SCM_CLOSEDP(x) (!SCM_OPENP(x)) #define SCM_CLOSEDP(x) (!SCM_OPENP(x))
#define SCM_PTAB_ENTRY(x) ((scm_port *) SCM_CDR(x)) #define SCM_PTAB_ENTRY(x) ((scm_port *) SCM_CDR(x))
#define SCM_SETPTAB_ENTRY(x,ent) SCM_SETCDR ((x), (SCM)(ent)) #define SCM_SETPTAB_ENTRY(x,ent) SCM_SETCDR ((x), (SCM)(ent))
@ -199,7 +199,7 @@ typedef struct scm_ptob_descriptor
} 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))) #define SCM_PTOBNUM(x) (SCM_TC2PTOBNUM (SCM_CAR (x)))
/* SCM_PTOBNAME can be 0 if name is missing */ /* SCM_PTOBNAME can be 0 if name is missing */
#define SCM_PTOBNAME(ptobnum) scm_ptobs[ptobnum].name #define SCM_PTOBNAME(ptobnum) scm_ptobs[ptobnum].name

10
libguile/print.c
View file

@ -404,11 +404,11 @@ taloop:
env = SCM_ENV (SCM_CDR (exp)); env = SCM_ENV (SCM_CDR (exp));
scm_puts ("#<", port); scm_puts ("#<", port);
} }
if (SCM_CAR (exp) & (3L << 16)) if (SCM_CARW(exp) & (3L << 16))
scm_puts ("macro", port); scm_puts ("macro", port);
else else
scm_puts ("syntax", port); scm_puts ("syntax", port);
if (SCM_CAR (exp) & (2L << 16)) if (SCM_CARW (exp) & (2L << 16))
scm_putc ('!', port); scm_putc ('!', port);
} }
else else
@ -768,13 +768,13 @@ scm_ipruk (char *hdr, SCM ptr, SCM port)
if (SCM_CELLP (ptr)) if (SCM_CELLP (ptr))
{ {
scm_puts (" (0x", port); scm_puts (" (0x", port);
scm_intprint (SCM_CAR (ptr), 16, port); scm_intprint ((int) SCM_CAR (ptr), 16, port);
scm_puts (" . 0x", 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 (") @", port);
} }
scm_puts (" 0x", port); scm_puts (" 0x", port);
scm_intprint (ptr, 16, port); scm_intprint ((int) ptr, 16, port);
scm_putc ('>', port); scm_putc ('>', port);
} }

3
libguile/print.h
View file

@ -100,7 +100,8 @@ typedef struct scm_print_state {
extern SCM scm_print_state_vtable; 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); extern SCM scm_print_options (SCM setting);
SCM scm_make_print_state (void); SCM scm_make_print_state (void);

2
libguile/procs.h
View file

@ -84,7 +84,7 @@ typedef struct
SCM documentation; SCM documentation;
} scm_subr_entry; } 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) \ #define SCM_SET_SUBRNUM(subr, num) \
SCM_SETCAR (subr, (num >> 8) + SCM_TYP7 (subr)) SCM_SETCAR (subr, (num >> 8) + SCM_TYP7 (subr))
#define SCM_SUBR_ENTRY(x) (scm_subr_table[SCM_SUBRNUM (x)]) #define SCM_SUBR_ENTRY(x) (scm_subr_table[SCM_SUBRNUM (x)])

364
libguile/ramap.c
View file

@ -42,6 +42,10 @@
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ 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" #include "ramap.h"
#define SCM_RAMAPC(ramap,proc,ra0,lra) do { scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME); } while (0)
typedef struct typedef struct
{ {
char *name; 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 */ /* Fast, recycling scm_vector ref */
#define RVREF(ra, i, e) (e = scm_cvref(ra, i, e)) #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. */ /* 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 static scm_sizet
cind (SCM ra, SCM inds) cind (SCM ra, SCM inds)
{ {
scm_sizet i; scm_sizet i;
int k; int k;
long *ve = SCM_VELTS (inds); long *ve = (long*) SCM_VELTS (inds);
if (!SCM_ARRAYP (ra)) if (!SCM_ARRAYP (ra))
return *ve; return *ve;
i = SCM_ARRAY_BASE (ra); i = SCM_ARRAY_BASE (ra);
@ -410,7 +456,7 @@ SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
"is unspecified.") "is unspecified.")
#define FUNC_NAME s_scm_array_fill_x #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; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -575,6 +621,7 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore)
#undef FUNC_NAME #undef FUNC_NAME
static int static int
racp (SCM src, SCM dst) racp (SCM src, SCM dst)
{ {
@ -586,6 +633,15 @@ racp (SCM src, SCM dst)
i_d = SCM_ARRAY_BASE (dst); i_d = SCM_ARRAY_BASE (dst);
src = SCM_ARRAY_V (src); src = SCM_ARRAY_V (src);
dst = SCM_ARRAY_V (dst); 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 switch SCM_TYP7
(dst) (dst)
{ {
@ -620,19 +676,18 @@ racp (SCM src, SCM dst)
sv++; sv++;
n -= SCM_LONG_BIT - (i_s % SCM_LONG_BIT); n -= SCM_LONG_BIT - (i_s % SCM_LONG_BIT);
} }
IVDEP (src != dst,
for (; n >= SCM_LONG_BIT; n -= SCM_LONG_BIT, sv++, dv++) for (; n >= SCM_LONG_BIT; n -= SCM_LONG_BIT, sv++, dv++)
* dv = *sv;) * dv = *sv;
if (n) /* trailing partial word */ if (n) /* trailing partial word */
*dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n)); *dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n));
} }
else else
{ {
for (; n-- > 0; i_s += inc_s, i_d += inc_d) 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))) if (SCM_BITVEC_REF(src, i_s))
SCM_VELTS (dst)[i_d / SCM_LONG_BIT] |= (1L << (i_d % SCM_LONG_BIT)); SCM_BITVEC_SET(dst, i_d);
else else
SCM_VELTS (dst)[i_d / SCM_LONG_BIT] &= ~(1L << (i_d % SCM_LONG_BIT)); SCM_BITVEC_CLR(dst, i_d);
} }
break; break;
case scm_tc7_uvect: case scm_tc7_uvect:
@ -641,9 +696,8 @@ racp (SCM src, SCM dst)
else else
{ {
long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (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) for (; n-- > 0; i_s += inc_s, i_d += inc_d)
d[i_d] = s[i_s];) d[i_d] = s[i_s];
break; break;
} }
case scm_tc7_ivect: case scm_tc7_ivect:
@ -652,9 +706,8 @@ racp (SCM src, SCM dst)
else else
{ {
long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (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) for (; n-- > 0; i_s += inc_s, i_d += inc_d)
d[i_d] = s[i_s];) d[i_d] = s[i_s];
break; break;
} }
#ifdef SCM_FLOATS #ifdef SCM_FLOATS
@ -670,19 +723,16 @@ racp (SCM src, SCM dst)
goto gencase; goto gencase;
case scm_tc7_ivect: case scm_tc7_ivect:
case scm_tc7_uvect: case scm_tc7_uvect:
IVDEP (src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) for (; n-- > 0; i_s += inc_s, i_d += inc_d)
d[i_d] = ((long *) s)[i_s];) d[i_d] = ((long *) s)[i_s];
break; break;
case scm_tc7_fvect: case scm_tc7_fvect:
IVDEP (src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) for (; n-- > 0; i_s += inc_s, i_d += inc_d)
d[i_d] = s[i_s];) d[i_d] = s[i_s];
break; break;
case scm_tc7_dvect: case scm_tc7_dvect:
IVDEP (src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) for (; n-- > 0; i_s += inc_s, i_d += inc_d)
d[i_d] = ((double *) s)[i_s];) d[i_d] = ((double *) s)[i_s];
break; break;
} }
break; break;
@ -699,19 +749,16 @@ racp (SCM src, SCM dst)
goto gencase; goto gencase;
case scm_tc7_ivect: case scm_tc7_ivect:
case scm_tc7_uvect: case scm_tc7_uvect:
IVDEP (src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) for (; n-- > 0; i_s += inc_s, i_d += inc_d)
d[i_d] = ((long *) s)[i_s];) d[i_d] = ((long *) s)[i_s];
break; break;
case scm_tc7_fvect: case scm_tc7_fvect:
IVDEP (src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) for (; n-- > 0; i_s += inc_s, i_d += inc_d)
d[i_d] = ((float *) s)[i_s];) d[i_d] = ((float *) s)[i_s];
break; break;
case scm_tc7_dvect: case scm_tc7_dvect:
IVDEP (src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) for (; n-- > 0; i_s += inc_s, i_d += inc_d)
d[i_d] = s[i_s];) d[i_d] = s[i_s];
break; break;
} }
break; break;
@ -727,40 +774,32 @@ racp (SCM src, SCM dst)
goto gencase; goto gencase;
case scm_tc7_ivect: case scm_tc7_ivect:
case scm_tc7_uvect: case scm_tc7_uvect:
IVDEP (src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) for (; n-- > 0; i_s += inc_s, i_d += inc_d)
{ {
d[i_d][0] = ((long *) s)[i_s]; d[i_d][0] = ((long *) s)[i_s];
d[i_d][1] = 0.0; d[i_d][1] = 0.0;
} }
)
break; break;
case scm_tc7_fvect: case scm_tc7_fvect:
IVDEP (src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) for (; n-- > 0; i_s += inc_s, i_d += inc_d)
{ {
d[i_d][0] = ((float *) s)[i_s]; d[i_d][0] = ((float *) s)[i_s];
d[i_d][1] = 0.0; d[i_d][1] = 0.0;
} }
)
break; break;
case scm_tc7_dvect: case scm_tc7_dvect:
IVDEP (src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) for (; n-- > 0; i_s += inc_s, i_d += inc_d)
{ {
d[i_d][0] = ((double *) s)[i_s]; d[i_d][0] = ((double *) s)[i_s];
d[i_d][1] = 0.0; d[i_d][1] = 0.0;
} }
)
break; break;
case scm_tc7_cvect: case scm_tc7_cvect:
IVDEP (src != dst,
for (; n-- > 0; i_s += inc_s, i_d += inc_d) for (; n-- > 0; i_s += inc_s, i_d += inc_d)
{ {
d[i_d][0] = s[i_s][0]; d[i_d][0] = s[i_s][0];
d[i_d][1] = s[i_s][1]; d[i_d][1] = s[i_s][1];
} }
)
} }
break; break;
} }
@ -783,7 +822,7 @@ SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
"dimension. The order is unspecified.") "dimension. The order is unspecified.")
#define FUNC_NAME s_scm_array_copy_x #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; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -809,39 +848,39 @@ scm_ra_eqp (SCM ra0, SCM ras)
{ {
SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED; SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
if (SCM_FALSEP(scm_eq_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))) if (SCM_FALSEP(scm_eq_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
BVE_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
break; break;
} }
case scm_tc7_uvect: case scm_tc7_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
if (SCM_VELTS (ra1)[i1] != SCM_VELTS (ra2)[i2]) if (SCM_VELTS (ra1)[i1] != SCM_VELTS (ra2)[i2])
BVE_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
break; break;
#ifdef SCM_FLOATS #ifdef SCM_FLOATS
#ifdef SCM_SINGLES #ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
if (((float *) SCM_VELTS (ra1))[i1] != ((float *) SCM_VELTS (ra2))[i2]) if (((float *) SCM_VELTS (ra1))[i1] != ((float *) SCM_VELTS (ra2))[i2])
BVE_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
break; break;
#endif /*SCM_SINGLES*/ #endif /*SCM_SINGLES*/
case scm_tc7_dvect: case scm_tc7_dvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
if (((double *) SCM_VELTS (ra1))[i1] != ((double *) SCM_VELTS (ra2))[i2]) if (((double *) SCM_VELTS (ra1))[i1] != ((double *) SCM_VELTS (ra2))[i2])
BVE_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
break; break;
case scm_tc7_cvect: case scm_tc7_cvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
if (((double *) SCM_VELTS (ra1))[2 * i1] != ((double *) SCM_VELTS (ra2))[2 * i2] || 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]) ((double *) SCM_VELTS (ra1))[2 * i1 + 1] != ((double *) SCM_VELTS (ra2))[2 * i2 + 1])
BVE_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
break; break;
#endif /*SCM_FLOATS*/ #endif /*SCM_FLOATS*/
} }
@ -867,42 +906,42 @@ ra_compare (SCM ra0,SCM ra1,SCM ra2,int opt)
{ {
SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED; SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
if (opt ? if (opt ?
SCM_NFALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) : 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_FALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
BVE_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
break; break;
} }
case scm_tc7_uvect: case scm_tc7_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
{ {
if (BVE_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
if (opt ? if (opt ?
SCM_VELTS (ra1)[i1] < SCM_VELTS (ra2)[i2] : SCM_VELTS (ra1)[i1] < SCM_VELTS (ra2)[i2] :
SCM_VELTS (ra1)[i1] >= SCM_VELTS (ra2)[i2]) SCM_VELTS (ra1)[i1] >= SCM_VELTS (ra2)[i2])
BVE_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
} }
break; break;
#ifdef SCM_FLOATS #ifdef SCM_FLOATS
#ifdef SCM_SINGLES #ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF(ra0, i0)) if (SCM_BITVEC_REF(ra0, i0))
if (opt ? if (opt ?
((float *) SCM_VELTS (ra1))[i1] < ((float *) SCM_VELTS (ra2))[i2] : ((float *) SCM_VELTS (ra1))[i1] < ((float *) SCM_VELTS (ra2))[i2] :
((float *) SCM_VELTS (ra1))[i1] >= ((float *) SCM_VELTS (ra2))[i2]) ((float *) SCM_VELTS (ra1))[i1] >= ((float *) SCM_VELTS (ra2))[i2])
BVE_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
break; break;
#endif /*SCM_SINGLES*/ #endif /*SCM_SINGLES*/
case scm_tc7_dvect: case scm_tc7_dvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
if (opt ? if (opt ?
((double *) SCM_VELTS (ra1))[i1] < ((double *) SCM_VELTS (ra2))[i2] : ((double *) SCM_VELTS (ra1))[i1] < ((double *) SCM_VELTS (ra2))[i2] :
((double *) SCM_VELTS (ra1))[i1] >= ((double *) SCM_VELTS (ra2))[i2]) ((double *) SCM_VELTS (ra1))[i1] >= ((double *) SCM_VELTS (ra2))[i2])
BVE_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
break; break;
#endif /*SCM_FLOATS*/ #endif /*SCM_FLOATS*/
} }
@ -964,48 +1003,16 @@ scm_ra_sum (SCM ra0, SCM ras)
} }
case scm_tc7_uvect: case scm_tc7_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
{ BINARY_ELTS_CODE( +=, long);
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;
}
#ifdef SCM_FLOATS #ifdef SCM_FLOATS
#ifdef SCM_SINGLES #ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
{ BINARY_ELTS_CODE( +=, float);
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;
}
#endif /* SCM_SINGLES */ #endif /* SCM_SINGLES */
case scm_tc7_dvect: case scm_tc7_dvect:
{ BINARY_ELTS_CODE( +=, double);
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: case scm_tc7_cvect:
{ BINARY_PAIR_ELTS_CODE( +=, double);
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;
}
#endif /* SCM_FLOATS */ #endif /* SCM_FLOATS */
} }
} }
@ -1029,36 +1036,20 @@ scm_ra_difference (SCM ra0, SCM ras)
{ {
SCM e0 = SCM_UNDEFINED; SCM e0 = SCM_UNDEFINED;
for (; n-- > 0; i0 += inc0) for (; n-- > 0; i0 += inc0)
scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0)); scm_array_set_x (ra0,
scm_difference (RVREF (ra0, i0, e0), SCM_UNDEFINED),
SCM_MAKINUM (i0));
break; break;
} }
#ifdef SCM_FLOATS #ifdef SCM_FLOATS
#ifdef SCM_SINGLES #ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
{ UNARY_ELTS_CODE( = -, float);
float *v0 = (float *) SCM_VELTS (ra0);
for (; n-- > 0; i0 += inc0)
v0[i0] = -v0[i0];
break;
}
#endif /* SCM_SINGLES */ #endif /* SCM_SINGLES */
case scm_tc7_dvect: case scm_tc7_dvect:
{ UNARY_ELTS_CODE( = -, double);
double *v0 = (double *) SCM_VELTS (ra0);
for (; n-- > 0; i0 += inc0)
v0[i0] = -v0[i0];
break;
}
case scm_tc7_cvect: case scm_tc7_cvect:
{ UNARY_PAIR_ELTS_CODE( = -, double);
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;
}
#endif /* SCM_FLOATS */ #endif /* SCM_FLOATS */
} }
} }
@ -1080,37 +1071,12 @@ scm_ra_difference (SCM ra0, SCM ras)
#ifdef SCM_FLOATS #ifdef SCM_FLOATS
#ifdef SCM_SINGLES #ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
{ BINARY_ELTS_CODE( -=, float);
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;
}
#endif /* SCM_SINGLES */ #endif /* SCM_SINGLES */
case scm_tc7_dvect: case scm_tc7_dvect:
{ BINARY_ELTS_CODE( -=, double);
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: case scm_tc7_cvect:
{ BINARY_PAIR_ELTS_CODE( -=, double);
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;
}
#endif /* SCM_FLOATS */ #endif /* SCM_FLOATS */
} }
} }
@ -1144,35 +1110,14 @@ scm_ra_product (SCM ra0, SCM ras)
} }
case scm_tc7_uvect: case scm_tc7_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
{ BINARY_ELTS_CODE( *=, long);
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;
}
#ifdef SCM_FLOATS #ifdef SCM_FLOATS
#ifdef SCM_SINGLES #ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
{ BINARY_ELTS_CODE( *=, float);
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;
}
#endif /* SCM_SINGLES */ #endif /* SCM_SINGLES */
case scm_tc7_dvect: case scm_tc7_dvect:
{ BINARY_ELTS_CODE( *=, double);
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: case scm_tc7_cvect:
{ {
double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0); double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
@ -1216,20 +1161,10 @@ scm_ra_divide (SCM ra0, SCM ras)
#ifdef SCM_FLOATS #ifdef SCM_FLOATS
#ifdef SCM_SINGLES #ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
{ UNARY_ELTS_CODE( = 1.0 / , float);
float *v0 = (float *) SCM_VELTS (ra0);
for (; n-- > 0; i0 += inc0)
v0[i0] = 1.0 / v0[i0];
break;
}
#endif /* SCM_SINGLES */ #endif /* SCM_SINGLES */
case scm_tc7_dvect: case scm_tc7_dvect:
{ UNARY_ELTS_CODE( = 1.0 / , double);
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_cvect:
{ {
register double d; register double d;
@ -1263,24 +1198,10 @@ scm_ra_divide (SCM ra0, SCM ras)
#ifdef SCM_FLOATS #ifdef SCM_FLOATS
#ifdef SCM_SINGLES #ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
{ BINARY_ELTS_CODE( /=, float);
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;
}
#endif /* SCM_SINGLES */ #endif /* SCM_SINGLES */
case scm_tc7_dvect: case scm_tc7_dvect:
{ BINARY_ELTS_CODE( /=, double);
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: case scm_tc7_cvect:
{ {
register double d, r; register double d, r;
@ -1384,7 +1305,7 @@ ramap_cxr (SCM ra0,SCM proc,SCM ras)
case scm_tc7_uvect: case scm_tc7_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
for (; n-- > 0; i0 += inc0, i1 += inc1) for (; n-- > 0; i0 += inc0, i1 += inc1)
dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]); dst[i0] = SCM_DSUBRF (proc) (SCM_ASWORD (SCM_VELTS (ra1)[i1]));
break; break;
} }
break; break;
@ -1404,7 +1325,7 @@ ramap_cxr (SCM ra0,SCM proc,SCM ras)
case scm_tc7_uvect: case scm_tc7_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
for (; n-- > 0; i0 += inc0, i1 += inc1) for (; n-- > 0; i0 += inc0, i1 += inc1)
dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]); dst[i0] = SCM_DSUBRF (proc) (SCM_ASWORD (SCM_VELTS (ra1)[i1]));
break; break;
} }
break; break;
@ -1433,18 +1354,18 @@ ramap_rp (SCM ra0,SCM proc,SCM ras)
{ {
default: default:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
if (SCM_FALSEP (SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)))) if (SCM_FALSEP (SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
BVE_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
break; break;
case scm_tc7_uvect: case scm_tc7_uvect:
case scm_tc7_ivect: case scm_tc7_ivect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
{ {
if (SCM_FALSEP (SCM_SUBRF (proc) (SCM_MAKINUM (SCM_VELTS (ra1)[i1]), if (SCM_FALSEP (SCM_SUBRF (proc) (SCM_MAKINUM (SCM_VELTS (ra1)[i1]),
SCM_MAKINUM (SCM_VELTS (ra2)[i2])))) SCM_MAKINUM (SCM_VELTS (ra2)[i2]))))
BVE_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
} }
break; break;
#ifdef SCM_FLOATS #ifdef SCM_FLOATS
@ -1453,12 +1374,12 @@ ramap_rp (SCM ra0,SCM proc,SCM ras)
{ {
SCM a1 = scm_makflo (1.0), a2 = scm_makflo (1.0); SCM a1 = scm_makflo (1.0), a2 = scm_makflo (1.0);
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
{ {
SCM_FLO (a1) = ((float *) SCM_VELTS (ra1))[i1]; SCM_FLO (a1) = ((float *) SCM_VELTS (ra1))[i1];
SCM_FLO (a2) = ((float *) SCM_VELTS (ra2))[i2]; SCM_FLO (a2) = ((float *) SCM_VELTS (ra2))[i2];
if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2))) if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2)))
BVE_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
} }
break; break;
} }
@ -1467,12 +1388,12 @@ 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); 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) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
{ {
SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[i1]; SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[i1];
SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[i2]; SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[i2];
if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2))) if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2)))
BVE_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
} }
break; break;
} }
@ -1480,14 +1401,14 @@ ramap_rp (SCM ra0,SCM proc,SCM ras)
{ {
SCM a1 = scm_makdbl (1.0, 1.0), a2 = scm_makdbl (1.0, 1.0); SCM a1 = scm_makdbl (1.0, 1.0), a2 = scm_makdbl (1.0, 1.0);
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (BVE_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
{ {
SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[2 * i1]; SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[2 * i1];
SCM_IMAG (a1) = ((double *) SCM_VELTS (ra1))[2 * i1 + 1]; SCM_IMAG (a1) = ((double *) SCM_VELTS (ra1))[2 * i1 + 1];
SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[2 * i2]; SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[2 * i2];
SCM_IMAG (a2) = ((double *) SCM_VELTS (ra2))[2 * i2 + 1]; SCM_IMAG (a2) = ((double *) SCM_VELTS (ra2))[2 * i2 + 1];
if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2))) if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2)))
BVE_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
} }
break; break;
} }
@ -1610,19 +1531,19 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
{ {
default: default:
gencase: gencase:
SCM_RAMAPC (ramap, proc, ra0, lra); scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
case scm_tc7_subr_1: case scm_tc7_subr_1:
SCM_RAMAPC (ramap_1, proc, ra0, lra); scm_ramapc (ramap_1, proc, ra0, lra, FUNC_NAME);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
case scm_tc7_subr_2: case scm_tc7_subr_2:
case scm_tc7_subr_2o: case scm_tc7_subr_2o:
SCM_RAMAPC (ramap_2o, proc, ra0, lra); scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
case scm_tc7_cxr: case scm_tc7_cxr:
if (!SCM_SUBRF (proc)) if (!SCM_SUBRF (proc))
goto gencase; goto gencase;
SCM_RAMAPC (ramap_cxr, proc, ra0, lra); scm_ramapc (ramap_cxr, proc, ra0, lra, FUNC_NAME);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
case scm_tc7_rpsubr: case scm_tc7_rpsubr:
{ {
@ -1635,14 +1556,14 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
{ {
while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra))) while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
{ {
SCM_RAMAPC (p->vproc, SCM_UNDEFINED, ra0, lra); scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
lra = SCM_CDR (lra); lra = SCM_CDR (lra);
} }
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra))) while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
{ {
SCM_RAMAPC (ramap_rp, proc, ra0, lra); scm_ramapc (ramap_rp, proc, ra0, lra, FUNC_NAME);
lra = SCM_CDR (lra); lra = SCM_CDR (lra);
} }
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
@ -1681,21 +1602,21 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
if (proc == p->sproc) if (proc == p->sproc)
{ {
if (ra0 != SCM_CAR (lra)) if (ra0 != SCM_CAR (lra))
SCM_RAMAPC (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL)); scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), FUNC_NAME);
lra = SCM_CDR (lra); lra = SCM_CDR (lra);
while (1) 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))) if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra)))
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
lra = SCM_CDR (lra); lra = SCM_CDR (lra);
} }
} }
SCM_RAMAPC (ramap_2o, proc, ra0, lra); scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
lra = SCM_CDR (lra); lra = SCM_CDR (lra);
if (SCM_NIMP (lra)) if (SCM_NIMP (lra))
for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra)) for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra))
SCM_RAMAPC (ramap_a, proc, ra0, lra); scm_ramapc (ramap_a, proc, ra0, lra, FUNC_NAME);
} }
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
@ -1749,7 +1670,7 @@ SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
#define FUNC_NAME s_scm_array_for_each #define FUNC_NAME s_scm_array_for_each
{ {
SCM_VALIDATE_PROC (1,proc); SCM_VALIDATE_PROC (1,proc);
SCM_RAMAPC (rafe, proc, ra0, lra); scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -1811,7 +1732,7 @@ SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
{ {
SCM args = SCM_EOL; SCM args = SCM_EOL;
SCM inds = scm_make_uve (SCM_ARRAY_NDIM (ra), SCM_MAKINUM (-1L)); 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; int j, k, kmax = SCM_ARRAY_NDIM (ra) - 1;
if (kmax < 0) if (kmax < 0)
return scm_array_set_x (ra, scm_apply(proc, SCM_EOL, SCM_EOL), return scm_array_set_x (ra, scm_apply(proc, SCM_EOL, SCM_EOL),
@ -1903,7 +1824,7 @@ raeql_1 (SCM ra0,SCM as_equal,SCM ra1)
} }
case scm_tc7_bvect: case scm_tc7_bvect:
for (; n--; i0 += inc0, i1 += inc1) for (; n--; i0 += inc0, i1 += inc1)
if (BVE_REF (ra0, i0) != BVE_REF (ra1, i1)) if (SCM_BITVEC_REF (ra0, i0) != SCM_BITVEC_REF (ra1, i1))
return 0; return 0;
return 1; return 1;
case scm_tc7_uvect: case scm_tc7_uvect:
@ -2008,8 +1929,11 @@ raeql (SCM ra0,SCM as_equal,SCM ra1)
} }
else else
{ {
/*
Huh ? Schizophrenic return type. --hwn
*/
if (1 != ndim) if (1 != ndim)
return SCM_BOOL_F; return 0;
s1->inc = 1; s1->inc = 1;
s1->lbnd = 0; s1->lbnd = 0;
s1->ubnd = SCM_LENGTH (v1) - 1; s1->ubnd = SCM_LENGTH (v1) - 1;
@ -2028,7 +1952,7 @@ raeql (SCM ra0,SCM as_equal,SCM ra1)
} }
} }
if (unroll && bas0 == bas1 && v0 == v1) 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), ""); return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), "");
} }

4
libguile/read.c
View file

@ -70,7 +70,7 @@ scm_option scm_read_opts[] = {
"Record positions of source code expressions." }, "Record positions of source code expressions." },
{ SCM_OPTION_BOOLEAN, "case-insensitive", 0, { SCM_OPTION_BOOLEAN, "case-insensitive", 0,
"Convert symbols to lower case."}, "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"} "Style of keyword recognition: #f or 'prefix"}
}; };
@ -489,7 +489,7 @@ tryagain_no_flush_ws:
goto tok; goto tok;
case ':': 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); j = scm_read_token ('-', tok_buf, port, 0);
p = scm_intern (SCM_CHARS (*tok_buf), j); p = scm_intern (SCM_CHARS (*tok_buf), j);

2
libguile/smob.c
View file

@ -116,7 +116,7 @@ scm_smob_print (SCM exp, SCM port, scm_print_state *pstate)
scm_puts ("#<", port); scm_puts ("#<", port);
scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port); scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
scm_putc (' ', 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); scm_putc ('>', port);
return 1; return 1;
} }

2
libguile/smob.h
View file

@ -87,7 +87,7 @@ do { \
#define SCM_SMOB_DATA(x) SCM_CDR (x) #define SCM_SMOB_DATA(x) SCM_CDR (x)
#define SCM_SET_SMOB_DATA(x, data) SCM_SETCDR (x, data) #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))) #define SCM_SMOBNUM(x) (SCM_TC2SMOBNUM (SCM_CAR (x)))
/* SCM_SMOBNAME can be 0 if name is missing */ /* SCM_SMOBNAME can be 0 if name is missing */
#define SCM_SMOBNAME(smobnum) scm_smobs[smobnum].name #define SCM_SMOBNAME(smobnum) scm_smobs[smobnum].name

4
libguile/srcprop.h
View file

@ -96,7 +96,7 @@ typedef struct scm_srcprops_chunk
} scm_srcprops_chunk; } scm_srcprops_chunk;
#define SRCPROPSP(p) (SCM_NIMP(p) && (SCM_TYP16 (p) == scm_tc16_srcprops)) #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 SRCPROPPOS(p) ((scm_srcprops *) SCM_CDR (p))->pos
#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12) #define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL) #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)))\ #define SRCBRKP(x) (SCM_NIMP (t.arg1 = scm_whash_lookup (scm_source_whash, (x)))\
&& SRCPROPSP (t.arg1)\ && 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)) #define PROCTRACEP(x) SCM_NFALSEP (scm_procedure_property (x, scm_sym_trace))

8
libguile/stacks.c
View file

@ -188,7 +188,7 @@ stack_depth (scm_debug_frame *dframe,long offset,SCM *id,int *maxp)
static void static void
read_frame (scm_debug_frame *dframe,long offset,scm_info_frame *iframe) 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; int size;
scm_debug_info *info; scm_debug_info *info;
if (SCM_EVALFRAMEP (*dframe)) 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)) && !SCM_UNBNDP (info[1].a.proc))
{ {
NEXT_FRAME (iframe, n, quit); 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->proc = info[1].a.proc;
iframe->args = info[1].a.args; 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)) 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->proc = info[1].a.proc;
iframe->args = info[1].a.args; iframe->args = info[1].a.args;
} }
else else
iframe->flags = SCM_INUM0; iframe->flags = SCM_ASWORD (SCM_INUM0);
iframe->source = scm_make_memoized (info[0].e.exp, iframe->source = scm_make_memoized (info[0].e.exp,
info[0].e.env); info[0].e.env);
info -= 2; info -= 2;

13
libguile/stacks.h
View file

@ -56,7 +56,8 @@
*/ */
typedef struct scm_info_frame { typedef struct scm_info_frame {
SCM flags; //SCM flags;
SCMWORD flags;
SCM source; SCM source;
SCM proc; SCM proc;
SCM args; SCM args;
@ -107,11 +108,11 @@ extern SCM scm_stack_type;
#define SCM_FRAMEF_EVAL_ARGS (1L << 5) #define SCM_FRAMEF_EVAL_ARGS (1L << 5)
#define SCM_FRAMEF_OVERFLOW (1L << 6) #define SCM_FRAMEF_OVERFLOW (1L << 6)
#define SCM_FRAME_VOID_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_VOID) #define SCM_FRAME_VOID_P(frame) (SCM_ASWORD (SCM_FRAME_FLAGS (frame)) & SCM_FRAMEF_VOID)
#define SCM_FRAME_REAL_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_REAL) #define SCM_FRAME_REAL_P(frame) (SCM_ASWORD (SCM_FRAME_FLAGS (frame)) & SCM_FRAMEF_REAL)
#define SCM_FRAME_PROC_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_PROC) #define SCM_FRAME_PROC_P(frame) (SCM_ASWORD (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_EVAL_ARGS_P(frame) (SCM_ASWORD (SCM_FRAME_FLAGS (frame)) & SCM_FRAMEF_EVAL_ARGS)
#define SCM_FRAME_OVERFLOW_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_OVERFLOW) #define SCM_FRAME_OVERFLOW_P(frame) (SCM_ASWORD (SCM_FRAME_FLAGS (frame)) & SCM_FRAMEF_OVERFLOW)

4
libguile/strports.c
View file

@ -83,7 +83,7 @@ stfill_buffer (SCM port)
if (pt->read_pos >= pt->read_end) if (pt->read_pos >= pt->read_end)
return EOF; return EOF;
else 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 /* 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 (target >= pt->write_buf_size)
{ {
if (!(SCM_CAR (port) & SCM_WRTNG)) if (!(SCM_CARW (port) & SCM_WRTNG))
{ {
if (target > pt->write_buf_size) if (target > pt->write_buf_size)
{ {

20
libguile/struct.c
View file

@ -173,7 +173,7 @@ scm_struct_init (SCM handle, int tail_elts, SCM inits)
{ {
tailp = 1; tailp = 1;
prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o'; prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
*mem++ = tail_elts; *mem++ = SCM_ASSCM (tail_elts);
n_fields += tail_elts - 1; n_fields += tail_elts - 1;
if (n_fields == 0) if (n_fields == 0)
break; break;
@ -324,7 +324,7 @@ scm_alloc_struct (int n_words, int n_extra, char *who)
SCM *p = block + n_extra; SCM *p = block + n_extra;
/* Adjust it even further so it's aligned on an eight-byte boundary. */ /* 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. */ /* Initialize a few fields as described above. */
p[scm_struct_i_free] = (SCM) scm_struct_free_standard; p[scm_struct_i_free] = (SCM) scm_struct_free_standard;
@ -345,13 +345,13 @@ scm_sizet
scm_struct_free_light (SCM *vtable, SCM *data) scm_struct_free_light (SCM *vtable, SCM *data)
{ {
free (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_sizet
scm_struct_free_standard (SCM *vtable, SCM *data) 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); * sizeof (SCM) + 7);
free ((void *) data[scm_struct_i_ptr]); free ((void *) data[scm_struct_i_ptr]);
return n; return n;
@ -360,7 +360,7 @@ scm_struct_free_standard (SCM *vtable, SCM *data)
scm_sizet scm_sizet
scm_struct_free_entity (SCM *vtable, SCM *data) 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); * sizeof (SCM) + 7);
free ((void *) data[scm_struct_i_ptr]); free ((void *) data[scm_struct_i_ptr]);
return n; return n;
@ -394,7 +394,7 @@ SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
tail_elts = SCM_INUM (tail_array_size); tail_elts = SCM_INUM (tail_array_size);
SCM_NEWCELL (handle); SCM_NEWCELL (handle);
SCM_DEFER_INTS; 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, data = scm_alloc_struct (basic_size + tail_elts,
scm_struct_entity_n_extra_words, scm_struct_entity_n_extra_words,
@ -520,7 +520,7 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0,
SCM * data; SCM * data;
SCM layout; SCM layout;
int p; int p;
int n_fields; SCMWORD n_fields;
unsigned char * fields_desc; unsigned char * fields_desc;
unsigned char field_type = 0; 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 /* The length of the hash table should be a relative prime it's not
necessary to shift down the address. */ necessary to shift down the address. */
return obj % n; return SCM_ASWORD (obj) % n;
} }
SCM SCM
@ -755,9 +755,9 @@ scm_print_struct (SCM exp, SCM port, scm_print_state *pstate)
else else
scm_puts ("struct", port); scm_puts ("struct", port);
scm_putc (' ', port); scm_putc (' ', port);
scm_intprint (vtable, 16, port); scm_intprint ((int) vtable, 16, port);
scm_putc (':', port); scm_putc (':', port);
scm_intprint (exp, 16, port); scm_intprint ((int)exp, 16, port);
scm_putc ('>', port); scm_putc ('>', port);
} }
} }

5
libguile/tag.c
View file

@ -105,9 +105,8 @@ SCM_DEFINE (scm_tag, "tag", 1, 0, 0,
return SCM_CDR (scm_utag_immediate_char) ; return SCM_CDR (scm_utag_immediate_char) ;
else else
{ {
int tag; SCM tag = SCM_MAKINUM ((SCM_ASWORD (x) >> 8) & 0xff);
tag = SCM_MAKINUM ((x >> 8) & 0xff); return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_flag_base) ) | (SCM_ASWORD (tag) << 8));
return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_flag_base) ) | (tag << 8));
} }
case scm_tc3_cons: case scm_tc3_cons:

61
libguile/tags.h
View file

@ -54,10 +54,27 @@
/* In the beginning was the Word: /* 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, /* 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 * (Not always impossible but it is fair to say that many details of tags
* are mutually dependent). */ * 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)) #define SCM_NIMP(x) (!SCM_IMP (x))
/* Here is a summary of tagging in SCM values as they might occur in /* 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: * 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_SLOPPY_CONSP(x) (!SCM_SLOPPY_NCONSP(x))
#define SCM_NCONSP(x) (SCM_IMP (x) || SCM_SLOPPY_NCONSP(x)) #define SCM_NCONSP(x) (SCM_IMP (x) || SCM_SLOPPY_NCONSP(x))
@ -286,13 +303,13 @@ typedef long SCM;
#define SCM_CELLP(x) (!SCM_NCELLP (x)) #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. /* See numbers.h for macros relating to immediate integers.
*/ */
#define SCM_ITAG3(x) (7 & (SCM) x) #define SCM_ITAG3(x) (7 & SCM_ASWORD(x))
#define SCM_TYP3(x) (7 & SCM_CAR (x)) #define SCM_TYP3(x) (7 & SCM_CARW (x))
#define scm_tc3_cons 0 #define scm_tc3_cons 0
#define scm_tc3_cons_gloc 1 #define scm_tc3_cons_gloc 1
#define scm_tc3_int_1 2 #define scm_tc3_int_1 2
@ -308,20 +325,20 @@ typedef long SCM;
*/ */
#define SCM_TYP7(x) (SCM_CAR (x) & 0x7f) #define SCM_TYP7(x) (0x7f & SCM_CARW (x))
#define SCM_TYP7S(x) (SCM_CAR (x) & (0x7f & ~2)) #define SCM_TYP7S(x) ((0x7f & ~2) & SCM_CARW (x))
#define SCM_TYP16(x) (0xffff & SCM_CAR (x)) #define SCM_TYP16(x) (0xffff & SCM_CARW (x))
#define SCM_TYP16S(x) (0xfeff & SCM_CAR (x)) #define SCM_TYP16S(x) (0xfeff & SCM_CARW (x))
#define SCM_GCTYP16(x) (0xff7f & SCM_CAR (x)) #define SCM_GCTYP16(x) (0xff7f & SCM_CARW (x))
/* Testing and Changing GC Marks in Various Standard Positions /* Testing and Changing GC Marks in Various Standard Positions
*/ */
#define SCM_GCMARKP(x) (1 & SCM_CDR (x)) #define SCM_GCMARKP(x) (1 & SCM_ASWORD (SCM_CDR (x)))
#define SCM_GC8MARKP(x) (0x80 & SCM_CAR (x)) #define SCM_GC8MARKP(x) (0x80 & SCM_CARW (x))
#define SCM_SETGCMARK(x) SCM_SETOR_CDR (x, 1) #define SCM_SETGCMARK(x) SCM_SETOR_CDR (x, 1)
#define SCM_CLRGCMARK(x) SCM_SETAND_CDR (x, ~1L) #define SCM_CLRGCMARK(x) SCM_SETAND_CDR (x, ~1L)
#define SCM_SETGC8MARK(x) SCM_SETOR_CAR (x, 0x80) #define SCM_SETGC8MARK(x) SCM_SETOR_CAR (x, 0x80)
@ -437,9 +454,9 @@ enum scm_tags
scm_tc8_iloc = 0xfc scm_tc8_iloc = 0xfc
}; };
#define SCM_ITAG8(X) ((SCM) (X) & 0xff) #define SCM_ITAG8(X) (SCM_ASWORD(X) & 0xff)
#define SCM_MAKE_ITAG8(X, TAG) (((X) << 8) + TAG) #define SCM_MAKE_ITAG8(X, TAG) SCM_ASSCM(((X) << 8) + TAG)
#define SCM_ITAG8_DATA(X) ((X) >> 8) #define SCM_ITAG8_DATA(X) (SCM_ASWORD(X) >> 8)
@ -447,15 +464,15 @@ enum scm_tags
*/ */
/* SCM_ISYMP tests for ISPCSYM and ISYM */ /* 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 */ /* SCM_IFLAGP tests for ISPCSYM, ISYM and IFLAG */
#define SCM_IFLAGP(n) ((0x87 & (SCM) (n)) == 4) #define SCM_IFLAGP(n) ((0x87 & SCM_ASWORD(n)) == 4)
#define SCM_ISYMNUM(n) ((SCM) ((n) >> 9)) #define SCM_ISYMNUM(n) (SCM_ASWORD(n) >> 9)
#define SCM_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM (n)]) #define SCM_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM (n)])
#define SCM_MAKSPCSYM(n) (((n) << 9) + ((n) << 3) + 4L) #define SCM_MAKSPCSYM(n) SCM_ASSCM(((n) << 9) + ((n) << 3) + 4L)
#define SCM_MAKISYM(n) (((n) << 9) + 0x74L) #define SCM_MAKISYM(n) SCM_ASSCM(((n) << 9) + 0x74L)
#define SCM_MAKIFLAG(n) (((n) << 9) + 0x174L) #define SCM_MAKIFLAG(n) SCM_ASSCM(((n) << 9) + 0x174L)
extern char *scm_isymnames[]; /* defined in print.c */ extern char *scm_isymnames[]; /* defined in print.c */

24
libguile/throw.c
View file

@ -68,19 +68,20 @@
/* the jump buffer data structure */ /* the jump buffer data structure */
static int scm_tc16_jmpbuffer; static int scm_tc16_jmpbuffer;
#define SCM_JMPBUFP(O) (SCM_NIMP(O) && (SCM_TYP16(O) == scm_tc16_jmpbuffer)) #define SCM_JMPBUFP(OBJ) (SCM_NIMP(OBJ) && (SCM_TYP16(OBJ) == scm_tc16_jmpbuffer))
#define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L))
#define ACTIVATEJB(O) (SCM_SETOR_CAR (O, (1L << 16L))) #define JBACTIVE(OBJ) (SCM_CARW (OBJ) & (1L << 16L))
#define DEACTIVATEJB(O) (SCM_SETAND_CAR (O, ~(1L << 16L))) #define ACTIVATEJB(OBJ) (SCM_SETOR_CAR (OBJ, (1L << 16L)))
#define DEACTIVATEJB(OBJ) (SCM_SETAND_CAR (OBJ, ~(1L << 16L)))
#ifndef DEBUG_EXTENSIONS #ifndef DEBUG_EXTENSIONS
#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) ) #define JBJMPBUF(OBJ) ((jmp_buf*)SCM_CDR (OBJ) )
#define SETJBJMPBUF SCM_SETCDR #define SETJBJMPBUF SCM_SETCDR
#else #else
#define SCM_JBDFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) ) #define SCM_JBDFRAME(OBJ) ((scm_debug_frame*)SCM_CAR (SCM_CDR (OBJ)) )
#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) ) #define JBJMPBUF(OBJ) ((jmp_buf*)SCM_CDR (SCM_CDR (OBJ)) )
#define SCM_SETJBDFRAME(O,X) SCM_SETCAR (SCM_CDR (O), (SCM)(X)) #define SCM_SETJBDFRAME(OBJ,X) SCM_SETCAR (SCM_CDR (OBJ), (SCM)(X))
#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X) #define SETJBJMPBUF(OBJ,X) SCM_SETCDR(SCM_CDR (OBJ), X)
static scm_sizet static scm_sizet
freejb (SCM jbsmob) freejb (SCM jbsmob)
@ -95,7 +96,8 @@ printjb (SCM exp, SCM port, scm_print_state *pstate)
{ {
scm_puts ("#<jmpbuffer ", port); scm_puts ("#<jmpbuffer ", port);
scm_puts (JBACTIVE(exp) ? "(active) " : "(inactive) ", port); scm_puts (JBACTIVE(exp) ? "(active) " : "(inactive) ", port);
scm_intprint((SCM) JBJMPBUF(exp), 16, port); scm_intprint(SCM_ASWORD ( JBJMPBUF(exp) ), 16, port);
scm_putc ('>', port); scm_putc ('>', port);
return 1 ; return 1 ;
} }
@ -274,7 +276,7 @@ make_lazy_catch (struct lazy_catch *c)
} }
#define SCM_LAZY_CATCH_P(obj) \ #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: /* Exactly like scm_internal_catch, except:

162
libguile/unif.c
View file

@ -42,6 +42,13 @@
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ 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 <stdio.h> #include <stdio.h>
@ -280,10 +287,9 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
enclosed = 0; enclosed = 0;
if (SCM_IMP (v)) if (SCM_IMP (v))
return SCM_BOOL_F; return SCM_BOOL_F;
loop:
switch (SCM_TYP7 (v)) while (SCM_TYP7 (v) == scm_tc7_smob)
{ {
case scm_tc7_smob:
if (!SCM_ARRAYP (v)) if (!SCM_ARRAYP (v))
return SCM_BOOL_F; return SCM_BOOL_F;
if (nprot) if (nprot)
@ -291,45 +297,55 @@ loop:
if (enclosed++) if (enclosed++)
return SCM_BOOL_F; return SCM_BOOL_F;
v = SCM_ARRAY_V (v); v = SCM_ARRAY_V (v);
goto loop; }
if (nprot)
return SCM_BOOL(nprot);
else
{
int protp = 0;
switch (SCM_TYP7 (v))
{
case scm_tc7_bvect: case scm_tc7_bvect:
return nprot || SCM_BOOL(SCM_BOOL_T==prot); protp = (SCM_BOOL_T==prot);
case scm_tc7_string: case scm_tc7_string:
return nprot || SCM_BOOL(SCM_CHARP(prot) && (prot != SCM_MAKE_CHAR('\0'))); protp = SCM_ICHRP(prot) && (prot != SCM_MAKICHR('\0'));
case scm_tc7_byvect: case scm_tc7_byvect:
return nprot || SCM_BOOL(prot == SCM_MAKE_CHAR('\0')); protp = prot == SCM_MAKICHR('\0');
case scm_tc7_uvect: case scm_tc7_uvect:
return nprot || SCM_BOOL(SCM_INUMP(prot) && SCM_INUM(prot)>0); protp = SCM_INUMP(prot) && SCM_INUM(prot)>0;
case scm_tc7_ivect: case scm_tc7_ivect:
return nprot || SCM_BOOL(SCM_INUMP(prot) && SCM_INUM(prot)<=0); protp = SCM_INUMP(prot) && SCM_INUM(prot)<=0;
case scm_tc7_svect: case scm_tc7_svect:
return ( nprot protp = SCM_SYMBOLP (prot)
|| (SCM_SYMBOLP (prot)
&& (1 == SCM_LENGTH (prot)) && (1 == SCM_LENGTH (prot))
&& ('s' == SCM_CHARS (prot)[0]))); && ('s' == SCM_CHARS (prot)[0]);
#ifdef HAVE_LONG_LONGS #ifdef HAVE_LONG_LONGS
case scm_tc7_llvect: case scm_tc7_llvect:
return ( nprot protp = SCM_SYMBOLP (prot)
|| (SCM_SYMBOLP (prot)
&& (1 == SCM_LENGTH (prot)) && (1 == SCM_LENGTH (prot))
&& ('s' == SCM_CHARS (prot)[0]))); && ('s' == SCM_CHARS (prot)[0]);
#endif #endif
# ifdef SCM_FLOATS # ifdef SCM_FLOATS
# ifdef SCM_SINGLES # ifdef SCM_SINGLES
case scm_tc7_fvect: case scm_tc7_fvect:
return nprot || SCM_BOOL(SCM_SINGP(prot)); protp = SCM_SINGP(prot);
# endif # endif
case scm_tc7_dvect: case scm_tc7_dvect:
return nprot || SCM_BOOL(SCM_REALP(prot)); protp = SCM_REALP(prot);
case scm_tc7_cvect: case scm_tc7_cvect:
return nprot || SCM_BOOL(SCM_CPLXP(prot)); protp = SCM_CPLXP(prot);
# endif # endif
case scm_tc7_vector: case scm_tc7_vector:
case scm_tc7_wvect: case scm_tc7_wvect:
return nprot || SCM_BOOL(SCM_NULLP(prot)); protp = SCM_NULLP(prot);
default:; default:
/* no default */
;
}
return SCM_BOOL(protp);
} }
return SCM_BOOL_F;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -1079,8 +1095,11 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
badarg: badarg:
SCM_WTA (1,v); SCM_WTA (1,v);
abort (); 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: case scm_tc7_smob:
{ /* enclosed */ { /* enclosed */
int k = SCM_ARRAY_NDIM (v); int k = SCM_ARRAY_NDIM (v);
@ -1096,7 +1115,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
return res; return res;
} }
case scm_tc7_bvect: 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; return SCM_BOOL_T;
else else
return SCM_BOOL_F; 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]); return SCM_MAKINUM (SCM_VELTS (v)[pos]);
# else # else
case scm_tc7_uvect: case scm_tc7_uvect:
return scm_ulong2num(SCM_VELTS(v)[pos]); return scm_ulong2num((unsigned long ) SCM_VELTS(v)[pos]);
case scm_tc7_ivect: case scm_tc7_ivect:
return scm_long2num(SCM_VELTS(v)[pos]); return scm_long2num((long) SCM_VELTS(v)[pos]);
# endif # endif
case scm_tc7_svect: case scm_tc7_svect:
@ -1151,7 +1170,7 @@ scm_cvref (SCM v, scm_sizet pos, SCM last)
default: default:
scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref"); scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref");
case scm_tc7_bvect: 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; return SCM_BOOL_T;
else else
return SCM_BOOL_F; return SCM_BOOL_F;
@ -1165,9 +1184,9 @@ scm_cvref (SCM v, scm_sizet pos, SCM last)
return SCM_MAKINUM (SCM_VELTS (v)[pos]); return SCM_MAKINUM (SCM_VELTS (v)[pos]);
# else # else
case scm_tc7_uvect: case scm_tc7_uvect:
return scm_ulong2num(SCM_VELTS(v)[pos]); return scm_ulong2num((unsigned long) SCM_VELTS(v)[pos]);
case scm_tc7_ivect: case scm_tc7_ivect:
return scm_long2num(SCM_VELTS(v)[pos]); return scm_long2num((long) SCM_VELTS(v)[pos]);
# endif # endif
case scm_tc7_svect: case scm_tc7_svect:
return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]); 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_FLOATS
#ifdef SCM_SINGLES #ifdef SCM_SINGLES
case scm_tc7_fvect: 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]; SCM_FLO (last) = ((float *) SCM_CDR (v))[pos];
return last; return last;
@ -1187,7 +1206,7 @@ scm_cvref (SCM v, scm_sizet pos, SCM last)
#endif #endif
case scm_tc7_dvect: case scm_tc7_dvect:
#ifdef SCM_SINGLES #ifdef SCM_SINGLES
if (SCM_NIMP (last) && scm_tc_dblr == SCM_CAR (last)) if (SCM_NIMP (last) && scm_tc_dblr == SCM_CARW (last))
#else #else
if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_dblr == SCM_CAR (last))) if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_dblr == SCM_CAR (last)))
#endif #endif
@ -1197,7 +1216,7 @@ scm_cvref (SCM v, scm_sizet pos, SCM last)
} }
return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0); return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0);
case scm_tc7_cvect: 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_REAL (last) = ((double *) SCM_CDR (v))[2 * pos];
SCM_IMAG (last) = ((double *) SCM_CDR (v))[2 * pos + 1]; 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: default: badarg1:
SCM_WTA (1,v); SCM_WTA (1,v);
abort (); abort ();
outrng:scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); outrng:
wna: scm_wrong_num_args (SCM_FUNC_NAME); scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos));
wna:
scm_wrong_num_args (SCM_FUNC_NAME);
case scm_tc7_smob: /* enclosed */ case scm_tc7_smob: /* enclosed */
goto badarg1; goto badarg1;
case scm_tc7_bvect: case scm_tc7_bvect:
if (SCM_BOOL_F == obj) 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) else if (SCM_BOOL_T == obj)
SCM_VELTS (v)[pos / SCM_LONG_BIT] |= (1L << (pos % SCM_LONG_BIT)); SCM_BITVEC_SET(v,pos);
else else
badobj:SCM_WTA (2,obj); badobj:SCM_WTA (2,obj);
break; break;
@ -1291,12 +1312,15 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
SCM_ASRTGO (SCM_INUM (obj) >= 0, badobj); SCM_ASRTGO (SCM_INUM (obj) >= 0, badobj);
/* fall through */ /* fall through */
case scm_tc7_ivect: 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 # else
case scm_tc7_uvect: 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: 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 # endif
case scm_tc7_svect: case scm_tc7_svect:
SCM_ASRTGO (SCM_INUMP (obj), badobj); 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 #define FUNC_NAME s_scm_bit_count
{ {
long i; long i;
register unsigned long cnt = 0, w; register unsigned long cnt = 0;
register unsigned long w;
SCM_VALIDATE_INUM (2,seq); SCM_VALIDATE_INUM (2,seq);
switch SCM_TYP7 (seq) switch SCM_TYP7 (seq)
{ {
@ -1737,7 +1762,7 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
if (0 == SCM_LENGTH (seq)) if (0 == SCM_LENGTH (seq))
return SCM_INUM0; return SCM_INUM0;
i = (SCM_LENGTH (seq) - 1) / SCM_LONG_BIT; i = (SCM_LENGTH (seq) - 1) / SCM_LONG_BIT;
w = SCM_VELTS (seq)[i]; w = SCM_ASWORD (SCM_VELTS (seq)[i]);
if (SCM_FALSEP (item)) if (SCM_FALSEP (item))
w = ~w; w = ~w;
w <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (seq) - 1) % SCM_LONG_BIT); 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]; cnt += cnt_tab[w & 0x0f];
if (0 == i--) if (0 == i--)
return SCM_MAKINUM (cnt); return SCM_MAKINUM (cnt);
w = SCM_VELTS (seq)[i]; w = SCM_ASWORD (SCM_VELTS (seq)[i]);
if (SCM_FALSEP (item)) if (SCM_FALSEP (item))
w = ~w; w = ~w;
} }
@ -1780,7 +1805,7 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
return SCM_MAKINUM (-1L); return SCM_MAKINUM (-1L);
lenw = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */ lenw = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */
i = pos / SCM_LONG_BIT; i = pos / SCM_LONG_BIT;
w = SCM_VELTS (v)[i]; w = SCM_ASWORD (SCM_VELTS (v)[i]);
if (SCM_FALSEP (item)) if (SCM_FALSEP (item))
w = ~w; w = ~w;
xbits = (pos % SCM_LONG_BIT); xbits = (pos % SCM_LONG_BIT);
@ -1814,7 +1839,7 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
if (++i > lenw) if (++i > lenw)
break; break;
pos += SCM_LONG_BIT; pos += SCM_LONG_BIT;
w = SCM_VELTS (v)[i]; w = SCM_ASWORD (SCM_VELTS (v)[i]);
if (SCM_FALSEP (item)) if (SCM_FALSEP (item))
w = ~w; w = ~w;
} }
@ -1846,22 +1871,22 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
switch SCM_TYP7 (v) switch SCM_TYP7 (v)
{ {
default: default:
badarg1:SCM_WTA (1,v); badarg1: SCM_WTA (1,v);
case scm_tc7_bvect: case scm_tc7_bvect:
vlen = SCM_LENGTH (v); vlen = SCM_LENGTH (v);
if (SCM_BOOL_F == obj) if (SCM_BOOL_F == obj)
for (i = SCM_LENGTH (kv); i;) 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_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) else if (SCM_BOOL_T == obj)
for (i = SCM_LENGTH (kv); i;) 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_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 else
badarg3:SCM_WTA (3,obj); 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); SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1);
if (SCM_BOOL_F == obj) if (SCM_BOOL_F == obj)
for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) 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) else if (SCM_BOOL_T == obj)
for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) 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 else
goto badarg3; goto badarg3;
break; break;
@ -1895,34 +1920,37 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
{ {
register long i, vlen, count = 0; register long i, vlen, count = 0;
register unsigned long k; register unsigned long k;
SCM_ASRTGO (SCM_NIMP (v), badarg1); SCM_ASRTGO (SCM_NIMP (v), badarg1);
SCM_ASRTGO (SCM_NIMP (kv), badarg2); SCM_ASRTGO (SCM_NIMP (kv), badarg2);
switch SCM_TYP7 (kv) switch SCM_TYP7 (kv)
{ {
default: default:
badarg2:SCM_WTA (2,kv); badarg2:
SCM_WTA (2,kv);
case scm_tc7_uvect: case scm_tc7_uvect:
switch SCM_TYP7 switch SCM_TYP7
(v) (v)
{ {
default: default:
badarg1:SCM_WTA (1,v); badarg1:
SCM_WTA (1,v);
case scm_tc7_bvect: case scm_tc7_bvect:
vlen = SCM_LENGTH (v); vlen = SCM_LENGTH (v);
if (SCM_BOOL_F == obj) if (SCM_BOOL_F == obj)
for (i = SCM_LENGTH (kv); i;) 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_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++; count++;
} }
else if (SCM_BOOL_T == obj) else if (SCM_BOOL_T == obj)
for (i = SCM_LENGTH (kv); i;) 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_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++; count++;
} }
else else
@ -1934,17 +1962,19 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
if (0 == SCM_LENGTH (v)) if (0 == SCM_LENGTH (v))
return SCM_INUM0; return SCM_INUM0;
SCM_ASRTGO (SCM_BOOL_T == obj || SCM_BOOL_F == obj, badarg3); 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; 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); k <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (v) - 1) % SCM_LONG_BIT);
while (!0) while (1)
{ {
for (; k; k >>= 4) for (; k; k >>= 4)
count += cnt_tab[k & 0x0f]; count += cnt_tab[k & 0x0f];
if (0 == i--) if (0 == i--)
return SCM_MAKINUM (count); 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); return SCM_MAKINUM (count);
@ -1965,7 +1995,7 @@ SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
{ {
case scm_tc7_bvect: case scm_tc7_bvect:
for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) 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; break;
default: default:
badarg1:SCM_WTA (1,v); badarg1:SCM_WTA (1,v);
@ -2329,11 +2359,11 @@ tail:
} }
case scm_tc7_ivect: case scm_tc7_ivect:
if (n-- > 0) 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) for (j += inc; n-- > 0; j += inc)
{ {
scm_putc (' ', port); scm_putc (' ', port);
scm_intprint (SCM_VELTS (ra)[j], 10, port); scm_intprint ((int)SCM_VELTS (ra)[j], 10, port);
} }
break; break;
@ -2435,7 +2465,7 @@ tail:
scm_putc ('*', port); scm_putc ('*', port);
for (i = 0; i < (SCM_LENGTH (exp)) / SCM_LONG_BIT; i++) 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--) for (j = SCM_LONG_BIT; j; j--)
{ {
scm_putc (w & 1 ? '1' : '0', port); scm_putc (w & 1 ? '1' : '0', port);
@ -2445,7 +2475,7 @@ tail:
j = SCM_LENGTH (exp) % SCM_LONG_BIT; j = SCM_LENGTH (exp) % SCM_LONG_BIT;
if (j) 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--) for (; j; j--)
{ {
scm_putc (w & 1 ? '1' : '0', port); scm_putc (w & 1 ? '1' : '0', port);

6
libguile/unif.h
View file

@ -76,10 +76,10 @@ typedef struct scm_array_dim
extern long scm_tc16_array; extern long scm_tc16_array;
#define SCM_ARRAYP(a) (SCM_NIMP(a) && (scm_tc16_array==SCM_TYP16(a))) #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_ARRAY_NDIM(x) ((scm_sizet)(SCM_CARW(x)>>17))
#define SCM_ARRAY_CONTIGUOUS 0x10000 #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_V(a) (((scm_array *)SCM_CDR(a))->v)
#define SCM_ARRAY_BASE(a) (((scm_array *)SCM_CDR(a))->base) #define SCM_ARRAY_BASE(a) (((scm_array *)SCM_CDR(a))->base)

2
libguile/variable.c
View file

@ -58,7 +58,7 @@ static int
prin_var (SCM exp,SCM port,scm_print_state *pstate) prin_var (SCM exp,SCM port,scm_print_state *pstate)
{ {
scm_puts ("#<variable ", port); scm_puts ("#<variable ", port);
scm_intprint(exp, 16, port); scm_intprint((int) exp, 16, port);
{ {
SCM val_cell; SCM val_cell;
val_cell = SCM_CDR(exp); val_cell = SCM_CDR(exp);

2
libguile/variable.h
View file

@ -56,7 +56,7 @@
extern int scm_tc16_variable; extern int scm_tc16_variable;
#define SCM_VARVCELL(V) SCM_CDR(V) #define SCM_VARVCELL(V) SCM_CDR(V)
#define SCM_VARIABLEP(X) (SCM_NIMP(X) && (scm_tc16_variable == SCM_CAR(X))) #define SCM_VARIABLEP(X) (SCM_NIMP(X) && (scm_tc16_variable == SCM_CARW(X)))
#define SCM_UDVARIABLEP(X) (SCM_VARIABLEP(X) && SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) #define SCM_UDVARIABLEP(X) (SCM_VARIABLEP(X) && SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X))))
#define SCM_DEFVARIABLEP(X) (SCM_VARIABLEP(X) && !SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) #define SCM_DEFVARIABLEP(X) (SCM_VARIABLEP(X) && !SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X))))

10
libguile/vectors.h
View file

@ -56,6 +56,16 @@
#define SCM_VELTS(x) ((SCM *)SCM_CDR(x)) #define SCM_VELTS(x) ((SCM *)SCM_CDR(x))
#define SCM_SETVELTS SCM_SETCDR #define SCM_SETVELTS SCM_SETCDR
/*
bit vectors
*/
#define SCM_BITVEC_REF(a, i) ((SCM_ASWORD(SCM_VELTS(a)[(i)/SCM_LONG_BIT]) & (1L<<((i)%SCM_LONG_BIT))) ? 1 : 0)
#define SCM_BITVEC_SET(a, i) SCM_ASWORD(SCM_VELTS(a)[(i)/SCM_LONG_BIT]) |= (1L<<((i)%SCM_LONG_BIT))
#define SCM_BITVEC_CLR(a, i) SCM_ASWORD(SCM_VELTS(a)[(i)/SCM_LONG_BIT]) &= ~(1L<<((i)%SCM_LONG_BIT))
extern SCM scm_vector_set_length_x (SCM vect, SCM len); extern SCM scm_vector_set_length_x (SCM vect, SCM len);

6
libguile/weaks.c
View file

@ -133,7 +133,7 @@ SCM_DEFINE (scm_make_weak_key_hash_table, "make-weak-key-hash-table", 1, 0, 0,
SCM_VALIDATE_INUM (1,k); SCM_VALIDATE_INUM (1,k);
v = scm_make_weak_vector (k, SCM_EOL); v = scm_make_weak_vector (k, SCM_EOL);
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
SCM_VELTS (v)[-1] = 1; SCM_ASWORD (SCM_VELTS (v)[-1]) = 1;
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return v; return v;
} }
@ -149,7 +149,7 @@ SCM_DEFINE (scm_make_weak_value_hash_table, "make-weak-value-hash-table", 1, 0,
SCM_VALIDATE_INUM (1,k); SCM_VALIDATE_INUM (1,k);
v = scm_make_weak_vector (k, SCM_EOL); v = scm_make_weak_vector (k, SCM_EOL);
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
SCM_VELTS (v)[-1] = 2; SCM_ASWORD (SCM_VELTS (v)[-1]) = 2;
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return v; return v;
} }
@ -166,7 +166,7 @@ SCM_DEFINE (scm_make_doubly_weak_hash_table, "make-doubly-weak-hash-table", 1, 0
SCM_VALIDATE_INUM (1,k); SCM_VALIDATE_INUM (1,k);
v = scm_make_weak_vector (k, SCM_EOL); v = scm_make_weak_vector (k, SCM_EOL);
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
SCM_VELTS (v)[-1] = 3; SCM_ASWORD (SCM_VELTS (v)[-1]) = 3;
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
return v; return v;
} }

6
libguile/weaks.h
View file

@ -53,9 +53,9 @@
#define SCM_WVECTP(x) (SCM_NIMP(x) && (SCM_TYP7(x)==scm_tc7_wvect)) #define SCM_WVECTP(x) (SCM_NIMP(x) && (SCM_TYP7(x)==scm_tc7_wvect))
#define SCM_IS_WHVEC(X) (SCM_VELTS(X)[-1] == 1) #define SCM_IS_WHVEC(X) (SCM_ASWORD (SCM_VELTS(X)[-1]) == 1)
#define SCM_IS_WHVEC_V(X) (SCM_VELTS(X)[-1] == 2) #define SCM_IS_WHVEC_V(X) (SCM_ASWORD (SCM_VELTS(X)[-1]) == 2)
#define SCM_IS_WHVEC_B(X) (SCM_VELTS(X)[-1] == 3) #define SCM_IS_WHVEC_B(X) (SCM_ASWORD (SCM_VELTS(X)[-1]) == 3)
#define SCM_IS_WHVEC_ANY(X) (SCM_VELTS(X)[-1]) #define SCM_IS_WHVEC_ANY(X) (SCM_VELTS(X)[-1])
#define SCM_WVECT_GC_CHAIN(X) (SCM_VELTS(X)[-2]) #define SCM_WVECT_GC_CHAIN(X) (SCM_VELTS(X)[-2])