From: Christophe Rhodes Date: Tue, 19 Aug 2003 13:04:39 +0000 (+0000) Subject: 0.8.2.44: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=1f7401c39a46466c307938c8f6cf7db224741981;p=sbcl.git 0.8.2.44: Mostly contrib frobs ... merge sb-grovel string handling (Andreas Fuchs sbcl-devel 2003-08-19) ... hack at sb-posix designator concept until it doesn't blow up when given list types; ... implement opendir/readdir/closedir in sb-posix [not yet properly: everything is done with (* T) rather than (* DIR) and (* DIRENT), but the interface is fine]; ... add a FINISH-OUTPUT to sb-rt, so that the failing tests are printed before the backtrace, not during; ... print ALIEN-VALUEs' alien type in PRINT-OBJECT --- diff --git a/contrib/sb-grovel/def-to-lisp.lisp b/contrib/sb-grovel/def-to-lisp.lisp index 97b524b..b73553f 100644 --- a/contrib/sb-grovel/def-to-lisp.lisp +++ b/contrib/sb-grovel/def-to-lisp.lisp @@ -5,7 +5,7 @@ (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 @@ -18,8 +18,10 @@ (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) diff --git a/contrib/sb-grovel/foreign-glue.lisp b/contrib/sb-grovel/foreign-glue.lisp index b2c1f00..69d7044 100644 --- a/contrib/sb-grovel/foreign-glue.lisp +++ b/contrib/sb-grovel/foreign-glue.lisp @@ -22,14 +22,17 @@ ;;; (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-" "") @@ -40,16 +43,20 @@ (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 @@ -94,3 +101,45 @@ elements of the returned vector. See also FOREIGN-VECTOR-UNTIL-ZERO" (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)) diff --git a/contrib/sb-posix/TODO b/contrib/sb-posix/TODO index 4abc9d0..75d62ad 100644 --- a/contrib/sb-posix/TODO +++ b/contrib/sb-posix/TODO @@ -18,7 +18,7 @@ llseek lock lseek lstat madvise mincore mknod mlock mlockall 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 @@ -49,5 +49,6 @@ exceptional exit. For example, EINTR, EAGAIN, reading or writing big 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() ] diff --git a/contrib/sb-posix/constants.lisp b/contrib/sb-posix/constants.lisp index 17737ce..dd519f6 100644 --- a/contrib/sb-posix/constants.lisp +++ b/contrib/sb-posix/constants.lisp @@ -10,7 +10,8 @@ "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") @@ -53,4 +54,10 @@ (: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))) ) diff --git a/contrib/sb-posix/defpackage.lisp b/contrib/sb-posix/defpackage.lisp index 751c3c0..b7781de 100644 --- a/contrib/sb-posix/defpackage.lisp +++ b/contrib/sb-posix/defpackage.lisp @@ -1,4 +1,4 @@ -(defpackage :sb-posix (:use ) +(defpackage :sb-posix (:use) (:export #:syscall-error)) (defpackage :sb-posix-internal (:use #:sb-alien #:cl)) diff --git a/contrib/sb-posix/designator.lisp b/contrib/sb-posix/designator.lisp index 5094a94..b7cd3c3 100644 --- a/contrib/sb-posix/designator.lisp +++ b/contrib/sb-posix/designator.lisp @@ -1,4 +1,6 @@ (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" @@ -8,20 +10,9 @@ `(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)) diff --git a/contrib/sb-posix/interface.lisp b/contrib/sb-posix/interface.lisp index aac2314..1a0bd29 100644 --- a/contrib/sb-posix/interface.lisp +++ b/contrib/sb-posix/interface.lisp @@ -25,7 +25,7 @@ (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)) @@ -35,7 +35,15 @@ (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 diff --git a/contrib/sb-posix/macros.lisp b/contrib/sb-posix/macros.lisp index d32bfe5..00af8de 100644 --- a/contrib/sb-posix/macros.lisp +++ b/contrib/sb-posix/macros.lisp @@ -1,5 +1,17 @@ (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)) @@ -15,10 +27,10 @@ (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))) diff --git a/contrib/sb-posix/sb-posix.asd b/contrib/sb-posix/sb-posix.asd index 2a7252e..9fffc35 100644 --- a/contrib/sb-posix/sb-posix.asd +++ b/contrib/sb-posix/sb-posix.asd @@ -7,13 +7,13 @@ :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)))) diff --git a/contrib/sb-rt/rt.lisp b/contrib/sb-rt/rt.lisp index 6622760..117e68e 100644 --- a/contrib/sb-rt/rt.lisp +++ b/contrib/sb-rt/rt.lisp @@ -250,4 +250,5 @@ (length new-failures) new-failures))) )) + (finish-output s) (null pending)))) diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index fe4aff5..ff91742 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -178,9 +178,10 @@ (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) diff --git a/version.lisp-expr b/version.lisp-expr index 460a317..929fcb5 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.2.43" +"0.8.2.44"