1 /*
2 * proc.c - Procedures
3 *
4 * Copyright (c) 2000-2020 Shiro Kawai <shiro@acm.org>
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
34 #define LIBGAUCHE_BODY
35 #include "gauche.h"
36 #include "gauche/class.h"
37 #include "gauche/code.h"
38 #include "gauche/priv/builtin-syms.h"
39
40 /*=================================================================
41 * Classes
42 */
43
44 static void proc_print(ScmObj obj, ScmPort *port, ScmWriteContext *);
45
46 SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_ProcedureClass, proc_print);
47
proc_print(ScmObj obj,ScmPort * port,ScmWriteContext * ctx SCM_UNUSED)48 static void proc_print(ScmObj obj, ScmPort *port,
49 ScmWriteContext *ctx SCM_UNUSED)
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, " %S", info);
56 }
57 SCM_PUTC('>', port);
58 } else {
59 Scm_Printf(port, "#<closure %S>", info);
60 }
61 }
62
63 /*=================================================================
64 * Closure
65 */
66
Scm_MakeClosure(ScmObj code,ScmEnvFrame * env)67 ScmObj Scm_MakeClosure(ScmObj code, ScmEnvFrame *env)
68 {
69 ScmClosure *c = SCM_NEW(ScmClosure);
70
71 SCM_ASSERT(SCM_COMPILED_CODE(code));
72 /* CODE->signatureInfo can be #f or (<signature> . <other-info>) */
73 ScmObj sig = SCM_COMPILED_CODE(code)->signatureInfo;
74 ScmObj info;
75 if (!SCM_PAIRP(sig)) {
76 /* No info available. */
77 info = Scm_Cons(Scm_CompiledCodeFullName(SCM_COMPILED_CODE(code)),
78 SCM_FALSE);
79 } else {
80 /* We can just use signature info. */
81 info = SCM_CAR(sig);
82 }
83 int req = SCM_COMPILED_CODE_REQUIRED_ARGS(code);
84 int opt = SCM_COMPILED_CODE_OPTIONAL_ARGS(code);
85
86 SCM_SET_CLASS(c, SCM_CLASS_PROCEDURE);
87 SCM_PROCEDURE_INIT(c, req, opt, SCM_PROC_CLOSURE, info);
88 c->code = code;
89 c->env = env;
90 SCM_PROCEDURE(c)->inliner = SCM_COMPILED_CODE(code)->intermediateForm;
91
92 return SCM_OBJ(c);
93 }
94
95 /*=================================================================
96 * Subr
97 */
98
Scm_MakeSubr(ScmSubrProc * func,void * data,int required,int optional,ScmObj info)99 ScmObj Scm_MakeSubr(ScmSubrProc *func,
100 void *data,
101 int required, int optional,
102 ScmObj info)
103 {
104 ScmSubr *s = SCM_NEW(ScmSubr);
105 SCM_SET_CLASS(s, SCM_CLASS_PROCEDURE);
106 SCM_PROCEDURE_INIT(s, required, optional, SCM_PROC_SUBR, info);
107 s->func = func;
108 s->data = data;
109 return SCM_OBJ(s);
110 }
111
112 /*
113 * A dummy function which does nothing. Convenient to pass to other
114 * functions which requires a thunk.
115 */
116 static ScmObj theNullProc = SCM_NIL;
117
null_proc(ScmObj * args SCM_UNUSED,int nargs SCM_UNUSED,void * data SCM_UNUSED)118 static ScmObj null_proc(ScmObj *args SCM_UNUSED,
119 int nargs SCM_UNUSED,
120 void *data SCM_UNUSED)
121 {
122 return SCM_UNDEFINED;
123 }
124
Scm_NullProc(void)125 ScmObj Scm_NullProc(void)
126 {
127 if (SCM_NULLP(theNullProc)) {
128 theNullProc = Scm_MakeSubr(null_proc, NULL, 0, 1,
129 SCM_MAKE_STR("nullproc"));
130 }
131 return SCM_OBJ(theNullProc);
132 }
133
134 /*=================================================================
135 * Copying
136 */
137
138 /* Procedure is inherently an immutable entity, so copying doesn't
139 make much sense. However, sometimes we do need to mutate procedure
140 instances to add various bookkeeping infos during construction,
141 and it comes handy to do "copy, then modify" workflow. */
Scm_CopyProcedure(ScmProcedure * proc)142 ScmObj Scm_CopyProcedure(ScmProcedure *proc)
143 {
144 ScmObj n = SCM_UNDEFINED;
145
146 switch (proc->type) {
147 case SCM_PROC_SUBR:
148 n = Scm_MakeSubr(SCM_SUBR_FUNC(proc),
149 SCM_SUBR_DATA(proc),
150 SCM_PROCEDURE_REQUIRED(proc),
151 SCM_PROCEDURE_OPTIONAL(proc),
152 SCM_PROCEDURE_INFO(proc));
153 SCM_PROCEDURE_INLINER(n) = SCM_PROCEDURE_INLINER(proc);
154 SCM_PROCEDURE_SETTER(n) = SCM_PROCEDURE_SETTER(proc);
155 SCM_PROCEDURE_SETTER_LOCKED(n) = SCM_PROCEDURE_SETTER_LOCKED(proc);
156 SCM_PROCEDURE_CURRYING(n) = SCM_PROCEDURE_CURRYING(proc);
157 SCM_SUBR_FLAGS(n) = SCM_SUBR_FLAGS(proc);
158 break;
159 case SCM_PROC_CLOSURE:
160 n = Scm_MakeClosure(SCM_CLOSURE_CODE(proc),
161 SCM_CLOSURE_ENV(proc));
162 SCM_PROCEDURE_INLINER(n) = SCM_PROCEDURE_INLINER(proc);
163 SCM_PROCEDURE_SETTER(n) = SCM_PROCEDURE_SETTER(proc);
164 SCM_PROCEDURE_SETTER_LOCKED(n) = SCM_PROCEDURE_SETTER_LOCKED(proc);
165 SCM_PROCEDURE_CURRYING(n) = SCM_PROCEDURE_CURRYING(proc);
166 break;
167 case SCM_PROC_GENERIC:
168 case SCM_PROC_METHOD:
169 case SCM_PROC_NEXT_METHOD:
170 /* CLOS is inherently mutable and relies on object identity;
171 copying won't make much sense. */
172 Scm_Error("procedure-copy can only copy subr or closure: %S",
173 SCM_OBJ(proc));
174 }
175 return n;
176 }
177
178 /*=================================================================
179 * Currying
180 */
181
182 /* NB: This code doesn't work yet if the original procedure takes
183 variable length arguments. We disable this feature for now. */
184
185 #if 0
186
187 /* When a procedure is marked autocurrying and it is given with args less
188 * than reqargs, Scm_CurryProcedure is called. It saves the given args
189 * into the curried_packet and creates a subr of curried procedure.
190 *
191 * The argument GIVEN points the beginning of argument array. It actually
192 * points into the VM stack, so we should copy the information before
193 * calling anything that might change the VM state.
194 * The # of given argument is indicated by NGIVEN.
195 *
196 * Note that some of the given arguments are already folded into a list
197 * (in case we are called via APPLY).
198 *
199 * when FOLDLEN < 0 when FOLDLEN >= 0
200 * N = NGIVEN-1 N = NGIVEN-1
201 * K = NGIVEN-1-FOLDLEN
202 *
203 * | argN | | ----> (argK argK+1 ... argN)
204 * : : : :
205 * | arg1 | | arg1 |
206 * given >| arg0 | given >| arg0 |
207 *
208 * We assume at least one arg should be given in order to curry, and
209 * ngiven should always be smaller than the # of required args (otherwise
210 * we don't need to curry at all!). Thus 0 < NGIVEN < REQUIRED.
211 */
212 typedef struct curried_packet_rec {
213 ScmObj proc;
214 int ngiven;
215 ScmObj argv[4]; /* keep first 4 args unfolded */
216 ScmObj more; /* the rest of args */
217 } curried_packet;
218
219 static ScmObj kick_curried(ScmObj *args, int nargs, void *data)
220 {
221 curried_packet *p = (curried_packet*)data;
222 ScmObj proc = p->proc;
223 ScmObj *av = p->argv;
224 SCM_ASSERT(p->ngiven + nargs >= 2);
225
226 /* TODO: if p->proc takes variable length arguments, we shouldn't use
227 Scm_VMApply* family below, since the last word of args already
228 contains folded arguments, and Scm_VMApply causes to fold the
229 arguments again.
230 */
231
232 switch (p->ngiven + nargs) {
233 case 2:
234 return Scm_VMApply2(proc, p->argv[0], args[0]);
235 case 3:
236 switch (nargs) {
237 case 1: return Scm_VMApply3(proc, av[0], av[1], args[0]);
238 case 2: return Scm_VMApply3(proc, av[0], args[0], args[1]);
239 default: break; /*NOTREACHED*/
240 }
241 case 4:
242 switch (nargs) {
243 case 1: return Scm_VMApply4(proc, av[0], av[1], av[2], args[0]);
244 case 2: return Scm_VMApply4(proc, av[0], av[1], args[0], args[1]);
245 case 3: return Scm_VMApply4(proc, av[0], args[0], args[1], args[2]);
246 default: break; /*NOTREACHED*/
247 }
248 default:
249 {
250 ScmObj h = SCM_NIL, t = SCM_NIL;
251 for (int i = 0; i < p->ngiven; i++) SCM_APPEND1(h, t, av[i]);
252 if (SCM_PAIRP(p->more)) SCM_APPEND(h, t, Scm_CopyList(p->more));
253 for (int i = 0; i < nargs; i++) SCM_APPEND1(h, t, args[i]);
254 return Scm_VMApply(proc, h);
255 }
256 }
257 return SCM_UNDEFINED; /* dummy */
258 }
259
260 ScmObj Scm_CurryProcedure(ScmObj proc, ScmObj *given, int ngiven, int foldlen)
261 {
262 int required = SCM_PROCEDURE_REQUIRED(proc);
263 int n = ngiven - foldlen;
264 ScmObj h = SCM_NIL, t = SCM_NIL;
265 ScmObj restarg = (foldlen > 0)? given[n] : SCM_NIL;
266
267 SCM_ASSERT(SCM_PROCEDUREP(proc));
268 SCM_ASSERT(ngiven < required && ngiven > 0);
269 curried_packet *packet = SCM_NEW(curried_packet);
270 packet->proc = proc;
271 packet->ngiven = ngiven;
272
273 /* pack the given args into the packet */
274 switch (n) {
275 default: packet->argv[3] = given[3]; /*FALLTHROUGH*/
276 case 3: packet->argv[2] = given[2]; /*FALLTHROUGH*/
277 case 2: packet->argv[1] = given[1]; /*FALLTHROUGH*/
278 case 1: packet->argv[0] = given[0]; /*FALLTHROUGH*/
279 }
280 if (foldlen > 0) {
281 for (int i=n; i<4 && SCM_PAIRP(restarg); i++, restarg = SCM_CDR(restarg)) {
282 packet->argv[i] = SCM_CAR(restarg);
283 }
284 }
285 for (int i=4; i<n; i++) {
286 SCM_APPEND1(h, t, given[i]);
287 }
288 if (SCM_PAIRP(restarg)) {
289 SCM_APPEND(h, t, Scm_CopyList(restarg));
290 }
291 packet->more = h;
292
293 ScmObj subr = Scm_MakeSubr(kick_curried, (void*)packet,
294 required - ngiven, SCM_PROCEDURE_OPTIONAL(proc),
295 Scm_Cons(SCM_SYM_CURRIED, SCM_PROCEDURE_INFO(proc)));
296 SCM_PROCEDURE_CURRYING(subr) = TRUE;
297 return subr;
298 }
299
300 #endif /* 0 : disabling currying feature for now */
301
302 /*=================================================================
303 * Mapper family
304 * OBSOLETED - map and for-each is defiend in Scheme now (liblist.scm)
305 * These are just kept for the backward compatibility. Will be gone
306 * in 1.0.
307 */
308
Scm_ForEach1(ScmObj proc,ScmObj args)309 ScmObj Scm_ForEach1(ScmObj proc, ScmObj args)
310 {
311 return Scm_ForEach(proc, args, SCM_NIL);
312 }
313
Scm_Map1(ScmObj proc,ScmObj args)314 ScmObj Scm_Map1(ScmObj proc, ScmObj args)
315 {
316 return Scm_Map(proc, args, SCM_NIL);
317 }
318
Scm_ForEach(ScmObj proc,ScmObj arg1,ScmObj args)319 ScmObj Scm_ForEach(ScmObj proc, ScmObj arg1, ScmObj args)
320 {
321 static ScmObj stub = SCM_UNDEFINED;
322 SCM_BIND_PROC(stub, "for-each", Scm_SchemeModule());
323 return Scm_VMApply(stub, Scm_Cons(proc, Scm_Cons(arg1, args)));
324 }
325
Scm_Map(ScmObj proc,ScmObj arg1,ScmObj args)326 ScmObj Scm_Map(ScmObj proc, ScmObj arg1, ScmObj args)
327 {
328 static ScmObj stub = SCM_UNDEFINED;
329 SCM_BIND_PROC(stub, "map", Scm_SchemeModule());
330 return Scm_VMApply(stub, Scm_Cons(proc, Scm_Cons(arg1, args)));
331 }
332
333 /*=================================================================
334 * Generic setter
335 */
336
Scm_SetterSet(ScmProcedure * proc,ScmProcedure * setter,int lock)337 ScmObj Scm_SetterSet(ScmProcedure *proc, ScmProcedure *setter, int lock)
338 {
339 if (SCM_PROCEDURE_SETTER_LOCKED(proc)) {
340 Scm_Error("can't change the locked setter of procedure %S", proc);
341 }
342 proc->setter = SCM_OBJ(setter);
343 proc->locked = lock;
344 return SCM_OBJ(proc);
345 }
346
object_setter(ScmObj * args,int nargs,void * data)347 static ScmObj object_setter(ScmObj *args, int nargs, void *data)
348 {
349 SCM_ASSERT(nargs == 1);
350 return Scm_VMApply(SCM_OBJ(&Scm_GenericObjectSetter),
351 Scm_Cons(SCM_OBJ(data), args[0]));
352 }
353
354 static SCM_DEFINE_STRING_CONST(object_setter__NAME, "object-setter", 13, 13);
355
Scm_Setter(ScmObj proc)356 ScmObj Scm_Setter(ScmObj proc)
357 {
358 if (SCM_PROCEDUREP(proc)) {
359 /* NB: This used to signal an error if no setter procedure is associated
360 to proc; now it returns #f in such case */
361 return SCM_PROCEDURE(proc)->setter;
362 } else {
363 /* fallback to (setter object-apply) */
364 return Scm_MakeSubr(object_setter, (void*)proc, 0, 1,
365 SCM_OBJ(&object_setter__NAME));
366 }
367 }
368
Scm_HasSetter(ScmObj proc)369 int Scm_HasSetter(ScmObj proc)
370 {
371 if (SCM_PROCEDUREP(proc)) {
372 return !SCM_FALSEP(SCM_PROCEDURE(proc)->setter);
373 } else {
374 /* setter of object-apply is used. */
375 return TRUE;
376 }
377 }
378
379 /*=================================================================
380 * Scheme-level accessors
381 */
proc_required(ScmProcedure * p)382 static ScmObj proc_required(ScmProcedure *p)
383 {
384 return SCM_MAKE_INT(p->required);
385 }
386
proc_optional(ScmProcedure * p)387 static ScmObj proc_optional(ScmProcedure *p)
388 {
389 return SCM_MAKE_BOOL(p->optional); /* for backward compatibility */
390 }
391
proc_optcount(ScmProcedure * p)392 static ScmObj proc_optcount(ScmProcedure *p)
393 {
394 return SCM_MAKE_INT(p->optional);
395 }
396
proc_locked(ScmProcedure * p)397 static ScmObj proc_locked(ScmProcedure *p)
398 {
399 return SCM_MAKE_BOOL(SCM_PROCEDURE_SETTER_LOCKED(p));
400 }
401
proc_currying(ScmProcedure * p)402 static ScmObj proc_currying(ScmProcedure *p)
403 {
404 return SCM_MAKE_BOOL(p->currying);
405 }
406
proc_constant(ScmProcedure * p)407 static ScmObj proc_constant(ScmProcedure *p)
408 {
409 return SCM_MAKE_BOOL(p->constant);
410 }
411
proc_info(ScmProcedure * p)412 static ScmObj proc_info(ScmProcedure *p)
413 {
414 return p->info;
415 }
416
proc_setter(ScmProcedure * p)417 static ScmObj proc_setter(ScmProcedure *p)
418 {
419 return p->setter;
420 }
421
422 static ScmClassStaticSlotSpec proc_slots[] = {
423 SCM_CLASS_SLOT_SPEC("required", proc_required, NULL),
424 SCM_CLASS_SLOT_SPEC("optional", proc_optional, NULL),
425 SCM_CLASS_SLOT_SPEC("optcount", proc_optcount, NULL),
426 SCM_CLASS_SLOT_SPEC("locked", proc_locked, NULL),
427 SCM_CLASS_SLOT_SPEC("currying", proc_currying, NULL),
428 SCM_CLASS_SLOT_SPEC("constant", proc_constant, NULL),
429 SCM_CLASS_SLOT_SPEC("info", proc_info, NULL),
430 SCM_CLASS_SLOT_SPEC("setter", proc_setter, NULL),
431 SCM_CLASS_SLOT_SPEC_END()
432 };
433
434
435 /*=================================================================
436 * Initialization
437 */
Scm__InitProc(void)438 void Scm__InitProc(void)
439 {
440 Scm_InitStaticClass(&Scm_ProcedureClass, "<procedure>",
441 Scm_GaucheModule(), proc_slots, 0);
442 Scm_ProcedureClass.flags |= SCM_CLASS_APPLICABLE;
443 }
444