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

;;;; Scheme48 Stubber
;;;; Top-Level Driver

;;; This code is written by Taylor R. Campbell and placed in the Public
;;; Domain.  All warranties are disclaimed.

(define (stub-file name stub-pathname c-pathname scheme-pathname
                   environment)
  (let ((stub (read-stub-from-file stub-pathname environment)))
    (receive (c-declarations c-initializations scheme-forms)
             (run-stub stub)
      (write-stub-c-to-file (reverse c-declarations)
                            (reverse c-initializations)
                            name
                            c-pathname
                            environment)
      (write-stub-scheme-to-file (reverse scheme-forms)
                                 name
                                 scheme-pathname
                                 environment))))

(define (read-stub-from-file pathname environment)
  (call-with-input-file pathname
    (lambda (input-port)
      (read-stub input-port environment))))

(define (write-stub-c-to-file c-declarations c-initializations
                              name pathname environment)
  (call-with-output-file pathname
    (lambda (output-port)
      (write-stub-c c-declarations
                    c-initializations
                    name
                    output-port
                    environment))))

(define (write-stub-scheme-to-file scheme-forms name pathname environment)
  (call-with-output-file pathname
    (lambda (output-port)
      (write-stub-scheme scheme-forms name output-port environment))))

(define (write-stub-c c-declarations c-initializations
                      name output-port environment)
  (let* ((output-port (make-tracking-output-port output-port))
         (emit (lambda (item)
                 (item output-port)
                 (newline output-port))))
    (emit (stub-environment-c-prelude environment))
    (for-each emit c-declarations)
    (emit ((stub-environment-c-initializer environment)
           name c-initializations environment))
    (force-output output-port)))

(define (write-stub-scheme scheme-forms name output-port environment)
  (let ((write-forms
         (let ((write (stub-environment-scheme-writer environment)))
           (lambda (forms)
             (for-each (lambda (form)
                         (write form output-port)
                         (newline output-port))
                       forms)))))
    (write-forms ((stub-environment-scheme-prelude environment)
                  name environment))
    (write-forms scheme-forms)))

(define (read-stub input-port environment)
  (let loop ((stub (empty-stub)))
    (let ((form (read input-port)))
      (if (eof-object? form)
          stub
          (loop (combine-stub stub (process-form form environment)))))))

(define (run-stub stub)
  (stub '() '() '()))

(define (losing-stub form)
  (warn "Ignoring malformed stub form:" form)
  (empty-stub))

(define (empty-stub)
  (lambda (c-declarations c-initializations scheme-forms)
    (values c-declarations c-initializations scheme-forms)))

(define (combine-stub . states)
  (reduce-right combine-stub-2 (empty-stub) states))

(define (combine-stub-2 stub stub*)
  (lambda (c-declarations c-initializations scheme-forms)
    (receive (c-declarations* c-initializations* scheme-forms*)
             (stub c-declarations c-initializations scheme-forms)
      (stub* c-declarations* c-initializations* scheme-forms*))))

(define (stub/c-declarations . forms)
  (lambda (c-declarations c-initializations scheme-forms)
    (values (append-reverse forms c-declarations)
            c-initializations
            scheme-forms)))

(define (stub/c-initializations . forms)
  (lambda (c-declarations c-initializations scheme-forms)
    (values c-declarations
            (append-reverse forms c-initializations)
            scheme-forms)))

(define (stub/scheme-forms . forms)
  (lambda (c-declarations c-initializations scheme-forms)
    (values c-declarations
            c-initializations
            (append-reverse forms scheme-forms))))

(define-record-type* stub-environment
  (make-stub-environment (c-prelude)
                         (c-initializer)
                         (scheme-prelude)
                         (scheme-writer)
                         (binding-namer)
                         (c-stub-namer)
                         (c-variable-namer)
                         (form-handlers)
                         (parameter-handlers)
                         (expression-handlers)
                         )
  ((temporary-counter 0)))

(define (copy-stub-environment environment)
  (define (copy-entry entry)
    (cons (car entry) (cdr entry)))
  (make-stub-environment
   (stub-environment-c-prelude environment)
   (stub-environment-c-initializer environment)
   (stub-environment-scheme-prelude environment)
   (stub-environment-scheme-writer environment)
   (stub-environment-binding-namer environment)
   (stub-environment-c-stub-namer environment)
   (stub-environment-c-variable-namer environment)
   (map copy-entry (stub-environment-form-handlers environment))
   (map copy-entry (stub-environment-parameter-handlers environment))
   (map copy-entry
        (stub-environment-expression-handlers environment))))

(define (handler-definer get-handlers set-handlers!)
  (lambda (name environment handler)
    (let ((handlers (get-handlers environment)))
      (cond ((assq name handlers)
             => (lambda (probe)
                  (set-cdr! probe handler)))
            (else
             (set-handlers! environment
                            (cons (cons name handler) handlers)))))))

(define (handler-finder get-handlers)
  (lambda (environment name)
    (cond ((assq name (get-handlers environment))
           => cdr)
          (else #f))))

(define *define-form-handler
  (handler-definer stub-environment-form-handlers
                   set-stub-environment-form-handlers!))

(define stub-environment-form-handler
  (handler-finder stub-environment-form-handlers))

(define *define-parameter-handler
  (handler-definer stub-environment-parameter-handlers
                   set-stub-environment-parameter-handlers!))

(define stub-environment-parameter-handler
  (handler-finder stub-environment-parameter-handlers))

(define *define-expression-handler
  (handler-definer stub-environment-expression-handlers
                   set-stub-environment-expression-handlers!))

(define stub-environment-expression-handler
  (handler-finder stub-environment-expression-handlers))

;;; Macrolized versions of the above.

(define-syntax define-form-handler
  (syntax-rules ()
    ((DEFINE-FORM-HANDLER name environment
         (form-variable environment-variable)
       rule0 rule1 ...)
     (*DEFINE-FORM-HANDLER
      'name environment
      (LAMBDA (form-variable environment-variable)
        (MATCH form-variable
          rule0 rule1 ...
          (ELSE (LOSING-STUB form-variable))))))))

(define-syntax define-parameter-handler
  (syntax-rules ()
    ((DEFINE-PARAMETER-HANDLER name environment
         (form-variable environment-variable)
       rule0 rule1 ...)
     (*DEFINE-PARAMETER-HANDLER
      'name environment
      (LAMBDA (form-variable environment-variable)
        (MATCH form-variable
          rule0 rule1 ...
          (ELSE (ERROR "Malformed parameter:" form-variable))))))))

(define-syntax define-simple-parameter-handler
  (syntax-rules ()
    ((DEFINE-SIMPLE-PARAMETER-HANDLER name environment constructor)
     (*DEFINE-PARAMETER-HANDLER
      'name environment
      (LAMBDA (*FORM *ENVIRONMENT)
        *ENVIRONMENT                    ;ignore
        (IF (EQ? *FORM 'name)
            constructor
            (ERROR "Malformed parameter:" *FORM)))))))

(define-syntax define-expression-handler
  (syntax-rules ()
    ((DEFINE-EXPRESSION-HANDLER name environment
         (form-variable environment-variable)
       rule0 rule1 ...)
     (*DEFINE-EXPRESSION-HANDLER
      'name environment
      (LAMBDA (form-variable environment-variable)
        (MATCH form-variable
          rule0 rule1 ...
          (ELSE (ERROR "Malformed expression:" form-variable))))))))

(define-syntax define-constant-expression-handler
  (syntax-rules ()
    ((DEFINE-CONSTANT-EXPRESSION-HANDLER name environment constructor)
     (DEFINE-EXPRESSION-HANDLER name environment
         (*FORM *ENVIRONMENT)
       ((OR 'name ('name)) (constructor))))))

(define-syntax define-simple-expression-handler
  (syntax-rules ()
    ((DEFINE-SIMPLE-EXPRESSION-HANDLER name environment constructor)
     (DEFINE-EXPRESSION-HANDLER name environment
         (*FORM *ENVIRONMENT)
       (('name EXPRESSION)
        (constructor EXPRESSION))))))

;;;;; User Interface Conveniences

(define (*define-form-expander name environment expander)
  (*define-form-handler
   name environment
   (lambda (form environment)
     (process-form (expander form) environment))))

(define-syntax define-form-expander
  (syntax-rules ()
    ((DEFINE-FORM-EXPANDER name environment rule0 rule1 ...)
     (*DEFINE-FORM-EXPANDER
      'name environment
      (LAMBDA (FORM)
        (MATCH FORM
          rule0 rule1 ...
          (ELSE (LOSING-STUB FORM))))))))

(define (*define-parameter-wrapper name environment procedure)
  (*define-parameter-handler
   name environment
   (lambda (form environment)
     (process-parameter (procedure form) environment))))

(define-syntax define-parameter-wrapper
  (syntax-rules ()
    ((DEFINE-PARAMETER-WRAPPER name environment rule0 rule1 ...)
     (*DEFINE-PARAMETER-WRAPPER
      'name environment
      (LAMBDA (FORM)
        (MATCH FORM
          rule0 rule1 ...
          (ELSE (ERROR "Malformed parameter:" FORM))))))))

(define (*define-expression-expander name environment expander)
  (*define-expression-handler
   name environment
   (lambda (form environment)
     (process-expression (expander form) environment))))

(define-syntax define-expression-expander
  (syntax-rules ()
    ((DEFINE-EXPRESSION-EXPANDER name environment rule0 rule1 ...)
     (*DEFINE-EXPRESSION-EXPANDER
      'name environment
      (LAMBDA (FORM)
        (MATCH FORM
          rule0 rule1 ...
          (ELSE (ERROR "Malformed expression:" FORM))))))))

(define (process-form form environment)
  (match form
    (((? symbol? operator) operands ___)
     (cond ((stub-environment-form-handler environment operator)
            => (lambda (handler)
                 (handler form environment)))
           (else
            (losing-stub form))))
    (else
     (losing-stub form))))

(define (process-parameter form environment)
  (define (lose)
    (error "Malformed parameter:" form))
  (define (handle tag)
    (cond ((stub-environment-parameter-handler environment tag)
           => (lambda (handler)
                (handler form environment)))
          (else
           (lose))))
  (match form
    ((? symbol? tag)
     (handle tag))
    (((? symbol? tag) operands ___)
     (handle tag))
    (else
     (lose))))

(define (process-expression form environment)
  (define (lose)
    (error "Malformed expression:" form))
  (define (handle tag)
    (cond ((stub-environment-expression-handler environment tag)
           => (lambda (handler)
                (handler form environment)))
          (else
           (lose))))
  (match form
    (((? symbol? tag) operands ___)
     (handle tag))
    (else
     (lose))))

(define (symbol->binding-name scheme-name environment)
  ((stub-environment-binding-namer environment) scheme-name))

(define (symbol->c-stub-name scheme-name environment)
  ((stub-environment-c-stub-namer environment) scheme-name))

(define (symbol->c-variable-name scheme-name environment)
  ((stub-environment-c-variable-namer environment) scheme-name))

(define (count-temporary environment)
  (let ((n (stub-environment-temporary-counter environment)))
    (set-stub-environment-temporary-counter! environment (+ n 1))
    n))

(define (generate-scheme-temporary name environment)
  (string->symbol
   (string-append (symbol->string name)
                  ".g"
                  (number->string (count-temporary environment)))))

(define (generate-c-temporary name environment)
  (output-sequence "__temp_" name "_g" (count-temporary environment)))