;;; -*- Mode: Scheme -*-

;;;; C Stub Generator for Scheme
;;;; Formatting C Code

;;; Copyright (c) 2009, Taylor R. Campbell
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; * Redistributions of source code must retain the above copyright
;;;   notice, this list of conditions and the following disclaimer.
;;;
;;; * Redistributions in binary form must reproduce the above copyright
;;;   notice, this list of conditions and the following disclaimer in
;;;   the documentation and/or other materials provided with the
;;;   distribution.
;;;
;;; * Neither the names of the authors nor the names of contributors
;;;   may be used to endorse or promote products derived from this
;;;   software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(define-format (c-format:comment . formats)
  (format:join "/* " "" " */" formats))

(define-format (c-format:block . body)
  (format:bracketed (format:indented-line "{") (format:indented-line "}")
    (format:with-indentation +2 (format:list body))))

(define-format (c-format:function return-type name parameters . body)
  (c-format:with-context 'TOP-LEVEL
    (format:sequence (format:line-start)
                     (format:line-break)
                     return-type
                     (format:line (c-format:call name parameters))
                     (c-format:block (format:list body)))))

(define-format (c-format:parameter type name)
  (format:sequence type (format:soft-break) name))

(define-format (c-format:with-keyword keyword . body)
  (format:sequence keyword (format:soft-break) (format:list body)))

(define-format (c-format:if condition body)
  (format:indented-line
   (c-format:with-keyword "if" (c-format:parenthesis condition)
     (format:soft-break)
     (format:with-indentation +2 body))))

(define-format (c-format:else body)
  (format:indented-line
   (c-format:with-keyword "else" (format:with-indentation +2 body))))

(define-format (c-format:else-if condition body)
  (format:indented-line
   (c-format:with-keyword "else if" (c-format:parenthesis condition)
     (format:soft-break)
     (format:with-indentation +2 body))))

(define-format (c-format:block* . body)
  (c-format:do/while (c-format:false) (format:list body)))

(define-format (c-format:while condition . body)
  (format:indented-line
   (c-format:with-keyword "while" (c-format:parenthesis condition)
     (format:with-indentation +2 (format:list body)))))

(define-format (c-format:for initialize condition increment . body)
  (format:indented-line
   (c-format:with-keyword "for"
       (c-format:parenthesis
        (format:sequence initialize ";" condition ";" increment))
     (format:with-indentation +2 (format:list body)))))

(define-format (c-format:do/while condition . body)
  (format:indented-line
   (c-format:with-keyword "do"
     (format:bracketed (c-format:do/while:open)
                       (c-format:do/while:close condition)
                       (format:with-indentation +2 (format:list body))))))

(define-format (c-format:do/while:open)
  (format:sequence "{" (format:line-break)))

(define-format (c-format:do/while:close condition)
  (format:indented-line
   "}"
   (format:soft-break)
   (c-format:with-keyword "while" (c-format:parenthesis condition))))

(define-format (c-format:label name)
  (format:with-indentation -1 (format:indented-line name ":")))

(define-format (c-format:declaration . body)
  (c-format:with-context 'DECLARATION
    (format:indented-line (format:list body) ";")))

(define-format (c-format:declare type name . names)
  (c-format:declare:list type (cons name names)))

(define-format (c-format:declare:list type names)
  (c-format:declaration
   type
   (format:soft-break)
   (format:with-alignment
    (format:join/infix
     (format:sequence "," (format:line-break) (format:indentation))
     names))))

