src-mcl/primitives.cl

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          primitives.cl
   6 ;;;; Purpose:       UFFI source to handle immediate types
   7 ;;;; Programmers:   Kevin M. Rosenberg and John DeSoi
   8 ;;;; Date Started:  Feb 2002
   9 ;;;;
  10 ;;;; $Id: primitives.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 (defvar *keyword-package* (find-package "KEYWORD"))
  25
  26 ; MCL and OpenMCL expect a lot of FFI elements to be keywords (e.g. struct field names in OpenMCL)
  27 ; So this provides a function to convert any quoted symbols to keywords.
  28 (defun keyword (obj)
  29   (cond ((keywordp obj)
  30          obj)
  31         ((null obj)
  32          nil)
  33         ((symbolp obj)
  34          (intern (symbol-name obj) *keyword-package*))
  35         ((and (listp obj) (eq (car obj) 'cl:quote))
  36          (keyword (cadr obj)))
  37         ((stringp obj)
  38          (intern obj *keyword-package*))
  39         (t
  40          obj)))
  41
  42
  43 ; Wrapper for unexported function we have to use
  44 #-openmcl
  45 (defmacro def-mcl-type (name type)
  46   `(ccl::def-mactype ,(keyword name) (ccl:find-mactype ,type)))
  47
  48
  49 (defmacro def-constant (name value &key (export nil))
  50   "Macro to define a constant and to export it"
  51   `(eval-when (:compile-toplevel :load-toplevel :execute)
  52      (defconstant ,name ,value)
  53      ,(if export (list 'export `(quote ,name)) (values))))
  54
  55 (defmacro def-type (name type)
  56   "Generates a (deftype) statement for CL. Currently, only CMUCL
  57 supports takes advantage of this optimization."
  58   (declare (ignore type))
  59   `(deftype ,name () t))
  60
  61 (defmacro null-char-p (val)
  62   "Returns T if character is NULL"
  63   `(zerop ,val))
  64
  65
  66 (defmacro def-foreign-type (name uffi-type)
  67   (let ((type (convert-from-uffi-type uffi-type :type)))
  68     (unless (keywordp type)
  69       (setf type `(quote ,type)))
  70     #-openmcl
  71     `(def-mcl-type ,(keyword name) ,type)
  72     #+openmcl
  73     `(ccl::def-foreign-type ,(keyword name) ,type)))
  74
  75
  76 (eval-when (:compile-toplevel :load-toplevel :execute)
  77   (defvar +type-conversion-hash+ (make-hash-table :size 20)))
  78
  79 #-openmcl
  80 (defconstant +type-conversion-list+
  81     '((* . :pointer) (:void . :void)
  82       (:short . :short)
  83       (:pointer-void . :pointer)
  84       (:cstring . :string)
  85       (:char . :character)
  86       (:unsigned-char . :unsigned-byte)
  87       (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte)
  88       (:int . :integer) (:unsigned-int . :unsigned-integer)
  89       (:long . :long) (:unsigned-long . :unsigned-long)
  90       (:float . :single-float) (:double . :double-float)
  91       (:array . :array)))
  92
  93 #+openmcl
  94 (defconstant +type-conversion-list+
  95     '((* . :address) (:void . :void)
  96       (:short . :short)
  97       (:pointer-void . :address)
  98       (:cstring . :address)
  99       (:char . :signed-char)
 100       (:unsigned-char . :unsigned-char)
 101       (:byte . :signed-byte) (:unsigned-byte . :unsigned-byte)
 102       (:int . :int) (:unsigned-int . :unsigned-int)
 103       (:long . :long) (:unsigned-long . :unsigned-long)
 104       (:long-long . :signed-doubleword) (:unsigned-long-long . :unsigned-doubleword)
 105       (:float . :single-float) (:double . :double-float)
 106       (:array . :array)))
 107
 108 (dolist (type +type-conversion-list+)
 109   (setf (gethash (car type) +type-conversion-hash+) (cdr type)))
 110
 111
 112 (defmethod ph (&optional (os *standard-output*))
 113   (maphash #'(lambda (k v) (format os "~&~S => ~S" k v)) +type-conversion-hash+))
 114
 115
 116
 117 (defun basic-convert-from-uffi-type (type)
 118   (let ((found-type (gethash type +type-conversion-hash+)))
 119     (if found-type
 120         found-type
 121         (keyword type))))
 122
 123 (defun %convert-from-uffi-type (type context)
 124   "Converts from a uffi type to an implementation specific type"
 125   (if (atom type)
 126     (cond
 127      #-openmcl
 128      ((and (eq type :void) (eq context :return)) nil)
 129      (t (basic-convert-from-uffi-type type)))
 130     (if (eq (car type) 'cl:quote)
 131       (%convert-from-uffi-type (cadr type) context)
 132       (cons (%convert-from-uffi-type (first type) context)
 133             (%convert-from-uffi-type (rest type) context)))))
 134
 135 (defun convert-from-uffi-type (type context)
 136   (let ((result (%convert-from-uffi-type type context)))
 137     (cond
 138      ((atom result) result)
 139      #+openmcl
 140      ((eq (car result) :address) :address)
 141      #-openmcl
 142      ((and (eq (car result) :pointer) (eq context :allocation) :pointer))
 143      (t result))))