1
/*===========================================================================
3
* About : R5RS quasiquote
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>
10
* All rights reserved.
12
* Redistribution and use in source and binary forms, with or without
13
* modification, are permitted provided that the following conditions
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.
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
===========================================================================*/
40
#include "sigscheme.h"
41
#include "sigschemeinternal.h"
43
/*=======================================
44
File Local Macro Definitions
45
=======================================*/
46
#define ERRMSG_BAD_SPLICE_LIST "bad splice list"
48
/*=======================================
49
File Local Type Definitions
50
=======================================*/
52
/*=======================================
54
=======================================*/
56
/*=======================================
57
File Local Function Declarations
58
=======================================*/
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 */
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
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()).
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().
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()
97
* Everything prefixed with TRL_ is specific to list translators.
98
* Likewise, TRV_ shows specificity to vector translators. TR_
99
* denotes a polymorphism.
103
* Message IDs. We have to bring this upfront because ISO C forbids
104
* forward reference to enumerations.
107
/** Don't do anything. */
110
/** Put OBJ in place of the current element. */
113
/** Splice OBJ into the current cell. */
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
124
/** Advance the iterator on the input. */
127
/** Extract the product. */
130
/** True iff the end of the sequence has been reached. */
134
* Splice OBJ and discard all cells at or after the current one
135
* in the input. Only implemented for list translators.
140
#define TR_BOOL_MSG_P(m) ((m) == TR_MSG_ENDP)
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;
155
struct _list_translator {
162
struct _vector_translator {
165
ScmQueue q; /* Points to diff. */
166
scm_int_t index; /* Current position. */
170
struct _sequence_translator {
171
translator_ret (*trans)(sequence_translator *t, tr_msg msg, ScmObj obj);
174
vector_translator vec;
178
union _translator_ret {
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
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)
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, \
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 */
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)
234
/*=======================================
236
=======================================*/
238
static translator_ret scm_listran(sequence_translator *t, tr_msg msg,
241
static translator_ret scm_vectran(sequence_translator *t, tr_msg msg,
244
static tr_param qquote_internal(ScmObj input, ScmObj env, scm_int_t nest);
247
#define RETURN_OBJECT(o) \
249
translator_ret _ret; \
253
#define RETURN_BOOLEAN(b) \
255
translator_ret _ret; \
256
_ret.boolean = (b); \
260
* Performs (relatively) complex operations on a list translator.
262
* @see list_translator, tr_msg
264
static translator_ret
265
scm_listran(sequence_translator *t, tr_msg msg, ScmObj obj)
267
DECLARE_INTERNAL_FUNCTION("(list translator)");
270
case TR_MSG_NOP: /* for better performance */
274
RETURN_BOOLEAN(TRL_ENDP(*t));
277
RETURN_OBJECT(TRL_GET_ELM(*t));
286
case TRL_MSG_SET_SUBLS:
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);
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);
301
t->u.lst.src = obj = CDR(t->u.lst.cur);
303
SCM_QUEUE_SLOPPY_APPEND(t->u.lst.q, obj);
307
RETURN_OBJECT(TRL_EXTRACT(*t));
312
RETURN_OBJECT(SCM_INVALID);
316
#define REPLACED_INDEX(i) (i)
317
/* '- 1' allows zero as spliced index */
318
#define SPLICED_INDEX(i) (-(i) - 1)
320
static translator_ret
321
scm_vectran(sequence_translator *t, tr_msg msg, ScmObj obj)
323
ScmObj subst_rec, subst_index;
324
scm_int_t splice_len;
325
scm_int_t change_index;
326
DECLARE_INTERNAL_FUNCTION("(vector translator)");
329
case TR_MSG_NOP: /* for better performance */
333
RETURN_OBJECT(TRV_GET_ELM(*t));
340
RETURN_BOOLEAN(TRV_ENDP(*t));
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);
354
change_index = REPLACED_INDEX(t->u.vec.index);
357
subst_index = MAKE_INT(change_index);
358
subst_rec = CONS(subst_index, obj);
359
SCM_QUEUE_ADD(t->u.vec.q, subst_rec);
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;
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)
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;
384
copy_buf[cpi++] = src_buf[i];
388
/* We replaced an element this round. */
392
change_index = src_len;
394
change_index = SCM_INT_VALUE(CAAR(diff));
396
ret = MAKE_VECTOR(copy_buf, src_len + t->u.vec.growth);
399
RETURN_OBJECT(t->u.vec.src);
404
RETURN_OBJECT(SCM_INVALID);
407
#undef REPLACED_INDEX
409
#endif /* SCM_USE_VECTOR */
412
#undef RETURN_BOOLEAN
414
/*===========================================================================
415
R5RS : 4.2 Derived expression types : 4.2.6 Quasiquotation
416
===========================================================================*/
419
* Interpret a quasiquoted expression.
422
qquote_internal(ScmObj input, ScmObj env, scm_int_t nest)
424
ScmObj obj, form, args;
425
sequence_translator tr;
428
DECLARE_INTERNAL_FUNCTION("quasiquote");
431
* syntax: quasiquote <qq template>
432
* syntax: `<qq template>
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);
445
/* This implementation adopt "minimum mercy" interpretation depending
446
* on the R5RS specification cited below, to simplify the code.
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)) {
454
form = TRL_GET_SUBLS(tr);
456
unwrapped = SCM_UNWRAP_KEYWORD(obj);
458
* R5RS: 7.1.4 Quasiquotations
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.
465
if (EQ(unwrapped, SYM_QUASIQUOTE)) {
467
if (args = CDR(form), !LIST_1_P(args))
468
ERR_OBJ("invalid quasiquote form", form);
471
} else if (EQ(unwrapped, SYM_UNQUOTE)) {
473
if (args = CDR(form), !LIST_1_P(args))
474
ERR_OBJ("invalid unquote form", form);
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;
483
} else if (EQ(unwrapped, SYM_UNQUOTE_SPLICING)) {
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);
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(). */
499
ERR(",@<x> must evaluate to a proper list");
502
my_result.msg = TR_MSG_SPLICE;
506
tmp_result = qquote_internal(obj, env, nest);
507
(void)TRL_EXECUTE(tr, tmp_result);
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);
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;
525
tmp_result.obj = SCM_INVALID;
526
tmp_result.msg = TR_MSG_NOP;
530
my_result.obj = TR_EXTRACT(tr);
531
my_result.msg = EQ(my_result.obj, input) ? TR_MSG_NOP : TR_MSG_REPLACE;
536
scm_s_quasiquote(ScmObj datum, ScmObj env)
539
DECLARE_FUNCTION("quasiquote", syntax_fixed_1);
541
ret = qquote_internal(datum, env, 1);
547
/* R5RS: 4.2.6 Quasiquotation
548
* A comma at-sign should only appear within a list or vector <qq
550
ERR_OBJ(",@ in invalid context", datum);
560
scm_s_unquote(ScmObj dummy, ScmObj env)
562
DECLARE_FUNCTION("unquote", syntax_fixed_1);
564
ERR("unquote outside quasiquote");
570
scm_s_unquote_splicing(ScmObj dummy, ScmObj env)
572
DECLARE_FUNCTION("unquote-splicing", syntax_fixed_1);
574
ERR("unquote-splicing outside quasiquote");
added
removed
sigscheme/src/qquote.c
