uffi/mcl/objects.cl

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          objects.cl
   6 ;;;; Purpose:       UFFI source to handle objects and pointers
   7 ;;;; Programmers:   Kevin M. Rosenberg and John DeSoi
   8 ;;;; Date Started:  Feb 2002
   9 ;;;;
  10 ;;;; $Id: objects.cl,v 1.3 2002/08/23 19:21:54 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 ;;; Some MCL specific utilities
  26 ;;;
  27 (defun foreign-object-size (type)
  28   "Returns the size for the specified mcl type or record type"
  29   (let ((mcl-type (ccl:find-mactype type nil t)))
  30     (if mcl-type
  31       (ccl::mactype-record-size mcl-type)
  32       (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)) ) ) ) ;error if not a record
  33
  34
  35 ; trap macros don't work right directly in the macros
  36 (eval-when (:compile-toplevel :load-toplevel :execute)
  37
  38 (defun new-ptr (size)
  39   (#_NewPtr size))
  40
  41 (defun dispose-ptr (ptr)
  42   (#_DisposePtr ptr))
  43
  44 )
  45
  46 ;;;
  47 ;;; Start of standard UFFI
  48 ;;;
  49 (defmacro allocate-foreign-object (type &optional (size :unspecified))
  50   "Allocates an instance of TYPE. If size is specified, then allocate
  51 an array of TYPE with size SIZE."
  52   (if (eq size :unspecified)
  53     `(new-ptr ,(foreign-object-size (convert-from-uffi-type type :allocation)))
  54     `(new-ptr ,(* size (foreign-object-size (convert-from-uffi-type type :allocation))))))
  55
  56
  57
  58 (defmacro free-foreign-object (obj)
  59   `(dispose-ptr ,obj))
  60
  61 (defmacro null-pointer-p (obj)
  62  `(ccl:%null-ptr-p ,obj))
  63
  64
  65 (defmacro make-null-pointer (type)
  66   (declare (ignore type))
  67   `(ccl:%null-ptr))
  68
  69
  70 ;! need to check uffi update and see if :routine is the right context
  71
  72 (defun accessor-symbol (type get-or-set)
  73   "Returns the symbol used to access the foreign type."
  74   (let* ((mcl-type (convert-from-uffi-type (eval type) :routine))
  75          (mac-type (ccl:find-mactype mcl-type))
  76          name)
  77     (ecase get-or-set
  78       (:get (setf name (ccl::mactype-get-function mac-type)))
  79       (:set (setf name (ccl::mactype-set-function mac-type))))
  80     (find-symbol (symbol-name name) :ccl)))
  81
  82 (defmacro deref-pointer (ptr type)
  83   `(,(accessor-symbol type :get) ,ptr))
  84
  85
  86 (defmacro deref-pointer-set (ptr type value)
  87   `(,(accessor-symbol type :set) ,ptr ,value))
  88
  89
  90 (defsetf deref-pointer deref-pointer-set)
  91
  92
  93 (defmacro pointer-address (obj)
  94   `(ccl:%ptr-to-int ,obj))
  95
  96
  97 (defmacro with-foreign-objects (bindings &rest body)
  98   (let ((simple nil) (recs nil) type)
  99     (dolist (spec (reverse bindings)) ;keep order - macroexpands to let*
 100       (setf type (convert-from-uffi-type (eval (nth 1 spec)) :allocate))
 101       (if (ccl:mactype-p type)
 102         (push (list (first spec) (foreign-object-size type)) simple)
 103         (push spec recs)))
 104     (cond ((and simple recs)
 105            `(ccl:%stack-block ,simple
 106               (ccl:rlet ,recs
 107                 ,@body)))
 108           (simple `(ccl:%stack-block ,simple ,@body))
 109           (recs `(ccl:rlet ,recs ,@body)))))
 110
 111
 112 (defmacro with-foreign-object ((var type) &rest body)
 113   `(with-foreign-objects ((,var ,type)) ,@body))