1 /*===========================================================================
2 * Filename : qquote.c
3 * About : R5RS quasiquote
4 *
5 * Copyright (C) 2005 Kazuki Ohta <mover AT hct.zaq.ne.jp>
6 * Copyright (C) 2005-2006 Jun Inoue <jun.lambda AT gmail.com>
7 * Copyright (C) 2005-2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp>
8 * Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
9 *
10 * All rights reserved.
11 *
12 * Redistribution and use in source and binary forms, with or without
13 * modification, are permitted provided that the following conditions
14 * are met:
15 *
16 * 1. Redistributions of source code must retain the above copyright
17 * notice, this list of conditions and the following disclaimer.
18 * 2. Redistributions in binary form must reproduce the above copyright
19 * notice, this list of conditions and the following disclaimer in the
20 * documentation and/or other materials provided with the distribution.
21 * 3. Neither the name of authors nor the names of its contributors
22 * may be used to endorse or promote products derived from this software
23 * without specific prior written permission.
24 *
25 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
26 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
27 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
28 * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
29 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
30 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
31 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
32 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
33 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
34 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
35 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36 ===========================================================================*/
37
38 #include <config.h>
39
40 #include "sigscheme.h"
41 #include "sigschemeinternal.h"
42
43 /*=======================================
44 File Local Macro Definitions
45 =======================================*/
46 #define ERRMSG_BAD_SPLICE_LIST "bad splice list"
47
48 /*=======================================
49 File Local Type Definitions
50 =======================================*/
51
52 /*=======================================
53 Variable Definitions
54 =======================================*/
55
56 /*=======================================
57 File Local Function Declarations
58 =======================================*/
59
60 /*===========================================================================
61 Utilities: Sequential Datum Translators
62 ===========================================================================*/
63 /* Since the translator is only used for quasiquotation, and will not be used
64 * for other purpose including macro
65 * (http://d.hatena.ne.jp/jun0/20060403#1144019957), all codes have been made
66 * qquote.c local. separate this again as generic utility if needed.
67 * -- YamaKen 2006-06-24 */
68
69 /*
70 * These utilities are for copying a sequence with partial
71 * modifications. They're used for handling quasiquotation and macro
72 * expansion. Translator works as a copy-on-write iterator for a list
73 * or vector.
74 *
75 * First, initialize the proper type of translator with either
76 * TRL_INIT() or TRV_INIT(), supplying the datum to be duplicated.
77 * Then, traverse over the `copy' by successively and alternately
78 * calling TR_GET_ELM() and TR_NEXT(). If an item returned by
79 * TR_GET_ELM() should be replaced, then call TR_EXECUTE() with the
80 * message TR_MSG_REPLACE or TR_MSG_SPLICE (see their definition for
81 * details). When TR_ENDP() returns true, stop and obtain the
82 * duplicate with TR_EXTRACT(). TR_CALL() is a low-level construct
83 * that doesn't demultiplex the return value. Usually you would want
84 * TR_EXECUTE() instead. The only exception is if you expect a
85 * boolean to be returned (those that test true for TR_BOOL_MSG_P()).
86 *
87 * The last cdr of an improper list is *not* considered a part of the
88 * list and will be treated just like the () of a proper list. In
89 * order to retrieve that last cdr, call TRL_GET_SUBLS() *after*
90 * TR_ENDP() returns true. Replacement of that portion must be done
91 * with TRL_SET_SUBLS().
92 *
93 * No operation except TRL_GET_SUBLS(), TRL_SET_SUBLS(), TR_EXTRACT(),
94 * and TR_ENDP() can be done on a translator for which TR_ENDP()
95 * returns true.
96 *
97 * Everything prefixed with TRL_ is specific to list translators.
98 * Likewise, TRV_ shows specificity to vector translators. TR_
99 * denotes a polymorphism.
100 */
101
102 /**
103 * Message IDs. We have to bring this upfront because ISO C forbids
104 * forward reference to enumerations.
105 */
106 enum _tr_msg {
107 /** Don't do anything. */
108 TR_MSG_NOP,
109
110 /** Put OBJ in place of the current element. */
111 TR_MSG_REPLACE,
112
113 /** Splice OBJ into the current cell. */
114 TR_MSG_SPLICE,
115
116 /**
117 * Get the object at the current position. If the input is an
118 * improper list, the terminator is not returned in reply to this
119 * message. Use TRL_GET_SUBLS() to retrieve the terminator in
120 * that case.
121 */
122 TR_MSG_GET_ELM,
123
124 /** Advance the iterator on the input. */
125 TR_MSG_NEXT,
126
127 /** Extract the product. */
128 TR_MSG_EXTRACT,
129
130 /** True iff the end of the sequence has been reached. */
131 TR_MSG_ENDP,
132
133 /**
134 * Splice OBJ and discard all cells at or after the current one
135 * in the input. Only implemented for list translators.
136 */
137 TRL_MSG_SET_SUBLS,
138
139 TR_MSG_USR
140 #define TR_BOOL_MSG_P(m) ((m) == TR_MSG_ENDP)
141 };
142
143 typedef enum _tr_msg tr_msg;
144 typedef struct _tr_param tr_param;
145 typedef struct _list_translator list_translator;
146 typedef struct _vector_translator vector_translator;
147 typedef struct _sequence_translator sequence_translator;
148 typedef union _translator_ret translator_ret;
149
150 struct _tr_param {
151 tr_msg msg;
152 ScmObj obj;
153 };
154
155 struct _list_translator {
156 ScmObj output;
157 ScmObj cur;
158 ScmObj src;
159 ScmQueue q;
160 };
161
162 struct _vector_translator {
163 ScmObj src;
164 ScmObj diff;
165 ScmQueue q; /* Points to diff. */
166 scm_int_t index; /* Current position. */
167 scm_int_t growth;
168 };
169
170 struct _sequence_translator {
171 translator_ret (*trans)(sequence_translator *t, tr_msg msg, ScmObj obj);
172 union {
173 list_translator lst;
174 vector_translator vec;
175 } u;
176 };
177
178 union _translator_ret {
179 ScmObj object;
180 scm_bool boolean;
181 };
182
183 /*
184 * Operations on translators. If a list- or vector-specific macro has
185 * the same name (sans prefix) as a polymorphic one, the former tends
186 * to be faster.
187 */
188
189 /* List-specific macros. */
190 #define TRL_INIT(_t, _in) ((_t).u.lst.output = (_in), \
191 SCM_QUEUE_POINT_TO((_t).u.lst.q, \
192 (_t).u.lst.output), \
193 (_t).u.lst.src = (_in), \
194 (_t).u.lst.cur = (_in), \
195 (_t).trans = scm_listran)
196 #define TRL_GET_ELM(_t) (CAR((_t).u.lst.cur))
197 #define TRL_NEXT(_t) ((_t).u.lst.cur = CDR((_t).u.lst.cur))
198 #define TRL_ENDP(_t) (!CONSP((_t).u.lst.cur))
199 #define TRL_GET_SUBLS(_t) ((_t).u.lst.cur)
200 #define TRL_SET_SUBLS(_t, _o) (TRL_CALL((_t), TRL_MSG_SET_SUBLS, (_o)))
201 #define TRL_EXTRACT(_t) ((_t).u.lst.output)
202 #define TRL_CALL(_t, _m, _o) (scm_listran(&(_t), (_m), (_o)))
203 #define TRL_EXECUTE(_t, _p) (SCM_ASSERT(!TR_BOOL_MSG_P((_p).msg)), \
204 scm_listran(&(_t), (_p).msg, (_p).obj).object)
205
206 #if SCM_USE_VECTOR
207 /* Vector-specific macros. */
208 #define TRV_INIT(_t, _in) ((_t).u.vec.diff = SCM_NULL, \
209 SCM_QUEUE_POINT_TO((_t).u.vec.q, \
210 (_t).u.vec.diff), \
211 (_t).u.vec.src = (_in), \
212 (_t).u.vec.index = 0, \
213 (_t).u.vec.growth = 0, \
214 (_t).trans = scm_vectran)
215 #define TRV_GET_ELM(_t) (SCM_VECTOR_VEC((_t).u.vec.src)[(_t).u.vec.index])
216 #define TRV_NEXT(_t) (++(_t).u.vec.index)
217 #define TRV_GET_INDEX(_t) ((_t).u.vec.index)
218 #define TRV_GET_VEC(_t) (SCM_VECTOR_VEC((_t).u.vec.src))
219 #define TRV_ENDP(_t) (SCM_VECTOR_LEN((_t).u.vec.src) <= (_t).u.vec.index)
220 #define TRV_EXTRACT(_t) (TRV_CALL((_t), TR_MSG_EXTRACT, SCM_INVALID).object)
221 #define TRV_EXECUTE(_t, _p) (TRV_CALL((_t), (_p).msg, (_p).obj).object)
222 #define TRV_CALL(_t, _m, _o) (scm_vectran(&(_t), (_m), (_o)))
223 #endif /* SCM_USE_VECTOR */
224
225 /* Polymorphic macros. */
226 #define TR_CALL(_t, _msg, _o) ((*(_t).trans)(&(_t), (_msg), (_o)))
227 #define TR_EXECUTE(_t, _p) (TR_CALL((_t), (_p).msg, (_p).obj).object)
228 #define TR_GET_ELM(_t) (TR_CALL((_t), TR_MSG_GET_ELM, SCM_INVALID).object)
229 #define TR_NEXT(_t) ((void)TR_CALL((_t), TR_MSG_NEXT, SCM_INVALID))
230 #define TR_ENDP(_t) (TR_CALL((_t), TR_MSG_ENDP, SCM_INVALID).boolean)
231 #define TR_EXTRACT(_t) (TR_CALL((_t), TR_MSG_EXTRACT, SCM_INVALID).object)
232
233
234 /*=======================================
235 Function Definitions
236 =======================================*/
237
238 static translator_ret scm_listran(sequence_translator *t, tr_msg msg,
239 ScmObj obj);
240 #if SCM_USE_VECTOR
241 static translator_ret scm_vectran(sequence_translator *t, tr_msg msg,
242 ScmObj obj);
243 #endif
244 static tr_param qquote_internal(ScmObj input, ScmObj env, scm_int_t nest);
245
246
247 #define RETURN_OBJECT(o) \
248 do { \
249 translator_ret _ret; \
250 _ret.object = (o); \
251 return _ret; \
252 } while (0)
253 #define RETURN_BOOLEAN(b) \
254 do { \
255 translator_ret _ret; \
256 _ret.boolean = (b); \
257 return _ret; \
258 } while (0)
259 /**
260 * Performs (relatively) complex operations on a list translator.
261 *
262 * @see list_translator, tr_msg
263 */
264 static translator_ret
scm_listran(sequence_translator * t,tr_msg msg,ScmObj obj)265 scm_listran(sequence_translator *t, tr_msg msg, ScmObj obj)
266 {
267 DECLARE_INTERNAL_FUNCTION("(list translator)");
268
269 switch (msg) {
270 case TR_MSG_NOP: /* for better performance */
271 break;
272
273 case TR_MSG_ENDP:
274 RETURN_BOOLEAN(TRL_ENDP(*t));
275
276 case TR_MSG_GET_ELM:
277 RETURN_OBJECT(TRL_GET_ELM(*t));
278
279 case TR_MSG_NEXT:
280 TRL_NEXT(*t);
281 break;
282
283 case TR_MSG_REPLACE:
284 obj = LIST_1(obj);
285 /* Fall through. */
286 case TRL_MSG_SET_SUBLS:
287 case TR_MSG_SPLICE:
288
289 /* Execute deferred copies. */
290 while (!EQ(t->u.lst.src, t->u.lst.cur)) {
291 SCM_QUEUE_ADD(t->u.lst.q, CAR(t->u.lst.src));
292 t->u.lst.src = CDR(t->u.lst.src);
293 }
294
295 if (msg != TRL_MSG_SET_SUBLS) {
296 SCM_QUEUE_APPEND(t->u.lst.q, obj);
297 #if SCM_STRICT_ARGCHECK
298 if (!NULLP(SCM_QUEUE_TERMINATOR(t->u.lst.q)))
299 ERR_OBJ(ERRMSG_BAD_SPLICE_LIST, obj);
300 #endif
301 t->u.lst.src = obj = CDR(t->u.lst.cur);
302 }
303 SCM_QUEUE_SLOPPY_APPEND(t->u.lst.q, obj);
304 break;
305
306 case TR_MSG_EXTRACT:
307 RETURN_OBJECT(TRL_EXTRACT(*t));
308
309 default:
310 SCM_NOTREACHED;
311 }
312 RETURN_OBJECT(SCM_INVALID);
313 }
314
315 #if SCM_USE_VECTOR
316 #define REPLACED_INDEX(i) (i)
317 /* '- 1' allows zero as spliced index */
318 #define SPLICED_INDEX(i) (-(i) - 1)
319
320 static translator_ret
scm_vectran(sequence_translator * t,tr_msg msg,ScmObj obj)321 scm_vectran(sequence_translator *t, tr_msg msg, ScmObj obj)
322 {
323 ScmObj subst_rec, subst_index;
324 scm_int_t splice_len;
325 scm_int_t change_index;
326 DECLARE_INTERNAL_FUNCTION("(vector translator)");
327
328 switch (msg) {
329 case TR_MSG_NOP: /* for better performance */
330 break;
331
332 case TR_MSG_GET_ELM:
333 RETURN_OBJECT(TRV_GET_ELM(*t));
334
335 case TR_MSG_NEXT:
336 TRV_NEXT(*t);
337 break;
338
339 case TR_MSG_ENDP:
340 RETURN_BOOLEAN(TRV_ENDP(*t));
341
342 case TR_MSG_SPLICE:
343 splice_len = scm_length(obj);
344 /* obj MUST be a proper list regardless of strictness
345 * configuration. Otherwise the encoded length feeds broken execution.
346 * -- YamaKen 2006-06-25 */
347 if (!SCM_LISTLEN_PROPERP(splice_len))
348 ERR_OBJ(ERRMSG_BAD_SPLICE_LIST, obj);
349 t->u.vec.growth += splice_len - 1;
350 change_index = SPLICED_INDEX(t->u.vec.index);
351 goto record_change;
352
353 case TR_MSG_REPLACE:
354 change_index = REPLACED_INDEX(t->u.vec.index);
355
356 record_change:
357 subst_index = MAKE_INT(change_index);
358 subst_rec = CONS(subst_index, obj);
359 SCM_QUEUE_ADD(t->u.vec.q, subst_rec);
360 break;
361
362 case TR_MSG_EXTRACT:
363 /* Create a new vector iff modifications have been recorded. */
364 if (!NULLP(t->u.vec.diff)) {
365 ScmObj *copy_buf, *src_buf;
366 ScmObj diff, appendix, elm, ret;
367 scm_int_t src_len, i, cpi;
368
369 src_len = SCM_VECTOR_LEN(t->u.vec.src);
370 src_buf = SCM_VECTOR_VEC(t->u.vec.src);
371 copy_buf = scm_malloc((src_len + t->u.vec.growth)
372 * sizeof(ScmObj));
373
374 diff = t->u.vec.diff;
375 change_index = SCM_INT_VALUE(CAAR(diff));
376 for (i = cpi = 0; i < src_len; i++) {
377 if (REPLACED_INDEX(i) == change_index) {
378 copy_buf[cpi++] = CDAR(diff);
379 } else if (SPLICED_INDEX(i) == change_index) {
380 appendix = CDAR(diff);
381 FOR_EACH (elm, appendix)
382 copy_buf[cpi++] = elm;
383 } else {
384 copy_buf[cpi++] = src_buf[i];
385 continue;
386 }
387
388 /* We replaced an element this round. */
389 diff = CDR(diff);
390 if (NULLP(diff))
391 /* Invalidate. */
392 change_index = src_len;
393 else
394 change_index = SCM_INT_VALUE(CAAR(diff));
395 }
396 ret = MAKE_VECTOR(copy_buf, src_len + t->u.vec.growth);
397 RETURN_OBJECT(ret);
398 }
399 RETURN_OBJECT(t->u.vec.src);
400
401 default:
402 SCM_NOTREACHED;
403 }
404 RETURN_OBJECT(SCM_INVALID);
405 }
406
407 #undef REPLACED_INDEX
408 #undef SPLICED_INDEX
409 #endif /* SCM_USE_VECTOR */
410
411 #undef RETURN_OBJECT
412 #undef RETURN_BOOLEAN
413
414 /*===========================================================================
415 R5RS : 4.2 Derived expression types : 4.2.6 Quasiquotation
416 ===========================================================================*/
417
418 /**
419 * Interpret a quasiquoted expression.
420 */
421 static tr_param
qquote_internal(ScmObj input,ScmObj env,scm_int_t nest)422 qquote_internal(ScmObj input, ScmObj env, scm_int_t nest)
423 {
424 ScmObj obj, form, args;
425 sequence_translator tr;
426 tr_param tmp_result;
427 tr_param my_result;
428 DECLARE_INTERNAL_FUNCTION("quasiquote");
429
430 /*
431 * syntax: quasiquote <qq template>
432 * syntax: `<qq template>
433 */
434
435 #if SCM_USE_VECTOR
436 if (VECTORP(input)) {
437 for (TRV_INIT(tr, input); !TRV_ENDP(tr); TRV_NEXT(tr)) {
438 obj = TRV_GET_ELM(tr);
439 tmp_result = qquote_internal(obj, env, nest);
440 (void)TRV_EXECUTE(tr, tmp_result);
441 }
442 } else
443 #endif
444 if (CONSP(input)) {
445 /* This implementation adopt "minimum mercy" interpretation depending
446 * on the R5RS specification cited below, to simplify the code.
447 *
448 * 4.2.6 Quasiquotation
449 * Unpredictable behavior can result if any of the symbols quasiquote,
450 * unquote, or unquote-splicing appear in positions within a <qq
451 * template> otherwise than as described above. */
452 for (TRL_INIT(tr, input); !TRL_ENDP(tr); TRL_NEXT(tr)) {
453 ScmObj unwrapped;
454 form = TRL_GET_SUBLS(tr);
455 obj = CAR(form);
456 unwrapped = SCM_UNWRAP_KEYWORD(obj);
457 /*
458 * R5RS: 7.1.4 Quasiquotations
459 *
460 * In <quasiquotation>s, a <list qq template D> can sometimes be
461 * confused with either an <unquotation D> or a <splicing
462 * unquotation D>. The interpretation as an <unquotation> or
463 * <splicing unquotation D> takes precedence.
464 */
465 if (EQ(unwrapped, SYM_QUASIQUOTE)) {
466 /* FORM == `x */
467 if (args = CDR(form), !LIST_1_P(args))
468 ERR_OBJ("invalid quasiquote form", form);
469
470 ++nest;
471 } else if (EQ(unwrapped, SYM_UNQUOTE)) {
472 /* FORM == ,x */
473 if (args = CDR(form), !LIST_1_P(args))
474 ERR_OBJ("invalid unquote form", form);
475
476 if (--nest == 0) {
477 obj = EVAL(CAR(args), env);
478 TRL_SET_SUBLS(tr, obj);
479 my_result.obj = TRL_EXTRACT(tr);
480 my_result.msg = TR_MSG_REPLACE;
481 return my_result;
482 }
483 } else if (EQ(unwrapped, SYM_UNQUOTE_SPLICING)) {
484 /* FORM == ,@x */
485 if (!EQ(form, input)) /* (a . ,@b) */
486 ERR_OBJ(",@ in invalid context", input);
487 if (args = CDR(form), !LIST_1_P(args))
488 ERR_OBJ("invalid unquote-splicing form", form);
489
490 if (--nest == 0) {
491 /* R5RS: 4.2.6 Quasiquotation
492 * If a comma appears followed immediately by an
493 * at-sign (@), then the following expression must
494 * evaluate to a list */
495 obj = EVAL(CAR(args), env);
496 /* Properness check of the list is performed on splice
497 * operation of (lis|vec)tran(). */
498 if (!LISTP(obj))
499 ERR(",@<x> must evaluate to a proper list");
500
501 my_result.obj = obj;
502 my_result.msg = TR_MSG_SPLICE;
503 return my_result;
504 }
505 }
506 tmp_result = qquote_internal(obj, env, nest);
507 (void)TRL_EXECUTE(tr, tmp_result);
508 }
509 /* Interpret the tail if an improper list. */
510 if (!NULLP(TRL_GET_SUBLS(tr))) {
511 tmp_result = qquote_internal(TRL_GET_SUBLS(tr), env, nest);
512 SCM_ASSERT(tmp_result.msg != TR_MSG_SPLICE);
513 if (tmp_result.msg == TR_MSG_REPLACE)
514 TRL_SET_SUBLS(tr, tmp_result.obj);
515 }
516 } else {
517 /* An atomic datum. */
518 #if SCM_USE_HYGIENIC_MACRO
519 if (FARSYMBOLP(input)) {
520 tmp_result.obj = SCM_UNWRAP_SYNTAX(input);
521 tmp_result.msg = TR_MSG_REPLACE;
522 return tmp_result;
523 }
524 #endif
525 tmp_result.obj = SCM_INVALID;
526 tmp_result.msg = TR_MSG_NOP;
527 return tmp_result;
528 }
529
530 my_result.obj = TR_EXTRACT(tr);
531 my_result.msg = EQ(my_result.obj, input) ? TR_MSG_NOP : TR_MSG_REPLACE;
532 return my_result;
533 }
534
535 SCM_EXPORT ScmObj
scm_s_quasiquote(ScmObj datum,ScmObj env)536 scm_s_quasiquote(ScmObj datum, ScmObj env)
537 {
538 tr_param ret;
539 DECLARE_FUNCTION("quasiquote", syntax_fixed_1);
540
541 ret = qquote_internal(datum, env, 1);
542
543 switch (ret.msg) {
544 case TR_MSG_NOP:
545 return datum;
546 case TR_MSG_SPLICE:
547 /* R5RS: 4.2.6 Quasiquotation
548 * A comma at-sign should only appear within a list or vector <qq
549 * template>. */
550 ERR_OBJ(",@ in invalid context", datum);
551 /* NOTREACHED */
552 case TR_MSG_REPLACE:
553 return ret.obj;
554 default:
555 SCM_NOTREACHED;
556 }
557 }
558
559 SCM_EXPORT ScmObj
scm_s_unquote(ScmObj dummy,ScmObj env)560 scm_s_unquote(ScmObj dummy, ScmObj env)
561 {
562 DECLARE_FUNCTION("unquote", syntax_fixed_1);
563
564 ERR("unquote outside quasiquote");
565 /* NOTREACHED */
566 return SCM_FALSE;
567 }
568
569 SCM_EXPORT ScmObj
scm_s_unquote_splicing(ScmObj dummy,ScmObj env)570 scm_s_unquote_splicing(ScmObj dummy, ScmObj env)
571 {
572 DECLARE_FUNCTION("unquote-splicing", syntax_fixed_1);
573
574 ERR("unquote-splicing outside quasiquote");
575 /* NOTREACHED */
576 return SCM_FALSE;
577 }
578