[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.7-194-gdfd1d3b

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

The branch, stable-2.0 has been updated
       via  dfd1d3b144d97522b2a4e82dc583a43e0b4f8b93 (commit)
      from  24475b860b02880b1cfdf4e03f9659a8af09eb72 (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 dfd1d3b144d97522b2a4e82dc583a43e0b4f8b93
Author: Andy Wingo <address@hidden>
Date:   Tue Mar 12 22:07:50 2013 +0100

    failing to load module in psyntax indicates an identifier is not macro
    
    * module/ice-9/boot-9.scm (false-if-exception): Add optional #:warning
      TEMPLATE ARG... tail, which indicates that we should print a warning
      on failure.
      (load-in-vicinity): Use the new #:warning.
      (make-autoload-interface): Surround the bits that load modules with a
      false-if-exception with #:warning.  Fixes
      http://debbugs.gnu.org/cgi/bugreport.cgi?bug=12202.
    
    * test-suite/tests/syncase.test ("missing autoloads do not foil
      psyntax"): Add a test.

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

Summary of changes:
 module/ice-9/boot-9.scm       |  107 +++++++++++++++++++++--------------------
 test-suite/tests/syncase.test |   12 ++++-
 2 files changed, 65 insertions(+), 54 deletions(-)

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 067d672..ed7ebea 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -947,10 +947,26 @@ VALUE."
 (define (and=> value procedure) (and value (procedure value)))
 (define call/cc call-with-current-continuation)
 
-(define-syntax-rule (false-if-exception expr)
-  (catch #t
-    (lambda () expr)
-    (lambda (k . args) #f)))
+(define-syntax false-if-exception
+  (syntax-rules ()
+    ((false-if-exception expr)
+     (catch #t
+       (lambda () expr)
+       (lambda args #f)))
+    ((false-if-exception expr #:warning template arg ...)
+     (catch #t
+       (lambda () expr)
+       (lambda (key . args)
+         (for-each (lambda (s)
+                     (if (not (string-null? s))
+                         (format (current-warning-port) ";;; ~a\n" s)))
+                   (string-split
+                    (call-with-output-string
+                     (lambda (port)
+                       (format port template arg ...)
+                       (print-exception port #f key args)))
+                    #\newline))
+         #f)))))
 
 
 
@@ -2786,16 +2802,18 @@ VALUE."
 
 (define (make-autoload-interface module name bindings)
   (let ((b (lambda (a sym definep)
-             (and (memq sym bindings)
-                  (let ((i (module-public-interface (resolve-module name))))
-                    (if (not i)
-                        (error "missing interface for module" name))
-                    (let ((autoload (memq a (module-uses module))))
-                      ;; Replace autoload-interface with actual interface if
-                      ;; that has not happened yet.
-                      (if (pair? autoload)
-                          (set-car! autoload i)))
-                    (module-local-variable i sym))))))
+             (false-if-exception
+              (and (memq sym bindings)
+                   (let ((i (module-public-interface (resolve-module name))))
+                     (if (not i)
+                         (error "missing interface for module" name))
+                     (let ((autoload (memq a (module-uses module))))
+                       ;; Replace autoload-interface with actual interface if
+                       ;; that has not happened yet.
+                       (if (pair? autoload)
+                           (set-car! autoload i)))
+                     (module-local-variable i sym)))
+              #:warning "Failed to autoload ~a in ~a:\n" sym name))))
     (module-constructor (make-hash-table 0) '() b #f #f name 'autoload #f
                         (make-hash-table 0) '() (make-weak-value-hash-table 
31) #f
                         (make-hash-table 0) #f #f #f)))
@@ -3750,15 +3768,6 @@ when none is available, reading FILE-NAME with READER."
      #:opts %auto-compilation-options
      #:env (current-module)))
 
-  (define (warn-about-exception key args)
-    (for-each (lambda (s)
-                (if (not (string-null? s))
-                    (format (current-warning-port) ";;; ~a\n" s)))
-              (string-split
-               (call-with-output-string
-                (lambda (port) (print-exception port #f key args)))
-               #\newline)))
-
   ;; Returns the .go file corresponding to `name'.  Does not search load
   ;; paths, only the fallback path.  If the .go file is missing or out
   ;; of date, and auto-compilation is enabled, will try
@@ -3775,30 +3784,25 @@ when none is available, reading FILE-NAME with READER."
     ;; Return GO-FILE-NAME after making sure that it contains a freshly
     ;; compiled version of source file NAME with stat SCMSTAT; return #f
     ;; on failure.
-    (catch #t
-      (lambda ()
-        (let ((gostat (and (not %fresh-auto-compile)
-                           (stat go-file-name #f))))
-          (if (and gostat (more-recent? gostat scmstat))
-              go-file-name
-              (begin
-                (if gostat
-                    (format (current-warning-port)
-                            ";;; note: source file ~a\n;;;       newer than 
compiled ~a\n"
-                            name go-file-name))
-                (cond
-                 (%load-should-auto-compile
-                  (%warn-auto-compilation-enabled)
-                  (format (current-warning-port) ";;; compiling ~a\n" name)
-                  (let ((cfn (compile name)))
-                    (format (current-warning-port) ";;; compiled ~a\n" cfn)
-                    cfn))
-                 (else #f))))))
-      (lambda (k . args)
-        (format (current-warning-port)
-                ";;; WARNING: compilation of ~a failed:\n" name)
-        (warn-about-exception k args)
-        #f)))
+    (false-if-exception
+     (let ((gostat (and (not %fresh-auto-compile)
+                        (stat go-file-name #f))))
+       (if (and gostat (more-recent? gostat scmstat))
+           go-file-name
+           (begin
+             (if gostat
+                 (format (current-warning-port)
+                         ";;; note: source file ~a\n;;;       newer than 
compiled ~a\n"
+                         name go-file-name))
+             (cond
+              (%load-should-auto-compile
+               (%warn-auto-compilation-enabled)
+               (format (current-warning-port) ";;; compiling ~a\n" name)
+               (let ((cfn (compile name)))
+                 (format (current-warning-port) ";;; compiled ~a\n" cfn)
+                 cfn))
+              (else #f)))))
+     #:warning "WARNING: compilation of ~a failed:\n" name))
 
   (define (sans-extension file)
     (let ((dot (string-rindex file #\.)))
@@ -3810,12 +3814,9 @@ when none is available, reading FILE-NAME with READER."
     ;; Load from ABS-FILE-NAME, using a compiled file or auto-compiling
     ;; if needed.
     (define scmstat
-      (catch #t
-        (lambda ()
-          (stat abs-file-name))
-        (lambda (key . args)
-          (warn-about-exception key args)
-          #f)))
+      (false-if-exception
+       (stat abs-file-name)
+       #:warning "Stat of ~a failed:\n" abs-file-name))
 
     (define (pre-compiled)
       (and=> (search-path %load-compiled-path (sans-extension file-name)
diff --git a/test-suite/tests/syncase.test b/test-suite/tests/syncase.test
index 0e81f65..b1b2922 100644
--- a/test-suite/tests/syncase.test
+++ b/test-suite/tests/syncase.test
@@ -1,6 +1,6 @@
 ;;;; syncase.test --- test suite for (ice-9 syncase)            -*- scheme -*-
 ;;;;
-;;;;   Copyright (C) 2001, 2006, 2009, 2010, 2011 Free Software Foundation, 
Inc.
+;;;;   Copyright (C) 2001, 2006, 2009, 2010, 2011, 2013 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
@@ -239,3 +239,13 @@
                  ((odd? x) (not (even? x)))))
              (even? 10))
           (current-module))))
+
+(define-module (test-suite test-syncase-3)
+  #:autoload (test-syncase-3-does-not-exist) (baz))
+
+(define-module (test-suite test-syncase)) ;; back to main module
+
+(pass-if "missing autoloads do not foil psyntax"
+  (parameterize ((current-warning-port (%make-void-port "w")))
+    (eval '(if #f (baz) #t)
+          (resolve-module '(test-suite test-syncase-3)))))


hooks/post-receive
-- 
GNU Guile