1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
24 #include "libguile/_scm.h"
25 #include "libguile/procprop.h"
26 #include "libguile/root.h"
28 #include "libguile/gsubr.h"
29 #include "libguile/deprecation.h"
33 * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
37 /* #define GSUBR_TEST */
39 SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
41 SCM scm_f_gsubr_apply;
44 create_gsubr (int define, const char *name,
45 int req, int opt, int rst, SCM (*fcn)())
49 switch (SCM_GSUBR_MAKTYPE (req, opt, rst))
51 case SCM_GSUBR_MAKTYPE(0, 0, 0):
52 subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
54 case SCM_GSUBR_MAKTYPE(1, 0, 0):
55 subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn);
57 case SCM_GSUBR_MAKTYPE(0, 1, 0):
58 subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn);
60 case SCM_GSUBR_MAKTYPE(1, 1, 0):
61 subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn);
63 case SCM_GSUBR_MAKTYPE(2, 0, 0):
64 subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn);
66 case SCM_GSUBR_MAKTYPE(3, 0, 0):
67 subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn);
69 case SCM_GSUBR_MAKTYPE(0, 0, 1):
70 subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn);
72 case SCM_GSUBR_MAKTYPE(2, 0, 1):
73 subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn);
76 scm_define (SCM_SUBR_ENTRY(subr).name, subr);
80 SCM cclo = scm_makcclo (scm_f_gsubr_apply, 3L);
81 SCM subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
82 SCM sym = SCM_SUBR_ENTRY(subr).name;
83 if (SCM_GSUBR_MAX < req + opt + rst)
86 "ERROR in scm_c_make_gsubr: too many args (%d) to %s\n",
87 req + opt + rst, name);
90 SCM_SET_GSUBR_PROC (cclo, subr);
91 SCM_SET_GSUBR_TYPE (cclo,
92 scm_from_int (SCM_GSUBR_MAKTYPE (req, opt, rst)));
93 if (SCM_REC_PROCNAMES_P)
94 scm_set_procedure_property_x (cclo, scm_sym_name, sym);
96 scm_define (sym, cclo);
103 scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
105 return create_gsubr (0, name, req, opt, rst, fcn);
109 scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
111 return create_gsubr (1, name, req, opt, rst, fcn);
115 create_gsubr_with_generic (int define,
125 switch (SCM_GSUBR_MAKTYPE(req, opt, rst))
127 case SCM_GSUBR_MAKTYPE(0, 0, 0):
128 subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_0, fcn, gf);
130 case SCM_GSUBR_MAKTYPE(1, 0, 0):
131 subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1, fcn, gf);
133 case SCM_GSUBR_MAKTYPE(0, 1, 0):
134 subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1o, fcn, gf);
136 case SCM_GSUBR_MAKTYPE(1, 1, 0):
137 subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2o, fcn, gf);
139 case SCM_GSUBR_MAKTYPE(2, 0, 0):
140 subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2, fcn, gf);
142 case SCM_GSUBR_MAKTYPE(3, 0, 0):
143 subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_3, fcn, gf);
145 case SCM_GSUBR_MAKTYPE(0, 0, 1):
146 subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr, fcn, gf);
148 case SCM_GSUBR_MAKTYPE(2, 0, 1):
149 subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr_2, fcn, gf);
152 scm_define (SCM_SUBR_ENTRY(subr).name, subr);
157 scm_misc_error ("scm_c_make_gsubr_with_generic",
158 "can't make primitive-generic with this arity",
160 return SCM_BOOL_F; /* never reached */
164 scm_c_make_gsubr_with_generic (const char *name,
171 return create_gsubr_with_generic (0, name, req, opt, rst, fcn, gf);
175 scm_c_define_gsubr_with_generic (const char *name,
182 return create_gsubr_with_generic (1, name, req, opt, rst, fcn, gf);
187 scm_gsubr_apply (SCM args)
188 #define FUNC_NAME "scm_gsubr_apply"
190 SCM self = SCM_CAR (args);
191 SCM (*fcn)() = SCM_SUBRF (SCM_GSUBR_PROC (self));
192 SCM v[SCM_GSUBR_MAX];
193 int typ = scm_to_int (SCM_GSUBR_TYPE (self));
194 long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
196 if (n > SCM_GSUBR_MAX)
197 scm_misc_error (FUNC_NAME,
198 "Function ~S has illegal arity ~S.",
199 scm_list_2 (self, scm_from_int (n)));
201 args = SCM_CDR (args);
202 for (i = 0; i < SCM_GSUBR_REQ (typ); i++) {
203 if (scm_is_null (args))
204 scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self)));
205 v[i] = SCM_CAR(args);
206 args = SCM_CDR(args);
208 for (; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++) {
209 if (SCM_NIMP (args)) {
210 v[i] = SCM_CAR (args);
211 args = SCM_CDR(args);
214 v[i] = SCM_UNDEFINED;
216 if (SCM_GSUBR_REST(typ))
218 else if (!scm_is_null (args))
219 scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self)));
221 case 2: return (*fcn)(v[0], v[1]);
222 case 3: return (*fcn)(v[0], v[1], v[2]);
223 case 4: return (*fcn)(v[0], v[1], v[2], v[3]);
224 case 5: return (*fcn)(v[0], v[1], v[2], v[3], v[4]);
225 case 6: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5]);
226 case 7: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6]);
227 case 8: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7]);
228 case 9: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8]);
229 case 10: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8], v[9]);
231 return SCM_BOOL_F; /* Never reached. */
237 /* A silly example, taking 2 required args, 1 optional, and
238 a scm_list of rest args
241 gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
243 scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
244 scm_display(req1, scm_cur_outp);
245 scm_puts ("\n req2: ", scm_cur_outp);
246 scm_display(req2, scm_cur_outp);
247 scm_puts ("\n opt: ", scm_cur_outp);
248 scm_display(opt, scm_cur_outp);
249 scm_puts ("\n rest: ", scm_cur_outp);
250 scm_display(rst, scm_cur_outp);
251 scm_newline(scm_cur_outp);
252 return SCM_UNSPECIFIED;
260 scm_f_gsubr_apply = scm_c_make_subr ("gsubr-apply", scm_tc7_lsubr,
263 scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
266 #include "libguile/gsubr.x"