Fix make-array transforms.

[sbcl.git] / contrib / sb-posix / interface.lisp

diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp
index 0995a1d..8e6be50 100644 (file)
--- a/contrib/sb-posix/interface.lisp
+++ b/contrib/sb-posix/interface.lisp
@@ -8,7 +8,11 @@
       (export ',name :sb-posix)
       (defclass ,name ,superclasses
         ,(loop for slotd in slots
       (export ',name :sb-posix)
       (defclass ,name ,superclasses
         ,(loop for slotd in slots

-               collect (ldiff slotd (member :array-length slotd)))
+               ;; KLUDGE: Splice out :ARRAY-LENGTH options (they're
+               ;; for the conversion functions, not for DEFCLASS).
+               for array-length-option = (member :array-length slotd)
+               collect (append (ldiff slotd array-length-option)
+                               (cddr array-length-option)))

         ,@options)
       (declaim (inline ,to-alien ,to-protocol))
       (declaim (inline ,to-protocol ,to-alien))
         ,@options)
       (declaim (inline ,to-alien ,to-protocol))
       (declaim (inline ,to-protocol ,to-alien))

@@ -57,14 +61,25 @@
       (find-class ',name))))
 
 (define-condition sb-posix:syscall-error (error)
       (find-class ',name))))
 
 (define-condition sb-posix:syscall-error (error)

-  ((errno :initarg :errno :reader sb-posix:syscall-errno))
+  ((errno :initarg :errno :reader sb-posix:syscall-errno)
+   (name :initarg :name :initform nil :reader sb-posix:syscall-name))

   (:report (lambda (c s)
   (:report (lambda (c s)

-             (let ((errno (sb-posix:syscall-errno c)))
-               (format s "System call error ~A (~A)"
-                       errno (sb-int:strerror errno))))))
-
-(defun syscall-error ()
-  (error 'sb-posix:syscall-error :errno (get-errno)))
+             (let ((errno (sb-posix:syscall-errno c))
+                   (name (sb-posix:syscall-name c)))
+               (if name
+                   (format s "Error in ~S: ~A (~A)"
+                           name
+                           (sb-int:strerror errno)
+                           errno)
+                   (format s "Error in syscall: ~A (~A)"
+                           (sb-int:strerror errno)
+                           errno))))))
+
+(declaim (ftype (function (&optional symbol) nil) syscall-error))
+(defun syscall-error (&optional name)
+  (error 'sb-posix:syscall-error
+         :name name
+         :errno (get-errno)))

 
 (defun unsupported-error (lisp-name c-name)
   (error "~S is unsupported by SBCL on this platform due to lack of ~A()."
 
 (defun unsupported-error (lisp-name c-name)
   (error "~S is unsupported by SBCL on this platform due to lack of ~A()."

@@ -121,11 +136,15 @@
                        (open-with-mode pathname flags mode)
                        (open-without-mode pathname flags))))))
     (def #-win32 "open" #+win32 "_open"))
                        (open-with-mode pathname flags mode)
                        (open-without-mode pathname flags))))))
     (def #-win32 "open" #+win32 "_open"))

+(define-call* "read" int minusp
+    (fd file-descriptor) (buf (* t)) (count int))

 (define-call "rename" int minusp (oldpath filename) (newpath filename))
 (define-call* "rmdir" int minusp (pathname filename))
 (define-call* "unlink" int minusp (pathname filename))
 (define-call #-netbsd "opendir" #+netbsd "_opendir"
     (* t) null-alien (pathname filename))
 (define-call "rename" int minusp (oldpath filename) (newpath filename))
 (define-call* "rmdir" int minusp (pathname filename))
 (define-call* "unlink" int minusp (pathname filename))
 (define-call #-netbsd "opendir" #+netbsd "_opendir"
     (* t) null-alien (pathname filename))

+(define-call* "write" int minusp
+    (fd file-descriptor) (buf (* t)) (count int))

 #+inode64
 (define-call ("readdir" :c-name "readdir$INODE64" :options :largefile)
   (* dirent)
 #+inode64
 (define-call ("readdir" :c-name "readdir$INODE64" :options :largefile)
   (* dirent)

@@ -187,7 +206,7 @@
                                                                        (function ,result-type system-area-pointer))
                                                          (sb-alien::vector-sap arg))))
                               (when (,errorp result)
                                                                        (function ,result-type system-area-pointer))
                                                          (sb-alien::vector-sap arg))))
                               (when (,errorp result)

-                                (syscall-error))
+                                (syscall-error ',lisp-name))

                               ;; FIXME: We'd rather return pathnames, but other
                               ;; SB-POSIX functions like this return strings...
                               (let ((pathname (sb-ext:octets-to-string
                               ;; FIXME: We'd rather return pathnames, but other
                               ;; SB-POSIX functions like this return strings...
                               (let ((pathname (sb-ext:octets-to-string

@@ -262,48 +281,57 @@
 
   ;; uid, gid
   (define-call "geteuid" uid-t never-fails) ; "always successful", it says
 
   ;; uid, gid
   (define-call "geteuid" uid-t never-fails) ; "always successful", it says

+  #-sunos

   (define-call "getresuid" uid-t never-fails)
   (define-call "getuid" uid-t never-fails)
   (define-call "seteuid" int minusp (uid uid-t))
   (define-call "getresuid" uid-t never-fails)
   (define-call "getuid" uid-t never-fails)
   (define-call "seteuid" int minusp (uid uid-t))

+  #-sunos

   (define-call "setfsuid" int minusp (uid uid-t))
   (define-call "setreuid" int minusp (ruid uid-t) (euid uid-t))
   (define-call "setfsuid" int minusp (uid uid-t))
   (define-call "setreuid" int minusp (ruid uid-t) (euid uid-t))

+  #-sunos

   (define-call "setresuid" int minusp (ruid uid-t) (euid uid-t) (suid uid-t))
   (define-call "setuid" int minusp (uid uid-t))
   (define-call "getegid" gid-t never-fails)
   (define-call "getgid" gid-t never-fails)
   (define-call "setresuid" int minusp (ruid uid-t) (euid uid-t) (suid uid-t))
   (define-call "setuid" int minusp (uid uid-t))
   (define-call "getegid" gid-t never-fails)
   (define-call "getgid" gid-t never-fails)

+  #-sunos

   (define-call "getresgid" gid-t never-fails)
   (define-call "setegid" int minusp (gid gid-t))
   (define-call "getresgid" gid-t never-fails)
   (define-call "setegid" int minusp (gid gid-t))

+  #-sunos

   (define-call "setfsgid" int minusp (gid gid-t))
   (define-call "setgid" int minusp (gid gid-t))
   (define-call "setregid" int minusp (rgid gid-t) (egid gid-t))
   (define-call "setfsgid" int minusp (gid gid-t))
   (define-call "setgid" int minusp (gid gid-t))
   (define-call "setregid" int minusp (rgid gid-t) (egid gid-t))

+  #-sunos

   (define-call "setresgid" int minusp (rgid gid-t) (egid gid-t) (sgid gid-t))
 
   ;; processes, signals
   (define-call "alarm" int never-fails (seconds unsigned))
 
   (define-call "setresgid" int minusp (rgid gid-t) (egid gid-t) (sgid gid-t))
 
   ;; processes, signals
   (define-call "alarm" int never-fails (seconds unsigned))
 

+  ;; exit and abort, not much point inlining these
+  (define-simple-call abort void)
+  (define-simple-call exit void (status int))
+  (define-simple-call _exit void (status int))

 
 

-
+  ;; FIXME this is a lie, of course this can fail, but there's no
+  ;; error handling here yet!

   #+mach-exception-handler
   #+mach-exception-handler

-  (progn
-    ;; FIXME this is a lie, of course this can fail, but there's no
-    ;; error handling here yet!
-    (define-call "setup_mach_exceptions" void never-fails)
-    (define-call ("posix_fork" :c-name "fork") pid-t minusp)
-    (defun fork ()
-      (tagbody
-         (sb-thread::with-all-threads-lock
-           (when (cdr sb-thread::*all-threads*)
-             (go :error))
-           (let ((pid (posix-fork)))
-             (when (= pid 0)
-               (setup-mach-exceptions))
-             (return-from fork pid)))
-       :error
-         (error "Cannot fork with multiple threads running.")))
-    (export 'fork :sb-posix))
-
-  #-mach-exception-handler
-  (define-call "fork" pid-t minusp)
+  (define-call "setup_mach_exceptions" void never-fails)
+  (define-call ("posix_fork" :c-name "fork") pid-t minusp)
+  (defun fork ()
+    "Forks the current process, returning 0 in the new process and the PID of
+the child process in the parent. Forking while multiple threads are running is
+not supported."
+    (tagbody
+       (sb-thread::with-all-threads-lock
+         (when (cdr sb-thread::*all-threads*)
+           (go :error))
+         (let ((pid (posix-fork)))
+           #+mach-exception-handler
+           (when (= pid 0)
+             (setup-mach-exceptions))
+           (return-from fork pid)))
+     :error
+       (error "Cannot fork with multiple threads running.")))
+  (export 'fork :sb-posix)

 
   (define-call "getpgid" pid-t minusp (pid pid-t))
   (define-call "getppid" pid-t never-fails)
 
   (define-call "getpgid" pid-t minusp (pid pid-t))
   (define-call "getppid" pid-t never-fails)

@@ -344,12 +372,12 @@
     "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)))
           (cond ((minusp count)
               path buf length)))
       (with-growing-c-string (buf size)
         (let ((count (%readlink (filename pathspec) buf size)))
           (cond ((minusp count)

-                 (syscall-error))
+                 (syscall-error 'readlink))

                 ((< 0 count size)
                  (buf count))))))))
 
                 ((< 0 count size)
                  (buf count))))))))
 

@@ -367,7 +395,7 @@
           (cond (result
                  (buf))
                 ((/= (get-errno) sb-posix:erange)
           (cond (result
                  (buf))
                 ((/= (get-errno) sb-posix:erange)

-                 (syscall-error))))))))
+                 (syscall-error 'getcwd))))))))

 
 #-win32
 (progn
 
 #-win32
 (progn

@@ -381,7 +409,7 @@
                   (extern-alien "wait" (function pid-t (* int)))
                   (sb-sys:vector-sap ptr)))))
      (if (minusp pid)
                   (extern-alien "wait" (function pid-t (* int)))
                   (sb-sys:vector-sap ptr)))))
      (if (minusp pid)

-         (syscall-error)
+         (syscall-error 'wait)

          (values pid (aref ptr 0))))))
 
 #-win32
          (values pid (aref ptr 0))))))
 
 #-win32

