Commit 32c8edbd authored by Christophe Rhodes's avatar Christophe Rhodes
Browse files

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)
parent f3f1143a

contrib/sb-bsd-sockets/array-data.lisp

deleted100644 → 0
+0 −72
Original line number Diff line number Diff line 
(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))))))))

contrib/sb-bsd-sockets/def-to-lisp.lisp

deleted100644 → 0
+0 −70
Original line number Diff line number Diff line 
(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)))))

contrib/sb-bsd-sockets/foreign-glue.lisp

deleted100644 → 0
+0 −92
Original line number Diff line number Diff line 
(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))

contrib/sb-bsd-sockets/inet.lisp

+2 −2
Original line number Diff line number Diff line
@@ -38,7 +38,7 @@ 
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

  (let ((ent (sb-grovel::foreign-vector (sockint::getprotobyname name) 1

				        sockint::size-of-protoent)))

    (sockint::protoent-proto ent)))

contrib/sb-bsd-sockets/local.lisp

+1 −1
Original line number Diff line number Diff line
@@ -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)))