;; unfortunately; and it will only accept unquoted type
;; forms.
`(sb-alien:array ,elt-type ,(or array-size
- (/ size (eval `(sb-alien:alien-size ,elt-type :bytes))))))
- `(vector t))))
+ (/ size (eval `(sb-alien:alien-size ,elt-type :bytes))))))
+ t)))
(defun retrieve-type-for (type size table)
(multiple-value-bind (type-fn found)
:type `(array char ,len)
:offset offset
:size len
- :name (gensym "PADDING")))
+ :name (gentemp "PADDING")))
(defun mk-struct (offset &rest children)
- (make-instance 'struct :name (gensym "STRUCT")
+ (make-instance 'struct :name (gentemp "STRUCT")
:children (remove nil children)
:offset offset))
(defun mk-union (offset &rest children)
- (make-instance 'union :name (gensym "UNION")
+ (make-instance 'union :name (gentemp "UNION")
:children (remove nil children)
:offset offset))
(defun mk-val (name type h-type offset size)
(defgeneric accessor-modifier-for (element-type accessor-type))
-(defun identity-1 (thing &rest ignored)
+(defmacro identity-1 (thing &rest ignored)
(declare (ignore ignored))
thing)
(defun (setf identity-1) (new-thing place &rest ignored)
(defmethod accessor-modifier-for ((element-type (eql 'C-STRING))
(accessor-type (eql :setter)))
'c-string->lisp-string)
-(defmethod accessor-modifier-for ((element-type (eql 'C-STRING))
- (accessor-type (eql :getter)))
- 'c-string->lisp-string)
(defun c-string->lisp-string (string &optional limit)
(declare (ignore limit))
(symbol-name (name root)))))
(labels ((accessor (root rpath)
(apply #'sane-slot 'struct (mapcar 'name (append (rest rpath) (list root))))))
- `((defun ,(intern accessor-name) (struct)
- (declare (type (alien ,struct-name) struct)
+ `((declaim (inline ,(intern accessor-name)
+ (setf ,(intern accessor-name))))
+ (defun ,(intern accessor-name) (struct)
+ (declare (cl:type (alien (* ,struct-name)) struct)
(optimize (speed 3)))
(,(accessor-modifier-for (reintern (type root) (find-package :sb-grovel))
:getter)
,(accessor root rpath) ,(size root)))
(defun (setf ,(intern accessor-name)) (new-val struct)
- (declare (type (alien ,struct-name) struct)
- (type ,(lisp-type-for (type root) (size root)) new-val)
+ (declare (cl:type (alien (* ,struct-name)) struct)
+ (cl:type ,(lisp-type-for (type root) (size root)) new-val)
(optimize (speed 3)))
,(let* ((accessor-modifier (accessor-modifier-for (reintern (type root)
(find-package :sb-grovel))
(size root)))))
(generate-struct-definition name root nil))
`(progn
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (sb-alien:define-alien-type ,@(first struct-elements)))
+ (sb-alien:define-alien-type ,@(first struct-elements))
,@accessors
(defmacro ,(intern (format nil "WITH-~A" name)) (var (&rest field-values) &body body)
- (labels ((field-name (x)
- (intern (concatenate 'string
- (symbol-name ',name) "-"
- (symbol-name x))
- ,(symbol-package name))))
- `(let ((,var ,'(,(intern (format nil "ALLOCATE-~A" name)))))
- (unwind-protect
- (progn
- (progn ,@(mapcar (lambda (pair)
- `(setf (,(field-name (first pair)) ,var) ,(second pair)))
- field-values))
- ,@body)
- (funcall ',',(intern (format nil "FREE-~A" name)) ,var)))))
+ (labels ((field-name (x)
+ (intern (concatenate 'string
+ (symbol-name ',name) "-"
+ (symbol-name x))
+ ,(symbol-package name))))
+ `(sb-alien:with-alien ((,var (* ,',name) ,'(,(intern (format nil "ALLOCATE-~A" name)))))
+ (unwind-protect
+ (progn
+ (progn ,@(mapcar (lambda (pair)
+ `(setf (,(field-name (first pair)) ,var) ,(second pair)))
+ field-values))
+ ,@body)
+ (funcall ',',(intern (format nil "FREE-~A" name)) ,var)))))
(defconstant ,(intern (format nil "SIZE-OF-~A" name)) ,size)
(defun ,(intern (format nil "ALLOCATE-~A" name)) ()
- (sb-alien:make-alien ,name))
+ (let* ((o (sb-alien:make-alien ,name))
+ (c-o (cast o (* (unsigned 8)))))
+ ;; we have to initialize the object to all-0 before we can
+ ;; expect to make sensible use of it - the object returned
+ ;; by make-alien is initialized to all-D0 bytes.
+
+ ;; FIXME: This should be fixed in sb-alien, where better
+ ;; optimizations might be possible.
+ (loop for i from 0 below ,size
+ do (setf (deref c-o i) 0))
+ o))
(defun ,(intern (format nil "FREE-~A" name)) (o)
(sb-alien:free-alien o)))))
(defun foreign-nullp (c)
"C is a pointer to 0?"
- (null-alien c))
\ No newline at end of file
+ (null-alien c))