src/functions.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          function.lisp
   6 ;;;; Purpose:       UFFI source to C function definitions
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Feb 2002
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; This file, part of UFFI, is Copyright (c) 2005 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; *************************************************************************
  15
  16 (in-package #:uffi)
  17
  18 (defun process-function-args (args)
  19   (if (null args)
  20       #+(or lispworks cmu sbcl scl cormanlisp digitool) nil
  21       #+allegro '(:void)
  22       #+openmcl (values nil nil)
  23
  24       ;; args not null
  25       #+(or lispworks allegro cmu sbcl scl digitool cormanlisp)
  26       (let (processed)
  27         (dolist (arg args)
  28           (push (process-one-function-arg arg) processed))
  29         (nreverse processed))
  30       #+openmcl
  31       (let ((processed nil)
  32             (params nil))
  33         (dolist (arg args)
  34           (let ((name (car arg))
  35                 (type (convert-from-uffi-type (cadr arg) :routine)))
  36             ;;(when (and (listp type) (eq (car type) :address))
  37             ;;(setf type :address))
  38             (push name params)
  39             (push type processed)
  40             (push name processed)))
  41         (values (nreverse params) (nreverse processed)))
  42     ))
  43
  44 (defun process-one-function-arg (arg)
  45   (let ((name (car arg))
  46         (type (convert-from-uffi-type (cadr arg) :routine)))
  47     #+(or cmu sbcl scl)
  48     ;(list name type :in)
  49     `(,name ,type ,@(if (= (length arg) 3) (list (third arg)) (values)))
  50     #+(or allegro lispworks digitool)
  51     (if (and (listp type) (listp (car type)))
  52         (append (list name) type)
  53       (list name type))
  54     #+openmcl
  55     (declare (ignore name type))
  56     ))
  57
  58
  59 (defun allegro-convert-return-type (type)
  60   (if (and (listp type) (not (listp (car type))))
  61       (list type)
  62     type))
  63
  64 (defun funcallable-lambda-list (args)
  65   (let ((ll nil))
  66     (dolist (arg args)
  67       (push (car arg) ll))
  68     (nreverse ll)))
  69
  70 #|
  71 (defmacro def-funcallable (name args &key returning)
  72   (let ((result-type (convert-from-uffi-type returning :return))
  73         (function-args (process-function-args args)))
  74     #+lispworks
  75     `(fli:define-foreign-funcallable ,name ,function-args
  76       :result-type ,result-type
  77       :language :ansi-c
  78       :calling-convention :cdecl)
  79     #+(or cmu scl sbcl)
  80     ;; requires the type of the function pointer be declared correctly!
  81     (let* ((ptrsym (gensym))
  82            (ll (funcallable-lambda-list args)))
  83       `(defun ,name ,(cons ptrsym ll)
  84         (alien::alien-funcall ,ptrsym ,@ll)))
  85     #+openmcl
  86     (multiple-value-bind (params args) (process-function-args args)
  87       (let ((ptrsym (gensym)))
  88         `(defun ,name ,(cons ptrsym params)
  89           (ccl::ff-call ,ptrsym ,@args ,result-type))))
  90     #+allegro
  91     ;; this is most definitely wrong
  92     (let* ((ptrsym (gensym))
  93            (ll (funcallable-lambda-list args)))
  94       `(defun ,name ,(cons ptrsym ll)
  95         (system::ff-funcall ,ptrsym ,@ll)))
  96     ))
  97 |#
  98
  99 (defun convert-lispworks-args (args)
 100   (loop for arg in args
 101         with processed = nil
 102         do
 103         (if (and (= (length arg) 3) (eq (third arg) :out))
 104             (push (list (first arg)
 105                         (list :reference-return (second arg))) processed)
 106             (push (subseq arg 0 2) processed))
 107         finally (return (nreverse processed))))
 108
 109 (defun preprocess-names (names)
 110   (let ((fname (gensym)))
 111     (if (atom names)
 112         (values (list names fname) fname (uffi::make-lisp-name names))
 113         (values (list (first names) fname) fname (second names)))))
 114
 115 (defun preprocess-args (args)
 116   (loop for arg in args
 117         with lisp-args = nil and out = nil and processed = nil
 118         do
 119         (if (= (length arg) 3)
 120             (ecase (third arg)
 121               (:in
 122                (progn
 123                  (push (first arg) lisp-args)
 124                  (push (list (first arg) (second arg)) processed)))
 125               (:out
 126                (progn
 127                  (push (list (first arg) (second arg)) out)
 128                  (push (list (first arg) (list '* (second arg))) processed))))
 129             (progn
 130               (push (first arg) lisp-args)
 131               (push arg processed)))
 132         finally (return (values (nreverse lisp-args)
 133                                 (nreverse out)
 134                                 (nreverse processed)))))
 135
 136
 137 (defmacro def-function (names args &key module returning)
 138   (multiple-value-bind (lisp-args out processed)
 139       (preprocess-args args)
 140     (declare (ignorable lisp-args processed))
 141     (if (= (length out) 0)
 142         `(%def-function ,names ,args
 143           ,@(if module (list :module module) (values))
 144           ,@(if returning (list :returning returning) (values)))
 145
 146         #+(or cmu scl sbcl)
 147         `(%def-function ,names ,args
 148           ,@(if returning (list :returning returning) (values)))
 149         #+(and lispworks lispworks5)
 150         (multiple-value-bind (name-pair fname lisp-name)
 151             (preprocess-names names)
 152           `(progn
 153                (%def-function ,name-pair ,(convert-lispworks-args args)
 154                               ,@(if module (list :module module) (values))
 155                               ,@(if returning (list :returning returning) (values)))
 156                (defun ,lisp-name ,lisp-args
 157                  (,fname ,@(mapcar
 158                             #'(lambda (arg)
 159                                 (cond ((member (first arg) lisp-args)
 160                                        (first arg))
 161                                       ((member (first arg) out :key #'first)
 162                                        t)))
 163                           args)))))
 164         #+(and lispworks (not lispworks5))
 165         `(%def-function ,names ,(convert-lispworks-args args)
 166           ,@(if module (list :module module) (values))
 167           ,@(if returning (list :returning returning) (values)))
 168         #-(or cmu scl sbcl lispworks)
 169         (multiple-value-bind (name-pair fname lisp-name)
 170             (preprocess-names names)
 171           `(progn
 172             (%def-function ,name-pair ,processed
 173              :module ,module :returning ,returning)
 174             ;(declaim (inline ,fname))
 175             (defun ,lisp-name ,lisp-args
 176               (with-foreign-objects ,out
 177                 (values (,fname ,@(mapcar #'first args))
 178                         ,@(mapcar #'(lambda (arg)
 179                                       (list 'deref-pointer
 180                                             (first arg)
 181                                             (second arg))) out))))))
 182         )))
 183
 184
 185 ;; name is either a string representing foreign name, or a list
 186 ;; of foreign-name as a string and lisp name as a symbol
 187 (defmacro %def-function (names args &key module returning)
 188   #+(or cmu sbcl scl allegro openmcl digitool cormanlisp) (declare (ignore module))
 189
 190   (let* ((result-type (convert-from-uffi-type returning :return))
 191          (function-args (process-function-args args))
 192          (foreign-name (if (atom names) names (car names)))
 193          (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
 194     ;; todo: calling-convention :stdcall for cormanlisp
 195     #+allegro
 196     `(ff:def-foreign-call (,lisp-name ,foreign-name)
 197          ,function-args
 198        :returning ,(allegro-convert-return-type result-type)
 199        :call-direct t
 200        :strings-convert nil)
 201     #+(or cmu scl)
 202     `(alien:def-alien-routine (,foreign-name ,lisp-name)
 203          ,result-type
 204        ,@function-args)
 205     #+sbcl
 206     `(sb-alien:define-alien-routine (,foreign-name ,lisp-name)
 207          ,result-type
 208        ,@function-args)
 209     #+lispworks
 210     `(fli:define-foreign-function (,lisp-name ,foreign-name :source)
 211          ,function-args
 212        ,@(if module (list :module module) (values))
 213        :result-type ,result-type
 214       :language :ansi-c
 215        #+:mswindows :calling-convention #+:mswindows :cdecl)
 216     #+digitool
 217     `(eval-when (:compile-toplevel :load-toplevel :execute)
 218        (ccl:define-entry-point (,lisp-name ,foreign-name)
 219          ,function-args
 220          ,result-type))
 221     #+openmcl
 222     (declare (ignore function-args))
 223     #+(and openmcl darwinppc-target)
 224     (setf foreign-name (concatenate 'string "_" foreign-name))
 225     #+openmcl
 226     (multiple-value-bind (params args) (process-function-args args)
 227       `(defun ,lisp-name ,params
 228          (ccl::external-call ,foreign-name ,@args ,result-type)))
 229     #+cormanlisp
 230     `(ct:defun-dll ,lisp-name (,function-args)
 231        :return-type ,result-type
 232        ,@(if module (list :library-name module) (values))
 233        :entry-name ,foreign-name
 234        :linkage-type ,calling-convention) ; we need :pascal
 235     ))
 236
 237
 238
 239