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