;;; -*- Mode: Scheme; scheme48-package: c-groveller -*-

;;;; C Data Groveller

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

(define (grovel-file input-filename output-filename)
  (call-with-input-file input-filename
    (lambda (input-port)
      (call-with-output-file output-filename
        (lambda (output-port)
          (grovel-port input-port output-port))))))

(define (grovel-port input-port output-port)
  (let ((output-port (make-tracking-output-port output-port)))
    (let ((prelude (read input-port)))
      (cond ((and (pair? prelude)
                  (eq? (car prelude) 'PRELUDE)
                  (list? (cdr prelude)))
             (write-grovel-prelude (list-sequence
                                    (map grovel (cdr prelude)))
                                   output-port))
            ((eof-object? prelude)
             (error "empty grovel specification"))
            (else
             (warn "grovel specification contains no prelude")
             (write-grovel-prelude (sequence) output-port)
             (write-grovel-item (grovel prelude) output-port))))
    (let loop ()
      (let ((form (read input-port)))
        (cond ((not (eof-object? form))
               (write-grovel-item (grovel form) output-port)
               (loop)))))
    (write-grovel-postlude output-port)
    (force-output output-port)))

(define (grovel form)
  (cond ((string? form)
         (c-line form))
        ((and (pair? form)
              (list? (cdr form))
              (assq (car form) *grovellers*))
         => (lambda (probe)
              ((cdr probe) form)))
        (else
         (error "malformed grovel form" form))))

(define *grovellers* '())

(define (define-groveller name procedure)
  (cond ((assq name *grovellers*)
         => (lambda (probe)
              (set-cdr! probe procedure)))
        (else
         (set! *grovellers* (cons (cons name procedure)
                                  *grovellers*)))))

(define-groveller 'BEGIN
  (lambda (form)
    (list-sequence (map grovel (cdr form)))))

(define-groveller 'SCHEME
  (lambda (form)
    (list-sequence (map (lambda (scheme-form)
                          (c-printf "%s\\n"
                                    (stringify (writer scheme-form))))
                        (cdr form)))))

(define-groveller 'DEFINE
  (lambda (form)
    (destructure (((name value) (cdr form)))
      (cond ((string? value)
             (c-constant-definition name value))
            ((string-list? value)
             (alternative-constant-definition
              name value
              (cpp-error (sequence "No definition found for `"
                                   (symbol->string name)
                                   "' in "
                                   (decorated-list-sequence
                                    "(\"" "\" \"" "\")"
                                    value)))))
            (else
             (error
              "invalid syntax -- value neither string nor string list"
              form))))))

(define-groveller 'DEFINE-MAYBE
  (lambda (form)
    (destructure (((name value) (cdr form)))
      (cond ((string? value)
             (conditional-c-constant-definition name value))
            ((string-list? value)
             (alternative-constant-definition
              name value
              (scheme-constant-definition name "#f")))
            (else
             (error
              "invalid syntax -- value neither string nor string list"
              form))))))

(define (string-list? obj)
  (if (pair? obj)
      (and (string? (car obj))
           (string-list? (cdr obj)))
      (null? obj)))

(define-groveller 'STRUCT
  (lambda (form)
    (destructure (((scheme-name c-name . fields) (cdr form)))
      (scheme-struct scheme-name c-name fields))))

(define-groveller 'INCLUDE
  (lambda (form)
    (list-sequence (map cpp-include (cdr form)))))

(define-groveller 'SYSTEM-INCLUDE
  (lambda (form)
    (list-sequence (map cpp-system-include (cdr form)))))

(define-groveller 'DEFINE-MACRO
  (lambda (form)
    (destructure (((macro . lines) (cdr form)))
      (cpp-define macro
                  (decorated-list-sequence ""
                                           (sequence " \\" newline
                                                     "  ")
                                           ""
                                           lines)))))

(define-groveller 'IF
  (lambda (form)
    (destructure (((condition consequent . alternative) (cdr form)))
      (cpp-if (frob-cpp-condition condition)
              (grovel consequent)
              (if (pair? alternative)
                  (if (null? (cdr alternative))
                      (sequence (cpp-else)
                                (grovel (car alternative)))
                      (error "invalid syntax -- too many subforms"
                             form))
                  (sequence))))))

(define (frob-cpp-condition condition)
  (let ((lose (lambda ()
                (error "invalid cpp condition" condition))))
    (cond ((string? condition)
           condition)
          ((not (and (pair? condition)
                     (symbol? (car condition))
                     (list? (cdr condition))))
           (lose))
          (else
           (case (car condition)
             ((NOT) (cpp-not (frob-cpp-condition (cadr condition))))
             ((OR)  (cpp-or  (map frob-cpp-condition (cdr condition))))
             ((AND) (cpp-and (map frob-cpp-condition (cdr condition))))
             ((EQ?) (cpp-eq? (cadr condition) (caddr condition)))
             ((DEFINED?) (cpp-defined? (cadr condition)))
             (else  (cpp-call (car condition) (cdr condition))))))))

(define-groveller 'COND
  (lambda (form)
    (grovel
     (let recur ((clauses (cdr form)))
       (if (pair? clauses)
           (destructure (( ((condition . consequent) . more-clauses)
                           clauses))
             (if (eq? condition 'ELSE)
                 (if (null? more-clauses)
                     `(BEGIN ,@consequent)
                     (error "invalid syntax -- clauses after ELSE"
                            form))
                 `(IF ,condition
                      (BEGIN ,@consequent)
                      ,(recur more-clauses)))))))))

;;; Randomness

(define-groveller 'COMMENT
  (lambda (form)
    (c-comment (list-sequence (cdr form)))))