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

   1 (in-package :sb-bsd-sockets-internal)
   2
   3 ;;;; Foreign function glue.  This is the only file in the distribution
   4 ;;;; that's _intended_ to be vendor-specific.  The macros defined here
   5 ;;;; are called from constants.lisp, which was generated from constants.ccon
   6 ;;;; by the C compiler as driven by that wacky def-to-lisp thing.
   7
   8 ;;;; of course, the whole thing is vendor-specific actually, due to
   9 ;;;; the way we use cmucl alien types in constants.ccon as a cheap way
  10 ;;;; of transforming C-world alues into Lisp-world values.  But if
  11 ;;;; anyone were to port that bit to their preferred implementation, they
  12 ;;;; wouldn't need to port all the rest of the cmucl alien interface at
  13 ;;;; the same time
  14
  15 ;;; (def-foreign-routine ("stat" STAT ) (INTEGER 32) (FILE-NAME
  16 ;;; C-CALL:C-STRING) (BUF (* T)) )
  17
  18 ;;; I can't help thinking this was originally going to do something a
  19 ;;; lot more complex
  20 (defmacro def-foreign-routine
  21   (&whole it (c-name lisp-name) return-type &rest args)
  22   (declare (ignorable c-name lisp-name return-type args))
  23   `(def-alien-routine ,@(cdr it)))
  24 #|
  25 (define-c-accessor FOO-PORT SOCKADDR-IN (ARRAY (UNSIGNED 8) 2) 2 2)
  26 (define-c-accessor SOCKADDR-IN-FAMILY SOCKADDR-IN INTEGER 6 2)
  27 |#
  28 ;;; define-c-accessor makes us a setter and a getter for changing
  29 ;;; memory at the appropriate offset
  30
  31 ;;;    (define-c-accessor STAT-ATIME STAT (INTEGER 32) 56 4)
  32
  33 (defmacro define-c-accessor (el structure type offset length)
  34   (declare (ignore structure))
  35   (let* ((ty (cond
  36                ((eql type 'integer) `(,type ,(* 8 length)))
  37                ((eql (car type) '*) `(unsigned ,(* 8 length)))
  38                ((eql type 'c-string) `(unsigned ,(* 8 length)))
  39                ((eql (car type) 'array) (cadr type))))
  40          (sap-ref-? (intern (format nil "~ASAP-REF-~A"
  41                                     (if (member (car ty) '(INTEGER SIGNED))
  42                                         "SIGNED-" "")
  43                                     (cadr ty))
  44                             (find-package "SB-SYS"))))
  45     (labels ((template (before after)
  46                `(let* ((addr (+ 8 (logandc1 7 (sb-kernel:get-lisp-obj-address ptr))))
  47                        (sap (sb-sys:int-sap (the (unsigned-byte 32) (+ addr ,offset)))))
  48                  (,before (,sap-ref-? sap index) ,after))))
  49       `(progn
  50         ;;(declaim (inline ,el (setf ,el)))
  51         (defun ,el (ptr &optional (index 0))
  52           (declare (optimize (speed 3)))
  53           (sb-sys:without-gcing
  54            ,(template 'prog1 nil)))
  55         (defconstant ,(intern (format nil "OFFSET-OF-~A" el)) ,offset)
  56         (defun (setf ,el) (newval ptr &optional (index 0))
  57           (declare (optimize (speed 3)))
  58           (sb-sys:without-gcing
  59            ,(template 'setf 'newval)))))))
  60
  61
  62 ;;; make memory allocator for appropriately-sized block of memory, and
  63 ;;; a constant to tell us how big it was anyway
  64 (defmacro define-c-struct (name size)
  65   (labels ((p (x) (intern (concatenate 'string x (symbol-name name)))))
  66     `(progn
  67       (defun ,(p "ALLOCATE-") () (make-array ,size :initial-element 0
  68                                              :element-type '(unsigned-byte 8)))
  69       (defconstant ,(p "SIZE-OF-") ,size)
  70       (defun ,(p "FREE-" ) (p) (declare (ignore p))))))
  71
  72 (defun foreign-nullp (c)
  73   "C is a pointer to 0?"
  74   (= 0 (sb-sys:sap-int (sb-alien:alien-sap  c))))
  75
  76 ;;; this could be a lot faster if I cared enough to think about it
  77 (defun foreign-vector (pointer size length)
  78   "Compose a vector of the words found in foreign memory starting at
  79 POINTER.  Each word is SIZE bytes long; LENGTH gives the number of
  80 elements of the returned vector.  See also FOREIGN-VECTOR-UNTIL-ZERO"
  81   (assert (= size 1))
  82   (let ((ptr
  83          (typecase pointer
  84            (sb-sys:system-area-pointer
  85             (sap-alien pointer (* (sb-alien:unsigned 8))))
  86            (t
  87             (sb-alien:cast pointer (* (sb-alien:unsigned 8))))))
  88         (result (make-array length :element-type '(unsigned-byte 8))))
  89     (loop for i from 0 to (1- length) by size
  90           do (setf (aref result i) (sb-alien:deref ptr i)))
  91      ;;(format t "~S~%" result)
  92     result))