#!/usr/bin/guile-@guile_version@ \
-e main -s
!#

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


;; *** Theme linker main program ***


(import (rnrs exceptions)
	(rnrs conditions)
	(srfi srfi-1)
	(th-scheme-utilities stdutils)
	(th-scheme-utilities hrecord)
	(th-scheme-utilities parse-command-line)
	(theme-d common theme-d-config)
	(theme-d translator theme-d-linker))


(init-theme-d-config)

(define gl-theme-d-translator-dir
  (get-theme-d-config-var 'translator-dir))

(define gl-theme-d-lib-dir
  (get-theme-d-config-var 'lib-dir))

(define gl-guile-version
  (get-theme-d-config-var 'guile-version))


(define (parse-module-name mod-name-str)
  (assert (string? mod-name-str))
  (let ((len (string-length mod-name-str)))
    (cond
     ((= len 0)
      (raise 'empty-module-name))
     ((eqv? (string-ref mod-name-str 0) #\()
      (strong-assert (eqv? (string-ref mod-name-str (- len 1)) #\)))
      (let ((str2 (substring mod-name-str 1 (- len 1))))
	(if (= (string-length str2) 0)
	    (raise 'empty-list-module-name)
	    (let* ((str-list-path (split-string str2 #\space)))
	      (if (= (length str-list-path) 0)
		  (raise 'parse-module-name:internal-error)
		  (let ((mod-name (map string->symbol str-list-path)))
		    mod-name))))))
     (else
      (if (string-contains-char? mod-name-str #\space)
	  (raise 'invalid-module-name)
	  (string->symbol mod-name-str))))))


(define (get-unit-name unit-filename)
  (let* ((file (theme-open-input-file unit-filename))
	 (name (theme-read file)))
    (theme-close-input-port file)
    (strong-assert (and (list? name) (not-null? name)
			(and-map? symbol? name)))
    name))


(define (my-error-exit backtrace?)
  (if backtrace?
      (raise 'error)
      (exit 1)))


(define (main args)
  (let ((module-search-path0 "")
	(source-filename "")
	(interm-filename "")
	(target-filename "")
	(message-level 1)
	(s-intermediate-language0 'tree-il)
	(s-intermediate-language '())
	(l-str-custom-modules '())
	(l-str-custom-relative-modules '())
	(final-compilation? #t)
	(keep-intermediate? #f)
	(link-to-cache? #f)
	(all-assertions? #t)
	(factorize? #t)
	(strip? #t)
	(pretty-print? #f)
	(verbose-errors? #t)
	(verbose-typechecks? #f)
	(verbose-unlinked-procedures? #t)
	(backtrace? #f)
	(runtime-pretty-backtrace? #f)
	(module-debug-output? #f))
    (let* ((argd1 (make-hrecord <argument-descriptor> #\m #t
				(lambda (option-arg)
				  (set! module-search-path0 option-arg))))
	   (argd2 (make-hrecord <argument-descriptor> "module-path" #t
				(lambda (option-arg)
				  (set! module-search-path0 option-arg))))
	   (argd3 (make-hrecord <argument-descriptor> #\o #t
				(lambda (option-arg)
				  (set! target-filename option-arg))))
	   (argd4 (make-hrecord <argument-descriptor> "output" #t
				(lambda (option-arg)
				  (set! target-filename option-arg))))
	   (argd5 (make-hrecord <argument-descriptor> #\l #t
				(lambda (option-arg)
				  (set! message-level
					(string->number option-arg)))))
	   (argd6 (make-hrecord <argument-descriptor> "message-level" #t
				(lambda (option-arg)
				  (set! message-level
					(string->number option-arg)))))	   
	   (argd7 (make-hrecord <argument-descriptor> "intermediate-language"
				#t
				(lambda (option-arg)
				  (set! s-intermediate-language0
					(string->symbol option-arg)))))
	   (argd8 (make-hrecord <argument-descriptor> #\i
				#t
				(lambda (option-arg)
				  (set! s-intermediate-language0
					(string->symbol option-arg)))))
	   (argd9 (make-hrecord <argument-descriptor> "no-final-compilation" #f
				(lambda ()
				  (set! final-compilation? #f))))
	   (argd10 (make-hrecord <argument-descriptor> "no-weak-assertions" #f
				 (lambda ()
				   (set! all-assertions? #f))))
	   (argd11 (make-hrecord <argument-descriptor> "no-factorization" #f
				 (lambda ()
				   (set! factorize? #f))))
	   (argd12 (make-hrecord <argument-descriptor> "no-strip" #f
				(lambda ()
				  (set! strip? #f))))
	   (argd13 (make-hrecord <argument-descriptor> "pretty-print" #f
				(lambda ()
				  (set! pretty-print? #t))))
	   (argd14 (make-hrecord <argument-descriptor> "no-verbose-errors" #f
				(lambda ()
				  (set! verbose-errors? #f))))
	   (argd15 (make-hrecord <argument-descriptor> "verbose-typechecks" #f
				(lambda ()
				  (set! verbose-typechecks? #t))))
	   (argd16 (make-hrecord <argument-descriptor> "backtrace" #f
				(lambda ()
				  (set! backtrace? #t))))
	   (argd17 (make-hrecord <argument-descriptor> "intermediate-file"
				 #t
				 (lambda (option-arg)
				   (set! interm-filename option-arg))))
	   (argd18 (make-hrecord <argument-descriptor> #\n
				 #t
				 (lambda (option-arg)
				   (set! interm-filename option-arg))))
	   (argd19 (make-hrecord <argument-descriptor> "keep-intermediate" #f
				(lambda ()
				  (set! keep-intermediate? #t))))
	   (argd20 (make-hrecord <argument-descriptor> "link-to-cache" #f
				(lambda ()
				  (set! link-to-cache? #t))))
	   (argd21 (make-hrecord <argument-descriptor>
				 "no-unlinked-procedure-names" #f
				(lambda ()
				  (set! verbose-unlinked-procedures? #f))))
	   (argd22 (make-hrecord <argument-descriptor>
				 "runtime-pretty-backtrace"
				 #f
				 (lambda ()
				   (set! runtime-pretty-backtrace? #t))))
	   (argd23 (make-hrecord <argument-descriptor>
				 "module-debug-output"
				 #f
				 (lambda ()
				   (set! module-debug-output? #t))))
	   (argd24 (make-hrecord <argument-descriptor> #\x #t
				 (lambda (option-arg)
				   (set! l-str-custom-modules
					 (append l-str-custom-modules
						 (list option-arg))))))
	   (argd25 (make-hrecord <argument-descriptor> #\y #t
				 (lambda (option-arg)
				   (set! l-str-custom-relative-modules
					 (append l-str-custom-relative-modules
						 (list option-arg))))))
	   (arg-descs (list argd1 argd2 argd3 argd4 argd5 argd6 argd7 argd8
			    argd9 argd10 argd11 argd12 argd13 argd14
			    argd15 argd16 argd17 argd18 argd19 argd20
			    argd21 argd22 argd23 argd24 argd25))
	   (args-without-cmd (cdr args))
	   (handle-proper-args (lambda (proper-args)
				 (if (= (length proper-args) 1)
				     (set! source-filename (car proper-args))
				     (raise 'command-line-syntax-error)))))
      (parse-command-line args-without-cmd arg-descs handle-proper-args)
      (if (or (not (string? source-filename))
	      (string-null? source-filename))
	  (begin
	    (write-line-info "Invalid source filename.")
	    (my-error-exit backtrace?)))
      (if (not (file-exists? source-filename))
	  (begin
	    (write-line-info "Source file does not exist.")
	    (my-error-exit backtrace?)))
      (set! gl-show-info? (not (= message-level 0)))
      (if (> message-level 0)
	  (set! debug-level (- message-level 1))
	  (set! debug-level 0))
      (let ((module-search-path
	     (if (string-null? module-search-path0)
		 (list gl-theme-d-lib-dir ".")
		 (parse-search-path module-search-path0 gl-theme-d-lib-dir)))
	    (program-name
	     (guard (exc
		     ((and (condition? exc) (theme-file-exception? exc))
		      (display (get-file-error-message exc))
		      (newline)
		      (my-error-exit backtrace?))
		     (else (display "Error.\n")))
		    (get-unit-name source-filename))))
	(if (not (is-module-name? program-name))
	    (begin
	      (write-line-info "Program file corrupted. Invalid program name.")
	      (my-error-exit backtrace?)))
	(if (or (not (symbol? s-intermediate-language0))
		(not (memq s-intermediate-language0
			   '(tree-il tree-il-2.2 tree-il-2.0 scheme
				     scheme-no-opt racket bigloo))))
	    (begin
	      (write-line-info "Unknown intermediate language.")
	      (my-error-exit backtrace?)))
	(set! s-intermediate-language
	      (cond
	       ((memq s-intermediate-language0 gl-l-all-int-lang)
		s-intermediate-language0)
	       ((eq? s-intermediate-language0 'tree-il)
		(cond
		 ((string=? gl-guile-version "3.0") 'tree-il-3.0)
		 ((string=? gl-guile-version "2.2") 'tree-il-2.2)
		 ((string=? gl-guile-version "2.0") 'tree-il-2.0)
		 (else
		  (write-line-info
		   "Invalid Guile version in the configuration file.")
		  (my-error-exit backtrace?))))
	       (else
		(write-line-info
		 "Invalid intermediate language.")
		(my-error-exit backtrace?))))
	;; Racket target files are not currently compiled.
	;; Hence we keep the intermediate file always.
	(if (eq? s-intermediate-language 'racket)
	    (begin
	      (set! final-compilation? #f)
	      (set! keep-intermediate? #t)))
	(if (and (not-null? l-str-custom-relative-modules)
		 (not (eq? s-intermediate-language 'racket)))
	    (begin
	      (write-line-info
	       "Relative modules are supported only for Racket.")
	      (my-error-exit backtrace?)))
	(dw1 "source filename: ")
	(dwl1 source-filename)
	(dw1 "intermediate filename (empty for default): ")
	(dwl1 interm-filename)
	(dw1 "target filename (empty for default): ")
	(dwl1 target-filename)
	(dw1 "module search path: ")
	(dwl1 module-search-path)
	(dw1 "intermediate language: ")
	(dwl1 (symbol->string s-intermediate-language))
	(dw1 "custom modules: ")
	(dwl1 l-str-custom-modules)
	(dw1 "custom relative modules: ")
	(dwl1 l-str-custom-relative-modules)
	(dw1 "final compilation: ")
	(dwl1 (if final-compilation? "yes" "no"))
	(dw1 "keep intermediate: ")
	(dwl1 (if keep-intermediate? "yes" "no"))
	(dw1 "link to cache: ")
	(dwl1 (if link-to-cache? "yes" "no"))
	(dw1 "check all assertions: ")
	(dwl1 (if all-assertions? "yes" "no"))
	(dw1 "factorize out type expressions: ")
	(dwl1 (if factorize? "yes" "no"))
	(dw1 "strip unused code: ")
	(dwl1 (if strip? "yes" "no"))
	(dw1 "message level: ")
	(dwl1 message-level)
	(dw1 "pretty print target code: ")
	(dwl1 (if pretty-print? "yes" "no"))
	(dw1 "verbose error messages: ")
	(dwl1 (if verbose-errors? "yes" "no"))
	(dw1 "verbose typechecks: ")
	(dwl1 (if verbose-typechecks? "yes" "no"))
	(dw1 "report unlinked procedure names: ")
	(dwl1 (if verbose-unlinked-procedures? "yes" "no"))
	(dw1 "backtrace: ")
	(dwl1 (if backtrace? "yes" "no"))
	(dw1 "runtime pretty backtrace: ")
	(dwl1 (if runtime-pretty-backtrace? "yes" "no"))
	(dw1 "module debug output: ")
	(dwl1 (if module-debug-output? "yes" "no"))
	(theme-link-program gl-linker program-name
			    source-filename
			    interm-filename
			    target-filename
			    module-search-path
			    s-intermediate-language
			    l-str-custom-modules
			    l-str-custom-relative-modules
			    final-compilation?
			    keep-intermediate?
			    link-to-cache?
			    all-assertions?
			    factorize?
			    strip?
			    pretty-print?
			    verbose-errors?
			    verbose-typechecks?
			    verbose-unlinked-procedures?
			    backtrace?
			    runtime-pretty-backtrace?
			    module-debug-output?))))
  0)