(define-format (c-format:statement . body)
  (format:indented-line (c-format:with-context 'STATEMENT (format:list body))
                        ";"))

(define-format (c-format:return expression)
  (c-format:statement
   (c-format:with-keyword "return" (c-format:parenthesis expression))))

(define-format (c-format:goto label)
  (c-format:statement (c-format:with-keyword "goto" label)))

(define-format (c-format:call-statement function arguments)
  (c-format:statement (c-format:call function arguments)))

(define-format (c-format:call function arguments)
  (c-format:expression 'CALL
    (format:sequence
     (c-format:with-context 'OPERATOR function)
     (format:with-indentation +2
       (format:soft-break)
       (format:bracketed "(" ")"
         (format:with-alignment
           (format:join/infix (format:sequence "," (format:soft-break))
                              (map (lambda (argument)
                                     (c-format:with-context 'OPERAND argument))
                                   arguments))))))))

(define-format (c-format:%assign location expression)
  (format:sequence (c-format:location location)
                   (format:with-indentation +2
                     (c-format:infix-operator "=")
                     (format:with-alignment
                       (c-format:with-context 'ASSIGNMENT expression)))))

(define-format (c-format:assign location expression)
  (c-format:expression '= (c-format:%assign location expression)))

(define-format (c-format:assign-statement location expression)
  (c-format:statement (c-format:%assign location expression)))

(define-format (c-format:infix-operator string)
  (format:sequence (format:soft-break) string (format:soft-break)))

(define-format (c-format:initialize variable expression)
  (c-format:%assign variable expression))

(define-format (c-format:parenthesis format)
  (format:bracketed "(" ")"
    (format:with-alignment (c-format:with-context 'PARENTHESIS format))))

;;;; Miscellaneous Expressions

(define-format (c-format:true) "1")
(define-format (c-format:false) "0")

(define-format (c-format:cast type expression)
  (c-format:expression 'CAST
    (format:sequence (c-format:parenthesis type)
                     (format:soft-break)
                     expression)))

(define-format (c-format:sizeof expression)
  (c-format:call "sizeof" (list expression)))

(define-format (c-format:unary operator expression)
  (format:sequence operator (c-format:with-context 'UNARY-OPERAND expression)))

(define-format (c-format:address-of expression)
  (c-format:expression 'UNARY& (c-format:unary "&" expression)))

(define-format (c-format:dereference expression)
  (c-format:expression 'UNARY* (c-format:unary "*" expression)))

(define-format (c-format:array-ref array index)
  (c-format:expression 'ARRAY
    (format:sequence
     array
     (format:with-indentation +2
       (format:soft-break)
       (format:sequence "["
                        (c-format:with-context 'SUBSCRIPT
                          (format:with-alignment index))
                        "]")))))

(define-format (c-format:field expression name)
  (c-format:expression 'STRUCT.
    (format:sequence expression (c-format:infix-operator ".") name)))

(define-format (c-format:pointer-field expression name)
  (c-format:expression 'STRUCT->
    (format:sequence expression (c-format:infix-operator "->") name)))

(define-format (c-format:not expression)
  (c-format:expression 'UNARY-NOT (c-format:unary "!" expression)))

(define-format (c-format:and . expressions)
  (c-format:and:list expressions))

(define-format (c-format:and:list expressions)
  (c-format:infix-reduction "1" "&&" 'BINARY-AND expressions))

(define-format (c-format:or . expressions)
  (c-format:or:list expressions))

(define-format (c-format:or:list expressions)
  (c-format:infix-reduction "0" "||" 'BINARY-OR expressions))

(define-format (c-format:infix-reduction nullary-case operator context
                                         expressions)
  (if (pair? expressions)
      (c-format:expression context
        (format:join/infix (c-format:infix-operator operator) expressions))
      nullary-case))

;;;; Types, Storage Classes, and Other Cruft

(define-format (c-format:static mumble)
  (c-format:with-keyword "static" mumble))

(define-format (c-format:const mumble)
  (c-format:with-keyword "const" mumble))

(define-format (c-format:struct-type name)
  (c-format:with-keyword "struct" name))

(define-format (c-format:pointer-type type)
  (format:sequence type (format:non-breaking-space) "*"))

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

(define-format (c-format:array name size)
  (format:sequence
   name
   (format:with-indentation +2
     (format:soft-break)
     (format:sequence "[" (format:with-alignment size) "]"))))

(define-format (c-format:with-context context format)
  (format:with-property 'C:CONTEXT context format))

(define-format (c-format:location format)
  (c-format:with-context 'LOCATION format))

;++ This is a kludge that ought to be improved.  I guess there has to
;++ be some sort of precedence table or something here.

(define-format (c-format:expression class format)
  (let ((format (c-format:with-context class format)))
    (procedure->format
     (lambda (state)
       ((lambda (format)
          (apply-format format state))
        (case (format-state/lookup-property state 'C:CONTEXT #f)
          ((#F TOP-LEVEL DECLARATION STATEMENT PARENTHESIS SUBSCRIPT) format)
          (else (c-format:parenthesis format))))))))

(define-format (c-format:call-with-temporary-name hint formatter)
  (procedure->format
   (lambda (state)
     (let ((generator
            (format-state/lookup-property state
                                          'C-TEMPORARY-NAMER
                                          default-c-temporary-namer))
           (count
            (format-state/lookup-property state 'C-TEMPORARY-COUNT 0)))
       (apply-format (formatter (generator state hint count))
                     (format-state/insert-property state
                                                   'C-TEMPORARY-COUNT
                                                   (+ count 1)))))))

(define (format-with-c-temporary-namer generator)
  (format-with-property 'C-TEMPORARY-NAMER generator))

(define (default-c-temporary-namer state hint count)
  state                                 ;ignore
  (format:sequence "_temporary_" hint "_" (format:number count)))