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