diff options
author | Ludovic Courtès <ludo@gnu.org> | 2010-04-09 00:30:10 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2010-04-09 00:32:15 +0200 |
commit | 01ad5a7ba9edb5d8c96567ed80ea1a34019c5338 (patch) | |
tree | 0e99da198557e8718718377432f0771c45f7025a | |
parent | 4551e860f02244ffb3858c941319f1613bac40e4 (diff) | |
download | guile-01ad5a7ba9edb5d8c96567ed80ea1a34019c5338.tar.gz |
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.
-rw-r--r-- | libguile/foreign.c | 18 | ||||
-rw-r--r-- | test-suite/Makefile.am | 1 | ||||
-rw-r--r-- | test-suite/lib.scm | 3 | ||||
-rw-r--r-- | test-suite/tests/foreign.test | 57 |
4 files changed, 78 insertions, 1 deletions
diff --git a/libguile/foreign.c b/libguile/foreign.c index 0d6b67000..eaeea6c90 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); @@ -161,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); @@ -237,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; diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 006b13107..be66dea54 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 41dda9882..f32c7c308 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 000000000..b1add5382 --- /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)))) |