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

;;;; C Stub Generator for Scheme
;;;; Callbacks -- Syntax

;;; 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-syntax define-c-with-callbacks
  (syntax-rules (DECLARE)
    ((DEFINE-C-WITH-CALLBACKS . junk)
     (DEFINE-C . junk))))

(define-syntax c-local-callback
  (syntax-rules (SCHEME->C C-LOCAL-CALLBACK)
    ((C-LOCAL-CALLBACK SCHEME->C continuation scheme-name c-name
                       (C-LOCAL-CALLBACK callback-name code-name
                                         environment-type environment-name))
     (C-CALLBACK-PARAMETER continuation scheme-name c-name callback-name
                           C-PARAMETER/LOCAL-CALLBACK code-name
                           environment-type environment-name))
    ((C-LOCAL-CALLBACK SCHEME->C continuation scheme-name c-name use)
     (SYNTACTIC-ERROR "Invalid C parameter conversion:" use))))

(define-syntactic-invoker c-parameter/local-callback)

(define-syntax c-dynamic-callback
  (syntax-rules (SCHEME->C C-DYNAMIC-CALLBACK)
    ((C-DYNAMIC-CALLBACK
      SCHEME->C continuation scheme-name c-name
      (C-DYNAMIC-CALLBACK callback-name code-name
                          environment-type environment-name))
     (C-CALLBACK-PARAMETER continuation scheme-name c-name callback-name
                           C-PARAMETER/DYNAMIC-CALLBACK code-name
                           environment-type environment-name))
    ((C-DYNAMIC-CALLBACK SCHEME->C continuation scheme-name c-name use)
     (SYNTACTIC-ERROR "Invalid C parameter conversion:" use))))

(define-syntactic-invoker c-parameter/dynamic-callback)

(define-syntax c-callback-parameter
  (syntax-rules ()
    ((C-CALLBACK-PARAMETER continuation scheme-name c-name callback-name
                           constructor . arguments)
     (callback-name
      CALLBACK-PROTOTYPE
      (C-CALLBACK/CONTINUE continuation scheme-name c-name callback-name
                           constructor . arguments)))))

