(let* ((ty (cond
((eql type (intern "INTEGER"))
`(,type ,(* 8 length)))
- ((and (listp type) (eql (car type) (intern "*"))) ; pointer
+ ((and (consp type) (eql (car type) (intern "*"))) ; pointer
`(unsigned ,(* 8 length)))
((eql type (intern "C-STRING")) ; c-string as array
`(base-char 8))
- ((and (listp type) (eql (car type) (intern "ARRAY")))
- (cadr type))))
+ ((and (consp type) (eql (car type) (intern "ARRAY")))
+ (cadr type))
+ ((let ((type (sb-alien-internals:unparse-alien-type
+ (sb-alien-internals:parse-alien-type type nil))))
+ (cond
+ ((consp type)
+ (case (car type)
+ (signed `(integer ,(cadr type)))
+ (unsigned type)))
+ (t (error "foo")))))))
(sap-ref-? (intern (format nil "~ASAP-REF-~A"
(if (member (car ty) '(INTEGER SIGNED))
"SIGNED-" "")
(cadr ty))
(find-package "SB-SYS"))))
- (labels ((template (before after)
- `(let* ((addr (+ 8 (logandc1 7 (sb-kernel:get-lisp-obj-address ptr))))
- (sap (sb-sys:int-sap (the (unsigned-byte 32) (+ addr ,offset)))))
+ (labels
+ ((template (before after)
+ `(let* ((addr
+ (the (unsigned-byte ,sb-vm:n-machine-word-bits)
+ (+ #.(ash 1 sb-vm:n-lowtag-bits)
+ (logandc1 #.(1- (ash 1 sb-vm:n-lowtag-bits))
+ (sb-kernel:get-lisp-obj-address ptr)))))
+ (sap (sb-sys:int-sap
+ (the (unsigned-byte ,sb-vm:n-machine-word-bits)
+ (+ addr ,offset)))))
(,before (,sap-ref-? sap index) ,after))))
`(progn
;;(declaim (inline ,el (setf ,el)))
(defun ,el (ptr &optional (index 0))
- (declare (optimize (speed 3)))
+ (declare (optimize (speed 3) (safety 0)))
(sb-sys:without-gcing
,(if (eql type (intern "C-STRING"))
`(naturalize-bounded-c-string ptr ,offset ,length)
(template 'prog1 nil))))
(defconstant ,(intern (format nil "OFFSET-OF-~A" el)) ,offset)
(defun (setf ,el) (newval ptr &optional (index 0))
- (declare (optimize (speed 3)))
+ (declare (optimize (speed 3) (safety 0)))
(sb-sys:without-gcing
,(if (eql type (intern "C-STRING"))
`(set-bounded-c-string ptr ,offset ,length newval)
(defun ,(p "ALLOCATE-") () (make-array ,size :initial-element 0
:element-type '(unsigned-byte 8)))
(defconstant ,(p "SIZE-OF-") ,size)
+ (deftype ,name () '(simple-array (unsigned-byte 8) (,size)))
(defun ,(p "FREE-" ) (p) (declare (ignore p)))
(defmacro ,(p "WITH-") (var (&rest field-values) &body body)
(labels ((field-name (x)
--- /dev/null
+test-passed
a.out
*.lisp-temp
foo.c
+test-lab
test-passed
-1) optional arguments
+1) optional arguments (e.g. OPEN)
3) partial list of section 2 manpages from Debian Linux box: functions
we may want to consider interfaces for. Some of the obviously
adding.
FD_CLR FD_ISSET FD_SET FD_ZERO accept acct adjtime adjtimex bdflush
-bind break brk cacheflush capget capset chroot clone connect creat
-create_module delete_module execve exit fcntl fdatasync flock fork
-fstat fstatfs fsync ftime ftruncate getcontext getdents getdomainname
+bind break brk cacheflush capget capset chroot clone connect
+create_module delete_module execve exit fcntl flock fork
+fstatfs ftime getcontext getdents getdomainname
getdtablesize getgroups gethostid gethostname getitimer
getpeername getpriority getrlimit getrusage getsockname getsockopt
gettimeofday gtty idle init_module ioctl ioctl_list ioperm iopl listen
-llseek lock lseek lstat madvise mincore mknod mlock mlockall
+llseek lock madvise mincore mknod mlock mlockall
modify_ldt mount mprotect mpx mremap msgctl msgget msgop msgrcv msgsnd
-munlock munlockall nanosleep nice open pause pipe poll
+munlock munlockall nanosleep nice pause poll
prctl pread prof profil pselect ptrace pwrite query_module quotactl
-read readlink readv reboot recv recvfrom recvmsg rename rmdir
+read readlink readv reboot recv recvfrom recvmsg
sbrk sched_get_priority_max sched_get_priority_min sched_getparam
sched_getscheduler sched_rr_get_interval sched_setparam
sched_setscheduler sched_yield select semctl semget semop send
sendfile sendmsg sendto setcontext setdomainname setgroups sethostid
sethostname setitimer setpgrp setpriority setrlimit setsid setsockopt
settimeofday sgetmask shmat shmctl shmdt shmget shmop shutdown
- sigaction sigaltstack sigblock siggetmask sigmask signal sigpause
+sigaction sigaltstack sigblock siggetmask sigmask signal sigpause
sigpending sigprocmask sigreturn sigsetmask sigsuspend sigvec socket
-socketcall socketpair ssetmask stat statfs stime stty swapoff swapon
-symlink sync syscalls sysctl sysfs sysinfo syslog time times truncate
-ulimit umask umount uname ustat utime utimes vfork vhangup wait wait3
+socketcall socketpair ssetmask statfs stime stty swapoff swapon
+syscalls sysctl sysfs sysinfo syslog time times
+ulimit umount uname ustat utime utimes vfork vhangup wait wait3
wait4 waitpid write writev
4) In the spec but not implemented:
(:type gid-t "gid_t")
(:type pid-t "pid_t")
+ (:type ino-t "ino_t")
+ (:type nlink-t "nlink_t")
+ (:type time-t "time_t")
+ (:type dev-t "dev_t")
+
;; signals
(:integer SIGHUP "SIGHUP" #+sb-doc "terminal line hangup.")
(:integer SIGINT "SIGINT" #+sb-doc "interrupt program.")
(:integer SIGUSR2 "SIGUSR2" #+sb-doc "User defined signal 2.")
(:integer SIGRTMIN "SIGRTMIN" #+sb-doc "Smallest real-time signal number.")
(:integer SIGRTMAX "SIGRTMAX" #+sb-doc "Largest real-time signal number.")
+
+ ;; error numbers
+ (:integer eperm "EPERM")
+ (:integer enoent "ENOENT")
+ (:integer esrch "ESRCH")
+ (:integer eintr "EINTR")
+ (:integer eio "EIO")
+ (:integer enxio "ENXIO")
+ (:integer e2big "E2BIG")
+ (:integer enoexec "ENOEXEC")
+ (:integer ebadf "EBADF")
+ (:integer echild "ECHILD")
+ (:integer eagain "EAGAIN")
+ (:integer enomem "ENOMEM")
+ (:integer eacces "EACCES")
+ (:integer efault "EFAULT")
+ (:integer enotblk "ENOTBLK")
+ (:integer ebusy "EBUSY")
+ (:integer eexist "EEXIST")
+ (:integer exdev "EXDEV")
+ (:integer enodev "ENODEV")
+ (:integer enotdir "ENOTDIR")
+ (:integer eisdir "EISDIR")
+ (:integer einval "EINVAL")
+ (:integer enfile "ENFILE")
+ (:integer emfile "EMFILE")
+ (:integer enotty "ENOTTY")
+ (:integer etxtbsy "ETXTBSY")
+ (:integer efbig "EFBIG")
+ (:integer enospc "ENOSPC")
+ (:integer espipe "ESPIPE")
+ (:integer erofs "EROFS")
+ (:integer emlink "EMLINK")
+ (:integer epipe "EPIPE")
+ (:integer edom "EDOM")
+ (:integer erange "ERANGE")
+ (:integer edeadlk "EDEADLK")
+ (:integer enametoolong "ENAMETOOLONG")
+ (:integer enolck "ENOLCK")
+ (:integer enosys "ENOSYS")
+ (:integer enotempty "ENOTEMPTY")
+ (:integer eloop "ELOOP")
+ (:integer ewouldblock "EWOULDBLOCK")
+ (:integer enomsg "ENOMSG")
+ (:integer eidrm "EIDRM")
+ (:integer echrng "ECHRNG")
+ (:integer el2nsync "EL2NSYNC")
+ (:integer el3hlt "EL3HLT")
+ (:integer el3rst "EL3RST")
+ (:integer elnrng "ELNRNG")
+ (:integer eunatch "EUNATCH")
+ (:integer enocsi "ENOCSI")
+ (:integer el2hlt "EL2HLT")
+ (:integer ebade "EBADE")
+ (:integer ebadr "EBADR")
+ (:integer exfull "EXFULL")
+ (:integer enoano "ENOANO")
+ (:integer ebadrqc "EBADRQC")
+ (:integer ebadslt "EBADSLT")
+ (:integer edeadlock "EDEADLOCK")
+ (:integer ebfont "EBFONT")
+ (:integer enostr "ENOSTR")
+ (:integer enodata "ENODATA")
+ (:integer etime "ETIME")
+ (:integer enosr "ENOSR")
+ (:integer enonet "ENONET")
+ (:integer enopkg "ENOPKG")
+ (:integer eremote "EREMOTE")
+ (:integer enolink "ENOLINK")
+ (:integer eadv "EADV")
+ (:integer esrmnt "ESRMNT")
+ (:integer ecomm "ECOMM")
+ (:integer eproto "EPROTO")
+ (:integer emultihop "EMULTIHOP")
+ (:integer edotdot "EDOTDOT")
+ (:integer ebadmsg "EBADMSG")
+ (:integer eoverflow "EOVERFLOW")
+ (:integer enotuniq "ENOTUNIQ")
+ (:integer ebadfd "EBADFD")
+ (:integer eremchg "EREMCHG")
+ (:integer elibacc "ELIBACC")
+ (:integer elibbad "ELIBBAD")
+ (:integer elibscn "ELIBSCN")
+ (:integer elibmax "ELIBMAX")
+ (:integer elibexec "ELIBEXEC")
+ (:integer eilseq "EILSEQ")
+ (:integer erestart "ERESTART")
+ (:integer estrpipe "ESTRPIPE")
+ (:integer eusers "EUSERS")
+ (:integer enotsock "ENOTSOCK")
+ (:integer edestaddrreq "EDESTADDRREQ")
+ (:integer emsgsize "EMSGSIZE")
+ (:integer eprototype "EPROTOTYPE")
+ (:integer enoprotoopt "ENOPROTOOPT")
+ (:integer eprotonosupport "EPROTONOSUPPORT")
+ (:integer esocktnosupport "ESOCKTNOSUPPORT")
+ (:integer eopnotsupp "EOPNOTSUPP")
+ (:integer epfnosupport "EPFNOSUPPORT")
+ (:integer eafnosupport "EAFNOSUPPORT")
+ (:integer eaddrinuse "EADDRINUSE")
+ (:integer eaddrnotavail "EADDRNOTAVAIL")
+ (:integer enetdown "ENETDOWN")
+ (:integer enetunreach "ENETUNREACH")
+ (:integer enetreset "ENETRESET")
+ (:integer econnaborted "ECONNABORTED")
+ (:integer econnreset "ECONNRESET")
+ (:integer enobufs "ENOBUFS")
+ (:integer eisconn "EISCONN")
+ (:integer enotconn "ENOTCONN")
+ (:integer eshutdown "ESHUTDOWN")
+ (:integer etoomanyrefs "ETOOMANYREFS")
+ (:integer etimedout "ETIMEDOUT")
+ (:integer econnrefused "ECONNREFUSED")
+ (:integer ehostdown "EHOSTDOWN")
+ (:integer ehostunreach "EHOSTUNREACH")
+ (:integer ealready "EALREADY")
+ (:integer einprogress "EINPROGRESS")
+ (:integer estale "ESTALE")
+ (:integer euclean "EUCLEAN")
+ (:integer enotnam "ENOTNAM")
+ (:integer enavail "ENAVAIL")
+ (:integer eremoteio "EREMOTEIO")
+ (:integer edquot "EDQUOT")
+ (:integer enomedium "ENOMEDIUM")
+ (:integer emediumtype "EMEDIUMTYPE")
;; mode_t
(:type mode-t "mode_t")
("struct dirent"
(:c-string name "char *" "d_name"
:distrust-length #+sunos t #-sunos nil)))
+
+ (:structure stat
+ ("struct stat"
+ (mode-t mode "mode_t" "st_mode")
+ (ino-t ino "ino_t" "st_ino")
+ (dev-t dev "dev_t" "st_dev")
+ (nlink-t nlink "nlink_t" "st_nlink")
+ (uid-t uid "uid_t" "st_uid")
+ (gid-t gid "gid_t" "st_gid")
+ (off-t size "off_t" "st_size")
+ (time-t atime "time_t" "st_atime")
+ (time-t mtime "time_t" "st_mtime")
+ (time-t ctime "time_t" "st_ctime")))
+
+ ;; open()
+ (:integer o-creat "O_CREAT")
+ (:integer o-excl "O_EXCL")
+ (:integer o-noctty "O_NOCTTY")
+ (:integer o-trunc "O_TRUNC")
+ (:integer o-append "O_APPEND")
+ (:integer o-nonblock "O_NONBLOCK")
+ (:integer o-ndelay "O_NDELAY")
+ (:integer o-sync "O_SYNC")
+ (:integer o-nofollow "O_NOFOLLOW")
+ (:integer o-directory "O_DIRECTORY")
+ (:integer o-direct "O_DIRECT")
+ (:integer o-async "O_ASYNC")
+ (:integer o-largefile "O_LARGEFILE") ; hmm...
+
+ ;; lseek()
+ (:integer seek-set "SEEK_SET")
+ (:integer seek-cur "SEEK_CUR")
+ (:integer seek-end "SEEK_END")
)
(defpackage :sb-posix (:use)
- (:export #:syscall-error))
+ (:export #:syscall-error #:syscall-errno))
(defpackage :sb-posix-internal (:use #:sb-alien #:cl))
(cl:in-package :sb-posix-internal)
-(define-condition sb-posix::syscall-error (error)
- ((errno :initarg :errno :reader sb-posix::syscall-errno))
+(define-condition sb-posix:syscall-error (error)
+ ((errno :initarg :errno :reader sb-posix:syscall-errno))
(:report (lambda (c s)
- (let ((errno (sb-posix::syscall-errno c)))
+ (let ((errno (sb-posix:syscall-errno c)))
(format s "System call error ~A (~A)"
errno (sb-int:strerror errno))))))
(defun syscall-error ()
(error 'sb-posix:syscall-error :errno (get-errno)))
+(declaim (inline never-fails))
+(defun never-fails (&rest args)
+ (declare (ignore args))
+ nil)
+
;;; filesystem access
(define-call "access" int minusp (pathname filename) (mode int))
(define-call "chown" int minusp (pathname filename)
(owner sb-posix::uid-t) (group sb-posix::gid-t))
(define-call "close" int minusp (fd file-descriptor))
+(define-call "creat" int minusp (pathname filename) (mode sb-posix::mode-t))
(define-call "dup" int minusp (oldfd file-descriptor))
(define-call "dup2" int minusp (oldfd file-descriptor) (newfd file-descriptor))
(define-call "fchdir" int minusp (fd file-descriptor))
(define-call "fchmod" int minusp (fd file-descriptor) (mode sb-posix::mode-t))
(define-call "fchown" int minusp (fd file-descriptor)
(owner sb-posix::uid-t) (group sb-posix::gid-t))
-(define-call "link" int minusp (oldpath filename) (newpath filename))
+(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))
+(define-call "lseek" sb-posix::off-t minusp (fd file-descriptor) (offset sb-posix::off-t) (whence int))
(define-call "mkdir" int minusp (pathname filename) (mode sb-posix::mode-t))
+(define-call "mkfifo" int minusp (pathname filename) (mode sb-posix::mode-t))
+;;; FIXME: MODE arg should be optional?
+(define-call "open" int minusp (pathname filename) (flags int) (mode sb-posix::mode-t))
;;(define-call "readlink" int minusp (path filename) (buf (* t)) (len int))
+(define-call "rename" int minusp (oldpath filename) (newpath filename))
(define-call "rmdir" int minusp (pathname filename))
(define-call "symlink" int minusp (oldpath filename) (newpath filename))
+(define-call "sync" void never-fails)
+(define-call "truncate" int minusp (pathname filename) (length sb-posix::off-t))
(define-call "unlink" int minusp (pathname filename))
(define-call "opendir" (* t) null-alien (pathname filename))
not
(dir (* t)))
(define-call "closedir" int minusp (dir (* t)))
-
+
+(define-call "umask" sb-posix::mode-t never-fails (mode sb-posix::mode-t))
+
;;; uid, gid
-(define-call "geteuid" sb-posix::uid-t not) ;"always successful", it says
-#+linux (define-call "getresuid" sb-posix::uid-t not)
-(define-call "getuid" sb-posix::uid-t not)
+(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 "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 "setreuid" int minusp
(suid sb-posix::uid-t))
(define-call "setuid" int minusp (uid sb-posix::uid-t))
-(define-call "getegid" sb-posix::gid-t not)
-(define-call "getgid" sb-posix::gid-t not)
-#+linux (define-call "getresgid" sb-posix::gid-t not)
+(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 "setegid" int minusp (gid sb-posix::gid-t))
#+linux (define-call "setfsgid" int minusp (gid sb-posix::gid-t))
(define-call "setgid" int minusp (gid sb-posix::gid-t))
(egid sb-posix::gid-t) (sgid sb-posix::gid-t))
;;; processes, signals
-(define-call "alarm" int not (seconds unsigned))
+(define-call "alarm" int never-fails (seconds unsigned))
(define-call "getpgid" sb-posix::pid-t minusp (pid sb-posix::pid-t))
-(define-call "getpid" sb-posix::pid-t not)
-(define-call "getppid" sb-posix::pid-t not)
-(define-call "getpgrp" sb-posix::pid-t not)
+(define-call "getpid" sb-posix::pid-t never-fails)
+(define-call "getppid" sb-posix::pid-t never-fails)
+(define-call "getpgrp" sb-posix::pid-t never-fails)
(define-call "getsid" sb-posix::pid-t minusp (pid sb-posix::pid-t))
(define-call "kill" int minusp (pid sb-posix::pid-t) (signal int))
(define-call "killpg" int minusp (pgrp int) (signal int))
(define-call "getpagesize" int minusp)
+(defmacro define-stat-call (name arg designator-fun type)
+ ;; FIXME: this isn't the documented way of doing this, surely?
+ (let ((lisp-name (intern (string-upcase name) :sb-posix)))
+ `(progn
+ (export ',lisp-name :sb-posix)
+ (declaim (inline ,lisp-name))
+ (defun ,lisp-name (,arg &optional stat)
+ (declare (type (or null sb-posix::stat) stat))
+ (unless stat
+ (setq stat (sb-posix::allocate-stat)))
+ ;; FIXME: Hmm. WITH-PINNED-OBJECTS/WITHOUT-GCING or something
+ ;; is probably needed round here.
+ (let* ((s (sb-sys:int-sap
+ ;; FIXME: WILL NOT WORK ON 64-BIT LISP. VECTOR-SAP
+ ;; would be better if the STAT object were
+ ;; guaranteed to be a vector, but it's not (and may
+ ;; well turn into an alien soon).
+ (+ 8 (logandc2 (sb-kernel:get-lisp-obj-address stat) 7))))
+ (r (alien-funcall
+ (extern-alien ,name ,type)
+ (,designator-fun ,arg)
+ s)))
+ (when (minusp r)
+ (syscall-error)))
+ stat))))
+(define-stat-call "stat" pathname sb-posix::filename
+ ;; FIXME: (* T)? Ew. (* STAT) would be preferable
+ (function int c-string (* t)))
+(define-stat-call "lstat" pathname sb-posix::filename
+ (function int c-string (* t)))
+(define-stat-call "fstat" fd sb-posix::file-descriptor
+ (function int int (* t)))
+
+(export 'sb-posix::pipe :sb-posix)
+(declaim (inline sb-posix::pipe))
+(defun sb-posix::pipe (&optional filedes2)
+ (declare (type (or null (simple-array (signed-byte 32) (2))) filedes2))
+ (unless filedes2
+ (setq filedes2 (make-array 2 :element-type '(signed-byte 32))))
+ (let ((r (alien-funcall
+ ;; FIXME: (* INT)? (ARRAY INT 2) would be better
+ (extern-alien "pipe" (function int (* int)))
+ (sb-sys:vector-sap filedes2))))
+ (when (minusp r)
+ (syscall-error)))
+ (values (aref filedes2 0) (aref filedes2 1)))
+
--- /dev/null
+(defpackage "SB-POSIX-TESTS"
+ (:use "COMMON-LISP" "SB-RT"))
+
+(in-package "SB-POSIX-TESTS")
+
+(defvar *test-directory*
+ (ensure-directories-exist
+ (merge-pathnames (make-pathname :directory '(:relative "test-lab"))
+ (make-pathname :directory
+ (pathname-directory *load-truename*)))))
+
+(defvar *current-directory* *default-pathname-defaults*)
+
+(defvar *this-file* *load-truename*)
+
+(deftest chdir.1
+ (sb-posix:chdir *test-directory*)
+ 0)
+
+(deftest chdir.2
+ (sb-posix:chdir (namestring *test-directory*))
+ 0)
+
+(deftest chdir.3
+ (sb-posix:chdir "/")
+ 0)
+
+(deftest chdir.4
+ (sb-posix:chdir #p"/")
+ 0)
+
+(deftest chdir.5
+ (sb-posix:chdir *current-directory*)
+ 0)
+
+(deftest chdir.error.1
+ (let ((dne (make-pathname :directory '(:relative "chdir.does-not-exist"))))
+ (handler-case
+ (sb-posix:chdir (merge-pathnames dne *test-directory*))
+ (sb-posix:syscall-error (c)
+ (sb-posix:syscall-errno c))))
+ #.sb-posix::enoent)
+
+(deftest chdir.error.2
+ (handler-case
+ (sb-posix:chdir *this-file*)
+ (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
+ (sb-posix:mkdir (merge-pathnames dne *test-directory*) 0)
+ ;; FIXME: no delete-directory in CL, but using our own operators
+ ;; is probably not ideal
+ (ignore-errors (sb-posix:rmdir (merge-pathnames dne *test-directory*)))))
+ 0)
+
+(deftest mkdir.2
+ (let ((dne (make-pathname :directory '(:relative "mkdir.does-not-exist.2"))))
+ (unwind-protect
+ (sb-posix:mkdir (namestring (merge-pathnames dne *test-directory*)) 0)
+ (ignore-errors (sb-posix:rmdir (merge-pathnames dne *test-directory*)))))
+ 0)
+
+(deftest mkdir.error.1
+ (handler-case
+ (sb-posix:mkdir *test-directory* 0)
+ (sb-posix:syscall-error (c)
+ (sb-posix:syscall-errno c)))
+ #.sb-posix::eexist)
+
+(deftest mkdir.error.2
+ (handler-case
+ (sb-posix:mkdir "/" 0)
+ (sb-posix:syscall-error (c)
+ (sb-posix:syscall-errno c)))
+ #.sb-posix::eexist)
+
+(deftest mkdir.error.3
+ (handler-case
+ (sb-posix:mkdir "/almost-certainly-does-not-exist" 0)
+ (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*))
+ (sb-posix:rmdir (merge-pathnames dne *test-directory*)))
+ 0)
+
+(deftest rmdir.2
+ (let ((dne (make-pathname :directory '(:relative "rmdir.does-not-exist.2"))))
+ (ensure-directories-exist (merge-pathnames dne *test-directory*))
+ (sb-posix:rmdir (namestring (merge-pathnames dne *test-directory*))))
+ 0)
+
+(deftest rmdir.error.1
+ (let ((dne (make-pathname :directory '(:relative "rmdir.dne.error.1"))))
+ (handler-case
+ (sb-posix:rmdir (merge-pathnames dne *test-directory*))
+ (sb-posix:syscall-error (c)
+ (sb-posix:syscall-errno c))))
+ #.sb-posix::enoent)
+
+(deftest rmdir.error.2
+ (handler-case
+ (sb-posix:rmdir *this-file*)
+ (sb-posix:syscall-error (c)
+ (sb-posix:syscall-errno c)))
+ #.sb-posix::enotdir)
+
+(deftest rmdir.error.3
+ (handler-case
+ (sb-posix:rmdir "/")
+ (sb-posix:syscall-error (c)
+ (sb-posix:syscall-errno c)))
+ #.sb-posix::ebusy)
+
+(deftest rmdir.error.4
+ (let* ((dir (ensure-directories-exist
+ (merge-pathnames
+ (make-pathname :directory '(:relative "rmdir.error.4"))
+ *test-directory*)))
+ (file (make-pathname :name "foo" :defaults dir)))
+ (with-open-file (s file :direction :output)
+ (write "" :stream s))
+ (handler-case
+ (sb-posix:rmdir dir)
+ (sb-posix:syscall-error (c)
+ (delete-file file)
+ (sb-posix:rmdir dir)
+ (sb-posix:syscall-errno c))))
+ #.sb-posix::enotempty)
+
+(deftest rmdir.error.5
+ (let* ((dir (merge-pathnames
+ (make-pathname :directory '(:relative "rmdir.error.5"))
+ *test-directory*))
+ (dir2 (merge-pathnames
+ (make-pathname :directory '(:relative "unremovable"))
+ dir)))
+ (sb-posix:mkdir dir #xffffffff)
+ (sb-posix:mkdir dir2 #xffffffff)
+ (sb-posix:chmod dir 0)
+ (handler-case
+ (sb-posix:rmdir dir2)
+ (sb-posix:syscall-error (c)
+ (sb-posix:chmod dir (logior sb-posix::s-iread sb-posix::s-iwrite sb-posix::s-iexec))
+ (sb-posix:rmdir dir2)
+ (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)))
+ ;; FIXME: Ugly ::s everywhere
+ (logand mode (logior sb-posix::s-iread sb-posix::s-iwrite sb-posix::s-iexec)))
+ #.(logior sb-posix::s-iread sb-posix::s-iwrite sb-posix::s-iexec))
+
+(deftest stat.2
+ (let* ((stat (sb-posix:stat "/root"))
+ (mode (sb-posix::stat-mode stat)))
+ (logand mode sb-posix::s-iwoth))
+ 0)
+
+(deftest stat.3
+ (let* ((now (get-universal-time))
+ ;; FIXME: (encode-universal-time 00 00 00 01 01 1970)
+ (unix-now (- now 2208988800))
+ (stat (sb-posix:stat *test-directory*))
+ (atime (sb-posix::stat-atime stat)))
+ ;; FIXME: breaks if mounted noatime :-(
+ (< (- atime unix-now) 10))
+ t)
+
+;;; FIXME: add tests for carrying a stat structure around in the
+;;; optional argument to SB-POSIX:STAT
+
+(deftest stat.error.1
+ (handler-case (sb-posix:stat "")
+ (sb-posix:syscall-error (c)
+ (sb-posix:syscall-errno c)))
+ #.sb-posix::enoent)
+
+(deftest stat.error.2
+ (let* ((dir (merge-pathnames
+ (make-pathname :directory '(:relative "stat.error.2"))
+ *test-directory*))
+ (file (merge-pathnames
+ (make-pathname :name "unstatable")
+ dir)))
+ (sb-posix:mkdir dir #xffffffff)
+ (with-open-file (s file :direction :output)
+ (write "" :stream s))
+ (sb-posix:chmod dir 0)
+ (handler-case
+ (sb-posix:stat file)
+ (sb-posix:syscall-error (c)
+ (sb-posix:chmod dir (logior sb-posix::s-iread sb-posix::s-iwrite sb-posix::s-iexec))
+ (sb-posix:unlink file)
+ (sb-posix:rmdir dir)
+ (sb-posix:syscall-errno c))))
+ #.sb-posix::eacces)
:package :sb-posix :depends-on ("defpackage"))
(:file "interface" :depends-on ("constants" "macros" "designator"))))
+(defsystem sb-posix-tests
+ :depends-on (sb-rt)
+ :components ((:file "posix-tests")))
+
(defmethod perform :after ((o load-op) (c (eql (find-system :sb-posix))))
(provide 'sb-posix))
(defmethod perform ((o test-op) (c (eql (find-system :sb-posix))))
- t)
+ (operate 'load-op 'sb-posix-tests)
+ (operate 'test-op 'sb-posix-tests))
+
+(defmethod perform ((o test-op) (c (eql (find-system :sb-posix-tests))))
+ (or (funcall (intern "DO-TESTS" (find-package "SB-RT")))
+ (error "test-op failed")))
(defsetf signed-sap-ref-16 %set-signed-sap-ref-16)
(defsetf sap-ref-32 %set-sap-ref-32)
(defsetf signed-sap-ref-32 %set-signed-sap-ref-32)
-#!+alpha (defsetf sap-ref-64 %set-sap-ref-64)
-#!+alpha (defsetf signed-sap-ref-64 %set-signed-sap-ref-64)
+(defsetf sap-ref-64 %set-sap-ref-64)
+(defsetf signed-sap-ref-64 %set-signed-sap-ref-64)
(defsetf sap-ref-sap %set-sap-ref-sap)
(defsetf sap-ref-single %set-sap-ref-single)
(defsetf sap-ref-double %set-sap-ref-double)
(declaim (type (or index null) *gc-trigger*))
(defvar *gc-trigger* nil)
-;;; When >0, inhibits garbage collection.
-(defvar *gc-inhibit*) ; initialized in cold init
-
;;; When T, indicates that a GC should have happened but did not due to
;;; *GC-INHIBIT*.
(defvar *need-to-collect-garbage* nil) ; initialized in cold init
(in-package "SB!IMPL")
-;;; FIXME Not the most sensible way to do this: we could just use
-;;; LOCK ADD, given that we don't need the old version. This will
-;;; do until we get around to writing new VOPs
-;;; FIXME in fact we're not SMP-safe without LOCK anyway, but
-;;; this will do us for UP systems
-
(defmacro atomic-incf/symbol (symbol-name &optional (delta 1))
#!-sb-thread
`(incf ,symbol-name ,delta)
(declare (optimize (safety 0) (speed 3)))
(sb!vm::locked-symbol-global-value-add ',symbol-name ,delta)))
+;;; When >0, inhibits garbage collection.
+(declaim (type index *gc-inhibit*))
+(defvar *gc-inhibit*) ; initialized in cold init
+
(defmacro without-gcing (&rest body)
#!+sb-doc
"Executes the forms in the body without doing a garbage collection."
(sap-ref-32 sap offset))
;;; Return the 64-bit quadword at OFFSET bytes from SAP.
-#!+alpha
(defun sap-ref-64 (sap offset)
(declare (type system-area-pointer sap)
(fixnum offset))
(signed-sap-ref-32 sap offset))
;;; Return the signed 64-bit quadword at OFFSET bytes from SAP.
-#!+alpha
(defun signed-sap-ref-64 (sap offset)
(declare (type system-area-pointer sap)
(fixnum offset))
(type (unsigned-byte 32) new-value))
(setf (sap-ref-32 sap offset) new-value))
-#!+alpha
(defun %set-sap-ref-64 (sap offset new-value)
(declare (type system-area-pointer sap)
(fixnum offset)
(type (signed-byte 32) new-value))
(setf (signed-sap-ref-32 sap offset) new-value))
-#!+alpha
(defun %set-signed-sap-ref-64 (sap offset new-value)
(declare (type system-area-pointer sap)
(fixnum offset)
(move result value)))))
;;; helper for alien stuff.
-(defmacro sb!sys::with-pinned-objects ((&rest objects) &body body)
+(defmacro with-pinned-objects ((&rest objects) &body body)
"Arrange with the garbage collector that the pages occupied by
OBJECTS will not be moved in memory for the duration of BODY.
Useful for e.g. foreign calls where another thread may trigger
;;; 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.1"
+"0.8.5.2"
projects / sbcl.git / commitdiff