UFFI cormanlisp support

Dies ist eine mehrteilige Nachricht im MIME-Format.
--------------269CD5B1F75AF20CFDFE4FEE
Content-Type: text/plain; charset=us-ascii
Content-Transfer-Encoding: 7bit

my first start. not tested yet, just written. more later this week.
missing are the strings, aggregates and testing. not a big deal at all.
CLISP is probably the worst case to support.

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-Transfer-Encoding: 7bit
Content-Disposition: inline;
 filename="corman.diff"

--- ./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" <[email protected]>
+;;;; Date Started:  Feb 2002
+;;;;
+;;;; $Id: getenv.cl,v 1.9 2002/04/02 23:27:05 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--