--- /dev/null
+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" <prunesquallor@attbi.com>
++;;;; Date Started: Feb 2002
++;;;;
++;;;; $Id: corman-uffi.cl,v 1.1 2002/04/22 21:13:30 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
+
projects / uffi.git / commitdiff