X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fsb-grovel%2Fforeign-glue.lisp;h=b2c1f00bbffa25c15d155d0d9a428d562067659b;hb=22c1de0a40df83bb5628974010a879cb2c17ff53;hp=c74c333da4d40cae07c542fa9d73f013b6e100dd;hpb=a09b213e5812edd1ef3e88c18bde6bd1294da547;p=sbcl.git

diff --git a/contrib/sb-grovel/foreign-glue.lisp b/contrib/sb-grovel/foreign-glue.lisp
index c74c333..b2c1f00 100644
--- a/contrib/sb-grovel/foreign-glue.lisp
+++ b/contrib/sb-grovel/foreign-glue.lisp
@@ -61,7 +61,18 @@
       (defun ,(p "ALLOCATE-") () (make-array ,size :initial-element 0
 					     :element-type '(unsigned-byte 8)))
       (defconstant ,(p "SIZE-OF-") ,size)
-      (defun ,(p "FREE-" ) (p) (declare (ignore p))))))
+      (defun ,(p "FREE-" ) (p) (declare (ignore p)))
+      (defmacro ,(p "WITH-") (var (&rest field-values) &body body)
+	(labels ((field-name (x)
+			     (intern (concatenate 'string
+						  (symbol-name ',name) "-"
+						  (symbol-name x))
+				     ,(symbol-package name))))
+	  (append `(let ((,var ,'(,(p "ALLOCATE-")))))
+		  (mapcar (lambda (pair)
+			    `(setf (,(field-name (car pair)) ,var) ,(cadr pair)))
+			  field-values)
+		  body))))))
 
 (defun foreign-nullp (c)
   "C is a pointer to 0?"