[uim-commit] r3008 - in branches/r5rs/sigscheme: . src test

yamaken at freedesktop.org yamaken at freedesktop.org
Fri Jan 27 17:29:29 PST 2006


Author: yamaken
Date: 2006-01-27 17:29:26 -0800 (Fri, 27 Jan 2006)
New Revision: 3008

Modified:
   branches/r5rs/sigscheme/TODO
   branches/r5rs/sigscheme/src/syntax.c
   branches/r5rs/sigscheme/test/test-quote.scm
Log:
* sigscheme/src/syntax.c
  - (qquote_internal):
    * Add form check for quasiquote, unquote and unquote-splicing
    * Simplify by depending on the "minimum mercy" policy
* sigscheme/test/test-quote.scm
  - Add tests for quasiquote
* sigscheme/TODO
  - Update


Modified: branches/r5rs/sigscheme/TODO
===================================================================
--- branches/r5rs/sigscheme/TODO	2006-01-28 00:21:59 UTC (rev 3007)
+++ branches/r5rs/sigscheme/TODO	2006-01-28 01:29:26 UTC (rev 3008)
@@ -18,9 +18,6 @@
   - All files except for operations-srfi1.c, storage-compact.h and
     test-compact.c are checked
 
-* Review and refactor some functions in syntax.c(qquote_internal) (other files
-  had already been done)
-
 * Make 64bit-safe
   - Write tests
   - Make the tests passed on actual 64bit environment with fatty representation

