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