@@ -399,7 +427,7 @@
                                                     pid-t (* int) int))
                   pid (sb-sys:vector-sap ptr) options))))
      (if (minusp pid)
                                                     pid-t (* int) int))
                   pid (sb-sys:vector-sap ptr) options))))
      (if (minusp pid)

-         (syscall-error)
+         (syscall-error 'waitpid)

          (values pid (aref ptr 0)))))
  ;; waitpid macros
  (define-call "wifexited" boolean never-fails (status int))
          (values pid (aref ptr 0)))))
  ;; waitpid macros
  (define-call "wifexited" boolean never-fails (status int))

@@ -423,8 +451,29 @@
  (define-call "munmap" int minusp
    (start sb-sys:system-area-pointer) (length unsigned))
 
  (define-call "munmap" int minusp
    (start sb-sys:system-area-pointer) (length unsigned))
 

+#-win32

 (define-call "msync" int minusp
   (addr sb-sys:system-area-pointer) (length unsigned) (flags int)))
 (define-call "msync" int minusp
   (addr sb-sys:system-area-pointer) (length unsigned) (flags int)))

+#+win32
+(progn
+  ;; No attempt is made to offer a full mmap-like interface on Windows.
+  ;; It would be possible to do so (and has been done by AK on his
+  ;; branch), but the use case is unclear to me.  However, the following
+  ;; definitions are needed to keep existing code in sb-simple-streams
+  ;; running. --DFL
+  (defconstant PROT-READ #x02)
+  (defconstant PROT-WRITE #x04)
+  (defconstant PROT-EXEC #x10)
+  (defconstant PROT-NONE 0)
+  (defconstant MAP-SHARED 0)
+  (defconstant MAP-PRIVATE 1)
+  (defconstant MS-ASYNC nil)
+  (defconstant MS-SYNC nil)
+  (export                            ;export on the fly like define-call
+   (defun msync (address length flags)
+     (declare (ignore flags))
+     (when (zerop (sb-win32:flush-view-of-file address length))
+       (sb-win32::win32-error "FlushViewOfFile")))))

 
 ;;; mlockall, munlockall
 (define-call "mlockall" int minusp (flags int))
 
 ;;; mlockall, munlockall
 (define-call "mlockall" int minusp (flags int))

@@ -457,8 +506,8 @@
         :documentation "Initial working directory.")
    (shell :initarg :shell :accessor passwd-shell
           :documentation "Program to use as shell."))
         :documentation "Initial working directory.")
    (shell :initarg :shell :accessor passwd-shell
           :documentation "Program to use as shell."))

