projects
/
uffi.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
01de613
)
r1790: Completed MCL support for enum, struct, and union.
author
John DeSoi
<desoi@mac.com>
Tue, 23 Apr 2002 01:06:56 +0000
(
01:06
+0000)
committer
John DeSoi
<desoi@mac.com>
Tue, 23 Apr 2002 01:06:56 +0000
(
01:06
+0000)
src/mcl/aggregates.cl
patch
|
blob
|
history
diff --git
a/src/mcl/aggregates.cl
b/src/mcl/aggregates.cl
index 2b7625336d89f34f804fb9e7ecae321d16ff9ae2..cf0e76745d76de4ba17494cb0f022d464d9ed2a6 100644
(file)
--- a/
src/mcl/aggregates.cl
+++ b/
src/mcl/aggregates.cl
@@
-7,7
+7,7
@@
;;;; Programmers: Kevin M. Rosenberg and John DeSoi
;;;; Date Started: Feb 2002
;;;;
;;;; Programmers: Kevin M. Rosenberg and John DeSoi
;;;; Date Started: Feb 2002
;;;;
-;;;; $Id: aggregates.cl,v 1.
3 2002/04/06 19:45:14 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
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;; and John DeSoi
@@
-21,11
+21,6
@@
(in-package :uffi)
(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
(defmacro def-enum (enum-name args &key (separator-string "#"))
"Creates a constants for a C type enum list, symbols are created
@@
-53,24
+48,15
@@
of the enum-name name, separator-string, and field-name"
#+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))
#+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))
(nreverse constants)))
cmds))
-#|
+
(defmacro def-array-pointer (name-array type)
(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)
; this is how rref expands array slot access (minus adding the struct offset)
(defmacro deref-array (obj type i)
@@
-83,51
+69,54
@@
of the enum-name name, separator-string, and field-name"
(defsetf deref-array deref-array-set)
(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 (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))
(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)
(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)
(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)
(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