;;; -*- Mode: Scheme; scheme48-package: stubber-syntax -*-

;;;; C Stub Generator for Scheme
;;;; Scheme48 Syntax Monstrosities

;;; 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-module-local the-local-c-stub stub:local-descriptor)

(define-syntax set-local-c-stub!
  (syntax-rules ()
    ((SET-LOCAL-C-STUB! stub)
     (SET-MODULE-LOCAL! THE-LOCAL-C-STUB stub))))

(define-syntax local-c-stub
  (syntax-rules ()
    ((LOCAL-C-STUB continuation)
     (MODULE-LOCAL (LOCAL-C-STUB/CONTINUE continuation) THE-LOCAL-C-STUB))))

(define-syntax local-c-stub/continue
  (lambda (form rename compare)
    rename compare                      ;ignore
    (let ((stub (cadr form))
          (macro (caaddr form))
          (environment (cdaddr form)))
      (cond ((not stub) (syntax-error "No C stub being generated."))
            ((string? stub) (syntax-error "C stub generation finished."))
            (else `(,macro ,stub . ,environment)))))
  ())

(define-syntax local-c-stub-name
  (syntax-rules ()
    ((LOCAL-C-STUB-NAME continuation)
     (MODULE-LOCAL (LOCAL-C-STUB-NAME/CONTINUE continuation)
                   THE-LOCAL-C-STUB))))

(define-syntax local-c-stub-name/continue
  (lambda (form rename compare)
    rename compare                      ;ignore
    (let ((stub (cadr form))
          (macro (caaddr form))
          (environment (cdaddr form)))
      (if (not stub)
          (syntax-error "No C stub being generated.")
          `(,macro ,(if (string? stub) stub (c-stub.name stub))
                   . ,environment))))
  ())

;;;; Opening and Closing Stubs

(define-syntax begin-c-stub
  (lambda (form rename compare)
    compare                             ;ignore
    (let ((name (cadr form))
          (pathname (and (pair? (cddr form)) (caddr form))))
      (let ((stub (open-c-stub name pathname)))
        `(,(rename 'SET-LOCAL-C-STUB!) ,stub))))
  (%BEGIN-C-STUB))

(define-syntax end-c-stub
  (syntax-rules ()
    ((END-C-STUB)
     (LOCAL-C-STUB (END-C-STUB/CONTINUE)))))

(define-syntax end-c-stub/continue
  (lambda (form rename compare)
    compare                             ;ignore
    (let* ((stub (cadr form))
           (name (c-stub.name stub)))
      (close-c-stub stub)
      (compile-c-stub stub)
      (let ((library-pathname (link-c-stub stub)))
        `(,(rename 'BEGIN)
           (,(rename 'SET-LOCAL-C-STUB!) ,name)
           (,(rename 'LOAD-DYNAMIC-EXTERNALS)
            (,(rename 'TRANSLATE) (,(rename 'QUOTE) ,library-pathname))
            #F #T #T)))))
  (BEGIN SET-LOCAL-C-STUB! LOAD-DYNAMIC-EXTERNALS QUOTE))

;;;; Emitting Stubs

(define-syntax c-stub
  (syntax-rules ()
    ((C-STUB form ...)
     (LOCAL-C-STUB (C-STUB/EMITTER form ...)))))

(define-syntax c-stub/emitter
  (lambda (form rename compare)
    compare                             ;ignore
    (let ((stub (cadr form))
          (forms (cddr form))
          (%begin (rename 'BEGIN))
          (%define-syntax (rename 'DEFINE-SYNTAX))
          (%emitter (rename 'EMITTER))
          (%c-stub/loop (rename 'C-STUB/LOOP))
          (&lambda (meta LAMBDA))
          (&let (meta LET))
          (&c-stub-emit (meta C-STUB-EMIT))
          (&code-quote (meta CODE-QUOTE))
          (&cadr (meta CADR))
          (&caddr (meta CADDR)))
      `(,%begin (,%define-syntax ,%emitter
                  (,&lambda (FORM RENAME COMPARE)
                    RENAME COMPARE ;ignore
                    (,&c-stub-emit (,&code-quote ,stub) (,&caddr FORM))
                    (,&cadr FORM))
                  ())
                (,%c-stub/loop ,%emitter ,@forms))))
  (BEGIN DEFINE-SYNTAX C-STUB/LOOP))

(define-syntax c-stub/loop
  (syntax-rules ()
    ((C-STUB/LOOP emitter) 'C-STUB)
    ((C-STUB/LOOP emitter (macro . arguments) . forms)
     (macro (C-STUB/CONTINUE emitter . forms) . arguments))))

(define-syntax c-stub/continue
  (syntax-rules ()
    ((C-STUB/CONTINUE item emitter . forms)
     (emitter (C-STUB/LOOP emitter . forms) item))))

(define-syntax define-syntactic-invoker
  (lambda (form rename compare)
    compare                             ;ignore
    (let ((syntactic-name (cadr form))
          (semantic-name (if (pair? (cddr form)) (caddr form) (cadr form)))
          (%define-syntax (rename 'DEFINE-SYNTAX))
          (&lambda (meta LAMBDA))
          (&let (meta LET))
          (&caadr (meta CAADR))
          (&cdadr (meta CDADR))
          (&cddr (meta CDDR))
          (&cons (meta CONS))
          (&apply (meta APPLY))
          (&desyntaxify (meta DESYNTAXIFY)))
      `(,%define-syntax ,syntactic-name
         (,&lambda (FORM RENAME COMPARE)
           COMPARE                      ;ignore
           (,&let ((MACRO (,&caadr FORM))
                   (ENVIRONMENT (,&cdadr FORM))
                   (ARGUMENTS (,&cddr FORM)))
             (,&cons MACRO
                     (,&cons (,&apply ,semantic-name (,&desyntaxify ARGUMENTS))
                             ENVIRONMENT))))
         ())))
  (DEFINE-SYNTAX))

;;;; The Easy Parts

(define-syntax c-include
  (syntax-rules ()
    ((C-INCLUDE pathname ...)
     (C-STUB (C-STUB/INCLUDE pathname) ...))))

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

(define-syntax c-system-include
  (syntax-rules ()
    ((C-SYSTEM-INCLUDE pathname ...)
     (C-STUB (C-STUB/SYSTEM-INCLUDE pathname) ...))))

(define-syntactic-invoker c-stub/system-include)

(define-syntax c-declare
  (syntax-rules ()
    ((C-DECLARE line ...)
     (C-STUB (C-STUB/DECLARE line ...)))))

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

(define-syntax c-initialize
  (syntax-rules ()
    ((C-DECLARE line ...)
     (C-STUB (C-STUB/INITIALIZE line ...)))))

(define-syntactic-invoker c-stub/initialize)

;;;; A Hard Part: DEFINE-C

(define-syntax define-c
  (syntax-rules (C-DECLARE)

    ((DEFINE-C (name parameter ...) (C-DECLARE declaration ...) result wrapper)
     (PROCESS-PARAMETERS
      (DEFINE-C/PROCEDURE/CONTINUE name (declaration ...) result wrapper)
      (parameter ...)))

    ((DEFINE-C (name parameter ...) (C-DECLARE declaration ...) result)
     (DEFINE-C (name parameter ...) (C-DECLARE declaration ...) result #F))

    ((DEFINE-C (name parameter ...) result wrapper)
     (DEFINE-C (name parameter ...) (C-DECLARE) result wrapper))

    ((DEFINE-C (name parameter ...) result)
     (DEFINE-C (name parameter ...) (C-DECLARE) result #F))

    ((DEFINE-C name expression)
     (PROCESS-EXPRESSION (DEFINE-C/VARIABLE/CONTINUE name) expression))))

(define-syntax define-c/procedure/continue
  (syntax-rules ()
    ((DEFINE-C/PROCEDURE/CONTINUE parameters name declaration result wrapper)
     (PROCESS-RESULT
      (DEFINE-C/PROCEDURE/FINISH name parameters declaration)
      result
      wrapper))))

(define-syntax define-c/procedure/finish
  (syntax-rules ()
    ((DEFINE-C/PROCEDURE/FINISH result wrapper name parameters declarations)
     (DEFINE-C-PROCEDURE name parameters declarations result wrapper))))

(define-syntax define-c/variable/continue
  (syntax-rules ()
    ((DEFINE-C/VARIABLE/CONTINUE expression name)
     (DEFINE-C-VARIABLE name expression))))

(define-syntax define-c-procedure
  (syntax-rules ()
    ((DEFINE-C-PROCEDURE name parameters declarations result wrapper)
     (C-STUB-BINDING-NAME
      (DEFINE-C-PROCEDURE/GENERATE name parameters declarations result wrapper)
      name))))

(define-syntax define-c-procedure/generate
  (syntax-rules ()
    ((DEFINE-C-PROCEDURE/GENERATE
       binding-name
       name
       ((scheme-name (scheme-expression c-parameter) ...) ...)
       declarations result wrapper)
     (BEGIN
       (C-STUB
        (C-STUB/PROCEDURE name binding-name (c-parameter ... ...) declarations
                          result))
       (DEFINE name
         (LET ((BINDING (LOOKUP-IMPORTED-BINDING binding-name)))
           (LAMBDA (scheme-name ...)
             (INVOKE-WRAPPER
              wrapper
              (CALL-IMPORTED-BINDING BINDING scheme-expression ... ...)))))))))

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

(define-syntax invoke-wrapper
  (syntax-rules (THUNK)
    ((INVOKE-WRAPPER #F expression)
     expression)
    ((INVOKE-WRAPPER (THUNK wrapper) expression)
     (wrapper (LAMBDA () expression)))
    ((INVOKE-WRAPPER wrapper expression)
     (wrapper expression))))

(define-syntax define-c-variable
  (syntax-rules ()
    ((DEFINE-C-VARIABLE name expression)
     (C-STUB-BINDING-NAME (DEFINE-C-VARIABLE/GENERATE name expression) name))))

(define-syntax define-c-variable/generate
  (syntax-rules ()
    ((DEFINE-C-VARIABLE/GENERATE binding-name name expression)
     (BEGIN
       (C-STUB (C-STUB/VARIABLE binding-name expression))
       (DEFINE (name)
         (SHARED-BINDING-REF (LOOKUP-IMPORTED-BINDING binding-name)))))))

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

(define-syntax c-stub-binding-name
  (syntax-rules ()
    ((C-STUB-BINDING-NAME continuation name)
     (LOCAL-C-STUB-NAME (C-STUB-BINDING-NAME/CONTINUE continuation name)))))

(define-syntax c-stub-binding-name/continue
  (lambda (form rename compare)
    (let ((context (cadr form))
          (macro (caaddr form))
          (environment (cdaddr form))
          (name (cadddr form)))
      (cons macro
            (cons (string-append "(" context ")"
                                 (symbol->string (desyntaxify name)))
                  environment))))
  ())

;;;; Processing Parameters and Expressions

(define-syntax process-parameters
  (syntax-rules ()
    ((PROCESS-PARAMETERS continuation parameters)
     (SYNTACTIC-MAP continuation PROCESS-PARAMETER parameters))))

(define-syntax process-parameter
  (syntax-rules ()
    ((PROCESS-PARAMETER continuation (scheme-name conversion))
     (PROCESS-PARAMETER continuation (scheme-name scheme-name conversion)))

    ((PROCESS-PARAMETER continuation (scheme-name c-name (macro . arguments)))
     (macro SCHEME->C (PROCESS-PARAMETER/CONTINUE scheme-name continuation)
            scheme-name c-name (macro . arguments)))

    ((PROCESS-PARAMETER continuation (scheme-name c-name macro))
     (macro SCHEME->C (PROCESS-PARAMETER/CONTINUE scheme-name continuation)
            scheme-name c-name macro))))

(define-syntax process-parameter/continue
  (syntax-rules ()
    ((PROCESS-PARAMETER/CONTINUE expressions&c-parameters name continuation)
     (SYNTACTIC-CONTINUE continuation (name . expressions&c-parameters)))))

(define-syntax process-expressions
  (syntax-rules ()
    ((PROCESS-EXPRESSIONS continuation expressions)
     (SYNTACTIC-MAP continuation PROCESS-EXPRESSION expressions))))

(define-syntax process-expression
  (syntax-rules ()
    ((PROCESS-EXPRESSION continuation (macro . arguments))
     (macro C->SCHEME continuation (macro . arguments)))))

(define-syntax process-commands
  (syntax-rules ()
    ((PROCESS-COMMANDS continuation commands)
     (SYNTACTIC-MAP continuation PROCESS-COMMAND commands))))

(define-syntax process-command          ;++ Implement command dispatching.
  (syntax-rules ()
    ((PROCESS-COMMAND continuation command)
     (SYNTACTIC-CONTINUE continuation command))))

;;;; Processing Results

(define-syntax process-result
  (syntax-rules (C-BEGIN C-IF C-COND C-ELSE C-VALUES)
    ((PROCESS-RESULT continuation (C-BEGIN expression) wrapper)
     (PROCESS-RESULT continuation expression wrapper))

    ;; No tail patterns.
    ;; ((PROCESS-RESULT continuation (C-BEGIN command ... expression) wrapper)
    ;;  (PROCESS-COMMANDS (PROCESS-RESULT/COMMANDS continuation
    ;;                                             expression
    ;;                                             wrapper)
    ;;                    (command ...)))

    ((PROCESS-RESULT continuation (C-BEGIN command0 command1+ ...) wrapper)
     (PROCESS-COMMAND (PROCESS-RESULT/SEQUENCE continuation
                                               (C-BEGIN command1+ ...)
                                               wrapper)
                      command0))

    ((PROCESS-RESULT continuation (C-IF test consequent alternative) wrapper)
     (PROCESS-RESULT
      (PROCESS-RESULT/CONDITIONAL continuation test alternative wrapper)
      consequent
      #F))

    ((PROCESS-RESULT continuation
                     (C-COND (C-ELSE command0 command1+ ...))
                     wrapper)
     (PROCESS-RESULT continuation (C-BEGIN command0 command1+ ...) wrapper))

    ((PROCESS-RESULT continuation
                     (C-COND (test command0 command1+ ...)
                             (tests commands0 commands1+ ...)
                             ...)
                     wrapper)
     (PROCESS-RESULT continuation
                     (C-IF test
                           (C-BEGIN command0 command1+ ...)
                           (C-COND (tests commands0 commands1+ ...)
                                   ...))
                     wrapper))

    ((PROCESS-RESULT continuation (C-VALUES) wrapper)
     (SYNTACTIC-ERROR "No zero-value returns!"))        ;++ Why not?

    ((PROCESS-RESULT continuation (C-VALUES value) wrapper)
     (PROCESS-RESULT continuation value wrapper))

    ((PROCESS-RESULT continuation (C-VALUES value0 value1+ ...) wrapper)
     (PROCESS-RESULT
      (PROCESS-RESULT/VALUES continuation (value1+ ...) () wrapper)
      value0
      #F))

    ((PROCESS-RESULT continuation expression wrapper)
     (PROCESS-EXPRESSION (PROCESS-RESULT/EXPRESSION continuation wrapper)
                         expression))))

(define-syntax process-result/expression
  (syntax-rules ()
    ((PROCESS-RESULT/EXPRESSION expression continuation wrapper)
     (SYNTACTIC-CONTINUE continuation expression wrapper))))

;;;;; Processing Tests

(define-syntax process-test
  (syntax-rules (C-AND C-OR C-NOT)
    ((PROCESS-TEST continuation (C-AND))
     (SYNTACTIC-CONTINUE continuation #T))
    ((PROCESS-TEST continuation (C-AND test))
     (PROCESS-TEST continuation test))
    ((PROCESS-TEST continuation (C-AND test0 test1+ ...))
     (SYNTACTIC-MAP (PROCESS-TEST/CONNECTIVE continuation C-FORMAT:AND)
                    PROCESS-TEST
                    (test0 test1+ ...)))

    ((PROCESS-TEST continuation (C-OR))
     (SYNTACTIC-CONTINUE continuation #F))
    ((PROCESS-TEST continuation (C-OR test))
     (PROCESS-TEST continuation test))
    ((PROCESS-TEST continuation (C-OR test0 test1+ ...))
     (SYNTACTIC-MAP (PROCESS-TEST/CONNECTIVE continuation C-FORMAT:OR)
                    PROCESS-TEST
                    (test0 test1+ ...)))

    ((PROCESS-TEST continuation (C-NOT test))
     (PROCESS-TEST (PROCESS-TEST/NEGATE continuation) test))

    ((PROCESS-TEST continuation test)
     ;++ Check that TEST is a string.
     (SYNTACTIC-CONTINUE continuation test))))

(define-syntax process-test/negate
  (syntax-rules ()
    ((PROCESS-TEST/NEGATE test continuation)
     (C-FORMAT:NOT continuation test))))

(define-syntax process-test/connective
  (syntax-rules ()
    ((PROCESS-TEST/CONNECTIVE tests continuation connective)
     (connective continuation . tests))))

(define-syntactic-invoker c-format:and)
(define-syntactic-invoker c-format:or)
(define-syntactic-invoker c-format:not)

;;;;; Processing Conditionals and Sequences

(define-syntax process-result/conditional
  (syntax-rules ()
    ((PROCESS-RESULT/CONDITIONAL #T #F continuation test alternative wrapper)
     (PROCESS-RESULT continuation alternative wrapper))
    ((PROCESS-RESULT/CONDITIONAL result #F
                                 continuation test alternative wrapper)
     (PROCESS-RESULT
      (PROCESS-RESULT/CONDITIONAL/CONTINUE continuation result test wrapper)
      alternative
      #F))))

(define-syntax process-result/conditional/continue
  (syntax-rules ()
    ((PROCESS-RESULT/CONDITIONAL/CONTINUE #T #F
                                          continuation consequent test wrapper)
     (SYNTACTIC-CONTINUE continuation consequent wrapper))
    ((PROCESS-RESULT/CONDITIONAL/CONTINUE alternative #F
                                          continuation consequent test wrapper)
     (PROCESS-TEST
      (PROCESS-RESULT/CONDITIONAL/TEST continuation
                                       consequent
                                       alternative
                                       wrapper)
      test))))

(define-syntax process-result/conditional/test
  (syntax-rules ()
    ((PROCESS-RESULT/CONDITIONAL/TEST test
                                      continuation
                                      consequent
                                      alternative
                                      wrapper)
     (C-EXPRESSION/CONDITIONAL
      (PROCESS-RESULT/CONDITIONAL/FINISH continuation wrapper)
      test
      consequent
      alternative))))

(define-syntactic-invoker c-expression/conditional)

(define-syntax process-result/conditional/finish
  (syntax-rules ()
    ((PROCESS-RESULT/CONDITIONAL/FINISH result continuation wrapper)
     (SYNTACTIC-CONTINUE continuation result wrapper))))

(define-syntax process-result/sequence
  (syntax-rules ()
    ((PROCESS-RESULT/SEQUENCE command continuation expression wrapper)
     (PROCESS-RESULT (PROCESS-RESULT/SEQUENCE/CONTINUE continuation command)
                     expression
                     wrapper))))

(define-syntax process-result/sequence/continue
  (syntax-rules ()
    ((PROCESS-RESULT/SEQUENCE/CONTINUE expression wrapper continuation command)
     (C-EXPRESSION/SEQUENCE
      (PROCESS-RESULT/SEQUENCE/FINISH wrapper continuation)
      command
      expression))))

(define-syntactic-invoker c-expression/sequence)

(define-syntax process-result/sequence/finish
  (syntax-rules ()
    ((PROCESS-RESULT/SEQUENCE/FINISH expression wrapper continuation)
     (SYNTACTIC-CONTINUE continuation expression wrapper))))

;;;;; Expression Versions of the Above

(define-syntax c-begin
  (syntax-rules (C->SCHEME C-BEGIN)
    ((C-BEGIN C->SCHEME continuation (C-BEGIN expression))
     (PROCESS-EXPRESSION continuation expression))
    ((C-BEGIN C->SCHEME continuation (C-BEGIN command0 command1+ ...))
     (PROCESS-COMMAND (C-BEGIN/CONTINUE continuation command1+ ...)
                      command0))))

(define-syntax c-begin/continue
  (syntax-rules ()
    ((C-BEGIN/CONTINUE command continuation more ...)
     (PROCESS-EXPRESSION (C-BEGIN/FINISH command continuation)
                         (C-BEGIN more ...)))))

(define-syntax c-begin/finish
  (syntax-rules ()
    ((C-BEGIN/FINISH expression command continuation)
     (C-EXPRESSION/SEQUENCE contiuation command expression))))

(define-syntax c-if
  (syntax-rules (C->SCHEME C-IF)
    ((C-IF C->SCHEME continuation (C-IF test consequent alternative))
     (PROCESS-TEST (C-IF/CONSEQUENT consequent alternative continuation)
                   test))))

(define-syntax c-if/consequent
  (syntax-rules ()
    ((C-IF/CONSEQUENT test consequent alternative continuation)
     (PROCESS-EXPRESSION (C-IF/ALTERNATIVE test alternative continuation)
                         consequent))))

(define-syntax c-if/alternative
  (syntax-rules ()
    ((C-IF/ALTERNATIVE consequent test alternative continuation)
     (PROCESS-EXPRESSION (C-IF/FINISH test consequent continuation)
                         alternative))))

(define-syntax c-if/finish
  (syntax-rules ()
    ((C-IF/FINISH alternative test consequent continuation)
     (C-EXPRESSION/CONDITIONAL continuation test consequent alternative))))

(define-syntax c-cond
  (syntax-rules (C->SCHEME C-COND C-ELSE)
    ((C-COND C->SCHEME continuation (C-COND (C-ELSE command0 command1+ ...)))
     (PROCESS-EXPRESSION continuation (C-BEGIN command0 command1+ ...)))
    ((C-COND C->SCHEME continuation
             (C-COND (test command0 command1+ ...)
                     (tests commands0 commands1+ ...)
                     ...))
     (PROCESS-EXPRESSION
      continuation
      (C-IF test
            (C-BEGIN command0 command1+ ...)
            (C-COND (tests0 commands0 commands1+ ...) ...))))))

;;;;; Processing Multiple-Value Results

(define-syntax process-result/values
  (syntax-rules ()
    ((PROCESS-RESULT/VALUES result #F
                            continuation (value . values) results wrapper)
     (PROCESS-RESULT
      (PROCESS-RESULT/VALUES continuation values (result . results) wrapper)
      value
      #F))
    ((PROCESS-RESULT/VALUES result #F continuation () results wrapper)
     (SYNTACTIC-REVERSE (PROCESS-RESULT/VALUES/CONTINUE continuation wrapper)
                        (result . results)))))

(define-syntax process-result/values/continue
  (syntax-rules ()
    ((PROCESS-RESULT/VALUES/CONTINUE (result0 result1) continuation wrapper)
     (C-EXPRESSION/CONS (PROCESS-RESULT/VALUES/PAIR continuation wrapper)
                        result0
                        result1))
    ((PROCESS-RESULT/VALUES/CONTINUE results continuation wrapper)
     (C-EXPRESSION/VECTOR
      (PROCESS-RESULT/VALUES/VECTOR continuation wrapper results)
      results))))

(define-syntactic-invoker c-expression/cons)
(define-syntactic-invoker c-expression/vector)

(define-syntax process-result/values/pair
  (syntax-rules ()
    ((PROCESS-RESULT/VALUES/PAIR result continuation #F)
     (SYNTACTIC-CONTINUE continuation
                         result (LAMBDA (P) (VALUES (CAR P) (CDR P)))))
    ((PROCESS-RESULT/VALUES/PAIR result continuation wrapper)
     (SYNTACTIC-CONTINUE continuation
                         result (LAMBDA (P) (wrapper (CAR P) (CDR P)))))))

(define-syntax process-result/values/vector
  (syntax-rules ()
    ((PROCESS-RESULT/VALUES/VECTOR result continuation wrapper results)
     (PROCESS-RESULT/VALUES/VECTOR-INDICES
      (PROCESS-RESULT/VALUES/VECTOR/FINISH continuation result wrapper)
      results))))

(define-syntax process-result/values/vector/finish
  (syntax-rules ()
    ((PROCESS-RESULT/VALUES/VECTOR/FINISH (index ...) continuation result #F)
     (SYNTACTIC-CONTINUE continuation
                         result
                         (LAMBDA (V) (VALUES (VECTOR-REF V index) ...))))
    ((PROCESS-RESULT/VALUES/VECTOR/FINISH (index ...)
                                          continuation
                                          result
                                          wrapper)
     (SYNTACTIC-CONTINUE continuation
                         result
                         (LAMBDA (V) (wrapper (VECTOR-REF V index) ...))))))

(define-syntax process-result/values/vector-indices
  (lambda (form rename compare)
    `(,(caadr form)
      ,(collect-list (for index (up-from 0 (to (length (cdadr form))))) index)
      . ,(cdadr form)))
  ())

;;;; Simple Parameters and Expressions

(define-syntax simple-parameter
  (syntax-rules ()
    ((SIMPLE-PARAMETER continuation name expression macro . arguments)
     (macro (SIMPLE-PARAMETER/CONTINUE continuation expression)
            . arguments))))

(define-syntax simple-parameter/continue
  (syntax-rules ()
    ((SIMPLE-PARAMETER/CONTINUE c-parameter continuation expression)
     (SYNTACTIC-CONTINUE continuation ((expression c-parameter))))))

(define-syntax simple-expression
  (syntax-rules ()
    ((SIMPLE-EXPRESSION continuation macro . arguments)
     (macro continuation . arguments))))

(define-syntax define-c-simple-parameter
  (syntax-rules ()
    ((DEFINE-C-SIMPLE-PARAMETER name (literal-name ...) sanitizer
       (constructor . pattern)
       . default)
     (DEFINE-SYNTAX name
       (SYNTAX-RULES (SCHEME->C name literal-name ...)
         ((name SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME (name . pattern))
          (SIMPLE-PARAMETER ?CONTINUATION
                            ?SCHEME-NAME
                            (sanitizer ?SCHEME-NAME '?SCHEME-NAME)
                            constructor ?C-NAME . pattern))
         ((name SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME name)
          (SIMPLE-PARAMETER ?CONTINUATION
                            ?SCHEME-NAME
                            (sanitizer ?SCHEME-NAME '?SCHEME-NAME)
                            constructor ?C-NAME . default))
         ((name SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME ?USE)
          (SYNTACTIC-ERROR "Invalid C parameter conversion:" ?USE)))))))

(define-syntax define-c-very-simple-parameter
  (syntax-rules ()
    ((DEFINE-C-VERY-SIMPLE-PARAMETER name sanitizer
       (constructor . pattern) . default)
     (BEGIN
       (DEFINE-SYNTACTIC-INVOKER constructor)
       (DEFINE-C-SIMPLE-PARAMETER name () sanitizer
         (constructor . pattern)
         . default)))))

(define-syntax define-c-simple-expression
  (syntax-rules ()
    ((DEFINE-C-SIMPLE-EXPRESSION name (constructor . pattern) . default)
     (DEFINE-SYNTAX name
       (SYNTAX-RULES (C->SCHEME name)
         ((name C->SCHEME ?CONTINUATION (name . pattern))
          (SIMPLE-EXPRESSION ?CONTINUATION constructor . pattern))
         ((name C->SCHEME ?CONTINUATION name)
          (SIMPLE-EXPRESSION ?CONTINUATION constructor . default))
         ((name C->SCHEME ?CONTINUATION ?USE)
          (SYNTACTIC-ERROR "Invalid C expression conversion:" ?USE)))))))

(define-syntax define-c-very-simple-expression
  (syntax-rules ()
    ((DEFINE-C-VERY-SIMPLE-EXPRESSION name (constructor . pattern) . default)
     (BEGIN
       (DEFINE-SYNTACTIC-INVOKER constructor)
       (DEFINE-C-SIMPLE-EXPRESSION name (constructor . pattern) . default)))))

(define-syntax define-c-simple-conversion
  (syntax-rules ()
    ((DEFINE-C-SIMPLE-CONVERSION name (literal-name ...) sanitizer
       ((parameter-name . parameter-pattern) parameter-default ...)
       ((expression-name . expression-pattern) expression-default ...))
     (DEFINE-SYNTAX name
       (SYNTAX-RULES (C->SCHEME SCHEME->C name literal-name ...)

         ((name SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME
                (name . parameter-pattern))
          (SIMPLE-PARAMETER ?CONTINUATION
                            ?SCHEME-NAME
                            (sanitizer ?SCHEME-NAME '?SCHEME-NAME)
                            parameter-name ?C-NAME . parameter-pattern))

         ((name SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME name)
          (name SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME
                (name parameter-default ...)))

         ((name SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME ?USE)
          (SYNTACTIC-ERROR "Invalid C parameter conversion:" ?USE))

         ((name C->SCHEME ?CONTINUATION (name . expression-pattern))
          (SIMPLE-EXPRESSION ?CONTINUATION
                             expression-name . expression-pattern))

         ((name C->SCHEME ?CONTINUATION (name ?EXPRESSION))
          (name C->SCHEME ?CONTINUATION
                (name expression-default ... ?EXPRESSION)))

         ((name C->SCHEME ?CONTINUATION ?USE)
          (SYNTACTIC-ERROR "Invalid C result conversion:" ?USE)))))))

(define-syntax define-c-very-simple-conversion
  (syntax-rules ()
    ((DEFINE-C-VERY-SIMPLE-CONVERSION name sanitizer
       ((parameter . parameter-pattern) parameter-default ...)
       ((expression . expression-pattern) expression-default ...))
     (BEGIN
       (DEFINE-SYNTACTIC-INVOKER parameter)
       (DEFINE-SYNTACTIC-INVOKER expression)
       (DEFINE-C-SIMPLE-CONVERSION name ()
           sanitizer
         ((parameter . parameter-pattern) parameter-default ...)
         ((expression . expression-pattern) expression-default ...))))))

(define-syntax identity-syntax
  (syntax-rules ()
    ((IDENTITY-SYNTAX expression) expression)))

(define-syntax convert-if
  (syntax-rules ()
    ((CONVERT-IF predicate conversion)
     (LET-SYNTAX ((CHECKER
                   (SYNTAX-RULES ()
                     ((CHECKER ?VALUE ?CONTEXT)
                      (IF (predicate ?VALUE)
                          (conversion ?VALUE)
                          (ERROR "Invalid argument:" ?VALUE ?CONTEXT))))))
       CHECKER))))

(define-syntax check
  (syntax-rules ()
    ((CHECK predicate)
     (CONVERT-IF predicate IDENTITY-SYNTAX))))

(define-c-very-simple-conversion c-boolean (check boolean?)
  ((c-parameter/boolean c-type) "int")
  ((c-expression/boolean c-type c-expression) "int"))

(define-c-very-simple-conversion c-char (check char?)
  ((c-parameter/char c-type) "char")
  ((c-expression/char c-type c-expression) "char"))

(define-c-very-simple-conversion c-integral
    (check (lambda (x) (and (integer? x) (exact? x))))
  ((c-parameter/integral c-type) "long")
  ((c-expression/integral c-type c-expression) "long"))

(define-c-very-simple-conversion c-signed
    (check (lambda (x) (and (integer? x) (exact? x))))
  ((c-parameter/signed c-type) "signed long")
  ((c-expression/signed c-type c-expression) "signed long"))

(define-c-very-simple-conversion c-unsigned
    (check (lambda (x) (and (integer? x) (exact? x) (positive? x))))
  ((c-parameter/unsigned c-type) "unsigned long")
  ((c-expression/unsigned c-type c-expression) "unsigned long"))

(define-syntax *define-c-integral-conversion
  (syntax-rules ()
    ((*DEFINE-C-INTEGRAL-CONVERSION name type conversion)
     (DEFINE-SYNTAX name
       (SYNTAX-RULES (SCHEME->C C->SCHEME name)
         ((name SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME (name))
          (conversion SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME
                      (conversion type)))
         ((name SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME name)
          (name SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME (name)))
         ((name SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME ?USE)
          (SYNTACTIC-ERROR "Invalid C parameter conversion:" ?USE))
         ((name C->SCHEME ?CONTINUATION (name ?EXPRESSION))
          (conversion C->SCHEME ?CONTINUATION (conversion type ?EXPRESSION)))
         ((name C->SCHEME ?CONTINUATION ?USE)
          (SYNTACTIC-ERROR "Invalid C expression conversion:" ?USE)))))))

(define-syntax define-c-integral-conversion
  (syntax-rules ()
    ((DEFINE-C-INTEGRAL-CONVERSION name type)
     (*DEFINE-C-INTEGRAL-CONVERSION name type C-INTEGRAL))))

(define-syntax define-c-signed-conversion
  (syntax-rules ()
    ((DEFINE-C-SIGNED-CONVERSION name type)
     (*DEFINE-C-SIGNED-CONVERSION name type C-SIGNED))))

(define-syntax define-c-unsigned-conversion
  (syntax-rules ()
    ((DEFINE-C-UNSIGNED-CONVERSION name type)
     (*DEFINE-C-UNSIGNED-CONVERSION name type C-UNSIGNED))))

(define-c-very-simple-conversion c-floating-point
    (convert-if real? exact->inexact)
  ((c-parameter/floating-point c-type) "double")
  ((c-expression/floating-point c-type c-expression) "double"))

(define-c-very-simple-parameter c-shared-asciz-string (check string?)
  (c-parameter/shared-asciz-string))

(define-c-very-simple-parameter c-immutable-asciz-string (check string?)
  (c-parameter/immutable-asciz-string))

(define-c-very-simple-conversion c-copied-asciz-string (check string?)
  ((c-parameter/copied-asciz-string))
  ((c-expression/copied-asciz-string c-expression)))

(define-c-very-simple-conversion c-copied&freed-asciz-string (check string?)
  ((c-parameter/copied&freed-asciz-string))
  ((c-expression/copied&freed-asciz-string c-expression)))

(define-c-very-simple-parameter c-shared-asciz-utf-8-string (check string?)
  (c-parameter/shared-asciz-utf-8-string))

(define-c-very-simple-parameter c-immutable-asciz-utf-8-string (check string?)
  (c-parameter/immutable-asciz-utf-8-string))

(define-c-very-simple-conversion c-copied-asciz-utf-8-string (check string?)
  ((c-parameter/copied-asciz-utf-8-string))
  ((c-expression/copied-asciz-utf-8-string c-expression)))

(define-c-very-simple-conversion c-copied&freed-asciz-utf-8-string
    (check string?)
  ((c-parameter/copied&freed-asciz-utf-8-string))
  ((c-expression/copied&freed-asciz-utf-8-string c-expression)))

(define-c-very-simple-expression c-unspecific (c-expression/unspecific))
(define-c-very-simple-expression c-false (c-expression/false))
(define-c-very-simple-expression c-true (c-expression/true))

(define-syntax c-void
  (syntax-rules (C->SCHEME C-VOID)
    ((C-VOID C->SCHEME continuation (C-VOID command ...))
     (PROCESS-RESULT (C-VOID/CONTINUE continuation)
                     (C-BEGIN command ... (C-UNSPECIFIC))
                     #F))))

(define-syntax c-void/continue
  (syntax-rules ()
    ((C-VOID/CONTINUE result #F continuation)
     (SYNTACTIC-CONTINUE continuation result))))

(define-syntax c-array-pointers->vector
  (syntax-rules (C->SCHEME C-ARRAY-POINTERS->VECTOR)
    ((C-ARRAY-POINTERS->VECTOR
      C->SCHEME continuation
      (C-ARRAY-POINTERS->VECTOR type array size element expression))
     (PROCESS-EXPRESSION
      (C-ARRAY-CONTENTS/CONTINUE C-EXPRESSION/ARRAY-POINTERS->VECTOR
                                 continuation type array size element)
      expression))))

(define-syntactic-invoker c-expression/array-pointers->vector)

(define-syntax c-array-elements->vector
  (syntax-rules (C->SCHEME C-ARRAY-ELEMENTS->VECTOR)
    ((C-ARRAY-ELEMENTS->VECTOR
      C->SCHEME continuation
      (C-ARRAY-ELEMENTS->VECTOR type array size element expression))
     (PROCESS-EXPRESSION
      (C-ARRAY-CONTENTS/CONTINUE C-EXPRESSION/ARRAY-ELEMENTS->VECTOR
                                 continuation type array size element)
      expression))))

(define-syntactic-invoker c-expression/array-elements->vector)

(define-syntax c-array-pointers->list
  (syntax-rules (C->SCHEME C-ARRAY-POINTERS->LIST)
    ((C-ARRAY-POINTERS->LIST
      C->SCHEME continuation
      (C-ARRAY-POINTERS->LIST type array size element expression))
     (PROCESS-EXPRESSION
      (C-ARRAY-CONTENTS/CONTINUE C-EXPRESSION/ARRAY-POINTERS->LIST
                                 continuation type array size element)
      expression))))

(define-syntactic-invoker c-expression/array-pointers->list)

(define-syntax c-array-elements->list
  (syntax-rules (C->SCHEME C-ARRAY-ELEMENTS->LIST)
    ((C-ARRAY-ELEMENTS->LIST
      C->SCHEME continuation
      (C-ARRAY-ELEMENTS->LIST type array size element expression))
     (PROCESS-EXPRESSION
      (C-ARRAY-CONTENTS/CONTINUE C-EXPRESSION/ARRAY-ELEMENTS->LIST
                                 continuation type array size element)
      expression))))

(define-syntax c-array-contents/continue
  (syntax-rules ()
    ((C-ARRAY-CONTENTS/CONTINUE expression
                                constructor
                                continuation type array size element)
     (constructor continuation type array size element expression))))

(define-syntactic-invoker c-expression/array-elements->list)

;;;; Fixed Pairs and Vectors

(define-syntax c-cons
  (syntax-rules (C->SCHEME C-CONS)
    ((CONS C->SCHEME continuation (C-CONS car-expression cdr-expression))
     (PROCESS-EXPRESSION (C-CONS/CONTINUE continuation car-expression)
                         cdr-expression))))

(define-syntax c-cons/continue
  (syntax-rules ()
    ((C-CONS/CONTINUE cdr-expression continuation car-expression)
     (PROCESS-EXPRESSION (C-CONS/FINISH cdr-expression continuation)
                         car-expression))))

(define-syntax c-cons/finish
  (syntax-rules ()
    ((C-CONS/FINISH car-expression cdr-expression continuation)
     (C-EXPRESSION/CONS continuation car-expression cdr-expression))))

;;; Already defined above.

;(define-syntactic-invoker c-expression/cons)

(define-syntax c-vector
  (syntax-rules (C->SCHEME C-VECTOR)
    ((C-VECTOR C->SCHEME continuation
               (C-VECTOR element-expression ...))
     (C-VECTOR/LOOP continuation (element-expression ...) ()))))

(define-syntax c-vector/loop
  (syntax-rules ()
    ((C-VECTOR/LOOP continuation () elements*)
     (SYNTACTIC-REVERSE (C-VECTOR/FINISH continuation) elements*))
    ((C-VECTOR/LOOP continuation (element . elements) elements*)
     (PROCESS-EXPRESSION
      (C-VECTOR/CONTINUE continuation elements elements*)
      element))))

(define-syntax c-vector/continue
  (syntax-rules ()
    ((C-VECTOR/CONTINUE element* continuation elements elements*)
     (C-VECTOR/LOOP continuation elements (element* . elements*)))))

(define-syntax c-vector/finish
  (syntax-rules ()
    ((C-VECTOR/FINISH elements continuation)
     (C-EXPRESSION/VECTOR continuation elements))))

;;; Already defined above.

;(define-syntactic-invoker c-expression/vector)

(define-syntax c-if-false
  (syntax-rules (SCHEME->C C-IF-FALSE)
    ((C-IF-FALSE SCHEME->C continuation scheme-name c-name
                 (C-IF-FALSE substitute (macro . arguments)))
     (macro SCHEME->C
            (C-IF-FALSE/CONTINUE continuation
                                 (C-IF-FALSE substitute (macro . arguments)))
            scheme-name c-name
            (macro . arguments)))
    ((C-IF-FALSE SCHEME->C continuation scheme-name c-name
                 (C-IF-FALSE substitute macro))
     (macro SCHEME->C
            (C-IF-FALSE/CONTINUE continuation (C-IF-FALSE macro))
            scheme-name c-name
            macro))
    ((C-IF-FALSE SCHEME->C continuation scheme-name c-name use)
     (SYNTACTIC-ERROR "Invalid C parameter conversion:" use))))

(define-syntax c-if-false/continue
  (syntax-rules ()
    ((C-IF-FALSE/CONTINUE ((expression c-parameter))
                          continuation substitute original)
     (C-PARAMETER/IF-FALSE
      (C-IF-FALSE/FINISH continuation expression)
      substitute
      c-parameter))

    ((C-IF-FALSE/CONTINUE expressions&parameters
                          continuation substitute original)
     (SYNTACTIC-ERROR "Invalid C parameter conversion:" original))))

(define-syntax c-if-false/finish
  (syntax-rules ()
    ((C-IF-FALSE/FINISH c-parameter continuation expression)
     (SYNTACTIC-CONTINUE continuation ((expression c-parameter))))))

(define-syntactic-invoker c-parameter/if-false)

;;;; Handles, Byte Vectors, and Aliens

(define-c-very-simple-parameter c-handle (check handle?)
  (c-parameter/handle))

(define-c-very-simple-parameter c-alien-handle (check handle?)
  (c-parameter/alien-handle c-type))

(define-c-very-simple-parameter c-shared-byte-vector (check byte-vector?)
  (c-parameter/shared-byte-vector c-name length-name))

(define-c-very-simple-parameter c-immutable-byte-vector (check byte-vector?)
  (c-parameter/immutable-byte-vector c-name length-name))

(define-c-very-simple-conversion c-copied-byte-vector (check byte-vector?)
  ((c-parameter/copied-byte-vector c-name length-name))
  ((c-expression/copied-byte-vector c-expression c-offset c-size)))

(define-c-very-simple-conversion c-copied&freed-byte-vector
    (check byte-vector?)
  ((c-parameter/copied-byte-vector c-name length-name))
  ((c-expression/copied-byte-vector c-expression c-offset c-size)))

;;; I can never remember why alien pointers exist.

(define-c-very-simple-conversion c-alien-pointer (check byte-vector?)
  ((c-parameter/alien-pointer c-type))
  ((c-expression/alien-pointer c-type c-expression)))

(define-c-very-simple-conversion c-alien (check byte-vector?)
  ((c-parameter/alien c-type))
  ((c-expression/alien c-type c-expression)))

(define-syntax define-c-alien-conversion
  (syntax-rules ()
    ((DEFINE-C-ALIEN-CONVERSION name type)
     (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 (BYTE-VECTOR? ?SCHEME-NAME)
                                ?SCHEME-NAME
                                (ERROR "Invalid argument:"
                                       ?SCHEME-NAME
                                       '?SCHEME-NAME))
                            C-PARAMETER/ALIEN ?C-NAME type))

         ((name SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME ?USE)
          (SYNTACTIC-ERROR "Invalid C parameter conversion:" ?USE))

         ((name C->SCHEME ?CONTINUATION (name ?EXPRESSION))
          (SIMPLE-EXPRESSION ?CONTINUATION
                             C-EXPRESSION/ALIEN type ?EXPRESSION))

         ((name C->SCHEME ?CONTINUATION ?USE)
          (SYNTACTIC-ERROR "Invalid C expression conversion:" ?USE)))))))

(define-syntax define-c-wrapped-alien-parameter
  (syntax-rules ()
    ((DEFINE-C-WRAPPED-ALIEN-PARAMETER name type predicate accessor)
     (%DEFINE-C-WRAPPED-ALIEN-PARAMETER C-PARAMETER/ALIEN name
       type predicate accessor))
    ((DEFINE-C-WRAPPED-ALIEN-PARAMETER alien pointer
       type predicate accessor)
     (BEGIN
       (DEFINE-C-WRAPPED-ALIEN-PARAMETER alien type predicate accessor)
       (%DEFINE-C-WRAPPED-ALIEN-PARAMETER C-PARAMETER/ALIEN-POINTER pointer
         type predicate accessor)))))

(define-syntax %define-c-wrapped-alien-parameter
  (syntax-rules ()
    ((%DEFINE-C-WRAPPED-ALIEN-PARAMETER constructor name
       type predicate accessor)
     (DEFINE-SYNTAX name
       (SYNTAX-RULES (SCHEME->C)
         ((name SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME name)
          (SIMPLE-PARAMETER ?CONTINUATION
                            ?SCHEME-NAME
                            (IF (predicate ?SCHEME-NAME)
                                (accessor ?SCHEME-NAME)
                                (ERROR "Invalid argument:"
                                       ?SCHEME-NAME
                                       '?SCHEME-NAME))
                            constructor ?C-NAME type))

         ((name SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME ?USE)
          (SYNTACTIC-ERROR "Invalid C parameter conversion:" ?USE)))))))

;;;; Constant Enumerations

(define-syntax define-c-constant-enumeration
  (syntax-rules ()
    ((DEFINE-C-CONSTANT-ENUMERATION name type (enumerand-name enumerand) ...)
     (%DEFINE-C-CONSTANT-ENUMERATION name type
       (enumerand-name enumerand)
       ...))))

(define-syntax %define-c-constant-enumeration
  (lambda (form rename compare)
    (let ((name (desyntaxify (cadr form)))
          (dispatcher-name (cadr form))
          (type (caddr form))
          (enumerand-names (map car (cdddr form)))
          (enumerands (map cadr (cdddr form))))
      (define (make-name . components)
        (string->symbol (apply string-append (map symbol->string components))))
      (let ((rtd-name (make-name ': name))
            (predicate-name (make-name name '?))
            (vector-name (make-name name '- 'VECTOR))
            (enumerand->name (make-name name '- '> 'NAME))
            (enumerand->index (make-name name '- '> 'INDEX))
            (available?-name (make-name name '- 'AVAILABLE?))
            (conversion (make-name 'C '- name))
            (%begin (rename 'BEGIN))
            (%define-enumerated-type (rename 'DEFINE-ENUMERATED-TYPE))
            (%define-c-constant-enumeration/generate
             (rename 'DEFINE-C-CONSTANT-ENUMERATION/GENERATE))
            (%define-c-constant-enumerand-conversion
             (rename 'DEFINE-C-CONSTANT-ENUMERAND-CONVERSION)))
        `(,%begin
           (,%define-enumerated-type ,dispatcher-name ,rtd-name ,predicate-name
             ,vector-name ,enumerand->name ,enumerand->index
             ,enumerand-names)
           (,%define-c-constant-enumeration/generate ,name ,type ,vector-name
             ,enumerands)
           (,%define-c-constant-enumerand-conversion ,conversion ,name ,type
             ,dispatcher-name ,predicate-name ,enumerand->index))))))

(define-syntax define-c-constant-enumerand-conversion
  (syntax-rules ()
    ((DEFINE-C-CONSTANT-ENUMERAND-CONVERSION conversion name type
       dispatcher predicate enumerand->index)
     (DEFINE-SYNTAX conversion
       (SYNTAX-RULES (SCHEME->C C->SCHEME conversion)
         ((conversion ?ENUMERAND-NAME) (dispatcher ?ENUMERAND-NAME))
         ((conversion SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME conversion)
          (SIMPLE-PARAMETER ?CONTINUATION
                            ?SCHEME-NAME
                            (IF (predicate ?SCHEME-NAME)
                                (enumerand->index ?SCHEME-NAME)
                                (ERROR "Invalid argument:" ?SCHEME-NAME))
                            C-PARAMETER/CONSTANT-ENUMERAND ?C-NAME type name))
         ((conversion SCHEME->C ?CONTINUATION ?SCHEME-NAME ?C-NAME ?USE)
          (SYNTACTIC-ERROR "Invalid C parameter conversion:" ?USE))
         ((conversion C->SCHEME ?CONTINUATION (conversion ?C-EXPRESSION))
          (SIMPLE-EXPRESSION ?CONTINUATION
                             C-EXPRESSION/CONSTANT-ENUMERAND
                             type name ?C-EXPRESSION))
         ((conversion C->SCHEME ?CONTINUATION ?USE)
          (SYNTACTIC-ERROR "Invalid C result conversion:" ?USE)))))))

(define-syntactic-invoker c-parameter/constant-enumerand)
(define-syntactic-invoker c-expression/constant-enumerand)

(define-syntax define-c-constant-enumeration/generate
  (syntax-rules ()
    ((DEFINE-C-CONSTANT-ENUMERATION/GENERATE name type vector-name
       enumerands)
     (C-STUB-BINDING-NAME
      (DEFINE-C-CONSTANT-ENUMERATION/CONTINUE name type vector-name enumerands)
      vector-name))))

(define-syntax define-c-constant-enumeration/continue
  (syntax-rules ()
    ((DEFINE-C-CONSTANT-ENUMERATION/CONTINUE binding-name name type vector
       enumerands)
     (BEGIN
       (DEFINE-EXPORTED-BINDING binding-name vector)
       (PROCESS-CONSTANT-ENUMERANDS
        (DEFINE-C-CONSTANT-ENUMERATION/FINISH name type vector binding-name)
        enumerands)))))

(define-syntax define-c-constant-enumeration/finish
  (syntax-rules ()
    ((DEFINE-C-CONSTANT-ENUMERATION/FINISH enumerands
       name type vector binding-name)
     (C-STUB
      (C-STUB/CONSTANT-ENUMERATION name type vector binding-name
                                   enumerands)))))

(define-syntactic-invoker c-stub/constant-enumeration)

(define-syntax process-constant-enumerands
  (syntax-rules ()
    ((PROCESS-CONSTANT-ENUMERANDS continuation enumerands)
     (PROCESS-CONSTANT-ENUMERANDS continuation enumerands ()))

    ((PROCESS-CONSTANT-ENUMERANDS continuation
                                  (enumerand . enumerands)
                                  enumerands*)
     (PROCESS-CONSTANT-ENUMERAND
      (PROCESS-CONSTANT-ENUMERANDS/CONTINUE continuation
                                            enumerands
                                            enumerands*)
      enumerand))

    ((PROCESS-CONSTANT-ENUMERANDS continuation () enumerands*)
     (SYNTACTIC-REVERSE continuation enumerands*))))

(define-syntax process-constant-enumerands/continue
  (syntax-rules ()
    ((PROCESS-CONSTANT-ENUMERANDS/CONTINUE enumerand
                                           continuation
                                           enumerands
                                           enumerands*)
     (PROCESS-CONSTANT-ENUMERANDS continuation
                                  enumerands
                                  (enumerand . enumerands*)))))

(define-syntax process-constant-enumerand
  (syntax-rules (EXPRESSION IF OR)
    ((PROCESS-CONSTANT-ENUMERAND continuation enumerand)
     (STUB-FORMAT:UNAVAILABLE-ENUMERAND
      (PROCESS-CONSTANT-ENUMERAND/ALTERNATIVE continuation enumerand)))

    ((PROCESS-CONSTANT-ENUMERAND continuation
                                 (EXPRESSION c-expression)
                                 alternative)
     (STUB-FORMAT:AVAILABLE-ENUMERAND continuation c-expression))

    ((PROCESS-CONSTANT-ENUMERAND continuation
                                 (IF condition c-expression)
                                 alternative)
     (STUB-FORMAT:CONDITIONAL-ENUMERAND continuation
                                        condition c-expression alternative))

    ((PROCESS-CONSTANT-ENUMERAND continuation (OR enumerand) alternative)
     (PROCESS-CONSTANT-ENUMERAND continuation enumerand alternative))

    ((PROCESS-CONSTANT-ENUMERAND continuation
                                 (OR enumerand0 enumerand1+ ...)
                                 alternative)
     (PROCESS-CONSTANT-ENUMERAND
      (PROCESS-CONSTANT-ENUMERAND/ALTERNATIVE continuation enumerand0)
      (OR enumerand1+ ...)))

    ((PROCESS-CONSTANT-ENUMERAND continuation constant alternative)
     (STUB-FORMAT:CONSTANT-ENUMERAND continuation constant alternative))))

(define-syntactic-invoker stub-format:available-enumerand)
(define-syntactic-invoker stub-format:unavailable-enumerand)
(define-syntactic-invoker stub-format:conditional-enumerand)
(define-syntactic-invoker stub-format:constant-enumerand)

(define-syntax process-constant-enumerand/alternative
  (syntax-rules ()
    ((PROCESS-CONSTANT-ENUMERAND/ALTERNATIVE alternative
                                             continuation
                                             enumerand)
     (PROCESS-CONSTANT-ENUMERAND continuation enumerand alternative))))

;;;; Syntactic Utilities

(define-syntax syntactic-reverse
  (lambda (form rename compare)
    (let ((macro (caadr form))
          (environment (cdadr form))
          (list (caddr form)))
      `(,macro ,(reverse list) . ,environment))))

;; (define-syntax syntactic-reverse
;;   (syntax-rules ()
;;     ((SYNTACTIC-REVERSE continuation list)
;;      (SYNTACTIC-REVERSE continuation list ()))

;;     ((SYNTACTIC-REVERSE continuation (item . ins) outs)
;;      (SYNTACTIC-REVERSE continuation ins (item . outs)))

;;     ((SYNTACTIC-REVERSE continuation () outs)
;;      (SYNTACTIC-CONTINUE continuation outs))))

(define-syntax syntactic-map
  (syntax-rules ()
    ((SYNTACTIC-MAP continuation procedure list)
     (SYNTACTIC-MAP continuation procedure list ()))
    ((SYNTACTIC-MAP continuation procedure (element . list) list*)
     (procedure (SYNTACTIC-MAP/CONTINUE continuation procedure list list*)
                element))
    ((SYNTACTIC-MAP continuation procedure () list*)
     (SYNTACTIC-REVERSE continuation list*))))

(define-syntax syntactic-map/continue
  (syntax-rules ()
    ((SYNTACTIC-MAP/CONTINUE element* continuation procedure list list*)
     (SYNTACTIC-MAP continuation procedure list (element* . list*)))))

(define-syntax syntactic-continue
  (syntax-rules ()
    ((SYNTACTIC-CONTINUE (macro . environment) argument ...)
     (macro argument ... . environment))))

;;;; Error Reporting

;;; Use this definition of SYNTACTIC-ERROR if your favourite Scheme
;;; doesn't have one already.  Note that this is distinct from a
;;; SYNTAX-ERROR procedure, since it must signal a compile-time error.

(define-syntax syntactic-error (syntax-rules ()))

(define-syntax syntactic-name?
  (syntax-rules ()
    ((SYNTACTIC-NAME? (a . d) if-yes if-no) if-no)
    ((SYNTACTIC-NAME? #(v ...) if-yes if-no) if-no)
    ((SYNTACTIC-NAME? datum if-yes if-no)
     (LET-SYNTAX ((TEST-ELLIPSIS
                   (SYNTAX-RULES ()
                     ((TEST-ELLIPSIS (VARIABLE datum) YES NO) YES)
                     ((TEST-ELLIPSIS OTHERWISE YES NO) NO))))
       (TEST-ELLIPSIS (MAGICAL MYSTERY LIST)
                      if-yes
                      (LET-SYNTAX ((TEST-NAME
                                    (SYNTAX-RULES ()
                                      ((TEST-NAME datum YES NO) YES)
                                      ((TEST-NAME OTHERWISE YES NO) NO))))
                        (TEST-NAME MAGICAL-MYSTERY-SYMBOL if-yes if-no)))))))

(define-syntax syntactic-ellipsis?
  (syntax-rules ()
    ((SYNTACTIC-ELLIPSIS? (a . d) if-yes if-no) if-no)
    ((SYNTACTIC-ELLIPSIS? #(v ...) if-yes if-no) if-no)
    ((SYNTACTIC-ELLIPSIS? datum if-yes if-no)
     (LET-SYNTAX ((TEST-ELLIPSIS
                   (SYNTAX-RULES ()
                     ((TEST-ELLIPSIS (VARIABLE datum) YES NO) YES)
                     ((TEST-ELLIPSIS OTHERWISE YES NO) NO))))
       (TEST-ELLIPSIS (MAGICAL MYSTERY LIST) if-yes if-no)))))

(define-syntax syntactic-error-if-not-name
  (syntax-rules ()
    ((SYNTACTIC-ERROR-IF-NOT-NAME name (message irritant ...) if-ok)
     (SYNTACTIC-NAME? name
       if-ok
       (SYNTACTIC-ERROR message irritant ...)))))

(define-syntax syntactic-error-if-not-names
  (syntax-rules ()
    ((SYNTACTIC-ERROR-IF-NOT-NAMES () (message irritant ...) if-ok)
     if-ok)
    ((SYNTACTIC-ERROR-IF-NOT-NAMES (name0 name1+ ...) (message irritant ...)
       if-ok)
     (SYNTACTIC-ERROR-IF-NOT-NAME name0 (message irritant ...)
       (SYNTACTIC-ERROR-IF-NOT-NAMES (name1+ ...) (message irritant ...)
         if-ok)))))

(define-syntax syntactic-error-if-not-bvl
  (syntax-rules ()
    ((SYNTACTIC-ERROR-IF-NOT-BVL bvl (message irritant ...) if-ok)
     if-ok)))

(define-syntax syntactic-error-if-not-bvls
  (syntax-rules ()
    ((SYNTACTIC-ERROR-IF-NOT-BVLS (bvl ...) (message irritant ...) if-ok)
     if-ok)))