From 46fbc92bfdcb2504d863929bde42962275e80e74 Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Mon, 22 Apr 2002 21:13:30 +0000 Subject: [PATCH] r1786: added Reini patch file to directory --- src/corman/corman-uffi.cl | 274 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 274 insertions(+) create mode 100644 src/corman/corman-uffi.cl diff --git a/src/corman/corman-uffi.cl b/src/corman/corman-uffi.cl new file mode 100644 index 0000000..8aa1141 --- /dev/null +++ b/src/corman/corman-uffi.cl @@ -0,0 +1,274 @@ +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.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 + -- 2.34.1