+++ /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.3 2002/08/23 15:28:20 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 / blobdiff