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.
Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1887
diff -u -r1.1887 NEWS
--- NEWS 28 Feb 2011 12:12:19 -0000 1.1887
+++ NEWS 2 Mar 2011 09:38:15 -0000
@@ -8,6 +8,8 @@
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 @@
* 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.
Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.5203
diff -u -r1.5203 version.lisp-expr
--- version.lisp-expr 2 Mar 2011 09:30:09 -0000 1.5203
+++ version.lisp-expr 2 Mar 2011 09:38:15 -0000
@@ -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"
Index: contrib/sb-posix/interface.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-posix/interface.lisp,v
retrieving revision 1.62
diff -u -r1.62 interface.lisp
--- contrib/sb-posix/interface.lisp 19 Oct 2010 17:00:52 -0000 1.62
+++ contrib/sb-posix/interface.lisp 2 Mar 2011 09:38:15 -0000
@@ -344,7 +344,7 @@
"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 @@
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 @@
(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 @@
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 @@
(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 @@
(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 @@
#+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 @@
(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 @@
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))
Index: doc/manual/ffi.texinfo
===================================================================
RCS file: /cvsroot/sbcl/sbcl/doc/manual/ffi.texinfo,v
retrieving revision 1.20
diff -u -r1.20 ffi.texinfo
--- doc/manual/ffi.texinfo 6 Jun 2010 20:43:58 -0000 1.20
+++ doc/manual/ffi.texinfo 2 Mar 2011 09:38:16 -0000
@@ -284,11 +284,13 @@
@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.
Index: src/code/host-c-call.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/host-c-call.lisp,v
retrieving revision 1.14
diff -u -r1.14 host-c-call.lisp
--- src/code/host-c-call.lisp 2 Mar 2011 09:30:09 -0000 1.14
+++ src/code/host-c-call.lisp 2 Mar 2011 09:38:16 -0000
@@ -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)
Index: src/code/unix.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/unix.lisp,v
retrieving revision 1.114
diff -u -r1.114 unix.lisp
--- src/code/unix.lisp 10 Nov 2010 17:49:30 -0000 1.114
+++ src/code/unix.lisp 2 Mar 2011 09:38:16 -0000
@@ -111,7 +111,7 @@
(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 @@
#!-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
Index: tests/alien.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/alien.impure.lisp,v
retrieving revision 1.26
diff -u -r1.26 alien.impure.lisp
--- tests/alien.impure.lisp 4 Oct 2010 11:26:10 -0000 1.26
+++ tests/alien.impure.lisp 2 Mar 2011 09:38:16 -0000
@@ -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
|