mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 16:50:21 +02:00
Code Activity

* Replaced a lot of calls to SCM_C[AD]R with more appropriate macros.

Browse source 
* Minor cleanups to hashtable implementation.
* Minor code beautifications.
This commit is contained in:
Dirk Herrmann 2001-03-30 15:03:23 +00:00
parent 8715ff1703
commit 22a52da14d
23 changed files with 218 additions and 220 deletions
Download patch file Download diff file Expand all files Collapse all files

14
libguile/async.c
View file

@ -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 * 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 * it under the terms of the GNU General Public License as published by
@ -130,7 +130,7 @@ scm_asyncs_pending ()
{ {
SCM pos; SCM pos;
pos = scm_asyncs; pos = scm_asyncs;
while (pos != SCM_EOL) while (!SCM_NULLP (pos))
{ {
SCM a = SCM_CAR (pos); SCM a = SCM_CAR (pos);
if (ASYNC_GOT_IT (a)) 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.") "add it to the system's list of active async objects.")
#define FUNC_NAME s_scm_system_async #define FUNC_NAME s_scm_system_async
{ {
SCM it; SCM it = scm_async (thunk);
SCM list; scm_asyncs = scm_cons (it, scm_asyncs);
it = scm_async (thunk);
SCM_NEWCELL (list);
SCM_SETCAR (list, it);
SCM_SETCDR (list, scm_asyncs);
scm_asyncs = list;
return it; return it;
} }
#undef FUNC_NAME #undef FUNC_NAME

9
libguile/debug.c
View file

@ -504,11 +504,10 @@ SCM_REGISTER_PROC (s_reverse_lookup, "reverse-lookup", 2, 0, 0, scm_reverse_look
SCM SCM
scm_reverse_lookup (SCM env, SCM data) scm_reverse_lookup (SCM env, SCM data)
{ {
SCM names, values; while (SCM_CONSP (env) && SCM_CONSP (SCM_CAR (env)))
while (SCM_NIMP (env) && SCM_SLOPPY_CONSP (SCM_CAR (env)))
{ {
names = SCM_CAAR (env); SCM names = SCM_CAAR (env);
values = SCM_CDAR (env); SCM values = SCM_CDAR (env);
while (SCM_CONSP (names)) while (SCM_CONSP (names))
{ {
if (SCM_EQ_P (SCM_CAR (values), data)) if (SCM_EQ_P (SCM_CAR (values), data))
@ -516,7 +515,7 @@ scm_reverse_lookup (SCM env, SCM data)
names = SCM_CDR (names); names = SCM_CDR (names);
values = SCM_CDR (values); values = SCM_CDR (values);
} }
if (! SCM_NULLP (names) && SCM_EQ_P (values, data)) if (!SCM_NULLP (names) && SCM_EQ_P (values, data))
return names; return names;
env = SCM_CDR (env); env = SCM_CDR (env);
} }

4
libguile/eq.c
View file

@ -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 * 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 * 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; return SCM_BOOL_F;
if (SCM_IMP (y)) if (SCM_IMP (y))
return SCM_BOOL_F; 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)))) if (SCM_FALSEP (scm_equal_p (SCM_CAR (x), SCM_CAR (y))))
return SCM_BOOL_F; return SCM_BOOL_F;

89
libguile/eval.c
View file

@ -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 * 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 * 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_lookupcar (x, env, 1) \
: SCM_CEVAL (SCM_CAR (x), env)) : 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_IMP (SCM_CAR (x)) \
? SCM_EVALIM (SCM_CAR (x), env) \ ? SCM_EVALIM (SCM_CAR (x), env) \
: SCM_GLOC_VAL (SCM_CAR (x))) \ : SCM_GLOC_VAL (SCM_CAR (x))) \
@ -790,11 +790,11 @@ scm_m_quasiquote (SCM xorig, SCM env)
static SCM static SCM
iqq (SCM form,SCM env,int depth) iqq (SCM form, SCM env, int depth)
{ {
SCM tmp; SCM tmp;
int edepth = depth; int edepth = depth;
if (SCM_IMP(form)) if (SCM_IMP (form))
return form; return form;
if (SCM_VECTORP (form)) if (SCM_VECTORP (form))
{ {
@ -805,7 +805,7 @@ iqq (SCM form,SCM env,int depth)
tmp = scm_cons (data[i], tmp); tmp = scm_cons (data[i], tmp);
return scm_vector (iqq (tmp, env, depth)); return scm_vector (iqq (tmp, env, depth));
} }
if (SCM_NCONSP(form)) if (!SCM_CONSP (form))
return form; return form;
tmp = SCM_CAR (form); tmp = SCM_CAR (form);
if (SCM_EQ_P (scm_sym_quasiquote, tmp)) if (SCM_EQ_P (scm_sym_quasiquote, tmp))
@ -824,7 +824,7 @@ iqq (SCM form,SCM env,int depth)
return evalcar (form, env); return evalcar (form, env);
return scm_cons2 (tmp, iqq (SCM_CAR (form), env, depth), SCM_EOL); 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); tmp = SCM_CDR (tmp);
if (0 == --edepth) if (0 == --edepth)
@ -876,10 +876,11 @@ scm_m_define (SCM x, SCM env)
/* Only the first definition determines the name. */ /* Only the first definition determines the name. */
&& SCM_FALSEP (scm_procedure_property (arg1, scm_sym_name))) && SCM_FALSEP (scm_procedure_property (arg1, scm_sym_name)))
scm_set_procedure_property_x (arg1, scm_sym_name, proc); scm_set_procedure_property_x (arg1, scm_sym_name, proc);
else if (SCM_TYP16 (arg1) == scm_tc16_macro else if (SCM_MACROP (arg1)
&& !SCM_EQ_P (SCM_CDR (arg1), 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; goto proc;
} }
} }
@ -1144,19 +1145,17 @@ scm_m_at_call_with_values (SCM xorig, SCM env)
SCM SCM
scm_m_expand_body (SCM xorig, SCM env) 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; char *what = SCM_ISYMCHARS (SCM_CAR (xorig)) + 2;
while (SCM_NIMP (x)) while (SCM_NIMP (x))
{ {
form = SCM_CAR (x); SCM form = SCM_CAR (x);
if (SCM_IMP (form) || SCM_NCONSP (form)) if (!SCM_CONSP (form))
break;
if (SCM_IMP (SCM_CAR (form)))
break; break;
if (!SCM_SYMBOLP (SCM_CAR (form))) if (!SCM_SYMBOLP (SCM_CAR (form)))
break; break;
form = scm_macroexp (scm_cons_source (form, form = scm_macroexp (scm_cons_source (form,
SCM_CAR (form), SCM_CAR (form),
SCM_CDR (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))) if (SCM_EQ_P (SCM_IM_DEFINE, SCM_CAR (form)))
{ {
defs = scm_cons (SCM_CDR (form), defs); 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; break;
} }
@ -1177,7 +1176,7 @@ scm_m_expand_body (SCM xorig, SCM env)
} }
else else
{ {
x = scm_cons (form, SCM_CDR(x)); x = scm_cons (form, SCM_CDR (x));
break; break;
} }
} }
@ -1229,13 +1228,11 @@ scm_macroexp (SCM x, SCM env)
/* Only handle memoizing macros. `Acros' and `macros' are really /* Only handle memoizing macros. `Acros' and `macros' are really
special forms and should not be evaluated here. */ special forms and should not be evaluated here. */
if (SCM_IMP (proc) if (!SCM_MACROP (proc) || SCM_MACRO_TYPE (proc) != 2)
|| scm_tc16_macro != SCM_TYP16 (proc)
|| (SCM_CELL_WORD_0 (proc) >> 16) != 2)
return x; return x;
unmemocar (x, env); 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) if (scm_ilength (res) <= 0)
res = scm_cons2 (SCM_IM_BEGIN, res, SCM_EOL); res = scm_cons2 (SCM_IM_BEGIN, res, SCM_EOL);
@ -1510,7 +1507,7 @@ SCM
scm_eval_args (SCM l, SCM env, SCM proc) scm_eval_args (SCM l, SCM env, SCM proc)
{ {
SCM results = SCM_EOL, *lloc = &results, res; SCM results = SCM_EOL, *lloc = &results, res;
while (SCM_NIMP (l)) while (!SCM_IMP (l))
{ {
#ifdef SCM_CAUTIOUS #ifdef SCM_CAUTIOUS
if (SCM_CONSP (l)) if (SCM_CONSP (l))
@ -1538,7 +1535,7 @@ scm_eval_args (SCM l, SCM env, SCM proc)
l = SCM_CDR (l); l = SCM_CDR (l);
} }
#ifdef SCM_CAUTIOUS #ifdef SCM_CAUTIOUS
if (SCM_NNULLP (l)) if (!SCM_NULLP (l))
{ {
wrongnumargs: wrongnumargs:
scm_wrong_num_args (proc); scm_wrong_num_args (proc);
@ -1733,7 +1730,7 @@ SCM
scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc) scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
{ {
SCM *results = lloc, res; SCM *results = lloc, res;
while (SCM_NIMP (l)) while (!SCM_IMP (l))
{ {
#ifdef SCM_CAUTIOUS #ifdef SCM_CAUTIOUS
if (SCM_CONSP (l)) if (SCM_CONSP (l))
@ -1761,7 +1758,7 @@ scm_deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
l = SCM_CDR (l); l = SCM_CDR (l);
} }
#ifdef SCM_CAUTIOUS #ifdef SCM_CAUTIOUS
if (SCM_NNULLP (l)) if (!SCM_NULLP (l))
{ {
wrongnumargs: wrongnumargs:
scm_wrong_num_args (proc); scm_wrong_num_args (proc);
@ -1943,11 +1940,11 @@ dispatch:
begin: begin:
/* If we are on toplevel with a lookup closure, we need to sync /* If we are on toplevel with a lookup closure, we need to sync
with the current module. */ 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; t.arg1 = x;
UPDATE_TOPLEVEL_ENV (env); 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); EVALCAR (x, env);
x = t.arg1; x = t.arg1;
@ -1964,7 +1961,7 @@ dispatch:
x = SCM_CDR (x); x = SCM_CDR (x);
nontoplevel_begin: nontoplevel_begin:
t.arg1 = x; 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))) if (SCM_IMP (SCM_CAR (x)))
{ {
@ -1974,7 +1971,7 @@ dispatch:
goto nontoplevel_begin; goto nontoplevel_begin;
} }
else else
SCM_EVALIM2 (SCM_CAR(x)); SCM_EVALIM2 (SCM_CAR (x));
} }
else else
SCM_CEVAL (SCM_CAR (x), env); SCM_CEVAL (SCM_CAR (x), env);
@ -1982,7 +1979,7 @@ dispatch:
} }
carloop: /* scm_eval car of last form in list */ 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); x = SCM_CAR (x);
RETURN (SCM_IMP (x) ? SCM_EVALIM (x, env) : SCM_GLOC_VAL (x)) RETURN (SCM_IMP (x) ? SCM_EVALIM (x, env) : SCM_GLOC_VAL (x))
@ -2026,18 +2023,18 @@ dispatch:
case SCM_BIT8(SCM_IM_COND): case SCM_BIT8(SCM_IM_COND):
while (SCM_NIMP (x = SCM_CDR (x))) while (!SCM_IMP (x = SCM_CDR (x)))
{ {
proc = SCM_CAR (x); proc = SCM_CAR (x);
t.arg1 = EVALCAR (proc, env); t.arg1 = EVALCAR (proc, env);
if (SCM_NFALSEP (t.arg1)) if (SCM_NFALSEP (t.arg1))
{ {
x = SCM_CDR (proc); x = SCM_CDR (proc);
if SCM_NULLP (x) if (SCM_NULLP (x))
{ {
RETURN (t.arg1) 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); PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto begin; goto begin;
@ -2147,10 +2144,10 @@ dispatch:
case SCM_BIT8(SCM_IM_OR): case SCM_BIT8(SCM_IM_OR):
x = SCM_CDR (x); x = SCM_CDR (x);
t.arg1 = x; t.arg1 = x;
while (SCM_NNULLP (t.arg1 = SCM_CDR (t.arg1))) while (!SCM_NULLP (t.arg1 = SCM_CDR (t.arg1)))
{ {
x = EVALCAR (x, env); x = EVALCAR (x, env);
if (SCM_NFALSEP (x)) if (!SCM_FALSEP (x))
{ {
RETURN (x); RETURN (x);
} }
@ -2576,7 +2573,7 @@ dispatch:
unmemocar (x, env); unmemocar (x, env);
goto badfun; goto badfun;
} }
if (scm_tc16_macro == SCM_TYP16 (proc)) if (SCM_MACROP (proc))
{ {
unmemocar (x, env); unmemocar (x, env);
@ -2586,19 +2583,19 @@ dispatch:
application frames can be deleted from the backtrace. */ application frames can be deleted from the backtrace. */
SCM_SET_MACROEXP (debug); SCM_SET_MACROEXP (debug);
#endif #endif
t.arg1 = SCM_APPLY (SCM_CDR (proc), x, t.arg1 = SCM_APPLY (SCM_MACRO_CODE (proc), x,
scm_cons (env, scm_listofnull)); scm_cons (env, scm_listofnull));
#ifdef DEVAL #ifdef DEVAL
SCM_CLEAR_MACROEXP (debug); SCM_CLEAR_MACROEXP (debug);
#endif #endif
switch (SCM_CELL_WORD_0 (proc) >> 16) switch (SCM_MACRO_TYPE (proc))
{ {
case 2: case 2:
if (scm_ilength (t.arg1) <= 0) if (scm_ilength (t.arg1) <= 0)
t.arg1 = scm_cons2 (SCM_IM_BEGIN, t.arg1, SCM_EOL); t.arg1 = scm_cons2 (SCM_IM_BEGIN, t.arg1, SCM_EOL);
#ifdef DEVAL #ifdef DEVAL
if (!SCM_CLOSUREP (SCM_CDR (proc))) if (!SCM_CLOSUREP (SCM_MACRO_CODE (proc)))
{ {
SCM_DEFER_INTS; SCM_DEFER_INTS;
SCM_SETCAR (x, SCM_CAR (t.arg1)); SCM_SETCAR (x, SCM_CAR (t.arg1));
@ -2626,7 +2623,7 @@ dispatch:
} }
else else
proc = SCM_CEVAL (SCM_CAR (x), env); proc = SCM_CEVAL (SCM_CAR (x), env);
SCM_ASRTGO (SCM_NIMP (proc), badfun); SCM_ASRTGO (!SCM_IMP (proc), badfun);
#ifndef SCM_RECKLESS #ifndef SCM_RECKLESS
#ifdef SCM_CAUTIOUS #ifdef SCM_CAUTIOUS
checkargs: checkargs:
@ -2635,19 +2632,19 @@ dispatch:
{ {
arg2 = SCM_CAR (SCM_CODE (proc)); arg2 = SCM_CAR (SCM_CODE (proc));
t.arg1 = SCM_CDR (x); t.arg1 = SCM_CDR (x);
while (SCM_NIMP (arg2)) while (!SCM_IMP (arg2))
{ {
if (SCM_NCONSP (arg2)) if (!SCM_CONSP (arg2))
goto evapply; goto evapply;
if (SCM_IMP (t.arg1)) if (SCM_IMP (t.arg1))
goto umwrongnumargs; goto umwrongnumargs;
arg2 = SCM_CDR (arg2); arg2 = SCM_CDR (arg2);
t.arg1 = SCM_CDR (t.arg1); t.arg1 = SCM_CDR (t.arg1);
} }
if (SCM_NNULLP (t.arg1)) if (!SCM_NULLP (t.arg1))
goto umwrongnumargs; goto umwrongnumargs;
} }
else if (scm_tc16_macro == SCM_TYP16 (proc)) else if (SCM_MACROP (proc))
goto handle_a_macro; goto handle_a_macro;
#endif #endif
} }
@ -3778,7 +3775,7 @@ promise_print (SCM exp, SCM port, scm_print_state *pstate)
int writingp = SCM_WRITINGP (pstate); int writingp = SCM_WRITINGP (pstate);
scm_puts ("#<promise ", port); scm_puts ("#<promise ", port);
SCM_SET_WRITINGP (pstate, 1); SCM_SET_WRITINGP (pstate, 1);
scm_iprin1 (SCM_CDR (exp), port, pstate); scm_iprin1 (SCM_CELL_WORD_1 (exp), port, pstate);
SCM_SET_WRITINGP (pstate, writingp); SCM_SET_WRITINGP (pstate, writingp);
scm_putc ('>', port); scm_putc ('>', port);
return !0; return !0;

10
libguile/eval.h
View file

@ -1,8 +1,8 @@
/* classes: h_files */ /* classes: h_files */
#ifndef EVALH #ifndef SCM_EVAL_H
#define EVALH #define SCM_EVAL_H
/* 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 * 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 * 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 scm_f_apply;
extern scm_bits_t scm_tc16_macro;
/* A resolved global variable reference in the CAR position /* 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 * of a list is stored (in code only) as a pointer to a pair with a
* tag of 1. This is called a "gloc". * 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); extern void scm_init_eval (void);
#endif /* EVALH */ #endif /* SCM_EVAL_H */
/* /*
Local Variables: Local Variables:

6
libguile/fluids.c
View file

@ -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 * 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 * 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 void
scm_swap_fluids (SCM fluids, SCM vals) scm_swap_fluids (SCM fluids, SCM vals)
{ {
while (SCM_NIMP (fluids)) while (!SCM_NULLP (fluids))
{ {
SCM fl = SCM_CAR (fluids); SCM fl = SCM_CAR (fluids);
SCM old_val = scm_fluid_ref (fl); SCM old_val = scm_fluid_ref (fl);
@ -200,7 +200,7 @@ same fluid appears multiple times in the fluids list. */
void void
scm_swap_fluids_reverse (SCM fluids, SCM vals) scm_swap_fluids_reverse (SCM fluids, SCM vals)
{ {
if (SCM_NIMP (fluids)) if (!SCM_NULLP (fluids))
{ {
SCM fl, old_val; SCM fl, old_val;

22
libguile/gc.c
View file

@ -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 * 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 * 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); ptr = SCM_CDR (ptr);
goto gc_mark_loop; goto gc_mark_loop;
case scm_tc7_pws: case scm_tc7_pws:
RECURSE (SCM_CELL_OBJECT_2 (ptr)); RECURSE (SCM_SETTER (ptr));
ptr = SCM_CDR (ptr); ptr = SCM_PROCEDURE (ptr);
goto gc_mark_loop; goto gc_mark_loop;
case scm_tcs_cons_gloc: case scm_tcs_cons_gloc:
{ {
@ -1241,13 +1241,13 @@ gc_mark_loop_first_time:
} }
break; break;
case scm_tcs_closures: case scm_tcs_closures:
if (SCM_IMP (SCM_CDR (ptr))) if (SCM_IMP (SCM_ENV (ptr)))
{ {
ptr = SCM_CLOSCAR (ptr); ptr = SCM_CLOSCAR (ptr);
goto gc_mark_nimp; goto gc_mark_nimp;
} }
RECURSE (SCM_CLOSCAR (ptr)); RECURSE (SCM_CLOSCAR (ptr));
ptr = SCM_CDR (ptr); ptr = SCM_ENV (ptr);
goto gc_mark_nimp; goto gc_mark_nimp;
case scm_tc7_vector: case scm_tc7_vector:
i = SCM_VECTOR_LENGTH (ptr); i = SCM_VECTOR_LENGTH (ptr);
@ -1541,8 +1541,8 @@ gc_sweep_freelist_finish (scm_freelist_t *freelist)
if (!SCM_NULLP (freelist->cells)) if (!SCM_NULLP (freelist->cells))
{ {
SCM c = freelist->cells; SCM c = freelist->cells;
SCM_SETCAR (c, SCM_CDR (c)); SCM_SET_CELL_WORD_0 (c, SCM_FREE_CELL_CDR (c));
SCM_SETCDR (c, SCM_EOL); SCM_SET_CELL_WORD_1 (c, SCM_EOL);
freelist->collected += freelist->collected +=
freelist->span * (freelist->cluster_size - freelist->left_to_collect); freelist->span * (freelist->cluster_size - freelist->left_to_collect);
} }
@ -1733,7 +1733,7 @@ scm_gc_sweep ()
SCM_SETSTREAM (scmptr, 0); SCM_SETSTREAM (scmptr, 0);
scm_remove_from_port_table (scmptr); scm_remove_from_port_table (scmptr);
scm_gc_ports_collected++; scm_gc_ports_collected++;
SCM_SETAND_CAR (scmptr, ~SCM_OPN); SCM_CLR_PORT_OPEN_FLAG (scmptr);
} }
break; break;
case scm_tc7_smob: case scm_tc7_smob:
@ -1770,7 +1770,7 @@ scm_gc_sweep ()
if (!--left_to_collect) if (!--left_to_collect)
{ {
SCM_SETCAR (scmptr, nfreelist); SCM_SET_CELL_WORD_0 (scmptr, nfreelist);
*freelist->clustertail = scmptr; *freelist->clustertail = scmptr;
freelist->clustertail = SCM_CDRLOC (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_SET_CELL_TYPE (scmptr, scm_tc_free_cell);
SCM_SETCDR (scmptr, PTR2SCM (nxt)); SCM_SET_FREE_CELL_CDR (scmptr, PTR2SCM (nxt));
ptr = nxt; ptr = nxt;
} }
@ -2463,7 +2463,7 @@ scm_unprotect_object (SCM obj)
handle = scm_hashq_get_handle (scm_protects, 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"); fprintf (stderr, "scm_unprotect_object called on unprotected object\n");
abort (); abort ();

8
libguile/guardians.c
View file

@ -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 * 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 * 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) \ #define TCONC_IN(tc, obj, pair) \
do { \ do { \
SCM_SETCAR ((tc).tail, obj); \ SCM_SETCAR ((tc).tail, obj); \
SCM_SETCAR (pair, SCM_BOOL_F); \ SCM_SET_CELL_WORD_0 (pair, SCM_BOOL_F); \
SCM_SETCDR (pair, SCM_EOL); \ SCM_SET_CELL_WORD_1 (pair, SCM_EOL); \
SCM_SETCDR ((tc).tail, pair); \ SCM_SETCDR ((tc).tail, pair); \
(tc).tail = pair; \ (tc).tail = pair; \
} while (0) } while (0)
@ -258,7 +258,7 @@ scm_guard (SCM guardian, SCM obj, int throw_p)
if (GREEDY_P (g)) if (GREEDY_P (g))
{ {
if (SCM_NFALSEP (scm_hashq_get_handle if (!SCM_FALSEP (scm_hashq_get_handle
(greedily_guarded_whash, obj))) (greedily_guarded_whash, obj)))
{ {
SCM_ALLOW_INTS; SCM_ALLOW_INTS;

63
libguile/hashtab.c
View file

@ -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 * 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 * 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); return scm_c_make_vector (k, SCM_EOL);
} }
SCM SCM
scm_hash_fn_get_handle (SCM table,SCM obj,unsigned int (*hash_fn)(),SCM (*assoc_fn)(),void * closure) 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; unsigned int k;
SCM h; 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) if (SCM_VECTOR_LENGTH (table) == 0)
return SCM_EOL; return SCM_BOOL_F;
k = hash_fn (obj, SCM_VECTOR_LENGTH (table), closure); k = hash_fn (obj, SCM_VECTOR_LENGTH (table), closure);
if (k >= SCM_VECTOR_LENGTH (table)) if (k >= SCM_VECTOR_LENGTH (table))
scm_out_of_range ("hash_fn_get_handle", scm_ulong2num (k)); scm_out_of_range ("hash_fn_get_handle", scm_ulong2num (k));
h = assoc_fn (obj, SCM_VELTS (table)[k], closure); h = assoc_fn (obj, SCM_VELTS (table)[k], closure);
return h; return h;
} }
#undef FUNC_NAME
SCM SCM
@ -116,13 +119,11 @@ SCM
scm_hash_fn_ref (SCM table,SCM obj,SCM dflt,unsigned int (*hash_fn)(), scm_hash_fn_ref (SCM table,SCM obj,SCM dflt,unsigned int (*hash_fn)(),
SCM (*assoc_fn)(),void * closure) SCM (*assoc_fn)(),void * closure)
{ {
SCM it; SCM it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure);
if (SCM_CONSP (it))
it = scm_hash_fn_get_handle (table, obj, hash_fn, assoc_fn, closure);
if (SCM_IMP (it))
return dflt;
else
return SCM_CDR (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_DEFINE (scm_hashq_get_handle, "hashq-get-handle", 2, 0, 0,
(SCM table, SCM obj), (SCM table, SCM key),
"This procedure is similar to its @code{-ref} cousin, but returns a\n" "This procedure returns the @code{(key . value)} pair from the\n"
"@dfn{handle} from the hash table rather than the value associated with\n" "hash table @var{table}. If @var{table} does not hold an\n"
"@var{key}. By convention, a handle in a hash table is the pair which\n" "associated value for @var{key}, @code{#f} is returned.\n"
"associates a key with a value. Where @code{hashq-ref table key} returns\n" "Uses @code{eq?} for equality testing.")
"only a @code{value}, @code{hashq-get-handle table key} returns the pair\n"
"@code{(key . value)}.")
#define FUNC_NAME s_scm_hashq_get_handle #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 #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_DEFINE (scm_hashv_get_handle, "hashv-get-handle", 2, 0, 0,
(SCM table, SCM obj), (SCM table, SCM key),
"This procedure is similar to its @code{-ref} cousin, but returns a\n" "This procedure returns the @code{(key . value)} pair from the\n"
"@dfn{handle} from the hash table rather than the value associated with\n" "hash table @var{table}. If @var{table} does not hold an\n"
"@var{key}. By convention, a handle in a hash table is the pair which\n" "associated value for @var{key}, @code{#f} is returned.\n"
"associates a key with a value. Where @code{hashv-ref table key} returns\n" "Uses @code{eqv?} for equality testing.")
"only a @code{value}, @code{hashv-get-handle table key} returns the pair\n"
"@code{(key . value)}.")
#define FUNC_NAME s_scm_hashv_get_handle #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 #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_DEFINE (scm_hash_get_handle, "hash-get-handle", 2, 0, 0,
(SCM table, SCM obj), (SCM table, SCM key),
"This procedure is similar to its @code{-ref} cousin, but returns a\n" "This procedure returns the @code{(key . value)} pair from the\n"
"@dfn{handle} from the hash table rather than the value associated with\n" "hash table @var{table}. If @var{table} does not hold an\n"
"@var{key}. By convention, a handle in a hash table is the pair which\n" "associated value for @var{key}, @code{#f} is returned.\n"
"associates a key with a value. Where @code{hash-ref table key} returns\n" "Uses @code{equal?} for equality testing.")
"only a @code{value}, @code{hash-get-handle table key} returns the pair\n"
"@code{(key . value)}.")
#define FUNC_NAME s_scm_hash_get_handle #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 #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) for (i = 0; i < n; ++i)
{ {
SCM ls = SCM_VELTS (table)[i], handle; SCM ls = SCM_VELTS (table)[i], handle;
while (SCM_NNULLP (ls)) while (!SCM_NULLP (ls))
{ {
SCM_ASSERT (SCM_CONSP (ls), SCM_ASSERT (SCM_CONSP (ls),
table, SCM_ARG1, s_scm_hash_fold); table, SCM_ARG1, s_scm_hash_fold);

8
libguile/keywords.c
View file

@ -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 * 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 * 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}.") "Returns @code{#t} if the argument @var{obj} is a keyword, else @code{#f}.")
#define FUNC_NAME s_scm_keyword_p #define FUNC_NAME s_scm_keyword_p
{ {
return SCM_BOOL(SCM_KEYWORDP (obj)); return SCM_BOOL (SCM_KEYWORDP (obj));
} }
#undef FUNC_NAME #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}.") "This is the inverse of @code{make-keyword-from-dash-symbol}.")
#define FUNC_NAME s_scm_keyword_dash_symbol #define FUNC_NAME s_scm_keyword_dash_symbol
{ {
SCM_VALIDATE_KEYWORD (1,keyword); SCM_VALIDATE_KEYWORD (1, keyword);
return SCM_CDR (keyword); return SCM_KEYWORDSYM (keyword);
} }
#undef FUNC_NAME #undef FUNC_NAME

12
libguile/macros.h
View file

@ -1,8 +1,8 @@
/* classes: h_files */ /* classes: h_files */
#ifndef MACROSH #ifndef SCM_MACROS_H
#define MACROSH #define SCM_MACROS_H
/* Copyright (C) 1998, 2000 Free Software Foundation, Inc. /* Copyright (C) 1998,2000,2001 Free Software Foundation, Inc.
* *
* This program is free software; you can redistribute it and/or modify * 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 * it under the terms of the GNU General Public License as published by
@ -51,6 +51,10 @@
#define SCM_ASSYNT(_cond, _msg, _subr) \ #define SCM_ASSYNT(_cond, _msg, _subr) \
if (!(_cond)) scm_misc_error (_subr, _msg, SCM_EOL); 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_bits_t scm_tc16_macro;
extern SCM scm_makacro (SCM code); extern SCM scm_makacro (SCM code);
@ -65,7 +69,7 @@ extern SCM scm_make_synt (const char *name,
SCM (*fcn) ()); SCM (*fcn) ());
extern void scm_init_macros (void); extern void scm_init_macros (void);
#endif /* MACROSH */ #endif /* SCM_MACROS_H */
/* /*
Local Variables: Local Variables:

2
libguile/ports.c
View file

@ -663,7 +663,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
else else
rv = 0; rv = 0;
scm_remove_from_port_table (port); scm_remove_from_port_table (port);
SCM_SETAND_CAR (port, ~SCM_OPN); SCM_CLR_PORT_OPEN_FLAG (port);
return SCM_NEGATE_BOOL (rv < 0); return SCM_NEGATE_BOOL (rv < 0);
} }
#undef FUNC_NAME #undef FUNC_NAME

12
libguile/ports.h
View file

@ -1,8 +1,8 @@
/* classes: h_files */ /* classes: h_files */
#ifndef PORTSH #ifndef SCM_PORTS_H
#define PORTSH #define SCM_PORTS_H
/* Copyright (C) 1995,1996,1997,1998,1999, 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 * 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 * 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_BUF0 (8L<<16) /* Is it unbuffered? */
#define SCM_BUFLINE (64L<<16) /* Is it line-buffered? */ #define SCM_BUFLINE (64L<<16) /* Is it line-buffered? */
#define SCM_PORTP(x) (SCM_NIMP(x) && (SCM_TYP7(x)==scm_tc7_port)) #define SCM_PORTP(x) (SCM_NIMP (x) && (SCM_TYP7 (x) == scm_tc7_port))
#define SCM_OPPORTP(x) (SCM_NIMP(x) && (((0x7f | SCM_OPN) & SCM_CELL_WORD_0(x))==(scm_tc7_port | SCM_OPN))) #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_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))) #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))) && (((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_OPENP(x) (SCM_NIMP(x) && (SCM_OPN & SCM_CELL_WORD_0 (x)))
#define SCM_CLOSEDP(x) (!SCM_OPENP(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_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))) #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 /* SCM_DEBUG_DEPRECATED == 0 */
#endif /* PORTSH */ #endif /* SCM_PORTS_H */
/* /*
Local Variables: Local Variables:

26
libguile/print.c
View file

@ -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 * 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 * 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; pstate->revealed = 0;
SCM_NEWCELL (handle); SCM_NEWCELL (handle);
SCM_DEFER_INTS; SCM_DEFER_INTS;
SCM_SETCAR (handle, print_state); SCM_SET_CELL_WORD_0 (handle, print_state);
SCM_SETCDR (handle, SCM_CDR (print_state_pool)); SCM_SET_CELL_WORD_1 (handle, SCM_CDR (print_state_pool));
SCM_SETCDR (print_state_pool, handle); SCM_SETCDR (print_state_pool, handle);
SCM_ALLOW_INTS; SCM_ALLOW_INTS;
} }
@ -419,7 +419,7 @@ taloop:
exp, port, pstate))) exp, port, pstate)))
{ {
SCM name, code, env; SCM name, code, env;
if (SCM_TYP16 (exp) == scm_tc16_macro) if (SCM_MACROP (exp))
{ {
/* Printing a macro. */ /* Printing a macro. */
prinmacro: prinmacro:
@ -806,10 +806,11 @@ scm_ipruk (char *hdr, SCM ptr, SCM port)
scm_putc ('>', 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 void
scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate) 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 */ /* No cdr cycles intrinsic to this list */
scm_iprin1 (SCM_CAR (exp), port, pstate); scm_iprin1 (SCM_CAR (exp), port, pstate);
exp = SCM_CDR (exp); for (exp = SCM_CDR (exp); SCM_ECONSP (exp); exp = SCM_CDR (exp))
for (; SCM_NIMP (exp); exp = SCM_CDR (exp))
{ {
register int i; register int i;
if (SCM_NECONSP (exp))
break;
for (i = floor; i >= 0; --i) for (i = floor; i >= 0; --i)
if (SCM_EQ_P (pstate->ref_stack[i], exp)) if (SCM_EQ_P (pstate->ref_stack[i], exp))
goto circref; goto circref;
@ -852,7 +850,7 @@ scm_iprlist (char *hdr,SCM exp,int tlr,SCM port,scm_print_state *pstate)
/* CHECK_INTS; */ /* CHECK_INTS; */
scm_iprin1 (SCM_CAR (exp), port, pstate); scm_iprin1 (SCM_CAR (exp), port, pstate);
} }
if (SCM_NNULLP (exp)) if (!SCM_NULLP (exp))
{ {
scm_puts (" . ", port); scm_puts (" . ", port);
scm_iprin1 (exp, port, pstate); scm_iprin1 (exp, port, pstate);
@ -869,12 +867,10 @@ fancy_printing:
scm_iprin1 (SCM_CAR (exp), port, pstate); scm_iprin1 (SCM_CAR (exp), port, pstate);
exp = SCM_CDR (exp); --n; 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; register unsigned long i;
if (SCM_NECONSP (exp))
break;
for (i = 0; i < pstate->top; ++i) for (i = 0; i < pstate->top; ++i)
if (SCM_EQ_P (pstate->ref_stack[i], exp)) if (SCM_EQ_P (pstate->ref_stack[i], exp))
goto fancy_circref; goto fancy_circref;

12
libguile/procs.h
View file

@ -1,8 +1,8 @@
/* classes: h_files */ /* classes: h_files */
#ifndef PROCSH #ifndef SCM_PROCS_H
#define PROCSH #define SCM_PROCS_H
/* 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 * 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 * 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_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)) \ #define SCM_SETCODE(x, e) (SCM_SET_CELL_WORD_0 (x, SCM_UNPACK (scm_cons ((e), SCM_EOL)) \
+ scm_tc3_closure)) + scm_tc3_closure))
#define SCM_ENV(x) SCM_CDR(x) #define SCM_ENV(x) SCM_CELL_OBJECT_1 (x)
#define SCM_SETENV(x, e) SCM_SETCDR (x, e) #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))) #define SCM_TOP_LEVEL(ENV) (SCM_NULLP (ENV) || (SCM_EQ_P (scm_procedure_p (SCM_CAR (ENV)), SCM_BOOL_T)))
/* Procedure-with-setter /* Procedure-with-setter
@ -194,7 +194,7 @@ extern SCM scm_make_cclo (SCM proc, SCM len);
#endif /* SCM_DEBUG_DEPRECATED == 0 */ #endif /* SCM_DEBUG_DEPRECATED == 0 */
#endif /* PROCSH */ #endif /* SCM_PROCS_H */
/* /*
Local Variables: Local Variables:

24
libguile/properties.c
View file

@ -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 * 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 * 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 #undef FUNC_NAME
SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0, SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0,
(SCM prop, SCM obj), (SCM prop, SCM obj),
"Return the property @var{prop} of @var{obj}. When no value\n" "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}.") "default value of @var{prop}.")
#define FUNC_NAME s_scm_primitive_property_ref #define FUNC_NAME s_scm_primitive_property_ref
{ {
SCM h, assoc; SCM h;
SCM_VALIDATE_CONS (SCM_ARG1, prop); SCM_VALIDATE_CONS (SCM_ARG1, prop);
h = scm_hashq_get_handle (scm_properties_whash, obj); h = scm_hashq_get_handle (scm_properties_whash, obj);
assoc = (SCM_NIMP (h) ? scm_assq (prop, SCM_CDR (h)) : SCM_BOOL_F); if (!SCM_FALSEP (h))
if (SCM_NIMP (assoc)) {
return SCM_CDR (assoc); SCM assoc = scm_assq (prop, SCM_CDR (h));
if (!SCM_FALSEP (assoc))
return SCM_CDR (assoc);
}
if (SCM_FALSEP (SCM_CAR (prop))) if (SCM_FALSEP (SCM_CAR (prop)))
return SCM_BOOL_F; return SCM_BOOL_F;
else else
{ {
SCM val = scm_apply (SCM_CAR (prop), SCM val = scm_apply (SCM_CAR (prop), SCM_LIST2 (prop, obj), SCM_EOL);
SCM_LIST2 (prop, obj), SCM_EOL); if (SCM_FALSEP (h))
if (SCM_IMP (h))
h = scm_hashq_create_handle_x (scm_properties_whash, obj, SCM_EOL); h = scm_hashq_create_handle_x (scm_properties_whash, obj, SCM_EOL);
SCM_SETCDR (h, scm_acons (prop, val, SCM_CDR (h))); SCM_SETCDR (h, scm_acons (prop, val, SCM_CDR (h)));
return val; return val;
@ -106,6 +109,7 @@ SCM_DEFINE (scm_primitive_property_ref, "primitive-property-ref", 2, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
SCM_DEFINE (scm_primitive_property_set_x, "primitive-property-set!", 3, 0, 0, SCM_DEFINE (scm_primitive_property_set_x, "primitive-property-set!", 3, 0, 0,
(SCM prop, SCM obj, SCM val), (SCM prop, SCM obj, SCM val),
"Associate @var{code} with @var{prop} and @var{obj}.") "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 #undef FUNC_NAME
SCM_DEFINE (scm_primitive_property_del_x, "primitive-property-del!", 2, 0, 0, SCM_DEFINE (scm_primitive_property_del_x, "primitive-property-del!", 2, 0, 0,
(SCM prop, SCM obj), (SCM prop, SCM obj),
"Remove any value associated with @var{prop} and @var{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 h;
SCM_VALIDATE_CONS (SCM_ARG1, prop); SCM_VALIDATE_CONS (SCM_ARG1, prop);
h = scm_hashq_get_handle (scm_properties_whash, obj); 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)); SCM_SETCDR (h, scm_assq_remove_x (SCM_CDR (h), prop));
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #undef FUNC_NAME
void void
scm_init_properties () scm_init_properties ()
{ {

4
libguile/smob.c
View file

@ -88,9 +88,11 @@ scm_mark0 (SCM ptr)
} }
SCM SCM
/* Dirk::FIXME: The name markcdr is misleading, since the term cdr should only
be used for real pairs. */
scm_markcdr (SCM ptr) scm_markcdr (SCM ptr)
{ {
return SCM_CDR (ptr); return SCM_CELL_OBJECT_1 (ptr);
} }
/* {Free} /* {Free}

18
libguile/tags.h
View file

@ -1,8 +1,8 @@
/* classes: h_files */ /* classes: h_files */
#ifndef TAGSH #ifndef SCM_TAGS_H
#define TAGSH #define SCM_TAGS_H
/* Copyright (C) 1995, 96, 97, 98, 99, 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 * 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 * 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: * 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_CONSP(x) (!SCM_IMP (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_NCONSP(x) (!SCM_CONSP (x)) #define SCM_NCONSP(x) (!SCM_CONSP (x))
@ -283,7 +280,7 @@ typedef long scm_bits_t;
*/ */
#define SCM_ECONSP(x) \ #define SCM_ECONSP(x) \
(!SCM_IMP (x) \ (!SCM_IMP (x) \
&& (SCM_SLOPPY_CONSP (x) \ && (SCM_CONSP (x) \
|| (SCM_TYP3 (x) == 1 \ || (SCM_TYP3 (x) == 1 \
&& (SCM_STRUCT_VTABLE_DATA (x)[scm_vtable_index_vcell] != 0)))) && (SCM_STRUCT_VTABLE_DATA (x)[scm_vtable_index_vcell] != 0))))
#define SCM_NECONSP(x) (!SCM_ECONSP (x)) #define SCM_NECONSP(x) (!SCM_ECONSP (x))
@ -542,6 +539,9 @@ extern char *scm_isymnames[]; /* defined in print.c */
#if (SCM_DEBUG_DEPRECATED == 0) #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_ssymbol scm_tc7_symbol
#define scm_tc7_msymbol scm_tc7_symbol #define scm_tc7_msymbol scm_tc7_symbol
#define scm_tcs_symbols 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 /* SCM_DEBUG_DEPRECATED == 0 */
#endif /* TAGSH */ #endif /* SCM_TAGS_H */
/* /*
Local Variables: Local Variables:

8
libguile/throw.c
View file

@ -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 * 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 * 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 SCM_JMPBUFP(OBJ) SCM_TYP16_PREDICATE (tc16_jmpbuffer, OBJ)
#define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L)) #define JBACTIVE(OBJ) (SCM_CELL_WORD_0 (OBJ) & (1L << 16L))
#define ACTIVATEJB(OBJ) (SCM_SETOR_CAR (OBJ, (1L << 16L))) #define ACTIVATEJB(x) \
#define DEACTIVATEJB(OBJ) (SCM_SETAND_CAR (OBJ, ~(1L << 16L))) (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 JBJMPBUF(OBJ) ((jmp_buf *) SCM_CELL_WORD_1 (OBJ))
#define SETJBJMPBUF(x,v) (SCM_SET_CELL_WORD_1 ((x), (v))) #define SETJBJMPBUF(x,v) (SCM_SET_CELL_WORD_1 ((x), (v)))

41
libguile/variable.c
View file

@ -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 * 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 * 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) variable_print (SCM exp, SCM port, scm_print_state *pstate)
{ {
scm_puts ("#<variable ", port); scm_puts ("#<variable ", port);
scm_intprint(SCM_UNPACK (exp), 16, port); scm_intprint (SCM_UNPACK (exp), 16, port);
{ {
SCM val_cell; SCM vcell = SCM_VARVCELL (exp);
val_cell = SCM_CDR(exp); if (!SCM_UNBNDP (SCM_CAR (vcell)))
if (!SCM_UNBNDP (SCM_CAR (val_cell)))
{ {
scm_puts (" name: ", port); scm_puts (" name: ", port);
scm_iprin1 (SCM_CAR (val_cell), port, pstate); scm_iprin1 (SCM_CAR (vcell), port, pstate);
} }
scm_puts (" binding: ", port); scm_puts (" binding: ", port);
scm_iprin1 (SCM_CDR (val_cell), port, pstate); scm_iprin1 (SCM_CDR (vcell), port, pstate);
} }
scm_putc('>', port); scm_putc('>', port);
return 1; return 1;
@ -78,7 +77,7 @@ variable_print (SCM exp, SCM port, scm_print_state *pstate)
static SCM static SCM
variable_equalp (SCM var1, SCM var2) 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") "variable may exist, so @var{name-hint} is just that---a hint.\n")
#define FUNC_NAME s_scm_make_variable #define FUNC_NAME s_scm_make_variable
{ {
SCM val_cell; SCM vcell;
if (SCM_UNBNDP (name_hint)) if (SCM_UNBNDP (name_hint))
name_hint = anonymous_variable_sym; name_hint = anonymous_variable_sym;
SCM_NEWCELL(val_cell); vcell = scm_cons (name_hint, init);
SCM_DEFER_INTS; return make_vcell_variable (vcell);
SCM_SETCAR (val_cell, name_hint);
SCM_SETCDR (val_cell, init);
SCM_ALLOW_INTS;
return make_vcell_variable (val_cell);
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -129,11 +124,7 @@ SCM_DEFINE (scm_make_undefined_variable, "make-undefined-variable", 0, 1, 0,
if (SCM_UNBNDP (name_hint)) if (SCM_UNBNDP (name_hint))
name_hint = anonymous_variable_sym; name_hint = anonymous_variable_sym;
SCM_NEWCELL (vcell); vcell = scm_cons (name_hint, SCM_UNDEFINED);
SCM_DEFER_INTS;
SCM_SETCAR (vcell, name_hint);
SCM_SETCDR (vcell, SCM_UNDEFINED);
SCM_ALLOW_INTS;
return make_vcell_variable (vcell); return make_vcell_variable (vcell);
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -158,7 +149,7 @@ SCM_DEFINE (scm_variable_ref, "variable-ref", 1, 0, 0,
#define FUNC_NAME s_scm_variable_ref #define FUNC_NAME s_scm_variable_ref
{ {
SCM_VALIDATE_VARIABLE (1, var); SCM_VALIDATE_VARIABLE (1, var);
return SCM_CDR (SCM_CDR (var)); return SCM_CDR (SCM_VARVCELL (var));
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -171,8 +162,8 @@ SCM_DEFINE (scm_variable_set_x, "variable-set!", 2, 0, 0,
"value. Return an unspecified value.\n") "value. Return an unspecified value.\n")
#define FUNC_NAME s_scm_variable_set_x #define FUNC_NAME s_scm_variable_set_x
{ {
SCM_VALIDATE_VARIABLE (1,var); SCM_VALIDATE_VARIABLE (1, var);
SCM_SETCDR (SCM_CDR (var), val); SCM_SETCDR (SCM_VARVCELL (var), val);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #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") "Throws an error if @var{var} is not a variable object.\n")
#define FUNC_NAME s_scm_variable_bound_p #define FUNC_NAME s_scm_variable_bound_p
{ {
SCM_VALIDATE_VARIABLE (1,var); SCM_VALIDATE_VARIABLE (1, var);
return SCM_NEGATE_BOOL(SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var)))); return SCM_BOOL (!SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (var))));
} }
#undef FUNC_NAME #undef FUNC_NAME

10
libguile/variable.h
View file

@ -1,8 +1,8 @@
/* classes: h_files */ /* classes: h_files */
#ifndef VARIABLEH #ifndef SCM_VARIABLE_H
#define VARIABLEH #define SCM_VARIABLE_H
/* 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 * 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 * it under the terms of the GNU General Public License as published by
@ -55,7 +55,7 @@
*/ */
extern scm_bits_t scm_tc16_variable; 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_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_UDVARIABLEP(X) (SCM_VARIABLEP(X) && SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X))))
#define SCM_DEFVARIABLEP(X) (SCM_VARIABLEP(X) && !SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X)))) #define SCM_DEFVARIABLEP(X) (SCM_VARIABLEP(X) && !SCM_UNBNDP (SCM_CDR (SCM_VARVCELL (X))))
@ -71,7 +71,7 @@ extern SCM scm_builtin_variable (SCM name);
extern SCM scm_variable_bound_p (SCM var); extern SCM scm_variable_bound_p (SCM var);
extern void scm_init_variable (void); extern void scm_init_variable (void);
#endif /* VARIABLEH */ #endif /* SCM_VARIABLE_H */
/* /*
Local Variables: Local Variables:

19
libguile/vectors.c
View file

@ -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 * 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 * 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 #define FUNC_NAME s_scm_vector
{ {
SCM res; SCM res;
register SCM *data; SCM *data;
int i; long i;
SCM_VALIDATE_LIST_COPYLEN (1,l,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); res = scm_c_make_vector (i, SCM_UNSPECIFIED);
data = SCM_VELTS (res); data = SCM_VELTS (res);
for(; i && SCM_NIMP(l); --i, l = SCM_CDR (l)) while (!SCM_NULLP (l))
*data++ = SCM_CAR (l); {
*data++ = SCM_CAR (l);
l = SCM_CDR (l);
}
return res; return res;
} }
#undef FUNC_NAME #undef FUNC_NAME

17
libguile/weaks.c
View file

@ -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 * 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 * 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 #define FUNC_NAME s_scm_weak_vector
{ {
SCM res; SCM res;
register SCM *data; SCM *data;
long i; long i;
/* Dirk:FIXME:: In case of multiple threads, the list might get corrupted
while the vector is being created. */
i = scm_ilength (l); i = scm_ilength (l);
SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME); SCM_ASSERT (i >= 0, l, SCM_ARG1, FUNC_NAME);
res = scm_make_weak_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED); res = scm_make_weak_vector (SCM_MAKINUM (i), SCM_UNSPECIFIED);
data = SCM_VELTS (res); data = SCM_VELTS (res);
for (;
i && SCM_CONSP (l); while (!SCM_NULLP (l))
--i, l = SCM_CDR (l)) {
*data++ = SCM_CAR (l); *data++ = SCM_CAR (l);
l = SCM_CDR (l);
}
return res; return res;
} }
#undef FUNC_NAME #undef FUNC_NAME