[Sbcl-commits] CVS: sbcl/contrib/sb-posix interface.lisp, 1.29, 1.30 macros.lisp, 1.16, 1.17

[Juho S. <js...@us...>]

Update of /cvsroot/sbcl/sbcl/contrib/sb-posix
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv7608/contrib/sb-posix

Modified Files:
	interface.lisp macros.lisp 
Log Message:
0.9.18.46:
        Support files >2GB on Linux/x86. 

        * Compile the runtime (and the C type grovelers) with various flags
          to enable a 64-bit off_t.
        * Add C-side wrappers for various POSIX functions, so that we can 
          reliably get the largefile versions of them from Lisp-side.


Index: interface.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-posix/interface.lisp,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -d -r1.29 -r1.30
--- interface.lisp	12 Nov 2006 09:20:22 -0000	1.29
+++ interface.lisp	12 Nov 2006 23:04:59 -0000	1.30
@@ -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)
@@ -320,7 +323,8 @@
                   (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

Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-posix/macros.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- macros.lisp	13 Apr 2006 22:52:56 -0000	1.16
+++ macros.lisp	12 Nov 2006 23:04:59 -0000	1.17
@@ -17,9 +17,26 @@
   (null (sb-alien:sap-alien (sb-sys:int-sap 0) (* t)))
   ((alien (* t)) alien-pointer-to-anything-or-nil))
 
-(defun lisp-for-c-symbol (s)
-  (let ((root (if (eql #\_ (char s 0)) (subseq s 1) s)))
-    (intern (substitute #\- #\_ (string-upcase root)) :sb-posix)))
+(defun lisp-for-c-symbol (name)
+  (etypecase name
+    (list
+     (lisp-for-c-symbol (car name)))
+    (string
+     (let ((root (if (eql #\_ (char name 0)) (subseq name 1) name)))
+       (intern (substitute #\- #\_ (string-upcase root)) :sb-posix)))))
+
+(defun real-c-name (name)
+  (etypecase name
+    (list
+     (destructuring-bind (name &rest options) name
+
+       (cond #+largefile
+             ((member :largefile options)
+              (format nil "~a_largefile" name))
+             (t
+              name))))
+    (string
+     name)))
 
 (defmacro define-call-internally (lisp-name c-name return-type error-predicate
                                   &rest arguments)
@@ -50,11 +67,12 @@
       `(sb-int:style-warn "Didn't find definition for ~S" ,c-name)))
 
 (defmacro define-call (name return-type error-predicate &rest arguments)
-  (let ((lisp-name (lisp-for-c-symbol name)))
+  (let ((lisp-name (lisp-for-c-symbol name))
+        (real-c-name (real-c-name name)))
     `(progn
        (export ',lisp-name :sb-posix)
        (define-call-internally ,lisp-name
-           ,name
+           ,real-c-name
          ,return-type
          ,error-predicate
          ,@arguments))))