Commit | Line | Data |
---|---|---|
2b829bbb | 1 | /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006 Free Software Foundation, Inc. |
c0fa6561 | 2 | * |
73be1d9e MV |
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. | |
c0fa6561 | 7 | * |
73be1d9e | 8 | * This library is distributed in the hope that it will be useful, |
0f2d19dd | 9 | * but WITHOUT ANY WARRANTY; without even the implied warranty of |
73be1d9e MV |
10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
11 | * Lesser General Public License for more details. | |
c0fa6561 | 12 | * |
73be1d9e MV |
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 | |
92205699 | 15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
73be1d9e | 16 | */ |
1bbd0b84 | 17 | |
0f2d19dd JB |
18 | \f |
19 | ||
20 | #include <stdio.h> | |
a0599745 MD |
21 | #include "libguile/_scm.h" |
22 | #include "libguile/procprop.h" | |
23 | #include "libguile/root.h" | |
0f2d19dd | 24 | |
a0599745 | 25 | #include "libguile/gsubr.h" |
1be6b49c | 26 | #include "libguile/deprecation.h" |
22fc179a HWN |
27 | |
28 | #include "libguile/private-options.h" | |
0f2d19dd JB |
29 | \f |
30 | /* | |
31 | * gsubr.c | |
32 | * Provide `gsubrs' -- subrs taking a prescribed number of required, optional, | |
33 | * and rest arguments. | |
34 | */ | |
35 | ||
952bedad | 36 | /* #define GSUBR_TEST */ |
0f2d19dd | 37 | |
85db4a2c DH |
38 | SCM_GLOBAL_SYMBOL (scm_sym_name, "name"); |
39 | ||
dc0938d8 | 40 | SCM scm_f_gsubr_apply; |
1cc91f1b | 41 | |
9d78586f | 42 | static SCM |
c0fa6561 | 43 | create_gsubr (int define, const char *name, |
9d78586f | 44 | int req, int opt, int rst, SCM (*fcn)()) |
0f2d19dd | 45 | { |
9d78586f MV |
46 | SCM subr; |
47 | ||
48 | switch (SCM_GSUBR_MAKTYPE (req, opt, rst)) | |
0f2d19dd | 49 | { |
9d78586f MV |
50 | case SCM_GSUBR_MAKTYPE(0, 0, 0): |
51 | subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn); | |
52 | goto create_subr; | |
53 | case SCM_GSUBR_MAKTYPE(1, 0, 0): | |
54 | subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn); | |
55 | goto create_subr; | |
56 | case SCM_GSUBR_MAKTYPE(0, 1, 0): | |
57 | subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn); | |
58 | goto create_subr; | |
59 | case SCM_GSUBR_MAKTYPE(1, 1, 0): | |
60 | subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn); | |
61 | goto create_subr; | |
62 | case SCM_GSUBR_MAKTYPE(2, 0, 0): | |
63 | subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn); | |
64 | goto create_subr; | |
65 | case SCM_GSUBR_MAKTYPE(3, 0, 0): | |
66 | subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn); | |
67 | goto create_subr; | |
68 | case SCM_GSUBR_MAKTYPE(0, 0, 1): | |
69 | subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn); | |
70 | goto create_subr; | |
71 | case SCM_GSUBR_MAKTYPE(2, 0, 1): | |
72 | subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn); | |
73 | create_subr: | |
74 | if (define) | |
75 | scm_define (SCM_SUBR_ENTRY(subr).name, subr); | |
76 | return subr; | |
77 | default: | |
78 | { | |
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) | |
83 | { | |
c0fa6561 TTN |
84 | fprintf (stderr, |
85 | "ERROR in scm_c_make_gsubr: too many args (%d) to %s\n", | |
86 | req + opt + rst, name); | |
9d78586f MV |
87 | exit (1); |
88 | } | |
89 | SCM_SET_GSUBR_PROC (cclo, subr); | |
90 | SCM_SET_GSUBR_TYPE (cclo, | |
e11e83f3 | 91 | scm_from_int (SCM_GSUBR_MAKTYPE (req, opt, rst))); |
9d78586f MV |
92 | if (SCM_REC_PROCNAMES_P) |
93 | scm_set_procedure_property_x (cclo, scm_sym_name, sym); | |
9d78586f MV |
94 | if (define) |
95 | scm_define (sym, cclo); | |
0f2d19dd | 96 | return cclo; |
9d78586f | 97 | } |
0f2d19dd | 98 | } |
0f2d19dd JB |
99 | } |
100 | ||
9de33deb | 101 | SCM |
9d78586f | 102 | scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)()) |
9de33deb | 103 | { |
9d78586f MV |
104 | return create_gsubr (0, name, req, opt, rst, fcn); |
105 | } | |
106 | ||
107 | SCM | |
108 | scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)()) | |
109 | { | |
110 | return create_gsubr (1, name, req, opt, rst, fcn); | |
111 | } | |
112 | ||
113 | static SCM | |
114 | create_gsubr_with_generic (int define, | |
115 | const char *name, | |
116 | int req, | |
117 | int opt, | |
118 | int rst, | |
119 | SCM (*fcn)(), | |
120 | SCM *gf) | |
121 | { | |
122 | SCM subr; | |
123 | ||
124 | switch (SCM_GSUBR_MAKTYPE(req, opt, rst)) | |
125 | { | |
126 | case SCM_GSUBR_MAKTYPE(0, 0, 0): | |
127 | subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_0, fcn, gf); | |
128 | goto create_subr; | |
129 | case SCM_GSUBR_MAKTYPE(1, 0, 0): | |
130 | subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1, fcn, gf); | |
131 | goto create_subr; | |
132 | case SCM_GSUBR_MAKTYPE(0, 1, 0): | |
133 | subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1o, fcn, gf); | |
134 | goto create_subr; | |
135 | case SCM_GSUBR_MAKTYPE(1, 1, 0): | |
136 | subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2o, fcn, gf); | |
137 | goto create_subr; | |
138 | case SCM_GSUBR_MAKTYPE(2, 0, 0): | |
139 | subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2, fcn, gf); | |
140 | goto create_subr; | |
141 | case SCM_GSUBR_MAKTYPE(3, 0, 0): | |
142 | subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_3, fcn, gf); | |
143 | goto create_subr; | |
144 | case SCM_GSUBR_MAKTYPE(0, 0, 1): | |
145 | subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr, fcn, gf); | |
146 | goto create_subr; | |
147 | case SCM_GSUBR_MAKTYPE(2, 0, 1): | |
148 | subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr_2, fcn, gf); | |
149 | create_subr: | |
150 | if (define) | |
151 | scm_define (SCM_SUBR_ENTRY(subr).name, subr); | |
152 | return subr; | |
153 | default: | |
154 | ; | |
155 | } | |
156 | scm_misc_error ("scm_c_make_gsubr_with_generic", | |
9de33deb MD |
157 | "can't make primitive-generic with this arity", |
158 | SCM_EOL); | |
4260a7fc | 159 | return SCM_BOOL_F; /* never reached */ |
9de33deb MD |
160 | } |
161 | ||
9d78586f MV |
162 | SCM |
163 | scm_c_make_gsubr_with_generic (const char *name, | |
164 | int req, | |
165 | int opt, | |
166 | int rst, | |
167 | SCM (*fcn)(), | |
168 | SCM *gf) | |
169 | { | |
170 | return create_gsubr_with_generic (0, name, req, opt, rst, fcn, gf); | |
171 | } | |
172 | ||
173 | SCM | |
174 | scm_c_define_gsubr_with_generic (const char *name, | |
175 | int req, | |
176 | int opt, | |
177 | int rst, | |
178 | SCM (*fcn)(), | |
179 | SCM *gf) | |
180 | { | |
181 | return create_gsubr_with_generic (1, name, req, opt, rst, fcn, gf); | |
182 | } | |
183 | ||
0f2d19dd | 184 | |
6fa73e72 GB |
185 | SCM |
186 | scm_gsubr_apply (SCM args) | |
a4bb4e6d | 187 | #define FUNC_NAME "scm_gsubr_apply" |
0f2d19dd | 188 | { |
1be6b49c ML |
189 | SCM self = SCM_CAR (args); |
190 | SCM (*fcn)() = SCM_SUBRF (SCM_GSUBR_PROC (self)); | |
a4bb4e6d | 191 | SCM v[SCM_GSUBR_MAX]; |
e11e83f3 | 192 | int typ = scm_to_int (SCM_GSUBR_TYPE (self)); |
c014a02e | 193 | long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ); |
adc02cce | 194 | #if 0 |
a4bb4e6d | 195 | if (n > SCM_GSUBR_MAX) |
c0fa6561 TTN |
196 | scm_misc_error (FUNC_NAME, |
197 | "Function ~S has illegal arity ~S.", | |
e11e83f3 | 198 | scm_list_2 (self, scm_from_int (n))); |
adc02cce | 199 | #endif |
1be6b49c ML |
200 | args = SCM_CDR (args); |
201 | for (i = 0; i < SCM_GSUBR_REQ (typ); i++) { | |
d2e53ed6 | 202 | if (scm_is_null (args)) |
a4bb4e6d | 203 | scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self))); |
0f2d19dd JB |
204 | v[i] = SCM_CAR(args); |
205 | args = SCM_CDR(args); | |
206 | } | |
1be6b49c ML |
207 | for (; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++) { |
208 | if (SCM_NIMP (args)) { | |
209 | v[i] = SCM_CAR (args); | |
0f2d19dd JB |
210 | args = SCM_CDR(args); |
211 | } | |
212 | else | |
213 | v[i] = SCM_UNDEFINED; | |
214 | } | |
dc0938d8 | 215 | if (SCM_GSUBR_REST(typ)) |
0f2d19dd | 216 | v[i] = args; |
d2e53ed6 | 217 | else if (!scm_is_null (args)) |
a4bb4e6d | 218 | scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self))); |
0f2d19dd | 219 | switch (n) { |
0f2d19dd JB |
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]); | |
229 | } | |
4260a7fc | 230 | return SCM_BOOL_F; /* Never reached. */ |
0f2d19dd | 231 | } |
a4bb4e6d | 232 | #undef FUNC_NAME |
0f2d19dd JB |
233 | |
234 | ||
235 | #ifdef GSUBR_TEST | |
236 | /* A silly example, taking 2 required args, 1 optional, and | |
c0fa6561 | 237 | a scm_list of rest args |
0f2d19dd JB |
238 | */ |
239 | SCM | |
1bbd0b84 | 240 | gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst) |
0f2d19dd | 241 | { |
b7f3516f | 242 | scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp); |
0f2d19dd | 243 | scm_display(req1, scm_cur_outp); |
b7f3516f | 244 | scm_puts ("\n req2: ", scm_cur_outp); |
0f2d19dd | 245 | scm_display(req2, scm_cur_outp); |
b7f3516f | 246 | scm_puts ("\n opt: ", scm_cur_outp); |
0f2d19dd | 247 | scm_display(opt, scm_cur_outp); |
b7f3516f | 248 | scm_puts ("\n rest: ", scm_cur_outp); |
0f2d19dd JB |
249 | scm_display(rst, scm_cur_outp); |
250 | scm_newline(scm_cur_outp); | |
251 | return SCM_UNSPECIFIED; | |
252 | } | |
253 | #endif | |
254 | ||
255 | ||
0f2d19dd JB |
256 | void |
257 | scm_init_gsubr() | |
0f2d19dd | 258 | { |
9d78586f MV |
259 | scm_f_gsubr_apply = scm_c_make_subr ("gsubr-apply", scm_tc7_lsubr, |
260 | scm_gsubr_apply); | |
0f2d19dd | 261 | #ifdef GSUBR_TEST |
9d78586f | 262 | scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */ |
0f2d19dd | 263 | #endif |
85db4a2c | 264 | |
85db4a2c | 265 | #include "libguile/gsubr.x" |
0f2d19dd | 266 | } |
89e00824 ML |
267 | |
268 | /* | |
269 | Local Variables: | |
270 | c-file-style: "gnu" | |
271 | End: | |
272 | */ |