src/functions.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          function.cl
   6 ;;;; Purpose:       UFFI source to C function defintions
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Feb 2002
   9 ;;;;
  10 ;;;; $Id: functions.lisp,v 1.1 2002/09/30 10:02:36 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 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  20 (in-package :uffi)
  21
  22 (defun process-function-args (args)
  23   (if (null args)
  24       #+lispworks nil
  25       #+allegro '(:void)
  26       #+cmu nil
  27       #+(and mcl (not openmcl)) nil
  28       #+mcl (values nil nil)
  29
  30       ;; args not null
  31       #+(or lispworks allegro cmu (and mcl (not openmcl)))
  32       (let (processed)
  33         (dolist (arg args)
  34           (push (process-one-function-arg arg) processed))
  35         (nreverse processed))
  36       #+openmcl
  37       (let ((processed nil)
  38             (params nil)
  39             name type)
  40         (dolist (arg args)
  41           (setf name (car arg))
  42           (setf type (convert-from-uffi-type (cadr arg) :routine))
  43           ;;(when (and (listp type) (eq (car type) :address))
  44           ;;(setf type :address))
  45           (push name params)
  46           (push type processed)
  47           (push name processed))
  48         (values (nreverse params) (nreverse processed)))
  49     ))
  50
  51 (defun process-one-function-arg (arg)
  52   (let ((name (car arg))
  53         (type (convert-from-uffi-type (cadr arg) :routine)))
  54     #+cmu
  55     (list name type :in)
  56     #+(or allegro lispworks (and mcl (not openmcl)))
  57     (if (and (listp type) (listp (car type)))
  58         (append (list name) type)
  59       (list name type))
  60     ))
  61
  62
  63 (defun allegro-convert-return-type (type)
  64   (if (and (listp type) (not (listp (car type))))
  65       (list type)
  66     type))
  67
  68 ;; name is either a string representing foreign name, or a list
  69 ;; of foreign-name as a string and lisp name as a symbol
  70 (defmacro def-function (names args &key module returning)
  71   #+(or cmu allegro mcl) (declare (ignore module))
  72
  73   (let* ((result-type (convert-from-uffi-type returning :return))
  74          (function-args (process-function-args args))
  75          (foreign-name (if (atom names) names (car names)))
  76          (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
  77
  78     #+allegro
  79     `(ff:def-foreign-call (,lisp-name ,foreign-name)
  80          ,function-args
  81        :returning ,(allegro-convert-return-type result-type)
  82        :call-direct t
  83        :strings-convert nil)
  84     #+cmu
  85     `(alien:def-alien-routine (,foreign-name ,lisp-name)
  86          ,result-type
  87        ,@function-args)
  88     #+lispworks
  89     `(fli:define-foreign-function (,lisp-name ,foreign-name :source)
  90          ,function-args
  91        ,@(if module (list :module module) (values))
  92        :result-type ,result-type
  93        :calling-convention :cdecl)
  94     #+(and mcl (not openmcl))
  95     `(eval-when (:compile-toplevel :load-toplevel :execute)
  96        (ccl:define-entry-point (,lisp-name ,foreign-name)
  97          ,function-args
  98          ,result-type))
  99     #+(and openmcl darwinppc-target)
 100     (setf foreign-name (concatenate 'string "_" foreign-name))
 101     #+openmcl
 102     (multiple-value-bind (params args) (process-function-args args)
 103       `(defun ,lisp-name ,params
 104          (ccl::external-call ,foreign-name ,@args ,result-type)))
 105     ))
 106
 107
 108 (defun make-lisp-name (name)
 109   (let ((converted (substitute #\- #\_ name)))
 110      (intern
 111       #+case-sensitive converted
 112       #-case-sensitive (string-upcase converted))))
 113
 114