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.1 2002/09/16 17:57:43 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                        #+mcl `((def-mcl-type ,enum-name :integer))
  52                        (nreverse constants)))
  53     cmds))
  54
  55
  56
  57 (defmacro def-array-pointer (name-array type)
  58   `(def-mcl-type ,name-array '(:array ,type)))
  59
  60
  61 ; this is how rref expands array slot access (minus adding the struct offset)
  62 (defmacro deref-array (obj type i)
  63   "Returns a field from a row"
  64   `(,(accessor-symbol type :get) ,obj (* (the fixnum ,i) ,(foreign-object-size type))))
  65
  66 (defmacro deref-array-set (obj type i value)
  67     `(,(accessor-symbol type :set) ,obj ,value (* (the fixnum ,i) ,(foreign-object-size type))))
  68
  69 (defsetf deref-array deref-array-set)
  70
  71
  72 (defun process-struct-fields (name fields variant)
  73   (let (processed)
  74     (dolist (field fields)
  75       (let* ((field-name (car field))
  76              (type (cadr field))
  77              (def  (append (list field-name)
  78                     (if (eq type :pointer-self)
  79                         #+cmu `((* (alien:struct ,name)))
  80                         #-cmu `((* ,name))
  81                         `(,(convert-from-uffi-type type :struct))))))
  82         (if variant
  83           (push (list def) processed)
  84           (push def processed))))
  85     (nreverse processed)))
  86
  87
  88 (defmacro def-struct (name &rest fields)
  89   `(ccl:defrecord ,name ,@(process-struct-fields name fields nil)))
  90
  91
  92 (defmacro def-union (name &rest fields)
  93   `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t))))
  94
  95
  96 ; Assuming everything is pointer based - no support for Mac handles
  97 (defmacro get-slot-value (obj type slot) ;use setf to set values
  98    `(ccl:pref ,obj ,(read-from-string (format nil "~a.~a" type slot))))
  99
 100
 101 (defmacro get-slot-pointer (obj type slot)
 102   `(ccl:%int-to-ptr (+ (ccl:%ptr-to-int ,obj) (the fixnum (ccl:field-info ,type ,slot)))))
 103
 104
 105
 106 #| a few simple tests
 107 (def-union union
 108   (l1 :long)
 109   (s1 :short))
 110
 111 (def-struct struct
 112   (s1 :short)
 113    (l1 :long)
 114    (u1 :union))
 115
 116 (defvar s (allocate-foreign-object :struct))
 117 (setf (get-slot-value s :struct :s1) 3)
 118 (get-slot-value s :struct :s1)
 119 (setf (get-slot-value s :struct :u1.s1) 5)
 120 (get-slot-value s :struct :u1.s1)
 121
 122 |#