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

* Fixed scm_thunk_p's results when applied to closures.

Browse source 
* Extracted macro printing code from print.c to macros.c.
* Minor cleanups.
This commit is contained in:
Dirk Herrmann 2001-04-19 14:46:01 +00:00
parent e038c04203
commit 726d810a75
10 changed files with 132 additions and 120 deletions
Download patch file Download diff file Expand all files Collapse all files

28
libguile/ChangeLog
View file

@ -1,3 +1,31 @@
2001-04-19 Dirk Herrmann <D.Herrmann@tu-bs.de>
* procs.h (SCM_CLOSURE_FORMALS): New macro.
* debug.c (scm_procedure_source), eval.c (scm_badformalsp,
SCM_CEVAL, SCM_APPLY), goops.c (get_slot_value, set_slot_value),
procprop.c (scm_i_procedure_arity), sort.c (closureless): Use
SCM_CLOSURE_FORMALS.
* eval.c (scm_badformalsp, SCM_CEVAL), procprop.c
(scm_i_procedure_arity): Prefer stronger predicates like
SCM_NULLP or SCM_FALSEP over SCM_IMP.
* macros.c (macro_print): Extracted macro printing code from
print.c and simplified it.
(scm_macro_type): Use SCM_MACRO_TYPE;
(scm_init_macros): Use macro_print for printing macros.
* print.c (scm_print_opts): Improved option documentation.
(scm_iprin1): Extracted printing of macros to macros.c.
Simplified printing of ordinary closures.
* procs.c (scm_thunk_p): Fixed handling of closures. Thanks to
Martin Grabmueller for the bug report.
2001-04-19 Dirk Herrmann <D.Herrmann@tu-bs.de>
This patch eliminates some further applications of SCM_C[AD]R to

2
libguile/debug.c
View file

@ -429,7 +429,7 @@ SCM_DEFINE (scm_procedure_source, "procedure-source", 1, 0, 0,
SCM src;
src = scm_source_property (SCM_CDR (SCM_CODE (proc)), scm_sym_copy);
if (! SCM_FALSEP (src))
return scm_cons2 (scm_sym_lambda, SCM_CAR (SCM_CODE (proc)), src);
return scm_cons2 (scm_sym_lambda, SCM_CLOSURE_FORMALS (proc), src);
src = SCM_CODE (proc);
return scm_cons (scm_sym_lambda,
scm_unmemocopy (src,

36
libguile/eval.c
View file

@ -1489,10 +1489,10 @@ scm_badargsp (SCM formals, SCM args)
static int
scm_badformalsp (SCM closure, int n)
{
SCM formals = SCM_CAR (SCM_CODE (closure));
while (SCM_NIMP (formals))
SCM formals = SCM_CLOSURE_FORMALS (closure);
while (!SCM_NULLP (formals))
{
if (SCM_NCONSP (formals))
if (!SCM_CONSP (formals))
return 0;
if (n == 0)
return 1;
@ -2218,7 +2218,7 @@ dispatch:
debug.info->a.args = t.arg1;
#endif
#ifndef SCM_RECKLESS
if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), t.arg1))
if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), t.arg1))
goto wrongnumargs;
#endif
ENTER_APPLY;
@ -2238,7 +2238,7 @@ dispatch:
SCM_SETCDR (tl, t.arg1);
}
env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), argl, SCM_ENV (proc));
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), argl, SCM_ENV (proc));
x = SCM_CODE (proc);
goto nontoplevel_cdrxbegin;
}
@ -2630,9 +2630,9 @@ dispatch:
#endif
if (SCM_CLOSUREP (proc))
{
arg2 = SCM_CAR (SCM_CODE (proc));
arg2 = SCM_CLOSURE_FORMALS (proc);
t.arg1 = SCM_CDR (x);
while (!SCM_IMP (arg2))
while (!SCM_NULLP (arg2))
{
if (!SCM_CONSP (arg2))
goto evapply;
@ -2690,7 +2690,7 @@ evapply:
goto umwrongnumargs;
case scm_tcs_closures:
x = SCM_CODE (proc);
env = EXTEND_ENV (SCM_CAR (x), SCM_EOL, SCM_ENV (proc));
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), SCM_EOL, SCM_ENV (proc));
goto nontoplevel_cdrxbegin;
case scm_tcs_cons_gloc:
if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
@ -2842,9 +2842,9 @@ evapply:
/* clos1: */
x = SCM_CODE (proc);
#ifdef DEVAL
env = EXTEND_ENV (SCM_CAR (x), debug.info->a.args, SCM_ENV (proc));
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), debug.info->a.args, SCM_ENV (proc));
#else
env = EXTEND_ENV (SCM_CAR (x), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), scm_cons (t.arg1, SCM_EOL), SCM_ENV (proc));
#endif
goto nontoplevel_cdrxbegin;
case scm_tcs_cons_gloc:
@ -3005,11 +3005,11 @@ evapply:
case scm_tcs_closures:
/* clos2: */
#ifdef DEVAL
env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
debug.info->a.args,
SCM_ENV (proc));
#else
env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
scm_cons2 (t.arg1, arg2, SCM_EOL), SCM_ENV (proc));
#endif
x = SCM_CODE (proc);
@ -3083,11 +3083,11 @@ evapply:
debug.info->a.proc = proc;
if (!SCM_CLOSUREP (proc))
goto evap3;
if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), debug.info->a.args))
if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), debug.info->a.args))
goto umwrongnumargs;
case scm_tcs_closures:
SCM_SET_ARGSREADY (debug);
env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
debug.info->a.args,
SCM_ENV (proc));
x = SCM_CODE (proc);
@ -3145,7 +3145,7 @@ evapply:
if (!SCM_CLOSUREP (proc))
goto evap3;
{
SCM formals = SCM_CAR (SCM_CODE (proc));
SCM formals = SCM_CLOSURE_FORMALS (proc);
if (SCM_NULLP (formals)
|| (SCM_CONSP (formals)
&& (SCM_NULLP (SCM_CDR (formals))
@ -3157,7 +3157,7 @@ evapply:
#ifdef DEVAL
SCM_SET_ARGSREADY (debug);
#endif
env = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)),
env = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc),
scm_cons2 (t.arg1,
arg2,
scm_eval_args (x, env, proc)),
@ -3471,7 +3471,7 @@ tail:
arg1 = (SCM_UNBNDP (arg1) ? SCM_EOL : scm_cons (arg1, args));
#endif
#ifndef SCM_RECKLESS
if (scm_badargsp (SCM_CAR (SCM_CODE (proc)), arg1))
if (scm_badargsp (SCM_CLOSURE_FORMALS (proc), arg1))
goto wrongnumargs;
#endif
@ -3490,7 +3490,7 @@ tail:
SCM_SETCDR (tl, arg1);
}
args = EXTEND_ENV (SCM_CAR (SCM_CODE (proc)), args, SCM_ENV (proc));
args = EXTEND_ENV (SCM_CLOSURE_FORMALS (proc), args, SCM_ENV (proc));
proc = SCM_CDR (SCM_CODE (proc));
again:
arg1 = proc;

