From fee7ef83a31a2c83711e726c8a346d554864352d Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Tue, 18 Apr 2000 14:12:07 +0000 Subject: [PATCH] Fixed some SCM/scm_bits_t mixups. --- libguile/ChangeLog | 28 ++++++++++++++++++++++++++++ libguile/options.c | 4 +--- libguile/print.c | 2 +- libguile/print.h | 2 +- libguile/ramap.c | 37 +++++++++++++++++++++++++++---------- libguile/read.c | 6 +++--- libguile/stacks.c | 4 ++-- libguile/strings.c | 11 ++++++----- libguile/struct.h | 2 +- libguile/unif.c | 27 +++++++++++++-------------- 10 files changed, 83 insertions(+), 40 deletions(-) diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 19f2ca09f..b20111198 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,31 @@ +2000-04-18 Dirk Herrmann + + * options.c (scm_options), read.c (recsexpr): Remove redundant + SCM_IMP test. + + * print.c (scm_iprin1): Made the access of the struct vcell + element explicit. + + * print.h (SCM_PRINT_CLOSURE): Added call to SCM_PACK. + + * ramap.c (scm_ra_eqp, ra_compare), unif.c + (scm_uniform_vector_ref, scm_cvref, rapr1): Separated accesses to + unsigned long and signed long arrays and clarified the way the + access is performed. + + * ramap.c (scm_array_map_x, raeql), read.c (scm_lreadr), stacks.c + (narrow_stack), unif.c (scm_cvref, scm_uniform_array_read_x, + scm_raprin1): Use SCM_EQ_P to compare SCM values. + + * strings.c (scm_makstr): Treat the msymbol slots as a field of + scm_bits_t values. + + * struct.h (SCM_SET_VTABLE_DESTRUCTOR): Treat the struct data as + a field of scm_bits_t values. + + * unif.c (l2ra): Don't test result of scm_array_set_x against + zero: It is always SCM_UNSPECIFIED. + 2000-04-18 Mikael Djurfeldt * script.c (scm_compile_shell_switches): Also enable diff --git a/libguile/options.c b/libguile/options.c index bb63cb24c..c59f18759 100644 --- a/libguile/options.c +++ b/libguile/options.c @@ -124,9 +124,7 @@ static SCM protected_objects; SCM scm_options (SCM arg, scm_option options[], int n, const char *s) { - int i, docp = (!SCM_UNBNDP (arg) - && !SCM_NULLP (arg) - && (SCM_IMP (arg) || SCM_NCONSP (arg))); + int i, docp = (!SCM_UNBNDP (arg) && !SCM_NULLP (arg) && !SCM_CONSP (arg)); /* Let `arg' GC protect the arguments */ SCM new_mode = arg, ans = SCM_EOL, ls; for (i = 0; i < n; ++i) diff --git a/libguile/print.c b/libguile/print.c index e92cd7835..8e5480602 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -349,7 +349,7 @@ taloop: { case scm_tcs_cons_gloc: - if (SCM_CDR ((SCM) SCM_STRUCT_VTABLE_DATA (exp)) == (SCM) 0) + if (SCM_STRUCT_VTABLE_DATA (exp) [scm_vtable_index_vcell] == 0) { ENTER_NESTED_DATA (pstate, exp, circref); if (SCM_OBJ_CLASS_FLAGS (exp) & SCM_CLASSF_GOOPS) diff --git a/libguile/print.h b/libguile/print.h index 1f2702be0..f72c62832 100644 --- a/libguile/print.h +++ b/libguile/print.h @@ -53,7 +53,7 @@ extern scm_option scm_print_opts[]; -#define SCM_PRINT_CLOSURE ((SCM) scm_print_opts[0].val) +#define SCM_PRINT_CLOSURE (SCM_PACK (scm_print_opts[0].val)) #define SCM_PRINT_SOURCE_P ((int) scm_print_opts[1].val) #define SCM_N_PRINT_OPTIONS 2 diff --git a/libguile/ramap.c b/libguile/ramap.c index 8c2f7bae2..853af5be1 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -848,10 +848,15 @@ scm_ra_eqp (SCM ra0, SCM ras) break; } case scm_tc7_uvect: + for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) + if (SCM_BITVEC_REF (ra0, i0)) + if (((unsigned long *) SCM_VELTS (ra1))[i1] != ((unsigned long *) SCM_VELTS (ra2))[i2]) + SCM_BITVEC_CLR (ra0, i0); + break; case scm_tc7_ivect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) if (SCM_BITVEC_REF (ra0, i0)) - if (SCM_VELTS (ra1)[i1] != SCM_VELTS (ra2)[i2]) + if (((signed long *) SCM_VELTS (ra1))[i1] != ((signed long *) SCM_VELTS (ra2))[i2]) SCM_BITVEC_CLR (ra0, i0); break; case scm_tc7_fvect: @@ -904,13 +909,22 @@ ra_compare (SCM ra0,SCM ra1,SCM ra2,int opt) break; } case scm_tc7_uvect: + for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) + { + if (SCM_BITVEC_REF (ra0, i0)) + if (opt ? + ((unsigned long *) SCM_VELTS (ra1))[i1] < ((unsigned long *) SCM_VELTS (ra2))[i2] : + ((unsigned long *) SCM_VELTS (ra1))[i1] >= ((unsigned long *) SCM_VELTS (ra2))[i2]) + SCM_BITVEC_CLR (ra0, i0); + } + break; case scm_tc7_ivect: for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) { if (SCM_BITVEC_REF (ra0, i0)) if (opt ? - SCM_VELTS (ra1)[i1] < SCM_VELTS (ra2)[i2] : - SCM_VELTS (ra1)[i1] >= SCM_VELTS (ra2)[i2]) + ((signed long *) SCM_VELTS (ra1))[i1] < ((signed long *) SCM_VELTS (ra2))[i2] : + ((signed long *) SCM_VELTS (ra1))[i1] >= ((signed long *) SCM_VELTS (ra2))[i2]) SCM_BITVEC_CLR (ra0, i0); } break; @@ -1511,7 +1525,7 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, goto gencase; scm_array_fill_x (ra0, SCM_BOOL_T); for (p = ra_rpsubrs; p->name; p++) - if (proc == p->sproc) + if (SCM_EQ_P (proc, p->sproc)) { while (SCM_NNULLP (lra) && SCM_NNULLP (SCM_CDR (lra))) { @@ -1548,19 +1562,22 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, /* 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))) + if (SCM_EQ_P (v0, ra1) + || (SCM_ARRAYP (ra1) && SCM_EQ_P (v0, SCM_ARRAY_V (ra1)))) + if (!SCM_EQ_P (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))) + if (SCM_EQ_P (v0, ra1) + || (SCM_ARRAYP (ra1) && SCM_EQ_P (v0, SCM_ARRAY_V (ra1)))) goto gencase; } for (p = ra_asubrs; p->name; p++) - if (proc == p->sproc) + if (SCM_EQ_P (proc, p->sproc)) { - if (ra0 != SCM_CAR (lra)) + if (!SCM_EQ_P (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) @@ -1906,7 +1923,7 @@ raeql (SCM ra0,SCM as_equal,SCM ra1) vlen *= s0[k].ubnd - s1[k].lbnd + 1; } } - if (unroll && bas0 == bas1 && v0 == v1) + if (unroll && bas0 == bas1 && SCM_EQ_P (v0, v1)) return 1; return scm_ramapc (raeql_1, as_equal, ra0, scm_cons (ra1, SCM_EOL), ""); } diff --git a/libguile/read.c b/libguile/read.c index 051e75511..15924b44f 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -187,9 +187,9 @@ scm_casei_streq (char *s1, char *s2) static SCM recsexpr (SCM obj,int line,int column,SCM filename) { - if (SCM_IMP (obj) || SCM_NCONSP(obj)) + if (!SCM_CONSP(obj)) { return obj; - { + } else { SCM tmp = obj, copy; /* If this sexpr is visible in the read:sharp source, we want to keep that information, so only record non-constant cons cells @@ -492,7 +492,7 @@ tryagain_no_flush_ws: goto tok; case ':': - if (SCM_PACK (SCM_KEYWORD_STYLE) == scm_keyword_prefix) + if (SCM_EQ_P (SCM_PACK (SCM_KEYWORD_STYLE), scm_keyword_prefix)) { j = scm_read_token ('-', tok_buf, port, 0); p = scm_intern (SCM_CHARS (*tok_buf), j); diff --git a/libguile/stacks.c b/libguile/stacks.c index 8f3ab9b1d..85c13a624 100644 --- a/libguile/stacks.c +++ b/libguile/stacks.c @@ -389,7 +389,7 @@ narrow_stack (SCM stack,int inner,SCM inner_key,int outer,SCM outer_key) /* Use standard cutting procedure. */ { for (i = 0; inner; --inner) - if (s->frames[i++].proc == inner_key) + if (SCM_EQ_P (s->frames[i++].proc, inner_key)) break; } s->frames = &s->frames[i]; @@ -397,7 +397,7 @@ narrow_stack (SCM stack,int inner,SCM inner_key,int outer,SCM outer_key) /* Cut outer part. */ for (; n && outer; --outer) - if (s->frames[--n].proc == outer_key) + if (SCM_EQ_P (s->frames[--n].proc, outer_key)) break; s->length = n; diff --git a/libguile/strings.c b/libguile/strings.c index 783bfd4f9..c9c7af4dc 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -117,18 +117,19 @@ SCM scm_makstr (long len, int slots) { SCM s; - SCM * mem; + scm_bits_t * mem; + SCM_NEWCELL (s); --slots; SCM_REDEFER_INTS; - mem = (SCM *)scm_must_malloc (sizeof (SCM) * (slots + 1) + len + 1, - "scm_makstr"); + mem = (scm_bits_t *) scm_must_malloc (sizeof (scm_bits_t) * (slots + 1) + + len + 1, "scm_makstr"); if (slots >= 0) { int x; - mem[slots] = (SCM)mem; + mem[slots] = (scm_bits_t) mem; for (x = 0; x < slots; ++x) - mem[x] = SCM_BOOL_F; + mem[x] = SCM_UNPACK (SCM_BOOL_F); } SCM_SETCHARS (s, (char *) (mem + slots + 1)); SCM_SETLENGTH (s, len, scm_tc7_string); diff --git a/libguile/struct.h b/libguile/struct.h index a2c3edbfb..c7abfc577 100644 --- a/libguile/struct.h +++ b/libguile/struct.h @@ -87,7 +87,7 @@ typedef scm_sizet (*scm_struct_free_t) (scm_bits_t * vtable, scm_bits_t * data); #define SCM_STRUCT_VTABLE(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_vtable])) #define SCM_STRUCT_PRINTER(X) (SCM_PACK (SCM_STRUCT_VTABLE_DATA (X) [scm_vtable_index_printer])) -#define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA(X)[scm_struct_i_free] = (SCM) D) +#define SCM_SET_VTABLE_DESTRUCTOR(X, D) (SCM_STRUCT_DATA (X) [scm_struct_i_free] = (scm_bits_t) (D)) /* Efficiency is important in the following macro, since it's used in GC */ #define SCM_LAYOUT_TAILP(X) (((X) & 32) == 0) /* R, W or O */ diff --git a/libguile/unif.c b/libguile/unif.c index f61f4e3b1..8e2761227 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1149,9 +1149,9 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, case scm_tc7_byvect: return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]); case scm_tc7_uvect: - return scm_ulong2num((unsigned long ) SCM_VELTS(v)[pos]); + return scm_ulong2num (((unsigned long *) SCM_VELTS (v))[pos]); case scm_tc7_ivect: - return scm_long2num((long) SCM_VELTS(v)[pos]); + return scm_long2num(((signed long *) SCM_VELTS (v))[pos]); case scm_tc7_svect: return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]); @@ -1194,9 +1194,9 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) case scm_tc7_byvect: return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]); case scm_tc7_uvect: - return scm_ulong2num((unsigned long) SCM_VELTS(v)[pos]); + return scm_ulong2num(((unsigned long *) SCM_VELTS (v))[pos]); case scm_tc7_ivect: - return scm_long2num((long) SCM_VELTS(v)[pos]); + return scm_long2num(((signed long *) SCM_VELTS (v))[pos]); case scm_tc7_svect: return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]); #ifdef HAVE_LONG_LONGS @@ -1204,14 +1204,14 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) return scm_long_long2num (((long_long *) SCM_CELL_WORD_1 (v))[pos]); #endif case scm_tc7_fvect: - if (SCM_NIMP (last) && last != scm_flo0 && SCM_SLOPPY_REALP (last)) + if (SCM_NIMP (last) && !SCM_EQ_P (last, scm_flo0) && SCM_SLOPPY_REALP (last)) { SCM_REAL_VALUE (last) = ((float *) SCM_CELL_WORD_1 (v))[pos]; return last; } return scm_make_real (((float *) SCM_CELL_WORD_1 (v))[pos]); case scm_tc7_dvect: - if (SCM_NIMP (last) && last != scm_flo0 && SCM_SLOPPY_REALP (last)) + if (SCM_NIMP (last) && !SCM_EQ_P (last, scm_flo0) && SCM_SLOPPY_REALP (last)) { SCM_REAL_VALUE (last) = ((double *) SCM_CELL_WORD_1 (v))[pos]; return last; @@ -1599,7 +1599,7 @@ loop: if (SCM_TYP7 (v) == scm_tc7_bvect) ans *= SCM_LONG_BIT; - if (v != ra && cra != ra) + if (!SCM_EQ_P (v, ra) && !SCM_EQ_P (cra, ra)) scm_array_copy_x (cra, ra); return SCM_MAKINUM (ans); @@ -2210,12 +2210,11 @@ l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet k) { if (SCM_IMP (lst) || SCM_NCONSP (lst)) return 0; - ok = ok && scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), SCM_MAKINUM (base)); base += inc; lst = SCM_CDR (lst); } if (SCM_NNULLP (lst)) - return 0; + return 0; } return ok; } @@ -2313,23 +2312,23 @@ tail: if (n-- > 0) { /* intprint can't handle >= 2^31. */ - sprintf (str, "%lu", (unsigned long) SCM_VELTS (ra)[j]); + sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]); scm_puts (str, port); } for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); - sprintf (str, "%lu", (unsigned long) SCM_VELTS (ra)[j]); + sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]); scm_puts (str, port); } } case scm_tc7_ivect: if (n-- > 0) - scm_intprint ((int)SCM_VELTS (ra)[j], 10, port); + scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port); for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); - scm_intprint ((int)SCM_VELTS (ra)[j], 10, port); + scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port); } break; @@ -2425,7 +2424,7 @@ tail: } } case scm_tc7_bvect: - if (exp == v) + if (SCM_EQ_P (exp, v)) { /* a uve, not an scm_array */ register long i, j, w; scm_putc ('*', port); -- 2.20.1