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

;;;; Scheme48 Stubber
;;;; C Output

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

(define $c-indentation (make-fluid 0))

(define (with-c-alignment item)
  (let ((write-output (output-item item)))
    (lambda (port)
      (let-fluid $c-indentation (current-column port)
        (lambda ()
          (write-output port))))))

(define (with-c-indentation indentation item)
  (let ((write-output (output-item item)))
    (lambda (port)
      (let-fluid $c-indentation (+ indentation (fluid $c-indentation))
        (lambda ()
          (write-output port))))))

(define (c-indentation)
  (lambda (port)
    (write-string (make-string (fluid $c-indentation)
                               #\space)
                  port)))

(define (c-comment . elements)
  (output-decorated-list "/* " "" " */" elements ""))

(define (c-line . elements)
  (output-line (c-indentation) (output-list elements)))

(define (c-block . body)
  (output-sequence (c-line "{")
                   (with-c-indentation 2 (output-list body))
                   (c-line "}")))

(define (c-function return-type name parameters . body)
  (output-sequence
   (c-line return-type)
   (c-line name " " (c-parameter-list parameters))
   (c-block (output-list body))))

(define (c-if1 condition consequent)
  (output-sequence
   (c-line "if " (c-expression condition))
   (with-c-indentation 2 consequent)))

(define (c-if condition consequent alternative)
  (output-sequence
   (c-line "if " (c-expression condition))
   (with-c-indentation 2 consequent)
   (c-line "else")
   (with-c-indentation 2 alternative)))

;;; Exactly which of these is wrapped by default in a statement or
;;; declaration is random.  At the moment, I think the ones that can be
;;; used only as statements or declarations are wrapped by default,
;;; while anything that can be an expression is not wrapped by
;;; default.  All expressions are wrapped where they are used.  This
;;; should be thought out more clearly.

(define (c-label name)                  ;Assumes some indentation
  (with-c-indentation -1 (c-line name ":")))

(define (c-declaration . elements)
  (c-line (output-list elements) ";"))

(define (c-declare type name . names)
  ;++ spread across multiple lines
  (c-declaration type " " (reduce-operator ", " #f (cons name names))))

(define (c-statement . elements)
  (c-line (output-list elements) ";"))

(define (c-return value)
  (c-statement "return " (c-expression value)))

(define (c-goto label)
  (c-statement "goto " label))

(define (c-expression item)
  (output-sequence "(" (with-c-alignment item) ")"))

(define (c-call function arguments)
  (output-sequence
   function
   " "
   (c-parameter-list (map c-expression arguments))))

(define (c-parameter-list forms)
  (with-c-alignment
    (with-c-indentation 1               ;Add 1 for the left bracket.
      (output-decorated-list "("
                             (output-sequence ","
                                              newline
                                              (c-indentation))
                             ")"
                             forms))))

(define (c-assign location expression)
  (output-sequence (c-expression location)
                   " =" newline
                   (with-c-indentation 2
                     (output-sequence (c-indentation)
                                      (c-expression expression)))))

;;; For use in conjunction with C-DECLARE to initialize variables.
;;; C-ASSIGN won't work because it parenthesizes the location.

(define (c-initialize variable expression)
  (output-sequence variable " = " (c-expression expression)))

(define (c-cast type datum)
  (output-sequence (c-expression type) " " (c-expression datum)))

(define (c-sizeof datum)
  (c-call "sizeof" (list datum)))

(define (c-address-of datum)
  (output-sequence "& " (c-expression datum)))

(define (c-dereference pointer)
  (output-sequence "* " (c-expression pointer)))

(define (c-array-ref array index)
  (output-sequence (c-expression array)
                   " [" (with-c-alignment index) "]"))

(define (c-field struct field)
  (output-sequence (c-expression struct) " . " field))

(define (c-pointer-field struct field)
  (output-sequence (c-expression struct) " -> " field))

(define (c-struct-type struct-name)
  (output-sequence "struct " struct-name))

(define (c-pointer-type type)
  (output-sequence type " *"))

(define (c-struct-pointer-type struct-name)
  (c-pointer-type (c-struct-type struct-name)))

(define (c-address-type)
  (c-pointer-type "char"))

(define (c-not expression)
  (output-sequence "! " (c-expression expression)))

(define (c-and . conjuncts)
  (c-and* conjuncts))

(define (c-and* conjuncts)
  (reduce-operator " && " conjuncts 1))

(define (c-or . disjuncts)
  (c-or* disjuncts))

(define (c-or* disjuncts)
  (reduce-operator " || " disjuncts 0))

(define (reduce-operator operator operands identity)
  (reduce-map (lambda (a b) (output-sequence a operator b))
              c-expression
              identity
              operands))

(define (reduce-map operator mapper right-identity list)
  (if (pair? list)
      (let loop ((list (cdr list)) (result (mapper (car list))))
        (if (pair? list)
            (loop (cdr list)
                  (operator result (mapper (car list))))
            result))
      right-identity))