2 we need the :pascal (:stdcall) calling conventions for
3 (def-function names args &key module returning calling-convention)
4 so I added this. calling-convention defaults to :cdecl
5 but on win32 we mostly use :stdcall
7 #+corman is invalid, #+cormanlisp instead
9 cormanlisp doesn't need to load and register the dll, since the underlying
10 LoadLibrary() call does this. we need the module keyword for def-function
12 (should probably default to kernel32.dll)
13 I'll think about library.cl, but we'll need more real-world win32 examples.
14 (ideally the complete winapi :)
15 I also have to look at valentina.
17 patch -p0 < corman.diff
20 http://xarch.tu-graz.ac.at/home/rurban/
21 --------------269CD5B1F75AF20CFDFE4FEE
22 Content-Type: text/plain; charset=us-ascii; name="corman.diff"
23 Content-Disposition: inline; filename="corman.diff"
24 Content-Transfer-Encoding: 7bit
26 --- ./examples/getenv-ccl.cl~ Tue Apr 9 21:08:18 2002
27 +++ ./examples/getenv-ccl.cl Tue Apr 9 20:58:16 2002
29 +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
30 +;;;; *************************************************************************
31 +;;;; FILE IDENTIFICATION
33 +;;;; Name: getenv-ccl.cl
34 +;;;; Purpose: cormanlisp version
35 +;;;; Programmer: "Joe Marshall" <prunesquallor@attbi.com>
36 +;;;; Date Started: Feb 2002
38 +;;;; $Id: corman-uffi.cl,v 1.3 2002/08/23 19:21:54 kevin Exp $
40 +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
42 +;;;; UFFI users are granted the rights to distribute and use this software
43 +;;;; as governed by the terms of the Lisp Lesser GNU Public License
44 +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
45 +;;;; *************************************************************************
47 +(in-package :cl-user)
49 +(ct:defun-dll c-getenv ((lpname LPSTR)
52 + :library-name "kernel32.dll"
54 + :entry-name "GetEnvironmentVariableA"
55 + :linkage-type :pascal)
58 + (let ((nsizebuf (ct:malloc (sizeof :long)))
59 + (buffer (ct:malloc 1))
60 + (cname (ct:lisp-string-to-c-string name)))
61 + (setf (ct:cref lpdword nsizebuf 0) 0)
62 + (let* ((needed-size (c-getenv cname buffer nsizebuf))
63 + (buffer1 (ct:malloc (1+ needed-size))))
64 + (setf (ct:cref lpdword nsizebuf 0) needed-size)
65 + (prog1 (if (zerop (c-getenv cname buffer1 nsizebuf))
67 + (ct:c-string-to-lisp-string buffer1))
69 + (ct:free nsizebuf)))))
71 +(defun cl:user-homedir-pathname (&optional host)
72 + (cond ((or (stringp host)
74 + (every #'stringp host))) nil)
75 + ((or (eq host :unspecific)
77 + (let ((homedrive (getenv "HOMEDRIVE"))
78 + (homepath (getenv "HOMEPATH")))
80 + (if (and (stringp homedrive)
82 + (= (length homedrive) 2)
83 + (> (length homepath) 0))
84 + (concatenate 'string homedrive homepath "\\")
86 + (t (error "HOST must be a string, list of strings, NIL or :unspecific"))))
89 +(uffi:def-function ("getenv" c-getenv)
91 + :returning :cstring)
93 +(defun my-getenv (key)
94 + "Returns an environment variable, or NIL if it does not exist"
95 + (check-type key string)
96 + (uffi:with-cstring (key-native key)
97 + (uffi:convert-from-cstring (c-getenv key-native))))
101 + (flet ((print-results (str)
102 + (format t "~&(getenv ~S) => ~S" str (my-getenv str))))
103 + (print-results "USER")
104 + (print-results "_FOO_")))
109 + (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv")
110 + (util.test:test (and (stringp (my-getenv "USER"))
111 + (< 0 (length (my-getenv "USER"))))
112 + t :fail-info "Error retrieving getenv")
116 \ No newline at end of file
117 --- ./Makefile~ Tue Apr 9 20:03:18 2002
118 +++ ./Makefile Tue Apr 9 20:38:03 2002
125 + if [ -f TAGS ]; then mv -f TAGS TAGS~; fi
126 + find . -name \*.cl -exec /usr/bin/etags -a \{\} \;
127 --- ./set-logical.cl~ Tue Apr 9 20:03:20 2002
128 +++ ./set-logical.cl Tue Apr 9 20:35:44 2002
134 + #+cormanlisp "cormanlisp"
137 - #-(or allegro lispworks clisp cmu sbcl corman mcl openmcl) "unknown")
138 + #-(or allegro lispworks clisp cmu sbcl cormanlisp mcl openmcl) "unknown")
140 (defun set-logical-host-for-pathname (host base-pathname)
141 (setf (logical-pathname-translations host)
142 --- ./src/functions.cl~ Tue Apr 9 20:03:24 2002
143 +++ ./src/functions.cl Tue Apr 9 21:00:07 2002
145 ;;;; FILE IDENTIFICATION
147 ;;;; Name: function.cl
148 -;;;; Purpose: UFFI source to C function defintions
149 +;;;; Purpose: UFFI source to C function definitions
150 ;;;; Programmer: Kevin M. Rosenberg
151 ;;;; Date Started: Feb 2002
155 (defun process-function-args (args)
158 + #+(or lispworks cmu cormanlisp) nil
163 (push (process-one-function-arg arg) processed))
165 (type (convert-from-uffi-type (cadr arg) :routine)))
168 - #+(or allegro lispworks)
169 + #+(or allegro lispworks cormanlisp)
170 (if (and (listp type) (listp (car type)))
171 (append (list name) type)
175 ;; name is either a string representing foreign name, or a list
176 ;; of foreign-name as a string and lisp name as a symbol
177 -(defmacro def-function (names args &key module returning)
178 - #+(or cmu allegro) (declare (ignore module))
179 +(defmacro def-function (names args &key module returning calling-convention)
180 + #+(or cmu allegro cormanlisp) (declare (ignore module))
182 (let* ((result-type (convert-from-uffi-type returning :return))
183 (function-args (process-function-args args))
184 (foreign-name (if (atom names) names (car names)))
185 (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
188 + #+allegro ; todo: calling-convention :stdcall
189 `(ff:def-foreign-call (,lisp-name ,foreign-name)
191 :returning ,(allegro-convert-return-type result-type)
194 ,@(if module (list :module module) (values))
195 :result-type ,result-type
196 - :calling-convention :cdecl)
197 + :calling-convention ,calling-convention)
199 + `(ct:defun-dll ,lisp-name (,function-args)
200 + :return-type ,result-type
201 + ,@(if module (list :library-name module) (values))
202 + :entry-name ,foreign-name
203 + :linkage-type ,calling-convention) ; we need :pascal
207 --- ./src/primitives.cl~ Tue Apr 9 20:03:25 2002
208 +++ ./src/primitives.cl Tue Apr 9 21:05:13 2002
210 (defmacro def-type (name type)
211 "Generates a (deftype) statement for CL. Currently, only CMUCL
212 supports takes advantage of this optimization."
213 - #+(or lispworks allegro)
214 + #+(or lispworks allegro cormanlisp)
215 (declare (ignore type))
216 - #+(or lispworks allegro)
217 + #+(or lispworks allegro cormanlisp)
218 `(deftype ,name () t)
220 `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare)))
222 #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type))
223 #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type))
224 #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
225 + #+cormanlisp `(ct:defctype ,name ,(convert-from-uffi-type type :type))
228 (eval-when (:compile-toplevel :load-toplevel :execute)
230 (:float . alien:single-float)
231 (:double . alien:double-float)
233 - "Conversions in CMUCL or def-foreign-type are different thatn in def-function")
234 + "Conversions in CMUCL for def-foreign-type are different that in def-function")
239 (:long . c-call:long) (:unsigned-long . c-call:unsigned-long)
240 (:float . c-call:float) (:double . c-call:double)
241 (:array . alien:array)))
243 +#+(or allegro cormanlisp)
244 (defconstant +type-conversion-list+
245 '((* . *) (:void . :void)
248 "Converts from a uffi type to an implementation specific type"
252 + #+(or allegro cormanlisp)
253 ((and (or (eq context :routine) (eq context :return))
255 (setq type '((* :char) integer)))
256 --- ./uffi.system~ Tue Apr 9 20:03:20 2002
257 +++ ./uffi.system Tue Apr 9 20:36:14 2002
262 - #+(or cmu allegro lispworks)
263 + #+(or cmu allegro lispworks cormanlisp)
266 '(:relative "src" "mcl")
268 --------------269CD5B1F75AF20CFDFE4FEE--
270 _______________________________________________
271 UFFI-Devel mailing list
273 http://www.b9.com/mailman/listinfo/uffi-devel