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


;; *** Linker main program ***


(import (rnrs exceptions)
	(srfi srfi-1)
	(ice-9 pretty-print)
	(th-scheme-utilities stdutils)
	(th-scheme-utilities hrecord))


(define gl-l-all-int-lang '(tree-il-3.0 tree-il-2.2 tree-il-2.0
					scheme scheme-no-opt
					racket bigloo))

(define gl-l-tree-il-lang '(tree-il-3.0 tree-il-2.2 tree-il-2.0))

(define gl-l-scheme-lang '(scheme scheme-no-opt racket bigloo))

(define gl-i-ht-used-size 20000)

(define gl-i-ht-method-defs-size 10000)

(define gl-i-ht-method-decls-size 10000)

(define gl-i-ht-used-decls-size 10000)

(define gl-i-ht-rebound-size 10000)

(define gl-i-ht-decl-types-size 10000)

(define gl-i-ht-globals-by-address-size 10000)

(define gl-i-ht-globals-by-name-size 10000)

(define gl-i-ht-cycles-size 1000)

(define gl-i-ht-goops-classes-size 2000)

(define gl-i-ht-prim-classes-size 500)

(define gl-i-ht-fact-size 500)

(define gl-i-ht-module-indices-size 100)

(define gl-i-ht-lexical-vars-size 10000)

(define gl-i-ht-raw-procs-size 2000)

(define gl-i-ht-equal-size 500)

(define gl-i-ht-equal-objects-size 500)

(define gl-i-ht-equal-contents-size 500)

(define gl-debug '())

(define gl-flag20?)


(define (use-tree-il? linker)
  (memq (hfield-ref linker 's-intermediate-language) gl-l-tree-il-lang))


(define (use-racket? linker)
  (eq? (hfield-ref linker 's-intermediate-language) 'racket))


(define (get-first-free-loc linker module-name)
  (let* ((actual-module-name (get-actual-module-name module-name))
	 (ext (get-pcode-suffix 'body))
	 (module-search-path
	  (hfield-ref linker 'module-search-path))
	 (source-filename (search-file module-search-path
				       actual-module-name ext)))
    (if (string? source-filename)
	(let* ((file-source (theme-open-input-file source-filename))
	       (i-first-free-loc (begin (theme-read file-source)
					(theme-read file-source)
					(theme-read file-source))))
	  (theme-close-input-port file-source)
	  (if (and (integer? i-first-free-loc) (>= i-first-free-loc 0))
	      i-first-free-loc
	      (raise 'invalid-first-free-loc)))
	(raise (list 'module-body-not-found
		     (cons 'module-name module-name))))))


(define (get-interm-file-ext s-int)
  (assert (memq s-int gl-l-all-int-lang))
  (cond
   ((memq s-int gl-l-tree-il-lang)
    tree-il-file-ext)
   ((eq? s-int 'racket)
    racket-file-ext)
   (else
    scheme-file-ext)))


(define (get-pcode-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 pcode-proper-program-ext) 'proper-program)
     ((string=? ext pcode-script-ext) 'script)
     (else (raise 'unable-to-compute-unit-type)))))


(define (parse-guile-module-name str-module-name)
  (strong-assert (string? str-module-name))
  (let ((i-len (string-length str-module-name)))
    (if (and (> i-len 2)
	     (eqv? (string-ref str-module-name 0) #\()
	     (eqv? (string-ref str-module-name (- i-len 1)) #\)))
	(let* ((str2
		(substring str-module-name 1 (- i-len 1))))
	  (map string->symbol (split-string str2 #\space)))
	(raise (list 'invalid-guile-module-name
		     (cons 'str-module-name str-module-name))))))


(define (compile-program-prefix-tree-il linker script? l-str-custom-modules)
  (assert (boolean? script?))
  (assert (and (list? l-str-custom-modules)
	       (for-all string? l-str-custom-modules)))
  (let ((l-result
	 (list
	  (tc-tree-il-import-target-module
	   linker '(rnrs))
	  (tc-tree-il-import-target-module
	   linker '(srfi srfi-1))
	  (tc-tree-il-import-target-module
	   linker '(oop goops))
	  (tc-tree-il-import-target-module
	   linker '(th-scheme-utilities stdutils))
	  (tc-tree-il-import-target-module
	   linker '(theme-d runtime theme-d-support))
	  (tc-tree-il-import-target-module
	   linker '(theme-d runtime theme-d-stdlib-support))
	  (tc-tree-il-import-target-module
	   linker '(theme-d runtime runtime-theme-d-environment))))
	(s-call (tree-il-get-call-keyword linker)))
    (if (not-null? l-str-custom-modules)
	(set! l-result
	      (append
	       l-result
	       (map (lambda (str-module)
		      (tc-tree-il-import-target-module
		       linker (parse-guile-module-name str-module)))
		    l-str-custom-modules))))
    (set! l-result
	  (append l-result
		  (list
		   `(,s-call (toplevel set-theme-d-script!)
			     (const ,script?)))))
    (set! l-result
	  (append l-result
		  (list
		   `(,s-call
		     (toplevel set-pretty-backtrace-support!)
		     (const
		      ,(hfield-ref linker 'runtime-pretty-backtrace?))))))
    (set! l-result
	  (append l-result
		  (list
		   `(,s-call (toplevel theme-set-command-line!)
			     (,s-call (toplevel command-line))))))
    l-result))


(define (compile-program-prefix-guile linker script?
				      l-str-custom-modules)
  (assert (boolean? script?))
  (assert (and (list? l-str-custom-modules)
	       (for-all string? l-str-custom-modules)))
  (let ((l-result
	 (list
	  '(import (rnrs))
	  '(import (srfi srfi-1))
	  '(import (oop goops))
	  '(import (th-scheme-utilities stdutils))
	  '(import (theme-d runtime theme-d-support))
	  '(import (theme-d runtime theme-d-stdlib-support))
	  '(import (theme-d runtime runtime-theme-d-environment)))))
    (if (not-null? l-str-custom-modules)
	(set! l-result
	      (append l-result
		      (list
		       `(import ,@(map parse-guile-module-name
				       l-str-custom-modules))))))
    (set! l-result
	  (append l-result
		  (list
		   `(set-theme-d-script! ,script?))))
    (set! l-result
	  (append l-result
		  (list
		   `(set-pretty-backtrace-support!
		     ,(hfield-ref linker 'runtime-pretty-backtrace?)))))
    (set! l-result
	  (append l-result
		  (list
		   '(theme-set-command-line! (command-line)))))
    l-result))


(define (compile-program-prefix-racket linker script?
				       l-str-custom-modules
				       l-str-custom-relative-modules)
  (assert (and (list? l-str-custom-modules)
	       (for-all string? l-str-custom-modules)))
  (assert (and (list? l-str-custom-relative-modules)
	       (for-all string? l-str-custom-relative-modules)))
  (let ((l-result
	 (if (not script?)
	     (list '(provide main))
	     '())))
    (set! l-result
	  (append
	   l-result
	   (list
	    '(require (except-in rnrs assert))
	    '(require rnrs/mutable-pairs-6)
	    '(require theme-d-racket/th-scheme-utilities/stdutils)
	    '(require theme-d-racket/runtime/runtime-theme-d-environment)
	    '(require theme-d-racket/runtime/theme-d-alt-support)
	    '(require theme-d-racket/runtime/theme-d-stdlib-support)
	    `(set-pretty-backtrace-support!
	      ,(hfield-ref linker 'runtime-pretty-backtrace?)))))
    (if (not-null? l-str-custom-modules)
	(set! l-result
	      (append l-result
		      (list
		       `(require ,@(map string->symbol
					l-str-custom-modules))))))
    (if (not-null? l-str-custom-relative-modules)
	(set! l-result
	      (append l-result
		      (list
		       `(require ,@l-str-custom-relative-modules)))))
    (set! l-result
	  (append l-result
		  (list
		   '(theme-set-command-line!
		     ;; The first argument is the program name.
		     (cons "" (vector->list
			       (current-command-line-arguments)))))))
    l-result))


(define (not-null-texpr? texpr)
  (and (not (null? texpr)) (not (equal? texpr '(quote ())))))


(define (write-module-body file texpr-list pretty-print?)
  (if pretty-print?
      (for-each (lambda (texpr)
		  (if (not-null-texpr? texpr)
		      (begin
			(pretty-print texpr file) (newline file))))
		texpr-list)
      (for-each (lambda (texpr)
		  (if (not-null-texpr? texpr)
		      (begin (write texpr file) (newline file))))
		texpr-list)))


(define (write-target-expr linker file pretty-print? t-expr)
  (if (not-null-texpr? t-expr)
      (let ((lst
	     (if (and (pair? t-expr)
		      (equal? (car t-expr) '_splice))
		 (cdr t-expr)
		 (list t-expr))))
	(guard (exc (else
		     (make-file-exception
		      'error-writing-file
		      (hfield-ref linker 'interm-filename))))
	       (set! gl-debug t-expr)
	       (write-module-body file lst pretty-print?)))))
  

(define (theme-target-compile-program linker lst-entities)
  (cond
   ((use-tree-il? linker)
    (map-in-order (lambda (entity)
		    (let ((result (tc-tree-il-entity linker entity)))
		      (if (not-null? result) result '(void))))
		  lst-entities))
   ((memq (hfield-ref linker 's-intermediate-language)
	  '(scheme racket bigloo))
    (map-in-order (lambda (entity) (tc-scheme-entity linker entity))
		  lst-entities))
   ((eq? (hfield-ref linker 's-intermediate-language) 'scheme-no-opt)
    (map-in-order (lambda (entity) (tcomp-entity linker entity))
		  lst-entities))
   (else (raise 'internal-error))))


(define (compile-decl-param-proc-instances linker)
  ;; We compute the list in reversed order in order to optimize.
  (let ((instances (reverse (hfield-ref linker 'decl-proc-instances))))
    (map-in-order
     (lambda (inst)
       (assert (= (length inst) 3))
       (let ((var (car inst))
	     (param-proc (cadr inst))
	     (type-var-values (caddr inst))
	     (s-lang (hfield-ref linker 's-intermediate-language)))
	 (cond
	  ((memq s-lang gl-l-tree-il-lang)
	   (tc-tree-il-decl-proc-instance linker var
					  param-proc
					  type-var-values))
	  ((memq s-lang '(scheme racket bigloo))
	   (tc-scheme-decl-proc-instance linker var
					 param-proc
					 type-var-values)) 
	  ((eq? s-lang 'scheme-no-opt)
	   (compile-decl-proc-instance linker var
				       param-proc
				       type-var-values))
	  (else (raise 'internal-error)))))
     instances)))


(define (theme-link-program-imports linker address-env imports)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (and (list? imports) (and-map? is-module-name? imports)))
  (for-each
   (lambda (submod)
     (theme-link-interfaces linker "" submod 'interface address-env '() #f))
   imports))


(define (theme-link-body-imports linker address-env mod-name imports)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (is-module-name? mod-name))
  (assert (and (list? imports) (and-map? is-module-name? imports)))
  (for-each
   (lambda (submod)
     (theme-link-interfaces linker "" submod 'interface address-env
			    '() #f))
   imports))


(define (theme-link-interface-imports linker address-env mod-name
				      hierarchy imports)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (and (list? hierarchy) (and-map? is-module-name? hierarchy)))
  (assert (and (list? imports) (and-map? is-module-name? imports)))
  (for-each
   (lambda (submod)
     (theme-link-interfaces linker "" submod 'interface address-env
			    hierarchy #f))
   imports))


;; (define (theme-prelink linker address-env hierarchy l-bodies)
;;   (assert (hrecord-is-instance? linker <linker>))
;;   (assert (hrecord-is-instance? address-env <address-environment>))
;;   (assert (and (list? hierarchy) (and-map? is-module-name? hierarchy)))
;;   (assert (and (list? l-bodies) (and-map? is-module-name? l-bodies)))
;;   (for-each
;;    (lambda (submod)
;;      (theme-link-interfaces linker "" submod 'body address-env hierarchy #f #t))
;;    l-bodies))


;; The output of this procedure updates necessary declared method variables
;; in case the generic procedure where they belong is stripped out.
(define (compile-used-method-decl linker address method-def)
  (assert (is-linker? linker))
  (assert (is-address? address))
  (assert (hrecord-is-instance? method-def <method-definition>))
  (let ((gen-proc (hfield-ref method-def 'gen-proc)))
    (assert (is-entity? gen-proc))
    ;; We may have to check globals-by-address her.
    (let ((ht-used (hfield-ref linker 'ht-used))
	  (ht-used-decls (hfield-ref linker 'ht-used-decls))
	  (addr-gen-proc (hfield-ref gen-proc 'address)))
      (assert (is-address? addr-gen-proc))
      (if (and (not (address-hash-ref ht-used addr-gen-proc))
	       (address-hash-ref ht-used-decls address))
	(let ((t-var-name (get-target-var-name linker address))
	      (repr-proc (hfield-ref method-def 'procexpr)))
	  (cond
	   ((use-tree-il? linker)
	    (let ((t-proc (theme-target-tree-il-compile linker repr-proc)))
	      `(set! (toplevel ,t-var-name) ,t-proc)))
	   ((memq (hfield-ref linker 's-intermediate-language)
		  '(scheme racket bigloo))
	      (let ((t-proc (theme-target-scheme-compile linker repr-proc)))
		(list 'set! t-var-name t-proc)))
	   ((eq? (hfield-ref linker 's-intermediate-language) 'scheme-no-opt)
	      (let ((t-proc (theme-target-compile linker repr-proc)))
		(list 'set! t-var-name t-proc)))
	   (else (raise 'internal-error))))
	(if (use-tree-il? linker)
	    '(void)
	    '(quote ()))))))
	  

(define (compile-used-method-decls linker)
  (hash-map->list
   (lambda (addr-key method-def)
     (compile-used-method-decl linker addr-key method-def))
   (hfield-ref linker 'ht-used-decls)))


(define (handle-tree-il-splice linker texpr)
  (if (and
       (list? texpr)
       (not-null? texpr)
       (eq? (car texpr) '_splice))
      (tc-tree-il-compile-sequence linker (cdr texpr))
      texpr))


(define (handle-tree-il-splices linker l-texprs)
  (map (lambda (texpr) (handle-tree-il-splice linker texpr)) l-texprs))


(define (filter-void l-texprs)
  (filter (lambda (texpr) (not (equal? texpr '(void)))) l-texprs))


(define (add-body-to-link! linker mod-name)
  (let ((l-bodies (hfield-ref linker 'l-bodies-to-link)))
    (if (not (member mod-name l-bodies))
	(hfield-set! linker 'l-bodies-to-link (cons mod-name l-bodies)))))


(define (add-body-to-process! linker mod-name)
  (let ((l-bodies (hfield-ref linker 'l-bodies-to-process)))
    (if (not (member mod-name l-bodies))
	(hfield-set! linker 'l-bodies-to-process (cons mod-name l-bodies)))))


(define (emit-debug-module-start linker mod-name)
  (let ((expr1 (make-debug-output-expr "starting to load module body "))
	(expr2 (make-debug-output-expr mod-name))
	(expr3 (make-debug-output-expr "\n")))
    (hfield-set! linker 'repr-list
		 (cons expr3
		       (cons expr2
			     (cons expr1
				   (hfield-ref linker 'repr-list)))))))


(define (emit-debug-module-end linker mod-name)
  (let ((expr1 (make-debug-output-expr "finished loading module body "))
	(expr2 (make-debug-output-expr mod-name))
	(expr3 (make-debug-output-expr "\n")))
    (hfield-set! linker 'repr-list
		 (cons expr3
		       (cons expr2
			     (cons expr1
				   (hfield-ref linker 'repr-list)))))))


(define (theme-link-unit linker mod-name unit-type address-env
			 prelink? l-visited)
  (cond
   ((member mod-name l-visited)
    (raise (list 'cyclic-prelink (cons 'mod-name mod-name))))
   ((member mod-name (hfield-ref linker 'l-linked-bodies2))
    '())
   (else
    (let* ((ext (get-pcode-suffix unit-type))
	   (source-filename
	    (search-file (hfield-ref linker 'module-search-path)
			 mod-name ext)))
      (if (not (eq? source-filename #f))
	  (let ((l-new-visited (cons mod-name l-visited))
		(source-file
		 (theme-open-input-file source-filename)))
	    (hfield-set! linker 'l-linked-bodies2
			 (cons mod-name
			       (hfield-ref linker 'l-linked-bodies2)))
	    ;; Skip the header except prelinked bodies.
	    (do ((i 0 (+ i 1))) ((>= i 6)) (theme-read source-file))
	    (let ((prev-module (hfield-ref linker 'current-module)))
	      (hfield-set! linker 'current-module mod-name)
	      (let* ((l-prelink (theme-read source-file))
		     (body (theme-read-file source-file)))
		(theme-close-input-port source-file)
		(assert (and (list? l-prelink)
			     (and-map? is-module-name? l-prelink)))
		(if prelink?
		    (for-each
		     (lambda (mod-name1)
		       (theme-link-unit linker mod-name1 'body address-env
					#t l-new-visited))
		     l-prelink))
		(if (not-null? (cdr body)) (raise 'extra-code-in-impl-file))
		(hfield-set! linker 'state 'pcode-reading)
		(dw1 "Body pseudocode reading: ")
		(dwl1 mod-name)
		(if (hfield-ref linker 'module-debug-output?)
		    (emit-debug-module-start linker mod-name))
		(do ((s-body (car body) (cdr s-body)))
		    ((null? s-body))
		  (let ((sexpr (car s-body)))
		    (hfield-set! linker 'current-toplevel-expr sexpr)
		    (let ((rexpr (theme-read-body-expr linker address-env
						       sexpr)))
		      (hfield-set! linker 'current-toplevel-expr '())
		      (hfield-set! linker 'repr-list
				   (cons rexpr
					 (hfield-ref linker 'repr-list)))))))
	      (hfield-set! linker 'current-module prev-module))
	    (if (hfield-ref linker 'module-debug-output?)
		(emit-debug-module-end linker mod-name)))
	  (raise 'module-not-found))))))


(define (theme-link-interfaces linker source-filename mod-name unit-type
			       address-env hierarchy program?)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (string? source-filename))
  ;; Module name has to be a list.
  (assert (is-module-name? mod-name))
  (assert (memq unit-type '(proper-program script interface body)))
  (assert (hrecord-is-instance? address-env <address-environment>))
  (assert (and (list? hierarchy) (and-map? is-module-name? hierarchy)))
  (assert (boolean? program?))
  (dw1 "Linking unit: ")
  (dw1 mod-name)
  (dw1 ", ")
  (dwl1 unit-type)
  (let ((prev-module (hfield-ref linker 'current-module)))
    (hfield-set! linker 'current-module mod-name)
    (cond
     ((and (eq? unit-type 'interface) (member mod-name hierarchy))
      (begin
	;;	(write-error-info mod-name)
	(raise 'cyclic-interface-dependency)))
     ;; ((and prelink? (not (eq? unit-type 'body)))
     ;;  (raise 'internal-error-with-prelinking))
     ;; ((and prelink? (member mod-name hierarchy))
     ;;  (begin
     ;; 	;;	(write-error-info mod-name)
     ;; 	(raise (list 'cyclic-prelink-dependency
     ;; 		     (cons 'module-name mod-name)))))
     ;; ((and prelink? (not (member mod-name
     ;; 				 (hfield-ref linker 'linked-interfaces))))
     ;;  (raise 'prelinked-body-interface-not-linked))
     ((and (eq? unit-type 'interface)
	   (member mod-name (hfield-ref linker 'linked-interfaces)))
      (begin
	(dwl1 "revisiting")
	'()))
     ((and (eq? unit-type 'body)
	   (member mod-name (hfield-ref linker 'linked-bodies)))
      (begin
	(dwl1 "revisiting")
	'()))
     ((and (memq unit-type '(proper-program script))
	   (not program?))
      (raise 'invalid-program-linkage))
     (else
      (let* ((ext (get-pcode-suffix unit-type))
	     (source-filename1
	      (if (string-null? source-filename)
		  (search-file (hfield-ref linker 'module-search-path)
			       mod-name ext)
		  source-filename)))
	(if (not (eqv? source-filename1 #f))
	    (let ((source-file
		   (theme-open-input-file source-filename1)))
	      (let* ((name (theme-read source-file))
		     (actual-name (if (symbol? name) (list name) name))
		     (script0? (theme-read source-file))
		     (first-free-loc (theme-read source-file))
		     ;; Read imports, imports-with-reexports, and uses.
		     (imports
		      (append (theme-read source-file)
			      (theme-read source-file)
			      (theme-read source-file)))
		     (l-prelinked-bodies
		      (theme-read source-file))
		     (body (theme-read-file source-file)))
		(theme-close-input-port source-file)
		(if (not-null? (cdr body))
		    (raise 'extra-code-in-impl-file))
		(if (not (module-name=? mod-name actual-name))
		    (begin
		      (display mod-name)
		      (newline)
		      (display actual-name)
		      (newline)
		      (raise 'module-name-mismatch)))
		;; It is essential to update linker-interfaces and linked-bodies
		;; here before further linking of the unit.
		(cond
		 ((eq? unit-type 'interface)
		  (hfield-set! linker 'linked-interfaces
			       (cons mod-name
				     (hfield-ref linker 'linked-interfaces))))
		 ((eq? unit-type 'body)
		  (hfield-set! linker 'linked-bodies
			       (cons mod-name
				     (hfield-ref linker 'linked-bodies)))))
		(let ((visited-cur (cons mod-name hierarchy)))
		  (dw1 "Linking unit imports: ") 
		  (dwl1 mod-name)
		  (cond
		   ((memq unit-type '(proper-program script))
		    (theme-link-program-imports linker address-env imports))
		   ((eq? unit-type 'interface)
		    (let ((new-hierarchy (cons mod-name hierarchy)))
		      (theme-link-interface-imports linker address-env
						    mod-name new-hierarchy
						    imports)))
		   ((eq? unit-type 'body)
		    (theme-link-body-imports linker address-env mod-name imports))
		   (else (raise 'internal-error)))
		  ;; (if (not-null? l-prelinked-bodies)
		  ;;     (if (not (eq? unit-type 'interface))
		  ;; 	  (begin
		  ;; 	    (dw1 "Prelinking bodies: ")
		  ;; 	    (dwl1 mod-name)
		  ;; 	    (theme-prelink linker address-env visited-cur
		  ;; 			   l-prelinked-bodies))
		  ;; 	  (raise 'prelink-in-interface)))

		  (dw1 "Reading unit contents: ") 
		  (dw1 mod-name)
		  (dw1 ", ")
		  (dwl1 unit-type)
		  
		  ;; Updating variable numbering.
		  (let ((ht (hfield-ref linker 'ht-module-indices)))
		    ;; An interface is always read before its body
		    ;; so we do not need to handle bodies here.
		    (if (and (or (eq? unit-type 'interface)
				 (eq? unit-type 'proper-program)
				 (eq? unit-type 'script))
			     (not (hash-ref ht actual-name)))
			(let ((i-current-var-start
			       (hfield-ref linker 'i-next-var-start))
			      (i-number-of-vars
			       (if (eq? unit-type 'interface)
				   (get-first-free-loc linker actual-name)
				   first-free-loc)))
			    (hfield-set!
			     linker
			     'i-next-var-start
			     (+ (hfield-ref linker 'i-next-var-start)
				i-number-of-vars))
			    (hash-set! ht actual-name i-current-var-start))))

		  (if (eq? unit-type 'interface)
		      (add-body-to-process! linker mod-name))
		  (cond
		   ;; ((eq? unit-type 'body)
		   ;;  (add-body-to-link! linker mod-name)
		   ;;  (for-each
		   ;;   (lambda (mod-name1)
		   ;;     (add-body-to-link! linker mod-name1))
		   ;;   imports))
		   ((eq? unit-type 'interface)
		    (hfield-set! linker 'state 'pcode-reading)
		    (dw1 "Interface pseudocode reading: ")
		    (dwl1 mod-name)
		    (do ((s-body (car body) (cdr s-body)))
			((null? s-body))
		      (let ((sexpr (car s-body)))
			(hfield-set! linker 'current-toplevel-expr sexpr)
			(let ((rexpr (theme-read-body-expr linker
							   address-env
							   sexpr)))
			  (hfield-set! linker 'current-toplevel-expr '())
			  (hfield-set!
			   linker 'repr-list
			   (cons rexpr
				 (hfield-ref linker 'repr-list)))))))))))
	    ;; (for-each
	    ;;  (lambda (imp)
	    ;;    (if (not (member imp
	    ;; 		    (hfield-ref linker 'linked-bodies)))
	    ;;        (theme-link-interfaces linker "" imp 'body address-env
	    ;; 			'() #f #f)))
	    ;;  imports))))))
	    (raise 'module-not-found)))))
    (hfield-set! linker 'current-module prev-module)))


(define (theme-do-link-program linker source-filename mod-name unit-type
			       address-env)
  (dwl1 "Linking interfaces")
  (theme-link-interfaces linker source-filename mod-name unit-type
			 address-env '() #t)
  (do () ((null? (hfield-ref linker 'l-bodies-to-process)))
    (let ((mn-cur-body (car (hfield-ref linker 'l-bodies-to-process))))
      (hfield-set! linker 'l-bodies-to-process
		   (cdr (hfield-ref linker 'l-bodies-to-process)))
      (if (not (member mn-cur-body (hfield-ref linker 'linked-bodies)))
	  (begin
	    (add-body-to-link! linker mn-cur-body)
	    (theme-link-interfaces linker "" mn-cur-body
				   'body address-env '() #f)))))
  (dwl1 "Linking bodies")
  (hfield-set! linker 'l-linked-bodies2 '())
  (for-each
   (lambda (body-name)
     (theme-link-unit linker body-name 'body address-env #t ''()))
   (hfield-ref linker 'l-bodies-to-link))
  (dwl1 "Reading the main program")
  ;; No need to prelink the modules imported by the main program
  ;; since the main program is linked last.
  (theme-link-unit linker mod-name unit-type address-env #f '()))


(define gl-linker
  (make-hrecord <linker>
		'()
		#t
		#t
		#f
		#f
		#f
		#t
		#f
		#t
		#t
		#f
		'tree-il-2.2
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		""
		""
		'()
		'()
		'()
		'()
		'()
		'()
		0
		0
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		'()
		#f
		#f
		'()
		'()
		0
		'()
		'()
		'()
		'()
		'()
		'()))


(set! gl-linker-fwd gl-linker)


(define (init-linker linker compiler-root-env module-search-path
		     all-assertions? factorize? strip?
		     pretty-print?
		     verbose-errors?
		     verbose-typechecks?
		     verbose-unlinked-procedures?
		     backtrace?
		     runtime-pretty-backtrace?
		     module-debug-output?
		     s-intermediate-language)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (hrecord-is-instance? compiler-root-env <environment>))
  (assert (and (list? module-search-path)
	       (and-map? string? module-search-path)))
  (assert (boolean? all-assertions?))
  (assert (boolean? pretty-print?))
  (assert (boolean? verbose-errors?))
  (assert (boolean? verbose-typechecks?))
  (assert (boolean? backtrace?))
  (assert (boolean? runtime-pretty-backtrace?))
  (assert (boolean? module-debug-output?))
  (assert (memq s-intermediate-language gl-l-all-int-lang))
  (let* ((linker-root-env (make-address-environment compiler-root-env))
	 (alloc-loc (lambda (s-name toplevel?)
		      (linker-alloc-loc linker s-name toplevel?)))
	 (param-cache-parsing (make-hrecord <param-cache> '()))
	 (param-cache-instantiation (make-hrecord <param-cache> '()))
	 (ht-used (make-hash-table gl-i-ht-used-size))
	 (ht-method-defs (make-hash-table gl-i-ht-method-defs-size))
	 (ht-method-decls (make-hash-table gl-i-ht-method-decls-size))
	 (ht-used-decls (make-hash-table gl-i-ht-used-decls-size))
	 (ht-rebound (make-hash-table gl-i-ht-rebound-size))
	 (ht-decl-types (make-hash-table gl-i-ht-decl-types-size))
	 (ht-globals-by-address
	  (make-hash-table gl-i-ht-globals-by-address-size))
	 (ht-globals-by-name
	  (make-hash-table gl-i-ht-globals-by-name-size))
	 (ht-cycles (make-hash-table gl-i-ht-cycles-size))
	 (ht-goops-classes (make-hash-table gl-i-ht-goops-classes-size))
	 (ht-prim-classes (make-hash-table gl-i-ht-prim-classes-size))
	 (ht-fact (make-hash-table gl-i-ht-fact-size))
	 (ht-module-indices (make-hash-table gl-i-ht-module-indices-size))
	 (ht-lexical-vars (make-hash-table gl-i-ht-lexical-vars-size))
	 (ht-raw-procs (make-hash-table gl-i-ht-raw-procs-size))
	 (ht-equal (make-hash-table gl-i-ht-equal-size))
	 (ht-equal-objects (make-hash-table gl-i-ht-equal-objects-size))
	 (ht-equal-contents (make-hash-table gl-i-ht-equal-contents-size))
	 (optimize-raw-proc-inst?
	  (if (memq s-intermediate-language gl-l-tree-il-lang)
	      #t
	      #f))
	 (binder-parsing (make-hrecord <binder>
				       param-cache-parsing
				       alloc-loc
				       #t
				       #t
				       #f
				       #f
				       #f
				       #f
				       #f
				       '()
				       ht-globals-by-address
				       ht-method-decls
				       '()
				       '()
				       '()
				       #f
				       #f
				       '()
				       '()
				       ""
				       '()
				       optimize-raw-proc-inst?
				       ht-raw-procs))
	 (binder-instantiation (make-hrecord <binder>
					     param-cache-instantiation
					     alloc-loc
					     #t
					     #t
					     #f
					     #t
					     #t
					     #f
					     #f
					     '()
					     ht-globals-by-address
					     ht-method-decls
					     '()
					     '()
					     '()
					     #f
					     #f
					     '()
					     '()
					     ""
					     '()
					     optimize-raw-proc-inst?
					     ht-raw-procs)))
    (address-env-add-binding! linker-root-env tp-cast-vector0)
    (address-env-add-binding! linker-root-env tp-cast-mutable-vector0)
    (address-env-add-binding! linker-root-env tp-cast-value-vector0)
    (address-env-add-binding! linker-root-env tp-cast-mutable-value-vector0)
    (hfield-set! linker 'state 'initial)
    (hfield-set! linker 'all-assertions? all-assertions?)
    (hfield-set! linker 'factorize? factorize?)
    (hfield-set! linker 'pretty-print? pretty-print?)
    (hfield-set! linker 'verbose-errors? verbose-errors?)
    (hfield-set! linker 'verbose-typechecks? verbose-typechecks?)
    (hfield-set! linker 'backtrace? backtrace?)
    (hfield-set! linker 'runtime-pretty-backtrace?
		 runtime-pretty-backtrace?)
    (hfield-set! linker 'strip? strip?)
    (hfield-set! linker 'verbose-unlinked-procedures?
		 verbose-unlinked-procedures?)
    (hfield-set! linker 'module-debug-output? module-debug-output?)
    (hfield-set! linker 's-intermediate-language
		 s-intermediate-language)
    (hfield-set! linker 'repr-list '())
    (hfield-set! linker 'ht-used ht-used)
    (hfield-set! linker 'ht-method-defs ht-method-defs)
    (hfield-set! linker 'ht-method-decls ht-method-decls)
    (hfield-set! linker 'ht-used-decls ht-used-decls)
    (hfield-set! linker 'ht-rebound ht-rebound)
    (hfield-set! linker 'ht-decl-types ht-decl-types)
    (hfield-set! linker 'ht-cycles ht-cycles)
    (hfield-set! linker 'ht-goops-classes ht-goops-classes)
    (hfield-set! linker 'ht-prim-classes ht-prim-classes)
    (hfield-set! linker 'ht-fact ht-fact)
    (hfield-set! linker 'ht-module-indices ht-module-indices)
    (hfield-set! linker 'ht-lexical-vars ht-lexical-vars)
    (hfield-set! linker 'ht-equal ht-equal)
    (hfield-set! linker 'ht-equal-objects ht-equal-objects)
    (hfield-set! linker 'ht-equal-contents ht-equal-contents)
    (hfield-set! linker 'lst-enclosing-cycles '())
    (hfield-set! linker 'interm-file '())
    (hfield-set! linker 'interm-filename "")
    (hfield-set! linker 'target-filename "")
    (hfield-set! linker 'module-search-path module-search-path)
    (hfield-set! linker 'param-cache-parsing param-cache-parsing)
    (hfield-set! linker 'param-cache-instantiation param-cache-instantiation)
    (hfield-set! linker 'binder-parsing binder-parsing)
    (hfield-set! linker 'binder-instantiation binder-instantiation)
    (hfield-set! linker 'fixed-tvars '())
    (hfield-set! linker 'next-free-loc gl-i-loc-start)
    (hfield-set! linker 'next-tvar-number 0)
    (hfield-set! linker 'current-module '())
    (hfield-set! linker 'linked-interfaces '())
    (hfield-set! linker 'linked-bodies '())
    (hfield-set! linker 'root-env linker-root-env)
    (hfield-set! linker 'global-decls '())
    (hfield-set! linker 'ht-globals-by-name ht-globals-by-name)
    (hfield-set! linker 'ht-globals-by-address ht-globals-by-address)
    (hfield-set! linker 'decl-proc-instances '())
    (hfield-set! linker 'inside-param-def? #f)
    (hfield-set! linker 'tcomp-inside-param-proc? #f)
    (hfield-set! linker 't-tvars '())
    (hfield-set! linker 'visited-in-binding '())
    (hfield-set! linker 'i-next-var-start 0)
    (hfield-set! linker 'current-expr '())
    (hfield-set! linker 'current-toplevel-expr '())
    (hfield-set! linker 'current-repr '())
    (hfield-set! linker 'current-toplevel-repr '())
    (hfield-set! linker 'current-instance '())
    (hfield-set! linker 'current-repr-to-bind '())))


(define (make-extra-initializations linker)
  (assert (hrecord-is-instance? linker <linker>))
  (let ((first-free-number (hfield-ref linker 'next-tvar-number)))
    (if (use-tree-il? linker)
	(let ((s-call (tree-il-get-call-keyword linker)))
	  `((,s-call (toplevel vector-set!)
		     (,s-call (toplevel vector-ref)
			      (toplevel gl-rte)
			      (toplevel i-rte-tvar-allocator))
		     (toplevel i-tva-start)
		     (const ,first-free-number))))
	`((vector-set! (vector-ref gl-rte i-rte-tvar-allocator)
		       i-tva-start ,first-free-number)))))


(define (is-my-main? address)
  (and
   (eqv? (hfield-ref address 'number) address-number-target)
   (eqv? (hfield-ref address 'source-name) '_main)))


(define (get-main linker)
  (address-env-get-item-general
   (hfield-ref linker 'root-env)
   (lambda (key value) (is-my-main? key))))


(define (get-main-def lst-reprs)
  (find (lambda (repr)
	  (and
	   (hrecord-is-instance? repr <variable-definition>)
	   (is-my-main? (hfield-ref (hfield-ref repr 'variable) 'address))))
	lst-reprs))


(define (compile-main linker)
  (cond
   ((use-tree-il? linker)
    (tc-tree-il-define-main linker))
   ((use-racket? linker)
    (tcomp-define-racket-main linker))
   (else
    (tcomp-define-main linker))))


(define (theme-link-program 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?)
  (assert (hrecord-is-instance? linker <linker>))
  (assert (or (symbol? program-name) (is-module-name? program-name)))
  (assert (and (string? source-filename) (not (string-null? source-filename))))
  (assert (string? interm-filename))
  (assert (string? target-filename))
  (assert (boolean? final-compilation?))
  (assert (boolean? all-assertions?))
  (assert (boolean? factorize?))
  (assert (boolean? strip?))
  (assert (boolean? pretty-print?))
  (assert (boolean? verbose-errors?))
  (assert (boolean? verbose-typechecks?))
  (assert (boolean? verbose-unlinked-procedures?))
  (assert (boolean? backtrace?))
  (assert (boolean? runtime-pretty-backtrace?))
  (assert (boolean? module-debug-output?))
  (assert (memq s-intermediate-language gl-l-all-int-lang))
  (dw1 "Linking program ")
  (dwl1 program-name)
  (guard
   (exc (else (handle-linker-error linker exc)))
   (let* ((l-comp '())
	  (interm-file-ext (get-interm-file-ext s-intermediate-language))
	  (interm-filename1
	   (if (string-null? interm-filename)
	       (string-append
		(get-filename-without-ext
		 (get-filename-without-path source-filename))
		interm-file-ext)
	       interm-filename))
	  (interm-file (theme-open-output-file interm-filename1))
	  (script? (eq? (get-pcode-unit-type source-filename) 'script))
	  (target-filename1
	   (if (and final-compilation? (not link-to-cache?))
	       (if (string-null? target-filename)
		   (string-append
		    (get-filename-without-ext
		     (get-filename-without-path source-filename))
		    target-file-ext)
		   target-filename)
	       "")))
     (init-linker linker global-builtins-symtbl
		  module-search-path all-assertions? factorize? strip?
		  pretty-print? verbose-errors?
		  verbose-typechecks?
		  verbose-unlinked-procedures?
		  backtrace?
		  runtime-pretty-backtrace?
		  module-debug-output?
		  s-intermediate-language)
     (hfield-set! linker 'interm-file interm-file)
     (hfield-set! linker 'interm-filename interm-filename1)
     (hfield-set! linker 'target-filename target-filename1)
     (let ((l-prefix
	    (cond
	     ((use-tree-il? linker)
	      (compile-program-prefix-tree-il linker script?
					      l-str-custom-modules))
	     ((use-racket? linker)
	      (compile-program-prefix-racket
	       linker script?
	       l-str-custom-modules
	       l-str-custom-relative-modules))
	     (else
	      (compile-program-prefix-guile linker script?
					    l-str-custom-modules)))))
       (set! l-comp l-prefix))
     (hfield-set! linker 'state 'pcode-reading)
     (theme-do-link-program linker source-filename program-name
			    (if script? 'script 'proper-program)
			    (hfield-ref linker 'root-env))
     (if (and (not script?)
	      (not (get-main linker)))
	 (raise 'main-procedure-not-defined)) 
     (hfield-set! linker 'state 'decl-param-proc-instances)    
     (set! l-comp
	   (append l-comp (compile-decl-param-proc-instances linker)))
     (hfield-set! linker 'state 'making-extra-initializations)
     (set! l-comp
	   (append
	    l-comp
	    (make-extra-initializations linker)))
     (let ((repr-list (hfield-ref linker 'repr-list)))
       (if (hfield-ref linker 'strip?)
	   (begin
	     (dwl1 "Performing coverage analysis")
	     (hfield-set! linker 'state 'coverage-analysis)
	     (let ((ht-var-defs (make-var-def-hash-table repr-list)))
	       (hfield-set! linker 'ht-var-defs ht-var-defs)
	       (determine-total-coverage linker)
	       (do-prevent-stripping linker))))
       (hfield-set! linker 'state 'instantiation)
       (dwl1 "Computing parametrized entity instances")
       (dw1 "Number of expressions to handle: ")
       (dwl1 (length (hfield-ref linker 'repr-list)))
       (let ((lst-processed
	      (theme-instantiate-program linker
					 (hfield-ref linker 'repr-list))))
	 (hfield-set! linker 'state 'target-compilation)
	 (dwl1 "Linking the target entities")
	 (set! l-comp
	       (append l-comp
		       (theme-target-compile-program linker lst-processed)))
	 (set! l-comp
	       (append l-comp
		       (compile-used-method-decls linker)))))
     (dwl1 "Linked the target entities")
     
     (if (not script?)
	 (set! l-comp (append l-comp (compile-main linker))))

     ;; TBR?
     (for-each
      (lambda (sx)
	(set! gl-counter24 (+ gl-counter24 1))
	;; (dwl1 gl-counter24)
	(if (not (is-primitive-value? sx))
	    (begin
	      (display "Illegal target expression detected.\n")
	      (display gl-counter24)
	      (newline)
	      (dvar1-set! sx)
	      (raise 'stop-illegal-expr))))
      l-comp)
     
     (dwl1 "Making the intermediate file")

     (if (use-racket? linker)
	 (display "\n#lang racket\n\n" interm-file))
     
     (if (use-tree-il? linker)
	 (let ((l-comp2
		(tc-tree-il-compile-sequence
		 linker
		 (filter-void (handle-tree-il-splices linker l-comp)))))
	   (if pretty-print?
	       (begin
		 (pretty-print l-comp2 interm-file))
	       (write l-comp2 interm-file))
	   (newline interm-file))
	 (for-each (lambda (texpr)
		     (write-target-expr linker interm-file pretty-print?
					texpr))
		   l-comp))
     (theme-close-output-port interm-file)
     (hfield-set! linker 'interm-file '())
     ;; We keep the intermediate filename field during the final compilation.
     (if final-compilation?
	 (begin
	   (dwl1 "Compiling the guile objcode file")
	   (hfield-set! linker 'state 'final-compilation)
	   (if link-to-cache?
	       (if (not (= (system
			    (if (use-tree-il? linker)
				(string-append "guild compile --from=tree-il "
					       interm-filename1)
				(string-append "guild compile "
					       interm-filename1)))
			   0))
		   (raise 'error-in-final-compilation))
	       (if (not (= (system
			    (if (use-tree-il? linker)
				(string-append "guild compile "
					       "--from=tree-il --output="
					       target-filename1
					       " "
					       interm-filename1)
				(string-append "guild compile --output="
					       target-filename1
					       " "
					       interm-filename1)))
			   0))
		   (raise 'error-in-final-compilation)))))
     (hfield-set! linker 'interm-filename "")
     (hfield-set! linker 'target-filename "")
     (if (not keep-intermediate?)
	 (delete-file interm-filename1))))
  (write-line-info "Program linked successfully."))


;; Note that theme-link-program1 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-link-program1 main-module module-search-path
			     s-intermediate-language
			     l-str-custom-modules
			     l-str-custom-relative-modules
			     script?
			     final-compilation?
			     keep-intermediate?
			     link-to-cache?
			     factorize?
			     strip?
			     all-assertions?
			     pretty-print?
			     verbose-errors?
			     verbose-typechecks?
			     verbose-unlinked-procedures?
			     runtime-pretty-backtrace?
			     module-debug-output?)
  (assert (or (symbol? main-module) (is-module-name? main-module)))
  (let* ((actual-main-module (get-actual-module-name main-module))
	 (ext (if script?
		  (get-pcode-suffix 'script)
		  (get-pcode-suffix 'proper-program)))
	 (source-filename (search-file module-search-path
				       actual-main-module ext)))
    (if (not (eq? source-filename #f))
	(let* ((basename (get-filename-without-ext source-filename))
	       (interm-file-ext (get-interm-file-ext s-intermediate-language))
	       (interm-filename (string-append basename interm-file-ext))
	       (target-filename (string-append basename target-file-ext)))
	  (theme-link-program gl-linker actual-main-module
			      source-filename interm-filename target-filename
			      module-search-path
			      s-intermediate-language
			      l-str-custom-modules
			      l-str-custom-relative-modules
			      script?
			      final-compilation?
			      keep-intermediate?
			      link-to-cache?
			      all-assertions?
			      factorize?
			      strip?
			      pretty-print?
			      verbose-errors?
			      verbose-typechecks?
			      verbose-unlinked-procedures?
			      #t
			      runtime-pretty-backtrace?
			      module-debug-output?))
	(raise 'program-file-not-found))))