6
libguile/goops.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1998, 1999, 2000, 2001 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
@ -1065,7 +1065,7 @@ get_slot_value (SCM class, SCM obj, SCM slotdef)
code = SCM_CAR (access);
if (!SCM_CLOSUREP (code))
return SCM_SUBRF (code) (obj);
env = SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code)),
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
SCM_LIST1 (obj),
SCM_ENV (code));
/* Evaluate the closure body */
@ -1104,7 +1104,7 @@ set_slot_value (SCM class, SCM obj, SCM slotdef, SCM value)
SCM_SUBRF (code) (obj, value);
else
{
env = SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code)),
env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
SCM_LIST2 (obj, value),
SCM_ENV (code));
/* Evaluate the closure body */

50
libguile/macros.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
* it under the terms of the GNU General Public License as published by
@ -45,6 +45,10 @@
#include "libguile/_scm.h"
#include "libguile/alist.h" /* for SCM_EXTEND_ENV (well...) */
#include "libguile/eval.h"
#include "libguile/ports.h"
#include "libguile/print.h"
#include "libguile/root.h"
#include "libguile/smob.h"
@ -53,6 +57,47 @@
scm_bits_t scm_tc16_macro;
static int
macro_print (SCM macro, SCM port, scm_print_state *pstate)
{
SCM code = SCM_MACRO_CODE (macro);
if (!SCM_CLOSUREP (code)
|| SCM_FALSEP (scm_procedure_p (SCM_PRINT_CLOSURE))
|| SCM_FALSEP (scm_printer_apply (SCM_PRINT_CLOSURE,
macro, port, pstate)))
{
if (!SCM_CLOSUREP (code))
scm_puts ("#<primitive-", port);
else
scm_puts ("#<", port);
if (SCM_MACRO_TYPE (macro) == 0)
scm_puts ("syntax", port);
else if (SCM_MACRO_TYPE (macro) == 1)
scm_puts ("macro", port);
if (SCM_MACRO_TYPE (macro) == 2)
scm_puts ("macro!", port);
scm_putc (' ', port);
scm_iprin1 (scm_macro_name (macro), port, pstate);
if (SCM_CLOSUREP (code) && SCM_PRINT_SOURCE_P)
{
SCM formals = SCM_CLOSURE_FORMALS (code);
SCM env = SCM_ENV (code);
SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env);
SCM src = scm_unmemocopy (SCM_CODE (code), xenv);
scm_putc (' ', port);
scm_iprin1 (src, port, pstate);
}
scm_putc ('>', port);
}
return 1;
}
SCM_DEFINE (scm_makacro, "procedure->syntax", 1, 0, 0,
(SCM code),
"Return a @dfn{macro} which, when a symbol defined to this value\n"
@ -139,7 +184,7 @@ SCM_DEFINE (scm_macro_type, "macro-type", 1, 0, 0,
{
if (!SCM_TYP16_PREDICATE (scm_tc16_macro, m))
return SCM_BOOL_F;
switch (SCM_CELL_WORD_0 (m) >> 16)
switch (SCM_MACRO_TYPE (m))
{
case 0: return scm_sym_syntax;
case 1: return scm_sym_macro;
@ -186,6 +231,7 @@ scm_init_macros ()
{
scm_tc16_macro = scm_make_smob_type ("macro", 0);
scm_set_smob_mark (scm_tc16_macro, scm_markcdr);
scm_set_smob_print (scm_tc16_macro, macro_print);
#ifndef SCM_MAGIC_SNARFER
#include "libguile/macros.x"
#endif

110
libguile/print.c
View file

@ -128,8 +128,8 @@ char *scm_isymnames[] =
};
scm_option scm_print_opts[] = {
{ SCM_OPTION_SCM, "closure-hook", SCM_UNPACK(SCM_BOOL_F),
"Hook for printing closures." },
{ SCM_OPTION_SCM, "closure-hook", SCM_UNPACK (SCM_BOOL_F),
"Hook for printing closures (should handle macros as well)." },
{ SCM_OPTION_BOOLEAN, "source", 0,
"Print closures with source." }
};
@ -310,6 +310,7 @@ print_circref (SCM port,scm_print_state *pstate,SCM ref)
SCM_GPROC(s_write, "write", 1, 1, 0, scm_write, g_write);
SCM_GPROC(s_display, "display", 1, 1, 0, scm_display, g_display);
void
scm_iprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
@ -408,83 +409,29 @@ taloop:
circref:
print_circref (port, pstate, exp);
break;
macros:
if (!SCM_CLOSUREP (SCM_CDR (exp)))
goto prinmacro;
case scm_tcs_closures:
/* The user supplied print closure procedure must handle
macro closures as well. */
if (SCM_FALSEP (scm_procedure_p (SCM_PRINT_CLOSURE))
|| SCM_FALSEP (scm_printer_apply (SCM_PRINT_CLOSURE,
exp, port, pstate)))
{
SCM name, code, env;
if (SCM_MACROP (exp))
{
/* Printing a macro. */
prinmacro:
name = scm_macro_name (exp);
if (!SCM_CLOSUREP (SCM_CDR (exp)))
{
code = env = SCM_UNDEFINED;
scm_puts ("#<primitive-", port);
}
else
{
code = SCM_CODE (SCM_CDR (exp));
env = SCM_ENV (SCM_CDR (exp));
scm_puts ("#<", port);
}
if (SCM_CELL_WORD_0 (exp) & (3L << 16))
scm_puts ("macro", port);
else
scm_puts ("syntax", port);
if (SCM_CELL_WORD_0 (exp) & (2L << 16))
scm_putc ('!', port);
}
else
{
/* Printing a closure. */
name = scm_procedure_name (exp);
code = SCM_CODE (exp);
env = SCM_ENV (exp);
scm_puts ("#<procedure", port);
}
if (SCM_SYMBOLP (name))
{
scm_putc (' ', port);
scm_lfwrite (SCM_SYMBOL_CHARS (name), SCM_SYMBOL_LENGTH (name), port);
}
else if (SCM_STRINGP (name))
{
scm_putc (' ', port);
scm_lfwrite (SCM_STRING_CHARS (name), SCM_STRING_LENGTH (name), port);
}
if (!SCM_UNBNDP (code))
{
if (SCM_PRINT_SOURCE_P)
{
code = scm_unmemocopy (code,
SCM_EXTEND_ENV (SCM_CAR (code),
SCM_EOL,
env));
ENTER_NESTED_DATA (pstate, exp, circref);
scm_iprlist (" ", code, '>', port, pstate);
EXIT_NESTED_DATA (pstate);
}
else
{
if (SCM_TYP16 (exp) != scm_tc16_macro)
{
scm_putc (' ', port);
scm_iprin1 (SCM_CAR (code), port, pstate);
}
scm_putc ('>', port);
}
}
else
{
SCM formals = SCM_CLOSURE_FORMALS (exp);
scm_puts ("#<procedure", port);
scm_putc (' ', port);
scm_iprin1 (scm_procedure_name (exp), port, pstate);
scm_putc (' ', port);
if (SCM_PRINT_SOURCE_P)
{
SCM env = SCM_ENV (exp);
SCM xenv = SCM_EXTEND_ENV (formals, SCM_EOL, env);
SCM src = scm_unmemocopy (SCM_CODE (exp), xenv);
ENTER_NESTED_DATA (pstate, exp, circref);
scm_iprin1 (src, port, pstate);
EXIT_NESTED_DATA (pstate);
}
else
scm_iprin1 (formals, port, pstate);
scm_putc ('>', port);
}
}
break;
case scm_tc7_substring:
case scm_tc7_string:
@ -698,19 +645,10 @@ taloop:
register long i;
ENTER_NESTED_DATA (pstate, exp, circref);
i = SCM_SMOBNUM (exp);
if (i < scm_numsmob && scm_smobs[i].print
&& (scm_smobs[i].print) (exp, port, pstate))
{
EXIT_NESTED_DATA (pstate);
break;
}
if (i < scm_numsmob && scm_smobs[i].print)
(scm_smobs[i].print) (exp, port, pstate);
EXIT_NESTED_DATA (pstate);
/* Macros have their print field set to NULL. They are
handled at the same place as closures in order to achieve
non-redundancy. Placing the condition here won't slow
down printing of other smobs. */
if (SCM_TYP16 (exp) == scm_tc16_macro)
goto macros;
break;
}
default:
punk:

8
libguile/procprop.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
* it under the terms of the GNU General Public License as published by
@ -128,15 +128,15 @@ scm_i_procedure_arity (SCM proc)
proc = SCM_PROCEDURE (proc);
goto loop;
case scm_tcs_closures:
proc = SCM_CAR (SCM_CODE (proc));
if (SCM_IMP (proc))
proc = SCM_CLOSURE_FORMALS (proc);
if (SCM_NULLP (proc))
break;
while (SCM_CONSP (proc))
{
++a;
proc = SCM_CDR (proc);
}
if (SCM_NIMP (proc))
if (!SCM_NULLP (proc))
r = 1;
break;
case scm_tcs_cons_gloc:

7
libguile/procs.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995, 1996, 1997, 1999, 2000 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,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
@ -223,7 +223,7 @@ SCM_DEFINE (scm_closure_p, "closure?", 1, 0, 0,
"Return @code{#t} if @var{obj} is a closure.")
#define FUNC_NAME s_scm_closure_p
{
return SCM_BOOL(SCM_CLOSUREP (obj));
return SCM_BOOL (SCM_CLOSUREP (obj));
}
#undef FUNC_NAME
@ -238,8 +238,7 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
switch (SCM_TYP7 (obj))
{
case scm_tcs_closures:
if (SCM_NULLP (SCM_CAR (SCM_CODE (obj))))
return SCM_BOOL_T;
return SCM_BOOL (!SCM_CONSP (SCM_CLOSURE_FORMALS (obj)));
case scm_tc7_subr_0:
case scm_tc7_subr_1o:
case scm_tc7_lsubr:

1
libguile/procs.h
View file

@ -93,6 +93,7 @@ typedef struct
#define SCM_CLOSUREP(x) (SCM_NIMP(x) && (SCM_TYP3 (x) == scm_tc3_closure))
#define SCM_CLOSCAR(x) SCM_PACK (SCM_CELL_WORD_0 (x) - scm_tc3_closure)
#define SCM_CODE(x) SCM_CAR (SCM_CLOSCAR (x))
#define SCM_CLOSURE_FORMALS(x) SCM_CAR (SCM_CODE (x))
#define SCM_PROCPROPS(x) SCM_CDR (SCM_CLOSCAR (x))
#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)) \

4
libguile/sort.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1999, 2000 Free Software Foundation, Inc.
/* Copyright (C) 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
* the Free Software Foundation; either version 2, or (at your option)
@ -374,7 +374,7 @@ lsubrless (SCM less, const void *a, const void *b)
static int
closureless (SCM code, const void *a, const void *b)
{
SCM env = SCM_EXTEND_ENV (SCM_CAR (SCM_CODE (code)),
SCM env = SCM_EXTEND_ENV (SCM_CLOSURE_FORMALS (code),
scm_cons (*(SCM *) a,
scm_cons (*(SCM *) b, SCM_EOL)),
SCM_ENV (code));