src-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.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 ;;; Some MCL specific utilities
  26 ;;;
  27
  28 ; trap macros don't work right directly in the macros
  29 (eval-when (:compile-toplevel :load-toplevel :execute)
  30
  31 #-openmcl
  32 (defun new-ptr (size)
  33   (#_NewPtr size))
  34
  35 #-openmcl
  36 (defun dispose-ptr (ptr)
  37   (#_DisposePtr ptr))
  38
  39 #+openmcl
  40 (defmacro new-ptr (size)
  41   `(ccl::malloc ,size))
  42
  43 #+openmcl
  44 (defmacro dispose-ptr (ptr)
  45   `(ccl::free ,ptr))
  46
  47 )
  48
  49 ;;;
  50 ;;; Start of standard UFFI
  51 ;;;
  52 (defun size-of-foreign-type (type)
  53   "Returns the size for the specified mcl type or record type"
  54   #+openmcl
  55   (ccl::%foreign-type-or-record-size type :bytes)
  56   #-openmcl
  57   (let ((mcl-type (ccl:find-mactype type nil t)))
  58     (if mcl-type
  59       (ccl::mactype-record-size mcl-type)
  60       (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)) ) ) ) ;error if not a record
  61
  62
  63
  64 (defmacro allocate-foreign-object (type &optional (size :unspecified))
  65   "Allocates an instance of TYPE. If size is specified, then allocate
  66 an array of TYPE with size SIZE."
  67   (if (eq size :unspecified)
  68     `(new-ptr ,(size-of-foreign-type (convert-from-uffi-type type :allocation)))
  69     `(new-ptr (* ,size ,(size-of-foreign-type (convert-from-uffi-type type :allocation))))))
  70
  71
  72
  73 (defmacro free-foreign-object (obj)
  74   `(dispose-ptr ,obj))
  75
  76 (defmacro null-pointer-p (obj)
  77  `(ccl:%null-ptr-p ,obj))
  78
  79
  80 (defmacro make-null-pointer (type)
  81   (declare (ignore type))
  82   `(ccl:%null-ptr))
  83
  84
  85 ;already a macptr
  86 (defmacro char-array-to-pointer (obj)
  87   obj)
  88
  89
  90 (defmacro deref-pointer (ptr type)
  91   `(ccl:pref ,ptr ,(convert-from-uffi-type type :deref)))
  92
  93 (defmacro deref-pointer-set (ptr type value)
  94   `(setf (ccl:pref ,ptr ,(convert-from-uffi-type type :deref)) ,value))
  95
  96 (defsetf deref-pointer deref-pointer-set)
  97
  98
  99 (defmacro ensure-char-character (obj)
 100   #-openmcl obj
 101   #+openmcl `(code-char ,obj))
 102
 103
 104 (defmacro ensure-char-integer (obj)
 105   #-openmcl `(char-code ,obj)
 106   #+openmcl obj)
 107
 108
 109 (defmacro pointer-address (obj)
 110   `(ccl:%ptr-to-int ,obj))
 111
 112
 113
 114 (defmacro with-foreign-objects (bindings &rest body)
 115   (let ((params nil) type count)
 116     (dolist (spec (reverse bindings)) ;keep order - macroexpands to let*
 117       (setf type (convert-from-uffi-type (eval (nth 1 spec)) :allocate))
 118       (setf count 1)
 119       (when (and (listp type) (eq (first type) :array))
 120         (setf count (nth 2 type))
 121         (unless (integerp count) (error "Invalid size for array: ~a" type))
 122         (setf type (nth 1 type)))
 123       (push (list (first spec) (* count (size-of-foreign-type type))) params))
 124     `(ccl:%stack-block ,params ,@body)))
 125
 126
 127 (defmacro with-foreign-object ((var type) &rest body)
 128   `(with-foreign-objects ((,var ,type))
 129      ,@body))
 130