356d771e81fb3309ce3b385288cb4bb57b819615
1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006 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
21 #include "libguile/_scm.h"
22 #include "libguile/procprop.h"
23 #include "libguile/root.h"
25 #include "libguile/gsubr.h"
26 #include "libguile/deprecation.h"
28 #include "libguile/private-options.h"
32 * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
36 /* #define GSUBR_TEST */
38 SCM_GLOBAL_SYMBOL (scm_sym_name
, "name");
40 SCM scm_f_gsubr_apply
;
43 create_gsubr (int define
, const char *name
,
44 int req
, int opt
, int rst
, SCM (*fcn
)())
48 switch (SCM_GSUBR_MAKTYPE (req
, opt
, rst
))
50 case SCM_GSUBR_MAKTYPE(0, 0, 0):
51 subr
= scm_c_make_subr (name
, scm_tc7_subr_0
, fcn
);
53 case SCM_GSUBR_MAKTYPE(1, 0, 0):
54 subr
= scm_c_make_subr (name
, scm_tc7_subr_1
, fcn
);
56 case SCM_GSUBR_MAKTYPE(0, 1, 0):
57 subr
= scm_c_make_subr (name
, scm_tc7_subr_1o
, fcn
);
59 case SCM_GSUBR_MAKTYPE(1, 1, 0):
60 subr
= scm_c_make_subr (name
, scm_tc7_subr_2o
, fcn
);
62 case SCM_GSUBR_MAKTYPE(2, 0, 0):
63 subr
= scm_c_make_subr (name
, scm_tc7_subr_2
, fcn
);
65 case SCM_GSUBR_MAKTYPE(3, 0, 0):
66 subr
= scm_c_make_subr (name
, scm_tc7_subr_3
, fcn
);
68 case SCM_GSUBR_MAKTYPE(0, 0, 1):
69 subr
= scm_c_make_subr (name
, scm_tc7_lsubr
, fcn
);
71 case SCM_GSUBR_MAKTYPE(2, 0, 1):
72 subr
= scm_c_make_subr (name
, scm_tc7_lsubr_2
, fcn
);
75 scm_define (SCM_SUBR_ENTRY(subr
).name
, subr
);
79 SCM cclo
= scm_makcclo (scm_f_gsubr_apply
, 3L);
80 SCM subr
= scm_c_make_subr (name
, scm_tc7_subr_0
, fcn
);
81 SCM sym
= SCM_SUBR_ENTRY(subr
).name
;
82 if (SCM_GSUBR_MAX
< req
+ opt
+ rst
)
85 "ERROR in scm_c_make_gsubr: too many args (%d) to %s\n",
86 req
+ opt
+ rst
, name
);
89 SCM_SET_GSUBR_PROC (cclo
, subr
);
90 SCM_SET_GSUBR_TYPE (cclo
,
91 scm_from_int (SCM_GSUBR_MAKTYPE (req
, opt
, rst
)));
92 if (SCM_REC_PROCNAMES_P
)
93 scm_set_procedure_property_x (cclo
, scm_sym_name
, sym
);
95 scm_define (sym
, cclo
);
102 scm_c_make_gsubr (const char *name
, int req
, int opt
, int rst
, SCM (*fcn
)())
104 return create_gsubr (0, name
, req
, opt
, rst
, fcn
);
108 scm_c_define_gsubr (const char *name
, int req
, int opt
, int rst
, SCM (*fcn
)())
110 return create_gsubr (1, name
, req
, opt
, rst
, fcn
);
114 create_gsubr_with_generic (int define
,
124 switch (SCM_GSUBR_MAKTYPE(req
, opt
, rst
))
126 case SCM_GSUBR_MAKTYPE(0, 0, 0):
127 subr
= scm_c_make_subr_with_generic (name
, scm_tc7_subr_0
, fcn
, gf
);
129 case SCM_GSUBR_MAKTYPE(1, 0, 0):
130 subr
= scm_c_make_subr_with_generic (name
, scm_tc7_subr_1
, fcn
, gf
);
132 case SCM_GSUBR_MAKTYPE(0, 1, 0):
133 subr
= scm_c_make_subr_with_generic (name
, scm_tc7_subr_1o
, fcn
, gf
);
135 case SCM_GSUBR_MAKTYPE(1, 1, 0):
136 subr
= scm_c_make_subr_with_generic (name
, scm_tc7_subr_2o
, fcn
, gf
);
138 case SCM_GSUBR_MAKTYPE(2, 0, 0):
139 subr
= scm_c_make_subr_with_generic (name
, scm_tc7_subr_2
, fcn
, gf
);
141 case SCM_GSUBR_MAKTYPE(3, 0, 0):
142 subr
= scm_c_make_subr_with_generic (name
, scm_tc7_subr_3
, fcn
, gf
);
144 case SCM_GSUBR_MAKTYPE(0, 0, 1):
145 subr
= scm_c_make_subr_with_generic (name
, scm_tc7_lsubr
, fcn
, gf
);
147 case SCM_GSUBR_MAKTYPE(2, 0, 1):
148 subr
= scm_c_make_subr_with_generic (name
, scm_tc7_lsubr_2
, fcn
, gf
);
151 scm_define (SCM_SUBR_ENTRY(subr
).name
, subr
);
156 scm_misc_error ("scm_c_make_gsubr_with_generic",
157 "can't make primitive-generic with this arity",
159 return SCM_BOOL_F
; /* never reached */
163 scm_c_make_gsubr_with_generic (const char *name
,
170 return create_gsubr_with_generic (0, name
, req
, opt
, rst
, fcn
, gf
);
174 scm_c_define_gsubr_with_generic (const char *name
,
181 return create_gsubr_with_generic (1, name
, req
, opt
, rst
, fcn
, gf
);
186 scm_gsubr_apply (SCM args
)
187 #define FUNC_NAME "scm_gsubr_apply"
189 SCM self
= SCM_CAR (args
);
190 SCM (*fcn
)() = SCM_SUBRF (SCM_GSUBR_PROC (self
));
191 SCM v
[SCM_GSUBR_MAX
];
192 int typ
= scm_to_int (SCM_GSUBR_TYPE (self
));
193 long i
, n
= SCM_GSUBR_REQ (typ
) + SCM_GSUBR_OPT (typ
) + SCM_GSUBR_REST (typ
);
195 if (n
> SCM_GSUBR_MAX
)
196 scm_misc_error (FUNC_NAME
,
197 "Function ~S has illegal arity ~S.",
198 scm_list_2 (self
, scm_from_int (n
)));
200 args
= SCM_CDR (args
);
201 for (i
= 0; i
< SCM_GSUBR_REQ (typ
); i
++) {
202 if (scm_is_null (args
))
203 scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self
)));
204 v
[i
] = SCM_CAR(args
);
205 args
= SCM_CDR(args
);
207 for (; i
< SCM_GSUBR_REQ (typ
) + SCM_GSUBR_OPT (typ
); i
++) {
208 if (SCM_NIMP (args
)) {
209 v
[i
] = SCM_CAR (args
);
210 args
= SCM_CDR(args
);
213 v
[i
] = SCM_UNDEFINED
;
215 if (SCM_GSUBR_REST(typ
))
217 else if (!scm_is_null (args
))
218 scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self
)));
220 case 2: return (*fcn
)(v
[0], v
[1]);
221 case 3: return (*fcn
)(v
[0], v
[1], v
[2]);
222 case 4: return (*fcn
)(v
[0], v
[1], v
[2], v
[3]);
223 case 5: return (*fcn
)(v
[0], v
[1], v
[2], v
[3], v
[4]);
224 case 6: return (*fcn
)(v
[0], v
[1], v
[2], v
[3], v
[4], v
[5]);
225 case 7: return (*fcn
)(v
[0], v
[1], v
[2], v
[3], v
[4], v
[5], v
[6]);
226 case 8: return (*fcn
)(v
[0], v
[1], v
[2], v
[3], v
[4], v
[5], v
[6], v
[7]);
227 case 9: return (*fcn
)(v
[0], v
[1], v
[2], v
[3], v
[4], v
[5], v
[6], v
[7], v
[8]);
228 case 10: return (*fcn
)(v
[0], v
[1], v
[2], v
[3], v
[4], v
[5], v
[6], v
[7], v
[8], v
[9]);
230 return SCM_BOOL_F
; /* Never reached. */
236 /* A silly example, taking 2 required args, 1 optional, and
237 a scm_list of rest args
240 gsubr_21l(SCM req1
, SCM req2
, SCM opt
, SCM rst
)
242 scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp
);
243 scm_display(req1
, scm_cur_outp
);
244 scm_puts ("\n req2: ", scm_cur_outp
);
245 scm_display(req2
, scm_cur_outp
);
246 scm_puts ("\n opt: ", scm_cur_outp
);
247 scm_display(opt
, scm_cur_outp
);
248 scm_puts ("\n rest: ", scm_cur_outp
);
249 scm_display(rst
, scm_cur_outp
);
250 scm_newline(scm_cur_outp
);
251 return SCM_UNSPECIFIED
;
259 scm_f_gsubr_apply
= scm_c_make_subr ("gsubr-apply", scm_tc7_lsubr
,
262 scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l
); /* example */
265 #include "libguile/gsubr.x"