[Guile-commits] GNU Guile branch, master, updated. release_1-9-9-61-g01ad5a7

[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=01ad5a7ba9edb5d8c96567ed80ea1a34019c5338

The branch, master has been updated
       via  01ad5a7ba9edb5d8c96567ed80ea1a34019c5338 (commit)
       via  4551e860f02244ffb3858c941319f1613bac40e4 (commit)
       via  b577bc90bbaadfac508acc809e59b983db33b7aa (commit)
       via  1606312f9a1200950336d485bd29866c0f8e3942 (commit)
       via  6c76da4c32dd8a2c1f38d51df6e58dcc0b7cee11 (commit)
      from  e39d0b76684ae8e6f2bffa511e28ff2c2d44a106 (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 01ad5a7ba9edb5d8c96567ed80ea1a34019c5338
Author: Ludovic Courtès <address@hidden>
Date:   Fri Apr 9 00:30:10 2010 +0200

    Raise an error when attempting to modify the value of `%null-pointer'.
    
    * libguile/foreign.c (sym_null_pointer_error): New variable.
      (null_pointer_error): New function.
      (scm_foreign_set_x): Raise an error if attempting to modify
      NULL_POINTER.
      (scm_foreign_to_bytevector): Use `null_pointer_error ()' instead of
      `scm_misc_error ()'.
    
    * test-suite/tests/foreign.test: New file.
    
    * test-suite/Makefile.am (SCM_TESTS): Add tests/foreign.test.
    
    * test-suite/lib.scm (exception:null-pointer-error): New variable.

commit 4551e860f02244ffb3858c941319f1613bac40e4
Author: Ludovic Courtès <address@hidden>
Date:   Fri Apr 9 00:14:34 2010 +0200

    Allocate foreign pointer objects in GC-scanned memory.
    
    * libguile/foreign.c (scm_take_foreign_pointer): Allocate RET in
      GC-scanned memory.  This fixes a bug where the object pointed to by
      SCM_CIF in the pair returned by `cif_to_procedure ()' would be
      reclaimed (as a consequence of commit
      087aa6aa312a8d0af51fa9b2f7bfc1332ad97338).

commit b577bc90bbaadfac508acc809e59b983db33b7aa
Author: Ludovic Courtès <address@hidden>
Date:   Fri Apr 9 00:01:38 2010 +0200

    Avoid obsolescent C declarator with empty parentheses.
    
    * libguile/foreign.c (scm_i_foreign_call): Don't declare FUNC with a
      declarator with empty parentheses (bug #23681).

commit 1606312f9a1200950336d485bd29866c0f8e3942
Author: Ludovic Courtès <address@hidden>
Date:   Thu Apr 8 19:17:25 2010 +0200

    Fix `module-reverse-lookup'.
    
    * libguile/modules.c (scm_module_reverse_lookup): Type-check VARIABLE.
      Don't traverse the `uses' list when MODULE is #f.
    
    * test-suite/tests/modules.test ("foundations")["module-reverse-lookup
      [pre-module-obarray]", "module-reverse-lookup [wrong-type-arg]"]: New
      tests.

commit 6c76da4c32dd8a2c1f38d51df6e58dcc0b7cee11
Author: Ludovic Courtès <address@hidden>
Date:   Thu Apr 8 23:55:41 2010 +0200

    Remove `fold' from (sxml fold).
    
    * module/sxml/fold.scm: Use (srfi srfi-1).
      (fold): Remove.
      (fold-values): Update docstring accordingly.
    
    * test-suite/tests/sxml.fold.test: Use (srfi srfi-1).

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

Summary of changes:
 libguile/foreign.c              |   28 +++++++++++++-----
 libguile/modules.c              |   27 ++++++++++--------
 module/sxml/fold.scm            |   15 ++--------
 test-suite/Makefile.am          |    1 +
 test-suite/lib.scm              |    3 ++
 test-suite/tests/foreign.test   |   57 +++++++++++++++++++++++++++++++++++++++
 test-suite/tests/modules.test   |   12 +++++++-
 test-suite/tests/sxml.fold.test |    1 +
 8 files changed, 110 insertions(+), 34 deletions(-)
 create mode 100644 test-suite/tests/foreign.test

diff --git a/libguile/foreign.c b/libguile/foreign.c
index 9f307ef..eaeea6c 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -52,6 +52,7 @@ SCM_SYMBOL (sym_size_t, "size_t");
 SCM_SYMBOL (sym_asterisk, "*");
 
 SCM_SYMBOL (sym_null, "%null-pointer");
+SCM_SYMBOL (sym_null_pointer_error, "null-pointer-error");
 
 /* The cell representing the null pointer.  */
 static const scm_t_bits null_pointer[2] =
@@ -60,6 +61,15 @@ static const scm_t_bits null_pointer[2] =
     0
   };
 
+/* Raise a null pointer dereference error.  */
+static void
+null_pointer_error (const char *func_name)
+{
+  scm_error (sym_null_pointer_error, func_name,
+            "null pointer dereference", SCM_EOL, SCM_EOL);
+}
+
+
 static SCM cif_to_procedure (SCM cif, SCM func_ptr);
 
 
@@ -89,12 +99,8 @@ scm_take_foreign_pointer (scm_t_foreign_type type, void 
*ptr, size_t len,
                        | (finalizer ? (1<<16) : 0) | (len<<17));
   if (SCM_UNLIKELY ((word0 >> 17) != len))
     scm_out_of_range ("scm_take_foreign_pointer", scm_from_size_t (len));
-    
-  ret = PTR2SCM (scm_gc_malloc_pointerless (sizeof (scm_t_bits) * 2,
-                                            "foreign"));
-  SCM_SET_CELL_WORD_0 (ret, word0);
-  SCM_SET_CELL_WORD_1 (ret, (scm_t_bits)ptr);
 
+  ret = scm_cell (word0, (scm_t_bits) ptr);
   if (finalizer)
     {
       /* Register a finalizer for the newly created instance.  */
@@ -165,6 +171,12 @@ SCM_DEFINE (scm_foreign_set_x, "foreign-set!", 2, 0, 0,
   scm_t_uint8 *ptr;
 
   SCM_VALIDATE_FOREIGN (1, foreign);
+
+  if (SCM_UNLIKELY (scm_is_eq (foreign, PTR2SCM (&null_pointer))))
+    /* Attempting to modify the pointer value of NULL_POINTER (which is
+       read-only anyway), so raise an error.  */
+    null_pointer_error (FUNC_NAME);
+
   ptr = SCM_FOREIGN_POINTER (foreign, scm_t_uint8);
   ftype = SCM_FOREIGN_TYPE (foreign);
 
@@ -241,7 +253,7 @@ SCM_DEFINE (scm_foreign_to_bytevector, 
"foreign->bytevector", 1, 3, 0,
   ptr = SCM_FOREIGN_POINTER (foreign, scm_t_int8);
 
   if (SCM_UNLIKELY (ptr == NULL))
-    scm_misc_error (FUNC_NAME, "null pointer dereference", SCM_EOL);
+    null_pointer_error (FUNC_NAME);
 
   if (SCM_UNBNDP (uvec_type))
     btype = SCM_ARRAY_ELEMENT_TYPE_VU8;
@@ -966,7 +978,7 @@ scm_i_foreign_call (SCM foreign, const SCM *argv)
   /* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
      objtable. */
   ffi_cif *cif;
-  void (*func)();
+  void (*func) (void);
   scm_t_uint8 *data;
   void *rvalue;
   void **args;
@@ -978,7 +990,7 @@ scm_i_foreign_call (SCM foreign, const SCM *argv)
   func = SCM_FOREIGN_POINTER (SCM_CDR (foreign), void);
 
   /* Argument pointers.  */
-  args = alloca (sizeof(void*) * cif->nargs);
+  args = alloca (sizeof (void *) * cif->nargs);
 
   /* Compute the amount of memory needed to store all the argument values.
      Note: as of libffi 3.0.9 `cif->bytes' is undocumented and is zero, so it
diff --git a/libguile/modules.c b/libguile/modules.c
index 545281a..fc6ff3b 100644
--- a/libguile/modules.c
+++ b/libguile/modules.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,2008,2009 Free 
Software Foundation, Inc.
+/* Copyright (C) 1998,2000,2001,2002,2003,2004,2006,2007,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
@@ -801,6 +801,8 @@ SCM_DEFINE (scm_module_reverse_lookup, 
"module-reverse-lookup", 2, 0, 0,
       obarray = SCM_MODULE_OBARRAY (module);
     }
 
+  SCM_VALIDATE_VARIABLE (SCM_ARG2, variable);
+
   if (!SCM_HASHTABLE_P (obarray))
       return SCM_BOOL_F;
 
@@ -830,17 +832,18 @@ SCM_DEFINE (scm_module_reverse_lookup, 
"module-reverse-lookup", 2, 0, 0,
        }
     }
 
-  /* Try the `uses' list.  */
-  {
-    SCM uses = SCM_MODULE_USES (module);
-    while (scm_is_pair (uses))
-      {
-       SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
-       if (scm_is_true (sym))
-         return sym;
-       uses = SCM_CDR (uses);
-      }
-  }
+  if (!scm_is_false (module))
+    {
+      /* Try the `uses' list.  */
+      SCM uses = SCM_MODULE_USES (module);
+      while (scm_is_pair (uses))
+       {
+         SCM sym = scm_module_reverse_lookup (SCM_CAR (uses), variable);
+         if (scm_is_true (sym))
+           return sym;
+         uses = SCM_CDR (uses);
+       }
+    }
 
   return SCM_BOOL_F;
 }
diff --git a/module/sxml/fold.scm b/module/sxml/fold.scm
index 4a39da0..0d2a5bc 100644
--- a/module/sxml/fold.scm
+++ b/module/sxml/fold.scm
@@ -1,6 +1,6 @@
 ;;;; (sxml fold) -- transformation of sxml via fold operations
 ;;;;
-;;;;   Copyright (C) 2009  Free Software Foundation, Inc.
+;;;;   Copyright (C) 2009, 2010  Free Software Foundation, Inc.
 ;;;;    Written 2007 by Andy Wingo <wingo at pobox dot com>.
 ;;;; 
 ;;;; This library is free software; you can redistribute it and/or
@@ -28,8 +28,8 @@
 ;;; Code:
 
 (define-module (sxml fold)
+  #:use-module (srfi srfi-1)
   #:export (foldt
-            fold
             foldts
             foldts*
             fold-values
@@ -50,15 +50,6 @@
                   (foldt fup fhere kid))
                 tree))))
 
