mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-16 16:50:21 +02:00
remove tc7_subr_* and tc7_lsubr_*
* libguile/tags.h: Remove tc7 #defines for subrs, replacing them with
placeholders. These were public, but hopfully unused. I don't see how
to usefully deprecate them.
* libguile/array-map.c (scm_array_map_x): Remove special cases for
certain subr types. This might make things slower for the moment,
otoh, native compilation should moot that question.
* libguile/eval.i.c:
* libguile/eval.c: Remove subr-handling cases. To regain this speed and
more won't have to wait for native compilation, though -- this change
smooths the way for subr dispatch in the VM.
* libguile/gsubr.c (scm_i_gsubr_apply): Fix a bug in which we didn't
detect too-many-arguments. This would only show up when using ceval,
as only ceval called this function.
* test-suite/tests/ramap.test ("array-map!"): Change the expected
exception if passed a procedure of the wrong arity. It now gives
wrong-num-args.
more won't have to wait for native compilation, though -- this change
smooths the way for subr dispatch in the VM.
* libguile/goops.c (scm_class_of): Remove subr cases. No speed
implication.
* libguile/objects.c (scm_valid_object_procedure_p): Remove this public
but undocumented, and useless, function. I do not think this will
affect anyone at all.
(scm_set_object_procedure_x): Replace a call to
scm_valid_object_procedure_p with scm_procedure_p, and actually wrap
with a scm_is_true.
* module/oop/goops.scm (initialize-object-procedure): Don't call
valid-object-procedure?.
This commit is contained in:
Andy Wingo
parent
df9ca8d8b2
commit
df338a2264
11 changed files with 18 additions and 154 deletions
|
|
@ -741,26 +741,6 @@ ramap_rp (SCM ra0, SCM proc, SCM ras)
|
|||
|
||||
|
||||
|
||||
static int
|
||||
ramap_1 (SCM ra0, SCM proc, SCM ras)
|
||||
{
|
||||
SCM ra1 = SCM_CAR (ras);
|
||||
long n = SCM_I_ARRAY_DIMS (ra0)->ubnd - SCM_I_ARRAY_DIMS (ra0)->lbnd + 1;
|
||||
unsigned long i0 = SCM_I_ARRAY_BASE (ra0), i1 = SCM_I_ARRAY_BASE (ra1);
|
||||
long inc0 = SCM_I_ARRAY_DIMS (ra0)->inc, inc1 = SCM_I_ARRAY_DIMS (ra1)->inc;
|
||||
ra0 = SCM_I_ARRAY_V (ra0);
|
||||
ra1 = SCM_I_ARRAY_V (ra1);
|
||||
if (scm_tc7_vector == SCM_TYP7 (ra0) || scm_tc7_wvect == SCM_TYP7 (ra0))
|
||||
for (; n-- > 0; i0 += inc0, i1 += inc1)
|
||||
GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1)));
|
||||
else
|
||||
for (; n-- > 0; i0 += inc0, i1 += inc1)
|
||||
GVSET (ra0, i0, SCM_SUBRF (proc) (GVREF (ra1, i1)));
|
||||
return 1;
|
||||
}
|
||||
|
||||
|
||||
|
||||
static int
|
||||
ramap_2o (SCM ra0, SCM proc, SCM ras)
|
||||
{
|
||||
|
|
@ -836,21 +816,6 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
|
|||
default:
|
||||
gencase:
|
||||
scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
|
||||
return SCM_UNSPECIFIED;
|
||||
case scm_tc7_subr_1:
|
||||
if (! scm_is_pair (lra))
|
||||
SCM_WRONG_NUM_ARGS (); /* need 1 source */
|
||||
scm_ramapc (ramap_1, proc, ra0, lra, FUNC_NAME);
|
||||
return SCM_UNSPECIFIED;
|
||||
case scm_tc7_subr_2:
|
||||
if (! (scm_is_pair (lra) && scm_is_pair (SCM_CDR (lra))))
|
||||
SCM_WRONG_NUM_ARGS (); /* need 2 sources */
|
||||
goto subr_2o;
|
||||
case scm_tc7_subr_2o:
|
||||
if (! scm_is_pair (lra))
|
||||
SCM_WRONG_NUM_ARGS (); /* need 1 source */
|
||||
subr_2o:
|
||||
scm_ramapc (ramap_2o, proc, ra0, lra, FUNC_NAME);
|
||||
return SCM_UNSPECIFIED;
|
||||
case scm_tc7_dsubr:
|
||||
if (! scm_is_pair (lra))
|
||||
|
|
|
|||
|
|
@ -226,17 +226,9 @@ SCM_DEFINE (scm_class_of, "class-of", 1, 0, 0,
|
|||
return scm_class_fraction;
|
||||
}
|
||||
case scm_tc7_asubr:
|
||||
case scm_tc7_subr_0:
|
||||
case scm_tc7_subr_1:
|
||||
case scm_tc7_dsubr:
|
||||
case scm_tc7_cxr:
|
||||
case scm_tc7_subr_3:
|
||||
case scm_tc7_subr_2:
|
||||
case scm_tc7_rpsubr:
|
||||
case scm_tc7_subr_1o:
|
||||
case scm_tc7_subr_2o:
|
||||
case scm_tc7_lsubr_2:
|
||||
case scm_tc7_lsubr:
|
||||
case scm_tc7_gsubr:
|
||||
if (SCM_SUBR_GENERIC (x) && *SCM_SUBR_GENERIC (x))
|
||||
return scm_class_primitive_generic;
|
||||
|
|
|
|||
|
|
@ -205,6 +205,10 @@ scm_i_gsubr_apply (SCM proc, SCM arg, ...)
|
|||
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. */
|
||||
|
|
|
|||
|
|
@ -295,7 +295,7 @@ memoize_env_ref_transformer (SCM env, SCM x)
|
|||
{
|
||||
SCM mac = scm_variable_ref (var);
|
||||
if (SCM_IMP (SCM_MACRO_CODE (mac))
|
||||
|| SCM_TYP7 (SCM_MACRO_CODE (mac)) != scm_tc7_subr_2)
|
||||
|| (SCM_TYP7 (SCM_MACRO_CODE (mac)) != scm_tc7_gsubr))
|
||||
syntax_error ("bad macro", x, SCM_UNDEFINED);
|
||||
else
|
||||
return (t_syntax_transformer)SCM_SUBRF (SCM_MACRO_CODE (mac)); /* global macro */
|
||||
|
|
|
|||
|
|
@ -53,26 +53,12 @@ scm_i_procedure_arity (SCM proc)
|
|||
loop:
|
||||
switch (SCM_TYP7 (proc))
|
||||
{
|
||||
case scm_tc7_subr_1o:
|
||||
o = 1;
|
||||
case scm_tc7_subr_0:
|
||||
break;
|
||||
case scm_tc7_subr_2o:
|
||||
o = 1;
|
||||
case scm_tc7_subr_1:
|
||||
case scm_tc7_dsubr:
|
||||
case scm_tc7_cxr:
|
||||
a += 1;
|
||||
break;
|
||||
case scm_tc7_subr_2:
|
||||
a += 2;
|
||||
break;
|
||||
case scm_tc7_subr_3:
|
||||
a += 3;
|
||||
break;
|
||||
case scm_tc7_asubr:
|
||||
case scm_tc7_rpsubr:
|
||||
case scm_tc7_lsubr:
|
||||
r = 1;
|
||||
break;
|
||||
case scm_tc7_program:
|
||||
|
|
@ -80,10 +66,6 @@ scm_i_procedure_arity (SCM proc)
|
|||
break;
|
||||
else
|
||||
return SCM_BOOL_F;
|
||||
case scm_tc7_lsubr_2:
|
||||
a += 2;
|
||||
r = 1;
|
||||
break;
|
||||
case scm_tc7_smob:
|
||||
if (SCM_SMOB_APPLICABLE_P (proc))
|
||||
{
|
||||
|
|
|
|||
|
|
@ -135,9 +135,6 @@ SCM_DEFINE (scm_thunk_p, "thunk?", 1, 0, 0,
|
|||
{
|
||||
case scm_tcs_closures:
|
||||
return scm_from_bool (SCM_CLOSURE_NUM_REQUIRED_ARGS (obj) == 0);
|
||||
case scm_tc7_subr_0:
|
||||
case scm_tc7_subr_1o:
|
||||
case scm_tc7_lsubr:
|
||||
case scm_tc7_rpsubr:
|
||||
case scm_tc7_asubr:
|
||||
return SCM_BOOL_T;
|
||||
|
|
|
|||
|
|
@ -44,39 +44,7 @@
|
|||
OPT optional arguments, and REST (0 or 1) arguments. This has to be in
|
||||
sync with `create_gsubr ()'. */
|
||||
#define SCM_SUBR_ARITY_TO_TYPE(req, opt, rest) \
|
||||
((rest) == 0 \
|
||||
? ((opt) == 0 \
|
||||
? ((req) == 0 \
|
||||
? scm_tc7_subr_0 \
|
||||
: ((req) == 1 \
|
||||
? scm_tc7_subr_1 \
|
||||
: ((req) == 2 \
|
||||
? scm_tc7_subr_2 \
|
||||
: ((req) == 3 \
|
||||
? scm_tc7_subr_3 \
|
||||
: scm_tc7_gsubr \
|
||||
| (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))))) \
|
||||
: ((opt) == 1 \
|
||||
? ((req) == 0 \
|
||||
? scm_tc7_subr_1o \
|
||||
: ((req) == 1 \
|
||||
? scm_tc7_subr_2o \
|
||||
: scm_tc7_gsubr | \
|
||||
(SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))) \
|
||||
: scm_tc7_gsubr | \
|
||||
(SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))) \
|
||||
: ((rest) == 1 \
|
||||
? ((opt) == 0 \
|
||||
? ((req) == 0 \
|
||||
? scm_tc7_lsubr \
|
||||
: ((req) == 2 \
|
||||
? scm_tc7_lsubr_2 \
|
||||
: scm_tc7_gsubr \
|
||||
| (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))) \
|
||||
: scm_tc7_gsubr \
|
||||
| (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U)) \
|
||||
: scm_tc7_gsubr \
|
||||
| (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U)))
|
||||
(scm_tc7_gsubr | (SCM_GSUBR_MAKTYPE (req, opt, rest) << 8U))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -429,16 +429,16 @@ typedef scm_t_uintptr scm_t_bits;
|
|||
#define scm_tc7_gsubr 63
|
||||
#define scm_tc7_rpsubr 69
|
||||
#define scm_tc7_program 79
|
||||
#define scm_tc7_subr_0 85
|
||||
#define scm_tc7_subr_1 87
|
||||
#define scm_tc7_unused_9 85
|
||||
#define scm_tc7_unused_10 87
|
||||
#define scm_tc7_cxr 93
|
||||
#define scm_tc7_subr_3 95
|
||||
#define scm_tc7_subr_2 101
|
||||
#define scm_tc7_unused_11 95
|
||||
#define scm_tc7_unused_12 101
|
||||
#define scm_tc7_asubr 103
|
||||
#define scm_tc7_subr_1o 109
|
||||
#define scm_tc7_subr_2o 111
|
||||
#define scm_tc7_lsubr_2 117
|
||||
#define scm_tc7_lsubr 119
|
||||
#define scm_tc7_unused_13 109
|
||||
#define scm_tc7_unused_14 111
|
||||
#define scm_tc7_unused_15 117
|
||||
#define scm_tc7_unused_16 119
|
||||
|
||||
/* There are 256 port subtypes. */
|
||||
#define scm_tc7_port 125
|
||||
|
|
@ -676,17 +676,9 @@ enum scm_tc8_tags
|
|||
*/
|
||||
#define scm_tcs_subrs \
|
||||
scm_tc7_asubr:\
|
||||
case scm_tc7_subr_0:\
|
||||
case scm_tc7_subr_1:\
|
||||
case scm_tc7_dsubr:\
|
||||
case scm_tc7_cxr:\
|
||||
case scm_tc7_subr_3:\
|
||||
case scm_tc7_subr_2:\
|
||||
case scm_tc7_rpsubr:\
|
||||
case scm_tc7_subr_1o:\
|
||||
case scm_tc7_subr_2o:\
|
||||
case scm_tc7_lsubr_2:\
|
||||
case scm_tc7_lsubr: \
|
||||
case scm_tc7_gsubr
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -296,21 +296,6 @@ apply_foreign (SCM proc, SCM *args, int nargs, int headroom)
|
|||
arglist = scm_cons (args[nargs], arglist);
|
||||
return scm_closure_apply (proc, arglist);
|
||||
}
|
||||
case scm_tc7_subr_2o:
|
||||
if (nargs > 2 || nargs < 1) scm_wrong_num_args (proc);
|
||||
return SCM_SUBRF (proc) (arg1, arg2);
|
||||
case scm_tc7_subr_2:
|
||||
if (nargs != 2) scm_wrong_num_args (proc);
|
||||
return SCM_SUBRF (proc) (arg1, arg2);
|
||||
case scm_tc7_subr_0:
|
||||
if (nargs != 0) scm_wrong_num_args (proc);
|
||||
return SCM_SUBRF (proc) ();
|
||||
case scm_tc7_subr_1:
|
||||
if (nargs != 1) scm_wrong_num_args (proc);
|
||||
return SCM_SUBRF (proc) (arg1);
|
||||
case scm_tc7_subr_1o:
|
||||
if (nargs > 1) scm_wrong_num_args (proc);
|
||||
return SCM_SUBRF (proc) (arg1);
|
||||
case scm_tc7_dsubr:
|
||||
if (nargs != 1) scm_wrong_num_args (proc);
|
||||
if (SCM_I_INUMP (arg1))
|
||||
|
|
@ -326,24 +311,6 @@ apply_foreign (SCM proc, SCM *args, int nargs, int headroom)
|
|||
case scm_tc7_cxr:
|
||||
if (nargs != 1) scm_wrong_num_args (proc);
|
||||
return scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc));
|
||||
case scm_tc7_subr_3:
|
||||
if (nargs != 3) scm_wrong_num_args (proc);
|
||||
return SCM_SUBRF (proc) (arg1, arg2, arg3);
|
||||
case scm_tc7_lsubr:
|
||||
{
|
||||
SCM arglist = SCM_EOL;
|
||||
while (nargs--)
|
||||
arglist = scm_cons (args[nargs], arglist);
|
||||
return SCM_SUBRF (proc) (arglist);
|
||||
}
|
||||
case scm_tc7_lsubr_2:
|
||||
if (nargs < 2) scm_wrong_num_args (proc);
|
||||
{
|
||||
SCM arglist = SCM_EOL;
|
||||
while (nargs-- > 2)
|
||||
arglist = scm_cons (args[nargs], arglist);
|
||||
return SCM_SUBRF (proc) (arg1, arg2, arglist);
|
||||
}
|
||||
case scm_tc7_asubr:
|
||||
if (nargs < 2)
|
||||
return SCM_SUBRF (proc) (arg1, SCM_UNDEFINED);
|
||||
|
|
|
|||
|
|
@ -1467,11 +1467,8 @@
|
|||
(cond ((not proc))
|
||||
((pair? proc)
|
||||
(apply set-object-procedure! object proc))
|
||||
((valid-object-procedure? proc)
|
||||
(set-object-procedure! object proc))
|
||||
(else
|
||||
(set-object-procedure! object
|
||||
(lambda args (apply proc args)))))))
|
||||
(set-object-procedure! object proc)))))
|
||||
|
||||
(define-method (initialize (applicable-struct <applicable-struct>) initargs)
|
||||
(next-method)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; ramap.test --- test array mapping functions -*- scheme -*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2004, 2005, 2006 Free Software Foundation, Inc.
|
||||
;;;; Copyright (C) 2004, 2005, 2006, 2009 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
|
||||
|
|
@ -148,7 +148,7 @@
|
|||
(make-array #f 5) (make-array #f 5))
|
||||
(equal? a (make-array 'foo 5))))
|
||||
|
||||
(pass-if-exception "subr_1" exception:wrong-type-arg
|
||||
(pass-if-exception "subr_1" exception:wrong-num-args
|
||||
(array-map! (make-array #f 5) length
|
||||
(make-array #f 5) (make-array #f 5)))
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue