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

;;;; C Stub Generator for Scheme
;;;; C Records -- 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 (c-expression/record type-name c-expression rtd-binding-name)
  (lambda (locative)
    (assign-locative
     locative
     (c-format:call (c-format:s48-record-enter-name type-name rtd-binding-name)
                    (list c-expression)))))

(define (c-parameter/record name c-type type-name rtd-binding-name)
  (let* ((c-name (maybe-mangle-name name))
         (s48-name (format:sequence c-name "_s48")))
    (make-c-parameter
     s48-name
     c-name
     (list s48-name)
     (c-format:declare c-type c-name)
     (c-format:call-statement
      (c-format:s48-record-extract-name type-name rtd-binding-name)
      (list s48-name
            (c-format:address-of c-name)))
     #f)))

(define (c-stub/record-type type-name c-type field-names rtd-binding-name
                            c-enter-argument expressions
                            c-extract-argument parameters c-extract-statements)
  (let ((c-rtd-binding-name
         (stub-format:binding-variable (mangle-name rtd-binding-name))))
    (compound-emission
     (declaration-emission
      ;++ static?
      (c-format:static (c-format:s48-declare-unspecific c-rtd-binding-name)))
     (initialization-emission
      (c-format:s48-gc-protect-global c-rtd-binding-name)
      (c-format:s48-import-binding rtd-binding-name
                                   (variable-locative c-rtd-binding-name)))
     (c-stub/record-enter type-name c-type
                          rtd-binding-name c-rtd-binding-name
                          c-enter-argument expressions)
     (c-stub/record-extract type-name c-type
                            rtd-binding-name c-rtd-binding-name
                            c-extract-argument parameters
                            c-extract-statements))))

(define (c-stub/record-enter type-name c-type
                             rtd-binding-name c-rtd-binding-name
                             c-enter-argument expressions)
  (declaration-emission
   (c-format:call-with-temporary-name "record"
     (lambda (record-name)
       (c-format:call-with-temporary-name "temporary"
         (lambda (temporary-name)
           (let ((protected (list record-name temporary-name)))
             (c-format:function (c-format:s48-value-type)
                 (c-format:s48-record-enter-name type-name rtd-binding-name)
                 (list
                  (c-format:parameter
                   (c-format:const (c-format:pointer-type c-type))
                   c-enter-argument))
               (format:sequence
                (stub-format:comment "Declarations")
                (c-format:s48-declare-unspecific record-name temporary-name)
                (format:blank-line)
                (stub-format:comment "GC Protection")
                (c-format:s48-declare-gc-protect (length protected))
                (c-format:s48-gc-protect protected)
                (format:blank-line)
                (stub-format:comment "Initialization")
                (c-format:assign-statement
                 record-name
                 (c-format:call "s48_make_record" (list c-rtd-binding-name)))
                (format:blank-line)
                (stub-format:comment "Body")
                (format:list
                 (collect-list ((for index (up-from 0))
                                (for expression (in-list expressions)))
                   (expression
                    (hybrid-locative
                     "value"
                     temporary-name
                     (c-format:call "S48_UNSAFE_RECORD_REF"
                                    (list record-name index))
                     (lambda (expression)
                       (c-format:call-statement
                        "S48_UNSAFE_RECORD_SET"
                        (list record-name index expression)))))))
                (format:blank-line)
                (stub-format:comment "Finalization")
                (c-format:s48-gc-unprotect)
                (format:blank-line)
                (c-format:return record-name))))))))))

(define (c-stub/record-extract type-name c-type
                               rtd-binding-name c-rtd-binding-name
                               c-extract-argument parameters
                               c-extract-statements)
  (declaration-emission
   (c-format:call-with-temporary-name "record"
     (lambda (record-name)
       (let ((protected
              (cons record-name
                    (map c-parameter.name parameters))))
         (c-format:function "void"       ;++ fix the C formatter
             (c-format:s48-record-extract-name type-name rtd-binding-name)
             (list (c-format:parameter (c-format:s48-value-type) record-name)
                   (c-format:parameter (c-format:pointer-type c-type)
                                       c-extract-argument))
           (format:sequence
            (stub-format:comment "Declarations")
            (c-format:s48-declare-unspecific:list
             (map c-parameter.name parameters))
            (format:list (filter-map c-parameter.declaration parameters))
            (format:blank-line)
            (stub-format:comment "GC Protection")
            (c-format:s48-declare-gc-protect (length protected))
            (c-format:s48-gc-protect protected)
            (format:blank-line)
            (stub-format:comment "Initialization")
            (c-format:call-statement "s48_check_record_type"
                                     (list record-name c-rtd-binding-name))
            (format:list
             (collect-list ((for index (up-from 0))
                            (for parameter (in-list parameters)))
               (c-format:assign-statement
                (c-parameter.name parameter)
                (c-format:call "S48_UNSAFE_RECORD_REF"
                               (list record-name index)))))
            (format:list (filter-map c-parameter.initialization parameters))
            (format:blank-line)
            (stub-format:comment "Body")
            (map format:indented-line c-extract-statements)
            (format:blank-line)
            (stub-format:comment "Finalization")
            (c-format:s48-gc-unprotect))))))))

(define-format (c-format:s48-record-enter-name type-name rtd-binding-name)
  (format:sequence "s48_enter_" (mangle-name rtd-binding-name)))

(define-format (c-format:s48-record-extract-name type-name rtd-binding-name)
  (format:sequence "s48_extract_" (mangle-name rtd-binding-name)))