From 126e0a851c7e170b13c206c530083fc48572ea60 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 29 Oct 2003 19:14:59 +0000 Subject: [PATCH] 0.8.5.15: More SB-POSIX stuff ... merge patch from Zach Beane (sbcl-devel 2003-10-28) to wrap the stat S_ISFOO macros into callable functions ... merge patch CSR sbcl-devel to detect presence of various symbols at compile-time for conditional function definition ... slight frobs to make these two coexist: "interface" must depend on "alien", and these calls are NEVER-FAILS ... tests from Xach via #lisp IRC ... as yet unresolved: duplication of UNIX-DSO stuff Summarize contrib successes at the end of make.sh ... hope no-one's trisdekaphobic :-) --- contrib/sb-posix/alien/stat-macros.c | 61 ++++++++++++++++++++++++++++ contrib/sb-posix/interface.lisp | 25 ++++++++---- contrib/sb-posix/macros.lisp | 42 ++++++++++--------- contrib/sb-posix/posix-tests.lisp | 74 ++++++++++++++++++++++++++++++++-- contrib/sb-posix/sb-posix.asd | 72 ++++++++++++++++++++++++++++++++- make.sh | 10 +++-- src/code/target-load.lisp | 7 +++- version.lisp-expr | 2 +- 8 files changed, 255 insertions(+), 38 deletions(-) create mode 100644 contrib/sb-posix/alien/stat-macros.c diff --git a/contrib/sb-posix/alien/stat-macros.c b/contrib/sb-posix/alien/stat-macros.c new file mode 100644 index 0000000..dcd5593 --- /dev/null +++ b/contrib/sb-posix/alien/stat-macros.c @@ -0,0 +1,61 @@ +/* + * stat-macros.c + * + * Inspired mostly by section 4.3 and 4.21 of APUE + * + */ + +#include +#include +#include + +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 +} + + diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index b942f3e..bd7ed8d 100644 --- a/contrib/sb-posix/interface.lisp +++ b/contrib/sb-posix/interface.lisp @@ -33,8 +33,6 @@ (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)) @@ -65,26 +63,26 @@ ;;; 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)) @@ -152,6 +150,16 @@ (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) @@ -166,3 +174,4 @@ (syscall-error))) (values (aref filedes2 0) (aref filedes2 1))) +(define-call "frobozz" int minusp) diff --git a/contrib/sb-posix/macros.lisp b/contrib/sb-posix/macros.lisp index 959843b..882ac62 100644 --- a/contrib/sb-posix/macros.lisp +++ b/contrib/sb-posix/macros.lisp @@ -43,22 +43,26 @@ (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))))) diff --git a/contrib/sb-posix/posix-tests.lisp b/contrib/sb-posix/posix-tests.lisp index 2b8ff6e..c95359e 100644 --- a/contrib/sb-posix/posix-tests.lisp +++ b/contrib/sb-posix/posix-tests.lisp @@ -12,7 +12,7 @@ (defvar *current-directory* *default-pathname-defaults*) (defvar *this-file* *load-truename*) - + (deftest chdir.1 (sb-posix:chdir *test-directory*) 0) @@ -47,7 +47,7 @@ (sb-posix:syscall-error (c) (sb-posix:syscall-errno c))) #.sb-posix::enotdir) - + (deftest mkdir.1 (let ((dne (make-pathname :directory '(:relative "mkdir.does-not-exist.1")))) (unwind-protect @@ -84,7 +84,7 @@ (sb-posix:syscall-error (c) (sb-posix:syscall-errno c))) #.sb-posix::eacces) - + (deftest rmdir.1 (let ((dne (make-pathname :directory '(:relative "rmdir.does-not-exist.1")))) (ensure-directories-exist (merge-pathnames dne *test-directory*)) @@ -153,7 +153,7 @@ (sb-posix:rmdir dir) (sb-posix:syscall-errno c)))) #.sb-posix::eacces) - + (deftest stat.1 (let* ((stat (sb-posix:stat *test-directory*)) (mode (sb-posix::stat-mode stat))) @@ -205,7 +205,73 @@ (sb-posix:rmdir dir) (sb-posix:syscall-errno c)))) #.sb-posix::eacces) + +;;; 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) + ;;; see comment in filename's designator definition, in macros.lisp (deftest filename-designator.1 (let ((file (format nil "~A/[foo].txt" (namestring *test-directory*)))) diff --git a/contrib/sb-posix/sb-posix.asd b/contrib/sb-posix/sb-posix.asd index 6756d45..3fead6a 100644 --- a/contrib/sb-posix/sb-posix.asd +++ b/contrib/sb-posix/sb-posix.asd @@ -3,15 +3,85 @@ (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) diff --git a/make.sh b/make.sh index 284d240..776e97b 100755 --- a/make.sh +++ b/make.sh @@ -104,10 +104,14 @@ sh make-target-2.sh || exit 1 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)." diff --git a/src/code/target-load.lisp b/src/code/target-load.lisp index 56e0441..2e687c5 100644 --- a/src/code/target-load.lisp +++ b/src/code/target-load.lisp @@ -298,9 +298,12 @@ ;;; 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) diff --git a/version.lisp-expr b/version.lisp-expr index b370eaa..3702019 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4