X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-posix%2Finterface.lisp;h=0995a1d23c20cf2057885d942d4391ac6a64d9f1;hb=4fd24714c780827eec742db55297940ed7160ea7;hp=c111e7660c6bd17380d1cf3f4f85fe7036165874;hpb=4043155e2cccdd0872b6cc59570010c0e20d5e00;p=sbcl.git

diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp
index c111e76..0995a1d 100644
--- a/contrib/sb-posix/interface.lisp
+++ b/contrib/sb-posix/interface.lisp
@@ -126,6 +126,15 @@
 (define-call* "unlink" int minusp (pathname filename))
 (define-call #-netbsd "opendir" #+netbsd "_opendir"
     (* t) null-alien (pathname filename))
+#+inode64
+(define-call ("readdir" :c-name "readdir$INODE64" :options :largefile)
+  (* dirent)
+  ;; readdir() has the worst error convention in the world.  It's just
+  ;; too painful to support.  (return is NULL _and_ errno "unchanged"
+  ;; is not an error, it's EOF).
+  not
+  (dir (* t)))
+#-inode64
 (define-call (#-netbsd "readdir" #+netbsd "_readdir" :options :largefile)
   (* dirent)
   ;; readdir() has the worst error convention in the world.  It's just
@@ -169,7 +178,8 @@
                         (let* ((external-format sb-alien::*default-c-string-external-format*)
                                (arg (sb-ext:string-to-octets
                                      (filename template)
-                                     :external-format external-format)))
+                                     :external-format external-format
+                                     :null-terminate t)))
                           (sb-sys:with-pinned-objects (arg)
                             ;; accommodate for the call-by-reference
                             ;; nature of mks/dtemp's template strings.
@@ -181,7 +191,8 @@
                               ;; 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)))
+                                               arg :external-format external-format
+                                               :end (1- (length arg)))))
                                 ,(if values
                                      '(values result pathname)
                                      'pathname))))))
@@ -279,10 +290,16 @@
     (define-call "setup_mach_exceptions" void never-fails)
     (define-call ("posix_fork" :c-name "fork") pid-t minusp)
     (defun fork ()
-      (let ((pid (posix-fork)))
-        (when (= pid 0)
-          (setup-mach-exceptions))
-        pid))
+      (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
@@ -506,7 +523,9 @@
 
 (defmacro define-stat-call (name arg designator-fun type)
   ;; FIXME: this isn't the documented way of doing this, surely?
-  (let ((lisp-name (lisp-for-c-symbol name)))
+  (let ((lisp-name (lisp-for-c-symbol name))
+        (real-name #+inode64 (format nil "~A$INODE64" name)
+                   #-inode64 name))
     `(progn
       (export ',lisp-name :sb-posix)
       (declaim (inline ,lisp-name))
@@ -514,7 +533,7 @@
         (declare (type (or null stat) stat))
         (with-alien-stat a-stat ()
           (let ((r (alien-funcall
-                    (extern-alien ,(real-c-name (list name :options :largefile)) ,type)
+                    (extern-alien ,(real-c-name (list real-name :options :largefile)) ,type)
                     (,designator-fun ,arg)
                     a-stat)))
             (when (minusp r)
@@ -613,6 +632,11 @@
          (syscall-error))
        (setf termios (alien-to-termios a-termios termios))))
    termios)
+ (define-call "tcdrain" int minusp (fd file-descriptor))
+ (define-call "tcflow" int minusp (fd file-descriptor) (action int))
+ (define-call "tcflush" int minusp (fd file-descriptor) (queue-selector int))
+ (define-call "tcgetsid" pid-t minusp (fd file-descriptor))
+ (define-call "tcsendbreak" int minusp (fd file-descriptor) (duration int))
  (export 'cfsetispeed :sb-posix)
  (declaim (inline cfsetispeed))
  (defun cfsetispeed (speed &optional termios)
@@ -715,7 +739,10 @@
 
 ;;; environment
 
-(export 'getenv :sb-posix)
+(eval-when (:compile-toplevel :load-toplevel)
+  ;; Do this at compile-time as Win32 code below refers to it as
+  ;; sb-posix:getenv.
+  (export 'getenv :sb-posix))
 (defun getenv (name)
   (let ((r (alien-funcall
             (extern-alien "getenv" (function (* char) c-string))
@@ -723,7 +750,40 @@
     (declare (type (alien (* char)) r))
     (unless (null-alien r)
       (cast r c-string))))
-(define-call "putenv" int minusp (string 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))
+  (export 'putenv :sb-posix)
+  (defun putenv (string)
+    (declare (string string))
+    ;; We don't want to call actual putenv: the string passed to putenv ends
+    ;; up in environ, and we any string we allocate GC might move.
+    ;;
+    ;; This makes our wrapper nonconformant if you squit hard enough, but
+    ;; users who care about that should really be calling putenv() directly in
+    ;; order to be able to manage memory sanely.
+    (let ((p (position #\= string))
+          (n (length string)))
+      (if p
+          (if (= p n)
+              (unsetenv (subseq string 0 p))
+              (setenv (subseq string 0 p) (subseq string (1+ p)) 1))
+          (error "Invalid argument to putenv: ~S" string)))))
+#+win32
+(progn
+  ;; Windows doesn't define a POSIX setenv, but happily their _putenv is sane.
+  (define-call* "putenv" int minusp (string c-string))
+  (export 'setenv :sb-posix)
+  (defun setenv (name value overwrite)
+    (declare (string name value))
+    (if (and (zerop overwrite) (sb-posix:getenv name))
+        0
+        (putenv (concatenate 'string name "=" value))))
+  (export 'unsetenv :sb-posix)
+  (defun unsetenv (name)
+    (declare (string name))
+    (putenv (concatenate 'string name "="))))
 
 ;;; syslog
 #-win32