From 78e74f7d44e3ae306e6ebba9c149a428f8a0d79b Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 30 Sep 2002 08:50:00 +0000 Subject: [PATCH] r2907: *** empty log message *** --- src/aggregates.cl | 33 ++++++++++++++++++--------------- src/objects.cl | 40 ++++++++++++++++++++-------------------- src/primitives.cl | 16 ++++++++-------- src/strings.cl | 8 ++++---- 4 files changed, 50 insertions(+), 47 deletions(-) diff --git a/src/aggregates.cl b/src/aggregates.cl index bdc7704..83a7995 100644 --- a/src/aggregates.cl +++ b/src/aggregates.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: aggregates.cl,v 1.14 2002/09/30 07:51:01 kevin Exp $ +;;;; $Id: aggregates.cl,v 1.15 2002/09/30 08:50:00 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -67,18 +67,20 @@ of the enum-name name, separator-string, and field-name" `(ccl::def-foreign-type ,name-array (:array ,(convert-from-uffi-type type :array))) ) -(defun process-struct-fields (name fields) +(defun process-struct-fields (name fields &optional (variant nil)) (let (processed) (dolist (field fields) - (let ((field-name (car field)) - (type (cadr field))) - (push (append (list field-name) - (if (eq type :pointer-self) - #+cmu `((* (alien:struct ,name))) - #+mcl `((:* (:struct ,name))) - #-(or cmu mcl) `((* ,name)) - `(,(convert-from-uffi-type type :struct)))) - processed))) + (let* ((field-name (car field)) + (type (cadr field)) + (def (append (list field-name) + (if (eq type :pointer-self) + #+cmu `((* (alien:struct ,name))) + #+mcl `((:* (:struct ,name))) + #-(or cmu mcl) `((* ,name)) + `(,(convert-from-uffi-type type :struct)))))) + (if variant + (push (list def) processed) + (push def processed)))) (nreverse processed))) @@ -90,10 +92,11 @@ of the enum-name name, separator-string, and field-name" #+lispworks `(fli:define-c-struct ,name ,@(process-struct-fields name fields)) #+(and mcl (not openmcl)) - `(ccl:defrecord ,name ,@(process-struct-fields name fields nil)) + `(ccl:defrecord ,name ,@(process-struct-fields name fields)) #+openmcl - `(ccl::def-foreign-type nil - (:struct ,name ,@(process-struct-fields name fields nil))) + `(ccl::def-foreign-type + nil + (:struct ,name ,@(process-struct-fields name fields))) ) @@ -184,5 +187,5 @@ of the enum-name name, separator-string, and field-name" `(ccl:defrecord ,name (:variant ,@(process-struct-fields name fields t))) #+openmcl `(ccl::def-foreign-type nil - (:union ,name ,@(process-struct-fields name fields nil))) + (:union ,name ,@(process-struct-fields name fields))) ) diff --git a/src/objects.cl b/src/objects.cl index 3500301..6f1e8ce 100644 --- a/src/objects.cl +++ b/src/objects.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: objects.cl,v 1.24 2002/09/30 07:51:01 kevin Exp $ +;;;; $Id: objects.cl,v 1.25 2002/09/30 08:50:00 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -19,6 +19,20 @@ (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (in-package :uffi) +(defun size-of-foreign-type (type) + #+lispworks (fli:size-of type) + #+allegro (ff:sizeof-fobject type) + #+cmu (alien:alien-size type) + #+clisp (values (ffi:size-of type)) + #+(and mcl (not openmcl)) + (let ((mcl-type (ccl:find-mactype type nil t))) + (if mcl-type + (ccl::mactype-record-size mcl-type) + (ccl::record-descriptor-length (ccl:find-record-descriptor type t t)))) ;error if not a record + #+openmcl (ccl::%foreign-type-or-record-size type :bytes) + ) + + (defmacro allocate-foreign-object (type &optional (size :unspecified)) "Allocates an instance of TYPE. If size is specified, then allocate an array of TYPE with size SIZE. The TYPE parameter is evaluated." @@ -62,20 +76,6 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." #+mcl `(ccl:%null-ptr-p ,obj) ) -(defmacro size-of-foreign-type (type) - #+lispworks `(fli:size-of ,type) - #+allegro `(ff:sizeof-fobject ,type) - #+cmu `(alien:alien-size ,type) - #+clisp `(values (ffi:size-of ,type)) - #+(and mcl (not openmcl)) - `(let ((mcl-type (ccl:find-mactype ,type nil t))) - (if mcl-type - (ccl::mactype-record-size mcl-type) - (ccl::record-descriptor-length (ccl:find-record-descriptor ,type t t)))) ;error if not a record - #+opencml `(ccl::%foreign-type-or-record-size ,type :bytes) - ) - - (defmacro make-null-pointer (type) #+(or allegro cmu mcl) (declare (ignore type)) @@ -155,11 +155,6 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." ,@body) ) -#+mcl -(defmacro with-foreign-object ((var type) &rest body) - `(with-foreign-objects ((,var ,type)) - ,@body)) - #-mcl (defmacro with-foreign-objects (bindings &rest body) (if bindings @@ -181,3 +176,8 @@ an array of TYPE with size SIZE. The TYPE parameter is evaluated." (push (list (first spec) (* count (size-of-foreign-type type))) params)) `(ccl:%stack-block ,params ,@body))) +#+mcl +(defmacro with-foreign-object ((var type) &rest body) + `(with-foreign-objects ((,var ,type)) + ,@body)) + diff --git a/src/primitives.cl b/src/primitives.cl index 9a982be..0c35d8a 100644 --- a/src/primitives.cl +++ b/src/primitives.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: primitives.cl,v 1.24 2002/09/30 07:51:01 kevin Exp $ +;;;; $Id: primitives.cl,v 1.25 2002/09/30 08:50:00 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -74,13 +74,13 @@ supports takes advantage of this optimization." #+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)) #+mcl - (let ((type (convert-from-uffi-type uffi-type :type))) - (unless (or (keywordp type) (consp type)) - (setf type `(quote ,type))) + (let ((mcl-type (convert-from-uffi-type type :type))) + (unless (or (keywordp mcl-type) (consp mcl-type)) + (setf mcl-type `(quote ,mcl-type))) #+(and mcl (not openmcl)) - `(def-mcl-type ,(keyword name) ,type) + `(def-mcl-type ,(keyword name) ,mcl-type) #+openmcl - `(ccl::def-foreign-type ,(keyword name) ,type)) + `(ccl::def-foreign-type ,(keyword name) ,mcl-type)) ) (eval-when (:compile-toplevel :load-toplevel :execute) @@ -190,7 +190,7 @@ supports takes advantage of this optimization." (:array . :c-array))) #+(and mcl (not openmcl)) -(defconstant +type-conversion-list+ +(setq +type-conversion-list+ '((* . :pointer) (:void . :void) (:short . :short) (:unsigned-short . :unsigned-short) (:pointer-void . :pointer) @@ -204,7 +204,7 @@ supports takes advantage of this optimization." (:array . :array))) #+openmcl -(defconstant +type-conversion-list+ +(setq +type-conversion-list+ '((* . :address) (:void . :void) (:short . :short) (:unsigned-short . :unsigned-short) (:pointer-void . :address) diff --git a/src/strings.cl b/src/strings.cl index b47b863..e317017 100644 --- a/src/strings.cl +++ b/src/strings.cl @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: strings.cl,v 1.22 2002/09/30 07:51:01 kevin Exp $ +;;;; $Id: strings.cl,v 1.23 2002/09/30 08:50:00 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -24,7 +24,7 @@ #+cmu nil #+allegro 0 #+lispworks (fli:make-pointer :address 0 :type '(:unsigned :char)) - #+mcl (ccl:%nul-ptr) + #+mcl (ccl:%null-ptr) #-(or cmu allegro lispworks mcl) nil ) @@ -85,9 +85,9 @@ that LW/CMU automatically converts strings from c-calls." ,@body))) #+mcl `(if (stringp ,lisp-string) - (ccl:with-cstrs ((,foreign-string ,lisp-string)) + (ccl:with-cstrs ((,cstring ,lisp-string)) ,@body) - (let ((,foreign-string +null-cstring-pointer+)) + (let ((,cstring +null-cstring-pointer+)) ,@body)) ) -- 2.34.1