1 ;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;;;; *************************************************************************
3 ;;;; FILE IDENTIFICATION
6 ;;;; Purpose: UFFI source to C function defintions
7 ;;;; Programmer: Kevin M. Rosenberg
8 ;;;; Date Started: Feb 2002
10 ;;;; Copyright (c) 2002 Kevin M. Rosenberg
12 ;;;; $Id: functions.cl,v 1.1 2002/03/09 21:53:58 kevin Exp $
14 ;;;; This file is part of the UFFI.
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.
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.
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 ;;;; *************************************************************************
30 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
33 (defun process-function-args (args)
40 (push (process-one-function-arg arg) processed))
41 (nreverse processed))))
43 (defun process-one-function-arg (arg)
44 (let ((name (car arg))
45 (type (convert-from-uffi-type (cadr arg) :routine)))
48 #+(or allegro lispworks)
49 (if (and (listp type) (listp (car type)))
50 (append (list name) type)
54 (defun allegro-convert-return-type (type)
55 (if (and (listp type) (not (listp (car type))))
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-function (names args &key module returning)
62 #+(or cmu allegro) (declare (ignore module))
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))))
70 `(ff:def-foreign-call (,lisp-name ,foreign-name)
72 :returning ,(allegro-convert-return-type result-type)
76 `(alien:def-alien-routine (,foreign-name ,lisp-name)
80 `(fli:define-foreign-function (,lisp-name ,foreign-name :object)
82 ,@(if module (list :module module) (values))
83 :result-type ,result-type
84 :calling-convention :cdecl)
88 (defun make-lisp-name (name)
89 (let ((converted (substitute #\- #\_ name)))
91 #+case-sensitive converted
92 #-case-sensitive (string-upcase converted))))