-  (:documentation "Instances of this class represent entries in
-                   the system's user database."))
+  (:documentation
+   "Instances of this class represent entries in the system's user database."))

 
 ;;; group database
 #-win32
 
 ;;; group database
 #-win32

@@ -480,10 +529,14 @@
               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

@@ -512,14 +565,15 @@
                          bytes.  For symbolic links, the length
                          in bytes of the filename contained in
                          the symbolic link.")
                          bytes.  For symbolic links, the length
                          in bytes of the filename contained in
                          the symbolic link.")

+   (rdev :initarg :rdev :reader stat-rdev
+          :documentation "For devices the device number.")

    (atime :initarg :atime :reader stat-atime
           :documentation "Time of last access.")
    (mtime :initarg :mtime :reader stat-mtime
           :documentation "Time of last data modification.")
    (ctime :initarg :ctime :reader stat-ctime
    (atime :initarg :atime :reader stat-atime
           :documentation "Time of last access.")
    (mtime :initarg :mtime :reader stat-mtime
           :documentation "Time of last data modification.")
    (ctime :initarg :ctime :reader stat-ctime

-          :documentation "Time of last status change"))
-  (:documentation "Instances of this class represent Posix file
-                   metadata."))
+          :documentation "Time of last status change."))
+  (:documentation "Instances of this class represent POSIX file metadata."))

 
 (defmacro define-stat-call (name arg designator-fun type)
   ;; FIXME: this isn't the documented way of doing this, surely?
 
 (defmacro define-stat-call (name arg designator-fun type)
   ;; FIXME: this isn't the documented way of doing this, surely?

@@ -537,17 +591,17 @@
                     (,designator-fun ,arg)
                     a-stat)))
             (when (minusp r)
                     (,designator-fun ,arg)
                     a-stat)))
             (when (minusp r)

-              (syscall-error))
+              (syscall-error ',lisp-name))

             (alien-to-stat a-stat stat)))))))
 
 (define-stat-call #-win32 "stat" #+win32 "_stat"
                   pathname filename
             (alien-to-stat a-stat stat)))))))
 
 (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

@@ -583,7 +637,7 @@
                (extern-alien "pipe" (function int (* int)))
                (sb-sys:vector-sap filedes2)))))
      (when (minusp r)
                (extern-alien "pipe" (function int (* int)))
                (sb-sys:vector-sap filedes2)))))
      (when (minusp r)

-       (syscall-error)))
+       (syscall-error 'pipe)))

    (values (aref filedes2 0) (aref filedes2 1))))
 
 #-win32
    (values (aref filedes2 0) (aref filedes2 1))))
 
 #-win32

