;; C code generator
;; generates a small subset of C language constructs

;; for C BNF see
;; http://lists.canonical.org/pipermail/kragen-hacks/1999-October/000201.html


;; since C code is nested, it doesn't fit the flat assembler code
;; generation framework in BADNOP. however, it is easy to use just a
;; small subset on top of this abstraction that is flat, and can be
;; used as an assembler target language.

;; both EXPRESSION and STATEMENT sublanguages are organized as:
;; - a minimal set of sexp -> string formatting primitives
;; - a symbolic set of transformers on top of that

;; the formatter uses an s-expression interpreter interpreter defined
;; in the 'interpreter' macro.

;; note that the extension mechanism (s-expr only) is different from
;; the definition mechanism 'c-code-generators'.


;; (set-selective-display 3)

(module cgen mzscheme
  (require (lib "match.ss")
           (lib "list.ss")
           "indent.ss")
  
  (provide
   ;; default functionality
   statement->string
   expression->string

   ;; extensions
   extend-statements
   extend-expressions
   transformer)


  ;; GENERATORS

  (define (expression->string s-exp)
    (e s-exp))
  (define (statement->string s-exp)
    (*statement* s-exp
                 default-indent
                 default-tab))
  
  ;; create an s expression formatter (macro interpreter)
  ;; used for sexp -> string mapping
  (define-syntax formatter
    (syntax-rules  ()
      ((_ default-formatter
          (define (name . formals) body ...) ...)
       (lambda (e)
         (let ((args (cdr e)))
           (case (car e)
             ((name) (apply (lambda formals body ...) args))
             ...
             (else (default-formatter e))))))))
              

  ;; same as above, but default behaviour = return false
  ;; used for sexp -> sexp mapping
  (define (false x) #f)
  (define-syntax transformer
    (syntax-rules ()
      ((_ defines ...)
       (formatter false defines ...))))

  (define default-tab (make-tab "    "))

  ;; functionality is extended using these hooks
  (define *expression* #f)
  (define *statement*  #f)

  ;; extensions modify the variables above. for simplicity, extensions
  ;; are only s-expression transformers: primitive formatters are
  ;; fixed, and can take other objects besides s-expressions.

  ;; a transformer returns #f if it didn't transform the expression,
  ;; in which case transformation is delegated to parent. if it did
  ;; transform, the whole expression needs to be re-transformed from
  ;; toplevel.
         
  (define-syntax make-extender
    (syntax-rules ()
      ((_ *hook* top)
       (lambda (transformer)
         (let ((parent *hook*))
           (set! *hook*
                 (lambda (e . r) ;; expression . rest of formatter args
                   (define (continue tx e+)
                     (apply tx (cons e+ r)))
                   (let ((txe (transformer e)))
                     (if txe
                         (continue top txe)
                         (continue parent e))))))))))
  

  ;; these procedures take a single argument 'transformer' which is an
  ;; s-expression transformer. first one calls 'e' to support non-sexp.
  (define extend-expressions (make-extender *expression* e))
  (define extend-statements  (make-extender *statement*  *statement*))



  
  

  
  ;; EXPRESSION FORMATTER

  ;; using short names since they are used a lot. expressions are not
  ;; indented: they are nested on one line.

  ;; 3 entry points:
  
  ;; e  : expression
  ;; es : list of expressions
  ;; pe : parenthesized expression if infix
  ;; for symbol classes

  (define (->symbols lst)
    (map (lambda (x)
           (if (string? x)
               (string->symbol x) x)) lst))
  
  (define-syntax member-tests
    (syntax-rules ()
      ((_ (thing? lst) ...)
       (begin
         (define thing?
           (let ((symbols (->symbols lst)))
             (lambda (x)
               (and (member x symbols) #t))))
         ...))))
  
  (member-tests
   (key?
    '(return goto break continue))
   (infix?
    '("+" "-" "*" "/" "&" "|" "&&" "||" "<<" ">>"
      ">" "<" "<=" ">=" "!=" "=="
      "=" "+=" "-=" "|=" "&=" "<<=" ">>="
      "->"
      )))

  (define (e exp . opt)
    (if (pair? exp)
        ;; invoke s-expression interpreter
        (apply *expression* (cons exp opt))

        ;; not a list -> literal/variable
        ;; this needs to be '~s' instead of '~a' to enable literal strings
        (format "~s" exp)))

  (define (es exp-lst)
    (map e exp-lst))

  (define (infix-expression? exp)
    (and (pair? exp)
         (infix? (car exp))))


  (define (pe exp) (e exp 'paren))

  (define (join separator args)
    (if (null? args) ""
        (apply string-append
               (cons 
                (format "~a" (car args))
                (map
                 (lambda (arg)
                   (format "~a~a" separator arg))
                 (cdr args))))))

  
  ;; default expression formatter
  ;; need to wrap infix operators in parens if they are not toplevel.
  (define (simple-expression exp . opt)
    
    (define (nothing x) x)
    (define (paren x) (format "(~a)" x))
    
    (let ((fix
           (match opt
            (()       nothing)
            (('paren) paren))))

      (match
       exp
       
       (((and op (= infix? #t)) left right)
        (fix (format "~a ~a ~a" (pe left) op (pe right))))
     
       ((op . args)
        (format "~a~a" op
                (format
                 (cond
                  ;; ((null? args) "~a")
                  ((key? op)    " ~a")
                  (else         "(~a)"))
                 (join ", " (es args))))))))

  ;; default top level expression formatter
  (define (expression exp . opt)

    (define (default-expression e)
      (apply simple-expression (cons e opt)))

    ;; default expression formatter
    ((formatter
      default-expression ;; parent formatter

      (define (post  op arg) (format "~a~a"   (e arg) op))
      (define (pre   op arg) (format "~a~a"   op (e arg)))
      (define (index name i) (format "~a[~a]" (pe name) (e i)))
      
      (define (if test yes no)
        (format "~a ? ~a : ~a"
                (pe test) (pe yes) (pe no)))
      
      ;; downward let* using gcc extension "Statements and
      ;; Declarations in Exressions".
      (define (let* decls . body)
        (format "({ ~a})"
                (statement-noindent
                 `(statements (vars ,@decls) ,@body)))))
     exp))


  ;; STATEMENT FORMATTER
  
  ;; statements are indented.

  
  (define (null->void lst) (if (null? lst) '("void") lst))
  (define (declaration d) (format "~a ~a" (first d) (second d)))
  (define (declarations lst) (null->void (map declaration lst)))

  ;; format code to be included in an expression (for downward let)
  (define (statement-noindent s-exp)
    (*statement* s-exp
                 (format->indent format " ")
                 no-tab))
  
  ;; default top level statement formatter
  (define (statement s-expression indent tab)

    ;; formatting utilities bound to indentation
    (define (indented e) (*statement* e (tab indent) tab))
    (define (not-indented e) (*statement* e indent tab))
    (define (exp-statement exp) (indent "~a;" (e exp)))
    (define (expand lst)
      (apply string-append
       (map not-indented lst)))

    ((formatter
      exp-statement ;; bottom level formatter

      (define (statements . body) (expand body))
      (define (append str) str)
      (define (label-head name) (indent "~a:" name))
      (define (comment str) (indent "// ~a" str))
      (define (line str) (indent "~a" str))        
     
      (define (fun-head terminator fn . args)
        (format "~a(~a)~a"
                (declaration fn)
                (join ", " (declarations args))
                terminator))
      
      (define (indented . statements)
        (apply string-append
               (map indented statements)))
      
      (define (for-head . exp-lst)
        (indent "for (~a)" (join "; " (es exp-lst))))
      
      (define (var type name . vallist)
        (indent "~a ~a~a;" (e type) name
                (match vallist
                       (()  "")
                       ((v) (format " = ~a" (e v)))))))
     s-expression))
    
    
  ;; close hooks
  (set! *statement* statement)
  (set! *expression* expression)

  ;; TRANSFORMERS
  ;; highlevel statement/expression transformers
  
  (extend-statements
   (transformer

    (define (def decls . body) 
      `(statements
        (fun-head "\n" ,@decls)
        (block ,@body)))

    (define (decl . decls)
      `(fun-head ";\n" ,@decls))

    (define (label name . body)
      `((label-head ,name)
        (indented ,@body)))

    (define (vars . decls) 
      `(statements
        ,@(map (lambda (d)
                 (cons 'var d))
               decls)))
    
    (define (for exp-lst . body)
      `(statements
        (for-head ,@exp-lst)
        (block ,@body)))

    (define (bind decls . body)
      `(block
        (vars ,@decls)
        ,@body))

    (define (block . s)
      `(statements
        (line "{")
        (indented ,@s)
        (line "}")))))

  

  

)