;; Copyright (C) 2008-2013 Tommi Höynälänmaa
;; Distributed under GNU General Public License version 3,
;; see file doc/GPL-3.


;; Unit compilation main function


(import (rnrs exceptions)
	(srfi srfi-1)
	(th-scheme-utilities stdutils)
	(th-scheme-utilities hrecord))


(define gl-compiler
  (make-hrecord <compiler>
		'() '() '() '()
		'() '() '() '() '() '() '() '() '() '() '() '() '() '() '()
		'() '() '() '()
		""
		#f #t #f #f 0 '() '() '() '() '() '()
		#f #f '() '() '() '()
		'() '() '() '() #f '() '() #f "" '()))


(define (write-target x op pretty-print?)
  (if pretty-print?
      (pretty-print x op)
      (write x op)))


(define (check-declarations-defined compiler)
  (let ((l-undefined '()))
    (for-each (lambda (var)
		(dvar1-set! var)
		(cond
		 ((is-normal-variable? var)
		  (if (hfield-ref var 'forward-decl?)
		      (set! l-undefined
			    (cons
			     (hfield-ref (hfield-ref var 'address)
					 'source-name)
			     l-undefined))))
		 ((is-target-object? var)
		  (if (hfield-ref var 'incomplete?)
		      (set! l-undefined
			    (cons
			     (hfield-ref (hfield-ref var 'address)
					 'source-name)
			     l-undefined))))
		 (else (raise 'internal-error-with-declarations))))
	      (hfield-ref compiler 'public-decls))
	(if (not-null? l-undefined)
	    (raise (list 'declarations-not-defined
			 (cons 'l-undefined l-undefined))))))


(define (check-method-decls-defined compiler)
  (let ((l-undefined '()))
    (for-each (lambda (decl)
		(let ((gen-proc (caar decl))
		      (method (cdar decl))
		      (defined? (cdr decl)))
		  (assert (is-target-object? gen-proc))
		  (assert (is-target-object? method))
		  (if (not defined?)
		      (set! l-undefined
			    (cons (cons
				   (hfield-ref (hfield-ref gen-proc 'address)
					       'source-name)
				   (get-entity-type method))
				  l-undefined)))))
	      (hfield-ref compiler 'method-decls))
    (if (not-null? l-undefined)
	(raise (list 'method-declarations-not-defined
		     (cons 'l-undefined l-undefined))))))


(define (compute-reexport-decl var)
  (let* ((address (hfield-ref var 'address))
	 (p-address (theme-compile-address address)))
    (list 'reexport p-address)))


(define (compute-reexport-decls compiler)
  (map compute-reexport-decl (hfield-ref compiler 'reexports)))


(define (init-compiler compiler module-search-path
		       expand-only? no-expansion?
		       backtrace? err-expr?
		       pretty-print?)
  (let* ((param-cache
	  (make-hrecord <param-cache> '()))
	 (alloc-loc (lambda (s-name toplevel?) (compiler-alloc-loc
						compiler s-name toplevel?)))
	 (binder (make-hrecord <binder> param-cache alloc-loc #f #t #f #f
			       #f #f #f
			       '() '() '() '() '() '() #f #f
			       '() '() "" '() #t '())))
    (hfield-set! compiler 'binder binder)
    (hfield-set! compiler 'module-name '())
    (hfield-set! compiler 'state '())
    (hfield-set! compiler 'unit-type '())
    (hfield-set! compiler 'toplevel-unit-name '())
    (hfield-set! compiler 'lst-visited '())
    (hfield-set! compiler 'lst-enclosing-cycles '())
    ;; work-dir should not be needed
    (hfield-set! compiler 'work-dir '())
    (hfield-set! compiler 'module-search-path module-search-path)
    (hfield-set! compiler 'pretty-print-modules? pretty-print?)
    (hfield-set! compiler 'expand-only? expand-only?)
    (hfield-set! compiler 'no-expansion? no-expansion?)
    (hfield-set! compiler 'backtrace? backtrace?)
    (hfield-set! compiler 'next-free-loc gl-i-loc-start)
    (hfield-set! compiler 'imports '())
    (hfield-set! compiler 'imports-with-reexports '())
    (hfield-set! compiler 'l-used-modules '())
    (hfield-set! compiler 'l-prelinked-bodies '())
    (hfield-set! compiler 'imported-modules '())
    (hfield-set! compiler 'l-interface-imports '()) 
    (hfield-set! compiler 'reexports '())
    (hfield-set! compiler 'ht-globals-by-name '())
    (hfield-set! compiler 'ht-procs '()) 
    (hfield-set! compiler 'inside-pure-proc? #f)
    (hfield-set! compiler 'inside-param-def? #f)
    (hfield-set! compiler 'current-letrec-env '())
    (hfield-set! compiler 'current-expr '())
    (hfield-set! compiler 'current-toplevel-expr '()) 
    (hfield-set! compiler 'current-interface-var '())
    (hfield-set! compiler 'current-repr '())
    (hfield-set! compiler 'current-toplevel-repr '())
    (hfield-set! compiler 's-cur-toplevel-def '())
    (hfield-set! compiler 'error-info '())
    (hfield-set! compiler 'display-erroneous-expr? err-expr?)
    (hfield-set! compiler 'module-to-import '())
    (hfield-set! compiler 'variable-to-import '())
    (hfield-set! compiler 'show-imported-symbols?
		 gl-show-imported-symbols?)
    (hfield-set! compiler 'target-output-filename "")
    (hfield-set! compiler 'target-output-file '())))


(define (get-source-unit-type source-filename)
  (assert (string? source-filename))
  (let ((ext (get-filename-extension source-filename)))
    (cond
     ((string=? ext "") (raise 'unable-to-compute-unit-type))
     ((string=? ext source-proper-program-ext) 'proper-program)
     ((string=? ext source-script-ext) 'script)
     ((string=? ext source-interface-ext) 'interface)
     ((string=? ext source-body-ext) 'body)
     (else (raise 'unable-to-compute-unit-type)))))


(define (get-default-pcode-filename source-filename unit-type)
  (assert (string? source-filename))
  (assert (memq unit-type '(proper-program script interface body)))
  (let ((basename (get-filename-without-ext
		   (get-filename-without-path
		    source-filename)))
	(pcode-suffix (get-pcode-suffix unit-type)))
    (string-append basename pcode-suffix)))


(define (get-default-expanded-filename source-filename unit-type)
  (assert (string? source-filename))
  (assert (memq unit-type '(proper-program script interface body)))
  (let ((basename (get-filename-without-ext
		   (get-filename-without-path
		    source-filename)))
	(target-suffix
	 (case unit-type
	   ((proper-program) source-proper-program-ext)
	   ((script) source-script-ext)
	   ((interface) source-interface-ext)
	   ((body) source-body-ext)
	   (else (raise 'internal-error)))))
    (string-append basename ".expanded" target-suffix)))


(define (theme-expand-unit compiler source-filename target-filename
			   unit-type
			   module-search-path
			   backtrace? err-expr?
			   pretty-print?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (string? source-filename))
  (assert (string? target-filename))
  (assert (or (null? unit-type)
	      (memq unit-type '(proper-program script interface body))))
  (assert (and (list? module-search-path)
	       (and-map? string? module-search-path)))
  (assert (boolean? backtrace?))
  (assert (boolean? err-expr?))
  (assert (boolean? pretty-print?))
  (init-compiler compiler module-search-path
		 #t #f
		 backtrace? err-expr? pretty-print?)
  (let* ((unit-type1 (if (null? unit-type)
			 (get-source-unit-type source-filename)
			 unit-type))
	 (target-filename1 (if (string=? target-filename "")
			       (get-default-expanded-filename source-filename
							      unit-type1)
			       target-filename)))
    (hfield-set! compiler 'target-output-filename target-filename1)
    (let* ((binder (compiler-get-binder compiler))
	   (source
	    (let* ((source-file
		    (theme-open-input-file source-filename))
		   (source-code
		    (theme-read-file source-file)))
	      (theme-close-input-port source-file)
	      source-code)))
      (dw1 "Expanding unit file: ")
      (dwl1 source-filename)
      (theme-parse-unit compiler source unit-type1)
      (let* ((target-output-file
	      (theme-open-output-file target-filename1))
	     (s-keyword (case unit-type1
			  ((proper-program) skw-define-proper-program)
			  ((script) skw-define-script)
			  ((interface) skw-define-interface)
			  ((body) skw-define-body)
			  (else (raise 'internal-error))))
	     (module (hfield-ref compiler 'module-name)))
	(assert (is-module-name? module))
	(display "(" target-output-file)
	(write s-keyword target-output-file)
	(display " " target-output-file)
	(write module target-output-file)
	(newline target-output-file)
	(newline target-output-file)	
	(write-target (cons 'import (hfield-ref compiler 'imports))
		      target-output-file
		      pretty-print?)
	(newline target-output-file)
	(newline target-output-file)
	(write-target (cons 'import-and-reexport
			    (hfield-ref compiler 'imports-with-reexports))
		      target-output-file
		      pretty-print?)
	(newline target-output-file)
	(newline target-output-file)
	(write-target (cons 'use
			    (hfield-ref compiler 'l-used-modules))
		      target-output-file
		      pretty-print?)
	(newline target-output-file)
	(newline target-output-file)
	;; prelink-body forms are not allowed in interfaces.
	(if (not (eq? unit-type1 'interface))
	    (begin
	      (write-target (cons 'prelink-body
				  (hfield-ref compiler 'l-prelinked-bodies))
			    target-output-file
			    pretty-print?)
	      (newline target-output-file)
	      (newline target-output-file)))
	(for-each (lambda (expr)
		    (write-target expr target-output-file pretty-print?)
		    (newline target-output-file)
		    (newline target-output-file))
		  (hfield-ref compiler 'expanded-body))
	(display ")" target-output-file)
	(newline target-output-file)
	(theme-close-output-port target-output-file)
	(write-line-info "Unit expanded successfully.")))))


(define (theme-do-compile-unit compiler source-filename target-filename
			       unit-type
			       module-search-path
			       no-expansion?
			       backtrace? err-expr?
			       pretty-print?)
  (assert (hrecord-is-instance? compiler <compiler>))
  (assert (string? source-filename))
  (assert (string? target-filename))
  (assert (or (null? unit-type)
	      (memq unit-type '(proper-program script interface body))))
  (assert (and (list? module-search-path)
	       (and-map? string? module-search-path)))
  (assert (boolean? backtrace?))
  (assert (boolean? err-expr?))
  (assert (boolean? pretty-print?))
  (init-compiler compiler module-search-path
		 #f no-expansion?
		 backtrace? err-expr? pretty-print?)
  (let* ((unit-type1 (if (null? unit-type)
			 (get-source-unit-type source-filename)
			 unit-type))
	 (target-filename1 (if (string=? target-filename "")
			       (get-default-pcode-filename source-filename
							   unit-type1)
			       target-filename)))
    (hfield-set! compiler 'target-output-filename target-filename1)
    (let* ((binder (compiler-get-binder compiler))
	   (source
	    (let* ((source-file
		    (theme-open-input-file source-filename))
		   (source-code
		    (theme-read-file source-file)))
	      (theme-close-input-port source-file)
	      source-code)))
      (dw1 "Parsing unit file: ")
      (dwl1 source-filename)
      (theme-parse-unit compiler source unit-type1)
      (hfield-set! compiler 'state 'body-compilation)
      (if (memq unit-type1 '(body proper-program script))
	  (begin
	    (check-declarations-defined compiler)
	    (check-method-decls-defined compiler)))
      (dw1 "Actual compilation of ")
      (dw1 (case unit-type1
	     ((proper-program) "proper program")
	     ((script) "script")
	     ((interface) "interface")
	     ((body) "body")
	     (else (raise 'invalid-unit-type))))
      (dw1 " ")
      (dwl1 (hfield-ref compiler 'module-name))
      ;;      (hfield-set! compiler 'state 'body-compilation)
      (let ((target-output-file
	     (theme-open-output-file target-filename1)))
	(hfield-set! compiler 'target-output-file target-output-file)
	(if gl-test6 (raise 'error6))
	(guard
	 (exc (else
	       (raise (make-file-exception
		       'error-writing-file target-filename1))))
	 (write (hfield-ref compiler 'module-name) target-output-file)
	 (newline target-output-file)
	 (write (eq? unit-type1 'script) target-output-file)
	 (newline target-output-file)
	 (write (hfield-ref compiler 'next-free-loc) target-output-file)
	 (newline target-output-file)
	 (write (hfield-ref compiler 'imports)
		target-output-file)
	 (newline target-output-file)
	 (write (hfield-ref compiler 'imports-with-reexports)
		target-output-file)
	 (newline target-output-file)
	 (write (hfield-ref compiler 'l-used-modules)
		target-output-file)
	 (newline target-output-file)
	 (write (hfield-ref compiler 'l-prelinked-bodies)
		target-output-file)
	 (newline target-output-file)
	 (display "(" target-output-file))
	(do-compile-unit compiler
			 (hfield-ref compiler 'env)
			 (hfield-ref compiler 'body)
			 target-output-file target-filename1)
	(let ((reexport-decls
	       (compute-reexport-decls compiler)))
	  (guard
	   (exc (else
		 (raise (make-file-exception
			 'error-writing-file target-filename1))))
	   (for-each (lambda (reexport-decl)
		       (write reexport-decl target-output-file)
		       (newline target-output-file))
		     reexport-decls)
	   (display ")" target-output-file)
	   (newline target-output-file)))
	(theme-close-output-port target-output-file)
	(hfield-set! compiler 'target-output-file '())
	(hfield-set! compiler 'target-output-filename "")
	(hfield-set! compiler 'state '())
	(write-line-info "Unit compiled successfully.")))))


;; If target-filename = "" or unit-type = '() we try to compute them.
(define (theme-compile-unit compiler
			    source-filename target-filename
			    unit-type module-search-path
			    expand-only? no-expansion?
			    backtrace?
			    err-expr?
			    pretty-print?)
  (guard
   (exc
    (else (handle-compilation-error compiler exc)))
   (if (and (not expand-only?) (not no-expansion?))
       (init-source-expr-tables))
   (if (not expand-only?)
       (theme-do-compile-unit compiler source-filename target-filename
			      unit-type module-search-path
			      no-expansion?
			      backtrace?
			      err-expr?
			      pretty-print?)
       (theme-expand-unit compiler source-filename target-filename
			  unit-type module-search-path backtrace?
			  err-expr?
			  pretty-print?))))


;; Note that theme-compile-unit1 puts the target file
;; into the same directory with the source file.
;; This file is to be used inside guile interpreter
;; so we set backtrace on.
(define (theme-compile-unit1 mod-name unit-type
			     work-dir module-search-path
			     expand-only? no-expansion?
			     pretty-print?)
  (let* ((actual-mod-name
	  (if (symbol? mod-name) (list mod-name) mod-name))
	 (source-ext (get-source-code-suffix unit-type))
	 (source-filename (get-file-name-from-list-and-ext
			   work-dir
			   actual-mod-name
			   source-ext))
	 (source-ext (get-source-code-suffix unit-type))
	 (target-ext (get-pcode-suffix unit-type))
	 (target-filename
	  (if expand-only?
	      (get-file-name-from-list-and-ext
	       work-dir
	       actual-mod-name
	       (string-append ".expanded" source-ext))
	      (get-file-name-from-list-and-ext
	       work-dir
	       actual-mod-name
	       target-ext))))
    (theme-compile-unit gl-compiler
			source-filename target-filename unit-type
			module-search-path
			expand-only? no-expansion?
			#t #f pretty-print?)))
