src/routine.cl

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          routine.cl
   6 ;;;; Purpose:       UFFI source to C function defintions
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Feb 2002
   9 ;;;;
  10 ;;;; Copyright (c) 2002 Kevin M. Rosenberg
  11 ;;;;
  12 ;;;; $Id: routine.cl,v 1.1 2002/03/09 19:55:33 kevin Exp $
  13 ;;;;
  14 ;;;; This file is part of the UFFI.
  15 ;;;;
  16 ;;;; UFFI is free software; you can redistribute it and/or modify
  17 ;;;; it under the terms of the GNU General Public License (version 2) as
  18 ;;;; published by the Free Software Foundation.
  19 ;;;;
  20 ;;;; UFFI is distributed in the hope that it will be useful,
  21 ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  22 ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23 ;;;; GNU General Public License for more details.
  24 ;;;;
  25 ;;;; You should have received a copy of the GNU General Public License
  26 ;;;; along with UFFI; if not, write to the Free Software
  27 ;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  28 ;;;; *************************************************************************
  29
  30 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  31 (in-package :uffi)
  32
  33 (defun process-function-args (args)
  34   (if (null args)
  35       #+lispworks nil
  36       #+allegro '(:void)
  37       #+cmu nil
  38       (let (processed)
  39         (dolist (arg args)
  40           (push (process-one-function-arg arg) processed))
  41         (nreverse processed))))
  42
  43 (defun process-one-function-arg (arg)
  44   (let ((name (car arg))
  45         (type (convert-from-uffi-type (cadr arg) :routine)))
  46     #+cmu
  47     (list name type :in)
  48     #+(or allegro lispworks)
  49     (if (and (listp type) (listp (car type)))
  50         (append (list name) type)
  51       (list name type))
  52     ))
  53
  54 (defun allegro-convert-return-type (type)
  55   (if (and (listp type) (not (listp (car type))))
  56       (list type)
  57     type))
  58
  59 ;; name is either a string representing foreign name, or a list
  60 ;; of foreign-name as a string and lisp name as a symbol
  61 (defmacro def-routine (names args &key module returning)
  62   #+(or cmu allegro) (declare (ignore module))
  63
  64   (let* ((result-type (convert-from-uffi-type returning :return))
  65          (function-args (process-function-args args))
  66          (foreign-name (if (atom names) names (car names)))
  67          (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
  68
  69     #+allegro
  70     `(ff:def-foreign-call (,lisp-name ,foreign-name)
  71          ,function-args
  72        :returning ,(allegro-convert-return-type result-type)
  73        :call-direct t
  74        :strings-convert nil)
  75     #+cmu
  76     `(alien:def-alien-routine (,foreign-name ,lisp-name)
  77          ,result-type
  78        ,@function-args)
  79     #+lispworks
  80     `(fli:define-foreign-function (,lisp-name ,foreign-name :object)
  81          ,function-args
  82        ,@(if module (list :module module) (values))
  83        :calling-convention :cdecl)
  84     ))
  85
  86
  87 (defun make-lisp-name (name)
  88   (let ((converted (substitute #\- #\_ name)))
  89      (intern
  90       #+case-sensitive converted
  91       #-case-sensitive (string-upcase converted))))
  92
  93