def-function :out

retrying this now that i'm subscribed to the list.....

i've written preliminary support for :out arguments for def-function.
on cmucl, scl, sbcl, and lispworks, it delegates to their underlying
mechanisms.  for allegro, mcl, et al it creates wrapper functions.
(perhaps some inline declarations are in order.)

caveats:

1) this hasn't been tested on anything other than cmucl since i don't
have access!  the wrapper functions should work, though.

2) i'm not so good with patch.  i'm sending the full source to my
modified functions.lisp.

3) this is not very pretty, sorry.  as you can see i've grafted it on
top of your def-function (now %def-function.)  comments / revisions
would be appreciated.

thanks for the nice package, take care, B


;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: UFFI -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:          function.lisp
;;;; Purpose:       UFFI source to C function definitions
;;;; Programmer:    Kevin M. Rosenberg
;;;; Date Started:  Feb 2002
;;;;
;;;; $Id: functions.lisp 9012 2004-04-15 10:43:01Z kevin $
;;;;
;;;; 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.
;;;; *************************************************************************

(in-package #:uffi)

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

       ;; args not null
       #+(or lispworks allegro cmu sbcl scl (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))
         (dolist (arg args)
           (let ((name (car arg))
                 (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 scl)
     ;(list name type :in)
     `(,name ,type ,@(if (= (length arg) 3) (list (third arg)) (values)))
     #+(or allegro lispworks (and mcl (not openmcl)))
     (if (and (listp type) (listp (car type)))
         (append (list name) type)
       (list name type))
     #+openmcl
     (declare (ignore name type))
     ))


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

(defun convert-lispworks-args (args)
   (loop for arg in args
         with processed = nil
         do
         (if (and (= (length arg) 3) (eq (third arg) :out))
             (push (list (first arg)
                         (list :reference-return (second arg))) processed)
             (push (subseq arg 0 2) processed))
         finally (return processed)))

(defun preprocess-names (names)
   (let ((fname (gensym)))
     (if (atom names)
         (values (list names fname) fname (uffi::make-lisp-name names))
         (values (list (first names) fname) fname (second names)))))

(defun preprocess-args (args)
   (loop for arg in args
         with lisp-args = nil and out = nil and processed = nil
         do
         (if (= (length arg) 3)
             (ecase (third arg)
               (:in
                (progn
                  (push (first arg) lisp-args)
                  (push (list (first arg) (second arg)) processed)))
               (:out
                (progn
                  (push (list (first arg) (second arg)) out)
                  (push (list (first arg) (list '* (second arg))) processed))))
             (progn
               (push (first arg) lisp-args)
               (push arg processed)))
         finally (return (values (nreverse lisp-args)
                                 (nreverse out)
                                 (nreverse processed)))))


(defmacro def-function (names args &key module returning)
   #+(or cmu sbcl scl allegro mcl cormanlisp) (declare (ignore module))

   (multiple-value-bind (lisp-args out processed)
       (preprocess-args args)
     (if (= (length out) 0)
         `(%def-function ,names ,args
           ,@(if module (list :module module) (values))
           ,@(if returning (list :returning returning) (values)))

         #+(or cmu scl sbcl)
         `(%def-function ,names ,args
           ,@(if returning (list :returning returning) (values)))
         #+lispworks
         `(%def-function ,names ,(convert-lispworks-args args)
           ,@(if module (list :module module) (values))
           ,@(if returning (list :returning returning) (values)))
         #-(or cmu scl sbcl lispworks)
         (multiple-value-bind (name-pair fname lisp-name)
             (preprocess-names names)
           `(prog1
             (%def-function ,name-pair ,processed
              :module ,module :returning ,returning)
             ;(declaim (inline ,fname))
             (defun ,lisp-name ,lisp-args
               (with-foreign-objects ,out
                 (values (,fname ,@(mapcar #'first args))
                         ,@(mapcar #'first out))))))
         )))


;; 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 scl 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)
     #+(or cmu scl)
     `(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
       :language :ansi-c
        :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))
     #+openmcl
     (declare (ignore function-args))
     #+(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
     ))