- `(progn
- (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))))
- `(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)) ()
- (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)))))
-
+ (sb-int:with-unique-names (var field-values body field-name pair
+ object c-object index)
+ (let ((with (intern (format nil "WITH-~A" name)))
+ (allocate (intern (format nil "ALLOCATE-~A" name)))
+ (free (intern (format nil "FREE-~A" name)))
+ (size-of (intern (format nil "SIZE-OF-~A" name))))
+ `(progn
+ (sb-alien:define-alien-type ,@(first struct-elements))
+ ,@accessors
+ (defmacro ,with (,var (&rest ,field-values) &body ,body)
+ (labels ((,field-name (,var)
+ (intern
+ (format nil ,(format nil "~A-~~A" (symbol-name name))
+ (symbol-name ,var))
+ ,(symbol-package name))))
+ `(sb-alien:with-alien ((,,var (* ,',name) ,'(,allocate)))
+ (unwind-protect
+ (progn
+ (setf ,@(mapcan
+ (lambda (,pair)
+ `((,(,field-name (first ,pair)) ,,var)
+ ,(second ,pair)))
+ ,field-values))
+ ,@,body)
+ (,',free ,,var)))))
+ (defconstant ,size-of ,size)
+ (defun ,allocate ()
+ (let* ((,object (sb-alien:make-alien ,name))
+ (,c-object (cast ,object (* (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.
+ (dotimes (,index ,size)
+ (setf (deref ,c-object ,index) 0))
+ ,object))
+ (defun ,free (,object)
+ (sb-alien:free-alien ,object)))))))
+
+;; FIXME: Nothing in SBCL uses this, but kept it around in case there
+;; are third-party sb-grovel clients. It should go away eventually,
+;; on the principle that sb-grovel should only have to be loaded in
+;; order to do an actual groveling run.