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

;;;; Scheme48 Stubber
;;;; Usual Stub Environment

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

(define (usual-stub-file name input-pathname c-pathname scheme-pathname)
  (stub-file name
             input-pathname
             c-pathname
             scheme-pathname
             (make-usual-stub-environment)))

(define (make-usual-stub-environment)
  (copy-stub-environment usual-stub-environment))

(define usual-stub-environment
  (make-stub-environment
   (output-sequence
    (c-line (c-comment "This file is automatically generated.   "))
    (c-line (c-comment "Modify at your own peril!               "))
    newline
    (stub-header))
   (lambda (name c-initializations environment)
     (stub-initializer-function name c-initializations environment))
   (lambda (name environment)           ;Scheme prelude
     (stub-scheme-prelude name environment))
   p                                    ;Scheme writer (pretty-print)
   symbol->string                       ;Binding namer
   (lambda (scheme-name) (usual-c-stub-name scheme-name))
   (lambda (scheme-name) (usual-c-variable-name scheme-name))
   '()                                  ;Form handlers
   '()                                  ;Parameter handlers
   '()                                  ;Expression handlers
   ))

(define (usual-c-stub-name scheme-name)
  (output-sequence "scheme_stub__" (usual-c-variable-name scheme-name)))

(define (usual-c-variable-name scheme-name)       ;++ Silliness
  (output-list
   (map (lambda (char)
          (cond ((char=? char #\-) #\_)
                ((char=? char #\?) #\P)
                ((or (char-alphabetic? char)
                     (char-numeric? char))
                 char)
                (else
                 (output-sequence "_0x"
                                  (number->string (char->ascii char)
                                                  16)
                                  "_"))))
        (string->list (symbol->string scheme-name)))))

(define-form-handler INCLUDE usual-stub-environment
    (form environment)
  (('INCLUDE (? string? headers) ___)
   (stub/c-declarations (output-list (map cpp-include headers)))))

(define-form-handler SYSTEM-INCLUDE usual-stub-environment
    (form environment)
  (('SYSTEM-INCLUDE (? string? headers) ___)
   (stub/c-declarations
    (output-list (map cpp-system-include headers)))))

(define-form-handler C-DECLARE usual-stub-environment
    (form environment)
  (('C-DECLARE (? string? declarations) ___)
   (stub/c-declarations (output-list (map c-line declarations)))))

(define-form-handler C-INITIALIZE usual-stub-environment
    (form environment)
  (('C-INITIALIZE (? string? initializations) ___)
   (stub/c-initializations (output-list (map c-line initializations)))))

(define-form-handler SCHEME usual-stub-environment
    (form environment)
  (('SCHEME forms ___)
   (apply stub/scheme-forms forms)))

(define-form-handler DEFINE usual-stub-environment
    (form environment)
  (('DEFINE (? symbol? scheme-name) expression)
   (binding-definition scheme-name expression environment))
  (('DEFINE ((? symbol? scheme-name) parameters ___)
     expression)
   (lambda-definition scheme-name parameters '()
                      (list expression)
                      environment))
  (('DEFINE ((? symbol? scheme-name) parameters ___)
     ('DECLARE (? string? c-declarations) ___)
     expression)
   (lambda-definition scheme-name parameters c-declarations
                      (list expression)
                      environment)))

(define (binding-definition scheme-name expression environment)
  (stub/binding (binding-descriptor
                 (SCHEME-NAME scheme-name)
                 (C-BODY (process-expression expression environment))
                 (BINDING-NAME (symbol->binding-name scheme-name environment)))
                environment))

(define (lambda-definition scheme-name parameters c-declarations body
                           environment)
  (let ((binding-name (symbol->binding-name scheme-name environment))
        (c-name (symbol->c-stub-name scheme-name environment)))
    (stub/function
     (function-descriptor
      (BINDING-NAME binding-name)
      (SCHEME-NAME scheme-name)
      (PARAMETERS (process-parameters parameters environment))
      (C-NAME c-name)
      (C-DECLARATIONS (map c-line c-declarations))
      (C-BODY (process-body body environment)))
     environment)))

(define (process-parameters parameters environment)
  (map (lambda (parameter)
         (receive (scheme-name c-name form)
                  (parse-parameter parameter environment)
           ((process-parameter form environment) scheme-name c-name)))
       parameters))

(define (parse-parameter parameter environment)
  (match parameter
    (((? symbol? scheme-name) form)
     (values scheme-name
             (symbol->c-variable-name scheme-name environment)
             form))
    ((((? symbol? scheme-name) (? string? c-name)) form)
     (values scheme-name c-name form))
    (else
     (error "Malformed parameter:" parameter))))

(define (process-body body environment)
  (let recur ((body body))
    (let ((item (car body))
          (body (cdr body)))
      (if (null? body)
          (process-expression item environment)
          (stub-result/sequence item (recur body))))))

;;;;; Unix System Call Stubs

(define-form-handler DEFINE-UINT-SYSCALL usual-stub-environment
    (form environment)
  (('DEFINE-UINT-SYSCALL ((? symbol? scheme-name) parameters ___)
     (? string? value-variable)
     (? string? syscall) ((? string? arguments) ___)
     expression)
   (syscall-definition scheme-name parameters '()
                       "int" value-variable
                       syscall arguments
                       expression
                       environment))
  (('DEFINE-UINT-SYSCALL ((? symbol? scheme-name) parameters ___)
     ('DECLARE (? string? c-declarations) ___)
     (? string? value-variable)
     (? string? syscall) ((? string? arguments) ___)
     expression)
   (syscall-definition scheme-name parameters c-declarations
                       "int" value-variable
                       syscall arguments
                       expression
                       environment)))

(define-form-handler DEFINE-VOID-SYSCALL usual-stub-environment
    (form environment)
  (('DEFINE-VOID-SYSCALL ((? symbol? scheme-name) parameters ___)
     (? string? syscall) ((? string? arguments) ___)
     expression)
   (syscall-definition scheme-name parameters '()
                       "int" (generate-c-temporary "status" environment)
                       syscall arguments
                       expression
                       environment))
  (('DEFINE-VOID-SYSCALL ((? symbol? scheme-name) parameters ___)
     ('DECLARE (? string? c-declarations) ___)
     (? string? syscall) ((? string? arguments) ___)
     expression)
   (syscall-definition scheme-name parameters c-declarations
                       "int" (generate-c-temporary "status" environment)
                       syscall arguments
                       expression
                       environment)))

(define (syscall-definition scheme-name parameters c-declarations
                            value-type value-variable
                            syscall arguments
                            expression
                            environment)
  (lambda-definition
   scheme-name parameters
   (cons (output-sequence value-type " " value-variable ";")
         c-declarations)
   (list (c-statement
          (c-call "STD_UINT_SYSTEM_CALL"
                  (list (output-sequence "syscall_" syscall)
                        value-variable
                        (c-call syscall arguments))))
         expression)
   environment))

(define-form-handler DEFINE-CONSTANT-ENUMERATION
    usual-stub-environment
    (form environment)
  (('DEFINE-CONSTANT-ENUMERATION name rtd type-predicate
     instance-vector
     name-accessor
     index-accessor
     available-predicate
     ((? string? c-type)
      (? string? c-mapper)
      (? string? c-unmapper))
     (((? symbol? enumerand-names) enumerand-expressions) ___))
   (*define-enumeration-conversions name type-predicate index-accessor
                                    c-type c-mapper c-unmapper
                                    environment)
   (stub/constant-enumeration
    ;++ The order must match descriptor.scm.  This is gross, but not as gross
    ;++ as it was before -- at least the arguments are named, even if they are
    ;++ still positional.
    (constant-enumeration-descriptor
     (SCHEME-NAME name)
     (SCHEME-RTD rtd)
     (SCHEME-TYPE-PREDICATE type-predicate)
     (SCHEME-INSTANCE-VECTOR instance-vector)
     (SCHEME-NAME-ACCESSOR name-accessor)
     (SCHEME-INDEX-ACCESSOR index-accessor)
     (SCHEME-AVAILABLE-PREDICATE available-predicate)
     (SCHEME-ENUMERAND-NAMES enumerand-names)
     (INSTANCE-VECTOR-BINDING
      (symbol->binding-name instance-vector environment))
     (AVAILABLE-PREDICATE-BINDING
      (symbol->binding-name available-predicate environment))
     (C-TYPE c-type)
     (C-MAPPER c-mapper)
     (C-UNMAPPER c-unmapper)
     (C-ENUMERANDS enumerand-expressions))
    environment)))

(define (*define-enumeration-conversions name type-predicate index-accessor
                                         c-type c-mapper c-unmapper
                                         environment)
  (*define-parameter-handler
   name environment
   (enumerand-mapper name c-type c-mapper type-predicate index-accessor))
  (*define-expression-handler
   name environment
   (enumerand-unmapper name c-type c-unmapper)))

(define (enumerand-mapper name c-type c-mapper type-predicate index-accessor)
  (lambda (form environment)
    (if (not (eq? form name))
        (error "Malformed parameter:" form)
        (lambda (scheme-name c-name)
          (let ((parameter
                 ((simple-stub-parameter type-predicate
                                         (string-append (symbol->string name)
                                                        " enumerand")
                                         c-type
                                         c-mapper)
                  scheme-name
                  c-name)))
            (make-stub-parameter
             (stub-parameter-scheme-name parameter)
             `(,index-accessor ,(stub-parameter-scheme-expression parameter))
             (stub-parameter-c-name parameter)
             (stub-parameter-c-type parameter)
             (stub-parameter-c-declaration parameter)
             (stub-parameter-c-conversion parameter)))))))

(define (enumerand-unmapper name c-type c-unmapper)
  (lambda (form environment)
    (match form
      (((? (lambda (x) (eq? x name))) expression)
       (stub-result/expression
        (c-call c-unmapper (list expression)))))))

(define-simple-parameter-handler SCHEME-DATUM usual-stub-environment
  (stub-parameter/scheme))

(define-simple-parameter-handler BOOLEAN usual-stub-environment
  (stub-parameter/boolean))

(define-simple-parameter-handler CHAR usual-stub-environment
  (stub-parameter/char))

(define-simple-parameter-handler CHANNEL->FD usual-stub-environment
  (stub-parameter/channel->fd))

(define-parameter-handler INTEGRAL usual-stub-environment
    (form environment)
  (('INTEGRAL (? string? c-type))
   (stub-parameter/integral c-type)))

(define-parameter-handler FLOATING-POINT usual-stub-environment
    (form environment)
  (('FLOATING-POINT (? string? c-type))
   (stub-parameter/floating-point c-type)))

(define-simple-parameter-handler SHARED-STRING
  usual-stub-environment
  (stub-parameter/shared-string))

(define-simple-parameter-handler COPIED-STRING
  usual-stub-environment
  (stub-parameter/copied-string))

(define-simple-parameter-handler BYTE-POINTER usual-stub-environment
  (stub-parameter/byte-pointer))

(define-parameter-handler ALIEN-POINTER usual-stub-environment
    (form environment)
  (('ALIEN-POINTER (? string? c-type))
   (stub-parameter/alien-pointer c-type)))

(define-parameter-handler ALIEN usual-stub-environment
    (form environment)
  (('ALIEN (? string? c-type))
   (stub-parameter/alien c-type)))

(define-parameter-handler SHARED-BYTE-VECTOR usual-stub-environment
    (form environment)
  (('SHARED-BYTE-VECTOR (? string? c-type) (? string? c-length-name))
   (stub-parameter/shared-byte-vector c-type c-length-name)))

(define-parameter-handler COPIED-BYTE-VECTOR usual-stub-environment
    (form environment)
  (('COPIED-BYTE-VECTOR (? string? c-type) (? string? c-length-name))
   (stub-parameter/copied-byte-vector c-type c-length-name)))

(define-parameter-handler FALSE->NULL usual-stub-environment
    (form environment)
  (('FALSE->NULL parameter)
   (stub-parameter/false->null (process-parameter parameter environment))))

(define-simple-expression-handler SCHEME-DATUM
  usual-stub-environment
  stub-result/expression)

(define-constant-expression-handler TRUE usual-stub-environment
  stub-result/true)

(define-constant-expression-handler FALSE usual-stub-environment
  stub-result/false)

(define-constant-expression-handler NULL usual-stub-environment
  stub-result/null)

(define-constant-expression-handler UNSPECIFIC
  usual-stub-environment
  stub-result/unspecific)

(define-simple-expression-handler BOOLEAN usual-stub-environment
  stub-result/boolean)

(define-simple-expression-handler CHAR usual-stub-environment
  stub-result/char)

(define-simple-expression-handler INTEGRAL usual-stub-environment
  stub-result/integral)

(define-simple-expression-handler FLOATING-POINT
  usual-stub-environment
  stub-result/floating-point)

(define-simple-expression-handler STRING usual-stub-environment
  stub-result/string)

(define-simple-expression-handler FREED-STRING
  usual-stub-environment
  stub-result/freed-string)

(define-expression-handler SUBSTRING usual-stub-environment
    (form environment)
  (('SUBSTRING string-expression length-expression)
   (stub-result/substring string-expression length-expression)))

(define-expression-handler ALIEN-POINTER usual-stub-environment
    (form environment)
  (('ALIEN-POINTER (? string? c-type) expression)
   (stub-result/alien-pointer c-type expression)))

(define-expression-handler ALIEN usual-stub-environment
    (form environment)
  (('ALIEN (? string? c-type) expression)
   (stub-result/alien c-type expression)))

(define-expression-handler BYTE-VECTOR usual-stub-environment
    (form environment)
  (('BYTE-VECTOR pointer-expression length-expression)
   (stub-result/byte-vector pointer-expression length-expression)))

(define-expression-handler FREED-BYTE-VECTOR usual-stub-environment
    (form environment)
  (('FREED-BYTE-VECTOR pointer-expression length-expression)
   (stub-result/freed-byte-vector pointer-expression
                                  length-expression)))

;;;; Complex Expression Combinators

(define-expression-handler BEGIN usual-stub-environment
    (form environment)
  (('BEGIN item items ___)
   (process-body (cons item items) environment)))

(define-expression-handler IF usual-stub-environment
    (form environment)
  (('IF condition consequent alternative)
   (stub-result/conditional
    (process-condition condition environment)
    (process-expression consequent environment)
    (process-expression alternative environment))))

(define (process-condition condition environment)    ;++ ad-hockery
  (let process ((condition condition))
    (match condition
      ((? string?)          condition)
      (('NOT negated)       (c-not (process negated)))
      (('AND conjuncts ___) (c-and* (map process conjuncts)))
      (('OR  disjuncts ___) (c-or*  (map process disjuncts)))
      (else (error "Malformed condition:" condition)))))

(define-expression-handler COND usual-stub-environment
    (form environment)
  (('COND (AND clauses (conditions bodies ___)) ___)
   (if (null? clauses)
       (error "Empty COND.")
       (let recur ((clauses clauses))
         (match clauses
           ((('ELSE body ___))
            (process-body body environment))
           ((('ELSE body ___) . clauses)
            (error "Trailing clauses after ELSE in COND:"
                   clauses
                   `(ELSE ,@body)))
           (((condition body ___) . clauses)
            (stub-result/conditional
             (process-condition condition environment)
             (process-body body environment)
             (recur clauses))))))))

(define-expression-handler CONS usual-stub-environment
    (form environment)
  (('CONS car-expression cdr-expression)
   (stub-result/cons
    (process-expression car-expression environment)
    (process-expression cdr-expression environment))))

(define-expression-handler VECTOR usual-stub-environment
    (form environment)
  (('VECTOR element-expressions ___)
   (apply stub-result/vector
          (map (lambda (element-expression)
                 (process-expression element-expression environment))
               element-expressions))))

(define-expression-handler FD->CHANNEL usual-stub-environment
    (form environment)
  (('FD->CHANNEL fd-expression status-expression id-expression)
   (stub-result/fd->channel fd-expression
                            status-expression
                            id-expression)))

;;;; Miscellaneous

(define-expression-handler VOID usual-stub-environment
    (form environment)
  (('VOID (? string? commands) ___)
   (apply stub-result/sequence          ;++ ick
          (append commands
                  (list (stub-result/unspecific))))))

(define-expression-handler SYSCALL-ERROR usual-stub-environment
    (form environment)
  (('SYSCALL-ERROR)
   (stub-result/syscall-error #f "errno"))
  (('SYSCALL-ERROR syscall)
   (stub-result/syscall-error syscall "errno"))
  (('SYSCALL-ERROR syscall error-code)
   (stub-result/syscall-error syscall error-code)))

(define-expression-handler OUT-OF-MEMORY-ERROR
    usual-stub-environment
    (form environment)
  (('OUT-OF-MEMORY-ERROR)
   (stub-result/out-of-memory-error)))