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