;;;
;;; gauche.cgen.unit - cgen-unit
;;;  
;;;   Copyright (c) 2004-2007  Shiro Kawai  <shiro@acm.org>
;;;   
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;   
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;  
;;;   2. 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.
;;;  
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;  
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;   "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 COPYRIGHT
;;;   OWNER OR CONTRIBUTORS 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.
;;;  
;;;  $Id: unit.scm,v 1.6 2007/08/24 23:56:30 shirok Exp $
;;;

(define-module gauche.cgen.unit
  (use srfi-1)
  (use srfi-13)
  (use srfi-42)
  (use util.match)
  (use gauche.parameter)
  (use gauche.sequence)
  (export <cgen-unit> cgen-current-unit
          cgen-unit-c-file cgen-unit-init-name cgen-unit-h-file
          cgen-unit-toplevel-nodes cgen-add!
          cgen-emit-h cgen-emit-c

          <cgen-node> cgen-cpp-condition cgen-emit
          cgen-emit-xtrn cgen-emit-decl cgen-emit-body cgen-emit-init
          cgen-extern cgen-decl cgen-body cgen-init
          cgen-include cgen-define
          
          cgen-safe-name cgen-safe-name-friendly

          ;; semi-private routines
          cgen-emit-static-data)
  )
(select-module gauche.cgen.unit)

