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


;; *** Theme compiler and linker debugging ***


(import (th-scheme-utilities stdutils))


(define debug-level 0)

(define gl-show-indented-debug-info? #f)

(define gl-show-dvar-settings? #f)

;; (define flush-debug-output #t)

;; Set #t if you want a brief info to be displayed.
;; Note that Theme compiler main program sets this value, too.
(define gl-show-info? #t)

;; Set #t if you want the imported symbols to be listed.
(define gl-show-imported-symbols? #f)


(define gl-indent 0)


(define gl-l-active-debug-categories
  ;;  (list 'type-deduction 'tvar-binding))
  ;;  (list 'tvar-binding))
  ;;  (list 'subtyping))
  ;;  '(expand scan))
  ;; (list 'type-deduction))
  ;;  (list 'i-s2))
  ;;  '(scan2 expand2 core-lang2))
  ;;  '(expand))
  ;;  '(match-type))
  ;; '(debug1 phase2))
  ;; '(debug10))
  '())
;;  '(debug-union))

;; (define (debug-get-string x) (target-object-as-string x))
(define debug-get-string (lambda (x) ""))


(define do-nothing1 (lambda (x) #f))

;; Set #t to test interface compilation error handling.
(define gl-test1 #f)

;; Set #t to test body compilation error handling.
(define gl-test2 #f)

;; Set #t to test linker target compilation error handling.
(define gl-test3 #f)

;; Set #t to test linker instance compilation error handling.
(define gl-test4 #f)

;; Set #t to test reporting procedure applications in the compiler.
(define gl-test5 #f)

;; Set #t to test erroneous output file deletion.
(define gl-test6 #f)

;; Set #t to test parametrized class instantiation errors in the linker.
(define gl-test7 #f)

;; Set #t to test linker instantiation error messages.
(define gl-test8 #f)


(define dvar1 #f)
(define dvar2 #f)
(define dvar3 #f)
(define dvar4 #f)
(define dvar5 #f)
(define dvar6 #f)
(define dvar7 #f)

;; (define (write-line-and-flush x)
;;   (write-line x)
;;   (flush-tty/output))

;; (define write-line-debug
;;   (if flush-debug-output write-line-and-flush write-line))

(define write-line-debug write-line)

(define (write-info x)
  (if gl-show-info? (display x)))

(define (write-line-info x)
  (if gl-show-info?
      (begin
	(display x)
	(newline))))


(define (newline-info)
  (if gl-show-info? (newline)))


(define (dw1 x)
 (if (>= debug-level 1) (display x)))

(define (dnl1)
  (if (>= debug-level 1) (newline)))

(define (dwl1 x)
 (if (>= debug-level 1) (write-line-debug x)))

(define (dw1 x)
 (if (>= debug-level 1) (display x)))

(define (dnl1)
  (if (>= debug-level 1) (newline)))

(define (dwl2 x)
 (if (>= debug-level 2) (write-line-debug x)))

(define (dw2 x)
 (if (>= debug-level 2) (display x)))

(define (dnl2)
  (if (>= debug-level 2) (newline)))

(define (dwl3 x)
 (if (>= debug-level 3) (write-line-debug x)))

(define (dw3 x)
 (if (>= debug-level 3) (display x)))

(define (dnl3)
  (if (>= debug-level 3) (newline)))

(define (dwl4 x)
 (if (>= debug-level 4) (write-line-debug x)))

(define (dw4 x)
 (if (>= debug-level 4) (display x)))

(define (dnl4)
  (if (>= debug-level 4) (newline)))

(define (dwl5 x)
 (if (>= debug-level 5) (write-line-debug x)))

(define (dw5 x)
 (if (>= debug-level 5) (display x)))

(define (dnl5)
  (if (>= debug-level 5) (newline)))


(define dwl dwl3)

(define dw dw3)

(define (dwl-dvar x)
  (if gl-show-dvar-settings?
      (write-line-debug x)))

(define (write-error-info x)
  (write-line x))


(define (get-indentation-prefix0 level)
  (cond
   ((= level 0) "")
   ((< level 0) (raise 'internal-error))
   (else
    ;; Should we have get-indentation-prefix0 in the following?
    (string-append " " (get-indentation-prefix (- level 1))))))

(define (get-indentation-prefix level)
  (get-indentation-prefix0 (remainder level 40)))


(define (debug-write-line-and-indent obj)
  (if gl-show-indented-debug-info?
      (begin
	(display (get-indentation-prefix gl-indent))
	(display obj)
	(newline))))


(define (debug-write-and-indent obj)
  (if gl-show-indented-debug-info?
      (begin
	(display (get-indentation-prefix gl-indent))
	(display obj))))


(define dwli debug-write-line-and-indent)
(define dwi debug-write-and-indent)


(define (dwc obj)
  (if gl-show-indented-debug-info?
      (display obj)))


(define (dwli-newline)
  (if gl-show-indented-debug-info?
      (newline)))


(define (debug2-write-line-and-indent cat obj)
  (if (memq cat gl-l-active-debug-categories)
      (begin
	(display (get-indentation-prefix gl-indent))
	(display obj)
	(newline))))


(define (debug2-write-and-indent cat obj)
  (if (memq cat gl-l-active-debug-categories)
      (begin
	(display (get-indentation-prefix gl-indent))
	(display obj))))


(define d2wli debug2-write-line-and-indent)
(define d2wi debug2-write-and-indent)


(define (d2wc cat obj)
  (if (memq cat gl-l-active-debug-categories)
      (display obj)))


(define (d2wl cat obj)
  (if (memq cat gl-l-active-debug-categories)
      (begin
	(display obj)
	(newline))))

(define (d2wli-newline cat)
  (if (memq cat gl-l-active-debug-categories)
      (newline)))

(define d2-newline d2wli-newline)


(define dwli2 (lambda (obj) '()))
;;(define dwli2 dwli)
(define dwi2 (lambda (obj) '()))
;;(define dwi2 dwi)
(define dwc2 (lambda (obj) '()))
;;(define dwc2 dwc)
(define dwli-newline2 (lambda () '()))
;;(define dwli-newline2 dwli-newline)


(define (dvar1-set! x)
  (dwl-dvar "dvar1-set!")
  (set! dvar1 x))

(define (dvar2-set! x)
  (dwl-dvar "dvar2-set!")
  (set! dvar2 x))

(define (dvar3-set! x)
  (dwl-dvar "dvar3-set!")
  (set! dvar3 x))

(define (dvar4-set! x)
  (dwl-dvar "dvar4-set!")
  (set! dvar4 x))

(define (dvar5-set! x)
  (dwl-dvar "dvar5-set!")
  (set! dvar5 x))

(define debug-pause read)
;; (define debug-pause (lambda () #f))

(define (debug-prompt-and-pause)
  (display "Give input: ")
  (read))

(define dp debug-prompt-and-pause)
;;(define (dp) '())


(define gl-flag10? #f)
(define gl-flag11? #f)
(define gl-flag12? #f)
(define gl-flag13? #f)
(define gl-flag14? #f)
(define gl-flag15? #f)
(define gl-flag16? #f)
(define gl-flag17? #f)


(define gl-counter3 0)
(define gl-counter4 0)
(define gl-counter5 0)
(define gl-counter6 0)
(define gl-counter7 0)
(define gl-counter8 0)
(define gl-counter9 0)
(define gl-counter10 0)
(define gl-counter11 0)
(define gl-counter12 0)
(define gl-counter13 0)
(define gl-counter14 0)
(define gl-counter15 0)
(define gl-counter16 0)
(define gl-counter17 0)
(define gl-counter18 0)
(define gl-counter19 0)
(define gl-counter20 0)
(define gl-counter21 0)
(define gl-counter22 0)
(define gl-counter23 0)
(define gl-counter24 0)
(define gl-counter25 0)
(define gl-counter26 0)
(define gl-counter27 0)
(define gl-counter28 0)


(define (var-to-string var)
  (string-append
   (symbol->string (hfield-ref (hfield-ref var 'address)
			       'source-name))
   "["
   (number->string (hfield-ref (hfield-ref var 'address)
			       'number))
   "]"))


(define gl-ht-repr-counters (make-hash-table 100))
(define gl-ht-tno-counters (make-hash-table 100))


(define (debug-update-counter repr)
  (if (hrecord? repr)
      (begin
	(let* ((hrt (hrecord-type-of repr))
	       (i-prev0 (hashq-ref gl-ht-repr-counters hrt))
	       (i-prev (if (eq? i-prev0 #f) 0 i-prev0)))
	  (hashq-set! gl-ht-repr-counters hrt (+ i-prev 1)))
	(if (is-target-object? repr)
	    (let* ((to-type (get-entity-type repr))
		   (i-prev1 (hashq-ref gl-ht-tno-counters to-type))
		   (i-prev2 (if (eq? i-prev1 #f) 0 i-prev1)))
	      (hashq-set! gl-ht-tno-counters to-type (+ i-prev2 1)))))))
	    

(define (debug-get-list-output l)
  (cond
   ((null? l) "")
   ((and (pair? l) (not-null? (cdr l)))
    (string-append (debug-get-string (car l)) " "
		   (debug-get-list-output (cdr l))))
   (else (debug-get-string (car l)))))


(define (get-param-proc-instance-name param-proc type-var-values)
  (string-append
   "("
   (symbol->string (hfield-ref (hfield-ref param-proc 'address) 'source-name))
   " "
   (debug-get-list-output type-var-values)
   ")"))


