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

;;;; C Stub Generator for Scheme
;;;; Code Generation (Scheme48)

;;; 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-record-type <c-stub>
    (make-c-stub name output-port initializers)
    c-stub?
  (name c-stub.name)
  (output-port c-stub.output-port)
  (initializers c-stub.initializers set-c-stub.initializers!))

(define (open-c-stub name . pathname)
  pathname                              ;ignore
  (let ((stub
         (make-c-stub
          name
          (open-output-file (translate (c-stub-source-pathname name)))
          '())))
    (initialize-c-stub stub)
    stub))

(define (close-c-stub stub)
  (finalize-c-stub stub)
  (close-output-port (c-stub.output-port stub)))

(define (initialize-c-stub stub)
  (for-each (lambda (format)
              (c-stub-write stub format))
            (c-stub-prologue stub)))

(define (finalize-c-stub stub)
  (for-each (lambda (format)
              (c-stub-write stub format))
            (c-stub-epilogue stub)))

(define (c-stub-header-pathname name)
  (string-append "=c-stub-header/" name ".h"))

(define (c-stub-source-pathname name)
  (string-append "=c-stub-source/" name ".c"))

(define (c-stub-object-pathname name)
  (string-append "=c-stub-object/" name ".o"))

(define (c-stub-library-pathname name)
  (string-append "=c-stub-library/" name ".so"))

(define (c-stub.compiler-flags stub)
  `("-g" "-Wall"
    "-I/usr/local/include/scheme48-1.3/"
    ,(string-append "-I" (translate "=c-stub-header/"))))

(define (c-stub.linker-flags stub)
  '("-g" "-Wall" "-bundle" "-undefined" "dynamic_lookup"))

(define (c-stub.objects stub)
  `(,(translate (c-stub-object-pathname (c-stub.name stub)))
    ,(translate "=c-stub-header/s48-stubber.o")))

(define (compile-c-stub stub)
  (let ((name (c-stub.name stub)))
    (run-program "/usr/bin/gcc"
      `("gcc" ,@(c-stub.compiler-flags stub)
        "-o" ,(translate (c-stub-object-pathname name))
        "-c" ,(translate (c-stub-source-pathname name)))
      '())))

(define (link-c-stub stub)
  (let ((library-pathname (c-stub-library-pathname (c-stub.name stub))))
    (run-program "/usr/bin/gcc"
      `("gcc" ,@(c-stub.linker-flags stub)
        "-o" ,(translate library-pathname)
        ,@(c-stub.objects stub))
      '())
    library-pathname))

(define (c-stub-prologue stub)
  stub                                  ;ignore
  (list (format:sequence
         (stub-format:comment "This file was generated by magic.   ")
         (stub-format:comment "Stand back.  Do not modify.         ")
         (format:line-break))
        (cpp-format:include (cpp-format:local-header "s48-stubber.h"))))

(define (c-stub-epilogue stub)
  (list (c-format:function "void" "s48_on_load" (list "void")
          (format:list (reverse (c-stub.initializers stub))))
        (c-format:function "void" "s48_on_reload" (list "void")
          (c-format:statement (c-format:call "s48_on_load" '())))))

(define (c-stub-write stub format)
  (format-to-port
   (c-stub.output-port stub)
   (format-options (format-with-line-tracking 0 0)
                   (format-with-indentation 0))
   format))

(define (c-stub-emit stub emission)
  (emission stub))

(define (declaration-emission . formats)
  (lambda (stub)
    (c-stub-write stub (format:list formats))))

(define (initialization-emission . formats)
  (lambda (stub)
    (set-c-stub.initializers!
     stub
     (append-reverse formats (c-stub.initializers stub)))))

(define (compound-emission . emissions)
  (lambda (stub)
    (for-each (lambda (emission) (emission stub))
              emissions)))

(define (c-stub/include pathname)
  (declaration-emission
   (cpp-format:include (cpp-format:local-header pathname))))

(define (c-stub/system-include pathname)
  (declaration-emission
   (cpp-format:include (cpp-format:system-header pathname))))

(define (c-stub/declare . lines)
  (declaration-emission
   (format:list (map format:line lines))))

(define (c-stub/initialize . lines)
  (initialization-emission
   (format:list (map format:line lines))))

;;; Is this page supposed to have anything more on it?  For that
;;; matter, what good are `variables' like this?

;;; We don't use hybrid locatives here because we don't need to concern
;;; ourselves with GC protection except for reification.  This is
;;; because `s48_define_exported_binding' takes only one unsafe
;;; argument, so its evaluation cannot destroy other arguments.

(define (c-stub/variable name expression)
  (initialization-emission
   (expression
    (let ((assign (lambda (expression)
                    (c-format:s48-export-binding name expression))))
      (make-locative assign
                     assign
                     (lambda (initializer generator)
                       (c-format:call-with-temporary-s48-value "value"
                         (lambda (value)
                           (format:sequence
                            (c-format:assign-statement value initializer)
                            (generator value)
                            (assign value))))))))))

(define (mangle-name name)
  (list->string
   (apply append
          (map (lambda (char)
                 (cond ((char=? #\- char) '(#\_))
                       ((char=? #\? char) '(#\P))
                       ((or (char-alphabetic? char)
                            (char-numeric? char))
                        (list char))
                       (else
                        (string->list
                         (string-append "_0x"
                                        (number->string (char->integer char)
                                                        #x10)
                                        "_")))))
               (string->list
                (if (string? name)
                    name
                    (symbol->string name)))))))

(define (maybe-mangle-name name)
  (if (symbol? name)
      (mangle-name name)
      name))

(define (c-stub/procedure name binding-name parameters declarations result)
  (let ((c-name (string-append "s48_stub__" (maybe-mangle-name name))))
    (compound-emission
     (initialization-emission
      (c-format:s48-export-function binding-name c-name))
     (declaration-emission
      (c-format:call-with-temporary-name "result"
        (lambda (result-name)
          (let ((protected
                 (cons result-name
                       (append-map c-parameter.protected parameters))))
            (c-format:function (c-format:static (c-format:s48-value-type))
                c-name
                (map c-format:s48-parameter (map c-parameter.name parameters))
              (format:sequence
               (stub-format:comment "Declarations")
               (c-format:s48-declare-unspecific result-name)
               (format:list (filter-map c-parameter.declaration parameters))
               (format:list (map format:indented-line declarations))
               (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")
               (format:list (filter-map c-parameter.initialization parameters))
               (format:blank-line)
               (stub-format:comment "Body")
               (result (variable-locative result-name))
               (format:blank-line)
               (stub-format:comment "Finalization")
               (format:list (filter-map c-parameter.finalization parameters))
               (c-format:s48-gc-unprotect)
               (format:blank-line)
               (c-format:return result-name))))))))))

(define (format:blank-line)
  (format:sequence (format:line-start)
                   (format:line-break)))

(define-format (stub-format:enumeration-map name)
  (format:sequence "s48_enumeration__" (mangle-name name)))

(define-format (stub-format:enumeration/scheme->c enumeration)
  (format:sequence "s48_extract_" (mangle-name enumeration)))

(define-format (stub-format:enumeration/c->scheme enumeration)
  (format:sequence "s48_enter_" (mangle-name enumeration)))

(define (c-parameter/constant-enumerand name type enumeration)
  (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 type c-name)
     (c-format:if
         (c-format:not
          (c-format:call (stub-format:enumeration/scheme->c enumeration)
                         (list s48-name (c-format:address-of c-name))))
       (c-format:call-statement
        "s48_raise_string_os_error"
        (list "\"Enumerand not available on this system.\"")))
     #f)))

(define (c-expression/constant-enumerand type enumeration c-expression)
  (lambda (locative)
    (reify-locative locative (c-format:s48-unspecific)
      (lambda (location)
        (c-format:if
            (c-format:not
             (c-format:call (stub-format:enumeration/c->scheme enumeration)
                            (list c-expression
                                  (c-format:address-of location))))
          (c-format:call-statement
           "s48_raise_string_os_error"
           (list "\"Unrecognized enumerand value.\"")))))))

(define-format (stub-format:unavailable-enumerand)
  (format:indented-line "{ 0 }"))

(define-format (stub-format:available-enumerand expression)
  (format:indented-line "{ 1, " expression " }"))

(define-format (stub-format:constant-enumerand constant alternative)
  (cpp-format:ifdef constant
    (stub-format:available-enumerand constant)
    (cpp-format:else)
    alternative))

(define-format (stub-format:conditional-enumerand condition
                                                  consequent
                                                  alternative)
  (cpp-format:if condition consequent (cpp-format:else) alternative))

(define (c-expression/constant-enumerand-available? enumeration index count)
  (c-expression/boolean
   "char"                               ;++ Lose!
   (c-format:and
    (c-format:<= "0" index)
    (c-format:< index count)
    (c-format:field
     (c-format:array-ref (stub-format:enumeration-map enumeration) index)
     "available_p"))))

(define (c-stub/constant-enumeration name type vector binding-name enumerands)
  (let ((binding-variable
         (stub-format:binding-variable (maybe-mangle-name vector))))
    (compound-emission
     (initialization-emission
      (c-format:s48-gc-protect-global binding-variable)
      (c-format:s48-import-binding binding-name
                                   (variable-locative binding-variable)))
     (declaration-emission
      (format:line-break)
      (c-format:declare (c-format:static (c-format:s48-value-type))
                        (c-format:initialize binding-variable
                                             (c-format:s48-false)))
      (format:line-break)
      (stub-format:constant-enumeration-map name type enumerands)
      (format:line-break)
      (stub-format:constant-enumerand-mappers name
                                              type
                                              binding-variable
                                              (length enumerands))))))

(define-format (stub-format:constant-enumeration-map name type enumerands)
  (c-format:declare
   (c-format:static
    (c-format:const
     (c-format:struct-type
      (c-format:block (c-format:declare "char" "available_p")
                      (c-format:declare type "value")))))
   (c-format:initialize
    (c-format:array (stub-format:enumeration-map name) "")
    (format:sequence
     (format:line-break)
     (format:join "{" (format:sequence "," (format:soft-break)) "}"
       (map (lambda (enumerand)
              (format:with-alignment (format:with-indentation +1 enumerand)))
            enumerands))))))

(define-format (stub-format:constant-enumerand-mappers name type binding count)
  (format:sequence
   (format:line
    (cpp-format:call "SCHEME_DEFINE_ENUMERAND_SCHEME_TO_C"
                     (list (stub-format:enumeration/scheme->c name)
                           type
                           (stub-format:enumeration-map name))))
   (format:line
    (cpp-format:call "SCHEME_DEFINE_ENUMERAND_C_TO_SCHEME"
                     (list (stub-format:enumeration/c->scheme name)
                           type
                           (stub-format:enumeration-map name)
                           binding
                           count)))))

;;;; Scheme48 C Utilities

(define-format (stub-format:comment . text)
  (format:indented-line (c-format:comment (format:list text))))

(define-format (stub-format:binding-variable name)
  (format:sequence "s48_binding__" name))

(define-format (c-format:s48-value-type)  "s48_value")
(define-format (c-format:s48-true)        "S48_TRUE")
(define-format (c-format:s48-false)       "S48_FALSE")
(define-format (c-format:s48-unspecific)  "S48_UNSPECIFIC")

(define-format (c-format:s48-parameter name)
  (c-format:parameter (c-format:s48-value-type) name))

(define-format (c-format:s48-declare name . names)
  (c-format:s48-declare:list (cons name names)))

(define-format (c-format:s48-declare:list names)
  (c-format:declare:list (c-format:s48-value-type) names))

(define-format (c-format:s48-declare-false name . names)
  (c-format:s48-declare-false:list (cons name names)))

(define-format (c-format:s48-declare-false:list names)
  (c-format:s48-declare:list
   (map (lambda (name)
          (c-format:initialize name (c-format:s48-false)))
        names)))

(define-format (c-format:s48-declare-unspecific name . names)
  (c-format:s48-declare-unspecific:list (cons name names)))

(define-format (c-format:s48-declare-unspecific:list names)
  (c-format:s48-declare:list
   (map (lambda (name)
          (c-format:initialize name (c-format:s48-unspecific)))
        names)))

(define-format (c-format:<= a b)         ;++ FIX
  (format:sequence a (format:soft-break) "<=" (format:soft-break) b))

(define-format (c-format:< a b)         ;++ FIX
  (format:sequence a (format:soft-break) "<" (format:soft-break) b))

;++ Argh.

(define-format (c-format:post-increment location)
  (format:sequence location "++"))

(define-format (c-format:post-decrement location)
  (format:sequence location "--"))

(define-format (c-format:s48-export-binding name expression)
  (c-format:call-statement "s48_define_exported_binding"
                           (list (format:bracketed #\" #\" name)
                                 expression)))

(define-format (c-format:s48-export-function binding function)
  (c-format:s48-export-binding
   binding
   (c-format:call "s48_enter_pointer" (list function))))

(define-format (c-format:s48-import-binding name locative)
  (assign-locative locative
                   (c-format:call "s48_get_imported_binding"
                                  (list (format:bracketed #\" #\" name)))))

(define-format (c-format:s48-gc-protect-global location)
  (c-format:statement
   (cpp-format:call "S48_GC_PROTECT_GLOBAL" (list location))))

(define-format (c-format:s48-declare-gc-protect n)
  (c-format:statement
   (cpp-format:call "S48_DECLARE_GC_PROTECT" (list (format:number n)))))

(define-format (c-format:s48-gc-protect locations)
  (c-format:statement
   (cpp-format:call (string-append "S48_GC_PROTECT_"
                                   (number->string (length locations) #d10))
                    locations)))

(define-format (c-format:s48-gc-unprotect)
  (c-format:statement (cpp-format:call "S48_GC_UNPROTECT" '())))

(define-format (c-format:call-with-temporary-s48-value name receiver)
  (c-format:call-with-temporary-name name
    (lambda (temporary-name)
      (c-format:block
       (c-format:s48-declare-unspecific temporary-name)
       (c-format:s48-declare-gc-protect 1)
       (c-format:s48-gc-protect (list temporary-name))
       (receiver temporary-name)
       (c-format:s48-gc-unprotect)))))

(define-syntax collect-format           ;++ fix
  (syntax-rules ()
    ((COLLECT-FORMAT clause0 clause1+ ...)
     (FORMAT:LIST (COLLECT-LIST clause0 clause1+ ...)))))

(define-record-type <c-parameter>
    (make-c-parameter name
                      internal-name
                      protected
                      declaration
                      initialization
                      finalization)
    c-parameter?
  (name c-parameter.name)
  (internal-name c-parameter.internal-name)
  (protected c-parameter.protected)
  (declaration c-parameter.declaration)
  (initialization c-parameter.initialization)
  (finalization c-parameter.finalization))

(define (c-parameter/scheme name)
  (let ((c-name (maybe-mangle-name name)))
    (make-c-parameter c-name c-name (list c-name) #f #f #f)))

(define (simple-c-parameter name type extractor . finalizer)
  (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 type c-name)
     (c-format:assign-statement c-name
                                (c-format:call extractor (list s48-name)))
     (if (and (pair? finalizer)
              (car finalizer))
         (c-format:call-statement (car finalizer)
                                  (cons c-name (cdr finalizer)))
         #f))))

(define (alien-c-parameter name type argument extractor)
  (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 type c-name)
     (c-format:assign-statement
      c-name
      (c-format:call extractor (list s48-name argument)))
     #f)))

;++ Finalizing is currently broken due to non-local error exits.

(define (sized-c-parameter name type c-name length-name converter . finalizer)
  (let ((name (maybe-mangle-name name))
        (s48-name (format:sequence c-name "_s48")))
    (make-c-parameter
     s48-name
     c-name
     (list s48-name)
     (format:sequence (c-format:declare type c-name)
                      (c-format:declare "size_t" length-name))
     (converter s48-name)
     (if (and (pair? finalizer)
              (car finalizer))
         (c-format:call-statement (car finalizer)
                                  (cons c-name (cdr finalizer)))
         #f))))

;;;; Simple Parameters

(define (c-parameter/boolean name type)
  (simple-c-parameter name type "S48_EXTRACT_BOOLEAN"))

(define (c-parameter/char name type)
  (simple-c-parameter name type "s48_extract_char"))

(define (c-parameter/integral name type)
  (simple-c-parameter name type "s48_extract_integer"))

(define (c-parameter/signed name type)
  (simple-c-parameter name type "s48_extract_signed_integer"))

(define (c-parameter/unsigned name type)
  (simple-c-parameter name type "s48_extract_unsigned_integer"))

(define (c-parameter/floating-point name type)
  (simple-c-parameter name type "s48_extract_double"))

(define (c-parameter/shared-asciz-string name)
  (simple-c-parameter name "char *" "s48_extract_string"))

(define (c-parameter/immutable-asciz-string name)
  (simple-c-parameter name "const char *" "s48_extract_string"))

(define (c-parameter/copied-asciz-string name)
  (simple-c-parameter name "char *" "s48_extract_and_copy_string"))

(define (c-parameter/copied&freed-asciz-string name)
  (simple-c-parameter name "char *" "s48_extract_and_copy_string" "free"))

;++ UTF-8 lossage!

(define c-parameter/shared-asciz-utf-8-string c-parameter/shared-asciz-string)
(define c-parameter/immutable-asciz-utf-8-string
  c-parameter/immutable-asciz-string)
(define c-parameter/copied-asciz-utf-8-string c-parameter/copied-asciz-string)
(define c-parameter/copied&freed-asciz-utf-8-string
  c-parameter/copied&freed-asciz-string)

(define (c-parameter/alien-pointer name type)
  (alien-c-parameter name (c-format:pointer-type type) type
                     "S48_EXTRACT_VALUE_POINTER"))

(define (c-parameter/alien name type)
  (alien-c-parameter name type type "S48_EXTRACT_VALUE"))

(define (c-parameter/handle name)
  (c-parameter/scheme name))

(define (c-parameter/alien-handle name type)
  (alien-c-parameter name type type "S48_ALIEN_HANDLE_POINTER"))

;;;; Byte Vector Parameters

(define (shared-sized-c-parameter name type c-name length-name extractor
                                  length)
  (sized-c-parameter name type c-name length-name
    (lambda (s48-name)
      (format:sequence
       (c-format:assign-statement
        c-name
        (c-format:cast type (c-format:call extractor (list s48-name))))
       (c-format:assign-statement
        length-name
        (c-format:call length (list s48-name)))))))

(define (immutable-sized-c-parameter name type c-name length-name extractor
                                     length)
  (shared-sized-c-parameter name
                            (c-format:const type)
                            c-name
                            length-name
                            extractor
                            length))

(define (copied-sized-c-parameter name type c-name length-name extractor
                                  . finalizer)
  (apply sized-c-parameter name type c-name length-name
         (lambda (s48-name)
           (c-format:assign-statement
            c-name
            (c-format:cast
             type
             (c-format:call extractor
                            (list s48-name
                                  (c-format:address-of length-name))))))
         finalizer))

(define (copied&freed-sized-c-parameter name type c-name length-name extractor)
  (copied-sized-c-parameter name c-name length-name extractor "free"))

(define (c-parameter/shared-byte-vector name c-name length-name)
  (shared-sized-c-parameter name "char *" c-name length-name
                            "s48_extract_byte_vector"
                            "S48_BYTE_VECTOR_LENGTH"))

(define (c-parameter/immutable-byte-vector name c-name length-name)
  (immutable-sized-c-parameter name "char *" c-name length-name
                               "s48_extract_byte_vector"
                               "S48_BYTE_VECTOR_LENGTH"))

(define (c-parameter/copied-byte-vector name c-name length-name)
  (copied-sized-c-parameter name "char *" c-name length-name
                            "s48_extract_and_copy_byte_vector"))

(define (c-parameter/copied&freed-byte-vector name c-name length-name)
  (copied&freed-sized-c-parameter name "char *" c-name length-name
                                  "s48_extract_and_copy_byte_vector"))

;++ Will this work?

(define (c-parameter/if-false substitute parameter)
  (let ((test
         (c-format:call "S48_FALSE_P" (list (c-parameter.name parameter)))))
   (make-c-parameter
    (c-parameter.name parameter)
    (c-parameter.internal-name parameter)
    (c-parameter.protected parameter)
    (c-parameter.declaration parameter)
    (format:sequence
     (c-format:if test
       (c-format:assign-statement (c-parameter.internal-name parameter)
                                  substitute))
     (cond ((c-parameter.initialization parameter)
            => (lambda (initialization)
                 (c-format:else (c-format:block initialization))))
           (else #f)))
    ;;++ THIS IS WRONG
    (cond ((c-parameter.finalization parameter)
           => (lambda (finalization)
                (c-format:if (c-format:not test)
                  (c-format:block finalization))))
          (else #f)))))

;;;; C Expressions

(define (immediate-c-expression expression)
  (lambda (locative)
    (assign-locative/immediate locative expression)))

(define (c-expression/unspecific) (immediate-c-expression "S48_UNSPECIFIC"))
(define (c-expression/true) (immediate-c-expression "S48_TRUE"))
(define (c-expression/false) (immediate-c-expression "S48_FALSE"))
(define (c-expression/null) (immediate-c-expression "S48_NULL"))

(define (converted-c-expression expression type enter)
  (lambda (locative)
    (assign-locative
     locative
     (c-format:call
      enter
      (list (c-format:cast type (c-format:parenthesis expression)))))))

(define (c-expression/boolean type expression)
  type                                  ;ignore
  (converted-c-expression expression "int" "S48_ENTER_BOOLEAN"))

(define (c-expression/char expression)
  (converted-c-expression expression "char" "s48_enter_char"))

(define (c-expression/integral type expression)
  type                                  ;ignore
  (converted-c-expression expression "long" "s48_enter_integer"))

(define (c-expression/unsigned type expression)
  type                                  ;ignore
  (converted-c-expression expression
                          "unsigned long"
                          "s48_enter_unsigned_integer"))

(define (c-expression/signed type expression)
  type                                  ;ignore
  (converted-c-expression expression
                          "signed long"
                          "s48_enter_signed_integer"))

(define (c-expression/floating-point type expression)
  type                                  ;ignore
  (converted-c-expression expression "double" "s48_enter_double"))

(define (c-expression/copied-asciz-string expression)
  (converted-c-expression expression "char *" "s48_enter_string"))

(define (c-expression/copied&freed-asciz-string expression)
  (converted-c-expression expression "char *" "s48_enter_and_free_string"))

;++ UTF-8 lossage!

(define c-expression/copied-asciz-utf-8-string
  c-expression/copied-asciz-string)

(define c-expression/copied&freed-asciz-utf-8-string
  c-expression/copied&freed-asciz-string)

(define (c-expression/alien-pointer type expression)
  type                                  ;ignore
  (converted-c-expression expression "void *" "s48_enter_pointer"))

;;;;; Aliens and Simple Sized Structures

(define (c-expression/alien type expression)
  (lambda (locative)
    (reify-locative locative (c-format:call "S48_MAKE_VALUE" (list type))
      (lambda (value)
        (c-format:call-statement
         "S48_SET_VALUE"
         (list value type (c-format:parenthesis expression)))))))

;++ This is all broken.  Lose.

(define (c-expression-with-size expression offset size type enter)
  (lambda (locative)
    (assign-locative
     locative
     (c-format:call
      enter
      (list (c-format:cast type (c-format:parenthesis expression))
            (c-format:parenthesis offset)
            (c-format:parenthesis size))))))

(define (c-expression/copied-asciz-substring expression offset size)
  (c-expression-with-size expression offset size
                          "char *" "s48_enter_asciz_substring"))

(define (c-expression/copied&freed-asciz-substring expression offset size)
  (c-expression-with-size expression offset size
                          "char *" "s48_enter_and_free_asciz_substring"))

(define c-expression/copied-asciz-utf-8-substring
  c-expression/copied-asciz-substring)

(define c-expression/copied&freed-asciz-utf-8-substring
  c-expression/copied&freed-asciz-substring)

(define (c-expression/copied-byte-vector expression offset size)
  (c-expression-with-size expression offset size
                          "char *" "s48_enter_byte_subvector"))

(define (c-expression/copied&freed-byte-vector expression offset size)
  (c-expression-with-size expression offset size
                          "char *" "s48_enter_and_free_byte_subvector"))

;;;;; Compound Control and Data Structures

(define (c-expression/sequence command expression)
  (lambda (locative)
    (format:sequence (if (string? command)
                         (format:indented-line command)
                         command)
                     (expression locative))))

(define (c-expression/conditional condition consequent alternative)
  (lambda (locative)
    (format:sequence
     (c-format:if condition (c-format:block (consequent locative)))
     (c-format:else (c-format:block (alternative locative))))))

(define (c-expression/cons car-expression cdr-expression)
  (lambda (locative)
    (reify-locative locative
        (c-format:call "s48_cons" (list "S48_UNSPECIFIC" "S48_UNSPECIFIC"))
      (lambda (pair)
        (c-format:call-with-temporary-s48-value "component"
          (lambda (temporary-location)
            (define (locative name reader writer)
              (hybrid-locative
               name
               temporary-location
               (c-format:call reader (list pair))
               (lambda (expression)
                 (c-format:call-statement writer (list pair expression)))))
           (format:sequence
            (car-expression
             (locative "car" "S48_UNSAFE_CAR" "S48_UNSAFE_SET_CAR"))
            (cdr-expression
             (locative "cdr" "S48_UNSAFE_CDR" "S48_UNSAFE_SET_CDR")))))))))

(define (c-expression/vector element-expressions)
  (lambda (locative)
    (reify-locative locative
        (c-format:call "s48_make_vector"
                       (list (length element-expressions) "S48_UNSPECIFIC"))
      (lambda (vector)
        (c-format:call-with-temporary-s48-value "element"
          (lambda (temporary-location)
            (collect-format
                ((for element-expression (in-list element-expressions))
                 (for index (up-from 0)))
              (element-expression
               (vector-locative temporary-location vector index)))))))))

;;;;; Arrays

(define (c-expression/array-pointers type array size pointer expression
                                     generator)
  (generator
   array size expression
   (lambda (index)
     (c-format:declare
      (c-format:pointer-type type)
      (c-format:initialize
       pointer
       (c-format:address-of (c-format:array-ref array index)))))))

(define (c-expression/array-elements type array size element expression
                                     generator)
  (generator
   array size expression
   (lambda (index)
     (c-format:declare
      type
      (c-format:initialize element (c-format:array-ref array index))))))

(define (c-expression/array-pointers->list type array size pointer expression)
  (c-expression/array-pointers type array size pointer expression
                               c-array->list-expression))

(define (c-expression/array-elements->list type array size pointer expression)
  (c-expression/array-elements type array size pointer expression
                               c-array->list-expression))

(define (c-expression/array-pointers->vector type array size pointer
                                             expression)
  (c-expression/array-pointers type array size pointer expression
                               c-array->vector-expression))

(define (c-expression/array-elements->vector type array size pointer
                                             expression)
  (c-expression/array-elements type array size pointer expression
                               c-array->vector-expression))

(define (c-array->list-expression array size element-expression prefix)
  (lambda (locative)
    (reify-locative locative "S48_NULL"
      (lambda (list-location)
        (stub-format:call-with-array-temporaries
          (lambda (index temporary)
            (c-format:block
             (c-format:declare "int" (c-format:initialize index size))
             (c-format:while (c-format:post-decrement index)
               (c-format:block
                ;; It's too tricky to figure out how to arrange the
                ;; temporary variable so that it is generated only if
                ;; necessary.
                (c-format:s48-declare-unspecific temporary)
                (prefix index)
                (element-expression (variable-locative temporary))
                (c-format:assign-statement
                 list-location
                 (c-format:call "s48_cons"
                                (list temporary list-location))))))))))))

(define (c-array->vector-expression array size element-expression prefix)
  (lambda (locative)
    (reify-locative locative
        (c-format:call "s48_make_vector" (list size "S48_UNSPECIFIC"))
      (lambda (vector)
        (stub-format:call-with-array-temporaries
          (lambda (index temporary)
            (c-format:block
             (c-format:declare "int" (c-format:initialize index size))
             (c-format:while (c-format:post-decrement index)
               (c-format:block
                (prefix index)
                (element-expression
                 (vector-locative temporary vector index)))))))))))

(define (vector-locative temporary vector index)
  (hybrid-locative
   "element"
   temporary
   (c-format:call "S48_UNSAFE_VECTOR_REF" (list vector index))
   (lambda (expression)
     (c-format:call-statement "S48_UNSAFE_VECTOR_SET"
                              (list vector index expression)))))

(define (stub-format:call-with-array-temporaries receiver)
  (c-format:call-with-temporary-name "index"
    (lambda (index-name)
      (c-format:call-with-temporary-s48-value "element"
        (lambda (temporary-location)
          (receiver index-name temporary-location))))))

;;;;; Arrays to Vectors

(define (c-expression/array-pointers->vector type array size
                                             pointer expression)
  (c-array->vector-expression
   array size expression
   (lambda (index)
     (c-format:declare
      (c-format:pointer-type type)
      (c-format:initialize
       pointer
       (c-format:address-of (c-format:array-ref array index)))))))

(define (c-expression/array-elements->vector type array size
                                             element expression)
  (c-array->vector-expression
   array size expression
   (lambda (index)
     (c-format:declare
      type
      (c-format:initialize element (c-format:array-ref array index))))))

;;;;; Miscellanea: Errors and Handles

(define (c-expression/out-of-memory-error)
  (lambda (locative)
    locative                            ;ignore
    (c-command/out-of-memory-error)))

(define (c-command/out-of-memory-error)
  (c-format:call-statement "s48_raise_out_of_memory_error" '()))

;; (define (c-command/set-handle handle expression)
;;   (let ((handle (maybe-mangle-name handle)))
;;     (expression
;;      (hybrid-locative
;;       "fd"
;;       #f
;;       (c-format:call "S48_UNSAFE_RECORD_REF"
;;                      (list handle handle-descriptor-offset))
;;       (lambda (expression)
;;         (c-format:call-statement "S48_UNSAFE_RECORD_SET"
;;                                  (list handle
;;                                        handle-descriptor-offset
;;                                        expression)))))))

;; (define (c-command/set-fd-handle handle expression)
;;   (c-command/set-handle handle (c-expression/integral "int" expression)))

;; (define (c-command/set-socket-handle handle expression)
;;   (c-command/set-handle handle (c-expression/integral "int" expression)))

;++ fd handles, blocking, &c.

(define (c-command/register-fd-write fd expression)
  (c-command/register-fd #f fd expression))

(define (c-command/register-fd-read fd expression)
  (c-command/register-fd #t fd expression))

(define (c-command/register-fd read? fd expression)
  (c-format:if (c-format:not
                (c-format:call "s48_add_pending_fd"
                               (list fd (if read? "PSTRUE" "PSFALSE"))))
    (c-format:call "s48_out_of_memory_error" '())))

;;;; Locatives for Expression Values

(define-record-type <locative>
    (make-locative assign assign-immediate reify)
    locative?
  (assign locative.assign)
  (assign-immediate locative.assign-immediate)
  (reify locative.reify))

(define (assign-locative locative expression)
  ((locative.assign locative) expression))

(define (assign-locative/immediate locative immediate)
  ((locative.assign-immediate locative) immediate))

(define (reify-locative locative initializer generator)
  ((locative.reify locative) initializer generator))

(define (variable-locative name)
  (make-locative (lambda (expression)
                   (c-format:assign-statement name expression))
                 (lambda (expression)
                   (c-format:assign-statement name expression))
                 (lambda (initializer generator)
                   (format:sequence
                    (c-format:assign-statement name initializer)
                    (generator name)))))

;;; This abstraction is slightly suboptimal.  In some cases we know
;;; that we shall want a temporary location to be allocated early if at
;;; all (e.g., for filling up a vector), but we are not sure whether we
;;; need one at all (e.g., if the vector's components are easy to
;;; calculate).

(define (hybrid-locative name temporary-location expression assign)
  (define (call-with-temporary-location receiver)
    (if temporary-location
        (receiver temporary-location)
        (c-format:call-with-temporary-s48-value name receiver)))
  (make-locative
   (lambda (expression)
     (call-with-temporary-location
       (lambda (temporary-location)
         (format:sequence
          (c-format:assign-statement temporary-location expression)
          (assign temporary-location)))))
   assign
   (lambda (initializer generator)
     (call-with-temporary-location
       (lambda (temporary-location)
         (format:sequence
          (c-format:assign-statement temporary-location initializer)
          (generator temporary-location)
          (assign temporary-location)))))))