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.

diff --git a/NEWS b/NEWS
index 80d240b..25c86ad 100644 (file)
--- 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)
     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)
   * 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: 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.
 
 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 (file)
--- 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
     "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)))
               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)))))))
 
               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
 
 
 #-win32

@@ -542,12 +546,12 @@ not supported."
 
 (define-stat-call #-win32 "stat" #+win32 "_stat"
                   pathname filename
 
 (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
 
 #-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
 ;;; 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)
           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))
                                                (* alien-utimbuf))))
           (name (filename filename)))
       (if (not (and access-time modification-time))

@@ -719,7 +723,7 @@ not supported."
              (if (minusp value)
                  (syscall-error)
                  value)))
              (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))
                                                   (* (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
   (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
             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))
   (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.
 #+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))
   (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
   (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
                    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
 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))
                             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 (file)
--- a/doc/manual/ffi.texinfo
+++ b/doc/manual/ffi.texinfo
@@ -284,11 +284,13 @@ return zero values.
 
 @item
 @cindex External formats
 
 @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.
 
 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 (file)
--- 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)
 
 (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)
 
 (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
   (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)))
 
 (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))
 (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)
          (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)
     (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))
 
 (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))))))
 
                   #!-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))
 (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.
        ;; 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)
             `(%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
   ;; 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
      ((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)
      ((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 (file)
--- 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."
 (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)))

 \f
 ;;; from stdio.h
 
 \f
 ;;; 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))
 #!-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))

 \f
 ;;; from sys/types.h and gnu/types.h
 
 \f
 ;;; from sys/types.h and gnu/types.h
 

diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp
index e68737c..d60bd10 100644 (file)
--- a/tests/alien.impure.lisp
+++ b/tests/alien.impure.lisp
@@ -307,4 +307,16 @@
     (compiler-note (n)
       (error n))))
 
     (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
 ;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index fbac88c..e00a859 100644 (file)
--- 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".)
 ;;; 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"