0.9.18.46:

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

diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp
index 427efb1..e718b0c 100644 (file)
--- a/contrib/sb-posix/interface.lisp
+++ b/contrib/sb-posix/interface.lisp
@@ -83,8 +83,9 @@
 (define-call* "dup" int minusp (oldfd file-descriptor))
 (define-call* "dup2" int minusp (oldfd file-descriptor)
               (newfd file-descriptor))
-(define-call* "lseek" off-t minusp (fd file-descriptor) (offset off-t)
-              (whence int))
+(define-call* ("lseek" :largefile)
+    off-t minusp (fd file-descriptor) (offset off-t)
+    (whence int))
 (define-call* "mkdir" int minusp (pathname filename) (mode mode-t))
 (macrolet ((def (x)
                `(progn
@@ -123,7 +124,8 @@
   (define-call "fchown" int minusp (fd file-descriptor)
              (owner uid-t)  (group gid-t))
   (define-call "fdatasync" int minusp (fd file-descriptor))
-  (define-call "ftruncate" int minusp (fd file-descriptor) (length off-t))
+  (define-call ("ftruncate" :largefile)
+      int minusp (fd file-descriptor) (length off-t))
   (define-call "fsync" int minusp (fd file-descriptor))
   (define-call "lchown" int minusp (pathname filename)
                (owner uid-t)  (group gid-t))
@@ -131,7 +133,8 @@
   (define-call "mkfifo" int minusp (pathname filename) (mode mode-t))
   (define-call "symlink" int minusp (oldpath filename) (newpath filename))
   (define-call "sync" void never-fails)
-  (define-call "truncate" int minusp (pathname filename) (length off-t))
+  (define-call ("truncate" :largefile)
+      int minusp (pathname filename) (length off-t))
   ;; FIXME: Windows does have _mktemp, which has a slightlty different
   ;; interface
   (define-call "mkstemp" int minusp (template c-string))
@@ -238,7 +241,7 @@
 ;;; mmap, msync
 #-win32
 (progn
- (define-call "mmap" sb-sys:system-area-pointer
+ (define-call ("mmap" :largefile) sb-sys:system-area-pointer
    (lambda (res)
      (= (sb-sys:sap-int res) #.(1- (expt 2 sb-vm::n-machine-word-bits))))
    (addr sap-or-nil) (length unsigned) (prot unsigned)
@@ -305,7 +308,7 @@
         (declare (type (or null (sb-alien:alien (* alien-stat))) stat))
         (with-alien-stat a-stat ()
           (let ((r (alien-funcall
-                    (extern-alien ,name ,type)
+                    (extern-alien ,(real-c-name (list name :largefile)) ,type)
                     (,designator-fun ,arg)
                     a-stat)))
             (when (minusp r)
@@ -315,12 +318,13 @@
 ;; Note: _stat, _lstat, and _fstat for NetBSD are provided in
 ;; src/runtime/bsd-os.c.  See comments in that file
 ;; for an explanation. -- RMK 2006-10-15
-(define-stat-call #-(or win32 netbsd) "stat" #+(or win32 netbsd) "_stat" 
+(define-stat-call #-(or win32 netbsd) "stat" #+(or win32 netbsd) "_stat"
                   pathname filename
                   (function int c-string (* alien-stat)))
 
 #-win32
-(define-stat-call #-netbsd "lstat" #+netbsd "_lstat" pathname filename
+(define-stat-call #-netbsd "lstat" #+netbsd "_lstat"
+                  pathname filename
                   (function int c-string (* alien-stat)))
 ;;; No symbolic links on Windows, so use stat
 #+win32
@@ -445,6 +449,59 @@
                                  (function speed-t (* alien-termios)))
                     a-termios))))
 
+
+#-win32
+(progn
+  (export 'time :sb-posix)
+  (defun time ()
+    (let ((result (alien-funcall (extern-alien "time"
+                                               (function time-t (* time-t)))
+                                 nil)))
+      (if (minusp result)
+          (syscall-error)
+          result)))
+  (export 'utime :sb-posix)
+  (defun utime (filename &optional access-time modification-time)
+    (let ((fun (extern-alien "utime" (function int c-string
+                                               (* alien-utimbuf))))
+          (name (filename filename)))
+      (if (not (and access-time modification-time))
+          (alien-funcall fun name nil)
+          (with-alien ((utimbuf (struct alien-utimbuf)))
+            (setf (slot utimbuf 'actime) (or access-time 0)
+                  (slot utimbuf 'modtime) (or modification-time 0))
+            (let ((result (alien-funcall fun name (alien-sap utimbuf))))
+              (if (minusp result)
+                  (syscall-error)
+                  result))))))
+  (export 'utimes :sb-posix)
+  (defun utimes (filename &optional access-time modification-time)
+    (flet ((seconds-and-useconds (time)
+             (multiple-value-bind (integer fractional)
+                 (cl:truncate time)
+               (values integer (cl:truncate (* fractional 1000000)))))
+           (maybe-syscall-error (value)
+             (if (minusp value)
+                 (syscall-error)
+                 value)))
+      (let ((fun (extern-alien "utimes" (function int c-string
+                                                  (* (array alien-timeval 2)))))
+            (name (filename filename)))
+        (if (not (and access-time modification-time))
+            (maybe-syscall-error (alien-funcall fun name nil))
+            (with-alien ((buf (array alien-timeval 2)))
+              (let ((actime (deref buf 0))
+                    (modtime (deref buf 1)))
+                (setf (values (slot actime 'sec)
+                              (slot actime 'usec))
+                      (seconds-and-useconds (or access-time 0))
+                      (values (slot modtime 'sec)
+                              (slot modtime 'usec))
+                      (seconds-and-useconds (or modification-time 0)))
+                (maybe-syscall-error (alien-funcall fun name
+                                                    (alien-sap buf))))))))))
+
+
 ;;; environment
 
 (export 'getenv :sb-posix)