From: Christophe Rhodes Date: Wed, 11 Feb 2004 11:00:39 +0000 (+0000) Subject: 0.8.7.49: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=32c8edbd49ca77907154987e28e8d3f81f61dabc;hp=f3f1143a09fa2e50eec13614cc6b0306b2b11fad;p=sbcl.git 0.8.7.49: Make sb-bsd-sockets properly depend on sb-grovel. The disadvantage of reaching into sb-grovel internals is more than balanced by the advantage of not having two similar but diverging implementations of the same functionality. (patch VJA sbcl-devel 2004-02-08) --- diff --git a/contrib/sb-bsd-sockets/array-data.lisp b/contrib/sb-bsd-sockets/array-data.lisp deleted file mode 100644 index 8a53daa..0000000 --- a/contrib/sb-bsd-sockets/array-data.lisp +++ /dev/null @@ -1,72 +0,0 @@ -(in-package :sockint) - -;;; borrowed from CMUCL manual, lightly ported - -(defun array-data-address (array) - "Return the physical address of where the actual data of an array is -stored. - -ARRAY must be a specialized array type - an array of one of these types: - - double-float - single-float - (unsigned-byte 32) - (unsigned-byte 16) - (unsigned-byte 8) - (signed-byte 32) - (signed-byte 16) - (signed-byte 8) -" - (declare (type (or (array (signed-byte 8)) - (array base-char) - simple-base-string - (array (signed-byte 16)) - (array (signed-byte 32)) - (array (unsigned-byte 8)) - (array (unsigned-byte 16)) - (array (unsigned-byte 32)) - (array single-float) - (array double-float)) - array) - (optimize (speed 0) (debug 3) (safety 3))) - ;; with-array-data will get us to the actual data. However, because - ;; the array could have been displaced, we need to know where the - ;; data starts. - - (let* ((type (car (multiple-value-list (array-element-type array)))) - (type-size - (cond ((or (equal type '(signed-byte 8)) - (equal type 'cl::base-char) - (equal type '(unsigned-byte 8))) - 1) - ((or (equal type '(signed-byte 16)) - (equal type '(unsigned-byte 16))) - 2) - ((or (equal type '(signed-byte 32)) - (equal type '(unsigned-byte 32))) - 4) - ((equal type 'single-float) - 4) - ((equal type 'double-float) - 8) - (t (error "Unknown specialized array element type"))))) - (with-array-data ((data array) - (start) - (end)) - (declare (ignore end)) - ;; DATA is a specialized simple-array. Memory is laid out like this: - ;; - ;; byte offset Value - ;; 0 type code (e.g. 70 for double-float vector) - ;; 4 FIXNUMIZE(number of elements in vector) - ;; 8 1st element of vector - ;; ... ... - ;; - (let* ((addr (+ 8 (logandc1 7 (sb-kernel:get-lisp-obj-address data))))) - (declare (type (unsigned-byte 32) addr) - (optimize (speed 3) (safety 0))) - (sb-sys:int-sap (the (unsigned-byte 32) - (+ addr (* type-size start)))))))) - - - diff --git a/contrib/sb-bsd-sockets/def-to-lisp.lisp b/contrib/sb-bsd-sockets/def-to-lisp.lisp deleted file mode 100644 index 1dff7a9..0000000 --- a/contrib/sb-bsd-sockets/def-to-lisp.lisp +++ /dev/null @@ -1,70 +0,0 @@ -(in-package :SB-BSD-SOCKETS-SYSTEM) -(defvar *export-symbols* nil) - -(defun c-for-structure (stream lisp-name c-struct) - (destructuring-bind (c-name &rest elements) c-struct - (format stream "printf(\"(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 - (format stream "printf(\"(define-c-accessor ~A-~A ~A ~A \");~%" - lisp-name lisp-el-name lisp-name lisp-type) - ;; offset - (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) - (format stream "printf(\")\\n\");~%"))))) - -(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\");~%" - lisp-name) - (princ "printf(\"(def-foreign-routine (" stream) - (princ "\\\"" stream) (princ c-name stream) (princ "\\\" " stream) - (princ lisp-name stream) - (princ " ) " stream) - (dolist (d definition) - (write d :length nil - :right-margin nil :stream stream) - (princ " " stream)) - (format stream ")\\n\");") - (terpri stream)))) - - -(defun print-c-source (stream headers definitions package-name) - ;(format stream "#include \"struct.h\"~%") - (let ((*print-right-margin* nil)) - (loop for i in headers - do (format stream "#include <~A>~%" i)) - (format stream "main() { ~% -printf(\"(in-package ~S)\\\n\");~%" package-name) - (format stream "printf(\"(defconstant size-of-int %d)\\\n\",sizeof (int));~%") - (format stream "printf(\"(defconstant size-of-char %d)\\\n\",sizeof (char));~%") - (format stream "printf(\"(defconstant size-of-long %d)\\\n\",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);~%" - lispname doc cname)) - ((eq type :string) - (format stream - "printf(\"(defvar ~A %S \\\"~A\\\")\\\n\",~A);~%" - lispname doc cname)) - ((eq type :function) - (c-for-function stream lispname cname)) - ((eq type :structure) - (c-for-structure stream lispname cname)) - (t - (format stream - "printf(\";; Non hablo Espagnol, Monsieur~%"))))) - (format stream "exit(0);~%}"))) - -(defun c-constants-extract (filename output-file package) - (with-open-file (f output-file :direction :output :if-exists :supersede) - (with-open-file (i filename :direction :input) - (let* ((headers (read i)) - (definitions (read i))) - (print-c-source f headers definitions package))))) diff --git a/contrib/sb-bsd-sockets/foreign-glue.lisp b/contrib/sb-bsd-sockets/foreign-glue.lisp deleted file mode 100644 index 958497f..0000000 --- a/contrib/sb-bsd-sockets/foreign-glue.lisp +++ /dev/null @@ -1,92 +0,0 @@ -(in-package :sb-bsd-sockets-internal) - -;;;; Foreign function glue. This is the only file in the distribution -;;;; that's _intended_ to be vendor-specific. The macros defined here -;;;; are called from constants.lisp, which was generated from constants.ccon -;;;; by the C compiler as driven by that wacky def-to-lisp thing. - -;;;; of course, the whole thing is vendor-specific actually, due to -;;;; the way we use cmucl alien types in constants.ccon as a cheap way -;;;; of transforming C-world alues into Lisp-world values. But if -;;;; anyone were to port that bit to their preferred implementation, they -;;;; wouldn't need to port all the rest of the cmucl alien interface at -;;;; the same time - -;;; (def-foreign-routine ("stat" STAT ) (INTEGER 32) (FILE-NAME -;;; C-CALL:C-STRING) (BUF (* T)) ) - -;;; I can't help thinking this was originally going to do something a -;;; lot more complex -(defmacro def-foreign-routine - (&whole it (c-name lisp-name) return-type &rest args) - (declare (ignorable c-name lisp-name return-type args)) - `(def-alien-routine ,@(cdr it))) -#| -(define-c-accessor FOO-PORT SOCKADDR-IN (ARRAY (UNSIGNED 8) 2) 2 2) -(define-c-accessor SOCKADDR-IN-FAMILY SOCKADDR-IN INTEGER 6 2) -|# -;;; define-c-accessor makes us a setter and a getter for changing -;;; memory at the appropriate offset - -;;; (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)))) - (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))))) - (,before (,sap-ref-? sap index) ,after)))) - `(progn - ;;(declaim (inline ,el (setf ,el))) - (defun ,el (ptr &optional (index 0)) - (declare (optimize (speed 3))) - (sb-sys:with-pinned-objects (ptr) - ,(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:with-pinned-objects (ptr) - ,(template 'setf 'newval))))))) - - -;;; make memory allocator for appropriately-sized block of memory, and -;;; a constant to tell us how big it was anyway -(defmacro define-c-struct (name size) - (labels ((p (x) (intern (concatenate 'string x (symbol-name name))))) - `(progn - (defun ,(p "ALLOCATE-") () (make-array ,size :initial-element 0 - :element-type '(unsigned-byte 8))) - (defconstant ,(p "SIZE-OF-") ,size) - (defun ,(p "FREE-" ) (p) (declare (ignore p)))))) - -(defun foreign-nullp (c) - "C is a pointer to 0?" - (= 0 (sb-sys:sap-int (sb-alien:alien-sap c)))) - -;;; this could be a lot faster if I cared enough to think about it -(defun foreign-vector (pointer size length) - "Compose a vector of the words found in foreign memory starting at -POINTER. Each word is SIZE bytes long; LENGTH gives the number of -elements of the returned vector. See also FOREIGN-VECTOR-UNTIL-ZERO" - (assert (= size 1)) - (let ((ptr - (typecase pointer - (sb-sys:system-area-pointer - (sap-alien pointer (* (sb-alien:unsigned 8)))) - (t - (sb-alien:cast pointer (* (sb-alien:unsigned 8)))))) - (result (make-array length :element-type '(unsigned-byte 8)))) - (loop for i from 0 to (1- length) by size - do (setf (aref result i) (sb-alien:deref ptr i))) - ;;(format t "~S~%" result) - result)) diff --git a/contrib/sb-bsd-sockets/inet.lisp b/contrib/sb-bsd-sockets/inet.lisp index df52637..3ea609e 100644 --- a/contrib/sb-bsd-sockets/inet.lisp +++ b/contrib/sb-bsd-sockets/inet.lisp @@ -38,8 +38,8 @@ using getprotobyname(2) which typically looks in NIS or /etc/protocols" ;; for extra brownie points, could return canonical protocol name ;; and aliases as extra values - (let ((ent (sockint::foreign-vector (sockint::getprotobyname name) 1 - sockint::size-of-protoent))) + (let ((ent (sb-grovel::foreign-vector (sockint::getprotobyname name) 1 + sockint::size-of-protoent))) (sockint::protoent-proto ent))) diff --git a/contrib/sb-bsd-sockets/local.lisp b/contrib/sb-bsd-sockets/local.lisp index 2350e06..cf106f1 100644 --- a/contrib/sb-bsd-sockets/local.lisp +++ b/contrib/sb-bsd-sockets/local.lisp @@ -34,7 +34,7 @@ a network. (defmethod bits-of-sockaddr ((socket local-socket) sockaddr) "Return the file name of the local socket address SOCKADDR." (let ((name (sb-c-call::%naturalize-c-string - (sb-sys:sap+ (sockint::array-data-address sockaddr) + (sb-sys:sap+ (sb-grovel::array-data-address sockaddr) sockint::offset-of-sockaddr-un-path)))) (if (zerop (length name)) nil name))) diff --git a/contrib/sb-bsd-sockets/name-service.lisp b/contrib/sb-bsd-sockets/name-service.lisp index bf29529..c5ba475 100644 --- a/contrib/sb-bsd-sockets/name-service.lisp +++ b/contrib/sb-bsd-sockets/name-service.lisp @@ -43,13 +43,13 @@ grisly details." do (setf (sockint::in-addr-addr packed-addr i) (elt address i))) (make-host-ent (sb-sys:with-pinned-objects (packed-addr) - (sockint::gethostbyaddr (sockint::array-data-address packed-addr) + (sockint::gethostbyaddr (sb-grovel::array-data-address packed-addr) 4 sockint::af-inet))))) (defun make-host-ent (h) - (if (sockint::foreign-nullp h) (name-service-error "gethostbyname")) - (let* ((local-h (sockint::foreign-vector h 1 sockint::size-of-hostent)) + (if (sb-grovel::foreign-nullp h) (name-service-error "gethostbyname")) + (let* ((local-h (sb-grovel::foreign-vector h 1 sockint::size-of-hostent)) (length (sockint::hostent-length local-h)) (aliases (loop for i = 0 then (1+ i) @@ -64,7 +64,7 @@ grisly details." for ad = (sb-sys:sap-ref-32 address0 i) while (> ad 0) collect - (sockint::foreign-vector (sb-sys:sap+ address0 i) 1 length)))) + (sb-grovel::foreign-vector (sb-sys:sap+ address0 i) 1 length)))) (make-instance 'host-ent :name (sb-c-call::%naturalize-c-string (sb-sys:int-sap (sockint::hostent-name local-h))) diff --git a/contrib/sb-bsd-sockets/sb-bsd-sockets.asd b/contrib/sb-bsd-sockets/sb-bsd-sockets.asd index fd251d6..7fb71ed 100644 --- a/contrib/sb-bsd-sockets/sb-bsd-sockets.asd +++ b/contrib/sb-bsd-sockets/sb-bsd-sockets.asd @@ -76,18 +76,16 @@ #+sb-building-contrib "SYS:CONTRIB;SB-BSD-SOCKETS;" :components ((:file "defpackage") (:file "split" :depends-on ("defpackage")) - (:file "array-data" :depends-on ("defpackage")) (:unix-dso "alien" :components ((:c-source-file "undefs") (:c-source-file "get-h-errno"))) (:file "malloc" :depends-on ("defpackage")) - (:file "foreign-glue" :depends-on ("defpackage" "malloc")) (sb-grovel:grovel-constants-file "constants" :package :sockint - :depends-on ("def-to-lisp" "defpackage" "foreign-glue")) + :depends-on ("defpackage")) (:file "sockets" - :depends-on ("constants" "array-data")) + :depends-on ("constants")) (:file "sockopt" :depends-on ("sockets")) (:file "inet" :depends-on ("sockets" "split" "constants" )) @@ -95,8 +93,6 @@ (:file "name-service" :depends-on ("sockets" "constants" "alien")) (:file "misc" :depends-on ("sockets" "constants")) - (:file "def-to-lisp") - (:static-file "NEWS") ;; (:static-file "INSTALL") (:static-file "README") diff --git a/contrib/sb-bsd-sockets/sockets.lisp b/contrib/sb-bsd-sockets/sockets.lisp index c182cee..9f15ad6 100644 --- a/contrib/sb-bsd-sockets/sockets.lisp +++ b/contrib/sb-bsd-sockets/sockets.lisp @@ -64,7 +64,7 @@ See also bind(2)")) (let ((sockaddr (apply #'make-sockaddr-for socket nil address))) (if (= (sb-sys:with-pinned-objects (sockaddr) (sockint::bind (socket-file-descriptor socket) - (sockint::array-data-address sockaddr) + (sb-grovel::array-data-address sockaddr) (size-of-sockaddr socket))) -1) (socket-error "bind")))) @@ -79,7 +79,7 @@ values")) (let ((sockaddr (make-sockaddr-for socket))) (sb-sys:with-pinned-objects (sockaddr) (let ((fd (sockint::accept (socket-file-descriptor socket) - (sockint::array-data-address sockaddr) + (sb-grovel::array-data-address sockaddr) (size-of-sockaddr socket)))) (apply #'values (if (= fd -1) @@ -99,7 +99,7 @@ values")) (let* ((sockaddr (apply #'make-sockaddr-for socket nil peer))) (if (= (sb-sys:with-pinned-objects (sockaddr) (sockint::connect (socket-file-descriptor socket) - (sockint::array-data-address sockaddr) + (sb-grovel::array-data-address sockaddr) (size-of-sockaddr socket))) -1) (socket-error "connect") ))) @@ -112,7 +112,7 @@ values")) (let* ((sockaddr (make-sockaddr-for socket))) (when (= (sb-sys:with-pinned-objects (sockaddr) (sockint::getpeername (socket-file-descriptor socket) - (sockint::array-data-address sockaddr) + (sb-grovel::array-data-address sockaddr) (size-of-sockaddr socket))) -1) (socket-error "getpeername")) @@ -126,7 +126,7 @@ values")) (let* ((sockaddr (make-sockaddr-for socket))) (when (= (sb-sys:with-pinned-objects (sockaddr) (sockint::getsockname (socket-file-descriptor socket) - (sockint::array-data-address sockaddr) + (sb-grovel::array-data-address sockaddr) (size-of-sockaddr socket))) -1) (socket-error "getsockname")) @@ -172,10 +172,10 @@ small")) (sb-sys:with-pinned-objects (buffer sockaddr) (let ((len (sockint::recvfrom (socket-file-descriptor socket) - (sockint::array-data-address buffer) + (sb-grovel::array-data-address buffer) (or length (length buffer)) flags - (sockint::array-data-address sockaddr) + (sb-grovel::array-data-address sockaddr) (sb-alien:cast sa-len (* integer))))) (when (= len -1) (socket-error "recvfrom")) (apply #'values buffer len (multiple-value-list diff --git a/contrib/sb-bsd-sockets/sockopt.lisp b/contrib/sb-bsd-sockets/sockopt.lisp index 455779d..e44aa84 100644 --- a/contrib/sb-bsd-sockets/sockopt.lisp +++ b/contrib/sb-bsd-sockets/sockopt.lisp @@ -62,7 +62,7 @@ Code for options that not every system has should be conditionalised: :initial-element 0))) (sb-sys:with-pinned-objects (buf) (if (= -1 (sockint::getsockopt - fd ,find-level ,number (sockint::array-data-address buf) ,size)) + fd ,find-level ,number (sb-grovel::array-data-address buf) ,size)) (socket-error "getsockopt") (,mangle-return buf ,size))))) (defun (setf ,lisp-name) (new-val socket @@ -82,7 +82,7 @@ Code for options that not every system has should be conditionalised: ;; is a macro and evaluates its second arg at read time (let* ((v (make-array size :element-type '(unsigned-byte 8) :initial-element 0)) - (d (sockint::array-data-address v)) + (d (sb-grovel::array-data-address v)) (alien (sb-alien:sap-alien d; (sb-sys:int-sap d) (* (sb-alien:signed #.(* 8 sockint::size-of-int)))))) @@ -92,7 +92,7 @@ Code for options that not every system has should be conditionalised: (defun buffer-to-int (x size) (declare (ignore size)) (let ((alien (sb-alien:sap-alien - (sockint::array-data-address x) + (sb-grovel::array-data-address x) (* (sb-alien:signed #.(* 8 sockint::size-of-int)))))) (sb-alien:deref alien))) @@ -146,13 +146,13 @@ Code for options that not every system has should be conditionalised: (defun string-to-foreign (string size) (declare (ignore size)) - (let ((data (sockint::array-data-address string))) + (let ((data (sb-grovel::array-data-address string))) (sb-alien:sap-alien data (* t)))) (defun buffer-to-string (x size) (declare (ignore size)) (sb-c-call::%naturalize-c-string - (sockint::array-data-address x))) + (sb-grovel::array-data-address x))) (define-socket-option sockopt-bind-to-device sockint::sol-socket sockint::so-bindtodevice string-to-foreign sockint::ifnamsiz diff --git a/version.lisp-expr b/version.lisp-expr index 29abb7d..189e39f 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.7.48" +"0.8.7.49"