[Guile-commits] GNU Guile branch, syncase-in-boot-9, updated. a48358b38fed9486cebf7f8338dc05adc770fc0f

[Andy Wingo]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=a48358b38fed9486cebf7f8338dc05adc770fc0f

The branch, syncase-in-boot-9 has been updated
       via  a48358b38fed9486cebf7f8338dc05adc770fc0f (commit)
       via  d63927150aa22bb7e57125ed50e5ecbe11765fba (commit)
      from  47c8983f08157865a3937722c06acbbb3cbd7621 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit a48358b38fed9486cebf7f8338dc05adc770fc0f
Author: Andy Wingo <address@hidden>
Date:   Thu May 21 16:04:14 2009 +0200

    fix srfi-17.test
    
    * test-suite/tests/srfi-17.test (exception:bad-quote): Change the
      expected exception for (set! (quote foo) ...) errors.

commit d63927150aa22bb7e57125ed50e5ecbe11765fba
Author: Andy Wingo <address@hidden>
Date:   Thu May 21 15:34:29 2009 +0200

    just parse method arguments once.
    
    * module/oop/goops.scm (method): Tweak to just run through the arguments
      once. Thanks to Eli Barzilay for the tip.

-----------------------------------------------------------------------

Summary of changes:
 module/oop/goops.scm          |   38 ++++++++++++++++++++------------------
 test-suite/tests/srfi-17.test |    7 +++++--
 2 files changed, 25 insertions(+), 20 deletions(-)

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 8c98048..fd2d600 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -479,23 +479,26 @@
 
 (define-syntax method
   (lambda (x)
-    (define (compute-formals args)
-      (let lp ((ls args) (out '()))
-        (syntax-case ls ()
-          (((f s) . rest)  (lp (syntax rest) (cons (syntax f) out)))
-          ((f . rest)      (identifier? (syntax f))
-                           (lp (syntax rest) (cons (syntax f) out)))
-          (()              (reverse out))
-          (tail            (identifier? (syntax tail))
-                           (append (reverse out) (syntax tail))))))
-
-    (define (compute-specializers args)
-      (let lp ((ls args) (out '()))
+    (define (parse-args args)
+      (let lp ((ls args) (formals '()) (specializers '()))
         (syntax-case ls ()
-          (((f s) . rest)  (lp (syntax rest) (cons (syntax s) out)))
-          ((f . rest)      (lp (syntax rest) (cons (syntax <top>) out)))
-          (()              (reverse (cons (syntax '()) out)))
-          (tail            (reverse (cons (syntax <top>) out))))))
+          (((f s) . rest)
+           (and (identifier? (syntax f)) (identifier? (syntax s)))
+           (lp (syntax rest)
+               (cons (syntax f) formals)
+               (cons (syntax s) specializers)))
+          ((f . rest)
+           (identifier? (syntax f))
+           (lp (syntax rest)
+               (cons (syntax f) formals)
+               (cons (syntax <top>) specializers)))
+          (()
+           (list (reverse formals)
+                 (reverse (cons (syntax '()) specializers))))
+          (tail
+           (identifier? (syntax tail))
+           (list (append (reverse formals) (syntax tail))
+                 (reverse (cons (syntax <top>) specializers)))))))
 
     (define (find-free-id exp referent)
       (syntax-case exp ()
@@ -561,8 +564,7 @@
     (syntax-case x ()
       ((_ args) (syntax (method args (if #f #f))))
       ((_ args body0 body1 ...)
-       (with-syntax ((formals (compute-formals (syntax args)))
-                     ((specializer ...) (compute-specializers (syntax args))))
+       (with-syntax (((formals (specializer ...)) (parse-args (syntax args))))
          (call-with-values
              (lambda ()
                (compute-procedures (syntax formals) (syntax (body0 body1 
...))))
diff --git a/test-suite/tests/srfi-17.test b/test-suite/tests/srfi-17.test
index fbacb15..4841f2e 100644
--- a/test-suite/tests/srfi-17.test
+++ b/test-suite/tests/srfi-17.test
@@ -50,6 +50,9 @@
 
 (define %some-variable #f)
 
+(define exception:bad-quote
+  '(syntax-error . "quote: bad syntax"))
+
 (with-test-prefix "set!"
 
   (with-test-prefix "target is not procedure with setter"
@@ -59,7 +62,7 @@
       (set! (symbol->string 'x) 1))
 
     (pass-if-exception "(set! '#f 1)"
-      exception:bad-variable
+      exception:bad-quote
       (eval '(set! '#f 1) (interaction-environment))))
 
   (with-test-prefix "target uses macro"
@@ -72,7 +75,7 @@
     ;; The `(quote x)' below used to be memoized as an infinite list before
     ;; Guile 1.8.3.
     (pass-if-exception "(set! 'x 1)"
-      exception:bad-variable
+      exception:bad-quote
       (eval '(set! 'x 1) (interaction-environment)))))
 
 ;;


hooks/post-receive
-- 
GNU Guile