-(define (fold proc seed list)
-  "The standard list fold.
-
address@hidden is of type a -> b -> b. @var{seed} is of type b. @var{list}
-is of type [a]."
-  (if (null? list)
-      seed
-      (fold proc (proc (car list) seed) (cdr list))))
-
 (define (foldts fdown fup fhere seed tree)
   "The single-threaded tree fold originally defined in SSAX.
 @xref{sxml ssax,,(sxml ssax)}, for more information."
@@ -89,7 +80,7 @@ tree rewrites. Originally defined in Andy Wingo's 2007 paper,
                tree)))))
 
 (define (fold-values proc list . seeds)
-  "A variant of @ref{sxml fold fold,,fold} that allows multi-valued
+  "A variant of @ref{SRFI-1 Fold and Map, fold} that allows multi-valued
 seeds. Note that the order of the arguments differs from that of
 @code{fold}."
   (if (null? list)
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 006b131..be66dea 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -44,6 +44,7 @@ SCM_TESTS = tests/00-initial-env.test         \
            tests/exceptions.test               \
            tests/filesys.test                  \
            tests/fluids.test                   \
+           tests/foreign.test                  \
            tests/format.test                   \
            tests/fractions.test                \
            tests/ftw.test                      \
diff --git a/test-suite/lib.scm b/test-suite/lib.scm
index 41dda98..f32c7c3 100644
--- a/test-suite/lib.scm
+++ b/test-suite/lib.scm
@@ -36,6 +36,7 @@
  exception:miscellaneous-error
  exception:string-contains-nul
  exception:read-error
+ exception:null-pointer-error
 
  ;; Reporting passes and failures.
  run-test
@@ -278,6 +279,8 @@
   (cons 'misc-error "^.*"))
 (define exception:read-error
   (cons 'read-error "^.*$"))
+(define exception:null-pointer-error
+  (cons 'null-pointer-error "^.*$"))
 
 ;; as per throw in scm_to_locale_stringn()
 (define exception:string-contains-nul
diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test
new file mode 100644
index 0000000..b1add53
--- /dev/null
+++ b/test-suite/tests/foreign.test
@@ -0,0 +1,57 @@
+;;;; foreign.test --- FFI.           -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;;   Copyright (C) 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 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
+
+;;;
+;;; See also ../standalone/test-ffi for FFI tests.
+;;;
+
+(define-module (test-foreign)
+  #:use-module (system foreign)
+  #:use-module (rnrs bytevector)
+  #:use-module (test-suite lib))
+
+
+(with-test-prefix "null pointer"
+
+  (pass-if "zero"
+    (= 0 (foreign-ref %null-pointer)))
+
+  (pass-if-exception "foreign-set! %null-pointer"
+    exception:null-pointer-error
+    (foreign-set! %null-pointer 2))
+
+  (pass-if "foreign-set! other-null-pointer"
+    (let ((f (bytevector->foreign (make-bytevector 2))))
+      (and (not (= 0 (foreign-ref f)))
+           (begin
+             (foreign-set! f 0)
+             (= 0 (foreign-ref f)))
+           (begin
+             ;; Here changing the pointer value of F is perfectly valid.
+             (foreign-set! f 777)
+             (= 777 (foreign-ref f))))))
+
+  (pass-if-exception "foreign->bytevector %null-pointer"
+    exception:null-pointer-error
+    (foreign->bytevector %null-pointer))
+
+  (pass-if-exception "foreign->bytevector other-null-pointer"
+    exception:null-pointer-error
+    (let ((f (bytevector->foreign (make-bytevector 2))))
+      (foreign-set! f 0)
+      (foreign->bytevector f))))
diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test
index f22cfe9..ebcafe3 100644
--- a/test-suite/tests/modules.test
+++ b/test-suite/tests/modules.test
@@ -1,6 +1,6 @@
 ;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
 
-;;;; Copyright (C) 2006, 2007, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007, 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
@@ -125,7 +125,15 @@
               (map module-variable
                    (map resolve-interface mods)
                    syms)
-              locals))))
+              locals)))
+
+  (pass-if "module-reverse-lookup [pre-module-obarray]"
+    (let ((var (module-variable (current-module) 'string?)))
+      (eq? 'string? (module-reverse-lookup #f var))))
+
+  (pass-if-exception "module-reverse-lookup [wrong-type-arg]"
+    exception:wrong-type-arg
+    (module-reverse-lookup (current-module) 'foo)))
 
 
 
diff --git a/test-suite/tests/sxml.fold.test b/test-suite/tests/sxml.fold.test
index 121532f..6daa649 100644
--- a/test-suite/tests/sxml.fold.test
+++ b/test-suite/tests/sxml.fold.test
@@ -24,6 +24,7 @@
 
 (define-module (test-suite sxml-fold)
   #:use-module (test-suite lib)
+  #:use-module ((srfi srfi-1) #:select (fold))
   #:use-module (sxml fold))
 
 (define atom? (@@ (sxml fold) atom?))


hooks/post-receive
-- 
GNU Guile