src-mcl/functions.cl

   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 ;;;; Programmers:   Kevin M. Rosenberg and John DeSoi
   8 ;;;; Date Started:  Feb 2002
   9 ;;;;
  10 ;;;; $Id: functions.cl,v 1.1 2002/09/16 17:57:43 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;; and John DeSoi
  14 ;;;;
  15 ;;;; UFFI users are granted the rights to distribute and use this software
  16 ;;;; as governed by the terms of the Lisp Lesser GNU Public License
  17 ;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
  18 ;;;; *************************************************************************
  19
  20 (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
  21 (in-package :uffi)
  22
  23 (defun process-function-args (args)
  24   (if (null args)
  25       #+lispworks nil
  26       #+allegro '(:void)
  27       #+cmu nil
  28       #+mcl nil
  29       (let (processed)
  30         (dolist (arg args)
  31           (push (process-one-function-arg arg) processed))
  32         (nreverse processed))))
  33
  34 (defun process-one-function-arg (arg)
  35   (let ((name (car arg))
  36         (type (convert-from-uffi-type (cadr arg) :routine)))
  37     (if (and (listp type) (listp (car type)))
  38         (append (list name) type)
  39       (list name type))
  40     ))
  41
  42 (defun allegro-convert-return-type (type)
  43   (if (and (listp type) (not (listp (car type))))
  44       (list type)
  45     type))
  46
  47 ;; name is either a string representing foreign name, or a list
  48 ;; of foreign-name as a string and lisp name as a symbol
  49
  50
  51 (defmacro def-function (names args &key module returning)
  52   (declare (ignore module))
  53
  54   (let* ((result-type (convert-from-uffi-type returning :return))
  55          (function-args (process-function-args args))
  56          (foreign-name (if (atom names) names (car names)))
  57          (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
  58     `(eval-when (:compile-toplevel :load-toplevel :execute)
  59        (ccl:define-entry-point (,lisp-name ,foreign-name)
  60          ,function-args
  61          ,result-type))))
  62
  63
  64 (defun make-lisp-name (name)
  65   (let ((converted (substitute #\- #\_ name)))
  66      (intern
  67       #+case-sensitive converted
  68       #-case-sensitive (string-upcase converted))))
  69
  70