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/04/06 19:45: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 ;;; AGGREGATE SUPPORT IS NOT COMPLETE FOR MCL
  26 ;;;
  27
  28 ;! Need to finish enums, records and variants (unions)
  29
  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"
  34   (let ((counter 0)
  35         (cmds nil)
  36         (constants nil))
  37     (declare (fixnum counter))
  38     (dolist (arg args)
  39       (let ((name (if (listp arg) (car arg) arg))
  40             (value (if (listp arg)
  41                        (prog1
  42                            (setq counter (cadr arg))
  43                          (incf counter))
  44                      (prog1
  45                          counter
  46                        (incf counter)))))
  47         (setq name (intern (concatenate 'string
  48                              (symbol-name enum-name)
  49                              separator-string
  50                              (symbol-name 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)))
  57     cmds))
  58
  59
  60 #|
  61 (defmacro def-array-pointer (name-array type)
  62   #+allegro
  63   `(ff:def-foreign-type ,name-array
  64     (:array ,(convert-from-uffi-type type :array)))
  65   #+lispworks
  66   `(fli:define-c-typedef ,name-array
  67     (:c-array ,(convert-from-uffi-type type :array)))
  68   #+cmu
  69   `(alien:def-alien-type ,name-array
  70     (* ,(convert-from-uffi-type type :array)))
  71   )
  72
  73 |#
  74
  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))))
  79
  80 (defmacro deref-array-set (obj type i value)
  81     `(,(accessor-symbol type :set) ,obj ,value (* (the fixnum ,i) ,(foreign-object-size type))))
  82
  83 (defsetf deref-array deref-array-set)
  84
  85
  86
  87 (defun process-struct-fields (name fields)
  88   (let (processed)
  89     (dolist (field fields)
  90       (let ((field-name (car field))
  91             (type (cadr field)))
  92         (push (append (list field-name)
  93                     (if (eq type :pointer-self)
  94                         #+cmu `((* (alien:struct ,name)))
  95                         #-cmu `((* ,name))
  96                         `(,(convert-from-uffi-type type :struct))))
  97                     processed)))
  98     (nreverse processed)))
  99
 100
 101 (defmacro def-struct (name &rest fields)
 102   `(ccl:defrecord ,name ,@(process-struct-fields name fields))
 103   )
 104
 105
 106 (defmacro def-union (name &rest fields)
 107   `(ccl:defrecord ,name ,@(process-struct-fields name fields))
 108   )
 109
 110
 111 #| not done for mcl
 112 (defmacro get-slot-value (obj type slot)
 113  (declare (ignore type))
 114   #+allegro
 115   `(ff:fslot-value-typed ,type :c ,obj ,slot)
 116   #+lispworks
 117   `(fli:foreign-slot-value ,obj ,slot)
 118   #+cmu
 119   `(alien:slot ,obj ,slot)
 120   )
 121
 122 (defmacro get-slot-pointer (obj type slot)
 123   #+(or lispworks cmu) (declare (ignore type))
 124   #+allegro
 125   `(ff:fslot-value-typed ,type :c ,obj ,slot)
 126   #+lispworks
 127   `(fli:foreign-slot-pointer ,obj ,slot)
 128   #+cmu
 129   `(alien:slot ,obj ,slot)
 130   )
 131
 132 |#
 133