;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          function.cl
;;;; Purpose:       UFFI source to C function definitions
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Feb 2002
;;;;
;;;; $Id: functions.lisp,v 1.4 2002/10/14 03:07:41 kevin Exp $
;;;;
;;;; This file, part of UFFI, is Copyright (c) 2002 by Kevin M. Rosenberg
;;;;
;;;; UFFI users are granted the rights to distribute and use this software
;;;; as governed by the terms of the Lisp Lesser GNU Public License
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
;;;; *************************************************************************

(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
(in-package :uffi)

(defun process-function-args (args)
  (if (null args)
      #+(or lispworks cmu sbcl cormanlisp (and mcl (not openmcl))) nil
      #+allegro '(:void)
      #+mcl (values nil nil)

      ;; args not null
      #+(or lispworks allegro cmu sbcl (and mcl (not openmcl)) cormanlisp)
      (let (processed)
	(dolist (arg args)
	  (push (process-one-function-arg arg) processed))
	(nreverse processed))
      #+openmcl
      (let ((processed nil)
	    (params nil)
	    name type)
	(dolist (arg args)
	  (setf name (car arg))
	  (setf type (convert-from-uffi-type (cadr arg) :routine))
	  ;;(when (and (listp type) (eq (car type) :address))
	  ;;(setf type :address))
	  (push name params)
	  (push type processed)
	  (push name processed))
	(values (nreverse params) (nreverse processed)))
    ))

(defun process-one-function-arg (arg)
  (let ((name (car arg))
	(type (convert-from-uffi-type (cadr arg) :routine)))
    #+(or cmu sbcl)
    (list name type :in)
    #+(or allegro lispworks (and mcl (not openmcl)))
    (if (and (listp type) (listp (car type)))
	(append (list name) type)
      (list name type))
    ))    


(defun allegro-convert-return-type (type)
  (if (and (listp type) (not (listp (car type))))
      (list type)
    type))

;; name is either a string representing foreign name, or a list
;; of foreign-name as a string and lisp name as a symbol
(defmacro def-function (names args &key module returning)
  #+(or cmu sbcl allegro mcl cormanlisp) (declare (ignore module))
  
  (let* ((result-type (convert-from-uffi-type returning :return))
	 (function-args (process-function-args args))
	 (foreign-name (if (atom names) names (car names)))
	 (lisp-name (if (atom names) (make-lisp-name names) (cadr names))))

    ;; todo: calling-convention :stdcall for cormanlisp
    #+allegro
    `(ff:def-foreign-call (,lisp-name ,foreign-name)
	 ,function-args
       :returning ,(allegro-convert-return-type result-type)
       :call-direct t
       :strings-convert nil)
    #+cmu
    `(alien:def-alien-routine (,foreign-name ,lisp-name)
	 ,result-type
       ,@function-args)
    #+sbcl
    `(sb-alien:define-alien-routine (,foreign-name ,lisp-name)
	 ,result-type
       ,@function-args)
    #+lispworks
    `(fli:define-foreign-function (,lisp-name ,foreign-name :source)
	 ,function-args
       ,@(if module (list :module module) (values))
       :result-type ,result-type
       :calling-convention :cdecl)
    #+(and mcl (not openmcl))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (ccl:define-entry-point (,lisp-name ,foreign-name)
         ,function-args
         ,result-type))
    #+(and openmcl darwinppc-target)
    (setf foreign-name (concatenate 'string "_" foreign-name))
    #+openmcl
    (multiple-value-bind (params args) (process-function-args args)
      `(defun ,lisp-name ,params
         (ccl::external-call ,foreign-name ,@args ,result-type)))
    #+cormanlisp
    `(ct:defun-dll ,lisp-name (,function-args)
       :return-type ,result-type
       ,@(if module (list :library-name module) (values))
       :entry-name ,foreign-name
       :linkage-type ,calling-convention) ; we need :pascal
    ))


(defun make-lisp-name (name)
  (let ((converted (substitute #\- #\_ name)))
     (intern 
      #+case-sensitive converted
      #-case-sensitive (string-upcase converted))))