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

remove scm_tc7_gsubr

Browse source 
* libguile/tags.h (scm_tc7_gsubr): Return to the pool of unused tc7s, as
  there are no more gsubrs. Yay :)

* libguile/programs.h (SCM_F_PROGRAM_IS_PRIMITIVE):
  (SCM_PROGRAM_IS_PRIMITIVE): New flag and accessor.

* libguile/gsubr.c (create_gsubr):
* libguile/snarf.h (SCM_STATIC_PROGRAM): Give subrs a PRIMITIVE flag.

* libguile/smob.h:
* libguile/smob.c (scm_i_smob_arity): New internal procedure. Uses the
  old GSUBR type macros, local to the file.

* libguile/procprop.c (scm_i_procedure_arity): Call out to
  scm_i_smob_arity, and remove a gsubr case.

* libguile/gc.c (scm_i_tag_name):
* libguile/evalext.c (scm_self_evaluating_p):
* libguile/goops.c (scm_class_of):
* libguile/vm.c (apply_foreign):
* libguile/hash.c (scm_hasher):
* libguile/debug.c (scm_procedure_name):
* libguile/print.c (iprin1): Remove gsubr cases.

* libguile/gsubr.h (SCM_PRIMITIVE_P): Fix to work with the new VM
  program regimen.
  (SCM_GSUBR_TYPE, SCM_GSUBR_MAKTYPE, SCM_GSUBR_MAX, SCM_GSUBR_REQ)
  (SCM_GSUBR_OPT, SCM_GSUBR_REST): Remove these macros, that are no
  longer useful.
* libguile/gsubr.c (scm_i_gsubr_apply, scm_i_gsubr_apply_list)
  (scm_i_gsubr_apply_array): Remove internal gsubr application
  functions.
This commit is contained in:
Andy Wingo 2010-01-06 22:16:57 +01:00
parent 6c2961a011
commit cc7005bc37
16 changed files with 46 additions and 265 deletions
Download patch file Download diff file Expand all files Collapse all files

17
libguile/debug.c
View file

@ -137,20 +137,15 @@ SCM_DEFINE (scm_procedure_name, "procedure-name", 1, 0, 0,
"Return the name of the procedure @var{proc}")
#define FUNC_NAME s_scm_procedure_name
{
SCM name;
SCM_VALIDATE_PROC (1, proc);
while (SCM_STRUCTP (proc) && SCM_STRUCT_APPLICABLE_P (proc))
proc = SCM_STRUCT_PROCEDURE (proc);
switch (SCM_TYP7 (proc)) {
case scm_tc7_gsubr:
return SCM_SUBR_NAME (proc);
default:
{
SCM name = scm_procedure_property (proc, scm_sym_name);
if (scm_is_false (name) && SCM_PROGRAM_P (proc))
name = scm_program_name (proc);
return name;
}
}
name = scm_procedure_property (proc, scm_sym_name);
if (scm_is_false (name) && SCM_PROGRAM_P (proc))
name = scm_program_name (proc);
return name;
}
#undef FUNC_NAME

1
libguile/evalext.c
View file

