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.2 2002/09/20 04:51:14 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
  24 (defun make-lisp-name (name)
  25   (let ((converted (substitute #\- #\_ name)))
  26      (intern
  27       #+case-sensitive converted
  28       #-case-sensitive (string-upcase converted))))
  29
  30 #-openmcl
  31 (defun process-function-args (args)
  32   (if (null args)
  33     nil
  34     (let (processed)
  35       (dolist (arg args)
  36         (push (process-one-function-arg arg) processed))
  37       (nreverse processed))))
  38
  39 #-openmcl
  40 (defun process-one-function-arg (arg)
  41   (let ((name (car arg))
  42         (type (convert-from-uffi-type (cadr arg) :routine)))
  43     (if (and (listp type) (listp (car type)))
  44       (append (list name) type)
  45       (list name type))
  46     ))
  47
  48
  49 ;; name is either a string representing foreign name, or a list
  50 ;; of foreign-name as a string and lisp name as a symbol
  51 #-openmcl
  52 (defmacro def-function (names args &key module returning)
  53   (declare (ignore module))
  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
  65 #+openmcl
  66 (defun process-function-args (args)
  67   (if (null args)
  68     (values nil nil)
  69     (let ((processed nil)
  70           (params nil)
  71           name type)
  72       (dolist (arg args)
  73         (setf name (car arg))
  74         (setf type (convert-from-uffi-type (cadr arg) :routine))
  75         ;(when (and (listp type) (eq (car type) :address))
  76         ;(setf type :address))
  77         (push name params)
  78         (push type processed)
  79         (push name processed))
  80       (values (nreverse params) (nreverse processed)))))
  81
  82
  83 #+openmcl
  84 (defmacro def-function (names args &key module returning)
  85   (declare (ignore module))
  86   (let* ((result-type (convert-from-uffi-type returning :return))
  87          (foreign-name (if (atom names) names (car names)))
  88          (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))
  89     #+darwinppc-target
  90     (setf foreign-name (concatenate 'string "_" foreign-name))
  91     (multiple-value-bind (params args) (process-function-args args)
  92       `(defun ,lisp-name ,params
  93          (ccl::external-call ,foreign-name ,@args ,result-type)))))