;;;
;;; gauche.cgen.tmodule - Transient module
;;;  
;;;   Copyright (c) 2011  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.
;;;  

;; This is a private module used internally in cgen.  Not for general use.

;; The precompiler and genstub creates a temporary module in order to
;; keep track of the module where the target code runs; they shouldn't
;; be mixed with the module in which the precompiler or stub generator
;; itself is running.  Otherwise the compiled code may interfere with
;; the compiler unexpectedly.

(define-module gauche.cgen.tmodule
  (use gauche.cgen.unit)
  (use gauche.cgen.literal)
  (use gauche.parameter)
  (export <tmodule> current-tmodule-class
          current-tmodule tmodule-cname current-tmodule-cname
          all-tmodules find-tmodule select-tmodule with-tmodule)
  )
(select-module gauche.cgen.tmodule)

;; Base class
(define-class <tmodule> ()
  ([name    :init-keyword :name]
   [module  :init-form (make-module #f)]
   [cname   :init-value #f]   ; C variable name holding the module in init fn
                              ;  initialized on-demand
   [modules :allocation :class :init-value '()]))

(define-method initialize ((m <tmodule>) initargs)
  (next-method)
  (push! (class-slot-ref <tmodule> 'modules) m))

(define (tmodule-cname m)
  (or (~ m'cname)
      (rlet1 cname (cgen-allocate-static-datum)
        (set! (~ m'cname) cname)
        (let1 n (cgen-literal (~ m'name))
          (cgen-init (format "  ~a = SCM_OBJ(Scm_FindModule(SCM_SYMBOL(~a), \
                                                 SCM_FIND_MODULE_CREATE)); \
                                                 /* module ~a */"
                             cname (cgen-c-name n)
                             (cgen-safe-comment (~ m'name))))))))

;; we hide the parameter
(define %current-tmodule (make-parameter #f))

(define (current-tmodule) (%current-tmodule)) ;read-only api

;; whenever current-tmodule is switched, we need to emit a piece
;; of code in init function.
(define (%emit-select-module tm)
  (when tm
    (cgen-init (format "   Scm_SelectModule(SCM_MODULE(~a));"
                       (tmodule-cname tm)))))

;; An application may wish to use derived class.  find-tmodule and
;; select-tmodule will create a new tmodule implicitly, using this
;; class.
(define current-tmodule-class (make-parameter <tmodule>))

(define (current-tmodule-cname)
  (cond [(current-tmodule) => tmodule-cname]
        [else "mod"])) ; for the backward compatibility of genstub

(define (all-tmodules)
  (class-slot-ref <tmodule> 'modules))

(define (find-tmodule name)
  (or (find (^m (eq? name (~ m'name))) (all-tmodules))
      (make (current-tmodule-class) :name name)))

(define (select-tmodule name)
  (let1 cm (find-tmodule name)
    (%emit-select-module cm)
    (%current-tmodule cm)))

(define-syntax with-tmodule
  (syntax-rules ()
    [(_ name . body)
     (let ([prev-tm (%current-tmodule)]
           [new-tm  (find-tmodule name)])
       (dynamic-wind
           (^() (%emit-select-module new-tm))
           (^() (parameterize ((%current-tmodule new-tm)) . body))
           (^() (%emit-select-module prev-tm))))]))
