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

#lang racket

(provide
 make-theme-d-condition
 theme-d-condition?
 theme-d-condition-kind
 theme-d-condition-info
 call-stack-push
 call-stack-pop
 call-stack-print
 my-error-exit
 proc-not-linked
 theme-command-line
 theme-set-command-line!
 vector-copy-contents
 vector-copy-contents-rev
 set-cons!
 _b_<object>
 _b_<boolean>
 _b_<string>
 _b_<symbol>
 _b_<logical-type>
 _b_<class>
 _b_<field>
 _b_none
 _b_<null>
 _b_<character>
 _b_<real>
 _b_<integer>
 _b_<procedure>
 _b_<eof>
 _b_nil
 _b_eof
 _i_make-class
 _i_field-ref
 _i_field-set!
 _i_make-procedure
 _b_<type-variable>
 _b_<param-class>
 _b_<param-logical-type>
 _b_:param-proc
 _i_make-param-ltype
 _b_:union
 _b_<type>
 _b_:pair
 _b_:uniform-list
 _b_:simple-proc
 _b_:procedure
 _i_make-param-class-inst
 _b_:gen-proc
 _i_add-method!
 _b_:vector
 _b_:mutable-vector
 _b_:value-vector
 _b_:mutable-value-vector
 _i_make-param-proc-class
 _i_make-param-proc
 _i_construct-vector
 _i_construct-mutable-vector
 _i_construct-value-vector
 _i_construct-mutable-value-vector
 notify-custom-prim-class
 theme-class-of0
 theme-class-of
 is-valid-theme-d-object?
 _i_get-concrete-param-class-inst
 _i_get-pair-class-general
 _i_get-concrete-param-ltype-inst
 _i_get-param-class-inst1
 _i_get-param-ltype-inst1
 _i_get-pair-class-general1
 _b_<type-list>
 create-type-list
 _b_<rest>
 _i_make-rest-expression
 _b_<splice>
 _i_make-splice-expression
 _b_<type-join>
 _i_make-type-join
 _b_<type-loop>
 _i_make-type-loop
 translate-call-arguments
 construct-type-loop-repr1
 _b_<signature>
 make-signature
 _b_<param-signature>
 make-param-signature
 is-subtype?
 is-instance?
 is-param-inst-subclass?
 is-instance-of-simple-class?
 is-simple-class-subtype?
 _i_make-param-class
 _i_call-generic-proc
 _i_dispatch-generic-proc
 _i_call-simple-proc
 _i_call-param-proc
 _i_call-proc
 _i_cast
 _i_cast-error
 _b_cast-vector
 _b_raw_cast-vector
 _b_cast-mutable-vector
 _b_raw_cast-mutable-vector
 _b_cast-value-vector
 _b_raw_cast-value-vector
 _b_cast-mutable-value-vector
 _b_raw_cast-mutable-value-vector
 _b_cast-vector0
 _b_raw_cast-vector0
 _b_cast-mutable-vector0
 _b_raw_cast-mutable-vector0
 _b_cast-value-vector0
 _b_raw_cast-value-vector0
 _b_cast-mutable-value-vector0
 _b_raw_cast-mutable-value-vector0
 _b_cast-vector-metaclass
 _b_raw_cast-vector-metaclass
 _b_cast-mutable-vector-metaclass
 _b_raw_cast-mutable-vector-metaclass
 _b_cast-value-vector-metaclass
 _b_raw_cast-value-vector-metaclass
 _b_cast-mutable-value-vector-metaclass
 _b_raw_cast-mutable-value-vector-metaclass
 _i_result-type-error
 _i_check-result-type
 check-type-verbose
 _i_invalid-theme-d-object-error
 _i_match-type-strong-no-match
 check-var-unspecified
 check-field-unspecified
 check-letrec-unspecified
 check-type
 check-arglist-type
 theme-eof
 _i_make-simple-proc-class
 _i_make-tuple-type
 _b_field-ref
 _b_raw_field-ref
 _b_field-set!
 _b_raw_field-set!
 _b_class-of
 _b_raw_class-of
 _b_is-subtype?
 _b_raw_is-subtype?
 _b_is-instance?
 _b_raw_is-instance?
 _b_tuple-ref
 _b_raw_tuple-ref
 _b_make-vector
 _b_raw_make-vector
 _b_make-mutable-vector
 _b_raw_make-mutable-vector
 _b_make-value-vector
 _b_raw_make-value-vector
 _b_make-mutable-value-vector
 _b_raw_make-mutable-value-vector
 _b_vector
 _b_raw_vector
 _b_mutable-vector
 _b_raw_mutable-vector
 _b_value-vector
 _b_raw_value-vector
 _b_mutable-value-vector
 _b_raw_mutable-value-vector
 _i_raise-assertion-failed
 _b_equal-values?
 _b_raw_equal-values?
 _b_equal-objects?
 _b_raw_equal-objects?
 _b_equal-contents?
 _b_raw_equal-contents?
 _b_apply
 _b_apply-impl
 _b_apply-nonpure
 _b_call/cc
 _b_call/cc-nonpure
 _b_call/cc-without-result
 gl-rte
 i-rte-tvar-allocator
 prt
 prt-fwd
 i-tva-start
 _b_unspecified
 make-custom-prim-class
 make-empty-gen-proc
 i-object-class
 _i_make-concrete-union
 _i_make-procedure-type
 make-field
 i-class-type-constructor
 i-class-proc-constructor
 i-class-zero-value
 make-tvar-object
 make-pci-preobject2
 get-constructor
 theme-eof?
 i-rte-arg-xlat
 theme-equal?
 theme-equal-objects?
 theme-equal-contents?
 i-simple-proc-raw-proc
 is-instance-of-class?
 i-param-proc-raw-proc
 i-param-class-instance-has-zero
 i-param-class-instance-zero-proc
 get-zero
 _i_check-procedure-arg-list-type?
 _b_this
 set-rte-dbg!
 i-procedure-class-arg-list-type
 make-gen-proc-class
 i-class-has-zero
 general-list->list
 make-list-with-tail
 gl-custom-prim-classes
 gl-enable-rte-exception-info?
 set-rte-exception-info!
 set-verbose-errors!
 set-backtrace!
 set-pretty-backtrace!
 set-pretty-backtrace-support!)


;; *** Import modules ***


(require theme-d-racket/th-scheme-utilities/stdutils)
(require theme-d-racket/runtime/params)
(require theme-d-racket/runtime/theme-d-alt-support)
(require theme-d-racket/runtime/theme-d-special1)
;; We use the assert from stdutils.
(require (except-in rnrs assert))
(require rnrs/mutable-pairs-6)
;;(require (only-in srfi/1 every any find))
;;(require racket/fixnum)


;; *** Some global variables ***


