[uim-commit] r3004 - in branches/r5rs/sigscheme: . src test
yamaken at freedesktop.org
yamaken at freedesktop.org
Fri Jan 27 15:43:08 PST 2006
Author: yamaken
Date: 2006-01-27 15:43:04 -0800 (Fri, 27 Jan 2006)
New Revision: 3004
Modified:
branches/r5rs/sigscheme/TODO
branches/r5rs/sigscheme/src/syntax.c
branches/r5rs/sigscheme/test/test-quote.scm
Log:
* sigscheme/src/syntax.c
- (ERRMSG_BAD_SPLICE_LIST, REPLACED_INDEX, SPLICED_INDEX): New macro
- (listran, vectran):
* Simplify
* Make efficient
- (qquote_internal):
* Fix unsafe side-effective macro arg
* Add lacking validation for result of unquote-splicing
- (scm_s_quasiquote): Make top-level unquote-splicing error even if
!SCM_STRICT_R5RS
- (scm_s_unquote, scm_s_unquote_splicing): Trivial change
* sigscheme/test/test-quote.scm
- Insert license header
- Add various tests for quasiquote
* sigscheme/TODO
- Update
Modified: branches/r5rs/sigscheme/TODO
===================================================================
--- branches/r5rs/sigscheme/TODO 2006-01-27 11:06:32 UTC (rev 3003)
+++ branches/r5rs/sigscheme/TODO 2006-01-27 23:43:04 UTC (rev 3004)
@@ -17,10 +17,9 @@
* Fix all side-effective expression in macros
- All files except for operations-srfi1.c, storage-compact.h and
test-compact.c are checked
- - qquote_internal() still have such expression
-* Review and refactor some functions in syntax.c(listran, vectran,
- qquote_internal, scm_s_quasiquote) (other files had already been done)
+* Review and refactor some functions in syntax.c(qquote_internal) (other files
+ had already been done)
* Make 64bit-safe
- Write tests
Modified: branches/r5rs/sigscheme/src/syntax.c
===================================================================
--- branches/r5rs/sigscheme/src/syntax.c 2006-01-27 11:06:32 UTC (rev 3003)
+++ branches/r5rs/sigscheme/src/syntax.c 2006-01-27 23:43:04 UTC (rev 3004)
@@ -49,6 +49,7 @@
/*=======================================
File Local Macro Declarations
=======================================*/
+#define ERRMSG_BAD_SPLICE_LIST "bad splice list"
#define ERRMSG_BAD_DEFINE_PLACEMENT "bad define placement"
/*=======================================
@@ -244,7 +245,7 @@
DECLARE_INTERNAL_FUNCTION("(list translator)");
switch (msg) {
- default:
+ case TR_MSG_NOP: /* for better performance */
break;
case TR_MSG_ENDP:
@@ -273,7 +274,7 @@
SCM_QUEUE_APPEND(t->u.lst.q, obj);
#if SCM_STRICT_R5RS
if (!NULLP(SCM_QUEUE_TERMINATOR(t->u.lst.q)))
- ERR_OBJ("bad splice list", obj);
+ ERR_OBJ(ERRMSG_BAD_SPLICE_LIST, obj);
#endif
t->u.lst.src = obj = CDR(t->u.lst.cur);
}
@@ -281,27 +282,36 @@
break;
case TR_MSG_EXTRACT:
- return t->u.lst.output;
+ return TRL_EXTRACT(*t);
+
+ default:
+ SCM_ASSERT(scm_false);
}
return SCM_INVALID;
}
+#define REPLACED_INDEX(i) (i)
+/* '- 1' allows zero as spliced index */
+#define SPLICED_INDEX(i) (-(i) - 1)
+
static ScmObj
vectran(sequence_translator *t, tr_msg msg, ScmObj obj)
{
scm_int_t splice_len;
scm_int_t change_index;
- DECLARE_INTERNAL_FUNCTION("vectran");
+ DECLARE_INTERNAL_FUNCTION("(vector translator)");
switch (msg) {
- default:
+ case TR_MSG_NOP: /* for better performance */
break;
case TR_MSG_GET_OBJ:
return TRV_GET_OBJ(*t);
+
case TR_MSG_NEXT:
TRV_NEXT(*t);
break;
+
case TR_MSG_ENDP:
return MAKE_BOOL(TRV_ENDP(*t));
@@ -309,14 +319,14 @@
splice_len = scm_length(obj);
#if SCM_STRICT_R5RS
if (!SCM_LISTLEN_PROPERP(splice_len))
- ERR_OBJ("got bad splice list", obj);
+ ERR_OBJ(ERRMSG_BAD_SPLICE_LIST, obj);
#endif
t->u.vec.growth += splice_len - 1;
- change_index = -t->u.vec.index - 1;
+ change_index = SPLICED_INDEX(t->u.vec.index);
goto record_change;
case TR_MSG_REPLACE:
- change_index = t->u.vec.index;
+ change_index = REPLACED_INDEX(t->u.vec.index);
record_change:
SCM_QUEUE_ADD(t->u.vec.q, CONS(MAKE_INT(change_index), obj));
@@ -325,26 +335,23 @@
case TR_MSG_EXTRACT:
/* Create a new vector iff modifications have been recorded. */
if (!NULLP(t->u.vec.diff)) {
- ScmObj *copy_buf;
- ScmObj *src_buf;
- ScmObj tmp;
- ScmObj diff;
+ ScmObj *copy_buf, *src_buf;
+ ScmObj diff, appendix, elm;
scm_int_t src_len, i, cpi;
src_len = SCM_VECTOR_LEN(t->u.vec.src);
src_buf = SCM_VECTOR_VEC(t->u.vec.src);
- copy_buf = malloc ((src_len + t->u.vec.growth) * sizeof (ScmObj));
+ copy_buf = malloc((src_len + t->u.vec.growth) * sizeof(ScmObj));
diff = t->u.vec.diff;
change_index = SCM_INT_VALUE(CAAR(diff));
-
for (i = cpi = 0; i < src_len; i++) {
- if (i == change_index) {
+ if (REPLACED_INDEX(i) == change_index) {
copy_buf[cpi++] = CDAR(diff);
- } else if (-i-1 == change_index) {
- /* Splice. */
- for (tmp = CDAR(diff); CONSP(tmp); tmp = CDR(tmp))
- copy_buf[cpi++] = CAR(tmp);
+ } else if (SPLICED_INDEX(i) == change_index) {
+ appendix = CDAR(diff);
+ FOR_EACH (elm, appendix)
+ copy_buf[cpi++] = elm;
} else {
copy_buf[cpi++] = src_buf[i];
continue;
@@ -361,10 +368,16 @@
return MAKE_VECTOR(copy_buf, src_len + t->u.vec.growth);
}
break;
+
+ default:
+ SCM_ASSERT(scm_false);
}
return SCM_INVALID;
}
+#undef REPLACED_INDEX
+#undef SPLICED_INDEX
+
/*=======================================
R5RS : 4.1 Primitive expression types
=======================================*/
@@ -1137,8 +1150,8 @@
} else if (EQ(obj, SYM_UNQUOTE)) {
/* FORM == ,x */
if (--nest == 0) {
- /* FIXME: side-effective EVAL in another macro */
- TRL_SET_SUBLS(tr, EVAL(CADR(form), env));
+ obj = EVAL(CADR(form), env);
+ TRL_SET_SUBLS(tr, obj);
my_result.obj = TRL_EXTRACT(tr);
my_result.insn = TR_MSG_REPLACE;
return my_result;
@@ -1146,10 +1159,19 @@
} else if (EQ(obj, SYM_UNQUOTE_SPLICING)) {
/* FORM == , at x */
if (!EQ(form, input)) /* (a . , at b) */
- ERR_OBJ(",@ in wrong context", input);
+ ERR_OBJ(",@ in invalid context", input);
+
if (--nest == 0) {
+ /* R5RS: 4.2.6 Quasiquotation
+ * If a comma appears followed immediately by an
+ * at-sign (@), then the following expression must
+ * evaluate to a list */
+ obj = EVAL(CADR(form), env);
+ if (!LISTP(obj))
+ ERR(",@<x> must evaluate to a list");
+
+ my_result.obj = obj;
my_result.insn = TR_MSG_SPLICE;
- my_result.obj = EVAL(CADR(form), env);
return my_result;
}
}
@@ -1157,8 +1179,8 @@
}
} else {
/* An atomic datum. */
+ tmp_result.obj = SCM_INVALID;
tmp_result.insn = TR_MSG_NOP;
- tmp_result.obj = SCM_INVALID;
return tmp_result;
}
@@ -1193,14 +1215,15 @@
case TR_MSG_NOP:
return datum;
case TR_MSG_SPLICE:
-#if SCM_STRICT_R5RS
- ERR_OBJ("unquote-splicing in invalid context", datum);
-#endif
- /* Otherwise fall through. */
+ /* R5RS: 4.2.6 Quasiquotation
+ * A comma at-sign should only appear within a list or vector <qq
+ * template>. */
+ ERR_OBJ(",@ in invalid context", datum);
+ /* NOTREACHED */
case TR_MSG_REPLACE:
return ret.obj;
default:
- ERR_OBJ("bug in quasiquote", datum);
+ SCM_ASSERT(scm_false);
}
}
@@ -1210,7 +1233,8 @@
DECLARE_FUNCTION("unquote", syntax_fixed_1);
ERR("unquote outside quasiquote");
- return SCM_NULL;
+ /* NOTREACHED */
+ return SCM_FALSE;
}
ScmObj
@@ -1219,7 +1243,8 @@
DECLARE_FUNCTION("unquote-splicing", syntax_fixed_1);
ERR("unquote-splicing outside quasiquote");
- return SCM_NULL;
+ /* NOTREACHED */
+ return SCM_FALSE;
}
Modified: branches/r5rs/sigscheme/test/test-quote.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-quote.scm 2006-01-27 11:06:32 UTC (rev 3003)
+++ branches/r5rs/sigscheme/test/test-quote.scm 2006-01-27 23:43:04 UTC (rev 3004)
@@ -1,5 +1,40 @@
-(load "test/unittest.scm")
+;; FileName : test-quote.scm
+;; About : unit test for quote and quasiquote
+;;
+;; Copyright (C) 2005-2006 Kazuki Ohta <mover AT hct.zaq.ne.jp>
+;;
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;; 3. Neither the name of authors nor the names of its contributors
+;; may be used to endorse or promote products derived from this software
+;; without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
+;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
+;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+(load "./test/unittest.scm")
+
+(define tn test-name)
+(define *test-track-progress* #f)
+
(assert-true "quasiquote check #1" (equal? '(1 2 3) `(1 2 3)))
(assert-true "quasiquote check #2" (equal? '(5) `(,(+ 2 3))))
(assert-true "unquote check" (equal? `(1 2 3) `(1 ,(+ 1 1) ,(+ 1 2))))
@@ -33,4 +68,187 @@
'#(a b)
`#(,@(list 'a 'b)))
+(tn "quasiquote reference test of R5RS")
+(if (not (symbol-bound? 'sqrt))
+ (define sqrt
+ (lambda (x)
+ (cdr (assv x '((4 . 2)
+ (9 . 3)
+ (16 . 4)))))))
+(assert-equal? (tn)
+ '(list 3 4)
+ `(list ,(+ 1 2) 4))
+(assert-equal? (tn)
+ '(list a (quote a))
+ (let ((name 'a)) `(list ,name ',name)))
+(assert-equal? (tn)
+ '(a 3 4 5 6 b)
+ `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b))
+;; Commented out since the test seems to wrong. Even if the interpretation for
+;; the quote after foo (foo') may varied by implementation, at least the
+;; quasiquote before foo (`foo) must be remained.
+;;
+;; SigScheme: (((quasiquote foo') 7) . cons)
+;; Gauche: ((`foo '7) . cons)
+;; Guile: (((quasiquote foo') 7) . cons)
+;; Bigloo: (((quasiquote foo') 7) . cons)
+;; Scheme48: (((quasiquote foo) '7) . cons)
+;; SCM: (((quasiquote foo\') 7) . cons)
+;; PLT: read: illegal use of backquote
+;;(assert-equal? (tn)
+;; '((foo 7) . cons)
+;; `((`foo' ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons))))
+(assert-equal? (tn)
+ '#(10 5 2 4 3 8)
+ `#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8))
+(assert-equal? (tn)
+ '(a `(b ,(+ 1 2) ,(foo 4 d) e) f)
+ `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f))
+(assert-equal? (tn)
+ '(a `(b ,x ,'y d) e)
+ (let ((name1 'x)
+ (name2 'y))
+ `(a `(b ,,name1 ,',name2 d) e)))
+(assert-equal? (tn)
+ '(list 3 4)
+ (quasiquote (list (unquote (+ 1 2)) 4)))
+(assert-equal? (tn)
+ '`(list ,(+ 1 2) 4)
+ '(quasiquote (list (unquote (+ 1 2)) 4)))
+
+(tn "quasiquote valid form")
+(assert-equal? (tn) ''1 `'1)
+(assert-equal? (tn) '`1 ``1)
+(assert-equal? (tn) 1 `,1)
+(assert-equal? (tn) ''1 `',1)
+(assert-equal? (tn) '(quote 1) `'1)
+(assert-equal? (tn) '(quasiquote 1) ``1)
+(assert-equal? (tn) '(quote 1) `',1)
+(assert-equal? (tn) '('1) `('1))
+(assert-equal? (tn) '(`1) `(`1))
+(assert-equal? (tn) '(1) `(,1))
+(assert-equal? (tn) '('1) `(',1))
+(assert-equal? (tn) '((quote 1)) `('1))
+(assert-equal? (tn) '((quasiquote 1)) `(`1))
+(assert-equal? (tn) '(1) `(,1))
+(assert-equal? (tn) '((quote 1)) `(',1))
+(assert-equal? (tn) '() `(,@()))
+(assert-equal? (tn) '() `(,@(list)))
+(assert-equal? (tn) '(1) `(,@(list 1)))
+(assert-equal? (tn) '(1 2) `(,@(list 1 2)))
+(assert-equal? (tn) '(1 2 3) `(,@(list 1 2 3)))
+
+;; R5RS allows these forms to be an error
+(tn "unquote implementation-dependent form")
+(if (provided? "sigscheme")
+ (begin
+ (assert-error (tn) (lambda () `((unquote))))
+ (assert-error (tn) (lambda () `((unquote . 0))))
+ (assert-error (tn) (lambda () `((unquote 0 1))))
+ (assert-error (tn) (lambda () `((unquote 0 . 1))))
+ (assert-error (tn) (lambda () `(0 unquote)))
+ (assert-error (tn) (lambda () `(0 . (unquote))))
+ (assert-error (tn) (lambda () `(0 unquote 2 3)))
+ (assert-error (tn) (lambda () `(0 . (unquote 2 3))))
+ (assert-error (tn) (lambda () `(0 unquote 2 3 4)))
+ (assert-error (tn) (lambda () `(0 . (unquote 2 3 4))))
+ (assert-error (tn) (lambda () `(0 unquote . 0)))
+ (assert-error (tn) (lambda () `(0 . (unquote . 0))))
+ (assert-error (tn) (lambda () `(0 unquote 2 3 . 0)))
+ (assert-error (tn) (lambda () `(0 . (unquote 2 3 . 0))))
+ (assert-error (tn) (lambda () `(0 unquote 2 3 4 . 0)))
+ (assert-error (tn) (lambda () `(0 . (unquote 2 3 4 . 0))))))
+(tn "unquote-splicing implementation-dependent form")
+(if (provided? "sigscheme")
+ (begin
+ (assert-error (tn) (lambda () `(0 unquote-splicing)))
+ (assert-error (tn) (lambda () `(0 . (unquote-splicing))))
+ (assert-error (tn) (lambda () `(0 unquote-splicing 2 3)))
+ (assert-error (tn) (lambda () `(0 . (unquote-splicing 2 3))))
+ (assert-error (tn) (lambda () `(0 unquote-splicing 2 3 4)))
+ (assert-error (tn) (lambda () `(0 . (unquote-splicing 2 3 4))))
+ (assert-error (tn) (lambda () `(0 unquote-splicing . 0)))
+ (assert-error (tn) (lambda () `(0 . (unquote-splicing . 0))))
+ (assert-error (tn) (lambda () `(0 unquote-splicing 2 3 . 0)))
+ (assert-error (tn) (lambda () `(0 . (unquote-splicing 2 3 . 0))))
+ (assert-error (tn) (lambda () `(0 unquote-splicing 2 3 4 . 0)))
+ (assert-error (tn) (lambda () `(0 . (unquote-splicing 2 3 4 . 0))))
+ (assert-error (tn) (lambda () `((unquote-splicing))))
+ (assert-error (tn) (lambda () `((unquote-splicing . 0))))
+ (assert-error (tn) (lambda () `((unquote-splicing 0 1))))
+ (assert-error (tn) (lambda () `((unquote-splicing 0 . 1))))))
+
+(tn "quasiquote dotted list")
+(assert-equal? (tn) '(0 . '1) `(0 . '1))
+(assert-equal? (tn) '(0 . `1) `(0 . `1))
+(assert-equal? (tn) '(0 . 1) `(0 . ,1))
+(assert-equal? (tn) '(0 . (quote 1)) `(0 . '1))
+(assert-equal? (tn) '(0 . (quasiquote 1)) `(0 . `1))
+(assert-equal? (tn) '(0 . #(1)) `(0 . ,'#(1)))
+(assert-equal? (tn) '(0 . #(1)) `(0 . ,`#(1)))
+(assert-equal? (tn) '(0 . #(1 3)) `(0 . ,`#(1 ,(+ 1 2))))
+(assert-equal? (tn) '(0 . #(1 -1 -2)) `(0 . ,`#(1 ,@(list (- 1) (- 2)))))
+(assert-error (tn) (lambda () `(0 . ,@())))
+(assert-error (tn) (lambda () `(0 . ,@(list))))
+(assert-error (tn) (lambda () `(0 . ,@(list 1))))
+(assert-error (tn) (lambda () `(0 . ,@(list 1 2))))
+(assert-error (tn) (lambda () `(0 . ,@(list 1 2 3))))
+(assert-error (tn) (lambda () `(0 . ,@#t)))
+(assert-error (tn) (lambda () `(0 . , at 1)))
+(assert-error (tn) (lambda () `(0 . ,@#\a)))
+(assert-error (tn) (lambda () `(0 . ,@"str")))
+(assert-error (tn) (lambda () `(0 . ,@'sym)))
+(assert-error (tn) (lambda () `(0 . , at sym)))
+(assert-error (tn) (lambda () `(0 . , at var)))
+(assert-error (tn) (lambda () `(0 . ,@(lambda () #f))))
+(assert-error (tn) (lambda () `(0 . ,@(+ 1 2))))
+(assert-error (tn) (lambda () `(0 . ,@#(1 2))))
+(assert-error (tn) (lambda () `(0 . (unquote-splicing ()))))
+(assert-error (tn) (lambda () `(0 . (unquote-splicing (list)))))
+(assert-error (tn) (lambda () `(0 . (unquote-splicing (list 1)))))
+(assert-error (tn) (lambda () `(0 . (unquote-splicing (list 1 2)))))
+(assert-error (tn) (lambda () `(0 . (unquote-splicing (list 1 2 3)))))
+(assert-error (tn) (lambda () `(0 . (unquote-splicing #t))))
+(assert-error (tn) (lambda () `(0 . (unquote-splicing 1))))
+(assert-error (tn) (lambda () `(0 . (unquote-splicing #\a))))
+(assert-error (tn) (lambda () `(0 . (unquote-splicing "str"))))
+(assert-error (tn) (lambda () `(0 . (unquote-splicing 'sym))))
+(assert-error (tn) (lambda () `(0 . (unquote-splicing sym))))
+(assert-error (tn) (lambda () `(0 . (unquote-splicing var))))
+(assert-error (tn) (lambda () `(0 . (unquote-splicing (lambda () #f)))))
+(assert-error (tn) (lambda () `(0 . (unquote-splicing (+ 1 2)))))
+(assert-error (tn) (lambda () `(0 . (unquote-splicing #(1 2)))))
+
+(tn "unquote invalid form")
+
+(tn "unquote-splicing invalid form")
+(define sym 'sym)
+(define var 3)
+(assert-error (tn) (lambda () `,@()))
+(assert-error (tn) (lambda () `,@(list)))
+(assert-error (tn) (lambda () `,@(list 1)))
+(assert-error (tn) (lambda () `,@(list 1 2)))
+(assert-error (tn) (lambda () `,@(list 1 2 3)))
+(assert-error (tn) (lambda () `,@#t))
+(assert-error (tn) (lambda () `, at 1))
+(assert-error (tn) (lambda () `, at 1))
+(assert-error (tn) (lambda () `,@#\a))
+(assert-error (tn) (lambda () `,@"str"))
+(assert-error (tn) (lambda () `,@'sym))
+(assert-error (tn) (lambda () `, at sym))
+(assert-error (tn) (lambda () `, at var))
+(assert-error (tn) (lambda () `,@(lambda () #f)))
+(assert-error (tn) (lambda () `,@(+ 1 2)))
+(assert-error (tn) (lambda () `,@#(1 2)))
+(assert-error (tn) (lambda () `(,@#t)))
+(assert-error (tn) (lambda () `(, at 1)))
+(assert-error (tn) (lambda () `(,@#\a)))
+(assert-error (tn) (lambda () `(,@"str")))
+(assert-error (tn) (lambda () `(,@'sym)))
+(assert-error (tn) (lambda () `(, at sym)))
+(assert-error (tn) (lambda () `(, at var)))
+(assert-error (tn) (lambda () `(,@(lambda () #f))))
+(assert-error (tn) (lambda () `(,@(+ 1 2))))
+(assert-error (tn) (lambda () `(,@#(1 2))))
+
(total-report)
More information about the uim-commit
mailing list