+++ /dev/null
-(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))))))))
-
-
-
+++ /dev/null
-(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)))))
+++ /dev/null
-(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))
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)))
(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)))
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)
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)))
#+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" ))
(: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")
(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"))))
(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)
(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") )))
(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"))
(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"))
(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
: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
;; 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))))))
(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)))
(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
;;; 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"
projects / sbcl.git / commitdiff