;;; -*- Mode: Scheme -*-

;;;; C Stub Generator for Scheme
;;;; Callbacks -- Code Generation

;;; Copyright (c) 2009, Taylor R. Campbell
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; * Redistributions of source code must retain the above copyright
;;;   notice, this list of conditions and the following disclaimer.
;;;
;;; * Redistributions in binary form must reproduce the above copyright
;;;   notice, this list of conditions and the following disclaimer in
;;;   the documentation and/or other materials provided with the
;;;   distribution.
;;;
;;; * Neither the names of the authors nor the names of contributors
;;;   may be used to endorse or promote products derived from this
;;;   software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(define (callback-invoker-name name)
  (string-append "s48_callback_invoker__" (maybe-mangle-name name)))

(define (callback-c-parameter name return-type formals parameter-name
                              code-name environment-type environment-name
                              initialization)
  (let ((s48-name (format:sequence (maybe-mangle-name parameter-name) "_s48")))
    (make-c-parameter
     s48-name
     environment-name
     (list s48-name)
     (format:sequence
      (c-format:declaration
       (c-format:function-pointer return-type code-name formals))
      (c-format:declare environment-type environment-name))
     (format:sequence
      (c-format:assign-statement code-name (callback-invoker-name name))
      (initialization s48-name))
     #f)))

(define (c-parameter/local-callback name return-type formals parameter-name
                                    code-name
                                    environment-type environment-name)
  (callback-c-parameter name return-type formals parameter-name
      code-name environment-type environment-name
    (lambda (s48-name)
      (c-format:assign-statement
       environment-name
       (c-format:cast (c-format:pointer-type "void")
                      (c-format:address-of s48-name))))))

(define (c-parameter/dynamic-callback name return-type formals parameter-name
                                      code-name
                                      environment-type environment-name)
  (callback-c-parameter name return-type formals parameter-name
      code-name environment-type environment-name
    (lambda (s48-name)
      (c-format:assign-statement
       environment-name
       (c-format:call "SCHEME_DYNAMIC_CALLBACK_INITIALIZE"
                      (list s48-name))))))

;;; Argh.

(define (c-format:function-pointer return-type name formals)
  (format:sequence return-type
                   (format:soft-break)
                   (c-format:call (format:sequence "(*" name ")") formals)))

;;; This procedure is more than thrice as long as it should be, and the
;;; names are totally backwards.

(define (c-stub/callback name type parameter formals data results)
  (declaration-emission
   (stub-format:call-with-callback-invoker-temporaries (length results)
     (lambda (procedure-name argument-names)
       (let* ((scheme-names (cons procedure-name argument-names))
              (scheme-names
               (if parameter
                   (cons (c-parameter.name parameter) scheme-names)
                   scheme-names)))
         (c-format:function type (callback-invoker-name name) formals
           (format:sequence
            (stub-format:comment "Declarations")
            (if parameter (c-parameter.declaration parameter) (format:empty))
            (c-format:s48-declare-unspecific:list scheme-names)
            (format:blank-line)
            (stub-format:comment "GC Protection")
            (c-format:s48-declare-gc-protect (length scheme-names))
            (c-format:s48-gc-protect scheme-names)
            (format:blank-line)
            (stub-format:comment "Initialization")
            (c-format:assign-statement
             procedure-name
             (c-format:dereference
              (c-format:cast (c-format:pointer-type (c-format:s48-value-type))
                             data)))
            (format:list
             (map (lambda (argument-name result)
                    (result (variable-locative argument-name)))
                  argument-names
                  results))
            (format:blank-line)
            (stub-format:comment "Body")
            (let ((call
                   (c-format:call "s48_call_scheme"
                                  `(,procedure-name
                                    ,(length argument-names)
                                    ,@argument-names))))
              (if parameter
                  (c-format:assign-statement (c-parameter.name parameter) call)
                  (c-format:statement call)))
            (if parameter
                (c-parameter.initialization parameter)
                (format:empty))
            (format:blank-line)
            (stub-format:comment "Finalization")
            (if (and parameter (c-parameter.finalization parameter))
                (stub-format:comment "Parameter lossage!")
                (format:empty))
            (c-format:s48-gc-unprotect)
            (if parameter
                (c-format:return (c-parameter.internal-name parameter))
                (format:empty)))))))))

(define (stub-format:call-with-callback-invoker-temporaries count receiver)
  (c-format:call-with-temporary-name "procedure"
    (lambda (procedure-name)
      (loop continue ((with argument-names '())
                      (for i (down-from count (to 0))))
        => (receiver procedure-name argument-names)
        (c-format:call-with-temporary-name
            (string-append "argument_" (number->string i) "_s48")
          (lambda (argument-name)
            (continue (cons argument-name argument-names))))))))

(define (global-callback-binding name)
  (stub-format:binding-variable (maybe-mangle-name name)))

(define (c-parameter/global-callback name return-type formals parameter-name
                                     code-name)
  (let ((s48-name (format:sequence (maybe-mangle-name parameter-name) "_s48")))
    (make-c-parameter
     s48-name
     code-name
     (list s48-name)
     (c-format:declaration
      (c-format:function-pointer return-type code-name formals))
     (format:sequence
      (c-format:assign-statement code-name (callback-invoker-name name))
      (c-format:call-statement "S48_SHARED_BINDING_SET"
                               (list (global-callback-binding name) s48-name)))
     #f)))

(define (c-stub/global-callback name type parameter formals data results
                                binding-name)
  (let ((binding (global-callback-binding name)))
    (compound-emission
     (declaration-emission
      (c-format:declare (c-format:static (c-format:s48-value-type))
                        (c-format:initialize binding (c-format:s48-false))))
     (initialization-emission
      (c-format:s48-gc-protect-global binding)
      (c-format:s48-import-binding binding-name (variable-locative binding)))
     (c-stub/callback name type parameter formals data results))))