static long scm_tc16_arbiter;
+#define SCM_ARB_LOCKED(arb) (((SCMWORD) SCM_CAR(arb)) & (1L << 16))
+#define SCM_LOCK_ARB(arb) SCM_SETCAR (arb, (SCM) (scm_tc16_arbiter | (1L << 16)));
+#define SCM_UNLOCK_ARB(arb) SCM_SETCAR (arb, (SCM) scm_tc16_arbiter);
+
static int
prinarb (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts ("#<arbiter ", port);
- if (SCM_CAR (exp) & (1L << 16))
+ if (SCM_ARB_LOCKED (exp))
scm_puts ("locked ", port);
scm_iprin1 (SCM_CDR (exp), port, pstate);
scm_putc ('>', port);
{
SCM_VALIDATE_SMOB (1,arb,arbiter);
SCM_DEFER_INTS;
- if (SCM_CAR (arb) & (1L << 16))
+ if (SCM_ARB_LOCKED(arb))
arb = SCM_BOOL_F;
else
{
- SCM_SETCAR (arb, scm_tc16_arbiter | (1L << 16));
+ SCM_LOCK_ARB(arb);
arb = SCM_BOOL_T;
}
SCM_ALLOW_INTS;
#define FUNC_NAME s_scm_release_arbiter
{
SCM_VALIDATE_SMOB (1,arb,arbiter);
- if (!(SCM_CAR (arb) & (1L << 16)))
+ if (! SCM_ARB_LOCKED(arb))
return SCM_BOOL_F;
- SCM_SETCAR (arb, scm_tc16_arbiter);
+ SCM_UNLOCK_ARB (arb);
return SCM_BOOL_T;
}
#undef FUNC_NAME
#define FUNC_NAME s_scm_set_tick_rate
{
unsigned int old_n;
+
+
SCM_VALIDATE_INUM (1,n);
+
old_n = scm_tick_rate;
- scm_desired_tick_rate = SCM_INUM (n);
+
+
+ scm_desired_tick_rate = SCM_ASWORD (SCM_INUM (n));
scm_async_rate = 1 + scm_async_rate - scm_async_clock;
scm_async_clock = 1;
return SCM_MAKINUM (old_n);
unsigned int old_n;
SCM_VALIDATE_INUM (1,n);
old_n = scm_switch_rate;
- scm_desired_switch_rate = SCM_INUM (n);
+ scm_desired_switch_rate = SCM_ASWORD (SCM_INUM (n));
scm_async_rate = 1 + scm_async_rate - scm_async_clock;
scm_async_clock = 1;
return SCM_MAKINUM (old_n);
/* SCM_BOOL_NOT returns the other boolean.
* The order of ^s here is important for Borland C++ (!?!?!)
*/
-#define SCM_BOOL_NOT(x) ((x) ^ (SCM_BOOL_T ^ SCM_BOOL_F))
+#define SCM_BOOL_NOT(x) SCM_ASSCM(SCM_ASWORD(x) ^ (SCM_ASWORD (SCM_BOOL_T) ^ SCM_ASWORD (SCM_BOOL_F)))
\f
#define FUNC_NAME s_scm_gloc_p
{
return SCM_BOOL((SCM_MEMOIZEDP (obj)
- && (SCM_MEMOIZED_EXP (obj) & 7) == 1));
+ && (SCM_ASWORD(SCM_MEMOIZED_EXP (obj)) & 7) == 1));
}
#undef FUNC_NAME
prindebugobj (SCM obj,SCM port,scm_print_state *pstate)
{
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);
return 1;
}
get_dynl_obj (SCM dobj,const char *subr,int argn)
{
struct dynl_obj *d;
- SCM_ASSERT (SCM_NIMP (dobj) && SCM_CAR (dobj) == scm_tc16_dynamic_obj,
+ SCM_ASSERT (SCM_NIMP (dobj) && SCM_CARW (dobj) == scm_tc16_dynamic_obj,
dobj, argn, subr);
d = (struct dynl_obj *)SCM_CDR (dobj);
SCM_ASSERT (d->handle != NULL, dobj, argn, subr);
"otherwise.")
#define FUNC_NAME s_scm_dynamic_object_p
{
- return SCM_BOOL(SCM_NIMP (obj) && SCM_CAR (obj) == scm_tc16_dynamic_obj);
+ return SCM_BOOL(SCM_NIMP (obj) && SCM_CARW (obj) == scm_tc16_dynamic_obj);
}
#undef FUNC_NAME
#define SCM_BEFORE_GUARD(obj) (SCM_GUARDSMEM (obj)->before)
#define SCM_AFTER_GUARD(obj) (SCM_GUARDSMEM (obj)->after)
#define SCM_GUARD_DATA(obj) (SCM_GUARDSMEM (obj)->data)
-#define SCM_GUARDSP(obj) (SCM_NIMP(obj) && (SCM_CAR (obj) == tc16_guards))
+#define SCM_GUARDSP(obj) (SCM_NIMP(obj) && (SCM_CARW (obj) == tc16_guards))
static long tc16_guards;
printguards (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts ("#<guards ", port);
- scm_intprint (SCM_CDR (exp), 16, port);
+ scm_intprint (SCM_ASWORD (SCM_CDR (exp)), 16, port);
scm_putc ('>', port);
return 1;
}
#endif
}
#ifdef MEMOIZE_LOCALS
- iloc = (~SCM_IDSTMSK) & (iloc + SCM_IFRINC);
+ iloc = SCM_ASSCM ((~SCM_IDSTMSK) & SCM_ASWORD(iloc + SCM_IFRINC));
#endif
}
{
if (SCM_IMP (form))
return form;
c = SCM_CAR (form);
- if (1 == (c & 7))
+ if (1 == (SCM_ASWORD (c) & 7))
SCM_SETCAR (form, SCM_CAR (c - 1));
#ifdef MEMOIZE_LOCALS
#ifdef DEBUG_EXTENSIONS
if (SCM_IMP (proc)
|| scm_tc16_macro != SCM_TYP16 (proc)
- || (int) (SCM_CAR (proc) >> 16) != 2)
+ || (int) (SCM_CARW (proc) >> 16) != 2)
return x;
unmemocar (x, env);
* readable style... :)
*/
+#define SCM_BIT8(x) (127 & SCM_ASWORD (x))
+
static SCM
unmemocopy (SCM x, SCM env)
{
#endif
switch (SCM_TYP7 (x))
{
- case (127 & SCM_IM_AND):
+ case SCM_BIT8(SCM_IM_AND):
ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED);
break;
- case (127 & SCM_IM_BEGIN):
+ case SCM_BIT8(SCM_IM_BEGIN):
ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED);
break;
- case (127 & SCM_IM_CASE):
+ case SCM_BIT8(SCM_IM_CASE):
ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED);
break;
- case (127 & SCM_IM_COND):
+ case SCM_BIT8(SCM_IM_COND):
ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED);
break;
- case (127 & SCM_IM_DO):
+ case SCM_BIT8(SCM_IM_DO):
ls = scm_cons (scm_sym_do, SCM_UNSPECIFIED);
goto transform;
- case (127 & SCM_IM_IF):
+ case SCM_BIT8(SCM_IM_IF):
ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED);
break;
- case (127 & SCM_IM_LET):
+ case SCM_BIT8(SCM_IM_LET):
ls = scm_cons (scm_sym_let, SCM_UNSPECIFIED);
goto transform;
- case (127 & SCM_IM_LETREC):
+ case SCM_BIT8(SCM_IM_LETREC):
{
SCM f, v, e, s;
ls = scm_cons (scm_sym_letrec, SCM_UNSPECIFIED);
}
break;
}
- case (127 & SCM_IM_LETSTAR):
+ case SCM_BIT8(SCM_IM_LETSTAR):
{
SCM b, y;
x = SCM_CDR (x);
ls = scm_cons (scm_sym_letstar, z = scm_cons (y, SCM_UNSPECIFIED));
break;
}
- case (127 & SCM_IM_OR):
+ case SCM_BIT8(SCM_IM_OR):
ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED);
break;
- case (127 & SCM_IM_LAMBDA):
+ case SCM_BIT8(SCM_IM_LAMBDA):
x = SCM_CDR (x);
ls = scm_cons (scm_sym_lambda,
z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED));
env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
break;
- case (127 & SCM_IM_QUOTE):
+ case SCM_BIT8(SCM_IM_QUOTE):
ls = z = scm_cons (scm_sym_quote, SCM_UNSPECIFIED);
break;
- case (127 & SCM_IM_SET_X):
+ case SCM_BIT8(SCM_IM_SET_X):
ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED);
break;
- case (127 & SCM_IM_DEFINE):
+ case SCM_BIT8(SCM_IM_DEFINE):
{
SCM n;
x = SCM_CDR (x);
SCM_SETCAR (SCM_CAR (env), scm_cons (n, SCM_CAR (SCM_CAR (env))));
break;
}
- case (127 & SCM_MAKISYM (0)):
+ case SCM_BIT8(SCM_MAKISYM (0)):
z = SCM_CAR (x);
if (!SCM_ISYMP (z))
goto unmemo;
x = scm_cons (x, SCM_UNDEFINED);
goto retval;
- case (127 & SCM_IM_AND):
+ case SCM_BIT8(SCM_IM_AND):
x = SCM_CDR (x);
t.arg1 = x;
while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop;
- case (127 & SCM_IM_BEGIN):
+ case SCM_BIT8(SCM_IM_BEGIN):
cdrxnoap:
PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
cdrxbegin:
goto loop; /* tail recurse */
- case (127 & SCM_IM_CASE):
+ case SCM_BIT8(SCM_IM_CASE):
x = SCM_CDR (x);
t.arg1 = EVALCAR (x, env);
while (SCM_NIMP (x = SCM_CDR (x)))
RETURN (SCM_UNSPECIFIED)
- case (127 & SCM_IM_COND):
+ case SCM_BIT8(SCM_IM_COND):
while (SCM_NIMP (x = SCM_CDR (x)))
{
proc = SCM_CAR (x);
RETURN (SCM_UNSPECIFIED)
- case (127 & SCM_IM_DO):
+ case SCM_BIT8(SCM_IM_DO):
x = SCM_CDR (x);
proc = SCM_CAR (SCM_CDR (x)); /* inits */
t.arg1 = SCM_EOL; /* values */
goto begin;
- case (127 & SCM_IM_IF):
+ case SCM_BIT8(SCM_IM_IF):
x = SCM_CDR (x);
if (SCM_NFALSEP (EVALCAR (x, env)))
x = SCM_CDR (x);
goto carloop;
- case (127 & SCM_IM_LET):
+ case SCM_BIT8(SCM_IM_LET):
x = SCM_CDR (x);
proc = SCM_CAR (SCM_CDR (x));
t.arg1 = SCM_EOL;
goto cdrxnoap;
- case (127 & SCM_IM_LETREC):
+ case SCM_BIT8(SCM_IM_LETREC):
x = SCM_CDR (x);
env = EXTEND_ENV (SCM_CAR (x), scm_undefineds, env);
x = SCM_CDR (x);
goto cdrxnoap;
- case (127 & SCM_IM_LETSTAR):
+ case SCM_BIT8(SCM_IM_LETSTAR):
x = SCM_CDR (x);
proc = SCM_CAR (x);
if (SCM_IMP (proc))
while (SCM_NIMP (proc = SCM_CDR (proc)));
goto cdrxnoap;
- case (127 & SCM_IM_OR):
+ case SCM_BIT8(SCM_IM_OR):
x = SCM_CDR (x);
t.arg1 = x;
while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1)))
goto carloop;
- case (127 & SCM_IM_LAMBDA):
+ case SCM_BIT8(SCM_IM_LAMBDA):
RETURN (scm_closure (SCM_CDR (x), env));
- case (127 & SCM_IM_QUOTE):
+ case SCM_BIT8(SCM_IM_QUOTE):
RETURN (SCM_CAR (SCM_CDR (x)));
- case (127 & SCM_IM_SET_X):
+ case SCM_BIT8(SCM_IM_SET_X):
x = SCM_CDR (x);
proc = SCM_CAR (x);
switch (7 & (int) proc)
#endif
- case (127 & SCM_IM_DEFINE): /* only for internal defines */
+ case SCM_BIT8(SCM_IM_DEFINE): /* only for internal defines */
scm_misc_error (NULL, "Bad define placement", SCM_EOL);
/* new syntactic forms go here. */
- case (127 & SCM_MAKISYM (0)):
+ case SCM_BIT8(SCM_MAKISYM (0)):
proc = SCM_CAR (x);
SCM_ASRTGO (SCM_ISYMP (proc), badfun);
switch SCM_ISYMNUM (proc)
if (SCM_NIMP (t.arg1))
do
{
- i += (SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1)))
- [scm_si_hashsets + hashset]);
+ i += SCM_ASWORD ((SCM_STRUCT_DATA (scm_class_of (SCM_CAR (t.arg1))))
+ [scm_si_hashsets + hashset]);
t.arg1 = SCM_CDR (t.arg1);
}
while (--j && SCM_NIMP (t.arg1));
RETURN (x);
#ifdef MEMOIZE_LOCALS
- case (127 & SCM_ILOC00):
+ case SCM_BIT8(SCM_ILOC00):
proc = *scm_ilookup (SCM_CAR (x), env);
SCM_ASRTGO (SCM_NIMP (proc), badfun);
#ifndef SCM_RECKLESS
#ifdef DEVAL
SCM_CLEAR_MACROEXP (debug);
#endif
- switch ((int) (SCM_CAR (proc) >> 16))
+ switch ((int) (SCM_CARW (proc) >> 16))
{
case 2:
if (scm_ilength (t.arg1) <= 0)
#define FUNC_NAME s_scm_force
{
SCM_VALIDATE_SMOB (1,x,promise);
- if (!((1L << 16) & SCM_CAR (x)))
+ if (!((1L << 16) & SCM_CARW (x)))
{
SCM ans = scm_apply (SCM_CDR (x), SCM_EOL, SCM_EOL);
- if (!((1L << 16) & SCM_CAR (x)))
+ if (!((1L << 16) & SCM_CARW (x)))
{
SCM_DEFER_INTS;
SCM_SETCDR (x, ans);
#define SCM_IDSTMSK (-SCM_IDINC)
#define SCM_IFRAME(n) ((int)((SCM_ICDR-SCM_IFRINC)>>8) & ((int)(n)>>8))
#define SCM_IDIST(n) (((unsigned long)(n))>>20)
-#define SCM_ICDRP(n) (SCM_ICDR & (n))
+#define SCM_ICDRP(n) (SCM_ICDR & SCM_ASWORD(n))
\f
}
scm_intprint (SCM_HOOK_ARITY (hook), 10, port);
scm_putc (' ', port);
- scm_intprint (hook, 16, port);
+ scm_intprint ((int)hook, 16, port);
ls = SCM_HOOK_PROCEDURES (hook);
while (SCM_NIMP (ls))
{
#include "libguile/__scm.h"
#define SCM_HOOKP(x) (SCM_NIMP(x) && (SCM_TYP16 (x) == scm_tc16_hook))
-#define SCM_HOOK_ARITY(hook) (SCM_CAR (hook) >> 16)
+#define SCM_HOOK_ARITY(hook) (SCM_CARW (hook) >> 16)
#define SCM_HOOK_NAME(hook) SCM_CADR (hook)
#define SCM_HOOK_PROCEDURES(hook) SCM_CDDR (hook)
#define SCM_SET_HOOK_PROCEDURES(hook, procs) SCM_SETCDR (SCM_CDR (hook), procs)
if (SCM_CLOSEDP (exp))
scm_puts ("closed: ", port);
scm_puts ("directory stream ", port);
- scm_intprint (SCM_CDR (exp), 16, port);
+ scm_intprint ((int)SCM_CDR (exp), 16, port);
scm_putc ('>', port);
return 1;
}
extern long scm_tc16_dir;
#define SCM_DIRP(x) (SCM_NIMP(x) && (SCM_TYP16(x)==(scm_tc16_dir)))
-#define SCM_OPDIRP(x) (SCM_NIMP(x) && (SCM_CAR(x)==(scm_tc16_dir | SCM_OPN)))
+#define SCM_OPDIRP(x) (SCM_NIMP(x) && (SCM_CARW(x)==(scm_tc16_dir | SCM_OPN)))
\f
extern SCM scm_chown (SCM object, SCM owner, SCM group);
print_fluid (SCM exp, SCM port, scm_print_state *pstate)
{
scm_puts ("#<fluid ", port);
- scm_intprint (SCM_FLUID_NUM (exp), 10, port);
+ scm_intprint ((int) SCM_FLUID_NUM (exp), 10, port);
scm_putc ('>', port);
return 1;
}
extern long scm_tc16_fluid;
-#define SCM_FLUIDP(x) (SCM_NIMP(x) && (SCM_CAR(x) == scm_tc16_fluid))
-#define SCM_FLUID_NUM(x) SCM_CDR(x)
+#define SCM_FLUIDP(x) (SCM_NIMP(x) && (SCM_CARW (x) == scm_tc16_fluid))
+#define SCM_FLUID_NUM(x) SCM_ASWORD (SCM_CDR(x))
/* The fastest way to acces/modify the value of a fluid. These macros
do no error checking at all. You should only use them when you know
pt->write_end = pt->write_buf + pt->write_buf_size;
if (read_size > 0 || write_size > 0)
- SCM_SETCAR (port, SCM_CAR (port) & ~SCM_BUF0);
+ SCM_SETCAR (port, SCM_CARW (port) & ~SCM_BUF0);
else
- SCM_SETCAR (port, (SCM_CAR (port) | SCM_BUF0));
+ SCM_SETCAR (port, (SCM_CARW (port) | SCM_BUF0));
}
SCM_DEFINE (scm_setvbuf, "setvbuf", 2, 1, 0,
if (cmode == _IOLBF)
{
- SCM_SETCAR (port, SCM_CAR (port) | SCM_BUFLINE);
+ SCM_SETCAR (port, SCM_CARW (port) | SCM_BUFLINE);
cmode = _IOFBF;
}
else
{
- SCM_SETCAR (port, SCM_CAR (port) ^ SCM_BUFLINE);
+ SCM_SETCAR (port, SCM_CARW (port) ^ SCM_BUFLINE);
}
if (SCM_UNBNDP (size))
{
scm_puts (SCM_PTOBNAME (SCM_PTOBNUM (exp)), port);
scm_putc (' ', port);
- scm_intprint (SCM_CDR (exp), 16, port);
+ scm_intprint (SCM_ASWORD (SCM_CDR (exp)), 16, port);
}
scm_putc ('>', port);
return 1;
}
/* 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);
}
}
#define SCM_FPORT_FDES(x) (SCM_FSTREAM (x)->fdes)
#define SCM_FPORTP(x) (SCM_NIMP(x) && (SCM_TYP16S(x)==scm_tc7_port))
-#define SCM_OPFPORTP(x) (SCM_NIMP(x) && (((0xfeff | SCM_OPN) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN)))
-#define SCM_OPINFPORTP(x) (SCM_NIMP(x) && (((0xfeff | SCM_OPN | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG)))
-#define SCM_OPOUTFPORTP(x) (SCM_NIMP(x) && (((0xfeff | SCM_OPN | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG)))
+#define SCM_OPFPORTP(x) (SCM_NIMP(x) && (((0xfeff | SCM_OPN) & SCM_CARW (x))==(scm_tc7_port | SCM_OPN)))
+#define SCM_OPINFPORTP(x) (SCM_NIMP(x) && (((0xfeff | SCM_OPN | SCM_RDNG) & SCM_CARW (x))==(scm_tc7_port | SCM_OPN | SCM_RDNG)))
+#define SCM_OPOUTFPORTP(x) (SCM_NIMP(x) && (((0xfeff | SCM_OPN | SCM_WRTNG) & SCM_CARW (x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG)))
/* test whether fdes supports random access. */
#define SCM_FDES_RANDOM_P(fdes) ((lseek (fdes, 0, SEEK_CUR) == -1) ? 0 : 1)
int i;
int n;
SCM heap_segs;
- SCM local_scm_mtrigger;
- SCM local_scm_mallocated;
- SCM local_scm_heap_size;
- SCM local_scm_cells_allocated;
- SCM local_scm_gc_time_taken;
+ long int local_scm_mtrigger;
+ long int local_scm_mallocated;
+ long int local_scm_heap_size;
+ long int local_scm_cells_allocated;
+ long int local_scm_gc_time_taken;
SCM answer;
SCM_DEFER_INTS;
goto retry;
scm_block_gc = 0;
+ /// ? ?? ?
local_scm_mtrigger = scm_mtrigger;
local_scm_mallocated = scm_mallocated;
local_scm_heap_size = scm_heap_size;
scm_gc_end ()
{
scm_gc_rt = SCM_INUM (scm_get_internal_run_time ()) - scm_gc_rt;
- scm_gc_time_taken = scm_gc_time_taken + scm_gc_rt;
+ scm_gc_time_taken += scm_gc_rt;
scm_system_async_mark (scm_gc_async);
}
{
SCM vcell;
vcell = SCM_CAR (ptr) - 1L;
- switch (SCM_CDR (vcell))
+ switch (SCM_ASWORD (SCM_CDR (vcell)))
{
default:
scm_gc_mark (vcell);
that it removes the mark */
mem = (SCM *)SCM_GCCDR (ptr);
- if (vtable_data[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
+ if (SCM_ASWORD (vtable_data[scm_struct_i_flags]) & SCM_STRUCTF_ENTITY)
{
scm_gc_mark (mem[scm_struct_i_procedure]);
scm_gc_mark (mem[scm_struct_i_setter]);
scm_gc_mark (*mem);
if (fields_desc[x] == 'p')
{
+ int j;
if (SCM_LAYOUT_TAILP (fields_desc[x + 1]))
- for (x = *mem; x; --x)
+ for (j = (long int) *mem; x; --x)
scm_gc_mark (*++mem);
else
scm_gc_mark (*mem);
register SCM_CELLPTR ptr;
while (0 <= --m)
- if SCM_CELLP (*(SCM **) & x[m])
+ if (SCM_CELLP (*(SCM **) (& x[m])))
{
ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & x[m]));
i = 0;
register int i, j;
register SCM_CELLPTR ptr;
- if SCM_CELLP (*(SCM **) & value)
+ if SCM_CELLP (*(SCM **) (& value))
{
ptr = (SCM_CELLPTR) SCM2PTR ((*(SCM **) & value));
i = 0;
SCM vcell;
vcell = SCM_CAR (scmptr) - 1L;
- if ((SCM_CDR (vcell) == 0) || (SCM_CDR (vcell) == 1))
+ if ((SCM_CDR (vcell) == 0) || (SCM_ASWORD (SCM_CDR (vcell)) == 1))
{
scm_struct_free_t free
= (scm_struct_free_t) ((SCM*) vcell)[scm_struct_i_free];
case scm_tc16_flo:
if SCM_GC8MARKP (scmptr)
goto c8mrkcontinue;
- switch ((int) (SCM_CAR (scmptr) >> 16))
+ switch ((int) (SCM_CARW (scmptr) >> 16))
{
case (SCM_IMAG_PART | SCM_REAL_PART) >> 16:
m += sizeof (double);
--incar;
if ( ((name == SCM_BOOL_T) || (SCM_CAR (incar) == name))
&& (SCM_CDR (incar) != 0)
- && (SCM_CDR (incar) != 1))
+ && (SCM_ASWORD (SCM_CDR (incar)) != 1))
{
p->car = name;
}
{ /* empty */ }
+/*
+ What the heck is this? --hwn
+ */
SCM
scm_return_first (SCM elt, ...)
{
even if all other references are dropped, until someone applies
scm_unprotect_object to it. This function returns OBJ.
- Calls to scm_protect_object nest. For every object O, there is a
- counter which scm_protect_object(O) increments and
- scm_unprotect_object(O) decrements, if it is greater than zero. If
+ Calls to scm_protect_object nest. For every object OBJ, there is a
+ counter which scm_protect_object(OBJ) increments and
+ scm_unprotect_object(OBJ) decrements, if it is greater than zero. If
an object's counter is greater than zero, the garbage collector
will not free it.
#include "libguile/__scm.h"
\f
-#define SCM_FREEP(x) (SCM_NIMP(x) && SCM_CAR(x)==scm_tc_free_cell)
+#define SCM_FREEP(x) (SCM_NIMP(x) && SCM_CARW (x)==scm_tc_free_cell)
#define SCM_NFREEP(x) (!SCM_FREEP(x))
/* 1. This shouldn't be used on immediates.
2. It thinks that subrs are always unmarked (harmless). */
-#define SCM_MARKEDP(x) ((SCM_CAR(x) & 5) == 5 \
+#define SCM_MARKEDP(x) ((SCM_CARW (x) & 5) == 5 \
? SCM_GC8MARKP(x) \
: SCM_GCMARKP(x))
#define SCM_NMARKEDP(x) (!SCM_MARKEDP(x))
if (d) return (scm_hasher(SCM_CAR(obj), n, d/2)+scm_hasher(SCM_CDR(obj), n, d/2)) % n;
else return 1;
case scm_tc7_port:
- return ((SCM_RDNG & SCM_CAR(obj)) ? 260 : 261) % n;
+ return ((SCM_RDNG & SCM_CARW(obj)) ? 260 : 261) % n;
case scm_tcs_closures:
case scm_tc7_contin:
case scm_tcs_subrs:
\f
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))
\f
{
if (!(SCM_NIMP (m) && SCM_TYP16 (m) == scm_tc16_macro))
return SCM_BOOL_F;
- switch ((int) (SCM_CAR (m) >> 16))
+ switch ((int) (SCM_CARW (m) >> 16))
{
case 0: return scm_sym_syntax;
case 1: return scm_sym_macro;
prinmalloc (SCM exp,SCM port,scm_print_state *pstate)
{
scm_puts("#<malloc ", port);
- scm_intprint(SCM_CDR(exp), 16, port);
+ scm_intprint((int) SCM_CDR(exp), 16, port);
scm_putc('>', port);
return 1;
}
SCM
scm_abs (SCM x)
{
+ long int cx;
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
#endif
if (SCM_INUM (x) >= 0)
return x;
- x = - SCM_INUM (x);
- if (!SCM_POSFIXABLE (x))
+ cx = - SCM_INUM (x);
+ if (!SCM_POSFIXABLE (cx))
#ifdef SCM_BIGDIG
- return scm_long2big (x);
+ return scm_long2big (cx);
#else
- scm_num_overflow (s_abs);
+ scm_num_overflow (s_abs);
#endif
- return SCM_MAKINUM (x);
+ return SCM_MAKINUM (cx);
}
SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient);
#ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
- long w;
SCM_GASSERT2 (SCM_BIGP (x),
g_quotient, x, y, SCM_ARG1, s_quotient);
if (SCM_NINUMP (y))
z = -z;
if (z < SCM_BIGRAD)
{
- w = scm_copybig (x, SCM_BIGSIGN (x) ? (y > 0) : (y < 0));
- scm_divbigdig (SCM_BDIGITS (w), SCM_NUMDIGS (w), (SCM_BIGDIG) z);
- return scm_normbig (w);
+ SCM sw = scm_copybig (x, SCM_BIGSIGN (x) ? (SCM_ASWORD (y) > 0) : (SCM_ASWORD (y) < 0));
+ scm_divbigdig (SCM_BDIGITS (sw), SCM_NUMDIGS (sw), (SCM_BIGDIG) z);
+ return scm_normbig (sw);
}
+ { /* scope */
#ifndef SCM_DIGSTOOBIG
- w = scm_pseudolong (z);
+ long w = scm_pseudolong (z);
return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
(SCM_BIGDIG *) & w, SCM_DIGSPERLONG,
SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 2);
#else
- {
SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
scm_longdigs (z, zdigs);
return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
zdigs, SCM_DIGSPERLONG,
SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 2);
- }
#endif
+ } /* end scope */
}
if (SCM_NINUMP (y))
{
SCM
scm_gcd (SCM x, SCM y)
{
- register long u, v, k, t;
+ long u, v, k, t;
if (SCM_UNBNDP (y))
return SCM_UNBNDP (x) ? SCM_INUM0 : x;
tailrec:
{
case -1:
swaprec:
- t = scm_remainder (x, y);
- x = y;
- y = t;
+ {
+ SCM t = scm_remainder (x, y);
+ x = y;
+ y = t;
+ }
goto tailrec;
case 0:
return x;
}
if (SCM_NINUMP (y))
{
- t = x;
+ SCM t = x;
x = y;
y = t;
goto big_gcd;
#define FUNC_NAME s_scm_ash
{
/* GJB:FIXME:: what is going on here? */
- SCM res = SCM_INUM (n);
+ SCM res = SCM_ASSCM (SCM_INUM (n));
SCM_VALIDATE_INUM (2,cnt);
#ifdef SCM_BIGDIG
if (cnt < 0)
SCM
scm_mkbig (scm_sizet nlen, int sign)
{
- SCM v = nlen;
- /* Cast to SCM to avoid signed/unsigned comparison warnings. */
- if (((v << 16) >> 16) != (SCM) nlen)
+ SCM v;
+ /* Cast to long int to avoid signed/unsigned comparison warnings. */
+ if ((( ((long int)nlen) << 16) >> 16) != (long int) nlen)
scm_wta (SCM_MAKINUM (nlen), (char *) SCM_NALLOC, s_bignum);
+
SCM_NEWCELL (v);
SCM_DEFER_INTS;
SCM_SETCHARS (v, scm_must_malloc ((long) (nlen * sizeof (SCM_BIGDIG)),
{
num = 1;
i = 0;
- SCM_SETCAR (z, SCM_CAR (z) ^ 0x0100);
+ SCM_SETCAR (z, SCM_CARW (z) ^ 0x0100);
do
{
num += (SCM_BIGRAD - 1) - zds[i];
SCM_GASSERT1 (SCM_INUMP (x), g_positive_p, x, SCM_ARG1, s_positive_p);
#endif
#endif
- return SCM_BOOL(x > SCM_INUM0);
+ return SCM_BOOL(SCM_INUM(x) > 0);
}
SCM_GASSERT1 (SCM_INUMP (x), g_negative_p, x, SCM_ARG1, s_negative_p);
#endif
#endif
- return SCM_BOOL(x < SCM_INUM0);
+ return SCM_BOOL(SCM_INUM(x) < 0);
}
}
+#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_sum, "+", scm_tc7_asubr, scm_sum, g_sum);
+/*
+ This is sick, sick, sick code.
+
+ */
SCM
scm_sum (SCM x, SCM y)
{
#ifdef SCM_FLOATS
if (SCM_NINUMP (x))
{
- SCM t;
-#ifdef SCM_BIGDIG
+# ifdef SCM_BIGDIG
if (!SCM_NIMP (x))
{
badx2:
{
if (SCM_INUMP (y))
{
- t = x;
- x = y;
- y = t;
+ SCM_SWAP(x,y);
goto intbig;
}
SCM_ASRTGO (SCM_NIMP (y), bady);
{
if (SCM_NUMDIGS (x) > SCM_NUMDIGS (y))
{
- t = x;
- x = y;
- y = t;
+ SCM_SWAP(x,y);
}
return scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
SCM_BIGSIGN (x),
return scm_makdbl (scm_big2dbl (x) + SCM_REALPART (y),
SCM_CPLXP (y) ? SCM_IMAG (y) : 0.0);
}
+# endif /* SCM_BIGDIG */
SCM_ASRTGO (SCM_INEXP (x), badx2);
-#else
- SCM_ASRTGO (SCM_INEXP (x), badx2);
-#endif
+
if (SCM_INUMP (y))
{
- t = x;
- x = y;
- y = t;
+ SCM_SWAP(x,y);
goto intreal;
}
-#ifdef SCM_BIGDIG
+# ifdef SCM_BIGDIG
SCM_ASRTGO (SCM_NIMP (y), bady);
if (SCM_BIGP (y))
{
- t = x;
- x = y;
- y = t;
+ SCM_SWAP(x,y);
goto bigreal;
}
else if (!SCM_INEXP (y))
bady:
SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
-#else
+# else /* SCM_BIGDIG */
if (!SCM_INEXP (y))
{
bady:
SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
}
-#endif
+# endif /* SCM_BIGDIG */
{
double i = 0.0;
if (SCM_CPLXP (x))
}
if (SCM_NINUMP (y))
{
-#ifdef SCM_BIGDIG
+# ifdef SCM_BIGDIG
SCM_ASRTGO (SCM_NIMP (y), bady);
if (SCM_BIGP (y))
{
intbig:
{
-#ifndef SCM_DIGSTOOBIG
+# ifndef SCM_DIGSTOOBIG
long z = scm_pseudolong (SCM_INUM (x));
return scm_addbig ((SCM_BIGDIG *) & z,
SCM_DIGSPERLONG,
(x < 0) ? 0x0100 : 0,
y, 0);
-#else
+# else /* SCM_DIGSTOOBIG */
SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
scm_longdigs (SCM_INUM (x), zdigs);
return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0,
y, 0);
-#endif
+# endif /* SCM_DIGSTOOBIG */
}
}
+# endif /* SCM_BIGDIG */
SCM_ASRTGO (SCM_INEXP (y), bady);
-#else
- SCM_ASRTGO (SCM_INEXP (y), bady);
-#endif
intreal:
return scm_makdbl (SCM_INUM (x) + SCM_REALPART (y),
SCM_CPLXP (y) ? SCM_IMAG (y) : 0.0);
}
-#else
-#ifdef SCM_BIGDIG
+#else /* SCM_FLOATS */
+# ifdef SCM_BIGDIG
if (SCM_NINUMP (x))
{
SCM t;
SCM_ASRTGO (SCM_BIGP (x), badx2);
if (SCM_INUMP (y))
{
- t = x;
- x = y;
- y = t;
+ SCM_SWAP(x,y);
goto intbig;
}
SCM_ASRTGO (SCM_BIGP (y), bady);
if (SCM_NUMDIGS (x) > SCM_NUMDIGS (y))
- {
- t = x;
- x = y;
- y = t;
- }
+ SCM_SWAP(x,y);
return scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), SCM_BIGSIGN (x),
y, 0);
}
}
intbig:
{
-#ifndef SCM_DIGSTOOBIG
+# ifndef SCM_DIGSTOOBIG
long z = scm_pseudolong (SCM_INUM (x));
return scm_addbig (&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
-#else
+# else
SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
scm_longdigs (SCM_INUM (x), zdigs);
return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
-#endif
+# endif /* SCM_DIGSTOOBIG */
}
}
-#else
+# else /* SCM_BIGDIG */
SCM_ASRTGO (SCM_INUMP (x), badx2);
SCM_GASSERT2 (SCM_INUMP (y), g_sum, x, y, SCM_ARGn, s_sum);
-#endif
-#endif
- x = SCM_INUM (x) + SCM_INUM (y);
- if (SCM_FIXABLE (x))
- return SCM_MAKINUM (x);
+# endif/* SCM_BIGDIG */
+#endif /* SCM_FLOATS */
+
+ { /* scope */
+ long int i = SCM_INUM (x) + SCM_INUM (y);
+ if (SCM_FIXABLE (i))
+ return SCM_MAKINUM (i);
#ifdef SCM_BIGDIG
- return scm_long2big (x);
-#else
-#ifdef SCM_FLOATS
- return scm_makdbl ((double) x, 0.0);
-#else
- scm_num_overflow (s_sum);
- return SCM_UNSPECIFIED;
-#endif
-#endif
+ return scm_long2big (i);
+#else /* SCM_BIGDIG */
+
+# ifdef SCM_FLOATS
+ return scm_makdbl ((double) i, 0.0);
+# else
+ scm_num_overflow (s_sum);
+ return SCM_UNSPECIFIED;
+# endif/* SCM_FLOATS */
+#endif /* SCM_BIGDIG */
+ } /* end scope */
}
SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference);
+/*
+ HWN:FIXME:: This is sick,sick, sick code. Rewrite me.
+*/
SCM
scm_difference (SCM x, SCM y)
{
+ long int cx = 0;
#ifdef SCM_FLOATS
if (SCM_NINUMP (x))
{
- if (!(SCM_NIMP (x)))
+ if (!SCM_NIMP (x))
{
if (SCM_UNBNDP (y))
{
}
if (SCM_UNBNDP (y))
{
- x = -SCM_INUM (x);
+ cx = -SCM_INUM (x);
goto checkx;
}
if (SCM_NINUMP (y))
SCM_GASSERT2 (SCM_INUMP (x), g_difference, x, y, SCM_ARG1, s_difference);
if (SCM_UNBNDP (y))
{
- x = -SCM_INUM (x);
+ cx = -SCM_INUM (x);
goto checkx;
}
SCM_GASSERT2 (SCM_INUMP (y), g_difference, x, y, SCM_ARGn, s_difference);
#endif
#endif
- x = SCM_INUM (x) - SCM_INUM (y);
+ cx = SCM_INUM (x) - SCM_INUM (y);
checkx:
- if (SCM_FIXABLE (x))
- return SCM_MAKINUM (x);
+ if (SCM_FIXABLE (cx))
+ return SCM_MAKINUM (cx);
#ifdef SCM_BIGDIG
- return scm_long2big (x);
+ return scm_long2big (cx);
#else
#ifdef SCM_FLOATS
- return scm_makdbl ((double) x, 0.0);
+ return scm_makdbl ((double) cx, 0.0);
#else
scm_num_overflow (s_difference);
return SCM_UNSPECIFIED;
return scm_big2dbl (a);
#endif
SCM_ASSERT (0, a, "wrong type argument", why);
- return SCM_UNSPECIFIED;
+ /*
+ unreachable, hopefully.
+ */
+ return (double) 0.0; /* ugh. */
+ /* return SCM_UNSPECIFIED; */
}
#ifdef SCM_BIGDIG
if (SCM_BIGP (x))
{
- SCM z;
if (SCM_INUMP (y))
{
- z = SCM_INUM (y);
+ long int z = SCM_INUM (y);
#ifndef SCM_RECKLESS
if (!z)
scm_num_overflow (s_divide);
: scm_normbig (w));
}
#ifndef SCM_DIGSTOOBIG
+ /*ugh! Does anyone know what this is supposed to do?*/
z = scm_pseudolong (z);
- z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
- (SCM_BIGDIG *) & z, SCM_DIGSPERLONG,
- SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3);
+ z = SCM_INUM(scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
+ (SCM_BIGDIG *) & z, SCM_DIGSPERLONG,
+ SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3));
#else
{
SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3);
}
#endif
- return z ? z : scm_makdbl (scm_big2dbl (x) / SCM_INUM (y), 0.0);
+ return z ? SCM_ASSCM (z) : scm_makdbl (scm_big2dbl (x) / SCM_INUM (y), 0.0);
}
SCM_ASRTGO (SCM_NIMP (y), bady);
if (SCM_BIGP (y))
{
- z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
+ SCM z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
SCM_BDIGITS (y), SCM_NUMDIGS (y),
SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 3);
return z ? z : scm_makdbl (scm_big2dbl (x) / scm_big2dbl (y),
/* shifts of more than one are done by a library call, single shifts are
* performed in registers
*/
-# define SCM_MAKINUM(x) ((((x)<<1)<<1)+2L)
+# define SCM_MAKINUM(x) ((SCM) (((SCM_ASWORD(x)<<1)<<1)+2L))
#else
-# define SCM_MAKINUM(x) (((x)<<2)+2L)
+# define SCM_MAKINUM(x) ((SCM)((SCM_ASWORD(x)<<2)+2L))
#endif /* def __TURBOC__ */
/* SCM_SRS is signed right shift */
+/* SCM_INUM makes a C int from an SCM immediate number. */
/* Turbo C++ v1.0 has a bug with right shifts of signed longs!
* It is believed to be fixed in Turbo C++ v1.01
*/
#if (-1==(((-1)<<2)+2)>>2) && (__TURBOC__ != 0x295)
-# define SCM_SRS(x, y) ((x)>>y)
+# define SCM_SRS(x, y) (SCM_ASWORD (x)>>y)
# ifdef __TURBOC__
-# define SCM_INUM(x) (((x)>>1)>>1)
+# define SCM_INUM(x) ((SCM_ASWORD(x) >>1) >>1)
# else
# define SCM_INUM(x) SCM_SRS(x, 2)
# endif /* def __TURBOC__ */
#else
-# define SCM_SRS(x, y) (((x)<0) ? ~((~(x))>>y) : (x)>>y)
+# define SCM_SRS(x, y) ((SCM_ASWORD(x) < 0) ? ~( (~SCM_ASWORD(x)) >>y) : (SCM_ASWORD (x)>>y))
# define SCM_INUM(x) SCM_SRS(x, 2)
#endif /* (-1==(((-1)<<2)+2)>>2) && (__TURBOC__ != 0x295) */
*/
#define SCM_INEXP(x) (SCM_NIMP(x) && (SCM_TYP16(x)==scm_tc16_flo))
-#define SCM_CPLXP(x) (SCM_NIMP(x) && (SCM_CAR(x)==scm_tc_dblc))
+#define SCM_CPLXP(x) (SCM_NIMP(x) && (SCM_CARW (x)==scm_tc_dblc))
#define SCM_REAL(x) (*(((scm_dbl *) (SCM2PTR(x)))->real))
#define SCM_IMAG(x) (*((double *)(SCM_CHARS(x)+sizeof(double))))
/* ((&SCM_REAL(x))[1]) */
#ifdef SCM_SINGLES
-#define SCM_REALP(x) (SCM_NIMP(x) && ((~SCM_REAL_PART & SCM_CAR(x))==scm_tc_flo))
-#define SCM_SINGP(x) (SCM_NIMP(x) && (SCM_CAR(x)==scm_tc_flo))
+#define SCM_REALP(x) (SCM_NIMP(x) && ((~SCM_REAL_PART & SCM_CARW (x))==scm_tc_flo))
+#define SCM_SINGP(x) (SCM_NIMP(x) && (SCM_CARW (x)==scm_tc_flo))
#define SCM_FLO(x) (((scm_flo *)(SCM2PTR(x)))->num)
#define SCM_REALPART(x) (SCM_SINGP(x)?0.0+SCM_FLO(x):SCM_REAL(x))
#else /* SCM_SINGLES */
#define SCM_BIGP(x) (SCM_NIMP(x) && SCM_TYP16S(x)==scm_tc16_bigpos)
#define SCM_BIGSIGN(x) (0x0100 & (int)SCM_CAR(x))
#define SCM_BDIGITS(x) ((SCM_BIGDIG *)(SCM_CDR(x)))
-#define SCM_NUMDIGS(x) ((scm_sizet)(SCM_CAR(x)>>16))
+#define SCM_NUMDIGS(x) ((scm_sizet)(SCM_CARW (x)>>16))
#define SCM_SETNUMDIGS(x, v, t) SCM_SETCAR(x, (((v)+0L)<<16)+(t))
\f
case scm_tc7_smob:
{
- SCM type = SCM_TYP16 (x);
+ long type = SCM_TYP16 (x);
if (type == scm_tc16_flo)
{
- if (SCM_CAR (x) & SCM_IMAG_PART)
+ if (SCM_CARW (x) & SCM_IMAG_PART)
return scm_class_complex;
else
return scm_class_real;
/* fall through to ports */
}
case scm_tc7_port:
- return scm_port_class[(SCM_WRTNG & SCM_CAR (x)
- ? (SCM_RDNG & SCM_CAR (x)
+ return scm_port_class[(SCM_WRTNG & SCM_CARW (x)
+ ? (SCM_RDNG & SCM_CARW (x)
? SCM_INOUT_PCLASS_INDEX | SCM_PTOBNUM (x)
: SCM_OUT_PCLASS_INDEX | SCM_PTOBNUM (x))
: SCM_IN_PCLASS_INDEX | SCM_PTOBNUM (x))];
if (SCM_NIMP (ls))
do
{
- i += (SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls)))
+ i += SCM_ASWORD (SCM_STRUCT_DATA (scm_class_of (SCM_CAR (ls)))
[scm_si_hashsets + hashset]);
ls = SCM_CDR (ls);
}
* certain class or its subclasses when traversal of the inheritance
* graph would be too costly.
*/
-#define SCM_CLASS_FLAGS(class) (SCM_STRUCT_DATA (class)[scm_struct_i_flags])
+#define SCM_CLASS_FLAGS(class) SCM_ASWORD(SCM_STRUCT_DATA (class)[scm_struct_i_flags])
#define SCM_OBJ_CLASS_FLAGS(obj)\
-(SCM_STRUCT_VTABLE_DATA (obj)[scm_struct_i_flags])
+ SCM_ASWORD(SCM_STRUCT_VTABLE_DATA (obj)[scm_struct_i_flags])
#define SCM_SET_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) |= (f))
#define SCM_CLEAR_CLASS_FLAGS(c, f) (SCM_CLASS_FLAGS (c) &= ~(f))
#define SCM_CLASSF_MASK SCM_STRUCTF_MASK
#define SCM_CLASSF_OPERATOR (1L << 29)
#define SCM_I_OPERATORP(obj)\
-((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) != 0)
+ ((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_OPERATOR) != 0)
#define SCM_OPERATOR_CLASS(obj)\
((struct scm_metaclass_operator *) SCM_STRUCT_DATA (obj))
#define SCM_OBJ_OPERATOR_CLASS(obj)\
#define SCM_OPERATOR_SETTER(obj) (SCM_OBJ_OPERATOR_CLASS (obj)->setter)
#define SCM_I_ENTITYP(obj)\
-((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_ENTITY) != 0)
+ ((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_ENTITY) != 0)
#define SCM_ENTITY_PROCEDURE(obj) \
(SCM_STRUCT_DATA (obj)[scm_struct_i_procedure])
#define SCM_ENTITY_SETTER(obj) (SCM_STRUCT_DATA (obj)[scm_struct_i_setter])
goto cont;
case SCM_OPTION_SCM:
new_mode = SCM_CDR (new_mode);
- flags[i] = SCM_CAR (new_mode);
+ flags[i] = SCM_CARW (new_mode);
goto cont;
}
#ifndef SCM_RECKLESS
}
for (i = 0; i < n; ++i)
{
+ // scm_option doesn't know if its a long or an SCM
if (options[i].type == SCM_OPTION_SCM)
SCM_SETCDR (protected_objects,
scm_cons (flags[i],
{
int type;
char *name;
+
+ /*
+ schizophrenic use: both SCM and int
+ */
unsigned long val;
+ // SCM val
char *doc;
} scm_option;
#define SCM_CAR(x) (((scm_cell *)(SCM2PTR(x)))->car)
#define SCM_CDR(x) (((scm_cell *)(SCM2PTR(x)))->cdr)
-#define SCM_GCCDR(x) (~1L & SCM_CDR(x))
-#define SCM_SETCAR(x, v) (SCM_CAR(x) = (SCM)(v))
-#define SCM_SETCDR(x, v) (SCM_CDR(x) = (SCM)(v))
+#define SCM_GCCDR(x) SCM_ASSCM(~1L & SCM_ASWORD (SCM_CDR(x)))
+#define SCM_SETCAR(x, v) (SCM_CAR(x) = SCM_ASSCM(v))
+#define SCM_SETCDR(x, v) (SCM_CDR(x) = SCM_ASSCM(v))
#define SCM_CARLOC(x) (&SCM_CAR (x))
#define SCM_CDRLOC(x) (&SCM_CDR (x))
-#define SCM_SETAND_CAR(x, y) (SCM_CAR (x) &= (y))
-#define SCM_SETAND_CDR(x, y) (SCM_CDR (x) &= (y))
-#define SCM_SETOR_CAR(x, y) (SCM_CAR (x) |= (y))
-#define SCM_SETOR_CDR(x, y) (SCM_CDR (x) |= (y))
+#define SCM_SETAND_CAR(x, y) (SCM_CARW (x) &= (y))
+#define SCM_SETAND_CDR(x, y) (SCM_ASWORD (SCM_CDR (x)) &= (y))
+#define SCM_SETOR_CAR(x, y) (SCM_CARW (x) |= (y))
+#define SCM_SETOR_CDR(x, y) (SCM_ASWORD (SCM_CDR (x)) |= (y))
#define SCM_CAAR(OBJ) SCM_CAR (SCM_CAR (OBJ))
#define SCM_CDAR(OBJ) SCM_CDR (SCM_CAR (OBJ))
scm_markstream (SCM ptr)
{
int openp;
- openp = SCM_CAR (ptr) & SCM_OPN;
+ openp = SCM_CARW (ptr) & SCM_OPN;
if (openp)
return SCM_STREAM (ptr);
else
port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPPORT (1,port);
- if (SCM_CAR (port) & SCM_RDNG) {
- if (SCM_CAR (port) & SCM_WRTNG)
+ if (SCM_CARW (port) & SCM_RDNG) {
+ if (SCM_CARW (port) & SCM_WRTNG)
strcpy (modes, "r+");
else
strcpy (modes, "r");
}
- else if (SCM_CAR (port) & SCM_WRTNG)
+ else if (SCM_CARW (port) & SCM_WRTNG)
strcpy (modes, "w");
- if (SCM_CAR (port) & SCM_BUF0)
+ if (SCM_CARW (port) & SCM_BUF0)
strcat (modes, "0");
return scm_makfromstr (modes, strlen (modes), 0);
}
{
scm_puts (SCM_CLOSEDP (exp)
? "closed: "
- : (SCM_RDNG & SCM_CAR (exp)
- ? (SCM_WRTNG & SCM_CAR (exp)
+ : (SCM_RDNG & SCM_CARW (exp)
+ ? (SCM_WRTNG & SCM_CARW (exp)
? "input-output: "
: "input: ")
- : (SCM_WRTNG & SCM_CAR (exp)
+ : (SCM_WRTNG & SCM_CARW (exp)
? "output: "
: "bogus: ")),
port);
scm_print_port_mode (exp, port);
scm_puts (type, port);
scm_putc (' ', port);
- scm_intprint (SCM_CDR (exp), 16, port);
+ scm_intprint ((int) SCM_CDR (exp), 16, port);
scm_putc ('>', port);
return 1;
}
#define SCM_BUFLINE (64L<<16) /* Is it line-buffered? */
#define SCM_PORTP(x) (SCM_NIMP(x) && (SCM_TYP7(x)==scm_tc7_port))
-#define SCM_OPPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN)))
-#define SCM_OPINPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG)))
-#define SCM_OPOUTPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG)))
-#define SCM_INPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_RDNG) & SCM_CAR(x))==(scm_tc7_port | SCM_RDNG)))
-#define SCM_OUTPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_WRTNG) & SCM_CAR(x))==(scm_tc7_port | SCM_WRTNG)))
-#define SCM_OPENP(x) (SCM_NIMP(x) && (SCM_OPN & SCM_CAR(x)))
+#define SCM_OPPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN) & SCM_CARW(x))==(scm_tc7_port | SCM_OPN)))
+#define SCM_OPINPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN | SCM_RDNG) & SCM_CARW(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG)))
+#define SCM_OPOUTPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN | SCM_WRTNG) & SCM_CARW(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG)))
+#define SCM_INPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_RDNG) & SCM_CARW(x))==(scm_tc7_port | SCM_RDNG)))
+#define SCM_OUTPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_WRTNG) & SCM_CARW(x))==(scm_tc7_port | SCM_WRTNG)))
+#define SCM_OPENP(x) (SCM_NIMP(x) && (SCM_OPN & SCM_CARW (x)))
#define SCM_CLOSEDP(x) (!SCM_OPENP(x))
#define SCM_PTAB_ENTRY(x) ((scm_port *) SCM_CDR(x))
#define SCM_SETPTAB_ENTRY(x,ent) SCM_SETCDR ((x), (SCM)(ent))
} scm_ptob_descriptor;
-#define SCM_TC2PTOBNUM(x) (0x0ff & ((x) >> 8))
+#define SCM_TC2PTOBNUM(x) (0x0ff & (SCM_ASWORD(x) >> 8))
#define SCM_PTOBNUM(x) (SCM_TC2PTOBNUM (SCM_CAR (x)))
/* SCM_PTOBNAME can be 0 if name is missing */
#define SCM_PTOBNAME(ptobnum) scm_ptobs[ptobnum].name
env = SCM_ENV (SCM_CDR (exp));
scm_puts ("#<", port);
}
- if (SCM_CAR (exp) & (3L << 16))
+ if (SCM_CARW(exp) & (3L << 16))
scm_puts ("macro", port);
else
scm_puts ("syntax", port);
- if (SCM_CAR (exp) & (2L << 16))
+ if (SCM_CARW (exp) & (2L << 16))
scm_putc ('!', port);
}
else
if (SCM_CELLP (ptr))
{
scm_puts (" (0x", port);
- scm_intprint (SCM_CAR (ptr), 16, port);
+ scm_intprint ((int) SCM_CAR (ptr), 16, port);
scm_puts (" . 0x", port);
- scm_intprint (SCM_CDR (ptr), 16, port);
+ scm_intprint ((int) SCM_CDR (ptr), 16, port);
scm_puts (") @", port);
}
scm_puts (" 0x", port);
- scm_intprint (ptr, 16, port);
+ scm_intprint ((int) ptr, 16, port);
scm_putc ('>', port);
}
extern SCM scm_print_state_vtable;
-extern SCM scm_tc16_port_with_ps;
+// ? scm or long? print.h and print.c disagree
+extern long scm_tc16_port_with_ps;
extern SCM scm_print_options (SCM setting);
SCM scm_make_print_state (void);
SCM documentation;
} scm_subr_entry;
-#define SCM_SUBRNUM(subr) (SCM_CAR (subr) >> 8)
+#define SCM_SUBRNUM(subr) (SCM_CARW (subr) >> 8)
#define SCM_SET_SUBRNUM(subr, num) \
SCM_SETCAR (subr, (num >> 8) + SCM_TYP7 (subr))
#define SCM_SUBR_ENTRY(x) (scm_subr_table[SCM_SUBRNUM (x)])
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
+/*
+ HWN:FIXME::
+ Someone should rename this to arraymap.c; that would reflect the
+ contents better. */
\f
#include "ramap.h"
\f
-#define SCM_RAMAPC(ramap,proc,ra0,lra) do { scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME); } while (0)
-
typedef struct
{
char *name;
};
-#define BVE_REF(a, i) ((SCM_VELTS(a)[(i)/SCM_LONG_BIT] & (1L<<((i)%SCM_LONG_BIT))) ? 1 : 0)
-#define BVE_SET(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] |= (1L<<((i)%SCM_LONG_BIT)))
-#define BVE_CLR(a, i) (SCM_VELTS(a)[(i)/SCM_LONG_BIT] &= ~(1L<<((i)%SCM_LONG_BIT)))
/* Fast, recycling scm_vector ref */
#define RVREF(ra, i, e) (e = scm_cvref(ra, i, e))
/* inds must be a uvect or ivect, no check. */
+
+/*
+ Yes, this is really ugly, but it prevents multiple code
+ */
+#define BINARY_ELTS_CODE(OPERATOR, type) \
+do { type *v0 = (type*)SCM_VELTS (ra0);\
+ type *v1 = (type*)SCM_VELTS (ra1);\
+ IVDEP (ra0 != ra1, \
+ for (; n-- > 0; i0 += inc0, i1 += inc1) \
+ v0[i0] OPERATOR v1[i1];) \
+ break; \
+} while (0)
+
+/* This macro is used for all but binary division and
+ multiplication of complex numbers -- see the expanded
+ version in the functions later in this file */
+#define BINARY_PAIR_ELTS_CODE(OPERATOR, type) \
+do { type (*v0)[2] = (type (*)[2]) SCM_VELTS (ra0);\
+ type (*v1)[2] = (type (*)[2]) SCM_VELTS (ra1);\
+ IVDEP (ra0 != ra1, \
+ for (; n-- > 0; i0 += inc0, i1 += inc1) {\
+ v0[i0][0] OPERATOR v1[i1][0]; \
+ v0[i0][1] OPERATOR v1[i1][1]; \
+ }) \
+ break; \
+} while (0)
+
+#define UNARY_ELTS_CODE(OPERATOR, type) \
+ do { type *v0 = (type *) SCM_VELTS (ra0);\
+ for (; n-- > 0; i0 += inc0) \
+ v0[i0] OPERATOR v0[i0];\
+ break;\
+ } while (0)
+
+
+/* This macro is used for all but unary divison
+ of complex numbers -- see the expanded version in the
+ function later in this file. */
+#define UNARY_PAIR_ELTS_CODE(OPERATOR, type) \
+ do { type (*v0)[2] = (type (*)[2]) SCM_VELTS (ra0);\
+ for (; n-- > 0; i0 += inc0) {\
+ v0[i0][0] OPERATOR v0[i0][0];\
+ v0[i0][1] OPERATOR v0[i0][1];\
+ }\
+ break;\
+ } while (0)
+
static scm_sizet
cind (SCM ra, SCM inds)
{
scm_sizet i;
int k;
- long *ve = SCM_VELTS (inds);
+ long *ve = (long*) SCM_VELTS (inds);
if (!SCM_ARRAYP (ra))
return *ve;
i = SCM_ARRAY_BASE (ra);
int exact = 2 /* 4 */ ; /* Don't care about values >2 (yet?) */
if (SCM_IMP (ra0)) return 0;
switch (SCM_TYP7 (ra0))
- {
- default:
- return 0;
- case scm_tc7_vector:
- case scm_tc7_wvect:
- case scm_tc7_string:
- case scm_tc7_byvect:
- case scm_tc7_bvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_svect:
+ {
+ default:
+ return 0;
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ case scm_tc7_string:
+ case scm_tc7_byvect:
+ case scm_tc7_bvect:
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ case scm_tc7_svect:
#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
+ case scm_tc7_llvect:
#endif
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- s0->lbnd = 0;
- s0->inc = 1;
- s0->ubnd = (long) SCM_LENGTH (ra0) - 1;
- break;
- case scm_tc7_smob:
- if (!SCM_ARRAYP (ra0))
- return 0;
- ndim = SCM_ARRAY_NDIM (ra0);
- s0 = SCM_ARRAY_DIMS (ra0);
- bas0 = SCM_ARRAY_BASE (ra0);
- break;
- }
+ case scm_tc7_fvect:
+ case scm_tc7_dvect:
+ case scm_tc7_cvect:
+ s0->lbnd = 0;
+ s0->inc = 1;
+ s0->ubnd = (long) SCM_LENGTH (ra0) - 1;
+ break;
+ case scm_tc7_smob:
+ if (!SCM_ARRAYP (ra0))
+ return 0;
+ ndim = SCM_ARRAY_NDIM (ra0);
+ s0 = SCM_ARRAY_DIMS (ra0);
+ bas0 = SCM_ARRAY_BASE (ra0);
+ break;
+ }
while (SCM_NIMP (ras))
- {
- ra1 = SCM_CAR (ras);
- if (SCM_IMP (ra1))
- return 0;
- switch SCM_TYP7
- (ra1)
- {
- default:
- return 0;
- case scm_tc7_vector:
- case scm_tc7_wvect:
- case scm_tc7_string:
- case scm_tc7_byvect:
- case scm_tc7_bvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_svect:
+ {
+ ra1 = SCM_CAR (ras);
+ if (SCM_IMP (ra1))
+ return 0;
+ switch SCM_TYP7
+ (ra1)
+ {
+ default:
+ return 0;
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ case scm_tc7_string:
+ case scm_tc7_byvect:
+ case scm_tc7_bvect:
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ case scm_tc7_svect:
#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
+ case scm_tc7_llvect:
#endif
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- if (1 != ndim)
- return 0;
- switch (exact)
- {
- case 4:
- if (0 != bas0)
- exact = 3;
- case 3:
- if (1 != s0->inc)
- exact = 2;
- case 2:
- if ((0 == s0->lbnd) && (s0->ubnd == SCM_LENGTH (ra1) - 1))
- break;
- exact = 1;
- case 1:
- if (s0->lbnd < 0 || s0->ubnd >= SCM_LENGTH (ra1))
- return 0;
- }
- break;
- case scm_tc7_smob:
- if (!SCM_ARRAYP (ra1) || ndim != SCM_ARRAY_NDIM (ra1))
- return 0;
- s1 = SCM_ARRAY_DIMS (ra1);
- if (bas0 != SCM_ARRAY_BASE (ra1))
+ case scm_tc7_fvect:
+ case scm_tc7_dvect:
+ case scm_tc7_cvect:
+ if (1 != ndim)
+ return 0;
+ switch (exact)
+ {
+ case 4:
+ if (0 != bas0)
exact = 3;
- for (i = 0; i < ndim; i++)
- switch (exact)
- {
- case 4:
- case 3:
- if (s0[i].inc != s1[i].inc)
- exact = 2;
- case 2:
- if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd)
- break;
- exact = 1;
- default:
- if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
- return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
- }
- break;
+ case 3:
+ if (1 != s0->inc)
+ exact = 2;
+ case 2:
+ if ((0 == s0->lbnd) && (s0->ubnd == SCM_LENGTH (ra1) - 1))
+ break;
+ exact = 1;
+ case 1:
+ if (s0->lbnd < 0 || s0->ubnd >= SCM_LENGTH (ra1))
+ return 0;
}
- ras = SCM_CDR (ras);
- }
+ break;
+ case scm_tc7_smob:
+ if (!SCM_ARRAYP (ra1) || ndim != SCM_ARRAY_NDIM (ra1))
+ return 0;
+ s1 = SCM_ARRAY_DIMS (ra1);
+ if (bas0 != SCM_ARRAY_BASE (ra1))
+ exact = 3;
+ for (i = 0; i < ndim; i++)
+ switch (exact)
+ {
+ case 4:
+ case 3:
+ if (s0[i].inc != s1[i].inc)
+ exact = 2;
+ case 2:
+ if (s0[i].lbnd == s1[i].lbnd && s0[i].ubnd == s1[i].ubnd)
+ break;
+ exact = 1;
+ default:
+ if (s0[i].lbnd < s1[i].lbnd || s0[i].ubnd > s1[i].ubnd)
+ return (s0[i].lbnd <= s0[i].ubnd ? 0 : 1);
+ }
+ break;
+ }
+ ras = SCM_CDR (ras);
+ }
return exact;
}
return (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra));
case 1:
gencase: /* Have to loop over all dimensions. */
- vra0 = scm_make_ra (1);
- if (SCM_ARRAYP (ra0))
+ vra0 = scm_make_ra (1);
+ if (SCM_ARRAYP (ra0))
+ {
+ kmax = SCM_ARRAY_NDIM (ra0) - 1;
+ if (kmax < 0)
{
- kmax = SCM_ARRAY_NDIM (ra0) - 1;
- if (kmax < 0)
- {
- SCM_ARRAY_DIMS (vra0)->lbnd = 0;
- SCM_ARRAY_DIMS (vra0)->ubnd = 0;
- SCM_ARRAY_DIMS (vra0)->inc = 1;
- }
- else
- {
- SCM_ARRAY_DIMS (vra0)->lbnd = SCM_ARRAY_DIMS (ra0)[kmax].lbnd;
- SCM_ARRAY_DIMS (vra0)->ubnd = SCM_ARRAY_DIMS (ra0)[kmax].ubnd;
- SCM_ARRAY_DIMS (vra0)->inc = SCM_ARRAY_DIMS (ra0)[kmax].inc;
- }
- SCM_ARRAY_BASE (vra0) = SCM_ARRAY_BASE (ra0);
- SCM_ARRAY_V (vra0) = SCM_ARRAY_V (ra0);
+ SCM_ARRAY_DIMS (vra0)->lbnd = 0;
+ SCM_ARRAY_DIMS (vra0)->ubnd = 0;
+ SCM_ARRAY_DIMS (vra0)->inc = 1;
}
- else
- {
- kmax = 0;
- SCM_ARRAY_DIMS (vra0)->lbnd = 0;
- SCM_ARRAY_DIMS (vra0)->ubnd = SCM_LENGTH (ra0) - 1;
- SCM_ARRAY_DIMS (vra0)->inc = 1;
- SCM_ARRAY_BASE (vra0) = 0;
- SCM_ARRAY_V (vra0) = ra0;
- ra0 = vra0;
- }
- lvra = SCM_EOL;
- plvra = &lvra;
- for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
- {
- ra1 = SCM_CAR (z);
- vra1 = scm_make_ra (1);
- SCM_ARRAY_DIMS (vra1)->lbnd = SCM_ARRAY_DIMS (vra0)->lbnd;
- SCM_ARRAY_DIMS (vra1)->ubnd = SCM_ARRAY_DIMS (vra0)->ubnd;
- if (SCM_ARRAYP (ra1))
- {
- if (kmax >= 0)
- SCM_ARRAY_DIMS (vra1)->inc = SCM_ARRAY_DIMS (ra1)[kmax].inc;
- SCM_ARRAY_V (vra1) = SCM_ARRAY_V (ra1);
- }
- else
- {
- SCM_ARRAY_DIMS (vra1)->inc = 1;
- SCM_ARRAY_V (vra1) = ra1;
- }
- *plvra = scm_cons (vra1, SCM_EOL);
- plvra = SCM_CDRLOC (*plvra);
- }
- inds = scm_make_uve (SCM_ARRAY_NDIM (ra0), SCM_MAKINUM (-1L));
- vinds = (long *) SCM_VELTS (inds);
- for (k = 0; k <= kmax; k++)
- vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd;
- k = kmax;
- do
- {
- if (k == kmax)
- {
- SCM y = lra;
- SCM_ARRAY_BASE (vra0) = cind (ra0, inds);
- for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y))
- SCM_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), inds);
- if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
- return 0;
- k--;
- continue;
- }
- if (vinds[k] < SCM_ARRAY_DIMS (ra0)[k].ubnd)
- {
- vinds[k]++;
- k++;
- continue;
- }
- vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd - 1;
- k--;
- }
- while (k >= 0);
- return 1;
+ else
+ {
+ SCM_ARRAY_DIMS (vra0)->lbnd = SCM_ARRAY_DIMS (ra0)[kmax].lbnd;
+ SCM_ARRAY_DIMS (vra0)->ubnd = SCM_ARRAY_DIMS (ra0)[kmax].ubnd;
+ SCM_ARRAY_DIMS (vra0)->inc = SCM_ARRAY_DIMS (ra0)[kmax].inc;
+ }
+ SCM_ARRAY_BASE (vra0) = SCM_ARRAY_BASE (ra0);
+ SCM_ARRAY_V (vra0) = SCM_ARRAY_V (ra0);
+ }
+ else
+ {
+ kmax = 0;
+ SCM_ARRAY_DIMS (vra0)->lbnd = 0;
+ SCM_ARRAY_DIMS (vra0)->ubnd = SCM_LENGTH (ra0) - 1;
+ SCM_ARRAY_DIMS (vra0)->inc = 1;
+ SCM_ARRAY_BASE (vra0) = 0;
+ SCM_ARRAY_V (vra0) = ra0;
+ ra0 = vra0;
+ }
+ lvra = SCM_EOL;
+ plvra = &lvra;
+ for (z = lra; SCM_NIMP (z); z = SCM_CDR (z))
+ {
+ ra1 = SCM_CAR (z);
+ vra1 = scm_make_ra (1);
+ SCM_ARRAY_DIMS (vra1)->lbnd = SCM_ARRAY_DIMS (vra0)->lbnd;
+ SCM_ARRAY_DIMS (vra1)->ubnd = SCM_ARRAY_DIMS (vra0)->ubnd;
+ if (SCM_ARRAYP (ra1))
+ {
+ if (kmax >= 0)
+ SCM_ARRAY_DIMS (vra1)->inc = SCM_ARRAY_DIMS (ra1)[kmax].inc;
+ SCM_ARRAY_V (vra1) = SCM_ARRAY_V (ra1);
+ }
+ else
+ {
+ SCM_ARRAY_DIMS (vra1)->inc = 1;
+ SCM_ARRAY_V (vra1) = ra1;
+ }
+ *plvra = scm_cons (vra1, SCM_EOL);
+ plvra = SCM_CDRLOC (*plvra);
+ }
+ inds = scm_make_uve (SCM_ARRAY_NDIM (ra0), SCM_MAKINUM (-1L));
+ vinds = (long *) SCM_VELTS (inds);
+ for (k = 0; k <= kmax; k++)
+ vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd;
+ k = kmax;
+ do
+ {
+ if (k == kmax)
+ {
+ SCM y = lra;
+ SCM_ARRAY_BASE (vra0) = cind (ra0, inds);
+ for (z = lvra; SCM_NIMP (z); z = SCM_CDR (z), y = SCM_CDR (y))
+ SCM_ARRAY_BASE (SCM_CAR (z)) = cind (SCM_CAR (y), inds);
+ if (0 == (SCM_UNBNDP (data) ? cproc(vra0, lvra) : cproc(vra0, data, lvra)))
+ return 0;
+ k--;
+ continue;
+ }
+ if (vinds[k] < SCM_ARRAY_DIMS (ra0)[k].ubnd)
+ {
+ vinds[k]++;
+ k++;
+ continue;
+ }
+ vinds[k] = SCM_ARRAY_DIMS (ra0)[k].lbnd - 1;
+ k--;
+ }
+ while (k >= 0);
+ return 1;
}
}
SCM_DEFINE (scm_array_fill_x, "array-fill!", 2, 0, 0,
- (SCM ra, SCM fill),
+ (SCM ra, SCM fill),
"Stores @var{fill} in every element of @var{array}. The value returned\n"
"is unspecified.")
#define FUNC_NAME s_scm_array_fill_x
{
- SCM_RAMAPC (scm_array_fill_int, fill, ra, SCM_EOL);
+ scm_ramapc (scm_array_fill_int, fill, ra, SCM_EOL, FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
#undef FUNC_NAME
+
static int
racp (SCM src, SCM dst)
{
i_d = SCM_ARRAY_BASE (dst);
src = SCM_ARRAY_V (src);
dst = SCM_ARRAY_V (dst);
+
+
+ /* untested optimization: don't copy if we're we. This allows the
+ ugly UNICOS macros (IVDEP) to go .
+ */
+
+ if (src == dst)
+ return 1 ;
+
switch SCM_TYP7
(dst)
- {
- default:
- gencase:
- case scm_tc7_vector:
- case scm_tc7_wvect:
+ {
+ default:
+ gencase:
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- scm_array_set_x (dst, scm_cvref (src, i_s, SCM_UNDEFINED), SCM_MAKINUM (i_d));
- break;
- case scm_tc7_string:
- case scm_tc7_byvect:
- if (scm_tc7_string != SCM_TYP7 (dst))
- goto gencase;
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- SCM_CHARS (dst)[i_d] = SCM_CHARS (src)[i_s];
- break;
- case scm_tc7_bvect:
- if (scm_tc7_bvect != SCM_TYP7 (dst))
- goto gencase;
- if (1 == inc_d && 1 == inc_s && i_s % SCM_LONG_BIT == i_d % SCM_LONG_BIT && n >= SCM_LONG_BIT)
- {
- long *sv = (long *) SCM_VELTS (src);
- long *dv = (long *) SCM_VELTS (dst);
- sv += i_s / SCM_LONG_BIT;
- dv += i_d / SCM_LONG_BIT;
- if (i_s % SCM_LONG_BIT)
- { /* leading partial word */
- *dv = (*dv & ~(~0L << (i_s % SCM_LONG_BIT))) | (*sv & (~0L << (i_s % SCM_LONG_BIT)));
- dv++;
- sv++;
- n -= SCM_LONG_BIT - (i_s % SCM_LONG_BIT);
- }
- IVDEP (src != dst,
- for (; n >= SCM_LONG_BIT; n -= SCM_LONG_BIT, sv++, dv++)
- * dv = *sv;)
- if (n) /* trailing partial word */
- *dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n));
- }
- else
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ scm_array_set_x (dst, scm_cvref (src, i_s, SCM_UNDEFINED), SCM_MAKINUM (i_d));
+ break;
+ case scm_tc7_string:
+ case scm_tc7_byvect:
+ if (scm_tc7_string != SCM_TYP7 (dst))
+ goto gencase;
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ SCM_CHARS (dst)[i_d] = SCM_CHARS (src)[i_s];
+ break;
+ case scm_tc7_bvect:
+ if (scm_tc7_bvect != SCM_TYP7 (dst))
+ goto gencase;
+ if (1 == inc_d && 1 == inc_s && i_s % SCM_LONG_BIT == i_d % SCM_LONG_BIT && n >= SCM_LONG_BIT)
+ {
+ long *sv = (long *) SCM_VELTS (src);
+ long *dv = (long *) SCM_VELTS (dst);
+ sv += i_s / SCM_LONG_BIT;
+ dv += i_d / SCM_LONG_BIT;
+ if (i_s % SCM_LONG_BIT)
+ { /* leading partial word */
+ *dv = (*dv & ~(~0L << (i_s % SCM_LONG_BIT))) | (*sv & (~0L << (i_s % SCM_LONG_BIT)));
+ dv++;
+ sv++;
+ n -= SCM_LONG_BIT - (i_s % SCM_LONG_BIT);
+ }
+ for (; n >= SCM_LONG_BIT; n -= SCM_LONG_BIT, sv++, dv++)
+ * dv = *sv;
+ if (n) /* trailing partial word */
+ *dv = (*dv & (~0L << n)) | (*sv & ~(~0L << n));
+ }
+ else
+ {
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ if (SCM_BITVEC_REF(src, i_s))
+ SCM_BITVEC_SET(dst, i_d);
+ else
+ SCM_BITVEC_CLR(dst, i_d);
+ }
+ break;
+ case scm_tc7_uvect:
+ if (scm_tc7_uvect != SCM_TYP7 (src))
+ goto gencase;
+ else
+ {
+ long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src);
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = s[i_s];
+ break;
+ }
+ case scm_tc7_ivect:
+ if (scm_tc7_uvect != SCM_TYP7 (src) && scm_tc7_ivect != SCM_TYP7 (src))
+ goto gencase;
+ else
+ {
+ long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src);
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = s[i_s];
+ break;
+ }
+#ifdef SCM_FLOATS
+#ifdef SCM_SINGLES
+ case scm_tc7_fvect:
+ {
+ float *d = (float *) SCM_VELTS (dst);
+ float *s = (float *) SCM_VELTS (src);
+ switch SCM_TYP7
+ (src)
{
+ default:
+ goto gencase;
+ case scm_tc7_ivect:
+ case scm_tc7_uvect:
for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- if (SCM_VELTS (src)[i_s / SCM_LONG_BIT] & (1L << (i_s % SCM_LONG_BIT)))
- SCM_VELTS (dst)[i_d / SCM_LONG_BIT] |= (1L << (i_d % SCM_LONG_BIT));
- else
- SCM_VELTS (dst)[i_d / SCM_LONG_BIT] &= ~(1L << (i_d % SCM_LONG_BIT));
+ d[i_d] = ((long *) s)[i_s];
+ break;
+ case scm_tc7_fvect:
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = s[i_s];
+ break;
+ case scm_tc7_dvect:
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = ((double *) s)[i_s];
+ break;
}
break;
- case scm_tc7_uvect:
- if (scm_tc7_uvect != SCM_TYP7 (src))
- goto gencase;
- else
+ }
+#endif /* SCM_SINGLES */
+ case scm_tc7_dvect:
+ {
+ double *d = (double *) SCM_VELTS (dst);
+ double *s = (double *) SCM_VELTS (src);
+ switch SCM_TYP7
+ (src)
{
- long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src);
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = s[i_s];)
+ default:
+ goto gencase;
+ case scm_tc7_ivect:
+ case scm_tc7_uvect:
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = ((long *) s)[i_s];
+ break;
+ case scm_tc7_fvect:
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = ((float *) s)[i_s];
+ break;
+ case scm_tc7_dvect:
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ d[i_d] = s[i_s];
break;
}
- case scm_tc7_ivect:
- if (scm_tc7_uvect != SCM_TYP7 (src) && scm_tc7_ivect != SCM_TYP7 (src))
- goto gencase;
- else
+ break;
+ }
+ case scm_tc7_cvect:
+ {
+ double (*d)[2] = (double (*)[2]) SCM_VELTS (dst);
+ double (*s)[2] = (double (*)[2]) SCM_VELTS (src);
+ switch SCM_TYP7
+ (src)
{
- long *d = (long *) SCM_VELTS (dst), *s = (long *) SCM_VELTS (src);
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = s[i_s];)
+ default:
+ goto gencase;
+ case scm_tc7_ivect:
+ case scm_tc7_uvect:
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
+ {
+ d[i_d][0] = ((long *) s)[i_s];
+ d[i_d][1] = 0.0;
+ }
break;
- }
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float *d = (float *) SCM_VELTS (dst);
- float *s = (float *) SCM_VELTS (src);
- switch SCM_TYP7
- (src)
+ case scm_tc7_fvect:
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
{
- default:
- goto gencase;
- case scm_tc7_ivect:
- case scm_tc7_uvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = ((long *) s)[i_s];)
- break;
- case scm_tc7_fvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = s[i_s];)
- break;
- case scm_tc7_dvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = ((double *) s)[i_s];)
- break;
+ d[i_d][0] = ((float *) s)[i_s];
+ d[i_d][1] = 0.0;
}
- break;
- }
-#endif /* SCM_SINGLES */
- case scm_tc7_dvect:
- {
- double *d = (double *) SCM_VELTS (dst);
- double *s = (double *) SCM_VELTS (src);
- switch SCM_TYP7
- (src)
+ break;
+ case scm_tc7_dvect:
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
{
- default:
- goto gencase;
- case scm_tc7_ivect:
- case scm_tc7_uvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = ((long *) s)[i_s];)
- break;
- case scm_tc7_fvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = ((float *) s)[i_s];)
- break;
- case scm_tc7_dvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- d[i_d] = s[i_s];)
- break;
+ d[i_d][0] = ((double *) s)[i_s];
+ d[i_d][1] = 0.0;
}
- break;
- }
- case scm_tc7_cvect:
- {
- double (*d)[2] = (double (*)[2]) SCM_VELTS (dst);
- double (*s)[2] = (double (*)[2]) SCM_VELTS (src);
- switch SCM_TYP7
- (src)
+ break;
+ case scm_tc7_cvect:
+ for (; n-- > 0; i_s += inc_s, i_d += inc_d)
{
- default:
- goto gencase;
- case scm_tc7_ivect:
- case scm_tc7_uvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- {
- d[i_d][0] = ((long *) s)[i_s];
- d[i_d][1] = 0.0;
- }
- )
- break;
- case scm_tc7_fvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- {
- d[i_d][0] = ((float *) s)[i_s];
- d[i_d][1] = 0.0;
- }
- )
- break;
- case scm_tc7_dvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- {
- d[i_d][0] = ((double *) s)[i_s];
- d[i_d][1] = 0.0;
- }
- )
- break;
- case scm_tc7_cvect:
- IVDEP (src != dst,
- for (; n-- > 0; i_s += inc_s, i_d += inc_d)
- {
- d[i_d][0] = s[i_s][0];
- d[i_d][1] = s[i_s][1];
- }
- )
+ d[i_d][0] = s[i_s][0];
+ d[i_d][1] = s[i_s][1];
}
- break;
- }
+ }
+ break;
}
+ }
#endif /* SCM_FLOATS */
return 1;
}
SCM_DEFINE (scm_array_copy_x, "array-copy!", 2, 0, 0,
- (SCM src, SCM dst),
+ (SCM src, SCM dst),
"Copies every element from vector or array @var{source} to the\n"
"corresponding element of @var{destination}. @var{destination} must have\n"
"the same rank as @var{source}, and be at least as large in each\n"
"dimension. The order is unspecified.")
#define FUNC_NAME s_scm_array_copy_x
{
- SCM_RAMAPC (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL));
+ scm_ramapc (racp, SCM_UNDEFINED, src, scm_cons (dst, SCM_EOL), FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
{
SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (BVE_REF (ra0, i0))
- if (SCM_FALSEP(scm_eq_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
- BVE_CLR (ra0, i0);
+ if (SCM_BITVEC_REF (ra0, i0))
+ if (SCM_FALSEP(scm_eq_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
+ SCM_BITVEC_CLR (ra0, i0);
break;
}
case scm_tc7_uvect:
case scm_tc7_ivect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (BVE_REF (ra0, i0))
- if (SCM_VELTS (ra1)[i1] != SCM_VELTS (ra2)[i2])
- BVE_CLR (ra0, i0);
+ if (SCM_BITVEC_REF (ra0, i0))
+ if (SCM_VELTS (ra1)[i1] != SCM_VELTS (ra2)[i2])
+ SCM_BITVEC_CLR (ra0, i0);
break;
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (BVE_REF (ra0, i0))
- if (((float *) SCM_VELTS (ra1))[i1] != ((float *) SCM_VELTS (ra2))[i2])
- BVE_CLR (ra0, i0);
+ if (SCM_BITVEC_REF (ra0, i0))
+ if (((float *) SCM_VELTS (ra1))[i1] != ((float *) SCM_VELTS (ra2))[i2])
+ SCM_BITVEC_CLR (ra0, i0);
break;
#endif /*SCM_SINGLES*/
case scm_tc7_dvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (BVE_REF (ra0, i0))
- if (((double *) SCM_VELTS (ra1))[i1] != ((double *) SCM_VELTS (ra2))[i2])
- BVE_CLR (ra0, i0);
+ if (SCM_BITVEC_REF (ra0, i0))
+ if (((double *) SCM_VELTS (ra1))[i1] != ((double *) SCM_VELTS (ra2))[i2])
+ SCM_BITVEC_CLR (ra0, i0);
break;
case scm_tc7_cvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (BVE_REF (ra0, i0))
- if (((double *) SCM_VELTS (ra1))[2 * i1] != ((double *) SCM_VELTS (ra2))[2 * i2] ||
- ((double *) SCM_VELTS (ra1))[2 * i1 + 1] != ((double *) SCM_VELTS (ra2))[2 * i2 + 1])
- BVE_CLR (ra0, i0);
+ if (SCM_BITVEC_REF (ra0, i0))
+ if (((double *) SCM_VELTS (ra1))[2 * i1] != ((double *) SCM_VELTS (ra2))[2 * i2] ||
+ ((double *) SCM_VELTS (ra1))[2 * i1 + 1] != ((double *) SCM_VELTS (ra2))[2 * i2 + 1])
+ SCM_BITVEC_CLR (ra0, i0);
break;
#endif /*SCM_FLOATS*/
}
{
SCM e1 = SCM_UNDEFINED, e2 = SCM_UNDEFINED;
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (BVE_REF (ra0, i0))
- if (opt ?
- SCM_NFALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) :
- SCM_FALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
- BVE_CLR (ra0, i0);
+ if (SCM_BITVEC_REF (ra0, i0))
+ if (opt ?
+ SCM_NFALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))) :
+ SCM_FALSEP (scm_less_p (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
+ SCM_BITVEC_CLR (ra0, i0);
break;
}
case scm_tc7_uvect:
case scm_tc7_ivect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
{
- if (BVE_REF (ra0, i0))
- if (opt ?
- SCM_VELTS (ra1)[i1] < SCM_VELTS (ra2)[i2] :
- SCM_VELTS (ra1)[i1] >= SCM_VELTS (ra2)[i2])
- BVE_CLR (ra0, i0);
+ if (SCM_BITVEC_REF (ra0, i0))
+ if (opt ?
+ SCM_VELTS (ra1)[i1] < SCM_VELTS (ra2)[i2] :
+ SCM_VELTS (ra1)[i1] >= SCM_VELTS (ra2)[i2])
+ SCM_BITVEC_CLR (ra0, i0);
}
break;
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (BVE_REF(ra0, i0))
- if (opt ?
- ((float *) SCM_VELTS (ra1))[i1] < ((float *) SCM_VELTS (ra2))[i2] :
- ((float *) SCM_VELTS (ra1))[i1] >= ((float *) SCM_VELTS (ra2))[i2])
- BVE_CLR (ra0, i0);
+ if (SCM_BITVEC_REF(ra0, i0))
+ if (opt ?
+ ((float *) SCM_VELTS (ra1))[i1] < ((float *) SCM_VELTS (ra2))[i2] :
+ ((float *) SCM_VELTS (ra1))[i1] >= ((float *) SCM_VELTS (ra2))[i2])
+ SCM_BITVEC_CLR (ra0, i0);
break;
#endif /*SCM_SINGLES*/
case scm_tc7_dvect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (BVE_REF (ra0, i0))
- if (opt ?
- ((double *) SCM_VELTS (ra1))[i1] < ((double *) SCM_VELTS (ra2))[i2] :
- ((double *) SCM_VELTS (ra1))[i1] >= ((double *) SCM_VELTS (ra2))[i2])
- BVE_CLR (ra0, i0);
+ if (SCM_BITVEC_REF (ra0, i0))
+ if (opt ?
+ ((double *) SCM_VELTS (ra1))[i1] < ((double *) SCM_VELTS (ra2))[i2] :
+ ((double *) SCM_VELTS (ra1))[i1] >= ((double *) SCM_VELTS (ra2))[i2])
+ SCM_BITVEC_CLR (ra0, i0);
break;
#endif /*SCM_FLOATS*/
}
long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
ra0 = SCM_ARRAY_V (ra0);
if (SCM_NNULLP(ras))
- {
- SCM ra1 = SCM_CAR (ras);
- scm_sizet i1 = SCM_ARRAY_BASE (ra1);
- long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
+ {
+ SCM ra1 = SCM_CAR (ras);
+ scm_sizet i1 = SCM_ARRAY_BASE (ra1);
+ long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_ARRAY_V (ra1);
+ switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
+ {
+ default:
{
- default:
- {
- SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- scm_array_set_x (ra0, scm_sum (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
- SCM_MAKINUM (i0));
- break;
- }
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- {
- long *v0 = SCM_VELTS (ra0);
- long *v1 = SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] += v1[i1];)
- break;
- }
+ SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ scm_array_set_x (ra0, scm_sum (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
+ SCM_MAKINUM (i0));
+ break;
+ }
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ BINARY_ELTS_CODE( +=, long);
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float *v0 = (float *) SCM_VELTS (ra0);
- float *v1 = (float *) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] += v1[i1];)
- break;
- }
+ case scm_tc7_fvect:
+ BINARY_ELTS_CODE( +=, float);
#endif /* SCM_SINGLES */
- case scm_tc7_dvect:
- {
- double *v0 = (double *) SCM_VELTS (ra0);
- double *v1 = (double *) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] += v1[i1];)
- break;
- }
- case scm_tc7_cvect:
- {
- double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
- double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- {
- v0[i0][0] += v1[i1][0];
- v0[i0][1] += v1[i1][1];
- }
- );
- break;
- }
+ case scm_tc7_dvect:
+ BINARY_ELTS_CODE( +=, double);
+ case scm_tc7_cvect:
+ BINARY_PAIR_ELTS_CODE( +=, double);
#endif /* SCM_FLOATS */
- }
- }
+ }
+ }
return 1;
}
long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
ra0 = SCM_ARRAY_V (ra0);
if (SCM_NULLP (ras))
- {
- switch (SCM_TYP7 (ra0))
- {
- default:
- {
- SCM e0 = SCM_UNDEFINED;
- for (; n-- > 0; i0 += inc0)
- scm_array_set_x (ra0, scm_difference (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
- break;
- }
+ {
+ switch (SCM_TYP7 (ra0))
+ {
+ default:
+ {
+ SCM e0 = SCM_UNDEFINED;
+ for (; n-- > 0; i0 += inc0)
+ scm_array_set_x (ra0,
+ scm_difference (RVREF (ra0, i0, e0), SCM_UNDEFINED),
+ SCM_MAKINUM (i0));
+ break;
+ }
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float *v0 = (float *) SCM_VELTS (ra0);
- for (; n-- > 0; i0 += inc0)
- v0[i0] = -v0[i0];
- break;
- }
+ case scm_tc7_fvect:
+ UNARY_ELTS_CODE( = -, float);
#endif /* SCM_SINGLES */
- case scm_tc7_dvect:
- {
- double *v0 = (double *) SCM_VELTS (ra0);
- for (; n-- > 0; i0 += inc0)
- v0[i0] = -v0[i0];
- break;
- }
- case scm_tc7_cvect:
- {
- double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
- for (; n-- > 0; i0 += inc0)
- {
- v0[i0][0] = -v0[i0][0];
- v0[i0][1] = -v0[i0][1];
- }
- break;
- }
+ case scm_tc7_dvect:
+ UNARY_ELTS_CODE( = -, double);
+ case scm_tc7_cvect:
+ UNARY_PAIR_ELTS_CODE( = -, double);
#endif /* SCM_FLOATS */
- }
- }
+ }
+ }
else
{
SCM ra1 = SCM_CAR (ras);
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect:
- {
- float *v0 = (float *) SCM_VELTS (ra0);
- float *v1 = (float *) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] -= v1[i1];)
- break;
- }
+ BINARY_ELTS_CODE( -=, float);
#endif /* SCM_SINGLES */
case scm_tc7_dvect:
- {
- double *v0 = (double *) SCM_VELTS (ra0);
- double *v1 = (double *) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] -= v1[i1];)
- break;
- }
+ BINARY_ELTS_CODE( -=, double);
case scm_tc7_cvect:
- {
- double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
- double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- {
- v0[i0][0] -= v1[i1][0];
- v0[i0][1] -= v1[i1][1];
- }
- )
- break;
- }
+ BINARY_PAIR_ELTS_CODE( -=, double);
#endif /* SCM_FLOATS */
}
}
long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
ra0 = SCM_ARRAY_V (ra0);
if (SCM_NNULLP (ras))
- {
- SCM ra1 = SCM_CAR (ras);
- scm_sizet i1 = SCM_ARRAY_BASE (ra1);
- long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_ARRAY_V (ra1);
- switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
+ {
+ SCM ra1 = SCM_CAR (ras);
+ scm_sizet i1 = SCM_ARRAY_BASE (ra1);
+ long inc1 = SCM_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_ARRAY_V (ra1);
+ switch (SCM_TYP7 (ra0) == SCM_TYP7 (ra1) ? SCM_TYP7 (ra0) : 0)
+ {
+ default:
{
- default:
- {
- SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- scm_array_set_x (ra0, scm_product (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
- SCM_MAKINUM (i0));
- break;
- }
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- {
- long *v0 = SCM_VELTS (ra0);
- long *v1 = SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] *= v1[i1];)
- break;
- }
+ SCM e0 = SCM_UNDEFINED, e1 = SCM_UNDEFINED;
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ scm_array_set_x (ra0, scm_product (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
+ SCM_MAKINUM (i0));
+ break;
+ }
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ BINARY_ELTS_CODE( *=, long);
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float *v0 = (float *) SCM_VELTS (ra0);
- float *v1 = (float *) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] *= v1[i1];)
- break;
- }
+ case scm_tc7_fvect:
+ BINARY_ELTS_CODE( *=, float);
#endif /* SCM_SINGLES */
- case scm_tc7_dvect:
- {
- double *v0 = (double *) SCM_VELTS (ra0);
- double *v1 = (double *) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] *= v1[i1];)
- break;
- }
- case scm_tc7_cvect:
- {
- double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
- register double r;
- double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- {
- r = v0[i0][0] * v1[i1][0] - v0[i0][1] * v1[i1][1];
- v0[i0][1] = v0[i0][0] * v1[i1][1] + v0[i0][1] * v1[i1][0];
- v0[i0][0] = r;
- }
- );
- break;
- }
-#endif /* SCM_FLOATS */
+ case scm_tc7_dvect:
+ BINARY_ELTS_CODE( *=, double);
+ case scm_tc7_cvect:
+ {
+ double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
+ register double r;
+ double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
+ IVDEP (ra0 != ra1,
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ {
+ r = v0[i0][0] * v1[i1][0] - v0[i0][1] * v1[i1][1];
+ v0[i0][1] = v0[i0][0] * v1[i1][1] + v0[i0][1] * v1[i1][0];
+ v0[i0][0] = r;
+ }
+ );
+ break;
}
- }
+#endif /* SCM_FLOATS */
+ }
+ }
return 1;
}
long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
ra0 = SCM_ARRAY_V (ra0);
if (SCM_NULLP (ras))
- {
- switch (SCM_TYP7 (ra0))
- {
- default:
- {
- SCM e0 = SCM_UNDEFINED;
- for (; n-- > 0; i0 += inc0)
- scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
- break;
- }
+ {
+ switch (SCM_TYP7 (ra0))
+ {
+ default:
+ {
+ SCM e0 = SCM_UNDEFINED;
+ for (; n-- > 0; i0 += inc0)
+ scm_array_set_x (ra0, scm_divide (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
+ break;
+ }
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float *v0 = (float *) SCM_VELTS (ra0);
- for (; n-- > 0; i0 += inc0)
- v0[i0] = 1.0 / v0[i0];
- break;
- }
+ case scm_tc7_fvect:
+ UNARY_ELTS_CODE( = 1.0 / , float);
#endif /* SCM_SINGLES */
- case scm_tc7_dvect:
- {
- double *v0 = (double *) SCM_VELTS (ra0);
- for (; n-- > 0; i0 += inc0)
- v0[i0] = 1.0 / v0[i0];
- break;
- }
- case scm_tc7_cvect:
+ case scm_tc7_dvect:
+ UNARY_ELTS_CODE( = 1.0 / , double);
+ case scm_tc7_cvect:
+ {
+ register double d;
+ double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
+ for (; n-- > 0; i0 += inc0)
{
- register double d;
- double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0);
- for (; n-- > 0; i0 += inc0)
- {
- d = v0[i0][0] * v0[i0][0] + v0[i0][1] * v0[i0][1];
- v0[i0][0] /= d;
- v0[i0][1] /= -d;
- }
- break;
+ d = v0[i0][0] * v0[i0][0] + v0[i0][1] * v0[i0][1];
+ v0[i0][0] /= d;
+ v0[i0][1] /= -d;
}
+ break;
+ }
#endif /* SCM_FLOATS */
- }
- }
+ }
+ }
else
{
SCM ra1 = SCM_CAR (ras);
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect:
- {
- float *v0 = (float *) SCM_VELTS (ra0);
- float *v1 = (float *) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] /= v1[i1];)
- break;
- }
+ BINARY_ELTS_CODE( /=, float);
#endif /* SCM_SINGLES */
case scm_tc7_dvect:
- {
- double *v0 = (double *) SCM_VELTS (ra0);
- double *v1 = (double *) SCM_VELTS (ra1);
- IVDEP (ra0 != ra1,
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- v0[i0] /= v1[i1];)
- break;
- }
+ BINARY_ELTS_CODE( /=, double);
case scm_tc7_cvect:
{
register double d, r;
double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1);
IVDEP (ra0 != ra1,
for (; n-- > 0; i0 += inc0, i1 += inc1)
- {
- d = v1[i1][0] * v1[i1][0] + v1[i1][1] * v1[i1][1];
- r = (v0[i0][0] * v1[i1][0] + v0[i0][1] * v1[i1][1]) / d;
- v0[i0][1] = (v0[i0][1] * v1[i1][0] - v0[i0][0] * v1[i1][1]) / d;
- v0[i0][0] = r;
- }
+ {
+ d = v1[i1][0] * v1[i1][0] + v1[i1][1] * v1[i1][1];
+ r = (v0[i0][0] * v1[i1][0] + v0[i0][1] * v1[i1][1]) / d;
+ v0[i0][1] = (v0[i0][1] * v1[i1][0] - v0[i0][0] * v1[i1][1]) / d;
+ v0[i0][0] = r;
+ }
)
break;
}
long base = SCM_ARRAY_BASE (ra0) - i * inc;
ra0 = SCM_ARRAY_V (ra0);
if (SCM_NULLP (ras))
- for (; i <= n; i++)
- scm_array_set_x (ra0, scm_apply (proc, SCM_EOL, SCM_EOL), SCM_MAKINUM (i * inc + base));
+ for (; i <= n; i++)
+ scm_array_set_x (ra0, scm_apply (proc, SCM_EOL, SCM_EOL), SCM_MAKINUM (i * inc + base));
else
{
SCM ra1 = SCM_CAR (ras);
ra1 = SCM_ARRAY_V (ra1);
ras = SCM_CDR (ras);
if (SCM_NULLP(ras))
- ras = scm_nullvect;
+ ras = scm_nullvect;
else
{
ras = scm_vector (ras);
ra0 = SCM_ARRAY_V (ra0);
ra1 = SCM_ARRAY_V (ra1);
switch (SCM_TYP7 (ra0))
- {
- default:
- gencase:
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- scm_array_set_x (ra0, scm_apply (proc, RVREF (ra1, i1, e1), scm_listofnull), SCM_MAKINUM (i0));
- break;
+ {
+ default:
+ gencase:
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ scm_array_set_x (ra0, scm_apply (proc, RVREF (ra1, i1, e1), scm_listofnull), SCM_MAKINUM (i0));
+ break;
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float *dst = (float *) SCM_VELTS (ra0);
- switch (SCM_TYP7 (ra1))
- {
- default:
- goto gencase;
- case scm_tc7_fvect:
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- dst[i0] = SCM_DSUBRF (proc) ((double) ((float *) SCM_VELTS (ra1))[i1]);
- break;
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]);
- break;
- }
- break;
- }
+ case scm_tc7_fvect:
+ {
+ float *dst = (float *) SCM_VELTS (ra0);
+ switch (SCM_TYP7 (ra1))
+ {
+ default:
+ goto gencase;
+ case scm_tc7_fvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ dst[i0] = SCM_DSUBRF (proc) ((double) ((float *) SCM_VELTS (ra1))[i1]);
+ break;
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ dst[i0] = SCM_DSUBRF (proc) (SCM_ASWORD (SCM_VELTS (ra1)[i1]));
+ break;
+ }
+ break;
+ }
#endif /* SCM_SINGLES */
- case scm_tc7_dvect:
- {
- double *dst = (double *) SCM_VELTS (ra0);
- switch (SCM_TYP7 (ra1))
- {
- default:
- goto gencase;
- case scm_tc7_dvect:
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- dst[i0] = SCM_DSUBRF (proc) (((double *) SCM_VELTS (ra1))[i1]);
- break;
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- dst[i0] = SCM_DSUBRF (proc) ((double) SCM_VELTS (ra1)[i1]);
- break;
- }
- break;
- }
-#endif /* SCM_FLOATS */
+ case scm_tc7_dvect:
+ {
+ double *dst = (double *) SCM_VELTS (ra0);
+ switch (SCM_TYP7 (ra1))
+ {
+ default:
+ goto gencase;
+ case scm_tc7_dvect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ dst[i0] = SCM_DSUBRF (proc) (((double *) SCM_VELTS (ra1))[i1]);
+ break;
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ dst[i0] = SCM_DSUBRF (proc) (SCM_ASWORD (SCM_VELTS (ra1)[i1]));
+ break;
+ }
+ break;
}
+#endif /* SCM_FLOATS */
+ }
return 1;
}
{
default:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (BVE_REF (ra0, i0))
- if (SCM_FALSEP (SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
- BVE_CLR (ra0, i0);
+ if (SCM_BITVEC_REF (ra0, i0))
+ if (SCM_FALSEP (SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2))))
+ SCM_BITVEC_CLR (ra0, i0);
break;
case scm_tc7_uvect:
case scm_tc7_ivect:
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (BVE_REF (ra0, i0))
- {
- if (SCM_FALSEP (SCM_SUBRF (proc) (SCM_MAKINUM (SCM_VELTS (ra1)[i1]),
- SCM_MAKINUM (SCM_VELTS (ra2)[i2]))))
- BVE_CLR (ra0, i0);
- }
+ if (SCM_BITVEC_REF (ra0, i0))
+ {
+ if (SCM_FALSEP (SCM_SUBRF (proc) (SCM_MAKINUM (SCM_VELTS (ra1)[i1]),
+ SCM_MAKINUM (SCM_VELTS (ra2)[i2]))))
+ SCM_BITVEC_CLR (ra0, i0);
+ }
break;
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
{
SCM a1 = scm_makflo (1.0), a2 = scm_makflo (1.0);
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (BVE_REF (ra0, i0))
- {
- SCM_FLO (a1) = ((float *) SCM_VELTS (ra1))[i1];
- SCM_FLO (a2) = ((float *) SCM_VELTS (ra2))[i2];
- if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2)))
- BVE_CLR (ra0, i0);
- }
+ if (SCM_BITVEC_REF (ra0, i0))
+ {
+ SCM_FLO (a1) = ((float *) SCM_VELTS (ra1))[i1];
+ SCM_FLO (a2) = ((float *) SCM_VELTS (ra2))[i2];
+ if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2)))
+ SCM_BITVEC_CLR (ra0, i0);
+ }
break;
}
#endif /*SCM_SINGLES*/
{
SCM a1 = scm_makdbl (1.0 / 3.0, 0.0), a2 = scm_makdbl (1.0 / 3.0, 0.0);
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (BVE_REF (ra0, i0))
- {
- SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[i1];
- SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[i2];
- if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2)))
- BVE_CLR (ra0, i0);
- }
+ if (SCM_BITVEC_REF (ra0, i0))
+ {
+ SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[i1];
+ SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[i2];
+ if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2)))
+ SCM_BITVEC_CLR (ra0, i0);
+ }
break;
}
case scm_tc7_cvect:
{
SCM a1 = scm_makdbl (1.0, 1.0), a2 = scm_makdbl (1.0, 1.0);
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
- if (BVE_REF (ra0, i0))
- {
- SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[2 * i1];
- SCM_IMAG (a1) = ((double *) SCM_VELTS (ra1))[2 * i1 + 1];
- SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[2 * i2];
- SCM_IMAG (a2) = ((double *) SCM_VELTS (ra2))[2 * i2 + 1];
- if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2)))
- BVE_CLR (ra0, i0);
- }
+ if (SCM_BITVEC_REF (ra0, i0))
+ {
+ SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[2 * i1];
+ SCM_IMAG (a1) = ((double *) SCM_VELTS (ra1))[2 * i1 + 1];
+ SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[2 * i2];
+ SCM_IMAG (a2) = ((double *) SCM_VELTS (ra2))[2 * i2 + 1];
+ if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2)))
+ SCM_BITVEC_CLR (ra0, i0);
+ }
break;
}
#endif /*SCM_FLOATS*/
ra1 = SCM_ARRAY_V (ra1);
ras = SCM_CDR (ras);
if (SCM_NULLP (ras))
- {
- if (scm_tc7_vector == SCM_TYP7 (ra0)
- || scm_tc7_wvect == SCM_TYP7 (ra0))
+ {
+ if (scm_tc7_vector == SCM_TYP7 (ra0)
+ || scm_tc7_wvect == SCM_TYP7 (ra0))
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), SCM_UNDEFINED),
- SCM_MAKINUM (i0));
- else
- for (; n-- > 0; i0 += inc0, i1 += inc1)
- scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1), SCM_UNDEFINED),
- SCM_MAKINUM (i0));
- }
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ scm_array_set_x (ra0, SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), SCM_UNDEFINED),
+ SCM_MAKINUM (i0));
+ else
+ for (; n-- > 0; i0 += inc0, i1 += inc1)
+ scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra1, i1, e1), SCM_UNDEFINED),
+ SCM_MAKINUM (i0));
+ }
else
{
SCM ra2 = SCM_CAR (ras);
if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0))
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
scm_array_set_x (ra0,
- SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), scm_cvref (ra2, i2, SCM_UNDEFINED)),
- SCM_MAKINUM (i0));
+ SCM_SUBRF (proc) (scm_cvref (ra1, i1, SCM_UNDEFINED), scm_cvref (ra2, i2, SCM_UNDEFINED)),
+ SCM_MAKINUM (i0));
else
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
scm_array_set_x (ra0,
- SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)),
- SCM_MAKINUM (i0));
+ SCM_SUBRF (proc) (RVREF (ra1, i1, e1), RVREF (ra2, i2, e2)),
+ SCM_MAKINUM (i0));
}
return 1;
}
long inc0 = SCM_ARRAY_DIMS (ra0)->inc;
ra0 = SCM_ARRAY_V (ra0);
if (SCM_NULLP (ras))
- for (; n-- > 0; i0 += inc0)
- scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
+ for (; n-- > 0; i0 += inc0)
+ scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), SCM_UNDEFINED), SCM_MAKINUM (i0));
else
{
SCM ra1 = SCM_CAR (ras);
ra1 = SCM_ARRAY_V (ra1);
for (; n-- > 0; i0 += inc0, i1 += inc1)
scm_array_set_x (ra0, SCM_SUBRF (proc) (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1)),
- SCM_MAKINUM (i0));
+ SCM_MAKINUM (i0));
}
return 1;
}
SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
- (SCM ra0, SCM proc, SCM lra),
+ (SCM ra0, SCM proc, SCM lra),
"@var{array1}, @dots{} must have the same number of dimensions as\n"
"@var{array0} and have a range for each index which includes the range\n"
"for the corresponding index in @var{array0}. @var{proc} is applied to\n"
{
SCM_VALIDATE_PROC (2,proc);
switch (SCM_TYP7 (proc))
+ {
+ default:
+ gencase:
+ scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
+ return SCM_UNSPECIFIED;
+ case scm_tc7_subr_1:
+ scm_ramapc (ramap_1, proc, ra0, lra, FUNC_NAME);
+ return SCM_UNSPECIFIED;
+ case scm_tc7_subr_2:
+ case scm_tc7_subr_2o:
+ scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
+ return SCM_UNSPECIFIED;
+ case scm_tc7_cxr:
+ if (!SCM_SUBRF (proc))
+ goto gencase;
+ scm_ramapc (ramap_cxr, proc, ra0, lra, FUNC_NAME);
+ return SCM_UNSPECIFIED;
+ case scm_tc7_rpsubr:
{
- default:
- gencase:
- SCM_RAMAPC (ramap, proc, ra0, lra);
- return SCM_UNSPECIFIED;
- case scm_tc7_subr_1:
- SCM_RAMAPC (ramap_1, proc, ra0, lra);
- return SCM_UNSPECIFIED;
- case scm_tc7_subr_2:
- case scm_tc7_subr_2o:
- SCM_RAMAPC (ramap_2o, proc, ra0, lra);
- return SCM_UNSPECIFIED;
- case scm_tc7_cxr:
- if (!SCM_SUBRF (proc))
+ ra_iproc *p;
+ if (SCM_FALSEP (scm_array_p (ra0, SCM_BOOL_T)))
goto gencase;
- SCM_RAMAPC (ramap_cxr, proc, ra0, lra);
+ scm_array_fill_x (ra0, SCM_BOOL_T);
+ for (p = ra_rpsubrs; p->name; p++)
+ if (proc == p->sproc)
+ {
+ while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
+ {
+ scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
+ lra = SCM_CDR (lra);
+ }
+ return SCM_UNSPECIFIED;
+ }
+ while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
+ {
+ scm_ramapc (ramap_rp, proc, ra0, lra, FUNC_NAME);
+ lra = SCM_CDR (lra);
+ }
return SCM_UNSPECIFIED;
- case scm_tc7_rpsubr:
+ }
+ case scm_tc7_asubr:
+ if (SCM_NULLP (lra))
+ {
+ SCM prot, fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
+ if (SCM_INUMP(fill))
+ {
+ prot = scm_array_prototype (ra0);
+ if (SCM_INEXP (prot))
+ fill = scm_makdbl ((double) SCM_INUM (fill), 0.0);
+ }
+
+ scm_array_fill_x (ra0, fill);
+ }
+ else
{
+ SCM tail, ra1 = SCM_CAR (lra);
+ SCM v0 = (SCM_ARRAYP (ra0) ? SCM_ARRAY_V (ra0) : ra0);
ra_iproc *p;
- if (SCM_FALSEP (scm_array_p (ra0, SCM_BOOL_T)))
- goto gencase;
- scm_array_fill_x (ra0, SCM_BOOL_T);
- for (p = ra_rpsubrs; p->name; p++)
+ /* Check to see if order might matter.
+ This might be an argument for a separate
+ SERIAL-ARRAY-MAP! */
+ if (v0 == ra1 || (SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1)))
+ if (ra0 != ra1 || (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0)))
+ goto gencase;
+ for (tail = SCM_CDR (lra); SCM_NNULLP (tail); tail = SCM_CDR (tail))
+ {
+ ra1 = SCM_CAR (tail);
+ if (v0 == ra1 || (SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1)))
+ goto gencase;
+ }
+ for (p = ra_asubrs; p->name; p++)
if (proc == p->sproc)
{
- while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
+ if (ra0 != SCM_CAR (lra))
+ scm_ramapc (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL), FUNC_NAME);
+ lra = SCM_CDR (lra);
+ while (1)
{
- SCM_RAMAPC (p->vproc, SCM_UNDEFINED, ra0, lra);
+ scm_ramapc (p->vproc, SCM_UNDEFINED, ra0, lra, FUNC_NAME);
+ if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra)))
+ return SCM_UNSPECIFIED;
lra = SCM_CDR (lra);
}
- return SCM_UNSPECIFIED;
}
- while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra)))
- {
- SCM_RAMAPC (ramap_rp, proc, ra0, lra);
- lra = SCM_CDR (lra);
- }
- return SCM_UNSPECIFIED;
+ scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
+ lra = SCM_CDR (lra);
+ if (SCM_NIMP (lra))
+ for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra))
+ scm_ramapc (ramap_a, proc, ra0, lra, FUNC_NAME);
}
- case scm_tc7_asubr:
- if (SCM_NULLP (lra))
- {
- SCM prot, fill = SCM_SUBRF (proc) (SCM_UNDEFINED, SCM_UNDEFINED);
- if (SCM_INUMP(fill))
- {
- prot = scm_array_prototype (ra0);
- if (SCM_INEXP (prot))
- fill = scm_makdbl ((double) SCM_INUM (fill), 0.0);
- }
-
- scm_array_fill_x (ra0, fill);
- }
- else
- {
- SCM tail, ra1 = SCM_CAR (lra);
- SCM v0 = (SCM_ARRAYP (ra0) ? SCM_ARRAY_V (ra0) : ra0);
- ra_iproc *p;
- /* Check to see if order might matter.
- This might be an argument for a separate
- SERIAL-ARRAY-MAP! */
- if (v0 == ra1 || (SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1)))
- if (ra0 != ra1 || (SCM_ARRAYP(ra0) && !SCM_ARRAY_CONTP(ra0)))
- goto gencase;
- for (tail = SCM_CDR (lra); SCM_NNULLP (tail); tail = SCM_CDR (tail))
- {
- ra1 = SCM_CAR (tail);
- if (v0 == ra1 || (SCM_ARRAYP (ra1) && v0 == SCM_ARRAY_V (ra1)))
- goto gencase;
- }
- for (p = ra_asubrs; p->name; p++)
- if (proc == p->sproc)
- {
- if (ra0 != SCM_CAR (lra))
- SCM_RAMAPC (scm_array_identity, SCM_UNDEFINED, ra0, scm_cons (SCM_CAR (lra), SCM_EOL));
- lra = SCM_CDR (lra);
- while (1)
- {
- SCM_RAMAPC (p->vproc, SCM_UNDEFINED, ra0, lra);
- if (SCM_IMP (lra) || SCM_IMP (SCM_CDR (lra)))
- return SCM_UNSPECIFIED;
- lra = SCM_CDR (lra);
- }
- }
- SCM_RAMAPC (ramap_2o, proc, ra0, lra);
- lra = SCM_CDR (lra);
- if (SCM_NIMP (lra))
- for (lra = SCM_CDR (lra); SCM_NIMP (lra); lra = SCM_CDR (lra))
- SCM_RAMAPC (ramap_a, proc, ra0, lra);
- }
- return SCM_UNSPECIFIED;
- }
+ return SCM_UNSPECIFIED;
+ }
}
#undef FUNC_NAME
long n = SCM_ARRAY_DIMS (ra0)->ubnd;
ra0 = SCM_ARRAY_V (ra0);
if (SCM_NULLP (ras))
- for (; i <= n; i++, i0 += inc0)
- scm_apply (proc, scm_cvref (ra0, i0, SCM_UNDEFINED), scm_listofnull);
+ for (; i <= n; i++, i0 += inc0)
+ scm_apply (proc, scm_cvref (ra0, i0, SCM_UNDEFINED), scm_listofnull);
else
{
SCM ra1 = SCM_CAR (ras);
ra1 = SCM_ARRAY_V (ra1);
ras = SCM_CDR (ras);
if (SCM_NULLP(ras))
- ras = scm_nullvect;
+ ras = scm_nullvect;
else
{
ras = scm_vector (ras);
SCM_DEFINE (scm_array_for_each, "array-for-each", 2, 0, 1,
- (SCM proc, SCM ra0, SCM lra),
+ (SCM proc, SCM ra0, SCM lra),
"@var{proc} is applied to each tuple of elements of @var{array0} @dots{}\n"
"in row-major order. The value returned is unspecified.")
#define FUNC_NAME s_scm_array_for_each
{
SCM_VALIDATE_PROC (1,proc);
- SCM_RAMAPC (rafe, proc, ra0, lra);
+ scm_ramapc (rafe, proc, ra0, lra, FUNC_NAME);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_array_index_map_x, "array-index-map!", 2, 0, 0,
- (SCM ra, SCM proc),
+ (SCM ra, SCM proc),
"applies @var{proc} to the indices of each element of @var{array} in\n"
"turn, storing the result in the corresponding element. The value\n"
"returned and the order of application are unspecified.\n\n"
{
SCM args = SCM_EOL;
SCM inds = scm_make_uve (SCM_ARRAY_NDIM (ra), SCM_MAKINUM (-1L));
- long *vinds = SCM_VELTS (inds);
+ long *vinds = (long *) SCM_VELTS (inds);
int j, k, kmax = SCM_ARRAY_NDIM (ra) - 1;
if (kmax < 0)
return scm_array_set_x (ra, scm_apply(proc, SCM_EOL, SCM_EOL),
scm_sizet n = SCM_LENGTH (ra0);
ra1 = SCM_CAR (ra1);
if (SCM_ARRAYP(ra0))
- {
- n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
- i0 = SCM_ARRAY_BASE (ra0);
- inc0 = SCM_ARRAY_DIMS (ra0)->inc;
- ra0 = SCM_ARRAY_V (ra0);
- }
+ {
+ n = SCM_ARRAY_DIMS (ra0)->ubnd - SCM_ARRAY_DIMS (ra0)->lbnd + 1;
+ i0 = SCM_ARRAY_BASE (ra0);
+ inc0 = SCM_ARRAY_DIMS (ra0)->inc;
+ ra0 = SCM_ARRAY_V (ra0);
+ }
if (SCM_ARRAYP (ra1))
+ {
+ i1 = SCM_ARRAY_BASE (ra1);
+ inc1 = SCM_ARRAY_DIMS (ra1)->inc;
+ ra1 = SCM_ARRAY_V (ra1);
+ }
+ switch (SCM_TYP7 (ra0))
+ {
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ default:
+ for (; n--; i0 += inc0, i1 += inc1)
+ {
+ if (SCM_FALSEP (as_equal))
+ {
+ if (SCM_FALSEP (scm_array_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1))))
+ return 0;
+ }
+ else if (SCM_FALSEP (scm_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1))))
+ return 0;
+ }
+ return 1;
+ case scm_tc7_string:
+ case scm_tc7_byvect:
{
- i1 = SCM_ARRAY_BASE (ra1);
- inc1 = SCM_ARRAY_DIMS (ra1)->inc;
- ra1 = SCM_ARRAY_V (ra1);
+ char *v0 = SCM_CHARS (ra0) + i0;
+ char *v1 = SCM_CHARS (ra1) + i1;
+ for (; n--; v0 += inc0, v1 += inc1)
+ if (*v0 != *v1)
+ return 0;
+ return 1;
}
- switch (SCM_TYP7 (ra0))
+ case scm_tc7_bvect:
+ for (; n--; i0 += inc0, i1 += inc1)
+ if (SCM_BITVEC_REF (ra0, i0) != SCM_BITVEC_REF (ra1, i1))
+ return 0;
+ return 1;
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
{
- case scm_tc7_vector:
- case scm_tc7_wvect:
- default:
- for (; n--; i0 += inc0, i1 += inc1)
- {
- if (SCM_FALSEP (as_equal))
- {
- if (SCM_FALSEP (scm_array_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1))))
- return 0;
- }
- else if (SCM_FALSEP (scm_equal_p (RVREF (ra0, i0, e0), RVREF (ra1, i1, e1))))
- return 0;
- }
+ long *v0 = (long *) SCM_VELTS (ra0) + i0;
+ long *v1 = (long *) SCM_VELTS (ra1) + i1;
+ for (; n--; v0 += inc0, v1 += inc1)
+ if (*v0 != *v1)
+ return 0;
return 1;
- case scm_tc7_string:
- case scm_tc7_byvect:
- {
- char *v0 = SCM_CHARS (ra0) + i0;
- char *v1 = SCM_CHARS (ra1) + i1;
- for (; n--; v0 += inc0, v1 += inc1)
- if (*v0 != *v1)
- return 0;
- return 1;
- }
- case scm_tc7_bvect:
- for (; n--; i0 += inc0, i1 += inc1)
- if (BVE_REF (ra0, i0) != BVE_REF (ra1, i1))
+ }
+ case scm_tc7_svect:
+ {
+ short *v0 = (short *) SCM_VELTS (ra0) + i0;
+ short *v1 = (short *) SCM_VELTS (ra1) + i1;
+ for (; n--; v0 += inc0, v1 += inc1)
+ if (*v0 != *v1)
return 0;
return 1;
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- {
- long *v0 = (long *) SCM_VELTS (ra0) + i0;
- long *v1 = (long *) SCM_VELTS (ra1) + i1;
- for (; n--; v0 += inc0, v1 += inc1)
- if (*v0 != *v1)
- return 0;
- return 1;
- }
- case scm_tc7_svect:
- {
- short *v0 = (short *) SCM_VELTS (ra0) + i0;
- short *v1 = (short *) SCM_VELTS (ra1) + i1;
- for (; n--; v0 += inc0, v1 += inc1)
- if (*v0 != *v1)
- return 0;
- return 1;
- }
+ }
#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
- {
- long long *v0 = (long long *) SCM_VELTS (ra0) + i0;
- long long *v1 = (long long *) SCM_VELTS (ra1) + i1;
- for (; n--; v0 += inc0, v1 += inc1)
- if (*v0 != *v1)
- return 0;
- return 1;
- }
+ case scm_tc7_llvect:
+ {
+ long long *v0 = (long long *) SCM_VELTS (ra0) + i0;
+ long long *v1 = (long long *) SCM_VELTS (ra1) + i1;
+ for (; n--; v0 += inc0, v1 += inc1)
+ if (*v0 != *v1)
+ return 0;
+ return 1;
+ }
#endif
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
- case scm_tc7_fvect:
- {
- float *v0 = (float *) SCM_VELTS (ra0) + i0;
- float *v1 = (float *) SCM_VELTS (ra1) + i1;
- for (; n--; v0 += inc0, v1 += inc1)
- if (*v0 != *v1)
- return 0;
- return 1;
- }
+ case scm_tc7_fvect:
+ {
+ float *v0 = (float *) SCM_VELTS (ra0) + i0;
+ float *v1 = (float *) SCM_VELTS (ra1) + i1;
+ for (; n--; v0 += inc0, v1 += inc1)
+ if (*v0 != *v1)
+ return 0;
+ return 1;
+ }
#endif /* SCM_SINGLES */
- case scm_tc7_dvect:
- {
- double *v0 = (double *) SCM_VELTS (ra0) + i0;
- double *v1 = (double *) SCM_VELTS (ra1) + i1;
- for (; n--; v0 += inc0, v1 += inc1)
- if (*v0 != *v1)
+ case scm_tc7_dvect:
+ {
+ double *v0 = (double *) SCM_VELTS (ra0) + i0;
+ double *v1 = (double *) SCM_VELTS (ra1) + i1;
+ for (; n--; v0 += inc0, v1 += inc1)
+ if (*v0 != *v1)
+ return 0;
+ return 1;
+ }
+ case scm_tc7_cvect:
+ {
+ double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0) + i0;
+ double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1) + i1;
+ for (; n--; v0 += inc0, v1 += inc1)
+ {
+ if ((*v0)[0] != (*v1)[0])
return 0;
- return 1;
- }
- case scm_tc7_cvect:
- {
- double (*v0)[2] = (double (*)[2]) SCM_VELTS (ra0) + i0;
- double (*v1)[2] = (double (*)[2]) SCM_VELTS (ra1) + i1;
- for (; n--; v0 += inc0, v1 += inc1)
- {
- if ((*v0)[0] != (*v1)[0])
- return 0;
- if ((*v0)[1] != (*v1)[1])
- return 0;
- }
- return 1;
- }
-#endif /* SCM_FLOATS */
+ if ((*v0)[1] != (*v1)[1])
+ return 0;
+ }
+ return 1;
}
+#endif /* SCM_FLOATS */
+ }
}
scm_sizet bas0 = 0, bas1 = 0;
int k, unroll = 1, vlen = 1, ndim = 1;
if (SCM_ARRAYP (ra0))
- {
- ndim = SCM_ARRAY_NDIM (ra0);
- s0 = SCM_ARRAY_DIMS (ra0);
- bas0 = SCM_ARRAY_BASE (ra0);
- v0 = SCM_ARRAY_V (ra0);
- }
+ {
+ ndim = SCM_ARRAY_NDIM (ra0);
+ s0 = SCM_ARRAY_DIMS (ra0);
+ bas0 = SCM_ARRAY_BASE (ra0);
+ v0 = SCM_ARRAY_V (ra0);
+ }
else
{
s0->inc = 1;
unroll = 0;
}
if (SCM_ARRAYP (ra1))
- {
- if (ndim != SCM_ARRAY_NDIM (ra1))
- return 0;
- s1 = SCM_ARRAY_DIMS (ra1);
- bas1 = SCM_ARRAY_BASE (ra1);
- v1 = SCM_ARRAY_V (ra1);
- }
+ {
+ if (ndim != SCM_ARRAY_NDIM (ra1))
+ return 0;
+ s1 = SCM_ARRAY_DIMS (ra1);
+ bas1 = SCM_ARRAY_BASE (ra1);
+ v1 = SCM_ARRAY_V (ra1);
+ }
else
{
+ /*
+ Huh ? Schizophrenic return type. --hwn
+ */
if (1 != ndim)
- return SCM_BOOL_F;
+ return 0;
s1->inc = 1;
s1->lbnd = 0;
s1->ubnd = SCM_LENGTH (v1) - 1;
}
}
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), "");
}
#if 0
/* GJB:FIXME:: Why not use SCM_DEFINE1 for array-equal? */
SCM_DEFINE1 (scm_array_equal_p, "array-equal?", scm_tc7_rpsubr,
- (SCM ra0, SCM ra1),
+ (SCM ra0, SCM ra1),
"Returns @code{#t} iff all arguments are arrays with the same shape, the\n"
"same type, and have corresponding elements which are either\n"
"@code{equal?} or @code{array-equal?}. This function differs from\n"
scm_array_equal_p (SCM ra0, SCM ra1)
{
if (SCM_IMP (ra0) || SCM_IMP (ra1))
- callequal:return scm_equal_p (ra0, ra1);
+ callequal:return scm_equal_p (ra0, ra1);
switch (SCM_TYP7(ra0))
- {
- default:
+ {
+ default:
+ goto callequal;
+ case scm_tc7_bvect:
+ case scm_tc7_string:
+ case scm_tc7_byvect:
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ case scm_tc7_fvect:
+ case scm_tc7_dvect:
+ case scm_tc7_cvect:
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ break;
+ case scm_tc7_smob:
+ if (!SCM_ARRAYP (ra0))
goto callequal;
- case scm_tc7_bvect:
- case scm_tc7_string:
- case scm_tc7_byvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- case scm_tc7_vector:
- case scm_tc7_wvect:
- break;
- case scm_tc7_smob:
- if (!SCM_ARRAYP (ra0))
- goto callequal;
- }
+ }
switch (SCM_TYP7 (ra1))
- {
- default:
+ {
+ default:
+ goto callequal;
+ case scm_tc7_bvect:
+ case scm_tc7_string:
+ case scm_tc7_byvect:
+ case scm_tc7_uvect:
+ case scm_tc7_ivect:
+ case scm_tc7_fvect:
+ case scm_tc7_dvect:
+ case scm_tc7_cvect:
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ break;
+ case scm_tc7_smob:
+ if (!SCM_ARRAYP (ra1))
goto callequal;
- case scm_tc7_bvect:
- case scm_tc7_string:
- case scm_tc7_byvect:
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- case scm_tc7_fvect:
- case scm_tc7_dvect:
- case scm_tc7_cvect:
- case scm_tc7_vector:
- case scm_tc7_wvect:
- break;
- case scm_tc7_smob:
- if (!SCM_ARRAYP (ra1))
- goto callequal;
- }
+ }
return SCM_BOOL(raeql (ra0, SCM_BOOL_F, ra1));
}
"Record positions of source code expressions." },
{ SCM_OPTION_BOOLEAN, "case-insensitive", 0,
"Convert symbols to lower case."},
- { SCM_OPTION_SCM, "keywords", SCM_BOOL_F,
+ { SCM_OPTION_SCM, "keywords", SCM_ASWORD (SCM_BOOL_F),
"Style of keyword recognition: #f or 'prefix"}
};
goto tok;
case ':':
- if (SCM_KEYWORD_STYLE == scm_keyword_prefix)
+ if (SCM_ASSCM (SCM_KEYWORD_STYLE) == scm_keyword_prefix)
{
j = scm_read_token ('-', tok_buf, port, 0);
p = scm_intern (SCM_CHARS (*tok_buf), j);
scm_puts ("#<", port);
scm_puts (SCM_SMOBNAME (n) ? SCM_SMOBNAME (n) : "smob", port);
scm_putc (' ', port);
- scm_intprint (scm_smobs[n].size ? SCM_CDR (exp) : exp, 16, port);
+ scm_intprint (SCM_ASWORD (scm_smobs[n].size ? SCM_CDR (exp) : exp), 16, port);
scm_putc ('>', port);
return 1;
}
#define SCM_SMOB_DATA(x) SCM_CDR (x)
#define SCM_SET_SMOB_DATA(x, data) SCM_SETCDR (x, data)
-#define SCM_TC2SMOBNUM(x) (0x0ff & ((x) >> 8))
+#define SCM_TC2SMOBNUM(x) (0x0ff & (SCM_ASWORD(x) >> 8))
#define SCM_SMOBNUM(x) (SCM_TC2SMOBNUM (SCM_CAR (x)))
/* SCM_SMOBNAME can be 0 if name is missing */
#define SCM_SMOBNAME(smobnum) scm_smobs[smobnum].name
} scm_srcprops_chunk;
#define SRCPROPSP(p) (SCM_NIMP(p) && (SCM_TYP16 (p) == scm_tc16_srcprops))
-#define SRCPROPBRK(p) (SCM_BOOL((1L << 16) & SCM_CAR (p)))
+#define SRCPROPBRK(p) (SCM_BOOL((1L << 16) & SCM_CARW (p)))
#define SRCPROPPOS(p) ((scm_srcprops *) SCM_CDR (p))->pos
#define SRCPROPLINE(p) (SRCPROPPOS(p) >> 12)
#define SRCPROPCOL(p) (SRCPROPPOS(p) & 0x0fffL)
#define SRCBRKP(x) (SCM_NIMP (t.arg1 = scm_whash_lookup (scm_source_whash, (x)))\
&& SRCPROPSP (t.arg1)\
- && (1L << 16) & SCM_CAR (t.arg1))
+ && ((1L << 16) & SCM_ASWORD (SCM_CAR (t.arg1))))
#define PROCTRACEP(x) SCM_NFALSEP (scm_procedure_property (x, scm_sym_trace))
static void
read_frame (scm_debug_frame *dframe,long offset,scm_info_frame *iframe)
{
- SCM flags = SCM_INUM0;
+ SCMWORD flags = SCM_ASWORD (SCM_INUM0); /* UGh. */
int size;
scm_debug_info *info;
if (SCM_EVALFRAMEP (*dframe))
&& !SCM_UNBNDP (info[1].a.proc))
{
NEXT_FRAME (iframe, n, quit);
- iframe->flags = SCM_INUM0 | SCM_FRAMEF_PROC;
+ iframe->flags = SCM_ASWORD(SCM_INUM0) | SCM_FRAMEF_PROC;
iframe->proc = info[1].a.proc;
iframe->args = info[1].a.args;
}
{
if (!SCM_UNBNDP (info[1].a.proc))
{
- iframe->flags = SCM_INUM0 | SCM_FRAMEF_PROC;
+ iframe->flags = SCM_ASWORD(SCM_INUM0) | SCM_FRAMEF_PROC;
iframe->proc = info[1].a.proc;
iframe->args = info[1].a.args;
}
else
- iframe->flags = SCM_INUM0;
+ iframe->flags = SCM_ASWORD (SCM_INUM0);
iframe->source = scm_make_memoized (info[0].e.exp,
info[0].e.env);
info -= 2;
*/
typedef struct scm_info_frame {
- SCM flags;
+ //SCM flags;
+ SCMWORD flags;
SCM source;
SCM proc;
SCM args;
#define SCM_FRAMEF_EVAL_ARGS (1L << 5)
#define SCM_FRAMEF_OVERFLOW (1L << 6)
-#define SCM_FRAME_VOID_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_VOID)
-#define SCM_FRAME_REAL_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_REAL)
-#define SCM_FRAME_PROC_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_PROC)
-#define SCM_FRAME_EVAL_ARGS_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_EVAL_ARGS)
-#define SCM_FRAME_OVERFLOW_P(frame) (SCM_FRAME_FLAGS (frame) & SCM_FRAMEF_OVERFLOW)
+#define SCM_FRAME_VOID_P(frame) (SCM_ASWORD (SCM_FRAME_FLAGS (frame)) & SCM_FRAMEF_VOID)
+#define SCM_FRAME_REAL_P(frame) (SCM_ASWORD (SCM_FRAME_FLAGS (frame)) & SCM_FRAMEF_REAL)
+#define SCM_FRAME_PROC_P(frame) (SCM_ASWORD (SCM_FRAME_FLAGS (frame)) & SCM_FRAMEF_PROC)
+#define SCM_FRAME_EVAL_ARGS_P(frame) (SCM_ASWORD (SCM_FRAME_FLAGS (frame)) & SCM_FRAMEF_EVAL_ARGS)
+#define SCM_FRAME_OVERFLOW_P(frame) (SCM_ASWORD (SCM_FRAME_FLAGS (frame)) & SCM_FRAMEF_OVERFLOW)
\f
if (pt->read_pos >= pt->read_end)
return EOF;
else
- return scm_return_first (*pt->read_pos, port);
+ return scm_return_first (*pt->read_pos, port); /* huh? -- hwn*/
}
/* change the size of a port's string to new_size. this doesn't
if (target >= pt->write_buf_size)
{
- if (!(SCM_CAR (port) & SCM_WRTNG))
+ if (!(SCM_CARW (port) & SCM_WRTNG))
{
if (target > pt->write_buf_size)
{
{
tailp = 1;
prot = prot == 'R' ? 'r' : prot == 'W' ? 'w' : 'o';
- *mem++ = tail_elts;
+ *mem++ = SCM_ASSCM (tail_elts);
n_fields += tail_elts - 1;
if (n_fields == 0)
break;
SCM *p = block + n_extra;
/* Adjust it even further so it's aligned on an eight-byte boundary. */
- p = (SCM *) (((SCM) p + 7) & ~7);
+ p = (SCM *) (((SCMWORD) SCM_ASWORD (p) + 7) & ~7);
/* Initialize a few fields as described above. */
p[scm_struct_i_free] = (SCM) scm_struct_free_standard;
scm_struct_free_light (SCM *vtable, SCM *data)
{
free (data);
- return vtable[scm_struct_i_size] & ~SCM_STRUCTF_MASK;
+ return SCM_ASWORD (vtable[scm_struct_i_size]) & ~SCM_STRUCTF_MASK;
}
scm_sizet
scm_struct_free_standard (SCM *vtable, SCM *data)
{
- size_t n = ((data[scm_struct_i_n_words] + scm_struct_n_extra_words)
+ size_t n = ((SCM_ASWORD (data[scm_struct_i_n_words]) + scm_struct_n_extra_words)
* sizeof (SCM) + 7);
free ((void *) data[scm_struct_i_ptr]);
return n;
scm_sizet
scm_struct_free_entity (SCM *vtable, SCM *data)
{
- size_t n = ((data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words)
+ size_t n = (SCM_ASWORD(data[scm_struct_i_n_words] + scm_struct_entity_n_extra_words)
* sizeof (SCM) + 7);
free ((void *) data[scm_struct_i_ptr]);
return n;
tail_elts = SCM_INUM (tail_array_size);
SCM_NEWCELL (handle);
SCM_DEFER_INTS;
- if (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags] & SCM_STRUCTF_ENTITY)
+ if (SCM_ASWORD (SCM_STRUCT_DATA (vtable)[scm_struct_i_flags]) & SCM_STRUCTF_ENTITY)
{
data = scm_alloc_struct (basic_size + tail_elts,
scm_struct_entity_n_extra_words,
SCM * data;
SCM layout;
int p;
- int n_fields;
+ SCMWORD n_fields;
unsigned char * fields_desc;
unsigned char field_type = 0;
{
/* The length of the hash table should be a relative prime it's not
necessary to shift down the address. */
- return obj % n;
+ return SCM_ASWORD (obj) % n;
}
SCM
else
scm_puts ("struct", port);
scm_putc (' ', port);
- scm_intprint (vtable, 16, port);
+ scm_intprint ((int) vtable, 16, port);
scm_putc (':', port);
- scm_intprint (exp, 16, port);
+ scm_intprint ((int)exp, 16, port);
scm_putc ('>', port);
}
}
return SCM_CDR (scm_utag_immediate_char) ;
else
{
- int tag;
- tag = SCM_MAKINUM ((x >> 8) & 0xff);
- return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_flag_base) ) | (tag << 8));
+ SCM tag = SCM_MAKINUM ((SCM_ASWORD (x) >> 8) & 0xff);
+ return SCM_MAKINUM (SCM_INUM (SCM_CDR (scm_utag_flag_base) ) | (SCM_ASWORD (tag) << 8));
}
case scm_tc3_cons:
\f
+
/* 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,
* (Not always impossible but it is fair to say that many details of tags
* are mutually dependent). */
-#define SCM_IMP(x) (6 & (SCM) (x))
+#define SCM_IMP(x) (6 & SCM_ASWORD(x))
#define SCM_NIMP(x) (!SCM_IMP (x))
/* Here is a summary of tagging in SCM values as they might occur in
* stored in the SCM_CAR of a non-immediate object have a 1 in bit 1:
*/
-#define SCM_SLOPPY_NCONSP(x) (1 & SCM_CAR (x))
+#define SCM_SLOPPY_NCONSP(x) (1 & SCM_CARW (x))
#define SCM_SLOPPY_CONSP(x) (!SCM_SLOPPY_NCONSP(x))
#define SCM_NCONSP(x) (SCM_IMP (x) || SCM_SLOPPY_NCONSP(x))
\f
#define SCM_CELLP(x) (!SCM_NCELLP (x))
-#define SCM_NCELLP(x) ((sizeof (scm_cell) - 1) & (SCM) (x))
+#define SCM_NCELLP(x) ((sizeof (scm_cell) - 1) & (SCMWORD) SCM_ASWORD(x))
/* See numbers.h for macros relating to immediate integers.
*/
-#define SCM_ITAG3(x) (7 & (SCM) x)
-#define SCM_TYP3(x) (7 & SCM_CAR (x))
+#define SCM_ITAG3(x) (7 & SCM_ASWORD(x))
+#define SCM_TYP3(x) (7 & SCM_CARW (x))
#define scm_tc3_cons 0
#define scm_tc3_cons_gloc 1
#define scm_tc3_int_1 2
-#define scm_tc3_closure 3
-#define scm_tc3_imm24 4
-#define scm_tc3_tc7_1 5
-#define scm_tc3_int_2 6
-#define scm_tc3_tc7_2 7
+#define scm_tc3_closure 3
+#define scm_tc3_imm24 4
+#define scm_tc3_tc7_1 5
+#define scm_tc3_int_2 6
+#define scm_tc3_tc7_2 7
/*
*/
-#define SCM_TYP7(x) (SCM_CAR (x) & 0x7f)
-#define SCM_TYP7S(x) (SCM_CAR (x) & (0x7f & ~2))
+#define SCM_TYP7(x) (0x7f & SCM_CARW (x))
+#define SCM_TYP7S(x) ((0x7f & ~2) & SCM_CARW (x))
-#define SCM_TYP16(x) (0xffff & SCM_CAR (x))
-#define SCM_TYP16S(x) (0xfeff & SCM_CAR (x))
-#define SCM_GCTYP16(x) (0xff7f & SCM_CAR (x))
+#define SCM_TYP16(x) (0xffff & SCM_CARW (x))
+#define SCM_TYP16S(x) (0xfeff & SCM_CARW (x))
+#define SCM_GCTYP16(x) (0xff7f & SCM_CARW (x))
/* Testing and Changing GC Marks in Various Standard Positions
*/
-#define SCM_GCMARKP(x) (1 & SCM_CDR (x))
-#define SCM_GC8MARKP(x) (0x80 & SCM_CAR (x))
+#define SCM_GCMARKP(x) (1 & SCM_ASWORD (SCM_CDR (x)))
+#define SCM_GC8MARKP(x) (0x80 & SCM_CARW (x))
#define SCM_SETGCMARK(x) SCM_SETOR_CDR (x, 1)
#define SCM_CLRGCMARK(x) SCM_SETAND_CDR (x, ~1L)
#define SCM_SETGC8MARK(x) SCM_SETOR_CAR (x, 0x80)
scm_tc8_iloc = 0xfc
};
-#define SCM_ITAG8(X) ((SCM) (X) & 0xff)
-#define SCM_MAKE_ITAG8(X, TAG) (((X) << 8) + TAG)
-#define SCM_ITAG8_DATA(X) ((X) >> 8)
+#define SCM_ITAG8(X) (SCM_ASWORD(X) & 0xff)
+#define SCM_MAKE_ITAG8(X, TAG) SCM_ASSCM(((X) << 8) + TAG)
+#define SCM_ITAG8_DATA(X) (SCM_ASWORD(X) >> 8)
\f
*/
/* SCM_ISYMP tests for ISPCSYM and ISYM */
-#define SCM_ISYMP(n) ((0x187 & (SCM) (n)) == 4)
+#define SCM_ISYMP(n) ((0x187 & SCM_ASWORD(n)) == 4)
/* SCM_IFLAGP tests for ISPCSYM, ISYM and IFLAG */
-#define SCM_IFLAGP(n) ((0x87 & (SCM) (n)) == 4)
-#define SCM_ISYMNUM(n) ((SCM) ((n) >> 9))
+#define SCM_IFLAGP(n) ((0x87 & SCM_ASWORD(n)) == 4)
+#define SCM_ISYMNUM(n) (SCM_ASWORD(n) >> 9)
#define SCM_ISYMCHARS(n) (scm_isymnames[SCM_ISYMNUM (n)])
-#define SCM_MAKSPCSYM(n) (((n) << 9) + ((n) << 3) + 4L)
-#define SCM_MAKISYM(n) (((n) << 9) + 0x74L)
-#define SCM_MAKIFLAG(n) (((n) << 9) + 0x174L)
+#define SCM_MAKSPCSYM(n) SCM_ASSCM(((n) << 9) + ((n) << 3) + 4L)
+#define SCM_MAKISYM(n) SCM_ASSCM(((n) << 9) + 0x74L)
+#define SCM_MAKIFLAG(n) SCM_ASSCM(((n) << 9) + 0x174L)
extern char *scm_isymnames[]; /* defined in print.c */
/* the jump buffer data structure */
static int scm_tc16_jmpbuffer;
-#define SCM_JMPBUFP(O) (SCM_NIMP(O) && (SCM_TYP16(O) == scm_tc16_jmpbuffer))
-#define JBACTIVE(O) (SCM_CAR (O) & (1L << 16L))
-#define ACTIVATEJB(O) (SCM_SETOR_CAR (O, (1L << 16L)))
-#define DEACTIVATEJB(O) (SCM_SETAND_CAR (O, ~(1L << 16L)))
+#define SCM_JMPBUFP(OBJ) (SCM_NIMP(OBJ) && (SCM_TYP16(OBJ) == scm_tc16_jmpbuffer))
+
+#define JBACTIVE(OBJ) (SCM_CARW (OBJ) & (1L << 16L))
+#define ACTIVATEJB(OBJ) (SCM_SETOR_CAR (OBJ, (1L << 16L)))
+#define DEACTIVATEJB(OBJ) (SCM_SETAND_CAR (OBJ, ~(1L << 16L)))
#ifndef DEBUG_EXTENSIONS
-#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (O) )
+#define JBJMPBUF(OBJ) ((jmp_buf*)SCM_CDR (OBJ) )
#define SETJBJMPBUF SCM_SETCDR
#else
-#define SCM_JBDFRAME(O) ((scm_debug_frame*)SCM_CAR (SCM_CDR (O)) )
-#define JBJMPBUF(O) ((jmp_buf*)SCM_CDR (SCM_CDR (O)) )
-#define SCM_SETJBDFRAME(O,X) SCM_SETCAR (SCM_CDR (O), (SCM)(X))
-#define SETJBJMPBUF(O,X) SCM_SETCDR(SCM_CDR (O), X)
+#define SCM_JBDFRAME(OBJ) ((scm_debug_frame*)SCM_CAR (SCM_CDR (OBJ)) )
+#define JBJMPBUF(OBJ) ((jmp_buf*)SCM_CDR (SCM_CDR (OBJ)) )
+#define SCM_SETJBDFRAME(OBJ,X) SCM_SETCAR (SCM_CDR (OBJ), (SCM)(X))
+#define SETJBJMPBUF(OBJ,X) SCM_SETCDR(SCM_CDR (OBJ), X)
static scm_sizet
freejb (SCM jbsmob)
{
scm_puts ("#<jmpbuffer ", 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);
return 1 ;
}
}
#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:
/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
+/*
+ This file has code for arrays in lots of variants (double, integer,
+ unsigned etc. ). It suffers from hugely repetitive code because
+ there is similar (but different) code for every variant included. (urg.)
+
+ --hwn
+*/
\f
#include <stdio.h>
enclosed = 0;
if (SCM_IMP (v))
return SCM_BOOL_F;
-loop:
- switch (SCM_TYP7 (v))
+
+ while (SCM_TYP7 (v) == scm_tc7_smob)
{
- case scm_tc7_smob:
if (!SCM_ARRAYP (v))
return SCM_BOOL_F;
if (nprot)
if (enclosed++)
return SCM_BOOL_F;
v = SCM_ARRAY_V (v);
- goto loop;
- case scm_tc7_bvect:
- return nprot || SCM_BOOL(SCM_BOOL_T==prot);
- case scm_tc7_string:
- return nprot || SCM_BOOL(SCM_CHARP(prot) && (prot != SCM_MAKE_CHAR('\0')));
- case scm_tc7_byvect:
- return nprot || SCM_BOOL(prot == SCM_MAKE_CHAR('\0'));
- case scm_tc7_uvect:
- return nprot || SCM_BOOL(SCM_INUMP(prot) && SCM_INUM(prot)>0);
- case scm_tc7_ivect:
- return nprot || SCM_BOOL(SCM_INUMP(prot) && SCM_INUM(prot)<=0);
- case scm_tc7_svect:
- return ( nprot
- || (SCM_SYMBOLP (prot)
- && (1 == SCM_LENGTH (prot))
- && ('s' == SCM_CHARS (prot)[0])));
+ }
+ if (nprot)
+ return SCM_BOOL(nprot);
+ else
+ {
+ int protp = 0;
+
+ switch (SCM_TYP7 (v))
+ {
+ case scm_tc7_bvect:
+ protp = (SCM_BOOL_T==prot);
+ case scm_tc7_string:
+ protp = SCM_ICHRP(prot) && (prot != SCM_MAKICHR('\0'));
+ case scm_tc7_byvect:
+ protp = prot == SCM_MAKICHR('\0');
+ case scm_tc7_uvect:
+ protp = SCM_INUMP(prot) && SCM_INUM(prot)>0;
+ case scm_tc7_ivect:
+ protp = SCM_INUMP(prot) && SCM_INUM(prot)<=0;
+
+ case scm_tc7_svect:
+ protp = SCM_SYMBOLP (prot)
+ && (1 == SCM_LENGTH (prot))
+ && ('s' == SCM_CHARS (prot)[0]);
#ifdef HAVE_LONG_LONGS
- case scm_tc7_llvect:
- return ( nprot
- || (SCM_SYMBOLP (prot)
- && (1 == SCM_LENGTH (prot))
- && ('s' == SCM_CHARS (prot)[0])));
+ case scm_tc7_llvect:
+ protp = SCM_SYMBOLP (prot)
+ && (1 == SCM_LENGTH (prot))
+ && ('s' == SCM_CHARS (prot)[0]);
#endif
# ifdef SCM_FLOATS
# ifdef SCM_SINGLES
- case scm_tc7_fvect:
- return nprot || SCM_BOOL(SCM_SINGP(prot));
+ case scm_tc7_fvect:
+ protp = SCM_SINGP(prot);
# endif
- case scm_tc7_dvect:
- return nprot || SCM_BOOL(SCM_REALP(prot));
- case scm_tc7_cvect:
- return nprot || SCM_BOOL(SCM_CPLXP(prot));
+ case scm_tc7_dvect:
+ protp = SCM_REALP(prot);
+ case scm_tc7_cvect:
+ protp = SCM_CPLXP(prot);
# endif
- case scm_tc7_vector:
- case scm_tc7_wvect:
- return nprot || SCM_BOOL(SCM_NULLP(prot));
- default:;
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ protp = SCM_NULLP(prot);
+ default:
+ /* no default */
+ ;
+ }
+ return SCM_BOOL(protp);
}
- return SCM_BOOL_F;
}
#undef FUNC_NAME
badarg:
SCM_WTA (1,v);
abort ();
- outrng:scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos));
- wna: scm_wrong_num_args (SCM_FUNC_NAME);
+
+ outrng:
+ scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos));
+ wna:
+ scm_wrong_num_args (SCM_FUNC_NAME);
case scm_tc7_smob:
{ /* enclosed */
int k = SCM_ARRAY_NDIM (v);
return res;
}
case scm_tc7_bvect:
- if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT)))
+ if (SCM_BITVEC_REF (v, pos))
return SCM_BOOL_T;
else
return SCM_BOOL_F;
return SCM_MAKINUM (SCM_VELTS (v)[pos]);
# else
case scm_tc7_uvect:
- return scm_ulong2num(SCM_VELTS(v)[pos]);
+ return scm_ulong2num((unsigned long ) SCM_VELTS(v)[pos]);
case scm_tc7_ivect:
- return scm_long2num(SCM_VELTS(v)[pos]);
+ return scm_long2num((long) SCM_VELTS(v)[pos]);
# endif
case scm_tc7_svect:
default:
scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref");
case scm_tc7_bvect:
- if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT)))
+ if (SCM_BITVEC_REF(v,pos))
return SCM_BOOL_T;
else
return SCM_BOOL_F;
return SCM_MAKINUM (SCM_VELTS (v)[pos]);
# else
case scm_tc7_uvect:
- return scm_ulong2num(SCM_VELTS(v)[pos]);
+ return scm_ulong2num((unsigned long) SCM_VELTS(v)[pos]);
case scm_tc7_ivect:
- return scm_long2num(SCM_VELTS(v)[pos]);
+ return scm_long2num((long) SCM_VELTS(v)[pos]);
# endif
case scm_tc7_svect:
return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]);
#ifdef SCM_FLOATS
#ifdef SCM_SINGLES
case scm_tc7_fvect:
- if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_flo == SCM_CAR (last)))
+ if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_flo == SCM_CARW (last)))
{
SCM_FLO (last) = ((float *) SCM_CDR (v))[pos];
return last;
#endif
case scm_tc7_dvect:
#ifdef SCM_SINGLES
- if (SCM_NIMP (last) && scm_tc_dblr == SCM_CAR (last))
+ if (SCM_NIMP (last) && scm_tc_dblr == SCM_CARW (last))
#else
if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_dblr == SCM_CAR (last)))
#endif
}
return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0);
case scm_tc7_cvect:
- if (SCM_NIMP (last) && scm_tc_dblc == SCM_CAR (last))
+ if (SCM_NIMP (last) && scm_tc_dblc == SCM_CARW (last))
{
SCM_REAL (last) = ((double *) SCM_CDR (v))[2 * pos];
SCM_IMAG (last) = ((double *) SCM_CDR (v))[2 * pos + 1];
default: badarg1:
SCM_WTA (1,v);
abort ();
- outrng:scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos));
- wna: scm_wrong_num_args (SCM_FUNC_NAME);
+ outrng:
+ scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos));
+ wna:
+ scm_wrong_num_args (SCM_FUNC_NAME);
case scm_tc7_smob: /* enclosed */
goto badarg1;
case scm_tc7_bvect:
if (SCM_BOOL_F == obj)
- SCM_VELTS (v)[pos / SCM_LONG_BIT] &= ~(1L << (pos % SCM_LONG_BIT));
+ SCM_BITVEC_CLR(v,pos);
else if (SCM_BOOL_T == obj)
- SCM_VELTS (v)[pos / SCM_LONG_BIT] |= (1L << (pos % SCM_LONG_BIT));
+ SCM_BITVEC_SET(v,pos);
else
badobj:SCM_WTA (2,obj);
break;
SCM_ASRTGO (SCM_INUM (obj) >= 0, badobj);
/* fall through */
case scm_tc7_ivect:
- SCM_ASRTGO(SCM_INUMP(obj), badobj); SCM_VELTS(v)[pos] = SCM_INUM(obj); break;
+ SCM_ASRTGO(SCM_INUMP(obj), badobj); SCM_VELTS(v)[pos] = SCM_INUM(obj);
+ break;
# else
case scm_tc7_uvect:
- SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG2, FUNC_NAME); break;
+ SCM_VELTS(v)[pos] = SCM_ASSCM (scm_num2ulong(obj, (char *)SCM_ARG2, FUNC_NAME));
+ break;
case scm_tc7_ivect:
- SCM_VELTS(v)[pos] = scm_num2long(obj, (char *)SCM_ARG2, FUNC_NAME); break;
+ SCM_VELTS(v)[pos] = SCM_ASSCM (scm_num2long(obj, (char *)SCM_ARG2, FUNC_NAME));
+ break;
# endif
case scm_tc7_svect:
SCM_ASRTGO (SCM_INUMP (obj), badobj);
#define FUNC_NAME s_scm_bit_count
{
long i;
- register unsigned long cnt = 0, w;
+ register unsigned long cnt = 0;
+ register unsigned long w;
SCM_VALIDATE_INUM (2,seq);
switch SCM_TYP7 (seq)
{
if (0 == SCM_LENGTH (seq))
return SCM_INUM0;
i = (SCM_LENGTH (seq) - 1) / SCM_LONG_BIT;
- w = SCM_VELTS (seq)[i];
+ w = SCM_ASWORD (SCM_VELTS (seq)[i]);
if (SCM_FALSEP (item))
w = ~w;
w <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (seq) - 1) % SCM_LONG_BIT);
cnt += cnt_tab[w & 0x0f];
if (0 == i--)
return SCM_MAKINUM (cnt);
- w = SCM_VELTS (seq)[i];
+ w = SCM_ASWORD (SCM_VELTS (seq)[i]);
if (SCM_FALSEP (item))
w = ~w;
}
return SCM_MAKINUM (-1L);
lenw = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */
i = pos / SCM_LONG_BIT;
- w = SCM_VELTS (v)[i];
+ w = SCM_ASWORD (SCM_VELTS (v)[i]);
if (SCM_FALSEP (item))
w = ~w;
xbits = (pos % SCM_LONG_BIT);
if (++i > lenw)
break;
pos += SCM_LONG_BIT;
- w = SCM_VELTS (v)[i];
+ w = SCM_ASWORD (SCM_VELTS (v)[i]);
if (SCM_FALSEP (item))
w = ~w;
}
switch SCM_TYP7 (v)
{
default:
- badarg1:SCM_WTA (1,v);
+ badarg1: SCM_WTA (1,v);
case scm_tc7_bvect:
vlen = SCM_LENGTH (v);
if (SCM_BOOL_F == obj)
for (i = SCM_LENGTH (kv); i;)
{
- k = SCM_VELTS (kv)[--i];
+ k = SCM_ASWORD (SCM_VELTS (kv)[--i]);
SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME);
- SCM_VELTS (v)[k / SCM_LONG_BIT] &= ~(1L << (k % SCM_LONG_BIT));
+ SCM_BITVEC_CLR(v,k);
}
else if (SCM_BOOL_T == obj)
for (i = SCM_LENGTH (kv); i;)
{
- k = SCM_VELTS (kv)[--i];
+ k = SCM_ASWORD (SCM_VELTS (kv)[--i]);
SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME);
- SCM_VELTS (v)[k / SCM_LONG_BIT] |= (1L << (k % SCM_LONG_BIT));
+ SCM_BITVEC_SET(v,k);
}
else
badarg3:SCM_WTA (3,obj);
SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1);
if (SCM_BOOL_F == obj)
for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
- SCM_VELTS (v)[k] &= ~(SCM_VELTS (kv)[k]);
+ SCM_ASWORD (SCM_VELTS (v)[k]) &= ~ SCM_ASWORD(SCM_VELTS (kv)[k]);
else if (SCM_BOOL_T == obj)
for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
- SCM_VELTS (v)[k] |= SCM_VELTS (kv)[k];
+ SCM_ASWORD (SCM_VELTS (v)[k]) |= SCM_ASWORD (SCM_VELTS (kv)[k]);
else
goto badarg3;
break;
{
register long i, vlen, count = 0;
register unsigned long k;
+
SCM_ASRTGO (SCM_NIMP (v), badarg1);
SCM_ASRTGO (SCM_NIMP (kv), badarg2);
switch SCM_TYP7 (kv)
{
default:
- badarg2:SCM_WTA (2,kv);
+ badarg2:
+ SCM_WTA (2,kv);
case scm_tc7_uvect:
switch SCM_TYP7
(v)
{
default:
- badarg1:SCM_WTA (1,v);
+ badarg1:
+ SCM_WTA (1,v);
case scm_tc7_bvect:
vlen = SCM_LENGTH (v);
if (SCM_BOOL_F == obj)
for (i = SCM_LENGTH (kv); i;)
{
- k = SCM_VELTS (kv)[--i];
+ k = SCM_ASWORD (SCM_VELTS (kv)[--i]);
SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME);
- if (!(SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT))))
+ if (!SCM_BITVEC_REF(v,k))
count++;
}
else if (SCM_BOOL_T == obj)
for (i = SCM_LENGTH (kv); i;)
{
- k = SCM_VELTS (kv)[--i];
+ k = SCM_ASWORD (SCM_VELTS (kv)[--i]);
SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME);
- if (SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT)))
+ if (SCM_BITVEC_REF (v,k))
count++;
}
else
if (0 == SCM_LENGTH (v))
return SCM_INUM0;
SCM_ASRTGO (SCM_BOOL_T == obj || SCM_BOOL_F == obj, badarg3);
- obj = (SCM_BOOL_T == obj);
+ obj = (SCM_BOOL_T == obj); /* ugh. */
i = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT;
- k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]);
+ k = SCM_ASWORD (SCM_VELTS (kv)[i]) & (obj ? SCM_ASWORD (SCM_VELTS (v)[i]) : ~ SCM_ASWORD (SCM_VELTS (v)[i]));
k <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (v) - 1) % SCM_LONG_BIT);
- while (!0)
+ while (1)
{
for (; k; k >>= 4)
count += cnt_tab[k & 0x0f];
if (0 == i--)
return SCM_MAKINUM (count);
- k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]);
+
+ /* urg. repetitive (see above.) */
+ k = SCM_ASWORD (SCM_VELTS (kv)[i]) & (obj ? SCM_ASWORD(SCM_VELTS (v)[i]) : ~SCM_ASWORD (SCM_VELTS (v)[i]));
}
}
return SCM_MAKINUM (count);
{
case scm_tc7_bvect:
for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
- SCM_VELTS (v)[k] = ~SCM_VELTS (v)[k];
+ SCM_ASWORD (SCM_VELTS (v)[k]) = ~SCM_ASWORD(SCM_VELTS (v)[k]);
break;
default:
badarg1:SCM_WTA (1,v);
}
case scm_tc7_ivect:
if (n-- > 0)
- scm_intprint (SCM_VELTS (ra)[j], 10, port);
+ scm_intprint ((int)SCM_VELTS (ra)[j], 10, port);
for (j += inc; n-- > 0; j += inc)
{
scm_putc (' ', port);
- scm_intprint (SCM_VELTS (ra)[j], 10, port);
+ scm_intprint ((int)SCM_VELTS (ra)[j], 10, port);
}
break;
scm_putc ('*', port);
for (i = 0; i < (SCM_LENGTH (exp)) / SCM_LONG_BIT; i++)
{
- w = SCM_VELTS (exp)[i];
+ SCMWORD w = SCM_ASWORD (SCM_VELTS (exp)[i]);
for (j = SCM_LONG_BIT; j; j--)
{
scm_putc (w & 1 ? '1' : '0', port);
j = SCM_LENGTH (exp) % SCM_LONG_BIT;
if (j)
{
- w = SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT];
+ w = SCM_ASWORD (SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT]);
for (; j; j--)
{
scm_putc (w & 1 ? '1' : '0', port);
extern long scm_tc16_array;
-#define SCM_ARRAYP(a) (SCM_NIMP(a) && (scm_tc16_array==SCM_TYP16(a)))
-#define SCM_ARRAY_NDIM(x) ((scm_sizet)(SCM_CAR(x)>>17))
+#define SCM_ARRAYP(a) (SCM_NIMP(a) && (scm_tc16_array == SCM_TYP16(a)))
+#define SCM_ARRAY_NDIM(x) ((scm_sizet)(SCM_CARW(x)>>17))
#define SCM_ARRAY_CONTIGUOUS 0x10000
-#define SCM_ARRAY_CONTP(x) (SCM_ARRAY_CONTIGUOUS & (int)SCM_CAR(x))
+#define SCM_ARRAY_CONTP(x) (SCM_ARRAY_CONTIGUOUS & (int)(SCM_CARW(x)))
#define SCM_ARRAY_V(a) (((scm_array *)SCM_CDR(a))->v)
#define SCM_ARRAY_BASE(a) (((scm_array *)SCM_CDR(a))->base)
prin_var (SCM exp,SCM port,scm_print_state *pstate)
{
scm_puts ("#<variable ", port);
- scm_intprint(exp, 16, port);
+ scm_intprint((int) exp, 16, port);
{
SCM val_cell;
val_cell = SCM_CDR(exp);
extern int scm_tc16_variable;
#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_DEFVARIABLEP(X) (SCM_VARIABLEP(X) && !SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X))))
#define SCM_VELTS(x) ((SCM *)SCM_CDR(x))
#define SCM_SETVELTS SCM_SETCDR
+
+\f
+/*
+ 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))
+
+
\f
extern SCM scm_vector_set_length_x (SCM vect, SCM len);
SCM_VALIDATE_INUM (1,k);
v = scm_make_weak_vector (k, SCM_EOL);
SCM_ALLOW_INTS;
- SCM_VELTS (v)[-1] = 1;
+ SCM_ASWORD (SCM_VELTS (v)[-1]) = 1;
SCM_ALLOW_INTS;
return v;
}
SCM_VALIDATE_INUM (1,k);
v = scm_make_weak_vector (k, SCM_EOL);
SCM_ALLOW_INTS;
- SCM_VELTS (v)[-1] = 2;
+ SCM_ASWORD (SCM_VELTS (v)[-1]) = 2;
SCM_ALLOW_INTS;
return v;
}
SCM_VALIDATE_INUM (1,k);
v = scm_make_weak_vector (k, SCM_EOL);
SCM_ALLOW_INTS;
- SCM_VELTS (v)[-1] = 3;
+ SCM_ASWORD (SCM_VELTS (v)[-1]) = 3;
SCM_ALLOW_INTS;
return v;
}
#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_V(X) (SCM_VELTS(X)[-1] == 2)
-#define SCM_IS_WHVEC_B(X) (SCM_VELTS(X)[-1] == 3)
+#define SCM_IS_WHVEC(X) (SCM_ASWORD (SCM_VELTS(X)[-1]) == 1)
+#define SCM_IS_WHVEC_V(X) (SCM_ASWORD (SCM_VELTS(X)[-1]) == 2)
+#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_WVECT_GC_CHAIN(X) (SCM_VELTS(X)[-2])
HCoop / bpt / guile.git / commitdiff