+++ /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.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
-
--- /dev/null
+;;;; -*- 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: 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")
+)
+
;;;; 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
;;;;
(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))
;; 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
(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
))
;;;; 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
;;;;
(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
#+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))
(:float . float) (:double . double)
(:array . array)))
-#+allegro
+#+(or allegro cormanlisp)
(setq +type-conversion-list+
'((* . *) (:void . :void)
(:short . :short)
"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)))
projects / uffi.git / commitdiff