1 (in-package :bsd-sockets-internal
)
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.
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
15 ;;; (def-foreign-routine ("stat" STAT ) (INTEGER 32) (FILE-NAME
16 ;;; C-CALL:C-STRING) (BUF (* T)) )
18 ;;; I can't help thinking this was originally going to do something a
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
)))
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)
28 ;;; define-c-accessor makes us a setter and a getter for changing
29 ;;; memory at the appropriate offset
31 ;;; (define-c-accessor STAT-ATIME STAT (INTEGER 32) 56 4)
33 (defmacro define-c-accessor
(el structure type offset length
)
34 (declare (ignore structure
))
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
))
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
))))
50 ;;(declaim (inline ,el (setf ,el)))
51 (defun ,el
(ptr &optional
(index 0))
52 ,(template 'prog1 nil
))
53 (defconstant ,(intern (format nil
"OFFSET-OF-~A" el
)) ,offset
)
54 (defun (setf ,el
) (newval ptr
&optional
(index 0))
55 ,(template 'setf
'newval
))))))
58 ;;; make memory allocator for appropriately-sized block of memory, and
59 ;;; a constant to tell us how big it was anyway
60 (defmacro define-c-struct
(name size
)
61 (labels ((p (x) (intern (concatenate 'string x
(symbol-name name
)))))
63 (defun ,(p "ALLOCATE-") () (make-array ,size
:initial-element
0
64 :element-type
'(unsigned-byte 8)))
65 (defconstant ,(p "SIZE-OF-") ,size
)
66 (defun ,(p "FREE-" ) (p) (declare (ignore p
))))))
68 (defun foreign-nullp (c)
69 "C is a pointer to 0?"
70 (= 0 (sb-sys:sap-int
(sb-alien:alien-sap c
))))
72 ;;; this could be a lot faster if I cared enough to think about it
73 (defun foreign-vector (pointer size length
)
74 "Compose a vector of the words found in foreign memory starting at
75 POINTER. Each word is SIZE bytes long; LENGTH gives the number of
76 elements of the returned vector. See also FOREIGN-VECTOR-UNTIL-ZERO"
80 (sb-sys:system-area-pointer
81 (sap-alien pointer
(* (sb-alien:unsigned
8))))
83 (sb-alien:cast pointer
(* (sb-alien:unsigned
8))))))
84 (result (make-array length
:element-type
'(unsigned-byte 8))))
85 (loop for i from
0 to
(1- length
) by size
86 do
(setf (aref result i
) (sb-alien:deref ptr i
)))
87 ;;(format t "~S~%" result)