summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/array-map.c37
-rw-r--r--libguile/goops.c8
-rw-r--r--libguile/gsubr.c4
-rw-r--r--libguile/memoize.c2
-rw-r--r--libguile/procprop.c18
-rw-r--r--libguile/procs.c3
-rw-r--r--libguile/procs.h34
-rw-r--r--libguile/tags.h24
-rw-r--r--libguile/vm.c33
-rw-r--r--module/oop/goops.scm5
-rw-r--r--test-suite/tests/ramap.test4
11 files changed, 18 insertions, 154 deletions
diff --git a/libguile/array-map.c b/libguile/array-map.c
index eaac54a1f..89e6ec987 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -742,26 +742,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)
{
SCM ra1 = SCM_CAR (ras);
@@ -835,22 +815,7 @@ 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);
+ scm_ramapc (ramap, proc, ra0, lra, FUNC_NAME);
return SCM_UNSPECIFIED;
case scm_tc7_dsubr:
if (! scm_is_pair (lra))
diff --git a/libguile/goops.c b/libguile/goops.c
index dfa7117d0..a9210149e 100644
--- a/libguile/goops.c
+++ b/libguile/goops.c
@@ -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;
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 06e8830c8..24ba6700c 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -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. */
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 0574e1197..7dd5cd86f 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -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 */
diff --git a/libguile/procprop.c b/libguile/procprop.c
index cce800f2b..052e5a0c7 100644
--- a/libguile/procprop.c
+++ b/libguile/procprop.c
@@ -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))
{
diff --git a/libguile/procs.c b/libguile/procs.c
index 898a3710b..6fda200d0 100644
--- a/libguile/procs.c
+++ b/libguile/procs.c
@@ -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;
diff --git a/libguile/procs.h b/libguile/procs.h
index dc764edf8..e993c8f09 100644
--- a/libguile/procs.h
+++ b/libguile/procs.h
@@ -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))
diff --git a/libguile/tags.h b/libguile/tags.h
index 92d0bb800..217aa1516 100644
--- a/libguile/tags.h
+++ b/libguile/tags.h
@@ -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
diff --git a/libguile/vm.c b/libguile/vm.c
index 51426a5a4..a05494f5b 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -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);
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index bf13e3830..0195036b0 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -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)
diff --git a/test-suite/tests/ramap.test b/test-suite/tests/ramap.test
index 948a77870..7131904bf 100644
--- a/test-suite/tests/ramap.test
+++ b/test-suite/tests/ramap.test
@@ -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)))