contrib/sb-grovel/foreign-glue.lisp

   1 (in-package :sb-grovel)
   2
   3 ;;;; The macros defined here are called from #:Gconstants.lisp, which was
   4 ;;;; generated from constants.lisp by the C compiler as driven by that
   5 ;;;; wacky def-to-lisp thing.
   6
   7 ;;; (def-foreign-routine ("stat" STAT ) (INTEGER 32) (FILE-NAME
   8 ;;; C-CALL:C-STRING) (BUF (* T)) )
   9
  10 ;;; I can't help thinking this was originally going to do something a
  11 ;;; lot more complex
  12 (defmacro define-foreign-routine
  13   (&whole it (c-name lisp-name) return-type &rest args)
  14   (declare (ignorable c-name lisp-name return-type args))
  15   `(define-alien-routine ,@(cdr it)))
  16 #||
  17 (define-c-accessor FOO-PORT SOCKADDR-IN (ARRAY (UNSIGNED 8) 2) 2 2)
  18 (define-c-accessor SOCKADDR-IN-FAMILY SOCKADDR-IN INTEGER 6 2)
  19 ||#
  20 ;;; define-c-accessor makes us a setter and a getter for changing
  21 ;;; memory at the appropriate offset
  22
  23 ;;;    (define-c-accessor STAT-ATIME STAT (INTEGER 32) 56 4)
  24
  25 (defmacro define-c-accessor (el structure type offset length)
  26   (declare (ignore structure))
  27   (let* ((ty (cond
  28                ((eql type (intern "INTEGER"))
  29                 `(,type ,(* 8 length)))
  30                ((and (consp type) (eql (car type) (intern "*"))) ; pointer
  31                 `(unsigned ,(* 8 length)))
  32                ((eql type (intern "C-STRING")) ; c-string as array
  33                 `(base-char 8))
  34                ((and (consp type) (eql (car type) (intern "ARRAY")))
  35                 (cadr type))
  36                ((let ((type (sb-alien-internals:unparse-alien-type
  37                              (sb-alien-internals:parse-alien-type type nil))))
  38                   (cond
  39                     ((consp type)
  40                      (case (car type)
  41                        (signed `(integer ,(cadr type)))
  42                        (unsigned type)))
  43                     (t (error "foo")))))))
  44          (sap-ref-? (intern (format nil "~ASAP-REF-~A"
  45                                     (if (member (car ty) '(INTEGER SIGNED))
  46                                         "SIGNED-" "")
  47                                     (cadr ty))
  48                             (find-package "SB-SYS"))))
  49     (labels
  50         ((template (before after)
  51            `(let* ((addr
  52                     (the (unsigned-byte ,sb-vm:n-machine-word-bits)
  53                       (+ #.(ash 1 sb-vm:n-lowtag-bits)
  54                          (logandc1 #.(1- (ash 1 sb-vm:n-lowtag-bits))
  55                                    (sb-kernel:get-lisp-obj-address ptr)))))
  56                    (sap (sb-sys:int-sap
  57                          (the (unsigned-byte ,sb-vm:n-machine-word-bits)
  58                            (+ addr ,offset)))))
  59                  (,before (,sap-ref-? sap index) ,after))))
  60       `(progn
  61          ;;(declaim (inline ,el (setf ,el)))
  62          (defun ,el (ptr &optional (index 0))
  63            (declare (optimize (speed 3) (safety 0)))
  64            (sb-sys:without-gcing
  65             ,(if (eql type (intern "C-STRING"))
  66                  `(naturalize-bounded-c-string ptr ,offset ,length)
  67                  (template 'prog1 nil))))
  68          (defconstant ,(intern (format nil "OFFSET-OF-~A" el)) ,offset)
  69          (defun (setf ,el) (newval ptr &optional (index 0))
  70            (declare (optimize (speed 3) (safety 0)))
  71            (sb-sys:without-gcing
  72             ,(if (eql type (intern "C-STRING"))
  73                  `(set-bounded-c-string ptr ,offset ,length newval)
  74                  (template 'setf 'newval))))))))
  75
  76
  77 ;;; make memory allocator for appropriately-sized block of memory, and
  78 ;;; a constant to tell us how big it was anyway
  79 (defmacro define-c-struct (name size)
  80   (labels ((p (x) (intern (concatenate 'string x (symbol-name name))
  81                           (symbol-package name))))
  82     `(progn
  83       (defun ,(p "ALLOCATE-") () (make-array ,size :initial-element 0
  84                                              :element-type '(unsigned-byte 8)))
  85       (defconstant ,(p "SIZE-OF-") ,size)
  86       (deftype ,name () '(simple-array (unsigned-byte 8) (,size)))
  87       (defun ,(p "FREE-" ) (p) (declare (ignore p)))
  88       (defmacro ,(p "WITH-") (var (&rest field-values) &body body)
  89         (labels ((field-name (x)
  90                              (intern (concatenate 'string
  91                                                   (symbol-name ',name) "-"
  92                                                   (symbol-name x))
  93                                      ,(symbol-package name))))
  94           (append `(let ((,var ,'(,(p "ALLOCATE-")))))
  95                   (mapcar (lambda (pair)
  96                             `(setf (,(field-name (car pair)) ,var) ,(cadr pair)))
  97                           field-values)
  98                   body))))))
  99
 100 (defun foreign-nullp (c)
 101   "C is a pointer to 0?"
 102   (= 0 (sb-sys:sap-int (sb-alien:alien-sap  c))))
 103
 104 ;;; this could be a lot faster if I cared enough to think about it
 105 (defun foreign-vector (pointer size length)
 106   "Compose a vector of the words found in foreign memory starting at
 107 POINTER.  Each word is SIZE bytes long; LENGTH gives the number of
 108 elements of the returned vector.  See also FOREIGN-VECTOR-UNTIL-ZERO"
 109   (assert (= size 1))
 110   (let ((ptr
 111          (typecase pointer
 112            (sb-sys:system-area-pointer
 113             (sap-alien pointer (* (sb-alien:unsigned 8))))
 114            (t
 115             (sb-alien:cast pointer (* (sb-alien:unsigned 8))))))
 116         (result (make-array length :element-type '(unsigned-byte 8))))
 117     (loop for i from 0 to (1- length) by size
 118           do (setf (aref result i) (sb-alien:deref ptr i)))
 119     result))
 120
 121 (defun naturalize-bounded-c-string (pointer offset &optional max-length)
 122   "Return the 0-terminated string starting at (+ POINTER OFFSET) with
 123 maximum length MAX-LENGTH, as a lisp object."
 124   (let* ((ptr
 125           (typecase pointer
 126             (sb-sys:system-area-pointer
 127              (sap-alien (sb-sys:sap+ pointer offset) (* sb-alien:char)))
 128             (t
 129              (sap-alien (sb-sys:sap+ (alien-sap pointer) offset) (* sb-alien:char)))))
 130          (length (loop for i upfrom 0
 131                        until (or (and max-length
 132                                       (= i (1- max-length)))
 133                                  (= (sb-alien:deref ptr i) 0))
 134                        finally (return i)))
 135          (result (make-string length
 136                               :element-type 'base-char)))
 137     (sb-kernel:copy-from-system-area (alien-sap ptr) 0
 138                                      result (* sb-vm:vector-data-offset
 139                                                sb-vm:n-word-bits)
 140                                      (* length sb-vm:n-byte-bits))
 141     result))
 142
 143 (defun set-bounded-c-string (pointer offset max-length value)
 144   "Set the range from POINTER + OFFSET to at most POINTER + OFFSET +
 145 MAX-LENGTH to the string contained in VALUE."
 146   (assert (numberp max-length) nil
 147           "Structure field must have a grovelable maximum length.")
 148   (assert (< (length value) max-length))
 149   (let* ((ptr
 150           (typecase pointer
 151             (sb-sys:system-area-pointer
 152              (sap-alien (sb-sys:sap+ pointer offset) (* sb-alien:char)))
 153             (t
 154              (sap-alien (sb-sys:sap+ (alien-sap pointer) offset) (* sb-alien:char)))))
 155          (length (length value)))
 156     (sb-kernel:copy-to-system-area value (* sb-vm:vector-data-offset
 157                                              sb-vm:n-word-bits)
 158                                    (alien-sap ptr) 0
 159                                    (* length sb-vm:n-byte-bits))
 160     (setf (sb-alien:deref ptr length) 0)
 161     value))