Modified: branches/r5rs/sigscheme/src/syntax.c
===================================================================
--- branches/r5rs/sigscheme/src/syntax.c	2006-01-28 00:21:59 UTC (rev 3007)
+++ branches/r5rs/sigscheme/src/syntax.c	2006-01-28 01:29:26 UTC (rev 3008)
@@ -1117,66 +1117,77 @@
 static qquote_result
 qquote_internal(ScmObj input, ScmObj env, scm_int_t nest)
 {
-    ScmObj obj;
+    ScmObj obj, form, args;
     sequence_translator tr;
-    qquote_result tmp_result;
-    qquote_result my_result;
+    qquote_result tmp_result, my_result;
     DECLARE_INTERNAL_FUNCTION("quasiquote");
 
     if (VECTORP(input)) {
-        TRV_INIT(tr, input);
+        for (TRV_INIT(tr, input); !TRV_ENDP(tr); TRV_NEXT(tr)) {
+            obj = TRV_GET_ELM(tr);
+            tmp_result = qquote_internal(obj, env, nest);
+            vectran(&tr, tmp_result.insn, tmp_result.obj);
+        }
     } else if (CONSP(input)) {
-        TRL_INIT(tr, input);
-        /* If INPUT has 2 or more elements, we process up to the
-         * penultimate item and see if the tail has the form (<syn>
-         * <datum>) where <syn> is unquote, unquote-splicing, or
-         * quasiquote.
-         */
-        if (CONSP(CDR(input))) {
-            for (; CONSP(CDDR(TRL_GET_SUBLS(tr))); TRL_NEXT(tr)) {
-                obj = TRL_GET_ELM(tr);
-                tmp_result = qquote_internal(obj, env, nest);
-                listran(&tr, tmp_result.insn, tmp_result.obj);
-            }
-            if (NULLP(CDDR(TRL_GET_SUBLS(tr)))) {
-                ScmObj form;
+        /* This implementation adopt "minimum mercy" interpretation depending
+         * on the R5RS specification cited below, to simplify the code.
+         * 
+         * 4.2.6 Quasiquotation
+         * Unpredictable behavior can result if any of the symbols quasiquote,
+         * unquote, or unquote-splicing appear in positions within a <qq
+         * template> otherwise than as described above. */
+        for (TRL_INIT(tr, input); !TRL_ENDP(tr); TRL_NEXT(tr)) {
+            form = TRL_GET_SUBLS(tr);
+            obj = CAR(form);
+            if (EQ(obj, SYM_QUASIQUOTE)) {
+                /* FORM == `x */
+                if (args = CDR(form), !LIST_1_P(args))
+                    ERR_OBJ("invalid quasiquote form", form);
 
-                form = TRL_GET_SUBLS(tr);
-                obj  = CAR(form);
+                ++nest;
+            } else if (EQ(obj, SYM_UNQUOTE)) {
+                /* FORM == ,x */
+                if (args = CDR(form), !LIST_1_P(args))
+                    ERR_OBJ("invalid unquote form", form);
 
-                if (EQ(obj, SYM_QUASIQUOTE)) {
-                    /* FORM == `x */
-                    ++nest;
-                } else if (EQ(obj, SYM_UNQUOTE)) {
-                    /* FORM == ,x */
-                    if (--nest == 0) {
-                        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;
-                    }
-                } else if (EQ(obj, SYM_UNQUOTE_SPLICING)) {
-                    /* FORM == , at x */
-                    if (!EQ(form, input)) /* (a . , at b) */
-                        ERR_OBJ(",@ in invalid context", input);
+                if (--nest == 0) {
+                    form = TRL_GET_SUBLS(tr);
+                    obj = EVAL(CAR(args), env);
+                    TRL_SET_SUBLS(tr, obj);
+                    my_result.obj  = TRL_EXTRACT(tr);
+                    my_result.insn = TR_MSG_REPLACE;
+                    return my_result;
+                }
+            } else if (EQ(obj, SYM_UNQUOTE_SPLICING)) {
+                /* FORM == , at x */
+                if (!EQ(form, input)) /* (a . , at b) */
+                    ERR_OBJ(",@ in invalid context", input);
+                if (args = CDR(form), !LIST_1_P(args))
+                    ERR_OBJ("invalid unquote-splicing form", form);
 
-                    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");
+                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(CAR(args), env);
+                    if (!LISTP(obj))
+                        ERR(",@<x> must evaluate to a list");
 
-                        my_result.obj  = obj;
-                        my_result.insn = TR_MSG_SPLICE;
-                        return my_result;
-                    }
+                    my_result.obj  = obj;
+                    my_result.insn = TR_MSG_SPLICE;
+                    return my_result;
                 }
             }
+            tmp_result = qquote_internal(obj, env, nest);
+            listran(&tr, tmp_result.insn, tmp_result.obj);
         }
+        /* Interpret the tail if an improper list. */
+        if (!NULLP(TRL_GET_SUBLS(tr))) {
+            tmp_result = qquote_internal(TRL_GET_SUBLS(tr), env, nest);
+            if (tmp_result.insn != TR_MSG_NOP)
+                TRL_SET_SUBLS(tr, tmp_result.obj);
+        }
     } else {
         /* An atomic datum. */
         tmp_result.obj  = SCM_INVALID;
@@ -1184,20 +1195,6 @@
         return tmp_result;
     }
 
-    /* Process all the other elements. */
-    for (; !TR_ENDP(tr); TR_NEXT(tr)) {
-        obj = TR_GET_ELM(tr);
-        tmp_result = qquote_internal(obj, env, nest);
-        TR_CALL(tr, tmp_result.insn, tmp_result.obj);
-    }
-
-    /* Interpret the tail if an improper list. */
-    if (CONSP(input) && !NULLP(TRL_GET_SUBLS(tr))) {
-        tmp_result = qquote_internal(TRL_GET_SUBLS(tr), env, nest);
-        if (tmp_result.insn != TR_MSG_NOP)
-            TRL_SET_SUBLS(tr, tmp_result.obj);
-    }
-
     my_result.obj = TR_EXTRACT(tr);
     my_result.insn = VALIDP(my_result.obj) ? TR_MSG_REPLACE : TR_MSG_NOP;
     return my_result;

Modified: branches/r5rs/sigscheme/test/test-quote.scm
===================================================================
--- branches/r5rs/sigscheme/test/test-quote.scm	2006-01-28 00:21:59 UTC (rev 3007)
+++ branches/r5rs/sigscheme/test/test-quote.scm	2006-01-28 01:29:26 UTC (rev 3008)
@@ -138,7 +138,49 @@
 (assert-equal? (tn) '(1 2)   `(,@(list 1 2)))
 (assert-equal? (tn) '(1 2 3) `(,@(list 1 2 3)))
 
+(tn "quasiquote nested")
+(assert-equal? (tn)
+               '((quasiquote q) q)
+               `(`q ,`q))
+(assert-equal? (tn)
+               '((quasiquote q) (q (quasiquote q)))
+               `(`q ,`(q `q)))
+(assert-equal? (tn)
+               '((quasiquote q) (q q))
+               `(`q ,`(q ,`q)))
+(assert-equal? (tn)
+               '((quasiquote q) (q q (quasiquote q)))
+               `(`q ,`(q ,`q `q)))
+(assert-equal? (tn)
+               '((quasiquote q) (q q (quasiquote (unquote q))))
+               `(`q ,`(q ,`q `,q)))
+(assert-equal? (tn)
+               '((quasiquote q) (q q (quasiquote (unquote (quasiquote q)))))
+               `(`q ,`(q ,`q `,`q)))
+(assert-equal? (tn)
+               '((quasiquote q) (q q (quasiquote (unquote q))))
+               `(`q ,`(q ,`q `,,`q)))
+
 ;; R5RS allows these forms to be an error
+(tn "quasiquote implementation-dependent form")
+(if (provided? "sigscheme")
+    (begin
+      (assert-error  (tn) (lambda () `((quasiquote))))
+      (assert-error  (tn) (lambda () `((quasiquote . 0))))
+      (assert-error  (tn) (lambda () `((quasiquote 0 1))))
+      (assert-error  (tn) (lambda () `((quasiquote 0 . 1))))
+      (assert-error  (tn) (lambda () `(0 quasiquote)))
+      (assert-error  (tn) (lambda () `(0 . (quasiquote))))
+      (assert-error  (tn) (lambda () `(0 quasiquote 2 3)))
+      (assert-error  (tn) (lambda () `(0 . (quasiquote 2 3))))
+      (assert-error  (tn) (lambda () `(0 quasiquote 2 3 4)))
+      (assert-error  (tn) (lambda () `(0 . (quasiquote 2 3 4))))
+      (assert-error  (tn) (lambda () `(0 quasiquote . 0)))
+      (assert-error  (tn) (lambda () `(0 . (quasiquote . 0))))
+      (assert-error  (tn) (lambda () `(0 quasiquote 2 3 . 0)))
+      (assert-error  (tn) (lambda () `(0 . (quasiquote 2 3 . 0))))
+      (assert-error  (tn) (lambda () `(0 quasiquote 2 3 4 . 0)))
+      (assert-error  (tn) (lambda () `(0 . (quasiquote 2 3 4 . 0))))))
 (tn "unquote implementation-dependent form")
 (if (provided? "sigscheme")
     (begin



More information about the uim-commit mailing list