--- /dev/null
+/*
+ * stat-macros.c
+ *
+ * Inspired mostly by section 4.3 and 4.21 of APUE
+ *
+ */
+
+#include <sys/types.h>
+#include <sys/stat.h>
+#include <unistd.h>
+
+mode_t s_isreg(mode_t mode)
+{
+ return S_ISREG(mode);
+}
+
+
+mode_t s_isdir(mode_t mode)
+{
+ return S_ISDIR(mode);
+}
+
+
+mode_t s_ischr(mode_t mode)
+{
+ return S_ISCHR(mode);
+}
+
+
+mode_t s_isblk(mode_t mode)
+{
+ return S_ISBLK(mode);
+}
+
+
+mode_t s_isfifo(mode_t mode)
+{
+ return S_ISFIFO(mode);
+}
+
+
+mode_t s_islnk(mode_t mode)
+{
+#ifdef S_ISLNK
+ return S_ISLNK(mode);
+#else
+ return ((mode & S_IFMT) == S_IFLNK);
+#endif
+}
+
+
+mode_t s_issock(mode_t mode)
+{
+#ifdef S_ISSOCK
+ return S_ISSOCK(mode);
+#else
+ return ((mode & S_IFMT) == S_IFSOCK);
+#endif
+}
+
+
(define-call "fdatasync" int minusp (fd file-descriptor))
(define-call "ftruncate" int minusp (fd file-descriptor) (length sb-posix::off-t))
(define-call "fsync" int minusp (fd file-descriptor))
-;;; no lchown on Darwin
-#-darwin
(define-call "lchown" int minusp (pathname filename)
(owner sb-posix::uid-t) (group sb-posix::gid-t))
(define-call "link" int minusp (oldpath filename) (newpath filename))
;;; uid, gid
(define-call "geteuid" sb-posix::uid-t never-fails) ; "always successful", it says
-#+linux (define-call "getresuid" sb-posix::uid-t never-fails)
+(define-call "getresuid" sb-posix::uid-t never-fails)
(define-call "getuid" sb-posix::uid-t never-fails)
(define-call "seteuid" int minusp (uid sb-posix::uid-t))
-#+linux (define-call "setfsuid" int minusp (uid sb-posix::uid-t))
+(define-call "setfsuid" int minusp (uid sb-posix::uid-t))
(define-call "setreuid" int minusp
(ruid sb-posix::uid-t) (euid sb-posix::uid-t))
-#+linux (define-call "setresuid" int minusp
+(define-call "setresuid" int minusp
(ruid sb-posix::uid-t) (euid sb-posix::uid-t)
(suid sb-posix::uid-t))
(define-call "setuid" int minusp (uid sb-posix::uid-t))
(define-call "getegid" sb-posix::gid-t never-fails)
(define-call "getgid" sb-posix::gid-t never-fails)
-#+linux (define-call "getresgid" sb-posix::gid-t never-fails)
+(define-call "getresgid" sb-posix::gid-t never-fails)
(define-call "setegid" int minusp (gid sb-posix::gid-t))
-#+linux (define-call "setfsgid" int minusp (gid sb-posix::gid-t))
+(define-call "setfsgid" int minusp (gid sb-posix::gid-t))
(define-call "setgid" int minusp (gid sb-posix::gid-t))
(define-call "setregid" int minusp
(rgid sb-posix::gid-t) (egid sb-posix::gid-t))
-#+linux (define-call "setresgid" int minusp
+(define-call "setresgid" int minusp
(rgid sb-posix::gid-t)
(egid sb-posix::gid-t) (sgid sb-posix::gid-t))
(define-stat-call "fstat" fd sb-posix::file-descriptor
(function int int (* t)))
+
+;;; mode flags
+(define-call "s_isreg" sb-posix::mode-t never-fails (mode sb-posix::mode-t))
+(define-call "s_isdir" sb-posix::mode-t never-fails (mode sb-posix::mode-t))
+(define-call "s_ischr" sb-posix::mode-t never-fails (mode sb-posix::mode-t))
+(define-call "s_isblk" sb-posix::mode-t never-fails (mode sb-posix::mode-t))
+(define-call "s_isfifo" sb-posix::mode-t never-fails (mode sb-posix::mode-t))
+(define-call "s_islnk" sb-posix::mode-t never-fails (mode sb-posix::mode-t))
+(define-call "s_issock" sb-posix::mode-t never-fails (mode sb-posix::mode-t))
+
(export 'sb-posix::pipe :sb-posix)
(declaim (inline sb-posix::pipe))
(defun sb-posix::pipe (&optional filedes2)
(syscall-error)))
(values (aref filedes2 0) (aref filedes2 1)))
+(define-call "frobozz" int minusp)
(defmacro define-call (name return-type error-predicate &rest arguments)
(let ((lisp-name (lisp-for-c-symbol name)))
- `(progn
- (export ',lisp-name :sb-posix)
- (declaim (inline ,lisp-name))
- (defun ,lisp-name ,(mapcar #'car arguments)
- (let ((r (alien-funcall
- (extern-alien
- ,name
- (function ,return-type
- ,@(mapcar
- (lambda (x)
- (gethash (cadr x) *designator-types* (cadr x)))
- arguments)))
- ,@(mapcar (lambda (x)
- (if (nth-value 1 (gethash (cadr x) *designator-types*))
- `(,(intern (symbol-name (cadr x)) :sb-posix)
- ,(car x))
- (car x)))
- arguments))))
- (if (,error-predicate r) (syscall-error) r))))))
+ (if (sb-fasl::foreign-symbol-address-as-integer-or-nil name)
+ `(progn
+ (export ',lisp-name :sb-posix)
+ (declaim (inline ,lisp-name))
+ (defun ,lisp-name ,(mapcar #'car arguments)
+ (let ((r (alien-funcall
+ (extern-alien
+ ,name
+ (function ,return-type
+ ,@(mapcar
+ (lambda (x)
+ (gethash (cadr x) *designator-types* (cadr x)))
+ arguments)))
+ ,@(mapcar (lambda (x)
+ (if (nth-value 1 (gethash (cadr x) *designator-types*))
+ `(,(intern (symbol-name (cadr x)) :sb-posix)
+ ,(car x))
+ (car x)))
+ arguments))))
+ (if (,error-predicate r) (syscall-error) r))))
+ `(progn
+ (export ',lisp-name :sb-posix)
+ (sb-int:style-warn "Didn't find definition for ~S" ,name)))))
(defvar *current-directory* *default-pathname-defaults*)
(defvar *this-file* *load-truename*)
-
+\f
(deftest chdir.1
(sb-posix:chdir *test-directory*)
0)
(sb-posix:syscall-error (c)
(sb-posix:syscall-errno c)))
#.sb-posix::enotdir)
-
+\f
(deftest mkdir.1
(let ((dne (make-pathname :directory '(:relative "mkdir.does-not-exist.1"))))
(unwind-protect
(sb-posix:syscall-error (c)
(sb-posix:syscall-errno c)))
#.sb-posix::eacces)
-
+\f
(deftest rmdir.1
(let ((dne (make-pathname :directory '(:relative "rmdir.does-not-exist.1"))))
(ensure-directories-exist (merge-pathnames dne *test-directory*))
(sb-posix:rmdir dir)
(sb-posix:syscall-errno c))))
#.sb-posix::eacces)
-
+\f
(deftest stat.1
(let* ((stat (sb-posix:stat *test-directory*))
(mode (sb-posix::stat-mode stat)))
(sb-posix:rmdir dir)
(sb-posix:syscall-errno c))))
#.sb-posix::eacces)
+\f
+;;; stat-mode tests
+(defmacro with-stat-mode ((mode pathname) &body body)
+ (let ((stat (gensym)))
+ `(let* ((,stat (sb-posix:stat ,pathname))
+ (,mode (sb-posix::stat-mode ,stat)))
+ ,@body)))
+
+(defmacro with-lstat-mode ((mode pathname) &body body)
+ (let ((stat (gensym)))
+ `(let* ((,stat (sb-posix:lstat ,pathname))
+ (,mode (sb-posix::stat-mode ,stat)))
+ ,@body)))
+
+(deftest stat-mode.1
+ (with-stat-mode (mode *test-directory*)
+ (sb-posix:s-isreg mode))
+ 0)
+
+(deftest stat-mode.2
+ (with-stat-mode (mode *test-directory*)
+ (zerop (sb-posix:s-isdir mode)))
+ nil)
+
+(deftest stat-mode.3
+ (with-stat-mode (mode *test-directory*)
+ (sb-posix:s-ischr mode))
+ 0)
+(deftest stat-mode.4
+ (with-stat-mode (mode *test-directory*)
+ (sb-posix:s-isblk mode))
+ 0)
+
+(deftest stat-mode.5
+ (with-stat-mode (mode *test-directory*)
+ (sb-posix:s-isfifo mode))
+ 0)
+
+(deftest stat-mode.6
+ (with-stat-mode (mode *test-directory*)
+ (sb-posix:s-issock mode))
+ 0)
+
+(deftest stat-mode.7
+ (let ((link-pathname (make-pathname :name "stat-mode.7"
+ :defaults *test-directory*)))
+ (unwind-protect
+ (progn
+ (sb-posix:symlink *test-directory* link-pathname)
+ (with-lstat-mode (mode link-pathname)
+ (zerop (sb-posix:s-islnk mode))))
+ (ignore-errors (sb-posix:unlink link-pathname))))
+ nil)
+
+(deftest stat-mode.8
+ (let ((pathname (make-pathname :name "stat-mode.8"
+ :defaults *test-directory*)))
+ (unwind-protect
+ (progn
+ (with-open-file (out pathname :direction :output)
+ (write-line "test" out))
+ (with-stat-mode (mode pathname)
+ (zerop (sb-posix:s-isreg mode))))
+ (ignore-errors (delete-file pathname))))
+ nil)
+\f
;;; see comment in filename's designator definition, in macros.lisp
(deftest filename-designator.1
(let ((file (format nil "~A/[foo].txt" (namestring *test-directory*))))
(defpackage #:sb-posix-system (:use #:asdf #:cl #:sb-grovel))
(in-package #:sb-posix-system)
+
+;;; we also have a shared library with some .o files in it
+;;;
+;;; FIXME: we share this with SB-BSD-SOCKETS. This should either (a)
+;;; be part of ASDF itself, or (b) be in a shared file that we can
+;;; LOAD at this point.
+(defclass unix-dso (module) ())
+(defun unix-name (pathname)
+ (namestring
+ (typecase pathname
+ (logical-pathname (translate-logical-pathname pathname))
+ (t pathname))))
+
+(defmethod asdf::input-files ((operation compile-op) (dso unix-dso))
+ (mapcar #'component-pathname (module-components dso)))
+
+(defmethod output-files ((operation compile-op) (dso unix-dso))
+ (let ((dir (component-pathname dso)))
+ (list
+ (make-pathname :type "so"
+ :name (car (last (pathname-directory dir)))
+ :directory (butlast (pathname-directory dir))
+ :defaults dir))))
+
+
+(defmethod perform :after ((operation compile-op) (dso unix-dso))
+ (let ((dso-name (unix-name (car (output-files operation dso)))))
+ (unless (zerop
+ (run-shell-command
+ "gcc ~A -o ~S ~{~S ~}"
+ (if (sb-ext:posix-getenv "LDFLAGS")
+ (sb-ext:posix-getenv "LDFLAGS")
+ #+sunos "-shared -lresolv -lsocket -lnsl"
+ #+darwin "-bundle"
+ #-(or darwin sunos) "-shared")
+ dso-name
+ (mapcar #'unix-name
+ (mapcan (lambda (c)
+ (output-files operation c))
+ (module-components dso)))))
+ (error 'operation-error :operation operation :component dso))))
+
+;;; if this goes into the standard asdf, it could reasonably be extended
+;;; to allow cflags to be set somehow
+(defmethod output-files ((op compile-op) (c c-source-file))
+ (list
+ (make-pathname :type "o" :defaults
+ (component-pathname c))))
+(defmethod perform ((op compile-op) (c c-source-file))
+ (unless
+ (= 0 (run-shell-command "gcc ~A -o ~S -c ~S"
+ (if (sb-ext:posix-getenv "CFLAGS")
+ (sb-ext:posix-getenv "CFLAGS")
+ "-fPIC")
+ (unix-name (car (output-files op c)))
+ (unix-name (component-pathname c))))
+ (error 'operation-error :operation op :component c)))
+
+(defmethod perform ((operation load-op) (c c-source-file))
+ t)
+
+(defmethod perform ((o load-op) (c unix-dso))
+ (let ((co (make-instance 'compile-op)))
+ (let ((filename (car (output-files co c))))
+ #+cmu (ext:load-foreign filename)
+ #+sbcl (sb-alien:load-1-foreign filename))))
+
+
(defsystem sb-posix
:depends-on (sb-grovel)
:components ((:file "defpackage")
(:file "designator" :depends-on ("defpackage"))
+ (:unix-dso "alien"
+ :components ((:c-source-file "stat-macros")))
(:file "macros" :depends-on ("designator"))
(sb-grovel:grovel-constants-file
"constants"
:package :sb-posix :depends-on ("defpackage"))
- (:file "interface" :depends-on ("constants" "macros" "designator"))))
+ (:file "interface" :depends-on ("constants" "macros" "designator" "alien"))))
(defsystem sb-posix-tests
:depends-on (sb-rt)
sh make-target-contrib.sh || exit 1
# Sometimes people used to see the "No tests failed." output from the last
-# DEFTEST in contrib self-tests and thing that's all that is. So...
+# DEFTEST in contrib self-tests and think that's all that is. So...
+NCONTRIBS=`find contrib -name Makefile -print | wc -l`
+NPASSED=`find contrib -name test-passed -print | wc -l`
+
echo
-echo The build seems to have finished successfully. If you would like
-echo run more extensive tests on the new SBCL, you can try
+echo The build seems to have finished successfully, including $NPASSED
+echo (out of $NCONTRIBS) contributed modules. If you would like to run
+echo more extensive tests on the new SBCL, you can try
echo " cd tests && sh ./run-tests.sh"
echo "(but expect some failures on non-x86 platforms)."
;;; SB!SYS:GET-DYNAMIC-FOREIGN-SYMBOL-ADDRESS is in foreign.lisp, on
;;; platforms that have dynamic loading
+(defun foreign-symbol-address-as-integer-or-nil (foreign-symbol)
+ (or (find-foreign-symbol-in-table foreign-symbol *static-foreign-symbols*)
+ (sb!sys:get-dynamic-foreign-symbol-address foreign-symbol)))
+
(defun foreign-symbol-address-as-integer (foreign-symbol)
- (or (find-foreign-symbol-in-table foreign-symbol *static-foreign-symbols*)
- (sb!sys:get-dynamic-foreign-symbol-address foreign-symbol)
+ (or (foreign-symbol-address-as-integer-or-nil foreign-symbol)
(error "unknown foreign symbol: ~S" foreign-symbol)))
(defun foreign-symbol-address (symbol)
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.5.14"
+"0.8.5.15"
projects / sbcl.git / commitdiff