mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +02:00
Code Activity

Some fixes for strict typing.

Browse source
This commit is contained in:
Dirk Herrmann 2000-04-01 21:23:09 +00:00
parent 47a4dcc5b4
commit cf49832683
3 changed files with 36 additions and 27 deletions
Download patch file Download diff file Expand all files Collapse all files

9
libguile/ChangeLog
View file

@ -1,3 +1,12 @@
2000-04-01 Dirk Herrmann <D.Herrmann@tu-bs.de>
* eval.c (scm_lookupcar1, scm_lookupcar, scm_m_case, scm_m_cond,
scm_m_lambda, iqq, scm_m_define, scm_m_expand_body, unmemocopy,
SCM_CEVAL), procs.h (SCM_TOP_LEVEL): Don't use C operators to
compare SCM values.
(scm_makprom): Smob data is of type scm_bits_t.
2000-03-31 Dirk Herrmann <D.Herrmann@tu-bs.de> 2000-03-31 Dirk Herrmann <D.Herrmann@tu-bs.de>
* backtrace.c (display_error_body), debug.c (scm_procedure_source, * backtrace.c (display_error_body), debug.c (scm_procedure_source,

52
libguile/eval.c
View file

@ -278,18 +278,18 @@ scm_lookupcar (SCM vloc, SCM genv, int check)
#endif #endif
for (; SCM_NIMP (env); env = SCM_CDR (env)) for (; SCM_NIMP (env); env = SCM_CDR (env))
{ {
if (SCM_BOOL_T == scm_procedure_p (SCM_CAR (env))) if (SCM_TRUE_P (scm_procedure_p (SCM_CAR (env))))
break; break;
al = SCM_CARLOC (env); al = SCM_CARLOC (env);
for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl)) for (fl = SCM_CAR (*al); SCM_NIMP (fl); fl = SCM_CDR (fl))
{ {
if (SCM_NCONSP (fl)) if (SCM_NCONSP (fl))
{ {
if (fl == var) if (SCM_EQ_P (fl, var))
{ {
#ifdef MEMOIZE_LOCALS #ifdef MEMOIZE_LOCALS
#ifdef USE_THREADS #ifdef USE_THREADS
if (SCM_CAR (vloc) != var) if (! SCM_EQ_P (SCM_CAR (vloc), var))
goto race; goto race;
#endif #endif
SCM_SETCAR (vloc, iloc + SCM_ICDR); SCM_SETCAR (vloc, iloc + SCM_ICDR);
@ -300,7 +300,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check)
break; break;
} }
al = SCM_CDRLOC (*al); al = SCM_CDRLOC (*al);
if (SCM_CAR (fl) == var) if (SCM_EQ_P (SCM_CAR (fl), var))
{ {
#ifdef MEMOIZE_LOCALS #ifdef MEMOIZE_LOCALS
#ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */ #ifndef SCM_RECKLESS /* letrec inits to SCM_UNDEFINED */
@ -336,7 +336,7 @@ scm_lookupcar (SCM vloc, SCM genv, int check)
else else
top_thunk = SCM_BOOL_F; top_thunk = SCM_BOOL_F;
vcell = scm_sym2vcell (var, top_thunk, SCM_BOOL_F); vcell = scm_sym2vcell (var, top_thunk, SCM_BOOL_F);
if (vcell == SCM_BOOL_F) if (SCM_FALSEP (vcell))
goto errout; goto errout;
else else
var = vcell; var = vcell;
@ -638,7 +638,7 @@ scm_m_case (SCM xorig, SCM env)
proc = SCM_CAR (x); proc = SCM_CAR (x);
SCM_ASSYNT (scm_ilength (proc) >= 2, xorig, scm_s_clauses, s_case); SCM_ASSYNT (scm_ilength (proc) >= 2, xorig, scm_s_clauses, s_case);
SCM_ASSYNT (scm_ilength (SCM_CAR (proc)) >= 0 SCM_ASSYNT (scm_ilength (SCM_CAR (proc)) >= 0
|| scm_sym_else == SCM_CAR (proc), || SCM_EQ_P (scm_sym_else, SCM_CAR (proc)),
xorig, scm_s_clauses, s_case); xorig, scm_s_clauses, s_case);
} }
return scm_cons (SCM_IM_CASE, cdrx); return scm_cons (SCM_IM_CASE, cdrx);
@ -660,13 +660,13 @@ scm_m_cond (SCM xorig, SCM env)
arg1 = SCM_CAR (x); arg1 = SCM_CAR (x);
len = scm_ilength (arg1); len = scm_ilength (arg1);
SCM_ASSYNT (len >= 1, xorig, scm_s_clauses, s_cond); SCM_ASSYNT (len >= 1, xorig, scm_s_clauses, s_cond);
if (scm_sym_else == SCM_CAR (arg1)) if (SCM_EQ_P (scm_sym_else, SCM_CAR (arg1)))
{ {
SCM_ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2, SCM_ASSYNT (SCM_NULLP (SCM_CDR (x)) && len >= 2,
xorig, "bad ELSE clause", s_cond); xorig, "bad ELSE clause", s_cond);
SCM_SETCAR (arg1, SCM_BOOL_T); SCM_SETCAR (arg1, SCM_BOOL_T);
} }
if (len >= 2 && scm_sym_arrow == SCM_CAR (SCM_CDR (arg1))) if (len >= 2 && SCM_EQ_P (scm_sym_arrow, SCM_CAR (SCM_CDR (arg1))))
SCM_ASSYNT (3 == len && SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1)))), SCM_ASSYNT (3 == len && SCM_NIMP (SCM_CAR (SCM_CDR (SCM_CDR (arg1)))),
xorig, "bad recipient", s_cond); xorig, "bad recipient", s_cond);
x = SCM_CDR (x); x = SCM_CDR (x);
@ -686,7 +686,7 @@ scm_m_lambda (SCM xorig, SCM env)
proc = SCM_CAR (x); proc = SCM_CAR (x);
if (SCM_NULLP (proc)) if (SCM_NULLP (proc))
goto memlambda; goto memlambda;
if (SCM_IM_LET == proc) /* named let */ if (SCM_EQ_P (SCM_IM_LET, proc)) /* named let */
goto memlambda; goto memlambda;
if (SCM_IMP (proc)) if (SCM_IMP (proc))
goto badforms; goto badforms;
@ -835,12 +835,12 @@ iqq (SCM form,SCM env,int depth)
if (SCM_NCONSP(form)) if (SCM_NCONSP(form))
return form; return form;
tmp = SCM_CAR (form); tmp = SCM_CAR (form);
if (scm_sym_quasiquote == tmp) if (SCM_EQ_P (scm_sym_quasiquote, tmp))
{ {
depth++; depth++;
goto label; goto label;
} }
if (scm_sym_unquote == tmp) if (SCM_EQ_P (scm_sym_unquote, tmp))
{ {
--depth; --depth;
label: label:
@ -851,7 +851,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_sym_uq_splicing == SCM_CAR (tmp))) if (SCM_NIMP (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)
@ -903,10 +903,10 @@ scm_m_define (SCM x, SCM env)
proc: proc:
if (SCM_CLOSUREP (arg1) if (SCM_CLOSUREP (arg1)
/* Only the first definition determines the name. */ /* Only the first definition determines the name. */
&& scm_procedure_property (arg1, scm_sym_name) == SCM_BOOL_F) && 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_TYP16 (arg1) == scm_tc16_macro
&& SCM_CDR (arg1) != arg1) && !SCM_EQ_P (SCM_CDR (arg1), arg1))
{ {
arg1 = SCM_CDR (arg1); arg1 = SCM_CDR (arg1);
goto proc; goto proc;
@ -1197,7 +1197,7 @@ scm_m_expand_body (SCM xorig, SCM env)
SCM_CDR (form)), SCM_CDR (form)),
env); env);
if (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);
@ -1206,7 +1206,7 @@ scm_m_expand_body (SCM xorig, SCM env)
{ {
break; break;
} }
else if (SCM_IM_BEGIN == SCM_CAR (form)) else if (SCM_EQ_P (SCM_IM_BEGIN, SCM_CAR (form)))
{ {
x = scm_append (scm_cons2 (SCM_CDR (form), SCM_CDR (x), SCM_EOL)); x = scm_append (scm_cons2 (SCM_CDR (form), SCM_CDR (x), SCM_EOL));
} }
@ -1348,10 +1348,10 @@ unmemocopy (SCM x, SCM env)
z = EXTEND_ENV (f, SCM_EOL, env); z = EXTEND_ENV (f, SCM_EOL, env);
/* inits */ /* inits */
e = scm_reverse (unmemocopy (SCM_CAR (x), e = scm_reverse (unmemocopy (SCM_CAR (x),
SCM_CAR (ls) == scm_sym_letrec ? z : env)); SCM_EQ_P (SCM_CAR (ls), scm_sym_letrec) ? z : env));
env = z; env = z;
/* increments */ /* increments */
s = SCM_CAR (ls) == scm_sym_do s = SCM_EQ_P (SCM_CAR (ls), scm_sym_do)
? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x))), env)) ? scm_reverse (unmemocopy (SCM_CDR (SCM_CDR (SCM_CDR (x))), env))
: f; : f;
/* build transformed binding list */ /* build transformed binding list */
@ -1360,7 +1360,7 @@ unmemocopy (SCM x, SCM env)
{ {
z = scm_acons (SCM_CAR (v), z = scm_acons (SCM_CAR (v),
scm_cons (SCM_CAR (e), scm_cons (SCM_CAR (e),
SCM_CAR (s) == SCM_CAR (v) SCM_EQ_P (SCM_CAR (s), SCM_CAR (v))
? SCM_EOL ? SCM_EOL
: scm_cons (SCM_CAR (s), SCM_EOL)), : scm_cons (SCM_CAR (s), SCM_EOL)),
z); z);
@ -1371,7 +1371,7 @@ unmemocopy (SCM x, SCM env)
while (SCM_NIMP (v)); while (SCM_NIMP (v));
z = scm_cons (z, SCM_UNSPECIFIED); z = scm_cons (z, SCM_UNSPECIFIED);
SCM_SETCDR (ls, z); SCM_SETCDR (ls, z);
if (SCM_CAR (ls) == scm_sym_do) if (SCM_EQ_P (SCM_CAR (ls), scm_sym_do))
{ {
x = SCM_CDR (x); x = SCM_CDR (x);
/* test clause */ /* test clause */
@ -1977,7 +1977,7 @@ dispatch:
while (SCM_NIMP (x = SCM_CDR (x))) while (SCM_NIMP (x = SCM_CDR (x)))
{ {
proc = SCM_CAR (x); proc = SCM_CAR (x);
if (scm_sym_else == SCM_CAR (proc)) if (SCM_EQ_P (scm_sym_else, SCM_CAR (proc)))
{ {
x = SCM_CDR (proc); x = SCM_CDR (proc);
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
@ -2010,7 +2010,7 @@ dispatch:
{ {
RETURN (t.arg1) RETURN (t.arg1)
} }
if (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;
@ -2318,7 +2318,7 @@ dispatch:
do do
{ {
/* More arguments than specifiers => CLASS != ENV */ /* More arguments than specifiers => CLASS != ENV */
if (scm_class_of (SCM_CAR (t.arg1)) != SCM_CAR (z)) if (! SCM_EQ_P (scm_class_of (SCM_CAR (t.arg1)), SCM_CAR (z)))
goto next_method; goto next_method;
t.arg1 = SCM_CDR (t.arg1); t.arg1 = SCM_CDR (t.arg1);
z = SCM_CDR (z); z = SCM_CDR (z);
@ -2362,7 +2362,7 @@ dispatch:
if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env)) if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env))
|| t.arg1 == scm_lisp_nil)) || t.arg1 == scm_lisp_nil))
{ {
if (SCM_CAR (x) == SCM_UNSPECIFIED) if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED))
RETURN (t.arg1); RETURN (t.arg1);
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop; goto carloop;
@ -2390,7 +2390,7 @@ dispatch:
if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env)) if (!(SCM_FALSEP (t.arg1 = EVALCAR (proc, env))
|| t.arg1 == SCM_INUM0)) || t.arg1 == SCM_INUM0))
{ {
if (SCM_CAR (x) == SCM_UNSPECIFIED) if (SCM_EQ_P (SCM_CAR (x), SCM_UNSPECIFIED))
RETURN (t.arg1); RETURN (t.arg1);
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
goto carloop; goto carloop;
@ -3685,7 +3685,7 @@ long scm_tc16_promise;
SCM SCM
scm_makprom (SCM code) scm_makprom (SCM code)
{ {
SCM_RETURN_NEWSMOB (scm_tc16_promise, code); SCM_RETURN_NEWSMOB (scm_tc16_promise, SCM_UNPACK (code));
} }

2
libguile/procs.h
View file

@ -109,7 +109,7 @@ typedef struct
+ scm_tc3_closure)) + scm_tc3_closure))
#define SCM_ENV(x) SCM_CDR(x) #define SCM_ENV(x) SCM_CDR(x)
#define SCM_SETENV(x, e) SCM_SETCDR (x, e) #define SCM_SETENV(x, e) SCM_SETCDR (x, e)
#define SCM_TOP_LEVEL(SCM_ENV) (SCM_NULLP(SCM_ENV) || (SCM_BOOL_T == scm_procedure_p (SCM_CAR (SCM_ENV)))) #define SCM_TOP_LEVEL(SCM_ENV) (SCM_NULLP (SCM_ENV) || (SCM_TRUE_P (scm_procedure_p (SCM_CAR (SCM_ENV)))))
/* Procedure-with-setter /* Procedure-with-setter