@@ -597,9 +651,9 @@
    (lflag :initarg :lflag :accessor sb-posix:termios-lflag
           :documentation "Local modes.")
    (cc :initarg :cc :accessor sb-posix:termios-cc :array-length nccs
    (lflag :initarg :lflag :accessor sb-posix:termios-lflag
           :documentation "Local modes.")
    (cc :initarg :cc :accessor sb-posix:termios-cc :array-length nccs

-       :documentation "Control characters"))
-  (:documentation "Instances of this class represent I/O
-                   characteristics of the terminal."))
+       :documentation "Control characters."))
+  (:documentation
+   "Instances of this class represent I/O characteristics of the terminal."))

 
 #-win32
 (progn
 
 #-win32
 (progn

@@ -616,7 +670,7 @@
                    (function int int int (* alien-termios)))
                   fd actions a-termios)))
          (when (minusp r)
                    (function int int int (* alien-termios)))
                   fd actions a-termios)))
          (when (minusp r)

-           (syscall-error)))
+           (syscall-error 'tcsetattr)))

        (values))))
  (export 'tcgetattr :sb-posix)
  (declaim (inline tcgetattr))
        (values))))
  (export 'tcgetattr :sb-posix)
  (declaim (inline tcgetattr))

@@ -629,7 +683,7 @@
                (file-descriptor fd)
                a-termios)))
        (when (minusp r)
                (file-descriptor fd)
                a-termios)))
        (when (minusp r)

-         (syscall-error))
+         (syscall-error 'tcgetattr))

        (setf termios (alien-to-termios a-termios termios))))
    termios)
  (define-call "tcdrain" int minusp (fd file-descriptor))
        (setf termios (alien-to-termios a-termios termios))))
    termios)
  (define-call "tcdrain" int minusp (fd file-descriptor))

