X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fprimitives.cl;h=c61f6dd21680d7dc67ed3a25539726c47662af2d;hb=a624b86f5dd46f9fc682440e5c7b0b131dc28084;hp=a0bcae74361768916e7d066a5478042d07e90830;hpb=f3c0481a74e3289b222c26051fc817cc69e133a6;p=uffi.git diff --git a/src/primitives.cl b/src/primitives.cl index a0bcae7..c61f6dd 100644 --- a/src/primitives.cl +++ b/src/primitives.cl @@ -1,4 +1,4 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; @@ -7,59 +7,41 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; Copyright (c) 2002 Kevin M. Rosenberg +;;;; $Id: primitives.cl,v 1.16 2002/04/06 19:53:08 kevin Exp $ ;;;; -;;;; $Id: primitives.cl,v 1.2 2002/03/10 22:29:47 kevin Exp $ +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; -;;;; This file is part of the UFFI. -;;;; -;;;; UFFI is free software; you can redistribute it and/or modify -;;;; it under the terms of the GNU General Public License (version 2) as -;;;; published by the Free Software Foundation. -;;;; -;;;; UFFI is distributed in the hope that it will be useful, -;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;;;; GNU General Public License for more details. -;;;; -;;;; You should have received a copy of the GNU General Public License -;;;; along with UFFI; if not, write to the Free Software -;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;;;; UFFI users are granted the rights to distribute and use this software +;;;; as governed by the terms of the Lisp Lesser GNU Public License +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;;; ************************************************************************* (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (in-package :uffi) -(defmacro def-constant (name value) +(defmacro def-constant (name value &key (export nil)) "Macro to define a constant and to export it" `(eval-when (:compile-toplevel :load-toplevel :execute) (defconstant ,name ,value) - (export ',name))) - -(defmacro uffi-declare (type name) - "Generates a declare statement for CL. Currently, only CMUCL -supports this." - #+(or lispworks allegro) - (declare (ignore type name)) - #+cmu - `(declare (type (alien:alien ,type)) ,name) - ) + ,(when export (list 'export `(quote ,name))) + ',name)) -(defmacro slot-type (type) +(defmacro def-type (name type) + "Generates a (deftype) statement for CL. Currently, only CMUCL +supports takes advantage of this optimization." #+(or lispworks allegro) (declare (ignore type)) #+(or lispworks allegro) - t - #+cmu `'(alien:alien ,type)) + `(deftype ,name () t) + #+cmu + `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare))) + ) (defmacro null-char-p (val) - `(if (or (eql ,val 0) - (eq ,val #\Null)) - t - nil)) - + "Returns T if character is NULL" + `(zerop ,val)) -(defmacro def-type (name type) +(defmacro def-foreign-type (name type) #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type)) #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type)) #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type)) @@ -83,7 +65,9 @@ supports this." (:unsigned-long . (alien:unsigned 32)) (:float . alien:single-float) (:double . alien:double-float) - )) + ) + "Conversions in CMUCL or def-foreign-type are different thatn in def-function") + #+cmu (defconstant +type-conversion-list+ @@ -94,6 +78,8 @@ supports this." (:char . c-call:char) (:unsigned-char . (alien:unsigned 8)) (:byte . (alien:unsigned 8)) + (:short . c-call:unsigned-short) + (:unsigned-short . c-call:unsigned-short) (:int . alien:integer) (:unsigned-int . c-call:unsigned-int) (:long . c-call:long) (:unsigned-long . c-call:unsigned-long) (:float . c-call:float) (:double . c-call:double) @@ -103,7 +89,7 @@ supports this." '((* . *) (:void . :void) (:short . :short) (:pointer-void . (* :void)) - (:cstring . (* :char)) + (:cstring . (* :unsigned-char)) (:char . :char) (:unsigned-char . :unsigned-char) (:byte . :byte) @@ -116,8 +102,10 @@ supports this." '((* . :pointer) (:void . :void) (:short . :short) (:pointer-void . (:pointer :void)) - (:cstring . (:pointer :char)) - (:char . :char) + (:cstring . (:reference-pass :ef-mb-string :allow-null t)) + (:cstring-returning . (:reference :ef-mb-string :allow-null t)) + (:char . :char) + (:byte :byte) (:unsigned-char . (:unsigned :char)) (:int . :int) (:unsigned-int . (:unsigned :int)) (:long . :long) (:unsigned-long . (:unsigned :long)) @@ -131,8 +119,11 @@ supports this." (dolist (type +cmu-def-type-list+) (setf (gethash (car type) +cmu-def-type-hash+) (cdr type))) -(defun ph (&optional (os *standard-output*)) - (maphash #'(lambda (k v) (format os "~&~S => ~S" k v)) +type-conversion-hash+)) +(defun basic-convert-from-uffi-type (type) + (let ((found-type (gethash type +type-conversion-hash+))) + (if found-type + found-type + type))) (defun convert-from-uffi-type (type context) "Converts from a uffi type to an implementation specific type" @@ -147,17 +138,15 @@ supports this." (let ((cmu-type (gethash type +cmu-def-type-hash+))) (if cmu-type cmu-type - (let ((found-type (gethash type +type-conversion-hash+))) - (if found-type - found-type - type))))) + (basic-convert-from-uffi-type type)))) + #+lispworks + ((and (eq context :return) + (eq type :cstring)) + (basic-convert-from-uffi-type :cstring-returning)) (t - (let ((found-type (gethash type +type-conversion-hash+))) - (if found-type - found-type - type)))) - (cons (convert-from-uffi-type (first type) context) - (convert-from-uffi-type (rest type) context)))) + (basic-convert-from-uffi-type type))) + (cons (convert-from-uffi-type (first type) context) + (convert-from-uffi-type (rest type) context))))