(defun c-for-function (stream lisp-name alien-defn)
(destructuring-bind (c-name &rest definition) alien-defn
(let ((*print-right-margin* nil))
- (format stream "printf(\"(declaim (inline ~A))\\n\");~%"
+ (format stream "printf(\"(cl:declaim (cl:inline ~A))\\n\");~%"
lisp-name)
(princ "printf(\"(sb-grovel::define-foreign-routine (" stream)
(princ "\\\"" stream) (princ c-name stream) (princ "\\\" " stream)
(princ lisp-name stream)
(princ " ) " stream)
+ (terpri stream)
(dolist (d definition)
(write d :length nil
:right-margin nil :stream stream)
(defun print-c-source (stream headers definitions package-name)
(let ((*print-right-margin* nil))
+ (format stream "#define SIGNEDP(x) (((x)-1)<0)~%")
+ (format stream "#define SIGNED_(x) (SIGNEDP(x)?\"\":\"un\")~%")
(loop for i in headers
do (format stream "#include <~A>~%" i))
(format stream "main() { ~%
printf(\"(in-package ~S)\\\n\");~%" package-name)
- (format stream "printf(\"(deftype int () '(signed-byte %d))\\\n\",8*sizeof (int));~%")
- (format stream "printf(\"(deftype char () '(unsigned-byte %d))\\\n\",8*sizeof (char));~%")
- (format stream "printf(\"(deftype long () '(unsigned-byte %d))\\\n\",8*sizeof (long));~%")
+ (format stream "printf(\"(cl:deftype int () '(%ssigned-byte %d))\\\n\",SIGNED_(int),8*sizeof (int));~%")
+ (format stream "printf(\"(cl:deftype char () '(unsigned-byte %d))\\\n\",SIGNED_(char),8*sizeof (char));~%")
+ (format stream "printf(\"(cl:deftype long () '(unsigned-byte %d))\\\n\",SIGNED_(long),8*sizeof (long));~%")
(dolist (def definitions)
(destructuring-bind (type lispname cname &optional doc) def
(cond ((eq type :integer)
(format stream
- "printf(\"(defconstant ~A %d \\\"~A\\\")\\\n\",~A);~%"
+ "printf(\"(cl:defconstant ~A %d \\\"~A\\\")\\\n\",~A);~%"
lispname doc cname))
+ ((eq type :type)
+ (format stream
+ "printf(\"(sb-alien:define-alien-type ~A (sb-alien:%ssigned %d))\\\n\",SIGNED_(~A),8*(sizeof(~A)));~%"
+ lispname cname cname))
((eq type :string)
(format stream
- "printf(\"(defvar ~A %S \\\"~A\\\")\\\n\",~A);~%"
+ "printf(\"(cl:defvar ~A %S \\\"~A\\\")\\\n\",~A);~%"
lispname doc cname))
((eq type :function)
(c-for-function stream lispname cname))
--- /dev/null
+SYSTEM=sb-posix
+include ../asdf-module.mk
--- /dev/null
+-*- Text -*-
+
+* Scope
+
+The scope of this interface is "operating system calls on a typical
+Unixlike platform". This is section 2 of the Unix manual, plus
+section 3 calls that are (a) typically found in libc, but (b) not part
+of the C standard. For example, we intend to provide support for
+opendir() and readdir() , but not for printf()
+
+Some facilities are omitted where they offer absolutely no additional
+use over some portable function, or would be actively dangerous to the
+consistency of Lisp. Not all functions are available on all
+platforms. [TBD: unavailable functions should (a) not exist, or (b)
+exist but signal some kind of "not available on this platform" error]
+
+The general intent is for a low-level interface. There are three
+reasons for this: it's easier to write a high-level interface given a
+low-level one than vice versa, there are fewer philosophical
+disagreements about what it should look like, and the work of
+implementing it is easily parallelisable - and in fact, can be
+attempted on an as-needed basis by the various people who want it.
+
+* Function names
+
+The package name for this interface is SB-POSIX. In this package
+there is a Lisp function for each supported Unix function, and a
+variable or constant for each supported unix constant. A symbol name
+is derived from the C binding's name, by (a) uppercasing, then (b)
+replacing underscore (#\_) characters with the hyphen (#\-)
+
+No other changes to "Lispify" symbol names are made, so creat()
+becomes CREAT, not CREATE
+
+The user is encouraged not to (USE-PACKAGE :SB-POSIX) but instead to
+use the SB-POSIX: prefix on all references, as some of our symbols
+have the same name as CL symbols (OPEN, CLOSE, SIGNAL etc).
+
+[ Rationale: We use similar names to the C bindings so that unix
+manual pages can be used for documentation. To avoid name clashes
+with CL or other functions, the approaches considered were (a) prefix
+the names of clashing symbols with "POSIX-" or similar, (b) prefix
+_all_ symbols with "POSIX-", (c) use the packaging system to resolve
+ambiguities. (a) was rejected as the set of symbols we may
+potentially clash with is not fixed (for example, if new symbols are
+added to SB-EXT) so symbols might have to be renamed over the lifetime
+of SB-POSIX, which is not good. The choice between (b) and (c) was
+made on the grounds that POSIX-OPEN is about as much typing as
+SB-POSIX:OPEN anyway, and symbol munging is, the author feels,
+slightly tacky, when there's a package system available to do it more
+cleanly ]
+
+
+* Parameters
+
+The calling convention is modelled after that of CMUCL's UNIX package:
+in particular, it's like the C interface except
+
+a) length arguments are omitted or optional where the sensible value
+is obvious. For example,
+
+(read fd buffer &optional (length (length buffer))) => bytes-read
+
+b) where C simulates "out" parameters using pointers (for instance, in
+pipe() or socketpair()) we may use multiple return values instead.
+This doesn't apply to data transfer functions that fill buffers.
+
+c) some functions accept objects such as filenames or file
+descriptors. In the C bindings these are strings and small integers
+respectively. For the Lisp programmer's convenience we introduce
+"filename designators" and "file descriptor designator" concepts such
+that CL pathnames or open streams can be passed to these functions.
+
+[ Rationale: Keeping exact 1:1 correspondence with C conventions is
+less important here, as the function argument list can easily be
+accessed to find out exactly what the arguments are. Designators
+are primarily a convenience feature ]
+
+* Return values
+
+The return value is usually the same as for the C binding, except in
+error cases: where the C function is defined as returning some
+sentinel value and setting "errno" on error, we instead signal an
+error of type SYSCALL-ERROR. The actual error value ("errno") is
+stored in this condition and can be accessed with SYSCALL-ERRNO.
+[TBA: some interface to strerror, to get the user-readable translation
+of the error number]
+
+We do not automatically translate the returned value into "Lispy"
+objects - for example, SB-POSIX:OPEN returns a small integer, not a
+stream.
+
+[ Rationale: This is an interface to POSIX, not a high-level interface
+that uses POSIX, and many people using it will actually want to mess
+with the file descriptors directly. People needing Lispy interfaces
+can implement them atop this - or indeed, use the existing COMMON-LISP
+package, which already has many high-level constructs built on top of
+the operating system ;-) ]
+
+
+* Implementation
+
+The initial implementation is in contrib/sb-posix, and being filled
+out on an as-needed basis. Contributions following these style rules
+are welcome from anyone who writes them, provided the author is happy
+to release the code as Public Domain or MIT-style licence.
+
+See/update the TODO list for current status
+
+** Designators
+
+See designator.lisp, add a define-designator form
+
+** Adding functions
+
+The use of DEFINE-CALL macro in interface.lisp should be obvious from
+the existing examples, if less so from the macroexpansion
+
--- /dev/null
+1) optional arguments
+
+3) partial list of section 2 manpages from Debian Linux box: functions
+we may want to consider interfaces for. Some of the obviously
+unnecessary/dangerous functions have been deleted from this list, as
+have the ones we've already got bindings for, but even so, inclusion
+in this list does _not_ imply we've definitely decided something needs
+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
+getdtablesize
+getgroups
+gethostid
+gethostname
+getitimer
+getpagesize
+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
+mmap
+modify_ldt
+mount
+mprotect
+mpx
+mremap
+msgctl
+msgget
+msgop
+msgrcv
+msgsnd
+msync
+munlock
+munlockall
+munmap
+nanosleep
+nice
+open
+pause
+pipe
+poll
+prctl
+pread
+prof
+profil
+pselect
+ptrace
+pwrite
+query_module
+quotactl
+read
+readdir
+readlink
+readv
+reboot
+recv
+recvfrom
+recvmsg
+rename
+rmdir
+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
+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
+wait4
+waitpid
+write
+writev
--- /dev/null
+;;; -*- Lisp -*-
+
+;;; This isn't really lisp, but it's definitely a source file.
+
+;;; first, the headers necessary to find definitions of everything
+(#||#
+ "sys/types.h"
+ "unistd.h"
+ "sys/stat.h"
+
+ "sys/socket.h" "sys/un.h" "netinet/in.h" "netinet/in_systm.h"
+ "netinet/ip.h" "net/if.h" "netdb.h" "errno.h" "netinet/tcp.h"
+ "fcntl.h" )
+
+;;; then the stuff we're looking for
+((:integer af-inet "AF_INET" "IP Protocol family")
+
+ (:type uid-t "uid_t")
+ (:type gid-t "gid_t")
+
+ (:type pid-t "pid_t")
+
+ ;; mode_t
+ (:type mode-t "mode_t")
+ (:integer s-isuid "S_ISUID")
+ (:integer s-isgid "S_ISGID")
+ (:integer s-isvtx "S_ISVTX")
+ (:integer s-irusr "S_IRUSR")
+ (:integer s-iwusr "S_IWUSR")
+ (:integer s-ixusr "S_IXUSR")
+ (:integer s-iread "S_IRUSR")
+ (:integer s-iwrite "S_IWUSR")
+ (:integer s-iexec "S_IXUSR")
+ (:integer s-irgrp "S_IRGRP")
+ (:integer s-iwgrp "S_IWGRP")
+ (:integer s-ixgrp "S_IXGRP")
+ (:integer s-iroth "S_IROTH")
+ (:integer s-iwoth "S_IWOTH")
+ (:integer s-ixoth "S_IXOTH")
+
+ ;; access()
+ (:integer r-ok "R_OK")
+ (:integer w-ok "W_OK")
+ (:integer x-ok "X_OK")
+ (:integer f-ok "F_OK")
+ )
\ No newline at end of file
--- /dev/null
+(defpackage :sb-posix (:use ))
+(defpackage :sb-posix-internal (:use #:sb-alien #:cl))
--- /dev/null
+(in-package :sb-posix-internal)
+(defmacro define-designator (name result &body conversions)
+ (let ((type `(quote (or ,@(mapcar #'car conversions))))
+ (typename (intern (format nil "~A-~A"
+ (symbol-name name)
+ (symbol-name :designator))
+ #.*package*)))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (deftype ,typename () ,type)
+ (setf (get ',name 'designator-type) ',result))
+ (defun ,(intern (symbol-name name) :sb-posix) (,name)
+ (declare (type ,typename ,name))
+ (etypecase ,name
+ ,@conversions)))))
+
+(define-designator filename c-string
+ (pathname (namestring (translate-logical-pathname filename)))
+ (string filename))
+
+(define-designator file-descriptor (integer 32)
+ (sb-impl::file-stream (sb-impl::fd-stream-fd file-descriptor))
+ (fixnum file-descriptor))
+
--- /dev/null
+(cl:in-package :sb-posix-internal)
+
+(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)))
+ (format s "System call error ~A (~A)"
+ errno (sb-int:strerror errno))))))
+
+(defun syscall-error ()
+ (error 'sb-posix::syscall-error :errno (get-errno)))
+
+;;; filesystem access
+
+(define-call "access" int minusp (pathname filename) (mode int))
+(define-call "chdir" int minusp (pathname filename))
+(define-call "chmod" int minusp (pathname filename) (mode sb-posix::mode-t))
+(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 "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 "lchown" int minusp (pathname filename)
+ (owner sb-posix::uid-t) (group sb-posix::gid-t))
+(define-call "mkdir" int minusp (pathname filename) (mode sb-posix::mode-t))
+;;(define-call "readlink" int minusp (path filename) (buf (* t)) (len int))
+(define-call "rmdir" int minusp (pathname filename))
+(define-call "symlink" int minusp (oldpath filename) (newpath filename))
+(define-call "unlink" int minusp (pathname filename))
+
+
+;;; uid, gid
+
+(define-call "geteuid" sb-posix::uid-t not) ;"always successful", it says
+(define-call "getresuid" sb-posix::uid-t not)
+(define-call "getuid" sb-posix::uid-t not)
+(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
+ (ruid sb-posix::uid-t) (euid sb-posix::uid-t))
+(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 not)
+(define-call "getgid" sb-posix::gid-t not)
+(define-call "getresgid" sb-posix::gid-t not)
+(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))
+(define-call "setregid" int minusp
+ (rgid sb-posix::gid-t) (egid sb-posix::gid-t))
+(define-call "setresgid" int minusp
+ (rgid 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 "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 "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 "pause" int minusp)
+(define-call "setpgid" int minusp
+ (pid sb-posix::pid-t) (pgid sb-posix::pid-t))
+(define-call "setpgrp" int minusp)
--- /dev/null
+(in-package :sb-posix-internal)
+
+(defun lisp-for-c-symbol (s)
+ (intern (substitute #\- #\_ (string-upcase s)) :sb-posix))
+
+(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)
+ (get (cadr x) 'designator-type (cadr x)))
+ arguments)))
+ ,@(mapcar (lambda (x)
+ (if (get (cadr x) 'designator-type)
+ `(,(intern (symbol-name (cadr x)) :sb-posix)
+ ,(car x))
+ (car x)))
+ arguments))))
+ (if (,error-predicate r) (syscall-error) r))))))
--- /dev/null
+;;; -*- Lisp -*-
+(require :sb-grovel)
+(defpackage #:sb-posix-system (:use #:asdf #:cl #:sb-grovel))
+(in-package #:sb-posix-system)
+
+(defsystem sb-posix
+ :depends-on (sb-grovel)
+ :components ((:file "defpackage")
+ (:file "designator" :depends-on ("defpackage"))
+ (:file "macros" :depends-on ("defpackage"))
+ (sb-grovel:grovel-constants-file
+ "constants"
+ :package :sb-posix :depends-on ("defpackage"))
+ (:file "interface" :depends-on ("constants" "macros"))))
+
+#|
+(defmethod perform ((o test-op) (c (eql (find-system :sb-grovel))))
+ t)
+
+|#
\ No newline at end of file
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.pre8.56"
+"0.pre8.57"
projects / sbcl.git / commitdiff