(define-syntax c-callback/continue
  (syntax-rules ()
    ((C-CALLBACK/CONTINUE return-type formals
                          continuation scheme-name c-name callback-name
                          constructor . arguments)
     (SIMPLE-PARAMETER
      continuation
      scheme-name
      ((CHECK PROCEDURE?) scheme-name 'scheme-name)
      constructor callback-name return-type formals c-name . arguments))))

(define-syntax check
  (syntax-rules ()
    ((CHECK predicate)
     (LET-SYNTAX ((CHECKER
                   (SYNTAX-RULES ()
                     ((CHECKER ?VALUE ?CONTEXT)
                      (IF (predicate ?VALUE)
                          ?VALUE
                          (ERROR "Invalid argument:" ?VALUE ?CONTEXT))))))
       CHECKER))))

(define-syntax define-c-callback
  (syntax-rules (=>)
    ((DEFINE-C-CALLBACK name (formal ...)
         (=> scheme->c-conversion type)
       (data c->scheme-conversion ...))
     (PROCESS-CALLBACK-PARAMETERS
      (DEFINE-C-CALLBACK/CONTINUE
        name scheme->c-conversion type (formal ...) data)
      (c->scheme-conversion ...)
      ()))

    ((DEFINE-C-CALLBACK name (formal ...)
       (data c->scheme-conversion ...))
     (PROCESS-CALLBACK-PARAMETERS
      (DEFINE-C-CALLBACK/CONTINUE
        name #F "void" (formal ...) data)
      (c->scheme-conversion ...)
      ()))))

(define-syntax define-c-callback/continue
  (syntax-rules ()
    ((DEFINE-C-CALLBACK/CONTINUE expressions
       name #F "void" formals data)
     (DEFINE-C-CALLBACK/FINISH #F
       name "void" formals data expressions))

    ((DEFINE-C-CALLBACK/CONTINUE expressions
       name scheme->c-conversion type formals data)
     (PROCESS-CALLBACK-RESULT
      (DEFINE-C-CALLBACK/FINISH
        name type formals data expressions)
      scheme->c-conversion))))

(define-syntax define-c-callback/finish
  (syntax-rules ()
    ((DEFINE-C-CALLBACK/FINISH value
       name type formals data expressions)
     (BEGIN
       (C-STUB
        (C-STUB/CALLBACK name type value formals data expressions))
       (DEFINE-C-CALLBACK-DISPATCHER name type formals)))))

(define-syntactic-invoker c-stub/callback)

(define-syntax define-c-callback-dispatcher
  (syntax-rules ()
    ((DEFINE-C-CALLBACK-DISPATCHER name type formals)
     (DEFINE-SYNTAX name
       (SYNTAX-RULES (CALLBACK-PROTOTYPE)
         ((name CALLBACK-PROTOTYPE continuation)
          (SYNTACTIC-CONTINUE continuation type formals)))))))

;;;; Global Callbacks

(define-syntax c-global-callback
  (syntax-rules (SCHEME->C C-GLOBAL-CALLBACK)
    ((C-GLOBAL-CALLBACK SCHEME->C continuation scheme-name c-name
                        (C-GLOBAL-CALLBACK callback-name code-name))
     (C-CALLBACK-PARAMETER continuation scheme-name c-name callback-name
                           C-PARAMETER/GLOBAL-CALLBACK code-name))
    ((C-GLOBAL-CALLBACK SCHEME->C continuation scheme-name c-name use)
     (SYNTACTIC-ERROR "Invalid C parameter conversion:" use))))

(define-syntactic-invoker c-parameter/global-callback)

(define-syntax define-c-global-callback
  (syntax-rules (=>)
    ((DEFINE-C-GLOBAL-CALLBACK name (formal ...)
         (=> scheme->c-conversion type)
       (data c->scheme-conversion ...))
     (PROCESS-CALLBACK-PARAMETERS
      (DEFINE-C-GLOBAL-CALLBACK/CONTINUE
        name scheme->c-conversion type (formal ...) data)
      (c->scheme-conversion ...)
      ()))

    ((DEFINE-C-GLOBAL-CALLBACK name (formal ...)
       (data c->scheme-conversion ...))
     (PROCESS-CALLBACK-PARAMETERS
      (DEFINE-C-GLOBAL-CALLBACK/CONTINUE
        name #F "void" (formal ...) data)
      (c->scheme-conversion ...)
      ()))))

(define-syntax define-c-global-callback/continue
  (syntax-rules ()
    ((DEFINE-C-GLOBAL-CALLBACK/CONTINUE expressions
       name #F "void" formals data)
     (DEFINE-C-GLOBAL-CALLBACK/FINISH #F
       name "void" formals data expressions))

    ((DEFINE-C-GLOBAL-CALLBACK/CONTINUE expressions
       name scheme->c-conversion type formals data)
     (PROCESS-CALLBACK-RESULT
      (DEFINE-C-GLOBAL-CALLBACK/FINISH
        name type formals data expressions)
      scheme->c-conversion))))

(define-syntax define-c-global-callback/finish
  (syntax-rules ()
    ((DEFINE-C-GLOBAL-CALLBACK/FINISH value
       name type formals data expressions)
     (C-STUB-BINDING-NAME
      (DEFINE-C-GLOBAL-CALLBACK/GENERATE
        name type value formals data expressions)
      name))))

(define-syntax define-c-global-callback/generate
  (syntax-rules ()
    ((DEFINE-C-GLOBAL-CALLBACK/GENERATE binding-name
       name type value formals data results)
     (BEGIN
       (C-STUB
        (C-STUB/GLOBAL-CALLBACK name type value formals data results
                                binding-name))
       (DEFINE-C-CALLBACK-DISPATCHER name type formals)))))

(define-syntactic-invoker c-stub/global-callback)

;;; This is kinda backwards.

(define-syntax process-callback-result
  (syntax-rules ()
    ((PROCESS-CALLBACK-RESULT continuation scheme->c-conversion)
     (PROCESS-PARAMETER (PROCESS-CALLBACK-RESULT/CONTINUE continuation)
                        ;++ THIS IS TOTALLY WRONG
                        (%%%TEMPORARY-RESULT scheme->c-conversion)))))

(define-syntax process-callback-result/continue
  (syntax-rules ()
    ((PROCESS-CALLBACK-RESULT/CONTINUE (name (expression parameter))
                                       continuation)
     (SYNTACTIC-CONTINUE continuation parameter))))

(define-syntax process-callback-parameters
  (syntax-rules ()
    ((PROCESS-CALLBACK-PARAMETERS continuation () parameters*)
     (SYNTACTIC-REVERSE continuation parameters*))
    ((PROCESS-CALLBACK-PARAMETERS continuation
                                  (parameter . parameters)
                                  parameters*)
     (PROCESS-EXPRESSION
      (PROCESS-CALLBACK-PARAMETERS/CONTINUE continuation
                                            parameters
                                            parameters*)
      parameter))))

(define-syntax process-callback-parameters/continue
  (syntax-rules ()
    ((PROCESS-CALLBACK-PARAMETERS/CONTINUE parameter*
                                           continuation
                                           parameters
                                           parameters*)
     (PROCESS-CALLBACK-PARAMETERS continuation
                                  parameters
                                  (parameter* . parameters*)))))