[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.1-80-gad4bd7c

[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=ad4bd7c2c0c931a91160772e5ebf40af0f471874

The branch, stable-2.0 has been updated
       via  ad4bd7c2c0c931a91160772e5ebf40af0f471874 (commit)
       via  0dd8493cb33e69d202f93810a39279c988bd2d95 (commit)
      from  a02a606716d782e0351e5abc5b0f70ebc3d18ac8 (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 ad4bd7c2c0c931a91160772e5ebf40af0f471874
Author: Andy Wingo <address@hidden>
Date:   Sat May 21 18:29:03 2011 +0200

    fix define-module ordering
    
    * module/ice-9/boot-9.scm (define-module): Fix to load the #:use-module
      clauses in the order in which they appear in the define-module form.
      Thanks to Jan Nieuwenhuizen for the report.
    
    * test-suite/standalone/test-import-order: Add new test that
      define-module and use-modules resolve the interface in the right
      order.
    
    * test-suite/standalone/Makefile.am:
    * test-suite/standalone/test-import-order-a.scm:
    * test-suite/standalone/test-import-order-b.scm:
    * test-suite/standalone/test-import-order-c.scm:
    * test-suite/standalone/test-import-order-d.scm: Aux files.

commit 0dd8493cb33e69d202f93810a39279c988bd2d95
Author: Andy Wingo <address@hidden>
Date:   Sat May 21 13:12:44 2011 +0200

    (syntax foo) -> #'foo in goops
    
    * module/oop/goops.scm: Change instances of (syntax foo) to #'foo.

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

Summary of changes:
 module/ice-9/boot-9.scm                       |    6 +-
 module/oop/goops.scm                          |  152 ++++++++++++-------------
 test-suite/standalone/Makefile.am             |    5 +
 test-suite/standalone/test-import-order       |   31 +++++
 test-suite/standalone/test-import-order-a.scm |    4 +
 test-suite/standalone/test-import-order-b.scm |    4 +
 test-suite/standalone/test-import-order-c.scm |    4 +
 test-suite/standalone/test-import-order-d.scm |    4 +
 8 files changed, 128 insertions(+), 82 deletions(-)
 create mode 100755 test-suite/standalone/test-import-order
 create mode 100644 test-suite/standalone/test-import-order-a.scm
 create mode 100644 test-suite/standalone/test-import-order-b.scm
 create mode 100644 test-suite/standalone/test-import-order-c.scm
 create mode 100644 test-suite/standalone/test-import-order-d.scm

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 60d133f..539eac9 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3070,15 +3070,15 @@ module '(ice-9 q) '(make-q q-length))}."
          #`(#:filename 'f . #,(parse #'args imp exp rex rep aut)))
         ((#:use-module (name name* ...) . args)
          (and (and-map symbol? (syntax->datum #'(name name* ...))))
-         (parse #'args (cons #'((name name* ...)) imp) exp rex rep aut))
+         (parse #'args #`(#,@imp ((name name* ...))) exp rex rep aut))
         ((#:use-syntax (name name* ...) . args)
          (and (and-map symbol? (syntax->datum #'(name name* ...))))
          #`(#:transformer '(name name* ...)
-            . #,(parse #'args (cons #'((name name* ...)) imp) exp rex rep 
aut)))
+            . #,(parse #'args #`(#,@imp ((name name* ...))) exp rex rep aut)))
         ((#:use-module ((name name* ...) arg ...) . args)
          (and (and-map symbol? (syntax->datum #'(name name* ...))))
          (parse #'args
-                (cons #`((name name* ...) #,@(parse-iface #'(arg ...))) imp)
+                #`(#,@imp ((name name* ...) #,@(parse-iface #'(arg ...))))
                 exp rex rep aut))
         ((#:export (ex ...) . args)
          (parse #'args imp #`(#,@exp ex ...) rex rep aut))
diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index 2801aa2..1f9fd50 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -1,6 +1,6 @@
 ;;; installed-scm-file
 
-;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010 Free 
Software Foundation, Inc.
+;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003, 2006, 2009, 2010, 2011 Free 
Software Foundation, Inc.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
 ;;;; modify it under the terms of the GNU Lesser General Public
@@ -245,31 +245,28 @@
   (lambda (x)
     (syntax-case x ()
       ((_ (k arg rest ...) out ...)
-       (keyword? (syntax->datum (syntax k)))
-       (case (syntax->datum (syntax k))
+       (keyword? (syntax->datum #'k))
+       (case (syntax->datum #'k)
          ((#:getter #:setter)
-          (syntax
-           (define-class-pre-definition (rest ...)
-             out ...
-             (if (or (not (defined? 'arg))
-                     (not (is-a? arg <generic>)))
-                 (toplevel-define!
-                  'arg
-                  (ensure-generic (if (defined? 'arg) arg #f) 'arg))))))
+          #'(define-class-pre-definition (rest ...)
+              out ...
+              (if (or (not (defined? 'arg))
+                      (not (is-a? arg <generic>)))
+                  (toplevel-define!
+                   'arg
+                   (ensure-generic (if (defined? 'arg) arg #f) 'arg)))))
          ((#:accessor)
-          (syntax
-           (define-class-pre-definition (rest ...)
-             out ...
-             (if (or (not (defined? 'arg))
-                     (not (is-a? arg <accessor>)))
-                 (toplevel-define!
-                  'arg
-                  (ensure-accessor (if (defined? 'arg) arg #f) 'arg))))))
+          #'(define-class-pre-definition (rest ...)
+              out ...
+              (if (or (not (defined? 'arg))
+                      (not (is-a? arg <accessor>)))
+                  (toplevel-define!
+                   'arg
+                   (ensure-accessor (if (defined? 'arg) arg #f) 'arg)))))
          (else
-          (syntax
-           (define-class-pre-definition (rest ...) out ...)))))
+          #'(define-class-pre-definition (rest ...) out ...))))
       ((_ () out ...)
-       (syntax (begin out ...))))))
+       #'(begin out ...)))))
        
 ;; Some slot options require extra definitions to be made. In
 ;; particular, we want to make sure that the generic function objects
@@ -279,17 +276,17 @@
   (lambda (x)
     (syntax-case x ()
       ((_ () out ...)
-       (syntax (begin out ...)))
+       #'(begin out ...))
       ((_ (slot rest ...) out ...)
-       (keyword? (syntax->datum (syntax slot)))
-       (syntax (begin out ...)))
+       (keyword? (syntax->datum #'slot))
+       #'(begin out ...))
       ((_ (slot rest ...) out ...)
-       (identifier? (syntax slot))
-       (syntax (define-class-pre-definitions (rest ...)
-                 out ...)))
+       (identifier? #'slot)
+       #'(define-class-pre-definitions (rest ...)
+         out ...))
       ((_ ((slotname slotopt ...) rest ...) out ...)
-       (syntax (define-class-pre-definitions (rest ...) 
-                 out ... (define-class-pre-definition (slotopt ...))))))))
+       #'(define-class-pre-definitions (rest ...) 
+         out ... (define-class-pre-definition (slotopt ...)))))))
 
 (define-syntax define-class
   (syntax-rules ()
@@ -491,46 +488,46 @@
       (let lp ((ls args) (formals '()) (specializers '()))
         (syntax-case ls ()
           (((f s) . rest)
-           (and (identifier? (syntax f)) (identifier? (syntax s)))
-           (lp (syntax rest)
-               (cons (syntax f) formals)
-               (cons (syntax s) specializers)))
+           (and (identifier? #'f) (identifier? #'s))
+           (lp #'rest
+               (cons #'f formals)
+               (cons #'s specializers)))
           ((f . rest)
-           (identifier? (syntax f))
-           (lp (syntax rest)
-               (cons (syntax f) formals)
-               (cons (syntax <top>) specializers)))
+           (identifier? #'f)
+           (lp #'rest
+               (cons #'f formals)
+               (cons #'<top> specializers)))
           (()
            (list (reverse formals)
-                 (reverse (cons (syntax '()) specializers))))
+                 (reverse (cons #''() specializers))))
           (tail
-           (identifier? (syntax tail))
-           (list (append (reverse formals) (syntax tail))
-                 (reverse (cons (syntax <top>) specializers)))))))
+           (identifier? #'tail)
+           (list (append (reverse formals) #'tail)
+                 (reverse (cons #'<top> specializers)))))))
 
     (define (find-free-id exp referent)
       (syntax-case exp ()
         ((x . y)
-         (or (find-free-id (syntax x) referent)
-             (find-free-id (syntax y) referent)))
+         (or (find-free-id #'x referent)
+             (find-free-id #'y referent)))
         (x
-         (identifier? (syntax x))
-         (let ((id (datum->syntax (syntax x) referent)))
-           (and (free-identifier=? (syntax x) id) id)))
+         (identifier? #'x)
+         (let ((id (datum->syntax #'x referent)))
+           (and (free-identifier=? #'x id) id)))
         (_ #f)))
 
     (define (compute-procedure formals body)
       (syntax-case body ()
         ((body0 ...)
          (with-syntax ((formals formals))
-           (syntax (lambda formals body0 ...))))))
+           #'(lambda formals body0 ...)))))
 
     (define (->proper args)
       (let lp ((ls args) (out '()))
         (syntax-case ls ()
-          ((x . xs)        (lp (syntax xs) (cons (syntax x) out)))
+          ((x . xs)        (lp #'xs (cons #'x out)))
           (()              (reverse out))
-          (tail            (reverse (cons (syntax tail) out))))))
+          (tail            (reverse (cons #'tail out))))))
 
     (define (compute-make-procedure formals body next-method)
       (syntax-case body ()
@@ -538,24 +535,22 @@
          (with-syntax ((next-method next-method))
            (syntax-case formals ()
              ((formal ...)
-              (syntax
-               (lambda (real-next-method)
-                 (lambda (formal ...)
-                   (let ((next-method (lambda args
-                                        (if (null? args)
-                                            (real-next-method formal ...)
-                                            (apply real-next-method args)))))
-                     body ...)))))
+              #'(lambda (real-next-method)
+                  (lambda (formal ...)
+                    (let ((next-method (lambda args
+                                         (if (null? args)
+                                             (real-next-method formal ...)
+                                             (apply real-next-method args)))))
+                      body ...))))
              (formals
-              (with-syntax (((formal ...) (->proper (syntax formals))))
-                (syntax
-                 (lambda (real-next-method)
-                   (lambda formals
-                     (let ((next-method (lambda args
-                                          (if (null? args)
-                                              (apply real-next-method formal 
...)
-                                              (apply real-next-method args)))))
-                       body ...)))))))))))
+              (with-syntax (((formal ...) (->proper #'formals)))
+                #'(lambda (real-next-method)
+                    (lambda formals
+                      (let ((next-method (lambda args
+                                           (if (null? args)
+                                               (apply real-next-method formal 
...)
+                                               (apply real-next-method 
args)))))
+                        body ...))))))))))
 
     (define (compute-procedures formals body)
       ;; So, our use of this is broken, because it operates on the
@@ -564,28 +559,27 @@
       (let ((id (find-free-id body 'next-method)))
         (if id
             ;; return a make-procedure
-            (values (syntax #f)
+            (values #'#f
                     (compute-make-procedure formals body id))
             (values (compute-procedure formals body)
-                    (syntax #f)))))
+                    #'#f))))
 
     (syntax-case x ()
-      ((_ args) (syntax (method args (if #f #f))))
+      ((_ args) #'(method args (if #f #f)))
       ((_ args body0 body1 ...)
-       (with-syntax (((formals (specializer ...)) (parse-args (syntax args))))
+       (with-syntax (((formals (specializer ...)) (parse-args #'args)))
          (call-with-values
              (lambda ()
-               (compute-procedures (syntax formals) (syntax (body0 body1 
...))))
+               (compute-procedures #'formals #'(body0 body1 ...)))
            (lambda (procedure make-procedure)
              (with-syntax ((procedure procedure)
                            (make-procedure make-procedure))
-               (syntax
-                (make <method>
-                  #:specializers (cons* specializer ...)
-                  #:formals 'formals
-                  #:body '(body0 body1 ...)
-                  #:make-procedure make-procedure
-                  #:procedure procedure))))))))))
+               #'(make <method>
+                   #:specializers (cons* specializer ...)
+                   #:formals 'formals
+                   #:body '(body0 body1 ...)
+                   #:make-procedure make-procedure
+                   #:procedure procedure)))))))))
 
 ;;;
 ;;; {add-method!}
diff --git a/test-suite/standalone/Makefile.am 
b/test-suite/standalone/Makefile.am
index cf1fc4f..e239ac3 100644
--- a/test-suite/standalone/Makefile.am
+++ b/test-suite/standalone/Makefile.am
@@ -75,6 +75,11 @@ TESTS += test-require-extension
 check_SCRIPTS += test-guile-snarf
 TESTS += test-guile-snarf
 
+check_SCRIPTS += test-import-order
+TESTS += test-import-order
+EXTRA_DIST += test-import-order-a.scm test-import-order-b.scm \
+  test-import-order-c.scm test-import-order-d.scm
+
 # test-num2integral
 test_num2integral_SOURCES = test-num2integral.c
 test_num2integral_CFLAGS = ${test_cflags}
diff --git a/test-suite/standalone/test-import-order 
b/test-suite/standalone/test-import-order
new file mode 100755
index 0000000..333f2a4
--- /dev/null
+++ b/test-suite/standalone/test-import-order
@@ -0,0 +1,31 @@
+#!/bin/sh
+exec guile -q -L "$builddir" -s "$0" "$@"
+!#
+
+(define-module (base)
+  #:export (push! order))
+
+(define order '())
+(define (push!)
+  (set! order `(,@order ,(module-name (current-module)))))
+
+(define-module (test-1)
+  #:use-module (base)
+  #:use-module (test-import-order-a)
+  #:use-module (test-import-order-b))
+
+(use-modules (test-import-order-c) (test-import-order-d))
+
+(if (not (equal? order
+                 '((test-import-order-a)
+                   (test-import-order-b)
+                   (test-import-order-c)
+                   (test-import-order-d))))
+    (begin
+      (format (current-error-port) "Unexpected import order: ~a" order)
+      (exit 1))
+    (exit 0))
+
+;; Local Variables:
+;; mode: scheme
+;; End:
\ No newline at end of file
diff --git a/test-suite/standalone/test-import-order-a.scm 
b/test-suite/standalone/test-import-order-a.scm
new file mode 100644
index 0000000..d6fa29d
--- /dev/null
+++ b/test-suite/standalone/test-import-order-a.scm
@@ -0,0 +1,4 @@
+(define-module (test-import-order-a)
+  #:use-module (base))
+
+(push!)
diff --git a/test-suite/standalone/test-import-order-b.scm 
b/test-suite/standalone/test-import-order-b.scm
new file mode 100644
index 0000000..bc41bdf
--- /dev/null
+++ b/test-suite/standalone/test-import-order-b.scm
@@ -0,0 +1,4 @@
+(define-module (test-import-order-b)
+  #:use-module (base))
+
+(push!)
diff --git a/test-suite/standalone/test-import-order-c.scm 
b/test-suite/standalone/test-import-order-c.scm
new file mode 100644
index 0000000..4b58c3d
--- /dev/null
+++ b/test-suite/standalone/test-import-order-c.scm
@@ -0,0 +1,4 @@
+(define-module (test-import-order-c)
+  #:use-module (base))
+
+(push!)
diff --git a/test-suite/standalone/test-import-order-d.scm 
b/test-suite/standalone/test-import-order-d.scm
new file mode 100644
index 0000000..fb071be
--- /dev/null
+++ b/test-suite/standalone/test-import-order-d.scm
@@ -0,0 +1,4 @@
+(define-module (test-import-order-d)
+  #:use-module (base))
+
+(push!)


hooks/post-receive
-- 
GNU Guile