@ -90,7 +90,6 @@ SCM_DEFINE (scm_self_evaluating_p, "self-evaluating?", 1, 0, 0,
case scm_tc7_smob:
case scm_tc7_program:
case scm_tc7_bytevector:
case scm_tc7_gsubr:
case scm_tcs_struct:
return SCM_BOOL_T;
default:

3
libguile/gc.c
View file

@ -797,9 +797,6 @@ scm_i_tag_name (scm_t_bits tag)
case scm_tc7_variable:
return "variable";
break;
case scm_tc7_gsubr:
return "gsubr";
break;
case scm_tc7_port:
return "port";
break;

9
libguile/goops.c
View file

@ -248,11 +248,6 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
case scm_tc16_fraction:
return scm_class_fraction;
}
case scm_tc7_gsubr:
if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x))
return scm_class_primitive_generic;
else
return scm_class_procedure;
case scm_tc7_program:
if (SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x) && *SCM_SUBR_GENERIC (x))
return scm_class_primitive_generic;
@ -2048,7 +2043,9 @@ scm_sys_compute_applicable_methods (SCM gf, SCM args)
#undef FUNC_NAME
SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods", scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0, 0, scm_sys_compute_applicable_methods));
SCM_VARIABLE_INIT (var_compute_applicable_methods, "compute-applicable-methods",
scm_c_define_gsubr (s_sys_compute_applicable_methods, 2, 0, 0,
scm_sys_compute_applicable_methods));
/******************************************************************************
*

183
libguile/gsubr.c
View file

@ -21,8 +21,6 @@
# include <config.h>
#endif
#include <alloca.h>
#include <stdio.h>
#include <stdarg.h>
@ -809,7 +807,8 @@ create_gsubr (int define, const char *name,
table, SCM_BOOL_F);
/* set flags */
flags = generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;
flags = SCM_F_PROGRAM_IS_PRIMITIVE;
flags |= generic_loc ? SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC : 0;
SCM_SET_CELL_WORD_0 (ret, SCM_CELL_WORD_0 (ret) | flags);
/* define, if needed */
@ -854,184 +853,6 @@ scm_c_define_gsubr_with_generic (const char *name,
return create_gsubr (1, name, req, opt, rst, fcn, gf);
}
/* Apply PROC, a gsubr, to the ARGC arguments in ARGV. ARGC is expected to
match the number of arguments of the underlying C function. */
static SCM
gsubr_apply_raw (SCM proc, unsigned int argc, const SCM *argv)
{
SCM (*fcn) ();
unsigned int type, argc_max;
type = SCM_GSUBR_TYPE (proc);
argc_max = SCM_GSUBR_REQ (type) + SCM_GSUBR_OPT (type)
+ SCM_GSUBR_REST (type);
if (SCM_UNLIKELY (argc != argc_max))
/* We expect the exact argument count. */
scm_wrong_num_args (SCM_SUBR_NAME (proc));
fcn = SCM_SUBRF (proc);
switch (argc)
{
case 0:
return (*fcn) ();
case 1:
return (*fcn) (argv[0]);
case 2:
return (*fcn) (argv[0], argv[1]);
case 3:
return (*fcn) (argv[0], argv[1], argv[2]);
case 4:
return (*fcn) (argv[0], argv[1], argv[2], argv[3]);
case 5:
return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4]);
case 6:
return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
case 7:
return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
argv[6]);
case 8:
return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
argv[6], argv[7]);
case 9:
return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
argv[6], argv[7], argv[8]);
case 10:
return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
argv[6], argv[7], argv[8], argv[9]);
default:
scm_misc_error ((char *) SCM_SUBR_NAME (proc),
"gsubr invocation with more than 10 arguments not implemented",
SCM_EOL);
}
return SCM_BOOL_F; /* Never reached. */
}
/* Apply PROC, a gsubr, to the given arguments. Missing optional arguments
are added, and rest arguments are turned into a list. */
SCM
scm_i_gsubr_apply (SCM proc, SCM arg, ...)
{
unsigned int type, argc, argc_max;
SCM *argv;
va_list arg_list;
type = SCM_GSUBR_TYPE (proc);
argc_max = SCM_GSUBR_REQ (type) + SCM_GSUBR_OPT (type);
argv = alloca ((argc_max + SCM_GSUBR_REST (type)) * sizeof (*argv));
va_start (arg_list, arg);
for (argc = 0;
!SCM_UNBNDP (arg) && argc < argc_max;
argc++, arg = va_arg (arg_list, SCM))
argv[argc] = arg;
if (SCM_UNLIKELY (argc < SCM_GSUBR_REQ (type)))
/* too few args */
scm_wrong_num_args (SCM_SUBR_NAME (proc));
if (SCM_UNLIKELY (!SCM_UNBNDP (arg) && !SCM_GSUBR_REST (type)))
/* too many args */
scm_wrong_num_args (SCM_SUBR_NAME (proc));
/* Fill in optional arguments that were not passed. */
while (argc < argc_max)
argv[argc++] = SCM_UNDEFINED;
if (SCM_GSUBR_REST (type))
{
/* Accumulate rest arguments in a list. */
SCM *rest_loc;
argv[argc_max] = SCM_EOL;
for (rest_loc = &argv[argc_max];
!SCM_UNBNDP (arg);
rest_loc = SCM_CDRLOC (*rest_loc), arg = va_arg (arg_list, SCM))
*rest_loc = scm_cons (arg, SCM_EOL);
argc = argc_max + 1;
}
va_end (arg_list);
return gsubr_apply_raw (proc, argc, argv);
}
/* Apply SELF, a gsubr, to the arguments listed in ARGS. Missing optional
arguments are added, and rest arguments are kept into a list. */
SCM
scm_i_gsubr_apply_list (SCM self, SCM args)
#define FUNC_NAME "scm_i_gsubr_apply"
{
SCM v[SCM_GSUBR_MAX];
unsigned int typ = SCM_GSUBR_TYPE (self);
long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
for (i = 0; i < SCM_GSUBR_REQ (typ); i++) {
if (scm_is_null (args))
scm_wrong_num_args (SCM_SUBR_NAME (self));
v[i] = SCM_CAR(args);
args = SCM_CDR(args);
}
for (; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++) {
if (SCM_NIMP (args)) {
v[i] = SCM_CAR (args);
args = SCM_CDR(args);
}
else
v[i] = SCM_UNDEFINED;
}
if (SCM_GSUBR_REST(typ))
v[i] = args;
else if (!scm_is_null (args))
scm_wrong_num_args (SCM_SUBR_NAME (self));
return gsubr_apply_raw (self, n, v);
}
#undef FUNC_NAME
/* Apply SELF, a gsubr, to the arguments in ARGS. Missing optional
arguments are added, and rest arguments are consed into a list. */
SCM
scm_i_gsubr_apply_array (SCM self, SCM *args, int nargs, int headroom)
#define FUNC_NAME "scm_i_gsubr_apply"
{
unsigned int typ = SCM_GSUBR_TYPE (self);
long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
if (SCM_UNLIKELY (nargs < SCM_GSUBR_REQ (typ)))
scm_wrong_num_args (SCM_SUBR_NAME (self));
if (SCM_UNLIKELY (headroom < n - nargs))
{
/* fallback on apply-list */
SCM arglist = SCM_EOL;
while (nargs--)
arglist = scm_cons (args[nargs], arglist);
return scm_i_gsubr_apply_list (self, arglist);
}
for (i = nargs; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++)
args[i] = SCM_UNDEFINED;
if (SCM_GSUBR_REST(typ))
{
SCM rest = SCM_EOL;
/* fallback on apply-list */
while (nargs-- >= n)
rest = scm_cons (args[nargs], rest);
args[n - 1] = rest;
}
else if (nargs > n)
scm_wrong_num_args (SCM_SUBR_NAME (self));
return gsubr_apply_raw (self, n, args);
}
#undef FUNC_NAME
#ifdef GSUBR_TEST
/* A silly example, taking 2 required args, 1 optional, and

17
libguile/gsubr.h
View file

@ -37,7 +37,7 @@ SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq,
/* Subrs
*/
#define SCM_PRIMITIVE_P(x) (SCM_NIMP (x) && SCM_TYP7 (x) == scm_tc7_gsubr)
#define SCM_PRIMITIVE_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE (x))
#define SCM_PRIMITIVE_GENERIC_P(x) (SCM_PROGRAM_P (x) && SCM_PROGRAM_IS_PRIMITIVE_GENERIC (x))
#define SCM_SUBRF(x) ((SCM (*)()) (SCM_FOREIGN_OBJECT (SCM_SIMPLE_VECTOR_REF (SCM_PROGRAM_OBJTABLE (x), 0), void*)))
@ -49,17 +49,6 @@ SCM_API SCM scm_subr_objcode_trampoline (unsigned int nreq,
/* Return an integer describing the arity of GSUBR, a subr of type
`scm_tc7_gsubr'. The result can be interpreted with `SCM_GSUBR_REQ ()'
and similar. */
#define SCM_GSUBR_TYPE(gsubr) (SCM_CELL_TYPE (gsubr) >> 8)
#define SCM_GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8))
#define SCM_GSUBR_MAX 33
#define SCM_GSUBR_REQ(x) ((long)(x)&0xf)
#define SCM_GSUBR_OPT(x) (((long)(x)&0xf0)>>4)
#define SCM_GSUBR_REST(x) ((long)(x)>>8)
SCM_API SCM scm_c_make_gsubr (const char *name,
int req, int opt, int rst, SCM (*fcn) ());
SCM_API SCM scm_c_make_gsubr_with_generic (const char *name,
@ -71,10 +60,6 @@ SCM_API SCM scm_c_define_gsubr_with_generic (const char *name,
int req, int opt, int rst,
SCM (*fcn) (), SCM *gf);
SCM_INTERNAL SCM scm_i_gsubr_apply (SCM proc, SCM arg, ...);
SCM_INTERNAL SCM scm_i_gsubr_apply_list (SCM proc, SCM args);
SCM_INTERNAL SCM scm_i_gsubr_apply_array (SCM proc, SCM *args, int nargs,
int headroom);
SCM_INTERNAL void scm_init_gsubr (void);
#endif /* SCM_GSUBR_H */

5
libguile/hash.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997, 2000, 2001, 2003, 2004, 2006, 2008, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -169,8 +169,7 @@ scm_hasher(SCM obj, unsigned long n, size_t d)
else return 1;
case scm_tc7_port:
return ((SCM_RDNG & SCM_CELL_WORD_0 (obj)) ? 260 : 261) % n;
/* case scm_tcs_closures: */
case scm_tc7_gsubr:
case scm_tc7_program:
return 262 % n;
}
}

