From 579b6d8e7ce89151996dd3ea9c29bb4419a4a8ed Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Tue, 1 Oct 2002 17:05:55 +0000 Subject: [PATCH] r2927: Integrate Reini Urban's cormanlisp patches into main UFFI source --- Makefile | 7 +- debian/changelog | 1 + src/corman/corman-notes.txt | 17 +++ src/corman/corman-uffi.lisp | 274 ------------------------------------ src/corman/getenv-ccl.lisp | 86 +++++++++++ src/functions.lisp | 21 +-- src/primitives.lisp | 13 +- uffi.asd | 6 +- 8 files changed, 131 insertions(+), 294 deletions(-) create mode 100644 src/corman/corman-notes.txt delete mode 100644 src/corman/corman-uffi.lisp create mode 100644 src/corman/getenv-ccl.lisp diff --git a/Makefile b/Makefile index 36654b1..524c6bd 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.50 2002/05/13 03:24:46 kevin Exp $ +# CVS Id: $Id: Makefile,v 1.51 2002/10/01 17:05:29 kevin Exp $ # # This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg # @@ -43,4 +43,7 @@ doc: dist: clean $(MAKE) -C doc $@ - +.PHONY: TAGS +TAGS: + if [ -f TAGS ]; then mv -f TAGS TAGS~; fi + find . -name \*.lisp -exec /usr/bin/etags -a \{\} \; diff --git a/debian/changelog b/debian/changelog index a396425..d95e03a 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,6 +1,7 @@ cl-uffi (0.9.2-1) unstable; urgency=low * Add AUTHORS file + * Integrate Reini Urban's cormanlisp patches into main source -- Kevin M. Rosenberg Tue, 1 Oct 2002 08:11:21 -0600 diff --git a/src/corman/corman-notes.txt b/src/corman/corman-notes.txt new file mode 100644 index 0000000..471e244 --- /dev/null +++ b/src/corman/corman-notes.txt @@ -0,0 +1,17 @@ +some notes: + we need the :pascal (:stdcall) calling conventions for + (def-function names args &key module returning calling-convention) + so I added this. calling-convention defaults to :cdecl + but on win32 we mostly use :stdcall + + #+corman is invalid, #+cormanlisp instead + + cormanlisp doesn't need to load and register the dll, since the underlying + LoadLibrary() call does this. we need the module keyword for def-function +instead. + (should probably default to kernel32.dll) + I'll think about library.cl, but we'll need more real-world win32 examples. + (ideally the complete winapi :) + I also have to look at valentina. + +patch -p0 < corman.diff diff --git a/src/corman/corman-uffi.lisp b/src/corman/corman-uffi.lisp deleted file mode 100644 index c745c10..0000000 --- a/src/corman/corman-uffi.lisp +++ /dev/null @@ -1,274 +0,0 @@ -some notes: - we need the :pascal (:stdcall) calling conventions for - (def-function names args &key module returning calling-convention) - so I added this. calling-convention defaults to :cdecl - but on win32 we mostly use :stdcall - - #+corman is invalid, #+cormanlisp instead - - cormanlisp doesn't need to load and register the dll, since the underlying - LoadLibrary() call does this. we need the module keyword for def-function -instead. - (should probably default to kernel32.dll) - I'll think about library.cl, but we'll need more real-world win32 examples. - (ideally the complete winapi :) - I also have to look at valentina. - -patch -p0 < corman.diff --- -Reini Urban -http://xarch.tu-graz.ac.at/home/rurban/ ---------------269CD5B1F75AF20CFDFE4FEE -Content-Type: text/plain; charset=us-ascii; name="corman.diff" -Content-Disposition: inline; filename="corman.diff" -Content-Transfer-Encoding: 7bit - ---- ./examples/getenv-ccl.cl~ Tue Apr 9 21:08:18 2002 -+++ ./examples/getenv-ccl.cl Tue Apr 9 20:58:16 2002 -@@ -0,0 +1,87 @@ -+;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- -+;;;; ************************************************************************* -+;;;; FILE IDENTIFICATION -+;;;; -+;;;; Name: getenv-ccl.cl -+;;;; Purpose: cormanlisp version -+;;;; Programmer: "Joe Marshall" -+;;;; Date Started: Feb 2002 -+;;;; -+;;;; $Id: corman-uffi.lisp,v 1.1 2002/09/30 10:02:36 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. -+;;;; ************************************************************************* -+ -+(in-package :cl-user) -+ -+(ct:defun-dll c-getenv ((lpname LPSTR) -+ (lpbuffer LPSTR) -+ (nsize LPDWORD)) -+ :library-name "kernel32.dll" -+ :return-type DWORD -+ :entry-name "GetEnvironmentVariableA" -+ :linkage-type :pascal) -+ -+(defun getenv (name) -+ (let ((nsizebuf (ct:malloc (sizeof :long))) -+ (buffer (ct:malloc 1)) -+ (cname (ct:lisp-string-to-c-string name))) -+ (setf (ct:cref lpdword nsizebuf 0) 0) -+ (let* ((needed-size (c-getenv cname buffer nsizebuf)) -+ (buffer1 (ct:malloc (1+ needed-size)))) -+ (setf (ct:cref lpdword nsizebuf 0) needed-size) -+ (prog1 (if (zerop (c-getenv cname buffer1 nsizebuf)) -+ nil -+ (ct:c-string-to-lisp-string buffer1)) -+ (ct:free buffer1) -+ (ct:free nsizebuf))))) -+ -+(defun cl:user-homedir-pathname (&optional host) -+ (cond ((or (stringp host) -+ (and (consp host) -+ (every #'stringp host))) nil) -+ ((or (eq host :unspecific) -+ (null host)) -+ (let ((homedrive (getenv "HOMEDRIVE")) -+ (homepath (getenv "HOMEPATH"))) -+ (parse-namestring -+ (if (and (stringp homedrive) -+ (stringp homepath) -+ (= (length homedrive) 2) -+ (> (length homepath) 0)) -+ (concatenate 'string homedrive homepath "\\") -+ "C:\\")))) -+ (t (error "HOST must be a string, list of strings, NIL or :unspecific")))) -+ -+;| -+(uffi:def-function ("getenv" c-getenv) -+ ((name :cstring)) -+ :returning :cstring) -+ -+(defun my-getenv (key) -+ "Returns an environment variable, or NIL if it does not exist" -+ (check-type key string) -+ (uffi:with-cstring (key-native key) -+ (uffi:convert-from-cstring (c-getenv key-native)))) -+ -+#+examples-uffi -+(progn -+ (flet ((print-results (str) -+ (format t "~&(getenv ~S) => ~S" str (my-getenv str)))) -+ (print-results "USER") -+ (print-results "_FOO_"))) -+ -+ -+#+test-uffi -+(progn -+ (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv") -+ (util.test:test (and (stringp (my-getenv "USER")) -+ (< 0 (length (my-getenv "USER")))) -+ t :fail-info "Error retrieving getenv") -+) -+ -+|; -\ No newline at end of file ---- ./Makefile~ Tue Apr 9 20:03:18 2002 -+++ ./Makefile Tue Apr 9 20:38:03 2002 -@@ -64,3 +64,7 @@ - - wwwdist: dist - @./copy -+ -+TAGS: -+ if [ -f TAGS ]; then mv -f TAGS TAGS~; fi -+ find . -name \*.cl -exec /usr/bin/etags -a \{\} \; ---- ./set-logical.cl~ Tue Apr 9 20:03:20 2002 -+++ ./set-logical.cl Tue Apr 9 20:35:44 2002 -@@ -35,10 +35,10 @@ - #+clisp "clisp" - #+cmu "cmucl" - #+sbcl "sbcl" -- #+corman "corman" -+ #+cormanlisp "cormanlisp" - #+mcl "mcl" - #+openmcl "openmcl" -- #-(or allegro lispworks clisp cmu sbcl corman mcl openmcl) "unknown") -+ #-(or allegro lispworks clisp cmu sbcl cormanlisp mcl openmcl) "unknown") - - (defun set-logical-host-for-pathname (host base-pathname) - (setf (logical-pathname-translations host) ---- ./src/functions.cl~ Tue Apr 9 20:03:24 2002 -+++ ./src/functions.cl Tue Apr 9 21:00:07 2002 -@@ -3,7 +3,7 @@ - ;;;; FILE IDENTIFICATION - ;;;; - ;;;; Name: function.cl --;;;; Purpose: UFFI source to C function defintions -+;;;; Purpose: UFFI source to C function definitions - ;;;; Programmer: Kevin M. Rosenberg - ;;;; Date Started: Feb 2002 - ;;;; -@@ -21,9 +21,8 @@ - - (defun process-function-args (args) - (if (null args) -- #+lispworks nil -+ #+(or lispworks cmu cormanlisp) nil - #+allegro '(:void) -- #+cmu nil - (let (processed) - (dolist (arg args) - (push (process-one-function-arg arg) processed)) -@@ -34,7 +33,7 @@ - (type (convert-from-uffi-type (cadr arg) :routine))) - #+cmu - (list name type :in) -- #+(or allegro lispworks) -+ #+(or allegro lispworks cormanlisp) - (if (and (listp type) (listp (car type))) - (append (list name) type) - (list name type)) -@@ -47,15 +46,15 @@ - - ;; name is either a string representing foreign name, or a list - ;; of foreign-name as a string and lisp name as a symbol --(defmacro def-function (names args &key module returning) -- #+(or cmu allegro) (declare (ignore module)) -+(defmacro def-function (names args &key module returning calling-convention) -+ #+(or cmu allegro cormanlisp) (declare (ignore module)) - - (let* ((result-type (convert-from-uffi-type returning :return)) - (function-args (process-function-args args)) - (foreign-name (if (atom names) names (car names))) - (lisp-name (if (atom names) (make-lisp-name names) (cadr names)))) - -- #+allegro -+ #+allegro ; todo: calling-convention :stdcall - `(ff:def-foreign-call (,lisp-name ,foreign-name) - ,function-args - :returning ,(allegro-convert-return-type result-type) -@@ -70,7 +69,13 @@ - ,function-args - ,@(if module (list :module module) (values)) - :result-type ,result-type -- :calling-convention :cdecl) -+ :calling-convention ,calling-convention) -+ #+cormanlisp -+ `(ct:defun-dll ,lisp-name (,function-args) -+ :return-type ,result-type -+ ,@(if module (list :library-name module) (values)) -+ :entry-name ,foreign-name -+ :linkage-type ,calling-convention) ; we need :pascal - )) - - ---- ./src/primitives.cl~ Tue Apr 9 20:03:25 2002 -+++ ./src/primitives.cl Tue Apr 9 21:05:13 2002 -@@ -29,9 +29,9 @@ - (defmacro def-type (name type) - "Generates a (deftype) statement for CL. Currently, only CMUCL - supports takes advantage of this optimization." -- #+(or lispworks allegro) -+ #+(or lispworks allegro cormanlisp) - (declare (ignore type)) -- #+(or lispworks allegro) -+ #+(or lispworks allegro cormanlisp) - `(deftype ,name () t) - #+cmu - `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare))) -@@ -45,6 +45,7 @@ - #+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)) -+ #+cormanlisp `(ct:defctype ,name ,(convert-from-uffi-type type :type)) - ) - - (eval-when (:compile-toplevel :load-toplevel :execute) -@@ -66,7 +67,7 @@ - (:float . alien:single-float) - (:double . alien:double-float) - ) -- "Conversions in CMUCL or def-foreign-type are different thatn in def-function") -+ "Conversions in CMUCL for def-foreign-type are different that in def-function") - - - #+cmu -@@ -84,7 +85,7 @@ - (:long . c-call:long) (:unsigned-long . c-call:unsigned-long) - (:float . c-call:float) (:double . c-call:double) - (:array . alien:array))) --#+allegro -+#+(or allegro cormanlisp) - (defconstant +type-conversion-list+ - '((* . *) (:void . :void) - (:short . :short) -@@ -129,7 +130,7 @@ - "Converts from a uffi type to an implementation specific type" - (if (atom type) - (cond -- #+allegro -+ #+(or allegro cormanlisp) - ((and (or (eq context :routine) (eq context :return)) - (eq type :cstring)) - (setq type '((* :char) integer))) ---- ./uffi.system~ Tue Apr 9 20:03:20 2002 -+++ ./uffi.system Tue Apr 9 20:36:14 2002 -@@ -27,7 +27,7 @@ - (merge-pathnames - (make-pathname - :directory -- #+(or cmu allegro lispworks) -+ #+(or cmu allegro lispworks cormanlisp) - '(:relative "src") - #+mcl - '(:relative "src" "mcl") - ---------------269CD5B1F75AF20CFDFE4FEE-- - -_______________________________________________ -UFFI-Devel mailing list -UFFI-Devel@b9.com -http://www.b9.com/mailman/listinfo/uffi-devel - diff --git a/src/corman/getenv-ccl.lisp b/src/corman/getenv-ccl.lisp new file mode 100644 index 0000000..fa32861 --- /dev/null +++ b/src/corman/getenv-ccl.lisp @@ -0,0 +1,86 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;; ************************************************************************* +;;;; FILE IDENTIFICATION +;;;; +;;;; Name: getenv-ccl.cl +;;;; Purpose: cormanlisp version +;;;; Programmer: "Joe Marshall" +;;;; Date Started: Feb 2002 +;;;; +`;;;; $Id: getenv-ccl.lisp,v 1.1 2002/10/01 17:05:29 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. +;;;; ************************************************************************* + +(in-package :cl-user) + +(ct:defun-dll c-getenv ((lpname LPSTR) + (lpbuffer LPSTR) + (nsize LPDWORD)) + :library-name "kernel32.dll" + :return-type DWORD + :entry-name "GetEnvironmentVariableA" + :linkage-type :pascal) + +(defun getenv (name) + (let ((nsizebuf (ct:malloc (sizeof :long))) + (buffer (ct:malloc 1)) + (cname (ct:lisp-string-to-c-string name))) + (setf (ct:cref lpdword nsizebuf 0) 0) + (let* ((needed-size (c-getenv cname buffer nsizebuf)) + (buffer1 (ct:malloc (1+ needed-size)))) + (setf (ct:cref lpdword nsizebuf 0) needed-size) + (prog1 (if (zerop (c-getenv cname buffer1 nsizebuf)) + nil + (ct:c-string-to-lisp-string buffer1)) + (ct:free buffer1) + (ct:free nsizebuf))))) + +(defun cl:user-homedir-pathname (&optional host) + (cond ((or (stringp host) + (and (consp host) + (every #'stringp host))) nil) + ((or (eq host :unspecific) + (null host)) + (let ((homedrive (getenv "HOMEDRIVE")) + (homepath (getenv "HOMEPATH"))) + (parse-namestring + (if (and (stringp homedrive) + (stringp homepath) + (= (length homedrive) 2) + (> (length homepath) 0)) + (concatenate 'string homedrive homepath "\\") + "C:\\")))) + (t (error "HOST must be a string, list of strings, NIL or :unspecific")))) + +;| +(uffi:def-function ("getenv" c-getenv) + ((name :cstring)) + :returning :cstring) + +(defun my-getenv (key) + "Returns an environment variable, or NIL if it does not exist" + (check-type key string) + (uffi:with-cstring (key-native key) + (uffi:convert-from-cstring (c-getenv key-native)))) + +#examples-uffi +(progn + (flet ((print-results (str) + (format t "~&(getenv ~S) => ~S" str (my-getenv str)))) + (print-results "USER") + (print-results "_FOO_"))) + + +#test-uffi +(progn + (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv") + (util.test:test (and (stringp (my-getenv "USER")) + (< 0 (length (my-getenv "USER")))) + t :fail-info "Error retrieving getenv") +) + diff --git a/src/functions.lisp b/src/functions.lisp index 03b8d59..927365d 100644 --- a/src/functions.lisp +++ b/src/functions.lisp @@ -3,11 +3,11 @@ ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: function.cl -;;;; Purpose: UFFI source to C function defintions +;;;; Purpose: UFFI source to C function definitions ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: functions.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $ +;;;; $Id: functions.lisp,v 1.2 2002/10/01 17:05:29 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -21,14 +21,12 @@ (defun process-function-args (args) (if (null args) - #+lispworks nil + #+(or lispworks cmu cormanlisp (and mcl (not openmcl))) nil #+allegro '(:void) - #+cmu nil - #+(and mcl (not openmcl)) nil #+mcl (values nil nil) ;; args not null - #+(or lispworks allegro cmu (and mcl (not openmcl))) + #+(or lispworks allegro cmu (and mcl (not openmcl)) cormanlisp) (let (processed) (dolist (arg args) (push (process-one-function-arg arg) processed)) @@ -68,13 +66,14 @@ ;; name is either a string representing foreign name, or a list ;; of foreign-name as a string and lisp name as a symbol (defmacro def-function (names args &key module returning) - #+(or cmu allegro mcl) (declare (ignore module)) + #+(or cmu allegro mcl cormanlisp) (declare (ignore module)) (let* ((result-type (convert-from-uffi-type returning :return)) (function-args (process-function-args args)) (foreign-name (if (atom names) names (car names))) (lisp-name (if (atom names) (make-lisp-name names) (cadr names)))) - + + ;; todo: calling-convention :stdcall for cormanlisp #+allegro `(ff:def-foreign-call (,lisp-name ,foreign-name) ,function-args @@ -102,6 +101,12 @@ (multiple-value-bind (params args) (process-function-args args) `(defun ,lisp-name ,params (ccl::external-call ,foreign-name ,@args ,result-type))) + #+cormanlisp + `(ct:defun-dll ,lisp-name (,function-args) + :return-type ,result-type + ,@(if module (list :library-name module) (values)) + :entry-name ,foreign-name + :linkage-type ,calling-convention) ; we need :pascal )) diff --git a/src/primitives.lisp b/src/primitives.lisp index 6abd855..6147753 100644 --- a/src/primitives.lisp +++ b/src/primitives.lisp @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Feb 2002 ;;;; -;;;; $Id: primitives.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $ +;;;; $Id: primitives.lisp,v 1.2 2002/10/01 17:05:29 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -54,10 +54,8 @@ (defmacro def-type (name type) "Generates a (deftype) statement for CL. Currently, only CMUCL supports takes advantage of this optimization." - #+(or lispworks allegro mcl) - (declare (ignore type)) - #+(or lispworks allegro mcl) - `(deftype ,name () t) + #+(or lispworks allegro mcl cormanlisp) (declare (ignore type)) + #+(or lispworks allegro mcl cormanlisp) `(deftype ,name () t) #+cmu `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare))) #+sbcl @@ -73,6 +71,7 @@ supports takes advantage of this optimization." #+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)) + #+cormanlisp `(ct:defctype ,name ,(convert-from-uffi-type type :type)) #+mcl (let ((mcl-type (convert-from-uffi-type type :type))) (unless (or (keywordp mcl-type) (consp mcl-type)) @@ -157,7 +156,7 @@ supports takes advantage of this optimization." (:float . float) (:double . double) (:array . array))) -#+allegro +#+(or allegro cormanlisp) (setq +type-conversion-list+ '((* . *) (:void . :void) (:short . :short) @@ -236,7 +235,7 @@ supports takes advantage of this optimization." "Converts from a uffi type to an implementation specific type" (if (atom type) (cond - #+allegro + #+(or allegro cormanlisp) ((and (or (eq context :routine) (eq context :return)) (eq type :cstring)) (setq type '((* :char) integer))) diff --git a/uffi.asd b/uffi.asd index 76737d3..7e475ce 100644 --- a/uffi.asd +++ b/uffi.asd @@ -7,7 +7,7 @@ ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; -;;;; $Id: uffi.asd,v 1.17 2002/09/30 10:02:36 kevin Exp $ +;;;; $Id: uffi.asd,v 1.18 2002/10/01 17:05:29 kevin Exp $ ;;;; ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; @@ -19,7 +19,7 @@ (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (in-package :asdf) -#+(or allegro lispworks cmu mcl) +#+(or allegro lispworks cmu mcl cormanlisp) (defsystem uffi :name "cl-uffi" :author "Kevin M. Rosenberg " @@ -49,7 +49,7 @@ ((:file "uffi-corman"))) )) -#+(or allegro lispworks cmu mcl) +#+(or allegro lispworks cmu mcl cormanlisp) (when (ignore-errors (find-class 'load-compiled-op)) (defmethod perform :after ((op load-compiled-op) (c (eql (find-system :uffi)))) (pushnew :uffi cl:*features*))) -- 2.34.1