-;;;; -*- Mode: ANSI-Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Programmers: Kevin M. Rosenberg and John DeSoi
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: aggregates.cl,v 1.2 2002/04/06 19:11:15 kevin Exp $
+;;;; $Id: aggregates.cl,v 1.4 2002/04/23 01:06:56 desoi Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;; and John DeSoi
(in-package :uffi)
-;;;
-;;; AGGREGATE SUPPORT IS NOT COMPLETE FOR MCL
-;;;
-
-;! Need to finish enums, records and variants (unions)
(defmacro def-enum (enum-name args &key (separator-string "#"))
"Creates a constants for a C type enum list, symbols are created
#+allegro `((ff:def-foreign-type ,enum-name :int))
#+lispworks `((fli:define-c-typedef ,enum-name :int))
#+cmu `((alien:def-alien-type ,enum-name alien:signed))
+ #+mcl `((def-mcl-type ,enum-name :integer))
(nreverse constants)))
cmds))
-#|
+
(defmacro def-array-pointer (name-array type)
- #+allegro
- `(ff:def-foreign-type ,name-array
- (:array ,(convert-from-uffi-type type :array)))
- #+lispworks
- `(fli:define-c-typedef ,name-array
- (:c-array ,(convert-from-uffi-type type :array)))
- #+cmu
- `(alien:def-alien-type ,name-array
- (* ,(convert-from-uffi-type type :array)))
- )
-
-|#
+ `(def-mcl-type ,name-array '(:array ,type)))
+
; this is how rref expands array slot access (minus adding the struct offset)
(defmacro deref-array (obj type i)
(defsetf deref-array deref-array-set)
-
-(defun process-struct-fields (name fields)
+(defun process-struct-fields (name fields variant)
(let (processed)
(dolist (field fields)
- (let ((field-name (car field))
- (type (cadr field)))
- (push (append (list field-name)
+ (let* ((field-name (car field))
+ (type (cadr field))
+ (def (append (list field-name)
(if (eq type :pointer-self)
#+cmu `((* (alien:struct ,name)))
#-cmu `((* ,name))
- `(,(convert-from-uffi-type type :struct))))
- processed)))
+ `(,(convert-from-uffi-type type :struct))))))
+ (if variant
+ (push (list def) processed)
+ (push def processed))))
(nreverse processed)))
(defmacro def-struct (name &rest fields)
- `(ccl:defrecord ,name ,@(process-struct-fields name fields))
- )
+ `(ccl:defrecord ,name ,@(process-struct-fields name fields nil)))
(defmacro def-union (name &rest fields)
- `(ccl:defrecord ,name ,@(process-struct-fields name fields))
- )
+ `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t))))
+
+; Assuming everything is pointer based - no support for Mac handles
+(defmacro get-slot-value (obj type slot) ;use setf to set values
+ `(ccl:pref ,obj ,(read-from-string (format nil "~a.~a" type slot))))
-#| not done for mcl
-(defmacro get-slot-value (obj type slot)
- (declare (ignore type))
- #+allegro
- `(ff:fslot-value-typed ,type :c ,obj ,slot)
- #+lispworks
- `(fli:foreign-slot-value ,obj ,slot)
- #+cmu
- `(alien:slot ,obj ,slot)
- )
(defmacro get-slot-pointer (obj type slot)
- #+(or lispworks cmu) (declare (ignore type))
- #+allegro
- `(ff:fslot-value-typed ,type :c ,obj ,slot)
- #+lispworks
- `(fli:foreign-slot-pointer ,obj ,slot)
- #+cmu
- `(alien:slot ,obj ,slot)
- )
+ `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot)))))
+
+
+
+#| a few simple tests
+(def-union union
+ (l1 :long)
+ (s1 :short))
+
+(def-struct struct
+ (s1 :short)
+ (l1 :long)
+ (u1 :union))
-|#
+(defvar s (allocate-foreign-object :struct))
+(setf (get-slot-value s :struct :s1) 3)
+(get-slot-value s :struct :s1)
+(setf (get-slot-value s :struct :u1.s1) 5)
+(get-slot-value s :struct :u1.s1)
+|#
\ No newline at end of file