;;;-*- Mode: Lisp; Package: (MCL-INTERFACE (CL)) -*-
;;----------------------------------------------------------------------
;; 
;; Copyright:   Copyright (c) 1999 John Wiseman
;; File:        mcl-interface.lisp
;; Created:     22 January 1999
;; Author:      John Wiseman (wiseman@neodesic.com)
;; Free for commercial and non-commercial use.
;; 
;; Description: An adapter file that allows Richard Mann's OpenGL
;;              bindings to be used from MCL.
;;
;; Changed: 7/10/01 AR: modified foreign-function to be compatible with MCL 4.3
;;          1/05/02 AR: OS X native
;; 
;; 
;;----------------------------------------------------------------------


(in-package "MCL-INTERFACE")

(export '(foreign-function foreign-define))
(export '(ff::defun-c-callable ff::register-function) "FF")
#+openmcl
(eval-when (:compile-toplevel :load-toplevel :execute)
  (ccl:use-interface-dir :GL)
  (ccl:use-interface-dir :carbon)
  (ccl:open-shared-library "/System/Library/Frameworks/Carbon.framework/Carbon"))

;; added by Alexander Repenning: Apple library
#+(and mcl (not openmcl))
(ccl::add-to-shared-library-search-path "OpenGLUtility" :check)

;#-carbon-compat (ccl::add-to-shared-library-search-path "OpenGLEngine" :check)
#+(and mcl (not openmcl))
(ccl::add-to-shared-library-search-path "OpenGLLibrary" :check)
#+(and mcl (not openmcl))
(ccl::add-to-shared-library-search-path "OpenGLMemory" :check)
;#-carbon-compat (ccl::add-to-shared-library-search-path "OpenGLRenderer" :check)
;#-carbon-compat (ccl::add-to-shared-library-search-path "OpenGLRendererATI" :check)



(defparameter *type-mapping*
    '((unsigned-long :unsigned-long)
      (signed-char :signed-byte)
      (short :short)
      (double :double-float)
      (pointer :pointer)
      (unsigned-short :unsigned-short)
      (unsigned-char :unsigned-byte)
      (unsigned-byte :unsigned-byte)
      (unsigned-int :unsigned-long)
      (int :long)
      (fixnum :long)
      (void :void)
      (string :pointer)
      (float :single-float))
    "Defines a mapping from simple foreign types in Allegro Common Lisp
    to foreign types in Macintosh Common Lisp.")


(defun get-mcl-type (acl-type &optional (trap NIL))
  "Given an ACL foreign type spec, returns the equivalent MCL foreign
   type spec."
  ;; For specs like (pointer float) just return :pointer.
  (when (listp acl-type)
    (setf acl-type (car acl-type)))
  ;; :void -> nil in trap defs, but not in callback defs.
  (if (and trap (equalp (symbol-name acl-type) "VOID"))
    nil
    (let ((a (assoc (symbol-name acl-type) *type-mapping* :key #'symbol-name :test #'equalp)))
      (if (null a)
        (error "Unknown mapping for ACL type ~S." acl-type)
        (second a)))))



(defmacro foreign-define (name value)
  `(eval-when (compile eval load)
     (defconstant ,name ,value)
     (export ',name)))



#|

Turns a foreign-function FUNC into

  1. An MCL-equivalent deftrap _FUNC

  2. A Lisp function FUNC that accepts Lisp strings for
     char* arguments and coerces float arguments.


Example expansion #1:

  (foreign-function glutcreatewindow ((POINTER CHAR)) INT
                    "glutCreateWindow")

  ==>


  (PROGN
    (DEFTRAP-INLINE (_GLUTCREATEWINDOW "_glutCreateWindow")
      ((ARG1 :POINTER))
      :LONG
      'NIL)
    (DEFUN GLUTCREATEWINDOW (ARG1)
      (WITH-CSTRS ((#:G2122 ARG1))
        (REQUIRE-TRAP TRAPS::_GLUTCREATEWINDOW #:G2122)))
    (EXPORT 'GLUTCREATEWINDOW))


Example expansion #2:

  (foreign-function glclearindex (FLOAT) VOID "glClearIndex")

  ==>

  (PROGN
    (DEFTRAP-INLINE (_GLCLEARINDEX "_glClearIndex")
      ((ARG1 :SINGLE-FLOAT))
      NIL
      'NIL)
    (DEFUN GLCLEARINDEX (ARG1)
      (REQUIRE-TRAP TRAPS::_GLCLEARINDEX (FLOAT ARG1 0.0S0)))
    (EXPORT 'GLCLEARINDEX))

|#

(defmacro FOREIGN-FUNCTION (name arguments rettype string)
  (let ((trap-name (intern (format nil "_~S" name))))
    (let* ((args (let ((counter 0))
                   (mapcar #'(lambda (arg)
                               (declare (ignore arg))
                               (intern (format nil "ARG~S" (incf counter))))
                           arguments)))
           (arg-mcl-types (mapcar #'get-mcl-type arguments))
           (arg-string-vars (mapcar #'(lambda (arg)
                                        (if (string-pointer-p arg)
                                          (gensym)
                                          nil))
                                    arguments)))
      `(eval-when (compile eval load)
         (ccl:deftrap-inline ,(format nil "_~A" string)
           ,(mapcar #'(lambda (name type)
                        `(,name ,type))
                    args
                    arg-mcl-types)
           ,(get-mcl-type rettype T)
           '())
         (defun ,name ,args
           ,(let ((call `(ccl:require-trap ,(intern (symbol-name trap-name) "TRAPS")
                                           ,@(mapcar #'(lambda (name type string-var)
                                                         (cond ((eq type :single-float)
                                                                `(float ,name 0.0s0))
                                                               (string-var
                                                                string-var)
                                                               (T
                                                                name)))
                                                     args
                                                     arg-mcl-types
                                                     arg-string-vars))))
              (if (some #'identity arg-string-vars)
                `(ccl:with-cstrs ,(mapcan #'(lambda (gvar var)
                                              (if gvar
                                                (list (list gvar var))
                                                nil))
                                          arg-string-vars
                                          args)
                   ,call)
                call)))
         (export ',name)))))

(defun string-pointer-p (acl-type)
  (and (listp acl-type)
       (equalp (symbol-name (first acl-type)) "POINTER")
       (and (symbolp (second acl-type))
            (equalp (symbol-name (second acl-type)) "CHAR"))))






(defmacro FF::defun-c-callable (name args &body body)
  (let ((fn-name (gensym)))
    `(progn
       (ccl:defccallable ,fn-name
                         ,(let ((arg-list '()))
                            (dolist (arg args)
                              (push (get-mcl-type (second arg)) arg-list)
                              (push (first arg) arg-list))
                            (nreverse arg-list))
         :void
         ,@body)
       (defparameter ,name (ccl:pref (ccl:pref ,fn-name :RoutineDescriptor.RoutineRecords)
                                     :RoutineRecord.ProcDescriptor)))))

         
         
(defun FF::register-function (symbol)
  (assert (ccl:macptrp (symbol-value symbol)))
  (symbol-value symbol))