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



;; *** Theme compilation errors ***


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


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


(define (set-error-info! compiler info)
  (hfield-set! compiler 'error-info info))


(define (get-source-expr sexpr)
  (if (not-null? (source-properties sexpr))
      sexpr
      (let ((ht-source-exprs (hfield-ref gl-expander 'ht-source-exprs)))
	(if (not-null? ht-source-exprs)
	    (let ((sexpr1 (hashq-ref ht-source-exprs sexpr)))
	      (if sexpr1 sexpr1 sexpr))
	    sexpr))))


(define (convert-string-list-to-string lst)
  (cond
   ((null? lst) "")
   ((null? (cdr lst)) (car lst))
   (else
    (string-append (car lst) " "
		   (convert-string-list-to-string (cdr lst))))))


(define (convert-module-to-text module)
  ;; If module name is a single symbol it is converted to a list elsewhere.
  (assert (list? module))
  (let ((strings (map symbol->string module)))
    (string-append "("
		   (convert-string-list-to-string strings)
		   ")")))


(define (get-var-text var)
  (if (not-null? var)
      (let ((source-name
	     (get-var-orig-name
	      (hfield-ref (hfield-ref var 'address) 'source-name))))
	(if (not-null? source-name)
	    (string-append " of variable " (symbol->string source-name))
	    ""))
      ""))


(define (proc-ref->string x-name)
  (cond
   ((symbol? x-name) (symbol->string (get-var-orig-name x-name)))
   ((and (list? x-name) (not-null? x-name)
	 (eq? (car x-name) '@)
	 (symbol? (last x-name)))
    (symbol->string (last x-name)))
   (else "?")))


(define (get-proc-text s-proc1 s-proc2)
  (cond
   ((and (not-null? s-proc1) (not-null? s-proc2))
    (string-append "in an application of procedure "
		   (proc-ref->string s-proc1)
		   " in toplevel definition of "
		   (proc-ref->string s-proc2)))
   ((and (not-null? s-proc1) (null? s-proc2))
    (string-append "in an application of procedure "
		   (proc-ref->string s-proc1)))
   ((and (null? s-proc1) (not-null? s-proc2))
    (string-append "in toplevel definition of "
		   (proc-ref->string s-proc2)))
   ((and (null? s-proc1) (null? s-proc2))
    "in an application of a procedure")
   (else
    (raise 'internal-error))))


;; It is possible that we get non-symbol exceptions
;; from the system libraries.


(define (get-error-text compiler exc)
  (cond
   ((null? exc) "()")
   ((list? exc)
    (let ((x-head (car exc)))
      (cond
       ((memq x-head '(duplicate-imported-declaration
			  duplicate-imported-mutable-declaration))
	(let ((s-error-type x-head))
	  (case s-error-type
	    ((duplicate-imported-declaration)
	     (let ((s-name (cadr exc)))
	       (string-append "Duplicate imported declaration of variable "
			      (get-var-orig-name (symbol->string s-name)))))
	    ((duplicate-imported-mutable-declaration)
	     (let ((s-name (cadr exc)))
	       (string-append
		"Duplicate imported declaration of mutable variable "
		(get-var-orig-name (symbol->string s-name)))))
	    (else (string-append "??? ")))))
       ((eq? x-head 'type-mismatch-in-param-proc-appl-1)
	"Argument list type mismatch")
       ((eq? x-head 'method-declarations-not-defined)
	(string-append "Declarations of the following methods not defined in"
		       " body compilation:\n"
		       (let* ((al-prop (cdr exc))
			      (l-undefined (cdr (assq 'l-undefined al-prop))))
			 (apply string-append
				(map-in-order
				 (lambda (p)
				   (string-append
				    (symbol->string (car p))
				    ": "
				    (target-object-as-string (cdr p))
				    "\n"))
				 l-undefined)))))
       ((eq? x-head 'field-initializer-type-mismatch)
	(string-append "Type mismatch in the initializer of field "
		       (symbol->string (cdr (assq 's-field-name (cdr exc))))))
       ((eq? x-head 'field-type-mismatch-in-param-class)
	(string-append "Type mismatch in the initializer of field "
		       (symbol->string (cdr (assq 's-field-name (cdr exc))))))
       ((eq? x-head 'multiple-prim-class-definitions)
	(string-append "Multiple primitive class definitions with membership "
		       "predicate "
		       (symbol->string (cadr exc))))
       ((eq? x-head 'let:initializer-none)
	(string-append
	 "Let initializer of type <none> for variable "
	 (symbol->string (get-var-orig-name (cdr (assq 's-name (cdr exc)))))))
       ((eq? x-head 'letrec-initializer-with-type-none)
	(string-append
	 "Letrec initializer of type <none> for variable "
	 (symbol->string (get-var-orig-name (cdr (assq 's-name (cdr exc)))))))
       ((eq? x-head 'initializer-expression-with-type-none)
	(string-append
	 "Initializer of type <none> for variable "
	 (symbol->string (get-var-orig-name (cdr (assq 's-name (cdr exc)))))))
       ((eq? x-head 'let:type-mismatch)
	(string-append
	 "Type mismatch for let variable "
	 (symbol->string (get-var-orig-name (cdr (assq 's-name (cdr exc)))))))
       ((eq? x-head 'letrec-var-type-mismatch)
	(string-append
	 "Type mismatch for letrec variable "
	 (symbol->string (get-var-orig-name (cdr (assq 's-name (cdr exc)))))))
       ((eq? x-head 'invalid-let-var-type)
	(string-append
	 "Invalid type for let variable "
	 (symbol->string (get-var-orig-name (cdr (assq 's-name (cdr exc)))))))
       ((eq? x-head 'declaration-in-different-module)
	(string-append
	 "Declaration of variable "
	 (symbol->string (get-var-orig-name (cdr (assq 's-var-name (cdr exc)))))
	 " in different module "
	 (convert-module-to-text (cdr (assq 'module (cdr exc))))))
       ((eq? x-head 'illegal-use-of-keyword)
	(string-append
	 "Illegal use of keyword "
	 (symbol->string (cdr (assq 's-keyword (cdr exc))))))
       ((eq? x-head 'static-cast-type-mismatch)
	"Type mismatch in static cast")
       ((eq? x-head 'field-type-none1)
	(string-append "The type of the field "
		       (symbol->string (cdr (assq 's-field-name (cdr exc))))
		       " is <none>"))
       ((eq? x-head 'field-ref:nonexistent-field)
	(string-append "Reference to nonexistent field "
		       (symbol->string (cdr (assq 's-field-name (cdr exc))))))
       ((eq? x-head 'field-set!:nonexistent-field)
	(string-append "Trying to set nonexistent field "
		       (symbol->string (cdr (assq 's-field-name (cdr exc))))))
       ((eq? x-head 'nonexistent-field)
	(string-append "Trying to access nonexistent field "
		       (symbol->string (cdr (assq 's-field-name (cdr exc))))))
       ((eq? x-head 'forward-def-type-mismatch)
	(let ((s-name (cdr (assq 's-name (cdr exc)))))
	  (string-append
	   "Type mismatch when defining declared variable "
	   (symbol->string s-name))))
       ((eq? x-head 'mutable-forward-def-type-mismatch)
	(let ((s-name (cdr (assq 's-name (cdr exc)))))
	  (string-append
	   "Type mismatch when defining declared variable "
	   (symbol->string s-name))))
       ((eq? x-head 'unaccessible-letrec-variable)
	(let ((s-name (cdr (assq 's-name (cdr exc)))))
	  (string-append
	   "Unaccessible letrec variable "
	   (symbol->string (get-var-orig-name s-name)))))
       ((eq? x-head 'result-type-mismatch-1)
	"Result type mismatch")
       ((eq? x-head 'generic-static-dispatch-error-1)
	"Generic static dispatch error")
       ((memq x-head
	      (list 'invalid-number-of-args 'invalid-number-of-args-2))
	(let ((s-proc-name (cdr (assq 's-proc-name (cdr exc)))))
	  (if (not-null? s-proc-name)
	      (string-append
	       "Invalid number of arguments for procedure "
	       (symbol->string s-proc-name))
	      "Invalid number of arguments")))
       ((eq? x-head 'tuple-ref:not-a-tuple)
	(let ((tt (cdr (assq 'tt (cdr exc)))))
	  (string-append
	   "Type " (target-object-as-string tt) " is not a tuple")))
       ((eq? x-head 'declarations-not-defined)
	(let ((l-undefined (cdr (assq 'l-undefined (cdr exc)))))
	  (cond
	   ((null? l-undefined) "Internal error")
	   ((null? (cdr l-undefined))
	    (string-append "Declaration of variable "
			   (if (symbol? (car l-undefined))
			       (symbol->string (car l-undefined))
			       "?")
			   " not defined in target body compilation"))
	   (else
	    (string-append
	     "Declarations of the following variables are undefined"
	     " in the body compilation:\n"
	     (apply string-append
		    (map-in-order
		     (lambda (x)
		       (if (symbol? x)
			   (string-append "  " (symbol->string x) "\n")
			   "  ?\n"))
		     l-undefined)))))))
       ((eq? x-head 'illegal-incomplete-value)
	(let ((s-name (cdr (assq 's-name (cdr exc)))))
	  (string-append
	   "Illegal reference to an incomplete constant in the definition of "
	   "variable "
	   (symbol->string s-name))))
       ((eq? x-head 'illegal-incomplete-ref)
	(let ((s-name (cdr (assq 's-name (cdr exc)))))
	  (string-append
	   "Illegal reference to an incomplete variable in the definition of "
	   "variable "
	   (symbol->string s-name))))
       (else
	(if (= (length exc) 1)
	    (if (symbol? x-head)
		(string-append "Error " (symbol->string x-head))
		"?")
	    (if (symbol? x-head)
		(string-append "Error (" (symbol->string x-head) " ...)")
		"?"))))))
   (else
    (cond
     ((eq? exc 'module-name-mismatch)
      "Module name mismatch")
     ((eq? exc 'cannot-open-interface-file)
      "Cannot open interface file")
     ((eqv? exc 'unbound-variable)
      (string-append "Unbound variable "
		     (get-var-orig-name
		      (symbol->string (hfield-ref compiler 'error-info)))))
     ;; Global variables don't need get-var-orig-name.
     ((eqv? exc 'duplicate-definition)
      (string-append "Duplicate definition"
		     (get-var-text (hfield-ref compiler 'error-info))))
     ((eqv? exc 'invalid-redefinition)
      (string-append "Invalid redefinition"
		     (get-var-text (hfield-ref compiler 'error-info))))
     ((eqv? exc 'noncovariant-method-declaration-1)
      (string-append "Noncovariant method declaration in generic procedure "
		     (symbol->string (hfield-ref compiler 'error-info))))
     ;; (call-with-output-string
     ;;  (lambda (port)
     ;;    (let* ((error-info (hfield-ref compiler 'error-info))
     ;; 	      (sym-genproc (car error-info))
     ;; 	      (obj-method-type (cadr error-info)))
     ;;    (display "Noncovariant method definition in generic procedure " port)
     ;;    (display sym-genproc port)
     ;;    (display " with method type " port)
     ;;    (display obj-method-type port)))))
     ((eq? exc 'field-set-access-violation)
      "Access violation in field-set!")
     ((eq? exc 'definition-mutability-mismatch)
      "Definition mutability mismatch")
     ((eq? exc 'declaration-mutability-mismatch)
      "Declaration mutability mismatch")
     ((eq? exc 'purity-violation-in-set-expr)
      "Purity violation in set! expression")
     ((eq? exc 'purity-mismatch)
      ;; Exception purity-mismatch is raised only for procedures.
      "Procedure purity mismatch")
     ((eq? exc 'constructor-access-violation)
      "Constructor access violation")
     ((eq? exc 'proc-attribute-mismatch)
      "Procedure attribute mismatch")
     ((eq? exc 'invalid-immutable-class)
      "Invalid immutable class")
     ((eq? exc 'invalid-immutable-param-class-instance)
      "Invalid immutable parametrized class instance")
     ((memq exc (list 'invalid-generic-procedure
		      'declare-method:invalid-generic-procedure))
      "Invalid generic procedure")
     ((eq? exc 'internal-undefined-constructor)
      "Undefined constructor")
     ((eq? exc 'invalid-attributes-in-dispatch)
      "Invalid attributes in generic procedure dispatch")
     ((eq? exc 'trying-to-set-nonmutable-variable)
      "Trying to set a nonmutable variable")
     ((eq? exc 'not-a-param-proc)
      "Expected a parametrized procedure")
     ((eq? exc 'invalid-if-condition)
      "Invalid condition in if expression")
     ((eq? exc 'invalid-let-variable)
      "Invalid let variable")
     ((eq? exc 'invalid-letrec-variable)
      "Invalid letrec variable")
     ((eq? exc 'invalid-define-mutable-expr)
      "Invalid mutable definition")
     ((eq? exc 'invalid-let-var-name)
      "Invalid let variable name")
     ((eq? exc 'prelink-in-interface)
      "Form prelink-body may not occur in an interface")
     ((eq? exc 'match-type-strong:not-covered)
      "Expression type not covered by match-type-strong clauses")
     ((symbol? exc)
      (string-append "Error " (symbol->string exc)))
     (else "Error")))))


(define (convert-expr-to-text expr)
  (cond
   ((null? expr) "()")
   ((list? expr) "(...)")
   ((pair? expr) "(...)")
   ((number? expr) (number->string expr))
   ((char? expr) (string-append "\\" (string expr)))
   ((string? expr) (string-append "\"" expr "\""))
   ((symbol? expr) (symbol->string expr))
   ((boolean? expr) (if expr "#t" "#f"))
   (else "X")))


(define gl-print-only-first-element
  '(lambda let let* letrec letrec*
	   let-mutable let*-mutable
	   letrec-mutable letrec*-mutable))


(define (get-expr-output expr)
  (if (not (list? expr))
      (convert-expr-to-text expr)
      (let ((len (length expr)))
	(cond
	 ((= len 0)
	  "'()")
	 ((memv (car expr) gl-print-only-first-element)
	  (string-append "(" (symbol->string (car expr)) " ...)"))
	 ((= len 1)
	  (string-append "("
			 (convert-expr-to-text (car expr))
			 ")"))
	 ((= len 2)
	  (string-append "("
			 (convert-expr-to-text (car expr))
			 " "
			 (convert-expr-to-text (cadr expr))
			 ")"))
	 (else
	  (string-append "("
			 (convert-expr-to-text (car expr))
			 " "
			 (convert-expr-to-text (cadr expr))
			 " ...)"))))))


(define (get-expr-text expr toplevel?)
  (if toplevel?
      (string-append "toplevel expression " (get-expr-output expr))
      (string-append "expression " (get-expr-output expr))))


(define (get-line-and-column compiler)
  (let* ((sexpr1 (get-source-expr (hfield-ref compiler 'current-expr)))
	 ;; Toplevel expressions don't need get-source-expr.
	 (sexpr2 (hfield-ref compiler 'current-toplevel-expr))
	 (al-props1 (source-properties sexpr1))
	 (al-props2 (source-properties sexpr2))
	 (prop1? (if (assq 'line al-props1) #t #f))
	 (pr-line (if prop1? (assq 'line al-props1) (assq 'line al-props2)))
	 (pr-column (if prop1? (assq 'column al-props1)
			(assq 'column al-props2))))
    ;; Guile seems to give the line number one too small.
    (if (and (not (eq? pr-line #f)) (not (eq? pr-column #f)))
	(string-append
	 " (line " (number->string (+ (cdr pr-line) 1))
	 ", column " (number->string (cdr pr-column))
	 ")")
	(if (not (eq? pr-line #f))
	    (string-append
	     " (line " (number->string (+ (cdr pr-line) 1)) ")")
	    ""))))


(define (make-parsing-error-message compiler exc)
  (cond
   ((and (list? exc) (not-null? exc)
	 (eq? (car exc) 'did-not-deduce-all-type-vars))
    (let* ((s-proc1 (cadr exc))
	   (s-proc2 (hfield-ref compiler 's-cur-toplevel-def))
	   (str-text1 (get-proc-text s-proc1 s-proc2)))
      (string-append "Failed to deduce all type variables "
		     str-text1
		     (get-line-and-column compiler)
		     ".")))
   ((and (list? exc)
   	 (eq? (car exc) 'type-mismatch-in-proc-appl))
    (let* ((s-proc1 (cadr exc))
   	   (s-proc2 (hfield-ref compiler 's-cur-toplevel-def))
   	   (str-text1 (get-proc-text s-proc1 s-proc2)))
      (string-append "Type mismatch " str-text1
   		     (get-line-and-column compiler)
		     ".")))
   ((and (list? exc) (not-null? exc)
	 (memq (car exc) (list 'procedure-argument-with-type-none
			       'generic-procedure-argument-with-type-none)))
    (let* ((s-proc1 (cdr (assq 's-proc-name (cdr exc))))
	   (s-proc2 (hfield-ref compiler 's-cur-toplevel-def))
	   (str-text1 (get-proc-text s-proc1 s-proc2)))
      (string-append "Procedure argument with type <none> "
		     str-text1
		     (get-line-and-column compiler)
		     ".")))
   ;; Global variables don't need get-var-orig-name.
   ((and (list? exc)
   	 (eq? (car exc) 'redecl-type-mismatch))
    (string-append "Type mismatch in redeclaration of variable "
		   (symbol->string (cdr (assq 's-name (cdr exc))))
		   (get-line-and-column compiler)
		   "."))
   ;; Global variables don't need get-var-orig-name.
   ((and (list? exc)
   	 (memq (car exc) (list 'cannot-declare-existing-variable-1
			       'cannot-declare-existing-variable-2)))
    (string-append "Trying to declare an existing variable "
		   (symbol->string (cdr (assq 's-name (cdr exc))))
		   (get-line-and-column compiler)
		   "."))
   ((and (symbol? exc) (eq? exc 'illegal-toplevel-form))
    (string-append "A form can be used only toplevel."
		   (get-line-and-column compiler)))
   (else
    (let* ((error-text (get-error-text compiler exc))
	   (expr (get-source-expr (hfield-ref compiler 'current-expr)))
	   ;; Toplevel expressions don't need get-source-expr.
	   (toplevel-expr (hfield-ref compiler 'current-toplevel-expr))
	   (str-line-and-column (get-line-and-column compiler)))

      ;; TBR
      ;; (display "*1*\n")
      ;; (display (hfield-ref compiler 'current-expr))
      ;; (newline)
      ;; (display expr)
      ;; (newline)
      
      (if (or (null? expr) (equal? expr toplevel-expr))
	  (let ((toplevel-expr-text (get-expr-text toplevel-expr #t)))
	    (string-append error-text
			   " while parsing "
			   toplevel-expr-text
			   str-line-and-column
			   "."))
	  (let ((expr-text (get-expr-text expr #f))
		(toplevel-expr-text (get-expr-text toplevel-expr #t)))
	    (string-append error-text
			   " while parsing "
			   expr-text
			   " in "
			   toplevel-expr-text
			   str-line-and-column
			   ".")))))))


(define (make-importing-error-message compiler exc)
  (let ((error-text (get-error-text compiler exc))
	(variable-to-import (hfield-ref compiler 'variable-to-import))
	(module-to-import (hfield-ref compiler 'module-to-import)))
    (let ((module-text
	   (if (not-null? module-to-import)
	       (convert-module-to-text module-to-import)
	       "()")))
      (if (not-null? variable-to-import)
	  (begin
	    (assert (symbol? variable-to-import))
	    (string-append error-text
			   " while importing variable "
			   (symbol->string variable-to-import)
			   " from module "
			   module-text
			   "."))
	  (string-append error-text
			 " while importing module "
			 module-text
			 ".")))))


(define (make-interface-error-message compiler exc)
  (let ((current-interface-var (hfield-ref compiler 'current-interface-var)))
    (if (not-null? current-interface-var)
	(string-append (get-error-text compiler exc)
		       " while compiling variable "
		       (symbol->string
			(hfield-ref
			 (hfield-ref current-interface-var 'address)
			 'source-name))
		       " for the target interface.")
	(string-append (get-error-text compiler exc)
		       " in target interface compilation."))))


(define (make-body-error-message compiler exc)
  (let ((error-text (get-error-text compiler exc))
	(repr (hfield-ref compiler 'current-repr))
	(toplevel-repr (hfield-ref compiler 'current-toplevel-repr)))
    (cond
     ((and (pair? exc) (memq (car exc)
			     (list 'declarations-not-defined
				   'method-declarations-not-defined)))
      error-text)
     ((eqv? repr toplevel-repr)
      (if (not-null? toplevel-repr)
	  (string-append error-text
			 " while compiling "
			 (get-repr-text
			  toplevel-repr
			  #t)
			 " for the target body.")
	  (string-append error-text
			 " in target body compilation.")))
     ((and (not-null? repr) (not-null? toplevel-repr))
      (string-append error-text
		     " while compiling "
		     (get-repr-text
		      repr
		      #f)
		     " in "
		     (get-repr-text
		      toplevel-repr
		      #t)
		     " for the target body."))
     ((and (null? repr) (not-null? toplevel-repr))
      (string-append error-text
		     " while compiling "
		     (get-repr-text
		      toplevel-repr
		      #t)
		     " for the target body."))
     ((and (not-null? repr) (null? toplevel-repr))
      (string-append error-text
		     " while compiling "
		     (get-repr-text
		      repr
		      #f)
		     " for the target body."))
     (else (string-append error-text
			  " while compiling the target body.")))))


(define (make-other-error-message compiler exc)
  (let ((str-line-and-column (get-line-and-column compiler)))
    (string-append (get-error-text compiler exc) str-line-and-column ".")))


(define (get-list-error-message exc)
  (let ((s-error-type (car exc)))
    (cond
     ((memq s-error-type '(noncovariant-method-definition
			   noncovariant-method-declaration))
      (get-noncov-method-error-text exc))
     (else "Error."))))


(define (delete-target-file compiler)
  (let ((target-file (hfield-ref compiler 'target-output-file)))
    (if (not-null? target-file)
	(guard
	 (exc1 (else #t))
	 (close-output-port target-file)))
    (let ((filename (hfield-ref compiler 'target-output-filename)))
      (if (not (string-null? filename))
	  (begin
	    (guard
	     (exc (else
		   (display "Error cleaning target file.")
		   (newline)))
	     (if (file-exists? filename) (delete-file filename)))))))
  (hfield-set! compiler 'target-output-filename "")
  (hfield-set! compiler 'target-output-file '()))


(define (handle-compilation-error compiler exc)
  (delete-target-file compiler)
  (cond
   ((and (condition? exc) (theme-file-exception? exc))
    (display (get-file-error-message exc))
    (newline)
    (my-exit compiler))
   ((null? exc)
    (display "internal error\n")
    (my-exit compiler))
   ((eq? exc 'syntax-violation)
    (my-exit compiler))
   ((and
     (list? exc)
     (memq (car exc) '(noncovariant-method-definition
		       noncovariant-method-declaration)))
    (display (get-list-error-message exc))
    (display (get-line-and-column compiler))
    (display ".")
    (newline)
    (my-exit compiler))
   ((or (symbol? exc) (list? exc))
    (dwl2 "state:")
    (dwl2 (hfield-ref compiler 'state))
    (if (symbol? exc) (dwl2 exc))
    (if (list? exc) (dwl2 (car exc)))
    (let ((message
	   (case (hfield-ref compiler 'state)
	     ((parsing) (make-parsing-error-message compiler exc))
	     ((importing) (make-importing-error-message compiler exc))
	     ((interface-compilation)
	      (make-interface-error-message compiler exc))
	     ((body-compilation) (make-body-error-message compiler exc))
	     ((()) (make-other-error-message compiler exc))
	     (else
	      "Internal error in error handling."))))
      (display message)
      (newline)
      (if (and 
	   ;;	   (eqv? (hfield-ref compiler 'state) 'parsing)
	   (hfield-ref compiler 'display-erroneous-expr?)
	   (not-null? (hfield-ref compiler 'current-expr)))
	  (begin
	    (display "Expression causing the error:\n")
	    (write (get-source-expr (hfield-ref compiler 'current-expr)))
	    (newline)))
      (if (and (hfield-ref compiler 'display-erroneous-expr?)
	       (list? exc))
	  (cond
	   ((memq (car exc) '(result-type-mismatch-1
			      type-mismatch-in-param-proc-appl-1))
	    (let* ((al-prop (cdr exc))
		   (declared-type (cdr (assq 'declared-type al-prop)))
		   (actual-type (cdr (assq 'actual-type al-prop))))
	      (display "Actual type: ")
	      (display (target-object-as-string actual-type))
	      (newline)
	      (display "Declared type: ")
	      (display (target-object-as-string declared-type))
	      (newline)))
	   ((eq? (car exc) 'type-mismatch-in-proc-appl)
	    (let* ((al-prop (drop exc 2))
		   (declared-type (cdr (assq 'declared-type al-prop)))
		   (actual-type (cdr (assq 'actual-type al-prop))))
	      (display "Actual type: ")
	      (display (target-object-as-string actual-type))
	      (newline)
	      (display "Declared type: ")
	      (display (target-object-as-string declared-type))
	      (newline)))
	   ((eq? (car exc) 'did-not-deduce-all-type-vars)
	    (let* ((al-prop (drop exc 2))
		   (actual-type (cdr (assq 'actual-type al-prop)))
		   (declared-type (cdr (assq 'declared-type al-prop)))
		   (bindings (cdr (assq 'bindings al-prop)))
		   (l-needed (cdr (assq 'needed al-prop))))
	      (display "Actual type: ")
	      (display (target-object-as-string actual-type))
	      (newline)
	      (display "Declared type: ")
	      (display (target-object-as-string declared-type))
	      (newline)
	      (display-bindings bindings)
	      (display "Needed type variables: ")
	      (display (target-object-as-string l-needed))
	      (newline)))
	   ;; ((eq? (car exc) 'method-declaration-not-defined)
	   ;;  (let* ((al-prop (cdr exc))
	   ;; 	   (tt-method (cdr (assq 'tt-method al-prop))))
	   ;;    (display "Declared type: ")
	   ;;    (display (target-object-as-string tt-method))
	   ;;    (newline)))
	   ((memq (car exc)
		  (list 'redecl-type-mismatch
			'forward-def-type-mismatch
			'mutable-forward-def-type-mismatch))
	    (let* ((al-prop (cdr exc))
		   (tt-new (cdr (assq 'tt-new al-prop)))
		   (tt-old (cdr (assq 'tt-old al-prop))))
	      (display "New type: ")
	      (display (target-object-as-string tt-new))
	      (newline)	      
	      (display "Old type: ")
	      (display (target-object-as-string tt-old))
	      (newline)))
	   ((memq (car exc) (list 'field-initializer-type-mismatch
				  'field-type-mismatch-in-param-class))
	    (let* ((al-prop (cdr exc))
		   (tt-field (cdr (assq 'tt-field al-prop)))
		   (tt-init (cdr (assq 'tt-init al-prop))))
	      (display "Type of the field: ")
	      (display (target-object-as-string tt-field))
	      (newline)	      
	      (display "Type of the initializer: ")
	      (display (target-object-as-string tt-init))
	      (newline)))
	   ((memq (car exc)
		  (list 'let:type-mismatch 'letrec-var-type-mismatch
			'static-cast-type-mismatch))
	    (let* ((al-prop (cdr exc))
		   (tt-actual (cdr (assq 'tt-actual al-prop)))
		   (tt-declared (cdr (assq 'tt-declared al-prop))))
	      (display "Actual type: ")
	      (display (target-object-as-string tt-actual))
	      (newline)	      
	      (display "Declared type: ")
	      (display (target-object-as-string tt-declared))
	      (newline)))
	   ((eq? (car exc) 'generic-static-dispatch-error-1)
	    (let* ((al-prop (cdr exc))
		   (l-arg-types (cdr (assq 'arg-types al-prop))))
	      (display "Argument types: ")
	      (display (target-object-as-string l-arg-types))
	      (newline)))
	   ((eq? (car exc) 'invalid-number-of-args)
	    (let* ((al-prop (cdr exc))
		   (variable-length? (cdr (assq 'variable-length? al-prop)))
		   (i-actual-args (cdr (assq 'i-actual-args al-prop)))
		   (i-desired-args (cdr (assq 'i-desired-args al-prop))))
	      (display "Actual number of arguments: ")
	      (display i-actual-args)
	      (newline)
	      (display "Desired number of arguments: ")
	      (if variable-length? (display ">="))
	      (display i-desired-args)
	      (newline)))))
      (my-exit compiler)))
   (else
    (raise exc))))
