src/functions.cl

   1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   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.cl,v 1.2 2002/03/14 21:03:12 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       (let (processed)
  28         (dolist (arg args)
  29           (push (process-one-function-arg arg) processed))
  30         (nreverse processed))))
  31
  32 (defun process-one-function-arg (arg)
  33   (let ((name (car arg))
  34         (type (convert-from-uffi-type (cadr arg) :routine)))
  35     #+cmu
  36     (list name type :in)
  37     #+(or allegro lispworks)
  38     (if (and (listp type) (listp (car type)))
  39         (append (list name) type)
  40       (list name type))
  41     ))
  42
  43 (defun allegro-convert-return-type (type)
  44   (if (and (listp type) (not (listp (car type))))
  45       (list type)
  46     type))
  47
  48 ;; name is either a string representing foreign name, or a list
  49 ;; of foreign-name as a string and lisp name as a symbol
  50 (defmacro def-function (names args &key module returning)
  51   #+(or cmu allegro) (declare (ignore module))
  52
  53   (let* ((result-type (convert-from-uffi-type returning :return))
  54          (function-args (process-function-args args))
  55          (foreign-name (if (atom names) names (car names)))
  56          (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
  57
  58     #+allegro
  59     `(ff:def-foreign-call (,lisp-name ,foreign-name)
  60          ,function-args
  61        :returning ,(allegro-convert-return-type result-type)
  62        :call-direct t
  63        :strings-convert nil)
  64     #+cmu
  65     `(alien:def-alien-routine (,foreign-name ,lisp-name)
  66          ,result-type
  67        ,@function-args)
  68     #+lispworks
  69     `(fli:define-foreign-function (,lisp-name ,foreign-name :object)
  70          ,function-args
  71        ,@(if module (list :module module) (values))
  72        :result-type ,result-type
  73        :calling-convention :cdecl)
  74     ))
  75
  76
  77 (defun make-lisp-name (name)
  78   (let ((converted (substitute #\- #\_ name)))
  79      (intern
  80       #+case-sensitive converted
  81       #-case-sensitive (string-upcase converted))))
  82
  83