src/corman/corman-uffi.lisp

   1 some notes:
   2   we need the :pascal (:stdcall) calling conventions for
   3   (def-function names args &key module returning calling-convention)
   4   so I added this. calling-convention defaults to :cdecl
   5   but on win32 we mostly use :stdcall
   6
   7   #+corman is invalid, #+cormanlisp instead
   8
   9   cormanlisp doesn't need to load and register the dll, since the underlying
  10   LoadLibrary() call does this. we need the module keyword for def-function
  11 instead.
  12   (should probably default to kernel32.dll)
  13   I'll think about library.cl, but we'll need more real-world win32 examples.
  14   (ideally the complete winapi :)
  15   I also have to look at valentina.
  16
  17 patch -p0 < corman.diff
  18 --
  19 Reini Urban
  20 http://xarch.tu-graz.ac.at/home/rurban/
  21 --------------269CD5B1F75AF20CFDFE4FEE
  22 Content-Type: text/plain; charset=us-ascii; name="corman.diff"
  23 Content-Disposition: inline; filename="corman.diff"
  24 Content-Transfer-Encoding: 7bit
  25
  26 --- ./examples/getenv-ccl.cl~   Tue Apr  9 21:08:18 2002
  27 +++ ./examples/getenv-ccl.cl    Tue Apr  9 20:58:16 2002
  28 @@ -0,0 +1,87 @@
  29 +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
  30 +;;;; *************************************************************************
  31 +;;;; FILE IDENTIFICATION
  32 +;;;;
  33 +;;;; Name:          getenv-ccl.cl
  34 +;;;; Purpose:       cormanlisp version
  35 +;;;; Programmer:    "Joe Marshall" <prunesquallor@attbi.com>
  36 +;;;; Date Started:  Feb 2002
  37 +;;;;
  38 +;;;; $Id: corman-uffi.lisp,v 1.1 2002/09/30 10:02:36 kevin Exp $
  39 +;;;;
  40 +;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
  41 +;;;;
  42 +;;;; UFFI users are granted the rights to distribute and use this software
  43 +;;;; as governed by the terms of the Lisp Lesser GNU Public License
  44 +;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  45 +;;;; *************************************************************************
  46 +
  47 +(in-package :cl-user)
  48 +
  49 +(ct:defun-dll c-getenv ((lpname LPSTR)
  50 +                       (lpbuffer LPSTR)
  51 +                       (nsize LPDWORD))
  52 +  :library-name "kernel32.dll"
  53 +  :return-type DWORD
  54 +  :entry-name "GetEnvironmentVariableA"
  55 +  :linkage-type :pascal)
  56 +
  57 +(defun getenv (name)
  58 +  (let ((nsizebuf (ct:malloc (sizeof :long)))
  59 +        (buffer (ct:malloc 1))
  60 +        (cname (ct:lisp-string-to-c-string name)))
  61 +    (setf (ct:cref lpdword nsizebuf 0) 0)
  62 +    (let* ((needed-size (c-getenv cname buffer nsizebuf))
  63 +           (buffer1 (ct:malloc (1+ needed-size))))
  64 +      (setf (ct:cref lpdword nsizebuf 0) needed-size)
  65 +      (prog1 (if (zerop (c-getenv cname buffer1 nsizebuf))
  66 +                 nil
  67 +               (ct:c-string-to-lisp-string buffer1))
  68 +        (ct:free buffer1)
  69 +        (ct:free nsizebuf)))))
  70 +
  71 +(defun cl:user-homedir-pathname (&optional host)
  72 +  (cond ((or (stringp host)
  73 +             (and (consp host)
  74 +                  (every #'stringp host))) nil)
  75 +        ((or (eq host :unspecific)
  76 +             (null host))
  77 +         (let ((homedrive (getenv "HOMEDRIVE"))
  78 +               (homepath  (getenv "HOMEPATH")))
  79 +           (parse-namestring
  80 +             (if (and (stringp homedrive)
  81 +                      (stringp homepath)
  82 +                      (= (length homedrive) 2)
  83 +                      (> (length homepath) 0))
  84 +                 (concatenate 'string homedrive homepath "\\")
  85 +                 "C:\\"))))
  86 +        (t (error "HOST must be a string, list of strings, NIL or :unspecific"))))
  87 +
  88 +;|
  89 +(uffi:def-function ("getenv" c-getenv)
  90 +    ((name :cstring))
  91 +  :returning :cstring)
  92 +
  93 +(defun my-getenv (key)
  94 +  "Returns an environment variable, or NIL if it does not exist"
  95 +  (check-type key string)
  96 +  (uffi:with-cstring (key-native key)
  97 +    (uffi:convert-from-cstring (c-getenv key-native))))
  98 +
  99 +#+examples-uffi
 100 +(progn
 101 +  (flet ((print-results (str)
 102 +          (format t "~&(getenv ~S) => ~S" str (my-getenv str))))
 103 +    (print-results "USER")
 104 +    (print-results "_FOO_")))
 105 +
 106 +
 107 +#+test-uffi
 108 +(progn
 109 +  (util.test:test (my-getenv "_FOO_") nil :fail-info "Error retrieving non-existent getenv")
 110 +  (util.test:test (and (stringp (my-getenv "USER"))
 111 +                      (< 0 (length (my-getenv "USER"))))
 112 +                 t :fail-info "Error retrieving getenv")
 113 +)
 114 +
 115 +|;
 116 \ No newline at end of file
 117 --- ./Makefile~ Tue Apr  9 20:03:18 2002
 118 +++ ./Makefile  Tue Apr  9 20:38:03 2002
 119 @@ -64,3 +64,7 @@
 120
 121  wwwdist: dist
 122         @./copy
 123 +
 124 +TAGS:
 125 +       if [ -f TAGS ]; then mv -f TAGS TAGS~; fi
 126 +       find . -name \*.cl -exec /usr/bin/etags -a \{\} \;
 127 --- ./set-logical.cl~   Tue Apr  9 20:03:20 2002
 128 +++ ./set-logical.cl    Tue Apr  9 20:35:44 2002
 129 @@ -35,10 +35,10 @@
 130      #+clisp "clisp"
 131      #+cmu "cmucl"
 132      #+sbcl "sbcl"
 133 -    #+corman "corman"
 134 +    #+cormanlisp "cormanlisp"
 135      #+mcl "mcl"
 136      #+openmcl "openmcl"
 137 -    #-(or allegro lispworks clisp cmu sbcl corman mcl openmcl) "unknown")
 138 +    #-(or allegro lispworks clisp cmu sbcl cormanlisp mcl openmcl) "unknown")
 139
 140  (defun set-logical-host-for-pathname (host base-pathname)
 141    (setf (logical-pathname-translations host)
 142 --- ./src/functions.cl~ Tue Apr  9 20:03:24 2002
 143 +++ ./src/functions.cl  Tue Apr  9 21:00:07 2002
 144 @@ -3,7 +3,7 @@
 145  ;;;; FILE IDENTIFICATION
 146  ;;;;
 147  ;;;; Name:          function.cl
 148 -;;;; Purpose:       UFFI source to C function defintions
 149 +;;;; Purpose:       UFFI source to C function definitions
 150  ;;;; Programmer:    Kevin M. Rosenberg
 151  ;;;; Date Started:  Feb 2002
 152  ;;;;
 153 @@ -21,9 +21,8 @@
 154
 155  (defun process-function-args (args)
 156    (if (null args)
 157 -      #+lispworks nil
 158 +      #+(or lispworks cmu cormanlisp) nil
 159        #+allegro '(:void)
 160 -      #+cmu nil
 161        (let (processed)
 162         (dolist (arg args)
 163           (push (process-one-function-arg arg) processed))
 164 @@ -34,7 +33,7 @@
 165         (type (convert-from-uffi-type (cadr arg) :routine)))
 166      #+cmu
 167      (list name type :in)
 168 -    #+(or allegro lispworks)
 169 +    #+(or allegro lispworks cormanlisp)
 170      (if (and (listp type) (listp (car type)))
 171         (append (list name) type)
 172        (list name type))
 173 @@ -47,15 +46,15 @@
 174
 175  ;; name is either a string representing foreign name, or a list
 176  ;; of foreign-name as a string and lisp name as a symbol
 177 -(defmacro def-function (names args &key module returning)
 178 -  #+(or cmu allegro) (declare (ignore module))
 179 +(defmacro def-function (names args &key module returning calling-convention)
 180 +  #+(or cmu allegro cormanlisp) (declare (ignore module))
 181
 182    (let* ((result-type (convert-from-uffi-type returning :return))
 183          (function-args (process-function-args args))
 184          (foreign-name (if (atom names) names (car names)))
 185          (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
 186
 187 -    #+allegro
 188 +    #+allegro                          ; todo: calling-convention :stdcall
 189      `(ff:def-foreign-call (,lisp-name ,foreign-name)
 190          ,function-args
 191         :returning ,(allegro-convert-return-type result-type)
 192 @@ -70,7 +69,13 @@
 193          ,function-args
 194         ,@(if module (list :module module) (values))
 195         :result-type ,result-type
 196 -       :calling-convention :cdecl)
 197 +       :calling-convention ,calling-convention)
 198 +    #+cormanlisp
 199 +    `(ct:defun-dll ,lisp-name (,function-args)
 200 +       :return-type ,result-type
 201 +       ,@(if module (list :library-name module) (values))
 202 +       :entry-name ,foreign-name
 203 +       :linkage-type ,calling-convention) ; we need :pascal
 204      ))
 205
 206
 207 --- ./src/primitives.cl~        Tue Apr  9 20:03:25 2002
 208 +++ ./src/primitives.cl Tue Apr  9 21:05:13 2002
 209 @@ -29,9 +29,9 @@
 210  (defmacro def-type (name type)
 211    "Generates a (deftype) statement for CL. Currently, only CMUCL
 212  supports takes advantage of this optimization."
 213 -  #+(or lispworks allegro)
 214 +  #+(or lispworks allegro cormanlisp)
 215    (declare (ignore type))
 216 -  #+(or lispworks allegro)
 217 +  #+(or lispworks allegro cormanlisp)
 218    `(deftype ,name () t)
 219    #+cmu
 220    `(deftype ,name () '(alien:alien ,(convert-from-uffi-type type :declare)))
 221 @@ -45,6 +45,7 @@
 222    #+lispworks `(fli:define-c-typedef ,name ,(convert-from-uffi-type type :type))
 223    #+allegro `(ff:def-foreign-type ,name ,(convert-from-uffi-type type :type))
 224    #+cmu `(alien:def-alien-type ,name ,(convert-from-uffi-type type :type))
 225 +  #+cormanlisp `(ct:defctype ,name ,(convert-from-uffi-type type :type))
 226    )
 227
 228  (eval-when (:compile-toplevel :load-toplevel :execute)
 229 @@ -66,7 +67,7 @@
 230        (:float . alien:single-float)
 231        (:double . alien:double-float)
 232        )
 233 -  "Conversions in CMUCL or def-foreign-type are different thatn in def-function")
 234 +  "Conversions in CMUCL for def-foreign-type are different that in def-function")
 235
 236
 237  #+cmu
 238 @@ -84,7 +85,7 @@
 239        (:long . c-call:long) (:unsigned-long . c-call:unsigned-long)
 240        (:float . c-call:float) (:double . c-call:double)
 241        (:array . alien:array)))
 242 -#+allegro
 243 +#+(or allegro cormanlisp)
 244  (defconstant +type-conversion-list+
 245      '((* . *) (:void . :void)
 246        (:short . :short)
 247 @@ -129,7 +130,7 @@
 248    "Converts from a uffi type to an implementation specific type"
 249    (if (atom type)
 250        (cond
 251 -       #+allegro
 252 +       #+(or allegro cormanlisp)
 253         ((and (or (eq context :routine) (eq context :return))
 254              (eq type :cstring))
 255         (setq type '((* :char) integer)))
 256 --- ./uffi.system~      Tue Apr  9 20:03:20 2002
 257 +++ ./uffi.system       Tue Apr  9 20:36:14 2002
 258 @@ -27,7 +27,7 @@
 259                                (merge-pathnames
 260                                 (make-pathname
 261                                  :directory
 262 -                                #+(or cmu allegro lispworks)
 263 +                                #+(or cmu allegro lispworks cormanlisp)
 264                                  '(:relative "src")
 265                                  #+mcl
 266                                  '(:relative "src" "mcl")
 267
 268 --------------269CD5B1F75AF20CFDFE4FEE--
 269
 270 _______________________________________________
 271 UFFI-Devel mailing list
 272 UFFI-Devel@b9.com
 273 http://www.b9.com/mailman/listinfo/uffi-devel
 274