X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=src%2Fprimitives.cl;fp=src%2Fprimitives.cl;h=c10766416a0ee348599e604e66f4ea2b56abc0c2;hb=93d37518cbd27aa8b7f313bb89b9523d5a40ec88;hp=0000000000000000000000000000000000000000;hpb=6aca6ef38f1f406c9e7987e46cbaca3299c487fb;p=uffi.git diff --git a/src/primitives.cl b/src/primitives.cl new file mode 100644 index 0000000..c107664 --- /dev/null +++ b/src/primitives.cl @@ -0,0 +1,198 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: primitives.cl +;;;; Purpose: UFFI source to handle immediate types +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; $Id: primitives.cl,v 1.22 2002/08/23 15:28:52 kevin Exp $ +;;;; +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg +;;;; +;;;; 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 &key (export nil)) + "Macro to define a constant and to export it" + `(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant ,name ,value) + ,(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 + `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare))) + #+sbcl + `(deftype ,name () '(sb-alien:alien ,(convert-from-uffi-type type :declare))) + ) + +(defmacro null-char-p (val) + "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)) + #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type)) + #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type)) + #+sbcl `(sb-alien:def-alien-type ,name ,(convert-from-uffi-type type :type)) + ) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar +type-conversion-hash+ (make-hash-table :size 20)) + #+(or cmu sbcl) (defvar +cmu-def-type-hash+ (make-hash-table :size 20)) + ) + +#+cmu +(defconstant +cmu-def-type-list+ + '((:char . (alien:signed 8)) + (:unsigned-char . (alien:unsigned 8)) + (:byte . (alien:signed 8)) + (:unsigned-byte . (alien:unsigned 8)) + (:short . (alien:signed 16)) + (:unsigned-short . (alien:unsigned 16)) + (:int . (alien:signed 32)) + (:unsigned-int . (alien:unsigned 32)) + (:long . (alien:signed 32)) + (:unsigned-long . (alien:unsigned 32)) + (:float . alien:single-float) + (:double . alien:double-float) + ) + "Conversions in CMUCL for def-foreign-type are different than in def-function") +#+sbcl +(defconstant +cmu-def-type-list+ + '((:char . (sb-alien:signed 8)) + (:unsigned-char . (sb-alien:unsigned 8)) + (:byte . (sb-alien:signed 8)) + (:unsigned-byte . (sb-alien:unsigned 8)) + (:short . (sb-alien:signed 16)) + (:unsigned-short . (sb-alien:unsigned 16)) + (:int . (sb-alien:signed 32)) + (:unsigned-int . (sb-alien:unsigned 32)) + (:long . (sb-alien:signed 32)) + (:unsigned-long . (sb-alien:unsigned 32)) + (:float . sb-alien:single-float) + (:double . sb-alien:double-float) + ) + "Conversions in SBCL for def-foreign-type are different than in def-function") + +(defparameter +type-conversion-list+ nil) + +#+cmu +(setq +type-conversion-list+ + '((* . *) (:void . c-call:void) + (:short . c-call:short) + (:pointer-void . (* t)) + (:cstring . c-call:c-string) + (:char . c-call:char) + (:unsigned-char . (alien:unsigned 8)) + (:byte . (alien:signed 8)) + (:unsigned-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) + (:array . alien:array))) + +#+sbcl +(setq +type-conversion-list+ + '((* . *) (:void . void) + (:short . short) + (:pointer-void . (* t)) + (:cstring . c-string) + (:char . char) + (:unsigned-char . (sb-alien:unsigned 8)) + (:byte . (sb-alien:signed 8)) + (:unsigned-byte . (sb-alien:unsigned 8)) + (:short . unsigned-short) + (:unsigned-short . unsigned-short) + (:int . integer) (:unsigned-int . unsigned-int) + (:long . long) (:unsigned-long . unsigned-long) + (:float . float) (:double . double) + (:array . array))) + +#+allegro +(setq +type-conversion-list+ + '((* . *) (:void . :void) + (:short . :short) + (:pointer-void . (* :void)) + (:cstring . (* :unsigned-char)) + (:byte . :char) + (:unsigned-byte . :unsigned-byte) + (:char . :char) + (:unsigned-char . :unsigned-char) + (:int . :int) (:unsigned-int . :unsigned-int) + (:long . :long) (:unsigned-long . :unsigned-long) + (:float . :float) (:double . :double) + (:array . :array))) +#+lispworks +(setq +type-conversion-list+ + '((* . :pointer) (:void . :void) + (:short . :short) + (:pointer-void . (:pointer :void)) + (:cstring . (:reference-pass (:ef-mb-string :external-format :latin-1) + :allow-null t)) + (:cstring-returning . (:reference (:ef-mb-string :external-format :latin-1) :allow-null t)) + (:byte . :byte) + (:unsigned-byte . (:unsigned :byte)) + (:char . :char) + (:unsigned-char . (:unsigned :char)) + (:int . :int) (:unsigned-int . (:unsigned :int)) + (:long . :long) (:unsigned-long . (:unsigned :long)) + (:float . :float) (:double . :double) + (:array . :c-array))) + +(dolist (type +type-conversion-list+) + (setf (gethash (car type) +type-conversion-hash+) (cdr type))) + +#+(or cmu sbcl) +(dolist (type +cmu-def-type-list+) + (setf (gethash (car type) +cmu-def-type-hash+) (cdr type))) + +(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" + (if (atom type) + (cond + #+allegro + ((and (or (eq context :routine) (eq context :return)) + (eq type :cstring)) + (setq type '((* :char) integer))) + #+(or cmu sbcl) + ((eq context :type) + (let ((cmu-type (gethash type +cmu-def-type-hash+))) + (if cmu-type + cmu-type + (basic-convert-from-uffi-type type)))) + #+lispworks + ((and (eq context :return) + (eq type :cstring)) + (basic-convert-from-uffi-type :cstring-returning)) + (t + (basic-convert-from-uffi-type type))) + (cons (convert-from-uffi-type (first type) context) + (convert-from-uffi-type (rest type) context)))) + + + + + +