[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-10-36-g22
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-10-36-g22457d5 |
|
Date: |
Mon, 19 Apr 2010 14:49:56 +0000 |
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=22457d5730b2d5302c55a8f1f4c07470be975021
The branch, master has been updated
via 22457d5730b2d5302c55a8f1f4c07470be975021 (commit)
via 0abc21094420dc00312cfa74788e5d9c1524b04a (commit)
from b9e67767ae7f7544563286f731b135435967fa26 (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 22457d5730b2d5302c55a8f1f4c07470be975021
Author: Andy Wingo <address@hidden>
Date: Mon Apr 19 16:39:11 2010 +0200
filesystem trickery to scm_i_relativize_path in filesys.c; bugfix.
* libguile/filesys.h:
* libguile/filesys.c (scm_i_relativize_path): New function, moved here
from fports.c. Internal for now; we can make it external though if
people like its interface.
* libguile/fports.c (fport_canonicalize_filename): Move all of the
tricky bits to filesys.c. Also fixes a bug in which a delimiter wasn't
stripped.
commit 0abc21094420dc00312cfa74788e5d9c1524b04a
Author: Andy Wingo <address@hidden>
Date: Mon Apr 19 14:00:23 2010 +0200
deprecate @bind
* module/ice-9/boot-9.scm:
* module/ice-9/deprecated.scm (@bind): Deprecate @bind, which was a
thread-unsafe dynamic scoping mechanism, used in the old elisp
support. Fluids are more correct, and are probably faster, given the
VM support for with-fluids.
* test-suite/tests/dynamic-scope.test: Remove.
* test-suite/tests/fluids.test: Move relevant tests from
dynamic-scope.test here, recast in terms of with-fluids.
-----------------------------------------------------------------------
Summary of changes:
libguile/filesys.c | 46 ++++++++++++++++++
libguile/filesys.h | 3 +-
libguile/fports.c | 31 +++---------
module/ice-9/boot-9.scm | 32 -------------
module/ice-9/deprecated.scm | 38 +++++++++++++++-
test-suite/tests/dynamic-scope.test | 88 -----------------------------------
test-suite/tests/fluids.test | 56 ++++++++++++++++++++++
7 files changed, 148 insertions(+), 146 deletions(-)
delete mode 100644 test-suite/tests/dynamic-scope.test
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 0dbcc2b..68d90d9 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1654,6 +1654,52 @@ SCM_DEFINE (scm_canonicalize_path, "canonicalize-path",
1, 0, 0,
}
#undef FUNC_NAME
+SCM
+scm_i_relativize_path (SCM path, SCM in_path)
+{
+ char *str, *canon;
+ SCM scanon;
+
+ str = scm_to_locale_string (path);
+ canon = canonicalize_file_name (str);
+ free (str);
+
+ if (!canon)
+ return SCM_BOOL_F;
+
+ scanon = scm_take_locale_string (canon);
+
+ for (; scm_is_pair (in_path); in_path = scm_cdr (in_path))
+ if (scm_is_true (scm_string_prefix_p (scm_car (in_path),
+ scanon,
+ SCM_UNDEFINED, SCM_UNDEFINED,
+ SCM_UNDEFINED, SCM_UNDEFINED)))
+ {
+ size_t len = scm_c_string_length (scm_car (in_path));
+
+ /* The path either has a trailing delimiter or doesn't. scanon will be
+ delimited by single delimiters. In the case in which the path does
+ not have a trailing delimiter, add one to the length to strip off
the
+ delimiter within scanon. */
+ if (!len
+#ifdef __MINGW32__
+ || (scm_i_string_ref (scm_car (in_path), len - 1) != '/'
+ && scm_i_string_ref (scm_car (in_path), len - 1) != '\\')
+#else
+ || scm_i_string_ref (scm_car (in_path), len - 1) != '/'
+#endif
+ )
+ len++;
+
+ if (scm_c_string_length (scanon) > len)
+ return scm_substring (scanon, scm_from_size_t (len), SCM_UNDEFINED);
+ else
+ return SCM_BOOL_F;
+ }
+
+ return SCM_BOOL_F;
+}
+
diff --git a/libguile/filesys.h b/libguile/filesys.h
index a07f204..967ce74 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -3,7 +3,7 @@
#ifndef SCM_FILESYS_H
#define SCM_FILESYS_H
-/* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008, 2009 Free Software
Foundation, Inc.
+/* Copyright (C) 1995,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2010 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 License
@@ -66,6 +66,7 @@ SCM_API SCM scm_copy_file (SCM oldfile, SCM newfile);
SCM_API SCM scm_dirname (SCM filename);
SCM_API SCM scm_basename (SCM filename, SCM suffix);
SCM_API SCM scm_canonicalize_path (SCM path);
+SCM_INTERNAL SCM scm_i_relativize_path (SCM path, SCM in_path);
SCM_INTERNAL void scm_init_filesys (void);
diff --git a/libguile/fports.c b/libguile/fports.c
index 800e863..d541d95 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -281,30 +281,13 @@ fport_canonicalize_filename (SCM filename)
}
else if (scm_is_eq (mode, sym_relative))
{
- char *str, *canon;
- SCM scanon, load_path;
-
- str = scm_to_locale_string (filename);
- canon = canonicalize_file_name (str);
- free (str);
-
- if (!canon)
- return filename;
-
- scanon = scm_take_locale_string (canon);
-
- for (load_path = scm_variable_ref
- (scm_c_module_lookup (scm_the_root_module (), "%load-path"));
- scm_is_pair (load_path);
- load_path = scm_cdr (load_path))
- if (scm_is_true (scm_string_prefix_p (scm_car (load_path),
- scanon,
- SCM_UNDEFINED, SCM_UNDEFINED,
- SCM_UNDEFINED, SCM_UNDEFINED)))
- return scm_substring (scanon,
- scm_string_length (scm_car (load_path)),
- SCM_UNDEFINED);
- return filename;
+ SCM path, rel;
+
+ path = scm_variable_ref (scm_c_module_lookup (scm_the_root_module (),
+ "%load-path"));
+ rel = scm_i_relativize_path (filename, path);
+
+ return scm_is_true (rel) ? rel : filename;
}
else if (scm_is_eq (mode, sym_absolute))
{
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index ffd1f68..4beec1e 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -470,38 +470,6 @@ If there is no handler at all, Guile prints an error and
then exits."
(include-from-path "ice-9/quasisyntax")
-;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
-;;; Please let the Guile developers know if you are using this macro.
-;;;
-(define-syntax @bind
- (lambda (x)
- (define (bound-member id ids)
- (cond ((null? ids) #f)
- ((bound-identifier=? id (car ids)) #t)
- ((bound-member (car ids) (cdr ids)))))
-
- (syntax-case x ()
- ((_ () b0 b1 ...)
- #'(let () b0 b1 ...))
- ((_ ((id val) ...) b0 b1 ...)
- (and-map identifier? #'(id ...))
- (if (let lp ((ids #'(id ...)))
- (cond ((null? ids) #f)
- ((bound-member (car ids) (cdr ids)) #t)
- (else (lp (cdr ids)))))
- (syntax-violation '@bind "duplicate bound identifier" x)
- (with-syntax (((old-v ...) (generate-temporaries #'(id ...)))
- ((v ...) (generate-temporaries #'(id ...))))
- #'(let ((old-v id) ...
- (v val) ...)
- (dynamic-wind
- (lambda ()
- (set! id v) ...)
- (lambda () b0 b1 ...)
- (lambda ()
- (set! id old-v) ...)))))))))
-
-
;;; {Defmacros}
diff --git a/module/ice-9/deprecated.scm b/module/ice-9/deprecated.scm
index 081f3f8..02ba537 100644
--- a/module/ice-9/deprecated.scm
+++ b/module/ice-9/deprecated.scm
@@ -36,7 +36,9 @@
$sinh
$cosh
$tanh
- closure?))
+ closure?
+ %nil
+ @bind))
;;;; Deprecated definitions.
@@ -260,3 +262,37 @@
(procedure? x))
(define %nil #nil)
+
+;;; @bind is used by the old elisp code as a dynamic scoping mechanism.
+;;; Please let the Guile developers know if you are using this macro.
+;;;
+(define-syntax @bind
+ (lambda (x)
+ (define (bound-member id ids)
+ (cond ((null? ids) #f)
+ ((bound-identifier=? id (car ids)) #t)
+ ((bound-member (car ids) (cdr ids)))))
+
+ (issue-deprecation-warning
+ "address@hidden' is deprecated. Use `with-fluids' instead.")
+
+ (syntax-case x ()
+ ((_ () b0 b1 ...)
+ #'(let () b0 b1 ...))
+ ((_ ((id val) ...) b0 b1 ...)
+ (and-map identifier? #'(id ...))
+ (if (let lp ((ids #'(id ...)))
+ (cond ((null? ids) #f)
+ ((bound-member (car ids) (cdr ids)) #t)
+ (else (lp (cdr ids)))))
+ (syntax-violation '@bind "duplicate bound identifier" x)
+ (with-syntax (((old-v ...) (generate-temporaries #'(id ...)))
+ ((v ...) (generate-temporaries #'(id ...))))
+ #'(let ((old-v id) ...
+ (v val) ...)
+ (dynamic-wind
+ (lambda ()
+ (set! id v) ...)
+ (lambda () b0 b1 ...)
+ (lambda ()
+ (set! id old-v) ...)))))))))
diff --git a/test-suite/tests/dynamic-scope.test
b/test-suite/tests/dynamic-scope.test
deleted file mode 100644
index 08cf1c4..0000000
--- a/test-suite/tests/dynamic-scope.test
+++ /dev/null
@@ -1,88 +0,0 @@
-;;;; -*- scheme -*-
-;;;; dynamic-scop.test --- test suite for dynamic scoping constructs
-;;;;
-;;;; Copyright (C) 2001, 2006, 2009 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
-;;;; License as published by the Free Software Foundation; either
-;;;; version 3 of the License, or (at your option) any later version.
-;;;;
-;;;; This library is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-;;;; Lesser General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU Lesser General Public
-;;;; License along with this library; if not, write to the Free Software
-;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-
-(define-module (test-suite test-dynamic-scope)
- :use-module (test-suite lib))
-
-
-(define exception:syntax-error
- (cons 'syntax-error "failed to match"))
-(define exception:duplicate-binding
- (cons 'syntax-error "duplicate"))
-
-(define global-a 0)
-(define (fetch-global-a) global-a)
-
-(with-test-prefix "dynamic scope"
-
- (pass-if "@bind binds"
- (= (@bind ((global-a 1)) (fetch-global-a)) 1))
-
- (pass-if "@bind unbinds"
- (begin
- (set! global-a 0)
- (@bind ((global-a 1)) (fetch-global-a))
- (= global-a 0)))
-
- (pass-if-exception "duplicate @binds"
- exception:duplicate-binding
- (eval '(@bind ((a 1) (a 2)) (+ a a))
- (interaction-environment)))
-
- (pass-if-exception "@bind missing expression"
- exception:syntax-error
- (eval '(@bind ((global-a 1)))
- (interaction-environment)))
-
- (pass-if-exception "@bind bad bindings"
- exception:syntax-error
- (eval '(@bind (a) #f)
- (interaction-environment)))
-
- (pass-if-exception "@bind bad bindings"
- exception:syntax-error
- (eval '(@bind ((a)) #f)
- (interaction-environment)))
-
- (pass-if "@bind and dynamic-wind"
- (letrec ((co-routine #f)
- (spawn (lambda (proc)
- (set! co-routine proc)))
- (yield (lambda (val)
- (call-with-current-continuation
- (lambda (k)
- (let ((next co-routine))
- (set! co-routine k)
- (next val)))))))
-
- (spawn (lambda (val)
- (@bind ((global-a 'inside))
- (yield global-a)
- (yield global-a))))
-
- (set! global-a 'outside)
- (let ((inside-a (yield #f)))
- (let ((outside-a global-a))
- (let ((inside-a2 (yield #f)))
- (and (eq? inside-a 'inside)
- (eq? outside-a 'outside)
- (eq? inside-a2 'inside))))))))
-
-
-
diff --git a/test-suite/tests/fluids.test b/test-suite/tests/fluids.test
index 3784e54..8604dcb 100644
--- a/test-suite/tests/fluids.test
+++ b/test-suite/tests/fluids.test
@@ -21,10 +21,31 @@
:use-module (test-suite lib))
+(define exception:syntax-error
+ (cons 'syntax-error "failed to match"))
+(define exception:duplicate-binding
+ (cons 'syntax-error "duplicate"))
+
(define a (make-fluid))
(define b (make-fluid))
(define c #f)
+(with-test-prefix "syntax"
+ (pass-if-exception "with-fluids missing expression"
+ exception:syntax-error
+ (eval '(with-fluids ((a 1)))
+ (interaction-environment)))
+
+ (pass-if-exception "with-fluids bad bindings"
+ exception:syntax-error
+ (eval '(with-fluids (a) #f)
+ (interaction-environment)))
+
+ (pass-if-exception "with-fluids bad bindings"
+ exception:syntax-error
+ (eval '(with-fluids ((a)) #f)
+ (interaction-environment))))
+
(with-test-prefix "initial fluid values"
(pass-if "fluid-ref uninitialized fluid is #f"
(not (fluid-ref a)))
@@ -91,3 +112,38 @@
(loop (1- i)))))
(gc)
(fluid? (g))))
+
+(with-test-prefix "with-fluids"
+
+ (pass-if "with-fluids binds"
+ (= (with-fluids ((a 1)) (fluid-ref a)) 1))
+
+ (pass-if "with-fluids unbinds"
+ (begin
+ (fluid-set! a 0)
+ (with-fluids ((a 1)) (fluid-ref a))
+ (= (fluid-ref a) 0)))
+
+ (pass-if "with-fluids and dynamic-wind"
+ (letrec ((co-routine #f)
+ (spawn (lambda (proc)
+ (set! co-routine proc)))
+ (yield (lambda (val)
+ (call-with-current-continuation
+ (lambda (k)
+ (let ((next co-routine))
+ (set! co-routine k)
+ (next val)))))))
+
+ (spawn (lambda (val)
+ (with-fluids ((a 'inside))
+ (yield (fluid-ref a))
+ (yield (fluid-ref a)))))
+
+ (fluid-set! a 'outside)
+ (let ((inside-a (yield #f)))
+ (let ((outside-a (fluid-ref a)))
+ (let ((inside-a2 (yield #f)))
+ (and (eq? inside-a 'inside)
+ (eq? outside-a 'outside)
+ (eq? inside-a2 'inside))))))))
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-10-36-g22457d5,
Andy Wingo <=