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.2 2002/09/20 04:51:14 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   `(def-mcl-type ,name-array '(:array ,type)))
  60
  61
  62
  63 ; so we could allow '(:array :long) or deref with other type like :long only
  64 (defun array-type (type)
  65   (let ((result type))
  66     (when (listp type)
  67       (let ((type-list (if (eq (car type) 'quote) (nth 1 type) type)))
  68         (when (and (listp type-list) (eq (car type-list) :array))
  69           (setf result (cadr type-list)))))
  70     result))
  71
  72
  73 (defmacro deref-array (obj type i)
  74   "Returns a field from a row"
  75   (let* ((array-type (array-type type))
  76          (local-type (convert-from-uffi-type array-type :allocation))
  77          (accessor (first (macroexpand `(ccl:pref obj ,local-type)))))
  78     `(,accessor
  79       ,obj
  80       (* (the fixnum ,i) ,(size-of-foreign-type local-type)))))
  81
  82
  83 ; this expands to the %set-xx functions which has different params than %put-xx
  84 (defmacro deref-array-set (obj type i value)
  85   (let* ((array-type (array-type type))
  86          (local-type (convert-from-uffi-type array-type :allocation))
  87          (accessor (first (macroexpand `(ccl:pref obj ,local-type))))
  88          (settor (first (macroexpand `(setf (,accessor obj ,local-type) value)))))
  89     `(,settor
  90       ,obj
  91       (* (the fixnum ,i) ,(size-of-foreign-type local-type))
  92       ,value)))
  93
  94 (defsetf deref-array deref-array-set)
  95
  96
  97 (defun process-struct-fields (name fields variant)
  98   (let (processed)
  99     (dolist (field fields)
 100       (let* ((field-name (car field))
 101              (type (cadr field))
 102              (def  (append (list field-name)
 103                     (if (eq type :pointer-self)
 104                         #+cmu `((* (alien:struct ,name)))
 105                         #-cmu `((* ,name))
 106                         `(,(convert-from-uffi-type type :struct))))))
 107         (if variant
 108           (push (list def) processed)
 109           (push def processed))))
 110     (nreverse processed)))
 111
 112 #-openmcl
 113 (defmacro def-struct (name &rest fields)
 114   `(ccl:defrecord ,name ,@(process-struct-fields name fields nil)))
 115
 116 #-openmcl
 117 (defmacro def-union (name &rest fields)
 118   `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t))))
 119
 120
 121 #+openmcl
 122 (defmacro def-struct (name &rest fields)
 123   `(ccl::def-foreign-type nil
 124      (:struct ,name ,@(process-struct-fields name fields nil))))
 125
 126 #+openmcl
 127 (defmacro def-union (name &rest fields)
 128   `(ccl::def-foreign-type nil
 129      (:union ,name ,@(process-struct-fields name fields nil))))
 130
 131 ; Assuming everything is pointer based - no support for Mac handles
 132 (defmacro get-slot-value (obj type slot) ;use setf to set values
 133    `(ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))))
 134
 135 (defmacro set-slot-value (obj type slot value) ;use setf to set values
 136    `(setf (ccl:pref ,obj ,(read-from-string (format nil ":~a.~a" (keyword type) (keyword slot)))) ,value))
 137
 138
 139 (defsetf get-slot-value set-slot-value)
 140
 141
 142 #-openmcl
 143 (defmacro get-slot-pointer (obj type slot)
 144   `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot)))))
 145
 146 #+openmcl
 147 (defmacro get-slot-pointer (obj type slot)
 148   `(let ((field (ccl::%find-foreign-record-type-field ,type ,slot)))
 149      (ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl::foreign-record-field-offset field))))))
 150
 151
 152
 153 #| a few simple tests
 154 (def-union union
 155   (l1 :long)
 156   (s1 :short))
 157
 158 (def-struct struct
 159   (s1 :short)
 160    (l1 :long)
 161    (u1 :union))
 162
 163 (defvar s (allocate-foreign-object :struct))
 164 (setf (get-slot-value s :struct :s1) 3)
 165 (get-slot-value s :struct :s1)
 166 (setf (get-slot-value s :struct :u1.s1) 5)
 167 (get-slot-value s :struct :u1.s1)
 168
 169 |#