0.8.0.16:
[sbcl.git] / 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
26 (defmacro define-c-accessor (el structure type offset length)
27   (declare (ignore structure))
28   (let* ((ty (cond
29                ((eql type 'integer) `(,type ,(* 8 length)))
30                ((eql (car type) '*) `(unsigned ,(* 8 length)))
31                ((eql type 'c-string) `(unsigned ,(* 8 length)))
32                ((eql (car type) 'array) (cadr type))))
33          (sap-ref-? (intern (format nil "~ASAP-REF-~A"
34                                     (if (member (car ty) '(INTEGER SIGNED))
35                                         "SIGNED-" "")
36                                     (cadr ty))
37                             (find-package "SB-SYS"))))
38     (labels ((template (before after)
39                `(let* ((addr (+ 8 (logandc1 7 (sb-kernel:get-lisp-obj-address ptr))))
40                        (sap (sb-sys:int-sap (the (unsigned-byte 32) (+ addr ,offset)))))
41                  (,before (,sap-ref-? sap index) ,after))))
42       `(progn
43         ;;(declaim (inline ,el (setf ,el)))
44         (defun ,el (ptr &optional (index 0))
45           (declare (optimize (speed 3)))
46           (sb-sys:without-gcing 
47            ,(template 'prog1 nil)))
48         (defconstant ,(intern (format nil "OFFSET-OF-~A" el)) ,offset)
49         (defun (setf ,el) (newval ptr &optional (index 0))
50           (declare (optimize (speed 3)))
51           (sb-sys:without-gcing 
52            ,(template 'setf 'newval)))))))
53
54
55 ;;; make memory allocator for appropriately-sized block of memory, and
56 ;;; a constant to tell us how big it was anyway
57 (defmacro define-c-struct (name size)
58   (labels ((p (x) (intern (concatenate 'string x (symbol-name name))
59                           (symbol-package name))))
60     `(progn
61       (defun ,(p "ALLOCATE-") () (make-array ,size :initial-element 0
62                                              :element-type '(unsigned-byte 8)))
63       (defconstant ,(p "SIZE-OF-") ,size)
64       (defun ,(p "FREE-" ) (p) (declare (ignore p)))
65       (defmacro ,(p "WITH-") (var (&rest field-values) &body body)
66         (labels ((field-name (x)
67                              (intern (concatenate 'string
68                                                   (symbol-name ',name) "-"
69                                                   (symbol-name x))
70                                      ,(symbol-package name))))
71           (append `(let ((,var ,'(,(p "ALLOCATE-")))))
72                   (mapcar (lambda (pair)
73                             `(setf (,(field-name (car pair)) ,var) ,(cadr pair)))
74                           field-values)
75                   body))))))
76
77 (defun foreign-nullp (c)
78   "C is a pointer to 0?"
79   (= 0 (sb-sys:sap-int (sb-alien:alien-sap  c))))
80
81 ;;; this could be a lot faster if I cared enough to think about it
82 (defun foreign-vector (pointer size length)
83   "Compose a vector of the words found in foreign memory starting at
84 POINTER.  Each word is SIZE bytes long; LENGTH gives the number of
85 elements of the returned vector.  See also FOREIGN-VECTOR-UNTIL-ZERO"
86   (assert (= size 1))
87   (let ((ptr
88          (typecase pointer
89            (sb-sys:system-area-pointer
90             (sap-alien pointer (* (sb-alien:unsigned 8))))
91            (t
92             (sb-alien:cast pointer (* (sb-alien:unsigned 8))))))
93         (result (make-array length :element-type '(unsigned-byte 8))))
94     (loop for i from 0 to (1- length) by size
95           do (setf (aref result i) (sb-alien:deref ptr i)))
96     result))