1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
5 ;;;; Name: aggregates.cl
6 ;;;; Purpose: UFFI source to handle aggregate types
7 ;;;; Programmers: Kevin M. Rosenberg and John DeSoi
8 ;;;; Date Started: Feb 2002
10 ;;;; $Id: aggregates.cl,v 1.3 2002/04/06 19:45:14 kevin Exp $
12 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
15 ;;;; UFFI users are granted the rights to distribute and use this software
16 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
17 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
18 ;;;; *************************************************************************
20 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
25 ;;; AGGREGATE SUPPORT IS NOT COMPLETE FOR MCL
28 ;! Need to finish enums, records and variants (unions)
30 (defmacro def-enum (enum-name args &key (separator-string "#"))
31 "Creates a constants for a C type enum list, symbols are created
32 in the created in the current package. The symbol is the concatenation
33 of the enum-name name, separator-string, and field-name"
37 (declare (fixnum counter))
39 (let ((name (if (listp arg) (car arg) arg))
40 (value (if (listp arg)
42 (setq counter (cadr arg))
47 (setq name (intern (concatenate 'string
48 (symbol-name enum-name)
51 (push `(uffi:def-constant ,name ,value) constants)))
52 (setf cmds (append '(progn)
53 #+allegro `((ff:def-foreign-type ,enum-name :int))
54 #+lispworks `((fli:define-c-typedef ,enum-name :int))
55 #+cmu `((alien:def-alien-type ,enum-name alien:signed))
56 (nreverse constants)))
61 (defmacro def-array-pointer (name-array type)
63 `(ff:def-foreign-type ,name-array
64 (:array ,(convert-from-uffi-type type :array)))
66 `(fli:define-c-typedef ,name-array
67 (:c-array ,(convert-from-uffi-type type :array)))
69 `(alien:def-alien-type ,name-array
70 (* ,(convert-from-uffi-type type :array)))
75 ; this is how rref expands array slot access (minus adding the struct offset)
76 (defmacro deref-array (obj type i)
77 "Returns a field from a row"
78 `(,(accessor-symbol type :get) ,obj (* (the fixnum ,i) ,(foreign-object-size type))))
80 (defmacro deref-array-set (obj type i value)
81 `(,(accessor-symbol type :set) ,obj ,value (* (the fixnum ,i) ,(foreign-object-size type))))
83 (defsetf deref-array deref-array-set)
87 (defun process-struct-fields (name fields)
89 (dolist (field fields)
90 (let ((field-name (car field))
92 (push (append (list field-name)
93 (if (eq type :pointer-self)
94 #+cmu `((* (alien:struct ,name)))
96 `(,(convert-from-uffi-type type :struct))))
98 (nreverse processed)))
101 (defmacro def-struct (name &rest fields)
102 `(ccl:defrecord ,name ,@(process-struct-fields name fields))
106 (defmacro def-union (name &rest fields)
107 `(ccl:defrecord ,name ,@(process-struct-fields name fields))
112 (defmacro get-slot-value (obj type slot)
113 (declare (ignore type))
115 `(ff:fslot-value-typed ,type :c ,obj ,slot)
117 `(fli:foreign-slot-value ,obj ,slot)
119 `(alien:slot ,obj ,slot)
122 (defmacro get-slot-pointer (obj type slot)
123 #+(or lispworks cmu) (declare (ignore type))
125 `(ff:fslot-value-typed ,type :c ,obj ,slot)
127 `(fli:foreign-slot-pointer ,obj ,slot)
129 `(alien:slot ,obj ,slot)