/* [<][>][^][v][top][bottom][index][help] */
DEFINITIONS
This source file includes following definitions.
- proc_print
- Scm_MakeClosure
- Scm_MakeSubr
- null_proc
- Scm_NullProc
- foreach1_cc
- Scm_ForEach1
- map1_cc
- Scm_Map1
- mapper_collect_args
- foreachN_cc
- Scm_ForEach
- mapN_cc
- Scm_Map
- Scm_SetterSet
- object_setter
- Scm_Setter
- Scm_HasSetter
- proc_required
- proc_optional
- proc_locked
- proc_info
- proc_setter
- Scm__InitProc
1 /*
2 * proc.c - Procedures
3 *
4 * Copyright (c) 2000-2005 Shiro Kawai, All rights reserved.
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * 1. Redistributions of source code must retain the above copyright
11 * notice, this list of conditions and the following disclaimer.
12 *
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 *
17 * 3. Neither the name of the authors nor the names of its contributors
18 * may be used to endorse or promote products derived from this
19 * software without specific prior written permission.
20 *
21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 *
33 * $Id: proc.c,v 1.41 2005/05/24 23:28:38 shirok Exp $
34 */
35
36 #define LIBGAUCHE_BODY
37 #include "gauche.h"
38 #include "gauche/class.h"
39 #include "gauche/code.h"
40
41 /*=================================================================
42 * Classes
43 */
44
45 static void proc_print(ScmObj obj, ScmPort *port, ScmWriteContext *);
46
47 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_ProcedureClass, proc_print);
48
49 static void proc_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
50 {
51 ScmObj info = SCM_PROCEDURE_INFO(obj);
52 if (SCM_PROCEDURE_TYPE(obj) == SCM_PROC_SUBR) {
53 SCM_PUTZ("#<subr", -1, port);
54 if (!SCM_FALSEP(info)) {
55 Scm_Printf(port, " %A", info);
56 }
57 SCM_PUTC('>', port);
58 } else {
59 Scm_Printf(port, "#<closure %S>", info);
60 }
61 }
62
63 /*=================================================================
64 * Closure
65 */
66
67 ScmObj Scm_MakeClosure(ScmObj code, ScmEnvFrame *env)
68 {
69 ScmClosure *c = SCM_NEW(ScmClosure);
70 int req, opt;
71 ScmObj info;
72
73 SCM_ASSERT(SCM_COMPILED_CODE(code));
74 info = Scm_CompiledCodeFullName(SCM_COMPILED_CODE(code));
75 req = SCM_COMPILED_CODE_REQUIRED_ARGS(code);
76 opt = SCM_COMPILED_CODE_OPTIONAL_ARGS(code);
77
78 SCM_SET_CLASS(c, SCM_CLASS_PROCEDURE);
79 SCM_PROCEDURE_INIT(c, req, opt, SCM_PROC_CLOSURE, info);
80 c->code = code;
81 c->env = env;
82 SCM_PROCEDURE(c)->inliner = SCM_COMPILED_CODE(code)->intermediateForm;
83
84 return SCM_OBJ(c);
85 }
86
87 /*=================================================================
88 * Subr
89 */
90
91 ScmObj Scm_MakeSubr(ScmObj (*func)(ScmObj*, int, void*),
92 void *data,
93 int required, int optional,
94 ScmObj info)
95 {
96 ScmSubr *s = SCM_NEW(ScmSubr);
97 SCM_SET_CLASS(s, SCM_CLASS_PROCEDURE);
98 SCM_PROCEDURE_INIT(s, required, optional, SCM_PROC_SUBR, info);
99 s->func = func;
100 s->data = data;
101 return SCM_OBJ(s);
102 }
103
104 /*
105 * A dummy function which does nothing. Convenient to pass to other
106 * fhunctions which requires a thunk.
107 */
108 static ScmObj theNullProc = SCM_NIL;
109
110 static ScmObj null_proc(ScmObj *args, int nargs, void *data)
111 {
112 return SCM_UNDEFINED;
113 }
114
115 ScmObj Scm_NullProc(void)
116 {
117 if (SCM_NULLP(theNullProc)) {
118 theNullProc = Scm_MakeSubr(null_proc, NULL, 0, 1,
119 SCM_MAKE_STR("nullproc"));
120 }
121 return SCM_OBJ(theNullProc);
122 }
123
124 /*=================================================================
125 * Mapper family
126 */
127
128 /*
129 * One argument version of for-each, map and fold.
130 */
131 static ScmObj foreach1_cc(ScmObj result, void **data)
132 {
133 ScmObj args = SCM_OBJ(data[1]);
134 if (SCM_PAIRP(args)) {
135 ScmObj proc = SCM_OBJ(data[0]);
136 void *data[2];
137 data[0] = proc;
138 data[1] = SCM_CDR(args);
139 Scm_VMPushCC(foreach1_cc, data, 2);
140 SCM_RETURN(Scm_VMApply1(proc, SCM_CAR(args)));
141 } else {
142 SCM_RETURN(SCM_UNDEFINED);
143 }
144 }
145
146 ScmObj Scm_ForEach1(ScmObj proc, ScmObj args)
147 {
148 if (!SCM_NULLP(args)) {
149 void *data[2];
150 data[0] = proc;
151 data[1] = SCM_CDR(args);
152 Scm_VMPushCC(foreach1_cc, data, 2);
153 SCM_RETURN(Scm_VMApply1(SCM_OBJ(proc), SCM_CAR(args)));
154 } else {
155 SCM_RETURN(SCM_UNDEFINED);
156 }
157 }
158
159 static ScmObj map1_cc(ScmObj result, void **data)
160 {
161 ScmObj args = SCM_OBJ(data[1]);
162 ScmObj head = SCM_OBJ(data[2]);
163 ScmObj tail = SCM_OBJ(data[3]);
164
165 SCM_APPEND1(head, tail, result);
166
167 if (SCM_PAIRP(args)) {
168 ScmObj proc = SCM_OBJ(data[0]);
169 void *data[4];
170 data[0] = proc;
171 data[1] = SCM_CDR(args);
172 data[2] = head;
173 data[3] = tail;
174 Scm_VMPushCC(map1_cc, data, 4);
175 SCM_RETURN(Scm_VMApply1(proc, SCM_CAR(args)));
176 } else {
177 SCM_RETURN(head);
178 }
179 }
180
181 ScmObj Scm_Map1(ScmObj proc, ScmObj args)
182 {
183 if (!SCM_NULLP(args)) {
184 void *data[4];
185 data[0] = proc;
186 data[1] = SCM_CDR(args);
187 data[2] = SCM_NIL;
188 data[3] = SCM_NIL;
189 Scm_VMPushCC(map1_cc, data, 4);
190 SCM_RETURN(Scm_VMApply1(SCM_OBJ(proc), SCM_CAR(args)));
191 } else {
192 SCM_RETURN(SCM_NIL);
193 }
194 }
195
196 /*
197 * General case
198 */
199
200 /* gather CAR's and CDR's of given arglist. returns 1 if at least
201 one of the arglist reaches the end. */
202 static int mapper_collect_args(ScmObj argslist,
203 ScmObj *thisargs, ScmObj *moreargs)
204 {
205 ScmObj arg = SCM_NIL, argtail = SCM_NIL;
206 ScmObj more = SCM_NIL, moretail = SCM_NIL;
207 ScmObj cp;
208
209 SCM_FOR_EACH(cp, argslist) {
210 ScmObj argsN = SCM_CAR(cp);
211 if (!SCM_PAIRP(argsN)) {
212 /* ran out the argument. */
213 return 1;
214 }
215 SCM_APPEND1(arg, argtail, SCM_CAR(argsN));
216 SCM_APPEND1(more, moretail, SCM_CDR(argsN));
217 }
218 *thisargs = arg;
219 *moreargs = more;
220 return 0;
221 }
222
223
224 static ScmObj foreachN_cc(ScmObj result, void **data)
225 {
226 ScmObj proc;
227 ScmObj args_list = SCM_OBJ(data[1]);
228 ScmObj args, moreargs;
229 void *d[2];
230
231 if (mapper_collect_args(args_list, &args, &moreargs)) {
232 SCM_RETURN(SCM_UNDEFINED);
233 }
234
235 proc = SCM_OBJ(data[0]);
236 d[0] = proc;
237 d[1] = moreargs;
238 Scm_VMPushCC(foreachN_cc, d, 2);
239 SCM_RETURN(Scm_VMApply(proc, args));
240 }
241
242 ScmObj Scm_ForEach(ScmObj proc, ScmObj arg1, ScmObj args)
243 {
244 if (SCM_NULLP(args)) {
245 SCM_RETURN(Scm_ForEach1(proc, arg1)); /* shortcut */
246 } else {
247 void *data[2];
248 data[0] = proc;
249 data[1] = Scm_Cons(arg1, args);
250 SCM_RETURN(foreachN_cc(SCM_UNDEFINED, data));
251 }
252 }
253
254 static ScmObj mapN_cc(ScmObj result, void **data)
255 {
256 ScmObj proc;
257 ScmObj args_list = SCM_OBJ(data[1]);
258 ScmObj head = SCM_OBJ(data[2]);
259 ScmObj tail = SCM_OBJ(data[3]);
260 ScmObj args, moreargs;
261 void *d[4];
262
263 SCM_APPEND1(head, tail, result);
264
265 if (mapper_collect_args(args_list, &args, &moreargs)) {
266 SCM_RETURN(head);
267 }
268
269 proc = SCM_OBJ(data[0]);
270 d[0] = proc;
271 d[1] = moreargs;
272 d[2] = head;
273 d[3] = tail;
274 Scm_VMPushCC(mapN_cc, d, 4);
275 SCM_RETURN(Scm_VMApply(proc, args));
276 }
277
278 ScmObj Scm_Map(ScmObj proc, ScmObj arg1, ScmObj args)
279 {
280 if (SCM_NULLP(args)) {
281 SCM_RETURN(Scm_Map1(proc, arg1)); /* shortcut */
282 } else {
283 ScmObj thisargs, moreargs;
284 void *data[4];
285
286 if (mapper_collect_args(Scm_Cons(arg1, args),
287 &thisargs, &moreargs)) {
288 /* one of the arglist is already nil. */
289 SCM_RETURN(SCM_NIL);
290 }
291
292 data[0] = proc;
293 data[1] = moreargs;
294 data[2] = SCM_NIL;
295 data[3] = SCM_NIL;
296 Scm_VMPushCC(mapN_cc, data, 4);
297 SCM_RETURN(Scm_VMApply(SCM_OBJ(proc), thisargs));
298 }
299 }
300
301 /*=================================================================
302 * Generic setter
303 */
304
305 ScmObj Scm_SetterSet(ScmProcedure *proc, ScmProcedure *setter, int lock)
306 {
307 if (proc->locked) {
308 Scm_Error("can't change the locked setter of procedure %S", proc);
309 }
310 proc->setter = SCM_OBJ(setter);
311 proc->locked = lock;
312 return SCM_OBJ(proc);
313 }
314
315 static ScmObj object_setter(ScmObj *args, int nargs, void *data)
316 {
317 SCM_ASSERT(nargs == 1);
318 return Scm_VMApply(SCM_OBJ(&Scm_GenericObjectSetter),
319 Scm_Cons(SCM_OBJ(data), args[0]));
320 }
321
322 static SCM_DEFINE_STRING_CONST(object_setter__NAME, "object-setter", 13, 13);
323
324 ScmObj Scm_Setter(ScmObj proc)
325 {
326 if (SCM_PROCEDUREP(proc)) {
327 /* NB: This used to signal an error if no setter procedure is associated
328 to proc; now it returns #f in such case */
329 return SCM_PROCEDURE(proc)->setter;
330 } else {
331 /* fallback to (setter object-apply) */
332 return Scm_MakeSubr(object_setter, (void*)proc, 0, 1,
333 SCM_OBJ(&object_setter__NAME));
334 }
335 }
336
337 int Scm_HasSetter(ScmObj proc)
338 {
339 if (SCM_PROCEDUREP(proc)) {
340 return !SCM_FALSEP(SCM_PROCEDURE(proc)->setter);
341 } else {
342 /* setter of object-apply is used. */
343 return TRUE;
344 }
345 }
346
347 /*=================================================================
348 * Scheme-level accessors
349 */
350 static ScmObj proc_required(ScmProcedure *p)
351 {
352 return SCM_MAKE_INT(p->required);
353 }
354
355 static ScmObj proc_optional(ScmProcedure *p)
356 {
357 return SCM_MAKE_BOOL(p->optional);
358 }
359
360 static ScmObj proc_locked(ScmProcedure *p)
361 {
362 return SCM_MAKE_BOOL(p->locked);
363 }
364
365 static ScmObj proc_info(ScmProcedure *p)
366 {
367 return p->info;
368 }
369
370 static ScmObj proc_setter(ScmProcedure *p)
371 {
372 return p->setter;
373 }
374
375 static ScmClassStaticSlotSpec proc_slots[] = {
376 SCM_CLASS_SLOT_SPEC("required", proc_required, NULL),
377 SCM_CLASS_SLOT_SPEC("optional", proc_optional, NULL),
378 SCM_CLASS_SLOT_SPEC("locked", proc_locked, NULL),
379 SCM_CLASS_SLOT_SPEC("info", proc_info, NULL),
380 SCM_CLASS_SLOT_SPEC("setter", proc_setter, NULL),
381 {NULL},
382 };
383
384
385 /*=================================================================
386 * Initialization
387 */
388 void Scm__InitProc(void)
389 {
390 Scm_InitStaticClass(&Scm_ProcedureClass, "<procedure>",
391 Scm_GaucheModule(), proc_slots, 0);
392 Scm_ProcedureClass.flags |= SCM_CLASS_APPLICABLE;
393 }