[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.6-27-gb6aedd6

[Ludovic Courtès]

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=b6aedd68bcbb07c9c6fd60e10cde314b68b0e1e9

The branch, stable-2.0 has been updated
       via  b6aedd68bcbb07c9c6fd60e10cde314b68b0e1e9 (commit)
       via  e7350baf1e93d68eb7dc23fc16f711c066cb37ec (commit)
      from  985538837806ab8dadfe3c01388355b9f551a303 (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 b6aedd68bcbb07c9c6fd60e10cde314b68b0e1e9
Author: Ludovic Courtès <address@hidden>
Date:   Tue Sep 11 23:44:59 2012 +0200

    Don't stat(2) and access(2) the .go location before using it.
    
    * module/system/base/compile.scm (ensure-directory): Rename to...
      (ensure-directory): ... this.  Update callers.  When ERRNO is EEXIST,
      assume DIR is a writable directory instead of calling `stat' and
      `access?' again.  Fixes UID/EUID mismatches for setuid binaries.
      Reported by address@hidden at
      <http://lists.gnu.org/archive/html/guile-user/2012-06/msg00023.html>.

commit e7350baf1e93d68eb7dc23fc16f711c066cb37ec
Author: Ludovic Courtès <address@hidden>
Date:   Tue Sep 11 23:39:32 2012 +0200

    Rewrite SRFI-31 in terms of `syntax-rules'.
    
    * module/srfi/srfi-31.scm: Use `#:export' instead of `#:export-syntax'.
      (rec): Rewrite using `syntax-rules'.
    
    * test-suite/tests/srfi-31.test ("rec special form"): Change exception
      type to EXCEPTION:SYNTAX-PATTERN-UNMATCHED.

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

Summary of changes:
 module/srfi/srfi-31.scm        |   26 ++++++++++++--------------
 module/system/base/compile.scm |   19 +++++++++----------
 test-suite/tests/srfi-31.test  |    7 ++++---
 3 files changed, 25 insertions(+), 27 deletions(-)

diff --git a/module/srfi/srfi-31.scm b/module/srfi/srfi-31.scm
index 4238dc2..cf67e8a 100644
--- a/module/srfi/srfi-31.scm
+++ b/module/srfi/srfi-31.scm
@@ -1,6 +1,6 @@
 ;;; srfi-31.scm --- special form for recursive evaluation
 
-;;     Copyright (C) 2004, 2006 Free Software Foundation, Inc.
+;;     Copyright (C) 2004, 2006, 2012 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
@@ -19,17 +19,15 @@
 ;;; Original author: Rob Browning <address@hidden>
 
 (define-module (srfi srfi-31)
-  :export-syntax (rec))
+  #:export (rec))
 
-(define-macro (rec arg-form . body)
-  (cond
-   ((and (symbol? arg-form) (= 1 (length body)))
-    ;; (rec S (cons 1 (delay S)))
-    `(letrec ((,arg-form ,(car body)))
-       ,arg-form))
-   ;; (rec (f x) (+ x 1))
-   ((list? arg-form)
-    `(letrec ((,(car arg-form) (lambda ,(cdr arg-form) ,@body)))
-       ,(car arg-form)))
-   (else
-    (error "syntax error in rec form" `(rec ,arg-form ,@body)))))
+(define-syntax rec
+  (syntax-rules ()
+    "Return the given object, defined in a lexical environment where
+NAME is bound to itself."
+    ((_ (name . formals) body ...)                ; procedure
+     (letrec ((name (lambda formals body ...)))
+       name))
+    ((_ name expr)                                ; arbitrary object
+     (letrec ((name expr))
+       name))))
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index 0bc11a3..afcb55a 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -1,6 +1,6 @@
 ;;; High-level compiler interface
 
-;; Copyright (C) 2001, 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2001, 2009, 2010, 2011, 2012 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
@@ -72,7 +72,7 @@
 ;; before the check, so that we avoid races (possibly due to parallel
 ;; compilation).
 ;;
-(define (ensure-writable-dir dir)
+(define (ensure-directory dir)
   (catch 'system-error
     (lambda ()
       (mkdir dir))
@@ -80,13 +80,12 @@
       (let ((errno (and (pair? rest) (car rest))))
         (cond
          ((eqv? errno EEXIST)
-          (let ((st (stat dir)))
-            (if (or (not (eq? (stat:type st) 'directory))
-                    (not (access? dir W_OK)))
-                (error "directory not writable" dir))))
+          ;; Assume it's a writable directory, to avoid TOCTOU errors,
+          ;; as well as UID/EUID mismatches that occur with access(2).
+          #t)
          ((eqv? errno ENOENT)
-          (ensure-writable-dir (dirname dir))
-          (ensure-writable-dir dir))
+          (ensure-directory (dirname dir))
+          (ensure-directory dir))
          (else
           (throw k subr fmt args rest)))))))
 
@@ -125,7 +124,7 @@
                  %compile-fallback-path
                  (canonical->suffix (canonicalize-path file))
                  (compiled-extension))))
-         (and (false-if-exception (ensure-writable-dir (dirname f)))
+         (and (false-if-exception (ensure-directory (dirname f)))
               f))))
 
 (define* (compile-file file #:key
@@ -144,7 +143,7 @@
       ;; Choose the input encoding deterministically.
       (set-port-encoding! in (or enc "UTF-8"))
 
-      (ensure-writable-dir (dirname comp))
+      (ensure-directory (dirname comp))
       (call-with-output-file/atomic comp
         (lambda (port)
           ((language-printer (ensure-language to))
diff --git a/test-suite/tests/srfi-31.test b/test-suite/tests/srfi-31.test
index 8537d49..62645d9 100644
--- a/test-suite/tests/srfi-31.test
+++ b/test-suite/tests/srfi-31.test
@@ -1,6 +1,6 @@
 ;;;; srfi-31.test --- Test suite for Guile's SRFI-31 functions. -*- scheme -*-
 ;;;;
-;;;; Copyright (C) 2004, 2006, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2004, 2006, 2010, 2012 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
@@ -22,9 +22,10 @@
 
 (with-test-prefix "rec special form"
 
-  (pass-if-exception "bogus variable" '(misc-error . ".*")
+  (pass-if-exception "bogus variable"
+    exception:syntax-pattern-unmatched
     (eval '(rec #:foo) (current-module)))
-  
+
   (pass-if "rec expressions"
     (let ((ones-list (rec ones (cons 1 (delay ones)))))
       (and (= 1 (car ones-list))


hooks/post-receive
-- 
GNU Guile