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



;; *** Representation of target objects ***


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


(define is-t-subtype-fwd? '())
(define is-general-tuple-type-fwd? '())
(define is-type-fwd? '())


;; We had formerly eqv? here.
(define target-type=? eq?)


(define gl-ctr5 0)

(dwl4 1)


(define (make-primitive-object0 type contents)
  (assert (hrecord-is-instance? type <target-object>))
  (make-target-object 
   type
   #t #t '() #t #f
   '()
   contents))


(define (make-incomplete-object type exact-type?)
  (assert (is-target-object? type))
  (assert (boolean? exact-type?))
  (make-target-object 
   type
   #t
   exact-type?
   '()
   #f
   #t
   #f
   '()))


(define (search-field lst-fields sym-field-name)
  (let ((result '()))
    (do ((cur-fields lst-fields (cdr cur-fields)))
	((or (null? cur-fields) (not-null? result)))
      (let ((cur-field (car cur-fields)))
	(if (eq? (tno-field-ref cur-field 's-name) sym-field-name)
	    (set! result cur-field))))
    result))


;; Note that we do not handle the fields belonging to the superclasses.
(define (get-field-spec0 to-clas sym-field-name)
  (search-field (tno-field-ref to-clas 'l-fields) sym-field-name))

;; Here we search all fields.
(define (get-field-spec to-clas sym-field-name)
  (search-field (tno-field-ref to-clas 'l-all-fields) sym-field-name))


(define (get-instance-field-spec to-clas sym-field-name)
  (search-field (tno-field-ref to-clas 'l-instance-all-fields) sym-field-name))


(define (set-field-desc-type! desc-list field-name new-type)
  (assert (list? desc-list))
  (assert (symbol? field-name))
  (let ((field (search-field desc-list field-name)))
    (assert (not-null? field))
    (tno-field-set! field 'type new-type)))


;; (define (is-general-object? obj)
;;   (or (is-target-object? obj)
;;       (hrecord-is-instance? obj <type-variable>)
;;       (and (is-expression? obj) (expr-has-static-representation? obj))))


(define (create-class0 s-name inh? imm? ebv? has-zero? zero-prim? zero-value)
  (assert (symbol? s-name))
  (assert (boolean? inh?))
  (assert (boolean? imm?))
  (assert (boolean? ebv?))
  (assert (boolean? has-zero?))
  (assert (boolean? zero-prim?))
  (let* ((address (alloc-builtin-loc s-name))
	 (to-class
	  (make-target-object
	   '()
	   #t
	   #t
	   address
	   #f
	   #f
	   (list
	    (cons 'cl-superclass '())
	    (cons 'l-fields '())
	    (cons 'l-all-fields '())
	    (cons 'inheritable? inh?)
	    (cons 'immutable? imm?)
	    (cons 'eq-by-value? ebv?)
	    (cons 's-ctr-access 'public)
	    (cons 'type-constructor '())
	    (cons 'proc-constructor '())
	    (cons 'goops? #f)
	    (cons 'has-zero? has-zero?)
	    (cons 'zero-prim? zero-prim?)
	    (cons 'x-zero-value zero-value)
	    (cons 'module 'builtins)
	    (cons 'str-name (symbol->string s-name)))
	   '())))
    to-class))


(define (make-object-var to)
  (make-normal-variable1
   (hfield-ref to 'address)
   (hfield-ref to 'type)
   #t
   #t
   to))


(define (make-var-with-address to address)
  (make-normal-variable1
   address
   (hfield-ref to 'type)
   #t
   #t
   to))


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

(define tc-boolean (create-class0 '<boolean> #f #t #t #t #t #f))

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

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

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


(define (get-entity-type entity)
  (assert (is-entity? entity))
  (if (eq? entity tc-class)
      tc-class
      (hfield-ref entity 'type)))

(define get-object-type get-entity-type)
(define get-var-type get-entity-type)


(tno-field-set! tc-boolean 'cl-superclass tc-object)
(tno-field-set! tc-string 'cl-superclass tc-object)
(tno-field-set! tc-class 'cl-superclass tc-object)
(tno-field-set! tc-symbol 'cl-superclass tc-object)

(hfield-set! tc-object 'type tc-class)
(hfield-set! tc-boolean 'type tc-class)
(hfield-set! tc-string 'type tc-class)
;; We avoid a cyclic data structure here.
(hfield-set! tc-class 'type #t)
(hfield-set! tc-symbol 'type tc-class)

(define var-tc-object (make-object-var tc-object))
(define var-tc-boolean (make-object-var tc-boolean))
(define var-tc-string (make-object-var tc-string))
(define var-tc-class
  (make-normal-variable1
   (hfield-ref tc-class 'address)
   tc-class
   #t
   #t
   tc-class))
(define var-tc-symbol (make-object-var tc-symbol))


(define (is-t-subtype0? tc1 tc2)
  (assert (is-target-object? tc1))
  (assert (is-target-object? tc2))

  ;; TBR
  (dvar1-set! tc1)
  (dvar2-set! tc2)

  (cond
   ((null? tc1) #f)
   ((eq? tc1 tc2) #t)
   ((eq? tc1 tc-object) (eq? tc2 tc-object))
   (else
    (is-t-subtype0? (tno-field-ref tc1 'superclass) tc2))))


;; This procedure does not handle inheritance.
(define (make-t-predicate0 tc)
  (lambda (to) (and (is-target-object? to)
		    (eqv? (get-entity-type to) tc))))


(define tc-field (create-class0 '<field> #f #f #f #f #f '()))


(define is-t-field? (make-t-predicate0 tc-field))


(define is-t-class0? (make-t-predicate0 tc-class))


(define (is-access-spec? sym)
  (if (and (symbol? sym) (memq sym (list 'public 'module 'hidden))) #t #f))


(define (make-field s-name to-type s-read-access s-write-access
		    has-init-value? to-init-value)
  (if (not (symbol? s-name)) (begin (display s-name) (newline)))
  (assert (symbol? s-name))
  ;;  (assert (is-target-object? to-type))
  (assert (is-access-spec? s-read-access))
  (assert (is-access-spec? s-write-access))
  (assert (boolean? has-init-value?))
  (make-target-object
   tc-field
   #t
   #t
   '()
   #f
   #f
   (list
    (cons 's-name s-name)
    (cons 'type to-type)
    (cons 's-read-access s-read-access)
    (cons 's-write-access s-write-access)
    (cons 'has-init-value? has-init-value?)
    (cons 'x-init-value to-init-value))
   '()))


(define (make-readonly-field name tc init-value)
  (make-field name tc 'public 'hidden #t
	      (make-primitive-object0 tc init-value)))


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


(define (make-hidden-field name tc init-value)
  (make-field name tc 'hidden 'hidden #t
	      (make-primitive-object0 tc init-value)))


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


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

(define tc-class-all-fields tc-class-fields)


(tno-field-set! tc-class 'l-fields tc-class-fields)
(tno-field-set! tc-class 'l-all-fields tc-class-all-fields)


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

(define tc-field-all-fields tc-field-fields)

(tno-field-set! tc-field 'l-fields tc-field-fields)
(tno-field-set! tc-field 'l-all-fields tc-field-all-fields)
(tno-field-set! tc-field 'cl-superclass tc-object)
(hfield-set! tc-field 'type tc-class)


(define (create-primitive-class s-name imm? ebv? has-zero? zero-prim?
				zero-value)
  (assert (symbol? s-name))
  (assert (boolean? imm?))
  (assert (boolean? ebv?))
  (assert (boolean? has-zero?))
  (assert (boolean? zero-prim?))
  (let* ((address (alloc-builtin-loc s-name))
	 (to
	  (make-target-object
	   tc-class
	   #t
	   #f
	   address
	   #f
	   #f
	   (list
	    (cons 'cl-superclass tc-object)
	    (cons 'l-fields '())
	    (cons 'l-all-fields '())
	    (cons 'inheritable? #f)
	    (cons 'immutable? imm?)
	    (cons 'eq-by-value? ebv?)
	    (cons 's-ctr-access 'public)
	    (cons 'type-constructor '())
	    (cons 'proc-constructor '())
	    (cons 'goops? #f)
	    (cons 'has-zero? has-zero?)
	    (cons 'zero-prim? zero-prim?)
	    (cons 'x-zero-value zero-value)
	    (cons 'module 'builtins)
	    (cons 'str-name (symbol->string s-name)))
	   '())))
    to))


(define (create-custom-prim-class address str-name module goops?
				  tc-superclass inh? imm? ebv?
				  zero-address)
  (assert (string? str-name))
  (assert (boolean? goops?))
  (assert (is-entity? tc-superclass))
  (assert (boolean? inh?))
  (assert (boolean? imm?))
  (assert (boolean? ebv?))
  (assert (or (null? zero-address) (is-address? zero-address)))
  (let* ((to
	  (make-target-object
	   tc-class
	   #t
	   #f
	   address
	   #f
	   #f
	   (list
	    (cons 'cl-superclass tc-superclass)
	    (cons 'l-fields '())
	    (cons 'l-all-fields '())
	    (cons 'inheritable? inh?)
	    (cons 'immutable? imm?)
	    (cons 'eq-by-value? ebv?)
	    (cons 's-ctr-access 'public)
	    (cons 'type-constructor '())
	    (cons 'proc-constructor '())
	    (cons 'goops? goops?)
	    (cons 'has-zero? (not-null? zero-address))
	    (cons 'zero-prim? #f)
	    (cons 'x-zero-value zero-address)
	    (cons 'module module)
	    (cons 'str-name str-name))
	   '())))
    to))


(define (make-target-class address module tc-superclass l-fields
			   inh? imm? ebv? s-ctr-access)
  (assert (or (null? address) (is-address? address)))
  (assert (is-module-name? module))
  (assert (is-entity? tc-superclass))
  (assert (boolean? inh?))
  (assert (boolean? imm?))
  (assert (boolean? ebv?))
  (assert (is-access-spec? s-ctr-access))
  (let ((name (if (not-null? address)
		  (symbol->string (hfield-ref address 'source-name))
		  "no name")))
    (make-target-object     
     tc-class
     #t
     #f
     address
     #f
     #f
     (list 
      (cons 'cl-superclass tc-superclass)
      (cons 'l-fields l-fields)
      (cons 'l-all-fields
	    (append
	     (tno-field-ref tc-superclass 'l-all-fields) l-fields))
      (cons 'inheritable? inh?)
      (cons 'immutable? imm?)
      (cons 'eq-by-value? ebv?)
      (cons 's-ctr-access s-ctr-access)
      (cons 'type-constructor '())
      (cons 'proc-constructor '())
      (cons 'goops? #f)
      (cons 'has-zero? #f)
      (cons 'zero-prim? #f)
      (cons 'x-zero-value '())
      (cons 'module module)
      (cons 'str-name name))
     '())))


(define (make-target-class-var address module superclass fields inh? imm?
			       ebv? ctr-access)
  (assert (is-address? address))
  (assert (is-module-name? module))
  (assert (is-entity? superclass))
  (assert (list? fields))
  (assert (boolean? imm?))
  (assert (boolean? inh?))
  (assert (boolean? ebv?))
  (assert (and (symbol? ctr-access) (memq ctr-access gl-access-specifiers)))
  (let* ((to
	  (make-target-class
	   address
	   module
	   superclass
	   fields
	   inh?
	   imm?
	   ebv?
	   ctr-access))
	 (var
	  (make-normal-variable1
	   address
	   tc-class
	   #t
	   #t
	   to)))
    var))


(define (make-builtin-target-class s-name superclass fields inh? imm?
				   ebv? ctr-access)
  (assert (symbol? s-name))
  (assert (is-entity? superclass))
  (assert (list? fields))
  (assert (boolean? inh?))
  (assert (boolean? imm?))
  (assert (boolean? ebv?))
  (assert (and (symbol? ctr-access) (memq ctr-access gl-access-specifiers)))
  (make-target-class
   (alloc-builtin-loc s-name)
   (list 'builtins)
   superclass fields
   inh? imm? ebv?
   ctr-access))


(define tc-logical-type (make-builtin-target-class '<logical-type>
						   tc-object
						   '()
						   #t #t #t 'public))


(define is-t-logical-type? (make-t-predicate0 tc-logical-type))


(define var-tc-logical-type (make-object-var tc-logical-type))


(define (make-logical-type address obj)
  (let ((var (make-normal-variable1
	      address
	      (get-entity-type obj)
	      (hfield-ref obj 'exact-type?)
	      #t
	      obj)))
    var))


(define tt-none
  (make-target-object   
   tc-logical-type
   #t
   #t
   (alloc-builtin-loc 'none)
   #f
   #f
   '()
   '()))


(define var-tt-none (make-object-var tt-none))


(define empty-expression
  (make-hrecord <empty-expression>
		tt-none
		#t
		#t
		;; The following has to be checked when a result object
		;; is constructed for a static expression.
		'()
		#t
		#t
		#f
		'()))


(define (make-empty-expression) empty-expression)


(define tc-nil (create-primitive-class '<null> #t #t #t #t '()))

(define var-tc-nil (make-object-var tc-nil))

;; We should define the null character as the zero value here.
(define tc-char (create-primitive-class '<character> #f #t #f #f '()))

(define var-tc-char (make-object-var tc-char))

(define tc-integer (create-primitive-class '<integer> #f #t #t #t 0))

(define var-tc-integer (make-object-var tc-integer))

(define tc-real (create-primitive-class '<real> #f #t #t #t 0.0))

(define var-tc-real (make-object-var tc-real))

(define tc-procedure (make-builtin-target-class '<procedure>
						tc-object
						'()
						#f #t #f 'public))

(define var-tc-procedure (make-object-var tc-procedure))

(define tc-procedure-fields '())

(define tc-procedure-all-fields '())


;; Note that address is used only translation time
;; and number runtime.
(define tc-type-variable-fields
  (list
   (make-field 'address tc-object 'public 'hidden #f '())
   (make-field 'i-number tc-integer 'public 'hidden #t
	       (make-primitive-object0 tc-integer 0))))


(define tc-type-variable (make-builtin-target-class '<type-variable>
						    tc-object
						    tc-type-variable-fields
						    #f #t #t 'public))


(define var-tc-type-variable (make-object-var tc-type-variable))


(define is-t-type-variable? (make-t-predicate0 tc-type-variable))


;; value nil (actually we usually use '() and null)
(define to-nil
  (make-target-object 
   tc-nil #t #t '() #t #f '() '()))


(define (type-variable=? tvar1 tvar2)
  (dvar1-set! tvar1)
  (dvar2-set! tvar2)
  (assert (is-t-type-variable? tvar1))
  (assert (is-t-type-variable? tvar2))
  (or (eq? tvar1 tvar2)
      (and
       ;;       (= (tno-field-ref tvar1 'number)
       ;;	  (tno-field-ref tvar2 'number)))))
       (address=? (tno-field-ref tvar1 'address)
		  (tno-field-ref tvar2 'address)))))


(define t-param-class-fields
  (list
   (make-readonly-field-no-init 'i-params tc-integer)
   (make-readonly-field-no-init 'l-tvars tc-object)
   (make-readonly-field-no-init 'cl-instance-superclass tc-class)
   (make-readonly-field-no-init 'l-instance-fields tc-object)
   (make-readonly-field-no-init 'l-instance-all-fields tc-object)
   (make-readonly-field-no-init 'instances-inheritable? tc-boolean)
   (make-readonly-field-no-init 'instances-immutable? tc-boolean)
   (make-readonly-field-no-init 'instances-eq-by-value? tc-boolean)
   (make-readonly-field-no-init 'instance-has-constructor? tc-boolean)
   (make-readonly-field-no-init 's-instance-ctr-access tc-symbol)
   (make-readonly-field-no-init 'instance-has-zero? tc-boolean)
   (make-readonly-field-no-init 'proc-instance-zero tc-object)))


(define t-param-class
  (make-builtin-target-class '<param-class> tc-class
			     t-param-class-fields
			     #f #f #f
			     'public))


(define var-t-param-class (make-object-var t-param-class))


(define is-t-param-class? (make-t-predicate0 t-param-class))


(define t-param-logical-type-fields
  (list
   (make-readonly-field-no-init 'i-params tc-integer)
   (make-readonly-field-no-init 'l-tvars tc-object)
   (make-hidden-field-no-init 'x-value-expr tc-object)))


(define t-param-logical-type
  (make-builtin-target-class '<param-logical-type> tc-class
			     t-param-logical-type-fields
			     #f #f #f
			     'public))


(define var-t-param-logical-type (make-object-var t-param-logical-type))


(define is-t-param-logical-type? (make-t-predicate0 t-param-logical-type))


;; Fields i-first-number and i-nr-of-tvars exist only to be compatible
;; with the runtime object layout.
(define tpc-param-proc-fields
  (list
   (make-readonly-field-no-init 'i-first-number tc-integer)
   (make-readonly-field-no-init 'i-nr-of-tvars tc-integer)
   (make-readonly-field-no-init 'l-tvars tc-object)
   (make-readonly-field-no-init 'type-contents tc-object)))


(define tpc-param-proc
  (make-builtin-target-class ':param-proc tc-class
			     tpc-param-proc-fields
			     #f #f #t
			     'public))


(define var-tpc-param-proc (make-object-var tpc-param-proc))


(define is-tc-param-proc? (make-t-predicate0 tpc-param-proc))


(define t-param-proc-fields
  (list
   (make-hidden-field-no-init 'x-value-expr tc-object)
   (make-readonly-field-no-init 's-name tc-object)))


(define (make-param-proc-class-object name type-vars inst-type)
  (assert (string? name))
  (assert (and (list? type-vars)
	       (and-map? is-t-type-variable? type-vars)))
  (assert (is-target-object? inst-type))
  (make-target-object   
   tpc-param-proc
   ;; Should this class be not inheritable?
   #t
   #f
   '()
   #f
   #f
   (list
    (cons 'cl-superclass tc-procedure)
    (cons 'l-fields t-param-proc-fields)
    (cons 'l-all-fields (append tc-procedure-all-fields
				t-param-proc-fields))
    (cons 'inheritable? #t)
    (cons 'immutable? #t)
    ;; Comparison of the procedure classes has not been tested.
    (cons 'eq-by-value? #t)
    (cons 's-ctr-access 'public)
    (cons 'type-constructor '())
    (cons 'proc-constructor '())
    (cons 'goops? #f)
    (cons 'has-zero? #f)
    (cons 'zero-prim? #f)
    (cons 'x-zero-value '())
    (cons 'module 'builtins)
    (cons 'str-name name)
    (cons 'i-first-number 0)
    (cons 'i-nr-of-tvars (length type-vars))
    (cons 'l-tvars type-vars)
    (cons 'type-contents inst-type))
   '()))


(define (make-param-proc-object s-name to-ppc value-expr address)
  (assert (or (symbol? s-name) (null? s-name)))
  (assert (is-target-object? to-ppc))
  (assert (or (null? value-expr) (is-entity? value-expr)))
  (make-target-object   
   to-ppc
   #t
   #f
   address
   #f
   #f
   (list
    (cons 'x-value-expr value-expr)
    (cons 's-name s-name))
   '()))


(define (is-type0? obj)
  (is-target-object? obj))


(define (make-param-proc s-kind s-name l-module type-variables tc body-expr)
  (assert (or (symbol? s-name) (null? s-name)))
  (assert (and (list? type-variables)
	       (and-map? is-t-type-variable? type-variables)))
  (assert (is-type0? tc))
  (assert (or (null? body-expr) (is-entity? body-expr)))
  (let ((to (make-param-proc-object
	     s-name
	     tc
	     body-expr
	     '())))
    (make-hrecord <param-proc-expr>
		  tc
		  #t
		  #f
		  '()
		  #t
		  #t
		  #f
		  to
		  type-variables
		  body-expr
		  s-kind
		  s-name
		  l-module)))


(define (make-param-proc2 type-variables tc body-expr s-kind l-module to)
  (assert (and (list? type-variables)
	       (and-map? is-t-type-variable? type-variables)))
  (assert (is-type0? tc))
  (assert (or (null? body-expr) (is-entity? body-expr)))
  (assert (or (symbol? s-kind) (null? s-kind)))
  (assert (and (list? l-module) (and-map? symbol? l-module)))
  (make-hrecord <param-proc-expr>
		tc
		#t
		#f
		'()
		#t
		#t
		#f
		to
		type-variables
		body-expr
		s-kind
		(tno-field-ref to 's-name)
		l-module))


(define (make-param-proc3 type-variables tc body-expr to s-kind s-name
			  l-module)
  (assert (and (list? type-variables)
	       (and-map? is-t-type-variable? type-variables)))
  (assert (is-type0? tc))
  (assert (or (null? body-expr) (is-entity? body-expr)))
  (assert (or (symbol? s-kind) (null? s-kind)))
  (assert (or (symbol? s-name) (null? s-name)))
  (assert (and (list? l-module) (and-map? symbol? l-module)))
  (make-hrecord <param-proc-expr>
		tc
		#t
		#f
		'()
		#t
		#t
		#f
		to
		type-variables
		body-expr
		s-kind
		s-name
		l-module))


(define param-class-inst-fields
  (list (make-readonly-field-no-init 'l-tvar-values tc-object)
	(make-readonly-field-no-init 'l-param-exprs tc-object)))


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


(define (make-parametrized-class-object0
	 module
	 name
	 address
	 type-variables
	 instance-superclass
	 instance-fields
	 instance-all-fields
	 inh? imm? ebv?
	 instance-has-constructor?
	 instance-ctr-access)
  (assert (string? name))
  (assert (boolean? inh?))
  (assert (boolean? imm?))
  (assert (boolean? ebv?))
  (assert (boolean? instance-has-constructor?))
  (make-target-object   
   t-param-class
   #t
   #f
   address
   #f
   #f
   (list
    (cons 'cl-superclass tc-class)
    (cons 'l-fields param-class-inst-fields)
    (cons 'l-all-fields param-class-inst-all-fields)
    (cons 'inheritable? #f)
    (cons 'immutable? #t)
    (cons 'eq-by-value? #t)
    (cons 's-ctr-access 'public)
    (cons 'type-constructor '())
    (cons 'proc-constructor '())
    (cons 'goops? #f)
    (cons 'has-zero? #f)
    (cons 'zero-prim? #f)
    (cons 'zero-value '())
    (cons 'module module)
    (cons 'str-name name)
    (cons 'i-params (length type-variables))
    (cons 'l-tvars type-variables)
    (cons 'cl-instance-superclass instance-superclass)
    (cons 'l-instance-fields instance-fields)
    (cons 'l-instance-all-fields instance-all-fields)
    (cons 'instances-inheritable? inh?)
    (cons 'instances-immutable? imm?)
    (cons 'instances-eq-by-value? ebv?)
    (cons 'instance-has-constructor? instance-has-constructor?)
    (cons 's-instance-ctr-access instance-ctr-access)
    (cons 'instance-has-zero? #f)
    (cons 'proc-instance-zero '()))
   '()))


(define param-logical-type-inst-fields
  (list (make-readonly-field-no-init 'type-meta tc-object)
	(make-readonly-field-no-init 'l-tvar-values tc-object)
	(make-readonly-field-no-init 'regular? tc-boolean)))


(define param-logical-type-inst-all-fields
  param-logical-type-inst-fields)


(define (make-param-logical-type-object name address type-variables value-expr)
  (assert (string? name))
  (assert (or (null? address) (is-address? address)))
  (make-target-object   
   t-param-logical-type
   #t
   #f
   address
   #f
   #f
   (list
    (cons 'cl-superclass tc-logical-type)
    (cons 'l-fields param-logical-type-inst-fields)
    (cons 'l-all-fields param-logical-type-inst-all-fields)
    (cons 'inheritable? #f)
    (cons 'immutable? #t)
    (cons 'eq-by-value? #t)
    (cons 's-ctr-access 'public)
    (cons 'type-constructor '())
    (cons 'proc-constructor '())
    (cons 'goops? #f)
    (cons 'has-zero? #f)
    (cons 'zero-prim? #f)
    (cons 'x-zero-value '())
    (cons 'module 'builtins)
    (cons 'str-name name)
    (cons 'i-params (length type-variables))
    (cons 'l-tvars type-variables)
    (cons 'x-value-expr value-expr))
   '()))


(define (make-param-logical-type address type-variables
				 value-expr)
  (let* ((to (make-param-logical-type-object
	      (symbol->string (hfield-ref address 'source-name))
	      address
	      type-variables value-expr))
	 (var (make-object-var to)))
    var))


(define union-fields
  (list (make-readonly-field-no-init 'l-member-types tc-object)
	(make-readonly-field-no-init 'regular? tc-boolean)))


(define tmt-union
  (let* ((address (alloc-builtin-loc ':union))
	 (to
	  (make-target-object	   
	   t-param-logical-type
	   #t
	   #f
	   address
	   #f
	   #f
	   (list
	    (cons 'cl-superclass tc-logical-type)
	    (cons 'l-fields union-fields)
	    (cons 'l-all-fields (append
				 (tno-field-ref tc-logical-type 'l-all-fields)
				 union-fields))
	    (cons 'inheritable? #f)
	    (cons 'immutable? #t)
	    (cons 'eq-by-value? #t)
	    (cons 's-ctr-access 'public)
	    (cons 'type-constructor '())
	    (cons 'proc-constructor '())
	    (cons 'goops? #f)
	    (cons 'has-zero? #f)
	    (cons 'goops? #f)
	    (cons 'zero-prim? #f)
	    (cons 'x-zero-value '())
	    (cons 'module 'builtins)
	    (cons 'str-name ":union")
	    (cons 'i-params -1)
	    (cons 'l-tvars '())
	    (cons 'x-value-expr '()))
	   '())))
    to))


(define var-tmt-union (make-object-var tmt-union))


(define is-tt-union? (make-t-predicate0 tmt-union))


(define (make-tt-union . types)
  (make-target-object   
   tmt-union
   #t
   #f
   '()
   #f
   #f
   (list
    (cons 'l-member-types types)
    (cons 'regular? #t))
   '()))


(define tt-type
  (make-object-with-address
   (make-tt-union tc-class tc-logical-type)
   (alloc-builtin-loc '<type>)))


(define (make-type-variable address)
  (make-target-object   
   tc-type-variable
   #f
   #f
   address
   #f
   #f
   (list
    (cons 'address address)
    (cons 'i-number 0))
   '()))


;; It may be wrong to use alloc-builtin-loc here.
(define (make-type-var1 type-var-name)
  (assert (symbol? type-var-name))
  (make-type-variable (alloc-builtin-loc type-var-name)))


(define apti-fields
  (list (make-readonly-field-no-init 'type-meta tc-object)
	(make-readonly-field-no-init 'l-type-args tc-object)))


(define apti-all-fields apti-fields)


(define tc-abstract-param-type-inst
  (make-builtin-target-class
   'apti
   tc-logical-type
   apti-fields
   #f
   #f
   #f
   'public))


(define (make-apti param-type type-args)
  (make-target-object
   tc-abstract-param-type-inst #t #f '()
   #f #f
   (list
    (cons 'type-meta param-type)
    (cons 'l-type-args type-args))
   '()))


(define is-t-apti? (make-t-predicate0 tc-abstract-param-type-inst))


(define tvar-pair-first (make-type-var1 'first))


(define tvar-pair-second (make-type-var1 'second))


;; Note that the types of the fields are undefined so far.
(define tpc-pair-fields 
  (list (make-readonly-field-no-init 'first '())
	(make-readonly-field-no-init 'second '())))


(define tpc-pair
  (make-parametrized-class-object0
   'builtins
   ":pair"
   (alloc-builtin-loc ':pair)
   (list tvar-pair-first tvar-pair-second)
   tc-object
   tpc-pair-fields
   tpc-pair-fields
   #f
   #t
   #t
   ;; Pair constructors are handled specially.
   #f
   'public))


(define var-tpc-pair (make-object-var tpc-pair))


(define is-tc-pair? (make-t-predicate0 tpc-pair))


(define (make-tpci-pair tt1 tt2)
  (let* ((fields (list (make-readonly-field-no-init 'first tt1)
		       (make-readonly-field-no-init 'second tt2)))
	 (all-fields fields))
    (make-target-object 
     tpc-pair
     #t
     #f
     '()
     #f
     #f
     (list
      (cons 'cl-superclass tc-object)
      (cons 'l-fields fields)
      (cons 'l-all-fields all-fields)
      (cons 'inheritable? #f)
      (cons 'immutable? #t)
      (cons 'eq-by-value? #t)
      (cons 's-ctr-access 'public)
      (cons 'type-constructor '())
      (cons 'proc-constructor '())
      (cons 'goops? #f)
      (cons 'has-zero? #f)
      (cons 'zero-prim? #f)
      (cons 'x-zero-value '())
      (cons 'module 'builtins)
      (cons 'str-name "(:pair ...)")
      (cons 'l-tvar-values (list tt1 tt2))
      (cons 'l-param-exprs '()))
     '())))


(set! make-tpci-pair-fwd make-tpci-pair)


(define (get-pair-first-type tpci)
  (assert (target-type=? (get-entity-type tpci) tpc-pair))
  (car (tno-field-ref tpci 'l-tvar-values)))


(define (get-pair-second-type tpci)
  (assert (target-type=? (get-entity-type tpci) tpc-pair))
  (cadr (tno-field-ref tpci 'l-tvar-values)))


(define tpci-pair-of-objects
  (make-tpci-pair tc-object tc-object))


(define (make-tt-list . tt-members)
  (assert (or (null? tt-members) (is-type0? (car tt-members))))
  (cond
   ((null? tt-members) tc-nil)
   ((pair? tt-members)
    (make-tpci-pair
     (car tt-members)
     (apply make-tt-list (cdr tt-members))))
   (else (raise 'make-tt-list:invalid-type))))


(define tvar-uniform-list (make-type-var1 'tvar-uniform-list))


(define tplt-uniform-list
  (let* ((fields
	  (list (make-readonly-field-no-init 'member-types tc-object)))
	 (address (alloc-builtin-loc ':uniform-list))
	 (to
	  (make-target-object 
	   t-param-logical-type
	   #t
	   #f
	   address
	   #f
	   #f
	   (list
	    (cons 'cl-superclass tc-logical-type)
	    (cons 'l-fields fields)
	    (cons 'l-all-fields (append
				(tno-field-ref tc-logical-type
					       'l-all-fields)
				fields))
	    (cons 'inheritable? #f)
	    (cons 'immutable? #t)
	    (cons 'eq-by-value? #t)
	    (cons 's-ctr-access 'public)
	    (cons 'type-constructor '())
	    (cons 'proc-constructor '())
	    (cons 'goops? #f)
	    (cons 'has-zero? #f)
	    (cons 'zero-prim? #f)
	    (cons 'x-zero-value '())
	    (cons 'module 'builtins)
	    (cons 'str-name ":uniform-list")
	    (cons 'i-params 1)
	    (cons 'l-tvars (list tvar-uniform-list))
	    (cons 'x-value-expr '()))
	   '())))
    to))


(define var-tplt-uniform-list (make-object-var tplt-uniform-list))


(define is-tplt-uniform-list? (make-t-predicate0 tplt-uniform-list))


(define (make-tt-uniform-list tt-member)
  (assert (is-target-object? tt-member))
  (let* ((tt-pair
	  (make-tpci-pair tt-member tc-object))
	 (tt-list (make-tt-union tt-pair tc-nil))
	 (second-field
	  (get-field-spec tt-pair 'second)))
    (if (null? second-field) (raise 'make-tt-uniform-list:internal-error))
    (begin
      (tno-field-set! tt-pair 'l-tvar-values
		      (let ((member-types (tno-field-ref tt-pair
							 'l-tvar-values)))
			(list (car member-types) tt-list)))
      (tno-field-set! second-field 'type tt-list)
      tt-list)))


(define ul-value-expr (make-tt-uniform-list tvar-uniform-list))
(tno-field-set! tplt-uniform-list 'x-value-expr ul-value-expr)


(define tmt-procedure-class-fields
  (list
   (make-readonly-field-no-init 'type-arglist tc-object)
   (make-readonly-field-no-init 'type-result tc-object)
   (make-readonly-field-no-init 'pure-proc? tc-boolean)
   (make-readonly-field-no-init 'appl-always-returns? tc-boolean)
   (make-readonly-field-no-init 'appl-never-returns? tc-boolean)
   (make-readonly-field-no-init 'static-method? tc-boolean)))


(define tmt-procedure-class-all-fields
  (append
   tc-class-all-fields
   tmt-procedure-class-fields))


(define tmt-procedure
  (make-builtin-target-class ':procedure tc-class
			     tmt-procedure-class-fields
			     #f #t #t
			     'public))


(define var-tmt-procedure (make-object-var tmt-procedure))


(define is-tt-procedure? (make-t-predicate0 tmt-procedure))


(define tpc-simple-proc-class-fields
  (list
   (make-readonly-field-no-init 'type-arglist tc-object)
   (make-readonly-field-no-init 'type-result tc-object)
   (make-readonly-field-no-init 'pure-proc? tc-boolean)
   (make-readonly-field-no-init 'appl-always-returns? tc-boolean)
   (make-readonly-field-no-init 'appl-never-returns? tc-boolean)
   (make-readonly-field-no-init 'static-method? tc-boolean)))


(define tpc-simple-proc-class-all-fields
  (append
   tc-class-all-fields
   tpc-simple-proc-class-fields))


(define tpc-simple-proc
  (make-builtin-target-class ':simple-proc tc-class
			     tpc-simple-proc-class-fields
			     #f #t #t
			     'public))


(define var-tpc-simple-proc (make-object-var tpc-simple-proc))


(define is-tc-simple-proc? (make-t-predicate0 tpc-simple-proc))


(define general-proc-fields
  (list (make-field 'proc tc-object 'hidden 'hidden #f '())))


(define (make-tpti-general-proc simple?
				arg-list-type
				result-type
				pure-proc?
				always-returns?
				never-returns?
				static-method?)
  (assert (boolean? simple?))
  (assert (is-target-object? arg-list-type))
  (assert (is-target-object? result-type))
  (assert (boolean? pure-proc?))
  (assert (boolean? always-returns?))
  (assert (boolean? never-returns?))
  (assert (boolean? static-method?))
  ;; The contents of proc is not a proper Theme object.
  ;; The field is defined in order to get the size of
  ;; procedure variables right.
  (let ((all-fields general-proc-fields))
    (make-target-object 
     (if simple? tpc-simple-proc tmt-procedure)
     #t
     #f
     '()
     #f
     #f
     (list
      (cons 'cl-superclass tc-procedure)
      (cons 'l-fields general-proc-fields)
      (cons 'l-all-fields all-fields)
      (cons 'inheritable? #f)
      (cons 'immutable? #t)
      (cons 'eq-by-value? #f)
      (cons 's-ctr-access 'public)
      (cons 'type-constructor '())
      (cons 'proc-constructor '())
      (cons 'goops? #f)
      (cons 'has-zero? #f)
      (cons 'zero-prim? #f)
      (cons 'x-zero-value '())
      (cons 'module 'builtins)
      (cons 'str-name (if simple? "(:simple-proc ...)" "(:procedure ...)"))
      (cons 'type-arglist arg-list-type)
      (cons 'type-result result-type)
      (cons 'pure-proc? pure-proc?)
      (cons 'appl-always-returns? always-returns?)
      (cons 'appl-never-returns? never-returns?)
      (cons 'static-method? static-method?))
     '())))


(define tc-gen-proc-class-fields
  (list
   (make-readonly-field-no-init 'l-method-classes tc-object)))


(define tc-gen-proc-class-all-fields
  (append tc-class-all-fields tc-gen-proc-class-fields))


(define gen-proc-fields
  (list
   (make-readonly-field-no-init 'str-name tc-string)
   (make-readonly-field-no-init 'l-methods tc-object)))


(define tmc-gen-proc
  (make-builtin-target-class ':gen-proc tc-class
			     gen-proc-fields
			     #f #t #t
			     'public))


(define var-tmc-gen-proc (make-object-var tmc-gen-proc))


(define is-tc-gen-proc? (make-t-predicate0 tmc-gen-proc))


(define (is-t-gen-proc? obj)
  (is-tc-gen-proc? (get-entity-type obj)))


(define (make-gen-proc-class-object method-classes)
  (make-target-object 
   tmc-gen-proc
   #t
   #f
   '()
   #f
   #f
   (list
    (cons 'cl-superclass tc-object)
    (cons 'l-fields gen-proc-fields)
    (cons 'l-all-fields gen-proc-fields)
    (cons 'inheritable? #f)
    ;; Should the class be mutable?
    (cons 'immutable? #t)
    (cons 'eq-by-value? #f)
    (cons 's-ctr-access 'public)
    (cons 'type-constructor '())
    (cons 'proc-constructor '())
    (cons 'goops? #f)
    (cons 'has-zero? #f)
    (cons 'zero-prim? #f)
    (cons 'x-zero-value '())
    (cons 'module 'builtins)
    ;; Is the name correct?
    (cons 'str-name "(:gen-proc ...)")
    (cons 'l-method-classes method-classes))
   '()))


(define (make-gen-proc-object to-class name methods address)
  (assert (is-target-object? to-class))
  (assert (string? name))
  (assert (and (list? methods)
	       (and-map? is-target-object? methods)))
  (assert (or (null? address) (is-address? address)))
  (make-target-object 
   to-class
   #t
   #f
   address
   #f
   #f
   (list
    (cons 'str-name name)
    (cons 'l-methods methods))
   '()))


(define (make-general-vector-class tc imm? ebv? str-name tt-member
				   ent-member-expr)
  (make-target-object
   tc
   #t
   #f
   '()
   #f
   #f
   (list
    (cons 'cl-superclass tc-class)
    (cons 'l-fields '())
    (cons 'l-all-fields tc-class-all-fields)
    (cons 'inheritable? #f)
    (cons 'immutable? imm?)
    (cons 'eq-by-value? ebv?)
    (cons 's-ctr-access 'public)
    (cons 'type-constructor '())
    (cons 'proc-constructor '())
    (cons 'goops? #f)
    (cons 'has-zero? #f)
    (cons 'zero-prim? #f)
    (cons 'x-zero-value '())
    (cons 'module 'builtins)
    (cons 'str-name str-name)
    (cons 'l-tvar-values (list tt-member))
    (cons 'l-param-exprs (list ent-member-expr)))
   '()))


(define tvar-vector-member (make-type-var1 'vector-member))


(define tpc-vector
  (make-parametrized-class-object0
   'builtins
   ":vector"
   (alloc-builtin-loc ':vector)
   (list tvar-vector-member)
   tc-object
   '()
   '()
   #f
   #t
   #f
   #f
   'public))


(define var-tpc-vector (make-object-var tpc-vector))


(define is-tc-vector? (make-t-predicate0 tpc-vector))


(define (make-tpci-vector member-type member-expr)
  (make-general-vector-class
   tpc-vector
   #t
   #f
   "(:vector ...)"
   member-type
   member-expr))


(define tvar-value-vector-member (make-type-var1 'value-vector-member))


(define tpc-value-vector
  (make-parametrized-class-object0
   'builtins
   ":value-vector"
   (alloc-builtin-loc ':value-vector)
   (list tvar-value-vector-member)
   tc-object
   '()
   '()
   #f
   #t
   #t
   #f
   'public))


(define var-tpc-value-vector (make-object-var tpc-value-vector))


(define is-tc-value-vector? (make-t-predicate0 tpc-value-vector))


(define (make-tpci-value-vector member-type member-expr)
  (make-general-vector-class
   tpc-value-vector
   #t
   #t
   "(:value-vector ...)"
   member-type
   member-expr))


(define tvar-mutable-vector-member
  (make-type-var1 'mutable-vector-member))


(define tpc-mutable-vector
  (make-parametrized-class-object0
   'builtins
   ":mutable-vector"
   (alloc-builtin-loc ':mutable-vector)
   (list tvar-mutable-vector-member)
   tc-object
   '()
   '()
   #f
   #f
   #f
   #f
   'public))


(define var-tpc-mutable-vector
  (make-object-var tpc-mutable-vector))


(define is-tc-mutable-vector?
  (make-t-predicate0 tpc-mutable-vector))


(define (make-tpci-mutable-vector member-type member-expr)
  (make-general-vector-class
   tpc-mutable-vector
   #f
   #f
   "(:mutable-vector ...)"
   member-type
   member-expr))


(define tvar-mutable-value-vector-member
  (make-type-var1 'mutable-value-vector-member))


(define tpc-mutable-value-vector
  (make-parametrized-class-object0
   'builtins
   ":mutable-value-vector"
   (alloc-builtin-loc ':mutable-value-vector)
   (list tvar-mutable-value-vector-member)
   tc-object
   '()
   '()
   #f
   #f
   #t
   #f
   'public))


(define var-tpc-mutable-value-vector
  (make-object-var tpc-mutable-value-vector))


(define is-tc-mutable-value-vector?
  (make-t-predicate0 tpc-mutable-value-vector))


(define (make-tpci-mutable-value-vector member-type member-expr)
  (make-general-vector-class
   tpc-mutable-value-vector
   #f
   #t
   "(:mutable-value-vector ...)"
   member-type
   member-expr))


;; Exceptions

(define tc-exception
  (make-builtin-target-class '<exception> tc-object '() #t #f #f 'public))

(define var-tc-exception (make-object-var tc-exception))

(define file-exception-fields
  (list (make-readonly-field-no-init 'str-filename tc-string)))

(define file-exception-all-fields file-exception-fields)

(define tc-file-exception
  (make-builtin-target-class '<file-exception> tc-exception '() #t #f #f
			     'public))

(define var-tc-file-exception (make-object-var tc-file-exception))

(tno-field-set! tc-file-exception 'l-fields file-exception-fields)
(tno-field-set! tc-file-exception 'l-all-fields file-exception-all-fields)


;; Primitive types


(define (is-t-true? entity)
  (assert (hrecord-is-instance? entity <entity>))
  (and
   (is-t-primitive-object? entity)
   (eq? (hfield-ref entity 'obj-prim-contents) #t)))


(define (is-t-false? entity)
  (assert (hrecord-is-instance? entity <entity>))
  (and
   (is-t-primitive-object? entity)
   (eq? (hfield-ref entity 'obj-prim-contents) #f)))


(define (is-true? obj)
  (or (eq? obj #t) (and (is-entity? obj) (is-t-true? obj))))


(define (is-false? obj)
  (or (eq? obj #f) (and (is-entity? obj) (is-t-false? obj))))


(define (is-null-obj? obj)
  (or (null? obj)
      (and (is-t-primitive-object? obj)
	   (null? (hfield-ref obj 'obj-prim-contents)))))


(define (is-real? x)
  (and (real? x)
       ;; (not (and (integer? x) (exact? x)))))
       ;; Integer and rational numbers are not accepted as real numbers
       ;; in Theme-D.
       (not (exact? x))))

(define (is-integer? x)
  (and (integer? x) (exact? x)))


(define (is-t-atomic-class? tc)
  (if (memv tc (list tc-symbol tc-boolean tc-real tc-integer
		     tc-string tc-char tc-nil))
      #t
      #f))


(define (is-t-atomic-object? to)
  (and (is-t-primitive-object? to)
       (is-t-atomic-class? (get-entity-type to))))


(define (get-contents obj)
  (assert (is-t-primitive-object? obj))
  (let ((contents (hfield-ref obj 'obj-prim-contents)))
    (if (eqv? contents to-nil) '() contents)))


(define (is-primitive-value0? x l-visited)
  (cond
   ;; We do not allow cycles in primitive values.
   ((memq x l-visited) #f)
   ((symbol? x) #t)
   ((boolean? x) #t)
   ((is-real? x) #t)
   ((is-integer? x) #t)
   ((number? x) #f)
   ((string? x) #t)
   ((char? x) #t)
   ((null? x) #t)
   ((pair? x)
    (let ((l-new-visited (cons x l-visited)))
      (and (is-primitive-value0? (car x) l-new-visited)
	   (is-primitive-value0? (cdr x) l-new-visited))))
   (else #f)))


(define (is-primitive-value? x)
  (is-primitive-value0? x '()))


(define (get-primitive-type0 x l-visited)
  (cond
   ((memq x l-visited) (raise 'cycle-in-primitive-value))
   ((symbol? x) tc-symbol)
   ((boolean? x) tc-boolean)
   ((is-real? x) tc-real)
   ((is-integer? x) tc-integer)
   ((number? x) (raise 'unknown-number-type))
   ((string? x) tc-string)
   ((char? x) tc-char)
   ((null? x) tc-nil)
   ((pair? x)
    (let ((l-new-visited (cons x l-visited)))
      (make-tpci-pair (get-primitive-type0 (car x) l-new-visited)
		      (get-primitive-type0 (cdr x) l-new-visited))))
   (else (raise (list 'invalid-primitive-value x)))))


(define (get-primitive-type x)
  (if (is-primitive-value? x)
      (get-primitive-type0 x '())
      (raise 'not-a-primitive-value)))
			   

(define (theme-class-of x)
  (cond
   ((symbol? x) tc-symbol)
   ((boolean? x) tc-boolean)
   ((is-real? x) tc-real)
   ((is-integer? x) tc-integer)
   ((number? x) (raise 'unknown-number-type))
   ((string? x) tc-string)
   ((char? x) tc-char)
   ((null? x) tc-nil)
   ((pair? x)
    (make-tpci-pair (theme-class-of (car x)) (theme-class-of (cdr x))))
   ((hrecord-is-instance? x <target-object>)
    (get-entity-type x))
   (else (raise 'unknown-item-type))))


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


(define (is-primitive-class0? obj l-visited)
  (cond
   ;; We do not allow cycles in primitive values.
   ((memq obj l-visited) #f)
   ((memq obj
	  (list tc-symbol tc-boolean tc-real tc-integer 
		tc-string tc-char tc-nil))
    #t)
   ((is-tc-pair? obj)
    (let ((l-new-visited (cons obj l-visited)))
      (and (is-primitive-class0? (get-pair-first-type obj) l-new-visited)
	   (is-primitive-class0? (get-pair-second-type obj) l-new-visited))))
   (else #f)))


(define (is-primitive-class? obj)
  (is-primitive-class0? obj '()))


(define (is-pair-class? obj)
  (assert (is-target-object? obj))
  (eq? (get-entity-type obj) tpc-pair))


(define (make-primitive-object type contents)
  (assert (hrecord-is-instance? type <target-object>))
  (assert (or (is-primitive-value? contents)
	      (is-pair-class? (get-entity-type contents))))
  (make-target-object 
   type
   #t #t '() #t #f
   '()
   contents))


(define (make-primitive-object-w-opt type contents l-opt-contents)
  (assert (hrecord-is-instance? type <target-object>))
  (assert (or (is-primitive-value? contents)
	      (is-pair-class? (get-entity-type contents))))
  (if (is-pair-class? (get-entity-type contents))
      (let ((x-first (tno-field-ref contents 'first))
	    (x-second (tno-field-ref contents 'second)))
	(make-target-object-w-opt 
	 type
	 #t #t '() #t #f
	 (list
	  (cons 'first x-first)
	  (cons 'second x-second))
	 contents
	 l-opt-contents))
      (make-target-object-w-opt 
       type
       #t #t '() #t #f
       '()
       contents
       l-opt-contents)))


(define gl-true (make-primitive-object tc-boolean #t))
(define gl-false (make-primitive-object tc-boolean #f))


(define (check-normal-variable? var)
  (and
   (hrecord-is-instance? var <normal-variable>)
   (hrecord-is-instance? (hfield-ref var 'address) <address>)
   (hrecord-is-instance? (get-entity-type var) <target-object>)
   (boolean? (hfield-ref var 'exact-type?))
   (boolean? (hfield-ref var 'read-only?))
   (boolean? (hfield-ref var 'forward-decl?))
   (boolean? (hfield-ref var 'letrec-variable?))
   (or (null? (hfield-ref var 'value))
       (is-target-object? (hfield-ref var 'value)))
   (or (null? (hfield-ref var 'value-expr))
       (is-entity? (hfield-ref var 'value-expr)))
   (boolean? (hfield-ref var 'exported?))
   (boolean? (hfield-ref var 'changed-in-inst?))))


(set-field-desc-type! tpc-pair-fields 'first
		      tvar-pair-first)


(set-field-desc-type! tpc-pair-fields 'second
		      tvar-pair-second)


(define tc-signature-fields
  (list
   (make-readonly-field-no-init 'l-members tc-object)))


(define tc-signature-all-fields tc-signature-fields)


(define tc-signature
  (make-builtin-target-class
   '<signature>
   tc-logical-type
   tc-signature-fields
   #f
   #t
   #f
   'public))


(define var-tc-signature (make-object-var tc-signature))


(define is-t-signature? (make-t-predicate0 tc-signature))


(define (make-signature-object address members)
  (make-target-object   
   tc-signature
   #t
   #f
   address
   #f
   #f
   (list
    (cons 'l-members members))
   '()))


(define (make-signature-var address to)
  (make-normal-variable0
   address
   tc-signature
   #t
   #t
   #t
   #f
   #f
   #f
   to
   '()
   #f
   #f))


(define (is-signature? obj)
  (assert (is-target-object? obj))
  (target-type=? (get-entity-type obj) tc-signature))


(define param-sgn-fields
  (list (make-readonly-field-no-init 'l-tvars tc-object)
	(make-readonly-field-no-init 'l-members tc-object)))


(define param-sgn-all-fields
  (append tc-class-all-fields param-sgn-fields))


(define t-param-signature
  (make-builtin-target-class
   '<param-signature>
   tc-class
   param-sgn-fields
   #f
   #f
   #f
   'public))


(define var-t-param-signature (make-object-var t-param-signature))


(define is-t-param-signature? (make-t-predicate0 t-param-signature))


(define (make-param-sgn-object address type-variables members)
  (assert (or (null? address) (is-address? address)))
  (let ((name
	 (if (not-null? address)
	     (symbol->string (hfield-ref address 'source-name))
	     "no name")))
    (make-target-object     
     t-param-signature
     #t
     #f
     address
     #f
     #f
     (list
      (cons 'cl-superclass tc-signature)
      (cons 'l-fields param-sgn-fields)
      (cons 'l-all-fields param-sgn-all-fields)
      (cons 'inheritable? #f)
      (cons 'immutable? #t)
      (cons 'eq-by-value? #t)
      (cons 's-ctr-access 'public)
      (cons 'type-constructor '())
      (cons 'proc-constructor '())
      (cons 'goops? #f)
      (cons 'has-zero? #f)
      (cons 'zero-prim? #f)
      (cons 'x-zero-value '())
      (cons 'module 'builtins)
      (cons 'str-name name)
      (cons 'l-tvars type-variables)
      (cons 'l-members members))
     '())))


(define (make-param-sgn-inst-object to-sgn type-var-values)
  (make-incomplete-object tc-signature #t))


(define (is-t-param-sgn-instance? ent)
  (is-t-param-signature? (get-entity-type ent)))


(define (entity-is-none1? binder ent)
  (or
   ;; The following test is an optimization.
   (eq? ent tt-none)
   ;; The only type that inherits from <none> is <none>.
   (is-t-subtype? binder ent tt-none)))


(define (entity-type-is-none1? binder ent)
  (entity-is-none1? binder (get-entity-type ent)))


(define (contains-none-value? binder l)
  (or-map? (lambda (ent) (entity-type-is-none1? binder ent)) l))


(define (check-no-none-arguments binder arguments s-proc-name)
  (if (and (not-null? arguments)
	   (contains-none-value? binder arguments))
      (raise (list 'procedure-argument-with-type-none
		   (cons 's-proc-name s-proc-name)))))


(define (check-no-none-types? binder types)
  (and-map?
   (lambda (type) (not (entity-is-none1? binder type)))
   types))


;; (define (check-no-none-types types)
;;   (if (and (not-null? types)
;; 	   (or-map? entity-is-none? types))
;;       (raise 'illegal-use-of-none)))


(define (make-unknown-object type exact-type?)
  (assert (is-target-object? type))
  (assert (boolean? exact-type?))
  (make-target-object 
   type
   #t
   exact-type?
   '()
   #f
   #f
   #f
   '()))


(define (make-unknown-object-with-address type exact-type? address)
  (assert (is-target-object? type))
  (assert (boolean? exact-type?))
  (make-target-object 
   type
   #t
   exact-type?
   address
   #f
   #f
   #f
   '()))


(define (make-incomplete-object-with-address address type exact-type?)
  (assert (is-address? address))
  (assert (is-target-object? type))
  (assert (boolean? exact-type?))
  (make-target-object 
   type
   #t
   exact-type?
   address
   #f
   #t
   #f
   '()))


(define splice-fields
  (list (make-readonly-field-no-init 'type-component tc-object)))


(define tc-splice
  (make-builtin-target-class '<splice>
			     tc-logical-type splice-fields #f #t #f 'public))


(define var-tc-splice (make-object-var tc-splice))


(define is-t-splice? (make-t-predicate0 tc-splice))


(define (make-splice-object component)
  (assert (is-type0? component))
  (make-target-object   
   tc-splice
   #f
   #f
   '()
   #f
   #f
   (list (cons 'type-component component))
   '()))


(define rest-fields
  (list (make-readonly-field-no-init 'type-component tc-object)))


(define tc-rest
  (make-builtin-target-class '<rest>
			     tc-logical-type rest-fields #f #t #f 'public))


(define var-tc-rest (make-object-var tc-rest))


(define is-t-rest? (make-t-predicate0 tc-rest))


(define (make-rest-object component)
  (assert (is-type0? component))
  (make-target-object   
   tc-rest
   #f
   #f
   '()
   #f
   #f
   (list (cons 'type-component component))
   '()))


(define type-list-fields
  (list
   (make-readonly-field-no-init 'l-subtypes tc-object)))


(define tc-type-list
  (make-builtin-target-class '<type-list>
			     tc-logical-type type-list-fields #f #t #f 'public))


(define var-tc-type-list (make-object-var tc-type-list))


(define is-t-type-list? (make-t-predicate0 tc-type-list))


(define (make-type-list-object subtypes)
  (assert (and-map? is-type0? subtypes))
  (make-target-object   
   tc-type-list
   #f
   #f
   '()
   #f
   #f
   (list (cons 'l-subtypes subtypes))
   '()))


(define type-loop-fields
  (list
   (make-readonly-field-no-init 'tvar tc-object)
   (make-readonly-field-no-init 'x-subtypes tc-object)
   (make-readonly-field-no-init 'x-iter-expr tc-object)))


(define tc-type-loop
  (make-builtin-target-class '<type-loop>
			     tc-logical-type type-loop-fields #f #t #f 'public))


(define var-tc-type-loop (make-object-var tc-type-loop))


(define is-t-type-loop? (make-t-predicate0 tc-type-loop))


(define (make-type-loop-object iter-var subtypes iter-expr)
  (assert (is-t-type-variable? iter-var))
  (assert (or (is-t-type-variable? subtypes)
   	      (is-t-type-list? subtypes)
	      (is-tuple-type0? subtypes)
   	      (and (list? subtypes) (and-map? is-type0? subtypes))))
  (assert (is-target-object? iter-expr))
  (make-target-object   
   tc-type-loop
   #f
   #f
   '()
   #f
   #f
   (list (cons 'tvar iter-var)
	 (cons 'x-subtypes subtypes)
	 (cons 'x-iter-expr iter-expr))
   '()))


(define type-join-fields
  (list
   (make-readonly-field-no-init 'l-subtypes tc-object)))


(define tc-type-join
  (make-builtin-target-class '<type-join>
			     tc-logical-type type-join-fields #f #t #f 'public))


(define var-tc-type-join (make-object-var tc-type-join))


(define is-t-type-join? (make-t-predicate0 tc-type-join))


(define (make-type-join-object subtypes)
  (assert (and-map? is-type0? subtypes))
  (make-target-object
   tc-type-join
   #f
   #f
   '()
   #f
   #f
   (list (cons 'l-subtypes subtypes))
   '()))


(define (get-prim-proc-expression name proctype)
  (assert (symbol? name))
  (assert (is-target-object? proctype))
  (let* ((address (alloc-target-prim-loc name))
	 (to (make-target-object
	      proctype
	      #t #f address #f #f
	      #f '())))
    (make-hrecord <prim-proc-ref>
		  proctype
		  #t
		  #f
		  address
		  #t
		  #t
		  #f
		  to)))


(define (make-builtin-tvar name)
  (make-type-variable (alloc-builtin-loc name)))


(define (is-valid-immutable-class? tc)
  (let ((fields (tno-field-ref tc 'l-all-fields)))
    (and-map? (lambda (field) (eq? (tno-field-ref field 's-write-access)
				   'hidden))
	      fields)))



(define tt-list-of-objects
  (make-tt-uniform-list tc-object))


(define tt-fields-list
  (make-tt-uniform-list tc-field)) 


(define to-this
  (make-target-object
   tc-logical-type
   #t #t
   (alloc-builtin-loc 'this)
   #f #f
   '() '()))


;; We may create singletons in type expressions while handling
;; cyclic data structures (?).
(define (is-type? binder obj)
  (and (is-target-object? obj)
       (or (is-t-subtype-fwd? binder (get-entity-type obj) tt-type)
	   (is-t-type-variable? obj)
	   (eq? obj to-this))))


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


(define (is-type2? binder obj)
  (and (is-target-object? obj)
       (is-t-subtype-fwd? binder (get-entity-type obj) tt-type)))

			  
(define (is-null-class-entity? ent)
  (and (is-entity? ent) (eq? (get-entity-value ent) tc-nil)))


(define (make-normal-var-def type-decl
			     variable value-expr declared?)
  (make-hrecord <variable-definition>
		tt-none
		#t
		#f
		'()
		#f
		#f
		#f
		'()
		variable
		type-decl
		value-expr
		declared?
		#f
		#f))

(define (get-vector-class-element-type tc)
  (assert (memq (get-entity-type tc)
		(list tpc-vector tpc-value-vector
		      tpc-mutable-vector tpc-mutable-value-vector)))
  (car (tno-field-ref tc 'l-tvar-values)))


(define (make-procedure clas type-dispatched? exact-type? address
			s-u-name addr-raw-proc)
  (make-target-object
   clas
   type-dispatched?
   exact-type?
   address
   #f
   #f
   (list (cons 's-u-name s-u-name)
	 (cons 'addr-raw-proc addr-raw-proc))
   '()))


(define tc-macro-fields
  (list (make-hidden-field-no-init 'env tc-object)))


(define tc-macro (make-target-class
		  (alloc-builtin-loc 'macro)
		  (list 'builtins)
		  tc-object
		  tc-macro-fields
		  #f #f #f 'hidden))

(define (make-t-macro address env)
  (make-target-object tc-macro #t #t address #f #f
		      (list (cons 'env env))
		      '()))

(define is-t-macro? (make-t-predicate0 tc-macro))
