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)
* 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.
"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)))
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
(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
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))
(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))
(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))
#+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 '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
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))
@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.
(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)))
(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))
#!-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.
`(%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)
(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
#!-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
(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
;;; 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"
projects / sbcl.git / commitdiff