;;; -*- Mode: Scheme; scheme48-package: stubber-s48-code-generation -*-

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

;;; This code is written by Taylor R. Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

;;; This should be the only part of the stubber that knows anything
;;; about the grubby details of Scheme48's C interface.

(define (stub-header)
  (cpp-include "s48-stubber.h"))

(define (stub-initializer-function name c-initializations environment)
  name environment                      ;ignore
  (output-sequence
   (c-function "void" "s48_on_load" (list "void")
     (output-list c-initializations))
   (c-function "void" "s48_on_reload" (list "void")
     (c-statement (c-call "s48_on_load" '())))))

(define (stub-scheme-prelude name environment)
  name environment                      ;ignore
  '())

;;;; Simple Value Bindings

(define (stub/binding descriptor environment)
  (combine-stub
   (stub/binding/scheme descriptor environment)
   (stub/binding/c descriptor environment)))

(define (stub/binding/scheme descriptor environment)
  environment                           ;ignore
  (stub/scheme-forms
   `(IMPORT-DEFINITION ,(binding/scheme-name descriptor)
                       ,(binding/binding-name descriptor))))

(define (stub/binding/c descriptor environment)
  (stub/c-initializations
   (let ((temporary (generate-c-temporary "value" environment)))
     (c-block
      (s48-declare-false temporary)
      (s48-declare-gc-protect 1)
      (s48-gc-protect (list temporary))
      ((binding/c-body descriptor) temporary)
      (s48-export-binding
       (output-escaped-string (binding/binding-name descriptor))
       temporary)
      (s48-gc-unprotect)))))

;;;; Function Stubs

(define (stub/function descriptor environment)
  (combine-stub
   (stub/function/scheme descriptor environment)
   (stub/function/c descriptor environment)))

(define (stub/function/scheme descriptor environment)
  (stub/scheme-forms
   (let ((scheme-name (function/scheme-name descriptor))
         (binding-variable (generate-scheme-temporary 'BINDING environment))
         (binding-name (function/binding-name descriptor))
         (parameters (function/parameters descriptor)))
     `(DEFINE ,scheme-name
        (LET ((,binding-variable (LOOKUP-IMPORTED-BINDING ,binding-name)))
          (LAMBDA ,(map stub-parameter-scheme-name parameters)
            (CALL-IMPORTED-BINDING ,binding-variable
                                   ,@(map stub-parameter-scheme-expression
                                          parameters))))))))

(define (stub/function/c descriptor environment)
  (combine-stub
   (stub/c-initializations
    (c-stub-initialization (function/binding-name descriptor)
                           (function/c-name descriptor)))
   (stub/c-declarations
    (c-stub-definition (function/c-name descriptor)
                       (c-stub-result-variable descriptor environment)
                       (function/parameters descriptor)
                       (function/c-declarations descriptor)
                       (function/c-body descriptor)))))

(define (c-stub-result-variable descriptor environment)
  (generate-c-temporary (output-sequence "__"
                                         (function/c-name descriptor)
                                         "__result_s48")
                        environment))

(define (c-stub-initialization binding-name c-name)
  (s48-export-binding (output-escaped-string binding-name)
                      (c-call "s48_enter_pointer"
                              (list (c-cast "void *" c-name)))))

(define (c-stub-definition c-name result-variable
                           parameters c-declarations c-body)
  (c-function (output-sequence "static " (s48-value-type))
      c-name
      (map (lambda (parameter)
             (output-sequence (s48-value-type)
                              " "
                              (stub-parameter-c-name parameter)))
           parameters)
    (c-stub-body result-variable parameters c-declarations c-body)))

(define (c-stub-body result-variable parameters c-declarations c-body)
  (let ((protected-variables
         ;++ What about user-supplied protected variables?
         (cons result-variable (map stub-parameter-c-name parameters))))
    (output-sequence
     (c-stub-comment "Declarations")
     (output-list (map stub-parameter-c-declaration parameters))
     c-declarations
     (s48-declare-unspecific result-variable)
     (c-stub-comment "GC Protection")
     (s48-declare-gc-protect (length protected-variables))
     (s48-gc-protect protected-variables)
     (c-stub-comment "Conversions")
     (map stub-parameter-c-conversion parameters)
     (c-stub-comment "Body")
     (c-body result-variable)
     (c-stub-comment "Finish")
     (s48-gc-unprotect)
     (c-return result-variable))))

(define (c-stub-comment . elements)
  (output-sequence newline
                   (c-line (apply c-comment elements))
                   newline))

;;;; Enumeration Stubs

(define (stub/constant-enumeration descriptor environment)
  (combine-stub
   (stub/constant-enumeration/scheme descriptor environment)
   (stub/constant-enumeration/c descriptor environment)))

(define (stub/constant-enumeration/scheme descriptor environment)
  (stub/scheme-forms
   `(DEFINE-ENUMERATED-TYPE
        ,(constant-enumeration/scheme-name descriptor)
        ,(constant-enumeration/scheme-rtd descriptor)
        ,(constant-enumeration/scheme-type-predicate descriptor)
        ,(constant-enumeration/scheme-instance-vector descriptor)
        ,(constant-enumeration/scheme-name-accessor descriptor)
        ,(constant-enumeration/scheme-index-accessor descriptor)
      ,(constant-enumeration/scheme-enumerand-names descriptor))
   `(DEFINE-EXPORTED-BINDING
        ,(constant-enumeration/instance-vector-binding descriptor)
      ,(constant-enumeration/scheme-instance-vector descriptor))))

(define (stub/constant-enumeration/c descriptor environment)
  (receive (c-mapping-variable
            c-unmapping-binding-variable
            c-instance-vector-binding)
           (c-constant-enumeration-names descriptor environment)
    (combine-stub
     (stub/c-declarations
      (s48-declare-false c-unmapping-binding-variable))
     (stub/c-initializations
      (s48-gc-protect-global c-unmapping-binding-variable)
      (s48-import-binding
       (output-escaped-string
        (constant-enumeration/instance-vector-binding descriptor))
       c-unmapping-binding-variable))
     (stub/constant-enumeration/c-mapping descriptor
                                          c-mapping-variable
                                          environment)
     (stub/constant-enumeration/c-mapper descriptor
                                         c-mapping-variable
                                         environment)
     (stub/constant-enumeration/c-unmapper descriptor
                                           c-mapping-variable
                                           c-unmapping-binding-variable
                                           environment)
     (stub/constant-enumeration/c-predicate descriptor
                                            c-mapping-variable
                                            environment))))

(define (c-constant-enumeration-names descriptor environment)
  (let ((c-instance-vector
         (symbol->c-variable-name
          (constant-enumeration/scheme-instance-vector descriptor)
          environment)))
    (values (output-sequence c-instance-vector "_mapping")
            (output-sequence c-instance-vector "_unmapping_binding")
            c-instance-vector)))

(define (stub/constant-enumeration/c-mapping descriptor
                                             c-mapping-variable
                                             environment)
  (stub/c-declarations
   (c-constant-enumeration-mapping
    c-mapping-variable
    (constant-enumeration/c-type descriptor)
    (constant-enumeration/c-enumerands descriptor)
    environment)))

(define (stub/constant-enumeration/c-mapper descriptor
                                            c-mapping-variable
                                            environment)
  environment                           ;ignore
  (stub/c-declarations
   (c-constant-enumeration-mapper
    (constant-enumeration/c-mapper descriptor)
    (constant-enumeration/c-type descriptor)
    c-mapping-variable)))

(define (stub/constant-enumeration/c-unmapper descriptor
                                              c-mapping-variable
                                              c-unmapping-binding-variable
                                              environment)
  environment                           ;ignore
  (stub/c-declarations
   (c-constant-enumeration-unmapper
    (constant-enumeration/c-unmapper descriptor)
    (constant-enumeration/c-type descriptor)
    c-mapping-variable
    c-unmapping-binding-variable
    (length (constant-enumeration/c-enumerands descriptor)))))

(define (stub/constant-enumeration/c-predicate descriptor
                                               c-mapping-variable
                                               environment)
  ((lambda (descriptor) (stub/function descriptor environment))
   (let ((scheme-parameter (generate-scheme-temporary 'ENUMERAND environment))
         (predicate-name
          (constant-enumeration/scheme-available-predicate descriptor)))
     (function-descriptor
      (BINDING-NAME
       (constant-enumeration/available-predicate-binding descriptor))
      (SCHEME-NAME predicate-name)
      (PARAMETERS
       (list (stub-parameter/enumerand
              scheme-parameter
              (constant-enumeration/scheme-index-accessor descriptor)
              "index"
              (constant-enumeration/c-type descriptor))))
      (C-NAME (symbol->c-stub-name predicate-name environment))
      (C-DECLARATIONS '())
      (C-BODY
       (stub-result/boolean
        (c-field (c-array-ref c-mapping-variable "index")
                 "available_p")))))))

(define (stub-parameter/enumerand scheme-name index-accessor c-name c-type)
  (make-stub-parameter scheme-name
                       `(,index-accessor ,scheme-name)
                       c-name
                       c-type
                       ;; No conversion or declaration.
                       (output-nothing)
                       (output-nothing)))

(define (c-constant-enumeration-mapper c-mapper c-type c-mapping-variable)
  (c-line
   (cpp-call "S48_ENUMERAND_MAPPER"
             (list c-mapper c-type c-mapping-variable))))

(define (c-constant-enumeration-unmapper c-unmapper
                                         c-type
                                         c-mapping-variable
                                         c-unmapping-binding-variable
                                         count)
  (c-line
   (cpp-call "S48_ENUMERAND_UNMAPPER"
             (list c-unmapper
                   c-type
                   c-mapping-variable
                   c-unmapping-binding-variable
                   count))))

(define (c-constant-enumeration-mapping c-mapping-variable
                                        c-type
                                        c-enumerands
                                        environment)
  (c-declaration
   "struct" (c-block (c-declare "char" "available_p")
                     (c-declare c-type "value"))
   (output-sequence c-mapping-variable " [] ="     ;++ ick
                    (c-block
                     (map (lambda (enumerand)
                            (process-enumerand enumerand environment))
                          c-enumerands)))))

(define (process-enumerand enumerand environment)
  ((*process-enumerand enumerand environment)
   (c-unavailable-enumerand)))

(define (c-unavailable-enumerand)
  (c-line "{ 0 },"))

(define (c-available-enumerand expression)
  (c-line "{ 1, " expression " },"))

(define (*process-enumerand enumerand environment)
  (match enumerand
    ((? string? constant)
     (lambda (alternative)
       (cpp-ifdef constant
                  (c-available-enumerand constant)
                  (cpp-else)
                  alternative)))
    (('EXPRESSION (? string? expression))
     (lambda (alternative)
       alternative                      ;ignore
       (c-available-enumerand expression)))
    (('IF (? string? condition) (? string? expression))
     (lambda (alternative)
       (cpp-if condition expression (cpp-else) alternative)))
    (('OR) (lambda (alternative) alternative))
    (('OR option options ___)
     (lambda (alternative)
       ((*process-enumerand option environment)
        ((*process-enumerand `(OR ,@options) environment)
         alternative))))
    (else
     (error "Malformed enumerand:" enumerand))))

;;;; Stub Parameters

(define-record-type* stub-parameter
  (make-stub-parameter scheme-name
                       scheme-expression
                       c-name
                       c-type
                       c-declaration
                       c-conversion)
  ())

(define (stub-parameter/scheme)
  (lambda (scheme-name c-name)
    (make-stub-parameter
     scheme-name scheme-name
     c-name (s48-value-type)
     (c-line (c-comment "No declaration for " c-name))
     (c-line (c-comment "No conversion for " c-name)))))

(define (simple-stub-parameter predicate description c-type c-extract)
  (lambda (scheme-name c-name)
    (let ((s48-name (output-sequence c-name "_s48")))
      (make-stub-parameter
       scheme-name
       (make-scheme-check scheme-name predicate description)
       s48-name
       c-type
       (c-declare c-type c-name)
       (c-statement
        (c-assign c-name
                  (c-cast c-type (c-call c-extract (list s48-name)))))))))

;;; An `alien' is a C value stored in a Scheme byte vector.  An `alien
;;; pointer' is not an alien whose value is a pointer, but a pointer
;;; inside the byte vector.  Do not store these in heap images.

(define (alien-stub-parameter c-type c-extract)
  (lambda (scheme-name c-name)
    (let ((s48-name (output-sequence c-name "_s48")))
      (make-stub-parameter
       scheme-name
       (make-scheme-check scheme-name 'BYTE-VECTOR? "alien")
       s48-name
       c-type
       (c-declare c-type c-name)
       (c-statement
        ;; Use CPP-CALL here so that we avoid extraneous parentheses.
        ;; This may be significant around the type.  I am not sure, but
        ;; it doesn't hurt to be safe.
        (c-assign c-name (cpp-call c-extract (list s48-name c-type))))))))

(define (byte-vector-stub-parameter c-type c-length-name conversion-generator)
  (lambda (scheme-name c-name)
    (let ((s48-name (output-sequence c-name "_s48")))
      (make-stub-parameter
       scheme-name
       (make-scheme-check scheme-name 'BYTE-VECTOR? "byte-vector")
       s48-name
       c-type
       (output-sequence (c-declare c-type c-name)
                        (c-declare "size_t" c-length-name))
       (conversion-generator c-name s48-name)))))

(define (make-scheme-check scheme-name predicate description)
  `(IF (,predicate ,scheme-name)
       ,scheme-name
       (ERROR ,(string-append "Non-" description " argument:")
              ,scheme-name
              ',scheme-name)))

(define (stub-parameter/boolean)
  (simple-stub-parameter 'BOOLEAN? "boolean" "int" "S48_EXTRACT_BOOLEAN"))

(define (stub-parameter/char)
  (simple-stub-parameter 'CHAR? "char" "char" "s48_extract_char"))

(define (stub-parameter/integral c-type)
  (simple-stub-parameter '(LAMBDA (X)
                            (AND (INTEGER? X) (EXACT? X)))
                         "integral"
                         c-type
                         "s48_extract_integer"))

(define (stub-parameter/floating-point c-type)
  (simple-stub-parameter 'REAL? "real" c-type "s48_extract_double"))

(define (stub-parameter/shared-string)
  (simple-stub-parameter 'STRING? "string" "char *" "s48_extract_string"))

(define (stub-parameter/copied-string)
  (simple-stub-parameter 'STRING? "string" "char *"
                         "s48_extract_and_copy_string"))

(define (stub-parameter/byte-pointer)
  (simple-stub-parameter 'BYTE-VECTOR? "byte-vector" "char *"
                         "s48_extract_byte_vector"))

(define (stub-parameter/alien-pointer c-type)
  (alien-stub-parameter c-type "S48_EXTRACT_VALUE_POINTER"))

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

(define (stub-parameter/shared-byte-vector c-type c-length-name)
  (byte-vector-stub-parameter c-type c-length-name
    (lambda (c-name s48-name)
      (output-sequence
       (c-statement
        (c-assign c-name
                  (c-cast c-type
                          (c-call "s48_extract_byte_vector"
                                  (list s48-name)))))
       (c-statement
        (c-assign c-length-name
                  (c-call "S48_BYTE_VECTOR_LENGTH" (list s48-name))))))))

(define (stub-parameter/copied-byte-vector c-type c-length-name)
  (byte-vector-stub-parameter c-type c-length-name
    (lambda (c-name s48-name)
      (c-statement
       (c-assign c-name
                 (c-cast c-type
                         (c-call "s48_extract_and_copy_byte_vector"
                                 (list s48-name
                                       (c-address-of c-length-name)))))))))

;++ substrings
;++ byte subvectors

;;;;; Miscellaneous Stub Parameters

(define (stub-parameter/channel->fd)
  (lambda (scheme-name c-name)
    (let ((c-channel-name (output-sequence c-name "_channel_s48")))
      (make-stub-parameter
       scheme-name
       (make-scheme-check scheme-name 'CHANNEL? "channel")
       c-channel-name "int"
       (c-declare "int" c-name)
       (c-statement
        (c-assign c-name
                  (c-call "S48_UNSAFE_EXTRACT_FIXNUM"
                          (list (c-call "S48_UNSAFE_CHANNEL_OS_INDEX"
                                        (list c-channel-name))))))))))

(define (stub-parameter/false->null parameter-processor)
  (lambda (scheme-name c-name)
    (let ((parameter (parameter-processor scheme-name c-name)))
      (make-stub-parameter
       scheme-name
       (let ((expression (stub-parameter-scheme-expression parameter)))
         `(AND ,scheme-name ,expression))
       (stub-parameter-c-name parameter)
       (stub-parameter-c-type parameter)
       (stub-parameter-c-declaration parameter)
       (c-if (c-call "S48_FALSE_P"
                     (list (stub-parameter-c-name parameter)))
             (c-statement (c-assign c-name "NULL"))
             (c-block (stub-parameter-c-conversion parameter)))))))

;;;; Stub Results

(define (stub-result/expression expression)
  (lambda (result-location)
    (c-statement (c-assign result-location expression))))

(define (stub-result/false) (stub-result/expression "S48_FALSE"))
(define (stub-result/true) (stub-result/expression "S48_TRUE"))
(define (stub-result/null) (stub-result/expression "S48_NULL"))
(define (stub-result/unspecific)
  (stub-result/expression "S48_UNSPECIFIC"))

(define (simple-stub-result expression type enter)
  (lambda (result-location)
    (c-statement
     (c-assign result-location
               (c-call enter (list (c-cast type expression)))))))

(define (stub-result/boolean expression)
  (simple-stub-result expression "int" "S48_ENTER_BOOLEAN"))

(define (stub-result/char expression)
  (simple-stub-result expression "char" "s48_enter_char"))

(define (stub-result/integral expression)
  (simple-stub-result expression "long" "s48_enter_integer"))

(define (stub-result/floating-point expression)
  (simple-stub-result expression "double" "s48_enter_double"))

(define (stub-result/string expression)
  (simple-stub-result expression "char *" "s48_enter_string"))

(define (stub-result/freed-string expression)
  (simple-stub-result expression "char *" "s48_enter_and_free_string"))

(define (stub-result/alien-pointer c-type expression)
  c-type                                ;ignore
  (simple-stub-result expression "void *" "s48_enter_pointer"))

(define (stub-result/alien c-type expression)
  (lambda (result-location)
    (output-sequence
     ;** Use CPP-CALL here and not C-CALL so that the type is not
     ;** parenthesized.
     (c-statement
      (c-assign result-location
                (cpp-call "S48_MAKE_VALUE" (list c-type))))
     (c-statement
      (cpp-call "S48_SET_VALUE"
                (list result-location c-type expression))))))

(define (stub-result-with-length expression length type enter)
  (lambda (result-location)
    (c-statement
     (c-assign result-location
               (c-call enter (list (c-cast type expression)
                                   (c-cast "long" length)))))))

(define (stub-result/substring expression length)
  (stub-result-with-length expression length
                           "char *" "s48_enter_substring"))

(define (stub-result/byte-vector expression length)
  (stub-result-with-length expression length
                           "char *" "s48_enter_byte_vector"))

(define (stub-result/freed-byte-vector expression length)
  (stub-result-with-length expression length
                           "char *" "s48_enter_and_free_byte_vector"))

(define (stub-result/fd->channel fd status id)
  (lambda (result-location)
    (c-statement
     (c-call "s48_enter_channel"
             (list (c-address-of result-location) fd status id)))))

;++ freed substrings
;++ freed byte subvectors

;;;;; Complex Result Patterns

(define (stub-result/sequence item . items)
  (sequence-stub-result item items))

(define (sequence-stub-result item items)
  (let recur ((item item)
              (items items))
    (if (null? items)
        item
        (let ((item (if (string? item)
                        (c-line item)
                        item))
              (result (recur (car items) (cdr items))))
          (lambda (result-location)
            (output-sequence item (result result-location)))))))

(define (stub-result/conditional condition consequent alternative)
  (lambda (result-location)
    (c-if condition
          (c-block (consequent result-location))
          (c-block (alternative result-location)))))

(define (stub-result/cons car-result cdr-result)
  (lambda (result-location)
    (output-sequence
     (c-statement
      (c-assign result-location
                (c-call "s48_cons"
                        (list "S48_UNSPECIFIC" "S48_UNSPECIFIC"))))
     (car-result (c-call "S48_UNSAFE_CAR" (list result-location)))
     (cdr-result (c-call "S48_UNSAFE_CDR" (list result-location))))))

(define (stub-result/vector . element-results)
  (lambda (result-location)
    (output-sequence
     (c-statement
      (c-assign result-location
                (c-call "s48_make_vector"
                        (list (length element-results)
                              "S48_UNSPECIFIC"))))
     (let loop ((element-results element-results)
                (index 0)
                (output (output-nothing)))
       (if (null? element-results)
           output
           (loop (cdr element-results)
                 (+ index 1)
                 (output-sequence
                  output
                  ((car element-results)
                   (c-call "S48_UNSAFE_VECTOR_REF"
                           (list result-location index))))))))))

(define (stub-result/syscall-error syscall error-code)
  syscall                               ;ignore
  (lambda (result-location)
    result-location                     ;ignore
    (c-statement (c-call "s48_raise_os_error" (list error-code)))))

(define (stub-result/out-of-memory-error)
   (lambda (result-location)
     result-location                    ;ignore
     (c-statement (c-call "s48_raise_out_of_memory_error" '()))))

(define (s48-value-type)
  "s48_value")

(define (s48-export-binding binding-name expression)
  (c-statement
   (c-call "s48_define_exported_binding"
           (list binding-name expression))))

(define (s48-import-binding binding-name location)
  (c-statement
   (c-assign location
             (c-call "s48_get_imported_binding"
                     (list binding-name)))))

(define (s48-declare-false variable)
  (c-declare (s48-value-type)
             (c-initialize variable "S48_FALSE")))

(define (s48-declare-unspecific variable)
  (c-declare (s48-value-type)
             (c-initialize variable "S48_UNSPECIFIC")))

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

(define (s48-declare-gc-protect n)
  (c-statement (c-call "S48_DECLARE_GC_PROTECT" (list n))))

(define (s48-gc-protect locations)
  (c-statement
   (c-call (output-sequence "S48_GC_PROTECT_" (length locations))
           locations)))

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