11
libguile/print.c
View file

@ -789,17 +789,6 @@ iprin1 (SCM exp, SCM port, scm_print_state *pstate)
}
EXIT_NESTED_DATA (pstate);
break;
case scm_tc7_gsubr:
{
SCM name = scm_symbol_to_string (SCM_SUBR_NAME (exp));
scm_puts (SCM_SUBR_GENERIC (exp)
? "#<primitive-generic "
: "#<primitive-procedure ",
port);
scm_lfwrite_str (name, port);
scm_putc ('>', port);
break;
}
case scm_tc7_port:
{
register long i = SCM_PTOBNUM (exp);

19
libguile/procprop.c
View file

@ -56,24 +56,7 @@ scm_i_procedure_arity (SCM proc, int *req, int *opt, int *rest)
case scm_tc7_program:
return scm_i_program_arity (proc, req, opt, rest);
case scm_tc7_smob:
if (SCM_SMOB_APPLICABLE_P (proc))
{
int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type;
*req = SCM_GSUBR_REQ (type);
*opt = SCM_GSUBR_OPT (type);
*rest = SCM_GSUBR_REST (type);
return 1;
}
else
return 0;
case scm_tc7_gsubr:
{
unsigned int type = SCM_GSUBR_TYPE (proc);
*req = SCM_GSUBR_REQ (type);
*opt = SCM_GSUBR_OPT (type);
*rest = SCM_GSUBR_REST (type);
return 1;
}
return scm_i_smob_arity (proc, req, opt, rest);
case scm_tcs_struct:
if (!SCM_STRUCT_APPLICABLE_P (proc))
return 0;

10
libguile/procs.c
View file

@ -53,7 +53,6 @@ SCM_DEFINE (scm_procedure_p, "procedure?", 1, 0, 0,
if (!((SCM_OBJ_CLASS_FLAGS (obj) & SCM_CLASSF_PURE_GENERIC)
|| SCM_STRUCT_APPLICABLE_P (obj)))
break;
case scm_tc7_gsubr:
case scm_tc7_program:
return SCM_BOOL_T;
case scm_tc7_smob:
@ -125,14 +124,7 @@ SCM_DEFINE (scm_make_procedure_with_setter, "make-procedure-with-setter", 2, 0,
/* don't use procedure_name, because don't care enough to do a reverse
lookup */
switch (SCM_TYP7 (procedure)) {
case scm_tc7_gsubr:
name = SCM_SUBR_NAME (procedure);
break;
default:
name = scm_procedure_property (procedure, scm_sym_name);
break;
}
name = scm_procedure_property (procedure, scm_sym_name);
if (scm_is_true (name))
scm_set_procedure_property_x (ret, scm_sym_name, name);
return ret;

2
libguile/programs.h
View file

@ -27,6 +27,7 @@
*/
#define SCM_F_PROGRAM_IS_BOOT 0x100
#define SCM_F_PROGRAM_IS_PRIMITIVE 0x100
#define SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC 0x200
#define SCM_PROGRAM_P(x) (!SCM_IMP (x) && SCM_TYP7(x) == scm_tc7_program)
@ -36,6 +37,7 @@
#define SCM_PROGRAM_DATA(x) (SCM_OBJCODE_DATA (SCM_PROGRAM_OBJCODE (x)))
#define SCM_VALIDATE_PROGRAM(p,x) SCM_MAKE_VALIDATE (p, x, PROGRAM_P)
#define SCM_PROGRAM_IS_BOOT(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_BOOT)
#define SCM_PROGRAM_IS_PRIMITIVE(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PRIMITIVE)
#define SCM_PROGRAM_IS_PRIMITIVE_GENERIC(x) (SCM_CELL_WORD_0 (x) & SCM_F_PROGRAM_IS_PRIMITIVE_GENERIC)
SCM_API SCM scm_make_program (SCM objcode, SCM objtable, SCM free_variables);

24
libguile/smob.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -17,6 +17,13 @@
*/
#define SCM_GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8))
#define SCM_GSUBR_MAX 33
#define SCM_GSUBR_REQ(x) ((long)(x)&0xf)
#define SCM_GSUBR_OPT(x) (((long)(x)&0xf0)>>4)
#define SCM_GSUBR_REST(x) ((long)(x)>>8)
#ifdef HAVE_CONFIG_H
# include <config.h>
@ -586,6 +593,21 @@ scm_i_finalize_smob (GC_PTR ptr, GC_PTR data)
free_smob (smob);
}
int
scm_i_smob_arity (SCM proc, int *req, int *opt, int *rest)
{
if (SCM_SMOB_APPLICABLE_P (proc))
{
int type = SCM_SMOB_DESCRIPTOR (proc).gsubr_type;
*req = SCM_GSUBR_REQ (type);
*opt = SCM_GSUBR_OPT (type);
*rest = SCM_GSUBR_REST (type);
return 1;
}
else
return 0;
}
void
scm_smob_prehistory ()

4
libguile/smob.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_SMOB_H
#define SCM_SMOB_H
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2009 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -217,6 +217,8 @@ SCM_API void scm_assert_smob_type (scm_t_bits tag, SCM val);
SCM_API SCM scm_make_smob (scm_t_bits tc);
SCM_INTERNAL int scm_i_smob_arity (SCM proc, int *req, int *opt, int *rest);
SCM_API void scm_smob_prehistory (void);
#endif /* SCM_SMOB_H */

2
libguile/snarf.h
View file

@ -380,7 +380,7 @@ SCM_SNARF_INIT(scm_set_smob_apply((tag), (c_name), (req), (opt), (rest));)
#define SCM_STATIC_PROGRAM(c_name, objcode, objtable, freevars) \
SCM_STATIC_DOUBLE_CELL (c_name, \
scm_tc7_program, \
scm_tc7_program | (SCM_F_PROGRAM_IS_PRIMITIVE<<8), \
(scm_t_bits) objcode, \
(scm_t_bits) objtable, \
(scm_t_bits) freevars)

2
libguile/tags.h
View file

@ -422,7 +422,7 @@ typedef scm_t_uintptr scm_t_bits;
#define scm_tc7_vm_cont 71
#define scm_tc7_unused_17 61
#define scm_tc7_gsubr 63
#define scm_tc7_unused_21 63
#define scm_tc7_unused_19 69
#define scm_tc7_program 79
#define scm_tc7_unused_9 85

2
libguile/vm.c
View file

@ -299,8 +299,6 @@ apply_foreign (SCM proc, SCM *args, int nargs, int headroom)
return SCM_SMOB_APPLY_3 (proc, args[0], args[1], arglist);
}
}
case scm_tc7_gsubr:
return scm_i_gsubr_apply_array (proc, args, nargs, headroom);
default:
badproc:
scm_wrong_type_arg ("apply", SCM_ARG1, proc);