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

;;;; C Stub Generator for Scheme
;;;; C Records -- 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.

;++ Unfix the order of arguments here.

(define-syntax define-c-record
  (syntax-rules (C->RECORD RECORD->C)
    ((DEFINE-C-RECORD type-name c-type
         (scheme-constructor field-name ...)
       (C->RECORD c->record/c-name
         (c->record/field-name c->record/expression)
         ...)
       (RECORD->C record->c/c-name
           ((record->c/field-name record->c/parameter)
            ...)
         record->c/command
         ...))
     (SORT-FIELDS
      (DEFINE-C-RECORD-1
        type-name c-type
        (scheme-constructor field-name ...)
        (C->RECORD c->record/c-name)
        (RECORD->C record->c/c-name (record->c/command ...)))
      (field-name ...)
      ("C -> record fields" ((c->record/field-name c->record/expression) ...))
      ("record -> C fields"
       ((record->c/field-name record->c/parameter) ...))))))

(define-syntax sort-fields
  (lambda (form rename compare)
    rename                              ;ignore
    (let ((macro (caadr form))
          (environment (cdadr form))
          (field-names (caddr form))
          (name.alist-list (cdddr form)))
      (define (assoc-name key alist)
        (and (pair? alist)
             (if (compare key (caar alist))
                 (car alist)
                 (assoc-name key (cdr alist)))))
      (call-with-current-continuation
        (lambda (exit)
          ((lambda (arguments)
             `(,macro ,@arguments . ,environment))
           (map (lambda (name.alist)
                  (let ((name (car name.alist))
                        (alist (cadr name.alist)))
                    (map (lambda (field-name)
                           (or (assoc-name field-name alist)
                               (exit    ;++ This makes sense, at the moment.
                                (syntax-error
                                 (string-append "No entry for field in "
                                                name
                                                ":")
                                 field-name
                                 alist))))
                         field-names)))
                name.alist-list))))))
  ())                                   ;No auxiliary names

(define-syntax define-c-record-1
  (syntax-rules (C->RECORD RECORD->C)
    ((DEFINE-C-RECORD-1
         ((c->record/field-name c->record/expression) ...)
         record->c/parameters
       type-name c-type
       (scheme-constructor . field-names)
       (C->RECORD c->record/c-name)
       (RECORD->C record->c/c-name record->c/commands))
     (PROCESS-EXPRESSIONS
      (DEFINE-C-RECORD-2
        type-name c-type
        (scheme-constructor . field-names)
        (C->RECORD c->record/c-name)
        (RECORD->C record->c/c-name record->c/parameters record->c/commands))
      (c->record/expression ...)))))

(define-syntax define-c-record-2
  (syntax-rules (C->RECORD RECORD->C)
    ((DEFINE-C-RECORD-2 c->record/expressions
       type-name c-type
       (scheme-constructor . field-names)
       (C->RECORD c->record/c-name)
       (RECORD->C record->c/c-name record->c/parameters record->c/commands))
     (PROCESS-PARAMETERS
      (DEFINE-C-RECORD-3
        type-name c-type
        (scheme-constructor . field-names)
        (C->RECORD c->record/c-name c->record/expressions)
        (RECORD->C record->c/c-name record->c/commands))
      record->c/parameters))))

(define-syntax define-c-record-3
  (syntax-rules (C->RECORD RECORD->C)
    ((DEFINE-C-RECORD-3 ((record->c/scheme-name   ;++ BOGUS BOGUS BOGUS
                          (record->c/scheme-expression
                           record->c/c-parameter))
                         ...)
       type-name c-type
       (scheme-constructor . field-names)
       (C->RECORD c->record/c-name c->record/expressions)
       (RECORD->C record->c/c-name record->c/commands))
     (PROCESS-COMMANDS
      (DEFINE-C-RECORD-4
        type-name c-type
        (scheme-constructor . field-names)
        (C->RECORD c->record/c-name c->record/expressions)
        (RECORD->C record->c/c-name (record->c/c-parameter ...)))
      record->c/commands))))

(define-syntax define-c-record-4
  (syntax-rules ()
    ((DEFINE-C-RECORD-4 record->c/commands
       type-name c-type
       (scheme-constructor . field-names)
       (C->RECORD c->record/c-name c->record/expressions)
       (RECORD->C record->c/c-name record->c/parameters))
     (C-STUB-BINDING-NAME
      (DEFINE-C-RECORD/FINISH
        type-name c-type
        (scheme-constructor . field-names)
        (C->RECORD c->record/c-name c->record/expressions)
        (RECORD->C record->c/c-name record->c/parameters record->c/commands))
      type-name))))

(define-syntax define-c-record/finish
  (syntax-rules (C->RECORD RECORD->C)
    ((DEFINE-C-RECORD/FINISH rtd-binding-name
       type-name c-type
       (scheme-constructor field-name ...)
       (C->RECORD c->record/c-name c->record/expressions)
       (RECORD->C record->c/c-name record->c/parameters record->c/commands))
     (BEGIN
       (DEFINE-C-RECORD-TYPE type-name c-type rtd-binding-name
         scheme-constructor
         field-name ...)
       (C-STUB
        (C-STUB/RECORD-TYPE type-name c-type (field-name ...) rtd-binding-name
                            c->record/c-name c->record/expressions
                            record->c/c-name record->c/parameters
                            record->c/commands))))))

(define-syntactic-invoker c-stub/record-type)

(define-syntax define-c-record-type
  (lambda (form rename compare)
    compare                             ;ignore
    (let ((type-name (cadr form))
          (c-type (caddr form))
          (rtd-binding-name (cadddr form))
          (constructor-name (car (cddddr form)))
          (field-names (cdr (cddddr form)))
          (dot (string->symbol ".")))
      (define (symbol . components)
        (string->symbol (apply string-append (map symbol->string components))))
      (let ((rtd-name (symbol '< type-name '>))
            (conversion (symbol 'C '- type-name))
            (predicate-name (symbol type-name '?))
            (field-readers
             (map (lambda (field-name)
                    (symbol type-name dot field-name))
                  field-names))
            (field-writers
             (map (lambda (field-name)
                    (symbol 'SET '- type-name dot field-name '!))
                  field-names)))
        `(,(rename 'BEGIN)
           (,(rename 'DEFINE-RECORD-TYPE) ,type-name ,rtd-name
               (,constructor-name ,@field-names)
               ,predicate-name
             ,@(map list field-names field-readers field-writers))
           (,(rename 'DEFINE-C-RECORD-CONVERSION) ,conversion
               ,type-name ,c-type
             ,predicate-name
             ,rtd-binding-name)
           (,(rename 'DEFINE-EXPORTED-BINDING) ,rtd-binding-name
             ,rtd-name)))))
  (BEGIN DEFINE-RECORD-TYPE DEFINE-C-RECORD-CONVERSION
         DEFINE-EXPORTED-BINDING))

(define-syntax define-c-record-conversion
  (syntax-rules ()
    ((DEFINE-C-RECORD-CONVERSION name type-name c-type predicate
       rtd-binding-name)
     (DEFINE-SYNTAX name
       (SYNTAX-RULES (SCHEME->C C->SCHEME name)
         ((name SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME name)
          (SIMPLE-PARAMETER ?CONTINUATION
                            ?SCHEME-NAME
                            (IF (predicate ?SCHEME-NAME)
                                ?SCHEME-NAME
                                (ERROR "Invalid argument:" ?SCHEME-NAME))
                            C-PARAMETER/RECORD
                            ?SCHEME-NAME c-type name rtd-binding-name))
         ((name SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME ?USE)
          (SYNTACTIC-ERROR "Invalid C parameter conversion:" ?USE))
         ((name C->SCHEME ?CONTINUATION (name ?C-EXPRESSION))
          (SIMPLE-EXPRESSION ?CONTINUATION
                             C-EXPRESSION/RECORD
                             name ?C-EXPRESSION rtd-binding-name)))))))

(define-syntactic-invoker c-expression/record)
(define-syntactic-invoker c-parameter/record)