X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fprimitives.cl;h=d41c75dc8eb40219aeb896840af970527a7c3f0e;hb=9da7e692be03af191d9930169ebda2832232a7a8;hp=1df69e1cbdf5ecb3c4ba3288d2ee073518df62ca;hpb=63b0648b562bc5a8db5ef013804b1ff4e5c52314;p=uffi.git diff --git a/src/primitives.cl b/src/primitives.cl index 1df69e1..d41c75d 100644 --- a/src/primitives.cl +++ b/src/primitives.cl @@ -1,4 +1,4 @@ -;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; -*- Mode: ANSI-Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; @@ -7,38 +7,30 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; Copyright (c) 2002 Kevin M. Rosenberg +;;;; $Id: primitives.cl,v 1.14 2002/03/23 16:32:39 kevin Exp $ ;;;; -;;;; $Id: primitives.cl,v 1.3 2002/03/11 18:00:57 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))) + ,(when export (list 'export `(quote ,name))) + ',name)) (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) `(deftype ,name () t) #+cmu @@ -46,11 +38,8 @@ supports takes advantage of this optimization." ) (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-foreign-type (name type) #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type)) @@ -76,7 +65,9 @@ supports takes advantage of this optimization." (: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+ @@ -87,6 +78,8 @@ supports takes advantage of this optimization." (: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) @@ -96,7 +89,7 @@ supports takes advantage of this optimization." '((* . *) (:void . :void) (:short . :short) (:pointer-void . (* :void)) - (:cstring . (* :char)) + (:cstring . (* :unsigned-char)) (:char . :char) (:unsigned-char . :unsigned-char) (:byte . :byte) @@ -109,8 +102,10 @@ supports takes advantage of this optimization." '((* . :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)) @@ -124,8 +119,11 @@ supports takes advantage of this optimization." (dolist (type +cmu-def-type-list+) (setf (gethash (car type) +cmu-def-type-hash+) (cdr type))) -(defmethod 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" @@ -140,17 +138,15 @@ supports takes advantage of this optimization." (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))))