From: Kevin M. Rosenberg Date: Mon, 11 Mar 2002 18:00:57 +0000 (+0000) Subject: r1546: *** empty log message *** X-Git-Tag: v1.6.1~602 X-Git-Url: http://git.kpe.io/?p=uffi.git;a=commitdiff_plain;h=63b0648b562bc5a8db5ef013804b1ff4e5c52314 r1546: *** empty log message *** --- diff --git a/ChangeLog b/ChangeLog index 3f0291b..fddee63 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +11 Mar 2002 + + * Changed def-type to def-foreign-type + + * Created new macro def-type to generate cl:deftype forms. Removed + uffi-declare and uffi-slot-type as they are no longer necessary. + 10 Mar 2002 * Modified input parameters to load-foreign-library diff --git a/Makefile b/Makefile index 51dd113..41ac5b3 100644 --- a/Makefile +++ b/Makefile @@ -5,7 +5,7 @@ # Programer: Kevin M. Rosenberg, M.D. # Date Started: Mar 2002 # -# CVS Id: $Id: Makefile,v 1.10 2002/03/10 21:48:50 kevin Exp $ +# CVS Id: $Id: Makefile,v 1.11 2002/03/11 18:00:57 kevin Exp $ # # Copyright (c) 2002 by Kevin M. Rosenberg # @@ -41,12 +41,12 @@ realclean: clean docs: @(cd doc; make dist-doc) -VERSION=0.2.2 +VERSION=0.2.3 DISTDIR=uffi-${VERSION} DIST_TARBALL=${DISTDIR}.tar.gz DIST_ZIP=${DISTDIR}.zip SOURCE_FILES=src doc examples Makefile COPYING COPYRIGHT README \ - INSTALL uffi.lsm ChangeLog NEWS test-examples.cl + INSTALL uffi.lsm ChangeLog NEWS test-examples.cl set-logical.cl dist: realclean docs @rm -fr ${DISTDIR} ${DIST_TARBALL} ${DIST_ZIP} diff --git a/doc/notes.sgml b/doc/notes.sgml index cdb5f6d..c4e8603 100644 --- a/doc/notes.sgml +++ b/doc/notes.sgml @@ -77,8 +77,9 @@ Here is an example that should both methods being used for maximum cross-implementation optimization: +(uffi:def-type the-struct-type-def the-struct-type) (let ((a-foreign-struct (allocate-foreign-object 'the-struct-type))) - (uffi-declare 'the-struct-type a-foreign-struct) + (declare 'the-struct-type-def a-foreign-struct) (get-slot-value a-foreign-struct 'the-struct-type 'field-name)) diff --git a/doc/ref.sgml b/doc/ref.sgml index 33f8a56..aaf1fea 100644 --- a/doc/ref.sgml +++ b/doc/ref.sgml @@ -27,34 +27,16 @@ - - uffi-declare - - This is used wherever a declare - expression can be placed. For example: - - - -(let ((my-structure (uffi:allocate-foreign-object 'a-struct))) - (uffi:uffi-declare a-struct my-structure)) - - - - - - slot-type + + def-type - This is used inside of defclass and - defstruct expressions to set the type - for a field. Because the type identifier is not evaluated in - &cl;, the expression must be backquoted for effect. For - example: - + This is used wherever a &cl; deftype + expression can be placed. Used to declare types to +the compiler for optimization. Currently, on &cmucl; takes advantage +of this. -(eval - `(defclass a-class () - ((char-ptr :type ,(uffi:slot-type (* :char)))))) +(uffi:def-type my-struct-def my-struct-foreign-type) diff --git a/examples/gettime.cl b/examples/gettime.cl index a093306..1c64421 100644 --- a/examples/gettime.cl +++ b/examples/gettime.cl @@ -9,7 +9,7 @@ ;;;; ;;;; Copyright (c) 2002 Kevin M. Rosenberg ;;;; -;;;; $Id: gettime.cl,v 1.4 2002/03/10 22:29:47 kevin Exp $ +;;;; $Id: gettime.cl,v 1.5 2002/03/11 18:00:57 kevin Exp $ ;;;; ;;;; This file is part of UFFI. ;;;; @@ -29,7 +29,7 @@ (in-package :cl-user) -(uffi:def-type time-t :unsigned-long) +(uffi:def-foreign-type time-t :unsigned-long) (uffi:def-struct tm (sec :int) @@ -50,24 +50,30 @@ ((time (* time-t))) :returning (* tm)) +(uffi:def-type time-t :unsigned-long) +(uffi:def-type tm-pointer (* tm)) + (defun gettime () - "Returns the local time" - (let* ((time (uffi:allocate-foreign-object time-t))) -;; (uffi:uffi-declare time-t time) - (c-time time) - (let ((tm-ptr (c-localtime time))) -;; (uffi:uffi-declare (* tm) tm-ptr) - (let ((time-string (format nil "~2d/~2,'0d/~d ~2d:~2,'0d:~2,'0d" - (1+ (uffi:get-slot-value tm-ptr 'tm 'mon)) - (uffi:get-slot-value tm-ptr 'tm 'mday) - (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year)) - (uffi:get-slot-value tm-ptr 'tm 'hour) - (uffi:get-slot-value tm-ptr 'tm 'min) - (uffi:get-slot-value tm-ptr 'tm 'sec) - ))) - (uffi:free-foreign-object time) - time-string)) - )) + "Returns the local time" + (let* ((time (uffi:allocate-foreign-object time-t))) + (declare (type time-t time)) + (c-time time) + (let ((tm-ptr (the tm-pointer (c-localtime time)))) + (declare (type tm-pointer tm-ptr)) + (let ((time-string (format nil "~2d/~2,'0d/~d ~2d:~2,'0d:~2,'0d" + (1+ (uffi:get-slot-value tm-ptr 'tm 'mon)) + (uffi:get-slot-value tm-ptr 'tm 'mday) + (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year)) + (uffi:get-slot-value tm-ptr 'tm 'hour) + (uffi:get-slot-value tm-ptr 'tm 'min) + (uffi:get-slot-value tm-ptr 'tm 'sec) + ))) + (uffi:free-foreign-object time) + time-string)) + )) + + + #+test-uffi (format t "~&~A" (gettime)) diff --git a/examples/strtol.cl b/examples/strtol.cl index 518eb29..57d2b45 100644 --- a/examples/strtol.cl +++ b/examples/strtol.cl @@ -9,7 +9,7 @@ ;;;; ;;;; Copyright (c) 2002 Kevin M. Rosenberg ;;;; -;;;; $Id: strtol.cl,v 1.6 2002/03/10 11:13:07 kevin Exp $ +;;;; $Id: strtol.cl,v 1.7 2002/03/11 18:00:57 kevin Exp $ ;;;; ;;;; This file is part of UFFI. ;;;; @@ -29,7 +29,7 @@ (in-package :cl-user) -(uffi:def-type char-ptr (* :char)) +(uffi:def-foreign-type char-ptr (* :char)) ;; This example does not use :cstring to pass the input string since ;; the routine needs to do pointer arithmetic to see how many characters diff --git a/set-logical.cl b/set-logical.cl new file mode 100644 index 0000000..228023a --- /dev/null +++ b/set-logical.cl @@ -0,0 +1,75 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: set-logical.cl +;;;; Purpose: Sets a logical host for src/binaries based on a pathname. +;;;; Programmer: Kevin M. Rosenberg +;;;; Date Started: Feb 2002 +;;;; +;;;; Copyright (c) 2002 Kevin M. Rosenberg +;;;; +;;;; $Id: set-logical.cl,v 1.1 2002/03/11 18:00:57 kevin Exp $ +;;;; +;;;; This file is part of 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 +;;;; ************************************************************************* + + +;;; Setup logical pathname translaton with separate binary directories +;;; for each implementation + +;; push allegro case sensitivity on *features* +#+allegro +(eval-when (:compile-toplevel :load-toplevel :execute) + (if (or (eq excl:*current-case-mode* :case-sensitive-lower) + (eq excl:*current-case-mode* :case-sensitive-upper)) + (pushnew :case-sensitive cl:*features*) + (pushnew :case-insensitive cl:*features*))) + +(defconstant +set-logical-compiler-name+ + #+(and allegro ics case-sensitive) "acl-modern" + #+(and allegro (not ics) case-sensitive) "acl-modern8" + #+(and allegro ics (not case-sensitive)) "acl-ansi" + #+(and allegro (not ics) (not case-sensitive)) "acl-ansi8" + #+lispworks "lispworks" + #+clisp "clisp" + #+cmu "cmucl" + #+sbcl "sbcl" + #+corman "corman" + #+mcl "mcl" + #-(or allegro lispworks clisp cmu sbcl corman mcl) "unknown") + +(defun set-logical-host-for-pathname (host base-pathname) + (setf (logical-pathname-translations host) + `(("ROOT;" ,(make-pathname + :host (pathname-host base-pathname) + :device (pathname-device base-pathname) + :directory (pathname-directory base-pathname))) + ("**;bin;*.*.*" ,(merge-pathnames + (make-pathname + :name :wild + :type :wild + :directory + (append '(:relative :wild-inferiors + ".bin" #.+set-logical-compiler-name+))) + base-pathname)) + ("**;*.*.*" ,(merge-pathnames + (make-pathname + :name :wild + :type :wild + :directory '(:relative :wild-inferiors)) + base-pathname)))) + ) diff --git a/src/primitives.cl b/src/primitives.cl index a0bcae7..1df69e1 100644 --- a/src/primitives.cl +++ b/src/primitives.cl @@ -9,7 +9,7 @@ ;;;; ;;;; Copyright (c) 2002 Kevin M. Rosenberg ;;;; -;;;; $Id: primitives.cl,v 1.2 2002/03/10 22:29:47 kevin Exp $ +;;;; $Id: primitives.cl,v 1.3 2002/03/11 18:00:57 kevin Exp $ ;;;; ;;;; This file is part of the UFFI. ;;;; @@ -36,22 +36,15 @@ (defconstant ,name ,value) (export ',name))) -(defmacro uffi-declare (type name) - "Generates a declare statement for CL. Currently, only CMUCL -supports this." +(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 name)) + `(deftype ,name () t) #+cmu - `(declare (type (alien:alien ,type)) ,name) + `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare))) ) -(defmacro slot-type (type) - #+(or lispworks allegro) - (declare (ignore type)) - #+(or lispworks allegro) - t - #+cmu `'(alien:alien ,type)) - (defmacro null-char-p (val) `(if (or (eql ,val 0) (eq ,val #\Null)) @@ -59,7 +52,7 @@ supports this." nil)) -(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)) @@ -131,7 +124,7 @@ supports this." (dolist (type +cmu-def-type-list+) (setf (gethash (car type) +cmu-def-type-hash+) (cdr type))) -(defun ph (&optional (os *standard-output*)) +(defmethod ph (&optional (os *standard-output*)) (maphash #'(lambda (k v) (format os "~&~S => ~S" k v)) +type-conversion-hash+)) (defun convert-from-uffi-type (type context) diff --git a/tests/gettime.cl b/tests/gettime.cl index a093306..1c64421 100644 --- a/tests/gettime.cl +++ b/tests/gettime.cl @@ -9,7 +9,7 @@ ;;;; ;;;; Copyright (c) 2002 Kevin M. Rosenberg ;;;; -;;;; $Id: gettime.cl,v 1.4 2002/03/10 22:29:47 kevin Exp $ +;;;; $Id: gettime.cl,v 1.5 2002/03/11 18:00:57 kevin Exp $ ;;;; ;;;; This file is part of UFFI. ;;;; @@ -29,7 +29,7 @@ (in-package :cl-user) -(uffi:def-type time-t :unsigned-long) +(uffi:def-foreign-type time-t :unsigned-long) (uffi:def-struct tm (sec :int) @@ -50,24 +50,30 @@ ((time (* time-t))) :returning (* tm)) +(uffi:def-type time-t :unsigned-long) +(uffi:def-type tm-pointer (* tm)) + (defun gettime () - "Returns the local time" - (let* ((time (uffi:allocate-foreign-object time-t))) -;; (uffi:uffi-declare time-t time) - (c-time time) - (let ((tm-ptr (c-localtime time))) -;; (uffi:uffi-declare (* tm) tm-ptr) - (let ((time-string (format nil "~2d/~2,'0d/~d ~2d:~2,'0d:~2,'0d" - (1+ (uffi:get-slot-value tm-ptr 'tm 'mon)) - (uffi:get-slot-value tm-ptr 'tm 'mday) - (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year)) - (uffi:get-slot-value tm-ptr 'tm 'hour) - (uffi:get-slot-value tm-ptr 'tm 'min) - (uffi:get-slot-value tm-ptr 'tm 'sec) - ))) - (uffi:free-foreign-object time) - time-string)) - )) + "Returns the local time" + (let* ((time (uffi:allocate-foreign-object time-t))) + (declare (type time-t time)) + (c-time time) + (let ((tm-ptr (the tm-pointer (c-localtime time)))) + (declare (type tm-pointer tm-ptr)) + (let ((time-string (format nil "~2d/~2,'0d/~d ~2d:~2,'0d:~2,'0d" + (1+ (uffi:get-slot-value tm-ptr 'tm 'mon)) + (uffi:get-slot-value tm-ptr 'tm 'mday) + (+ 1900 (uffi:get-slot-value tm-ptr 'tm 'year)) + (uffi:get-slot-value tm-ptr 'tm 'hour) + (uffi:get-slot-value tm-ptr 'tm 'min) + (uffi:get-slot-value tm-ptr 'tm 'sec) + ))) + (uffi:free-foreign-object time) + time-string)) + )) + + + #+test-uffi (format t "~&~A" (gettime)) diff --git a/tests/strtol.cl b/tests/strtol.cl index 518eb29..57d2b45 100644 --- a/tests/strtol.cl +++ b/tests/strtol.cl @@ -9,7 +9,7 @@ ;;;; ;;;; Copyright (c) 2002 Kevin M. Rosenberg ;;;; -;;;; $Id: strtol.cl,v 1.6 2002/03/10 11:13:07 kevin Exp $ +;;;; $Id: strtol.cl,v 1.7 2002/03/11 18:00:57 kevin Exp $ ;;;; ;;;; This file is part of UFFI. ;;;; @@ -29,7 +29,7 @@ (in-package :cl-user) -(uffi:def-type char-ptr (* :char)) +(uffi:def-foreign-type char-ptr (* :char)) ;; This example does not use :cstring to pass the input string since ;; the routine needs to do pointer arithmetic to see how many characters diff --git a/uffi.system b/uffi.system index 312f9be..7491d63 100644 --- a/uffi.system +++ b/uffi.system @@ -9,7 +9,7 @@ ;;;; ;;;; Copyright (c) 2002 Kevin M. Rosenberg ;;;; -;;;; $Id: uffi.system,v 1.3 2002/03/10 21:48:50 kevin Exp $ +;;;; $Id: uffi.system,v 1.4 2002/03/11 18:00:57 kevin Exp $ ;;;; ;;;; This file is part of UFFI. ;;;; @@ -30,45 +30,9 @@ (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (in-package :cl-user) -;;; Setup logical pathname translaton with separate binary directories -;;; for each implementation - -;; push allegro case sensitivity on *features* -#+allegro -(eval-when (:compile-toplevel :load-toplevel :execute) - (if (or (eq excl:*current-case-mode* :case-sensitive-lower) - (eq excl:*current-case-mode* :case-sensitive-upper)) - (pushnew :case-sensitive cl:*features*) - (pushnew :case-insensitive cl:*features*))) - -(defconstant +uffi-compiler-name+ - #+(and allegro ics case-sensitive) "acl-modern" - #+(and allegro (not ics) case-sensitive) "acl-modern8" - #+(and allegro ics (not case-sensitive)) "acl-ansi" - #+(and allegro (not ics) (not case-sensitive)) "acl-ansi8" - #+lispworks "lispworks" - #+clisp "clisp" - #+cmu "cmucl" - #+sbcl "sbcl" - #+corman "corman" - #+mcl "mcl" - #-(or allegro lispworks clisp cmu sbcl corman mcl) "unknown") - -(setf (logical-pathname-translations "UFFI") - `(("**;bin;*.*.*" ,(merge-pathnames - (make-pathname - :name :wild - :type :wild - :directory - (append '(:relative :wild-inferiors - ".bin" #.+uffi-compiler-name+))) - *load-truename*)) - ("**;*.*.*" ,(merge-pathnames - (make-pathname - :name :wild - :type :wild - :directory '(:relative :wild-inferiors)) - *load-truename*)))) +(load (make-pathname :name "set-logical" :type "cl" + :defaults *load-truename*)) +(set-logical-host-for-pathname "UFFI" *load-truename*) ;;; UFFI system definition