From bb3994fcc9a556d1a26d35f6ff9386d01030821d Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Wed, 2 Mar 2011 09:40:22 +0000 Subject: [PATCH] 1.0.46.19: add :NOT-NULL option to C-STRING type By default NIL is a valid C-STRING, translated to and from C's NULL. This is very convenient because many C functions that normally return strings return NULL to indicate "false" or "don't know" -- and less commonly also special case it as an argument. There are however many C functions that don't check for NULL, so we want a non-horrible way to say that NIL is not a good value to pass on... ...it remains to be seen if this is non-horrible enough, but at least it fixes a bunch of memory faults from doing things like (posix-getenv nil), and replaces them with type-errors. Not all C-STRING types have been audited yet, just a bunch of the more obvious ones. --- NEWS | 5 +++++ contrib/sb-posix/interface.lisp | 39 ++++++++++++++++++++++-------------- doc/manual/ffi.texinfo | 12 ++++++----- src/code/host-c-call.lisp | 42 +++++++++++++++++++++++++++++---------- src/code/unix.lisp | 6 ++++-- tests/alien.impure.lisp | 12 +++++++++++ version.lisp-expr | 2 +- 7 files changed, 85 insertions(+), 33 deletions(-) diff --git a/NEWS b/NEWS index 80d240b..25c86ad 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,8 @@ changes relative to sbcl-1.0.46: processed using EVAL -- now the appropriate toplevel form is reported instead. * enhancement: more legible style-warnings for inappropriate IGNORE and IGNORABLE declarations. (lp#726331) + * enhancement: :NOT-NULL option has been added to alien C-STRING type to indicate + that NIL/NULL is excluded from the type. * optimization: SLOT-VALUE &co are faster in the presence of SLOT-VALUE-USING-CLASS and its compatriots. * optimization: core startup time is reduced by 30% on x86-64. (lp#557357) @@ -24,6 +26,9 @@ changes relative to sbcl-1.0.46: * bug fix: SLOT-BOUNDP information is correct during MAKE-INSTANCE in the presence of (SETF SLOT-VALUE-USING-CLASS) and SLOT-BOUNDP-USING-CLASS methods. (regression from 1.0.45.18) + * bug fix: several foreign functions accepting string also accepted NIL and + consequently caused a memory fault at 0 now signal a type-error instead. + (lp#721087) changes in sbcl-1.0.46 relative to sbcl-1.0.45: * enhancement: largefile support on Solaris. diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index 5c8a877..3121397 100644 --- a/contrib/sb-posix/interface.lisp +++ b/contrib/sb-posix/interface.lisp @@ -344,7 +344,7 @@ not supported." "Returns the resolved target of a symbolic link as a string." (flet ((%readlink (path buf length) (alien-funcall - (extern-alien "readlink" (function int c-string (* t) int)) + (extern-alien "readlink" (function int (c-string :not-null t) (* t) int)) path buf length))) (with-growing-c-string (buf size) (let ((count (%readlink (filename pathspec) buf size))) @@ -480,10 +480,14 @@ not supported." nil (,conv r))))))) -(define-obj-call "getpwnam" login-name (function (* alien-passwd) c-string) alien-to-passwd) -(define-obj-call "getpwuid" uid (function (* alien-passwd) uid-t) alien-to-passwd) -(define-obj-call "getgrnam" login-name (function (* alien-group) c-string) alien-to-group) -(define-obj-call "getgrgid" gid (function (* alien-group) gid-t) alien-to-group) +(define-obj-call "getpwnam" login-name (function (* alien-passwd) (c-string :not-null t)) + alien-to-passwd) +(define-obj-call "getpwuid" uid (function (* alien-passwd) uid-t) + alien-to-passwd) +(define-obj-call "getgrnam" login-name (function (* alien-group) (c-string :not-null t)) + alien-to-group) +(define-obj-call "getgrgid" gid (function (* alien-group) gid-t) + alien-to-group) #-win32 @@ -542,12 +546,12 @@ not supported." (define-stat-call #-win32 "stat" #+win32 "_stat" pathname filename - (function int c-string (* alien-stat))) + (function int (c-string :not-null t) (* alien-stat))) #-win32 (define-stat-call "lstat" pathname filename - (function int c-string (* alien-stat))) + (function int (c-string :not-null t) (* alien-stat))) ;;; No symbolic links on Windows, so use stat #+win32 (progn @@ -697,7 +701,7 @@ not supported." result))) (export 'utime :sb-posix) (defun utime (filename &optional access-time modification-time) - (let ((fun (extern-alien "utime" (function int c-string + (let ((fun (extern-alien "utime" (function int (c-string :not-null t) (* alien-utimbuf)))) (name (filename filename))) (if (not (and access-time modification-time)) @@ -719,7 +723,7 @@ not supported." (if (minusp value) (syscall-error) value))) - (let ((fun (extern-alien "utimes" (function int c-string + (let ((fun (extern-alien "utimes" (function int (c-string :not-null t) (* (array alien-timeval 2))))) (name (filename filename))) (if (not (and access-time modification-time)) @@ -745,15 +749,18 @@ not supported." (export 'getenv :sb-posix)) (defun getenv (name) (let ((r (alien-funcall - (extern-alien "getenv" (function (* char) c-string)) + (extern-alien "getenv" (function (* char) (c-string :not-null t))) name))) (declare (type (alien (* char)) r)) (unless (null-alien r) (cast r c-string)))) #-win32 (progn - (define-call "setenv" int minusp (name c-string) (value c-string) (overwrite int)) - (define-call "unsetenv" int minusp (name c-string)) + (define-call "setenv" int minusp + (name (c-string :not-null t)) + (value (c-string :not-null t)) + (overwrite int)) + (define-call "unsetenv" int minusp (name (c-string :not-null t))) (export 'putenv :sb-posix) (defun putenv (string) (declare (string string)) @@ -773,7 +780,7 @@ not supported." #+win32 (progn ;; Windows doesn't define a POSIX setenv, but happily their _putenv is sane. - (define-call* "putenv" int minusp (string c-string)) + (define-call* "putenv" int minusp (string (c-string :not-null t))) (export 'setenv :sb-posix) (defun setenv (name value overwrite) (declare (string name value)) @@ -793,7 +800,7 @@ not supported." (export 'closelog :sb-posix) (defun openlog (ident options &optional (facility log-user)) (alien-funcall (extern-alien - "openlog" (function void c-string int int)) + "openlog" (function void (c-string :not-null t) int int)) ident options facility)) (defun syslog (priority format &rest args) "Send a message to the syslog facility, with severity level @@ -801,7 +808,9 @@ PRIORITY. The message will be formatted as by CL:FORMAT (rather than C's printf) with format string FORMAT and arguments ARGS." (flet ((syslog1 (priority message) (alien-funcall (extern-alien - "syslog" (function void int c-string c-string)) + "syslog" (function void int + (c-string :not-null t) + (c-string :not-null t))) priority "%s" message))) (syslog1 priority (apply #'format nil format args)))) (define-call "closelog" void never-fails)) diff --git a/doc/manual/ffi.texinfo b/doc/manual/ffi.texinfo index 12aa045..d6b6d05 100644 --- a/doc/manual/ffi.texinfo +++ b/doc/manual/ffi.texinfo @@ -284,11 +284,13 @@ return zero values. @item @cindex External formats -The foreign type specifier @code{(sb-alien:c-string &key external-format -element-type)} is similar to @code{(* char)}, but is interpreted as a -null-terminated string, and is automatically converted into a Lisp -string when accessed; or if the pointer is C @code{NULL} or @code{0}, -then accessing it gives Lisp @code{nil}. +The foreign type specifier @code{(sb-alien:c-string &key +external-format element-type not-null)} is similar to +@code{(* char)}, but is interpreted as a null-terminated string, and +is automatically converted into a Lisp string when accessed; or if the +pointer is C @code{NULL} or @code{0}, then accessing it gives Lisp +@code{nil} unless @code{not-null} is true, in which case a type-error +is signalled. External format conversion is automatically done when Lisp strings are passed to foreign code, or when foreign strings are passed to Lisp code. diff --git a/src/code/host-c-call.lisp b/src/code/host-c-call.lisp index e4187db..7b558af 100644 --- a/src/code/host-c-call.lisp +++ b/src/code/host-c-call.lisp @@ -13,15 +13,18 @@ (define-alien-type-class (c-string :include pointer :include-args (to)) (external-format :default :type keyword) - (element-type 'character :type (member character base-char))) + (element-type 'character :type (member character base-char)) + (not-null nil :type boolean)) (define-alien-type-translator c-string (&key (external-format :default) - (element-type 'character)) + (element-type 'character) + (not-null nil)) (make-alien-c-string-type :to (parse-alien-type 'char (sb!kernel:make-null-lexenv)) :element-type element-type - :external-format external-format)) + :external-format external-format + :not-null not-null)) (defun c-string-external-format (type) (let ((external-format (alien-c-string-type-external-format type))) @@ -32,18 +35,23 @@ (define-alien-type-method (c-string :unparse) (type) (let* ((external-format (alien-c-string-type-external-format type)) (element-type (alien-c-string-type-element-type type)) + (not-null (alien-c-string-type-not-null type)) (tail (append (unless (eq :default external-format) (list :external-format external-format)) (unless (eq 'character element-type) - (list :element-type element-type))) )) + (list :element-type element-type)) + (when not-null + (list :not-null t))))) (if tail (cons 'c-string tail) 'c-string))) (define-alien-type-method (c-string :lisp-rep) (type) - (declare (ignore type)) - '(or simple-string null (alien (* char)) (simple-array (unsigned-byte 8)))) + (let ((possibilities '(simple-string (alien (* char)) (simple-array (unsigned-byte 8))))) + (if (alien-c-string-type-not-null type) + `(or ,@possibilities) + `(or null ,@possibilities)))) (define-alien-type-method (c-string :deport-pin-p) (type) (declare (ignore type)) @@ -68,9 +76,18 @@ #!-sb-unicode (eq (first (sb!impl::ef-names external-format)) :latin-1)))))) +(declaim (ftype (sfunction (t) nil) null-error)) +(defun null-error (type) + (aver (alien-c-string-type-not-null type)) + (error 'type-error + :expected-type `(alien ,(unparse-alien-type type)) + :datum nil)) + (define-alien-type-method (c-string :naturalize-gen) (type alien) `(if (zerop (sap-int ,alien)) - nil + ,(if (alien-c-string-type-not-null type) + `(null-error ',type) + nil) ;; Check whether we need to do a full external-format ;; conversion, or whether we can just do a cheap byte-by-byte ;; copy of the c-string data. @@ -90,17 +107,22 @@ `(%naturalize-c-string ,alien)))) (define-alien-type-method (c-string :deport-gen) (type value) - (declare (ignore type)) ;; This SAP taking is safe as DEPORT callers pin the VALUE when ;; necessary. `(etypecase ,value - (null (int-sap 0)) + (null + ,(if (alien-c-string-type-not-null type) + `(null-error ',type) + `(int-sap 0))) ((alien (* char)) (alien-sap ,value)) (vector (vector-sap ,value)))) (define-alien-type-method (c-string :deport-alloc-gen) (type value) `(etypecase ,value - (null nil) + (null + ,(if (alien-c-string-type-not-null type) + `(null-error ',type) + nil)) ((alien (* char)) ,value) (simple-base-string ,(if (c-string-needs-conversion-p type) diff --git a/src/code/unix.lisp b/src/code/unix.lisp index cddbca0..d5ac483 100644 --- a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ -111,7 +111,7 @@ SYSCALL-FORM. Repeat evaluation of SYSCALL-FORM if it is interrupted." (define-alien-routine ("getenv" posix-getenv) c-string "Return the \"value\" part of the environment string \"name=value\" which corresponds to NAME, or NIL if there is none." - (name c-string)) + (name (c-string :not-null t))) ;;; from stdio.h @@ -120,7 +120,9 @@ corresponds to NAME, or NIL if there is none." #!-win32 (defun unix-rename (name1 name2) (declare (type unix-pathname name1 name2)) - (void-syscall ("rename" c-string c-string) name1 name2)) + (void-syscall ("rename" (c-string :not-null t) + (c-string :not-null t)) + name1 name2)) ;;; from sys/types.h and gnu/types.h diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp index e68737c..d60bd10 100644 --- a/tests/alien.impure.lisp +++ b/tests/alien.impure.lisp @@ -307,4 +307,16 @@ (compiler-note (n) (error n)))) +(with-test (:name :bug-721087) + (assert (typep nil '(alien c-string))) + (assert (not (typep nil '(alien (c-string :not-null t))))) + (assert (eq :ok + (handler-case + (posix-getenv nil) + (type-error (e) + (when (and (null (type-error-datum e)) + (equal (type-error-expected-type e) + '(alien (c-string :not-null t)))) + :ok)))))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index fbac88c..e00a859 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -20,4 +20,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.46.18" +"1.0.46.19" -- 1.7.10.4