src/mcl/aggregates.cl

   1 ;;;; -*- Mode: ANSI-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 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Feb 2002
   9 ;;;;
  10 ;;;; $Id: aggregates.cl,v 1.1 2002/04/04 04:56:46 desoi Exp $
  11 ;;;;
  12 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; UFFI users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  16 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  17 ;;;; *************************************************************************
  18
  19 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  20 (in-package :uffi)
  21
  22
  23 ;;;
  24 ;;; AGGREGATE SUPPORT IS NOT COMPLETE FOR MCL
  25 ;;;
  26
  27 ;! Need to finish enums, records and variants (unions)
  28
  29 (defmacro def-enum (enum-name args &key (separator-string "#"))
  30   "Creates a constants for a C type enum list, symbols are created
  31 in the created in the current package. The symbol is the concatenation
  32 of the enum-name name, separator-string, and field-name"
  33   (let ((counter 0)
  34         (cmds nil)
  35         (constants nil))
  36     (declare (fixnum counter))
  37     (dolist (arg args)
  38       (let ((name (if (listp arg) (car arg) arg))
  39             (value (if (listp arg)
  40                        (prog1
  41                            (setq counter (cadr arg))
  42                          (incf counter))
  43                      (prog1
  44                          counter
  45                        (incf counter)))))
  46         (setq name (intern (concatenate 'string
  47                              (symbol-name enum-name)
  48                              separator-string
  49                              (symbol-name name))))
  50         (push `(uffi:def-constant ,name ,value) constants)))
  51     (setf cmds (append '(progn)
  52                        #+allegro `((ff:def-foreign-type ,enum-name :int))
  53                        #+lispworks `((fli:define-c-typedef ,enum-name :int))
  54                        #+cmu `((alien:def-alien-type ,enum-name alien:signed))
  55                        (nreverse constants)))
  56     cmds))
  57
  58
  59 #|
  60 (defmacro def-array-pointer (name-array type)
  61   #+allegro
  62   `(ff:def-foreign-type ,name-array
  63     (:array ,(convert-from-uffi-type type :array)))
  64   #+lispworks
  65   `(fli:define-c-typedef ,name-array
  66     (:c-array ,(convert-from-uffi-type type :array)))
  67   #+cmu
  68   `(alien:def-alien-type ,name-array
  69     (* ,(convert-from-uffi-type type :array)))
  70   )
  71
  72 |#
  73
  74 ; this is how rref expands array slot access (minus adding the struct offset)
  75 (defmacro deref-array (obj type i)
  76   "Returns a field from a row"
  77   `(,(accessor-symbol type :get) ,obj (* (the fixnum ,i) ,(foreign-object-size type))))
  78
  79 (defmacro deref-array-set (obj type i value)
  80     `(,(accessor-symbol type :set) ,obj ,value (* (the fixnum ,i) ,(foreign-object-size type))))
  81
  82 (defsetf deref-array deref-array-set)
  83
  84
  85
  86 (defun process-struct-fields (name fields)
  87   (let (processed)
  88     (dolist (field fields)
  89       (let ((field-name (car field))
  90             (type (cadr field)))
  91         (push (append (list field-name)
  92                     (if (eq type :pointer-self)
  93                         #+cmu `((* (alien:struct ,name)))
  94                         #-cmu `((* ,name))
  95                         `(,(convert-from-uffi-type type :struct))))
  96                     processed)))
  97     (nreverse processed)))
  98
  99
 100 (defmacro def-struct (name &rest fields)
 101   `(ccl:defrecord ,name ,@(process-struct-fields name fields))
 102   )
 103
 104
 105 (defmacro def-union (name &rest fields)
 106   `(ccl:defrecord ,name ,@(process-struct-fields name fields))
 107   )
 108
 109
 110 #| not done for mcl
 111 (defmacro get-slot-value (obj type slot)
 112  (declare (ignore type))
 113   #+allegro
 114   `(ff:fslot-value-typed ,type :c ,obj ,slot)
 115   #+lispworks
 116   `(fli:foreign-slot-value ,obj ,slot)
 117   #+cmu
 118   `(alien:slot ,obj ,slot)
 119   )
 120
 121 (defmacro get-slot-pointer (obj type slot)
 122   #+(or lispworks cmu) (declare (ignore type))
 123   #+allegro
 124   `(ff:fslot-value-typed ,type :c ,obj ,slot)
 125   #+lispworks
 126   `(fli:foreign-slot-pointer ,obj ,slot)
 127   #+cmu
 128   `(alien:slot ,obj ,slot)
 129   )
 130
 131 |#
 132