diff options
-rw-r--r-- | libguile/array-map.c | 37 | ||||
-rw-r--r-- | libguile/goops.c | 8 | ||||
-rw-r--r-- | libguile/gsubr.c | 4 | ||||
-rw-r--r-- | libguile/memoize.c | 2 | ||||
-rw-r--r-- | libguile/procprop.c | 18 | ||||
-rw-r--r-- | libguile/procs.c | 3 | ||||
-rw-r--r-- | libguile/procs.h | 34 | ||||
-rw-r--r-- | libguile/tags.h | 24 | ||||
-rw-r--r-- | libguile/vm.c | 33 | ||||
-rw-r--r-- | module/oop/goops.scm | 5 | ||||
-rw-r--r-- | test-suite/tests/ramap.test | 4 |
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))) |