@@ -648,7 +702,7 @@
                a-termios
                speed)))
        (when (minusp r)
                a-termios
                speed)))
        (when (minusp r)

-         (syscall-error))
+         (syscall-error 'cfsetispeed))

        (setf termios (alien-to-termios a-termios termios))))
    termios)
  (export 'cfsetospeed :sb-posix)
        (setf termios (alien-to-termios a-termios termios))))
    termios)
  (export 'cfsetospeed :sb-posix)

@@ -662,7 +716,7 @@
                a-termios
                speed)))
        (when (minusp r)
                a-termios
                speed)))
        (when (minusp r)

-         (syscall-error))
+         (syscall-error 'cfsetospeed))

        (setf termios (alien-to-termios a-termios termios))))
    termios)
  (export 'cfgetispeed :sb-posix)
        (setf termios (alien-to-termios a-termios termios))))
    termios)
  (export 'cfgetispeed :sb-posix)

@@ -693,12 +747,13 @@
                                                (function time-t (* time-t)))
                                  nil)))
       (if (minusp result)
                                                (function time-t (* time-t)))
                                  nil)))
       (if (minusp result)

-          (syscall-error)
+          (syscall-error 'time)

           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
-                                               (* alien-utimbuf))))
+    (let ((fun (extern-alien #-netbsd "utime" #+netbsd "_utime"
+                             (function int (c-string :not-null t)
+                                       (* alien-utimbuf))))

           (name (filename filename)))
       (if (not (and access-time modification-time))
           (alien-funcall fun name nil)
           (name (filename filename)))
       (if (not (and access-time modification-time))
           (alien-funcall fun name nil)

@@ -707,7 +762,7 @@
                   (slot utimbuf 'modtime) (or modification-time 0))
             (let ((result (alien-funcall fun name (alien-sap utimbuf))))
               (if (minusp result)
                   (slot utimbuf 'modtime) (or modification-time 0))
             (let ((result (alien-funcall fun name (alien-sap utimbuf))))
               (if (minusp result)

-                  (syscall-error)
+                  (syscall-error 'utime)

                   result))))))
   (export 'utimes :sb-posix)
   (defun utimes (filename &optional access-time modification-time)
                   result))))))
   (export 'utimes :sb-posix)
   (defun utimes (filename &optional access-time modification-time)

@@ -717,9 +772,9 @@
                (values integer (cl:truncate (* fractional 1000000)))))
            (maybe-syscall-error (value)
              (if (minusp value)
                (values integer (cl:truncate (* fractional 1000000)))))
            (maybe-syscall-error (value)
              (if (minusp value)

-                 (syscall-error)
+                 (syscall-error 'utimes)

                  value)))
                  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 +800,18 @@
   (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 +831,7 @@
 #+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 +851,7 @@
   (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 +859,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))