1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009 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 License
5 * as published by the Free Software Foundation; either version 3 of
6 * the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful, but
9 * 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
29 #include "libguile/_scm.h"
30 #include "libguile/procprop.h"
31 #include "libguile/root.h"
33 #include "libguile/gsubr.h"
34 #include "libguile/deprecation.h"
36 #include "libguile/private-options.h"
40 * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
44 /* #define GSUBR_TEST */
46 SCM_GLOBAL_SYMBOL (scm_sym_name
, "name");
49 create_gsubr (int define
, const char *name
,
50 unsigned int req
, unsigned int opt
, unsigned int rst
,
55 switch (SCM_GSUBR_MAKTYPE (req
, opt
, rst
))
57 case SCM_GSUBR_MAKTYPE(0, 0, 0):
58 subr
= scm_c_make_subr (name
, scm_tc7_subr_0
, fcn
);
60 case SCM_GSUBR_MAKTYPE(1, 0, 0):
61 subr
= scm_c_make_subr (name
, scm_tc7_subr_1
, fcn
);
63 case SCM_GSUBR_MAKTYPE(0, 1, 0):
64 subr
= scm_c_make_subr (name
, scm_tc7_subr_1o
, fcn
);
66 case SCM_GSUBR_MAKTYPE(1, 1, 0):
67 subr
= scm_c_make_subr (name
, scm_tc7_subr_2o
, fcn
);
69 case SCM_GSUBR_MAKTYPE(2, 0, 0):
70 subr
= scm_c_make_subr (name
, scm_tc7_subr_2
, fcn
);
72 case SCM_GSUBR_MAKTYPE(3, 0, 0):
73 subr
= scm_c_make_subr (name
, scm_tc7_subr_3
, fcn
);
75 case SCM_GSUBR_MAKTYPE(0, 0, 1):
76 subr
= scm_c_make_subr (name
, scm_tc7_lsubr
, fcn
);
78 case SCM_GSUBR_MAKTYPE(2, 0, 1):
79 subr
= scm_c_make_subr (name
, scm_tc7_lsubr_2
, fcn
);
85 type
= SCM_GSUBR_MAKTYPE (req
, opt
, rst
);
86 if (SCM_GSUBR_REQ (type
) != req
87 || SCM_GSUBR_OPT (type
) != opt
88 || SCM_GSUBR_REST (type
) != rst
)
89 scm_out_of_range ("create_gsubr", scm_from_uint (req
+ opt
+ rst
));
91 subr
= scm_c_make_subr (name
, scm_tc7_gsubr
| (type
<< 8U),
97 scm_define (SCM_SUBR_NAME (subr
), subr
);
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_NAME (subr
), 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
);
185 /* Apply PROC, a gsubr, to the ARGC arguments in ARGV. ARGC is expected to
186 match the number of arguments of the underlying C function. */
188 gsubr_apply_raw (SCM proc
, unsigned int argc
, const SCM
*argv
)
191 unsigned int type
, argc_max
;
193 type
= SCM_GSUBR_TYPE (proc
);
194 argc_max
= SCM_GSUBR_REQ (type
) + SCM_GSUBR_OPT (type
)
195 + SCM_GSUBR_REST (type
);
197 if (SCM_UNLIKELY (argc
!= argc_max
))
198 /* We expect the exact argument count. */
199 scm_wrong_num_args (SCM_SUBR_NAME (proc
));
201 fcn
= SCM_SUBRF (proc
);
208 return (*fcn
) (argv
[0]);
210 return (*fcn
) (argv
[0], argv
[1]);
212 return (*fcn
) (argv
[0], argv
[1], argv
[2]);
214 return (*fcn
) (argv
[0], argv
[1], argv
[2], argv
[3]);
216 return (*fcn
) (argv
[0], argv
[1], argv
[2], argv
[3], argv
[4]);
218 return (*fcn
) (argv
[0], argv
[1], argv
[2], argv
[3], argv
[4], argv
[5]);
220 return (*fcn
) (argv
[0], argv
[1], argv
[2], argv
[3], argv
[4], argv
[5],
223 return (*fcn
) (argv
[0], argv
[1], argv
[2], argv
[3], argv
[4], argv
[5],
226 return (*fcn
) (argv
[0], argv
[1], argv
[2], argv
[3], argv
[4], argv
[5],
227 argv
[6], argv
[7], argv
[8]);
229 return (*fcn
) (argv
[0], argv
[1], argv
[2], argv
[3], argv
[4], argv
[5],
230 argv
[6], argv
[7], argv
[8], argv
[9]);
232 scm_misc_error ((char *) SCM_SUBR_NAME (proc
),
233 "gsubr invocation with more than 10 arguments not implemented",
237 return SCM_BOOL_F
; /* Never reached. */
240 /* Apply PROC, a gsubr, to the given arguments. Missing optional arguments
241 are added, and rest arguments are turned into a list. */
243 scm_i_gsubr_apply (SCM proc
, SCM arg
, ...)
245 unsigned int type
, argc
, argc_max
;
249 type
= SCM_GSUBR_TYPE (proc
);
250 argc_max
= SCM_GSUBR_REQ (type
) + SCM_GSUBR_OPT (type
);
251 argv
= alloca ((argc_max
+ SCM_GSUBR_REST (type
)) * sizeof (*argv
));
253 va_start (arg_list
, arg
);
256 !SCM_UNBNDP (arg
) && argc
< argc_max
;
257 argc
++, arg
= va_arg (arg_list
, SCM
))
260 if (SCM_UNLIKELY (argc
< SCM_GSUBR_REQ (type
)))
261 scm_wrong_num_args (SCM_SUBR_NAME (proc
));
263 /* Fill in optional arguments that were not passed. */
264 while (argc
< argc_max
)
265 argv
[argc
++] = SCM_UNDEFINED
;
267 if (SCM_GSUBR_REST (type
))
269 /* Accumulate rest arguments in a list. */
272 argv
[argc_max
] = SCM_EOL
;
274 for (rest_loc
= &argv
[argc_max
];
276 rest_loc
= SCM_CDRLOC (*rest_loc
), arg
= va_arg (arg_list
, SCM
))
277 *rest_loc
= scm_cons (arg
, SCM_EOL
);
284 return gsubr_apply_raw (proc
, argc
, argv
);
287 /* Apply SELF, a gsubr, to the arguments listed in ARGS. Missing optional
288 arguments are added, and rest arguments are kept into a list. */
290 scm_i_gsubr_apply_list (SCM self
, SCM args
)
291 #define FUNC_NAME "scm_i_gsubr_apply"
293 SCM v
[SCM_GSUBR_MAX
];
294 unsigned int typ
= SCM_GSUBR_TYPE (self
);
295 long i
, n
= SCM_GSUBR_REQ (typ
) + SCM_GSUBR_OPT (typ
) + SCM_GSUBR_REST (typ
);
297 for (i
= 0; i
< SCM_GSUBR_REQ (typ
); i
++) {
298 if (scm_is_null (args
))
299 scm_wrong_num_args (SCM_SUBR_NAME (self
));
300 v
[i
] = SCM_CAR(args
);
301 args
= SCM_CDR(args
);
303 for (; i
< SCM_GSUBR_REQ (typ
) + SCM_GSUBR_OPT (typ
); i
++) {
304 if (SCM_NIMP (args
)) {
305 v
[i
] = SCM_CAR (args
);
306 args
= SCM_CDR(args
);
309 v
[i
] = SCM_UNDEFINED
;
311 if (SCM_GSUBR_REST(typ
))
313 else if (!scm_is_null (args
))
314 scm_wrong_num_args (SCM_SUBR_NAME (self
));
316 return gsubr_apply_raw (self
, n
, v
);
322 /* A silly example, taking 2 required args, 1 optional, and
323 a scm_list of rest args
326 gsubr_21l(SCM req1
, SCM req2
, SCM opt
, SCM rst
)
328 scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp
);
329 scm_display(req1
, scm_cur_outp
);
330 scm_puts ("\n req2: ", scm_cur_outp
);
331 scm_display(req2
, scm_cur_outp
);
332 scm_puts ("\n opt: ", scm_cur_outp
);
333 scm_display(opt
, scm_cur_outp
);
334 scm_puts ("\n rest: ", scm_cur_outp
);
335 scm_display(rst
, scm_cur_outp
);
336 scm_newline(scm_cur_outp
);
337 return SCM_UNSPECIFIED
;
346 scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l
); /* example */
349 #include "libguile/gsubr.x"