(module dotnet_dotnet
   (include "Ast/unit.sch"
	    "Engine/pass.sch")
   
   (import type_type
	   type_typeof
	   ast_var
	   ast_node
	   ast_env
	   tools_shape
	   tools_error
	   cc_exec
	   object_class
	   engine_param
	   module_module
	   read_jvm
	   backend_c_main
	   backend_c_prototype
	   dotnet_compile
	   dotnet_as)
   
   (export (dotnet ::pair-nil))
   
   (eval   (export *dotnet-external-asms*)))

;*---------------------------------------------------------------------*/
;*    dotnet ...                                                       */
;*---------------------------------------------------------------------*/
(define (dotnet globals)
   ;; the dotnet prelude (hello message and *DEST* update)
   (pass-prelude ".Net" start-dotnet-emission!)
   (verbose 2 "      [module: " *module* " qualified type name: "
	    (module->qualified-type *module*) "]"#\Newline)
   (set! *jvm-purify* #t)
   ;; if we are going to link and we have not found a main yet, we
   ;; have to produce a fake one
   (if (and (not *main*) (memq *pass* '(ld distrib)))
       (set! *main* (make-bigloo-main)))
   ;; the dotnet driver
   (define (emit code* dest)
      (let ((dir *dotnet-dir-name*))
	 (let ((port (if (not (string? dest))
			 (current-output-port)
			 (open-output-file (make-file-name dir dest)))))
	    (for-each (lambda (c) (dotnet-as c port)) code*)
	    (if (not (eq? port (current-output-port)))
		(close-output-port port)))))
   (let ((l* (dotnet-compile globals))
	 (bname (cond
		   ((eq? *pass* 'ld)
		    (if (pair? *src-files*)
			(addsuffix (prefix (basename (car *src-files*))))
			"a.class"))
		   ((not (string? *dest*))
		    (if (pair? *src-files*)
			(addsuffix (prefix (basename (car *src-files*))))
			#f))
		   (else
		    (addsuffix (prefix (basename *dest*)))))))
      ;; assembly code emission
      (cond
	 ((eq? *pass* 'il)
	  (emit l* bname))
	 (*dotnet-use-external-asm*
	  (emit l* bname)
	  (dotnet-external-asm (make-file-name *dotnet-dir-name* bname)))
	 (else
	  #unspecified))))

(define *dotnet-dir-name* ".")

(define (addsuffix name)
   (string-append name ".il") )

(define (ilname cf)
   (match-case cf
      (((class ?name) . ?-)
       (addsuffix (symbol->string name)))))

;*---------------------------------------------------------------------*/
;*    start-dotnet-emission! ...                                       */
;*---------------------------------------------------------------------*/
(define (start-dotnet-emission!)
   (cond
      ((string? *dest*)
       (let ((dname (dirname *dest*)))
	  (if (not (string=? dname ""))
	      (set! *dotnet-dir-name* (dirname *dest*)))))
      ((eq? *pass* 'ld)
       (if (pair? *src-files*)
	   (set! *dotnet-dir-name* (dirname (car *src-files*))))))
   (if (not (and (file-exists? *dotnet-dir-name*)
		 (directory? *dotnet-dir-name*) ))
       (error "start-dotnet-emission!"
	      "Can't write dest file because directory doesn't exist"
	      *dotnet-dir-name*)
       #t))

;*---------------------------------------------------------------------*/
;*    *dotnet-external-asms* ...                                       */
;*---------------------------------------------------------------------*/
(define *dotnet-external-asms* 
   (list (cons 'pnet dotnet-external-pnet-asm)))

;*---------------------------------------------------------------------*/
;*    dotnet-external-asm ...                                          */
;*---------------------------------------------------------------------*/
(define (dotnet-external-asm name)
   (let* ((id *dotnet-external-asm-style*)
	  (c (assq id *dotnet-external-asms*)))
      (if (and (pair? c)
	       (procedure? (cdr c))
	       (correct-arity? (cdr c) 1))
	  (begin
	     ((cdr c) name)
	     (if *rm-tmp-files*
		 (let ((f (string-append (prefix name) ".il")))
		    (verbose 2 "      [rm " f  #\] #\Newline)
		    (delete-file f))))
	  (error "asm (dotnet)"
		 (apply string-append
			"Unknown asm style, supported: "
			(map (lambda (x)
				(if (and (pair? x)
					 (symbol? (car x)))
				    (string-append (symbol->string (car x))
						   " ")
				    ""))
			     *dotnet-external-asms*))
		 *dotnet-external-asm-style*))))

;*---------------------------------------------------------------------*/
;*    dotnet-external-pnet-asm ...                                     */
;*---------------------------------------------------------------------*/
(define (dotnet-external-pnet-asm name)
   (if (string=? *dotnet-external-asm* "")
       (error "ast (dotnet)"
	      "Illegal DotNet asm (bad .NET Bigloo confguration)"
	      *dotnet-external-asm*)
       (let ((cmd (string-append *dotnet-external-asm*
				 " "
				 (prefix name) ".il")))
	  (verbose 1 "   . ilasm (" *dotnet-external-asm* ")" #\Newline)
	  (verbose 2 "      ["  cmd #\] #\Newline)
	  (exec cmd #t "ilasm"))))
      