(define gl-verbose-errors? #t)
(define gl-backtrace? #f)
(define gl-pretty-backtrace? #f)
(define gl-pretty-backtrace-support? #f)
(define gl-script? #f)
(define gl-enable-rte-exception-info? #f)


(define platform 'racket)

(define dbg 0)

(define dbg-counter 0)
(define dbg-counter2 0)

(define _b_unspecified (void))

(define unspecified? void?)

(if1 (or (not (integer? gl-i-ht-goops-native-classes-size))
	 (< gl-i-ht-goops-native-classes-size 0))
     (begin
       (display "Invalid value for gl-i-ht-goops-native-classes-size\n")
       (exit 1)))

(if1 (or (not (integer? gl-i-ht-goops-classes-size))
	 (< gl-i-ht-goops-classes-size 0))
     (begin
       (display "Invalid value for gl-i-ht-goops-classes-size\n")
       (exit 1)))

(define rte-dbg? #f)

(define (set-rte-dbg! b) (set! rte-dbg? b))


;; Theme-D condition type


(define-condition-type &theme-d-condition &condition
  make-theme-d-condition theme-d-condition?
  (s-kind theme-d-condition-kind)
  (al-info theme-d-condition-info))


;; *** Printing runtime objects ***


(define (list-contents-to-string lst visited)
  (let ((result
	 (if (null? lst)
	     ""
	     (string-append
	      (obj->string-to-display (car lst) visited)
	      (if (not-null? (cdr lst)) " " "")
	      (list-contents-to-string (cdr lst) visited)))))
    result))


(define (tvar->string-to-display tvar)
  (string-append
   "%"
   (number->string (vector-ref tvar i-tvar-object-number))))


(define (aplti->string-to-display aplti visited)
  (string-append
   "(*"
   (vector-ref (vector-ref aplti i-aplti-param-ltype) i-class-name)
   " "
   (list-contents-to-string (vector-ref aplti i-aplti-tvar-values)
			    visited)
   "*)"))


(define (apci->string-to-display apci visited)
  (string-append
   "(*"
   (vector-ref (vector-ref apci i-apci-param-class) i-class-name)
   " "
   (list-contents-to-string (vector-ref apci i-apci-tvar-values)
			    visited)
   "*)"))


(define (obj->string-to-display obj visited)
  (let ((new-visited (cons obj visited)))
    (cond
     ((null? obj) "[]")
     ((eq? obj _b_<null>) "{}")
     ((mymemq obj visited) "/cycle/")
     ((is-tvar-object? obj)
      (tvar->string-to-display obj))
     ((list? obj)
      (string-append
       "["
       (list-contents-to-string obj new-visited)
       "]"))
     ((pair? obj)
      (string-append "["
		     (obj->string-to-display (car obj) new-visited)
		     " . "
		     (obj->string-to-display (cdr obj) new-visited)
		     "]"))
     ((is-tuple-type? obj)
      (string-append
       "{"
       (list-contents-to-string (tuple-type->list-reject-cycles obj)
				new-visited)
       "}"))
     ((is-pair-class? obj)
      (string-append
       "{"
       (obj->string-to-display (gen-car obj) new-visited)
       " . "
       (obj->string-to-display (gen-cdr obj) new-visited)
       "}"))
     ((is-simple-proc-class? obj)
      (string-append
       "(:simple-proc "
       (obj->string-to-display (vector-ref obj i-procedure-class-arg-list-type)
			       new-visited)
       " "
       (obj->string-to-display (vector-ref obj i-procedure-class-result-type)
			       new-visited)
       " "
       (if (vector-ref obj i-procedure-class-pure-proc) "pure" "nonpure")
       ")"))
     ((is-param-proc-class? obj)
      (let ((tvars (vector-ref obj i-ppc-tvars))
	    (inst-type (vector-ref obj i-ppc-inst-type)))
	(string-append
	 "(:param-proc ["
	 (list-contents-to-string tvars new-visited)
	 "] "
	 (obj->string-to-display
	  (vector-ref inst-type i-procedure-class-arg-list-type)
	  new-visited)
	 " "
	 (obj->string-to-display
	  (vector-ref inst-type i-procedure-class-result-type)
	  new-visited)
	 " "
	 (if (vector-ref inst-type i-procedure-class-pure-proc)
	     "pure" "nonpure")
	 ")")))
     ((is-abstract-proc-type? obj)
      (string-append
       "(:procedure "
       (obj->string-to-display (vector-ref obj i-procedure-class-arg-list-type)
			       new-visited)
       " "
       (obj->string-to-display (vector-ref obj i-procedure-class-result-type)
			       new-visited)
       " "
       (if (vector-ref obj i-procedure-class-pure-proc) "pure" "nonpure")
       ")"))
     ((is-type-list? obj)
      (string-append
       "(type-list "
       (list-contents-to-string (vector-ref obj i-type-list-subexprs)
				new-visited)
       ")"))
     ((is-splice-expression? obj)
      (string-append
       "(splice "
       (obj->string-to-display (vector-ref obj i-splice-component)
			       new-visited)
       ")"))
     ;; ((is-concrete-uniform-list? obj)
     ;;  (string-append
     ;;   "(:uniform-list "
     ;;   (obj->string-to-display (get-uniform-list-element-type obj))
     ;;  ")"))
     ((is-type-loop? obj)
      (string-append
       "(type-loop "
       (tvar->string-to-display (vector-ref obj i-type-loop-iter-var))
       " "
       (obj->string-to-display (vector-ref obj i-type-loop-subtype-list)
			       new-visited)
       " "
       (obj->string-to-display (vector-ref obj i-type-loop-iter-expr)
			       new-visited)
       ")"))
     ((is-class? obj)
      (vector-ref obj i-class-name))
     ((is-aplti? obj)
      (aplti->string-to-display obj new-visited))
     ((is-apci? obj)
      (apci->string-to-display obj new-visited))
     ((is-union? obj)
      (string-append
       "(:union "
       (list-contents-to-string (vector-ref obj i-union-member-types)
				new-visited)
       ")"))
     ((is-singleton? obj)
      (string-append
       "(<singleton> "
       (obj->string-to-display (vector-ref obj i-singleton-element)
			       new-visited)
       ")"))
     ((is-marker? obj)
      (string-append
       "(<marker> "
       (obj->string-to-display (vector-ref obj i-marker-object)
			       new-visited)
       ")"))
     ((eq? obj _b_none)
      "<none>")
     (else
      (let* ((cl (theme-class-of obj))
	     (class-name (vector-ref cl i-class-name)))
	(string-append "@" class-name))))))


(define (prt obj)
  (display (obj->string-to-display obj '()))
  (newline))


(define prt-fwd prt)


;; *** Debugging ***


(define dwl
  (lambda (obj)
    (if1 (>= dbg 2) (write-line obj))))

(define dwl2
  (lambda (obj)
    (if1 (>= dbg 2) (write-line obj))))

(define dwl1
  (lambda (obj)
    (if1 (>= dbg 1) (write-line obj))))

(define dw
  (lambda (obj)
    (if1 (>= dbg 2) (display obj))))

(define dw2
  (lambda (obj)
    (if1 (>= dbg 2) (display obj))))


(define dw1
  (lambda (obj)
    (if1 (>= dbg 1) (display obj))))


(define debug-prt
  (lambda (obj) '()))
;;  (lambda (obj)
;;    (if (>= dbg 1) (prt-fwd obj))))


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


(define (debug-pause)
  (if1 dbg (read)))


(define dvar1 #f)

(define dvar2 #f)

(define dvar3 #f)

(define dvar4 #f)

(define dvar5 #f)


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


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


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


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


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


(define gl-ctr1 0)
(define gl-flag? #f)
(define gl-flag2? #f)


(define gl-l-call-stack '())


(define gl-i-indent 0)

(define (get-indentation-prefix level)
  (cond
   ((= level 0) "")
   ((< level 0) (raise 'internal-error))
   (else
    (string-append " " (get-indentation-prefix (- level 1))))))

(define (dwli obj)
  (if rte-dbg?
      (begin
	(display (get-indentation-prefix gl-i-indent))
	(display obj)
	(newline))
      (void)))

(define (prti obj)
  (if rte-dbg?
      (begin
	(display (get-indentation-prefix gl-i-indent))
	(display (obj->string-to-display obj '()))
	(newline))
      (void)))

(define (call-stack-push s-kind s-name s-module)
  (set! gl-l-call-stack
	(cons (list s-kind s-name s-module) gl-l-call-stack)))


(define (call-stack-pop)
  (assert (not-null? gl-l-call-stack))
  (set! gl-l-call-stack (cdr gl-l-call-stack)))


(define (call-stack-print-entry i l-entry)
  (format #t "~5@a ~8a ~20a ~a\n"
	  i
	  (list-ref l-entry 0)
	  (list-ref l-entry 1)
	  (list-ref l-entry 2)))


(define (call-stack-print)
 (let ((l1 (reverse gl-l-call-stack)))
   (display "Theme-D backtrace:\n")
   (do ((l2 l1 (cdr l2)) (i 1 (+ i 1))) ((null? l2))
     (call-stack-print-entry i (car l2)))
   (newline)))


  (define (print-genproc-attr-error
	   type appl-pure?
	   appl-always-returns?
	   appl-never-returns?
	   static-method?)
    (display "Generic procedure attribute mismatch")
    (newline)
    (display "pure (1): ")
    (display (vector-ref 
	      type
	      i-procedure-class-pure-proc))
    (newline)
    (display "always returns (1): ")
    (display (vector-ref
	      type
	      i-procedure-class-appl-always-returns))
    (newline)
    (display "never returns (1): ")
    (display (vector-ref
	      type
	      i-procedure-class-appl-never-returns))
    (newline)
    (display "static method (1): ")
    (display (vector-ref
	      type
	      i-procedure-class-static-method))
    (newline)
    (display "pure (2): ")
    (display appl-pure?)
    (newline)
    (display "always returns (2): ")
    (display appl-always-returns?)
    (newline)
    (display "never returns (2): ")
    (display appl-never-returns?)
    (newline)
    (display "static method (2): ")
    (display static-method?)
    (newline))


(define (display-error-info exc)
  (if1 (theme-d-condition? exc)
       (let ((s-kind (theme-d-condition-kind exc))
	     (al-info (theme-d-condition-info exc)))
	 (if1 (not (eq? al-info #f))
	      (case s-kind
		((suitable-method-not-found)
		 (display "Suitable method not found for ")
		 (display "generic procedure ")
		 (display (cdr (assq 'str-name al-info)))
		 (display ".\n"))
		((assertion-failed)
		 (display "Assertion ")
		 (display-normal-list (cdr (assq 'sx-condition al-info)))
		 (display " failed.\n"))
		((runtime-type-mismatch-in-cast)
		 (display "Runtime type mismatch in cast.\n")
		 (display "Type of the object: ")
		 (prt-fwd (cdr (assq 'cl-object al-info)))
		 (display "Type to cast: ")
		 (prt-fwd (cdr (assq 'type-target al-info))))
		((cast-vector:element-type-mismatch)
		 (display "cast-vector: element type mismatch\n")
		 (display "new element type: ")
		 (prt-fwd (cdr (assq 'type-new al-info)))
		 (display "old element type: ")
		 (prt-fwd (cdr (assq 'type-old al-info))))
		((cast-mutable-vector:element-type-mismatch)
		 (display "cast-mutable-vector: element type mismatch\n")
		 (display "new element type: ")
		 (prt-fwd (cdr (assq 'type-new al-info)))
		 (display "old element type: ")
		 (prt-fwd (cdr (assq 'type-old al-info))))
		((cast-value-vector:element-type-mismatch)
		 (display "cast-value-vector: element type mismatch\n")
		 (display "new element type: ")
		 (prt-fwd (cdr (assq 'type-new al-info)))
		 (display "old element type: ")
		 (prt-fwd (cdr (assq 'type-old al-info))))
		((cast-mutable-value-vector:element-type-mismatch)
		 (display "cast-mutable-value-vector: element type mismatch\n")
		 (display "new element type: ")
		 (prt-fwd (cdr (assq 'type-new al-info)))
		 (display "old element type: ")
		 (prt-fwd (cdr (assq 'type-old al-info))))
		((param-proc-type-mismatch)
		 (display "Type mismatch applying parametrized procedure ")
		 (display (cdr (assq 'str-name al-info)))
		 (display ".\n")
		 (display "Actual type: ")
		 (prt-fwd (cdr (assq 'type-actual al-info)))
		 (display "Declared type: ")
		 (prt-fwd (cdr (assq 'type-declared al-info))))
		((generic-dispatch:invalid-attributes)
		 (print-genproc-attr-error
		  (cdr (assq 'type al-info))
		  (cdr (assq 'appl-pure? al-info))
		  (cdr (assq 'appl-always-returns? al-info))
		  (cdr (assq 'appl-never-returns? al-info))
		  (cdr (assq 'static-method? al-info))))
		((arg-list-type-mismatch)
		 (let ((s-proc-name (cdr (assq 's-proc-name al-info))))
		   (if (null? s-proc-name)
		       (begin
			 (display "Argument type list mismatch.\n")
			 (display "Actual type: ")
			 (prt-fwd (cdr (assq 'type-actual al-info)))
			 (display "Declared type: ")
			 (prt-fwd (cdr (assq 'type-declared al-info))))
		       (begin
			 (display "Argument type list mismatch ")
			 (display "while calling procedure ")
			 (display s-proc-name)
			 (display ".\n")
			 (display "Actual type: ")
			 (prt-fwd (cdr (assq 'type-actual al-info)))
			 (display "Declared type: ")
			 (prt-fwd (cdr (assq 'type-declared al-info)))))))
		((procedure-result-type-mismatch)
		 (display "Result type mismatch with procedure ")
		 (display (cdr (assq 's-proc-name al-info)))
		 (display ".\n")
		 (display "Actual type: ")
		 (prt-fwd (cdr (assq 'type-actual al-info)))
		 (display "Declared type: ")
		 (prt-fwd (cdr (assq 'type-declared al-info))))
		((runtime-type-check-failed)
		 (display "Type mismatch.\n")
		 (display "Actual type: ")
		 (prt-fwd (cdr (assq 'type-actual al-info)))
		 (display "Declared type: ")
		 (prt-fwd (cdr (assq 'type-declared al-info))))
		((runtime-type-check-failed-verbose)
		 (display "Value of expression\n")
		 (display (cdr (assq 'sx-expression al-info)))
		 (display "\nof type\n")
		 (prt-fwd (cdr (assq 'type-actual al-info)))
		 (display "is not an instance of type\n")
		 (prt-fwd (cdr (assq 'type-declared al-info))))
		((unspecified-var-value)
		 (let ((s-var-name (cdr (assq 's-var-name al-info))))
		   (if (symbol? s-var-name)
		       (display (string-append
				 "Variable "
				 (symbol->string s-var-name)
				 " is unspecified.\n"))    
		       (display "Unspecified variable value.\n"))))
		((unspecified-letrec-var-value)
		 (let ((s-var-name (cdr (assq 's-var-name al-info))))
		   (display (string-append
			     "Unspecified value for variable "
			     (symbol->string s-var-name)
			     " in a letrec expression\n"))))
		((unspecified-field-value)
		 (let ((s-field-name (cdr (assq 's-field-name al-info))))
		   (if (symbol? s-field-name)
		       (display (string-append
				 "Field "
				 (symbol->string s-field-name)
				 " is unspecified.\n"))    
		       (display "Unspecified field value.\n"))))
		((not-a-theme-d-object)
		 (display "Invalid Theme-D object returned from procedure ")
		 (display (cdr (assq 'str-proc-name al-info)))
		 (display ".\n"))
		((match-type-strong:no-match)
		 (display "No matching clause in a match-type-strong ")
		 (display "expression.\n"))
		((io-error)
		 (display "subkind: ")
		 (display (cdr (assq 's-subkind al-info)))
		 (newline)
		 (display "filename: ")
		 (display (cdr (assq 'str-filename al-info)))
		 (newline)))))))


(define (my-error-exit exc)
  (cond
   ((not (theme-d-condition? exc))
    (if1 gl-pretty-backtrace? (call-stack-print))
    (raise exc))
   ((eq? (theme-d-condition-kind exc) 'exit)
    (exit (cdr (assq 'i-exit-code (theme-d-condition-info exc)))))
   (else
    (if1 gl-verbose-errors? (display-error-info exc))
    (if1 gl-pretty-backtrace? (call-stack-print))
    (let ((exc1
	   (if (theme-d-condition? exc)
	       (theme-d-condition-kind exc)
	       exc)))
      (if gl-backtrace?
	  (raise exc1)
	  (begin
	    (display "Error: ")
	    (display exc1)
	    (newline)
	    (exit 1)))))))


;; (set! my-error-exit-fwd my-error-exit)


(define (my-raise exc)
  (if (symbol? exc)
      (raise (make-theme-d-condition exc '()))
      (if gl-enable-rte-exception-info?
	  (raise (make-theme-d-condition (car exc) (cdr exc)))
	  ;; If the Theme-D default exception handler is not launched the
	  ;; auxiliary information could cause ugly output with the
	  ;; Guile default exception handler.
	  (if (not-null? (cdr exc))
	      (raise (make-theme-d-condition (car exc) #f))
	      (raise (make-theme-d-condition (car exc) '()))))))


;; The following procedure includes the exception info always.
(define (my-raise1 exc)
  (if (symbol? exc)
      (raise (make-theme-d-condition exc '()))
      (raise (make-theme-d-condition (car exc) (cdr exc)))))


(define (proc-not-linked s-name)
  (display "Procedure ")
  (display s-name)
  (display " used before linked.")
  (newline)
  (my-raise 'proc-not-linked))


;; *** Setting some flags ***


(define (set-rte-exception-info! b)
  (set! gl-enable-rte-exception-info? b))


(define (set-verbose-errors! b)
  (set! gl-verbose-errors? b))


(define (set-backtrace! b)
  (set! gl-backtrace? b))


(define (set-pretty-backtrace! b)
  (if (and b (not gl-pretty-backtrace-support?))
      (my-raise1 'pretty-backtrace-not-linked)
      (void))
  (set! gl-pretty-backtrace? b))


(define (set-pretty-backtrace-support! b)
  (set! gl-pretty-backtrace-support? b))


;; *** Command line ***


(define gl-l-command-line '())


(define (theme-set-command-line! l)
  (set! gl-l-command-line l))


(define (theme-command-line)
  gl-l-command-line)


;; *** Auxiliary procedures and variables ***


(dwl "*1*")


(define (eq-pairs? pr1 pr2)
  (and (eq? (car pr1) (car pr2))
       (eq? (cdr pr1) (cdr pr2))))


(define (vector-copy-contents src dest)
  (let ((len1 (vector-length src))
	(len2 (vector-length dest)))
    (dvar1-set! src)
    (dvar2-set! dest)
    (assert (= len1 len2))
    (do ((i 0 (+ i 1))) ((>= i len1))
      (vector-set! dest i (vector-ref src i)))))


(define (vector-copy-contents-rev dest src)
  (vector-copy-contents src dest))


(define (set-cons! dest src)
  (assert (pair? dest))
  (assert (pair? src))
  (set-car! dest (car src))
  (set-mcdr! dest (cdr src)))


(define (pair-contents-eqv? p1 p2)
  (and (eqv? (car p1) (car p2))
       (eqv? (cdr p1) (cdr p2))))


(define equal-types-forward? '())


(define (lists-eqv? l1 l2)
  (and
   (= (length l1) (length l2))
   (and-map? eqv? l1 l2)))


;; NOTE: The following predicates do not handle inheritance.
(define (get-class-predicate cls)
  (lambda (obj)
    (and
     (vector? obj)
     (>= (vector-length obj) 1)
     (eq? (vector-ref obj 0) cls))))


(define (make-list-with-tail elements tl)
  (if (null? elements)
      tl
      (cons (car elements)
	    (make-list-with-tail (cdr elements) tl))))


(define (get-integer-sequence start count)
  (assert (>= count 0))
  (if (= count 0)
      '()
      (cons start (get-integer-sequence (+ start 1) (- count 1)))))


;; *** Association lists ***


(define <alo-fwd> '())


(define is-alo-fwd? '())


(define i-alo-bindings 1)
(define i-alo-eq-pred 2)


(define (make-alo0)
  (vector <alo-fwd> '() equal?))


(define (make-alo bindings eq-pred)
  (assert (list? bindings))
  (assert (procedure? eq-pred))
  (vector <alo-fwd> bindings eq-pred))


(define (alo-fetch alo key)
  (assert (is-alo-fwd? alo))
  (dwl2 "alo-fetch ENTER")
  ;; (assoc key
  ;; 	 (vector-ref alo i-alo-bindings)
  ;; 	 (vector-ref alo i-alo-eq-pred)))
  (let* ((pred (vector-ref alo i-alo-eq-pred))
	 (result
	  (myfind (lambda (mp) (pred (car mp) key))
		  (vector-ref alo i-alo-bindings))))
    (dwl2 "alo-fetch EXIT")
    result))


;; No check for duplicate keys.
(define (alo-add-binding0! alo key value)
  (assert (is-alo-fwd? alo))
  (vector-set! alo i-alo-bindings
	       (cons (cons key value)
		     (vector-ref alo i-alo-bindings))))


;; The following procedure does not allow duplicate keys.
(define (alo-add-binding! alo key value)
  (assert (is-alo-fwd? alo))
  (strong-assert (eq? (alo-fetch alo key) #f))
  (alo-add-binding0! alo key value))


(define (alo-add-binding-weak! alo key value)
  (assert (is-alo-fwd? alo))
  (if1 (eq? (alo-fetch alo key) #f)
       (alo-add-binding0! alo key value)))


(define (alo-exists? alo key)
  (not (eq? (alo-fetch alo key) #f)))


;; *** Parametrized instance cache ***


(define (listq=? l1 l2)
  (and
   (list? l1)
   (list? l2)
   (= (length l1) (length l2))
   (myevery eq? l1 l2)))


(define (listq-hash-value l)
  (let ((sum 0))
    (do ((l1 l (cdr l1))) ((null? l1) sum)
      (set! sum (fx+ sum (eq-hash-code (car l1)))))))

				      
;; (define is-param-cache? hash-table?)


;; (define (make-param-cache)
;;   (make-hash-table 1000))
(define (make-param-cache)
  (make-hashtable listq-hash-value listq=?))


;; (define (param-key-eq? tp1 tp2)
;;   (and (= (length tp1) (length tp2))
;;        (and-map? (lambda (t1 t2) (eq? t1 t2))
;; 		 tp1 tp2)))


;; (define (param-assoc o-key alist)
;;   (assoc o-key alist param-key-eq?))


;; (define (param-hash o-key i-size)
;;   (assert (list? o-key))
;;   (remainder (apply + (map (lambda (o) (hashq o i-size)) o-key))
;; 	     i-size))


(define (param-cache-fetch param-cache param-class type-params)
  ;; (hashx-ref param-hash param-assoc param-cache
  ;; 	     (cons param-class type-params)))
  (hashtable-ref param-cache
		 (cons param-class type-params)
		 #f))


(define param-cache-fetch0 param-cache-fetch)


(define (param-cache-add-binding! param-cache param-class type-params
				  new-instance)
  ;; (hashx-set! param-hash param-assoc param-cache
  ;; 	      (cons param-class type-params)
  ;; 	      new-instance))
  (hashtable-set! param-cache (cons param-class type-params) new-instance))


(define (param-cache-bind-declared! param-cache param-class type-params
				    new-instance)
  ;; (let ((o (hashx-ref param-hash param-assoc param-cache
  ;; 		      (cons param-class type-params))))
  (let ((o (hashtable-ref param-cache
			  (cons param-class type-params)
			  #f)))
    (if (not (eq? o #f))
	(begin
	  (vector-copy-contents-rev o new-instance)
	  o)
	(my-raise 'cached-object-not-found))))


;; *** Basic classes ***


(define is-pair-class-fwd? '())


(define gl-custom-prim-classes '())


;; (define gl-ht-goops-classes (make-hash-table gl-i-ht-goops-classes-size))
(define gl-ht-goops-classes (make-hasheq))


;; (define gl-ht-goops-assoc (make-hash-table gl-i-ht-goops-native-classes-size))
(define gl-ht-goops-assoc (make-hasheq))


(define is-instance-forward? '())


(dwl1 "a1")


(define i-object-class 0)


(define type=? eq?)


(define c-class-fields 15)


(define i-class-superclass 1)
(define i-class-fields 2)
(define i-class-all-fields 3)
(define i-class-inheritable 4)
(define i-class-immutable 5)
(define i-class-eq-by-value 6)
(define i-class-ctr-access 7)
(define i-class-type-constructor 8)
(define i-class-proc-constructor 9)
(define i-class-goops 10)
(define i-class-has-zero 11)
(define i-class-zero-prim 12)
(define i-class-zero-value 13)
(define i-class-module 14)
(define i-class-name 15)


(define (create-class0 name inh? imm? ebv? has-zero? zero-value)
  (let ((obj (make-vector (+ c-class-fields 1) '())))
    (vector-set! obj i-class-inheritable inh?)
    (vector-set! obj i-class-immutable imm?)
    (vector-set! obj i-class-eq-by-value ebv?)
    (vector-set! obj i-class-ctr-access 'public)
    (vector-set! obj i-class-has-zero has-zero?)
    (vector-set! obj i-class-zero-prim #f)
    (vector-set! obj i-class-zero-value zero-value)
    (vector-set! obj i-class-name name)
    obj))


(define _b_<object> (create-class0 "<object>" #t #t #f #f '()))

(define _b_<boolean> (create-class0 "<boolean>" #f #t #t #t #f))

(define _b_<string> (create-class0 "<string>" #f #t #t #t ""))

(define _b_<symbol> (create-class0 "<symbol>" #f #t #t #f '()))

;; Not sure if <logical-type> has to be eq-by-value
(define _b_<logical-type> (create-class0 "<logical-type>" #t #t #t #f '()))

(define _b_<class> (create-class0 "<class>" #t #t #f #f '()))


(vector-set! _b_<boolean> 1 _b_<object>)
(vector-set! _b_<string> 1 _b_<object>)
(vector-set! _b_<symbol> 1 _b_<object>)
(vector-set! _b_<logical-type> 1 _b_<object>)
(vector-set! _b_<class> 1 _b_<object>)

(vector-set! _b_<object> 0 _b_<class>)
(vector-set! _b_<boolean> 0 _b_<class>)
(vector-set! _b_<string> 0 _b_<class>)
(vector-set! _b_<symbol> 0 _b_<class>)
(vector-set! _b_<logical-type> 0 _b_<class>)
(vector-set! _b_<class> 0 #t)


(define (get-zero clas)
  (assert (eq? (vector-ref clas i-object-class) _b_<class>))
  ;; Not sure if strong assert is needed.
  (strong-assert (vector-ref clas i-class-has-zero))
  (vector-ref clas i-class-zero-value))


(define is-object?
  (get-class-predicate _b_<object>))


(define _b_<field> (create-class0 "<field>" #f #t #f #f '()))


(vector-set! _b_<field> 0 _b_<class>)
(vector-set! _b_<field> 1 _b_<object>)


(define is-field?
  (get-class-predicate _b_<field>))


(define c-field-fields 6)


(define i-field-name 1)
(define i-field-type 2)
(define i-field-read-access 3)
(define i-field-write-access 4)
(define i-field-has-init-value 5)
(define i-field-init-value 6)


(define (make-field name type read-access write-access
		    has-init-value? init-value)
  (let ((result (make-vector (+ c-field-fields 1) '())))
    (vector-set! result i-object-class _b_<field>)
    (vector-set! result i-field-name name)
    (vector-set! result i-field-type type)
    (vector-set! result i-field-read-access read-access)
    (vector-set! result i-field-write-access write-access)
    (vector-set! result i-field-has-init-value has-init-value?)
    (vector-set! result i-field-init-value init-value)
    result))


(define (make-readonly-field name clas init-value)
  (make-field name clas 'public 'hidden #t init-value))


(define (make-readonly-field-no-init name clas)
  (make-field name clas 'public 'hidden #f '()))


(define (make-hidden-field name clas init-value)
  (make-field name clas 'hidden 'hidden #t init-value))


(define (make-hidden-field-no-init name clas)
  (make-field name clas 'hidden 'hidden #f '()))


(define (make-public-field-no-init name clas)
  (make-field name clas 'public 'public #f '()))


(define field-fields
  (list (make-readonly-field-no-init 's-name _b_<symbol>)
	(make-readonly-field-no-init 'type _b_<object>)
	(make-readonly-field-no-init 's-read-access _b_<symbol>)
	(make-readonly-field-no-init 's-write-access _b_<symbol>)
	(make-readonly-field-no-init 'has-init-value? _b_<boolean>)
	(make-readonly-field-no-init 'x-init-value _b_<object>)))


(define field-all-fields field-fields)


(vector-set! _b_<field> i-class-fields field-fields)


(vector-set! _b_<field> i-class-all-fields field-all-fields)


(define class-fields
  (list
   (make-readonly-field 'cl-superclass _b_<class> '())
   (make-readonly-field 'l-fields _b_<object> '())
   (make-readonly-field 'l-all-fields _b_<object> '())
   (make-readonly-field 'inheritable? _b_<boolean> #f)
   (make-readonly-field 'immutable? _b_<boolean> #f)
   (make-readonly-field 'eq-by-value? _b_<boolean> #f)
   (make-readonly-field 's-ctr-access _b_<symbol> 'public)
   (make-readonly-field 'type-constructor _b_<object> '())
   (make-readonly-field 'proc-constructor _b_<object> '())
   (make-readonly-field 'goops? _b_<boolean> #f)
   (make-readonly-field 'has-zero? _b_<boolean> #f)
   (make-readonly-field 'zero-prim? _b_<boolean> #f)
   (make-readonly-field 'x-zero-value _b_<object> '())
   (make-readonly-field 'module _b_<object> '())
   (make-readonly-field 'str-name _b_<string> "")))


(define class-all-fields class-fields)
(define c-class-all-fields (length class-all-fields))

(vector-set! _b_<class> i-class-fields class-fields)

(vector-set! _b_<class> i-class-all-fields class-all-fields)


(define _b_none (vector _b_<logical-type>))


(define (create-primitive-class name imm? ebv? has-zero? zero-value)
  (let ((obj (make-vector (+ c-class-fields 1) '())))
    (vector-set! obj i-object-class _b_<class>)
    (vector-set! obj i-class-superclass _b_<object>)
    (vector-set! obj i-class-inheritable #f)
    (vector-set! obj i-class-immutable imm?)
    (vector-set! obj i-class-eq-by-value ebv?)
    (vector-set! obj i-class-ctr-access 'public)
    (vector-set! obj i-class-has-zero has-zero?)
    (vector-set! obj i-class-zero-prim #f)
    (vector-set! obj i-class-zero-value zero-value)
    (vector-set! obj i-class-name name)
    obj))


(define _b_<null> (create-primitive-class "<null>" #t #t #t '()))

(define _b_<character> (create-primitive-class "<character>" #t #t #f '()))

;; (define _b_<complex> (create-primitive-class #t #t))

(define _b_<real> (create-primitive-class "<real>" #t #t #t 0.0))

(define _b_<integer> (create-primitive-class "<integer>" #t #t #t 0))


(dwl1 "a4")


(define (create-class name superclass fields inh? imm? ebv? ctr-access)
  (let ((obj (make-vector (+ c-class-fields 1) '()))
	(all-fields (append (vector-ref superclass i-class-all-fields)
			    fields)))
    (vector-set! obj i-object-class _b_<class>)
    (vector-set! obj i-class-superclass superclass)
    (vector-set! obj i-class-fields fields)
    (vector-set! obj i-class-all-fields all-fields)
    (vector-set! obj i-class-inheritable inh?)
    (vector-set! obj i-class-immutable imm?)
    (vector-set! obj i-class-eq-by-value ebv?)
    (vector-set! obj i-class-ctr-access ctr-access)
    (vector-set! obj i-class-has-zero #f)
    (vector-set! obj i-class-zero-prim #f)
    (vector-set! obj i-class-name name)
    obj))


(define (create-goops-class name superclass inh? imm? ebv?)
  (let ((obj (make-vector (+ c-class-fields 1) '()))
	(all-fields (vector-ref superclass i-class-all-fields)))
    (vector-set! obj i-object-class _b_<class>)
    (vector-set! obj i-class-superclass superclass)
    (vector-set! obj i-class-fields '())
    (vector-set! obj i-class-all-fields all-fields)
    (vector-set! obj i-class-inheritable inh?)
    (vector-set! obj i-class-immutable imm?)
    (vector-set! obj i-class-eq-by-value ebv?)
    (vector-set! obj i-class-ctr-access 'public)
    (vector-set! obj i-class-goops #t)
    (vector-set! obj i-class-has-zero #f)
    (vector-set! obj i-class-zero-prim #f)
    (vector-set! obj i-class-name name)
    obj))


(define _i_make-class create-class)


(define _i_make-class-instance create-class)


(define (make-custom-prim-class name imm? ebv?)
  (create-class name _b_<object> '() #f imm? ebv? 'public))


(define _b_<procedure>
  (create-class "<procedure>" _b_<object> '() #t #t #f 'public))


(define _b_nil '())


(define (is-empty? x)
  (eq? x _b_none))


(define (_i_create-empty-class)
  (make-vector (+ c-class-fields 1) '()))


(define _b_<eof>
  (create-class "<eof>" _b_<object> '() #f #t #t 'public))


(define theme-eof
  (vector _b_<eof>))


(define _b_eof theme-eof)


(define <placeholder>
  (create-class "<placeholder>" _b_<object> '() #f #f #f 'public))

		
(define _b_<exception>
  (create-class "<exception>" _b_<object> '() #t #f #f 'public))


(define file-exception-fields
  (list
   (make-public-field-no-init 'exception-type _b_<symbol>)
   (make-public-field-no-init 'filename _b_<string>)))


(define _b_<file-exception>
  (create-class "<file-exception>" _b_<exception> file-exception-fields
		#t #f #f 'public))


(define (_i_init-class clas name superclass fields inh? imm? ebv? ctr-access)
  (let ((all-fields (append (vector-ref superclass 3) fields)))
    (vector-set! clas i-object-class _b_<class>)
    (vector-set! clas i-class-superclass superclass)
    (vector-set! clas i-class-fields fields)
    (vector-set! clas i-class-all-fields all-fields)
    (vector-set! clas i-class-inheritable inh?)
    (vector-set! clas i-class-immutable imm?)
    (vector-set! clas i-class-eq-by-value ebv?)
    (vector-set! clas i-class-ctr-access ctr-access)
    (vector-set! clas i-class-has-zero #f)
    (vector-set! clas i-class-zero-prim #f)
    (vector-set! clas i-class-name name)))


(define (search-index l-fields key index)
  (dwl "search-index")
  (cond
   ((null? l-fields) -1)
   ((eq? key (vector-ref (car l-fields) i-field-name)) index)
   (else
    (search-index (cdr l-fields) key (+ index 1)))))


(define (_i_field-ref obj field-name)
  (strong-assert (symbol? field-name))
  (let* ((cl (theme-class-of obj))
	 (fields (vector-ref cl i-class-all-fields))
	 (index (search-index fields field-name 0)))
    (if (< index 0)
	(begin
	  (dvar1-set! obj)
	  (dvar2-set! field-name)
	  (dvar3-set! fields)
	  (dvar4-set! index)
	  (my-raise 'ref-to-nonexistent-field))
	(check-field-unspecified
	 (vector-ref obj (+ index 1))
	 field-name))))


(define (_i_field-set! obj field-name field-value)
  (strong-assert (symbol? field-name))
  (let* ((cl (theme-class-of obj))
	 (fields (vector-ref cl i-class-all-fields))
	 (index (search-index fields field-name 0)))
    (if (< index 0)
	(begin
	  (dvar1-set! obj)
	  (dvar2-set! field-name)
	  (dvar3-set! fields)
	  (dvar4-set! index)
	  (my-raise 'setting-nonexistent-field))
	(vector-set! obj (+ index 1) field-value))))


(define _i_make-procedure vector)


(define i-simple-proc-raw-proc 1)


(define _i_make-object vector)


;; *** Internal definitions ***


(define <alo>
  (create-class
   "<alo>"
   _b_<object>
   (list
    (make-hidden-field 'bindings _b_<object> '())
    (make-hidden-field 'eq-pred _b_<object> '()))
   #f #f #f 'public))


(set! <alo-fwd> <alo>)


(define is-alo?
  (get-class-predicate <alo>))


(set! is-alo-fwd? is-alo?)


;; Field address is not used runtime.
(define <tvar-object>
  (create-class
   "<tvar-object>"
   _b_<object>
   (list
    (make-field 'address _b_<object> 'hidden 'hidden #f '())
    (make-field 'i-number _b_<integer> 'public 'hidden #t 0))
   #f #t #t 'public))


(define _b_<type-variable> <tvar-object>)


(define i-tvar-object-number 2)


(define is-tvar-object?
  (get-class-predicate <tvar-object>))


(define (tvar-object=? tvar1 tvar2)
  (assert (is-tvar-object? tvar1))
  (assert (is-tvar-object? tvar2))
  (= (vector-ref tvar1 i-tvar-object-number)
     (vector-ref tvar2 i-tvar-object-number)))


(define (make-tvar-object number)
  (vector <tvar-object> '() number))


(define (get-tvar-object-number tvar)
  (assert (is-tvar-object? tvar))
  (vector-ref tvar i-tvar-object-number))


(define <argument-translator>
  (create-class
   "<argument-translator>"
   _b_<object>
   '()
   #f #t #f 'public))


(define is-argument-translator?
  (get-class-predicate <argument-translator>))


(define (make-argument-translator)
  (vector <argument-translator>))


(define <transformer>
  (create-class
   "<transformer>"
   _b_<object>
   '()
   #f #t #f 'public))


(define is-transformer?
  (get-class-predicate <transformer>))


(define (make-transformer)
  (vector <transformer>))


(define <type-checker>
  (create-class
   "<type-checker>"
   _b_<object>
   (list (make-readonly-field-no-init 'param-cache _b_<object>))
   #f #t #f 'public))


(define is-type-checker?
  (get-class-predicate <type-checker>))


(define (make-type-checker param-cache)
  (vector <type-checker> param-cache))


(define param-cache->type-checker make-type-checker)


(define <tvar-allocator>
  (create-class
   "<tvar-allocator>"
   _b_<object>
   (list
    (make-field 'start _b_<integer> 'public 'public #t -1)
    (make-field 'ranges _b_<object> 'public 'public #t '()))
   #f #f #f 'public))


(define i-tva-start 1)
(define i-tva-ranges 2)


(define (make-tvar-allocator)
  (vector <tvar-allocator> -1 '()))


(define <rte>
  (create-class
   "<rte>"
   _b_<object>
   (list
    (make-field 'param-cache _b_<object> 'public 'public #f '())
    (make-field 'arg-xlat <argument-translator> 'public 'public #f '())
    (make-field 'type-checker <type-checker> 'public 'public #f '())
    (make-field 'tvar-allocator <tvar-allocator> 'public 'public #f '()))
   #f #f #f 'public))


(define i-rte-param-cache 1)
(define i-rte-arg-xlat 2)
(define i-rte-type-checker 3)
(define i-rte-tvar-allocator 4)


(define gl-rte
  (let* ((param-cache (make-param-cache))
	 (arg-xlat (make-argument-translator))
	 (type-checker (make-type-checker param-cache))
	 (tvar-allocator (make-tvar-allocator)))
    (vector <rte>
	    param-cache
	    arg-xlat
	    type-checker
	    tvar-allocator)))


(define <singleton>
  (create-class
   "<singleton>"
   _b_<object>
   (list
    (make-field 'x-element _b_<object> 'public 'public #f '()))
   #f #f #f 'public))


(define i-singleton-element 1)


(define is-singleton?
  (get-class-predicate <singleton>))


(define (make-singleton element)
  (vector <singleton> element))


(define (get-singleton-element sgl)
  (assert (is-singleton? sgl))
  (vector-ref sgl i-singleton-element))


(define (set-singleton-element! sgl value)
  (assert (is-singleton? sgl))
  (vector-set! sgl i-singleton-element value))


(define translator-singleton '())


;; *** Procedures for the type variable allocator ***


(dwl1 "a5")


(define (do-search-range ranges range-size)
  (assert (list? ranges))
  (assert (integer? range-size))
  (if (null? ranges)
      #f
      (let ((prev-result (do-search-range (cdr ranges) range-size)))
	(if (not (eq? prev-result #f))
	    prev-result
	    (let ((cur-start (caar ranges)))
	      (if (null? (cdr ranges))
		  (if (<= range-size cur-start)
		      (cons 0 '())
		      #f)
		  (let* ((prev-start (caadr ranges))
			 (prev-size (cdadr ranges))
			 (past-prev (+ prev-start prev-size)))
		    (if (<= range-size (- cur-start past-prev))
			(cons past-prev (cdr ranges))
			#f))))))))


(define (search-range ranges range-size)
  (assert (list? ranges))
  (assert (integer? range-size))
  (if (null? ranges)
      (cons 0 '())
      (let ((res1 (do-search-range ranges range-size)))
	(if (not (eq? res1 #f))
	    res1
	    (let* ((start (caar ranges))
		   (size (cdar ranges))
		   (past (+ start size)))
	      (cons past ranges))))))


(define (insert-range ranges first-number range-size position)
  (assert (list? ranges))
  (assert (integer? first-number))
  (assert (integer? range-size))
  (assert (list? position))
  (cond
   ((eqv? ranges position)
    (cons (cons first-number range-size) position))
   ((null? ranges)
    (my-raise 'insert-ranges:internal-error))
   (else
    (cons (car ranges)
	  (insert-range (cdr ranges)
			first-number range-size
			position)))))


(define (alloc-range ranges range-size)
  (assert (list? ranges))
  (assert (integer? range-size))
  (let ((alloc-result (search-range ranges range-size)))
    (assert (not (eq? alloc-result #f)))
    (let* ((first-number (car alloc-result))
	   (position (cdr alloc-result))
	   (new-ranges (insert-range ranges first-number range-size position)))
      (cons alloc-result new-ranges))))


(define (dealloc-range-node ranges node)
  (assert (list? ranges))
  (assert (pair? node))
  (let ((cur-range (car ranges)))
    (if (eqv? cur-range node)
	(cdr ranges)
	(cons cur-range
	      (dealloc-range-node (cdr ranges) node)))))


(define (dealloc-range ranges first-number)
  (assert (list? ranges))
  (assert (integer? first-number))
  (let ((position (general-assoc first-number ranges =)))
    (if (eq? position #f)
	(my-raise 'trying-to-dealloc-nonexistent-range)
	(dealloc-range-node ranges position))))


(define (tva-alloc tva range-size)
  (let ((res (alloc-range (vector-ref tva i-tva-ranges) range-size))
	(start (vector-ref tva i-tva-start)))
    (vector-set! tva i-tva-ranges
		 (cdr res))
    (+ (caar res) start)))


(define (tva-dealloc tva first-number)
  (let* ((start (vector-ref tva i-tva-start))
	 (fixed-first-number (- first-number start))
	 (res (dealloc-range (vector-ref tva i-tva-ranges)
			     fixed-first-number)))
    (vector-set! tva i-tva-ranges res)))


;; *** Some procedures related to parametrized types ***


(define this-number
  (tva-alloc (vector-ref gl-rte i-rte-tvar-allocator) 1))


(define _b_this (make-tvar-object this-number))


(define substitute-tvar-objects-forward '())


(define (substitute-field field bindings)
  (if rte-dbg? (dwli "substitute-field ENTER") (void))
  (let* ((name (vector-ref field i-field-name))
	 (type (vector-ref field i-field-type))
	 (read-access (vector-ref field i-field-read-access))
	 (write-access (vector-ref field i-field-write-access))
	 (has-init? (vector-ref field i-field-has-init-value))
	 (init (if has-init? (vector-ref field i-field-init-value) '()))
	 (tmp1 (begin
		 (if rte-dbg? (dwli "substitute-field/1") (void))
		 0))
	 (new-type (substitute-tvar-objects-forward type bindings))
	 (tmp1 (begin
		 (if rte-dbg? (dwli "substitute-field/2") (void))
		 0))
	 (new-init
	  (if has-init?
	      (substitute-tvar-objects-forward init bindings)
	      '()))
	 (tmp1 (begin
		 (if rte-dbg? (dwli "substitute-field/3") (void))
		 0))
	 (result
	  (make-field name new-type read-access write-access
		      has-init? new-init)))
    (if rte-dbg? (dwli "substitute-field EXIT") (void))
    result))


(define (substitute-fields fields bindings)
  (map (lambda (field) (substitute-field field bindings)) fields))


(define (_i_make-param-class-inst0 param-class type-var-values)
  (dwli "_i_make-param-class-inst0 ENTER")
  ;; (prt type-var-values)
  (dvar1-set! param-class)
  (let* ((result (make-vector (+ c-param-class-inst-all-fields 1) '()))
	 (params (vector-ref param-class i-param-class-params))
	 (bindings (map cons params type-var-values))
	 (tmp1 (begin
		 (dwli "_i_make-param-class-inst0/1")
		 0))
	 (superclass
	  (substitute-tvar-objects-forward
	   (vector-ref param-class
		       i-param-class-instance-superclass)
	   bindings))
	 (tmp2 (begin
		 (dwli "_i_make-param-class-inst0/2")
		 0))
	 (fields
	  (substitute-fields
	   (vector-ref param-class
		       i-param-class-instance-fields)
	   bindings))
	 (tmp3 (begin
		 (dwli "_i_make-param-class-inst0/3")
		 0))
	 (superclass-fields
	  (vector-ref superclass i-class-all-fields))
	 (all-fields (append superclass-fields fields)))
    (vector-set! result i-object-class param-class)
    (vector-set! result i-class-superclass superclass)
    (vector-set! result i-class-fields fields)
    (vector-set! result i-class-all-fields all-fields)
    (vector-set! result i-class-inheritable
		 (vector-ref param-class i-param-class-instances-inheritable))
    (vector-set! result i-class-immutable
		 (vector-ref param-class i-param-class-instances-immutable))
    (vector-set! result i-class-eq-by-value
		 (vector-ref param-class i-param-class-instances-eq-by-value))
    (vector-set! result i-class-ctr-access
		 (vector-ref param-class i-param-class-instance-ctr-access))
    (vector-set! result i-class-has-zero
		 (vector-ref param-class i-param-class-instance-has-zero))
    (vector-set! result i-class-zero-prim #f)
    (vector-set! result i-class-name
		 (string-append "("
				(vector-ref param-class i-class-name)
				" ...)"))
    (vector-set! result i-param-class-inst-type-var-values type-var-values)
    (if1 (not (eq? param-class _b_:pair))
	 (let ((proc-ctr (create-constructor result)))
	   (vector-set! result i-class-type-constructor 
			(vector-ref proc-ctr i-object-class))
	   (vector-set! result i-class-proc-constructor proc-ctr)))
    (vector-set! result i-class-has-zero #f)
    (dwli "_i_make-param-class-inst0 EXIT")
    result))


(define (make-pci-preobject param-class type-var-values)
  (let ((result (make-vector (+ c-param-class-inst-all-fields 1) '())))
    (vector-set! result i-object-class param-class)
    (vector-set! result i-class-inheritable
		 (vector-ref param-class i-param-class-instances-inheritable))
    (vector-set! result i-class-immutable
		 (vector-ref param-class i-param-class-instances-immutable))
    (vector-set! result i-class-eq-by-value
		 (vector-ref param-class i-param-class-instances-eq-by-value))
    (vector-set! result i-class-ctr-access
		 (vector-ref param-class i-param-class-instance-ctr-access))
    (vector-set! result i-class-name
		 (string-append "("
				(vector-ref param-class i-class-name)
				" ...)"))
    (vector-set! result i-param-class-inst-type-var-values type-var-values)
    result))


(define (make-pci-preobject2 param-class)
  (let ((result (make-vector (+ c-param-class-inst-all-fields 1) '())))
    (vector-set! result i-object-class param-class)
    result))


(define (_i_get-concrete-param-class-inst0 param-class tvar-values)
  ;; (dwl "_i_get-concrete-param-class-inst0")
  ;; (dw "param. class: ")
  ;; (dwl (vector-ref param-class i-class-name))
  (let* ((rte gl-rte)
	 (param-cache (vector-ref rte i-rte-param-cache))
	 (binding (param-cache-fetch0 param-cache param-class tvar-values)))
    ;; (dwl "_i_get-concrete-param-class-inst0/1")
    (let ((result
	   (if (eq? binding #f)
	       (begin
		 (let ((val
			(_i_make-param-class-inst0 param-class tvar-values)))
		   ;; (dwl "_i_get-concrete-param-class-inst0/2")
		   (param-cache-add-binding! param-cache
					     param-class tvar-values val)
		   ;; (dwl "_i_get-concrete-param-class-inst0/3")
		   val))
	       binding)))
      ;; (dwl "_i_get-concrete-param-class-inst0 EXIT")
      result)))


;; The following procedure does not need the subtype checking procedures
;; so it can be used also when the Theme runtime system is loaded.
(define (_i_get-pair-class0 type1 type2)
  (let* ((rte gl-rte)
	 (param-cache (vector-ref rte i-rte-param-cache))
	 (tvar-values (list type1 type2))
	 (binding (param-cache-fetch0 param-cache _b_:pair tvar-values)))
    (let ((result
	   (if (eq? binding #f)
	       (begin
		 (let ((val
			(_i_make-pair-class-inst type1 type2)))
		   (param-cache-add-binding! param-cache
					     _b_:pair tvar-values val)
		   val))
	       binding)))
      result)))


(define (_i_make-tuple-type . item-types)
  (cond
   ((null? item-types)
    _b_<null>)
   ((pair? item-types)
    (_i_get-pair-class0 (car item-types) (apply _i_make-tuple-type (cdr item-types))))
   (else
    (my-raise 'internal-erroneous-list))))


;; *** Constructors ***



(define (get-field-arg-types fields)
  (dwl2 "get-field-arg-types")
  (assert (list? fields))
  (let ((result '()))
    (do ((cur-lst fields (cdr cur-lst)))
	((null? cur-lst) result)
      (let ((cur-field (car cur-lst)))
	(dvar1-set! cur-field)
	(dwl2 "get-field-arg-types/1")   
	(if1 (not (vector-ref cur-field i-field-has-init-value))
	     (begin
	       (dwl2 "get-field-arg-types/2")   
	       (dvar1-set! cur-field)
	       (let ((type (vector-ref cur-field i-field-type)))
		 (set! result
		       (append result (list type))))))))))


(define (get-constructor-type clas)
  (dwl "get-constructor-type")
  (if (is-pair-class-fwd? clas)
      '()
      (let* ((all-fields (vector-ref clas i-class-all-fields))
	     (field-arg-types (get-field-arg-types all-fields))
	     (arg-list-type (apply _i_make-tuple-type field-arg-types))
	     (proc-type
	      (_i_make-procedure-type
	       arg-list-type
	       clas
	       #t
	       #f
	       #f
	       #f
	       #t)))
	proc-type)))


;; This procedure accepts only primitive values for field init values.
(define (initialize-object raw-object fields init-args)
  (dwl2 "initialize-object")
  (dwl2 (vector-length raw-object))
  (dwl2 (length fields))
  (dwl2 (length init-args))
  ;; i is an index to the field list and j is an index to the
  ;; constructor argument list.
  (let ((j 0))
    (dwl2 "initialize-object/1")
    (do ((i 1 (+ i 1)) (cur-lst fields (cdr cur-lst)))
	((null? cur-lst))
      (dwl2 "initialize-object/2")
      (dvar1-set! (car cur-lst))
      (let* ((cur-field (car cur-lst))
	     (has-init-value? (vector-ref cur-field i-field-has-init-value))
	     (cur-init-value
	      (if has-init-value?
		  (vector-ref cur-field i-field-init-value)
		  '())))
	(dwl2 "initialize-object/3")
	(if has-init-value?
	    (vector-set! raw-object i cur-init-value)
	    (begin
	      (vector-set! raw-object i (list-ref init-args j))
	      (set! j (+ j 1))))))))


(define (get-constructor-impl clas)
  (if (is-pair-class-fwd? clas)
      cons
      (let* ((all-fields (vector-ref clas i-class-all-fields))
	     (field-count (length all-fields)))
	(lambda args
	  (let ((result (make-vector (+ field-count 1) '())))
	    (vector-set! result i-object-class clas)
	    (initialize-object result all-fields args)
	    result)))))


(define (create-constructor clas)
  (let ((proc-type (get-constructor-type clas))
	(proc-impl (get-constructor-impl clas)))
    (_i_make-procedure proc-type proc-impl)))


(define (get-constructor clas)
  (if (is-pair-class-fwd? clas)
      (_i_make-procedure
       (_i_make-procedure-type
	(_i_make-tuple-type
	 (get-pair-first-type clas)
	 (get-pair-second-type clas))
	clas
	#t
	#f
	#f
	#f
	#t)
       cons)
      (begin
	(dvar1-set! clas)
	(vector-ref clas i-class-proc-constructor))))


;; *** Parametrized objects ***


(dwl1 "a5-1")


(define param-class-fields
  (list
   (make-readonly-field 'i-params _b_<integer> 0)
   (make-readonly-field 'l-tvars _b_<object> '())
   (make-readonly-field 'cl-instance-superclass _b_<class> _b_<object>)
   (make-readonly-field 'l-instance-fields _b_<object> '())
   (make-readonly-field 'l-instance-all-fields _b_<object> '())
   (make-readonly-field 'instances-inheritable? _b_<boolean> #t)
   (make-readonly-field 'instances-immutable? _b_<boolean> #f)
   (make-readonly-field 'instances-eq-by-value? _b_<boolean> #f)
   (make-readonly-field 'instance-has-constructor? _b_<boolean> #f)
   (make-readonly-field 's-instance-ctr-access _b_<symbol> 'public)
   (make-readonly-field 'instance-has-zero? _b_<boolean> #f)
   (make-readonly-field 'proc-instance-zero _b_<object> '())))


(define c-param-class-all-fields
  (+ c-class-all-fields (length param-class-fields)))


(define i-param-class-nr-of-params (+ c-class-all-fields 1))
(define i-param-class-params (+ c-class-all-fields 2))
(define i-param-class-instance-superclass (+ c-class-all-fields 3))
(define i-param-class-instance-fields (+ c-class-all-fields 4))
(define i-param-class-instance-all-fields (+ c-class-all-fields 5))
(define i-param-class-instances-inheritable (+ c-class-all-fields 6))
(define i-param-class-instances-immutable (+ c-class-all-fields 7))
(define i-param-class-instances-eq-by-value (+ c-class-all-fields 8))
(define i-param-class-instance-has-constructor (+ c-class-all-fields 9))
(define i-param-class-instance-ctr-access (+ c-class-all-fields 10))
(define i-param-class-instance-has-zero (+ c-class-all-fields 11))
(define i-param-class-instance-zero-proc (+ c-class-all-fields 12))


(define param-class-inst-fields
  (list (make-readonly-field 'l-tvar-values _b_<object> '())
	(make-readonly-field 'l-param-exprs _b_<object> '())))

(define param-class-inst-all-fields
  (append class-all-fields param-class-inst-fields))

(define c-param-class-inst-fields (length param-class-inst-fields))

(define c-param-class-inst-all-fields
  (+ c-class-all-fields c-param-class-inst-fields))

(define i-param-class-inst-type-var-values (+ c-class-all-fields 1))


(define (_i_make-param-class0 name c-params params instance-superclass
			      instance-fields
			      inh? imm? ebv?
			      instance-has-constructor?
			      instance-ctr-access)
  (assert (or (= c-params -1) (= (length params) c-params)))
  (let ((result (make-vector (+ c-param-class-all-fields 1) '())))
    (vector-set! result i-object-class _b_<param-class>)
    (vector-set! result i-class-superclass _b_<class>)
    (vector-set! result i-class-fields param-class-inst-fields)
    (vector-set! result i-class-all-fields param-class-inst-all-fields)
    (vector-set! result i-class-inheritable #f)
    (vector-set! result i-class-immutable #t)
    (vector-set! result i-class-eq-by-value #t)
    (vector-set! result i-class-ctr-access 'public)
    (vector-set! result i-class-has-zero #f)
    (vector-set! result i-class-zero-prim #f)
    (vector-set! result i-class-name name)
    (vector-set! result i-param-class-nr-of-params c-params)
    (vector-set! result i-param-class-params params)
    (vector-set! result i-param-class-instance-superclass instance-superclass)
    (vector-set! result i-param-class-instance-fields instance-fields)
    (vector-set! result i-param-class-instance-all-fields
		 (append (vector-ref instance-superclass i-class-all-fields)
			 instance-fields))
    (vector-set! result i-param-class-instances-inheritable inh?)
    (vector-set! result i-param-class-instances-immutable imm?)
    (vector-set! result i-param-class-instances-eq-by-value ebv?)
    (vector-set! result i-param-class-instance-has-constructor
		 instance-has-constructor?)
    (vector-set! result i-param-class-instance-ctr-access instance-ctr-access)
    (vector-set! result i-param-class-instance-has-zero #f)
    result))


(define i-union-member-types 1)


;; MIETI immutable?
(define _b_<param-class>
  (create-class "<param-class>" _b_<class> param-class-fields #f #f #f 'public))


(define param-logical-type-fields
  ;; The types of the second and third field could be more specific.
  (list
   (make-readonly-field-no-init 'i--params _b_<integer>)
   (make-readonly-field-no-init 'l-tvars _b_<object>)
   (make-readonly-field-no-init 'x-value-expr _b_<object>)))


(define c-param-ltype-fields (length param-logical-type-fields))
(define c-param-ltype-all-fields
  (+ c-class-fields c-param-ltype-fields))

(define i-param-ltype-nr-of-params (+ c-class-fields 1))
(define i-param-ltype-type-variables (+ c-class-fields 2))
(define i-param-ltype-value-expr (+ c-class-fields 3))


(define _b_<param-logical-type>
  (create-class
   "<param-logical-type>"
   _b_<class>
   param-logical-type-fields
   #f
   #f
   #f
   'public))


(define param-proc-class-fields
  (list
   (make-readonly-field 'i-first-number _b_<integer> 0)
   (make-readonly-field 'i-nr-of-tvars _b_<integer> 0)
   (make-readonly-field 'l-tvars _b_<object> '())
   (make-readonly-field 'type-contents _b_<object> '())))

;;(define c-param-proc-class-all-fields
;;  (+ c-class-fields 4))

(define i-ppc-first-number (+ c-class-fields 1))
(define i-ppc-nr-of-tvars (+ c-class-fields 2))
(define i-ppc-tvars (+ c-class-fields 3))
(define i-ppc-inst-type (+ c-class-fields 4))


(define _b_:param-proc
  (create-class
   ":param-proc"
   _b_<class>
   param-proc-class-fields
   #f
   #t
   #t
   'public))


;; This is used only for unions.
(define param-ltype-inst-fields
  ;; The types of the fields could be more specific.
  (list
;;   (make-readonly-field-no-init 'param-ltype _b_<object>)
   (make-readonly-field-no-init 'type-params _b_<object>)
   (make-readonly-field-no-init 'regular? _b_<boolean>)))


(define param-ltype-inst-all-fields param-ltype-inst-fields)


;; - :union inherits from <logical-type> and all other
;;   parametrized logical types from <object>.
;; - Should we create a constructor for the class?
(define (_i_make-param-ltype name tvars value-expr superclass nr-of-params)
  (let ((result (make-vector (+ c-param-ltype-all-fields 1) '())))
    (vector-set! result i-object-class _b_<param-logical-type>)
    ;; Is the following correct?
    (vector-set! result i-class-superclass superclass)
    (vector-set! result i-class-fields param-ltype-inst-fields)
    (vector-set! result i-class-all-fields param-ltype-inst-all-fields)
    ;; Is the following correct?
    (vector-set! result i-class-inheritable #f)
    (vector-set! result i-class-immutable #t)
    (vector-set! result i-class-eq-by-value #t)
    (vector-set! result i-class-ctr-access 'public)
    (vector-set! result i-class-has-zero #f)
    (vector-set! result i-class-zero-prim #f)
    (vector-set! result i-class-name name)
    (vector-set! result i-param-ltype-nr-of-params nr-of-params)
    (vector-set! result i-param-ltype-type-variables tvars)
    (vector-set! result i-param-ltype-value-expr value-expr)
    result))


(dwl1 "a5-1-1")


;; The following procedures is used only for unions.
(define (_i_make-param-ltype-inst plt type-params)
  (vector plt type-params #t))


;; Unions don't have a fixed number of type parameters.
;; That's why we set nr-of-params to -1 here.
;; Unions are not instantiated with the ordinary type variable substitution
;; and we leave value-expr empty.
(define _b_:union
  (_i_make-param-ltype ":union" '() '() _b_<logical-type> -1))


(define (_i_make-concrete-union types)
  ;; (dwl1 "_i_make-concrete-union")
  (_i_make-param-ltype-inst _b_:union types))


(define (is-union? obj)
  (and
   (vector? obj)
   (>= (vector-length obj) 1)
   (eq? (vector-ref obj i-object-class) _b_:union)))


(dwl1 "*1*")


(define _b_<type> (_i_make-concrete-union (list _b_<class> _b_<logical-type>)))


(dwl1 "*2*")


(define pair-first-number
  (tva-alloc (vector-ref gl-rte i-rte-tvar-allocator) 2))


(dwl1 "*2-1*")


(define pair-tvar1 (make-tvar-object pair-first-number))
(define pair-tvar2 (make-tvar-object (+ pair-first-number 1)))


(define pair-tvars
  (list pair-tvar1 pair-tvar2))


(define _b_:pair
  (_i_make-param-class0
   ":pair"
   2
   pair-tvars
   _b_<object>
   (list (make-field 'first pair-tvar1 'public 'hidden #f '())
	 (make-field 'second pair-tvar2 'public 'hidden #f '()))
   #f
   #t
   #t
   #f
   'public))


(define is-pair-class?
  (get-class-predicate _b_:pair))


(set! is-pair-class-fwd? is-pair-class?)


(define (is-type? obj)
  (is-instance-forward? obj _b_<type>))


(define is-normal-object-fwd? '())


(define (get-pair-first-type prc)
  (assert (is-pair-class? prc))
  (car (vector-ref prc i-param-class-inst-type-var-values)))


(define (get-pair-second-type prc)
  (assert (is-pair-class? prc))
  (cadr (vector-ref prc i-param-class-inst-type-var-values)))


;; The following procedure does not use the instance cache.
(define (_i_make-pair-class-inst first-type second-type)
  (dwl2 "_i_make-pair-class-inst ENTER")
  (let* ((result (make-vector (+ c-param-class-inst-all-fields 1) '()))
	 (superclass _b_<object>)
	 (fields
	  (list (make-readonly-field-no-init 'first first-type)
		(make-readonly-field-no-init 'second second-type)))
	 (superclass-fields
	  (vector-ref superclass i-class-all-fields))
	 (all-fields (append superclass-fields fields)))
    (vector-set! result i-object-class _b_:pair)
    (vector-set! result i-class-superclass superclass)
    (vector-set! result i-class-fields fields)
    (vector-set! result i-class-all-fields all-fields)
    (vector-set! result i-class-inheritable
		 (vector-ref _b_:pair i-param-class-instances-inheritable))
    (vector-set! result i-class-immutable
		 (vector-ref _b_:pair i-param-class-instances-immutable))
    (vector-set! result i-class-eq-by-value
		 (vector-ref _b_:pair i-param-class-instances-eq-by-value))
    (vector-set! result i-class-ctr-access 'public)
    (vector-set! result i-class-has-zero #f)
    (vector-set! result i-class-zero-prim #f)
    (vector-set! result i-class-name "(:pair ...)")
    (vector-set! result i-param-class-inst-type-var-values
		 (list first-type second-type))
    (vector-set! result i-class-has-zero #f)
    (dwl2 "_i_make-pair-class-inst EXIT")
    result))


;; A tuple type uses <nil> for the empty list instead of nil.
(define (list->tuple-type lst)
  (dwl "list->tuple-type")
  (dvar1-set! lst)
  (if (null? lst)
      _b_<null>
      (let ((tail (list->tuple-type (cdr lst)))
	    (head (car lst)))
	(_i_get-pair-class0 head tail))))


(define (set-field-desc-type! desc-list field-name new-type)
  (assert (list? desc-list))
  (assert (symbol? field-name))
  ;; Field name is a symbol so it is safe to use eq? here.
  (dwl2 "set-field-desc-type! ENTER")
  (let ((desc (myfind
	       (lambda (field)
		 (eq? (vector-ref field i-field-name) field-name))
	       desc-list)))
    (dwl2 "set-field-desc-type!/1")
    (assert (not (eq? desc #f)))
    (dwl2 "set-field-desc-type!/2")
    (vector-set! desc i-field-type new-type)
    (dwl2 "set-field-desc-type! EXIT")
    (void)))


(dwl1 "*3*")


;; Maybe we should give type variables and value-expr for :uniform-list.
(define _b_:uniform-list
  (_i_make-param-ltype ":uniform-list" '() '() _b_<object> 1))


;; Procedure _i_make-uniform-list0 should only be used
;; when the Theme runtime environment is loaded.
(define (_i_make-uniform-list0 type)
  (dwl "_i_make-uniform-list0")
  (dvar1-set! type)
  ;; (debug-pause)
  ;; We must not cache t-pair as it is mutated later.
  (let* ((t-pair (_i_make-pair-class-inst type _b_<object>))
	 (tmp1 (begin (dwl "_i_make-uniform-list0/1") 0))
	 (t-list (_i_make-concrete-union (list t-pair _b_<null>)))
	 (tmp2 (begin (dwl "_i_make-uniform-list0/2") 0)))
    (begin
      (dwl "_i_make-uniform-list0/1")
      (vector-set! t-pair i-param-class-inst-type-var-values (list type t-list))
      (dwl "_i_make-uniform-list0/3")
      ;; Updating "fields" updates also "all-fields".
      (set-field-desc-type! (vector-ref t-pair i-class-fields) 'second t-list)
      (dwl "_i_make-uniform-list0/4")
      t-list)))


(define (_i_make-concrete-uniform-list type)
  (dwl "_i_make-concrete-uniform-list")
  ;; We must not cache t-pair as it is mutated later.
  (let* ((t-pair (_i_make-param-class-inst0 _b_:pair (list type _b_<object>)))
	 (t-list (_i_make-concrete-union (list t-pair _b_<null>))))
    (begin
      (dwl "_i_make-concrete-uniform-list/1")
      (vector-set! t-pair i-param-class-inst-type-var-values (list type t-list))
      (dwl "_i_make-concrete-uniform-list/2")
      ;; Updating "fields" updates also "all-fields".
      (set-field-desc-type! (vector-ref t-pair i-class-fields) 'second t-list)
      (dwl "_i_make-concrete-uniform-list/3")
      t-list)))


(define (_i_make-concrete-uniform-list-test type)
  (dwl "_i_make-concrete-uniform-list-test")
  ;; We must not cache t-pair as it is mutated later.
  (let* ((t-pair (_i_make-param-class-inst0 _b_:pair (list type _b_<object>)))
	 (t-list (_i_make-concrete-union (list t-pair _b_<null>))))
    (begin
      (dwl "_i_make-concrete-uniform-list-test/1")
      (prt t-pair)
      (prt t-list)
      (vector-set! t-pair i-param-class-inst-type-var-values (list type t-list))
      t-pair)))


(define (is-concrete-uniform-list? type)
  (and
   (is-union? type)
   (let ((mt (vector-ref type i-union-member-types)))
     (and
      (= (length mt) 2)
      (eq? (cadr mt) _b_<null>)
      (is-pair-class? (car mt))
      (let ((mt2 (vector-ref (car mt)
			     i-param-class-inst-type-var-values)))
	(and
	 (is-type? (car mt2))
	 (eq? (cadr mt2) type)))))))


(define (_i_make-abstract-uniform-list type)
  (dwl "_i_make-abstract-uniform-list")
  (let ((t-pair (_i_get-abstract-param-class-inst
		 _b_:pair (list type _b_<object>))))
    (assert (is-apci? t-pair))
    (dwl "_i_make-abstract-uniform-list/1")
    (let ((t-list (_i_make-abstract-union (list t-pair _b_<null>))))
      (dwl "_i_make-abstract-uniform-list/2")
      (vector-set! t-pair i-apci-tvar-values (list type t-list))
      (dwl "_i_make-abstract-uniform-list EXIT")
      t-list)))


(dwl1 "*4*")


(define (is-abstract-uniform-list? type)
  (and
   (is-union? type)
   (let ((mt (vector-ref type i-union-member-types)))
     (and
      (= (length mt) 2)
      (eq? (cadr mt) _b_<null>)
      (is-apci? (car mt))
      (let ((mt2 (vector-ref (car mt)
			     i-apci-tvar-values)))
	(and
	 (is-type? (car mt2))
	 (eq? (cadr mt2) type)))))))


(define (_i_make-uniform-list type)
  (dwl "_i_make-uniform-list")
  ;; Uniform list has only one type parameter
  ;; so we probably don't have to care about type operations.
  ;; (if (is-instance-forward? type _b_<type>)
  ;;     (_i_make-concrete-uniform-list type)
  ;;     (_i_make-abstract-uniform-list type)))
  (_i_make-concrete-uniform-list type))


(define (get-uniform-list-element-type ul)
  (assert (is-concrete-uniform-list? ul))
  (let* ((mt (vector-ref ul i-union-member-types))
	 (mt2 (vector-ref (car mt)
			  i-param-class-inst-type-var-values))
	 (element (car mt2)))
    element))


(dwl1 "a5-1-2")

(define <object-list>
  (_i_make-uniform-list0 _b_<object>))

(dwl1 "a5-1-3")

(define <field-list>
  (_i_make-uniform-list0 _b_<field>))

(dwl1 "a5-1-4")

(define <type-list>
  (_i_make-uniform-list0 _b_<type>))

(define <gen-type> (_i_make-concrete-union (list _b_<type> <tvar-object>)))

(define <gen-type-list> (_i_make-uniform-list0 <gen-type>))

(define <module-name> (_i_make-uniform-list0 _b_<symbol>))

(define <tvar-object-list> (_i_make-uniform-list0 <tvar-object>))

(define <maybe-type> (_i_make-concrete-union (list _b_<type> _b_<null>)))

(define <maybe-procedure>
  (_i_make-concrete-union (list _b_<procedure> _b_<null>)))

(define <maybe-symbol>
  (_i_make-concrete-union (list _b_<symbol> _b_<null>)))


(dwl1 "a5-1-5")


(set-field-desc-type! class-fields 'l-fields <field-list>)
(set-field-desc-type! class-fields 'l-all-fields <field-list>)
(set-field-desc-type! class-fields 'module <module-name>)
(set-field-desc-type! class-fields 'type-constructor <maybe-type>)
(set-field-desc-type! class-fields 'proc-constructor <maybe-procedure>)
(set-field-desc-type! param-class-fields 'l-tvars <tvar-object-list>)
(set-field-desc-type! param-class-fields 'cl-instance-superclass <gen-type>)
(set-field-desc-type! param-class-fields 'l-instance-fields <field-list>)
(set-field-desc-type! param-class-fields 'l-instance-all-fields <field-list>)
(set-field-desc-type! param-class-fields 'proc-instance-zero <maybe-procedure>)
(set-field-desc-type! param-logical-type-fields 'l-tvars
		      <tvar-object-list>)
(set-field-desc-type! param-logical-type-fields 'x-value-expr <gen-type>)
(set-field-desc-type! param-proc-class-fields 'l-tvars <tvar-object-list>)
(set-field-desc-type! param-proc-class-fields 'type-contents <gen-type>)
;; Could we use <type-list> instead of <gen-type-list>?
(set-field-desc-type! param-class-inst-fields 'l-tvar-values <gen-type-list>)


(dwl1 "a5-1-6")


(define (_i_make-tuple-type-with-tail tuple1 ul1)
  (dwl "_i_make-tuple-type-with-tail")
  ;; (prt tuple1)
  ;; (dwl "_i_make-tuple-type-with-tail/1")
  ;; (prt ul1)
  ;; (dwl "_i_make-tuple-type-with-tail/2")
  ;; Testing for null is probably unnecessary.
  (if (or (null? tuple1) (type=? tuple1 _b_<null>))
      ul1
      (let* ((tvv (vector-ref tuple1 i-param-class-inst-type-var-values))
	     (head (car tvv))
	     (tail (cadr tvv)))
	(_i_get-pair-class0 head
			    (_i_make-tuple-type-with-tail
			     tail ul1)))))


(define (is-tuple-type0? typ visited)
  (dwl "is-tuple-type0? ENTER")
  (let ((result
	 (cond
	  ((null? typ) #f)
	  ((eq? typ _b_<null>) #t)
	  ((mymemq typ visited) #t)
	  ((and (is-pair-class? typ)
		(is-tuple-type0?
		 (cadr (vector-ref typ i-param-class-inst-type-var-values))
		 (cons typ visited)))
	   #t)
	  (else #f))))
    (dwl "is-tuple-type0? EXIT")
    result))


(define (is-tuple-type? typ)
  (is-tuple-type0? typ '()))


(define (is-tuple-type-with-tail? typ)
  (cond
   ((null? typ) #f)
   ((eq? typ _b_<null>) #f)
   ((is-concrete-uniform-list? typ) #t)
   ((and (is-pair-class? typ)
	 (is-tuple-type-with-tail?
	  (cadr (vector-ref typ i-param-class-inst-type-var-values))))
    #t)
   (else #f)))


(define (tuple-type-length typ)
  (cond
   ((null? typ) (my-raise 'invalid-tuple-type))
   ((eq? typ _b_<null>) 0)
   ((is-pair-class? typ)
    (+ (tuple-type-length
	(cadr
	 (vector-ref typ i-param-class-inst-type-var-values))) 1))
   (else (my-raise 'invalid-tuple-type))))


(define (tuple-part-length typ)
  (cond
   ((null? typ) (my-raise 'invalid-tuple-type))
   ((eq? typ _b_<null>) 0)
   ((is-concrete-uniform-list? typ) 0)
   ((is-pair-class? typ)
    (+ (tuple-part-length
	(cadr
	 (vector-ref typ i-param-class-inst-type-var-values))) 1))
   (else (my-raise 'invalid-tuple-type))))


(define (tuple-type->list-reject-cycles0 tuple-type visited)
  (cond
   ((null? tuple-type)
    (my-raise 'corrupted-tuple-type1))
   ((eq? tuple-type _b_<null>) '())
   ((mymemq tuple-type visited)
    (my-raise 'illegal-tuple-type-cycle))
   ((is-pair-class? tuple-type)
    (let* ((params (vector-ref tuple-type i-param-class-inst-type-var-values))
	   (first-type (car params))
	   (second-type (cadr params)))
      (cons first-type
	    (tuple-type->list-reject-cycles0 second-type
					     (cons tuple-type visited)))))
   (else
    (my-raise 'corrupted-tuple-type2))))


(define (tuple-type->list-reject-cycles tuple-type)
  (tuple-type->list-reject-cycles0 tuple-type '()))


(define _i_get-pair-class-fwd '())


(define (get-tuple-type-fixed-part tuple-type)
  (cond
   ((null? tuple-type)
    (my-raise 'tuple-type-fixed-part:invalid-argument))
   ((eq? tuple-type _b_<null>) '())
   ((is-concrete-uniform-list? tuple-type) '())
   ((is-pair-class? tuple-type)
    (cons
     (get-pair-first-type tuple-type)
     (get-tuple-type-fixed-part
      (get-pair-second-type tuple-type))))
   (else
    (my-raise 'get-tuple-type-fixed-part:invalid-argument))))


(define (get-tuple-type-tail-part tuple-type)
  (cond
   ((is-concrete-uniform-list? tuple-type) tuple-type)
   ((null? tuple-type) (my-raise 'tuple-type-tail-part:invalid-argument))
   ((eq? tuple-type _b_<null>) (my-raise 'tuple-type-tail-part:invalid-argument))
   ((is-pair-class? tuple-type)
    (get-tuple-type-tail-part (get-pair-second-type tuple-type)))
   (else
    (my-raise 'get-tuple-type-tail-part:invalid-argument))))


(dwl1 "a5-2")


(define procedure-class-fields
  (list 
   (make-readonly-field 'type-arglist _b_<object> '())
   (make-readonly-field 'type-result _b_<object> '())
   (make-readonly-field 'pure-proc? _b_<boolean> #f)
   (make-readonly-field 'appl-always-returns? _b_<boolean> #f)
   (make-readonly-field 'appl-never-returns? _b_<boolean> #f)
   (make-readonly-field 'static-method? _b_<boolean> #f)))


(define i-procedure-class-arg-list-type (+ c-class-all-fields 1))
(define i-procedure-class-result-type (+ c-class-all-fields 2))
(define i-procedure-class-pure-proc (+ c-class-all-fields 3))
(define i-procedure-class-appl-always-returns (+ c-class-all-fields 4))
(define i-procedure-class-appl-never-returns (+ c-class-all-fields 5))
(define i-procedure-class-static-method (+ c-class-all-fields 6))


(define _b_:simple-proc
  (create-class ":simple-proc" _b_<class> procedure-class-fields #f #t #t 'public))


(dwl1 "a5-2-1")


(dwl1 "a5-2-2")


(define _b_:procedure
  (create-class ":procedure" _b_<class> procedure-class-fields #f #t #t 'public))


(define c-procedure-class-all-fields
  (+ c-class-fields (length procedure-class-fields)))


;; Note that the contents of the following field is not a Theme object.
(define procedure-class-inst-fields
  (list (make-hidden-field 'proc _b_<object> '())))


(define (_i_make-procedure-type arg-list-type result-type
				pure-proc?
				appl-always-returns?
				appl-never-returns?
				static-method?
				simple?)
  (dwl "_i_make-procedure-type")
  (let ((result (make-vector (+ c-procedure-class-all-fields 1) '()))
	(clas (if simple? _b_:simple-proc _b_:procedure)))
    (vector-set! result i-object-class clas)
    (vector-set! result i-class-superclass _b_<procedure>)
    (vector-set! result i-class-fields procedure-class-inst-fields)
    ;; Superclass _b_<procedure> does not have any fields.
    (vector-set! result i-class-all-fields procedure-class-inst-fields)
    (vector-set! result i-class-inheritable #f)
    (vector-set! result i-class-immutable #t)
    (vector-set! result i-class-eq-by-value #f)
    (vector-set! result i-class-ctr-access 'public)
    (vector-set! result i-class-has-zero #f)
    (vector-set! result i-class-zero-prim #f)
    (vector-set! result i-class-name
		 (if simple? "(:simple-proc ...)" "(:procedure ...)"))
    (vector-set! result i-procedure-class-arg-list-type arg-list-type)
    (vector-set! result i-procedure-class-result-type result-type)
    (vector-set! result i-procedure-class-pure-proc pure-proc?)
    (vector-set! result i-procedure-class-appl-always-returns
		 appl-always-returns?)
    (vector-set! result i-procedure-class-appl-never-returns
		 appl-never-returns?)
    (vector-set! result i-procedure-class-static-method static-method?)
    (dwl "_i_make-procedure-type EXIT")
    result))


(define (_i_make-simple-proc-class0 arg-list-type result-type
				    pure-proc?
				    appl-always-returns?
				    appl-never-returns?
				    static-method?)
  (_i_make-procedure-type arg-list-type result-type
			  pure-proc? appl-always-returns? appl-never-returns?
			  static-method? #t))


(define (_i_make-simple-proc-class arg-list-type result-type
				   pure-proc?)
  (_i_make-procedure-type arg-list-type result-type
			  pure-proc? #f #f #f #t))


(define (get-zero-arg-types n)
  (if (<= n 0)
      '()
      (cons _b_<type> (get-zero-arg-types (- n 1)))))


(define (handle-param-zero inst param-class type-var-values)
  (let ((has-zero?
	 (vector-ref param-class i-param-class-instance-has-zero)))
    (vector-set! inst i-class-has-zero has-zero?)
    ;; Should we check the contents of type parameters, too?
    (if1 (and has-zero? (not (or-map? is-tvar-object? type-var-values)))
	 (let* ((zero-proc
		 (vector-ref param-class i-param-class-instance-zero-proc))
		(zero-arg-types (get-zero-arg-types (length type-var-values)))
		;; (tmp1
		;; 	(begin (dvar1-set! param-class)
		;; 	       (dvar2-set! type-var-values)
		;; 	       (dvar3-set! zero-proc)
		;; 	       (dvar4-set! result)
		;; 	       (my-raise 'z-stop) 0))
		(zero-value
		 (apply (vector-ref zero-proc i-param-proc-raw-proc)
			type-var-values)))
	   ;;	       (zero-value (_i_call-proc zero-proc type-var-values zero-arg-types)))
	   (vector-set! inst i-class-zero-value zero-value)))))


(define (_i_make-param-class-inst param-class type-var-values)
  (if rte-dbg?
      (begin
	(dwli "_i_make-param-class-inst ENTER")
	(prti param-class)
	(dwli (list? type-var-values))
	(dwli (length type-var-values))
	(prti (car type-var-values))
	(with-handlers (((lambda (exc) #t)
			 (lambda (exc)
			   (display exc)
			   (newline)
			   (display (theme-d-condition-kind exc))
			   (newline)
			   (raise exc))))
		       (prti type-var-values)))
      (void))
  (dvar1-set! param-class)
  (let* ((result (_i_make-param-class-inst0 param-class type-var-values))
	 (has-zero?
	  (vector-ref param-class i-param-class-instance-has-zero)))
    (vector-set! result i-class-has-zero has-zero?)
    (if rte-dbg? (dwli "_i_make-param-class-inst/1") (void))
    (handle-param-zero result param-class type-var-values)
    (if rte-dbg? (dwli "_i_make-param-class-inst EXIT") (void))
    result))


(define i-gen-proc-name 1)
(define i-gen-proc-methods 2)


(define gen-proc-fields
  (list
   (make-readonly-field 'str-name _b_<string> '())
   (make-readonly-field 'l-methods
			(_i_make-uniform-list0 (_i_make-pair-class-inst
						_b_<procedure> _b_<boolean>))
			'())))


(dwl1 "a5-4")


;; Should _b_:gen-proc be a parametrized class at all?
(define _b_:gen-proc
  (_i_make-param-class0
   ":gen-proc"
   -1
   '()
   _b_<object>
   gen-proc-fields
   ;; Not sure about the following three values.
   #f #f #f #f 'public))


(dwl1 "a5-5")


(define (make-gen-proc-class method-classes)
  (_i_make-param-class-inst _b_:gen-proc method-classes))


(define (make-gen-proc clas name methods)
  (vector
   clas
   name
   methods))


(define (make-empty-gen-proc name)
  (let* ((clas (make-gen-proc-class '()))
	 (gen-proc (make-gen-proc clas name '())))
    gen-proc))


(define (_i_add-method! gen-proc method static?)
  (let* ((method-class (vector-ref method i-object-class))
	 (old-gen-proc-class (vector-ref gen-proc i-object-class))
	 (old-method-classes (vector-ref old-gen-proc-class
					 i-param-class-inst-type-var-values))
	 (new-method-classes
	  (cons method-class old-method-classes))
	 (new-gen-proc-class (make-gen-proc-class new-method-classes))
	 (old-methods (vector-ref gen-proc i-gen-proc-methods))
	 (new-methods (cons (cons method static?) old-methods)))
    (vector-set! gen-proc i-object-class new-gen-proc-class)
    (vector-set! gen-proc i-gen-proc-methods new-methods)))


(dwl1 "a6")


(define vector-first-number
  (tva-alloc (vector-ref gl-rte i-rte-tvar-allocator) 1))


(define vector-tvar (make-tvar-object vector-first-number))


(define vector-tvars
  (list vector-tvar))


(define _b_:vector
  (_i_make-param-class0
   ":vector" 1
   vector-tvars
   _b_<object>
   '()
   #f #t #f #f 'public))


(define mutable-vector-first-number
  (tva-alloc (vector-ref gl-rte i-rte-tvar-allocator) 1))


(define mutable-vector-tvar
  (make-tvar-object mutable-vector-first-number))


(define mutable-vector-tvars
  (list mutable-vector-tvar))


(define _b_:mutable-vector
  (_i_make-param-class0
   ":mutable-vector" 1
   mutable-vector-tvars
   _b_<object>
   '()
   #f #f #f #f 'public))


(define value-vector-first-number
  (tva-alloc (vector-ref gl-rte i-rte-tvar-allocator) 1))


(define value-vector-tvar (make-tvar-object value-vector-first-number))


(define value-vector-tvars
  (list value-vector-tvar))


(define _b_:value-vector
  (_i_make-param-class0
   ":value-vector" 1
   value-vector-tvars
   _b_<object>
   '()
   #f #t #t #f 'public))


(define mutable-value-vector-first-number
  (tva-alloc (vector-ref gl-rte i-rte-tvar-allocator) 1))


(define mutable-value-vector-tvar
  (make-tvar-object mutable-value-vector-first-number))


(define mutable-value-vector-tvars
  (list mutable-value-vector-tvar))


(define _b_:mutable-value-vector
  (_i_make-param-class0
   ":mutable-value-vector" 1
   mutable-value-vector-tvars
   _b_<object>
   '()
   #f #f #t #f 'public))


(define param-proc-class-all-fields
  (append class-all-fields param-proc-class-fields))


(define c-param-proc-class-all-fields
  (length param-proc-class-all-fields))


(define param-proc-fields
  (list
   ;; We don't use <procedure> here because proc is not a Theme procedure.
   (make-hidden-field-no-init 'proc _b_<object>)
   (make-readonly-field-no-init 's-name <maybe-symbol>)))


(define (_i_make-param-proc-class first-number nr-of-tvars tvars inst-type)
  (let ((result (make-vector (+ c-param-proc-class-all-fields 1) '())))
    (vector-set! result i-object-class _b_:param-proc)
    (vector-set! result i-class-superclass _b_<procedure>)
    (vector-set! result i-class-fields param-proc-fields)
    (vector-set! result i-class-all-fields param-proc-fields)
    (vector-set! result i-class-inheritable #f)
    (vector-set! result i-class-immutable #t)
    (vector-set! result i-class-eq-by-value #f)
    (vector-set! result i-class-ctr-access 'public)
    (vector-set! result i-class-has-zero #f)
    (vector-set! result i-class-zero-prim #f)
    (vector-set! result i-class-name "instance of <param-proc-class>")
    (vector-set! result i-ppc-first-number first-number)
    (vector-set! result i-ppc-nr-of-tvars nr-of-tvars)
    (vector-set! result i-ppc-tvars tvars)
    (vector-set! result i-ppc-inst-type inst-type)
    result))


(define c-param-proc-all-fields 2)


(define i-param-proc-raw-proc 1)
(define i-param-proc-name 2)


(define (_i_make-param-proc ppc proc name)
  (let ((result (make-vector (+ c-param-proc-all-fields 1) '())))
    (vector-set! result i-object-class ppc)
    (vector-set! result i-param-proc-raw-proc proc)
    (vector-set! result i-param-proc-name name)
    result))


(define (_i_construct-vector type-element)
  (_i_make-param-class-inst _b_:vector (list type-element)))


(define (_i_construct-mutable-vector type-element)
  (_i_make-param-class-inst _b_:mutable-vector (list type-element)))


(define (_i_construct-value-vector type-element)
  (_i_make-param-class-inst _b_:value-vector (list type-element)))


(define (_i_construct-mutable-value-vector type-element)
  (_i_make-param-class-inst _b_:mutable-value-vector (list type-element)))


(define (get-vector-element-type vec-type)
  (car (vector-ref vec-type i-param-class-inst-type-var-values)))


;; *** Types ***


(define i-prim-desc-equal 2)
(define i-prim-desc-equal-objects 3)
(define i-prim-desc-equal-contents 4)

(define i-goops-class-desc-equal 1)
(define i-goops-class-desc-equal-contents 2)


(define (notify-custom-prim-class
	 clas
	 member-pred
	 equal-pred
	 equal-objects-pred
	 equal-contents-pred)
  (set! gl-custom-prim-classes
	(cons
	 (list clas member-pred
	       equal-pred equal-objects-pred equal-contents-pred)
	 gl-custom-prim-classes)))


(define (notify-goops-class
	 clas
	 goops-class
	 equal-pred
	 equal-contents-pred)
  (hash-set! gl-ht-goops-classes clas
	     (list goops-class equal-pred equal-contents-pred))
  (hash-set! gl-ht-goops-assoc goops-class clas))


(define (check-custom-class-membership obj descs)
  (cond
   ((null? descs) '())
   ;; Custom primitive class predicates are always simple procedures.
   (((cadr (car descs)) obj)
    (car (car descs)))
   (else
    (check-custom-class-membership obj (cdr descs)))))


;; Perhaps we could raise an exception if goops-class is <top> here.
;; (define (search-goops-class goops-class)
;;   (if (eq? goops-class <top>)
;;       _b_<object>
;;       (let ((a (hashq-ref gl-ht-goops-assoc goops-class #f)))
;; 	(if (not (eq? a #f))
;; 	    a
;; 	    (search-goops-class (car (class-direct-supers goops-class)))))))


(define (theme-class-of0 x)
  (cond
   ((eq? x _b_<class>) _b_<class>)
   ((vector? x)
    (if (>= (vector-length x) 1)
	(vector-ref x i-object-class)
	(my-raise 'corrupted-vector)))
   ((symbol? x) _b_<symbol>)
   ((boolean? x) _b_<boolean>)
   ((is-real? x) _b_<real>)
   ((is-integer? x) _b_<integer>)
   ((number? x) #f)
   ((string? x) _b_<string>)
   ((char? x) _b_<character>)
   ((null? x) _b_<null>)
   ((pair? x)
    (_i_get-pair-class0 (theme-class-of (car x)) (theme-class-of (cdr x))))
   ((mpair? x)
    (_i_get-pair-class0 (theme-class-of (mcar x)) (theme-class-of (mcdr x))))
   ((placeholder? x) <placeholder>)
   ;; Predicate struct? has to be called with guile 2.2.
   ;; It is not mandatory in guile 2.0.
;;   ((and (struct? x) (instance? x))
    ;; It is essential to use class-of instead of theme-class-of here.
;;    (search-goops-class (class-of x)))
   (else
    (let ((custom-class
	   (check-custom-class-membership x gl-custom-prim-classes)))
      (if (not-null? custom-class)
	  custom-class
	  #f)))))


(define (theme-class-of x)
  (let ((tc-result (theme-class-of0 x)))
    (if tc-result
	tc-result
	(begin
	  (display x)
	  (newline)
	  (my-raise 'unknown-item-type)))))


;; (set! theme-class-of-fwd theme-class-of)


(define (is-valid-theme-d-object? x)
  (if (theme-class-of0 x) #t #f))


(define (is-union-type? typ)
  (type=? (theme-class-of typ) _b_:union))


;; (define (is-pair-class? cl)
;;  (type=? (theme-class-of cl) _b_:pair))


(define (is-abstract-proc-type? tp)
  (type=? (theme-class-of tp) _b_:procedure))


(define (is-simple-proc-class? tp)
  (type=? (theme-class-of tp) _b_:simple-proc))


(define (is-simple-proc? obj)
  (is-simple-proc-class? (theme-class-of obj)))


(define (is-param-proc-class? tp)
  (type=? (theme-class-of tp) _b_:param-proc))


(define (is-general-proc-type? tp)
  (or (is-abstract-proc-type? tp)
      (is-simple-proc-class? tp)))


(define (is-gen-proc-class? tp)
  (type=? (theme-class-of tp) _b_:gen-proc))


;; NOTE:
;; <integer> and <real> are separate
;; _b_<complex> has been removed
(define (is-atomic-class? type)
  (if (mymemq type (list _b_<null>
			 _b_<boolean> _b_<real> _b_<integer>
			 _b_<character> _b_<symbol> _b_<string>
			 _b_<eof>))
      #t #f))


(define (is-primitive-class? type)
  (if (mymemq type (list _b_<null>
			 _b_<boolean> _b_<real> _b_<integer>
			 _b_<character> _b_<symbol> _b_<string>
			 _b_<eof>))
      #t #f))


(define (get-custom-prim-class-desc cl)
  (myfind (lambda (prim) (eq? cl (car prim))) gl-custom-prim-classes))


;;(define (get-goops-class-desc cl)
;;  (hashq-ref gl-ht-goops-classes cl #f))


(define (is-custom-prim-class? type)
  (if (get-custom-prim-class-desc type) #t #f))


(define (is-primitive-object? obj)
  (is-primitive-class? (theme-class-of obj)))


(define (is-vector-class? type)
  (type=? (theme-class-of type) _b_:vector))


(define (is-value-vector-class? type)
  (type=? (theme-class-of type) _b_:value-vector))


(define (is-param-class? clas)
  (type=? (theme-class-of clas) _b_<param-class>))


(define (is-param-class-instance? type)
  (is-param-class? (theme-class-of type)))


(define (is-apci? type)
  ;; It is safe to use eq? here.
  (eq? (theme-class-of type) <abstract-param-class-inst>))


(define (is-aplti? type)
  ;; It is safe to use eq? here.
  (eq? (theme-class-of type) <abstract-param-ltype-inst>))


(define (is-simple-proc-type? type)
  (let ((theme-class-of-type (vector-ref type i-object-class)))
    (cond
     ((eq? theme-class-of-type _b_:simple-proc)
      #t)
     ((eq? theme-class-of-type _b_:procedure)
      #f)
     (else
      (my-raise 'internal:invalid-procedure-type)))))


;; *** Parametrized object instantiation ***


(define abstract-param-class-inst-fields
  (list
   (make-hidden-field-no-init 'param-class _b_<type>)
   (make-hidden-field-no-init 'tvar-values <type-list>)))


(define c-apci-fields 2)


(define i-apci-param-class 1)
(define i-apci-tvar-values 2)


(define <abstract-param-class-inst>
  (create-class
   "<abstract-param-class-inst>"
   _b_<object>
   abstract-param-class-inst-fields
   #f
   #t
   ;; Not sure about eq-by-value?.
   #t
   'public))


(define abstract-param-ltype-inst-fields
  (list
   (make-hidden-field-no-init 'param-ltype _b_<type>)
   (make-hidden-field-no-init 'tvar-values <type-list>)))


(define c-aplti-fields 2)


(define i-aplti-param-ltype 1)
(define i-aplti-tvar-values 2)


(define <abstract-param-ltype-inst>
  (create-class
   "<abstract-param-ltype-inst>"
   _b_<object>
   abstract-param-ltype-inst-fields
   #f
   #t
   ;; Not sure about eq-by-value?.
   #t
   'public))


(define (_i_get-abstract-param-class-inst param-class tvar-values)
  (dwl "_i_get-abstract-param-class-inst")
  ;;  (assert (not-null? param-class))
  ;;  (assert (not-null? (vector-ref param-class i-object-class)))
  (vector
   <abstract-param-class-inst>
   param-class
   tvar-values))


(define (_i_get-abstract-param-ltype-inst param-ltype tvar-values)
  (dwl "_i_get-abstract-param-ltype-inst")
  (vector
   <abstract-param-ltype-inst>
   param-ltype
   tvar-values))


(define (_i_make-abstract-union args)
  (_i_get-abstract-param-ltype-inst _b_:union args))


(define (_i_get-concrete-param-class-inst param-class tvar-values)
  (dwl2 "_i_get-concrete-param-class-inst")
  (let* ((rte gl-rte)
	 (param-cache (vector-ref rte i-rte-param-cache))
	 (binding (param-cache-fetch param-cache param-class tvar-values)))
    (dwl2 "_i_get-concrete-param-class-inst/1")

    ;;TBR
;;    (if (= dbg-counter 25)
;;	(debug-pause))

    (let ((result
	   (if (eq? binding #f)
	       (let ((preobj (make-pci-preobject param-class tvar-values)))
		 (param-cache-add-binding! param-cache param-class tvar-values preobj)		 
		 (dwl2 "_i_get-concrete-param-class-inst/2")
		 (let* ((val (_i_make-param-class-inst0 param-class
							tvar-values))
			(new-val (param-cache-bind-declared!
				  param-cache param-class tvar-values val)))

		   (dwl2 "_i_get-concrete-param-class-inst/4")
		   (handle-param-zero new-val param-class tvar-values)

		   ;; TO BE REMOVED
		   ;; (if (and
		   ;; 	(string=? (vector-ref param-class i-class-name) ":my-complex")
		   ;; 	(not (is-tvar-object? (car tvar-values)))
		   ;; 	(string=? (vector-ref (car tvar-values) i-class-name) "<real>"))
		   ;;     (begin
		   ;; 	 (dvar1-set! val)
		   ;; 	 (my-raise 'c-stop)))

		   new-val))
	       binding)))
      (dwl2 "_i_get-concrete-param-class-inst EXIT")
      result)))


(define contains-tvar-objects-fwd? '())


(define (_i_get-param-class-inst param-class arglist)
  (dwl "_i_get-param-class-inst ENTER")
  (dvar1-set! param-class)
  (dvar2-set! arglist)
  (let* ((arg-xlat (vector-ref gl-rte i-rte-arg-xlat))
	 (actual-arglist (construct-toplevel-type-repr arg-xlat arglist)))
    ;; We could also check that a concrete instance is not created
    ;; with type variables. (?)
    ;; Should we use actual-arglist for abstract instances, too?
    (let ((result
	   ;; If the class of param-class is null we have an incomplete
	   ;; object as a parametrized class.
	   (if (and (not-null? (vector-ref param-class i-object-class))
		    (not (unspecified? (vector-ref param-class i-object-class)))
		    (is-tuple-type? actual-arglist))
	       (let ((tvar-values (tuple-type->list-reject-cycles actual-arglist)))
		 (_i_get-concrete-param-class-inst param-class tvar-values))
	       (_i_get-abstract-param-class-inst param-class arglist))))
      (dwl "_i_get-param-class-inst EXIT")
      result)))


(define (_i_get-pair-class type1 type2)
  (dwl "_i_get-pair-class ENTER")
  (let ((result
	 (_i_get-param-class-inst _b_:pair (list type1 type2))))
    (dwl "_i_get-pair-class EXIT")
    result))


(set! _i_get-pair-class-fwd _i_get-pair-class)


;; (define (is-incomplete-pci? pci)
;;   (and (is-param-class-instance? pci)
;;        (null? (vector-ref pci i-param-class-inst-type-var-values))))


(define (_i_get-pair-class-general args)
  (dwl2 "_i_get-pair-class-general ENTER")
  (let ((result (_i_make-pair-class-inst (car args) (cadr args))))
    (dwl2 "_i_get-pair-class-general EXIT")
    result))
;;  (_i_get-param-class-inst _b_:pair args))


(define (_i_get-concrete-param-ltype-inst param-ltype tvar-values)
  (dwl "_i_get-concrete-param-ltype-inst ENTER")
  (let* ((rte gl-rte)
	 (param-cache (vector-ref rte i-rte-param-cache))
	 (binding (param-cache-fetch param-cache param-ltype tvar-values))
	 (result
	  (if (eq? binding #f)
	      (begin
		(dwl "_i_get-concrete-param-ltype-inst/1")
		(let ((preobj (make-singleton '())))
		  (param-cache-add-binding! param-cache param-ltype tvar-values preobj)
		  (let* ((tvars (vector-ref param-ltype i-param-ltype-type-variables))
			 (bindings (map cons tvars tvar-values))
			 (val (substitute-tvar-objects-forward
			       (vector-ref param-ltype i-param-ltype-value-expr)
			       bindings)))
		    (dwl "_i_get-concrete-param-ltype-inst/2")
		    (set-singleton-element! preobj val)
		    (dwl "_i_get-concrete-param-ltype-inst/3")
		    val)))
	      (begin
		(dwl "_i_get-concrete-param-ltype-inst/4")
		binding))))
    (dwl "_i_get-concrete-param-ltype-inst EXIT")
    result))


(define (_i_get-param-ltype-inst param-ltype arglist)
  (dwl "_i_get-param-ltype-inst ENTER")
  (dw "param. ltype: ")
  (dwl (vector-ref param-ltype i-class-name))
  (let* ((arg-xlat (vector-ref gl-rte i-rte-arg-xlat))
	 (tmp1 (begin (dwl "_i_get-param-ltype-inst/1") 0))
	 (actual-arglist (construct-toplevel-type-repr arg-xlat arglist))
	 (tmp2 (begin (dwl "_i_get-param-ltype-inst/2") 0))
	 ;; We could also check that a concrete instance is not created
	 ;; with type variables.
	 (result
	  (if (is-tuple-type? actual-arglist)
	      (let ((tvar-values (tuple-type->list-reject-cycles actual-arglist)))
		(if (eq? param-ltype _b_:union)
		    (_i_make-concrete-union tvar-values)
		    (if (not-null? (vector-ref param-ltype i-param-ltype-value-expr))
			(_i_get-concrete-param-ltype-inst param-ltype tvar-values)
			(_i_get-abstract-param-ltype-inst param-ltype tvar-values))))
	      (if (eq? param-ltype _b_:union)
		  (_i_make-abstract-union arglist)
		  (_i_get-abstract-param-ltype-inst param-ltype arglist)))))
    (dwl "_i_get-param-ltype-inst EXIT")
    result))


(define (_i_make-union args)
  (_i_get-param-ltype-inst _b_:union args))


(define (_i_get-param-class-inst1 param-class tvar-values)
  (substitute-tvar-objects (_i_get-param-class-inst param-class tvar-values)
			   '()))


(define (_i_get-param-ltype-inst1 param-ltype tvar-values)
  (substitute-tvar-objects (_i_get-param-ltype-inst param-ltype tvar-values)
			   '()))


(define (_i_get-pair-class-general1 args)

  ;; TBR
  ;; (dwl2 "_i_get-pair-class-general1")
  ;; (set! gl-ctr1 (+ gl-ctr1 1))
  ;; (dwl2 gl-ctr1)
  ;; (if (= gl-ctr1 292)
  ;;     (begin
  ;; 	(dvar1-set! args)
  ;; 	(my-raise 'stop292)))

  (substitute-tvar-objects (_i_get-pair-class-general args) '()))


(define (_i_get-union1 args)
  (substitute-tvar-objects (_i_make-union args) '()))


;; *** Data types for argument lists ***


(define i-type-list-subexprs 1)


(define _b_<type-list>
  (create-class
   "<type-list>"
   _b_<object>
   (list (make-readonly-field 'l-subexprs <type-list> '()))
   #f #t #f 'public))


(define (_i_make-type-list . subexprs)
  (dwl "_i_make-type-list")
  (let ((result (make-vector 2 '())))
    (vector-set! result i-object-class _b_<type-list>)
    (vector-set! result i-type-list-subexprs subexprs)
    (dwl "_i_make-type-list EXIT")
    result))


(define (create-type-list args)
  (let* ((arg-xlat (vector-ref gl-rte i-rte-arg-xlat))
	 (args2 (construct-toplevel-type-repr arg-xlat args)))
    (if (is-tuple-type? args2)
	(let ((arglist (tuple-type->list-reject-cycles args2)))
	  (apply _i_make-tuple-type arglist))
	;; Perhaps we could use args2 instead of args here.
	(apply _i_make-type-list args))))

(define is-type-list? (get-class-predicate _b_<type-list>))


(define i-rest-component 1)


(define _b_<rest>
  (create-class
   "<rest>"
   _b_<object>
   (list (make-readonly-field 'type-component _b_<type> '()))
   #f #t #f 'public))


(define (_i_make-rest-expression component-type)
  (let ((result (make-vector 2 '())))
    (vector-set! result i-object-class _b_<rest>)
    (vector-set! result i-rest-component component-type)
    result))


(define is-rest-expression? (get-class-predicate _b_<rest>))


(define i-splice-component 1)


(define _b_<splice>
  (create-class
   "<splice>"
   _b_<object>
   (list (make-readonly-field 'type-component _b_<type> '()))
   #f #t #f 'public))


(define (_i_make-splice-expression component-type)
  ;; We could test that component-type is a type list expression here.
  (let ((result (make-vector 2 '())))
    (vector-set! result i-object-class _b_<splice>)
    (vector-set! result i-splice-component component-type)
    result))


(define is-splice-expression? (get-class-predicate _b_<splice>))


(define c-join-all-fields 1)

(define i-join-subexprs 1)


(define _b_<type-join>
  (create-class
   "<type-join>"
   _b_<object>
   (list (make-readonly-field 'l-subexprs <type-list> '()))
   #f #t #f 'public))


(define (_i_make-type-join . subexprs)
  (dwl "_i_make-type-join")
  (let ((result (make-vector (+ c-join-all-fields 1) '())))
    (vector-set! result i-object-class _b_<type-join>)
    (vector-set! result i-join-subexprs subexprs)
    (dwl "_i_make-type-join EXIT")
    result))


(define is-join-expression? (get-class-predicate _b_<type-join>))


(define i-type-loop-iter-var 1)
(define i-type-loop-subtype-list 2)
(define i-type-loop-iter-expr 3)

(define c-type-loop-fields 3)


(define _b_<type-loop>
  (create-class
   "<type-loop>"
   _b_<object>
   (list
    (make-readonly-field-no-init 'tvar <tvar-object>)
    (make-readonly-field-no-init 'x-subtypes _b_<object>)
    (make-readonly-field-no-init 'x-iter-expr _b_<object>))
   #f #t #f 'public))


(define (_i_make-type-loop iter-var subtype-list iter-expr)
  (let ((result (make-vector (+ c-type-loop-fields 1) '())))
    (vector-set! result i-object-class _b_<type-loop>)
    (vector-set! result i-type-loop-iter-var iter-var)
    (vector-set! result i-type-loop-subtype-list subtype-list)
    (vector-set! result i-type-loop-iter-expr iter-expr)
    result))


(define is-type-loop? (get-class-predicate _b_<type-loop>))


;; *** Translating procedure call argument types ***


(define (translate-type-list-arg arg-desc arg-values)
  (assert (eq? (vector-ref arg-desc i-object-class)
	       _b_<type-list>))
  (assert (list? arg-values))
  (if (>= (length arg-values) 1)
      (cons (list (car arg-values)) (cdr arg-values))
      (my-raise 'out-of-call-arguments)))


(define (translate-simple-type-arg arg-desc arg-values)
  (dwl "translate-simple-type-arg")
  (dvar3-set! arg-desc)
  (assert (is-instance-forward? arg-desc _b_<type>))
  (assert (list? arg-values))
  (cons (list (car arg-values)) (cdr arg-values)))


(define (translate-rest-arg arg-desc arg-values)
  (assert (eq? (vector-ref arg-desc i-object-class) _b_<rest>))
  (assert (list? arg-values))
  (cons (list arg-values) '()))


;; The component type of a splice argument specifier has to be a type list
;; or a type loop.
;; Each subexpression of the type list has to be a simple type argument
;; specifier. (?)
;; If the component type is a type loop and its subtype list is not a list
;; (e.g. it is a type variable) we use all of the available source arguments
;; for the loop.
(define (translate-splice-arg arg-desc arg-values)
  (assert (eq? (vector-ref arg-desc i-object-class) _b_<splice>))
  (assert (list? arg-values))
  (let ((component-type
	 (vector-ref arg-desc i-splice-component)))
    (dvar1-set! component-type)
    (let ((count
	   (if (is-instance-forward? component-type
				     _b_<type-loop>)
	       (let* ((subtype-list (vector-ref component-type
						i-type-loop-subtype-list)))
		 (cond
		  ((is-instance-forward? subtype-list
					 _b_<type-list>)
		   (length (vector-ref subtype-list
				       i-type-list-subexprs)))
		  ((is-tuple-type? subtype-list)
		   (length (tuple-type->list-reject-cycles subtype-list)))
		  (else -1)))
	       (cond
		((is-instance-forward? component-type
				       _b_<type-list>)
		 (length (vector-ref component-type
				     i-type-list-subexprs)))
		((is-tuple-type? component-type)
		 (length (tuple-type->list-reject-cycles component-type)))
		(else
		 (my-raise 'invalid-splice-component-type))))))
      (cond
       ((= count -1)
	;; What will happen later if the length of the subtype list
	;; is not equal to the length of arg-values?
	(cons (list arg-values) '()))
       ((>= (length arg-values) count)
	(cons
	 (list (my-take arg-values count))
	 (my-drop arg-values count)))
       (else
	(dvar1-set! arg-desc)
	(dvar2-set! arg-values)
	(my-raise 'splice-out-of-arguments))))))


(define (translate-type-join-arg arg-desc arg-values)
  (assert (eq? (vector-ref arg-desc i-object-class)
	       _b_<type-join>))
  (assert (list? arg-values))
  (if (>= (length arg-values) 1)
      (cons (list (car arg-values)) (cdr arg-values))
      (my-raise 'out-of-call-arguments)))


(define (translate-type-loop-arg arg-desc arg-values)
  (assert (eq? (vector-ref arg-desc i-object-class)
	       _b_<type-loop>))
  (assert (list? arg-values))
  (if (>= (length arg-values) 1)
      (cons (list (car arg-values)) (cdr arg-values))
      (my-raise 'out-of-call-arguments)))


(define (translate-call-argument arg-desc arg-values)
  (dwl2 "translate-call-argument")
  (assert (list? arg-values))
  (dvar1-set! arg-desc)
  (let ((cl (vector-ref arg-desc i-object-class)))
    (cond
     ((eq? cl _b_<type-list>)
      (translate-type-list-arg arg-desc arg-values))
     ((eq? cl _b_<rest>)
      (translate-rest-arg arg-desc arg-values))
     ((eq? cl _b_<splice>)
      (translate-splice-arg arg-desc arg-values))
     ((eq? cl _b_<type-join>)
      (translate-type-join-arg arg-desc arg-values))
     ((eq? cl _b_<type-loop>)
      (translate-type-loop-arg arg-desc arg-values))
     (else
      (translate-simple-type-arg arg-desc arg-values)))))


(define (translate-call-arguments arg-descs arg-values)
  (assert (list? arg-descs))
  (assert (list? arg-values))
  (dwl2 "translate-call-arguments ENTER")
  ;; (debug-prt arg-descs)
  ;; (debug-prt arg-values)
  (dwl2 "translate-call-arguments/1")
  (cond
   ((and (null? arg-descs) (not-null? arg-values))
    (my-raise 'invalid-arguments))
   (else
    (let* ((cur-values arg-values)
	   (result '())
	   (res2
	    (do ((cur-descs arg-descs (cdr cur-descs)))
		((null? cur-descs) result)
	      (let* ((translated-arg (translate-call-argument
				      (car cur-descs)
				      cur-values))
		     (arg-result (car translated-arg))
		     (new-values (cdr translated-arg)))
		(set! result (append result arg-result))
		(set! cur-values new-values)))))
      (dwl2 "translate-call-arguments EXIT")
      res2))))


;; *** Constructing argument list types ***


(define construct-type-list-repr-fwd '())
(define construct-rest-repr-fwd '())
(define construct-splice-repr-fwd '())
(define construct-type-loop-repr-fwd '())
(define construct-type-join-repr-fwd '())


(define (do-bind-loop arg-xlat tvars iter-var subexprs iter-expr)
  (assert (is-argument-translator? arg-xlat))
  (assert (list? tvars))
  (assert (is-tvar-object? iter-var))
  (assert (list? subexprs))
  (let ((result
	 (if (null? subexprs)
	     '()
	     (let* ((cur-type (car subexprs))
		    (new-tvars
		     (cons
		      (cons iter-var cur-type)
		      tvars))
		    (bound-type
		     (substitute-tvar-objects iter-expr new-tvars)))
	       (cons bound-type
		     (do-bind-loop arg-xlat tvars iter-var (cdr subexprs)
				   iter-expr))))))
    result))


(define (construct-type-repr argument-translator type)
  (assert (is-argument-translator? argument-translator))
  (cond
   ((is-type-list? type)
    (construct-type-list-repr-fwd argument-translator type))
   ((is-type-loop? type)
    (construct-type-loop-repr-fwd argument-translator type))
   ((is-join-expression? type)
    (construct-type-join-repr-fwd argument-translator type))
   ((is-rest-expression? type)
    (my-raise 'invalid-use-of-rest-expr))
   ((is-splice-expression? type)
    (my-raise 'invalid-use-of-splice-expr))
   (else
    type)))


(define (compute-tuple-type-with-tail tuple-type tail-part)
  (if (or (null? tuple-type)
	  (eq? tuple-type _b_<null>))
      tail-part
      (let* ((old-tail (get-pair-second-type tuple-type))
	     (new-tail (compute-tuple-type-with-tail old-tail tail-part))
	     (tuple-head (get-pair-first-type tuple-type)))
	(if (eqv? new-tail old-tail)
	    tuple-type
	    (_i_get-pair-class0 tuple-head new-tail)))))


(define (join-two-tuple-types t1 t2)
  (assert (is-tuple-type? t1))
  (assert (is-tuple-type? t2))
  (cond
   ;; Empty tuple type is <null>, not null.
   ((null? t1)
    (my-raise 'invalid-tuple-type))
   ((eq? t1 _b_<null>) t2)
   (else
    (let* ((old-tail (get-pair-second-type t1))
	   (new-tail (join-two-tuple-types old-tail t2))
	   (tuple-head (get-pair-first-type t1)))
      (if (eq? new-tail old-tail)
	  t1
	  ;; Using _i_get-pair-class or _i_get-pair-class1 here
	  ;; could cause an infinite loop with
	  ;; do-construct-type-list-repr.
	  (_i_get-pair-class0 tuple-head new-tail))))))


(define (join-tuple-types . tuple-types)
  (dwl "join-tuple-types")
  (if (null? tuple-types)
      _b_<null>
      (join-two-tuple-types (car tuple-types)
			    (apply join-tuple-types (cdr tuple-types)))))


(define (construct-normal-type-list-repr lst)
  (dwl "construct-normal-type-list-repr")
  (strong-assert (not (or-map? is-rest-expression? lst)))
  ;; Checking is-type-list? is not needed if we trust that
  ;; type lists are properly simplified before calling this
  ;; procedure.
  (if (and-map? (lambda (item)
		  (not (and
			(is-splice-expression? item)
			(not
			 (is-tuple-type?
			  (vector-ref item i-splice-component))))))
		lst)
      (begin
	(dwl "construct-normal-type-list-repr/1")
	(let ((result
	       (apply
		_i_make-tuple-type
		(apply
		 append
		 (map (lambda (item)
			(if (is-splice-expression? item)
			    (let ((component
				   (vector-ref item i-splice-component)))
			      ;; The next test should not fail because
			      ;; of the and-map? test.
			      (if (is-tuple-type? component)
				  (tuple-type->list-reject-cycles
				   component)
				  (my-raise 'corrupted-splice)))
			    (list item)))
		      lst)))))
	  (dwl "construct-normal-type-list-repr EXIT 1")
	  result))
      (let ((result (_i_make-type-list lst)))
	(dwl "construct-normal-type-list-repr EXIT 2")
	result)))


(define (do-construct-type-list-repr argument-translator types)
  (dwl "do-construct-type-list-repr ENTER")
  (assert (is-argument-translator? argument-translator))
  (assert (list? types))
  (let ((result
	 (cond
	  ((null? types) _b_<null>)
	  ((and (is-rest-expression? (mylast types))
		(> (length types) 1))
	   (let ((tuple-types (my-drop-right types 1))
		 (tail-type
		  (vector-ref (mylast types) i-rest-component)))
	     (compute-tuple-type-with-tail
	      (construct-normal-type-list-repr tuple-types)
	      (_i_make-uniform-list tail-type))))
	  ((is-rest-expression? (mylast types))
	   (_i_make-uniform-list (vector-ref (mylast types) i-rest-component)))
	  (else (construct-normal-type-list-repr types)))))
    (dwl "do-construct-type-list-repr EXIT")
    result))


(define (construct-type-list-repr argument-translator type)
  (assert (is-argument-translator? argument-translator))
  (assert (is-type-list? type))
  (let ((subexprs (vector-ref type i-type-list-subexprs)))
    (do-construct-type-list-repr argument-translator subexprs)))


(set! construct-type-list-repr-fwd construct-type-list-repr)


(define construct-argument-type-repr-fwd '())


(define (construct-type-loop-repr1 argument-translator iter-var subtypes iter-expr)
  (assert (is-argument-translator? argument-translator))
  (let* ((subtype-list
	  (if (or (list? subtypes)
		  (is-tuple-type? subtypes))
	      subtypes
	      (construct-argument-type-repr-fwd argument-translator
						subtypes)))
	 (iter-expr1 (substitute-tvar-objects iter-expr '())))
    (let ((result
	   (if (is-tvar-object? subtype-list)
	       (_i_make-type-loop iter-var subtypes iter-expr1)
	       (let* ((subexprs
		       (cond
			((list? subtype-list) subtype-list)
			((is-type-list? subtype-list)
			 (vector-ref subtype-list i-type-list-subexprs))
			((is-tuple-type? subtype-list)
			 (tuple-type->list-reject-cycles subtype-list))
			(else
			 (my-raise 'invalid-type-loop))))
		      (result-types
		       (do-bind-loop
			argument-translator
			'()
			iter-var
			subexprs
			iter-expr1)))
		 (apply _i_make-tuple-type result-types)))))
      result)))


(define (construct-type-loop-repr argument-translator type)
  (assert (is-argument-translator? argument-translator))
  (assert (is-type-loop? type))
  (let ((iter-var
	 (vector-ref type i-type-loop-iter-var))
	(subtypes (vector-ref type i-type-loop-subtype-list))
	(iter-expr
	 (vector-ref type i-type-loop-iter-expr)))
    (construct-type-loop-repr1 argument-translator iter-var subtypes iter-expr)))


(set! construct-type-loop-repr-fwd construct-type-loop-repr)


(define (construct-type-join-repr argument-translator type)
  (assert (is-argument-translator? argument-translator))
  (assert (is-join-expression? type))
  (let ((subexprs (vector-ref type i-join-subexprs)))
    (if (or (is-tvar-object? subexprs)
	    (and
	     (is-splice-expression? (car subexprs))
	     (is-tvar-object? 
	      (vector-ref (car subexprs) i-splice-component))))
	(list->tuple-type (list type))
	(let ((subexprs1 (map
			  (lambda (cur-expr)
			    (construct-type-repr argument-translator cur-expr))
			  subexprs)))
	  (if (and-map? is-tuple-type? subexprs1)
	      (let* ((subexprs2 (apply join-tuple-types subexprs1))
		     (subexprs3 (tuple-type->list-reject-cycles subexprs2)))
		(strong-assert (and-map? is-tuple-type? subexprs3))
		(let ((result
		       (list->tuple-type
			(list
			 (apply join-tuple-types subexprs3)))))
		  result))
	      (list->tuple-type (list type)))))))


(set! construct-type-join-repr-fwd construct-type-join-repr)


(define construct-toplevel-type-repr do-construct-type-list-repr)


(define (construct-argument-type-repr argument-translator type)
  (cond
   ((is-splice-expression? type)
    (vector-ref type i-splice-component))
   ((is-rest-expression? type)
    (vector-ref type i-rest-component))
   (else type)))


(set! construct-argument-type-repr-fwd construct-argument-type-repr)


;; *** Expression cloning and substitution ***


;; Should we have the procedure itself as one component?


(define (get-components-singleton obj)
  (list (get-singleton-element obj)))


(define (get-components-spc obj)
  (list (vector-ref obj i-procedure-class-arg-list-type)
	(vector-ref obj i-procedure-class-result-type)))


(define (get-components-apt obj)
  (list (vector-ref obj i-procedure-class-arg-list-type)
	(vector-ref obj i-procedure-class-result-type)))


(define (get-components-ppc obj)
  (append
   (vector-ref obj i-ppc-tvars)
   (get-components (vector-ref obj i-ppc-inst-type))))


(define (get-components-param-class-inst obj)
  (assert (is-param-class-instance? obj))
  (cons
   (vector-ref obj i-object-class)
   (vector-ref obj i-param-class-inst-type-var-values)))


(define (get-components-union obj)
  (assert (is-union-type? obj))
  (vector-ref obj i-union-member-types))


(define (get-components-apci obj)
  (assert (is-apci? obj))
  (cons (vector-ref obj i-apci-param-class)
	(vector-ref obj i-apci-tvar-values)))


(define (get-components-aplti obj)
  (assert (is-aplti? obj))
  (cons (vector-ref obj i-aplti-param-ltype)
	(vector-ref obj i-aplti-tvar-values)))


(define (get-components obj)
  (cond
   ((unspecified? (vector-ref obj 0)) '())
   ((is-singleton? obj)
    (get-components-singleton obj))
   ((is-type-list? obj)
    (vector-ref obj i-type-list-subexprs))
   ((is-rest-expression? obj)
    (list (vector-ref obj i-rest-component)))
   ((is-type-loop? obj)
    (list
     (vector-ref obj i-type-loop-subtype-list)
     (vector-ref obj i-type-loop-iter-expr)))
   ((is-splice-expression? obj)
    (list (vector-ref obj i-splice-component)))
   ((is-join-expression? obj)
    (vector-ref obj i-join-subexprs))
   ((is-simple-proc-class? obj)
    (get-components-spc obj))
   ((is-param-proc-class? obj)
    (get-components-ppc obj))
   ((is-abstract-proc-type? obj)
    (get-components-apt obj))
   ((is-param-class-instance? obj)
    (get-components-param-class-inst obj))
   ((is-union-type? obj)
    (get-components-union obj))
   ((is-apci? obj)
    (get-components-apci obj))
   ((is-aplti? obj)
    (get-components-aplti obj))
   (else '())))


(define (contains-tvar-objects0? obj visited)
  (dwl "contains-tvar-objects0?")
  (let ((result
	 (cond
	  ((memv obj visited) #f)
	  ((is-tvar-object? obj) #t)
	  ((null? obj) #f)
	  ((pair? obj)
	   (let ((new-visited (cons obj visited)))
	     (or (contains-tvar-objects0? (car obj) new-visited)
		 (contains-tvar-objects0? (cdr obj) new-visited))))
	  (else
	   (let ((components (get-components obj)))
	     (if (null? components)
		 #f
		 (let ((new-visited (cons obj visited)))
		   (or-map?
		    (lambda (component)
		      (contains-tvar-objects0? component
					       new-visited))
		    components))))))))
    (dwl "contains-tvar-objects0? EXIT")
    result))


(define (contains-tvar-objects? obj)
  (contains-tvar-objects0? obj '()))


(set! contains-tvar-objects-fwd? contains-tvar-objects?)


;; Here "unbound tvar" means the same as "bound tvar" in the translator.
(define (contains-unbound-tvars0? obj visited tvars)
  (dwl "contains-unbound-tvars0?")
  (let ((result
	 (cond
	  ((memv obj visited) #f)
	  ((is-tvar-object? obj)
	   (not (general-member obj tvars tvar-object=?)))
	  ((null? obj) #f)
	  ((pair? obj)
	   (let ((new-visited (cons obj visited)))
	     (or (contains-unbound-tvars0? (car obj) new-visited tvars)
		 (contains-unbound-tvars0? (cdr obj) new-visited tvars))))
	  ((is-param-proc-class? obj)
	   (let ((new-tvars (append tvars (vector-ref obj i-ppc-tvars)))
		 (new-visited (cons obj visited)))
	     (contains-unbound-tvars0? (vector-ref obj i-ppc-inst-type)
				       new-visited new-tvars)))
	  ((is-type-loop? obj)
	   (let ((new-tvars (append tvars
				    (list (vector-ref
					   obj i-type-loop-iter-var))))
		 (new-visited (cons obj visited))
		 (subtype-list (vector-ref obj i-type-loop-subtype-list))
		 (iter-expr (vector-ref obj i-type-loop-iter-expr)))
	     (or (contains-unbound-tvars0? subtype-list new-visited new-tvars)
		 (contains-unbound-tvars0? iter-expr new-visited new-tvars))))
	  (else
	   (let ((components (get-components obj)))
	     (if (null? components)
		 #f
		 (let ((new-visited (cons obj visited)))
		   (or-map?
		    (lambda (component)
		      (contains-unbound-tvars0? component
						new-visited tvars))
		    components))))))))
    (dwl "contains-unbound-tvars0? EXIT")
    result))


(define (contains-unbound-tvars? obj)
  (contains-unbound-tvars0? obj '() '()))


(define (contains-specified-tvar-objects0? obj tvars visited)
  (dwl "contains-tvar-objects0?")
  (let ((result
	 (cond
	  ((memv obj visited) #f)
	  ((is-tvar-object? obj)
	   (if (general-assoc obj tvars tvar-object=?)
	       #t
	       #f))
	  ((null? obj) #f)
	  ((pair? obj)
	   (let ((new-visited (cons obj visited)))
	     (or (contains-specified-tvar-objects0?
		  (car obj) tvars new-visited)
		 (contains-specified-tvar-objects0?
		  (cdr obj) tvars new-visited))))
	  (else
	   (let ((components (get-components obj)))
	     (if (null? components)
		 #f
		 (let ((new-visited (cons obj visited)))
		   (or-map?
		    (lambda (component)
		      (contains-specified-tvar-objects0? component
							 tvars
							 new-visited))
		    components))))))))
    (dwl "contains-tvar-objects0? EXIT")
    result))


(define (contains-specified-tvar-objects? obj tvars)
  (contains-specified-tvar-objects0? obj tvars '()))


(define (component-equal? obj1 obj2)
  (if (is-tvar-object? obj1)
      (if (is-tvar-object? obj2)
	  (tvar-object=? obj1 obj2)
	  #f)
      (eqv? obj1 obj2)))


(define (component-lists-equal? lst1 lst2)
  (and (= (length lst1) (length lst2))
       (or (null? lst1)
	   (and-map? component-equal? lst1 lst2))))


(define (clone-singleton transformer obj new-components)
  (assert (is-transformer? transformer))
  (assert (is-singleton? obj))
  (assert (and (list? new-components) (= (length new-components) 1)))
  (let ((old-element (get-singleton-element obj))
	(new-element (car new-components)))
    (if (not (eqv? old-element new-element))
	(make-singleton new-element)
	obj)))


(define (clone-type-list transformer obj new-components)
  (assert (is-transformer? transformer))
  (let ((old-components (get-components obj)))
    (if (not (component-lists-equal? new-components old-components))
	(create-type-list new-components)
	obj)))


(define (clone-rest transformer obj new-components)
  (assert (is-transformer? transformer))
  (let ((old-components (get-components obj)))
    (assert (= (length new-components) 1))
    (if (not (component-lists-equal? new-components old-components))
	(_i_make-rest-expression (car new-components))
	obj)))


(define (clone-type-loop transformer obj new-components)
  (assert (is-transformer? transformer))
  (assert (is-type-loop? obj))
  (let ((new-subtype-list (car new-components))
	(new-iter-expr (cadr new-components))
	(old-subtype-list (vector-ref obj i-type-loop-subtype-list))
	(old-iter-expr (vector-ref obj i-type-loop-iter-expr)))
    (if (or (not (eq? new-subtype-list old-subtype-list))
	    (not (eq? new-iter-expr old-iter-expr)))
	(let ((arg-xlat (vector-ref gl-rte i-rte-arg-xlat))
	      (iter-var (vector-ref obj i-type-loop-iter-var)))
	  (construct-type-loop-repr
	   arg-xlat
	   (_i_make-type-loop iter-var new-subtype-list new-iter-expr)))
	obj)))


(define (clone-splice transformer obj new-components)
  (assert (is-transformer? transformer))
  (let ((old-components (get-components obj)))
    (assert (= (length old-components) 1))
    (assert (= (length new-components) 1))
    (if (not (eq? (car new-components) (car old-components)))
	(_i_make-splice-expression (car new-components))
	obj)))


;; We simplify the expression even though no component has changed.
(define (clone-join transformer obj new-components)
  (assert (is-transformer? transformer))
  (if (and-map?
       (lambda (item) (or (list? item) (is-type-list? obj)))
       new-components)
      (apply _i_make-type-list
	     (apply append
		    (map (lambda (item2)
			   (if (list? item2)
			       item2
			       (vector-ref item2 i-type-list-subexprs)))
			 new-components)))
      (let ((old-components (get-components obj)))
	(if (component-lists-equal? new-components old-components)
	    obj
	    (apply _i_make-type-join new-components)))))


(define (clone-spc-or-apt transformer obj new-components simple?)
  (dwl2 "clone-spc-or-apt")
  (assert (is-transformer? transformer))
  (assert (or
	   (and simple? (is-simple-proc-class? obj))
	   (and (not simple?) (is-abstract-proc-type? obj))))
  (dwl2 "clone-spc-or-apt/1")
  (assert (list? new-components))
  (dwl2 "clone-spc-or-apt/2")
  (assert (boolean? simple?))
  (dwl2 "clone-spc-or-apt/3")
  (let ((old-arg-list-desc (vector-ref obj i-procedure-class-arg-list-type))
	(old-result-type-desc
	 (vector-ref obj i-procedure-class-result-type))
	(new-arg-list-desc (car new-components))
	(new-result-type-desc (cadr new-components))
	(pure? (vector-ref obj i-procedure-class-pure-proc))
	(appl-always-returns?
	 (vector-ref obj i-procedure-class-appl-always-returns))
	(appl-never-returns?
	 (vector-ref obj i-procedure-class-appl-never-returns))
	(static-method? (vector-ref obj i-procedure-class-static-method)))
    (dwl2 "clone-spc-or-apt/4")
    (dvar1-set! new-arg-list-desc)
    (let ((lst (if (is-type-list? new-arg-list-desc)
		   (vector-ref new-arg-list-desc i-type-list-subexprs)
		   new-arg-list-desc)))
      (if (or (list? lst) (is-tuple-type? lst))
	  (let ((hd (if (and (not-null? lst)
			     (not (eq? lst _b_<null>)))
			(gen-car lst)
			'())))
	    (dwl2 "clone-spc-or-apt/5")
	    (if (and
		 (is-splice-expression? hd)
		 (is-tuple-type? (vector-ref hd i-splice-component)))
		(begin
		  (strong-assert (memv (gen-cdr new-arg-list-desc)
				       (list _b_<null> '())))
		  (_i_make-procedure-type
		   (vector-ref hd i-splice-component)
		   new-result-type-desc
		   pure?
		   appl-always-returns?
		   appl-never-returns?
		   static-method?
		   simple?))
		(if (and (eq? old-arg-list-desc new-arg-list-desc)
			 (eq? old-result-type-desc new-result-type-desc))
		    obj
		    (_i_make-procedure-type new-arg-list-desc
					    new-result-type-desc
					    pure?
					    appl-always-returns?
					    appl-never-returns?
					    static-method?
					    simple?))))
	  (if (and (eq? old-arg-list-desc new-arg-list-desc)
		   (eq? old-result-type-desc new-result-type-desc))
	      obj
	      (_i_make-procedure-type new-arg-list-desc
				      new-result-type-desc
				      pure?
				      appl-always-returns?
				      appl-never-returns?
				      static-method?
				      simple?))))))


(define (clone-spc transformer obj new-components)
  (clone-spc-or-apt transformer obj new-components #t))


(define (clone-apt transformer obj new-components)
  (clone-spc-or-apt transformer obj new-components #f))


(define (get-sequence-from-tvars tvars)
  (let* ((numbers (map get-tvar-object-number tvars))
	 (min-number (apply min numbers))
	 (max-number (apply max numbers))
	 (count (+ (- max-number min-number) 1)))
    (if (= count (length tvars))
	(cons min-number count)
	(my-raise 'tvars-not-a-sequence))))


(define (clone-ppc transformer obj new-components)
  (dwl "clone-ppc")
  (assert (is-transformer? transformer))
  (assert (is-param-proc-class? obj))
  ;; The component lists contain at least the instance types.
  (assert (and (list? new-components)
	       (not-null? new-components)))
  (dvar1-set! obj)
  (dvar2-set! new-components)
  (let ((old-components (get-components obj)))
    (assert (not-null? old-components))
    (let ((old-tvars (my-drop-right old-components 2))
	  (old-arg-list (car (my-take-right old-components 2)))
	  (old-result-type (cadr (my-take-right old-components 2)))
	  (new-tvars (my-drop-right new-components 2))
	  (new-arg-list (car (my-take-right new-components 2)))
	  (new-result-type (cadr (my-take-right new-components 2))))
      (if (and-map? is-tvar-object? new-tvars)
	  (if (and (= (length old-tvars) (length new-tvars))
		   ;; and-map? returns #t for empty list
		   (and-map? tvar-object=? old-tvars new-tvars)
		   (eq? old-arg-list new-arg-list)
		   (eq? old-result-type new-result-type))
	      obj
	      ;; The new type variable numbers have to form a sequence.
	      (let* ((seq (get-sequence-from-tvars new-tvars))
		     (first-number (car seq))
		     (nr-of-tvars (cdr seq))
		     (new-inst-type
		      (clone-with-branches transformer
					   (vector-ref obj i-ppc-inst-type)
					   (list new-arg-list new-result-type))))
		(_i_make-param-proc-class first-number nr-of-tvars
					  new-tvars new-inst-type)))
	  (if (not (or-map? is-tvar-object? new-tvars))
	      (begin
		;; Is the following assertion OK?
		(assert (and
			 (not (contains-tvar-objects? new-arg-list))
			 (not (contains-tvar-objects? new-result-type))))
		(clone-with-branches transformer
				     (vector-ref obj i-ppc-inst-type)
				     (list new-arg-list new-result-type)))
	      ;; The new type variable numbers have to form a sequence.
	      (let* ((new-tvars2 (filter is-tvar-object? new-tvars))
		     (seq (get-sequence-from-tvars new-tvars2))
		     (first-number (car seq))
		     (nr-of-tvars (cdr seq))
		     (new-inst-type
		      (clone-with-branches transformer
					   (vector-ref obj i-ppc-inst-type)
					   (list new-arg-list new-result-type))))
		(_i_make-param-proc-class first-number nr-of-tvars
					  new-tvars2 new-inst-type)))))))


(define (clone-param-class-inst transformer obj new-components)
  (if rte-dbg? (dwli "clone-param-class-inst") (void))
  (assert (is-transformer? transformer))
  (assert (is-param-class-instance? obj))
  (assert (list? new-components))
  (let ((old-components (get-components-param-class-inst obj)))
    (if (component-lists-equal? old-components new-components)
	obj
	(let ((param-class (car new-components))
	      ;; Type variable values are the tail of the list.
	      (tvv (cdr new-components)))
	  (if rte-dbg?
	      (begin
		(dwli "clone-param-class-inst/1")
		(prti (car tvv)))
	      (void))
	  (_i_make-param-class-inst param-class tvv)))))


(define (clone-union transformer obj new-components)
  (assert (is-transformer? transformer))
  (assert (is-union-type? obj))
  (assert (list? new-components))
  (let ((old-components (vector-ref obj i-union-member-types)))
    (if (or (and (not-null? new-components)
		 (not (= (length new-components) (length old-components))))
	    (not (and-map? eq? new-components old-components)))
	(_i_make-union new-components)
	obj)))


(define (clone-apci transformer obj new-components)
  (assert (is-transformer? transformer))
  (assert (is-apci? obj))
  (assert (list? new-components))
  (let ((old-components (get-components obj)))
    (if (or (and (not-null? new-components)
		 (not (= (length new-components) (length old-components))))
	    (not (and-map? eq? new-components old-components)))
	(let ((new-param-class (car new-components))
	      (new-tvar-values (cdr new-components)))
	  (_i_get-param-class-inst new-param-class new-tvar-values))
	obj)))


(define (clone-aplti transformer obj new-components)
  (assert (is-transformer? transformer))
  (assert (is-aplti? obj))
  (assert (list? new-components))
  (let ((old-components (get-components obj)))
    (if (or (and (not-null? new-components)
		 (not (= (length new-components) (length old-components))))
	    (not (and-map? eq? new-components old-components)))
	(let ((new-param-ltype (car new-components))
	      (new-tvar-values (cdr new-components)))
	  (_i_get-param-ltype-inst new-param-ltype new-tvar-values))
	obj)))


(define (clone-with-branches transformer obj new-components)
  (dwl "clone-with-branches")
  (assert (is-transformer? transformer))
  (cond
   ((null? new-components)
    obj)
   ((is-singleton? obj)
    (clone-singleton transformer obj new-components))
   ((is-type-list? obj)
    (clone-type-list transformer obj new-components))
   ((is-rest-expression? obj)
    (clone-rest transformer obj new-components))
   ((is-type-loop? obj)
    (clone-type-loop transformer obj new-components))
   ((is-splice-expression? obj)
    (clone-splice transformer obj new-components))
   ((is-join-expression? obj)
    (clone-join transformer obj new-components))
   ((is-simple-proc-class? obj)
    (clone-spc transformer obj new-components))
   ((is-param-proc-class? obj)
    (clone-ppc transformer obj new-components))
   ((is-abstract-proc-type? obj)
    (clone-apt transformer obj new-components))
   ((is-param-class-instance? obj)
    (clone-param-class-inst transformer obj new-components))
   ((is-union-type? obj)
    (clone-union transformer obj new-components))
   ((is-apci? obj)
    (clone-apci transformer obj new-components))
   ((is-aplti? obj)
    (clone-aplti transformer obj new-components))
   (else obj)))


(define <marker>
  (create-class
   "<marker>"
   _b_<object>
   (list (make-readonly-field-no-init 'object _b_<object>))
   #f #t #t 'public))


(define (make-marker object)
  (vector <marker> object))


(define is-marker?
  (get-class-predicate <marker>))


(define i-marker-object 1)


(define (marker=? m1 m2)
  (assert (is-marker? m1))
  (assert (is-marker? m2))
  (eqv? (vector-ref m1 i-marker-object)
	(vector-ref m2 i-marker-object)))


(define (substitute-type-loop argument-translator type bindings subtypes)
  (dwl "substitute-type-loop ENTER")
  (assert (is-argument-translator? argument-translator))
  (assert (is-type-loop? type))
  (let* ((subtype-list
	  (if (or (list? subtypes)
		  (is-tuple-type? subtypes))
	      subtypes
	      (construct-argument-type-repr-fwd argument-translator
						subtypes))))
    (let ((result
	   (if (is-tvar-object? subtype-list)
	       (_i_make-type-loop
		(vector-ref type i-type-loop-iter-var)
		subtype-list
		(vector-ref type i-type-loop-iter-expr))
	       (let ((subexprs
		      (cond
		       ((list? subtype-list) subtype-list)
		       ((is-type-list? subtype-list)
			(vector-ref subtype-list i-type-list-subexprs))
		       ((is-tuple-type? subtype-list)
			(tuple-type->list-reject-cycles subtype-list))
		       (else
			(my-raise 'invalid-type-loop)))))
		 (let* ((iter-var
			 (vector-ref type i-type-loop-iter-var))
			(iter-expr
			 (vector-ref type i-type-loop-iter-expr))
			(result-types
			 (do-bind-loop
			  argument-translator
			  bindings
			  iter-var
			  subexprs
			  iter-expr)))
		   (apply _i_make-tuple-type result-types))))))
      (dwl "substitute-type-loop EXIT")
      result)))

(define (substitute-tvar-objects0 obj bindings visited changes markers)
  (dwl2 "substitute-tvar-objects0")
  (cond
   ((null? obj)
    (dwl2 "substitute-tvar-objects0 EXIT 0")
    '())
   ((mymemq obj visited)
    (dwl2 "visited")
    (let ((marker (make-marker obj))
	  (marker-list (get-singleton-element markers)))
      (if (not (general-member marker marker-list marker=?))
	  (set-singleton-element!
	   markers
	   (cons marker marker-list))
	  (void))
      marker))
   ((is-tvar-object? obj)
    (dwl2 "substitute-tvar-objects0/1")
    (let* ((b (general-assoc obj bindings tvar-object=?))
	   (result
	    (if (not (eq? b #f)) (cdr b) obj)))
      (dwl2 "substitute-tvar-objects0 EXIT 1")
      result))
   ((pair? obj)
    (dwl2 "substitute-tvar-objects0/2")
    (let ((b3 (alo-fetch changes obj)))
      (if (not (eq? b3 #f))
	  (cdr b3)
	  (let* ((new-visited (cons obj visited))
		 (result
		  (cons
		   (substitute-tvar-objects0 (car obj) bindings new-visited
					     changes markers)
		   (substitute-tvar-objects0 (cdr obj) bindings new-visited
					     changes markers))))
	    (alo-add-binding! changes obj result)
	    result))))
   ((mpair? obj)
    (dwl2 "substitute-tvar-objects0/2")
    (let ((b3 (alo-fetch changes obj)))
      (if (not (eq? b3 #f))
	  (cdr b3)
	  (let* ((new-visited (cons obj visited))
		 (result
		  (mcons
		   (substitute-tvar-objects0 (mcar obj) bindings new-visited
					     changes markers)
		   (substitute-tvar-objects0 (mcdr obj) bindings new-visited
					     changes markers))))
	    (alo-add-binding! changes obj result)
	    result))))
   ((is-type-loop? obj) 
    (dwl2 "substitute-tvar-objects0/3")
    (let ((b4 (alo-fetch changes obj)))
      (if (not (eq? b4 #f))
	  (cdr b4)
	  (let* ((subtypes0 (vector-ref obj i-type-loop-subtype-list))
		 (new-visited (cons obj visited))
		 (subtypes (substitute-tvar-objects0 subtypes0 bindings
						     new-visited changes
						     markers))
		 (arg-xlat (vector-ref gl-rte i-rte-arg-xlat))
		 (result
		  (substitute-type-loop arg-xlat obj bindings subtypes)))
	    (alo-add-binding! changes obj result)
	    result))))
   (else
    (dwl2 "substitute-tvar-objects0/4")
    (let ((b2 (alo-fetch changes obj)))
      (if (not (eq? b2 #f))
	  (cdr b2)
	  (if (not (vector? obj))
	      ;; If we enter the following expression we have a primitive object
	      ;; unless an internal error has occurred.
	      obj
	      ;; All vectors should be Theme objects.
	      (let ((components (get-components obj)))
		(dwl2 "substitute-tvar-objects0/4-1")
		(if (null? components)
		    obj
		    (let* ((new-visited (cons obj visited))
			   (new-components
			    (map
			     (lambda (comp)
			       (substitute-tvar-objects0
				comp bindings new-visited changes markers))
			     components))
			   (result
			    (let ((transformer (make-transformer)))
			      (dwl2 "substitute-tvar-objects0/5")
			      (clone-with-branches transformer obj new-components))))
		      ;; We have checked that obj is not already in changes.
		      (alo-add-binding! changes obj result)
		      (dwl2 "substitute-tvar-objects0 EXIT 2")
		      result)))))))))


(define (get-markers obj all-markers changes)
  (let ((result '()))
    (do ((cur all-markers (cdr cur)))
	((null? cur) result)
      (let* ((cur-obj (vector-ref (car cur) i-marker-object))
	     (pr (alo-fetch changes cur-obj)))
	(if (and (not (eq? pr #f))
		 (eq? (mcdr pr) obj))
	    (set! result (cons (car cur) result))
	    (void))))))


(define (update-marker-table marker-table obj markers)
  (if (null? markers)
      '()
      (begin
	(alo-add-binding-weak! marker-table (car markers) obj)
	(update-marker-table marker-table obj (cdr markers)))))


(define (fix-cycles obj visited all-markers marker-table changes)
  (dwl "fix-cycles ENTER")
  (let ((result
	 (cond
	  ((null? obj) '())
	  ((memv obj visited)
	   (dwl "fix-cycles/1")
	   ;; Procedure substitute-tvar-objects0 should have created markers
	   ;; for cycles except those arising from type loops.
	   obj)
	  ((is-marker? obj)
	   (dwl "fix-cycles/2")
	   (let ((a (alo-fetch marker-table obj)))

	     ;; TO BE REMOVED
	     (dwl "fix-cycles: marker:")
	     (dwl (not (eq? a #f)))
	     ;;	     (dvar1-set! (list obj visited all-markers marker-table changes))
	     ;;	     (my-raise 'marker-stop)

	     (if (not (eq? a #f))
		 (mcdr a)
		 obj)))
	  ((pair? obj)
	   (dwl "fix-cycles/3")
	   (let* ((markers (get-markers obj all-markers changes))
		  (obj1 (if (not-null? markers)
			    (mcons '() '())
			    obj)))
	     (if (not-null? markers)
		 (update-marker-table marker-table obj1 markers)
		 (void))
	     (let* ((new-visited (cons obj visited))
		    (new-head (fix-cycles (car obj) new-visited
					  all-markers marker-table changes))
		    (new-tail (fix-cycles (cdr obj) new-visited
					  all-markers marker-table changes))
		    ;; We don't need this value if markers is null.
		    (result2 (if (pair? obj)
				 (cons new-head new-tail)
				 (mcons new-head new-tail))))
	       (if (not-null? markers)
		   (begin
		     (set-mcar! obj1 new-head)
		     (set-mcdr! obj1 new-tail)
		     obj1)
		   result2))))
	  ;; All vectors should be Theme objects.
	  ((vector? obj)
	   (dwl "fix-cycles/4")
	   (let* ((markers (get-markers obj all-markers changes))
		  (obj1 (if (not-null? markers)
			    (make-singleton '())
			    obj)))
	     (dwl "fix-cycles/4-1")
	     (if (not-null? markers)
		 (update-marker-table marker-table obj1 markers)
		 (void))
	     (dwl "fix-cycles/4-2")
	     (let* ((new-visited (cons obj visited))
		    (components (get-components obj))
		    (new-components
		     (map
		      (lambda (comp)
			(fix-cycles comp new-visited
				    all-markers marker-table changes))
		      components))
		    (result2
		     (let ((transformer (make-transformer)))
		       (clone-with-branches transformer obj new-components))))
	       (dwl "fix-cycles/4-3")
	       (if (not-null? markers)
		   (begin
		     (set-singleton-element! obj1 result2)
		     obj1)
		   result2))))
	  (else obj))))
    (dwl "fix-cycles EXIT")
    result))


(define (substitute-tvar-objects obj bindings)
  (dwl "substitute-tvar-objects ENTER")
  ;; Theme objects are never empty vectors
  ;; so it is safe to use eq? here.
  (let* ((changes (make-alo '() eq?))
	 (markers (make-singleton '()))
	 (marker-table (make-alo '() marker=?))
	 (subst
	  (substitute-tvar-objects0 obj bindings '() changes markers))
	 (result (fix-cycles subst '()
			     (get-singleton-element markers)
			     marker-table
			     changes)))
    (dwl "substitute-tvar-objects EXIT")
    result))


(set! substitute-tvar-objects-forward substitute-tvar-objects)


;; *** Signatures ***


(dwl1 "a7")


(define _b_<signature-member>
  (_i_make-pair-class-inst _b_<object> _b_<object>))


(dwl1 "a7-1")


(define _b_<signature-member-list>
  (_i_make-uniform-list0 _b_<signature-member>))


(dwl1 "a7-2")


(define signature-fields
  (list
   (make-readonly-field-no-init 'l-members _b_<signature-member-list>)))


(dwl1 "a7-3")


(define c-signature-fields 1)
(define i-signature-members 1)


(dwl1 "a7-4")


(define _b_<signature>
  (create-class
   "<signature>"
   _b_<logical-type>
   signature-fields
   #f
   #t
   #f
   'public))


(dwl1 "a7-5")


(define (make-signature members)
  (assert (is-instance-forward? members _b_<signature-member-list>))
  (vector _b_<signature> members))


(dwl1 "a8")


(define is-signature?
  (get-class-predicate _b_<signature>))


(define param-signature-fields
  (list
   (make-readonly-field-no-init 'l-tvars _b_<object>)
   (make-readonly-field-no-init 'l-members _b_<signature-member-list>)))


(define c-param-signature-fields 2)
(define i-param-signature-tvars 1)
(define i-param-signature-members 2)


(dwl1 "a7-4")


(define _b_<param-signature>
  (create-class
   "<param-signature>"
   _b_<logical-type>
   param-signature-fields
   #f
   #t
   #f
   'public))


(define (make-param-signature tvars members)
  (assert (is-instance-forward? members _b_<signature-member-list>))
  (vector _b_<param-signature> tvars members))


(dwl1 "a8")


(define is-param-signature?
  (get-class-predicate _b_<param-signature>))


;; *** Checking subtyping ***


(define check-if-subtype-forward? '())


(define (check-if-equal-types? type-checker marks t1 t2)
  (dwl "check-if-equal-types?")
  (let ((result
	 (and
	  (check-if-subtype-forward? type-checker marks t1 t2)
	  (check-if-subtype-forward? type-checker marks t2 t1))))
    (dwl "check-if-equal-types? EXIT")
    result))


;; Precondition: t1 has to be a class and t2 has to be a simple class.
(define (is-simple-class-subtype? t1 t2)
  (dwl2 "is-simple-class-subtype?")
  (cond
   ((eq? t1 t2) #t)
   ((eq? t2 _b_<object>) #t)
   ;; We known that t2 is not _b_<object> in the following.
   ((eq? t1 _b_<object>) #f)
   (else (is-simple-class-subtype?
	  (vector-ref t1 i-class-superclass) t2))))


(define (is-class? obj)
  (is-simple-class-subtype? (theme-class-of obj) _b_<class>))


(define (is-normal-object? x)
  (and (vector? x)
       (>= (vector-length x) 1)
       (is-class? (theme-class-of x))))


(set! is-normal-object-fwd? is-normal-object?)


(define (sgn-member-implemented? type-checker marks sgn mem target-type)
  (let* ((to (car mem))
	 (r-actual-type (theme-class-of to))
	 (r-type (cdr mem))
	 (al-bindings (list (cons _b_this target-type)))
	 (r-new-type (substitute-tvar-objects r-type al-bindings))
	 (result (check-if-subtype-forward? type-checker marks
					    r-actual-type r-new-type)))
    result))


(define (check-if-implements-signature? type-checker marks typ sgn)
  (let* ((l-members (vector-ref sgn i-signature-members))
	 (result?
	  (and-map? (lambda (mem)
		      (sgn-member-implemented? type-checker marks
					       sgn mem typ))
		    l-members)))
    result?))


(define (check-if-subsignature? type-checker marks sgn1 sgn2)
  (let ((l-members1 (vector-ref sgn1 i-signature-members))
	(l-members2 (vector-ref sgn2 i-signature-members))
	(match2? #t))
    (do ((l-cur2 l-members2 (cdr l-cur2)))
	((or (null? l-cur2) (not match2?)))
      (let ((o-cur2 (car l-cur2))
	    (match1? #f))
	(do ((l-cur1 l-members1 (cdr l-cur1)))
	    ((or (null? l-cur1) match1?))
	  (let ((o-cur1 (car l-cur1)))
	    (if1 (and
		  (eq? (car o-cur1) (car o-cur2))
		  (check-if-subtype-forward?
		   type-checker marks
		   (cdr o-cur1) (cdr o-cur2)))
		 (set! match1? #t))))
	(if1 (not match1?) (set! match2? #f))))
    match2?))


(define (check-if-param-inst-equal0? type-checker marks t1 t2)
  (and (eq? (theme-class-of t1) (theme-class-of t2))
	(let ((tvar-values1 (vector-ref t1 i-param-class-inst-type-var-values))
	      (tvar-values2 (vector-ref t2 i-param-class-inst-type-var-values)))
	  (and (= (length tvar-values1) (length tvar-values2))
	       (and-map? (lambda (tt1 tt2)
			   (check-if-equal-types? type-checker marks tt1 tt2))
			 tvar-values1 tvar-values2)))))


(define (check-if-param-inst-equal? type-checker marks t1 t2)
  (dwl "check-if-param-inst-equal?")
  (let ((p1 (is-param-class-instance? t1))
	(p2 (is-param-class-instance? t2)))
    (cond
     ((and (not p1) (not p2))
      (eq? t1 t2))
     ((or (and (not p1) p2)
	  (and p1 (not p2)))
      #f)
     (else
      (let ((result (check-if-param-inst-equal0? type-checker marks t1 t2)))
	result)))))


(define (check-if-param-inst-subclass? type-checker marks t1 t2)
  (dwl2 "check-if-param-inst-subclass?")
  (let ((result
	 (cond
	  ((eq? t2 _b_<object>) #t)
	  ;; We known that t2 is not _b_<object> in the following.
	  ((eq? t1 _b_<object>) #f)
	  ((check-if-param-inst-equal? type-checker marks t1 t2) #t)
	  (else
	   (check-if-param-inst-subclass? type-checker marks
					  (vector-ref t1 i-class-superclass)
					  t2)))))
    result))


(define (check-if-subtype-union-x? type-checker marks ut1 t2)
  (dwl "check-if-subtype-union-x?")
  (let ((member-types (vector-ref ut1 i-union-member-types))
	(result? #t))
    (do ((cur-list member-types (cdr cur-list)))
	((or (not result?) (null? cur-list)) result?)
      (if1 (not (check-if-subtype-forward? type-checker marks
					   (car cur-list) t2))
	   (set! result? #f)))))


(define (check-if-subtype-x-union? type-checker marks t1 ut2)
  (dwl "check-if-subtype-x-union?")
  (let ((member-types (vector-ref ut2 i-union-member-types))
	(result? #f))
    (do ((cur-list member-types (cdr cur-list)))
	((or result? (null? cur-list)) result?)
      (if1 (check-if-subtype-forward? type-checker marks
				      t1 (car cur-list))
	   (set! result? #t)))))


(define (check-if-pair-subclass? type-checker marks t1 t2)
  (dwl "check-if-pair-subclass?")
  (dvar1-set! t1)
  (dvar2-set! t2)
  (let* ((mt1 (vector-ref t1 i-param-class-inst-type-var-values))
	 (first1 (car mt1))
	 (second1 (cadr mt1))
	 (mt2 (vector-ref t2 i-param-class-inst-type-var-values))
	 (first2 (car mt2))
	 (second2 (cadr mt2)))
    (dwl "check-if-pair-subclass?/1")
    (let ((result
	   (and (check-if-subtype-forward? type-checker marks
					   first1 first2)
		(check-if-subtype-forward? type-checker marks
					   second1 second2))))
      (dwl "check-if-pair-subclass? EXIT")
      result)))


(define (proc-attr-inherit0? pure1? always-returns1? never-returns1?
			     static-method1?
			     pure2? always-returns2? never-returns2?
			     static-method2?)
  (and (not (and (not pure1?) pure2?))
       (or (and (not always-returns2?) (not never-returns2?))
	   (and
	    (eq? always-returns1? always-returns2?)
	    (eq? never-returns1? never-returns2?)))))


(define (proc-attr-inherit? t1 t2)
  (let ((pure1? (vector-ref t1 i-procedure-class-pure-proc))
	(pure2? (vector-ref t2 i-procedure-class-pure-proc))
	(always-returns1? (vector-ref t1 i-procedure-class-appl-always-returns))
	(always-returns2? (vector-ref t2 i-procedure-class-appl-always-returns))
	(never-returns1? (vector-ref t1 i-procedure-class-appl-never-returns))
	(never-returns2? (vector-ref t2 i-procedure-class-appl-never-returns))
	(static-method1? (vector-ref t1 i-procedure-class-static-method))
	(static-method2? (vector-ref t2 i-procedure-class-static-method)))
    (proc-attr-inherit0? pure1? always-returns1? never-returns1?
			 static-method1?
			 pure2? always-returns2? never-returns2?
			 static-method2?)))


;; NOTE:
;; Contravariant inheritance for the argument list type
;; and covariant inheritance for the result type.
(define (check-if-proc-subtype? type-checker marks t1 t2)
  (dwl "check-if-proc-subtype?")
  (let ((simple1? (is-simple-proc-type? t1))
	(simple2? (is-simple-proc-type? t2)))
    (if (not (and (not simple1?) simple2?))
	(let ((argl1 (vector-ref t1 i-procedure-class-arg-list-type))
	      (argl2 (vector-ref t2 i-procedure-class-arg-list-type))
	      (res1 (vector-ref t1 i-procedure-class-result-type))
	      (res2 (vector-ref t2 i-procedure-class-result-type))
	      (pure1? (vector-ref t1 i-procedure-class-pure-proc))
	      (pure2? (vector-ref t2 i-procedure-class-pure-proc)))
	  (and (proc-attr-inherit? t1 t2)
	       (check-if-subtype-forward? type-checker marks
					  argl2 argl1)
	       ;; If procedure class A inherits from procedure class B
	       ;; and the result type of B is none the result type of A
	       ;; can be anything.
	       (or (eq? res2 _b_none)
		   (check-if-subtype-forward? type-checker
					      marks res1 res2))))
	#f)))


(define deduce-argument-types-fwd '())
(define get-all-tvars-fwd '())


(define (do-check-param-proc-abst-proc? type-checker marks inst-type
					proc-type tvar-table all-tvars)
  (let* ((tvar-values (get-tvar-values tvar-table all-tvars))
	 (tvar-bindings (map cons all-tvars tvar-values))
	 (inst-type2 (substitute-tvar-objects inst-type tvar-bindings))
	 (proc-type2 (substitute-tvar-objects proc-type tvar-bindings))
	 (src-arg-list-type (vector-ref inst-type2
					i-procedure-class-arg-list-type))
	 (target-arg-list-type (vector-ref proc-type2
					   i-procedure-class-arg-list-type))
	 (src-result-type
	  (vector-ref inst-type2 i-procedure-class-result-type)) 
	 (target-result-type
	  (vector-ref proc-type2 i-procedure-class-result-type)))
    (and
     (or (eq? target-result-type _b_none)
	 (check-if-subtype? type-checker marks
			    src-result-type target-result-type))
     ;; Note the order.
     (check-if-subtype? type-checker marks
			target-arg-list-type src-arg-list-type))))


(define (check-param-proc-abst-proc? type-checker marks param-proc-class
				     proc-type)
  (dwl "check-param-proc-abst-proc?")
  (let* ((inst-type (vector-ref param-proc-class i-ppc-inst-type))
	 (src-tvars (vector-ref param-proc-class i-ppc-tvars))
	 ;; (old-tvars (vector-ref param-proc-class i-ppc-tvars))
	 ;; (tva (vector-ref gl-rte i-rte-tvar-allocator))
	 ;; (nr-of-tvars (vector-ref param-proc-class i-ppc-nr-of-tvars))
	 ;; (first-tvar-number (tva-alloc tva nr-of-tvars))
	 ;; (tvars (map make-tvar-object
	 ;; 	     (get-integer-sequence first-tvar-number
	 ;; 				   nr-of-tvars)))
	 ;; (tvar-bindings (map cons old-tvars tvars))
	 ;; (inst-type-new (substitute-tvar-objects inst-type tvar-bindings))
	 (arg-xlat (make-argument-translator))
	 (target-tvars (get-all-tvars-fwd proc-type))
	 (all-tvars (append src-tvars target-tvars))
	 (tvar-table (make-alo '() tvar-object=?)))
    (dwl "check-param-proc-abst-proc?/1")
    (let ((pure1? (vector-ref inst-type i-procedure-class-pure-proc))
	  (pure2? (vector-ref proc-type i-procedure-class-pure-proc)))
      (if (not (proc-attr-inherit? inst-type proc-type))
	  #f
	  (begin
	    ;; What if inst-type and proc-type share type variables?
	    (deduce-argument-types-fwd arg-xlat tvar-table
				       all-tvars
				       inst-type proc-type)
	    (dwl "check-param-proc-abst-proc?/2")
	    (let ((result
		   (if (deduced-all-tvars? tvar-table all-tvars)
		       (do-check-param-proc-abst-proc?
			type-checker marks inst-type proc-type
			tvar-table all-tvars)
		       (begin
			 (dwl "check-param-proc-abst-proc?/3")
			 (dvar1-set! tvar-table)
			 (dvar2-set! all-tvars)
			 (dvar3-set! param-proc-class)
			 (dvar4-set! proc-type)
			 #f))))
	      (dwl "check-param-proc-abst-proc? EXIT")
	      result))))))


(define (get-rebinding rebindings tvar)
  (dwl "get-rebinding ENTER")
  (let ((result
	 (if (null? rebindings)
	     tvar
	     (let* ((cur-assoc-list (cdr rebindings))
		    (b (general-assoc tvar cur-assoc-list tvar-object=?)))
	       (if (not (eq? b #f))
		   (cdr b)
		   (get-rebinding (car rebindings) tvar))))))
    (dwl "get-rebinding EXIT")
    result))


(define equal-type-trees0-fwd? '())


(define (handle-singleton0 obj visited)
  (assert (list? visited))
  (if (is-singleton? obj)
      (if (memv obj visited)
	  obj
	  (handle-singleton0
	   (get-singleton-element obj)
	   (cons obj visited)))
      obj))


(define (handle-singleton obj)
  (handle-singleton0 obj '()))


(define (equal-pair-class-trees? rebindings1 rebindings2 visited pc1 pc2)
  (assert (is-pair-class? pc1))
  (assert (is-pair-class? pc2))
  (and
   (equal-type-trees0-fwd? rebindings1
			   rebindings2
			   visited
			   (get-pair-first-type pc1)
			   (get-pair-first-type pc2))
   (equal-type-trees0-fwd? rebindings1
			   rebindings2
			   visited
			   (get-pair-second-type pc1)
			   (get-pair-second-type pc2))))


(define (equal-normal-type-trees? rebindings1 rebindings2 visited o1 o2)
  (dwl "equal-normal-type-trees?")
  (and
   (equal-type-trees0-fwd? rebindings1 rebindings2 visited
			   (theme-class-of o1) (theme-class-of o2))
   (let ((cpnt1 (get-components o1))
	 (cpnt2 (get-components o2)))
     (cond
      ((and (not-null? cpnt1) (not-null? cpnt2))
       (and
	(= (length cpnt1) (length cpnt2))
	(and-map? (lambda (c1 c2)
		    (equal-type-trees0-fwd? rebindings1
					    rebindings2
					    visited
					    c1 c2))
		  cpnt1 cpnt2)))
      ((or (not-null? cpnt1) (not-null? cpnt2)) #f)
      (else
       ;; General classes have to be handled last.
       (let ((c1? (is-class? o1))
	     (c2? (is-class? o2)))
	 (cond
	  ((and c1? c2?) (eq? o1 o2))
	  ((or c1? c2?) #f)
	  (else #f))))))))


(define (equal-ppc-trees? rebindings1 rebindings2 visited ppc1 ppc2)
  (dwl "equal-ppc-trees?")
  (assert (is-param-proc-class? ppc1))
  (assert (is-param-proc-class? ppc2))
  (let ((tvars1 (vector-ref ppc1 i-ppc-tvars))
	(tvars2 (vector-ref ppc2 i-ppc-tvars)))
    (if (= (length tvars1) (length tvars2))
	(if (and-map? tvar-object=? tvars1 tvars2)
	    #t
	    (let* ((tva (vector-ref gl-rte i-rte-tvar-allocator))
		   (nr-of-tvars (length tvars1))
		   (first-tvar-number (tva-alloc tva nr-of-tvars))
		   (new-tvars (map make-tvar-object
				   (get-integer-sequence first-tvar-number
							 nr-of-tvars)))
		   (new-toplevel-bindings1 (map cons tvars1 new-tvars))
		   (new-toplevel-bindings2 (map cons tvars2 new-tvars))
		   (new-rebindings1 (cons rebindings1 new-toplevel-bindings1))
		   (new-rebindings2 (cons rebindings2 new-toplevel-bindings2))
		   (inst-type1 (vector-ref ppc1 i-ppc-inst-type))
		   (inst-type2 (vector-ref ppc2 i-ppc-inst-type))
		   (result
		    (equal-type-trees0-fwd? new-rebindings1 new-rebindings2
					    visited inst-type1 inst-type2)))
	      ;; Here we have checked whole trees ppc1 and ppc2
	      ;; so it should be OK to deallocate the type variable numbers.
	      (tva-dealloc tva first-tvar-number)
	      result))
	#f)))


(define (equal-type-loop-trees? rebindings1 rebindings2 visited tl1 tl2)
  (dwl "equal-type-loop-trees?")
  (assert (is-type-loop? tl1))
  (assert (is-type-loop? tl2))
  (and
   (equal-type-trees0-fwd? rebindings1 rebindings2 visited
			   (vector-ref tl1 i-type-loop-subtype-list)
			   (vector-ref tl2 i-type-loop-subtype-list))
   (let ((tvar1 (vector-ref tl1 i-type-loop-iter-var))
	 (tvar2 (vector-ref tl2 i-type-loop-iter-var)))
     (assert (is-tvar-object? tvar1))
     (assert (is-tvar-object? tvar2))
     (if (tvar-object=? tvar1 tvar2)
	 (let ((iter-expr1 (vector-ref tl1 i-type-loop-iter-expr))
	       (iter-expr2 (vector-ref tl2 i-type-loop-iter-expr)))
	   (equal-type-trees0-fwd? rebindings1 rebindings2 visited
				   iter-expr1 iter-expr2))
	 (let* ((tva (vector-ref gl-rte i-rte-tvar-allocator))
		(tvar-number (tva-alloc tva 1))
		(new-tvar (make-tvar-object tvar-number))
		(new-toplevel-bindings1 (list (cons tvar1 new-tvar)))
		(new-toplevel-bindings2 (list (cons tvar2 new-tvar)))
		(new-rebindings1 (cons rebindings1 new-toplevel-bindings1))
		(new-rebindings2 (cons rebindings2 new-toplevel-bindings2))
		(iter-expr1 (vector-ref tl1 i-type-loop-iter-expr))
		(iter-expr2 (vector-ref tl2 i-type-loop-iter-expr)))
	   ;; Here we have checked whole trees tl1 and tl2
	   ;; so it should be OK to deallocate the type variable number.
	   (tva-dealloc tva tvar-number)
	   (equal-type-trees0-fwd? new-rebindings1 new-rebindings2 visited
				   iter-expr1 iter-expr2))))))


(define (equal-type-trees0? rebindings1 rebindings2 visited o1 o2)
  (dwl "equal-type-trees0? ENTER")
  (assert (list? rebindings1))
  (assert (list? rebindings2))
  (let ((result
	 (cond
	  ((general-member (cons o1 o2) visited pair-contents-eqv?)
	   #t)
	  ((or (eq? o1 _b_<class>) (eq? o2 _b_<class>))
	   (and (eq? o1 _b_<class>) (eq? o2 _b_<class>)))
	  (else
	   (let ((tv1? (is-tvar-object? o1))
		 (tv2? (is-tvar-object? o2)))
	     (dwl "equal-type-trees0?/1")
	     (cond
	      ((and tv1? tv2?)
	       (let ((new-tvar1 (get-rebinding rebindings1 o1))
		     (new-tvar2 (get-rebinding rebindings2 o2)))
		 (tvar-object=? new-tvar1 new-tvar2)))
	      ((or tv1? tv2?) #f)
	      (else
	       (let ((new-visited (cons (cons o1 o2) visited))
		     (p1 (handle-singleton o1))
		     (p2 (handle-singleton o2)))
		 ;; Pair classes may not be completely cached.
		 ;; That is why they are handled separately here.
		 (let ((pc1? (is-pair-class? p1))
		       (pc2? (is-pair-class? p2)))
		   (dwl "equal-type-trees0?/2")
		   (cond
		    ((and pc1? pc2?)
		     (equal-pair-class-trees? rebindings1
					      rebindings2
					      new-visited
					      p1
					      p2))
		    ((or pc1? pc2?) #f)
		    (else
		     (let ((ppc1? (is-param-proc-class? p1))
			   (ppc2? (is-param-proc-class? p2)))
		       (dwl "equal-type-trees0?/4")
		       (cond
			((and ppc1? ppc2?)
			 (equal-ppc-trees? rebindings1 rebindings2
					   new-visited p1 p2))
			((or ppc1? ppc2?) #f)
			(else
			 (let ((loop1? (is-type-loop? p1))
			       (loop2? (is-type-loop? p2)))
			   (dwl "equal-type-trees0?/5")
			   (cond
			    ((and loop1? loop2?)
			     (equal-type-loop-trees? rebindings1 rebindings2
						     new-visited p1 p2))
			    ((or loop1? loop2?) #f)
			    (else
			     (equal-normal-type-trees? rebindings1
						       rebindings2
						       new-visited
						       p1 p2))))))))))))))))))
    (dwl "equal-type-trees0? EXIT")
    result))


(set! equal-type-trees0-fwd? equal-type-trees0?)


(define (equal-type-trees? t1 t2)
  (equal-type-trees0? '() '() '() t1 t2))


(define (check-if-param-proc-subclass? type-checker marks ppc1 ppc2)
  (dwl "check-if-param-proc-subclass? ENTER")
  (assert (is-type-checker? type-checker))
  (assert (list? marks))
  (assert (is-param-proc-class? ppc1))
  (assert (is-param-proc-class? ppc2))
  (let* ((old-tvars1 (vector-ref ppc1 i-ppc-tvars))
	 (old-tvars2 (vector-ref ppc2 i-ppc-tvars))
	 (nr-of-tvars (length old-tvars1)))
    (if (= (length old-tvars2) nr-of-tvars)
	(let* ((tva (vector-ref gl-rte i-rte-tvar-allocator))
	       (first-tvar-number (tva-alloc tva nr-of-tvars))
	       (tvars (map make-tvar-object
			   (get-integer-sequence first-tvar-number
						 nr-of-tvars)))
	       (inst-type1 (vector-ref ppc1 i-ppc-inst-type))
	       (tvar-bindings1 (map cons old-tvars1 tvars))
	       (inst-type-new1
		(substitute-tvar-objects inst-type1 tvar-bindings1))
	       (inst-type2 (vector-ref ppc2 i-ppc-inst-type))
	       (tvar-bindings2 (map cons old-tvars2 tvars))
	       (inst-type-new2
		(substitute-tvar-objects inst-type2 tvar-bindings2))
	       (result (check-if-subtype-forward?
			type-checker marks
			inst-type-new1 inst-type-new2)))
	  (tva-dealloc tva first-tvar-number)
	  (dwl "check-if-param-proc-subclass? EXIT 1")
	  result)
	(begin
	  (dwl "check-if-param-proc-subclass? EXIT 2")
	  #f))))


(define (check-if-subtype-gen-pp? type-checker marks gp pp)
  (dwl "check-if-subtype-gen-pp?")
  (assert (is-type-checker? type-checker))
  (assert (is-gen-proc-class? gp))
  (assert (is-param-proc-class? pp))
  (let* ((method-classes (vector-ref gp i-param-class-inst-type-var-values))
	 (found? #f)
	 (res
	  (do ((cur-lst method-classes (cdr cur-lst)))
	      ((or (null? cur-lst) found?) found?)
	    (if1 (check-if-subtype-forward? type-checker marks
					    (car cur-lst) pp)
		 (set! found? #t)))))
    res))


(define (check-if-subtype-gen-abst? type-checker marks t1 t2)
  (dwl "check-if-subtype-gen-abst?")
  (assert (is-type-checker? type-checker))
  (assert (list? marks))
  (assert (is-gen-proc-class? t1))
  (assert (is-abstract-proc-type? t2))
  (let ((method-classes (vector-ref t1 i-param-class-inst-type-var-values))
	(result? #f))
    (do ((cur-list method-classes (cdr cur-list)))
	((or result? (null? cur-list)) result?)
      (if1 (check-if-subtype-forward? type-checker marks
				      (car cur-list) t2)
	   (set! result? #t)))))


(define (check-if-subtype-gen-gen? type-checker marks t1 t2)
  (dwl "check-if-subtype-gen-gen?")
  (assert (is-type-checker? type-checker))
  (assert (list? marks))
  (assert (is-gen-proc-class? t1))
  (assert (is-gen-proc-class? t2))
  (let* ((mc1 (vector-ref t1 i-param-class-inst-type-var-values))
	 (mc2 (vector-ref t2 i-param-class-inst-type-var-values))
	 (result2? #t)
	 (result
	  (do ((lst2 mc2 (cdr lst2)))
	      ((or (null? lst2) (not result2?)) result2?)
	    (if1 (not
		  (let ((result1? #f))
		    (do ((lst1 mc1 (cdr lst1)))
			((or (null? lst1) result1?) result1?)
		      (if1 (check-if-subtype-forward? type-checker
						      marks
						      (car lst1)
						      (car lst2))
			   (set! result1? #t)))))
		 (set! result2? #f)))))
    result))


(define (check-if-vector-subclass? type-checker marks tl1 tl2)
  (dwl "check-if-vector-subclass?")
  (let ((mt1 (car (vector-ref tl1 i-param-class-inst-type-var-values)))
	(mt2 (car (vector-ref tl2 i-param-class-inst-type-var-values))))
    (check-if-subtype-forward? type-checker marks mt1 mt2)))


(define (check-if-value-vector-subclass? type-checker marks tl1 tl2)
  (dwl "check-if-value-vector-subclass?")
  (let ((mt1 (car (vector-ref tl1 i-param-class-inst-type-var-values)))
	(mt2 (car (vector-ref tl2 i-param-class-inst-type-var-values))))
    (check-if-subtype-forward? type-checker marks mt1 mt2)))


(define (elementwise-subtypes? type-checker marks lst1 lst2)
  (let ((l1? (list? lst1))
	(l2? (list? lst2)))
    (cond
     ((and l1? l2?)
      (and (= (length lst1) (length lst2))
	   (and-map?
	    (lambda (tt1 tt2)
	      (check-if-subtype? type-checker marks tt1 tt2))
	    lst1 lst2)))
     ((and (not l1?) (not l2?))
      (check-if-subtype? type-checker marks lst1 lst2))
     (else #f))))


(define (check-if-apci-subclass? type-checker marks t1 t2)
  (let ((result
	 ;; Should we have a smarter test than eq? here?
	 (and (eq? (vector-ref t1 i-apci-param-class)
		   (vector-ref t2 i-apci-param-class))
	      (let ((params1 (vector-ref t1 i-apci-tvar-values))
		    (params2 (vector-ref t2 i-apci-tvar-values)))
		(elementwise-subtypes? type-checker marks params1 params2)))))
    result))


(define (check-if-aplti-subtype? type-checker marks t1 t2)
  (let ((result
	 ;; Should we have a smarter test than eq? here?
	 (and (eq? (vector-ref t1 i-aplti-param-ltype)
		   (vector-ref t2 i-aplti-param-ltype))
	      (let ((params1 (vector-ref t1 i-aplti-tvar-values))
		    (params2 (vector-ref t2 i-aplti-tvar-values)))
		(elementwise-subtypes? type-checker marks params1 params2)))))
    result))

(define (check-if-splice-subtype? type-checker marks t1 t2)
  (let ((comp1 (vector-ref t1 i-splice-component))
	(comp2 (vector-ref t2 i-splice-component)))
    (check-if-subtype-forward? type-checker marks comp1 comp2)))


(define (check-if-rest-subtype? type-checker marks t1 t2)
  (let ((comp1 (vector-ref t1 i-rest-component))
	(comp2 (vector-ref t2 i-rest-component)))
    (check-if-subtype-forward? type-checker marks comp1 comp2)))


(define (check-if-type-list-subtype? type-checker marks lst1 lst2)
  (let* ((subtypes1 (vector-ref lst1 i-type-list-subexprs))
	 (subtypes2 (vector-ref lst2 i-type-list-subexprs))
	 (result
	  (elementwise-subtypes? type-checker marks subtypes1 subtypes2)))
    result))


(define (check-if-join-subtype? type-checker marks lst1 lst2)
  (let* ((subtypes1 (vector-ref lst1 i-join-subexprs))
	 (subtypes2 (vector-ref lst2 i-join-subexprs))
	 (result
	  (elementwise-subtypes? type-checker marks subtypes1 subtypes2)))
    result))


(define (equal-loop-lists? lst1 lst2)
  (cond
   ((and (not (list? lst1)) (not (list? lst2)))
    (equal-type-trees? lst1 lst2))
   ((and (list? lst1) (list? lst2))
    (and (= (length lst1) (length lst2))
	 (and-map? equal-type-trees? lst1 lst2)))
   (else #f)))


(define (check-if-loop-subtype? type-checker marks loop1 loop2)
  (let ((iter-var1 (vector-ref loop1 i-type-loop-iter-var))
	(iter-var2 (vector-ref loop2 i-type-loop-iter-var)))
    (cond
     ((tvar-object=? iter-var1 iter-var2)
      (let ((subtypes1 (vector-ref loop1 i-type-loop-subtype-list))
	    (subtypes2 (vector-ref loop2 i-type-loop-subtype-list))
	    (iter-expr1 (vector-ref loop1 i-type-loop-iter-expr))
	    (iter-expr2 (vector-ref loop2 i-type-loop-iter-expr)))
	(if (equal-loop-lists? subtypes1 subtypes2)
	    (check-if-subtype-forward? type-checker marks
				       iter-expr1 iter-expr2)
	    #f)))
     ((equal-loop-lists?
       (vector-ref loop1 i-type-loop-subtype-list)
       (vector-ref loop2 i-type-loop-subtype-list))
      (let* ((iter-expr1 (vector-ref loop1 i-type-loop-iter-expr))
	     (iter-expr2 (vector-ref loop2 i-type-loop-iter-expr))
	     (tva (vector-ref gl-rte i-rte-tvar-allocator))
	     (tvar-number (tva-alloc tva 1))
	     (new-iter-var (make-tvar-object tvar-number))
	     (bindings1 (list (cons iter-var1 new-iter-var)))
	     (bindings2 (list (cons iter-var2 new-iter-var)))
	     (new-expr1 (substitute-tvar-objects iter-expr1 bindings1))
	     (new-expr2 (substitute-tvar-objects iter-expr2 bindings2))
	     (result
	      (check-if-subtype-forward? type-checker marks
					 new-expr1 new-expr2)))
	(tva-dealloc tva tvar-number)
	result))
     (else
      #f))))


(define (do-basic-subtype-checks? type-checker marks-new t1 t2)
  (cond
   ((type=? t1 t2) #t)
   ((type=? t2 _b_<object>) #t)
   ((and (is-tvar-object? t1) (is-tvar-object? t2))
    (tvar-object=? t1 t2))
   ((or (is-tvar-object? t1) (is-tvar-object? t2))
    #f)
   ;; The following should be unnecessary.
   ((and (is-primitive-class? t1)
	 (is-primitive-class? t2))
    (eq? t1 t2))
   (else '())))


(define (do-none-checks? type-checker marks-new t1 t2)
  (cond
   ;; <none> inherits only from <none> and <object>.
   ((type=? t1 _b_none)
    (type=? t2 _b_none))
   ;; No other type but <none> inherits from <none>.
   ((type=? t2 _b_none)
    (type=? t1 _b_none))
   (else '())))


(define (do-union-checks? type-checker marks-new t1 t2)
  (cond
   ((is-union-type? t1)
    (check-if-subtype-union-x? type-checker marks-new
			       t1 t2))
   ((is-union-type? t2)
    (check-if-subtype-x-union? type-checker marks-new
			       t1 t2))
   (else
    '())))


(define (do-pair-checks? type-checker marks-new t1 t2)
  (let ((p1? (is-pair-class? t1))
	(p2? (is-pair-class? t2)))
    (cond
     ((or (and p1? (not p2?))
	  (and (not p1?) p2?))
      #f)
     ((and p1? p2?)
      (check-if-pair-subclass? type-checker marks-new
			       t1 t2))
     (else '()))))


(define (do-proc-type-checks? type-checker marks-new t1 t2)
  (let ((ap1? (is-abstract-proc-type? t1))
	(ap2? (is-abstract-proc-type? t2))
	(sp1? (is-simple-proc-class? t1))
	(sp2? (is-simple-proc-class? t2))
	(pp1? (is-param-proc-class? t1))
	(pp2? (is-param-proc-class? t2))
	(gp1? (is-gen-proc-class? t1))
	(gp2? (is-gen-proc-class? t2)))
    (cond
     ((or (and ap1? sp2?) (and ap1? pp2?) (and sp1? pp2?)
	  (and pp1? sp2?)
	  (and gp1? sp2?)
	  (and ap1? gp2?) (and sp1? gp2?) (and pp1? gp2?))
      #f marks-new)
     ((or (and ap1? ap2?) (and sp1? ap2?) (and sp1? sp2?))
      (check-if-proc-subtype? type-checker marks-new
			      t1 t2))
     ((and pp1? ap2?)
      (check-param-proc-abst-proc?
       type-checker marks-new
       t1 t2))
     ((and pp1? pp2?)
      (check-if-param-proc-subclass?
       type-checker marks-new
       t1 t2))
     ((and gp1? ap2?)
      (check-if-subtype-gen-abst?
       type-checker marks-new
       t1 t2))
     ((and gp1? gp2?)
      (check-if-subtype-gen-gen?
       type-checker marks-new
       t1 t2))
     ((and gp1? pp2?)
      (check-if-subtype-gen-pp?
       type-checker marks-new
       t1 t2))
     (else '()))))


(define (do-vector-class-checks? type-checker marks-new t1 t2)
  (let ((uv1? (is-vector-class? t1))
	(uv2? (is-vector-class? t2)))
    (cond
     ((and uv1? uv2?)
      (check-if-vector-subclass?
       type-checker marks-new t1 t2))
     ((and uv1? (not uv2?))
      #f)
     ((and (not uv1?) uv2?)
      #f)
     (else
      (dwl "check-if-subtype?/5")
      (let ((vv1? (is-value-vector-class? t1))
	    (vv2? (is-value-vector-class? t2)))
	(cond
	 ((and vv1? vv2?)
	  (check-if-value-vector-subclass?
	   type-checker marks-new t1 t2))
	 ((and vv1? (not vv2?))
	  #f)
	 ((and (not vv1?) vv2?)
	  #f)
	 (else '())))))))


(define (do-apti-checks? type-checker marks-new t1 t2)
  (cond
   ((is-apci? t2)
    (if (is-apci? t1)
	(check-if-apci-subclass?
	 type-checker marks-new t1 t2)
	#f))
   ((is-aplti? t2)
    (if (is-aplti? t1)
	(check-if-aplti-subtype?
	 type-checker marks-new t1 t2)
	#f))
   (else '())))


(define (do-modifier-checks? type-checker marks-new t1 t2)
  (cond
   ((is-splice-expression? t1)
    (if (is-splice-expression? t2)
	(check-if-splice-subtype?
	 type-checker marks-new t1 t2)
	#f))
   ((is-rest-expression? t1)
    (if (is-rest-expression? t2)
	(check-if-rest-subtype?
	 type-checker marks-new t1 t2)
	#f))
   ((is-type-list? t1)
    (if (is-type-list? t2)
	(check-if-type-list-subtype?
	 type-checker marks-new t1 t2)
	#f))
   ((is-join-expression? t1)
    (if (is-join-expression? t2)
	(check-if-join-subtype?
	 type-checker marks-new t1 t2)
	#f))
   ((is-type-loop? t1)
    (if (is-type-loop? t2)
	(check-if-loop-subtype?
	 type-checker marks-new t1 t2)
	#f))
   (else '())))


(define (do-class-checks? type-checker marks-new t1 t2)
  (let ((inst1?
	 (is-param-class-instance? t1))
	(inst2?
	 (is-param-class-instance? t2))
	(cl1? (is-class? t1))
	(cl2? (is-class? t2)))
    (assert (not (and inst1? (not cl1?))))
    (assert (not (and inst2? (not cl2?))))
    (cond
     ((and cl1? inst2?)
      (check-if-param-inst-subclass?
       type-checker marks-new t1 t2))
     ((and cl1? cl2?)
      (is-simple-class-subtype? t1 t2))
     (else '()))))


(define (do-sgn-checks? type-checker marks-new t1 t2)
  (let* ((sgn1? (is-signature? t1))
	 (sgn2? (is-signature? t2)))
    (cond
     ((and (not sgn1?) sgn2?)
      (check-if-implements-signature? type-checker marks-new t1 t2))
     ((and sgn1? sgn2?)
      (check-if-subsignature? type-checker marks-new t1 t2))
     ;; Here we already know that sgn2 is not <object>.
     ((and sgn1? (not sgn2?))
      #f)
     (else '()))))


(define (check-if-subtype? type-checker marks t10 t20)
  (dwl "check-if-subtype?")
  (cond
   ((general-member (cons t10 t20) marks pair-contents-eqv?)
    (dwl "check-if-subtype? EXIT 1")
    #t)
   (else
    (let ((marks-new (cons (cons t10 t20) marks)))
      (dwl "check-if-subtype?/1")
      (let* ((t1 (handle-singleton t10))
	     (t2 (handle-singleton t20))
	     (res1
	      (do-basic-subtype-checks? type-checker marks-new t1 t2))
	     (res2
	      (if (boolean? res1)
		  res1
		  (do-sgn-checks? type-checker marks-new t1 t2)))
	     (res3
	      (if (boolean? res2)
		  res2
		  (do-union-checks? type-checker marks-new t1 t2)))
	     (res4
	      (if (boolean? res3)
		  res3
		  (do-none-checks? type-checker marks-new t1 t2)))
	     (res5
	      (if (boolean? res4)
		  res4
		  (do-pair-checks? type-checker marks-new t1 t2)))
	     (res6
	      (if (boolean? res5)
		  res5
		  (do-proc-type-checks? type-checker marks-new t1 t2)))
	     (res7
	      (if (boolean? res6)
		  res6
		  (do-vector-class-checks? type-checker marks-new t1 t2)))
	     (res8
	      (if (boolean? res7)
		  res7
		  (do-apti-checks? type-checker marks-new t1 t2)))
	     (res9
	      (if (boolean? res8)
		  res8
		  (do-modifier-checks? type-checker marks-new t1 t2)))
	     (res10
	      (if (boolean? res9)
		  res9
		  (do-class-checks? type-checker marks-new t1 t2)))
	     (result
	      (if (boolean? res10) res10 #f)))
	(dwl "check-if-subtype? EXIT 2")
	result)))))


(set! check-if-subtype-forward? check-if-subtype?)


;; NOTE: This procedure is allowed to return #f in case
;; t1 is a subtype of t2.
(define (is-subtype? t1 t2)
  ;;  (dwl "is-subtype?")
  (let ((type-checker (vector-ref gl-rte i-rte-type-checker)))
    (check-if-subtype? type-checker '() t1 t2)))


;; NOTE: no _b_<complex>
(define (is-instance? to tc)
  (cond
   ((eq? tc _b_<object>) #t)
   ((eq? tc _b_<null>) (or (null? to) (eq? to _b_nil)))
   ((eq? tc _b_<character>) (char? to))
   ((eq? tc _b_<real>) (is-real? to))
   ((eq? tc _b_<integer>) (is-integer? to))
   ;;   ((eq? tc _b_<complex>) (complex? to))
   ((eq? tc _b_<boolean>) (boolean? to))
   ((eq? tc _b_<symbol>) (symbol? to))
   ((eq? tc _b_<string>) (string? to))
   (else (is-subtype? (theme-class-of to) tc))))


(set! is-instance-forward? is-instance?)


(define (is-param-inst-subclass? t1 t2)
  (let ((type-checker (vector-ref gl-rte i-rte-type-checker)))
    (check-if-param-inst-subclass? type-checker '() t1 t2)))


;; Precondition: tc has to be a simple class.
;; This procedure is not used for optimizing checks of primitive classes.
(define (is-instance-of-simple-class? to tc)
  (is-simple-class-subtype? (theme-class-of to) tc))
;;  (is-subtype? (theme-class-of to) tc))


;; Precondition: tc has to be a simple class or an instance of a
;; parametrized class.
;; This procedure is not used for optimizing checks of primitive classes.
(define (is-instance-of-class? to tc)
  (is-param-inst-subclass? (theme-class-of to) tc))
  ;; (is-subtype? (theme-class-of to) tc))


;; We must not use _i_make-param-class in toplevel definitions before defining is-instance?.
(define (_i_make-param-class name c-params params instance-superclass
			     instance-fields
			     inh? imm? ebv?
			     instance-has-constructor?
			     instance-ctr-access)
  (assert (is-instance? instance-superclass _b_<class>))
  (_i_make-param-class0 name c-params params instance-superclass instance-fields
			inh? imm? ebv? instance-has-constructor?
			instance-ctr-access))


;; *** Deduction of type parameters ***


(define deduce-type-params0-fwd '())


(define (gen-car obj)
  (cond
   ((pair? obj) (car obj))
   ;; Abstract pair classes are not allowed.
   ((is-pair-class? obj)
    (get-pair-first-type obj))
   (else (my-raise 'gen-car:invalid-argument))))


(define (gen-cdr obj)
  (cond
   ((pair? obj) (cdr obj))
   ;; Abstract pair classes are not allowed.
   ((is-pair-class? obj)
    (get-pair-second-type obj))
   (else (my-raise 'gen-cdr:invalid-argument))))


(define (is-gen-pair? obj)
  ;; Return #f for abstract pair classes.
  (or (pair? obj) (is-pair-class? obj)))


(define (get-components-for-deduction obj)
  (cond
   ((or (null? obj)
	(eq? obj _b_<null>)
	(is-gen-pair? obj))
    obj)
   ((is-param-proc-class? obj)
    (get-components (vector-ref obj i-ppc-inst-type)))
   (else
    (get-components obj))))


;; Argument visited1 is not checked currently.
(define (deduce-subreprs tvars argument-translator all-type-vars t1 t2
			 visited)
  (dwl "deduce-subreprs")
  (assert (is-alo? tvars))
  (assert (is-argument-translator? argument-translator))
  ;; Is the following check correct?
  (strong-assert (is-gen-pair? t1))
  ;;  (assert (is-normal-object? t2))
  (assert (list? visited))
  (dwl "deduce-subreprs/1")
  (let* ((t1-new
	  (if (pair? t1)
	      (cons
	       (get-components-for-deduction (car t1))
	       (cdr t1))
	      (let ((hd (get-components-for-deduction (gen-car t1)))
		    (tl (gen-cdr t1)))
		(cons hd tl))))
	 (cmp2 (get-components-for-deduction t2)))

    ;; TO BE REMOVED
    ;; (if gl-flag?
    ;; 	(begin
    ;; 	  (dvar1-set! t1)
    ;; 	  (dvar2-set! t2)
    ;; 	  (dvar3-set! t1-new)
    ;; 	  (dvar4-set! cmp2)
    ;; 	  (my-raise 'debug-stop)))

    (deduce-type-params0-fwd tvars
			     argument-translator
			     all-type-vars
			     t1-new
			     cmp2
			     visited)
    (dwl "deduce-subreprs EXIT")
    (gen-cdr t1)))


(define (deduce-union-x tvars argument-translator all-type-vars
			t1 t2 visited)
  (assert (is-alo? tvars))
  (assert (is-argument-translator? argument-translator))
  (assert (and (list? all-type-vars)
	       (and-map? is-tvar-object? all-type-vars)))
  (assert (is-union-type? t1))
  ;;  (assert (is-normal-object? t2))
  (assert (list? visited))
  (let ((union-members (vector-ref t1 i-union-member-types)))
    (for-each
     (lambda (union-member)
       (deduce-type-params0-fwd tvars argument-translator all-type-vars
				(list union-member) t2
				visited))
     union-members)))


(define (deduce-x-union tvars argument-translator all-type-vars
			t1 t2 visited)
  (dwl "deduce-x-union ENTER")
  (assert (is-alo? tvars))
  (assert (is-argument-translator? argument-translator))
  (assert (and (list? all-type-vars)
	       (and-map? is-tvar-object? all-type-vars)))
  ;;  (assert (is-normal-object? t1))
  (assert (is-union-type? t2))
  (assert (list? visited))
  (dwl "deduce-x-union/1")
  (let* ((union-members (vector-ref t2 i-union-member-types))
	 (tmp1 (begin (dwl "deduce-x-union/2") 0))
	 (result
	  (for-each
	   (lambda (union-member)
	     (deduce-type-params0-fwd tvars argument-translator all-type-vars
				      t1 union-member
				      visited))
	   union-members)))
    (dwl "deduce-x-union EXIT")
    result))


(define (deduce-union-union tvars argument-translator all-type-vars
			    t1 t2 visited)
  (assert (is-alo? tvars))
  (assert (is-argument-translator? argument-translator))
  (assert (and (list? all-type-vars)
	       (and-map? is-tvar-object? all-type-vars)))
  (assert (is-union-type? t1))
  (assert (is-union-type? t2))
  (assert (list? visited))
  (let ((union-members1 (vector-ref t1 i-union-member-types))
	(union-members2 (vector-ref t2 i-union-member-types)))
    (do ((lst1 union-members1 (cdr lst1))
	 (lst2 union-members2 (cdr lst2)))
	((or (null? lst1) (null? lst2)))
      (deduce-type-params0-fwd tvars argument-translator all-type-vars
			       (list (car lst1))
			       (car lst2)
			       visited))))


(define (deduce-type-loop tvars argument-translator all-type-vars
			  src-args type-loop visited)
  (assert (is-alo? tvars))
  (assert (is-argument-translator? argument-translator))
  (assert (and (list? all-type-vars)
	       (and-map? is-tvar-object? all-type-vars)))
  (assert (list? src-args))
  (assert (is-type-loop? type-loop))
  (assert (list? visited))
  (let ((iter-var (vector-ref type-loop i-type-loop-iter-var))
	(subtype-list (vector-ref type-loop i-type-loop-subtype-list))
	(iter-expr (vector-ref type-loop i-type-loop-iter-expr)))
    (let* ((deduced-items '())
	   (source-list0 (car src-args))
	   (source-list
	    (cond
	     ((list? source-list0)
	      source-list0)
	     ((is-type-list? source-list0)
	      (vector-ref source-list0 i-type-list-subexprs))
	     ((is-tuple-type? source-list0)
	      (tuple-type->list-reject-cycles source-list0))
	     (else (my-raise 'error-in-type-deduction-of-loops))))
	   (all-type-vars1 (cons iter-var all-type-vars)))
      (do ((cur-src source-list (cdr cur-src)))
	  ((null? cur-src))
	(let ((new-tvar-values (make-alo (vector-ref tvars i-alo-bindings)
					 tvar-object=?)))
	  (deduce-type-params0-fwd new-tvar-values argument-translator
				   all-type-vars1
				   cur-src iter-expr visited)
	  (let ((new-deduction (alo-fetch new-tvar-values iter-var)))
	    (set! deduced-items
		  (append deduced-items (list new-deduction))))))
      (let ((result
	     (cond
	      ((memv #f deduced-items)
	       (cdr src-args))
	      ((and (is-tvar-object? subtype-list)
		    (not (alo-exists? tvars subtype-list)))
	       (alo-add-binding! tvars subtype-list
				 (create-type-list
				  (map cdr deduced-items)))
	       (cdr src-args))
	      (else
	       (let ((types
		      (map* (lambda (item)
			      (let* ((bindings
				      (append
				       (vector-ref tvars i-alo-bindings)
				       (list item)))
				     (repr
				      (substitute-tvar-objects
				       iter-expr bindings)))
				repr))
			    deduced-items)))
		 (deduce-type-params0 tvars argument-translator
				      all-type-vars src-args types
				      visited))))))
	result))))


(define (deduce-rest-expression tvars argument-translator all-type-vars
				src-args target-type visited)
  (assert (is-alo? tvars))
  (assert (is-argument-translator? argument-translator))
  (assert (and (list? all-type-vars)
	       (and-map? is-tvar-object? all-type-vars)))
  (assert (list? src-args))
  (assert (is-rest-expression? target-type))
  (assert (list? visited))
  (let* ((target-item-type (vector-ref target-type i-rest-component))
	 (result
	  (deduce-type-params0-fwd tvars argument-translator
				   all-type-vars src-args target-item-type
				   visited)))
    result))


(define (add-new-tvar-binding! tvars argument-translator tvar type)
  (assert (is-alo? tvars))
  (assert (is-argument-translator? argument-translator))
  (assert (is-tvar-object? tvar))

  ;; TO BE REMOVED
  ;; (if (= (vector-ref tvar i-tvar-object-number) 48)
  ;;     (begin
  ;; 	(dvar1-set! type)
  ;; 	(my-raise 'tvar-stop)))

  (let ((val
	 (if (list? type)
	     (construct-toplevel-type-repr argument-translator type)
	     (construct-argument-type-repr argument-translator type))))
    (alo-add-binding! tvars tvar val)))


(define (update-tvar-assoc! p-binding tvar-new x-new-src)
  (if1 (contains-specified-tvar-objects? (mcdr p-binding) (list tvar-new))
       (let* ((l-assoc (list (cons tvar-new x-new-src)))
	      (x-new-value (substitute-tvar-objects (mcdr p-binding)
						    l-assoc)))
	 (set-mcdr! p-binding x-new-value))))


(define (update-tvar-table! tvars tvar-new x-new-src)
  (let ((bindings (vector-ref tvars i-alo-bindings)))
    (for-each (lambda (p-binding)
		(update-tvar-assoc! p-binding tvar-new x-new-src))
	      bindings)))


(define (check-new-tvar tvars tvar-new x-new-src)
  (let ((l-tvars (map car (vector-ref tvars i-alo-bindings))))
    (if (contains-specified-tvar-objects? x-new-src l-tvars)
	(let* ((l-bindings (vector-ref tvars i-alo-bindings))
	       (l-new-bindings
		(map (lambda (tvar)
		       (general-assoc tvar l-bindings tvar-object=?))
		     l-tvars)))
	  (substitute-tvar-objects x-new-src l-new-bindings))
	x-new-src)))


(define (deduce-simple-type tvars argument-translator all-type-vars
			    source-list target-type visited)
  (dwl2 "deduce-simple-type ENTER")
  (assert (is-alo? tvars))
  (assert (is-argument-translator? argument-translator))
  (assert (and (list? all-type-vars)
	       (and-map? is-tvar-object? all-type-vars)))
  (assert (list? visited))
  (dwl2 "deduce-simple-type/1")

  ;; TO BE REMOVED
  ;; (if (= gl-ctr1 6)
  ;;     (begin
  ;; 	(dvar1-set! source-list)
  ;; 	(dvar2-set! target-type)
  ;; 	(dvar3-set! tvars)
  ;; 	(dvar4-set! all-type-vars)
  ;; 	(my-raise 'debug-stop)))

  (let ((result
	 (if (is-gen-pair? source-list)
	     (let ((src (gen-car source-list)))
	       (dwl2 "deduce-simple-type/2")
	       (if1 (and
		     (is-tvar-object? target-type)
		     (general-member target-type all-type-vars tvar-object=?)
		     (not (alo-exists? tvars target-type))
		     (not (contains-unbound-tvars? src)))
		    (begin
		      (dwl2 "deduce-simple-type/3")
		      (update-tvar-table! tvars target-type src)
		      (dwl2 "deduce-simple-type/4")
		      (let ((src2 (check-new-tvar tvars target-type src)))
			(dwl2 "deduce-simple-type/5")
			(add-new-tvar-binding! tvars argument-translator
					       target-type src))))
	       (dwl2 "deduce-simple-type/6")
	       (gen-cdr source-list))
	     source-list)))
    (dwl2 "deduce-simple-type EXIT")
    result))


(define (deduce-pair-class tvars argument-translator all-type-vars
			   t1 t2 visited)
  (dwl "deduce-pair-class")
  ;; If t1 does not fulfill the following condition
  ;; should we just do nothing instead of giving an error?
  (assert (is-gen-pair? t1))
  (assert (is-gen-pair? t2))

  ;; TO BE REMOVED
  ;; (if gl-flag?
  ;;     (begin
  ;; 	(dvar1-set! t1)
  ;; 	(dvar2-set! t2)
  ;; 	(my-raise 'stop)))

  (let ((src (gen-car t1)))
    (if1 (is-gen-pair? src)
	 (begin
	   (deduce-type-params0-fwd tvars argument-translator all-type-vars
				    src (gen-car t2) visited)
	   (deduce-type-params0-fwd tvars argument-translator all-type-vars
				    (list (gen-cdr src)) (gen-cdr t2)
				    visited)))
    (gen-cdr t1)))


(define (arg-list-desc->list arg-list-desc)
  (cond
   ((is-type-list? arg-list-desc)
    (vector-ref arg-list-desc i-type-list-subexprs))
   ;; We don't handle the case where arg-list-desc is not a normal tuple type.
   ((is-tuple-type? arg-list-desc)
    (tuple-type->list-reject-cycles arg-list-desc))
   (else '())))


(define select-best-method-class-fwd '())


;; NOTE: We don't handle the case where t1 has a rest argument.
;; The result value of the following procedure has no significance.
(define (deduce-gen-proc-abst-proc-result tvars argument-translator
					  all-type-vars
					  gp target-arg-list target-result
					  visited)
  (dwl2 "deduce-gen-proc-abst-proc-result ENTER")
  (assert (is-gen-proc-class? gp))
  (dvar1-set! gp)
  (dwl "deduce-gen-proc-abst-proc-result/1")
  (let* ((method-classes (vector-ref gp i-param-class-inst-type-var-values))
	 (best-method-class (select-best-method-class-fwd target-arg-list
							  method-classes)))

    ;; TO BE REMOVED
    ;; (if gl-flag2?
    ;; 	(begin
    ;; 	  (dvar1-set! target-arg-list)
    ;; 	  (dvar2-set! method-classes)
    ;; 	  (my-raise 'stop2)))

    (if (not (symbol? best-method-class))
	;; Maybe we should also handle the case where the
	;; dispatch result is ambiguous.
	(begin
	  (dwl2 "best method found")
	  (let ((best-result-type
		 (cond
		  ((is-simple-proc-class? best-method-class)
		   (vector-ref best-method-class
			       i-procedure-class-result-type))
		  ((is-param-proc-class? best-method-class)
		   (vector-ref (vector-ref best-method-class i-ppc-inst-type)
			       i-procedure-class-result-type))
		  (else (my-raise 'internal-error-with-method)))))
	    (deduce-type-params0 tvars argument-translator all-type-vars
				 (list best-result-type) target-result
				 visited)))
	(begin
	  (dwl2 "best method not found"))))
  (dwl2 "deduce-gen-proc-abst-proc-result EXIT"))


;; The result value of the following procedure has no significance.
(define (deduce-gen-proc-abst-proc-arg-list tvars argument-translator
					    all-type-vars
					    gp target-arg-list target-result
					    visited)
  (dwl2 "deduce-gen-proc-abst-proc-arg-list ENTER")
  (assert (is-gen-proc-class? gp))
  (dvar1-set! gp)
  (let* ((method-classes (vector-ref gp i-param-class-inst-type-var-values))
	 (best-method-class (select-best-method-class-fwd target-arg-list
							  method-classes)))
    (if (not (symbol? best-method-class))
	;; Maybe we should also handle the case where the
	;; dispatch result is ambiguous.
	(begin
	  (dwl2 "best method found")
	  (let ((best-arg-list-type
		 (cond
		  ((is-simple-proc-class? best-method-class)
		   (vector-ref best-method-class
			       i-procedure-class-arg-list-type))
		  ((is-param-proc-class? best-method-class)
		   (vector-ref (vector-ref best-method-class i-ppc-inst-type)
			       i-procedure-class-arg-list-type))
		  (else (my-raise 'internal-error-with-method)))))
	    (deduce-type-params0 tvars argument-translator all-type-vars
				 (list best-arg-list-type) target-arg-list
				 visited)))
	(begin
	  (dwl2 "best method not found"))))
  (dwl2 "deduce-gen-proc-abst-proc-arg-list EXIT"))


(define (deduce-gen-proc-abst-proc tvars argument-translator all-type-vars
				   t1 t2 visited)
  (dwl2 "deduce-gen-proc-abst-proc ENTER")
  (assert (is-gen-proc-class? t1))
  (assert (is-abstract-proc-type? t2))
  (let* ((target-arg-list (arg-list-desc->list
			   (vector-ref t2 i-procedure-class-arg-list-type)))
	 (target-result (vector-ref t2 i-procedure-class-result-type))
	 (tvars1? (contains-tvar-objects? target-arg-list))
	 (tvars2? (contains-tvar-objects? target-result)))
    (if1 tvars1?
	 (deduce-gen-proc-abst-proc-arg-list tvars argument-translator
					     all-type-vars
					     t1 target-arg-list target-result
					     visited))
    (if1 tvars2?
	 (deduce-gen-proc-abst-proc-result tvars argument-translator
					   all-type-vars
					   t1 target-arg-list target-result
					   visited))
    (dwl2 "deduce-gen-proc-abst-proc EXIT")))


(define (deduce-sgn-sgn tvars argument-translator
			all-type-vars
			t1 t2 visited)
  (assert (is-signature? t1))
  (assert (is-signature? t2))
  (let ((l-members1 (vector-ref t1 i-signature-members))
	(l-members2 (vector-ref t2 i-signature-members)))
    (do ((l-cur2 l-members2 (cdr l-cur2)))
	((null? l-cur2))
      (let ((o-cur2 (car l-cur2)))
	(do ((l-cur1 l-members1 (cdr l-cur1)))
	    ((null? l-cur1))
	  (let ((o-cur1 (car l-cur1)))
	    (if1 (eq? (car o-cur1) (car o-cur2))
		 (deduce-type-params0 tvars argument-translator all-type-vars
				      (list (cdr o-cur1)) (cdr o-cur2)
				      visited))))))))


(define (deduce-not-sgn-sgn tvars argument-translator
			    all-type-vars
			    t1 t2 visited)
  (assert (not (is-signature? t1)))
  (assert (is-signature? t2))
  (let ((l-members (vector-ref t2 i-signature-members)))
    (do ((l-cur l-members (cdr l-cur))) ((null? l-cur))
      (let* ((to (theme-class-of (car (car l-cur))))
	     (to-type (cdr (car l-cur)))
	     (al-bindings (list (cons _b_this t1)))
	     (to-new-type (substitute-tvar-objects to-type al-bindings)))
	(deduce-type-params0 tvars argument-translator
			     all-type-vars (list to) to-new-type
			     visited)))))


(define (handle-type-list type)
  (if (is-type-list? type)
      (vector-ref type i-type-list-subexprs)
      type))


(define (handle-general-list lst)
  (cond
   ((null? lst) '())
   ((eq? lst _b_<null>) '())
   ((is-type-list? lst) (vector-ref lst i-type-list-subexprs))
   ((pair? lst)
    (cons (handle-general-list (car lst))
	  (handle-general-list (cdr lst))))
   ((is-pair-class? lst)
    (_i_get-pair-class-general
     (list
      (handle-general-list (gen-car lst))
      (handle-general-list (gen-cdr lst)))))
   (else lst)))


(define (handle-source-splice type)
  (assert (is-gen-pair? type))
  (let ((hd (gen-car type)))
    (if (is-instance? hd _b_<splice>)
	(vector-ref hd i-splice-component)
	type)))

(define (prepare-source-type type)
  (handle-source-splice
   (if (pair? type)
       (cons
	(handle-type-list (handle-singleton (car type)))
	(cdr type))
       ;; _i_get-pair-class caused an infinite loop.
       (_i_get-pair-class0
	(handle-type-list (handle-singleton (gen-car type)))
	(gen-cdr type)))))


(define (deduce-type-params0 tvars argument-translator all-type-vars
			     t1 t2 visited)
  (dwl2 "deduce-type-params0")
  (debug-prt t1)
  (debug-prt t2)
  (assert (is-alo? tvars))
  (assert (is-argument-translator? argument-translator))
  (assert (and (list? all-type-vars)
	       (and-map? is-tvar-object? all-type-vars)))
  (assert (list? visited))
  (dwl "deduce-type-params0/1")
  (dvar1-set! t1)
  (dvar2-set! t2)
  (cond
   ((not (is-gen-pair? t1))
    (if (is-instance? t2 _b_<splice>)
	(deduce-type-params0 tvars argument-translator all-type-vars
			     (list (handle-type-list t1))
			     (vector-ref t2 i-splice-component)
			     visited)
	;; This may be an error situation
	#f))
   ((general-member (cons (gen-car t1) t2) visited eq-pairs?)
    '())
   (else
    (let ((new-visited (cons (cons (gen-car t1) t2) visited)))
      ;; Not sure if the following code is correct if the expressions
      ;; t1 and t2 contain both singletons and type lists.
      (let* ((tt1 (prepare-source-type t1))
	     (tt2 (handle-type-list (handle-singleton t2))))
	(dwl "deduce-type-params0/3")
	(if (contains-tvar-objects? tt2)
	    (cond
	     ((is-tvar-object? tt2)	
	      (dwl "tvar")
	      (deduce-simple-type tvars argument-translator
				  all-type-vars tt1 tt2
				  new-visited))
	     ((and (is-signature? (gen-car tt1)) (is-signature? tt2))
	      (deduce-sgn-sgn tvars argument-translator
			      all-type-vars (gen-car tt1) tt2
			      new-visited))
	     ((and (not (is-signature? (gen-car tt1)))
		   (is-signature? tt2))
	      (deduce-not-sgn-sgn tvars argument-translator
				  all-type-vars (gen-car tt1) tt2
				  new-visited))
	     ((and (is-signature? (gen-car tt1))
		   (not (is-signature? tt2)))
	      #f)
	     ((is-gen-pair? tt2)
	      (dwl "pair")
	      (deduce-pair-class tvars argument-translator
				 all-type-vars tt1 tt2
				 new-visited))
	     ((is-rest-expression? tt2)
	      (dwl "rest")
	      (deduce-rest-expression tvars argument-translator
				      all-type-vars tt1 tt2
				      new-visited))
	     ((is-splice-expression? tt2)
	      (dwl "splice")
	      (deduce-type-params0 tvars argument-translator
				   all-type-vars
				   (list tt1)
				   (vector-ref tt2 i-splice-component)
				   new-visited))
	     ((not (is-gen-pair? tt1))
	      ;; This may be an error situation.
	      #f)
	     ((is-type-loop? tt2)
	      (dwl "type loop")
	      (deduce-type-loop tvars argument-translator
				all-type-vars tt1 tt2
				new-visited))
	     (else
	      (let ((u1? (is-union-type? (gen-car tt1)))
		    (u2? (is-union-type? tt2)))
		(cond
		 ((and u1? (not u2?))
		  (dwl "union-x")
		  (deduce-union-x tvars argument-translator
				  all-type-vars (gen-car tt1) tt2
				  new-visited)
		  (gen-cdr tt1))
		 ((and (not u1?) u2?)
		  (dwl "x-union")
		  (deduce-x-union tvars argument-translator
				  all-type-vars tt1 tt2
				  new-visited)
		  (gen-cdr tt1))
		 ((and u1? u2?)
		  (dwl "union-union")
		  (deduce-union-union tvars argument-translator
				      all-type-vars (gen-car tt1) tt2
				      new-visited)
		  (gen-cdr tt1))
		 (else
		  (dwl "deduce else")
		  (if (and (is-gen-proc-class? (gen-car tt1))
			   (is-abstract-proc-type? tt2))
		      (begin
			(deduce-gen-proc-abst-proc tvars argument-translator
						   all-type-vars
						   (gen-car tt1) tt2
						   new-visited)
			(gen-cdr tt1))
		      (begin
			(dwl "subreprs")
			;; The following procedure can also be called
			;; in case t2 has not got any components.
			(deduce-subreprs tvars argument-translator
					 all-type-vars tt1 tt2
					 new-visited))))))))
	    (gen-cdr tt1)))))))


(set! deduce-type-params0-fwd deduce-type-params0)


;; We optimize slightly.
;; The procedure returns #t for no type variables.
(define (deduced-all-tvars? tvars all-type-vars)
  (let ((bindings (vector-ref tvars i-alo-bindings)))
    (and-map? (lambda (tvar)
		(not (eq? (general-assoc tvar bindings tvar-object=?) #f)))
	      all-type-vars)))


(define (get-tvar tvar-list var)
  (assert (is-instance? tvar-list <singleton>))
  (if1 (and
	(is-instance? var <tvar-object>)
	(not (general-member var (vector-ref tvar-list i-singleton-element)
		     tvar-object=?)))
       (vector-set! tvar-list i-singleton-element
		    (cons var (vector-ref tvar-list i-singleton-element)))))


(define (get-all-tvars0 tvar-list obj visited bound-tvars)
  (cond
   ((null? obj) '())
   ((memv obj visited) '())
   ((pair? obj)
    (let ((new-visited (cons obj visited)))
      (get-all-tvars0 tvar-list (car obj) new-visited bound-tvars)
      (get-all-tvars0 tvar-list (cdr obj) new-visited bound-tvars)))
   ((is-tvar-object? obj)
    (if (not (general-member obj bound-tvars tvar-object=?))
	(get-tvar tvar-list obj)
	'()))
   ((is-param-proc-class? obj)
    (get-all-tvars0 tvar-list
		    (vector-ref obj i-ppc-inst-type)
		    (cons obj visited)
		    bound-tvars))
   ((is-type-loop? obj)
    (let ((new-bound-tvars (append bound-tvars
				   (list (vector-ref
					  obj i-type-loop-iter-var))))
	  (new-visited (cons obj visited))
	  (subtype-list (vector-ref obj i-type-loop-subtype-list))
	  (iter-expr (vector-ref obj i-type-loop-iter-expr)))
      (get-all-tvars0 tvar-list subtype-list
		      new-visited new-bound-tvars)
      (get-all-tvars0 tvar-list iter-expr
		      new-visited new-bound-tvars)))
   (else
    (let ((subcmps (get-components obj))
	  (new-visited (cons obj visited)))
      (if (not-null? subcmps)
	  (for-each (lambda (subcmp)
		      (get-all-tvars0 tvar-list subcmp
				      new-visited bound-tvars))
		    subcmps)
	  '())))))


(define (get-all-tvars obj)
  (dwl "get-all-tvars")
  (let ((tvar-list (make-singleton '())))
    (get-all-tvars0 tvar-list obj '() '())
    (dwl "get-all-tvars/1")
    ;; Reversion of the list is probably not necessary.
    (reverse (vector-ref tvar-list i-singleton-element))))


(set! get-all-tvars-fwd get-all-tvars)


;; The following procedure does not check recursive data structures.
;; (define (make-tvars-unique old-tvars obj)
;;   (let* ((tva (vector-ref gl-rte i-rte-tvar-allocator))
;; 	 (nr-of-tvars (length old-tvars))
;; 	 (first-tvar-number (tva-alloc tva nr-of-tvars))
;; 	 (new-tvars (map make-tvar-object
;; 			 (get-integer-sequence first-tvar-number
;; 					       nr-of-tvars)))
;; 	 (bindings (map cons old-tvars new-tvars))
;; 	 (new-obj (substitute-tvar-objects obj bindings)))
;;     (cons new-obj new-tvars)))


;; (define (make-tvars-unique20 obj tva-starts bindings visited changes markers)
;;   (dwl "make-tvars-unique20")
;;   (assert (list? bindings))
;;   (assert (is-singleton? tva-starts))
;;   (assert (list? visited))
;;   (assert (is-alo? changes))
;;   (assert (is-singleton? markers))
;;   (cond
;;    ((null? obj) '())
;;    ((eq? obj _b_<null>) _b_<null>)
;;    ((memv obj visited)
;;     (let ((marker (make-marker obj))
;; 	  (marker-list (get-singleton-element markers)))
;;       (if1 (not (member marker marker-list marker=?))
;; 	   (set-singleton-element!
;; 	    markers
;; 	    (cons marker marker-list)))
;;       marker))
;;    ((pair? obj)
;;     (let ((new-visited (cons obj visited)))
;;       (cons
;;        (make-tvars-unique20
;; 	(car obj) tva-starts bindings new-visited changes markers)
;;        (make-tvars-unique20
;; 	(cdr obj) tva-starts bindings new-visited changes markers))))
;;    ((is-pair-class? obj)
;;     (let ((new-visited (cons obj visited)))
;;       (_i_get-pair-class
;;        (make-tvars-unique20
;; 	(gen-car obj) tva-starts bindings new-visited changes markers)
;;        (make-tvars-unique20
;; 	(gen-cdr obj) tva-starts bindings new-visited changes markers))))
;;    ((is-tvar-object? obj)
;;     (let* ((b (assoc obj bindings tvar-object=?))
;; 	   (result
;; 	    (if (not (eqv? b #f)) (cdr b) obj)))
;;       result))
;;    ((is-param-proc-class? obj)
;;     (let* ((tva (vector-ref gl-rte i-rte-tvar-allocator))
;; 	   (new-visited (cons obj visited))
;; 	   (old-tvars (vector-ref obj i-ppc-tvars))
;; 	   (nr-of-tvars (length old-tvars))
;; 	   (first-tvar-number (tva-alloc tva nr-of-tvars))
;; 	   (new-tvars (map make-tvar-object
;; 			   (get-integer-sequence first-tvar-number
;; 						 nr-of-tvars)))
;; 	   (new-bindings
;; 	    (map cons old-tvars new-tvars))
;; 	   (all-bindings (append new-bindings bindings))
;; 	   (components (get-components obj))
;; 	   (processed (map* (lambda (component)
;; 			      (make-tvars-unique20 component tva-starts
;; 						   all-bindings
;; 						   new-visited changes
;; 						   markers))
;; 			    components))
;; 	   (transformer (make-transformer))
;; 	   (new-object (clone-with-branches transformer obj processed)))
;;       (set-singleton-element! tva-starts
;; 			      (cons first-tvar-number
;; 				    (get-singleton-element tva-starts)))
;;       new-object))
;;    ((is-type-loop? obj)
;;     (let* ((tva (vector-ref gl-rte i-rte-tvar-allocator))
;; 	   (new-visited (cons obj visited))
;; 	   (first-tvar-number (tva-alloc tva 1))
;; 	   (new-iter-var (make-tvar-object first-tvar-number))
;; 	   (new-bindings
;; 	    (let ((old-iter-var (vector-ref obj i-type-loop-iter-var)))
;; 	      (list (cons old-iter-var new-iter-var))))
;; 	   (all-bindings (append new-bindings bindings))
;; 	   (components (get-components obj))
;; 	   (processed (map* (lambda (component)
;; 			      (make-tvars-unique20 component tva-starts
;; 						   all-bindings
;; 						   new-visited changes
;; 						   markers))
;; 			    components))
;; 	   (new-subtype-list (car processed))
;; 	   (new-iter-expr (cadr processed))
;; 	   (arg-xlat (vector-ref gl-rte i-rte-arg-xlat))
;; 	   (new-object
;; 	    (construct-type-loop-repr
;; 	     arg-xlat
;; 	     (_i_make-type-loop new-iter-var new-subtype-list new-iter-expr))))
;;       (set-singleton-element! tva-starts
;; 			      (cons first-tvar-number
;; 				    (get-singleton-element tva-starts)))
;;       new-object))
;;    (else
;;     (let ((b2 (alo-fetch changes obj)))
;;       (if (not (eqv? b2 #f))
;; 	  (cdr b2)
;; 	  (if (not (vector? obj))
;; 	      ;; If we enter the following expression we have a primitive object
;; 	      ;; unless an internal error has occurred.
;; 	      obj
;; 	      ;; All vectors should be Theme objects.
;; 	      (let ((components (get-components obj)))
;; 		(if (null? components)
;; 		    obj
;; 		    (let* ((new-visited (cons obj visited))
;; 			   (new-components
;; 			    (map
;; 			     (lambda (comp)
;; 			       (make-tvars-unique20
;; 				comp tva-starts
;; 				bindings new-visited
;; 				changes markers))
;; 			     components))
;; 			   (result
;; 			    (let ((transformer (make-transformer)))
;; 			      (clone-with-branches transformer obj new-components))))
;; 		      ;; We have checked that obj is not already in changes.
;; 		      (alo-add-binding! changes obj result)
;; 		      result)))))))))


;; (define (make-tvars-unique2 obj tva-starts)
;;   (dwl "make-tvars-unique2 ENTER")
;;   (assert (is-singleton? tva-starts))
;;   ;; Theme objects are never empty vectors
;;   ;; so it is safe to use eq? here.
;;   (let* ((changes (make-alo '() eq?))
;; 	 (markers (make-singleton '()))
;; 	 (marker-table (make-alo '() marker=?))
;; 	 (subst
;; 	  (make-tvars-unique20 obj tva-starts '() '() changes markers))
;; 	 (result (fix-cycles subst '()
;; 			     (get-singleton-element markers)
;; 			     marker-table
;; 			     changes)))
;;     (dwl "make-tvars-unique2 EXIT")
;;     result))


(define (deduce-step-forward tvars argument-translator all-type-vars
			     cur-src cur-target
			     old-count old-state)
  (dwl2 "deduce-step-forward")
  (assert (> old-state 0))
  (deduce-type-params0 tvars argument-translator all-type-vars
		       cur-src cur-target '())
  (dwl2 "deduce-step-forward/1")
  (let ((new-count (length (vector-ref tvars i-alo-bindings))))
    (assert (<= new-count (length all-type-vars)))
    (cond
     ((deduced-all-tvars? tvars all-type-vars)
      (list -1 new-count))
     ((= old-count new-count)
      (list (- old-state 1) new-count))
     (else
      (list 2 new-count)))))


(define (deduce-step-backward tvars argument-translator all-type-vars
			      cur-src cur-target
			      old-count old-state)
  (dwl "deduce-step-backward")
  (assert (> old-state 0))
  (deduce-type-params0 tvars argument-translator all-type-vars
		       cur-target cur-src '())
  (dwl "deduce-step-backward/1")
  (let ((new-count (length (vector-ref tvars i-alo-bindings))))
    (assert (<= new-count (length all-type-vars)))
    (cond
     ((deduced-all-tvars? tvars all-type-vars)
      (list -1 new-count))
     ((= old-count new-count)
      (list (- old-state 1) new-count))
     (else
      (list 2 new-count)))))


(define (substitute-arg-bindings1 bindings obj)
  (let* ((pred? (lambda (binding)
		  (contains-tvar-objects? (cdr binding))))
	 (partitions (call-with-values
			 (lambda () (partition pred? bindings))
		       (lambda (a b) (cons a b))))
	 (bindings1 (car partitions))
	 (bindings2 (cdr partitions))
	 (subst1
	  (if (not-null? bindings1)
	      (substitute-tvar-objects obj bindings1)
	      obj))
	 (subst2
	  (if (not-null? bindings2)
	      (substitute-tvar-objects subst1 bindings2)
	      subst1)))
    subst2))


(define (substitute-arg-bindings tvar-table obj)
  (assert (is-alo? tvar-table))
  (let ((bindings (vector-ref tvar-table i-alo-bindings)))
    (substitute-arg-bindings1 bindings obj)))


(define (deduce-argument-types arg-xlat tvar-table all-tvars
			       src target)
  (dwl "deduce-argument-types ENTER")
  (assert (is-argument-translator? arg-xlat))
  (assert (is-alo? tvar-table))
  (assert (null? (vector-ref tvar-table i-alo-bindings)))
  (assert (and (list? all-tvars)
	       (and-map? is-tvar-object? all-tvars)))
  (let ((old-count-src 0)
	(old-count-target 0)
	(cur-src src)
	(cur-target target)
	(state 2)
	(dir-forward? #t))

    (if1 gl-flag2?
	 (begin
	   (dwl2 "D: starting")
	   (debug-prt src)
	   (debug-prt target)))

    (do ((i 0 (+ i 1))) ((<= state 0))
      (dw2 "deduce-argument-types: starting step ")
      (dwl2 i)
      (if dir-forward?
	  (if1 (> state 0)
	       (let ((res
		      (deduce-step-forward tvar-table arg-xlat all-tvars
					   (list cur-src) cur-target
					   old-count-target state)))
		 (set! state (car res))
		 (set! old-count-target (cadr res))
		 (dwl2 "deduce-argument-types: binding target tvars (fwd)")
		 (set! cur-target (substitute-arg-bindings tvar-table target))
		 (dwl2 "deduce-argument-types: binding source tvars (fwd)")
		 (set! cur-src (substitute-arg-bindings tvar-table src))

		 ;; TO BE REMOVED
		 (if1 gl-flag2?
		      (begin
			(dw2 "D: bound tvars (fwd), step ")
			(dwl2 i)
			(debug-prt cur-src)
			(debug-prt cur-target)))))
	  
	  (if1 (> state 0)
	       (let ((res
		      (deduce-step-backward tvar-table arg-xlat all-tvars
					    cur-src (list cur-target)
					    old-count-src state)))
		 (set! state (car res))
		 (set! old-count-src (cadr res))
		 (dwl2 "deduce-argument-types: binding source tvars (bwd)")
		 (set! cur-src (substitute-arg-bindings tvar-table src))
		 (dwl2 "deduce-argument-types: binding target tvars (bwd)")
		 (set! cur-target (substitute-arg-bindings tvar-table target))
		 
		 ;; TO BE REMOVED
		 (if1 gl-flag2?
		      (begin
			(dw2 "D: bound tvars (bwd), step ")
			(dwl2 i)
			(debug-prt cur-src)
			(debug-prt cur-target))))))
      (set! dir-forward? (not dir-forward?)))
    (dwl "deduce-argument-types EXIT")
    (= state -1)))


(set! deduce-argument-types-fwd deduce-argument-types)


;; *** Generic procedure dispatch ***


(define (get-item-at-index fixed-args rest-arg n)
  (dwl "get-item-at-index")
  (if1 (< n 0)
       (my-raise 'internal-negative-index))
  (let ((len (length fixed-args)))
    (if (< n len)
	(list-ref fixed-args n)
	(if (is-empty? rest-arg)
	    (my-raise 'internal-index-out-of-range)
	    rest-arg))))


;;(define is-rest-expression? (get-class-predicate _b_<rest>))


(define (reject-by-length n v-arg-list-descs vb-included)
  (dwl "reject-by-length ENTER")
  ;; (dvar1-set! n)
  ;; (dvar2-set! v-arg-list-descs)
  ;; (dvar3-set! vb-included)
  ;; (my-raise 'stop)
  (let ((k (vector-length v-arg-list-descs)))
    (assert (= k (vector-length vb-included)))
    (dwl "reject-by-length/1")
    (do ((j 0 (+ j 1))) ((>= j k) vb-included)
      (dwl "reject-by-length/2")
      (if1 (vector-ref vb-included j)
	   (let ((cur-list-desc (vector-ref v-arg-list-descs j)))
	     (cond
	      ((is-tuple-type? cur-list-desc)
	       (if1 (not (= n (tuple-type-length cur-list-desc)))
		    (vector-set! vb-included j #f)))
	      ((is-tuple-type-with-tail? cur-list-desc)
	       (if1 (not (>= n (tuple-part-length cur-list-desc)))
		    (vector-set! vb-included j #f)))
	      ((is-type-list? cur-list-desc)
	       (let* ((cur-descs
		       (vector-ref cur-list-desc i-type-list-subexprs))
		      (cur-len (length cur-descs))
		      (has-rest?
		       (and (>= cur-len 1)
			    (is-rest-expression? (mylast cur-descs)))))
		 (if1 (not (or (and (not has-rest?) (= n cur-len))
			       (and has-rest? (>= n (- cur-len 1)))))
		      (vector-set! vb-included j #f))))
	      (else
	       ;; (dvar1-set! n)
	       ;; (dvar2-set! v-arg-list-descs)
	       ;; (dvar3-set! vb-included)
	       (my-raise 'reject-by-length:invalid-arg-list-type)))))))
  (dwl "reject-by-length EXIT"))



(define (reject-mismatches argl-type v-arg-list-types vb-included)
  ;; (dwl "reject-mismatches")
  ;; (dvar1-set! argl-type)
  ;; (dvar2-set! v-arg-list-types)
  ;; (dvar3-set! vb-included)
  ;; (my-raise 'stop)
  (let ((n (vector-length v-arg-list-types)))
    (assert (= (vector-length vb-included) n))
    (do ((i 0 (+ i 1))) ((>= i n))
      ;; Testataan aluksi vb-included, jotta vältetään turhia
      ;; funktion is-subtype? kutsuja.
      ;; (dwl (vector-ref vb-included i))
      ;; (dvar1-set! (vector-ref v-arg-list-types i))
      ;; (dwl "reject-mismatches/2")
      (if1 (or (not (vector-ref vb-included i))
	       (not (is-subtype? argl-type (vector-ref v-arg-list-types i))))
	   (vector-set! vb-included i #f)))))


(define (check-contravariant-inheritance type i v-fixed-args v-rest vb-inh
					 vb-included)
  (dwl2 "check-contravariant-inheritance")

  ;; TBR
;;  (dvar1-set! (vector-ref v-fixed-args 0))
;;  (my-raise 'contrav-stop)

  (let ((k (vector-length vb-inh)))
    (do ((j 0 (+ j 1))) ((>= j k))
      (if (and
	   (vector-ref vb-included j)
	   (is-subtype? (get-item-at-index (vector-ref v-fixed-args j)
					   (vector-ref v-rest j)
					   i)
			type))
	  (vector-set! vb-inh j #t)
	  (vector-set! vb-inh j #f)))))


(define (method-loop index v-fixed-args v-rest-arg vb-included t1 i n)
  (do ((j 0 (+ j 1))) ((>= j n))
    (if1 (and (not (= i j))
	      (vector-ref vb-included j))	
	 (let ((t2 (get-item-at-index
		    (vector-ref v-fixed-args j)
		    (vector-ref v-rest-arg j)
		    index)))
	   (if1 (and (is-subtype? t1 t2) (not (is-subtype? t2 t1)))
		;; t2 is excluded
		(vector-set! vb-included j #f))))))


(define (select-nearest-methods index v-fixed-args v-rest-arg vb-included)
  (let ((n (vector-length vb-included)))
    (do ((i 0 (+ i 1))) ((>= i n))
      (if1 (vector-ref vb-included i)
	   (let ((t1 (get-item-at-index
		      (vector-ref v-fixed-args i)
		      (vector-ref v-rest-arg i)
		      index)))
	     (method-loop index v-fixed-args v-rest-arg vb-included
			  t1 i n))))))


(define (parse-arg-list arg-list-desc)
  (cond
   ((eq? arg-list-desc #f) #f)
   ((is-tuple-type? arg-list-desc)
    (cons (tuple-type->list-reject-cycles arg-list-desc) _b_none))
   ((is-tuple-type-with-tail? arg-list-desc)
    (cons (get-tuple-type-fixed-part arg-list-desc)
	  (get-uniform-list-element-type
	   (get-tuple-type-tail-part arg-list-desc))))
   (else
    (my-raise 'parse-arg-list:invalid-argument-list))))


(define (parse-arg-lists v-arg-list-descs)
  (vector-map parse-arg-list v-arg-list-descs))


(define (select-best-methods-for-arg type i v-fixed-args v-rest vb-included)
  (dwl2 "select-best-methods-for-arg")
  ;; The following call should be unnecessary.
  ;;  (select-applicable-methods type i v-fixed-args v-rest vb-included)
  (let* ((m-count (vector-length v-fixed-args))
	 (vb-inh (make-vector m-count #f)))

    ;; TBR
;;    (dvar1-set! v-fixed-args)
;;    (my-raise 'select-stop)

    (check-contravariant-inheritance type i v-fixed-args v-rest vb-inh
				     vb-included)
    (let* ((vb-exact (vector-map
		      (lambda (b1 b2) (and b1 b2)) vb-included vb-inh))
	   (exact-match? #f))
      ;; Previously we had the stopping condition
      ;; (or (>= j m-count) exact-match?)
      (do ((j 0 (+ j 1))) ((or (>= j m-count)))
	(if1 (vector-ref vb-exact j)
	     (set! exact-match? #t)))
      (if exact-match?
	  (vector-copy-contents vb-exact vb-included)
	  ;; (select-nearest-method type i v-fixed-args v-rest vb-included)))))
	  (select-nearest-methods i v-fixed-args v-rest vb-included)))))


(define (reject-incompatible-param method-classes vb-included)
  (dwl "reject-incompatible-param")
  (let ((len (vector-length vb-included)))
    (assert (= (length method-classes) len))
    (do ((i 0 (+ i 1)) (cur-lst method-classes (cdr cur-lst)))
	((or (>= i len) (null? cur-lst)))
      (if1 (eq? (car cur-lst) #f)
	   (vector-set! vb-included i #f)))))


(define (car1 obj)
  (assert (or (pair? obj) (boolean? obj)))
  (if (eq? obj #f) #f (car obj)))


(define (cdr1 obj)
  (assert (or (pair? obj) (boolean? obj)))
  (if (eq? obj #f) #f (cdr obj)))


(define (vector-count-nonfalse v)
  (let ((i-size (vector-length v))
	(i-count 0))
    (do ((i 0 (+ i 1))) ((>= i i-size) i-count)
      (if (vector-ref v i)
	  (set! i-count (+ i-count 1))
	  (void)))))


(define (do-select-best-methods vb-included v-argl v-arg-list-descs)
  ;; (dwl "do-select-best-methods")
  (let* ((argl (parse-arg-lists v-arg-list-descs))
	 (v-fixed-args (vector-map car1 argl))
	 (v-rest-args (vector-map cdr1 argl)))
    (let ((n (vector-length v-argl))
	  (stop? #f))
      ;; (do ((k 0 (+ k 1))) ((or stop? (>= k n)))
      ;; 	(if (<= (vector-count-nonfalse vb-included) 1)
      ;; 	    (set! stop? #t)
      ;; 	    (select-best-methods-for-arg (vector-ref v-argl k) k
      ;; 					 v-fixed-args v-rest-args
      ;; 					 vb-included))))))
      (do ((k 0 (+ k 1))) ((>= k n))
	(select-best-methods-for-arg (vector-ref v-argl k) k
				     v-fixed-args v-rest-args
				     vb-included)))))


;; Note: The vectors created by the following procedure are not Theme
;; vectors.
(define (select-best-method0 argl method-classes)
  ;; (dwl "select-best-method")
  (let* ((v-argl (list->vector argl))
	 (arg-list-descs
	  (map
	   (lambda (mtc)
	     (if (not (eq? mtc #f))
		 (vector-ref mtc
			     i-procedure-class-arg-list-type)
		 #f))
	   method-classes))
	 (v-arg-list-descs (list->vector arg-list-descs))
	 (argl-type (apply _i_make-tuple-type argl)))
    ;; (dwl "sbm/1")
    (let* ((argcount (vector-length v-argl))
	   (m-count (vector-length v-arg-list-descs))
	   (vb-included (make-vector m-count #t)))
      ;; (dwl "sbm/2")
      (reject-incompatible-param method-classes vb-included)
      (reject-by-length argcount v-arg-list-descs vb-included)
      (reject-mismatches argl-type v-arg-list-descs vb-included)
      ;; (dvar3-set! vb-included)
      ;; (my-raise 'stop)
      (do-select-best-methods vb-included
			      v-argl
			      v-arg-list-descs)
      (let ((i-selected -1))
	;; (dwl "sbm/3")
	(do ((i1 0 (+ i1 1))) ((>= i1 m-count))
	  (if1 (vector-ref vb-included i1)
	       (if (= i-selected -1)
		   (set! i-selected i1)
		   (set! i-selected -2))))
	(case i-selected
	  ((-1) 'not-found)
	  ((-2) 'ambiguous)
	  (else i-selected))))))


(define (process-param-method argl mtc)
  (assert (is-instance? mtc _b_:param-proc))
  (let ((all-tvars (get-all-tvars (cons argl mtc)))
	(tvar-table (make-alo '() tvar-object=?))
	(arg-xlat (make-argument-translator))
	(method-arglist (vector-ref (vector-ref mtc i-ppc-inst-type)
				    i-procedure-class-arg-list-type)))
    (deduce-argument-types arg-xlat tvar-table all-tvars argl method-arglist)
    (if (deduced-all-tvars? tvar-table all-tvars)
	(let ((tvar-values (get-tvar-values2 tvar-table all-tvars)))
	  (assert (= (length tvar-values) (length all-tvars)))
	  (let* ((inst-type (vector-ref mtc i-ppc-inst-type))
		 (bindings (map cons all-tvars tvar-values))
		 (new-inst-type (substitute-arg-bindings1 bindings inst-type)))
	    new-inst-type))
	#f)))


(define (select-best-method argl mts)
  (let* ((method-classes (map (lambda (mt) (vector-ref mt i-object-class)) mts))
	 (processed-classes
	  (map (lambda (mtc)
		 (if (eq? (theme-class-of mtc) _b_:param-proc)
		     (process-param-method argl mtc)
		     mtc))
	       method-classes)))
    ;; (assert (and-map? (lambda (cl) (or (eq? cl #f)
    ;; 				       (is-simple-proc-class? cl)))
    ;; 		      processed-classes))
    (let ((selection (select-best-method0 argl processed-classes)))
      (if (symbol? selection)
	  selection
	  (begin
	    (assert (integer? selection))
	    (cons
	     (list-ref mts selection)
	     (list-ref processed-classes selection)))))))


(define (select-best-method-class argl method-classes)
  (assert (list? argl))
  (assert (and (list? method-classes)
	       (and-map? (lambda (mtc)
			   (or
			    (is-simple-proc-class? mtc)
			    (is-param-proc-class? mtc)))
			 method-classes)))
  (let* ((processed-classes
	  (map (lambda (mtc) (if (is-instance? mtc _b_:param-proc)
				 (process-param-method argl mtc)
				 mtc))
	       method-classes)))
    (assert (and-map? is-simple-proc-class? processed-classes))
    (let ((selection (select-best-method0 argl processed-classes)))
      (if (symbol? selection)
	  selection
	  (begin
	    (assert (integer? selection))
	    (list-ref method-classes selection))))))


(set! select-best-method-class-fwd select-best-method-class)


(define (_i_call-generic-proc genproc args)
  (dwl2 "_i_call-generic-proc")
  (assert (and (is-normal-object? genproc)
	       (is-gen-proc-class? (theme-class-of genproc))))
  (assert (list? args))
  (dwl "_i_call-generic-proc/1")
  (let ((arg-types (map theme-class-of args))
	(methods (map car (vector-ref genproc i-gen-proc-methods))))
    (dwl "_i_call-generic-proc/2")
    (let ((mt-best-match (select-best-method arg-types methods)))
      (dwl "_i_call-generic-proc/3")
      (let ((result
	     (cond
	      ((eq? mt-best-match 'not-found)
	       (my-raise (list 'suitable-method-not-found
			       (cons 'str-name
				     (vector-ref genproc i-gen-proc-name)))))
	      ((eq? mt-best-match 'ambiguous)
	       (my-raise 'ambiguous-generic-procedure-call))
	      (else
	       ;;	       (assert (is-simple-proc-class? (theme-class-of mt-best-match)))
	       ;;	       (apply (vector-ref mt-best-match i-simple-proc-raw-proc) args)))))
	       (let* ((method (car mt-best-match))
		      (clas (theme-class-of method)))
		 (assert (or (is-simple-proc-class? clas)
			     (is-param-proc-class? clas)))
		 ;; Generic procedure call is dispatched runtime
		 ;; so we probably have to use runtime argument types here.
		 (_i_call-proc method args arg-types))))))
	(dwl "_i_call-generic-proc EXIT")
	result))))


(dwl1 "b1")


(define (_i_dispatch-generic-proc genproc static-result-type arg-types
				  appl-pure? appl-always-returns?
				  appl-never-returns?)
  (dwl "_i_dispatch-generic-proc")
  (assert (and (is-normal-object? genproc)
	       (is-gen-proc-class? (theme-class-of genproc))))
  (assert (list? arg-types))
  (dwl "_i_dispatch-generic-proc/1")
  (let* ((arg-xlat (vector-ref gl-rte i-rte-arg-xlat))
	 (arg-type-list (construct-toplevel-type-repr arg-xlat arg-types)))
    (if (not (is-tuple-type? arg-type-list))
	(my-raise 'invalid-generic-dispatch-args)
	(let* ((actual-arg-types (tuple-type->list-reject-cycles arg-type-list))
	       (methods (map car (vector-ref genproc i-gen-proc-methods)))
	       (mt-best-match (select-best-method actual-arg-types methods)))
	  (dwl "_i_dispatch-generic-proc/3")
	  (let ((result
		 (cond
		  ((eq? mt-best-match 'not-found)
		   (my-raise 'suitable-method-not-found-2))
		  ((eq? mt-best-match 'ambiguous)
		   (my-raise 'ambiguous-generic-procedure-dispatch))
		  (else
		   (let ((proc (car mt-best-match)))
		     (if (is-simple-proc? proc)
			 (let* ((proc-type (vector-ref proc i-object-class))
				(result-type
				 (vector-ref
				  proc-type i-procedure-class-result-type)))
			   (cond
			    ((not
			      (proc-attr-inherit0?
			       (vector-ref 
				proc-type
				i-procedure-class-pure-proc)
			       (vector-ref
				proc-type
				i-procedure-class-appl-always-returns)
			       (vector-ref
				proc-type
				i-procedure-class-appl-never-returns)
			       (vector-ref
				proc-type
				i-procedure-class-static-method)
			       appl-pure?
			       appl-always-returns?
			       appl-never-returns?
			       #f))
			     (my-raise 'generic-dispatch:invalid-attributes-1))
			    ((or (null? static-result-type)
				 (is-subtype? result-type static-result-type))
			     proc)
			    (else (my-raise 'generic-dispatch:type-mismatch))))
			 (let ((type (cdr mt-best-match)))
			   (if1 (not
				 (proc-attr-inherit0?
				  (vector-ref 
				   type
				   i-procedure-class-pure-proc)
				  (vector-ref
				   type
				   i-procedure-class-appl-always-returns)
				  (vector-ref
				   type
				   i-procedure-class-appl-never-returns)
				  (vector-ref
				   type
				   i-procedure-class-static-method)
				  appl-pure?
				  appl-always-returns?
				  appl-never-returns?
				  #f))
				(my-raise
				 (list
				  'generic-dispatch:invalid-attributes
				  (cons 'type type)
				  (cons 'appl-pure? appl-pure?)
				  (cons 'appl-always-returns?
					appl-always-returns?)
				  (cons 'appl-never-returns?
					appl-never-returns?)
				  (cons 'static-method? #f))))
			   (_i_make-procedure
			    type
			    (if (and
				 (not-null? static-result-type)
				 (not (eq? static-result-type _b_none)))
				(lambda args
				  (check-type
				   (let ((result
					  (_i_call-param-proc 
					   proc args
					   actual-arg-types)))
				     (if1 (unspecified? result)
					  (my-raise
					   'illegal-unspecified-result))
				     result)
				   static-result-type))
				(lambda args
				  (_i_call-param-proc 
				   proc args actual-arg-types)))))))))))
	    (dwl "_i_dispatch-generic-proc EXIT")
	    result)))))


;; *** Calling procedures ***


(define check-arglist-type-fwd '())


(define (match-signature-to-args type-checker sgn arg-list-type)
  (assert (is-signature? sgn))
  (let ((lst-members (vector-ref sgn i-signature-members))
	(expr-result '()))
    (do ((lst-cur lst-members (cdr lst-cur)))
	((or (null? lst-cur) (not-null? expr-result)))
      (let* ((expr-type (cdr (car lst-cur)))
	     (decl-type0 (vector-ref expr-type
				     i-procedure-class-arg-list-type))
	     (l-bindings (list (cons _b_this sgn)))
	     (decl-type (substitute-tvar-objects decl-type0 l-bindings)))
	(if1 (is-subtype? arg-list-type decl-type)
	     (set! expr-result expr-type))))
    expr-result))


(define (pick-signatures lst-argtypes)
  (let ((lst-result '()))
    (do ((cur-lst lst-argtypes (cdr cur-lst)))
	((null? cur-lst))
      (let ((to-cur-type (car cur-lst)))
	(if1 (is-signature? to-cur-type)
	     (set! lst-result (append lst-result (list to-cur-type))))))
    lst-result))


(define (match-gen-call-with-signatures type-checker lst-signatures
					lst-argtypes)
  (let ((arg-list-type (apply _i_make-tuple-type
			      lst-argtypes))
	(expr-result '()))
    (do ((lst-cur lst-signatures (cdr lst-cur)))
	((or (null? lst-cur) (not-null? expr-result)))
      (set! expr-result (match-signature-to-args type-checker
						 (car lst-cur)
						 arg-list-type)))
    expr-result))


;; (define (_i_call-simple-proc proc args)
;;   (let ((result
;; 	 (apply (vector-ref proc i-simple-proc-raw-proc)
;; 		(check-arglist-type-fwd proc args ""))))
;;     result))


(define (_i_call-simple-proc proc args)
  (apply (vector-ref proc i-simple-proc-raw-proc) args))


(define (deduced-all-tvar-bindings? bindings tvars)
  (and-map? (lambda (tvar)
	      (not (eq? (general-assoc tvar bindings tvar-object=?) #f)))
	    tvars))


;;(define (deduced-all-tvars? alo tvars)
;;  (deduced-all-tvar-bindings? (vector-ref alo i-alo-bindings) tvars))


(define (get-tvar-values tvar-alo tvars)
  (map (lambda (tvar)
	 (let ((binding (alo-fetch tvar-alo tvar)))
	   (if (not (eq? binding #f))
	       (cdr binding)
	       #f)))
       tvars))


(define (get-tvar-values2 tvar-alo tvars)
  (map (lambda (tvar)
	 (let ((binding (alo-fetch tvar-alo tvar)))
	   (if (not (eq? binding #f))
	       (cdr binding)
	       tvar)))
       tvars))


(define (_i_call-param-proc proc args arg-types0)
  (let* ((arg-types (if (not-null? arg-types0)
			arg-types0
			(map theme-class-of args)))
	 (ppc (vector-ref proc i-object-class))
	 (old-tvars (vector-ref ppc i-ppc-tvars))
	 (nr-of-tvars (length old-tvars))
	 (tva (vector-ref gl-rte i-rte-tvar-allocator))
	 (first-tvar-number (tva-alloc tva nr-of-tvars))
	 (new-target-tvars (map make-tvar-object
				(get-integer-sequence first-tvar-number
						      nr-of-tvars)))
	 (new-target-bindings
	  (map cons old-tvars new-target-tvars))
	 (ppc-new (substitute-tvar-objects ppc new-target-bindings))
	 (inst-type-new (vector-ref ppc-new i-ppc-inst-type))
	 (arg-list-desc (vector-ref inst-type-new
				    i-procedure-class-arg-list-type))
;;	 (src-tva-starts (make-singleton '()))
;;	 (new-arg-types (make-tvars-unique2 arg-types src-tva-starts))
	 (old-src-tvars (get-all-tvars arg-types))
	 (nr-of-src-tvars (length old-src-tvars))
	 (first-src-tvar (tva-alloc tva nr-of-src-tvars))
	 (new-src-tvars (map make-tvar-object
			     (get-integer-sequence first-src-tvar
						   nr-of-src-tvars)))
	 (src-bindings (map cons old-src-tvars new-src-tvars))
	 (new-arg-types (substitute-tvar-objects arg-types src-bindings))
	 (all-new-tvars (append new-src-tvars new-target-tvars))
	 (deduced-tvar-table (make-alo '() tvar-object=?))
	 ;;	 (src-tvar-table (make-alo '() tvar-object=?))
	 (arg-xlat (vector-ref gl-rte i-rte-arg-xlat)))
    (deduce-argument-types arg-xlat deduced-tvar-table
			   all-new-tvars
			   new-arg-types arg-list-desc)
    ;; Should we ensure that the values of the target type variables
    ;; don't contain other type variables?
    (if (deduced-all-tvars? deduced-tvar-table new-target-tvars)
	(let ((tvar-values (get-tvar-values2 deduced-tvar-table all-new-tvars)))
	  (assert (= (length tvar-values) (length all-new-tvars)))
	  (let* ((bindings (map cons all-new-tvars tvar-values))
		 (inst-type2 (substitute-arg-bindings1 bindings inst-type-new))
		 (arg-types2 (substitute-arg-bindings1 bindings new-arg-types)))
	    ;; It should be safe to deallocate the type variables here.
	    (tva-dealloc tva first-tvar-number)
	    (tva-dealloc tva first-src-tvar)
;;	    (for-each (lambda (start) (tva-dealloc tva start))
;;		      (get-singleton-element src-tva-starts))
	    (let* ((arg-list-desc2
		    (vector-ref inst-type2 i-procedure-class-arg-list-type))
		   (target-arg-list-type
		    (cond
		     ((is-type-list? arg-list-desc2)
		      (construct-toplevel-type-repr
		       arg-xlat
		       (vector-ref arg-list-desc2 i-type-list-subexprs)))
		     ;; The type of the argument list may also be a single
		     ;; uniform list type.
		     (else arg-list-desc2)))
		   ;; ((is-tuple-type? arg-list-desc2) arg-list-desc2)
		   ;; (else
		   ;;  (my-raise '_i_call-param-proc:invalid-argument-list))))
		   (src-arg-list-type
		    (if (is-tuple-type? arg-types2)
			arg-types2
			(construct-toplevel-type-repr arg-xlat
						      arg-types2))))
	      (if (is-subtype? src-arg-list-type target-arg-list-type)
		  (begin
		    (let* ((target-tvar-values
			    (get-tvar-values2 deduced-tvar-table new-target-tvars))
			   (result
			    (apply
			     (vector-ref proc i-param-proc-raw-proc)
			     (append target-tvar-values args))))
		      result))
		  (begin
		    (dvar1-set! proc)
		    (dvar2-set! args)
		    (dvar3-set! (list src-arg-list-type target-arg-list-type))
		    (dvar4-set! (list all-new-tvars deduced-tvar-table))
		    (my-raise
		     (list 'param-proc-type-mismatch
			   (cons 'str-name
				 (vector-ref proc i-param-proc-name))
			   (cons 'type-actual src-arg-list-type)
			   (cons 'type-declared target-arg-list-type))))))))
	(begin
	  (dvar1-set! proc)
	  (dvar2-set! args)
	  (dvar3-set! (list new-arg-types arg-list-desc all-new-tvars))
	  (dvar4-set! deduced-tvar-table)
	  (dvar5-set! arg-types)
	  (my-raise 'could-not-deduce-all-tvars)))))


(define (_i_call-proc proc args arg-types)
  (let* ((clas (vector-ref proc i-object-class))
	 (result
	  (cond
	   ((is-instance-of-simple-class? clas _b_:simple-proc)
	    (_i_call-simple-proc proc args))
	   ((is-instance-of-simple-class? clas _b_:param-proc)
	    (_i_call-param-proc proc args arg-types))
	   ((is-instance-of-simple-class? clas _b_:gen-proc)
	    (_i_call-generic-proc proc args))
	   (else
	    (my-raise 'called-invalid-procedure)))))
    result))


;; (set! _i_call-proc-fwd _i_call-proc)


;; *** Typecasts ***


(define (_i_cast type value)
  (dwl "_i_cast")
  (if (is-instance? value type)
      value
      (my-raise (list 'runtime-type-mismatch-in-cast
		      (cons 'cl-object (theme-class-of value))
		      (cons 'type-target type)))))


(define (_i_cast-error type value)
  (my-raise (list 'runtime-type-mismatch-in-cast
		  (cons 'cl-object (theme-class-of value))
		  (cons 'type-target type))))


(define (_b_cast-vector-impl new-element-type vec)
  (dwl "_b_cast-vector-impl")
  (let ((len (- (vector-length vec) 1)))
    (do ((i 0 (+ i 1))) ((>= i len))
      (if1 (not (is-instance? (vector-ref vec (+ i 1)) new-element-type))
	   (my-raise (list 'cast-vector:element-type-mismatch
			   (cons 'type-new new-element-type)
			   (cons 'type-old
				 (car (vector-ref
				       (vector-ref vec i-object-class)
				       i-param-class-inst-type-var-values)))))))
    (let ((result (vector-copy vec))
	  (target-vector-type (_i_construct-vector new-element-type)))
      (vector-set! result 0 target-vector-type)
      result)))


(define _b_cast-vector
  (_i_make-procedure
   (_i_make-simple-proc-class (_i_make-tuple-type _b_<type> _b_<object>)
			      _b_<object>
			      #t)
   _b_cast-vector-impl))


(define _b_raw_cast-vector _b_cast-vector-impl)


(define (_b_cast-vector0-impl new-element-type vec)
  (dwl "_b_cast-vector0-impl")
  (let ((result (vector-copy vec))
	(target-vector-type (_i_construct-vector new-element-type)))
    (vector-set! result 0 target-vector-type)
    result))


(define _b_cast-vector0
  (_i_make-procedure
   (_i_make-simple-proc-class (_i_make-tuple-type _b_<type> _b_<object>)
			      _b_<object>
			      #t)
   _b_cast-vector0-impl))


(define _b_raw_cast-vector0 _b_cast-vector0-impl)


(define (_b_cast-mutable-vector-impl new-element-type vec)
  (dwl "_b_cast-mutable-vector-impl")
  (let ((len (- (vector-length vec) 1)))
    (do ((i 0 (+ i 1))) ((>= i len))
      (if1 (not (is-instance? (vector-ref vec (+ i 1)) new-element-type))
	   (my-raise (list 'cast-mutable-vector:element-type-mismatch
			   (cons 'type-new new-element-type)
			   (cons 'type-old
				 (car (vector-ref
				       (vector-ref vec i-object-class)
				       i-param-class-inst-type-var-values)))))))
    (let ((result (vector-copy vec))
	  (target-vector-type (_i_construct-mutable-vector
			       new-element-type)))
      (vector-set! result 0 target-vector-type)
      result)))


(define _b_cast-mutable-vector
  (_i_make-procedure
   (_i_make-simple-proc-class (_i_make-tuple-type _b_<type> _b_<object>)
			      _b_<object>
			      #t)
   _b_cast-mutable-vector-impl))


(define _b_raw_cast-mutable-vector _b_cast-mutable-vector-impl)


(define (_b_cast-mutable-vector0-impl new-element-type vec)
  (dwl "_b_cast-mutable-vector0-impl")
  (let ((result (vector-copy vec))
	(target-vector-type (_i_construct-mutable-vector
			     new-element-type)))
    (vector-set! result 0 target-vector-type)
    result))


(define _b_cast-mutable-vector0
  (_i_make-procedure
   (_i_make-simple-proc-class (_i_make-tuple-type _b_<type> _b_<object>)
			      _b_<object>
			      #t)
   _b_cast-mutable-vector0-impl))


(define _b_raw_cast-mutable-vector0 _b_cast-mutable-vector0-impl)


(define (_b_cast-value-vector-impl new-element-type vec)
  (let ((len (- (vector-length vec) 1)))
    (do ((i 0 (+ i 1))) ((>= i len))
      (if1 (not (is-instance? (vector-ref vec (+ i 1)) new-element-type))
	   (my-raise (list 'cast-value-vector:element-type-mismatch
			   (cons 'type-new new-element-type)
			   (cons 'type-old
				 (car (vector-ref
				       (vector-ref vec i-object-class)
				       i-param-class-inst-type-var-values)))))))
    (let ((result (vector-copy vec))
	  (target-vector-type (_i_construct-value-vector new-element-type)))
      (vector-set! result 0 target-vector-type)
      result)))


(define _b_cast-value-vector
  (_i_make-procedure
   (_i_make-simple-proc-class (_i_make-tuple-type _b_<type> _b_<object>)
			      _b_<object>
			      #t)
   _b_cast-value-vector-impl))


(define _b_raw_cast-value-vector _b_cast-value-vector-impl)


(define (_b_cast-value-vector0-impl new-element-type vec)
  (let ((result (vector-copy vec))
	(target-vector-type (_i_construct-value-vector new-element-type)))
    (vector-set! result 0 target-vector-type)
    result))


(define _b_cast-value-vector0
  (_i_make-procedure
   (_i_make-simple-proc-class (_i_make-tuple-type _b_<type> _b_<object>)
			      _b_<object>
			      #t)
   _b_cast-value-vector0-impl))


(define _b_raw_cast-value-vector0 _b_cast-value-vector0-impl)


(define (_b_cast-mutable-value-vector-impl new-element-type vec)
  (let ((len (- (vector-length vec) 1)))
    (do ((i 0 (+ i 1))) ((>= i len))
      (if1 (not (is-instance? (vector-ref vec (+ i 1)) new-element-type))
	   (my-raise (list 'cast-mutable-value-vector:element-type-mismatch
			   (cons 'type-new new-element-type)
			   (cons 'type-old
				 (car (vector-ref
				       (vector-ref vec i-object-class)
				       i-param-class-inst-type-var-values)))))))
    (let ((result (vector-copy vec))
	  (target-vector-type (_i_construct-mutable-value-vector
			       new-element-type)))
      (vector-set! result 0 target-vector-type)
      result)))


(define _b_cast-mutable-value-vector
  (_i_make-procedure
   (_i_make-simple-proc-class (_i_make-tuple-type _b_<type> _b_<object>)
			      _b_<object>
			      #t)
   _b_cast-mutable-value-vector-impl))


(define _b_raw_cast-mutable-value-vector _b_cast-mutable-value-vector-impl)


(define (_b_cast-mutable-value-vector0-impl new-element-type vec)
  (let ((result (vector-copy vec))
	(target-vector-type (_i_construct-mutable-value-vector
			     new-element-type)))
    (vector-set! result 0 target-vector-type)
    result))


(define _b_cast-mutable-value-vector0
  (_i_make-procedure
   (_i_make-simple-proc-class (_i_make-tuple-type _b_<type> _b_<object>)
			      _b_<object>
			      #t)
   _b_cast-mutable-value-vector0-impl))


(define _b_raw_cast-mutable-value-vector0 _b_cast-mutable-value-vector0-impl)


(define (_b_cast-vector-metaclass-impl vec)
  (let* ((result (vector-copy vec))
	 (element-type (get-vector-element-type (vector-ref vec i-object-class)))
	 (target-vector-type (_i_construct-vector element-type)))
    (vector-set! result 0 target-vector-type)
    result))


(define _b_cast-vector-metaclass
  (_i_make-procedure
   (_i_make-simple-proc-class (_i_make-tuple-type _b_<object>)
			      _b_<object>
			      #t)
   _b_cast-vector-metaclass-impl))


(define _b_raw_cast-vector-metaclass _b_cast-vector-metaclass-impl)


(define (_b_cast-mutable-vector-metaclass-impl vec)
  (let* ((result (vector-copy vec))
	 (element-type (get-vector-element-type (vector-ref vec i-object-class)))
	 (target-vector-type (_i_construct-mutable-vector element-type)))
    (vector-set! result 0 target-vector-type)
    result))


(define _b_cast-mutable-vector-metaclass
  (_i_make-procedure
   (_i_make-simple-proc-class (_i_make-tuple-type _b_<object>)
			      _b_<object>
			      #t)
   _b_cast-mutable-vector-metaclass-impl))


(define _b_raw_cast-mutable-vector-metaclass
  _b_cast-mutable-vector-metaclass-impl)


(define (_b_cast-value-vector-metaclass-impl vec)
  (let* ((result (vector-copy vec))
	 (element-type (get-vector-element-type (vector-ref vec i-object-class)))
	 (target-vector-type (_i_construct-value-vector element-type)))
    (vector-set! result 0 target-vector-type)
    result))


(define _b_cast-value-vector-metaclass
  (_i_make-procedure
   (_i_make-simple-proc-class (_i_make-tuple-type _b_<object>)
			      _b_<object>
			      #t)
   _b_cast-value-vector-metaclass-impl))


(define _b_raw_cast-value-vector-metaclass _b_cast-value-vector-metaclass-impl)


(define (_b_cast-mutable-value-vector-metaclass-impl vec)
  (let* ((result (vector-copy vec))
	 (element-type (get-vector-element-type (vector-ref vec i-object-class)))
	 (target-vector-type (_i_construct-mutable-value-vector element-type)))
    (vector-set! result 0 target-vector-type)
    result))


(define _b_cast-mutable-value-vector-metaclass
  (_i_make-procedure
   (_i_make-simple-proc-class (_i_make-tuple-type _b_<object>)
			      _b_<object>
			      #t)
   _b_cast-mutable-value-vector-metaclass-impl))


(define _b_raw_cast-mutable-value-vector-metaclass
  _b_cast-mutable-value-vector-metaclass-impl)


;; *** Built-in procedures ***


(dwl1 "b2")


(define (_i_result-type-error obj type source-name)
  (my-raise (list 'procedure-result-type-mismatch
		  (cons 's-proc-name source-name)
		  (cons 'type-actual (theme-class-of obj))
		  (cons 'type-declared type))))


(define (_i_check-result-type obj type source-name)
  (if (or (eq? type _b_none) (is-instance? obj type))
      #t
      (_i_result-type-error obj type source-name)))


(define (check-type-verbose obj type src-obj src-type)
  (if (or (eq? type _b_none) (is-instance? obj type))
      obj
      (my-raise (list 'runtime-type-check-failed-verbose
		      (cons 'sx-expression src-obj)
		      (cons 'type-actual (theme-class-of obj))
		      (cons 'type-declared type)))))


(define (_i_invalid-theme-d-object-error obj source-name)
  (my-raise (list 'not-a-theme-d-object
		  (cons 'str-proc-name source-name))))


(define (_i_match-type-strong-no-match)
  (my-raise 'match-type-strong:no-match))


(define (check-var-unspecified obj s-var-name)
  (if (or (unspecified? obj)
	  ;; Forward declared nonprimitive objects have all vector fields
	  ;; set to unspecified value.
	  (and (vector? obj)
	       (> (vector-length obj) 0)
	       (unspecified? (vector-ref obj 0))))
      (my-raise (list 'unspecified-var-value
		      (cons 's-var-name s-var-name)))
      obj))


(define (check-field-unspecified obj s-field-name)
  (if (unspecified? obj)
      (my-raise (list 'unspecified-field-value
		      (cons 's-field-name s-field-name)))
      obj))


(define (check-letrec-unspecified obj s-var-name)
  (if (unspecified? obj)
      (my-raise (list 'unspecified-letrec-var-value
		      (cons 's-var-name s-var-name)))
      obj))


(define (check-type obj type)
  (dwl2 "check-type ENTER")
  (let ((result
	 ;; If the result type of a procedure is <none> its body may
	 ;; return any value.
	 (if (or (eq? type _b_none) (is-instance? obj type))
	     obj
	     (my-raise (list 'runtime-type-check-failed
			     (cons 'type-actual (theme-class-of obj))
			     (cons 'type-declared type))))))
    (dwl2 "check-type EXIT")
    result))


(define (_i_check-procedure-arg-list-type? arg-list proc)
  (dvar1-set! arg-list)
  (dvar2-set! proc)
  (is-instance? arg-list
		(vector-ref proc i-procedure-class-arg-list-type)))


(define (check-arglist-type proc arg-list s-proc-name)
  (if (is-instance? arg-list
		    (vector-ref (vector-ref proc i-object-class)
				i-procedure-class-arg-list-type))
      arg-list
      (my-raise (list 'arg-list-type-mismatch
		      (cons 's-proc-name s-proc-name)
		      (cons 'type-declared
			    (vector-ref (vector-ref proc i-object-class)
					i-procedure-class-arg-list-type))
		      (cons 'type-actual (theme-class-of arg-list))))))


(set! check-arglist-type-fwd check-arglist-type)


(define (_b_field-ref-impl)
  (my-raise 'invalid-field-reference))


(define _b_field-ref
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type _b_<object> _b_<symbol>)
    _b_<object>
    #t)
   _b_field-ref-impl))


(define _b_raw_field-ref _b_field-ref-impl)


(define (_b_field-set!-impl)
  (my-raise 'invalid-field-setting))


(define _b_field-set!
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type _b_<object> _b_<symbol> _b_<object>)
    _b_none
    #f)
   _b_field-set!-impl))


(define _b_raw_field-set! _b_field-set!-impl)


(define _b_class-of
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type _b_<object>)
    _b_<class>
    #t)
   theme-class-of))


(define _b_raw_class-of theme-class-of)


(define _b_is-subtype?
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type _b_<type> _b_<type>)
    _b_<boolean>
    #t)
   is-subtype?))


(define _b_raw_is-subtype? is-subtype?)


(define _b_is-instance?
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type _b_<object> _b_<type>)
    _b_<boolean>
    #t)
   is-instance?))


(define _b_raw_is-instance? is-instance?)


(define _b_tuple-ref
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type _b_<object> _b_<integer>)
    _b_<object>
    #t)
   list-ref))


(define _b_raw_tuple-ref list-ref)


(define (_b_make-vector-impl type-element n item-value)
  (let ((result (make-vector (+ n 1) item-value)))
    (vector-set! result 0 (_i_construct-vector type-element))
    result))


(define _b_make-vector
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type _b_<type> _b_<integer> _b_<object>)
    _b_<object>
    #t)
   _b_make-vector-impl))


(define _b_raw_make-vector _b_make-vector-impl)


(define (_b_make-mutable-vector-impl type-element n item-value)
  (let ((result (make-vector (+ n 1) item-value)))
    (vector-set! result 0 (_i_construct-mutable-vector type-element))
    result))


(define _b_make-mutable-vector
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type _b_<type> _b_<integer> _b_<object>)
    _b_<object>
    #t)
   _b_make-mutable-vector-impl))


(define _b_raw_make-mutable-vector _b_make-mutable-vector-impl)


(define (_b_make-value-vector-impl type-element n item-value)
  (let ((result (make-vector (+ n 1) item-value)))
    (vector-set! result 0 (_i_construct-value-vector type-element))
    result))


(define _b_make-value-vector
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type _b_<type> _b_<integer> _b_<object>)
    _b_<object>
    #t)
   _b_make-value-vector-impl))


(define _b_raw_make-value-vector _b_make-value-vector-impl)


(define (_b_make-mutable-value-vector-impl type-element n item-value)
  (let ((result (make-vector (+ n 1) item-value)))
    (vector-set! result 0 (_i_construct-mutable-value-vector type-element))
    result))


(define _b_make-mutable-value-vector
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type _b_<type> _b_<integer> _b_<object>)
    _b_<object>
    #t)
   _b_make-mutable-value-vector-impl))


(define _b_raw_make-mutable-value-vector _b_make-mutable-value-vector-impl)


;; The following two procedures are apparently not used.


(define (_b_make-vector-from-mutable vec)
  (let* ((argument-type (theme-class-of vec))
	 (element-type
	  (car (vector-ref argument-type i-param-class-inst-type-var-values)))
	 (result-type (_i_construct-vector element-type))
	 (result (vector-copy vec)))
    (vector-set! result 0 result-type)
    result))


(define (_b_make-value-vector-from-mutable vec)
  (let* ((argument-type (theme-class-of vec))
	 (element-type
	  (car (vector-ref argument-type i-param-class-inst-type-var-values)))
	 (result-type (_i_construct-value-vector element-type))
	 (result (vector-copy vec)))
    (vector-set! result 0 result-type)
    result))


(dwl1 "b3")


(define (_i_copy-vector-values vec values len)
  (do ((i 1 (+ i 1)) (cur-values values (cdr cur-values)))
      ((> i len) vec)
    (vector-set! vec i (car cur-values))))


(dwl1 "b3-1")


(define (_b_vector-impl element-type . values)
  (let* ((result-type (_i_construct-vector element-type))
	 (len (length values))
	 (result (make-vector (+ len 1) '())))
    (vector-set! result 0 result-type)
    (_i_copy-vector-values result values len)
    result))


(dwl1 "b3-2")


(define _b_vector
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type-with-tail
     (_i_make-tuple-type _b_<type>)
     (_i_make-uniform-list0 _b_<object>))
    _b_<object>
    #t)
   _b_vector-impl))


(define _b_raw_vector _b_vector-impl)


(dwl1 "b3-3")


(define (_b_mutable-vector-impl element-type . values)
  (let* ((result-type (_i_construct-mutable-vector element-type))
	 (len (length values))
	 (result (make-vector (+ len 1) '())))
    (vector-set! result 0 result-type)
    (_i_copy-vector-values result values len)
    result))


(define _b_mutable-vector
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type-with-tail
     (_i_make-tuple-type _b_<type>)
     (_i_make-uniform-list0 _b_<object>))
    _b_<object>
    #t)
   _b_mutable-vector-impl))


(define _b_raw_mutable-vector _b_mutable-vector-impl)


(define (_b_value-vector-impl element-type . values)
  (let* ((result-type (_i_construct-value-vector element-type))
	 (len (length values))
	 (result (make-vector (+ len 1) '())))
    (vector-set! result 0 result-type)
    (_i_copy-vector-values result values len)
    result))


(define _b_value-vector
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type-with-tail
     (_i_make-tuple-type _b_<type>)
     (_i_make-uniform-list0 _b_<object>))
    _b_<object>
    #t)
   _b_value-vector-impl))


(define _b_raw_value-vector _b_value-vector-impl)


(define (_b_mutable-value-vector-impl element-type . values)
  (let* ((result-type (_i_construct-mutable-value-vector element-type))
	 (len (length values))
	 (result (make-vector (+ len 1) '())))
    (vector-set! result 0 result-type)
    (_i_copy-vector-values result values len)
    result))


(define _b_mutable-value-vector
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type-with-tail
     (_i_make-tuple-type _b_<type>)
     (_i_make-uniform-list0 _b_<object>))
    _b_<object>
    #t)
   _b_mutable-value-vector-impl))


(define _b_raw_mutable-value-vector _b_mutable-value-vector-impl)


(dwl1 "b4")


;; (define (_i_vector-ref uv i)
;;   (dwl "_i_vector-ref")
;;   (let ((result (vector-ref uv (+ i 1))))
;;     (dwl "_i_vector-ref EXIT")
;;     result))


;; (define (_b_assert condition condition-expr)
;;   (if (not condition)
;;       (my-raise1 (list 'assertion-failed
;; 		       (cons 'sx-condition condition-expr)))))


(define (_i_raise-assertion-failed sx-condition)
  (my-raise1 (list 'assertion-failed
		   (cons 'sx-condition sx-condition))))


;; *** Equality of objects ***


;; HUOM: _b_<complex> poistettu
(define (is-atomic-prim-class? cl)
  (if (memv cl (list
		_b_<symbol>
		_b_<boolean>
		_b_<integer>
		_b_<real>
		;;		_b_<complex>
		_b_<string>
		_b_<null>
		_b_<character>))
      #t
      #f))


(define theme-equal0-fwd? '())


(define (equal-types0? t1 t2 visited)
  ;; (display "equal-types0?\n")
  ;; (prt-fwd t1)
  ;; (prt-fwd t2)
  (cond
   ;; Is it correct to return #t here?
   ((general-member (cons t1 t2) visited pair-contents-eqv?)
    #t)
   ((is-primitive-class? t1)
    (eq? t1 t2))
   ((is-custom-prim-class? t1)
    (eq? t1 t2))
   (else
    (let ((pair1? (is-pair-class? t1))
	  (pair2? (is-pair-class? t2))
	  (new-visited (cons (cons t1 t2) visited)))
      (cond
       ((and pair1? pair2?)
	(and
	 (equal-types0? (get-pair-first-type t1)
			(get-pair-first-type t2)
			new-visited)
	 (equal-types0? (get-pair-second-type t1)
			(get-pair-second-type t2)
			new-visited)))
       ((or pair1? pair2?) #f)
       ((mymemq (theme-class-of t1)
		(list _b_:vector
		      _b_:mutable-vector
		      _b_:value-vector
		      _b_:mutable-value-vector))
	(and
	 (eq? (theme-class-of t1) (theme-class-of t2))
	 (let ((tvv1 (vector-ref t1 i-param-class-inst-type-var-values))
	       (tvv2 (vector-ref t2 i-param-class-inst-type-var-values)))
	   (and
	    ;; If the length of any of the type variable lists is not one
	    ;; we have corrupted data structures.
	    (= (length tvv1) 1)
	    (= (length tvv2) 1)
	    (equal-types0? (car tvv1) (car tvv2) new-visited)))))
       (else
	;; (prt-fwd (theme-class-of t1))
	;; (prt-fwd (theme-class-of t2))
	(let ((cl1? (is-class? t1))
	      (cl2? (is-class? t2)))
	  (cond
	   ((and cl1? cl2?)
	    (let ((inst1? (is-param-class-instance? t1))
		  (inst2? (is-param-class-instance? t2)))
	      (cond
	       ((and inst1? inst2?)
		(check-if-param-inst-equal0?
		 (vector-ref gl-rte i-rte-type-checker)
		 '()
		 t1
		 t2))
	       ((or inst1? inst2?) #f)
	       (else (eq? t1 t2)))))
	   ((or cl1? cl2?) #f)
	   (else
	    ;; Subtype checking does not use the Theme equality predicates
	    ;; so the following code is safe for cycles.
	    (and (is-subtype? t1 t2)
		 (is-subtype? t2 t1)))))))))))


(define (equal-types? t1 t2)
  (equal-types0? t1 t2 '()))


(dwl1 "b5")


(set! equal-types-forward? equal-types?)


;; Procedures equal-by-values? and equal-contents use
;; different procedures for the recursive calls of the
;; equality predicates.
(define (equal-by-value? obj1 obj2 visited)
  ;; We assume that cl1 and cl2 are equal in the sense of equal-types?.
  (let ((cl1 (theme-class-of obj1))
	(cl2 (theme-class-of obj2)))
    (let ((i-nr-fields (length (vector-ref cl1 i-class-all-fields)))
	  (result? #t))
      (assert (= i-nr-fields (length (vector-ref cl2 i-class-all-fields))))
      (do ((i 1 (+ i 1)))
	  ((or (> i i-nr-fields) (not result?)) result?)
	(if1 (not (theme-equal0-fwd? (vector-ref obj1 i)
				     (vector-ref obj2 i)
				     visited))
	     (set! result? #f))))))


(define theme-equal-contents0-fwd? '())


(define (equal-contents? obj1 obj2 visited)
  ;; We assume that cl1 and cl2 are equal in the sense of equal-types?.
  (let ((cl1 (theme-class-of obj1))
	(cl2 (theme-class-of obj2)))
    (let ((i-nr-fields (length (vector-ref cl1 i-class-all-fields)))
	  (result? #t))
      (assert (= i-nr-fields (length (vector-ref cl2 i-class-all-fields))))
      (do ((i 1 (+ i 1)))
	  ((or (> i i-nr-fields) (not result?)) result?)
	(if1 (not (theme-equal-contents0-fwd? (vector-ref obj1 i)
					      (vector-ref obj2 i)
					      visited))
	     (set! result? #f))))))


(define (equal-pairs? p1 p2 visited)
  (and (theme-equal0-fwd? (car p1) (car p2) visited)
       (theme-equal0-fwd? (cdr p1) (cdr p2) visited)))


(define (equal-pair-contents? p1 p2 visited)
  (and (theme-equal-contents0-fwd? (car p1) (car p2) visited)
       (theme-equal-contents0-fwd? (cdr p1) (cdr p2) visited)))


(define (equal-vectors? vec1 vec2 visited)
  (let ((len1 (vector-length vec1))
	(len2 (vector-length vec2)))
    (if (= len1 len2)
	(let ((result? #t))
	  (do ((i 1 (+ i 1)))
	      ((or (not result?) (>= i len1)) result?)
	    (if1 (not (theme-equal0-fwd? (vector-ref vec1 i)
					 (vector-ref vec2 i)
					 visited))
		 (set! result? #f))))
	#f)))


(define (equal-vector-contents? vec1 vec2 visited)
  (let ((len1 (vector-length vec1))
	(len2 (vector-length vec2)))
    (if (= len1 len2)
	(let ((result? #t))
	  (do ((i 1 (+ i 1)))
	      ((or (not result?) (>= i len1)) result?)
	    (if1 (not (theme-equal-contents0-fwd? (vector-ref vec1 i)
						  (vector-ref vec2 i)
						  visited))
		 (set! result? #f))))
	#f)))


;; Preconditions:
;;  - obj1 has to be an instance of a primitive class.
;;  - the classes of obj1 and obj2 have to be equal.
(define (equal-primitive-values? obj1 obj2)
  (cond
   ((boolean? obj1) (eq? obj1 obj2))
   ;; We know that both of the values are null.
   ((null? obj1) #t)
   ((is-integer? obj1) (eqv? obj1 obj2))
   ((is-real? obj1) (eqv? obj1 obj2))
   ((symbol? obj1) (eq? obj1 obj2))
   ((string? obj1) (string=? obj1 obj2))
   ((char? obj1) (eqv? obj1 obj2))
   ;; We know that both of the values are theme-eof.
   ((eq? (theme-class-of obj1) _b_<eof>) #t)
   (else (my-raise 'internal-error))))


;; Preconditions:
;;  - obj1 has to be an instance of a primitive class.
;;  - the classes of obj1 and obj2 have to be equal.
(define (equal-primitive-objects? obj1 obj2)
  (cond
   ((boolean? obj1) (eq? obj1 obj2))
   ;; We know that both of the values are null.
   ((null? obj1) #t)
   ((is-integer? obj1) (eqv? obj1 obj2))
   ((is-real? obj1) (eqv? obj1 obj2))
   ((symbol? obj1) (eq? obj1 obj2))
   ((string? obj1) (eqv? obj1 obj2))
   ((char? obj1) (eqv? obj1 obj2))
   ;; We know that both of the values are theme-eof.
   ((eq? (theme-class-of obj1) _b_<eof>) #t)
   (else (my-raise 'internal-error))))


(define (theme-equal0? obj1 obj2 visited)
  (if (eq? obj1 obj2)
      #t
      (let ((pr (cons obj1 obj2)))
	;; When we check cycles it is correct to compare
	;; the object pair with eqv? regardless of the object types.
	(if (general-member pr visited pair-contents-eqv?)
	    ;; Formerly we had #f here.
	    #t
	    (let ((cl1 (theme-class-of obj1))
		  (cl2 (theme-class-of obj2)))
	      (if (equal-types0? cl1 cl2 visited)
		  (cond
		   ((is-primitive-class? cl1)
		    (equal-primitive-values? obj1 obj2))
		   ;; Calling struct? is necessary in Guile 2.2.
		   ;; ((and (struct? obj1) (instance? obj1))
		   ;;  (let* ((desc (get-goops-class-desc cl1))
		   ;; 	   (pred (list-ref desc
		   ;; 			   i-goops-class-desc-equal)))
		   ;;    (pred obj1 obj2)))
		   ((is-custom-prim-class? cl1)
		    (let* ((desc (get-custom-prim-class-desc cl1))
			   (pred (list-ref desc i-prim-desc-equal)))
		      (pred obj1 obj2)))
		   (else
		    (let ((new-visited (cons pr visited)))
		      (cond
		       ((and (pair? obj1) (pair? obj2))
			(equal-pairs? obj1 obj2 new-visited))
		       ((or (pair? obj1) (pair? obj2)) #f)
		       ((and (is-instance? obj1 _b_<type>)
			     (is-instance? obj2 _b_<type>))
			;; equal-types? and related procedures
			;; have their own cycle checking
			(equal-types0? obj1 obj2 new-visited))
		       (else
			;; Here both obj1 and obj2 should be normal Theme objects,
			;; which are implemented as vectors.
			(let ((metaclass (theme-class-of cl1)))
			  (if (not (or (eq? metaclass _b_:value-vector)
				       (eq? metaclass _b_:mutable-value-vector)))
			      (if (vector-ref cl1 i-class-eq-by-value)
				  (equal-by-value? obj1 obj2 new-visited)
				  #f)
			      (equal-vectors? obj1 obj2 new-visited))))))))
		  #f))))))


(set! theme-equal0-fwd? theme-equal0?)


(define (theme-equal? obj1 obj2)
  (dwl "theme-equal? ENTER")
  (let ((result
	 (theme-equal0? obj1 obj2 '())))
    (dwl "theme-equal? EXIT")
    result))


(define (theme-equal-objects? obj1 obj2)
  ;; (if (or (and (struct? obj1) (instance? obj1))
  ;; 	  (and (struct? obj2) (instance? obj2)))
  (if (or (struct? obj1) (struct? obj2))
      ;; We compare GOOPS objects with eqv?.
      (eqv? obj1 obj2)
      (if (eq? obj1 obj2)
	  #t
	  (let ((cl1 (theme-class-of obj1))
		(cl2 (theme-class-of obj2)))
	    (if (equal-types0? cl1 cl2 '())
		(cond
		 ((is-primitive-class? cl1)
		  (equal-primitive-objects? obj1 obj2))
		 ((is-custom-prim-class? cl1)
		  (let* ((desc (get-custom-prim-class-desc cl1))
			 (pred (list-ref desc i-prim-desc-equal-objects)))
		    (pred obj1 obj2)))
		 (else
		  (eq? obj1 obj2)))
		#f)))))


(define (theme-equal-contents0? obj1 obj2 visited)
  ;; (display "theme-equal-contents0?\n")
  ;; (prt-fwd obj1)
  ;; (prt-fwd obj2)
  (if (eq? obj1 obj2)
      #t
      (let ((pr (cons obj1 obj2)))
	;; When we check cycles it is correct to compare
	;; the object pair with eqv? regardless of the object types.
	(if (general-member pr visited pair-contents-eqv?)
	    ;; Formerly we had #f here.
	    #t
	    (let ((cl1 (theme-class-of obj1))
		  (cl2 (theme-class-of obj2)))
	      ;; (display "theme-equal-contents0?/1\n")
	      ;; (prt-fwd cl1)
	      ;; (prt-fwd cl2)
	      (if (equal-types0? cl1 cl2 visited)
		  (cond
		   ((is-primitive-class? cl1)
		    (equal-primitive-values? obj1 obj2))
		   ;; ((and (struct? obj1) (instance? obj1))
		   ;;  (let* ((desc (get-goops-class-desc cl1))
		   ;; 	   (pred (list-ref desc
		   ;; 			   i-goops-class-desc-equal-contents)))
		   ;;    (pred obj1 obj2)))
		   ((is-custom-prim-class? cl1)
		    (let* ((desc (get-custom-prim-class-desc cl1))
			   (pred (list-ref desc i-prim-desc-equal-contents)))
		      (pred obj1 obj2)))
		   (else
		    (let ((new-visited (cons pr visited)))
		      (cond
		       ((and (pair? obj1) (pair? obj2))
			(equal-pair-contents? obj1 obj2 new-visited))
		       ((or (pair? obj1) (pair? obj2)) #f)
		       ((and (is-instance? obj1 _b_<type>)
			     (is-instance? obj2 _b_<type>))
			;; equal-types? and related procedures
			;; have their own cycle checking
			;; (display "HEP1\n")
			(equal-types0? obj1 obj2 new-visited))
		       (else
			;; Here both obj1 and obj2 should be normal Theme objects,
			;; which are implemented as vectors.
			(let ((metaclass (theme-class-of cl1)))
			  (if (not (mymemq metaclass
					   (list _b_:vector
						 _b_:mutable-vector
						 _b_:value-vector
						 _b_:mutable-value-vector)))
			      (equal-contents? obj1 obj2 new-visited)
			      (equal-vector-contents? obj1 obj2 new-visited))))))))
		  #f))))))


(set! theme-equal-contents0-fwd? theme-equal-contents0?)


(define (theme-equal-contents? obj1 obj2)
  (dwl "theme-equal-contents? ENTER")
  (let ((result
	 (theme-equal-contents0? obj1 obj2 '())))
    (dwl "theme-equal-contents? EXIT")
    result))


(dwl1 "b5-1")


(define _b_equal-values?
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type _b_<object> _b_<object>)
    _b_<boolean>
    #t)
   theme-equal?))


(define _b_raw_equal-values? theme-equal?)


(dwl1 "b5-2")


(define _b_equal-objects?
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type _b_<object> _b_<object>)
    _b_<boolean>
    #t)
   theme-equal-objects?))


(define _b_raw_equal-objects? theme-equal-objects?)


(dwl1 "b5-3")


(define _b_equal-contents?
  (_i_make-procedure
   (_i_make-simple-proc-class
    (_i_make-tuple-type _b_<object> _b_<object>)
    _b_<boolean>
    #t)
   theme-equal-contents?))


(define _b_raw_equal-contents? theme-equal-contents?)


(dwl1 "b5-4")


(define (general-list->list lst)
  (cond
   ((list? lst) lst)
   ((is-tuple-type? lst) (tuple-type->list-reject-cycles lst))
   ((is-type-list? lst) (vector-ref lst i-type-list-subexprs))
   (else
    (dvar1-set! lst)
    (my-raise 'general-list->list:invalid-argument))))


;; Primitive definitions for the runtime Theme-D system


(dwl1 "b5-5")


;; This implementation is used for apply-nonpure, too.
(define (_b_apply-impl %arglist %result proc args)
  (let ((arglist2 (general-list->list %arglist)))
    (_i_call-proc proc args arglist2)))


(define (_b_apply-without-result-impl %arglist proc args)
  (let ((arglist2 (general-list->list %arglist)))
    (_i_call-proc proc args arglist2)))


(dwl1 "b5-6")


(define (make-apply-class pure?)
  (let* ((tva (vector-ref gl-rte i-rte-tvar-allocator))
	 (first-number (tva-alloc tva 2))
	 (tvar-arglist (make-tvar-object first-number))
	 (tvar-result (make-tvar-object (+ first-number 1)))
	 (proc-type
	  (_i_make-procedure-type (_i_make-tuple-type
				   (_i_make-splice-expression tvar-arglist))
				  tvar-result
				  pure?
				  #f
				  #f
				  #f
				  #f))
	 (arg-list-desc (_i_make-tuple-type proc-type tvar-arglist))
	 (result-type-desc tvar-result)
	 (inst-type (_i_make-procedure-type arg-list-desc result-type-desc
					    pure? #f #f #f #t))
	 (ppc
	  (_i_make-param-proc-class
	   first-number 2 (list tvar-arglist tvar-result) inst-type)))
    ppc))


(define (make-apply-without-result-class)
  (let* ((tva (vector-ref gl-rte i-rte-tvar-allocator))
	 (first-number (tva-alloc tva 1))
	 (tvar-arglist (make-tvar-object first-number))
	 (proc-type
	  (_i_make-procedure-type (_i_make-tuple-type
				   (_i_make-splice-expression tvar-arglist))
				  _b_none #f #f #f #f #f))
	 (arg-list-desc (_i_make-tuple-type proc-type tvar-arglist))
	 (inst-type (_i_make-procedure-type arg-list-desc _b_none
					    #f #f #f #f #t))
	 (ppc
	  (_i_make-param-proc-class
	   first-number 1 (list tvar-arglist) inst-type)))
    ppc))


(dwl1 "b5-7")


(define _b_apply
  (_i_make-param-proc
   (make-apply-class #t)
   _b_apply-impl
   '_b_apply-impl))


(dwl1 "b5-8")


(define _b_apply-nonpure
  (_i_make-param-proc
   (make-apply-class #f)
   _b_apply-impl
   '_b_apply-impl))


(dwl1 "b5-9")


(define _b_apply-without-result
  (_i_make-param-proc
   (make-apply-without-result-class)
   _b_apply-without-result-impl
   '_b_apply-without-result-impl))


(dwl1 "b5-10")


(define (theme-eof? obj)
  (eq? (theme-class-of obj) _b_<eof>))


;; call-with-current-continuation


(dwl1 "b6")


(define (_b_call/cc-impl normal-type jump-type body-proc)
  (let* ((proc-type
	  (_i_make-procedure-type (_i_make-tuple-type jump-type)
				  _b_none #t #f #t #f #t))
	 (result
	  (call/cc
	   (lambda (proc)
	     (let ((my-proc (_i_make-procedure proc-type proc)))
	       (_i_call-proc body-proc (list my-proc) (list proc-type)))))))
    result))


(define (_b_call/cc-without-result-impl body-proc)
  (let* ((proc-type
	  (_i_make-procedure-type (_i_make-tuple-type)
				  _b_none #t #f #t #f #t))
	 (result
	  (call/cc
	   (lambda (proc)
	     (let* ((actual-proc (lambda () (proc '())))
		    (my-proc (_i_make-procedure proc-type
						actual-proc)))
	       (_i_call-proc body-proc (list my-proc) (list proc-type)))))))
    result))


(define (make-call/cc-class pure?)
  (let* ((tva (vector-ref gl-rte i-rte-tvar-allocator))
	 (first-number (tva-alloc tva 2))
	 (tvar-normal (make-tvar-object first-number))
	 (tvar-jump (make-tvar-object (+ first-number 1)))
	 (jump-proc-type
	  (_i_make-procedure-type (_i_make-tuple-type tvar-jump)
				  _b_none #t #f #t #f #t))
	 (body-proc-type
	  (_i_make-procedure-type (_i_make-tuple-type jump-proc-type)
				  tvar-normal pure? #f #f #f #t))
	 (arg-list-desc (_i_make-tuple-type body-proc-type))
	 (result-type-desc (_i_make-union (list tvar-normal tvar-jump)))
	 (inst-type (_i_make-procedure-type arg-list-desc result-type-desc
					    pure? #f #f #f #t))
	 (ppc
	  (_i_make-param-proc-class
	   first-number 2 (list tvar-normal tvar-jump) inst-type)))
    ppc))


(define call/cc-without-result-class
  (let* ((jump-proc-type
	  (_i_make-procedure-type (_i_make-tuple-type)
				  _b_none #t #f #t #f #t))
	 (body-proc-type
	  (_i_make-procedure-type (_i_make-tuple-type jump-proc-type)
				  _b_none #f #f #f #f #t))
	 (arg-list-desc (_i_make-tuple-type body-proc-type))
	 (inst-type (_i_make-procedure-type arg-list-desc _b_none
					    #f #f #f #f #t)))
    inst-type))


(dwl1 "b7")


(define _b_call/cc
  (_i_make-param-proc
   (make-call/cc-class #t)
   _b_call/cc-impl
   '_b_call/cc-impl))


(define _b_call/cc-nonpure
  (_i_make-param-proc
   (make-call/cc-class #f)
   _b_call/cc-impl
   '_b_call/cc-impl))


(define _b_call/cc-without-result
  (_i_make-procedure
   call/cc-without-result-class
   _b_call/cc-without-result-impl))


(dwl1 "end")

