src-mcl/aggregates.cl

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   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
   9 ;;;;
  10 ;;;; $Id: aggregates.cl,v 1.3 2002/09/30 01:57:32 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;; and John DeSoi
  14 ;;;;
  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 ;;;; *************************************************************************
  19
  20 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  21 (in-package :uffi)
  22
  23
  24
  25 (defmacro def-enum (enum-name args &key (separator-string "#"))
  26   "Creates a constants for a C type enum list, symbols are created
  27 in the created in the current package. The symbol is the concatenation
  28 of the enum-name name, separator-string, and field-name"
  29   (let ((counter 0)
  30         (cmds nil)
  31         (constants nil))
  32     (declare (fixnum counter))
  33     (dolist (arg args)
  34       (let ((name (if (listp arg) (car arg) arg))
  35             (value (if (listp arg)
  36                        (prog1
  37                            (setq counter (cadr arg))
  38                          (incf counter))
  39                      (prog1
  40                          counter
  41                        (incf counter)))))
  42         (setq name (intern (concatenate 'string
  43                              (symbol-name enum-name)
  44                              separator-string
  45                              (symbol-name name))))
  46         (push `(uffi:def-constant ,name ,value) constants)))
  47     (setf cmds (append '(progn)
  48                        #+allegro `((ff:def-foreign-type ,enum-name :int))
  49                        #+lispworks `((fli:define-c-typedef ,enum-name :int))
  50                        #+cmu `((alien:def-alien-type ,enum-name alien:signed))
  51                        #-openmcl `((def-mcl-type ,enum-name :integer))
  52                        #+openmcl `((ccl::def-foreign-type ,enum-name :int))
  53                        (nreverse constants)))
  54     cmds))
  55
  56
  57
  58 (defmacro def-array-pointer (name-array type)
  59   #-openmcl
  60   `(def-mcl-type ,name-array '(:array ,type))
  61   #+openmcl
  62   `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array))))
  63
  64
  65
  66 ; so we could allow '(:array :long) or deref with other type like :long only
  67 (defun array-type (type)
  68   (let ((result type))
  69     (when (listp type)
  70       (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type)))
  71         (when (and (listp type-list) (eq (car type-list) :array))
  72           (setf result (cadr type-list)))))
  73     result))
  74
  75
  76 (defmacro deref-array (obj type i)
  77   "Returns a field from a row"
  78   (let* ((array-type (array-type type))
  79          (local-type (convert-from-uffi-type array-type :allocation))
  80          (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
  81     `(,accessor
  82       ,obj
  83       (* (the fixnum ,i) ,(size-of-foreign-type local-type)))))
  84
  85
  86 ; this expands to the %set-xx functions which has different params than %put-xx
  87 (defmacro deref-array-set (obj type i value)
  88   (let* ((array-type (array-type type))
  89          (local-type (convert-from-uffi-type array-type :allocation))
  90          (accessor (first (macroexpand `(ccl:pref obj ,local-type))))
  91          (settor (first (macroexpand `(setf (,accessor obj ,local-type) value)))))
  92     `(,settor
  93       ,obj
  94       (* (the fixnum ,i) ,(size-of-foreign-type local-type))
  95       ,value)))
  96
  97 (defsetf deref-array deref-array-set)
  98
  99
 100 (defun process-struct-fields (name fields variant)
 101   (let (processed)
 102     (dolist (field fields)
 103       (let* ((field-name (car field))
 104              (type (cadr field))
 105              (def  (append (list field-name)
 106                     (cond
 107                       ((eq type :pointer-self)
 108                        #+cmu `((* (alien:struct ,name)))
 109                        #+openmcl `((:* (:struct ,name)))
 110                        #-(or cmu openmcl) `((* ,name))
 111                        )
 112                       (t
 113                        `(,(convert-from-uffi-type type :struct)))))))
 114         (if variant
 115           (push (list def) processed)
 116           (push def processed))))
 117     (nreverse processed)))
 118
 119 #-openmcl
 120 (defmacro def-struct (name &rest fields)
 121   `(ccl:defrecord ,name ,@(process-struct-fields name fields nil)))
 122
 123 #-openmcl
 124 (defmacro def-union (name &rest fields)
 125   `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t))))
 126
 127
 128 #+openmcl
 129 (defmacro def-struct (name &rest fields)
 130   `(ccl::def-foreign-type nil
 131      (:struct ,name ,@(process-struct-fields name fields nil))))
 132
 133 #+openmcl
 134 (defmacro def-union (name &rest fields)
 135   `(ccl::def-foreign-type nil
 136      (:union ,name ,@(process-struct-fields name fields nil))))
 137
 138 ; Assuming everything is pointer based - no support for Mac handles
 139 (defmacro get-slot-value (obj type slot) ;use setf to set values
 140    `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))))
 141
 142 (defmacro set-slot-value (obj type slot value) ;use setf to set values
 143    `(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value))
 144
 145
 146 (defsetf get-slot-value set-slot-value)
 147
 148
 149 #-openmcl
 150 (defmacro get-slot-pointer (obj type slot)
 151   `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot)))))
 152
 153 #+openmcl
 154 (defmacro get-slot-pointer (obj type slot)
 155   `(let ((field (ccl::%find-foreign-record-type-field ,type ,slot)))
 156      (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field))))))
 157
 158
 159
 160 #| a few simple tests
 161 (def-union union
 162   (l1 :long)
 163   (s1 :short))
 164
 165 (def-struct struct
 166   (s1 :short)
 167    (l1 :long)
 168    (u1 :union))
 169
 170 (defvar s (allocate-foreign-object :struct))
 171 (setf (get-slot-value s :struct :s1) 3)
 172 (get-slot-value s :struct :s1)
 173 (setf (get-slot-value s :struct :u1.s1) 5)
 174 (get-slot-value s :struct :u1.s1)
 175
 176 |#