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: functions.lisp,v 1.8 2003/06/06 21:59:18 kevin Exp $
  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     #+(or allegro lispworks (and mcl (not openmcl)))
  53     (if (and (listp type) (listp (car type)))
  54         (append (list name) type)
  55       (list name type))
  56     #+openmcl
  57     (declare (ignore name type))
  58     ))
  59
  60
  61 (defun allegro-convert-return-type (type)
  62   (if (and (listp type) (not (listp (car type))))
  63       (list type)
  64     type))
  65
  66 ;; name is either a string representing foreign name, or a list
  67 ;; of foreign-name as a string and lisp name as a symbol
  68 (defmacro def-function (names args &key module returning)
  69   #+(or cmu sbcl scl allegro mcl cormanlisp) (declare (ignore module))
  70
  71   (let* ((result-type (convert-from-uffi-type returning :return))
  72          (function-args (process-function-args args))
  73          (foreign-name (if (atom names) names (car names)))
  74          (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
  75
  76     ;; todo: calling-convention :stdcall for cormanlisp
  77     #+allegro
  78     `(ff:def-foreign-call (,lisp-name ,foreign-name)
  79          ,function-args
  80        :returning ,(allegro-convert-return-type result-type)
  81        :call-direct t
  82        :strings-convert nil)
  83     #+(or cmu scl)
  84     `(alien:def-alien-routine (,foreign-name ,lisp-name)
  85          ,result-type
  86        ,@function-args)
  87     #+sbcl
  88     `(sb-alien:define-alien-routine (,foreign-name ,lisp-name)
  89          ,result-type
  90        ,@function-args)
  91     #+lispworks
  92     `(fli:define-foreign-function (,lisp-name ,foreign-name :source)
  93          ,function-args
  94        ,@(if module (list :module module) (values))
  95        :result-type ,result-type
  96       :language :ansi-c
  97        :calling-convention :cdecl)
  98     #+(and mcl (not openmcl))
  99     `(eval-when (:compile-toplevel :load-toplevel :execute)
 100        (ccl:define-entry-point (,lisp-name ,foreign-name)
 101          ,function-args
 102          ,result-type))
 103     #+openmcl
 104     (declare (ignore function-args))
 105     #+(and openmcl darwinppc-target)
 106     (setf foreign-name (concatenate 'string "_" foreign-name))
 107     #+openmcl
 108     (multiple-value-bind (params args) (process-function-args args)
 109       `(defun ,lisp-name ,params
 110          (ccl::external-call ,foreign-name ,@args ,result-type)))
 111     #+cormanlisp
 112     `(ct:defun-dll ,lisp-name (,function-args)
 113        :return-type ,result-type
 114        ,@(if module (list :library-name module) (values))
 115        :entry-name ,foreign-name
 116        :linkage-type ,calling-convention) ; we need :pascal
 117     ))
 118
 119
 120 (defun make-lisp-name (name)
 121   (let ((converted (substitute #\- #\_ name)))
 122      (intern
 123       #+case-sensitive converted
 124       #-case-sensitive (string-upcase converted))))
 125
 126