(destructuring-bind (c-name &rest elements) c-struct
(format stream "printf(\"(sb-grovel::define-c-struct ~A %d)\\n\",sizeof (~A));~%" lisp-name c-name)
(dolist (e elements)
- (destructuring-bind (lisp-type lisp-el-name c-type c-el-name) e
+ (destructuring-bind (lisp-type lisp-el-name c-type c-el-name &key distrust-length) e
;; FIXME: this format string doesn't actually guarantee
;; non-multilined-string-constantness, it just makes it more
;; likely. Sort out the required behaviour (and maybe make
(format stream "{ ~A t;printf(\"%d \",((unsigned long)&(t.~A)) - ((unsigned long)&(t)) ); }~%"
c-name c-el-name)
;; length
- (format stream "{ ~A t;printf(\"%d\",(sizeof t.~A));}~%"
- c-name c-el-name)
+ (if distrust-length
+ (format stream "printf(\"nil\");")
+ (format stream "{ ~A t;printf(\"%d\",(sizeof t.~A));}~%"
+ c-name c-el-name))
(format stream "printf(\")\\n\");~%")))))
(defun c-for-function (stream lisp-name alien-defn)
;;; (define-c-accessor STAT-ATIME STAT (INTEGER 32) 56 4)
-
(defmacro define-c-accessor (el structure type offset length)
(declare (ignore structure))
(let* ((ty (cond
- ((eql type 'integer) `(,type ,(* 8 length)))
- ((eql (car type) '*) `(unsigned ,(* 8 length)))
- ((eql type 'c-string) `(unsigned ,(* 8 length)))
- ((eql (car type) 'array) (cadr type))))
+ ((eql type (intern "INTEGER"))
+ `(,type ,(* 8 length)))
+ ((and (listp 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))))
(sap-ref-? (intern (format nil "~ASAP-REF-~A"
(if (member (car ty) '(INTEGER SIGNED))
"SIGNED-" "")
(sap (sb-sys:int-sap (the (unsigned-byte 32) (+ addr ,offset)))))
(,before (,sap-ref-? sap index) ,after))))
`(progn
- ;;(declaim (inline ,el (setf ,el)))
- (defun ,el (ptr &optional (index 0))
- (declare (optimize (speed 3)))
- (sb-sys:without-gcing
- ,(template 'prog1 nil)))
- (defconstant ,(intern (format nil "OFFSET-OF-~A" el)) ,offset)
- (defun (setf ,el) (newval ptr &optional (index 0))
- (declare (optimize (speed 3)))
- (sb-sys:without-gcing
- ,(template 'setf 'newval)))))))
+ ;;(declaim (inline ,el (setf ,el)))
+ (defun ,el (ptr &optional (index 0))
+ (declare (optimize (speed 3)))
+ (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)))
+ (sb-sys:without-gcing
+ ,(if (eql type (intern "C-STRING"))
+ `(set-bounded-c-string ptr ,offset ,length newval)
+ (template 'setf 'newval))))))))
;;; make memory allocator for appropriately-sized block of memory, and
(loop for i from 0 to (1- length) by size
do (setf (aref result i) (sb-alien:deref ptr i)))
result))
+
+(defun naturalize-bounded-c-string (pointer offset &optional max-length)
+ "Return the 0-terminated string starting at (+ POINTER OFFSET) with
+maximum length MAX-LENGTH, as a lisp object."
+ (let* ((ptr
+ (typecase pointer
+ (sb-sys:system-area-pointer
+ (sap-alien (sb-sys:sap+ pointer offset) (* sb-alien:char)))
+ (t
+ (sap-alien (sb-sys:sap+ (alien-sap pointer) offset) (* sb-alien:char)))))
+ (length (loop for i upfrom 0
+ until (or (and max-length
+ (= i (1- max-length)))
+ (= (sb-alien:deref ptr i) 0))
+ finally (return i)))
+ (result (make-string length
+ :element-type 'base-char)))
+ (sb-kernel:copy-from-system-area (alien-sap ptr) 0
+ result (* sb-vm:vector-data-offset
+ sb-vm:n-word-bits)
+ (* length sb-vm:n-byte-bits))
+ result))
+
+(defun set-bounded-c-string (pointer offset max-length value)
+ "Set the range from POINTER + OFFSET to at most POINTER + OFFSET +
+MAX-LENGTH to the string contained in VALUE."
+ (assert (numberp max-length) nil
+ "Structure field must have a grovelable maximum length.")
+ (assert (< (length value) max-length))
+ (let* ((ptr
+ (typecase pointer
+ (sb-sys:system-area-pointer
+ (sap-alien (sb-sys:sap+ pointer offset) (* sb-alien:char)))
+ (t
+ (sap-alien (sb-sys:sap+ (alien-sap pointer) offset) (* sb-alien:char)))))
+ (length (length value)))
+ (sb-kernel:copy-to-system-area value (* sb-vm:vector-data-offset
+ sb-vm:n-word-bits)
+ (alien-sap ptr) 0
+ (* length sb-vm:n-byte-bits))
+ (setf (sb-alien:deref ptr length) 0)
+ value))
modify_ldt mount mprotect mpx mremap msgctl msgget msgop msgrcv msgsnd
msync munlock munlockall 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
+read 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
buffers, etc... It may be more efficient to just compare two integers
than going thru an exception mechanism that will be invoked everytime.
-
-
+9) proper alien definitions of structures [ possibly an sb-grovel
+problem, but the way we define calls exposes the problem -- see
+readdir() ]
"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" "sys/mman.h")
+ "fcntl.h" "sys/mman.h"
+ "dirent.h")
;;; then the stuff we're looking for
((:integer af-inet "AF_INET" "IP Protocol family")
(:integer map-shared "MAP_SHARED" "mmap: shared memory")
(:integer map-private "MAP_PRIVATE" "mmap: private mapping")
(:integer map-fixed "MAP_FIXED" "mmap: map at given location")
+
+ ;; opendir()
+ (:structure dirent
+ ("struct dirent"
+ (:c-string name "char *" "d_name"
+ :distrust-length #+solaris t #-solaris nil)))
)
-(defpackage :sb-posix (:use )
+(defpackage :sb-posix (:use)
(:export #:syscall-error))
(defpackage :sb-posix-internal (:use #:sb-alien #:cl))
(in-package :sb-posix-internal)
+(defvar *designator-types* (make-hash-table :test #'equal))
+
(defmacro define-designator (name result &body conversions)
(let ((type `(quote (or ,@(mapcar #'car conversions))))
(typename (intern (format nil "~A-~A"
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(deftype ,typename () ,type)
- (setf (get ',name 'designator-type) ',result))
+ (setf (gethash ',name *designator-types*) ',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))
-
-(define-designator sap-or-nil sb-sys:system-area-pointer
- (null (sb-sys:int-sap 0))
- (sb-sys:system-area-pointer sap-or-nil))
(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))
-;; no lchown on Darwin
+;;; no lchown on Darwin
#-darwin
(define-call "lchown" int minusp (pathname filename)
(owner sb-posix::uid-t) (group sb-posix::gid-t))
(define-call "symlink" int minusp (oldpath filename) (newpath filename))
(define-call "unlink" int minusp (pathname filename))
-
+(define-call "opendir" (* t) null-alien (pathname filename))
+(define-call "readdir" (* t)
+ ;; readdir() has the worst error convention in the world. It's just
+ ;; too painful to support. (return is NULL _and_ errno "unchanged"
+ ;; is not an error, it's EOF).
+ not
+ (dir (* t)))
+(define-call "closedir" int minusp (dir (* t)))
+
;;; uid, gid
(define-call "geteuid" sb-posix::uid-t not) ;"always successful", it says
(in-package :sb-posix-internal)
+(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))
+
+(define-designator sap-or-nil sb-sys:system-area-pointer
+ (null (sb-sys:int-sap 0))
+ (sb-sys:system-area-pointer sap-or-nil))
+
(defun lisp-for-c-symbol (s)
(intern (substitute #\- #\_ (string-upcase s)) :sb-posix))
(function ,return-type
,@(mapcar
(lambda (x)
- (get (cadr x) 'designator-type (cadr x)))
+ (gethash (cadr x) *designator-types* (cadr x)))
arguments)))
,@(mapcar (lambda (x)
- (if (get (cadr x) 'designator-type)
+ (if (nth-value 1 (gethash (cadr x) *designator-types*))
`(,(intern (symbol-name (cadr x)) :sb-posix)
,(car x))
(car x)))
:depends-on (sb-grovel)
:components ((:file "defpackage")
(:file "designator" :depends-on ("defpackage"))
- (:file "macros" :depends-on ("defpackage"))
+ (:file "macros" :depends-on ("designator"))
(sb-grovel:grovel-constants-file
"constants"
:package :sb-posix :depends-on ("defpackage"))
(:file "interface" :depends-on ("constants" "macros" "designator"))))
-(defmethod perform :after ((o test-op) (c (eql (find-system :sb-posix))))
+(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))))
(length new-failures)
new-failures)))
))
+ (finish-output s)
(null pending))))
(def!method print-object ((value alien-value) stream)
(print-unreadable-object (value stream)
(format stream
- "~S :SAP #X~8,'0X"
+ "~S ~S #X~8,'0X ~S ~S"
'alien-value
- (sap-int (alien-value-sap value)))))
+ :sap (sap-int (alien-value-sap value))
+ :type (unparse-alien-type (alien-value-type value)))))
#!-sb-fluid (declaim (inline null-alien))
(defun null-alien (x)
;;; 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.2.43"
+"0.8.2.44"
projects / sbcl.git / commitdiff