X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-posix%2Finterface.lisp;h=110a4eab0ad3ae064064bb40a98267d9fa43b8b4;hb=f7ba8c211a140c8c517c1122581dae63bedf672a;hp=cef0c715553e1fc026f95a7c80aef3c17043e365;hpb=2abe57fab08f09e167f7abad410f8ad4fd120a57;p=sbcl.git

diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp
index cef0c71..110a4ea 100644
--- a/contrib/sb-posix/interface.lisp
+++ b/contrib/sb-posix/interface.lisp
@@ -66,6 +66,14 @@
 (defun syscall-error ()
   (error 'sb-posix:syscall-error :errno (get-errno)))
 
+(defun unsupported-error (lisp-name c-name)
+  (error "~S is unsupported by SBCL on this platform due to lack of ~A()."
+         lisp-name c-name))
+
+(defun unsupported-warning (lisp-name c-name)
+  (warn "~S is unsupported by SBCL on this platform due to lack of ~A()."
+        lisp-name c-name))
+
 (declaim (inline never-fails))
 (defun never-fails (&rest args)
   (declare (ignore args))
@@ -152,26 +160,47 @@
   (define-call "sync" void never-fails)
   (define-call ("truncate" :options :largefile)
       int minusp (pathname filename) (length off-t))
-  ;; FIXME: Windows does have _mktemp, which has a slightlty different
-  ;; interface
-  (defun mkstemp (template)
-    ;; we are emulating sb-alien's charset conversion for strings
-    ;; here, to accommodate for the call-by-reference nature of
-    ;; mkstemp's template strings.
-    (let ((arg (sb-ext:string-to-octets
-                (filename template)
-                :external-format sb-alien::*default-c-string-external-format*)))
-      (sb-sys:with-pinned-objects (arg)
-        (let ((result (alien-funcall (extern-alien "mkstemp"
-                                                   (function int c-string))
-                                     (sap-alien (sb-alien::vector-sap arg)
-                                                (* char)))))
-          (when (minusp result)
-            (syscall-error))
-          (values result
-                  (sb-ext:octets-to-string
-                   arg
-                   :external-format sb-alien::*default-c-string-external-format*))))))
+  #-win32
+  (macrolet ((def-mk*temp (lisp-name c-name result-type errorp dirp values)
+               (declare (ignore dirp))
+               (if (sb-sys:find-foreign-symbol-address c-name)
+                   `(progn
+                      (defun ,lisp-name (template)
+                        (let* ((external-format sb-alien::*default-c-string-external-format*)
+                               (arg (sb-ext:string-to-octets
+                                     (filename template)
+                                     :external-format external-format)))
+                          (sb-sys:with-pinned-objects (arg)
+                            ;; accommodate for the call-by-reference
+                            ;; nature of mks/dtemp's template strings.
+                            (let ((result (alien-funcall (extern-alien ,c-name
+                                                                       (function ,result-type system-area-pointer))
+                                                         (sb-alien::vector-sap arg))))
+                              (when (,errorp result)
+                                (syscall-error))
+                              ;; FIXME: We'd rather return pathnames, but other
+                              ;; SB-POSIX functions like this return strings...
+                              (let ((pathname (sb-ext:octets-to-string
+                                               arg :external-format external-format)))
+                                ,(if values
+                                     '(values result pathname)
+                                     'pathname))))))
+                      (export ',lisp-name))
+                   `(progn
+                      (defun ,lisp-name (template)
+                        (declare (ignore template))
+                        (unsupported-error ',lisp-name ,c-name))
+                      (define-compiler-macro ,lisp-name (&whole form template)
+                        (declare (ignore template))
+                        (unsupported-warning ',lisp-name ,c-name)
+                        form)
+                      (export ',lisp-name)))))
+    (def-mk*temp mktemp "mktemp" (* char) null-alien nil nil)
+    ;; FIXME: Windows does have _mktemp, which has a slightly different
+    ;; interface
+    (def-mk*temp mkstemp "mkstemp" int minusp nil t)
+    ;; FIXME: What about Windows?
+    (def-mk*temp mkdtemp "mkdtemp" (* char) null-alien t nil))
   (define-call-internally ioctl-without-arg "ioctl" int minusp
                           (fd file-descriptor) (cmd int))
   (define-call-internally ioctl-with-int-arg "ioctl" int minusp
@@ -192,11 +221,32 @@
   (define-call-internally fcntl-with-pointer-arg "fcntl" int minusp
                           (fd file-descriptor) (cmd int)
                           (arg alien-pointer-to-anything-or-nil))
+  (define-protocol-class flock alien-flock ()
+   ((type :initarg :type :accessor flock-type
+          :documentation "Type of lock; F_RDLCK, F_WRLCK, F_UNLCK.")
+    (whence :initarg :whence :accessor flock-whence
+            :documentation "Flag for starting offset.")
+    (start :initarg :start :accessor flock-start
+           :documentation "Relative offset in bytes.")
+    (len :initarg :len :accessor flock-len
+         :documentation "Size; if 0 then until EOF.")
+    ;; Note: PID isn't initable, and is read-only.  But other stuff in
+    ;; SB-POSIX right now loses when a protocol-class slot is unbound,
+    ;; so we initialize it to 0.
+    (pid :initform 0 :reader flock-pid
+         :documentation
+         "Process ID of the process holding the lock; returned with F_GETLK."))
+   (:documentation "Class representing locks used in fcntl(2)."))
   (define-entry-point "fcntl" (fd cmd &optional (arg nil argp))
     (if argp
         (etypecase arg
           ((alien int) (fcntl-with-int-arg fd cmd arg))
-          ((or (alien (* t)) null) (fcntl-with-pointer-arg fd cmd arg)))
+          ((or (alien (* t)) null) (fcntl-with-pointer-arg fd cmd arg))
+          (flock (with-alien-flock a-flock ()
+                   (flock-to-alien arg a-flock)
+                   (let ((r (fcntl-with-pointer-arg fd cmd a-flock)))
+                     (alien-to-flock a-flock arg)
+                     r))))
         (fcntl-without-arg fd cmd)))
 
   ;; uid, gid