;; NB: a small experiment to see how I feel this...
;;  [@ a b c d] => (ref (ref (ref a b) c) d)
;; In string interpolations I have to use ,(@ ...) instead of ,[@ ...], for
;; the previous versions of interpolation code doesn't like #`",[...]".
;; Ideally this should be a compiler-macro (we can't make it a macro,
;; for we want to say (set! [@ x'y] val).
(define @
  (getter-with-setter
   (case-lambda
     ((obj selector) (ref obj selector))
     ((obj selector . more) (apply @ (ref obj selector) more)))
   (case-lambda
     ((obj selector val) ((setter ref) obj selector val))
     ((obj selector selector2 . rest)
      (apply (setter ref) (ref obj selector) selector2 rest)))))
;; end experiment

;;=============================================================
;; Unit
;;

;; A 'cgen-unit' is the unit of C source.  It generates one .c file,
;; and optionally one .h file.
;; During the processing, a "current unit" is kept in a parameter
;; cgen-current-unit, and most cgen APIs implicitly work to it.

(define-class <cgen-unit> ()
  ((name     :init-keyword :name   :init-value "cgen")
   (c-file   :init-keyword :c-file :init-value #f)
   (h-file   :init-keyword :h-file :init-value #f)
   (preamble :init-keyword :preamble
             :init-value '("/* Generated by gauche.cgen $Revision: 1.6 $ */"))
   (pre-decl :init-keyword :pre-decl :init-value '())
   (init-prologue :init-keyword :init-prologue :init-value #f)
   (init-epilogue :init-keyword :init-epilogue :init-value #f)
   (toplevels :init-value '())   ;; toplevel nodes to be realized
   (transients :init-value '())  ;; transient variables
   (literals  :init-form #f)     ;; literals. see gauche.cgen.literal
   (static-data-list :init-value '()) ;; static C data, see below
   ))

(define cgen-current-unit (make-parameter #f))

(define-method cgen-unit-c-file ((unit <cgen-unit>))
  (or [@ unit'c-file]
      #`",(@ unit 'name).c"))

(define-method cgen-unit-init-name ((unit <cgen-unit>))
  (format "Scm__Init_~a"
          (or [@ unit'init-name] (cgen-safe-name [@ unit'name]))))

(define-method cgen-unit-h-file ((unit <cgen-unit>))
  [@ unit'h-file])

(define-method cgen-unit-toplevel-nodes ((unit <cgen-unit>))
  [@ unit'toplevels])

(define (cgen-add! node)
  (and-let* ((unit (cgen-current-unit)))
    (slot-push! unit 'toplevels node))
  node)

(define-method cgen-emit-part ((unit <cgen-unit>) part)
  (let1 context (make-hash-table)
    (define (walker node)
      (unless (hash-table-get context node #f)
        (hash-table-put! context node #t)
        (cgen-node-traverse node walker)
        (cgen-emit node part)))
    (for-each walker (reverse [@ unit'toplevels]))))

(define-method cgen-emit-h ((unit <cgen-unit>))
  (and-let* ((h-file (cgen-unit-h-file unit)))
    (cgen-with-output-file h-file
      (lambda ()
        (cond ([@ unit'preamble] => emit-raw))
        (cgen-emit-part unit 'extern)))))

(define-method cgen-emit-c ((unit <cgen-unit>))
  (cgen-with-output-file (cgen-unit-c-file unit)
    (lambda ()
      (cond ([@ unit'preamble] => emit-raw))
      (cond ([@ unit'pre-decl] => emit-raw))
      (print "#include <gauche.h>")
      ;; This piece of code is required, for Win32 DLL doesn't like
      ;; structures to be const if it contains SCM_CLASS_PTR.  Doh!
      (print "#if defined(__CYGWIN__) || defined(GAUCHE_WINDOWS)")
      (print "#define SCM_CGEN_CONST /*empty*/")
      (print "#else")
      (print "#define SCM_CGEN_CONST const")
      (print "#endif")
      (cgen-emit-part unit 'decl)
      (cgen-emit-static-data unit)
      (cgen-emit-part unit 'body)
      (cond ([@ unit'init-prologue] => emit-raw)
            (else
             (print "Scm__Init_"(cgen-safe-name [@ unit'name])"(void)")
             (print "{")))
      (cgen-emit-part unit 'init)
      (cond ([@ unit'init-epilogue] => emit-raw)
            (else (print "}")))
      )))

;; NB: temporary solution for inter-module dependency.
;; The real procedure is defined in gauche.cgen.literal.
(define-generic cgen-emit-static-data)

;;=============================================================
;; Base node class
;;
(define-class <cgen-node> ()
  ((extern?        :init-keyword :extern? :init-value #f)
   (cpp-condition  :init-keyword :cpp-condition
                   :init-form (cgen-cpp-condition))
   ))

(define cgen-cpp-condition (make-parameter #f))

;; fallback methods
(define-method cgen-decl-common ((node <cgen-node>)) #f)

(define-method cgen-emit-xtrn ((node <cgen-node>)) #f)
(define-method cgen-emit-decl ((node <cgen-node>)) #f)
(define-method cgen-emit-body ((node <cgen-node>)) #f)
(define-method cgen-emit-init ((node <cgen-node>)) #f)

;; Should apply WALKER to the <cgen-node> instances the NODE

;; routine should visit.  The default method scans all slots
;; and picks up any <cgen-node>.  It fails to recognize, for example,
;; the node keeps a list of <cgen-nodes>; in which case the subclass
;; must provide a proper method.
(define-method cgen-node-traverse ((node <cgen-node>) walker)
  (do-ec (: slot (map slot-definition-name (class-slots (class-of node))))
         (if (slot-bound? node slot))
         (and-let* ((var (slot-ref node slot))
                    ( (is-a? var <cgen-node>) ))
           (walker var))))

(define-method cgen-emit ((node <cgen-node>) part)
  ;; A kludge for emitting cpp-condition only when necessary.
  (define (method-overridden? gf)
    (and-let* ((meths (compute-applicable-methods gf (list node)))
               ( (not (null? meths)) ))
      (match [@ (car meths)'specializers]
        (((? (cut eq? <> <cgen-node>))) #f)
        (_ #t))))
  (define (with-cpp-condition gf)
    (cond ([@ node'cpp-condition]
           => (lambda (cppc)
                (cond ((method-overridden? gf)
                       (print "#if "cppc)
                       (gf node)
                       (print "#endif /* "cppc" */"))
                      (else (gf node)))))
          (else (gf node))))
  (case part
    ((extern) (with-cpp-condition cgen-emit-xtrn))
    ((decl)   (with-cpp-condition cgen-emit-decl))
    ((body)   (with-cpp-condition cgen-emit-body))
    ((init)   (with-cpp-condition cgen-emit-init))))

;;=============================================================
;; Raw nodes - can be used to insert a raw piece of code
;;

(define-class <cgen-raw-xtrn> (<cgen-node>)
  ((code  :init-keyword :code :init-value "")))
(define-method cgen-emit-xtrn ((node <cgen-raw-xtrn>))
  (emit-raw [@ node'code]))

(define-class <cgen-raw-decl> (<cgen-node>)
  ((code  :init-keyword :code :init-value "")))
(define-method cgen-emit-decl ((node <cgen-raw-decl>))
  (emit-raw [@ node'code]))

(define-class <cgen-raw-body> (<cgen-node>)
  ((code  :init-keyword :code :init-value "")))
(define-method cgen-emit-body ((node <cgen-raw-body>))
  (emit-raw [@ node'code]))

(define-class <cgen-raw-init> (<cgen-node>)
  ((code  :init-keyword :code :init-value "")))
(define-method cgen-emit-init ((node <cgen-raw-init>))
  (emit-raw [@ node'code]))


(define (cgen-extern . code)
  (cgen-add! (make <cgen-raw-xtrn> :code code)))

(define (cgen-decl . code)
  (cgen-add! (make <cgen-raw-decl> :code code)))
   
(define (cgen-body . code)
  (cgen-add! (make <cgen-raw-body> :code code)))

(define (cgen-init . code)
  (cgen-add! (make <cgen-raw-init> :code code)))

;;=============================================================
;; cpp
;;

;; #include ---------------------------------------------------
(define-class <cgen-include> (<cgen-node>)
  ((path        :init-keyword :path)))

(define (include-common node)
  (print "#include "
         (if (string-prefix? "<" [@ node'path])
           [@ node'path]
           #`"\",(@ node'path)\"")))

(define-method cgen-emit-xtrn ((node <cgen-include>))
  (include-common node))
(define-method cgen-emit-decl ((node <cgen-include>))
  (include-common node))

(define (cgen-include path)
  (cgen-add! (make <cgen-include> :path path)))

;; #define -----------------------------------------------------
(define-class <cgen-cpp-define> (<cgen-node>)
  ((name   :init-keyword :name)
   (value  :init-keyword :value)
   ))

(define (cpp-define-common node)
  (print "#define "[@ node'name]" "[@ node'value]))

(define-method cgen-emit-xtrn ((node <cgen-cpp-define>))
  (cpp-define-common node))
(define-method cgen-emit-init ((node <cgen-cpp-define>))
  (cpp-define-common node))

(define (cgen-define name . maybe-value)
  (cgen-add!
   (make <cgen-cpp-define> :name name :value (get-optional maybe-value ""))))

;;=============================================================
;; Utilities
;;

(define (cgen-with-output-file file thunk)
  (receive (port tmpfile) (sys-mkstemp file)
    (guard (e (else 
               (close-output-port port)
               (sys-unlink tmpfile)
               (raise e)))
      (with-output-to-port port thunk)
      (close-output-port port)
      (sys-rename tmpfile file))))

(define (emit-raw code)
  (if (list? code)
    (for-each print code)
    (print code)))

;; Creates a C-safe name from Scheme string str
(define (cgen-safe-name str)
  (with-string-io str
    (lambda ()
      (let loop ((b (read-byte)))
        (cond ((eof-object? b))
              ((or (<= 48 b 57)
                   (<= 65 b 90)
                   (<= 97 b 122))
               (write-byte b) (loop (read-byte)))
              (else
               (format #t "_~2,'0x" b) (loop (read-byte))))))))

;; Like cgen-safe-name, but using more 'friendly' transliteration.
;; Used in genstub, since the transliterated name may be referred from
;; literal C code.
;; Not for general use, since this mapping is N to 1 and there's a
;; chance of name conflict.
(define (cgen-safe-name-friendly str)
  (with-string-io str
    (lambda ()
      (let loop ((c (read-char)))
        (unless (eof-object? c)
          (case c
            ((#\-) (let ((d (read-char)))
                     (cond ((eqv? d #\>) (display "_TO") (loop (read-char)))
                           (else         (display #\_) (loop d)))))
            ((#\?) (display #\P) (loop (read-char)))
            ((#\!) (display #\X) (loop (read-char)))
            ((#\<) (display "_LT") (loop (read-char)))
            ((#\>) (display "_GT") (loop (read-char)))
            ((#\* #\> #\@ #\$ #\% #\^ #\& #\* #\+ #\= #\: #\. #\/ #\~)
             (display #\_)
             (display (number->string (char->integer c) 16))
             (loop (read-char)))
            (else (display c) (loop (read-char)))
            ))))))

(provide "gauche/cgen/unit")


