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] =
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);
+}
+
+\f
static SCM cif_to_procedure (SCM cif, SCM func_ptr);
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);
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;
exception:miscellaneous-error
exception:string-contains-nul
exception:read-error
+ exception:null-pointer-error
;; Reporting passes and failures.
run-test
(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
--- /dev/null
+;;;; 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))
+
+\f
+(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))))