From 22a52da14dd86801cc3a36837601929effde1904 Mon Sep 17 00:00:00 2001 From: Dirk Herrmann Date: Fri, 30 Mar 2001 15:03:23 +0000 Subject: [PATCH] * Replaced a lot of calls to SCM_C[AD]R with more appropriate macros. * Minor cleanups to hashtable implementation. * Minor code beautifications. --- libguile/async.c | 14 ++----- libguile/debug.c | 9 ++--- libguile/eq.c | 4 +- libguile/eval.c | 89 +++++++++++++++++++++---------------------- libguile/eval.h | 10 ++--- libguile/fluids.c | 6 +-- libguile/gc.c | 22 +++++------ libguile/guardians.c | 8 ++-- libguile/hashtab.c | 63 ++++++++++++++---------------- libguile/keywords.c | 8 ++-- libguile/macros.h | 12 ++++-- libguile/ports.c | 2 +- libguile/ports.h | 12 +++--- libguile/print.c | 26 ++++++------- libguile/procs.h | 12 +++--- libguile/properties.c | 24 +++++++----- libguile/smob.c | 4 +- libguile/tags.h | 18 ++++----- libguile/throw.c | 8 ++-- libguile/variable.c | 41 ++++++++------------ libguile/variable.h | 10 ++--- libguile/vectors.c | 19 ++++++--- libguile/weaks.c | 17 ++++++--- 23 files changed, 218 insertions(+), 220 deletions(-) diff --git a/libguile/async.c b/libguile/async.c index e57b821ae..ae3f5dcaf 100644 --- a/libguile/async.c +++ b/libguile/async.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 96, 97, 98, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -130,7 +130,7 @@ scm_asyncs_pending () { SCM pos; pos = scm_asyncs; - while (pos != SCM_EOL) + while (!SCM_NULLP (pos)) { SCM a = SCM_CAR (pos); if (ASYNC_GOT_IT (a)) @@ -300,14 +300,8 @@ SCM_DEFINE (scm_system_async, "system-async", 1, 0, 0, "add it to the system's list of active async objects.") #define FUNC_NAME s_scm_system_async { - SCM it; - SCM list; - - it = scm_async (thunk); - SCM_NEWCELL (list); - SCM_SETCAR (list, it); - SCM_SETCDR (list, scm_asyncs); - scm_asyncs = list; + SCM it = scm_async (thunk); + scm_asyncs = scm_cons (it, scm_asyncs); return it; } #undef FUNC_NAME diff --git a/libguile/debug.c b/libguile/debug.c index 7c1cf8bc4..3b4f77fa9 100644 --- a/libguile/debug.c +++ b/libguile/debug.c @@ -504,11 +504,10 @@ SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_look SCM scm_reverse_lookup (SCM env, SCM data) { - SCM names, values; - while (SCM_NIMP (env) && SCM_SLOPPY_CONSP (SCM_CAR (env))) + while (SCM_CONSP (env) && SCM_CONSP (SCM_CAR (env))) { - names = SCM_CAAR (env); - values = SCM_CDAR (env); + SCM names = SCM_CAAR (env); + SCM values = SCM_CDAR (env); while (SCM_CONSP (names)) { if (SCM_EQ_P (SCM_CAR (values), data)) @@ -516,7 +515,7 @@ scm_reverse_lookup (SCM env, SCM data) names = SCM_CDR (names); values = SCM_CDR (values); } - if (! SCM_NULLP (names) && SCM_EQ_P (values, data)) + if (!SCM_NULLP (names) && SCM_EQ_P (values, data)) return names; env = SCM_CDR (env); } diff --git a/libguile/eq.c b/libguile/eq.c index 8eda34047..0bb7f0840 100644 --- a/libguile/eq.c +++ b/libguile/eq.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -136,7 +136,7 @@ SCM_DEFINE1 (scm_equal_p, "equal?", scm_tc7_rpsubr, return SCM_BOOL_F; if (SCM_IMP (y)) return SCM_BOOL_F; - if (SCM_SLOPPY_CONSP (x) && SCM_SLOPPY_CONSP (y)) + if (SCM_CONSP (x) && SCM_CONSP (y)) { if (SCM_FALSEP (scm_equal_p (SCM_CAR (x), SCM_CAR (y)))) return SCM_BOOL_F; diff --git a/libguile/eval.c b/libguile/eval.c index 0d3c620fc..67d90345f 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -150,7 +150,7 @@ char *alloca (); ? *scm_lookupcar (x, env, 1) \ : SCM_CEVAL (SCM_CAR (x), env)) -#define EVALCAR(x, env) (SCM_NCELLP (SCM_CAR (x)) \ +#define EVALCAR(x, env) (!SCM_CELLP (SCM_CAR (x)) \ ? (SCM_IMP (SCM_CAR (x)) \ ? SCM_EVALIM (SCM_CAR (x), env) \ : SCM_GLOC_VAL (SCM_CAR (x))) \ @@ -790,11 +790,11 @@ scm_m_quasiquote (SCM xorig, SCM env) static SCM -iqq (SCM form,SCM env,int depth) +iqq (SCM form, SCM env, int depth) { SCM tmp; int edepth = depth; - if (SCM_IMP(form)) + if (SCM_IMP (form)) return form; if (SCM_VECTORP (form)) { @@ -805,7 +805,7 @@ iqq (SCM form,SCM env,int depth) tmp = scm_cons (data[i], tmp); return scm_vector (iqq (tmp, env, depth)); } - if (SCM_NCONSP(form)) + if (!SCM_CONSP (form)) return form; tmp = SCM_CAR (form); if (SCM_EQ_P (scm_sym_quasiquote, tmp)) @@ -824,7 +824,7 @@ iqq (SCM form,SCM env,int depth) return evalcar (form, env); return scm_cons2 (tmp, iqq (SCM_CAR (form), env, depth), SCM_EOL); } - if (SCM_NIMP (tmp) && (SCM_EQ_P (scm_sym_uq_splicing, SCM_CAR (tmp)))) + if (SCM_CONSP (tmp) && (SCM_EQ_P (scm_sym_uq_splicing, SCM_CAR (tmp)))) { tmp = SCM_CDR (tmp); if (0 == --edepth) @@ -876,10 +876,11 @@ scm_m_define (SCM x, SCM env) /* Only the first definition determines the name. */ && SCM_FALSEP (scm_procedure_property (arg1, scm_sym_name))) scm_set_procedure_property_x (arg1, scm_sym_name, proc); - else if (SCM_TYP16 (arg1) == scm_tc16_macro - && !SCM_EQ_P (SCM_CDR (arg1), arg1)) + else if (SCM_MACROP (arg1) + /* Dirk::FIXME: Does the following test make sense? */ + && !SCM_EQ_P (SCM_MACRO_CODE (arg1), arg1)) { - arg1 = SCM_CDR (arg1); + arg1 = SCM_MACRO_CODE (arg1); goto proc; } } @@ -1144,19 +1145,17 @@ scm_m_at_call_with_values (SCM xorig, SCM env) SCM scm_m_expand_body (SCM xorig, SCM env) { - SCM form, x = SCM_CDR (xorig), defs = SCM_EOL; + SCM x = SCM_CDR (xorig), defs = SCM_EOL; char *what = SCM_ISYMCHARS (SCM_CAR (xorig)) + 2; while (SCM_NIMP (x)) { - form = SCM_CAR (x); - if (SCM_IMP (form) || SCM_NCONSP (form)) - break; - if (SCM_IMP (SCM_CAR (form))) + SCM form = SCM_CAR (x); + if (!SCM_CONSP (form)) break; if (!SCM_SYMBOLP (SCM_CAR (form))) break; - + form = scm_macroexp (scm_cons_source (form, SCM_CAR (form), SCM_CDR (form)), @@ -1165,9 +1164,9 @@ scm_m_expand_body (SCM xorig, SCM env) if (SCM_EQ_P (SCM_IM_DEFINE, SCM_CAR (form))) { defs = scm_cons (SCM_CDR (form), defs); - x = SCM_CDR(x); + x = SCM_CDR (x); } - else if (SCM_NIMP(defs)) + else if (!SCM_IMP (defs)) { break; } @@ -1177,7 +1176,7 @@ scm_m_expand_body (SCM xorig, SCM env) } else { - x = scm_cons (form, SCM_CDR(x)); + x = scm_cons (form, SCM_CDR (x)); break; } } @@ -1229,13 +1228,11 @@ scm_macroexp (SCM x, SCM env) /* Only handle memoizing macros. `Acros' and `macros' are really special forms and should not be evaluated here. */ - if (SCM_IMP (proc) - || scm_tc16_macro != SCM_TYP16 (proc) - || (SCM_CELL_WORD_0 (proc) >> 16) != 2) + if (!SCM_MACROP (proc) || SCM_MACRO_TYPE (proc) != 2) return x; unmemocar (x, env); - res = scm_apply (SCM_CDR (proc), x, scm_cons (env, scm_listofnull)); + res = scm_apply (SCM_MACRO_CODE (proc), x, scm_cons (env, scm_listofnull)); if (scm_ilength (res) <= 0) res = scm_cons2 (SCM_IM_BEGIN, res, SCM_EOL); @@ -1510,7 +1507,7 @@ SCM scm_eval_args (SCM l, SCM env, SCM proc) { SCM results = SCM_EOL, *lloc = &results, res; - while (SCM_NIMP (l)) + while (!SCM_IMP (l)) { #ifdef SCM_CAUTIOUS if (SCM_CONSP (l)) @@ -1538,7 +1535,7 @@ scm_eval_args (SCM l, SCM env, SCM proc) l = SCM_CDR (l); } #ifdef SCM_CAUTIOUS - if (SCM_NNULLP (l)) + if (!SCM_NULLP (l)) { wrongnumargs: scm_wrong_num_args (proc); @@ -1733,7 +1730,7 @@ SCM scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc) { SCM *results = lloc, res; - while (SCM_NIMP (l)) + while (!SCM_IMP (l)) { #ifdef SCM_CAUTIOUS if (SCM_CONSP (l)) @@ -1761,7 +1758,7 @@ scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc) l = SCM_CDR (l); } #ifdef SCM_CAUTIOUS - if (SCM_NNULLP (l)) + if (!SCM_NULLP (l)) { wrongnumargs: scm_wrong_num_args (proc); @@ -1943,11 +1940,11 @@ dispatch: begin: /* If we are on toplevel with a lookup closure, we need to sync with the current module. */ - if (SCM_CONSP(env) && !SCM_CONSP(SCM_CAR(env))) + if (SCM_CONSP (env) && !SCM_CONSP (SCM_CAR (env))) { t.arg1 = x; UPDATE_TOPLEVEL_ENV (env); - while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1))) { EVALCAR (x, env); x = t.arg1; @@ -1964,7 +1961,7 @@ dispatch: x = SCM_CDR (x); nontoplevel_begin: t.arg1 = x; - while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1))) { if (SCM_IMP (SCM_CAR (x))) { @@ -1974,7 +1971,7 @@ dispatch: goto nontoplevel_begin; } else - SCM_EVALIM2 (SCM_CAR(x)); + SCM_EVALIM2 (SCM_CAR (x)); } else SCM_CEVAL (SCM_CAR (x), env); @@ -1982,7 +1979,7 @@ dispatch: } carloop: /* scm_eval car of last form in list */ - if (SCM_NCELLP (SCM_CAR (x))) + if (!SCM_CELLP (SCM_CAR (x))) { x = SCM_CAR (x); RETURN (SCM_IMP (x) ? SCM_EVALIM (x, env) : SCM_GLOC_VAL (x)) @@ -2026,18 +2023,18 @@ dispatch: case SCM_BIT8(SCM_IM_COND): - while (SCM_NIMP (x = SCM_CDR (x))) + while (!SCM_IMP (x = SCM_CDR (x))) { proc = SCM_CAR (x); t.arg1 = EVALCAR (proc, env); if (SCM_NFALSEP (t.arg1)) { x = SCM_CDR (proc); - if SCM_NULLP (x) + if (SCM_NULLP (x)) { RETURN (t.arg1) } - if (! SCM_EQ_P (scm_sym_arrow, SCM_CAR (x))) + if (!SCM_EQ_P (scm_sym_arrow, SCM_CAR (x))) { PREP_APPLY (SCM_UNDEFINED, SCM_EOL); goto begin; @@ -2147,10 +2144,10 @@ dispatch: case SCM_BIT8(SCM_IM_OR): x = SCM_CDR (x); t.arg1 = x; - while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) + while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1))) { x = EVALCAR (x, env); - if (SCM_NFALSEP (x)) + if (!SCM_FALSEP (x)) { RETURN (x); } @@ -2576,7 +2573,7 @@ dispatch: unmemocar (x, env); goto badfun; } - if (scm_tc16_macro == SCM_TYP16 (proc)) + if (SCM_MACROP (proc)) { unmemocar (x, env); @@ -2586,19 +2583,19 @@ dispatch: application frames can be deleted from the backtrace. */ SCM_SET_MACROEXP (debug); #endif - t.arg1 = SCM_APPLY (SCM_CDR (proc), x, + t.arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x, scm_cons (env, scm_listofnull)); #ifdef DEVAL SCM_CLEAR_MACROEXP (debug); #endif - switch (SCM_CELL_WORD_0 (proc) >> 16) + switch (SCM_MACRO_TYPE (proc)) { case 2: if (scm_ilength (t.arg1) <= 0) t.arg1 = scm_cons2 (SCM_IM_BEGIN, t.arg1, SCM_EOL); #ifdef DEVAL - if (!SCM_CLOSUREP (SCM_CDR (proc))) + if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc))) { SCM_DEFER_INTS; SCM_SETCAR (x, SCM_CAR (t.arg1)); @@ -2626,7 +2623,7 @@ dispatch: } else proc = SCM_CEVAL (SCM_CAR (x), env); - SCM_ASRTGO (SCM_NIMP (proc), badfun); + SCM_ASRTGO (!SCM_IMP (proc), badfun); #ifndef SCM_RECKLESS #ifdef SCM_CAUTIOUS checkargs: @@ -2635,19 +2632,19 @@ dispatch: { arg2 = SCM_CAR (SCM_CODE (proc)); t.arg1 = SCM_CDR (x); - while (SCM_NIMP (arg2)) + while (!SCM_IMP (arg2)) { - if (SCM_NCONSP (arg2)) + if (!SCM_CONSP (arg2)) goto evapply; if (SCM_IMP (t.arg1)) goto umwrongnumargs; arg2 = SCM_CDR (arg2); t.arg1 = SCM_CDR (t.arg1); } - if (SCM_NNULLP (t.arg1)) + if (!SCM_NULLP (t.arg1)) goto umwrongnumargs; } - else if (scm_tc16_macro == SCM_TYP16 (proc)) + else if (SCM_MACROP (proc)) goto handle_a_macro; #endif } @@ -3778,7 +3775,7 @@ promise_print (SCM exp, SCM port, scm_print_state *pstate) int writingp = SCM_WRITINGP (pstate); scm_puts ("#', port); return !0; diff --git a/libguile/eval.h b/libguile/eval.h index ec387a4dd..60c5d737a 100644 --- a/libguile/eval.h +++ b/libguile/eval.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef EVALH -#define EVALH -/* Copyright (C) 1995, 1996 ,1998, 1999, 2000 Free Software Foundation, Inc. +#ifndef SCM_EVAL_H +#define SCM_EVAL_H +/* Copyright (C) 1995,1996,1998,1999,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -180,8 +180,6 @@ extern SCM scm_sym_args; extern SCM scm_f_apply; -extern scm_bits_t scm_tc16_macro; - /* A resolved global variable reference in the CAR position * of a list is stored (in code only) as a pointer to a pair with a * tag of 1. This is called a "gloc". @@ -259,7 +257,7 @@ extern SCM scm_eval_x (SCM exp, SCM module); extern void scm_init_eval (void); -#endif /* EVALH */ +#endif /* SCM_EVAL_H */ /* Local Variables: diff --git a/libguile/fluids.c b/libguile/fluids.c index a52b2c8df..a76b05c76 100644 --- a/libguile/fluids.c +++ b/libguile/fluids.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1996, 1997, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1996,1997,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -183,7 +183,7 @@ SCM_DEFINE (scm_fluid_set_x, "fluid-set!", 2, 0, 0, void scm_swap_fluids (SCM fluids, SCM vals) { - while (SCM_NIMP (fluids)) + while (!SCM_NULLP (fluids)) { SCM fl = SCM_CAR (fluids); SCM old_val = scm_fluid_ref (fl); @@ -200,7 +200,7 @@ same fluid appears multiple times in the fluids list. */ void scm_swap_fluids_reverse (SCM fluids, SCM vals) { - if (SCM_NIMP (fluids)) + if (!SCM_NULLP (fluids)) { SCM fl, old_val; diff --git a/libguile/gc.c b/libguile/gc.c index ebcddca09..a4336789f 100644 --- a/libguile/gc.c +++ b/libguile/gc.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 96, 97, 98, 99, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -1183,8 +1183,8 @@ gc_mark_loop_first_time: ptr = SCM_CDR (ptr); goto gc_mark_loop; case scm_tc7_pws: - RECURSE (SCM_CELL_OBJECT_2 (ptr)); - ptr = SCM_CDR (ptr); + RECURSE (SCM_SETTER (ptr)); + ptr = SCM_PROCEDURE (ptr); goto gc_mark_loop; case scm_tcs_cons_gloc: { @@ -1241,13 +1241,13 @@ gc_mark_loop_first_time: } break; case scm_tcs_closures: - if (SCM_IMP (SCM_CDR (ptr))) + if (SCM_IMP (SCM_ENV (ptr))) { ptr = SCM_CLOSCAR (ptr); goto gc_mark_nimp; } RECURSE (SCM_CLOSCAR (ptr)); - ptr = SCM_CDR (ptr); + ptr = SCM_ENV (ptr); goto gc_mark_nimp; case scm_tc7_vector: i = SCM_VECTOR_LENGTH (ptr); @@ -1541,8 +1541,8 @@ gc_sweep_freelist_finish (scm_freelist_t *freelist) if (!SCM_NULLP (freelist->cells)) { SCM c = freelist->cells; - SCM_SETCAR (c, SCM_CDR (c)); - SCM_SETCDR (c, SCM_EOL); + SCM_SET_CELL_WORD_0 (c, SCM_FREE_CELL_CDR (c)); + SCM_SET_CELL_WORD_1 (c, SCM_EOL); freelist->collected += freelist->span * (freelist->cluster_size - freelist->left_to_collect); } @@ -1733,7 +1733,7 @@ scm_gc_sweep () SCM_SETSTREAM (scmptr, 0); scm_remove_from_port_table (scmptr); scm_gc_ports_collected++; - SCM_SETAND_CAR (scmptr, ~SCM_OPN); + SCM_CLR_PORT_OPEN_FLAG (scmptr); } break; case scm_tc7_smob: @@ -1770,7 +1770,7 @@ scm_gc_sweep () if (!--left_to_collect) { - SCM_SETCAR (scmptr, nfreelist); + SCM_SET_CELL_WORD_0 (scmptr, nfreelist); *freelist->clustertail = scmptr; freelist->clustertail = SCM_CDRLOC (scmptr); @@ -2130,7 +2130,7 @@ init_heap_seg (SCM_CELLPTR seg_org, scm_sizet size, scm_freelist_t *freelist) } SCM_SET_CELL_TYPE (scmptr, scm_tc_free_cell); - SCM_SETCDR (scmptr, PTR2SCM (nxt)); + SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (nxt)); ptr = nxt; } @@ -2463,7 +2463,7 @@ scm_unprotect_object (SCM obj) handle = scm_hashq_get_handle (scm_protects, obj); - if (SCM_IMP (handle)) + if (SCM_FALSEP (handle)) { fprintf (stderr, "scm_unprotect_object called on unprotected object\n"); abort (); diff --git a/libguile/guardians.c b/libguile/guardians.c index fbecd9d9c..f7eac2817 100644 --- a/libguile/guardians.c +++ b/libguile/guardians.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1998,1999,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -89,8 +89,8 @@ typedef struct tconc_t #define TCONC_IN(tc, obj, pair) \ do { \ SCM_SETCAR ((tc).tail, obj); \ - SCM_SETCAR (pair, SCM_BOOL_F); \ - SCM_SETCDR (pair, SCM_EOL); \ + SCM_SET_CELL_WORD_0 (pair, SCM_BOOL_F); \ + SCM_SET_CELL_WORD_1 (pair, SCM_EOL); \ SCM_SETCDR ((tc).tail, pair); \ (tc).tail = pair; \ } while (0) @@ -258,7 +258,7 @@ scm_guard (SCM guardian, SCM obj, int throw_p) if (GREEDY_P (g)) { - if (SCM_NFALSEP (scm_hashq_get_handle + if (!SCM_FALSEP (scm_hashq_get_handle (greedily_guarded_whash, obj))) { SCM_ALLOW_INTS; diff --git a/libguile/hashtab.c b/libguile/hashtab.c index 54500fdfe..9bcc16826 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -60,21 +60,24 @@ scm_c_make_hash_table (unsigned long k) return scm_c_make_vector (k, SCM_EOL); } + SCM scm_hash_fn_get_handle (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn)(),void * closure) +#define FUNC_NAME "scm_hash_fn_get_handle" { unsigned int k; SCM h; - SCM_ASSERT (SCM_VECTORP (table), table, SCM_ARG1, "hash_fn_get_handle"); + SCM_VALIDATE_VECTOR (1, table); if (SCM_VECTOR_LENGTH (table) == 0) - return SCM_EOL; + return SCM_BOOL_F; k = hash_fn (obj, SCM_VECTOR_LENGTH (table), closure); if (k >= SCM_VECTOR_LENGTH (table)) scm_out_of_range ("hash_fn_get_handle", scm_ulong2num (k)); h = assoc_fn (obj, SCM_VELTS (table)[k], closure); return h; } +#undef FUNC_NAME SCM @@ -116,13 +119,11 @@ SCM scm_hash_fn_ref (SCM table,SCM obj,SCM dflt,unsigned int (*hash_fn)(), SCM (*assoc_fn)(),void * closure) { - SCM it; - - it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure); - if (SCM_IMP (it)) - return dflt; - else + SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure); + if (SCM_CONSP (it)) return SCM_CDR (it); + else + return dflt; } @@ -165,16 +166,14 @@ scm_hash_fn_remove_x (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn SCM_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0, - (SCM table, SCM obj), - "This procedure is similar to its @code{-ref} cousin, but returns a\n" - "@dfn{handle} from the hash table rather than the value associated with\n" - "@var{key}. By convention, a handle in a hash table is the pair which\n" - "associates a key with a value. Where @code{hashq-ref table key} returns\n" - "only a @code{value}, @code{hashq-get-handle table key} returns the pair\n" - "@code{(key . value)}.") + (SCM table, SCM key), + "This procedure returns the @code{(key . value)} pair from the\n" + "hash table @var{table}. If @var{table} does not hold an\n" + "associated value for @var{key}, @code{#f} is returned.\n" + "Uses @code{eq?} for equality testing.") #define FUNC_NAME s_scm_hashq_get_handle { - return scm_hash_fn_get_handle (table, obj, scm_ihashq, scm_sloppy_assq, 0); + return scm_hash_fn_get_handle (table, key, scm_ihashq, scm_sloppy_assq, 0); } #undef FUNC_NAME @@ -233,16 +232,14 @@ SCM_DEFINE (scm_hashq_remove_x, "hashq-remove!", 2, 0, 0, SCM_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0, - (SCM table, SCM obj), - "This procedure is similar to its @code{-ref} cousin, but returns a\n" - "@dfn{handle} from the hash table rather than the value associated with\n" - "@var{key}. By convention, a handle in a hash table is the pair which\n" - "associates a key with a value. Where @code{hashv-ref table key} returns\n" - "only a @code{value}, @code{hashv-get-handle table key} returns the pair\n" - "@code{(key . value)}.") + (SCM table, SCM key), + "This procedure returns the @code{(key . value)} pair from the\n" + "hash table @var{table}. If @var{table} does not hold an\n" + "associated value for @var{key}, @code{#f} is returned.\n" + "Uses @code{eqv?} for equality testing.") #define FUNC_NAME s_scm_hashv_get_handle { - return scm_hash_fn_get_handle (table, obj, scm_ihashv, scm_sloppy_assv, 0); + return scm_hash_fn_get_handle (table, key, scm_ihashv, scm_sloppy_assv, 0); } #undef FUNC_NAME @@ -299,16 +296,14 @@ SCM_DEFINE (scm_hashv_remove_x, "hashv-remove!", 2, 0, 0, SCM_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0, - (SCM table, SCM obj), - "This procedure is similar to its @code{-ref} cousin, but returns a\n" - "@dfn{handle} from the hash table rather than the value associated with\n" - "@var{key}. By convention, a handle in a hash table is the pair which\n" - "associates a key with a value. Where @code{hash-ref table key} returns\n" - "only a @code{value}, @code{hash-get-handle table key} returns the pair\n" - "@code{(key . value)}.") + (SCM table, SCM key), + "This procedure returns the @code{(key . value)} pair from the\n" + "hash table @var{table}. If @var{table} does not hold an\n" + "associated value for @var{key}, @code{#f} is returned.\n" + "Uses @code{equal?} for equality testing.") #define FUNC_NAME s_scm_hash_get_handle { - return scm_hash_fn_get_handle (table, obj, scm_ihash, scm_sloppy_assoc, 0); + return scm_hash_fn_get_handle (table, key, scm_ihash, scm_sloppy_assoc, 0); } #undef FUNC_NAME @@ -543,7 +538,7 @@ scm_internal_hash_fold (SCM (*fn) (), void *closure, SCM init, SCM table) for (i = 0; i < n; ++i) { SCM ls = SCM_VELTS (table)[i], handle; - while (SCM_NNULLP (ls)) + while (!SCM_NULLP (ls)) { SCM_ASSERT (SCM_CONSP (ls), table, SCM_ARG1, s_scm_hash_fold); diff --git a/libguile/keywords.c b/libguile/keywords.c index 84d942dfa..3509314ea 100644 --- a/libguile/keywords.c +++ b/libguile/keywords.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -112,7 +112,7 @@ SCM_DEFINE (scm_keyword_p, "keyword?", 1, 0, 0, "Returns @code{#t} if the argument @var{obj} is a keyword, else @code{#f}.") #define FUNC_NAME s_scm_keyword_p { - return SCM_BOOL(SCM_KEYWORDP (obj)); + return SCM_BOOL (SCM_KEYWORDP (obj)); } #undef FUNC_NAME @@ -123,8 +123,8 @@ SCM_DEFINE (scm_keyword_dash_symbol, "keyword-dash-symbol", 1, 0, 0, "This is the inverse of @code{make-keyword-from-dash-symbol}.") #define FUNC_NAME s_scm_keyword_dash_symbol { - SCM_VALIDATE_KEYWORD (1,keyword); - return SCM_CDR (keyword); + SCM_VALIDATE_KEYWORD (1, keyword); + return SCM_KEYWORDSYM (keyword); } #undef FUNC_NAME diff --git a/libguile/macros.h b/libguile/macros.h index 92436fe95..ccc80dffd 100644 --- a/libguile/macros.h +++ b/libguile/macros.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef MACROSH -#define MACROSH -/* Copyright (C) 1998, 2000 Free Software Foundation, Inc. +#ifndef SCM_MACROS_H +#define SCM_MACROS_H +/* Copyright (C) 1998,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -51,6 +51,10 @@ #define SCM_ASSYNT(_cond, _msg, _subr) \ if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL); +#define SCM_MACROP(x) SCM_TYP16_PREDICATE (scm_tc16_macro, (x)) +#define SCM_MACRO_TYPE(m) (SCM_CELL_WORD_0 (m) >> 16) +#define SCM_MACRO_CODE(m) SCM_CELL_OBJECT_1 (m) + extern scm_bits_t scm_tc16_macro; extern SCM scm_makacro (SCM code); @@ -65,7 +69,7 @@ extern SCM scm_make_synt (const char *name, SCM (*fcn) ()); extern void scm_init_macros (void); -#endif /* MACROSH */ +#endif /* SCM_MACROS_H */ /* Local Variables: diff --git a/libguile/ports.c b/libguile/ports.c index 6884811d1..c480b7fc8 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -663,7 +663,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, else rv = 0; scm_remove_from_port_table (port); - SCM_SETAND_CAR (port, ~SCM_OPN); + SCM_CLR_PORT_OPEN_FLAG (port); return SCM_NEGATE_BOOL (rv < 0); } #undef FUNC_NAME diff --git a/libguile/ports.h b/libguile/ports.h index fabf744eb..c8c96aa5b 100644 --- a/libguile/ports.h +++ b/libguile/ports.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef PORTSH -#define PORTSH -/* Copyright (C) 1995,1996,1997,1998,1999, 2000, 2001 Free Software Foundation, Inc. +#ifndef SCM_PORTS_H +#define SCM_PORTS_H +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -152,7 +152,7 @@ extern int scm_port_table_size; /* Number of ports in scm_port_table. */ #define SCM_BUF0 (8L<<16) /* Is it unbuffered? */ #define SCM_BUFLINE (64L<<16) /* Is it line-buffered? */ -#define SCM_PORTP(x) (SCM_NIMP(x) && (SCM_TYP7(x)==scm_tc7_port)) +#define SCM_PORTP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_port)) #define SCM_OPPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_OPN))) #define SCM_OPINPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN | SCM_RDNG) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_OPN | SCM_RDNG))) #define SCM_OPOUTPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN | SCM_WRTNG) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_OPN | SCM_WRTNG))) @@ -164,6 +164,8 @@ extern int scm_port_table_size; /* Number of ports in scm_port_table. */ && (((0x7f | SCM_WRTNG) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_WRTNG))) #define SCM_OPENP(x) (SCM_NIMP(x) && (SCM_OPN & SCM_CELL_WORD_0 (x))) #define SCM_CLOSEDP(x) (!SCM_OPENP(x)) +#define SCM_CLR_PORT_OPEN_FLAG(p) \ + SCM_SET_CELL_WORD_0 ((p), SCM_CELL_WORD_0 (p) & ~SCM_OPN) #define SCM_PTAB_ENTRY(x) ((scm_port *) SCM_CELL_WORD_1 (x)) #define SCM_SETPTAB_ENTRY(x,ent) (SCM_SET_CELL_WORD_1 ((x), (scm_bits_t) (ent))) @@ -324,7 +326,7 @@ extern SCM scm_close_all_ports_except (SCM ports); #endif /* SCM_DEBUG_DEPRECATED == 0 */ -#endif /* PORTSH */ +#endif /* SCM_PORTS_H */ /* Local Variables: diff --git a/libguile/print.c b/libguile/print.c index 0c2adba12..b1f59d249 100644 --- a/libguile/print.c +++ b/libguile/print.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995-1999, 2000, 2001 Free Software Foundation, Inc. +/* Copyright (C) 1995-1999,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -254,8 +254,8 @@ scm_free_print_state (SCM print_state) pstate->revealed = 0; SCM_NEWCELL (handle); SCM_DEFER_INTS; - SCM_SETCAR (handle, print_state); - SCM_SETCDR (handle, SCM_CDR (print_state_pool)); + SCM_SET_CELL_WORD_0 (handle, print_state); + SCM_SET_CELL_WORD_1 (handle, SCM_CDR (print_state_pool)); SCM_SETCDR (print_state_pool, handle); SCM_ALLOW_INTS; } @@ -419,7 +419,7 @@ taloop: exp, port, pstate))) { SCM name, code, env; - if (SCM_TYP16 (exp) == scm_tc16_macro) + if (SCM_MACROP (exp)) { /* Printing a macro. */ prinmacro: @@ -806,10 +806,11 @@ scm_ipruk (char *hdr, SCM ptr, SCM port) scm_putc ('>', port); } -/* Print a list. - */ - +/* Print a list. The list may be either a list of ordinary data, or it may be + a list that represents code. Lists that represent code may contain gloc + cells. + */ void scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) { @@ -837,13 +838,10 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) /* No cdr cycles intrinsic to this list */ scm_iprin1 (SCM_CAR (exp), port, pstate); - exp = SCM_CDR (exp); - for (; SCM_NIMP (exp); exp = SCM_CDR (exp)) + for (exp = SCM_CDR (exp); SCM_ECONSP (exp); exp = SCM_CDR (exp)) { register int i; - if (SCM_NECONSP (exp)) - break; for (i = floor; i >= 0; --i) if (SCM_EQ_P (pstate->ref_stack[i], exp)) goto circref; @@ -852,7 +850,7 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) /* CHECK_INTS; */ scm_iprin1 (SCM_CAR (exp), port, pstate); } - if (SCM_NNULLP (exp)) + if (!SCM_NULLP (exp)) { scm_puts (" . ", port); scm_iprin1 (exp, port, pstate); @@ -869,12 +867,10 @@ fancy_printing: scm_iprin1 (SCM_CAR (exp), port, pstate); exp = SCM_CDR (exp); --n; - for (; SCM_NIMP (exp); exp = SCM_CDR (exp)) + for (; SCM_ECONSP (exp); exp = SCM_CDR (exp)) { register unsigned long i; - if (SCM_NECONSP (exp)) - break; for (i = 0; i < pstate->top; ++i) if (SCM_EQ_P (pstate->ref_stack[i], exp)) goto fancy_circref; diff --git a/libguile/procs.h b/libguile/procs.h index 3e332f0ab..7007b3d2b 100644 --- a/libguile/procs.h +++ b/libguile/procs.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef PROCSH -#define PROCSH -/* Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc. +#ifndef SCM_PROCS_H +#define SCM_PROCS_H +/* Copyright (C) 1995,1996,1998,1999,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -97,8 +97,8 @@ typedef struct #define SCM_SETPROCPROPS(x, p) SCM_SETCDR (SCM_CLOSCAR (x), p) #define SCM_SETCODE(x, e) (SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_cons ((e), SCM_EOL)) \ + scm_tc3_closure)) -#define SCM_ENV(x) SCM_CDR(x) -#define SCM_SETENV(x, e) SCM_SETCDR (x, e) +#define SCM_ENV(x) SCM_CELL_OBJECT_1 (x) +#define SCM_SETENV(x, e) SCM_SET_CELL_OBJECT_1 ((x), (e)) #define SCM_TOP_LEVEL(ENV) (SCM_NULLP (ENV) || (SCM_EQ_P (scm_procedure_p (SCM_CAR (ENV)), SCM_BOOL_T))) /* Procedure-with-setter @@ -194,7 +194,7 @@ extern SCM scm_make_cclo (SCM proc, SCM len); #endif /* SCM_DEBUG_DEPRECATED == 0 */ -#endif /* PROCSH */ +#endif /* SCM_PROCS_H */ /* Local Variables: diff --git a/libguile/properties.c b/libguile/properties.c index b33343862..6d9d8031b 100644 --- a/libguile/properties.c +++ b/libguile/properties.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -72,6 +72,7 @@ SCM_DEFINE (scm_primitive_make_property, "primitive-make-property", 1, 0, 0, } #undef FUNC_NAME + SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0, (SCM prop, SCM obj), "Return the property @var{prop} of @var{obj}. When no value\n" @@ -83,22 +84,24 @@ SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0, "default value of @var{prop}.") #define FUNC_NAME s_scm_primitive_property_ref { - SCM h, assoc; + SCM h; SCM_VALIDATE_CONS (SCM_ARG1, prop); h = scm_hashq_get_handle (scm_properties_whash, obj); - assoc = (SCM_NIMP (h) ? scm_assq (prop, SCM_CDR (h)) : SCM_BOOL_F); - if (SCM_NIMP (assoc)) - return SCM_CDR (assoc); + if (!SCM_FALSEP (h)) + { + SCM assoc = scm_assq (prop, SCM_CDR (h)); + if (!SCM_FALSEP (assoc)) + return SCM_CDR (assoc); + } if (SCM_FALSEP (SCM_CAR (prop))) return SCM_BOOL_F; else { - SCM val = scm_apply (SCM_CAR (prop), - SCM_LIST2 (prop, obj), SCM_EOL); - if (SCM_IMP (h)) + SCM val = scm_apply (SCM_CAR (prop), SCM_LIST2 (prop, obj), SCM_EOL); + if (SCM_FALSEP (h)) h = scm_hashq_create_handle_x (scm_properties_whash, obj, SCM_EOL); SCM_SETCDR (h, scm_acons (prop, val, SCM_CDR (h))); return val; @@ -106,6 +109,7 @@ SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0, } #undef FUNC_NAME + SCM_DEFINE (scm_primitive_property_set_x, "primitive-property-set!", 3, 0, 0, (SCM prop, SCM obj, SCM val), "Associate @var{code} with @var{prop} and @var{obj}.") @@ -126,6 +130,7 @@ SCM_DEFINE (scm_primitive_property_set_x, "primitive-property-set!", 3, 0, 0, } #undef FUNC_NAME + SCM_DEFINE (scm_primitive_property_del_x, "primitive-property-del!", 2, 0, 0, (SCM prop, SCM obj), "Remove any value associated with @var{prop} and @var{obj}.") @@ -134,12 +139,13 @@ SCM_DEFINE (scm_primitive_property_del_x, "primitive-property-del!", 2, 0, 0, SCM h; SCM_VALIDATE_CONS (SCM_ARG1, prop); h = scm_hashq_get_handle (scm_properties_whash, obj); - if (SCM_NIMP (h)) + if (!SCM_FALSEP (h)) SCM_SETCDR (h, scm_assq_remove_x (SCM_CDR (h), prop)); return SCM_UNSPECIFIED; } #undef FUNC_NAME + void scm_init_properties () { diff --git a/libguile/smob.c b/libguile/smob.c index f7d00e910..6cd557cc7 100644 --- a/libguile/smob.c +++ b/libguile/smob.c @@ -88,9 +88,11 @@ scm_mark0 (SCM ptr) } SCM +/* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only + be used for real pairs. */ scm_markcdr (SCM ptr) { - return SCM_CDR (ptr); + return SCM_CELL_OBJECT_1 (ptr); } /* {Free} diff --git a/libguile/tags.h b/libguile/tags.h index 846d27000..0670c16f7 100644 --- a/libguile/tags.h +++ b/libguile/tags.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef TAGSH -#define TAGSH -/* Copyright (C) 1995, 96, 97, 98, 99, 2000 Free Software Foundation, Inc. +#ifndef SCM_TAGS_H +#define SCM_TAGS_H +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -271,10 +271,7 @@ typedef long scm_bits_t; * stored in the SCM_CAR of a non-immediate object have a 1 in bit 1: */ -#define SCM_SLOPPY_CONSP(x) ((1 & SCM_CELL_TYPE (x)) == 0) -#define SCM_SLOPPY_NCONSP(x) (!SCM_SLOPPY_CONSP(x)) - -#define SCM_CONSP(x) (!SCM_IMP (x) && SCM_SLOPPY_CONSP (x)) +#define SCM_CONSP(x) (!SCM_IMP (x) && ((1 & SCM_CELL_TYPE (x)) == 0)) #define SCM_NCONSP(x) (!SCM_CONSP (x)) @@ -283,7 +280,7 @@ typedef long scm_bits_t; */ #define SCM_ECONSP(x) \ (!SCM_IMP (x) \ - && (SCM_SLOPPY_CONSP (x) \ + && (SCM_CONSP (x) \ || (SCM_TYP3 (x) == 1 \ && (SCM_STRUCT_VTABLE_DATA (x)[scm_vtable_index_vcell] != 0)))) #define SCM_NECONSP(x) (!SCM_ECONSP (x)) @@ -542,6 +539,9 @@ extern char *scm_isymnames[]; /* defined in print.c */ #if (SCM_DEBUG_DEPRECATED == 0) +#define SCM_SLOPPY_CONSP(x) ((1 & SCM_CELL_TYPE (x)) == 0) +#define SCM_SLOPPY_NCONSP(x) (!SCM_SLOPPY_CONSP(x)) + #define scm_tc7_ssymbol scm_tc7_symbol #define scm_tc7_msymbol scm_tc7_symbol #define scm_tcs_symbols scm_tc7_symbol @@ -553,7 +553,7 @@ extern char *scm_isymnames[]; /* defined in print.c */ #endif /* SCM_DEBUG_DEPRECATED == 0 */ -#endif /* TAGSH */ +#endif /* SCM_TAGS_H */ /* Local Variables: diff --git a/libguile/throw.c b/libguile/throw.c index a1060595c..e0e921dcd 100644 --- a/libguile/throw.c +++ b/libguile/throw.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -71,8 +71,10 @@ static scm_bits_t tc16_jmpbuffer; #define SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ) #define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L)) -#define ACTIVATEJB(OBJ) (SCM_SETOR_CAR (OBJ, (1L << 16L))) -#define DEACTIVATEJB(OBJ) (SCM_SETAND_CAR (OBJ, ~(1L << 16L))) +#define ACTIVATEJB(x) \ + (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) | (1L << 16L)))) +#define DEACTIVATEJB(x) \ + (SCM_SET_CELL_WORD_0 ((x), (SCM_CELL_WORD_0 (x) & ~(1L << 16L)))) #define JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ)) #define SETJBJMPBUF(x,v) (SCM_SET_CELL_WORD_1 ((x), (v))) diff --git a/libguile/variable.c b/libguile/variable.c index 4ce7d6110..064744f73 100644 --- a/libguile/variable.c +++ b/libguile/variable.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1997, 1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -59,17 +59,16 @@ static int variable_print (SCM exp, SCM port, scm_print_state *pstate) { scm_puts ("#', port); return 1; @@ -78,7 +77,7 @@ variable_print (SCM exp, SCM port, scm_print_state *pstate) static SCM variable_equalp (SCM var1, SCM var2) { - return scm_equal_p (SCM_CDR (var1), SCM_CDR (var2)); + return scm_equal_p (SCM_VARVCELL (var1), SCM_VARVCELL (var2)); } @@ -100,17 +99,13 @@ SCM_DEFINE (scm_make_variable, "make-variable", 1, 1, 0, "variable may exist, so @var{name-hint} is just that---a hint.\n") #define FUNC_NAME s_scm_make_variable { - SCM val_cell; + SCM vcell; if (SCM_UNBNDP (name_hint)) name_hint = anonymous_variable_sym; - SCM_NEWCELL(val_cell); - SCM_DEFER_INTS; - SCM_SETCAR (val_cell, name_hint); - SCM_SETCDR (val_cell, init); - SCM_ALLOW_INTS; - return make_vcell_variable (val_cell); + vcell = scm_cons (name_hint, init); + return make_vcell_variable (vcell); } #undef FUNC_NAME @@ -129,11 +124,7 @@ SCM_DEFINE (scm_make_undefined_variable, "make-undefined-variable", 0, 1, 0, if (SCM_UNBNDP (name_hint)) name_hint = anonymous_variable_sym; - SCM_NEWCELL (vcell); - SCM_DEFER_INTS; - SCM_SETCAR (vcell, name_hint); - SCM_SETCDR (vcell, SCM_UNDEFINED); - SCM_ALLOW_INTS; + vcell = scm_cons (name_hint, SCM_UNDEFINED); return make_vcell_variable (vcell); } #undef FUNC_NAME @@ -158,7 +149,7 @@ SCM_DEFINE (scm_variable_ref, "variable-ref", 1, 0, 0, #define FUNC_NAME s_scm_variable_ref { SCM_VALIDATE_VARIABLE (1, var); - return SCM_CDR (SCM_CDR (var)); + return SCM_CDR (SCM_VARVCELL (var)); } #undef FUNC_NAME @@ -171,8 +162,8 @@ SCM_DEFINE (scm_variable_set_x, "variable-set!", 2, 0, 0, "value. Return an unspecified value.\n") #define FUNC_NAME s_scm_variable_set_x { - SCM_VALIDATE_VARIABLE (1,var); - SCM_SETCDR (SCM_CDR (var), val); + SCM_VALIDATE_VARIABLE (1, var); + SCM_SETCDR (SCM_VARVCELL (var), val); return SCM_UNSPECIFIED; } #undef FUNC_NAME @@ -213,8 +204,8 @@ SCM_DEFINE (scm_variable_bound_p, "variable-bound?", 1, 0, 0, "Throws an error if @var{var} is not a variable object.\n") #define FUNC_NAME s_scm_variable_bound_p { - SCM_VALIDATE_VARIABLE (1,var); - return SCM_NEGATE_BOOL(SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var)))); + SCM_VALIDATE_VARIABLE (1, var); + return SCM_BOOL (!SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var)))); } #undef FUNC_NAME diff --git a/libguile/variable.h b/libguile/variable.h index 22a2e0438..f5fc686ed 100644 --- a/libguile/variable.h +++ b/libguile/variable.h @@ -1,8 +1,8 @@ /* classes: h_files */ -#ifndef VARIABLEH -#define VARIABLEH -/* Copyright (C) 1995,1996, 2000 Free Software Foundation, Inc. +#ifndef SCM_VARIABLE_H +#define SCM_VARIABLE_H +/* Copyright (C) 1995,1996,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -55,7 +55,7 @@ */ extern scm_bits_t scm_tc16_variable; -#define SCM_VARVCELL(V) SCM_CDR(V) +#define SCM_VARVCELL(V) SCM_CELL_OBJECT_1 (V) #define SCM_VARIABLEP(X) (!SCM_IMP (X) && SCM_CELL_TYPE (X) == scm_tc16_variable) #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)))) @@ -71,7 +71,7 @@ extern SCM scm_builtin_variable (SCM name); extern SCM scm_variable_bound_p (SCM var); extern void scm_init_variable (void); -#endif /* VARIABLEH */ +#endif /* SCM_VARIABLE_H */ /* Local Variables: diff --git a/libguile/vectors.c b/libguile/vectors.c index bd1b7ba85..280b2eedf 100644 --- a/libguile/vectors.c +++ b/libguile/vectors.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,1999,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -178,13 +178,20 @@ SCM_DEFINE (scm_vector, "vector", 0, 0, 1, #define FUNC_NAME s_scm_vector { SCM res; - register SCM *data; - int i; - SCM_VALIDATE_LIST_COPYLEN (1,l,i); + SCM *data; + long i; + + /* Dirk:FIXME:: In case of multiple threads, the list might get corrupted + while the vector is being created. */ + SCM_VALIDATE_LIST_COPYLEN (1, l, i); res = scm_c_make_vector (i, SCM_UNSPECIFIED); data = SCM_VELTS (res); - for(; i && SCM_NIMP(l); --i, l = SCM_CDR (l)) - *data++ = SCM_CAR (l); + while (!SCM_NULLP (l)) + { + *data++ = SCM_CAR (l); + l = SCM_CDR (l); + } + return res; } #undef FUNC_NAME diff --git a/libguile/weaks.c b/libguile/weaks.c index c01da2c61..c6cf591bb 100644 --- a/libguile/weaks.c +++ b/libguile/weaks.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1998, 2000 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1998,2000,2001 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -88,17 +88,22 @@ SCM_DEFINE (scm_weak_vector, "weak-vector", 0, 0, 1, #define FUNC_NAME s_scm_weak_vector { SCM res; - register SCM *data; + SCM *data; long i; + /* Dirk:FIXME:: In case of multiple threads, the list might get corrupted + while the vector is being created. */ i = scm_ilength (l); SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME); res = scm_make_weak_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED); data = SCM_VELTS (res); - for (; - i && SCM_CONSP (l); - --i, l = SCM_CDR (l)) - *data++ = SCM_CAR (l); + + while (!SCM_NULLP (l)) + { + *data++ = SCM_CAR (l); + l = SCM_CDR (l); + } + return res; } #undef FUNC_NAME -- 2.20.1