X-Git-Url: http://git.kpe.io/?a=blobdiff_plain;f=uffi%2Fcorman%2Fcorman-uffi.cl;fp=uffi%2Fcorman%2Fcorman-uffi.cl;h=0000000000000000000000000000000000000000;hb=0eaed82d93e9d2afbdcbdb8b49b0fc2386f86963;hp=ba0fd53f7c62eb99ea38bd8524cbd4f7dcffbfee;hpb=39af1ecd34f7cefc376c62a005939f849f135629;p=uffi.git diff --git a/uffi/corman/corman-uffi.cl b/uffi/corman/corman-uffi.cl deleted file mode 100644 index ba0fd53..0000000 --- a/uffi/corman/corman-uffi.cl +++ /dev/null @@ -1,274 +0,0 @@ -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.3 2002/08/23 19:21:54 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 -