1 (in-package :sb-grovel)
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.
7 ;;; (def-foreign-routine ("stat" STAT ) (INTEGER 32) (FILE-NAME
8 ;;; C-CALL:C-STRING) (BUF (* T)) )
10 ;;; I can't help thinking this was originally going to do something a
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)))
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)
20 ;;; define-c-accessor makes us a setter and a getter for changing
21 ;;; memory at the appropriate offset
23 ;;; (define-c-accessor STAT-ATIME STAT (INTEGER 32) 56 4)
25 (defmacro define-c-accessor (el structure type offset length)
26 (declare (ignore structure))
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
34 ((and (consp type) (eql (car type) (intern "ARRAY")))
36 ((let ((type (sb-alien-internals:unparse-alien-type
37 (sb-alien-internals:parse-alien-type type nil))))
41 (signed `(integer ,(cadr type)))
43 (t (error "foo")))))))
44 (sap-ref-? (intern (format nil "~ASAP-REF-~A"
45 (if (member (car ty) '(INTEGER SIGNED))
48 (find-package "SB-SYS"))))
50 ((template (before after)
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)))))
57 (the (unsigned-byte ,sb-vm:n-machine-word-bits)
59 (,before (,sap-ref-? sap index) ,after))))
61 ;;(declaim (inline ,el (setf ,el)))
62 (defun ,el (ptr &optional (index 0))
63 (declare (optimize (speed 3) (safety 0)))
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)))
72 ,(if (eql type (intern "C-STRING"))
73 `(set-bounded-c-string ptr ,offset ,length newval)
74 (template 'setf 'newval))))))))
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))))
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) "-"
93 ,(symbol-package name))))
94 (append `(let ((,var ,'(,(p "ALLOCATE-")))))
95 (mapcar (lambda (pair)
96 `(setf (,(field-name (car pair)) ,var) ,(cadr pair)))
100 (defun foreign-nullp (c)
101 "C is a pointer to 0?"
102 (= 0 (sb-sys:sap-int (sb-alien:alien-sap c))))
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"
112 (sb-sys:system-area-pointer
113 (sap-alien pointer (* (sb-alien:unsigned 8))))
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)))
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."
126 (sb-sys:system-area-pointer
127 (sap-alien (sb-sys:sap+ pointer offset) (* sb-alien:char)))
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))
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
140 (* length sb-vm:n-byte-bits))
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))
151 (sb-sys:system-area-pointer
152 (sap-alien (sb-sys:sap+ pointer offset) (* sb-alien:char)))
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
159 (* length sb-vm:n-byte-bits))
160 (setf (sb-alien:deref ptr length) 0)